From e84cfd070664fe235158bcf54105ea87bfcfc5da Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Fri, 10 May 2024 15:19:43 +0200 Subject: [PATCH 01/14] sem model init --- _CoqProject | 4 +- theories/effects/delim.v | 295 +++++++++ theories/examples/delim_lang/adeq.v | 750 ++++++++++++++++++++++ theories/examples/delim_lang/interp.v | 381 ++--------- theories/examples/delim_lang/lang.v | 531 ++++++--------- theories/examples/input_lang_callcc/hom.v | 58 +- theories/gitree/weakestpre.v | 13 + theories/hom.v | 50 ++ 8 files changed, 1397 insertions(+), 685 deletions(-) create mode 100644 theories/effects/delim.v create mode 100644 theories/examples/delim_lang/adeq.v create mode 100644 theories/hom.v diff --git a/_CoqProject b/_CoqProject index 02dc8bc..f18d419 100644 --- a/_CoqProject +++ b/_CoqProject @@ -24,6 +24,7 @@ theories/gitree/reify.v theories/gitree/greifiers.v theories/gitree/reductions.v theories/gitree/weakestpre.v +theories/gitree/hom.v theories/gitree.v theories/program_logic.v @@ -31,11 +32,12 @@ theories/program_logic.v theories/effects/store.v theories/effects/callcc.v theories/effects/io_tape.v +theories/effects/delim.v theories/lib/pairs.v theories/lib/while.v theories/lib/factorial.v - theories/lib/iter.v +theories/lib/iter.v theories/examples/delim_lang/lang.v theories/examples/delim_lang/interp.v diff --git a/theories/effects/delim.v b/theories/effects/delim.v new file mode 100644 index 0000000..1a862e5 --- /dev/null +++ b/theories/effects/delim.v @@ -0,0 +1,295 @@ +From gitrees Require Import prelude gitree. +From iris.algebra Require Import list. + +(** * State, corresponding to a meta-continuation *) +Definition stateF : oFunctor := (listOF (▶ ∙ -n> ▶ ∙))%OF. + +#[local] Instance state_inhabited : Inhabited (stateF ♯ unitO). +Proof. apply _. Qed. + +#[local] Instance state_cofe X `{!Cofe X} : Cofe (stateF ♯ X). +Proof. apply _. Qed. + +(* We store a list of meta continuations in the state. *) + +(** * Signatures *) + +Program Definition shiftE : opInterp := + {| + Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); + Outs := (▶ ∙); + |}. + +Program Definition resetE : opInterp := + {| + Ins := (▶ ∙); + Outs := (▶ ∙); + |}. + +(* to apply the head of the meta continuation *) +Program Definition popE : opInterp := + {| + Ins := (▶ ∙); + Outs := Empty_setO; + |}. + +(* apply continuation, pushes outer context in meta *) +Program Definition appContE : opInterp := + {| + Ins := (▶ ∙ * (▶ (∙ -n> ∙))); + Outs := ▶ ∙; + |} . + +Definition delimE := @[shiftE; resetE; popE;appContE]. + +Notation op_shift := (inl ()). +Notation op_reset := (inr (inl ())). +Notation op_pop := (inr (inr (inl ()))). +Notation op_app_cont := (inr (inr (inr (inl ())))). + +Section reifiers. + Context {X} `{!Cofe X}. + Notation state := (stateF ♯ X). + + Definition reify_shift : ((laterO X -n> laterO X) -n> laterO X) * + state * (laterO X -n> laterO X) → + option (laterO X * state) := + λ '(f, σ, k), Some ((f k): laterO X, σ : state). + #[export] Instance reify_shift_ne : + NonExpansive (reify_shift : + prodO (prodO ((laterO X -n> laterO X) -n> laterO X) state) + (laterO X -n> laterO X) → + optionO (prodO (laterO X) state)). + Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; auto. Qed. + + Definition reify_reset : (laterO X) * state * (laterO X -n> laterO X) → + option (laterO X * state) := + λ '(e, σ, k), Some (e, (k :: σ)). + #[export] Instance reify_reset_ne : + NonExpansive (reify_reset : + prodO (prodO (laterO X) state) (laterO X -n> laterO X) → + optionO (prodO (laterO X) state)). + Proof. intros ?[[]][[]][[]]. simpl in *. by repeat f_equiv. Qed. + + + Definition reify_pop : (laterO X) * state * (Empty_setO -n> laterO X) → + option (laterO X * state) := + λ '(e, σ, _), + match σ with + | [] => Some (e, σ) + | k' :: σ' => Some (k' e, σ') + end. + #[export] Instance reify_pop_ne : + NonExpansive (reify_pop : + prodO (prodO (laterO X) state) (Empty_setO -n> laterO X) → + optionO (prodO (laterO X) state)). + Proof. intros ?[[]][[]][[]]. simpl in *. by repeat f_equiv. Qed. + + + Definition reify_app_cont : ((laterO X * (laterO (X -n> X))) * state * (laterO X -n> laterO X)) → + option (laterO X * state) := + λ '((e, k'), σ, k), + Some (((laterO_ap k' : laterO X -n> laterO X) e : laterO X), k::σ : state). + #[export] Instance reify_app_cont_ne : + NonExpansive (reify_app_cont : + prodO (prodO (prodO (laterO X) (laterO (X -n> X))) state) + (laterO X -n> laterO X) → + optionO (prodO (laterO X) (state))). + Proof. + intros ?[[[]]][[[]]]?. rewrite /reify_app_cont. + repeat f_equiv; apply H. + Qed. + +End reifiers. + +Canonical Structure reify_delim : sReifier CtxDep. +Proof. + simple refine {| + sReifier_ops := delimE; + sReifier_state := stateF + |}. + intros X HX op. + destruct op as [ | [ | [ | [| []]]]]; simpl. + - simple refine (OfeMor (reify_shift)). + - simple refine (OfeMor (reify_reset)). + - simple refine (OfeMor (reify_pop)). + - simple refine (OfeMor (reify_app_cont)). +Defined. + +Section constructors. + Context {E : opsInterp} {A} `{!Cofe A}. + Context {subEff0 : subEff delimE E}. + Context {subOfe0 : SubOfe natO A}. + Context {subOfe1 : SubOfe unitO A}. + Notation IT := (IT E A). + Notation ITV := (ITV E A). + + (** ** POP *) + + Program Definition POP : IT -n> IT := + λne e, Vis (E:=E) (subEff_opid op_pop) + (subEff_ins (F:=delimE) (op:=op_pop) (Next e)) + (Empty_setO_rec _ ◎ (subEff_outs (F:=delimE) (op:=op_pop))^-1). + Solve All Obligations with solve_proper. + + Notation 𝒫 := (get_val POP). + + (** ** RESET *) + + Program Definition RESET_ : (laterO IT -n> laterO IT) -n> + laterO IT -n> + IT := + λne k e, Vis (E:=E) (subEff_opid op_reset) + (subEff_ins (F := delimE) (op := op_reset) (laterO_map 𝒫 e)) + (k ◎ subEff_outs (F := delimE) (op := op_reset)^-1). + Solve Obligations with solve_proper. + + Program Definition RESET : laterO IT -n> IT := + RESET_ idfun. + + (** ** SHIFT *) + + Program Definition SHIFT_ : ((laterO IT -n> laterO IT) -n> laterO IT) -n> + (laterO IT -n> laterO IT) -n> + IT := + λne f k, Vis (E:=E) (subEff_opid op_shift) + (subEff_ins (F:=delimE) (op:=op_shift) ((laterO_map $ 𝒫) ◎ f)) + (k ◎ (subEff_outs (F:=delimE) (op:=op_shift))^-1). + Solve All Obligations with solve_proper. + + Program Definition SHIFT : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := + λne f, SHIFT_ f (idfun). + Solve Obligations with solve_proper. + + Lemma hom_SHIFT_ k e f `{!IT_hom f} : + f (SHIFT_ e k) ≡ SHIFT_ e (laterO_map (OfeMor f) ◎ k). + Proof. + unfold SHIFT_. + rewrite hom_vis/=. + f_equiv. by intro. + Qed. + + (** ** APP_CONT *) + + Program Definition APP_CONT_ : laterO IT -n> (laterO (IT -n> IT)) -n> + (laterO IT -n> laterO IT) -n> + IT := + λne e k k', Vis (E := E) (subEff_opid op_app_cont) + (subEff_ins (F:=delimE) (op:=op_app_cont) (e, k)) + (k' ◎ (subEff_outs (F:=delimE) (op:=op_app_cont))^-1). + Solve All Obligations with solve_proper. + + Program Definition APP_CONT : laterO IT -n> (laterO (IT -n> IT)) -n> + IT := + λne e k, APP_CONT_ e k idfun. + Solve All Obligations with solve_proper. + +End constructors. + +Notation 𝒫 := (get_val POP). + +Section weakestpre. + Context {sz : nat}. + Variable (rs : gReifiers CtxDep sz). + Context {subR : subReifier reify_delim rs}. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Context `{!SubOfe unitO R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Notation state := (stateF ♯ IT). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + (** * The symbolic execution rules *) + + (** ** SHIFT *) + + Lemma wp_shift (σ : state) (f : (laterO IT -n> laterO IT) -n> laterO IT) + (k : IT -n> IT) β {Hk : IT_hom k} Φ s : + laterO_map 𝒫 (f (laterO_map k)) ≡ Next β → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} β @ s {{ Φ }}) -∗ + WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. + Proof. + iIntros (Hp) "Hs Ha". + unfold SHIFT. simpl. + rewrite hom_vis. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (laterO_map 𝒫 $ f (laterO_map k)) with "Hs"). + { + simpl. do 2 f_equiv; last done. do 2 f_equiv. + rewrite ccompose_id_l. intro. simpl. by rewrite ofe_iso_21. + } + { exact Hp. } + iModIntro. + iApply "Ha". + Qed. + + Lemma wp_reset (σ : state) (e : IT) (k : IT -n> IT) {Hk : IT_hom k} + Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ + WP@{rs} 𝒫 e @ s {{ Φ }}) -∗ + WP@{rs} k $ (RESET (Next e)) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + unfold RESET. simpl. rewrite hom_vis. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (Next $ 𝒫 e) with "Hs"). + - simpl. repeat f_equiv. rewrite ccompose_id_l. + trans ((laterO_map k) :: σ); last reflexivity. + f_equiv. intro. simpl. by rewrite ofe_iso_21. + - reflexivity. + - iApply "Ha". + Qed. + + Lemma wp_pop_end (v : IT) + {HV : AsVal v} + Φ s : + has_substate [] -∗ + ▷ (£ 1 -∗ has_substate [] -∗ WP@{rs} v @ s {{ Φ }}) -∗ + WP@{rs} 𝒫 v @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + rewrite get_val_ITV. simpl. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ ((Next v)) with "Hs"). + - simpl. reflexivity. + - reflexivity. + - done. + Qed. + + Lemma wp_pop_cons (σ : state) (v : IT) (k : IT -n> IT) + {HV : AsVal v} + Φ s : + has_substate ((laterO_map k) :: σ) -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k $ v @ s {{ Φ }}) -∗ + WP@{rs} 𝒫 v @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + rewrite get_val_ITV. simpl. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ ((laterO_map k (Next v))) with "Hs"). + - simpl. reflexivity. + - reflexivity. + - done. + Qed. + + Lemma wp_app_cont (σ : state) (e : laterO IT) (k' : laterO (IT -n> IT)) + (k : IT -n> IT) β {Hk : IT_hom k} + Φ s : + laterO_ap k' e ≡ Next β → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ + WP@{rs} β @ s {{ Φ }}) -∗ + WP@{rs} k (APP_CONT e k') @ s {{ Φ }}. + Proof. + iIntros (Hb) "Hs Ha". + unfold APP_CONT. simpl. rewrite hom_vis. + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (Next β) with "Hs"). + - cbn-[laterO_ap]. rewrite Hb. do 2 f_equiv. + trans (laterO_map k :: σ); last reflexivity. + rewrite ccompose_id_l. f_equiv. intro. simpl. by rewrite ofe_iso_21. + - reflexivity. + - iApply "Ha". + Qed. + +End weakestpre. diff --git a/theories/examples/delim_lang/adeq.v b/theories/examples/delim_lang/adeq.v new file mode 100644 index 0000000..3326ad9 --- /dev/null +++ b/theories/examples/delim_lang/adeq.v @@ -0,0 +1,750 @@ +From gitrees Require Import gitree lang_generic hom. +From gitrees.effects Require Import delim. +From gitrees.examples.delim_lang Require Import lang interp. +From iris.algebra Require Import list. +From iris.proofmode Require Import classes tactics. +From iris.base_logic Require Import algebra. + +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope syn. + +Inductive ty := +| Tnat : ty +| Tarr : ty -> ty -> ty -> ty -> ty +| Tcont : ty → ty → ty. + +Declare Scope types. + +Notation "τ '∕' α '→' σ '∕' β" := (Tarr τ α σ β) (at level 60) : types. +Notation "'Cont' τ σ" := (Tcont τ σ) (at level 60) : types. + +Reserved Notation "Γ ';' α '⊢ₑ' e ':' τ ';' β" + (at level 90, e at next level, τ at level 20, no associativity). + +Reserved Notation "Γ ';' α '⊢ᵥ' e ':' τ ';' β" + (at level 90, e at next level, τ at level 20, no associativity). + +Reserved Notation "Γ ';' α '⊢ᵪ' e ':' τ ';' β" + (at level 90, e at next level, τ at level 20, no associativity). + +(* TODO: pure stuff has ∀ σ deeper inside *) +Inductive typed_expr {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := +| typed_Val v α τ β : + (Γ; α ⊢ᵥ v : τ; β) → + (Γ; α ⊢ₑ v : τ; β) +| typed_Var x τ α : + (Γ x = τ) → + (Γ; α ⊢ₑ (Var x) : τ; α) +| typed_App e₁ e₂ γ α β δ σ τ : + (Γ; γ ⊢ₑ e₁ : (Tarr σ α τ β); δ) → + (Γ; β ⊢ₑ e₂ : σ; γ) → + (Γ; α ⊢ₑ (App e₁ e₂) : τ; δ) +| typed_AppCont e₁ e₂ α β δ σ τ : + (Γ; δ ⊢ₑ e₁ : (Tcont τ α); β) → + (Γ; σ ⊢ₑ e₂ : τ; δ) → + (Γ; σ ⊢ₑ (AppCont e₁ e₂) : α; β) +| typed_NatOp o e₁ e₂ α β : + (Γ; α ⊢ₑ e₁ : Tnat; β) → + (Γ; α ⊢ₑ e₂ : Tnat; β) → + (Γ; α ⊢ₑ NatOp o e₁ e₂ : Tnat; β) +| typed_If e e₁ e₂ α β σ τ : + (Γ; σ ⊢ₑ e : Tnat; β) → + (Γ; α ⊢ₑ e₁ : τ; σ) → + (Γ; α ⊢ₑ e₂ : τ; σ) → + (Γ; α ⊢ₑ (if e then e₁ else e₂) : τ; β) +| typed_Shift (e : @expr (inc S)) τ α σ β : + (Γ ▹ (Tcont τ α); σ ⊢ₑ e : σ; β) → + (Γ; α ⊢ₑ Shift e : τ; β) +| typed_Reset e α σ τ : + (Γ; σ ⊢ₑ e : σ; τ) → + (Γ; α ⊢ₑ reset e : τ; α) +where "Γ ';' α '⊢ₑ' e ':' τ ';' β" := (typed_expr Γ α e τ β) : types +with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := +| typed_LitV n α : + (Γ; α ⊢ᵥ #n : Tnat; α) +| typed_RecV (e : expr (inc (inc S))) (δ σ τ α β : ty) : + ((Γ ▹ (Tarr σ α τ β) ▹ σ); α ⊢ₑ e : τ; β) -> + (Γ; δ ⊢ᵥ (RecV e) : (Tarr σ α τ β); δ) +| typed_ContV (k : cont S) τ α β : + (Γ; α ⊢ᵪ k : τ; β) → + (Γ; α ⊢ᵥ (ContV k) : τ; β) +where "Γ ';' α '⊢ᵥ' e ':' τ ';' β" := (typed_val Γ α e τ β) : types +with typed_cont {S : Set} (Γ : S -> ty) : ty -> cont S -> ty -> ty -> Prop := +| typed_END τ δ : + (Γ; δ ⊢ᵪ END : (Tcont τ τ); δ) +| typed_IfK e₁ e₂ α β δ A k τ : + (Γ; α ⊢ₑ e₁ : τ; β) -> + (Γ; α ⊢ₑ e₂ : τ; β) -> + (Γ; β ⊢ᵪ k : Tcont τ A; δ) -> + (Γ; α ⊢ᵪ IfK e₁ e₂ k : Tcont Tnat A; δ) +(* | typed_AppLK v k α β σ δ τ' τ : *) +(* (Γ; α ⊢ᵥ v : τ'; β) -> *) +(* (Γ; β ⊢ᵪ k : Tcont σ τ; δ) -> *) +(* (Γ; α ⊢ᵪ AppLK v k : Tcont (Tarr τ' α σ δ) τ; δ) *) +(* | typed_AppRK e k τ : *) +(* (Γ; τ ⊢ᵪ AppRK e k : τ; τ) *) +(* | typed_AppContLK v k τ : *) +(* (Γ; τ ⊢ᵪ AppContLK v k : τ; τ) *) +(* | typed_AppContRK e k τ : *) +(* (Γ; τ ⊢ᵪ AppContRK e k : τ; τ) *) +| typed_NatOpLK op v k α β δ τ : + (Γ; α ⊢ᵥ v : Tnat; β) -> + (Γ; β ⊢ᵪ k : Tcont Tnat τ; δ) -> + (Γ; α ⊢ᵪ NatOpLK op v k : Tcont Tnat τ; δ) +| typed_NatOpRK op e k α β δ τ : + (Γ; α ⊢ₑ e : Tnat; β) -> + (Γ; β ⊢ᵪ k : Tcont Tnat τ; δ) -> + (Γ; α ⊢ᵪ NatOpRK op e k : Tcont Tnat τ; δ) +where "Γ ';' α '⊢ᵪ' e ':' τ ';' β" := (typed_cont Γ α e τ β) : types +. + +Open Scope stdpp_scope. + +Section logrel. + Context {sz : nat}. + Variable (rs : gReifiers CtxDep sz). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Context `{!subReifier reify_delim rs}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ}. + Context `{!stateG rs R Σ}. + Notation iProp := (iProp Σ). + Notation restO := (gState_rest + (@sR_idx _ _ + (sReifier_NotCtxDep_CtxDep reify_delim)) rs ♯ IT). + + Canonical Structure exprO S := leibnizO (expr S). + Canonical Structure valO S := leibnizO (val S). + Canonical Structure contO S := leibnizO (cont S). + + Notation "'WP' α {{ β , Φ } }" := (wp rs α notStuck ⊤ (λ β, Φ)) + (at level 20, α, Φ at level 200, + format "'WP' α {{ β , Φ } }") + : bi_scope. + + Notation "'WP' α {{ Φ } }" := (wp rs α notStuck ⊤ Φ) + (at level 20, α, Φ at level 200, + format "'WP' α {{ Φ } }") : bi_scope. + + Definition logrel_nat' (βv : ITV) : iProp := + (∃ (n : natO), βv ≡ RetV n)%I. + Local Instance logrel_nat_ne : NonExpansive logrel_nat'. + Proof. solve_proper. Qed. + Definition logrel_nat : ITV -n> iProp := λne x, logrel_nat' x. + + (* --------- *) + (* Program Definition logrel_expr' *) + (* (f : (ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp) *) + (* (τ α β : ITV -n> iProp) *) + (* (βe : IT) : iProp := *) + (* (∀ (σ : stateF ♯ IT) (κ : HOM), *) + (* f τ α (FunV (Next κ)) *) + (* -∗ has_substate ((laterO_map κ :: σ) : sReifier_state reify_delim ♯ IT) *) + (* -∗ WP (𝒫 βe) {{ βv, β βv ∗ has_substate σ }})%I. *) + (* Local Instance logrel_expr_ne *) + (* : (∀ n, Proper (dist n *) + (* ==> dist n *) + (* ==> dist n *) + (* ==> dist n *) + (* ==> dist n *) + (* ==> dist n) *) + (* logrel_expr'). *) + (* Proof. solve_proper. Qed. *) + (* Program Definition logrel_expr *) + (* : ((ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp) *) + (* -n> (ITV -n> iProp) -n> (ITV -n> iProp) -n> (ITV -n> iProp) *) + (* -n> IT -n> iProp := *) + (* λne x y z w v, logrel_expr' x y z w v. *) + (* Solve All Obligations with solve_proper. *) + + (* Program Definition logrel_cont_pre *) + (* : ((ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp) *) + (* -n> ((ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp) := *) + (* λne μ τ α βv, *) + (* (∃ (f : HOM), (IT_of_V βv) ≡ (Fun (Next f)) *) + (* ∧ □ ∀ αv, τ αv → ∀ (β : ITV -n> iProp), *) + (* ▷ (logrel_expr μ α β β (`f (IT_of_V αv))))%I. *) + (* Solve All Obligations with solve_proper. *) + + (* Local Instance logrel_cont_pre_contr : Contractive logrel_cont_pre. *) + (* Proof. solve_contractive. Qed. *) + + (* Definition logrel_cont : (ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp *) + (* := fixpoint logrel_cont_pre. *) + (* Lemma logrel_cont_unfold τ α βv : *) + (* logrel_cont τ α βv *) + (* ≡ ((∃ (f : HOM), (IT_of_V βv) ≡ (Fun (Next (`f))) *) + (* ∧ □ ∀ αv, τ αv → ∀ (β : ITV -n> iProp), *) + (* ▷ (logrel_expr logrel_cont α β β (`f (IT_of_V αv))))%I). *) + (* Proof. apply (fixpoint_unfold logrel_cont_pre _). Qed. *) + + (* Program Definition logrel_arr' (τ α σ β : ITV -n> iProp) (βf : ITV) : iProp := *) + (* (∃ f, IT_of_V βf ≡ Fun f *) + (* ∧ □ ∀ (βv : ITV), *) + (* τ βv -∗ logrel_expr logrel_cont σ α β (APP' (Fun f) (IT_of_V βv)))%I. *) + (* Local Instance logrel_arr_ne *) + (* : (∀ n, Proper (dist n *) + (* ==> dist n *) + (* ==> dist n *) + (* ==> dist n *) + (* ==> dist n *) + (* ==> dist n) *) + (* logrel_arr'). *) + (* Proof. solve_proper. Qed. *) + (* Program Definition logrel_arr *) + (* : (ITV -n> iProp) *) + (* -n> (ITV -n> iProp) *) + (* -n> (ITV -n> iProp) *) + (* -n> (ITV -n> iProp) -n> ITV -n> iProp := *) + (* λne x y z w v, logrel_arr' x y z w v. *) + (* Solve All Obligations with solve_proper. *) + + (* Fixpoint interp_ty (τ : ty) : ITV -n> iProp := *) + (* match τ with *) + (* | Tnat => logrel_nat *) + (* | Tcont α β => logrel_cont (interp_ty α) (interp_ty β) *) + (* | Tarr τ α σ β => logrel_arr (interp_ty τ) (interp_ty α) *) + (* (interp_ty σ) (interp_ty β) *) + (* end. *) + + (* Definition logrel (τ α β : ty) : IT -n> iProp *) + (* := logrel_expr logrel_cont (interp_ty τ) (interp_ty α) (interp_ty β). *) + + (* Local Instance interp_ty_persistent (τ : ty) α : *) + (* Persistent (interp_ty τ α). *) + (* Proof. *) + (* revert α. induction τ=> α; simpl. *) + (* - unfold logrel_nat. apply _. *) + (* - unfold logrel_arr. apply _. *) + (* - unfold logrel_cont. *) + (* rewrite logrel_cont_unfold. *) + (* apply _. *) + (* Qed. *) + (* ---- *) + + (* -------------------------------------- *) + + Program Definition has_cont_stack : stateF ♯ IT -> iProp := λ σ, + (has_substate (σ : sReifier_state reify_delim ♯ IT) + ∗ ([∗ list] (x : laterO IT -n> laterO IT) ∈ σ, + ∃ (κ : HOM), x ≡ (laterO_map κ)))%I. + + Lemma wp_shift (σ : stateF ♯ IT) (f : (laterO IT -n> laterO IT) -n> laterO IT) + (k : IT -n> IT) β {Hk : IT_hom k} Φ : + laterO_map 𝒫 (f (laterO_map k)) ≡ Next β → + has_cont_stack σ -∗ + ▷ (£ 1 -∗ has_cont_stack σ -∗ WP β {{ Φ }}) -∗ + WP (k (SHIFT f)) {{ Φ }}. + Proof. + iIntros (Hp) "(Hs & G) Ha". + iApply (wp_shift with "[Hs]"); [done | done |]. + iNext. + iIntros "HCr Hs". + iApply ("Ha" with "HCr"). + iFrame. + Qed. + + Lemma wp_reset (σ : stateF ♯ IT) (e : IT) (k : IT -n> IT) {Hk : IT_hom k} + Φ : + has_cont_stack σ -∗ + ▷ (£ 1 -∗ has_cont_stack ((laterO_map k) :: σ) -∗ + WP 𝒫 e {{ Φ }}) -∗ + WP k $ (RESET (Next e)) {{ Φ }}. + Proof. + iIntros "(Hs & G) Ha". + iApply (wp_reset with "[Hs]"); [done |]. + iNext. + iIntros "HCr Hs". + iApply ("Ha" with "HCr"). + iFrame. + unshelve eset (F := exist _ k _ : HOM); first done. + iExists F. + now subst F. + Qed. + + Lemma wp_pop_end (v : IT) + {HV : AsVal v} + Φ : + has_cont_stack [] -∗ + ▷ (£ 1 -∗ has_cont_stack [] -∗ WP v {{ Φ }}) -∗ + WP 𝒫 v {{ Φ }}. + Proof. + iIntros "(Hs & G) Ha". + iApply (wp_pop_end with "Hs"). + iNext. + iIntros "HCr Hs". + iApply ("Ha" with "HCr"). + now iFrame. + Qed. + + Lemma wp_pop_cons (σ : stateF ♯ IT) (v : IT) (k : IT -n> IT) + {HV : AsVal v} + Φ : + has_cont_stack ((laterO_map k) :: σ) -∗ + ▷ (£ 1 -∗ has_cont_stack σ -∗ WP k $ v {{ Φ }}) -∗ + WP 𝒫 v {{ Φ }}. + Proof. + iIntros "(Hs & (_ & G)) Ha". + iApply (wp_pop_cons with "Hs"). + iNext. + iIntros "HCr Hs". + iApply ("Ha" with "HCr"). + iFrame. + Qed. + + Lemma wp_app_cont (σ : stateF ♯ IT) (e : laterO IT) (k' : laterO (IT -n> IT)) + (k : IT -n> IT) β {Hk : IT_hom k} + Φ : + laterO_ap k' e ≡ Next β → + has_cont_stack σ -∗ + ▷ (£ 1 -∗ has_cont_stack ((laterO_map k) :: σ) -∗ + WP β {{ Φ }}) -∗ + WP k (APP_CONT e k') {{ Φ }}. + Proof. + iIntros (Hb) "(Hs & G) Ha". + iApply (wp_app_cont with "Hs"); + first done. + iNext. + iIntros "HCr Hs". + iApply ("Ha" with "HCr"). + iFrame. + unshelve eset (F := exist _ k _ : HOM); first done. + iExists F. + now subst F. + Qed. + + Definition obs_ref' (P : ITV -n> iProp) (t : IT) : iProp := + (∀ (σ : stateF ♯ IT), + has_cont_stack σ + -∗ WP t {{ βv, ∃ σ', + P βv ∗ has_cont_stack σ' }})%I. + Local Instance obs_ref_ne : NonExpansive2 obs_ref'. + Proof. solve_proper. Qed. + Program Definition obs_ref : (ITV -n> iProp) -n> IT -n> iProp := + λne x y, obs_ref' x y. + Solve All Obligations with solve_proper. + + Program Definition logrel_cont' + (Pτ Pα : ITV -n> iProp) (k : ITV) + : iProp := + (∃ (f : HOM), + (IT_of_V k) ≡ (Fun (Next f)) + ∧ □ ∀ αv, Pτ αv -∗ obs_ref Pα ((`f) (IT_of_V αv)))%I. + Local Instance logrel_cont_ne : NonExpansive3 logrel_cont'. + Proof. solve_proper. Qed. + Program Definition logrel_cont + : (ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp := + λne x y z, logrel_cont' x y z. + Solve All Obligations with solve_proper. + + Program Definition logrel_expr' (Pτ Pα Pβ : ITV -n> iProp) + (e : IT) : iProp := + (∀ (σ : stateF ♯ IT) (κ : HOM), + logrel_cont Pτ Pα (FunV (Next κ)) + -∗ has_cont_stack ((laterO_map κ :: σ) : sReifier_state reify_delim ♯ IT) + -∗ WP (𝒫 e) {{ βv, ∃ σ', Pβ βv ∗ has_cont_stack σ' }})%I. + Local Instance logrel_expr_ne : NonExpansive4 logrel_expr'. + Proof. solve_proper. Qed. + Program Definition logrel_expr + : (ITV -n> iProp) -n> (ITV -n> iProp) -n> (ITV -n> iProp) -n> IT -n> iProp := + λne x y z w, logrel_expr' x y z w. + Solve All Obligations with solve_proper. + + Program Definition logrel_arr' (Pτ Pα Pσ Pβ : ITV -n> iProp) (f : ITV) : iProp := + (∃ f', IT_of_V f ≡ Fun f' + ∧ □ ∀ (βv : ITV), + Pτ βv -∗ logrel_expr Pσ Pα Pβ (APP' (Fun f') (IT_of_V βv)))%I. + Local Instance logrel_arr_ne + : (∀ n, Proper (dist n + ==> dist n + ==> dist n + ==> dist n + ==> dist n + ==> dist n) + logrel_arr'). + Proof. solve_proper. Qed. + Program Definition logrel_arr + : (ITV -n> iProp) + -n> (ITV -n> iProp) + -n> (ITV -n> iProp) + -n> (ITV -n> iProp) -n> ITV -n> iProp := + λne x y z w v, logrel_arr' x y z w v. + Solve All Obligations with solve_proper. + + Fixpoint interp_ty (τ : ty) : ITV -n> iProp := + match τ with + | Tnat => logrel_nat + | Tcont α β => logrel_cont (interp_ty α) (interp_ty β) + | Tarr τ α σ β => logrel_arr (interp_ty τ) (interp_ty α) + (interp_ty σ) (interp_ty β) + end. + + Local Instance interp_ty_persistent (τ : ty) α : + Persistent (interp_ty τ α). + Proof. + revert α. induction τ=> α; simpl. + - unfold logrel_nat. apply _. + - unfold logrel_arr. apply _. + - unfold logrel_cont. apply _. + Qed. + + Definition logrel (τ α β : ty) : IT -n> iProp + := logrel_expr (interp_ty τ) (interp_ty α) (interp_ty β). + + Program Definition ssubst_valid {S : Set} + (Γ : S -> ty) + (ss : interp_scope S) : iProp := + (∀ x α, □ logrel (Γ x) α α (ss x))%I. + + (* TODO: continuation *) + Program Definition valid {S : Set} + (Γ : S -> ty) + (e : interp_scope S -n> IT) + (τ α β : ty) : iProp := + (∀ γ, ssubst_valid Γ γ + -∗ logrel τ α β (e γ))%I. + + Lemma compat_var {S : Set} (Γ : S -> ty) (x : S) : + ⊢ (∀ α, valid Γ (interp_var x) (Γ x) α α). + Proof. + iIntros (α γ) "Hss". + iApply "Hss". + Qed. + + Lemma logrel_of_val τ α v : + interp_ty τ v -∗ logrel τ α α (IT_of_V v). + Proof. + iIntros "#H". + iIntros (σ κ) "#Hκ". + iIntros "Hs". + iApply (wp_pop_cons with "Hs"). + iDestruct "Hκ" as "(%f & #HEQ & Hκ)". + iPoseProof (Fun_inj' with "HEQ") as "HEQ'". + iNext. + iIntros "HCr Hσ". + unshelve eset (F := (λne βv, interp_ty α βv)%I : ITV -n> iProp); + first solve_proper. + iSpecialize ("Hκ" $! v with "H"). + iSpecialize ("Hκ" $! σ with "Hσ"). + subst F. + iAssert ((`κ) (IT_of_V v) ≡ (`f) (IT_of_V v))%I as "HEQ''". + { + unshelve iApply (f_equivI (λne (f : IT -n> IT), + f (IT_of_V v)) (`κ) (`f) with "HEQ'"); solve_proper. + } + iRewrite "HEQ''". + iExact "Hκ". + Qed. + + Lemma compat_recV {S : Set} (Γ : S -> ty) + τ1 α τ2 β e : + ⊢ □ valid ((Γ ▹ (Tarr τ1 α τ2 β) ▹ τ1)) e τ2 α β + -∗ (∀ θ, valid Γ (interp_rec rs e) (Tarr τ1 α τ2 β) θ θ). + Proof. + iIntros "#H". + iIntros (θ γ) "#Henv". + set (f := (ir_unf rs e γ)). + iAssert (interp_rec rs e γ ≡ IT_of_V $ FunV (Next f))%I as "Hf". + { iPureIntro. apply interp_rec_unfold. } + iRewrite "Hf". + Opaque IT_of_V. + iApply logrel_of_val; term_simpl. + iExists _. iSplit. + { iPureIntro. apply into_val. } + iModIntro. + iLöb as "IH". + iIntros (v) "#Hw". + iIntros (σ κ) "#Hκ Hσ". + rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. + pose (γ' := (extend_scope (extend_scope γ (interp_rec rs e γ)) (IT_of_V v))). + rewrite /logrel. + iSpecialize ("H" $! γ' with "[Hw]"). + { + iIntros (x). + destruct x as [| [| x]]; iIntros (ξ); iModIntro. + * iApply logrel_of_val. + iApply "Hw". + * simpl. + iRewrite "Hf". + iIntros (σ' κ') "Hκ' Hσ'". + iApply (wp_pop_cons with "Hσ'"). + iDestruct "Hκ'" as "(%g & #HEQ & Hκ')". + Transparent IT_of_V. + iDestruct (Fun_inj' with "HEQ") as "HEQ'". + iNext. + iIntros "HCr Hσ'". + iSpecialize ("Hκ'" $! (FunV (Next f))). + iSpecialize ("Hκ'" with "[]"). + { + iExists (Next f). + iSplit; first done. + iModIntro. + iIntros (v') "Hv'". + by iApply "IH". + } + iSpecialize ("Hκ'" $! σ' with "Hσ'"). + iAssert ((`κ') (IT_of_V (FunV (Next f))) + ≡ (`g) (IT_of_V (FunV (Next f))))%I as "HEQ''". + { + unshelve iPoseProof + (f_equivI (λne (f' : IT -n> IT), + f' (Fun (Next f))) (`κ') (`g) with "[HEQ']") as "GGG"; + first solve_proper; first solve_proper; first done. + iApply "GGG". + } + simpl. + iRewrite "HEQ''". + iExact "Hκ'". + * iApply "Henv". + } + Opaque extend_scope. + simpl. + rewrite hom_tick. + iApply wp_tick. + iNext. + subst γ'. + iApply ("H" with "Hκ Hσ"). + Qed. + + Program Definition 𝒫_HOM : @HOM sz CtxDep R _ _ := exist _ 𝒫 _. + Next Obligation. apply _. Qed. + + Lemma compat_reset {S : Set} (Γ : S -> ty) e σ τ : + ⊢ valid Γ e σ σ τ -∗ (∀ α, valid Γ (interp_reset rs e) τ α α). + Proof. + iIntros "H". + iIntros (α γ) "#Henv". + iIntros (σ' κ) "#Hκ Hσ'". + iApply (wp_reset with "Hσ'"). + iNext. + iIntros "HCr Hσ'". + iSpecialize ("H" $! γ with "Henv"). + iSpecialize ("H" $! (laterO_map (`κ) :: σ') 𝒫_HOM with "[] Hσ'"). + { + iExists 𝒫_HOM. + iSplit; first done. + iModIntro. + iIntros (v) "#Hv". + iIntros (σ'') "Hσ''". + destruct σ'' as [| κ' σ'']. + - simpl. + iApply (wp_pop_end with "Hσ''"). + iNext. + iIntros "HC Hs". + iApply wp_val. + iModIntro. + iExists []. + iFrame "Hs Hv". + - simpl. + simpl in κ'. + iDestruct "Hσ''" as "(H1 & #H2)". + rewrite big_opL_cons. + iDestruct "H2" as "((%κκ & Hκκ) & H2)". + iRewrite "Hκκ" in "H1". + iApply (delim.wp_pop_cons with "H1"). + iNext. + iIntros "HC Hs". + iDestruct "Hκ" as "(%g & #HEQ & #Hκ)". + iSpecialize ("Hκ" $! v). + (* pop cons different rule with extra tick *) + admit. + } + (* push continuation forward *) + iApply (wp_wand with "H"). + iIntros (v) "(%s & #G1 & G2)". + iModIntro. + iExists s. + iFrame. + admit. + Admitted. + + Lemma compat_shift {S : Set} (Γ : S -> ty) e σ α τ β : + ⊢ valid (Γ ▹ (Tcont τ α)) e σ σ β -∗ valid Γ (interp_shift _ e) τ α β. + Proof. + iIntros "H". + iIntros (γ) "#Henv". + iIntros (σ' κ) "#Hκ Hσ'". + iApply (wp_shift with "Hσ'"). + { apply (laterO_map_Next 𝒫). } + { + iNext. + iIntros "HCr Hσ'". + set (F := (FunV (Next (λne x : IT, Tau (laterO_map 𝒫 (Next x))))) : ITV). + iSpecialize ("H" $! (extend_scope γ (IT_of_V F)) with "[Hκ]"). + - iIntros (x τ'). + iDestruct "Hκ" as "(%g & #HEQ & #Hκ)". + iIntros (σ'' κ'). + iModIntro. + iIntros "Hκ' Hσ''". + destruct x as [| x]. + + Transparent extend_scope. + iApply (wp_pop_cons with "Hσ''"). + iDestruct (Fun_inj' with "HEQ") as "HEQ''". + iDestruct "Hκ'" as "(%h & #HEQ' & #Hκ')". + iDestruct (Fun_inj' with "HEQ'") as "HEQ'''". + iSpecialize ("Hκ'" $! F). + iNext. + iIntros "HCr Hs". + iApply (wp_wand with "[Hκ' Hs]"). + { + iAssert ((`κ') (extend_scope γ (IT_of_V F) VZ) + ≡ (`h) (extend_scope γ (IT_of_V F) VZ))%I as "HEQ''''". + { + unshelve iPoseProof (f_equivI (λne (f' : IT -n> IT), f' (extend_scope γ (IT_of_V F) VZ)) (`κ') (`h) with "[HEQ']") as "GGG"; + first solve_proper; first solve_proper; + first done. + iApply "GGG". + } + iRewrite "HEQ''''". + iApply "Hκ'"; last iApply "Hs". + simpl. + unfold logrel_cont'. + subst F. + unshelve eset (F' := exist _ (λne x : IT, Tau (laterO_map 𝒫 (Next x))) _ : HOM). + { + simpl. + econstructor. + - intros. + rewrite ->2 later_map_Next. + rewrite hom_tick. + rewrite <- Tick_eq. + rewrite <- Tick_eq. + reflexivity. + - intros. + rewrite -> later_map_Next. + rewrite hom_vis. + rewrite <- Tick_eq. + admit. + - intros. + rewrite -> later_map_Next. + rewrite hom_err. + admit. + } + iExists F'. + iSplit; first done. + iModIntro. + iIntros (v) "HHH". + subst F'. + simpl. + rewrite later_map_Next. + iIntros (s) "Hs". + rewrite <- Tick_eq. + iApply wp_tick. + iNext. + destruct s as [| x s]. + - iApply (wp_pop_end with "Hs"). + iNext. + iIntros "HCr Hs". + iApply wp_val. + iModIntro. + iExists []. + iFrame "Hs". + admit. + - admit. + } + iIntros (v) "HHH". + iModIntro. + iApply "HHH". + + iApply ("Henv" with "[Hκ'] Hσ''"). + iApply "Hκ'". + - subst F. + Opaque extend_scope. + simpl. + unfold logrel_expr'. + simpl. + iSpecialize ("H" $! σ' κ). + + admit. + } + Admitted. + + Lemma compat_appcont {S : Set} (Γ : S -> ty) e1 e2 τ α δ β σ : + valid Γ e1 (Tcont τ α) δ β + -∗ valid Γ e2 τ σ δ + -∗ valid Γ (interp_app_cont _ e1 e2) α σ β. + Proof. + iIntros "H G". + iIntros (γ) "#Henv". + iIntros (σ' κ) "#Hκ Hσ'". + iSpecialize ("H" $! γ with "Henv"). + iSpecialize ("G" $! γ with "Henv"). + iSpecialize ("H" $! σ'). + iSpecialize ("G" $! σ'). + (* (* bind + pop *) *) + admit. + Admitted. + +End logrel. + +Local Definition rs : gReifiers CtxDep 1 := gReifiers_cons reify_delim gReifiers_nil. + +Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. + +Lemma logpred_adequacy cr Σ R `{!Cofe R, SubOfe natO R} + `{!invGpreS Σ} `{!statePreG rs R Σ} τ β' + (α : interp_scope ∅ -n> IT (gReifiers_ops rs) R) + (β : IT (gReifiers_ops rs) R) st st' k : + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ}, + (£ cr ⊢ valid rs □ α τ τ β')%I) → + ssteps (gReifiers_sReifier rs) (𝒫 (α ı_scope)) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) + ∨ (∃ βv, IT_of_V βv ≡ β). +Proof. + intros Hlog Hst. + destruct (IT_to_V β) as [βv|] eqn:Hb. + { right. exists βv. apply IT_of_to_V'. rewrite Hb; eauto. } + left. + cut ((∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) + ∨ (∃ e, β ≡ Err e ∧ notStuck e)). + { intros [?|He]; first done. + destruct He as [? [? []]]. } + eapply (wp_safety cr); eauto. + { apply Hdisj. } + { by rewrite Hb. } + intros H1 H2. + exists (λ _, True)%I. split. (* (interp_ty _ τ)%I *) + { apply _. } + iIntros "[Hcr Hst]". + iPoseProof (Hlog with "Hcr") as "Hlog". + destruct st as [σ []]. + iAssert (has_substate σ) with "[Hst]" as "Hs". + { unfold has_substate, has_full_state. + assert (of_state rs (IT (gReifiers_ops rs) _) (σ,()) ≡ + of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ)) as ->; last done. + intro j. unfold sR_idx. simpl. + unfold of_state, of_idx. + destruct decide as [Heq|]; last first. + { inv_fin j; first done. + intros i. inversion i. } + inv_fin j; last done. + intros Heq. + rewrite (eq_pi _ _ Heq eq_refl)//. + } + iSpecialize ("Hlog" $! ı_scope with "[]"). + { iIntros ([]). } + iSpecialize ("Hlog" $! σ HOM_id with "[]"). + { + iExists HOM_id. + iSplit; first done. + iModIntro. + iIntros (αv) "HHH". + iIntros (βv) "Hκ". + simpl. + iApply wp_val. + iModIntro. + iExists βv. + iFrame. + } + iSpecialize ("Hlog" with "[Hs]"). + { + admit. + } + iApply (wp_wand with "Hlog"). + iIntros (βv). simpl. + iIntros "_". + done. +Admitted. diff --git a/theories/examples/delim_lang/interp.v b/theories/examples/delim_lang/interp.v index 5578614..ae6f12b 100644 --- a/theories/examples/delim_lang/interp.v +++ b/theories/examples/delim_lang/interp.v @@ -1,5 +1,5 @@ -(* From Equations Require Import Equations. *) From gitrees Require Import gitree lang_generic. +From gitrees.effects Require Import delim. From gitrees.examples.delim_lang Require Import lang. From iris.algebra Require Import list. From iris.proofmode Require Import classes tactics. @@ -7,311 +7,6 @@ From iris.base_logic Require Import algebra. Require Import Binding.Lib Binding.Set. - -(** * State, corresponding to a meta-continuation *) -Definition stateF : oFunctor := (listOF (▶ ∙ -n> ▶ ∙))%OF. - -#[local] Instance state_inhabited : Inhabited (stateF ♯ unitO). -Proof. apply _. Qed. - -#[local] Instance state_cofe X `{!Cofe X} : Cofe (stateF ♯ X). -Proof. apply _. Qed. - -(* We store a list of meta continuations in the state. *) - - -(** * Signatures *) - -Program Definition shiftE : opInterp := - {| - Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); - Outs := (▶ ∙); - |}. - -Program Definition resetE : opInterp := - {| - Ins := (▶ ∙); - Outs := (▶ ∙); - |}. - -(* to apply the head of the meta continuation *) -Program Definition popE : opInterp := - {| - Ins := (▶ ∙); - Outs := Empty_setO; - |}. - -(* apply continuation, pushes outer context in meta *) -Program Definition appContE : opInterp := - {| - Ins := (▶ ∙ * (▶ (∙ -n> ∙))); - Outs := ▶ ∙; - |} . - -Definition delimE := @[shiftE; resetE; popE;appContE]. - - - -Notation op_shift := (inl ()). -Notation op_reset := (inr (inl ())). -Notation op_pop := (inr (inr (inl ()))). -Notation op_app_cont := (inr (inr (inr (inl ())))). - - - -Section reifiers. - - Context {X} `{!Cofe X}. - Notation state := (stateF ♯ X). - - - Definition reify_shift : ((laterO X -n> laterO X) -n> laterO X) * - state * (laterO X -n> laterO X) → - option (laterO X * state) := - λ '(f, σ, k), Some ((f k): laterO X, σ : state). - #[export] Instance reify_shift_ne : - NonExpansive (reify_shift : - prodO (prodO ((laterO X -n> laterO X) -n> laterO X) state) - (laterO X -n> laterO X) → - optionO (prodO (laterO X) state)). - Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; auto. Qed. - - Definition reify_reset : (laterO X) * state * (laterO X -n> laterO X) → - option (laterO X * state) := - λ '(e, σ, k), Some (e, (k :: σ)). - #[export] Instance reify_reset_ne : - NonExpansive (reify_reset : - prodO (prodO (laterO X) state) (laterO X -n> laterO X) → - optionO (prodO (laterO X) state)). - Proof. intros ?[[]][[]][[]]. simpl in *. by repeat f_equiv. Qed. - - - Definition reify_pop : (laterO X) * state * (Empty_setO -n> laterO X) → - option (laterO X * state) := - λ '(e, σ, _), - match σ with - | [] => Some (e, σ) - | k' :: σ' => Some (k' e, σ') - end. - #[export] Instance reify_pop_ne : - NonExpansive (reify_pop : - prodO (prodO (laterO X) state) (Empty_setO -n> laterO X) → - optionO (prodO (laterO X) state)). - Proof. intros ?[[]][[]][[]]. simpl in *. by repeat f_equiv. Qed. - - - Definition reify_app_cont : ((laterO X * (laterO (X -n> X))) * state * (laterO X -n> laterO X)) → - option (laterO X * state) := - λ '((e, k'), σ, k), - Some (((laterO_ap k' : laterO X -n> laterO X) e : laterO X), k::σ : state). - #[export] Instance reify_app_cont_ne : - NonExpansive (reify_app_cont : - prodO (prodO (prodO (laterO X) (laterO (X -n> X))) state) - (laterO X -n> laterO X) → - optionO (prodO (laterO X) (state))). - Proof. - intros ?[[[]]][[[]]]?. rewrite /reify_app_cont. - repeat f_equiv; apply H. - Qed. - -End reifiers. - -Canonical Structure reify_delim : sReifier CtxDep. -Proof. - simple refine {| - sReifier_ops := delimE; - sReifier_state := stateF - |}. - intros X HX op. - destruct op as [ | [ | [ | [| []]]]]; simpl. - - simple refine (OfeMor (reify_shift)). - - simple refine (OfeMor (reify_reset)). - - simple refine (OfeMor (reify_pop)). - - simple refine (OfeMor (reify_app_cont)). -Defined. - - - -Section constructors. - Context {E : opsInterp} {A} `{!Cofe A}. - Context {subEff0 : subEff delimE E}. - Context {subOfe0 : SubOfe natO A}. - Context {subOfe1 : SubOfe unitO A}. - Notation IT := (IT E A). - Notation ITV := (ITV E A). - - - - (** ** POP *) - - Program Definition POP : IT -n> IT := - λne e, Vis (E:=E) (subEff_opid op_pop) - (subEff_ins (F:=delimE) (op:=op_pop) (Next e)) - (Empty_setO_rec _ ◎ (subEff_outs (F:=delimE) (op:=op_pop))^-1). - Solve All Obligations with solve_proper. - - Notation 𝒫 := (get_val POP). - - (** ** RESET *) - - Program Definition RESET_ : (laterO IT -n> laterO IT) -n> - laterO IT -n> - IT := - λne k e, Vis (E:=E) (subEff_opid op_reset) - (subEff_ins (F := delimE) (op := op_reset) (laterO_map 𝒫 e)) - (k ◎ subEff_outs (F := delimE) (op := op_reset)^-1). - Solve Obligations with solve_proper. - - Program Definition RESET : laterO IT -n> IT := - RESET_ idfun. - - (** ** SHIFT *) - - Program Definition SHIFT_ : ((laterO IT -n> laterO IT) -n> laterO IT) -n> - (laterO IT -n> laterO IT) -n> - IT := - λne f k, Vis (E:=E) (subEff_opid op_shift) - (subEff_ins (F:=delimE) (op:=op_shift) ((laterO_map $ 𝒫) ◎ f)) - (k ◎ (subEff_outs (F:=delimE) (op:=op_shift))^-1). - Solve All Obligations with solve_proper. - - Program Definition SHIFT : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := - λne f, SHIFT_ f (idfun). - Solve Obligations with solve_proper. - - Lemma hom_SHIFT_ k e f `{!IT_hom f} : - f (SHIFT_ e k) ≡ SHIFT_ e (laterO_map (OfeMor f) ◎ k). - Proof. - unfold SHIFT_. - rewrite hom_vis/=. - f_equiv. by intro. - Qed. - - - (** ** APP_CONT *) - - Program Definition APP_CONT_ : laterO IT -n> (laterO (IT -n> IT)) -n> - (laterO IT -n> laterO IT) -n> - IT := - λne e k k', Vis (E := E) (subEff_opid op_app_cont) - (subEff_ins (F:=delimE) (op:=op_app_cont) (e, k)) - (k' ◎ (subEff_outs (F:=delimE) (op:=op_app_cont))^-1). - Solve All Obligations with solve_proper. - - Program Definition APP_CONT : laterO IT -n> (laterO (IT -n> IT)) -n> - IT := - λne e k, APP_CONT_ e k idfun. - Solve All Obligations with solve_proper. - -End constructors. - -Notation 𝒫 := (get_val POP). - -Section weakestpre. - Context {sz : nat}. - Variable (rs : gReifiers CtxDep sz). - Context {subR : subReifier reify_delim rs}. - Notation F := (gReifiers_ops rs). - Context {R} `{!Cofe R}. - Context `{!SubOfe natO R}. - Context `{!SubOfe unitO R}. - Notation IT := (IT F R). - Notation ITV := (ITV F R). - Notation state := (stateF ♯ IT). - Context `{!invGS Σ, !stateG rs R Σ}. - Notation iProp := (iProp Σ). - - (** * The symbolic execution rules *) - - (** ** SHIFT *) - - Lemma wp_shift (σ : state) (f : (laterO IT -n> laterO IT) -n> laterO IT) - (k : IT -n> IT) β {Hk : IT_hom k} Φ s : - laterO_map 𝒫 (f (laterO_map k)) ≡ Next β → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} β @ s {{ Φ }}) -∗ - WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. - Proof. - iIntros (Hp) "Hs Ha". - unfold SHIFT. simpl. - rewrite hom_vis. - iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (laterO_map 𝒫 $ f (laterO_map k)) with "Hs"). - { - simpl. do 2 f_equiv; last done. do 2 f_equiv. - rewrite ccompose_id_l. intro. simpl. by rewrite ofe_iso_21. - } - { exact Hp. } - iModIntro. - iApply "Ha". - Qed. - - Lemma wp_reset (σ : state) (e : IT) (k : IT -n> IT) {Hk : IT_hom k} - Φ s : - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ - WP@{rs} 𝒫 e @ s {{ Φ }}) -∗ - WP@{rs} k $ (RESET (Next e)) @ s {{ Φ }}. - Proof. - iIntros "Hs Ha". - unfold RESET. simpl. rewrite hom_vis. - iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (Next $ 𝒫 e) with "Hs"). - - simpl. repeat f_equiv. rewrite ccompose_id_l. - trans ((laterO_map k) :: σ); last reflexivity. - f_equiv. intro. simpl. by rewrite ofe_iso_21. - - reflexivity. - - iApply "Ha". - Qed. - - (** XXX: Formulate the rules using AsVal *) - Lemma wp_pop_end (v : ITV) - Φ s : - has_substate [] -∗ - ▷ (£ 1 -∗ has_substate [] -∗ WP@{rs} IT_of_V v @ s {{ Φ }}) -∗ - WP@{rs} 𝒫 (IT_of_V v) @ s {{ Φ }}. - Proof. - iIntros "Hs Ha". - rewrite get_val_ITV. simpl. - iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ ((Next $ IT_of_V v)) with "Hs"). - - simpl. reflexivity. - - reflexivity. - - done. - Qed. - - Lemma wp_pop_cons (σ : state) (v : ITV) (k : IT -n> IT) - Φ s : - has_substate ((laterO_map k) :: σ) -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k $ IT_of_V v @ s {{ Φ }}) -∗ - WP@{rs} 𝒫 (IT_of_V v) @ s {{ Φ }}. - Proof. - iIntros "Hs Ha". - rewrite get_val_ITV. simpl. - iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ ((laterO_map k (Next $ IT_of_V v))) with "Hs"). - - simpl. reflexivity. - - reflexivity. - - done. - Qed. - - Lemma wp_app_cont (σ : state) (e : laterO IT) (k' : laterO (IT -n> IT)) - (k : IT -n> IT) β {Hk : IT_hom k} - Φ s : - laterO_ap k' e ≡ Next β → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ - WP@{rs} β @ s {{ Φ }}) -∗ - WP@{rs} k (APP_CONT e k') @ s {{ Φ }}. - Proof. - iIntros (Hb) "Hs Ha". - unfold APP_CONT. simpl. rewrite hom_vis. - iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (Next β) with "Hs"). - - cbn-[laterO_ap]. rewrite Hb. do 2 f_equiv. - trans (laterO_map k :: σ); last reflexivity. - rewrite ccompose_id_l. f_equiv. intro. simpl. by rewrite ofe_iso_21. - - reflexivity. - - iApply "Ha". - Qed. - -End weakestpre. - Section interp. Context {sz : nat}. Variable (rs : gReifiers CtxDep sz). @@ -437,6 +132,22 @@ Section interp. (k env)) (e env). Solve All Obligations with first [ solve_proper | solve_proper_please ]. + + (* Program Definition interp_app_cont {A} (k e : A -n> IT) : A -n> IT := *) + (* λne env, get_val (λne x, get_fun *) + (* (λne (f : laterO (IT -n> IT)), *) + (* (Tau (laterO_ap f (Next x)))) *) + (* (k env)) *) + (* (e env). *) + (* Next Obligation. *) + (* intros. *) + (* intros ???. *) + (* f_equiv. *) + (* now apply later_ap_ne. *) + (* Qed. *) + (* Next Obligation. solve_proper_please. Qed. *) + (* Next Obligation. solve_proper_please. Qed. *) + Global Instance interp_app_cont_ne A : NonExpansive2 (@interp_app_cont A). Proof. intros n??????. rewrite /interp_app_cont. intro. simpl. @@ -748,7 +459,6 @@ Section interp. apply hom_err. Qed. - #[local] Instance interp_cont_hom_appr {S} (K : cont S) (e : expr S) env : IT_hom (interp_cont K env) -> @@ -807,7 +517,6 @@ Section interp. - rewrite get_val_ITV. simpl. rewrite get_fun_err. apply hom_err. Qed. - #[local] Instance interp_cont_hom_natopr {S} (K : cont S) (e : expr S) op env : IT_hom (interp_cont K env) -> @@ -866,6 +575,16 @@ Section interp. rewrite interp_val_ren. f_equiv. intros ?; simpl; reflexivity. + (* - rewrite get_val_ITV. *) + (* simpl. *) + (* rewrite get_fun_fun. *) + (* simpl. *) + (* rewrite <-Tick_eq. *) + (* rewrite hom_tick. *) + (* rewrite hom_tick. *) + (* rewrite hom_tick. *) + (* rewrite hom_tick. *) + - subst. destruct n0; simpl. + by rewrite IF_False; last lia. @@ -954,6 +673,33 @@ Section interp. | |- context G [ofe_mor_car _ _ (get_fun _) (ofe_mor_car _ _ Fun ?f)] => set (fin := f) end. + (* unfold POP. *) + (* match goal with *) + (* |- ofe_mor_car _ _ (ofe_mor_car _ _ _ ?a) _ ≡ _ => *) + (* set (T := a) *) + (* end. *) + (* eassert (T ≡ _). *) + (* { *) + (* subst T. *) + (* rewrite get_val_ITV. *) + (* simpl. *) + (* rewrite get_fun_fun. *) + (* subst fin. *) + (* simpl. *) + (* rewrite <-Tick_eq. *) + (* (* rewrite hom_tick. *) *) + (* (* rewrite hom_tick. *) *) + (* (* rewrite hom_tick. *) *) + (* (* rewrite hom_tick. *) *) + (* reflexivity. *) + (* } *) + (* trans (reify (gReifiers_sReifier rs) *) + (* (𝒫 (interp_cont k env (Tick (Tick (𝒫 (interp_cont k' env (interp_val v env))))))) *) + (* (gState_recomp σr (sR_state σ))). *) + (* { *) + (* now do 2 f_equiv. *) + (* } *) + trans (reify (gReifiers_sReifier rs) (APP_CONT_ (Next (interp_val v env)) fin kk) @@ -973,6 +719,7 @@ Section interp. repeat f_equiv; eauto. solve_proper. } f_equiv. by rewrite -!Tick_eq. + (* admit. *) - remember (map_meta_cont mk env) as σ. trans (reify (gReifiers_sReifier rs) (POP (interp_val v env)) (gState_recomp σr (sR_state (laterO_map (𝒫 ◎ interp_cont k env) :: σ)))). @@ -1034,20 +781,20 @@ Section interp. assert ((n', m').1 = n') as Hn' by done. rewrite <-Heqc2 in IHs. specialize (IHs s n' t2 t' σ2 σ' Hn' Heqc2 Ht'). - inversion H0; subst; - try solve [specialize (interp_cred_no_reify env _ _ _ _ _ _ _ H0 Ht Heqc2) as Heq; - specialize (interp_cred_no_reify_state env _ _ _ _ _ _ _ H0 Ht Heqc2) as <-; + inversion H2; subst; + try solve [specialize (interp_cred_no_reify env _ _ _ _ _ _ _ H2 Ht Heqc2) as Heq; + specialize (interp_cred_no_reify_state env _ _ _ _ _ _ _ H2 Ht Heqc2) as <-; simpl in Heq|-*; rewrite Heq; eapply IHs]; try solve [eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done; - specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq; + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H2 Ht Heqc2) as Heq; cbn in Ht; eapply sstep_reify; last done; inversion Ht; rewrite !hom_vis; done]. + eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. - specialize (interp_cred_no_reify env _ _ _ _ _ _ _ H0 Ht Heqc2) as Heq. - specialize (interp_cred_no_reify_state env _ _ _ _ _ _ _ H0 Ht Heqc2) as <-. + specialize (interp_cred_no_reify env _ _ _ _ _ _ _ H2 Ht Heqc2) as Heq. + specialize (interp_cred_no_reify_state env _ _ _ _ _ _ _ H2 Ht Heqc2) as <-. simpl in Heq|-*; rewrite Heq. constructor; eauto. - + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq. + + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H2 Ht Heqc2) as Heq. simpl in Heq|-*. change (2+n') with (1+(1+n')). eapply ssteps_many; last first. @@ -1058,13 +805,13 @@ Section interp. rewrite get_val_ITV. simpl. rewrite get_fun_fun. simpl. rewrite !hom_vis. done. + eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. - specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq. + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H2 Ht Heqc2) as Heq. cbn in Ht; inversion Ht. subst. rewrite get_val_ITV. simpl. eapply sstep_reify; simpl in Heq; last first. * rewrite -Heq. f_equiv. f_equiv. rewrite get_val_ITV. simpl. done. * f_equiv. reflexivity. + eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. - specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq. + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H2 Ht Heqc2) as Heq. cbn in Ht; inversion Ht. subst. rewrite get_val_ITV. simpl. eapply sstep_reify; simpl in Heq; last first. * rewrite -Heq. repeat f_equiv. by rewrite get_val_ITV. diff --git a/theories/examples/delim_lang/lang.v b/theories/examples/delim_lang/lang.v index dbd9688..b533bf9 100644 --- a/theories/examples/delim_lang/lang.v +++ b/theories/examples/delim_lang/lang.v @@ -1,8 +1,10 @@ From gitrees Require Export prelude. - +From stdpp Require Import gmap. +(* From iris.heap_lang Require Import locations. *) Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. -(* Require Import FunctionalExtensionality. *) +(* Definition loc : Set := locations.loc. *) +(* Global Instance loc_dec_eq (l l' : loc) : Decision (l = l') := _. *) Variant nat_op := Add | Sub | Mult. Inductive expr {X : Set} := @@ -19,10 +21,15 @@ Inductive expr {X : Set} := (* The effects *) | Shift (e : @expr (inc X)) : expr | Reset (e : expr) : expr +(* | Alloc (e : expr) : expr *) +(* | Deref (e : expr) : expr *) +(* | Assign (e₁ : expr) (e₂ : expr) : expr *) with val {X : Set} := | LitV (n : nat) : val | RecV (e : @expr (inc (inc X))) : val | ContV (k : cont) : val +(* | LocV (l : loc) : val *) +(* | UnitV : val *) with cont {X : Set} := | END : cont | IfK (e1 : expr) (e2 : expr) : cont -> cont @@ -31,12 +38,15 @@ with cont {X : Set} := | AppContLK (v : val) : cont -> cont (* ◻ v *) | AppContRK (e : expr) : cont -> cont (* e ◻ *) | NatOpLK (op : nat_op) (v : val) : cont -> cont (* ◻ + v *) -| NatOpRK (op : nat_op) (e : expr) : cont -> cont. (* e + ◻ *) - +| NatOpRK (op : nat_op) (e : expr) : cont -> cont (* e + ◻ *) +(* | AllocK : cont → cont *) +(* | DerefK : cont → cont *) +(* | AssignRK (e : expr) : cont → cont (* E <- e *) *) +(* | AssignLK (v : val) : cont → cont (* v <- E *) *) +. (* conts are inside-out contexts: eg IfK e1 e2 (AppLK v ◻) ==> App (if ◻ then e1 else e2) v*) - Arguments val X%bind : clear implicits. Arguments expr X%bind : clear implicits. Arguments cont X%bind : clear implicits. @@ -53,6 +63,9 @@ Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) | Shift e => Shift (emap (f ↑) e) | Reset e => Reset (emap f e) + (* | Alloc e => Alloc (emap f e) *) + (* | Deref e => Deref (emap f e) *) + (* | Assign e₁ e₂ => Assign (emap f e₁) (emap f e₂) *) end with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := @@ -60,6 +73,8 @@ vmap {A B : Set} (f : A [→] B) (v : val A) : val B := | LitV n => LitV n | RecV e => RecV (emap ((f ↑) ↑) e) | ContV k => ContV (kmap f k) + (* | LocV l => LocV l *) + (* | UnitV => UnitV *) end with kmap {A B : Set} (f : A [→] B) (K : cont A) : cont B := match K with @@ -71,6 +86,10 @@ with kmap {A B : Set} (f : A [→] B) (K : cont A) : cont B := | AppContRK e k => AppContRK (emap f e) (kmap f k) | NatOpLK op v k => NatOpLK op (vmap f v) (kmap f k) | NatOpRK op e k => NatOpRK op (emap f e) (kmap f k) + (* | AllocK k => AllocK (kmap f k) *) + (* | DerefK k => DerefK (kmap f k) *) + (* | AssignRK e k => AssignRK (emap f e) (kmap f k) *) + (* | AssignLK v k => AssignLK (vmap f v) (kmap f k) *) end. @@ -90,6 +109,9 @@ Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) | Shift e => Shift (ebind (f ↑) e) | Reset e => Reset (ebind f e) + (* | Alloc e => Alloc (ebind f e) *) + (* | Deref e => Deref (ebind f e) *) + (* | Assign e₁ e₂ => Assign (ebind f e₁) (ebind f e₂) *) end with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := @@ -97,6 +119,8 @@ vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := | LitV n => LitV n | RecV e => RecV (ebind ((f ↑) ↑) e) | ContV k => ContV (kbind f k) + (* | LocV l => LocV l *) + (* | UnitV => UnitV *) end with kbind {A B : Set} (f : A [⇒] B) (K : cont A) : cont B := match K with @@ -108,6 +132,10 @@ with kbind {A B : Set} (f : A [⇒] B) (K : cont A) : cont B := | AppContRK e k => AppContRK (ebind f e) (kbind f k) | NatOpLK op v k => NatOpLK op (vbind f v) (kbind f k) | NatOpRK op e k => NatOpRK op (ebind f e) (kbind f k) + (* | AllocK k => AllocK (kbind f k) *) + (* | DerefK k => DerefK (kbind f k) *) + (* | AssignRK e k => AssignRK (ebind f e) (kbind f k) *) + (* | AssignLK v k => AssignLK (vbind f v) (kbind f k) *) end. #[export] Instance BindCore_expr : BindCore expr := @ebind. @@ -287,9 +315,12 @@ Fixpoint fill {X : Set} (K : cont X) (e : expr X) : expr X := | AppContRK el K => fill K (AppCont el e) | NatOpLK op v K => fill K (NatOp op e (Val v)) | NatOpRK op el K => fill K (NatOp op el e) + (* | AllocK K => fill K (Alloc e) *) + (* | DerefK K => fill K (Deref e) *) + (* | AssignRK e' K => fill K (Assign e e') *) + (* | AssignLK v K => fill K (Assign (Val v) e) *) end. - (*** Continuation operations *) @@ -314,6 +345,10 @@ Fixpoint cont_compose {S} (K1 K2 : cont S) : cont S := | AppContRK e K => AppContRK e (cont_compose K1 K) | NatOpLK op v K => NatOpLK op v (cont_compose K1 K) | NatOpRK op e K => NatOpRK op e (cont_compose K1 K) + (* | AllocK K => AllocK (cont_compose K1 K) *) + (* | DerefK K => DerefK (cont_compose K1 K) *) + (* | AssignRK e' K => AssignRK e' (cont_compose K1 K) *) + (* | AssignLK v K => AssignLK v (cont_compose K1 K) *) end. Lemma fill_comp {S} (K1 K2 : cont S) e : fill (cont_compose K1 K2) e = fill K1 (fill K2 e). @@ -322,20 +357,19 @@ Proof. intros H K1 e; simpl; by rewrite H. Qed. - Lemma fill_not_val : ∀ {S} K (e : expr S), to_val e = None → to_val (fill K e) = None. Proof. intros S K e. rewrite !eq_None_not_Some. eauto using fill_val. Qed. - (*** Abstract Machine semantics *) Definition Mcont {S} := list $ cont S. +(* Definition state X := gmap loc (val X). *) Variant config {S} : Type := - | Ceval : expr S -> cont S -> @Mcont S -> config + | Ceval : expr S -> cont S -> @Mcont S → config | Ccont : cont S -> val S -> @Mcont S -> config | Cmcont : @Mcont S -> val S -> config | Cexpr : expr S -> config @@ -344,183 +378,127 @@ Variant config {S} : Type := Reserved Notation "c '===>' c' / nm" (at level 40, c', nm at level 30). -Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := +Variant Cred {S : Set} : config (* * state S *) -> config (* * state S *) -> (nat * nat) -> Prop := (* init *) - | Ceval_init : forall (e : expr S), - Cexpr e ===> Ceval e END [] / (0,0) + | Ceval_init : forall (e : expr S) (* σ *), + (Cexpr e(* , σ *)) ===> (Ceval e END [](* , σ *)) / (0,0) + +(* eval *) +| Ceval_val : forall v k mk (* σ *), + (Ceval (Val v) k mk(* , σ *)) ===> (Ccont k v mk(* , σ *)) / (0,0) + +| Ceval_app : forall e0 e1 k mk (* σ *), + (Ceval (App e0 e1) k mk(* , σ *)) ===> (Ceval e1 (AppRK e0 k) mk(* , σ *)) / (0,0) - (* eval *) - | Ceval_val : forall v k mk, - Ceval (Val v) k mk ===> Ccont k v mk / (0,0) +| Ceval_app_cont : forall e0 e1 k mk (* σ *), + (Ceval (AppCont e0 e1) k mk(* , σ *)) ===> (Ceval e1 (AppContRK e0 k) mk(* , σ *)) / (0,0) - | Ceval_app : forall e0 e1 k mk, - Ceval (App e0 e1) k mk ===> Ceval e1 (AppRK e0 k) mk / (0,0) +| Ceval_natop : forall op e0 e1 k mk (* σ *), + (Ceval (NatOp op e0 e1) k mk(* , σ *)) ===> (Ceval e1 (NatOpRK op e0 k) mk(* , σ *)) / (0,0) - | Ceval_app_cont : forall e0 e1 k mk, - Ceval (AppCont e0 e1) k mk ===> Ceval e1 (AppContRK e0 k) mk / (0,0) +| Ceval_if : forall eb et ef k mk (* σ *), + (Ceval (If eb et ef) k mk(* , σ *)) ===> (Ceval eb (IfK et ef k) mk(* , σ *)) / (0,0) - | Ceval_natop : forall op e0 e1 k mk, - Ceval (NatOp op e0 e1) k mk ===> Ceval e1 (NatOpRK op e0 k) mk / (0,0) +| Ceval_reset : forall e k mk (* σ *), + (Ceval (Reset e) k mk(* , σ *)) ===> (Ceval e END (k :: mk)(* , σ *)) / (1, 1) - | Ceval_if : forall eb et ef k mk, - Ceval (If eb et ef) k mk ===> Ceval eb (IfK et ef k) mk / (0,0) +| Ceval_shift : forall (e : expr $ inc S) k mk (* σ *), + (Ceval (Shift e) k mk(* , σ *)) ===> + (Ceval (subst (Inc := inc) e (Val $ ContV k)) END mk(* , σ *)) / (1, 1) - | Ceval_reset : forall e k mk, - Ceval (Reset e) k mk ===> Ceval e END (k :: mk) / (1, 1) +(* cont *) +| Ccont_end : forall v mk (* σ *), + (Ccont END v mk(* , σ *)) ===> (Cmcont mk v(* , σ *)) / (0,0) - | Ceval_shift : forall (e : expr $ inc S) k mk, - Ceval (Shift e) k mk ===> - Ceval (subst (Inc := inc) e (Val $ ContV k)) - END mk / (1, 1) +| Ccont_appr : forall e v k mk (* σ *), + (Ccont (AppRK e k) v mk(* , σ *)) ===> (Ceval e (AppLK v k) mk(* , σ *)) / (0, 0) - (* cont *) - | Ccont_end : forall v mk, - Ccont END v mk ===> Cmcont mk v / (0,0) +| Ccont_app_contr : forall e v k mk (* σ *), + (Ccont (AppContRK e k) v mk(* , σ *)) ===> (Ceval e (AppContLK v k) mk(* , σ *)) / (0, 0) - | Ccont_appr : forall e v k mk, - Ccont (AppRK e k) v mk ===> Ceval e (AppLK v k) mk / (0, 0) +| Ccont_appl : forall e v k mk (* σ *), + (Ccont (AppLK v k) (RecV e) mk(* , σ *)) ===> + (Ceval (subst (Inc := inc) + (subst (F := expr) (Inc := inc) e + (Val (shift (Inc := inc) v))) + (Val (RecV e))) k mk(* , σ *)) / (1, 0) - | Ccont_app_contr : forall e v k mk, - Ccont (AppContRK e k) v mk ===> Ceval e (AppContLK v k) mk / (0, 0) +| Ccont_cont : forall v k k' mk (* σ *), + (Ccont (AppContLK v k) (ContV k') mk(* , σ *)) ===> + (Ccont k' v (k :: mk)(* , σ *)) / (2, 1) - | Ccont_appl : forall e v k mk, - Ccont (AppLK v k) (RecV e) mk ===> - Ceval (subst (Inc := inc) - (subst (F := expr) (Inc := inc) e - (Val (shift (Inc := inc) v))) - (Val (RecV e))) k mk / (1, 0) +| Ccont_if : forall et ef n k mk (* σ *), + (Ccont (IfK et ef k) (LitV n) mk(* , σ *)) ===> + (Ceval (if (n =? 0) then ef else et) k mk(* , σ *)) / (0, 0) - | Ccont_cont : forall v k k' mk, - Ccont (AppContLK v k) (ContV k') mk ===> - Ccont k' v (k :: mk) / (2, 1) +| Ccont_natopr : forall op e v k mk (* σ *), + (Ccont (NatOpRK op e k) v mk(* , σ *)) ===> + (Ceval e (NatOpLK op v k) mk(* , σ *)) / (0, 0) - | Ccont_if : forall et ef n k mk, - Ccont (IfK et ef k) (LitV n) mk ===> - Ceval (if (n =? 0) then ef else et) k mk / (0, 0) +| Ccont_natopl : forall op v0 v1 v2 k mk (* σ *), + nat_op_interp op v0 v1 = Some v2 -> + (Ccont (NatOpLK op v1 k) v0 mk(* , σ *)) ===> + (Ceval (Val v2) k mk(* , σ *)) / (0,0) - | Ccont_natopr : forall op e v k mk, - Ccont (NatOpRK op e k) v mk ===> - Ceval e (NatOpLK op v k) mk / (0, 0) +(* meta-cont *) +| Cmcont_cont : forall k mk v (* σ *), + (Cmcont (k :: mk) v(* , σ *)) ===> (Ccont k v mk(* , σ *)) / (1,1) - | Ccont_natopl : forall op v0 v1 v2 k mk, - nat_op_interp op v0 v1 = Some v2 -> - Ccont (NatOpLK op v1 k) v0 mk ===> - Ceval (Val v2) k mk / (0,0) +| Cmcont_ret : forall v (* σ *), + (Cmcont [] v(* , σ *)) ===> (Cret v(* , σ *)) / (1, 1) - (* meta-cont *) - | Cmcont_cont : forall k mk v, - Cmcont (k :: mk) v ===> Ccont k v mk / (1,1) +(* | Ceval_assign : forall e0 e1 k mk σ, *) +(* (Ceval (Assign e0 e1) k mk, σ) ===> (Ceval e1 (AssignRK e0 k) mk, σ) / (0, 0) *) - | Cmcont_ret : forall v, - Cmcont [] v ===> Cret v / (1, 1) +(* | Ccont_assignr : forall e v k mk σ, *) +(* (Ccont (AssignRK e k) v mk, σ) ===> (Ceval e (AssignLK v k) mk, σ) / (0, 0) *) +(* | Ccont_assignl : forall l v' k mk σ, *) +(* (Ccont (AssignLK (LocV l) k) v' mk, σ) ===> *) +(* (Ceval (Val UnitV) k mk, <[l:=v']>σ) / (0, 1) *) + +(* | Ceval_alloc : forall e k mk σ, *) +(* (Ceval (Alloc e) k mk, σ) ===> (Ceval e (AllocK k) mk, σ) / (0, 0) *) + +(* | Ceval_allock : ∀ l v k mk σ, *) +(* σ !! l = None -> *) +(* (Ccont (AllocK k) v mk, σ) ===> *) +(* (Ceval (Val (LocV l)) k mk, <[l:=v]>σ) / (0, 1) *) + +(* | Ceval_deref : forall e k mk σ, *) +(* (Ceval (Deref e) k mk, σ) ===> (Ceval e (DerefK k) mk, σ) / (0, 0) *) + +(* | Ceval_derefk : ∀ l v k mk σ, *) +(* σ !! l = Some v -> *) +(* (Ccont (DerefK k) (LocV l) mk, σ) ===> *) +(* (Ceval (Val v) k mk, σ) / (0, 1) *) where "c ===> c' / nm" := (Cred c c' nm). Arguments Mcont S%bind : clear implicits. Arguments config S%bind : clear implicits. -Inductive steps {S} : config S -> config S -> (nat * nat) -> Prop := +Inductive steps {S} : config S (* * state S *) -> config S (* * state S *) -> (nat * nat) -> Prop := | steps_zero : forall c, - steps c c (0,0) -| steps_many : forall c1 c2 c3 n m n' m', - c1 ===> c2 / (n,m) -> - steps c2 c3 (n',m') -> - steps c1 c3 (n+n',m+m'). + steps c c (0, 0) +| steps_many : forall c1 c2 c3 n m n' m' n'' m'', + n'' = n + n' -> m'' = m + m' -> + c1 ===> c2 / (n, m) -> + steps c2 c3 (n', m') -> + steps c1 c3 (n'', m''). Definition meta_fill {S} (mk : Mcont S) e := fold_left (λ e k, fill k e) mk e. -(*** Type system *) -(* Type system from [Filinski, Danvy 89] : A Functional Abstraction of Typed Contexts *) - Coercion Val : val >-> expr. -Inductive ty := -| Tnat : ty -| Tarr : ty -> ty -> ty -> ty -> ty -| TarrCont : ty -> ty -> ty -> ty -> ty. - - -(* Notation "'T' τ '/' α '->' σ '/' β" := (Tarr τ α σ β) (at level 99, only parsing). *) -(* Notation "τ '/' α '→k' σ '/' β" := (TarrCont τ α σ β) (at level 60). *) - -(* Reserved Notation " Γ , α ⊢ e : τ , β" *) -(* (at level 90, e at next level, τ at level 20, no associativity). *) - -(* Inductive typed {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := *) - -(* | typed_Lit α n : *) -(* Γ, α ⊢ (LitV n) : Tnat, α *) - -(* | typed_Rec (δ σ τ α β : ty) (e : expr (inc (inc S))) : *) -(* (Γ ▹ (Tarr σ α τ β) ▹ σ) , α ⊢ e : τ , β -> *) -(* Γ,δ ⊢ (RecV e) : (Tarr σ α τ β) , δ *) - -(* | typed_Cont (δ σ τ α : ty) (k : cont S) : *) -(* typed_cont Γ α k (TarrCont σ α τ α) α -> *) -(* Γ,δ ⊢ (ContV k) : (TarrCont σ α τ α) , δ *) - -(* with typed_cont {S : Set} (Γ : S -> ty) : ty -> cont S -> ty -> ty -> Prop := *) - -(* | typed_END τ α δ : *) -(* typed_cont Γ δ END (TarrCont τ α τ α) δ *) - -(* | typed_IfK τ τ' α ε e1 e2 : *) -(* Γ, α ⊢ e1 : τ, α -> *) -(* Γ, α ⊢ e2 : τ, α -> *) -(* typed_cont Γ α K *) -(* typed_cont Γ α (IfK e1 e2 K) (TarrCont Tnat ε τ' ε) α *) - -(* where "Γ , α ⊢ e : τ , β" := (typed Γ α e τ β). *) - -(* | typed_Val (τ : ty) (v : val S) : *) -(* typed_val Γ v τ → *) -(* typed Γ (Val v) τ *) -(* | typed_Var (τ : ty) (v : S) : *) -(* Γ v = τ → *) -(* typed Γ (Var v) τ *) -(* | typed_App (τ1 τ2 : ty) e1 e2 : *) -(* typed Γ e1 (Tarr τ1 τ2) → *) -(* typed Γ e2 τ1 → *) -(* typed Γ (App e1 e2) τ2 *) -(* | typed_NatOp e1 e2 op : *) -(* typed Γ e1 Tnat → *) -(* typed Γ e2 Tnat → *) -(* typed Γ (NatOp op e1 e2) Tnat *) -(* | typed_If e0 e1 e2 τ : *) -(* typed Γ e0 Tnat → *) -(* typed Γ e1 τ → *) -(* typed Γ e2 τ → *) -(* typed Γ (If e0 e1 e2) τ *) -(* | typed_Shift (e : expr (inc S)) τ : *) -(* typed (Γ ▹ Tcont τ) e τ -> *) -(* typed Γ (Shift e) τ *) -(* | typed_App_Cont (τ τ' : ty) e1 e2 : *) -(* typed Γ e1 (Tcont τ) -> *) -(* typed Γ e2 τ -> *) -(* typed Γ (App e1 e2) τ' *) -(* | type_Reset e τ : *) -(* typed Γ e τ -> *) -(* typed Γ (Reset e) τ *) -(* (* CHECK *) *) -(* with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := *) -(* | typed_Lit n : *) -(* typed_val Γ (LitV n) Tnat *) -(* | typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : *) -(* typed (Γ ▹ (Tarr τ1 τ2) ▹ σ) e τ2 → *) -(* typed_val Γ (RecV e) (Tarr τ1 τ2) *) -(* . *) - (*** Notations *) Declare Scope syn_scope. Delimit Scope syn_scope with syn. - +(* Coercion LocV : loc >-> val. *) Coercion App : expr >-> Funclass. -(* Coercion AppLK : expr >-> Funclass. *) -(* Coercion AppRK : expr >-> Funclass. *) Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. @@ -558,39 +536,11 @@ Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynEx __if K e₂ e₃ := cont_compose K (IfK (__asSynExpr e₂) (__asSynExpr e₃) END) }. - -(* Class OutputNotation (A B : Type) := { __output : A -> B }. *) - -(* Global Instance OutputNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : OutputNotation (F S) (expr S) := { *) -(* __output e := Output (__asSynExpr e) *) -(* }. *) - -(* Global Instance OutputNotationK {S : Set} : OutputNotation (cont S) (cont S) := { *) -(* __output K := cont_compose K (OutputK END) *) -(* }. *) - Class ResetNotation (A B : Type) := { __reset : A -> B }. Global Instance ResetNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : ResetNotation (F S) (expr S) := { __reset e := Reset (__asSynExpr e) }. -(* Global Instance ResetNotationK {S : Set} : ResetNotation (cont S) (cont S) := *) -(* { __reset K := cont_compose K (ResetK END) }. *) - -(* Class ThrowNotation (A B C : Type) := { __throw : A -> B -> C }. *) - -(* Global Instance ThrowNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : ThrowNotation (F S) (G S) (expr S) := { *) -(* __throw e₁ e₂ := Throw (__asSynExpr e₁) (__asSynExpr e₂) *) -(* }. *) - -(* Global Instance ThrowNotationLK {S : Set} {F : Set -> Type} `{AsSynExpr F} : ThrowNotation (cont S) (F S) (cont S) := { *) -(* __throw K e₂ := ThrowLK K (__asSynExpr e₂) *) -(* }. *) - -(* Global Instance ThrowNotationRK {S : Set} : ThrowNotation (val S) (cont S) (cont S) := { *) -(* __throw v K := ThrowRK v K *) -(* }. *) - Class AppNotation (A B C : Type) := { __app : A -> B -> C }. Global Instance AppNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : AppNotation (F S) (G S) (expr S) := { @@ -619,6 +569,45 @@ Global Instance AppContNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : A __app_cont e K := cont_compose K (AppContRK (__asSynExpr e) END) }. +(* Class AllocNotation (A B : Type) := { __alloc : A -> B }. *) +(* Notation "'alloc' e" := (__alloc e%syn) (at level 61) : syn_scope. *) + +(* Global Instance AllocNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : *) +(* AllocNotation (F S) (expr S) := { __alloc e := Alloc (__asSynExpr e) }. *) + +(* Global Instance AllocNotationK {S : Set} : AllocNotation (cont S) (cont S) := *) +(* { __alloc K := AllocK K }. *) + +(* Class DerefNotation (A B : Type) := { __deref : A -> B }. *) +(* Notation "'!' e" := (__deref e%syn) (at level 61) : syn_scope. *) + +(* Global Instance DerefNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : *) +(* DerefNotation (F S) (expr S) := { __deref e := Deref (__asSynExpr e) }. *) + +(* Global Instance DerefNotationK {S : Set} : DerefNotation (cont S) (cont S) := *) +(* { __deref K := DerefK K }. *) + +(* Class AssignNotation (A B C : Type) := { __assign : A -> B -> C }. *) +(* (* <- !!! *) *) +(* Notation "x '<-' y" := (__assign x%syn y%syn) *) +(* (at level 40, y at next level, left associativity) *) +(* : syn_scope. *) + +(* Global Instance AssignNotationExpr {S : Set} {F G : Set -> Type} *) +(* `{AsSynExpr F, AsSynExpr G} : AssignNotation (F S) (G S) (expr S) := { *) +(* __assign e₁ e₂ := Assign (__asSynExpr e₁) (__asSynExpr e₂) *) +(* }. *) + +(* Global Instance AssignNotationLK {S : Set} *) +(* : AssignNotation (cont S) (val S) (cont S) := { *) +(* __assign K v := AssignLK v K *) +(* }. *) + +(* Global Instance AssignNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} *) +(* : AssignNotation (F S) (cont S) (cont S) := { *) +(* __assign e K := AssignRK (__asSynExpr e) K *) +(* }. *) + Notation of_val := Val (only parsing). Notation "x '⋆' y" := (__app x%syn y%syn) (at level 40, y at next level, left associativity) : syn_scope. @@ -627,162 +616,58 @@ Notation "x '+' y" := (__op x%syn Add y%syn) : syn_scope. Notation "x '-' y" := (__op x%syn Sub y%syn) : syn_scope. Notation "x '*' y" := (__op x%syn Mult y%syn) : syn_scope. Notation "'if' x 'then' y 'else' z" := (__if x%syn y%syn z%syn) : syn_scope. -(* Notation "'output' x" := (__output x%syn) (at level 60) : syn_scope. *) -(* Notation "'throw' e₁ e₂" := (__throw e₁%syn e₂%syn) (at level 60) : syn_scope. *) Notation "'#' n" := (LitV n) (at level 60) : syn_scope. -(* Notation "'input'" := (Input) : syn_scope. *) Notation "'rec' e" := (RecV e%syn) (at level 60) : syn_scope. Notation "'shift/cc' e" := (Shift e%syn) (at level 60) : syn_scope. Notation "'reset' e" := (Reset e%syn) (at level 60) : syn_scope. -(* Notation "'cont' K" := (ContV K%syn) (at level 60) : syn_scope. *) Notation "'$' fn" := (set_pure_resolver fn) (at level 60) : syn_scope. -(* Notation "□" := (EmptyK) : syn_scope. *) Notation "K '⟪' e '⟫'" := (fill K%syn e%syn) (at level 60) : syn_scope. - -(* Notation "'lam' e" := (LamV e%syn) (at level 60) : syn_scope. *) - -(* Definition LetE {S : Set} (e : expr S) (e' : expr (inc S)) : expr S := *) -(* App (LamV e') (e). *) - -(* Notation "'let_' e₁ 'in' e₂" := (LetE e₁%syn e₂%syn) (at level 60, right associativity) : syn_scope. *) - -(* Definition SeqE {S : Set} (e e' : expr S) : expr S := *) -(* App (LamV (shift e)) e'. *) - -(* Notation "e₁ ';;' e₂" := (SeqE e₁%syn e₂%syn) : syn_scope. *) - -Declare Scope typ_scope. -Delimit Scope typ_scope with typ. - -Notation "'ℕ'" := (Tnat) (at level 1) : typ_scope. -Notation "A →ₜ B" := (Tarr A%typ B%typ) - (right associativity, at level 60) : typ_scope. -(* Notation "A 'Cont'" := (Tcont A%typ) *) -(* (at level 60) : typ_scope. *) - -Declare Scope typing_scope. -Delimit Scope typing_scope with typing. - -Class TypingNotation (A B C : Type) := { __typing : A -> B -> C -> Prop }. - -Notation "Γ ⊢ e : τ" := (__typing Γ e%syn τ%typ) (at level 70, e at level 60) : typing_scope. - -(* Global Instance TypingNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : TypingNotation (S -> ty) (F S) ty := { *) -(* __typing Γ e τ := typed Γ (__asSynExpr e) τ *) -(* }. *) - -(* Global Instance TypingNotationVal {S : Set} : TypingNotation (S -> ty) (val S) ty := { *) -(* __typing Γ e τ := typed_val Γ e τ *) -(* }. *) - Module SynExamples. Open Scope syn_scope. - Example test1 : expr (inc ∅) := ($ 0). - Example test2 : val ∅ := (rec (if ($ 1) then # 1 else # 0)). - (* Example test21 : val ∅ := (lam (if ($ 0) then # 1 else #0)). *) - Example test3 : expr ∅ := (shift/cc (rec ($ 0))). - Example test4 : expr ∅ := ((# 1) + (# 0)). - Example test5 : val ∅ := (rec (if ($ 1) then # 1 else (($ 0) ⋆ (($ 1) - (# 1))))). - Example test6 : expr (inc (inc ∅)) := ($ 0) ⋆ ($ 1). - (* Example test7 : expr ∅ := (let_ ((rec (if ($ 1) then # 1 else (($ 0) ⋆ (($ 1) - (# 1))))) ⋆ (# 5)) in (output ($ 0))). *) - - Open Scope typing_scope. - - (* Example test8 : Prop := (empty_env ⊢ (# 0) : ℕ). *) + Example test1 : expr (inc ∅) := $0. + Example test2 : expr (inc (inc ∅)) := ($0) ⋆ $1. + Example test3 : expr ∅ := (rec (reset (shift/cc (($0) @k $1)))). + Example test4 : expr ∅ := + (rec (if ($0) then #1 else (($0) ⋆ (($0) - #1)))). + (* Example test5 : expr ∅ := *) + (* ((alloc #1) <- #2). *) + (* Example test6 : expr ∅ := *) + (* (! alloc #1). *) + (* Example test7 : *) + (* (∃ (ℓ : loc), *) + (* steps (Cexpr (! alloc #1), empty) (Cret (#1 : val ∅), <[ℓ:=#1]>∅%stdpp) (1, 3)). *) + (* Proof. *) + (* set (ℓ := (fresh (dom (∅%stdpp : state ∅)))). *) + (* exists ℓ. *) + (* eapply steps_many with _ 0 0 1 3; first reflexivity; first reflexivity; *) + (* first apply Ceval_init. *) + (* eapply steps_many with _ _ _ 1 3; [| | apply Ceval_deref |]; *) + (* first reflexivity; first reflexivity. *) + (* eapply steps_many with _ _ _ 1 3; [| | apply Ceval_alloc |]; *) + (* first reflexivity; first reflexivity. *) + (* eapply steps_many with _ _ _ 1 3; [| | apply Ceval_val |]; *) + (* first reflexivity; first reflexivity. *) + (* eapply steps_many with _ _ _ 1 2; [| | apply (Ceval_allock ℓ) |]; *) + (* first reflexivity; first reflexivity; first set_solver. *) + (* eapply steps_many with _ _ _ 1 2; [| | apply Ceval_val |]; *) + (* first reflexivity; first reflexivity. *) + (* eapply steps_many with _ _ _ 1 _; [| | eapply (Ceval_derefk ℓ (LitV 1)) |]; *) + (* first reflexivity; first reflexivity; first set_solver. *) + (* eapply steps_many with _ _ _ 1 1; [| | apply Ceval_val |]; *) + (* first reflexivity; first reflexivity. *) + (* eapply steps_many with _ _ _ 1 1; [| | apply Ccont_end |]; *) + (* first reflexivity; first reflexivity. *) + (* eapply steps_many with _ _ _ 0 0; [| | apply Cmcont_ret |]; *) + (* first reflexivity; first reflexivity. *) + (* apply steps_zero. *) + (* Qed. *) + Example test8 : expr (inc ∅) := ($ 0). + Example test9 : val ∅ := (rec (if ($ 1) then # 1 else # 0)). + Example test10 : expr ∅ := (shift/cc (rec ($ 0))). + Example test11 : expr ∅ := ((# 1) + (# 0)). + Example test12 : val ∅ := (rec (if ($ 1) then # 1 else (($ 0) ⋆ (($ 1) - (# 1))))). + Example test13 : expr (inc (inc ∅)) := ($ 0) ⋆ ($ 1). End SynExamples. - -(* Definition compute_head_step {S} *) -(* (e : expr S) (K : cont S) : *) -(* option (expr S * cont S * (nat * nat)) := *) -(* match e with *) -(* | (App (Val (RecV e1)) (Val v2)) => *) -(* Some ((subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) *) -(* (Val (shift (Inc := inc) v2))) *) -(* (Val (RecV e1))), K, (1,0)) *) -(* (* | Input => *) *) -(* (* let '(n, σ') := update_input σ in *) *) -(* (* Some ((Val (LitV n)), σ', K, (1, 1)) *) *) -(* (* | Output (Val (LitV n)) => *) *) -(* (* (* let := update_output n σ in *) *) *) -(* (* Some ((Val (LitV 0)), σ', K, (1, 1)) *) *) -(* | (NatOp op (Val v1) (Val v2)) => *) -(* let res := nat_op_interp op v1 v2 in *) -(* option_rect (fun _ => option _) (fun v3 => Some ((Val v3), K, (0, 0))) None res *) -(* | (If (Val (LitV n)) e1 e2) => *) -(* if (decide (0 < n)) *) -(* then Some (e1, K, (0, 0)) *) -(* else *) -(* if (decide (n = 0)) *) -(* then Some (e2, K, (0, 0)) *) -(* else None *) -(* (* | (Shift e) => *) *) -(* (* let (Ki, Ko) := shift_context K in *) *) -(* (* let f := cont_to_rec Ki in *) *) -(* (* Some ((subst (Inc := inc) e (Val f)), Ko, (1, 1)) *) *) -(* | (Reset (Val v)) => Some (Val v, K, (1, 1)) *) -(* (* | (Reset (fill E (Shift e))) => None *) *) -(* | _ => None *) -(* end. *) -(* (* CHECK *) *) - -(* Example test21 : val ∅ := (rec (if ($ 0) then # 1 else #0))%syn. *) - - -(* Example testc : option (expr (inc ∅) * cont (inc ∅) * (nat * nat)) := *) -(* (compute_head_step (App (Val test1) (Val $ LitV 5)) []). *) -(* Eval compute in testc. *) - - -(* Lemma head_step_reflect {S : Set} (e : expr S) (K Ko : cont S) *) -(* : option_reflect (fun '(e', K', nm) => head_step e K e' K' Ko nm) *) -(* True *) -(* (compute_head_step e K). *) -(* Proof. *) -(* destruct e; try (by constructor). *) -(* - destruct e1; try (by constructor). *) -(* destruct v; try (by constructor). *) -(* destruct e2; try (by constructor). *) -(* constructor. *) -(* constructor. *) -(* - destruct e1; try (by constructor). *) -(* destruct e2; try (by constructor). *) -(* destruct (nat_op_interp op v v0) eqn:Heqn. *) -(* + simpl; rewrite Heqn. *) -(* simpl. *) -(* constructor. *) -(* by constructor. *) -(* + simpl; rewrite Heqn. *) -(* simpl. *) -(* constructor. *) -(* constructor. *) -(* - destruct e1; try (by constructor). *) -(* destruct v; try (by constructor). *) -(* simpl. *) -(* case_match; simpl. *) -(* + constructor. *) -(* constructor. *) -(* assumption. *) -(* + case_match; simpl. *) -(* * constructor. *) -(* constructor. *) -(* assumption. *) -(* * constructor. *) -(* constructor. *) -(* (* - simpl. *) *) -(* (* destruct (update_input σ) eqn:Heqn. *) *) -(* (* by do 2 constructor. *) *) -(* (* - simpl. *) *) -(* (* destruct e; try (by constructor). *) *) -(* (* destruct v; try (by constructor). *) *) -(* (* destruct (update_output n σ) eqn:Heqn. *) *) -(* (* by do 2 constructor. *) *) -(* (* - simpl. *) *) -(* (* destruct (shift_context K) as [Ki Ko] eqn:HK. *) *) -(* (* constructor. apply ShiftS with Ki =>//=. *) *) -(* - simpl. *) -(* destruct e; try (by constructor). *) -(* do 2 constructor. *) -(* Qed. *) diff --git a/theories/examples/input_lang_callcc/hom.v b/theories/examples/input_lang_callcc/hom.v index 17d197e..5b332f3 100644 --- a/theories/examples/input_lang_callcc/hom.v +++ b/theories/examples/input_lang_callcc/hom.v @@ -1,6 +1,7 @@ (** In this module, we package up IT homomorphism in a sigma type, and we will use it as a domain for logical relations on continuations *) From gitrees Require Import gitree lang_generic. +From gitrees Require Export hom. From gitrees.examples.input_lang_callcc Require Import lang interp. Require Import Binding.Lib Binding.Set Binding.Env. @@ -9,50 +10,19 @@ Open Scope stdpp_scope. Section hom. Context {sz : nat}. Context {rs : gReifiers CtxDep sz}. + Context {A : ofe}. + Context {CA : Cofe A}. + Context `{SubOfe natO A}. Context `{!subReifier reify_cont rs}. Context `{!subReifier (sReifier_NotCtxDep_CtxDep reify_io) rs}. Notation F := (gReifiers_ops rs). Notation IT := (IT F natO). Notation ITV := (ITV F natO). - Definition HOM : ofe := @sigO (IT -n> IT) IT_hom. - - Global Instance HOM_hom (κ : HOM) : IT_hom (`κ). - Proof. - apply (proj2_sig κ). - Qed. - - Program Definition HOM_id : HOM := exist _ idfun _. - Next Obligation. - apply _. - Qed. - - Lemma HOM_ccompose (f g : HOM) : - ∀ α, `f (`g α) = (`f ◎ `g) α. - Proof. - intro; reflexivity. - Qed. - - Program Definition HOM_compose (f g : HOM) : HOM := exist _ (`f ◎ `g) _. - Next Obligation. - intros f g; simpl. - apply _. - Qed. - - Lemma HOM_compose_ccompose (f g h : HOM) : - h = HOM_compose f g -> - `f ◎ `g = `h. - Proof. intros ->. done. Qed. - (** Specific packaged homomorphisms *) - Program Definition IFSCtx_HOM α β : HOM := exist _ (λne x, IFSCtx α β x) _. - Next Obligation. - intros; simpl. - apply _. - Qed. Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) - (α : @interp_scope F natO _ S -n> IT) (env : @interp_scope F natO _ S) + (α : @interp_scope F A _ S -n> IT) (env : @interp_scope F A _ S) : HOM := exist _ (interp_natoprk rs op α (λne env, idfun) env) _. Next Obligation. intros; simpl. @@ -60,7 +30,7 @@ Section hom. Qed. Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) - (α : IT) (env : @interp_scope F natO _ S) + (α : IT) (env : @interp_scope F A _ S) (Hv : AsVal α) : HOM := exist _ (interp_natoplk rs op (λne env, idfun) (constO α) env) _. Next Obligation. @@ -69,8 +39,8 @@ Section hom. Qed. Program Definition ThrowLSCtx_HOM {S : Set} - (α : @interp_scope F natO _ S -n> IT) - (env : @interp_scope F natO _ S) + (α : @interp_scope F A _ S -n> IT) + (env : @interp_scope F A _ S) : HOM := exist _ ((interp_throwlk rs (λne env, idfun) α env)) _. Next Obligation. intros; simpl. @@ -78,7 +48,7 @@ Section hom. Qed. Program Definition ThrowRSCtx_HOM {S : Set} - (β : IT) (env : @interp_scope F natO _ S) + (β : IT) (env : @interp_scope F A _ S) (Hv : AsVal β) : HOM := exist _ (interp_throwrk rs (constO β) (λne env, idfun) env) _. Next Obligation. @@ -104,16 +74,16 @@ Section hom. Qed. Program Definition OutputSCtx_HOM {S : Set} - (env : @interp_scope F natO _ S) - : HOM := exist _ ((interp_outputk rs (λne env, idfun) env)) _. + (env : @interp_scope F A _ S) + : @HOM _ _ A _ _ := exist _ ((interp_outputk rs (λne env, idfun) env)) _. Next Obligation. intros; simpl. apply _. Qed. Program Definition AppRSCtx_HOM {S : Set} - (α : @interp_scope F natO _ S -n> IT) - (env : @interp_scope F natO _ S) + (α : @interp_scope F A _ S -n> IT) + (env : @interp_scope F A _ S) : HOM := exist _ (interp_apprk rs α (λne env, idfun) env) _. Next Obligation. intros; simpl. @@ -121,7 +91,7 @@ Section hom. Qed. Program Definition AppLSCtx_HOM {S : Set} - (β : IT) (env : @interp_scope F natO _ S) + (β : IT) (env : @interp_scope F A _ S) (Hv : AsVal β) : HOM := exist _ (interp_applk rs (λne env, idfun) (constO β) env) _. Next Obligation. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index e6e343f..a4c8340 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -146,6 +146,19 @@ Section weakestpre. Definition has_substate {sR : sReifier a} `{!stateG Σ} `{!subReifier sR rs} (σ : sReifier_state sR ♯ IT) : iProp Σ := (own stateG_name (◯ (of_idx sR_idx (sR_state σ))))%I. + #[export] Instance has_substate_ne {sR : sReifier a} `{!stateG Σ} + `{!subReifier sR rs} : NonExpansive (has_substate). + Proof. + intros ????. + unfold has_substate. + do 2 f_equiv. + intros i. + unfold of_idx, weakestpre.of_idx. + destruct (decide (i = sR_idx)). + - subst; simpl. + now do 3 f_equiv. + - reflexivity. + Qed. #[export] Instance state_interp_ne `{!stateG Σ} : NonExpansive state_interp. Proof. solve_proper. Qed. diff --git a/theories/hom.v b/theories/hom.v new file mode 100644 index 0000000..d6ce75f --- /dev/null +++ b/theories/hom.v @@ -0,0 +1,50 @@ +From gitrees Require Import gitree lang_generic. +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope stdpp_scope. + +Section hom. + Context {sz : nat}. + Context {a : is_ctx_dep}. + Context {A : ofe}. + Context {CA : Cofe A}. + Context {rs : gReifiers a sz}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F A). + Notation ITV := (ITV F A). + + Definition HOM : ofe := @sigO (IT -n> IT) IT_hom. + + Global Instance HOM_hom (κ : HOM) : IT_hom (`κ). + Proof. + apply (proj2_sig κ). + Qed. + + Program Definition HOM_id : HOM := exist _ idfun _. + Next Obligation. + apply _. + Qed. + + Lemma HOM_ccompose (f g : HOM) : + ∀ α, `f (`g α) = (`f ◎ `g) α. + Proof. + intro; reflexivity. + Qed. + + Program Definition HOM_compose (f g : HOM) : HOM := exist _ (`f ◎ `g) _. + Next Obligation. + intros f g; simpl. + apply _. + Qed. + + Lemma HOM_compose_ccompose (f g h : HOM) : + h = HOM_compose f g -> + `f ◎ `g = `h. + Proof. intros ->. done. Qed. + + Program Definition IFSCtx_HOM `{!SubOfe natO A} α β : HOM := exist _ (λne x, IFSCtx α β x) _. + Next Obligation. + intros; simpl. + apply _. + Qed. +End hom. From b096f8b912ccbecc37f9e553a2ba9dbbb6c6294b Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Fri, 31 May 2024 00:22:10 +0200 Subject: [PATCH 02/14] delimited continuations, unary model --- theories/examples/delim_lang/adeq.v | 1317 +++++++++++++++---------- theories/examples/delim_lang/interp.v | 11 +- 2 files changed, 782 insertions(+), 546 deletions(-) diff --git a/theories/examples/delim_lang/adeq.v b/theories/examples/delim_lang/adeq.v index 3326ad9..9c44d5a 100644 --- a/theories/examples/delim_lang/adeq.v +++ b/theories/examples/delim_lang/adeq.v @@ -5,6 +5,8 @@ From iris.algebra Require Import list. From iris.proofmode Require Import classes tactics. From iris.base_logic Require Import algebra. +(* TODO: typing rules, if, compat for contexts, binary relation *) + Require Import Binding.Lib Binding.Set Binding.Env. Open Scope syn. @@ -16,88 +18,88 @@ Inductive ty := Declare Scope types. -Notation "τ '∕' α '→' σ '∕' β" := (Tarr τ α σ β) (at level 60) : types. -Notation "'Cont' τ σ" := (Tcont τ σ) (at level 60) : types. +(* Notation "τ '∕' α '→' σ '∕' β" := (Tarr τ α σ β) (at level 60) : types. *) +(* Notation "'Cont' τ σ" := (Tcont τ σ) (at level 60) : types. *) -Reserved Notation "Γ ';' α '⊢ₑ' e ':' τ ';' β" - (at level 90, e at next level, τ at level 20, no associativity). +(* Reserved Notation "Γ ';' α '⊢ₑ' e ':' τ ';' β" *) +(* (at level 90, e at next level, τ at level 20, no associativity). *) -Reserved Notation "Γ ';' α '⊢ᵥ' e ':' τ ';' β" - (at level 90, e at next level, τ at level 20, no associativity). +(* Reserved Notation "Γ ';' α '⊢ᵥ' e ':' τ ';' β" *) +(* (at level 90, e at next level, τ at level 20, no associativity). *) -Reserved Notation "Γ ';' α '⊢ᵪ' e ':' τ ';' β" - (at level 90, e at next level, τ at level 20, no associativity). +(* Reserved Notation "Γ ';' α '⊢ᵪ' e ':' τ ';' β" *) +(* (at level 90, e at next level, τ at level 20, no associativity). *) (* TODO: pure stuff has ∀ σ deeper inside *) -Inductive typed_expr {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := -| typed_Val v α τ β : - (Γ; α ⊢ᵥ v : τ; β) → - (Γ; α ⊢ₑ v : τ; β) -| typed_Var x τ α : - (Γ x = τ) → - (Γ; α ⊢ₑ (Var x) : τ; α) -| typed_App e₁ e₂ γ α β δ σ τ : - (Γ; γ ⊢ₑ e₁ : (Tarr σ α τ β); δ) → - (Γ; β ⊢ₑ e₂ : σ; γ) → - (Γ; α ⊢ₑ (App e₁ e₂) : τ; δ) -| typed_AppCont e₁ e₂ α β δ σ τ : - (Γ; δ ⊢ₑ e₁ : (Tcont τ α); β) → - (Γ; σ ⊢ₑ e₂ : τ; δ) → - (Γ; σ ⊢ₑ (AppCont e₁ e₂) : α; β) -| typed_NatOp o e₁ e₂ α β : - (Γ; α ⊢ₑ e₁ : Tnat; β) → - (Γ; α ⊢ₑ e₂ : Tnat; β) → - (Γ; α ⊢ₑ NatOp o e₁ e₂ : Tnat; β) -| typed_If e e₁ e₂ α β σ τ : - (Γ; σ ⊢ₑ e : Tnat; β) → - (Γ; α ⊢ₑ e₁ : τ; σ) → - (Γ; α ⊢ₑ e₂ : τ; σ) → - (Γ; α ⊢ₑ (if e then e₁ else e₂) : τ; β) -| typed_Shift (e : @expr (inc S)) τ α σ β : - (Γ ▹ (Tcont τ α); σ ⊢ₑ e : σ; β) → - (Γ; α ⊢ₑ Shift e : τ; β) -| typed_Reset e α σ τ : - (Γ; σ ⊢ₑ e : σ; τ) → - (Γ; α ⊢ₑ reset e : τ; α) -where "Γ ';' α '⊢ₑ' e ':' τ ';' β" := (typed_expr Γ α e τ β) : types -with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := -| typed_LitV n α : - (Γ; α ⊢ᵥ #n : Tnat; α) -| typed_RecV (e : expr (inc (inc S))) (δ σ τ α β : ty) : - ((Γ ▹ (Tarr σ α τ β) ▹ σ); α ⊢ₑ e : τ; β) -> - (Γ; δ ⊢ᵥ (RecV e) : (Tarr σ α τ β); δ) -| typed_ContV (k : cont S) τ α β : - (Γ; α ⊢ᵪ k : τ; β) → - (Γ; α ⊢ᵥ (ContV k) : τ; β) -where "Γ ';' α '⊢ᵥ' e ':' τ ';' β" := (typed_val Γ α e τ β) : types -with typed_cont {S : Set} (Γ : S -> ty) : ty -> cont S -> ty -> ty -> Prop := -| typed_END τ δ : - (Γ; δ ⊢ᵪ END : (Tcont τ τ); δ) -| typed_IfK e₁ e₂ α β δ A k τ : - (Γ; α ⊢ₑ e₁ : τ; β) -> - (Γ; α ⊢ₑ e₂ : τ; β) -> - (Γ; β ⊢ᵪ k : Tcont τ A; δ) -> - (Γ; α ⊢ᵪ IfK e₁ e₂ k : Tcont Tnat A; δ) -(* | typed_AppLK v k α β σ δ τ' τ : *) -(* (Γ; α ⊢ᵥ v : τ'; β) -> *) -(* (Γ; β ⊢ᵪ k : Tcont σ τ; δ) -> *) -(* (Γ; α ⊢ᵪ AppLK v k : Tcont (Tarr τ' α σ δ) τ; δ) *) -(* | typed_AppRK e k τ : *) -(* (Γ; τ ⊢ᵪ AppRK e k : τ; τ) *) -(* | typed_AppContLK v k τ : *) -(* (Γ; τ ⊢ᵪ AppContLK v k : τ; τ) *) -(* | typed_AppContRK e k τ : *) -(* (Γ; τ ⊢ᵪ AppContRK e k : τ; τ) *) -| typed_NatOpLK op v k α β δ τ : - (Γ; α ⊢ᵥ v : Tnat; β) -> - (Γ; β ⊢ᵪ k : Tcont Tnat τ; δ) -> - (Γ; α ⊢ᵪ NatOpLK op v k : Tcont Tnat τ; δ) -| typed_NatOpRK op e k α β δ τ : - (Γ; α ⊢ₑ e : Tnat; β) -> - (Γ; β ⊢ᵪ k : Tcont Tnat τ; δ) -> - (Γ; α ⊢ᵪ NatOpRK op e k : Tcont Tnat τ; δ) -where "Γ ';' α '⊢ᵪ' e ':' τ ';' β" := (typed_cont Γ α e τ β) : types -. +(* Inductive typed_expr {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := *) +(* | typed_Val v α τ β : *) +(* (Γ; α ⊢ᵥ v : τ; β) → *) +(* (Γ; α ⊢ₑ v : τ; β) *) +(* | typed_Var x τ α : *) +(* (Γ x = τ) → *) +(* (Γ; α ⊢ₑ (Var x) : τ; α) *) +(* | typed_App e₁ e₂ γ α β δ σ τ : *) +(* (Γ; γ ⊢ₑ e₁ : (Tarr σ α τ β); δ) → *) +(* (Γ; β ⊢ₑ e₂ : σ; γ) → *) +(* (Γ; α ⊢ₑ (App e₁ e₂) : τ; δ) *) +(* | typed_AppCont e₁ e₂ α β δ σ τ : *) +(* (Γ; δ ⊢ₑ e₁ : (Tcont τ α); β) → *) +(* (Γ; σ ⊢ₑ e₂ : τ; δ) → *) +(* (Γ; σ ⊢ₑ (AppCont e₁ e₂) : α; β) *) +(* | typed_NatOp o e₁ e₂ α β : *) +(* (Γ; α ⊢ₑ e₁ : Tnat; β) → *) +(* (Γ; α ⊢ₑ e₂ : Tnat; β) → *) +(* (Γ; α ⊢ₑ NatOp o e₁ e₂ : Tnat; β) *) +(* | typed_If e e₁ e₂ α β σ τ : *) +(* (Γ; σ ⊢ₑ e : Tnat; β) → *) +(* (Γ; α ⊢ₑ e₁ : τ; σ) → *) +(* (Γ; α ⊢ₑ e₂ : τ; σ) → *) +(* (Γ; α ⊢ₑ (if e then e₁ else e₂) : τ; β) *) +(* | typed_Shift (e : @expr (inc S)) τ α σ β : *) +(* (Γ ▹ (Tcont τ α); σ ⊢ₑ e : σ; β) → *) +(* (Γ; α ⊢ₑ Shift e : τ; β) *) +(* | typed_Reset e α σ τ : *) +(* (Γ; σ ⊢ₑ e : σ; τ) → *) +(* (Γ; α ⊢ₑ reset e : τ; α) *) +(* where "Γ ';' α '⊢ₑ' e ':' τ ';' β" := (typed_expr Γ α e τ β) : types *) +(* with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := *) +(* | typed_LitV n α : *) +(* (Γ; α ⊢ᵥ #n : Tnat; α) *) +(* | typed_RecV (e : expr (inc (inc S))) (δ σ τ α β : ty) : *) +(* ((Γ ▹ (Tarr σ α τ β) ▹ σ); α ⊢ₑ e : τ; β) -> *) +(* (Γ; δ ⊢ᵥ (RecV e) : (Tarr σ α τ β); δ) *) +(* | typed_ContV (k : cont S) τ α β : *) +(* (Γ; α ⊢ᵪ k : τ; β) → *) +(* (Γ; α ⊢ᵥ (ContV k) : τ; β) *) +(* where "Γ ';' α '⊢ᵥ' e ':' τ ';' β" := (typed_val Γ α e τ β) : types *) +(* with typed_cont {S : Set} (Γ : S -> ty) : ty -> cont S -> ty -> ty -> Prop := *) +(* | typed_END τ δ : *) +(* (Γ; δ ⊢ᵪ END : (Tcont τ τ); δ) *) +(* | typed_IfK e₁ e₂ α β δ A k τ : *) +(* (Γ; α ⊢ₑ e₁ : τ; β) -> *) +(* (Γ; α ⊢ₑ e₂ : τ; β) -> *) +(* (Γ; β ⊢ᵪ k : Tcont τ A; δ) -> *) +(* (Γ; α ⊢ᵪ IfK e₁ e₂ k : Tcont Tnat A; δ) *) +(* (* | typed_AppLK v k α β σ δ τ' τ : *) *) +(* (* (Γ; α ⊢ᵥ v : τ'; β) -> *) *) +(* (* (Γ; β ⊢ᵪ k : Tcont σ τ; δ) -> *) *) +(* (* (Γ; α ⊢ᵪ AppLK v k : Tcont (Tarr τ' α σ δ) τ; δ) *) *) +(* (* | typed_AppRK e k τ : *) *) +(* (* (Γ; τ ⊢ᵪ AppRK e k : τ; τ) *) *) +(* (* | typed_AppContLK v k τ : *) *) +(* (* (Γ; τ ⊢ᵪ AppContLK v k : τ; τ) *) *) +(* (* | typed_AppContRK e k τ : *) *) +(* (* (Γ; τ ⊢ᵪ AppContRK e k : τ; τ) *) *) +(* | typed_NatOpLK op v k α β δ τ : *) +(* (Γ; α ⊢ᵥ v : Tnat; β) -> *) +(* (Γ; β ⊢ᵪ k : Tcont Tnat τ; δ) -> *) +(* (Γ; α ⊢ᵪ NatOpLK op v k : Tcont Tnat τ; δ) *) +(* | typed_NatOpRK op e k α β δ τ : *) +(* (Γ; α ⊢ₑ e : Tnat; β) -> *) +(* (Γ; β ⊢ᵪ k : Tcont Tnat τ; δ) -> *) +(* (Γ; α ⊢ᵪ NatOpRK op e k : Tcont Tnat τ; δ) *) +(* where "Γ ';' α '⊢ᵪ' e ':' τ ';' β" := (typed_cont Γ α e τ β) : types *) +(* . *) Open Scope stdpp_scope. @@ -113,22 +115,26 @@ Section logrel. Context `{!invGS Σ}. Context `{!stateG rs R Σ}. Notation iProp := (iProp Σ). - Notation restO := (gState_rest - (@sR_idx _ _ - (sReifier_NotCtxDep_CtxDep reify_delim)) rs ♯ IT). + Notation restO + := (gState_rest + (@sR_idx _ _ + (sReifier_NotCtxDep_CtxDep reify_delim)) rs ♯ IT). Canonical Structure exprO S := leibnizO (expr S). Canonical Structure valO S := leibnizO (val S). Canonical Structure contO S := leibnizO (cont S). + Canonical Structure mcontO S := leibnizO (Mcont S). - Notation "'WP' α {{ β , Φ } }" := (wp rs α notStuck ⊤ (λ β, Φ)) - (at level 20, α, Φ at level 200, - format "'WP' α {{ β , Φ } }") + Notation "'WP' α {{ β , Φ } }" + := (wp rs α notStuck ⊤ (λ β, Φ)) + (at level 20, α, Φ at level 200, + format "'WP' α {{ β , Φ } }") : bi_scope. - Notation "'WP' α {{ Φ } }" := (wp rs α notStuck ⊤ Φ) - (at level 20, α, Φ at level 200, - format "'WP' α {{ Φ } }") : bi_scope. + Notation "'WP' α {{ Φ } }" + := (wp rs α notStuck ⊤ Φ) + (at level 20, α, Φ at level 200, + format "'WP' α {{ Φ } }") : bi_scope. Definition logrel_nat' (βv : ITV) : iProp := (∃ (n : natO), βv ≡ RetV n)%I. @@ -136,228 +142,52 @@ Section logrel. Proof. solve_proper. Qed. Definition logrel_nat : ITV -n> iProp := λne x, logrel_nat' x. - (* --------- *) - (* Program Definition logrel_expr' *) - (* (f : (ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp) *) - (* (τ α β : ITV -n> iProp) *) - (* (βe : IT) : iProp := *) - (* (∀ (σ : stateF ♯ IT) (κ : HOM), *) - (* f τ α (FunV (Next κ)) *) - (* -∗ has_substate ((laterO_map κ :: σ) : sReifier_state reify_delim ♯ IT) *) - (* -∗ WP (𝒫 βe) {{ βv, β βv ∗ has_substate σ }})%I. *) - (* Local Instance logrel_expr_ne *) - (* : (∀ n, Proper (dist n *) - (* ==> dist n *) - (* ==> dist n *) - (* ==> dist n *) - (* ==> dist n *) - (* ==> dist n) *) - (* logrel_expr'). *) - (* Proof. solve_proper. Qed. *) - (* Program Definition logrel_expr *) - (* : ((ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp) *) - (* -n> (ITV -n> iProp) -n> (ITV -n> iProp) -n> (ITV -n> iProp) *) - (* -n> IT -n> iProp := *) - (* λne x y z w v, logrel_expr' x y z w v. *) - (* Solve All Obligations with solve_proper. *) - - (* Program Definition logrel_cont_pre *) - (* : ((ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp) *) - (* -n> ((ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp) := *) - (* λne μ τ α βv, *) - (* (∃ (f : HOM), (IT_of_V βv) ≡ (Fun (Next f)) *) - (* ∧ □ ∀ αv, τ αv → ∀ (β : ITV -n> iProp), *) - (* ▷ (logrel_expr μ α β β (`f (IT_of_V αv))))%I. *) - (* Solve All Obligations with solve_proper. *) - - (* Local Instance logrel_cont_pre_contr : Contractive logrel_cont_pre. *) - (* Proof. solve_contractive. Qed. *) - - (* Definition logrel_cont : (ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp *) - (* := fixpoint logrel_cont_pre. *) - (* Lemma logrel_cont_unfold τ α βv : *) - (* logrel_cont τ α βv *) - (* ≡ ((∃ (f : HOM), (IT_of_V βv) ≡ (Fun (Next (`f))) *) - (* ∧ □ ∀ αv, τ αv → ∀ (β : ITV -n> iProp), *) - (* ▷ (logrel_expr logrel_cont α β β (`f (IT_of_V αv))))%I). *) - (* Proof. apply (fixpoint_unfold logrel_cont_pre _). Qed. *) - - (* Program Definition logrel_arr' (τ α σ β : ITV -n> iProp) (βf : ITV) : iProp := *) - (* (∃ f, IT_of_V βf ≡ Fun f *) - (* ∧ □ ∀ (βv : ITV), *) - (* τ βv -∗ logrel_expr logrel_cont σ α β (APP' (Fun f) (IT_of_V βv)))%I. *) - (* Local Instance logrel_arr_ne *) - (* : (∀ n, Proper (dist n *) - (* ==> dist n *) - (* ==> dist n *) - (* ==> dist n *) - (* ==> dist n *) - (* ==> dist n) *) - (* logrel_arr'). *) - (* Proof. solve_proper. Qed. *) - (* Program Definition logrel_arr *) - (* : (ITV -n> iProp) *) - (* -n> (ITV -n> iProp) *) - (* -n> (ITV -n> iProp) *) - (* -n> (ITV -n> iProp) -n> ITV -n> iProp := *) - (* λne x y z w v, logrel_arr' x y z w v. *) - (* Solve All Obligations with solve_proper. *) - - (* Fixpoint interp_ty (τ : ty) : ITV -n> iProp := *) - (* match τ with *) - (* | Tnat => logrel_nat *) - (* | Tcont α β => logrel_cont (interp_ty α) (interp_ty β) *) - (* | Tarr τ α σ β => logrel_arr (interp_ty τ) (interp_ty α) *) - (* (interp_ty σ) (interp_ty β) *) - (* end. *) - - (* Definition logrel (τ α β : ty) : IT -n> iProp *) - (* := logrel_expr logrel_cont (interp_ty τ) (interp_ty α) (interp_ty β). *) - - (* Local Instance interp_ty_persistent (τ : ty) α : *) - (* Persistent (interp_ty τ α). *) - (* Proof. *) - (* revert α. induction τ=> α; simpl. *) - (* - unfold logrel_nat. apply _. *) - (* - unfold logrel_arr. apply _. *) - (* - unfold logrel_cont. *) - (* rewrite logrel_cont_unfold. *) - (* apply _. *) - (* Qed. *) - (* ---- *) - - (* -------------------------------------- *) - - Program Definition has_cont_stack : stateF ♯ IT -> iProp := λ σ, - (has_substate (σ : sReifier_state reify_delim ♯ IT) - ∗ ([∗ list] (x : laterO IT -n> laterO IT) ∈ σ, - ∃ (κ : HOM), x ≡ (laterO_map κ)))%I. - - Lemma wp_shift (σ : stateF ♯ IT) (f : (laterO IT -n> laterO IT) -n> laterO IT) - (k : IT -n> IT) β {Hk : IT_hom k} Φ : - laterO_map 𝒫 (f (laterO_map k)) ≡ Next β → - has_cont_stack σ -∗ - ▷ (£ 1 -∗ has_cont_stack σ -∗ WP β {{ Φ }}) -∗ - WP (k (SHIFT f)) {{ Φ }}. - Proof. - iIntros (Hp) "(Hs & G) Ha". - iApply (wp_shift with "[Hs]"); [done | done |]. - iNext. - iIntros "HCr Hs". - iApply ("Ha" with "HCr"). - iFrame. - Qed. - - Lemma wp_reset (σ : stateF ♯ IT) (e : IT) (k : IT -n> IT) {Hk : IT_hom k} - Φ : - has_cont_stack σ -∗ - ▷ (£ 1 -∗ has_cont_stack ((laterO_map k) :: σ) -∗ - WP 𝒫 e {{ Φ }}) -∗ - WP k $ (RESET (Next e)) {{ Φ }}. - Proof. - iIntros "(Hs & G) Ha". - iApply (wp_reset with "[Hs]"); [done |]. - iNext. - iIntros "HCr Hs". - iApply ("Ha" with "HCr"). - iFrame. - unshelve eset (F := exist _ k _ : HOM); first done. - iExists F. - now subst F. - Qed. - - Lemma wp_pop_end (v : IT) - {HV : AsVal v} - Φ : - has_cont_stack [] -∗ - ▷ (£ 1 -∗ has_cont_stack [] -∗ WP v {{ Φ }}) -∗ - WP 𝒫 v {{ Φ }}. - Proof. - iIntros "(Hs & G) Ha". - iApply (wp_pop_end with "Hs"). - iNext. - iIntros "HCr Hs". - iApply ("Ha" with "HCr"). - now iFrame. - Qed. - - Lemma wp_pop_cons (σ : stateF ♯ IT) (v : IT) (k : IT -n> IT) - {HV : AsVal v} - Φ : - has_cont_stack ((laterO_map k) :: σ) -∗ - ▷ (£ 1 -∗ has_cont_stack σ -∗ WP k $ v {{ Φ }}) -∗ - WP 𝒫 v {{ Φ }}. - Proof. - iIntros "(Hs & (_ & G)) Ha". - iApply (wp_pop_cons with "Hs"). - iNext. - iIntros "HCr Hs". - iApply ("Ha" with "HCr"). - iFrame. - Qed. - - Lemma wp_app_cont (σ : stateF ♯ IT) (e : laterO IT) (k' : laterO (IT -n> IT)) - (k : IT -n> IT) β {Hk : IT_hom k} - Φ : - laterO_ap k' e ≡ Next β → - has_cont_stack σ -∗ - ▷ (£ 1 -∗ has_cont_stack ((laterO_map k) :: σ) -∗ - WP β {{ Φ }}) -∗ - WP k (APP_CONT e k') {{ Φ }}. - Proof. - iIntros (Hb) "(Hs & G) Ha". - iApply (wp_app_cont with "Hs"); - first done. - iNext. - iIntros "HCr Hs". - iApply ("Ha" with "HCr"). - iFrame. - unshelve eset (F := exist _ k _ : HOM); first done. - iExists F. - now subst F. - Qed. + Definition obs_ref' + (t : IT) (κ : HOM) (σ : stateF ♯ IT) + : iProp := + (has_substate σ -∗ WP (𝒫 (`κ t)) {{ βv, has_substate [] }})%I. + Local Instance obs_ref_ne : NonExpansive3 obs_ref'. + Proof. solve_proper. Qed. + Program Definition obs_ref : IT -n> HOM -n> (stateF ♯ IT) -n> iProp := + λne x y z, obs_ref' x y z. + Solve All Obligations with solve_proper. - Definition obs_ref' (P : ITV -n> iProp) (t : IT) : iProp := - (∀ (σ : stateF ♯ IT), - has_cont_stack σ - -∗ WP t {{ βv, ∃ σ', - P βv ∗ has_cont_stack σ' }})%I. - Local Instance obs_ref_ne : NonExpansive2 obs_ref'. + Definition logrel_mcont' (P : ITV -n> iProp) (F : stateF ♯ IT) := + (∀ αv, P αv -∗ obs_ref (IT_of_V αv) HOM_id F)%I. + Local Instance logrel_mcont_ne : NonExpansive2 logrel_mcont'. Proof. solve_proper. Qed. - Program Definition obs_ref : (ITV -n> iProp) -n> IT -n> iProp := - λne x y, obs_ref' x y. + Program Definition logrel_mcont : (ITV -n> iProp) -n> (stateF ♯ IT) -n> iProp + := λne x y, logrel_mcont' x y. Solve All Obligations with solve_proper. - Program Definition logrel_cont' - (Pτ Pα : ITV -n> iProp) (k : ITV) + Program Definition logrel_ectx' + (Pτ Pα : ITV -n> iProp) (κ : HOM) : iProp := - (∃ (f : HOM), - (IT_of_V k) ≡ (Fun (Next f)) - ∧ □ ∀ αv, Pτ αv -∗ obs_ref Pα ((`f) (IT_of_V αv)))%I. - Local Instance logrel_cont_ne : NonExpansive3 logrel_cont'. + (□ ∀ αv, Pτ αv -∗ ∀ σ, logrel_mcont Pα σ -∗ obs_ref (IT_of_V αv) κ σ)%I. + Local Instance logrel_ectx_ne : NonExpansive3 logrel_ectx'. Proof. solve_proper. Qed. - Program Definition logrel_cont - : (ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp := - λne x y z, logrel_cont' x y z. + Program Definition logrel_ectx + : (ITV -n> iProp) -n> (ITV -n> iProp) -n> HOM -n> iProp + := λne x y z, logrel_ectx' x y z. Solve All Obligations with solve_proper. - Program Definition logrel_expr' (Pτ Pα Pβ : ITV -n> iProp) - (e : IT) : iProp := - (∀ (σ : stateF ♯ IT) (κ : HOM), - logrel_cont Pτ Pα (FunV (Next κ)) - -∗ has_cont_stack ((laterO_map κ :: σ) : sReifier_state reify_delim ♯ IT) - -∗ WP (𝒫 e) {{ βv, ∃ σ', Pβ βv ∗ has_cont_stack σ' }})%I. - Local Instance logrel_expr_ne : NonExpansive4 logrel_expr'. + Program Definition logrel_cont' V W (βv : ITV) : iProp := + (∃ (κ : HOM), (IT_of_V βv) ≡ + (Fun (Next (λne x, Tau (laterO_map (𝒫 ◎ `κ) (Next x))))) + ∧ □ logrel_ectx V W κ)%I. + Local Instance logrel_cont_ne : NonExpansive3 logrel_cont'. Proof. solve_proper. Qed. - Program Definition logrel_expr - : (ITV -n> iProp) -n> (ITV -n> iProp) -n> (ITV -n> iProp) -n> IT -n> iProp := - λne x y z w, logrel_expr' x y z w. + Program Definition logrel_cont + : (ITV -n> iProp) -n> (ITV -n> iProp) -n> ITV -n> iProp + := λne x y z, logrel_cont' x y z. Solve All Obligations with solve_proper. - Program Definition logrel_arr' (Pτ Pα Pσ Pβ : ITV -n> iProp) (f : ITV) : iProp := - (∃ f', IT_of_V f ≡ Fun f' - ∧ □ ∀ (βv : ITV), - Pτ βv -∗ logrel_expr Pσ Pα Pβ (APP' (Fun f') (IT_of_V βv)))%I. + Program Definition logrel_arr' (Pτ Pα Pσ Pβ : ITV -n> iProp) (f : ITV) : iProp + := (∃ f', IT_of_V f ≡ Fun f' + ∧ □ ∀ (βv : ITV), + Pτ βv -∗ ∀ (κ : HOM), + logrel_ectx Pσ Pα κ -∗ ∀ σ, + logrel_mcont Pβ σ -∗ obs_ref (APP' (Fun f') (IT_of_V βv)) κ σ)%I. Local Instance logrel_arr_ne : (∀ n, Proper (dist n ==> dist n @@ -392,61 +222,185 @@ Section logrel. - unfold logrel_cont. apply _. Qed. + Program Definition logrel_expr (τ α δ : ITV -n> iProp) : IT -n> iProp + := λne e, (∀ E, logrel_ectx τ α E + -∗ ∀ F, logrel_mcont δ F + -∗ obs_ref e E F)%I. + Solve All Obligations with solve_proper. + Definition logrel (τ α β : ty) : IT -n> iProp := logrel_expr (interp_ty τ) (interp_ty α) (interp_ty β). Program Definition ssubst_valid {S : Set} (Γ : S -> ty) (ss : interp_scope S) : iProp := - (∀ x α, □ logrel (Γ x) α α (ss x))%I. + (∀ x τ, □ logrel (Γ x) τ τ (ss x))%I. - (* TODO: continuation *) Program Definition valid {S : Set} (Γ : S -> ty) (e : interp_scope S -n> IT) - (τ α β : ty) : iProp := - (∀ γ, ssubst_valid Γ γ - -∗ logrel τ α β (e γ))%I. + (τ α σ : ty) : iProp := + (□ ∀ γ, ssubst_valid Γ γ + -∗ logrel τ α σ (e γ))%I. + + Lemma compat_empty P : + ⊢ logrel_mcont P []. + Proof. + iIntros (v) "Pv HH". + iApply (wp_pop_end with "HH"). + iNext. + iIntros "_ HHH". + by iApply wp_val. + Qed. + + Lemma compat_cons P Q (x : HOM) (xs : list (later IT -n> later IT)) : + ⊢ logrel_ectx P Q x + -∗ logrel_mcont Q xs + -∗ logrel_mcont P (laterO_map (𝒫 ◎ `x) :: xs). + Proof. + iIntros "#H G". + iIntros (v) "Hv Hst". + iApply (wp_pop_cons with "Hst"). + iNext. + iIntros "_ Hst". + iSpecialize ("H" $! v with "Hv"). + iApply ("H" $! xs with "G Hst"). + Qed. + + Lemma compat_HOM_id P : + ⊢ logrel_ectx P P HOM_id. + Proof. + iIntros (v). + iModIntro. + iIntros "Pv". + iIntros (σ) "Hσ HH". + iApply ("Hσ" with "Pv HH"). + Qed. + + Lemma logrel_of_val τ α v : + interp_ty α v -∗ logrel α τ τ (IT_of_V v). + Proof. + iIntros "#H". + iIntros (κ) "Hκ". + iIntros (σ) "Hσ Hown". + iApply ("Hκ" with "H Hσ Hown"). + Qed. Lemma compat_var {S : Set} (Γ : S -> ty) (x : S) : ⊢ (∀ α, valid Γ (interp_var x) (Γ x) α α). Proof. - iIntros (α γ) "Hss". - iApply "Hss". + iIntros (α). + iModIntro. + iIntros (γ) "#Hss". + iIntros (E) "HE". + iIntros (F) "HF". + iIntros "Hσ". + iApply ("Hss" with "HE HF Hσ"). Qed. - Lemma logrel_of_val τ α v : - interp_ty τ v -∗ logrel τ α α (IT_of_V v). + Lemma compat_reset {S : Set} (Γ : S -> ty) e σ τ : + ⊢ valid Γ e σ σ τ -∗ (∀ α, valid Γ (interp_reset rs e) τ α α). + Proof. + iIntros "#H". + iIntros (α). + iModIntro. + iIntros (γ) "Hγ". + iIntros (κ) "Hκ". + iIntros (m) "Hm Hst". + assert (𝒫 ((`κ) (interp_reset rs e γ)) + ≡ (𝒫 ◎ `κ) (interp_reset rs e γ)) as ->. + { reflexivity. } + iApply (wp_reset with "Hst"). + iNext. + iIntros "_ Hst". + iSpecialize ("H" $! γ with "Hγ"). + iSpecialize ("H" $! HOM_id (compat_HOM_id _) (laterO_map (𝒫 ◎ `κ) :: m)). + iAssert (logrel_mcont (interp_ty τ) (laterO_map (𝒫 ◎ `κ) :: m)) + with "[Hm Hκ]" as "Hm". + { + iIntros (v) "Hv Hst". + iApply (wp_pop_cons with "Hst"). + iNext. + iIntros "_ Hst". + iSpecialize ("Hκ" $! v with "Hv"). + iSpecialize ("Hκ" $! m with "Hm"). + iSpecialize ("Hκ" with "Hst"). + iApply "Hκ". + } + iSpecialize ("H" with "Hm Hst"). + iApply "H". + Qed. + + Program Definition 𝒫_HOM : @HOM sz CtxDep R _ rs := exist _ 𝒫 _. + Next Obligation. + apply _. + Qed. + + Lemma compat_shift {S : Set} (Γ : S -> ty) e σ α τ β : + ⊢ valid (Γ ▹ (Tcont τ α)) e σ σ β -∗ valid Γ (interp_shift _ e) τ α β. Proof. iIntros "#H". - iIntros (σ κ) "#Hκ". - iIntros "Hs". - iApply (wp_pop_cons with "Hs"). - iDestruct "Hκ" as "(%f & #HEQ & Hκ)". - iPoseProof (Fun_inj' with "HEQ") as "HEQ'". + iModIntro. + iIntros (γ) "#Hγ". + iIntros (κ) "#Hκ". + iIntros (m) "Hm Hst". + assert (𝒫 ((`κ) (interp_shift rs e γ)) + ≡ (𝒫 ◎ `κ) (interp_shift rs e γ)) as ->. + { reflexivity. } + iApply (wp_shift with "Hst"). + { rewrite laterO_map_Next; reflexivity. } iNext. - iIntros "HCr Hσ". - unshelve eset (F := (λne βv, interp_ty α βv)%I : ITV -n> iProp); - first solve_proper. - iSpecialize ("Hκ" $! v with "H"). - iSpecialize ("Hκ" $! σ with "Hσ"). - subst F. - iAssert ((`κ) (IT_of_V v) ≡ (`f) (IT_of_V v))%I as "HEQ''". + iIntros "_ Hst". + match goal with + | |- context G [ofe_mor_car _ _ e ?a] => + set (γ' := a) + end. + iAssert (ssubst_valid (Γ ▹ Tcont τ α) γ') with "[Hγ Hκ]" as "Hγ'". { - unshelve iApply (f_equivI (λne (f : IT -n> IT), - f (IT_of_V v)) (`κ) (`f) with "HEQ'"); solve_proper. + iIntros (x τ'). + destruct x as [| x]. + - iModIntro. + subst γ'. + iIntros (E) "HE". + iIntros (F) "HF Hst". + simpl. + match goal with + | |- context G [ofe_mor_car _ _ (`E) (ofe_mor_car _ _ Fun ?a)] => + set (f := a) + end. + iApply ("HE" $! (FunV f) with "[Hκ] HF Hst"). + iExists κ. + iSplit. + + subst f; iPureIntro. + reflexivity. + + iApply "Hκ". + - iApply "Hγ". } - iRewrite "HEQ''". - iExact "Hκ". + iSpecialize ("H" $! γ' with "Hγ'"). + iSpecialize ("H" $! HOM_id (compat_HOM_id _) m with "Hm Hst"). + iApply "H". + Qed. + + Lemma compat_nat {S : Set} (Γ : S → ty) n α : + ⊢ valid Γ (interp_nat rs n) Tnat α α. + Proof. + iModIntro. + iIntros (γ) "#Hγ". + assert ((interp_nat rs n γ) ≡ IT_of_V (RetV n)) as ->. + { reflexivity. } + iApply logrel_of_val. + iExists _; by iPureIntro. Qed. Lemma compat_recV {S : Set} (Γ : S -> ty) τ1 α τ2 β e : - ⊢ □ valid ((Γ ▹ (Tarr τ1 α τ2 β) ▹ τ1)) e τ2 α β + ⊢ valid ((Γ ▹ (Tarr τ1 α τ2 β) ▹ τ1)) e τ2 α β -∗ (∀ θ, valid Γ (interp_rec rs e) (Tarr τ1 α τ2 β) θ θ). Proof. iIntros "#H". - iIntros (θ γ) "#Henv". + iIntros (θ). + iModIntro. + iIntros (γ) "#Hγ". set (f := (ir_unf rs e γ)). iAssert (interp_rec rs e γ ≡ IT_of_V $ FunV (Next f))%I as "Hf". { iPureIntro. apply interp_rec_unfold. } @@ -458,226 +412,509 @@ Section logrel. iModIntro. iLöb as "IH". iIntros (v) "#Hw". - iIntros (σ κ) "#Hκ Hσ". + iIntros (κ) "#Hκ". + iIntros (σ) "Hσ Hst". rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. - pose (γ' := (extend_scope (extend_scope γ (interp_rec rs e γ)) (IT_of_V v))). + pose (γ' := + (extend_scope (extend_scope γ (interp_rec rs e γ)) (IT_of_V v))). rewrite /logrel. + Opaque extend_scope. + simpl. + rewrite hom_tick. + rewrite hom_tick. + iApply wp_tick. + iNext. iSpecialize ("H" $! γ' with "[Hw]"). { iIntros (x). destruct x as [| [| x]]; iIntros (ξ); iModIntro. * iApply logrel_of_val. iApply "Hw". - * simpl. + * iIntros (κ') "Hκ'". + iIntros (σ') "Hσ' Hst". + Transparent extend_scope. + simpl. iRewrite "Hf". - iIntros (σ' κ') "Hκ' Hσ'". - iApply (wp_pop_cons with "Hσ'"). - iDestruct "Hκ'" as "(%g & #HEQ & Hκ')". - Transparent IT_of_V. - iDestruct (Fun_inj' with "HEQ") as "HEQ'". - iNext. - iIntros "HCr Hσ'". - iSpecialize ("Hκ'" $! (FunV (Next f))). - iSpecialize ("Hκ'" with "[]"). + iSpecialize ("Hκ'" $! (FunV (Next f)) with "[IH]"). { iExists (Next f). iSplit; first done. iModIntro. - iIntros (v') "Hv'". - by iApply "IH". - } - iSpecialize ("Hκ'" $! σ' with "Hσ'"). - iAssert ((`κ') (IT_of_V (FunV (Next f))) - ≡ (`g) (IT_of_V (FunV (Next f))))%I as "HEQ''". - { - unshelve iPoseProof - (f_equivI (λne (f' : IT -n> IT), - f' (Fun (Next f))) (`κ') (`g) with "[HEQ']") as "GGG"; - first solve_proper; first solve_proper; first done. - iApply "GGG". + iIntros (βv) "Hβv". + iIntros (κ'') "Hκ''". + iIntros (σ'') "Hσ'' Hst". + iApply ("IH" $! βv with "Hβv Hκ'' Hσ'' Hst"). } - simpl. - iRewrite "HEQ''". - iExact "Hκ'". - * iApply "Henv". + iApply ("Hκ'" $! σ' with "Hσ' Hst"). + * iApply "Hγ". } - Opaque extend_scope. - simpl. - rewrite hom_tick. - iApply wp_tick. - iNext. subst γ'. - iApply ("H" with "Hκ Hσ"). + iApply ("H" with "Hκ Hσ Hst"). Qed. - Program Definition 𝒫_HOM : @HOM sz CtxDep R _ _ := exist _ 𝒫 _. - Next Obligation. apply _. Qed. + Program Definition AppContRSCtx_HOM {S : Set} + (α : @interp_scope F R _ S -n> IT) + (env : @interp_scope F R _ S) + : HOM := exist _ (interp_app_contrk rs α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. - Lemma compat_reset {S : Set} (Γ : S -> ty) e σ τ : - ⊢ valid Γ e σ σ τ -∗ (∀ α, valid Γ (interp_reset rs e) τ α α). + Program Definition AppContLSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F R _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_app_contlk rs (constO β) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - intros ???. + do 2 f_equiv. + intros ?; simpl. + solve_proper. + - rewrite get_val_ITV. + rewrite get_val_ITV. + simpl. + rewrite get_fun_tick. + reflexivity. + - rewrite get_val_ITV. + simpl. rewrite get_fun_vis. simpl. + f_equiv. + intros ?; simpl. + apply later_map_ext. + intros ?; simpl. + rewrite get_val_ITV. + simpl. + reflexivity. + - rewrite get_val_ITV. simpl. rewrite get_fun_err. reflexivity. + Qed. + + Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) + (α : @interp_scope F R _ S -n> IT) (env : @interp_scope F R _ S) + : HOM := exist _ (interp_natoprk rs op α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) + (α : IT) (env : @interp_scope F R _ S) + (Hv : AsVal α) + : HOM := exist _ (interp_natoplk rs op (constO α) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition AppRSCtx_HOM {S : Set} + (α : @interp_scope F R _ S -n> IT) + (env : @interp_scope F R _ S) + : HOM := exist _ (interp_apprk rs α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition AppLSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F R _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_applk rs (constO β) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Lemma compat_nat_op {S : Set} (Γ : S → ty) + D E F e1 e2 op : + ⊢ valid Γ e1 Tnat E F + -∗ valid Γ e2 Tnat F D + -∗ valid Γ (interp_natop rs op e1 e2) Tnat E D. Proof. - iIntros "H". - iIntros (α γ) "#Henv". - iIntros (σ' κ) "#Hκ Hσ'". - iApply (wp_reset with "Hσ'"). - iNext. - iIntros "HCr Hσ'". - iSpecialize ("H" $! γ with "Henv"). - iSpecialize ("H" $! (laterO_map (`κ) :: σ') 𝒫_HOM with "[] Hσ'"). + iIntros "#H #G". + iModIntro. + iIntros (γ) "#Hγ". + iIntros (κ) "#Hκ". + iIntros (m) "Hm Hst". + rewrite /interp_natop //=. + + set (κ' := (NatOpRSCtx_HOM op e1 γ)). + assert ((NATOP (do_natop op) (e1 γ) (e2 γ)) = ((`κ') (e2 γ))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + + iSpecialize ("G" $! γ with "Hγ"). + iSpecialize ("G" $! sss). + iApply ("G" with "[H] Hm Hst"). + + iIntros (w). + iModIntro. + iIntros "#Hw". + iIntros (m') "Hm Hst". + subst sss. + subst κ'. + simpl. + + pose (κ' := (NatOpLSCtx_HOM op (IT_of_V w) γ _)). + assert ((NATOP (do_natop op) (e1 γ) (IT_of_V w)) = ((`κ') (e1 γ))) + as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + + iSpecialize ("H" $! γ with "Hγ"). + iSpecialize ("H" $! sss). + iApply ("H" with "[] Hm Hst"). + + iIntros (v). + iModIntro. + iIntros "#Hv". + iIntros (m'') "Hm Hst". + subst sss. + subst κ'. + simpl. + + iDestruct "Hw" as "(%n & #HEQ1)". + iDestruct "Hv" as "(%n' & #HEQ2)". + iSpecialize ("Hκ" $! (RetV (do_natop op n' n)) with "[]"). { - iExists 𝒫_HOM. - iSplit; first done. - iModIntro. - iIntros (v) "#Hv". - iIntros (σ'') "Hσ''". - destruct σ'' as [| κ' σ'']. - - simpl. - iApply (wp_pop_end with "Hσ''"). - iNext. - iIntros "HC Hs". - iApply wp_val. - iModIntro. - iExists []. - iFrame "Hs Hv". - - simpl. - simpl in κ'. - iDestruct "Hσ''" as "(H1 & #H2)". - rewrite big_opL_cons. - iDestruct "H2" as "((%κκ & Hκκ) & H2)". - iRewrite "Hκκ" in "H1". - iApply (delim.wp_pop_cons with "H1"). - iNext. - iIntros "HC Hs". - iDestruct "Hκ" as "(%g & #HEQ & #Hκ)". - iSpecialize ("Hκ" $! v). - (* pop cons different rule with extra tick *) - admit. + iExists _. + iPureIntro. + reflexivity. } - (* push continuation forward *) - iApply (wp_wand with "H"). - iIntros (v) "(%s & #G1 & G2)". - iModIntro. - iExists s. - iFrame. - admit. - Admitted. + iSpecialize ("Hκ" $! m'' with "Hm Hst"). + rewrite IT_of_V_Ret. - Lemma compat_shift {S : Set} (Γ : S -> ty) e σ α τ β : - ⊢ valid (Γ ▹ (Tcont τ α)) e σ σ β -∗ valid Γ (interp_shift _ e) τ α β. - Proof. - iIntros "H". - iIntros (γ) "#Henv". - iIntros (σ' κ) "#Hκ Hσ'". - iApply (wp_shift with "Hσ'"). - { apply (laterO_map_Next 𝒫). } + iAssert ((NATOP (do_natop op) (IT_of_V v) (IT_of_V w)) + ≡ (Ret (do_natop op n' n)))%I as "#HEQ". { - iNext. - iIntros "HCr Hσ'". - set (F := (FunV (Next (λne x : IT, Tau (laterO_map 𝒫 (Next x))))) : ITV). - iSpecialize ("H" $! (extend_scope γ (IT_of_V F)) with "[Hκ]"). - - iIntros (x τ'). - iDestruct "Hκ" as "(%g & #HEQ & #Hκ)". - iIntros (σ'' κ'). - iModIntro. - iIntros "Hκ' Hσ''". - destruct x as [| x]. - + Transparent extend_scope. - iApply (wp_pop_cons with "Hσ''"). - iDestruct (Fun_inj' with "HEQ") as "HEQ''". - iDestruct "Hκ'" as "(%h & #HEQ' & #Hκ')". - iDestruct (Fun_inj' with "HEQ'") as "HEQ'''". - iSpecialize ("Hκ'" $! F). - iNext. - iIntros "HCr Hs". - iApply (wp_wand with "[Hκ' Hs]"). - { - iAssert ((`κ') (extend_scope γ (IT_of_V F) VZ) - ≡ (`h) (extend_scope γ (IT_of_V F) VZ))%I as "HEQ''''". - { - unshelve iPoseProof (f_equivI (λne (f' : IT -n> IT), f' (extend_scope γ (IT_of_V F) VZ)) (`κ') (`h) with "[HEQ']") as "GGG"; - first solve_proper; first solve_proper; - first done. - iApply "GGG". - } - iRewrite "HEQ''''". - iApply "Hκ'"; last iApply "Hs". - simpl. - unfold logrel_cont'. - subst F. - unshelve eset (F' := exist _ (λne x : IT, Tau (laterO_map 𝒫 (Next x))) _ : HOM). - { - simpl. - econstructor. - - intros. - rewrite ->2 later_map_Next. - rewrite hom_tick. - rewrite <- Tick_eq. - rewrite <- Tick_eq. - reflexivity. - - intros. - rewrite -> later_map_Next. - rewrite hom_vis. - rewrite <- Tick_eq. - admit. - - intros. - rewrite -> later_map_Next. - rewrite hom_err. - admit. - } - iExists F'. - iSplit; first done. - iModIntro. - iIntros (v) "HHH". - subst F'. - simpl. - rewrite later_map_Next. - iIntros (s) "Hs". - rewrite <- Tick_eq. - iApply wp_tick. - iNext. - destruct s as [| x s]. - - iApply (wp_pop_end with "Hs"). - iNext. - iIntros "HCr Hs". - iApply wp_val. - iModIntro. - iExists []. - iFrame "Hs". - admit. - - admit. - } - iIntros (v) "HHH". - iModIntro. - iApply "HHH". - + iApply ("Henv" with "[Hκ'] Hσ''"). - iApply "Hκ'". - - subst F. - Opaque extend_scope. - simpl. - unfold logrel_expr'. - simpl. - iSpecialize ("H" $! σ' κ). + iRewrite "HEQ1". + rewrite IT_of_V_Ret. + iAssert ((IT_of_V v) ≡ IT_of_V (RetV n'))%I as "#HEQ2'". + { + iApply f_equivI. + iApply "HEQ2". + } + rewrite IT_of_V_Ret. + iAssert (NATOP (do_natop op) (IT_of_V v) (Ret n) + ≡ NATOP (do_natop op) (Ret n') (Ret n))%I as "#HEQ2''". + { + unshelve iApply (f_equivI (λne x, NATOP (do_natop op) x (Ret n))). + { solve_proper. } + { solve_proper. } + iApply "HEQ2'". + } + iRewrite "HEQ2''". + rewrite NATOP_Ret. + done. + } + iRewrite "HEQ". + iApply "Hκ". + Qed. + + Lemma compat_app {S : Set} (Γ : S → ty) + A B C D E F e1 e2 : + ⊢ valid Γ e1 (Tarr A C B E) E F + -∗ valid Γ e2 A F D + -∗ valid Γ (interp_app rs e1 e2) B C D. + Proof. + iIntros "#H #G". + iModIntro. + iIntros (γ) "#Hγ". + iIntros (κ) "#Hκ". + iIntros (σ) "Hσ Hst". + rewrite /interp_app //=. + + pose (κ' := (AppRSCtx_HOM e1 γ)). + assert ((e1 γ ⊙ (e2 γ)) = ((`κ') (e2 γ))) as ->. + { simpl; unfold AppRSCtx. reflexivity. } + assert ((`κ) ((`κ') (e2 γ)) = ((`κ) ◎ (`κ')) (e2 γ)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + + iSpecialize ("G" $! γ with "Hγ"). + iSpecialize ("G" $! sss). + iApply ("G" with "[H] Hσ Hst"). + + iIntros (w). + iModIntro. + iIntros "#Hw". + iIntros (m') "Hm Hst". + subst sss. + subst κ'. + simpl. - admit. + pose (κ'' := (AppLSCtx_HOM (IT_of_V w) γ _)). + assert (((`κ) (e1 γ ⊙ (IT_of_V w))) = (((`κ) ◎ (`κ'')) (e1 γ))) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ'')). + assert ((`κ ◎ `κ'') = (`sss)) as ->. + { reflexivity. } + + iSpecialize ("H" $! γ with "Hγ"). + iSpecialize ("H" $! sss). + iApply ("H" with "[] Hm Hst"). + + iIntros (v). + iModIntro. + iIntros "#Hv". + iIntros (m'') "Hm Hst". + subst sss. + subst κ''. + simpl. + + iDestruct "Hv" as "(%n' & #HEQ & Hv)". + iSpecialize ("Hv" $! w with "Hw"). + iSpecialize ("Hv" $! κ with "Hκ"). + iSpecialize ("Hv" $! m'' with "Hm Hst"). + iAssert ((IT_of_V v ⊙ (IT_of_V w)) + ≡ (Fun n' ⊙ (IT_of_V w)))%I as "#HEQ'". + { + iApply (f_equivI (λne x, (x ⊙ (IT_of_V w)))). + iApply "HEQ". } - Admitted. + iRewrite "HEQ'". + iApply "Hv". + Qed. Lemma compat_appcont {S : Set} (Γ : S -> ty) e1 e2 τ α δ β σ : - valid Γ e1 (Tcont τ α) δ β - -∗ valid Γ e2 τ σ δ + valid Γ e1 (Tcont τ α) σ δ + -∗ valid Γ e2 τ δ β -∗ valid Γ (interp_app_cont _ e1 e2) α σ β. Proof. - iIntros "H G". + iIntros "#H #G". + iModIntro. iIntros (γ) "#Henv". - iIntros (σ' κ) "#Hκ Hσ'". - iSpecialize ("H" $! γ with "Henv"). + iIntros (κ) "#Hκ". + iIntros (σ') "Hm Hst". + + pose (κ' := (AppContRSCtx_HOM e1 γ)). + assert ((interp_app_cont rs e1 e2 γ) = ((`κ') (e2 γ))) as ->. + { simpl. reflexivity. } + assert ((`κ) ((`κ') (e2 γ)) = ((`κ) ◎ (`κ')) (e2 γ)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + iSpecialize ("G" $! γ with "Henv"). - iSpecialize ("H" $! σ'). - iSpecialize ("G" $! σ'). - (* (* bind + pop *) *) - admit. + iSpecialize ("G" $! sss). + iApply ("G" with "[H] Hm Hst"). + + iIntros (w). + iModIntro. + iIntros "#Hw". + iIntros (m') "Hm Hst". + subst sss. + subst κ'. + Opaque interp_app_cont. + simpl. + + pose (κ'' := (AppContLSCtx_HOM (IT_of_V w) γ _)). + set (F := (`κ) _). + assert (F ≡ (((`κ) ◎ (`κ'')) (e1 γ))) as ->. + { + subst F. simpl. Transparent interp_app_cont. simpl. + f_equiv. + rewrite ->2 get_val_ITV. + simpl. + reflexivity. + } + pose (sss := (HOM_compose κ κ'')). + assert ((`κ ◎ `κ'') = (`sss)) as ->. + { reflexivity. } + + iSpecialize ("H" $! γ with "Henv"). + iSpecialize ("H" $! sss). + iApply ("H" with "[] Hm Hst"). + + iIntros (v). + iModIntro. + iIntros "#Hv". + iIntros (m'') "Hm Hst". + subst sss. + subst κ''. + Opaque APP_CONT. + simpl. + + rewrite get_val_ITV. + simpl. + + iDestruct "Hv" as "(%n' & #HEQ & #Hv)". + iRewrite "HEQ". + rewrite get_fun_fun. + simpl. + + match goal with + | |- context G [ofe_mor_car _ _ + (ofe_mor_car _ _ APP_CONT ?a) ?b] => + set (T := APP_CONT a b) + end. + iAssert (𝒫 ((`κ) T) ≡ (𝒫 ◎ (`κ)) T)%I as "HEQ'". + { iPureIntro. reflexivity. } + iRewrite "HEQ'"; iClear "HEQ'". + subst T. + + iApply (wp_app_cont with "[Hst]"). + { reflexivity. } + - iFrame "Hst". + - simpl. + iNext. + iIntros "_ Hst". + rewrite later_map_Next. + rewrite <-Tick_eq. + iApply wp_tick. + iNext. + iSpecialize ("Hv" $! w with "Hw"). + + iApply ("Hv" $! (laterO_map (𝒫 ◎ `κ) :: m'') with "[Hm] Hst"). + { + iIntros (p) "#Hp Hst". + iApply (wp_pop_cons with "Hst"). + iNext. + iIntros "_ Hst". + iApply ("Hκ" with "Hp Hm Hst"). + } + + Qed. + + Program Definition valid_ectx {S : Set} + (Γ : S -> ty) + (e : interp_scope S -n> IT -n> IT) + `{∀ γ, IT_hom (e γ)} + (τ α : ty) : iProp := + (□ ∀ γ, ssubst_valid Γ γ + -∗ logrel_ectx (interp_ty τ) (interp_ty α) (exist _ (e γ) _))%I. + Next Obligation. + intros; apply _. + Qed. + + (* bla-bla done *) + Lemma compat_natop_r {S : Set} (Γ : S → ty) α τ + op t (E : interp_scope S -n> IT -n> IT) + `{∀ γ, IT_hom (E γ)} + `{∀ γ, IT_hom (interp_natoprk _ op t E γ)} : + ⊢ valid_ectx Γ E Tnat τ + -∗ valid Γ t Tnat τ α + -∗ valid_ectx Γ (interp_natoprk _ op t E) Tnat α. + Proof. + iIntros "#H #G". + iIntros (γ). + iModIntro. + iIntros "#Hγ". + iIntros (v). + iModIntro. + iIntros "#Hv". + iIntros (m) "Hm Hst". + + pose (κ' := (NatOpLSCtx_HOM op (IT_of_V v) γ _)). + simpl. + assert (E γ (NATOP (do_natop op) (t γ) (IT_of_V v)) = ((E γ ◎ `κ') (t γ))) + as -> by done. + iSpecialize ("G" $! γ with "Hγ"). + unshelve iApply ("G" $! (exist _ (E γ ◎ `κ') _) with "[] Hm Hst"). + { apply _. } + simpl. + + iIntros (w). + iModIntro. + iIntros "#Hw". + iIntros (m') "Hm Hst". + simpl. + + iSpecialize ("H" $! γ with "Hγ"). Admitted. + (* bla-bla done *) + Lemma compat_natop_l {S : Set} (Γ : S → ty) α τ + op (t : interp_scope S -n> IT) (E : interp_scope S -n> IT -n> IT) + `{∀ γ, IT_hom (E γ)} + `{∀ γ, AsVal (t γ)} + `{∀ γ, IT_hom (interp_natoplk _ op t E γ)} : + ⊢ valid_ectx Γ E Tnat τ + -∗ valid Γ t Tnat τ α + -∗ valid_ectx Γ (interp_natoplk _ op t E) Tnat α. + Proof. + iIntros "#H #G". + iIntros (γ). + iModIntro. + iIntros "#Hγ". + iIntros (v). + iModIntro. + iIntros "#Hv". + iIntros (m) "Hm Hst". + simpl. + pose (κ' := (NATOP (do_natop op) (IT_of_V v))). + simpl. + assert (E γ (NATOP (do_natop op) (IT_of_V v) (t γ)) = ((E γ ◎ κ') (t γ))) + as -> by done. + iSpecialize ("G" $! γ with "Hγ"). + unshelve iApply ("G" $! (exist _ (E γ ◎ κ') _) with "[] Hm Hst"). + { apply _. } + subst κ'. + simpl. + + iIntros (w). + iModIntro. + iIntros "#Hw". + iIntros (m') "Hm Hst". + simpl. + + iSpecialize ("H" $! γ with "Hγ"). + Admitted. + + (* Lemma compat_app_l {S : Set} (Γ : S → ty) τ α c d e *) + (* (* (t : interp_scope S -n> ITVO) *) t *) + (* (E : interp_scope S -n> IT -n> IT) *) + (* `{∀ γ, IT_hom (E γ)} *) + (* (* `{∀ γ, AsVal (t γ)} *) *) + (* `{∀ γ, IT_hom (interp_app_contlk _ t E γ)} : *) + (* ⊢ valid_ectx Γ E τ α *) + (* -∗ valid Γ t c d e *) + (* -∗ valid_ectx Γ (interp_app_contlk _ t E) τ α. *) + (* Proof. *) + (* iIntros "#H #G". *) + (* iIntros (γ). *) + (* assert (AsVal (t γ)); first admit. *) + (* iModIntro. *) + (* iIntros "#Hγ". *) + (* iIntros (v). *) + (* iModIntro. *) + (* iIntros "#Hv". *) + (* iIntros (m) "Hm Hst". *) + (* simpl. *) + (* rewrite get_val_ITV. *) + (* simpl. *) + (* iSpecialize ("H" $! γ with "Hγ"). *) + (* iSpecialize ("H" $! v with "Hv"). *) + (* iSpecialize ("H" $! m with "Hm Hst"). *) + (* simpl. *) + + (* Lemma compat_app_r {S : Set} (Γ : S → ty) τ α c d e t *) + (* (E : interp_scope S -n> IT -n> IT) *) + (* `{∀ γ, IT_hom (E γ)} *) + (* `{∀ γ, IT_hom (interp_app_contrk _ t E γ)} : *) + (* ⊢ valid_ectx Γ E τ α *) + (* -∗ valid Γ t c d e *) + (* -∗ valid_ectx Γ (interp_app_contrk _ t E) τ α. *) + (* Proof. *) + (* iIntros "#H #G". *) + (* iIntros (γ). *) + (* iModIntro. *) + (* iIntros "#Hγ". *) + (* iIntros (v). *) + (* iModIntro. *) + (* iIntros "#Hv". *) + (* iIntros (m) "Hm Hst". *) + (* simpl. *) + (* rewrite get_val_ITV. *) + (* simpl. *) + (* iSpecialize ("H" $! γ with "Hγ"). *) + (* iSpecialize ("H" $! v with "Hv"). *) + (* iSpecialize ("H" $! m with "Hm Hst"). *) + (* simpl. *) + (* Qed. *) + End logrel. Local Definition rs : gReifiers CtxDep 1 := gReifiers_cons reify_delim gReifiers_nil. @@ -685,36 +922,40 @@ Local Definition rs : gReifiers CtxDep 1 := gReifiers_cons reify_delim gReifiers Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. Lemma logpred_adequacy cr Σ R `{!Cofe R, SubOfe natO R} - `{!invGpreS Σ} `{!statePreG rs R Σ} τ β' + `{!invGpreS Σ} `{!statePreG rs R Σ} τ (α : interp_scope ∅ -n> IT (gReifiers_ops rs) R) - (β : IT (gReifiers_ops rs) R) st st' k : + (e : IT (gReifiers_ops rs) R) st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ}, - (£ cr ⊢ valid rs □ α τ τ β')%I) → - ssteps (gReifiers_sReifier rs) (𝒫 (α ı_scope)) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) - ∨ (∃ βv, IT_of_V βv ≡ β). + (£ cr ⊢ valid rs □ α τ τ τ)%I) → + ssteps (gReifiers_sReifier rs) (𝒫 (α ı_scope)) ([], ()) e st' k → + (∃ β1 st1, sstep (gReifiers_sReifier rs) e st' β1 st1) + ∨ (∃ βv, IT_of_V βv ≡ e). Proof. intros Hlog Hst. - destruct (IT_to_V β) as [βv|] eqn:Hb. + destruct (IT_to_V e) as [βv|] eqn:Hb. { right. exists βv. apply IT_of_to_V'. rewrite Hb; eauto. } left. - cut ((∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) - ∨ (∃ e, β ≡ Err e ∧ notStuck e)). + cut ((∃ β1 st1, sstep (gReifiers_sReifier rs) e st' β1 st1) + ∨ (∃ e', e ≡ Err e' ∧ notStuck e')). { intros [?|He]; first done. destruct He as [? [? []]]. } eapply (wp_safety cr); eauto. { apply Hdisj. } { by rewrite Hb. } intros H1 H2. - exists (λ _, True)%I. split. (* (interp_ty _ τ)%I *) + exists (λ _, True)%I. split. { apply _. } iIntros "[Hcr Hst]". iPoseProof (Hlog with "Hcr") as "Hlog". - destruct st as [σ []]. - iAssert (has_substate σ) with "[Hst]" as "Hs". + match goal with + | |- context G [has_full_state (?a, _)] => + set (st := a) + end. + simpl in st. + iAssert (has_substate _) with "[Hst]" as "Hs". { unfold has_substate, has_full_state. - assert (of_state rs (IT (gReifiers_ops rs) _) (σ,()) ≡ - of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ)) as ->; last done. + eassert (of_state rs (IT (gReifiers_ops rs) _) (_,()) ≡ + of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state _)) as ->; last done. intro j. unfold sR_idx. simpl. unfold of_state, of_idx. destruct decide as [Heq|]; last first. @@ -723,28 +964,26 @@ Proof. inv_fin j; last done. intros Heq. rewrite (eq_pi _ _ Heq eq_refl)//. + simpl. + unfold iso_ofe_refl. + cbn. + reflexivity. } iSpecialize ("Hlog" $! ı_scope with "[]"). { iIntros ([]). } - iSpecialize ("Hlog" $! σ HOM_id with "[]"). + iSpecialize ("Hlog" $! HOM_id (compat_HOM_id _ _) [] with "[]"). { - iExists HOM_id. - iSplit; first done. - iModIntro. - iIntros (αv) "HHH". - iIntros (βv) "Hκ". - simpl. + iIntros (αv) "HHH GGG". + iApply (wp_pop_end with "GGG"). + iNext. + iIntros "_ GGG". iApply wp_val. - iModIntro. - iExists βv. - iFrame. - } - iSpecialize ("Hlog" with "[Hs]"). - { - admit. + by iModIntro. } + subst st. + iSpecialize ("Hlog" with "Hs"). iApply (wp_wand with "Hlog"). iIntros (βv). simpl. iIntros "_". done. -Admitted. +Qed. diff --git a/theories/examples/delim_lang/interp.v b/theories/examples/delim_lang/interp.v index ae6f12b..0e8fda4 100644 --- a/theories/examples/delim_lang/interp.v +++ b/theories/examples/delim_lang/interp.v @@ -21,11 +21,9 @@ Section interp. Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - Global Instance denot_cont_ne (κ : IT -n> IT) : - NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). - Proof. - solve_proper. - Qed. + Global Instance denot_cont_ne (κ : later IT -n> later IT) : + NonExpansive (λ x : IT, Tau (κ (Next x))). + Proof. solve_proper. Defined. (** * Interpreting individual operators *) @@ -41,7 +39,7 @@ Section interp. interp_scope S -n> IT := λne env, SHIFT (λne (k : laterO IT -n> laterO IT), Next (e (extend_scope env (λit x, Tau (k (Next x)))))). - Next Obligation. solve_proper. Qed. + Next Obligation. intros; apply denot_cont_ne. Defined. Next Obligation. solve_proper_prepare. repeat f_equiv. @@ -57,7 +55,6 @@ Section interp. repeat f_equiv. Qed. - (** ** NATOP *) Program Definition interp_natop {A} (op : nat_op) (t1 t2 : A -n> IT) : A -n> IT := λne env, NATOP (do_natop op) (t1 env) (t2 env). From a4b99482f614b7ce11a242c55e9e98667eaa7040 Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Fri, 31 May 2024 14:19:23 +0200 Subject: [PATCH 03/14] minor lemmas about ectx validity --- theories/examples/delim_lang/adeq.v | 80 +++++++++++++++++++++++++++-- 1 file changed, 76 insertions(+), 4 deletions(-) diff --git a/theories/examples/delim_lang/adeq.v b/theories/examples/delim_lang/adeq.v index 9c44d5a..60d1f46 100644 --- a/theories/examples/delim_lang/adeq.v +++ b/theories/examples/delim_lang/adeq.v @@ -789,7 +789,6 @@ Section logrel. intros; apply _. Qed. - (* bla-bla done *) Lemma compat_natop_r {S : Set} (Γ : S → ty) α τ op t (E : interp_scope S -n> IT -n> IT) `{∀ γ, IT_hom (E γ)} @@ -822,10 +821,46 @@ Section logrel. iIntros (m') "Hm Hst". simpl. + iDestruct "Hw" as "(%n & #HEQ1)". + iDestruct "Hv" as "(%n' & #HEQ2)". iSpecialize ("H" $! γ with "Hγ"). - Admitted. + iSpecialize ("H" $! (RetV (do_natop op n n')) with "[]"). + { + iExists _. + iPureIntro. + reflexivity. + } + iSpecialize ("H" $! m' with "Hm Hst"). + rewrite IT_of_V_Ret. + + iAssert ((NATOP (do_natop op) (IT_of_V w) (IT_of_V v)) + ≡ (Ret (do_natop op n n')))%I as "#HEQ". + { + iRewrite "HEQ2". + rewrite IT_of_V_Ret. + iAssert ((IT_of_V w) ≡ IT_of_V (RetV n))%I as "#HEQ1'". + { + iApply f_equivI. + iApply "HEQ1". + } + rewrite IT_of_V_Ret. + iAssert (NATOP (do_natop op) (IT_of_V w) (Ret n') + ≡ NATOP (do_natop op) (Ret n) (Ret n'))%I as "#HEQ2''". + { + unshelve iApply (f_equivI (λne x, NATOP (do_natop op) x (Ret n'))). + { solve_proper. } + { solve_proper. } + iApply "HEQ1'". + } + iRewrite "HEQ2''". + rewrite NATOP_Ret. + done. + } + iRewrite "HEQ". + simpl. + iApply "H". + Qed. - (* bla-bla done *) Lemma compat_natop_l {S : Set} (Γ : S → ty) α τ op (t : interp_scope S -n> IT) (E : interp_scope S -n> IT -n> IT) `{∀ γ, IT_hom (E γ)} @@ -861,7 +896,44 @@ Section logrel. simpl. iSpecialize ("H" $! γ with "Hγ"). - Admitted. + + iDestruct "Hw" as "(%n & #HEQ1)". + iDestruct "Hv" as "(%n' & #HEQ2)". + iSpecialize ("H" $! (RetV (do_natop op n' n)) with "[]"). + { + iExists _. + iPureIntro. + reflexivity. + } + iSpecialize ("H" $! m' with "Hm Hst"). + rewrite IT_of_V_Ret. + + iAssert ((NATOP (do_natop op) (IT_of_V v) (IT_of_V w)) + ≡ (Ret (do_natop op n' n)))%I as "#HEQ". + { + iRewrite "HEQ1". + rewrite IT_of_V_Ret. + iAssert ((IT_of_V v) ≡ IT_of_V (RetV n'))%I as "#HEQ2'". + { + iApply f_equivI. + iApply "HEQ2". + } + rewrite IT_of_V_Ret. + iAssert (NATOP (do_natop op) (IT_of_V v) (Ret n) + ≡ NATOP (do_natop op) (Ret n') (Ret n))%I as "#HEQ2''". + { + unshelve iApply (f_equivI (λne x, NATOP (do_natop op) x (Ret n))). + { solve_proper. } + { solve_proper. } + iApply "HEQ2'". + } + iRewrite "HEQ2''". + rewrite NATOP_Ret. + done. + } + iRewrite "HEQ". + iApply "H". + Qed. (* Lemma compat_app_l {S : Set} (Γ : S → ty) τ α c d e *) (* (* (t : interp_scope S -n> ITVO) *) t *) From b5292773b6da0b4f60e13a15c4e287da93d1655c Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Wed, 5 Jun 2024 02:36:19 +0200 Subject: [PATCH 04/14] l->r cbv, compat for app --- theories/examples/delim_lang/adeq.v | 523 +++++++++++++++++++------- theories/examples/delim_lang/interp.v | 301 +++++++++++---- theories/examples/delim_lang/lang.v | 46 +-- 3 files changed, 642 insertions(+), 228 deletions(-) diff --git a/theories/examples/delim_lang/adeq.v b/theories/examples/delim_lang/adeq.v index 60d1f46..aa415b5 100644 --- a/theories/examples/delim_lang/adeq.v +++ b/theories/examples/delim_lang/adeq.v @@ -5,7 +5,7 @@ From iris.algebra Require Import list. From iris.proofmode Require Import classes tactics. From iris.base_logic Require Import algebra. -(* TODO: typing rules, if, compat for contexts, binary relation *) +(* TODO: typing rules, compat for contexts, binary relation *) Require Import Binding.Lib Binding.Set Binding.Env. @@ -18,68 +18,75 @@ Inductive ty := Declare Scope types. -(* Notation "τ '∕' α '→' σ '∕' β" := (Tarr τ α σ β) (at level 60) : types. *) -(* Notation "'Cont' τ σ" := (Tcont τ σ) (at level 60) : types. *) - -(* Reserved Notation "Γ ';' α '⊢ₑ' e ':' τ ';' β" *) -(* (at level 90, e at next level, τ at level 20, no associativity). *) - -(* Reserved Notation "Γ ';' α '⊢ᵥ' e ':' τ ';' β" *) -(* (at level 90, e at next level, τ at level 20, no associativity). *) - -(* Reserved Notation "Γ ';' α '⊢ᵪ' e ':' τ ';' β" *) -(* (at level 90, e at next level, τ at level 20, no associativity). *) - -(* TODO: pure stuff has ∀ σ deeper inside *) -(* Inductive typed_expr {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := *) -(* | typed_Val v α τ β : *) -(* (Γ; α ⊢ᵥ v : τ; β) → *) -(* (Γ; α ⊢ₑ v : τ; β) *) -(* | typed_Var x τ α : *) -(* (Γ x = τ) → *) -(* (Γ; α ⊢ₑ (Var x) : τ; α) *) -(* | typed_App e₁ e₂ γ α β δ σ τ : *) -(* (Γ; γ ⊢ₑ e₁ : (Tarr σ α τ β); δ) → *) -(* (Γ; β ⊢ₑ e₂ : σ; γ) → *) -(* (Γ; α ⊢ₑ (App e₁ e₂) : τ; δ) *) -(* | typed_AppCont e₁ e₂ α β δ σ τ : *) -(* (Γ; δ ⊢ₑ e₁ : (Tcont τ α); β) → *) -(* (Γ; σ ⊢ₑ e₂ : τ; δ) → *) -(* (Γ; σ ⊢ₑ (AppCont e₁ e₂) : α; β) *) -(* | typed_NatOp o e₁ e₂ α β : *) -(* (Γ; α ⊢ₑ e₁ : Tnat; β) → *) -(* (Γ; α ⊢ₑ e₂ : Tnat; β) → *) -(* (Γ; α ⊢ₑ NatOp o e₁ e₂ : Tnat; β) *) -(* | typed_If e e₁ e₂ α β σ τ : *) -(* (Γ; σ ⊢ₑ e : Tnat; β) → *) -(* (Γ; α ⊢ₑ e₁ : τ; σ) → *) -(* (Γ; α ⊢ₑ e₂ : τ; σ) → *) -(* (Γ; α ⊢ₑ (if e then e₁ else e₂) : τ; β) *) -(* | typed_Shift (e : @expr (inc S)) τ α σ β : *) -(* (Γ ▹ (Tcont τ α); σ ⊢ₑ e : σ; β) → *) -(* (Γ; α ⊢ₑ Shift e : τ; β) *) -(* | typed_Reset e α σ τ : *) -(* (Γ; σ ⊢ₑ e : σ; τ) → *) -(* (Γ; α ⊢ₑ reset e : τ; α) *) -(* where "Γ ';' α '⊢ₑ' e ':' τ ';' β" := (typed_expr Γ α e τ β) : types *) -(* with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := *) -(* | typed_LitV n α : *) -(* (Γ; α ⊢ᵥ #n : Tnat; α) *) -(* | typed_RecV (e : expr (inc (inc S))) (δ σ τ α β : ty) : *) -(* ((Γ ▹ (Tarr σ α τ β) ▹ σ); α ⊢ₑ e : τ; β) -> *) -(* (Γ; δ ⊢ᵥ (RecV e) : (Tarr σ α τ β); δ) *) -(* | typed_ContV (k : cont S) τ α β : *) -(* (Γ; α ⊢ᵪ k : τ; β) → *) -(* (Γ; α ⊢ᵥ (ContV k) : τ; β) *) -(* where "Γ ';' α '⊢ᵥ' e ':' τ ';' β" := (typed_val Γ α e τ β) : types *) -(* with typed_cont {S : Set} (Γ : S -> ty) : ty -> cont S -> ty -> ty -> Prop := *) -(* | typed_END τ δ : *) -(* (Γ; δ ⊢ᵪ END : (Tcont τ τ); δ) *) -(* | typed_IfK e₁ e₂ α β δ A k τ : *) -(* (Γ; α ⊢ₑ e₁ : τ; β) -> *) -(* (Γ; α ⊢ₑ e₂ : τ; β) -> *) -(* (Γ; β ⊢ᵪ k : Tcont τ A; δ) -> *) -(* (Γ; α ⊢ᵪ IfK e₁ e₂ k : Tcont Tnat A; δ) *) +Notation "τ '∕' α '→' σ '∕' β" := (Tarr τ α σ β) (at level 60) : types. +Notation "'Cont' τ σ" := (Tcont τ σ) (at level 60) : types. + +Reserved Notation "Γ ';' α '⊢ₑ' e ':' τ ';' β" + (at level 90, e at next level, τ at level 20, no associativity). + +Reserved Notation "Γ ';' α '⊢ᵥ' e ':' τ ';' β" + (at level 90, e at next level, τ at level 20, no associativity). + +Reserved Notation "Γ '⊢ᵪ' e ':' τ '⤞' σ" + (at level 90, e at next level, τ at level 20, no associativity). + +Inductive typed_expr {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := +| typed_Val v α τ β : + (Γ; α ⊢ᵥ v : τ; β) → + (Γ; α ⊢ₑ v : τ; β) +| typed_Var x τ α : + (Γ x = τ) → + (Γ; α ⊢ₑ (Var x) : τ; α) +| typed_App e₁ e₂ γ α β δ σ τ : + (Γ; γ ⊢ₑ e₁ : (Tarr σ α τ β); δ) → + (Γ; β ⊢ₑ e₂ : σ; γ) → + (Γ; α ⊢ₑ (App e₁ e₂) : τ; δ) +| typed_AppCont e₁ e₂ α β δ σ τ : + (Γ; σ ⊢ₑ e₁ : (Tcont τ α); δ) → + (Γ; δ ⊢ₑ e₂ : τ; β) → + (Γ; σ ⊢ₑ (AppCont e₁ e₂) : α; β) +| typed_NatOp o e₁ e₂ α β γ : + (Γ; α ⊢ₑ e₁ : Tnat; β) → + (Γ; β ⊢ₑ e₂ : Tnat; γ) → + (Γ; α ⊢ₑ NatOp o e₁ e₂ : Tnat; γ) +| typed_If e e₁ e₂ α β σ τ : + (Γ; β ⊢ₑ e : Tnat; α) → + (Γ; σ ⊢ₑ e₁ : τ; β) → + (Γ; σ ⊢ₑ e₂ : τ; β) → + (Γ; σ ⊢ₑ (if e then e₁ else e₂) : τ; α) +| typed_Shift (e : @expr (inc S)) τ α σ β : + (Γ ▹ (Tcont τ α); σ ⊢ₑ e : σ; β) → + (Γ; α ⊢ₑ Shift e : τ; β) +| typed_Reset e α σ τ : + (Γ; σ ⊢ₑ e : σ; τ) → + (Γ; α ⊢ₑ reset e : τ; α) +where "Γ ';' α '⊢ₑ' e ':' τ ';' β" := (typed_expr Γ α e τ β) : types +with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := +| typed_LitV n α : + (Γ; α ⊢ᵥ #n : Tnat; α) +| typed_RecV (e : expr (inc (inc S))) (δ σ τ α β : ty) : + ((Γ ▹ (Tarr σ α τ β) ▹ σ); α ⊢ₑ e : τ; β) -> + (Γ; δ ⊢ᵥ (RecV e) : (Tarr σ α τ β); δ) +| typed_ContV (k : cont S) τ σ α : + (Γ ⊢ᵪ k : τ ⤞ σ) → + (Γ; α ⊢ᵥ (ContV k) : (Tcont τ σ); α) +where "Γ ';' α '⊢ᵥ' e ':' τ ';' β" := (typed_val Γ α e τ β) : types +with typed_cont {S : Set} (Γ : S -> ty) : cont S -> ty -> ty -> Prop := +| typed_END τ : + (Γ ⊢ᵪ END : τ ⤞ τ) +| typed_IfK k e₁ e₂ α β τ : + (Γ; α ⊢ₑ e₁ : τ; β) -> + (Γ; α ⊢ₑ e₂ : τ; β) -> + (Γ ⊢ᵪ k : τ ⤞ α) -> + (Γ ⊢ᵪ IfK e₁ e₂ k : Tnat ⤞ β) +| typed_NatOpLK op v k α τ : + (Γ; τ ⊢ᵥ v : Tnat; α) -> + (Γ ⊢ᵪ k : Tnat ⤞ τ) -> + (Γ ⊢ᵪ NatOpLK op v k : Tnat ⤞ α) +| typed_NatOpRK op e k α τ : + (Γ; τ ⊢ₑ e : Tnat; α) -> + (Γ ⊢ᵪ k : Tnat ⤞ τ) -> + (Γ ⊢ᵪ NatOpRK op e k : Tnat ⤞ α) (* (* | typed_AppLK v k α β σ δ τ' τ : *) *) (* (* (Γ; α ⊢ᵥ v : τ'; β) -> *) *) (* (* (Γ; β ⊢ᵪ k : Tcont σ τ; δ) -> *) *) @@ -90,16 +97,41 @@ Declare Scope types. (* (* (Γ; τ ⊢ᵪ AppContLK v k : τ; τ) *) *) (* (* | typed_AppContRK e k τ : *) *) (* (* (Γ; τ ⊢ᵪ AppContRK e k : τ; τ) *) *) -(* | typed_NatOpLK op v k α β δ τ : *) -(* (Γ; α ⊢ᵥ v : Tnat; β) -> *) -(* (Γ; β ⊢ᵪ k : Tcont Tnat τ; δ) -> *) -(* (Γ; α ⊢ᵪ NatOpLK op v k : Tcont Tnat τ; δ) *) -(* | typed_NatOpRK op e k α β δ τ : *) -(* (Γ; α ⊢ₑ e : Tnat; β) -> *) -(* (Γ; β ⊢ᵪ k : Tcont Tnat τ; δ) -> *) -(* (Γ; α ⊢ᵪ NatOpRK op e k : Tcont Tnat τ; δ) *) -(* where "Γ ';' α '⊢ᵪ' e ':' τ ';' β" := (typed_cont Γ α e τ β) : types *) -(* . *) +where "Γ '⊢ᵪ' e ':' τ '⤞' σ" := (typed_cont Γ e τ σ) : types +. + +Module Example. + Open Scope types. + + Lemma typ_example1 α : + empty_env; α ⊢ₑ ((#1) + + (reset + ((#3) + + (shift/cc ((($0) @k #5) + (($0) @k #6)))))) + : Tnat; α. + Proof. + eapply typed_NatOp. + - apply typed_Val. + apply typed_LitV. + - eapply typed_Reset. + eapply typed_NatOp. + + apply typed_Val. + apply typed_LitV. + + eapply typed_Shift. + eapply typed_NatOp. + * eapply typed_AppCont. + -- apply typed_Var. + reflexivity. + -- apply typed_Val. + apply typed_LitV. + * eapply typed_AppCont. + -- apply typed_Var. + reflexivity. + -- apply typed_Val. + apply typed_LitV. + Qed. + +End Example. Open Scope stdpp_scope. @@ -506,23 +538,44 @@ Section logrel. apply _. Qed. - Program Definition AppRSCtx_HOM {S : Set} + Program Definition AppLSCtx_HOM {S : Set} (α : @interp_scope F R _ S -n> IT) (env : @interp_scope F R _ S) - : HOM := exist _ (interp_apprk rs α (λne env, idfun) env) _. + : HOM := exist _ (interp_applk rs α (λne env, idfun) env) _. Next Obligation. intros; simpl. apply _. Qed. - Program Definition AppLSCtx_HOM {S : Set} + Transparent LET. + Program Definition AppRSCtx_HOM {S : Set} (β : IT) (env : @interp_scope F R _ S) (Hv : AsVal β) - : HOM := exist _ (interp_applk rs (constO β) (λne env, idfun) env) _. + : HOM := exist _ (interp_apprk rs (constO β) (λne env, idfun) env) _. Next Obligation. intros; simpl. - apply _. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - solve_proper_please. + - rewrite get_val_ITV. + simpl. + rewrite get_val_ITV. + simpl. + rewrite get_val_tick. + reflexivity. + - rewrite get_val_ITV. + simpl. + rewrite get_val_vis. + do 3 f_equiv. + intro; simpl. + rewrite get_val_ITV. + simpl. + reflexivity. + - rewrite get_val_ITV. + simpl. + rewrite get_val_err. + reflexivity. Qed. + Opaque LET. Lemma compat_nat_op {S : Set} (Γ : S → ty) D E F e1 e2 op : @@ -610,11 +663,15 @@ Section logrel. iApply "Hκ". Qed. + (* | typed_App e₁ e₂ γ α β δ σ τ : *) + (* (Γ; γ ⊢ₑ e₁ : (Tarr σ α τ β); δ) → *) + (* (Γ; β ⊢ₑ e₂ : σ; γ) → *) + (* (Γ; α ⊢ₑ (App e₁ e₂) : τ; δ) *) Lemma compat_app {S : Set} (Γ : S → ty) - A B C D E F e1 e2 : - ⊢ valid Γ e1 (Tarr A C B E) E F - -∗ valid Γ e2 A F D - -∗ valid Γ (interp_app rs e1 e2) B C D. + ξ α β δ η τ e1 e2 : + ⊢ valid Γ e1 (Tarr η α τ β) ξ δ + -∗ valid Γ e2 η β ξ + -∗ valid Γ (interp_app rs e1 e2) τ α δ. Proof. iIntros "#H #G". iModIntro. @@ -623,18 +680,23 @@ Section logrel. iIntros (σ) "Hσ Hst". rewrite /interp_app //=. - pose (κ' := (AppRSCtx_HOM e1 γ)). - assert ((e1 γ ⊙ (e2 γ)) = ((`κ') (e2 γ))) as ->. - { simpl; unfold AppRSCtx. reflexivity. } - assert ((`κ) ((`κ') (e2 γ)) = ((`κ) ◎ (`κ')) (e2 γ)) as ->. + pose (κ' := (AppLSCtx_HOM e2 γ)). + match goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => + set (F := b) + end. + assert (LET (e1 γ) F = ((`κ') (e1 γ))) as ->. + { simpl; unfold AppLSCtx. reflexivity. } + clear F. + assert ((`κ) ((`κ') (e1 γ)) = ((`κ) ◎ (`κ')) (e1 γ)) as ->. { reflexivity. } pose (sss := (HOM_compose κ κ')). assert ((`κ ◎ `κ') = (`sss)) as ->. { reflexivity. } - iSpecialize ("G" $! γ with "Hγ"). - iSpecialize ("G" $! sss). - iApply ("G" with "[H] Hσ Hst"). + iSpecialize ("H" $! γ with "Hγ"). + iSpecialize ("H" $! sss). + iApply ("H" with "[H] Hσ Hst"). iIntros (w). iModIntro. @@ -643,18 +705,22 @@ Section logrel. subst sss. subst κ'. simpl. + rewrite LET_Val. + cbn [ofe_mor_car]. - pose (κ'' := (AppLSCtx_HOM (IT_of_V w) γ _)). - assert (((`κ) (e1 γ ⊙ (IT_of_V w))) = (((`κ) ◎ (`κ'')) (e1 γ))) as ->. + match goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => + set (F := b) + end. + pose (κ'' := exist _ (LETCTX F) (LETCTX_Hom F) : HOM). + assert (((`κ) (LET (e2 γ) F)) = (((`κ) ◎ (`κ'')) (e2 γ))) as ->. { reflexivity. } pose (sss := (HOM_compose κ κ'')). assert ((`κ ◎ `κ'') = (`sss)) as ->. { reflexivity. } - - iSpecialize ("H" $! γ with "Hγ"). - iSpecialize ("H" $! sss). - iApply ("H" with "[] Hm Hst"). - + iSpecialize ("G" $! γ with "Hγ"). + iSpecialize ("G" $! sss). + iApply ("G" with "[H] Hm Hst"). iIntros (v). iModIntro. iIntros "#Hv". @@ -662,19 +728,22 @@ Section logrel. subst sss. subst κ''. simpl. - - iDestruct "Hv" as "(%n' & #HEQ & Hv)". - iSpecialize ("Hv" $! w with "Hw"). - iSpecialize ("Hv" $! κ with "Hκ"). - iSpecialize ("Hv" $! m'' with "Hm Hst"). - iAssert ((IT_of_V v ⊙ (IT_of_V w)) - ≡ (Fun n' ⊙ (IT_of_V w)))%I as "#HEQ'". + rewrite LET_Val. + subst F. + cbn [ofe_mor_car]. + + iDestruct "Hw" as "(%n' & #HEQ & Hw)". + iSpecialize ("Hw" $! v with "Hv"). + iSpecialize ("Hw" $! κ with "Hκ"). + iSpecialize ("Hw" $! m'' with "Hm Hst"). + iAssert ((IT_of_V w ⊙ (IT_of_V v)) + ≡ (Fun n' ⊙ (IT_of_V v)))%I as "#HEQ'". { - iApply (f_equivI (λne x, (x ⊙ (IT_of_V w)))). + iApply (f_equivI (λne x, (x ⊙ (IT_of_V v)))). iApply "HEQ". } iRewrite "HEQ'". - iApply "Hv". + iApply "Hw". Qed. Lemma compat_appcont {S : Set} (Γ : S -> ty) e1 e2 τ α δ β σ : @@ -775,7 +844,58 @@ Section logrel. iIntros "_ Hst". iApply ("Hκ" with "Hp Hm Hst"). } + Qed. + + Lemma compat_if {S : Set} (Γ : S -> ty) e e₁ e₂ τ σ α β : + ⊢ valid Γ e Tnat β α + -∗ valid Γ e₁ τ σ β + -∗ valid Γ e₂ τ σ β + -∗ valid Γ (interp_if rs e e₁ e₂) τ σ α. + Proof. + iIntros "#H #G #J". + iModIntro. + iIntros (γ) "#Henv". + iIntros (κ) "#Hκ". + iIntros (σ') "Hm Hst". + unfold interp_if. + cbn [ofe_mor_car]. + pose (κ' := (IFSCtx_HOM (e₁ γ) (e₂ γ))). + assert ((IF (e γ) (e₁ γ) (e₂ γ)) = ((`κ') (e γ))) as -> by reflexivity. + assert ((`κ) ((`κ') (e γ)) = ((`κ) ◎ (`κ')) (e γ)) + as -> by reflexivity. + pose (sss := (HOM_compose κ κ')). + rewrite (HOM_compose_ccompose κ κ' sss)//. + + iSpecialize ("H" $! γ with "Henv"). + iSpecialize ("H" $! sss). + iApply ("H" with "[] Hm Hst"). + iIntros (v). + iModIntro. + iIntros "#Hv". + iIntros (σ'') "Hm Hst". + iDestruct "Hv" as "(%n & #Hv)". + iRewrite "Hv". + rewrite IT_of_V_Ret. + subst sss. + subst κ'. + simpl. + unfold IFSCtx. + destruct (decide (0 < n)) as [H|H]. + - rewrite IF_True//. + iApply ("G" $! γ with "Henv [Hκ] Hm Hst"). + iIntros (w). + iModIntro. + iIntros "#Hw". + iIntros (σ''') "Hm Hst". + iApply ("Hκ" with "Hw Hm Hst"). + - rewrite IF_False//; last lia. + iApply ("J" $! γ with "Henv [Hκ] Hm Hst"). + iIntros (w). + iModIntro. + iIntros "#Hw". + iIntros (σ''') "Hm Hst". + iApply ("Hκ" with "Hw Hm Hst"). Qed. Program Definition valid_ectx {S : Set} @@ -789,6 +909,15 @@ Section logrel. intros; apply _. Qed. + Lemma compat_end {S : Set} (Γ : S → ty) τ + : ⊢ valid_ectx Γ (interp_cont rs END) τ τ. + Proof. + iIntros (γ). + iModIntro. + iIntros "#H". + iApply compat_HOM_id. + Qed. + Lemma compat_natop_r {S : Set} (Γ : S → ty) α τ op t (E : interp_scope S -n> IT -n> IT) `{∀ γ, IT_hom (E γ)} @@ -935,19 +1064,54 @@ Section logrel. iApply "H". Qed. - (* Lemma compat_app_l {S : Set} (Γ : S → ty) τ α c d e *) - (* (* (t : interp_scope S -n> ITVO) *) t *) + Lemma compat_ifk {S : Set} (Γ : S -> ty) + (E : interp_scope S -n> IT -n> IT) + e₁ e₂ + `{∀ γ, IT_hom (E γ)} + `{∀ γ, IT_hom (interp_ifk rs e₁ e₂ E γ)} + (τ α β : ty) : + ⊢ valid_ectx Γ E τ α + -∗ valid Γ e₁ τ α β + -∗ valid Γ e₂ τ α β + -∗ valid_ectx Γ (interp_ifk rs e₁ e₂ E) Tnat β. + Proof. + iIntros "#H #G #J". + iModIntro. + iIntros (γ) "#Henv". + iSpecialize ("H" $! γ with "Henv"). + + iIntros (v). + iModIntro. + iIntros "#Hv". + iIntros (σ'') "Hm Hst". + iDestruct "Hv" as "(%n & #Hv)". + iRewrite "Hv". + rewrite IT_of_V_Ret. + simpl. + destruct (decide (0 < n)) as [?|?]. + - rewrite IF_True//. + iSpecialize ("G" $! γ with "Henv"). + unshelve iSpecialize ("G" $! (exist _ (E γ) _)). + { apply _. } + iApply ("G" with "H Hm Hst"). + - rewrite IF_False//; last lia. + iSpecialize ("J" $! γ with "Henv"). + unshelve iSpecialize ("J" $! (exist _ (E γ) _)). + { apply _. } + iApply ("J" with "H Hm Hst"). + Qed. + + (* Lemma compat_appk_r {S : Set} (Γ : S → ty) τ α c d e t *) (* (E : interp_scope S -n> IT -n> IT) *) (* `{∀ γ, IT_hom (E γ)} *) - (* (* `{∀ γ, AsVal (t γ)} *) *) - (* `{∀ γ, IT_hom (interp_app_contlk _ t E γ)} : *) + (* `{∀ γ, IT_hom (interp_app_contrk _ t E γ)} : *) (* ⊢ valid_ectx Γ E τ α *) (* -∗ valid Γ t c d e *) - (* -∗ valid_ectx Γ (interp_app_contlk _ t E) τ α. *) - (* Proof. *) + (* -∗ valid_ectx Γ (interp_app_contrk _ t E) τ α. *) + (* Proof. *) + (* Opaque interp_app_cont. *) (* iIntros "#H #G". *) (* iIntros (γ). *) - (* assert (AsVal (t γ)); first admit. *) (* iModIntro. *) (* iIntros "#Hγ". *) (* iIntros (v). *) @@ -955,23 +1119,46 @@ Section logrel. (* iIntros "#Hv". *) (* iIntros (m) "Hm Hst". *) (* simpl. *) - (* rewrite get_val_ITV. *) - (* simpl. *) - (* iSpecialize ("H" $! γ with "Hγ"). *) - (* iSpecialize ("H" $! v with "Hv"). *) - (* iSpecialize ("H" $! m with "Hm Hst"). *) - (* simpl. *) - (* Lemma compat_app_r {S : Set} (Γ : S → ty) τ α c d e t *) + (* pose (κ'' := (AppContLSCtx_HOM (IT_of_V v) γ _)). *) + (* set (F := (E γ) _). *) + (* assert (F ≡ (((E γ) ◎ (`κ'')) (t γ))) as ->. *) + (* { *) + (* subst F. simpl. Transparent interp_app_cont. simpl. *) + (* f_equiv. *) + (* rewrite ->2 get_val_ITV. *) + (* simpl. *) + (* reflexivity. *) + (* } *) + (* pose (sss := (HOM_compose (exist _ (E γ) (H _)) κ'')). *) + (* assert (((E γ) ◎ `κ'') = (`sss)) as ->. *) + (* { reflexivity. } *) + + (* iSpecialize ("G" $! γ with "Hγ"). *) + (* iSpecialize ("G" $! sss). *) + (* iApply ("G" with "[] [] Hst"); *) + (* last admit. *) + (* iIntros (w). *) + (* iModIntro. *) + (* iIntros "#Hw". *) + (* iIntros (m') "Hm Hst". *) + (* Admitted. *) + + (* Lemma compat_appk_l {S : Set} (Γ : S → ty) τ α c d e *) + (* (t : interp_scope S -n> IT) *) (* (E : interp_scope S -n> IT -n> IT) *) (* `{∀ γ, IT_hom (E γ)} *) - (* `{∀ γ, IT_hom (interp_app_contrk _ t E γ)} : *) + (* `{∀ γ, AsVal (t γ)} *) + (* `{∀ γ, IT_hom (interp_app_contlk _ t E γ)} : *) (* ⊢ valid_ectx Γ E τ α *) (* -∗ valid Γ t c d e *) - (* -∗ valid_ectx Γ (interp_app_contrk _ t E) τ α. *) + (* -∗ valid_ectx Γ (interp_app_contlk _ t E) τ α. *) (* Proof. *) + (* Opaque interp_app_cont. *) (* iIntros "#H #G". *) (* iIntros (γ). *) + (* assert (AsVal (t γ)). *) + (* { apply _. } *) (* iModIntro. *) (* iIntros "#Hγ". *) (* iIntros (v). *) @@ -979,13 +1166,93 @@ Section logrel. (* iIntros "#Hv". *) (* iIntros (m) "Hm Hst". *) (* simpl. *) - (* rewrite get_val_ITV. *) - (* simpl. *) - (* iSpecialize ("H" $! γ with "Hγ"). *) - (* iSpecialize ("H" $! v with "Hv"). *) - (* iSpecialize ("H" $! m with "Hm Hst"). *) - (* simpl. *) - (* Qed. *) + + (* Admitted. *) + + Lemma compat_cont {S : Set} (Γ : S -> ty) τ σ + (k : interp_scope S -n> IT -n> IT) + `{∀ γ : interp_scope S, IT_hom (k γ)} + : ⊢ valid_ectx Γ k τ σ + -∗ ∀ α, valid Γ (interp_cont_val rs k) (Tcont τ σ) α α. + Proof. + iIntros "#H". + iIntros (α γ). + iModIntro. + iIntros "#Hγ". + iIntros (κ) "Hκ". + iIntros (m) "Hm Hst". + iSpecialize ("H" $! γ with "Hγ"). + unfold interp_cont_val. + simpl. + match goal with + | |- context G [ofe_mor_car _ _ Fun ?a] => + set (F := a) + end. + iSpecialize ("Hκ" $! (FunV F)). + iApply ("Hκ" with "[] Hm Hst"). + iExists (exist _ (k γ) (H _)). + iSplit. + - subst F. + Transparent IT_of_V. + simpl. + iPureIntro. + do 2 f_equiv. + intros ?; simpl. + rewrite later_map_Next. + rewrite Tick_eq. + reflexivity. + - iModIntro. + iApply "H". + Qed. + + Open Scope types. + + Lemma fundamental_expr {S : Set} (Γ : S -> ty) τ α β e : + Γ; α ⊢ₑ e : τ; β → ⊢ valid Γ (interp_expr rs e) τ α β + with fundamental_val {S : Set} (Γ : S -> ty) τ α β v : + Γ; α ⊢ᵥ v : τ; β → ⊢ valid Γ (interp_val rs v) τ α β + with fundamental_cont {S : Set} (Γ : S -> ty) τ σ κ : + Γ ⊢ᵪ κ : τ ⤞ σ → ⊢ valid_ectx Γ (interp_cont rs κ) τ σ. + Proof. + - intros H. + destruct H. + + by apply fundamental_val. + + subst; iApply compat_var. + + iApply compat_app; + by iApply fundamental_expr. + + iApply compat_appcont; + by iApply fundamental_expr. + + iApply compat_nat_op; + by iApply fundamental_expr. + + iApply compat_if; + by iApply fundamental_expr. + + iApply compat_shift; + by iApply fundamental_expr. + + iApply (compat_reset with "[]"); + by iApply fundamental_expr. + - intros H. + destruct H. + + iApply compat_nat. + + iApply (compat_recV with "[]"); + by iApply fundamental_expr. + + iPoseProof (fundamental_cont _ _ _ _ _ H) as "H". + iDestruct (compat_cont with "H") as "G". + iSpecialize ("G" $! α). + iApply "G". + - intros H. + destruct H. + + iApply compat_end. + + iApply compat_ifk; + [ by iApply fundamental_cont + | by iApply fundamental_expr + | by iApply fundamental_expr]. + + iApply compat_natop_l; + [ by iApply fundamental_cont + | by iApply fundamental_val]. + + iApply compat_natop_r; + [ by iApply fundamental_cont + | by iApply fundamental_expr]. + Qed. End logrel. diff --git a/theories/examples/delim_lang/interp.v b/theories/examples/delim_lang/interp.v index 0e8fda4..18bbc53 100644 --- a/theories/examples/delim_lang/interp.v +++ b/theories/examples/delim_lang/interp.v @@ -111,14 +111,51 @@ Section interp. simpl. unfold ir_unf. intro. simpl. reflexivity. Qed. - (** ** APP *) + (* Program Definition interp_app {A} (t1 t2 : A -n> IT) : A -n> IT := *) + (* λne env, get_fun *) + (* (λne (f : laterO (IT -n> IT)), *) + (* get_val (λne x, Tau (laterO_ap f (Next x))) (t2 env)) (t1 env). *) + (* Next Obligation. *) + (* solve_proper. *) + (* Qed. *) + (* Next Obligation. *) + (* intros ????????. *) + (* apply get_val_ne. *) + (* intros ?; simpl. *) + (* f_equiv. *) + (* apply Next_contractive. *) + (* destruct n as [| ?]. *) + (* - apply dist_later_0. *) + (* - apply dist_later_S in H. *) + (* apply dist_later_S. *) + (* by f_equiv. *) + (* Qed. *) + (* Next Obligation. *) + (* solve_proper_please. *) + (* Qed. *) Program Definition interp_app {A} (t1 t2 : A -n> IT) : A -n> IT := - λne env, APP' (t1 env) (t2 env). - Solve All Obligations with first [ solve_proper | solve_proper_please ]. + λne env, + LET (t1 env) $ λne f, + LET (t2 env) $ λne x, + APP' f x. + Solve All Obligations with solve_proper_please. + Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). - Proof. solve_proper. Qed. - Typeclasses Opaque interp_app. + Proof. + solve_proper_prepare. + f_equiv. + - by f_equiv. + - intro; simpl. + by do 2 f_equiv. + Qed. + (* Proof. *) + (* solve_proper_prepare. *) + (* do 2 f_equiv; last done. *) + (* intro; simpl. *) + (* by f_equiv. *) + (* Qed. *) + Typeclasses Opaque interp_app. (** ** APP_CONT *) @@ -129,22 +166,6 @@ Section interp. (k env)) (e env). Solve All Obligations with first [ solve_proper | solve_proper_please ]. - - (* Program Definition interp_app_cont {A} (k e : A -n> IT) : A -n> IT := *) - (* λne env, get_val (λne x, get_fun *) - (* (λne (f : laterO (IT -n> IT)), *) - (* (Tau (laterO_ap f (Next x)))) *) - (* (k env)) *) - (* (e env). *) - (* Next Obligation. *) - (* intros. *) - (* intros ???. *) - (* f_equiv. *) - (* now apply later_ap_ne. *) - (* Qed. *) - (* Next Obligation. solve_proper_please. Qed. *) - (* Next Obligation. solve_proper_please. Qed. *) - Global Instance interp_app_cont_ne A : NonExpansive2 (@interp_app_cont A). Proof. intros n??????. rewrite /interp_app_cont. intro. simpl. @@ -178,12 +199,58 @@ Section interp. Program Definition interp_apprk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : A -n> IT -n> IT := λne env t, (K env) $ interp_app q (λne env, t) env. - Solve All Obligations with solve_proper. + Next Obligation. + solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + do 2 f_equiv. + intro; simpl. + by do 2 f_equiv. + Qed. + (* Next Obligation. *) + (* solve_proper_prepare. *) + (* do 3 f_equiv. *) + (* intro; simpl. *) + (* by f_equiv. *) + (* Qed. *) + Next Obligation. + solve_proper_prepare. + f_equiv; first solve_proper. + f_equiv; first solve_proper. + intro; simpl. + solve_proper. + Qed. + (* Next Obligation. *) + (* solve_proper_prepare. *) + (* do 2 f_equiv; [done | | by f_equiv]. *) + (* f_equiv. *) + (* by intro; simpl. *) + (* Qed. *) Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : A -n> IT -n> IT := λne env t, (K env) $ interp_app (λne env, t) q env. - Solve All Obligations with solve_proper. + Next Obligation. + solve_proper. + Qed. + Next Obligation. + solve_proper. + Qed. + (* Next Obligation. *) + (* intros ????????. *) + (* do 3 f_equiv. *) + (* intro; simpl. *) + (* done. *) + (* Qed. *) + Next Obligation. + solve_proper_prepare. + f_equiv; first solve_proper. + f_equiv; first solve_proper. + Qed. + (* Next Obligation. *) + (* solve_proper_please. *) + (* Qed. *) Program Definition interp_app_contrk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : A -n> IT -n> IT := @@ -246,8 +313,8 @@ Section interp. match K with | END => λne env x, x | IfK e1 e2 K => interp_ifk (interp_expr e1) (interp_expr e2) (interp_cont K) - | AppLK v K => interp_applk (interp_val v) (interp_cont K) - | AppRK e K => interp_apprk (interp_expr e) (interp_cont K) + | AppLK e K => interp_applk (interp_expr e) (interp_cont K) + | AppRK v K => interp_apprk (interp_val v) (interp_cont K) | AppContLK v K => interp_app_contlk (interp_val v) (interp_cont K) | AppContRK e K => interp_app_contrk (interp_expr e) (interp_cont K) | NatOpLK op v K => interp_natoplk op (interp_val v) (interp_cont K) @@ -327,12 +394,20 @@ Section interp. interp_cont (fmap δ K) env ≡ interp_cont K (ren_scope δ env). Proof. - destruct e; simpl; try by repeat f_equiv. + + f_equiv; first by rewrite interp_expr_ren. + intro; simpl. + f_equiv; by rewrite interp_expr_ren. + (* f_equiv; last by rewrite interp_expr_ren. *) + (* f_equiv. intro. simpl. by f_equiv. *) + f_equiv; last by rewrite interp_expr_ren. f_equiv. intro. simpl. by f_equiv. - + repeat f_equiv. intro; simpl; repeat f_equiv. - rewrite interp_expr_ren. f_equiv. - intros [|a]; simpl; last done. - by repeat f_equiv. + + f_equiv; last eauto. f_equiv. intro. simpl. + rewrite !laterO_map_Next. + repeat f_equiv. + rewrite interp_expr_ren. + f_equiv. + intros [| ?]; simpl; first done. + reflexivity. - destruct e; simpl. + reflexivity. + clear -interp_expr_ren. @@ -354,17 +429,33 @@ Section interp. apply interp_cont_ren. - destruct K; try solve [simpl; repeat f_equiv; intro; simpl; repeat f_equiv; (apply interp_expr_ren || apply interp_val_ren || apply interp_cont_ren)]. - + intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. - intro. simpl. by repeat f_equiv. - + intro. simpl. f_equiv; eauto. do 2 f_equiv. - intro. simpl. by repeat f_equiv. + + intro. simpl. f_equiv; eauto. + f_equiv; first by rewrite interp_val_ren. + intro; simpl. + reflexivity. + (* intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. *) + (* intro. simpl. by repeat f_equiv. *) + + intro. simpl. f_equiv; eauto. + f_equiv. + intro; simpl. + f_equiv. + by rewrite interp_expr_ren. + (* intro. simpl. f_equiv; eauto. do 2 f_equiv. *) + (* intro. simpl. by repeat f_equiv. *) + + simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. + + simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. Qed. Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : cont S): interp_expr (fill K e) env ≡ (interp_cont K) env ((interp_expr e) env). Proof. elim : K e env; eauto. - intros. simpl. rewrite H. f_equiv. simpl. - do 2 f_equiv. intro. simpl. by repeat f_equiv. + - intros. simpl. rewrite H. f_equiv. simpl. + f_equiv. + intro; simpl. + reflexivity. + (* do 2 f_equiv. intro. simpl. by repeat f_equiv. *) + - intros. simpl. rewrite H. f_equiv. simpl. + do 2 f_equiv. intro. simpl. by repeat f_equiv. Qed. Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') @@ -394,11 +485,20 @@ Section interp. interp_cont (bind δ K) env ≡ interp_cont K (sub_scope δ env). Proof. - destruct e; simpl; try by repeat f_equiv. + + f_equiv; first by rewrite interp_expr_subst. + intro; simpl. + f_equiv; first by rewrite interp_expr_subst. + (* f_equiv; last eauto. f_equiv. intro. simpl. by repeat f_equiv. *) + f_equiv; last eauto. f_equiv. intro. simpl. by repeat f_equiv. - + repeat f_equiv. repeat (intro; simpl; repeat f_equiv). - rewrite interp_expr_subst. f_equiv. - intros [|a]; simpl; repeat f_equiv. rewrite interp_expr_ren. - f_equiv. intro. done. + + f_equiv; last eauto. f_equiv. intro. simpl. + rewrite !laterO_map_Next. + repeat f_equiv. + rewrite interp_expr_subst. + f_equiv. + intros [| ?]; simpl; first done. + rewrite interp_expr_ren. + f_equiv. + intros ?; simpl; done. - destruct e; simpl. + reflexivity. + clear -interp_expr_subst. @@ -424,12 +524,21 @@ Section interp. by rewrite interp_cont_subst. - destruct K; try solve [simpl; repeat f_equiv; intro; simpl; repeat f_equiv; (apply interp_expr_subst || apply interp_val_subst || apply interp_cont_subst)]. + + intro; simpl. + f_equiv; first by rewrite interp_cont_subst. + f_equiv; first by rewrite interp_val_subst. + intro; simpl; reflexivity. + (* simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. *) + + intro; simpl. + f_equiv; first by rewrite interp_cont_subst. + f_equiv. + intro; simpl. + f_equiv; first by rewrite interp_expr_subst. + (* simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. *) + simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. + simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. Qed. - - (** ** Interpretation of continuations is a homormophism *) #[local] Instance interp_cont_hom_emp {S} env : @@ -454,37 +563,65 @@ Section interp. by rewrite -hom_vis. - trans (interp_cont K env (Err e)); first (f_equiv; apply IF_Err). apply hom_err. - Qed. + Qed. + Transparent LET. #[local] Instance interp_cont_hom_appr {S} (K : cont S) - (e : expr S) env : + (v : val S) (env : interp_scope S) : IT_hom (interp_cont K env) -> - IT_hom (interp_cont (AppRK e K) env). + IT_hom (interp_cont (AppRK v K) env). Proof. - intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - by rewrite !hom_tick. - - rewrite !hom_vis. f_equiv. intro x. simpl. - by rewrite -laterO_map_compose. - - by rewrite !hom_err. + pose proof (interp_val_asval v (D := env)) as HHH. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite <-hom_tick. + f_equiv. + rewrite ->2 get_val_ITV. + simpl. + rewrite get_val_tick. + reflexivity. + - rewrite get_val_ITV. + simpl. + rewrite ->2 hom_vis. + f_equiv. + intro; simpl. + rewrite <-laterO_map_compose. + do 2 f_equiv. + intro; simpl. + rewrite get_val_ITV. + simpl. + reflexivity. + - rewrite <-hom_err. + rewrite get_val_ITV. + simpl. + f_equiv. + rewrite get_val_err. + reflexivity. Qed. + Opaque LET. + Transparent LET. #[local] Instance interp_cont_hom_appl {S} (K : cont S) - (v : val S) (env : interp_scope S) : + (e : expr S) env : IT_hom (interp_cont K env) -> - IT_hom (interp_cont (AppLK v K) env). + IT_hom (interp_cont (AppLK e K) env). Proof. intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - rewrite -hom_tick. f_equiv. apply APP'_Tick_l. apply interp_val_asval. - - trans (Vis op i (laterO_map (λne y, - (λne t : IT, interp_cont K env (t ⊙ (interp_val v env))) - y) ◎ ko)); - last (simpl; do 3 f_equiv; by intro). - by rewrite -hom_vis. - - trans (interp_cont K env (Err e)); - first (f_equiv; apply APP'_Err_l; apply interp_val_asval). - apply hom_err. + - rewrite <-hom_tick. + f_equiv. + rewrite get_val_tick. + reflexivity. + - rewrite !hom_vis. + f_equiv. + intro; simpl. + rewrite <-laterO_map_compose. + reflexivity. + - rewrite <-hom_err. + f_equiv. + rewrite hom_err. + rewrite get_val_err. + reflexivity. Qed. - + Opaque LET. #[local] Instance interp_cont_hom_app_contr {S} (K : cont S) (e : expr S) env : @@ -547,7 +684,8 @@ Section interp. (K : cont S) env : IT_hom (interp_cont K env). Proof. - induction K; simpl; apply _. + induction K; simpl; try apply _. + by apply interp_cont_hom_appr. Qed. (** ** Finally, preservation of reductions *) @@ -558,30 +696,39 @@ Section interp. (interp_config C' env) = (t', σ') -> t ≡ Tick_n n $ t'. Proof. - inversion 1; cbn-[IF APP' Tick get_ret2]; intros Ht Ht'; inversion Ht; inversion Ht'; try done. + inversion 1; cbn-[IF LET APP' Tick get_ret2]; intros Ht Ht'; inversion Ht; inversion Ht'; try done. + - do 3 f_equiv. + intro; simpl. + reflexivity. - do 4 f_equiv. intro. simpl. by repeat f_equiv. - rewrite -hom_tick. f_equiv. - erewrite APP_APP'_ITV; last apply _. - trans (interp_cont k env (APP (Fun (Next (ir_unf (interp_expr e) env))) (Next $ interp_val v env))). - { repeat f_equiv. apply interp_rec_unfold. } - rewrite APP_Fun. simpl. rewrite hom_tick. do 2 f_equiv. + match goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => + set (F := b) + end. + trans (interp_cont k env (LET (Fun (Next (ir_unf (interp_expr e) env))) F)). + { + do 3 f_equiv. + apply interp_rec_unfold. + } + subst F. + rewrite LET_Val. + simpl. + rewrite LET_Val. + simpl. + rewrite APP'_Fun_l. + rewrite laterO_map_Next. + rewrite <-Tick_eq. + rewrite hom_tick. + do 2 f_equiv. simplify_eq. rewrite !interp_expr_subst. + simpl. f_equiv. intros [| [| x]]; simpl; [| reflexivity | reflexivity]. rewrite interp_val_ren. f_equiv. intros ?; simpl; reflexivity. - (* - rewrite get_val_ITV. *) - (* simpl. *) - (* rewrite get_fun_fun. *) - (* simpl. *) - (* rewrite <-Tick_eq. *) - (* rewrite hom_tick. *) - (* rewrite hom_tick. *) - (* rewrite hom_tick. *) - (* rewrite hom_tick. *) - - subst. destruct n0; simpl. + by rewrite IF_False; last lia. diff --git a/theories/examples/delim_lang/lang.v b/theories/examples/delim_lang/lang.v index b533bf9..6ec68c6 100644 --- a/theories/examples/delim_lang/lang.v +++ b/theories/examples/delim_lang/lang.v @@ -33,8 +33,8 @@ with val {X : Set} := with cont {X : Set} := | END : cont | IfK (e1 : expr) (e2 : expr) : cont -> cont -| AppLK (v : val) : cont -> cont (* ◻ v *) -| AppRK (e : expr) : cont -> cont (* e ◻ *) +| AppRK (v : val) : cont -> cont (* v ◻ *) +| AppLK (e : expr) : cont -> cont (* ◻ e *) | AppContLK (v : val) : cont -> cont (* ◻ v *) | AppContRK (e : expr) : cont -> cont (* e ◻ *) | NatOpLK (op : nat_op) (v : val) : cont -> cont (* ◻ + v *) @@ -80,8 +80,8 @@ with kmap {A B : Set} (f : A [→] B) (K : cont A) : cont B := match K with | END => END | IfK e1 e2 k => IfK (emap f e1) (emap f e2) (kmap f k) - | AppLK v k => AppLK (vmap f v) (kmap f k) - | AppRK e k => AppRK (emap f e) (kmap f k) + | AppLK v k => AppLK (emap f v) (kmap f k) + | AppRK e k => AppRK (vmap f e) (kmap f k) | AppContLK v k => AppContLK (vmap f v) (kmap f k) | AppContRK e k => AppContRK (emap f e) (kmap f k) | NatOpLK op v k => NatOpLK op (vmap f v) (kmap f k) @@ -126,8 +126,8 @@ with kbind {A B : Set} (f : A [⇒] B) (K : cont A) : cont B := match K with | END => END | IfK e1 e2 k => IfK (ebind f e1) (ebind f e2) (kbind f k) - | AppLK v k => AppLK (vbind f v) (kbind f k) - | AppRK e k => AppRK (ebind f e) (kbind f k) + | AppLK v k => AppLK (ebind f v) (kbind f k) + | AppRK e k => AppRK (vbind f e) (kbind f k) | AppContLK v k => AppContLK (vbind f v) (kbind f k) | AppContRK e k => AppContRK (ebind f e) (kbind f k) | NatOpLK op v k => NatOpLK op (vbind f v) (kbind f k) @@ -309,8 +309,8 @@ Fixpoint fill {X : Set} (K : cont X) (e : expr X) : expr X := match K with | IfK e1 e2 K => fill K (If e e1 e2) | END => e - | AppLK v K => fill K (App e (Val v)) - | AppRK el K => fill K (App el e) + | AppRK v K => fill K (App (Val v) e) + | AppLK el K => fill K (App e el) | AppContLK v K => fill K (AppCont e (Val v)) | AppContRK el K => fill K (AppCont el e) | NatOpLK op v K => fill K (NatOp op e (Val v)) @@ -339,8 +339,8 @@ Fixpoint cont_compose {S} (K1 K2 : cont S) : cont S := match K2 with | END => K1 | IfK e1 e2 K => IfK e1 e2 (cont_compose K1 K) - | AppLK v K => AppLK v (cont_compose K1 K) - | AppRK e K => AppRK e (cont_compose K1 K) + | AppLK e K => AppLK e (cont_compose K1 K) + | AppRK v K => AppRK v (cont_compose K1 K) | AppContLK v K => AppContLK v (cont_compose K1 K) | AppContRK e K => AppContRK e (cont_compose K1 K) | NatOpLK op v K => NatOpLK op v (cont_compose K1 K) @@ -378,10 +378,10 @@ Variant config {S} : Type := Reserved Notation "c '===>' c' / nm" (at level 40, c', nm at level 30). -Variant Cred {S : Set} : config (* * state S *) -> config (* * state S *) -> (nat * nat) -> Prop := - - (* init *) - | Ceval_init : forall (e : expr S) (* σ *), +Variant Cred {S : Set} : config (* * state S *) -> config (* * state S *) + -> (nat * nat) -> Prop := +(* init *) +| Ceval_init : forall (e : expr S) (* σ *), (Cexpr e(* , σ *)) ===> (Ceval e END [](* , σ *)) / (0,0) (* eval *) @@ -389,7 +389,7 @@ Variant Cred {S : Set} : config (* * state S *) -> config (* * state S *) -> (na (Ceval (Val v) k mk(* , σ *)) ===> (Ccont k v mk(* , σ *)) / (0,0) | Ceval_app : forall e0 e1 k mk (* σ *), - (Ceval (App e0 e1) k mk(* , σ *)) ===> (Ceval e1 (AppRK e0 k) mk(* , σ *)) / (0,0) + (Ceval (App e0 e1) k mk(* , σ *)) ===> (Ceval e0 (AppLK e1 k) mk(* , σ *)) / (0,0) | Ceval_app_cont : forall e0 e1 k mk (* σ *), (Ceval (AppCont e0 e1) k mk(* , σ *)) ===> (Ceval e1 (AppContRK e0 k) mk(* , σ *)) / (0,0) @@ -411,14 +411,14 @@ Variant Cred {S : Set} : config (* * state S *) -> config (* * state S *) -> (na | Ccont_end : forall v mk (* σ *), (Ccont END v mk(* , σ *)) ===> (Cmcont mk v(* , σ *)) / (0,0) -| Ccont_appr : forall e v k mk (* σ *), - (Ccont (AppRK e k) v mk(* , σ *)) ===> (Ceval e (AppLK v k) mk(* , σ *)) / (0, 0) +| Ccont_appl : forall e v k mk (* σ *), + (Ccont (AppLK e k) v mk(* , σ *)) ===> (Ceval e (AppRK v k) mk(* , σ *)) / (0, 0) | Ccont_app_contr : forall e v k mk (* σ *), (Ccont (AppContRK e k) v mk(* , σ *)) ===> (Ceval e (AppContLK v k) mk(* , σ *)) / (0, 0) -| Ccont_appl : forall e v k mk (* σ *), - (Ccont (AppLK v k) (RecV e) mk(* , σ *)) ===> +| Ccont_appr : forall e v k mk (* σ *), + (Ccont (AppRK (RecV e) k) v mk(* , σ *)) ===> (Ceval (subst (Inc := inc) (subst (F := expr) (Inc := inc) e (Val (shift (Inc := inc) v))) @@ -547,12 +547,12 @@ Global Instance AppNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsS __app e₁ e₂ := App (__asSynExpr e₁) (__asSynExpr e₂) }. -Global Instance AppNotationLK {S : Set} : AppNotation (cont S) (val S) (cont S) := { - __app K v := cont_compose K (AppLK v END) +Global Instance AppNotationRK {S : Set} : AppNotation (cont S) (val S) (cont S) := { + __app K v := cont_compose K (AppRK v END) }. -Global Instance AppNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (cont S) (cont S) := { - __app e K := cont_compose K (AppRK (__asSynExpr e) END) +Global Instance AppNotationLK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (cont S) (cont S) := { + __app e K := cont_compose K (AppLK (__asSynExpr e) END) }. Class AppContNotation (A B C : Type) := { __app_cont : A -> B -> C }. From f7ee94f46e6a6845d7354b5a1e03ebdd232ed921 Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Wed, 5 Jun 2024 16:14:50 +0200 Subject: [PATCH 05/14] unary done --- _CoqProject | 1 + .../examples/delim_lang/{adeq.v => logpred.v} | 236 ++++++++++++++---- 2 files changed, 191 insertions(+), 46 deletions(-) rename theories/examples/delim_lang/{adeq.v => logpred.v} (86%) diff --git a/_CoqProject b/_CoqProject index f18d419..7cc6587 100644 --- a/_CoqProject +++ b/_CoqProject @@ -42,6 +42,7 @@ theories/lib/iter.v theories/examples/delim_lang/lang.v theories/examples/delim_lang/interp.v theories/examples/delim_lang/example.v +theories/examples/delim_lang/logpred.v theories/examples/input_lang_callcc/lang.v theories/examples/input_lang_callcc/interp.v diff --git a/theories/examples/delim_lang/adeq.v b/theories/examples/delim_lang/logpred.v similarity index 86% rename from theories/examples/delim_lang/adeq.v rename to theories/examples/delim_lang/logpred.v index aa415b5..eb160a7 100644 --- a/theories/examples/delim_lang/adeq.v +++ b/theories/examples/delim_lang/logpred.v @@ -5,7 +5,7 @@ From iris.algebra Require Import list. From iris.proofmode Require Import classes tactics. From iris.base_logic Require Import algebra. -(* TODO: typing rules, compat for contexts, binary relation *) +(* TODO: typing rules (ctx variables), compat for contexts, binary relation *) Require Import Binding.Lib Binding.Set Binding.Env. @@ -67,10 +67,12 @@ with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := | typed_RecV (e : expr (inc (inc S))) (δ σ τ α β : ty) : ((Γ ▹ (Tarr σ α τ β) ▹ σ); α ⊢ₑ e : τ; β) -> (Γ; δ ⊢ᵥ (RecV e) : (Tarr σ α τ β); δ) +(* unnecessary *) | typed_ContV (k : cont S) τ σ α : (Γ ⊢ᵪ k : τ ⤞ σ) → (Γ; α ⊢ᵥ (ContV k) : (Tcont τ σ); α) where "Γ ';' α '⊢ᵥ' e ':' τ ';' β" := (typed_val Γ α e τ β) : types +(* unnecessary *) with typed_cont {S : Set} (Γ : S -> ty) : cont S -> ty -> ty -> Prop := | typed_END τ : (Γ ⊢ᵪ END : τ ⤞ τ) @@ -87,12 +89,14 @@ with typed_cont {S : Set} (Γ : S -> ty) : cont S -> ty -> ty -> Prop := (Γ; τ ⊢ₑ e : Tnat; α) -> (Γ ⊢ᵪ k : Tnat ⤞ τ) -> (Γ ⊢ᵪ NatOpRK op e k : Tnat ⤞ α) -(* (* | typed_AppLK v k α β σ δ τ' τ : *) *) -(* (* (Γ; α ⊢ᵥ v : τ'; β) -> *) *) -(* (* (Γ; β ⊢ᵪ k : Tcont σ τ; δ) -> *) *) -(* (* (Γ; α ⊢ᵪ AppLK v k : Tcont (Tarr τ' α σ δ) τ; δ) *) *) -(* (* | typed_AppRK e k τ : *) *) -(* (* (Γ; τ ⊢ᵪ AppRK e k : τ; τ) *) *) +| typed_AppLK e k α β τ δ η : + (Γ; β ⊢ₑ e : δ; η) -> + (Γ ⊢ᵪ k : τ ⤞ α) -> + (Γ ⊢ᵪ AppLK e k : (Tarr δ α τ β) ⤞ η) +| typed_AppRK v k α β τ δ : + (∀ η, Γ; η ⊢ᵥ v : (Tarr τ α δ β); η) → + (Γ ⊢ᵪ k : δ ⤞ α) → + (Γ ⊢ᵪ AppRK v k : τ ⤞ β) (* (* | typed_AppContLK v k τ : *) *) (* (* (Γ; τ ⊢ᵪ AppContLK v k : τ; τ) *) *) (* (* | typed_AppContRK e k τ : *) *) @@ -663,10 +667,6 @@ Section logrel. iApply "Hκ". Qed. - (* | typed_App e₁ e₂ γ α β δ σ τ : *) - (* (Γ; γ ⊢ₑ e₁ : (Tarr σ α τ β); δ) → *) - (* (Γ; β ⊢ₑ e₂ : σ; γ) → *) - (* (Γ; α ⊢ₑ (App e₁ e₂) : τ; δ) *) Lemma compat_app {S : Set} (Γ : S → ty) ξ α β δ η τ e1 e2 : ⊢ valid Γ e1 (Tarr η α τ β) ξ δ @@ -706,7 +706,7 @@ Section logrel. subst κ'. simpl. rewrite LET_Val. - cbn [ofe_mor_car]. + cbn [ofe_mor_car]. match goal with | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => @@ -730,7 +730,7 @@ Section logrel. simpl. rewrite LET_Val. subst F. - cbn [ofe_mor_car]. + cbn [ofe_mor_car]. iDestruct "Hw" as "(%n' & #HEQ & Hw)". iSpecialize ("Hw" $! v with "Hv"). @@ -898,6 +898,7 @@ Section logrel. iApply ("Hκ" with "Hw Hm Hst"). Qed. + (* unnecessary *) Program Definition valid_ectx {S : Set} (Γ : S -> ty) (e : interp_scope S -n> IT -n> IT) @@ -1101,15 +1102,139 @@ Section logrel. iApply ("J" with "H Hm Hst"). Qed. - (* Lemma compat_appk_r {S : Set} (Γ : S → ty) τ α c d e t *) + Lemma compat_app_l {S : Set} (Γ : S → ty) τ δ α β η t + (E : interp_scope S -n> IT -n> IT) + `{∀ γ, IT_hom (E γ)} + `{∀ γ, IT_hom (interp_applk _ t E γ)} : + ⊢ valid_ectx Γ E τ α + -∗ valid Γ t δ β η + -∗ valid_ectx Γ (interp_applk _ t E) (Tarr δ α τ β) η. + Proof. + iIntros "#H #G". + iIntros (γ). + iModIntro. + iIntros "#Hγ". + iIntros (v). + iModIntro. + iIntros "#Hv". + iIntros (m) "Hm Hst". + + simpl. + rewrite LET_Val. + simpl. + + match goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => + set (F := b) + end. + pose (κ'' := exist _ (LETCTX F) (LETCTX_Hom F) : HOM). + assert (((E γ) (LET (t γ) F)) = (((E γ) ◎ (`κ'')) (t γ))) as ->. + { reflexivity. } + pose (sss := (HOM_compose (exist _ (E γ) (H _)) κ'')). + assert ((E γ ◎ `κ'') = (`sss)) as ->. + { reflexivity. } + iSpecialize ("G" $! γ with "Hγ"). + iSpecialize ("G" $! sss). + iApply ("G" with "[H] Hm Hst"). + iIntros (w). + iModIntro. + iIntros "#Hw". + iIntros (m'') "Hm Hst". + subst sss. + subst κ''. + simpl. + rewrite LET_Val. + subst F. + cbn [ofe_mor_car]. + + iDestruct "Hv" as "(%n' & #HEQ & Hv)". + iSpecialize ("Hv" $! w with "Hw"). + iAssert ((IT_of_V v ⊙ (IT_of_V w)) + ≡ (Fun n' ⊙ (IT_of_V w)))%I as "#HEQ'". + { + iApply (f_equivI (λne x, (x ⊙ (IT_of_V w)))). + iApply "HEQ". + } + iRewrite "HEQ'". + unshelve iApply ("Hv" $! (exist _ (E γ) _) with "[H] Hm Hst"). + - apply _. + - by iApply "H". + Qed. + + Lemma compat_app_r {S : Set} (Γ : S → ty) τ δ α β + (t : interp_scope S -n> IT) + (E : interp_scope S -n> IT -n> IT) + `{∀ γ, IT_hom (E γ)} + `{∀ γ, AsVal (t γ)} + `{∀ γ, IT_hom (interp_apprk _ t E γ)} : + ⊢ valid_ectx Γ E δ α + -∗ (∀ η, valid Γ t (Tarr τ α δ β) η η) + -∗ valid_ectx Γ (interp_apprk _ t E) τ β. + Proof. + iIntros "#H #G". + iIntros (γ). + assert (AsVal (t γ)). + { apply _. } + iModIntro. + iIntros "#Hγ". + iIntros (v). + iModIntro. + iIntros "#Hv". + iIntros (m) "Hm Hst". + simpl. + rewrite LET_Val. + simpl. + rewrite LET_Val. + simpl. + + unshelve epose (κ := exist _ (flipO APP' (IT_of_V v)) _ : HOM); + first apply _. + assert (((E γ) (t γ ⊙ (IT_of_V v))) = (((E γ) ◎ (`κ)) (t γ))) as ->. + { reflexivity. } + unshelve epose (sss := (HOM_compose (exist _ (E γ) _) κ)); + first apply _. + assert ((E γ ◎ `κ) = (`sss)) as ->. + { reflexivity. } + iSpecialize ("G" $! β γ with "Hγ"). + iSpecialize ("G" $! sss). + iApply ("G" with "[H] Hm Hst"). + iIntros (w). + iModIntro. + iIntros "#Hw". + iIntros (m'') "Hm Hst". + subst sss. + subst κ. + simpl. + + iDestruct "Hw" as "(%n' & #HEQ & Hw)". + iSpecialize ("Hw" $! v with "Hv"). + unshelve iSpecialize ("Hw" $! (exist _ (E γ) _) with "[H]"); + first apply _. + - iIntros (q). + iModIntro. + iIntros "#Hq". + iIntros (m''') "Hm Hst". + simpl. + iApply ("H" with "Hγ Hq Hm Hst"). + - iSpecialize ("Hw" $! m'' with "Hm Hst"). + iAssert ((IT_of_V w ⊙ (IT_of_V v)) + ≡ (Fun n' ⊙ (IT_of_V v)))%I as "#HEQ'". + { + iApply (f_equivI (λne x, (x ⊙ (IT_of_V v)))). + iApply "HEQ". + } + iRewrite "HEQ'". + iApply "Hw". + Qed. + + (* Lemma compat_appk_r {S : Set} (Γ : S → ty) τ α η t *) (* (E : interp_scope S -n> IT -n> IT) *) (* `{∀ γ, IT_hom (E γ)} *) (* `{∀ γ, IT_hom (interp_app_contrk _ t E γ)} : *) (* ⊢ valid_ectx Γ E τ α *) - (* -∗ valid Γ t c d e *) - (* -∗ valid_ectx Γ (interp_app_contrk _ t E) τ α. *) + (* -∗ (∀ β, valid Γ t (Tcont α η) β β) *) + (* -∗ valid_ectx Γ (interp_app_contrk _ t E) τ η. *) (* Proof. *) - (* Opaque interp_app_cont. *) (* iIntros "#H #G". *) (* iIntros (γ). *) (* iModIntro. *) @@ -1119,46 +1244,57 @@ Section logrel. (* iIntros "#Hv". *) (* iIntros (m) "Hm Hst". *) (* simpl. *) - - (* pose (κ'' := (AppContLSCtx_HOM (IT_of_V v) γ _)). *) - (* set (F := (E γ) _). *) - (* assert (F ≡ (((E γ) ◎ (`κ'')) (t γ))) as ->. *) - (* { *) - (* subst F. simpl. Transparent interp_app_cont. simpl. *) - (* f_equiv. *) - (* rewrite ->2 get_val_ITV. *) - (* simpl. *) - (* reflexivity. *) - (* } *) - (* pose (sss := (HOM_compose (exist _ (E γ) (H _)) κ'')). *) - (* assert (((E γ) ◎ `κ'') = (`sss)) as ->. *) - (* { reflexivity. } *) - - (* iSpecialize ("G" $! γ with "Hγ"). *) - (* iSpecialize ("G" $! sss). *) - (* iApply ("G" with "[] [] Hst"); *) - (* last admit. *) + (* rewrite get_val_ITV. *) + (* simpl. *) + (* match goal with *) + (* | |- context G [get_fun ?a] => *) + (* set (F := a) *) + (* end. *) + (* unshelve epose (FH := exist _ (E γ ◎ (get_fun F)) _ : HOM); *) + (* first apply _. *) + (* iSpecialize ("G" $! η γ with "Hγ"). *) + (* iApply ("G" $! FH with "[H] Hm Hst"). *) (* iIntros (w). *) (* iModIntro. *) (* iIntros "#Hw". *) - (* iIntros (m') "Hm Hst". *) + (* iIntros (m') "Hm Hst". *) + (* simpl. *) + (* iDestruct "Hw" as "(%n' & #HEQ & #Hw)". *) + (* iRewrite "HEQ". *) + (* rewrite get_fun_fun. *) + (* simpl. *) + (* rewrite hom_vis. *) + (* rewrite get_val_vis. *) + (* iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ *) + (* (NextO (Tick ((𝒫 ◎ `n') (IT_of_V v)))) with "Hst"); *) + (* [| reflexivity |]. *) + (* - simpl. *) + (* do 2 f_equiv. *) + (* + rewrite later_map_Next. *) + (* f_equiv. *) + (* rewrite Tick_eq. *) + (* reflexivity. *) + (* + reflexivity. *) + (* - iNext. *) + (* iIntros "_ Hst". *) + (* simpl. *) + (* iApply wp_tick. *) + (* iNext. *) + (* iSpecialize ("Hw" with ""). *) (* Admitted. *) - (* Lemma compat_appk_l {S : Set} (Γ : S → ty) τ α c d e *) + (* Lemma compat_appk_l {S : Set} (Γ : S → ty) τ δ α β *) (* (t : interp_scope S -n> IT) *) (* (E : interp_scope S -n> IT -n> IT) *) (* `{∀ γ, IT_hom (E γ)} *) (* `{∀ γ, AsVal (t γ)} *) (* `{∀ γ, IT_hom (interp_app_contlk _ t E γ)} : *) - (* ⊢ valid_ectx Γ E τ α *) - (* -∗ valid Γ t c d e *) - (* -∗ valid_ectx Γ (interp_app_contlk _ t E) τ α. *) + (* ⊢ valid_ectx Γ E δ α *) + (* -∗ (∀ η, valid Γ t (Tarr τ α δ β) η η) *) + (* -∗ valid_ectx Γ (interp_app_contlk _ t E) τ β. *) (* Proof. *) - (* Opaque interp_app_cont. *) (* iIntros "#H #G". *) (* iIntros (γ). *) - (* assert (AsVal (t γ)). *) - (* { apply _. } *) (* iModIntro. *) (* iIntros "#Hγ". *) (* iIntros (v). *) @@ -1166,7 +1302,8 @@ Section logrel. (* iIntros "#Hv". *) (* iIntros (m) "Hm Hst". *) (* simpl. *) - + (* rewrite get_val_ITV. *) + (* simpl. *) (* Admitted. *) Lemma compat_cont {S : Set} (Γ : S -> ty) τ σ @@ -1239,7 +1376,8 @@ Section logrel. iDestruct (compat_cont with "H") as "G". iSpecialize ("G" $! α). iApply "G". - - intros H. + - (* unnecessary *) + intros H. destruct H. + iApply compat_end. + iApply compat_ifk; @@ -1252,6 +1390,12 @@ Section logrel. + iApply compat_natop_r; [ by iApply fundamental_cont | by iApply fundamental_expr]. + + iApply compat_app_l; + [ by iApply fundamental_cont + | by iApply fundamental_expr]. + + iApply compat_app_r; + [ by iApply fundamental_cont + | iIntros (?); by iApply fundamental_val]. Qed. End logrel. From 435bb1abe5e73fff814b90f87629149753473c30 Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Thu, 6 Jun 2024 23:34:36 +0200 Subject: [PATCH 06/14] binary rel stub --- _CoqProject | 1 + theories/examples/delim_lang/lang.v | 43 +- theories/examples/delim_lang/logrel.v | 1159 +++++++++++++++++++++++++ theories/gitree/weakestpre.v | 13 + 4 files changed, 1202 insertions(+), 14 deletions(-) create mode 100644 theories/examples/delim_lang/logrel.v diff --git a/_CoqProject b/_CoqProject index 7cc6587..cd88e1e 100644 --- a/_CoqProject +++ b/_CoqProject @@ -43,6 +43,7 @@ theories/examples/delim_lang/lang.v theories/examples/delim_lang/interp.v theories/examples/delim_lang/example.v theories/examples/delim_lang/logpred.v +theories/examples/delim_lang/logrel.v theories/examples/input_lang_callcc/lang.v theories/examples/input_lang_callcc/interp.v diff --git a/theories/examples/delim_lang/lang.v b/theories/examples/delim_lang/lang.v index 6ec68c6..b1b5c9b 100644 --- a/theories/examples/delim_lang/lang.v +++ b/theories/examples/delim_lang/lang.v @@ -478,7 +478,8 @@ where "c ===> c' / nm" := (Cred c c' nm). Arguments Mcont S%bind : clear implicits. Arguments config S%bind : clear implicits. -Inductive steps {S} : config S (* * state S *) -> config S (* * state S *) -> (nat * nat) -> Prop := +Inductive steps {S} : config S (* * state S *) -> config S (* * state S *) -> + (nat * nat) -> Prop := | steps_zero : forall c, steps c c (0, 0) | steps_many : forall c1 c2 c3 n m n' m' n'' m'', @@ -513,25 +514,31 @@ Global Instance AsSynExprExpr : AsSynExpr expr := { Class OpNotation (A B C D : Type) := { __op : A -> B -> C -> D }. -Global Instance OpNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : OpNotation (F S) nat_op (G S) (expr S) := { +Global Instance OpNotationExpr {S : Set} {F G : Set -> Type} + `{AsSynExpr F, AsSynExpr G} : OpNotation (F S) nat_op (G S) (expr S) := { __op e₁ op e₂ := NatOp op (__asSynExpr e₁) (__asSynExpr e₂) }. -Global Instance OpNotationLK {S : Set} : OpNotation (cont S) (nat_op) (val S) (cont S) := { +Global Instance OpNotationLK {S : Set} : + OpNotation (cont S) (nat_op) (val S) (cont S) := { __op K op v := cont_compose K (NatOpLK op v END) }. -Global Instance OpNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : OpNotation (F S) (nat_op) (cont S) (cont S) := { +Global Instance OpNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : + OpNotation (F S) (nat_op) (cont S) (cont S) := { __op e op K := cont_compose K (NatOpRK op (__asSynExpr e) END) }. Class IfNotation (A B C D : Type) := { __if : A -> B -> C -> D }. -Global Instance IfNotationExpr {S : Set} {F G H : Set -> Type} `{AsSynExpr F, AsSynExpr G, AsSynExpr H} : IfNotation (F S) (G S) (H S) (expr S) := { +Global Instance IfNotationExpr {S : Set} {F G H : Set -> Type} + `{AsSynExpr F, AsSynExpr G, AsSynExpr H} : + IfNotation (F S) (G S) (H S) (expr S) := { __if e₁ e₂ e₃ := If (__asSynExpr e₁) (__asSynExpr e₂) (__asSynExpr e₃) }. -Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : +Global Instance IfNotationK {S : Set} {F G : Set -> Type} + `{AsSynExpr F, AsSynExpr G} : IfNotation (cont S) (F S) (G S) (cont S) := { __if K e₂ e₃ := cont_compose K (IfK (__asSynExpr e₂) (__asSynExpr e₃) END) }. @@ -543,29 +550,35 @@ Global Instance ResetNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : Class AppNotation (A B C : Type) := { __app : A -> B -> C }. -Global Instance AppNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : AppNotation (F S) (G S) (expr S) := { +Global Instance AppNotationExpr {S : Set} {F G : Set -> Type} + `{AsSynExpr F, AsSynExpr G} : AppNotation (F S) (G S) (expr S) := { __app e₁ e₂ := App (__asSynExpr e₁) (__asSynExpr e₂) }. -Global Instance AppNotationRK {S : Set} : AppNotation (cont S) (val S) (cont S) := { +Global Instance AppNotationRK {S : Set} : + AppNotation (cont S) (val S) (cont S) := { __app K v := cont_compose K (AppRK v END) }. -Global Instance AppNotationLK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (cont S) (cont S) := { +Global Instance AppNotationLK {S : Set} {F : Set -> Type} `{AsSynExpr F} : + AppNotation (F S) (cont S) (cont S) := { __app e K := cont_compose K (AppLK (__asSynExpr e) END) }. Class AppContNotation (A B C : Type) := { __app_cont : A -> B -> C }. -Global Instance AppContNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : AppContNotation (F S) (G S) (expr S) := { +Global Instance AppContNotationExpr {S : Set} {F G : Set -> Type} + `{AsSynExpr F, AsSynExpr G} : AppContNotation (F S) (G S) (expr S) := { __app_cont e₁ e₂ := AppCont (__asSynExpr e₁) (__asSynExpr e₂) }. -Global Instance AppContNotationLK {S : Set} : AppContNotation (cont S) (val S) (cont S) := { +Global Instance AppContNotationLK {S : Set} : + AppContNotation (cont S) (val S) (cont S) := { __app_cont K v := cont_compose K (AppContLK v END) }. -Global Instance AppContNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppContNotation (F S) (cont S) (cont S) := { +Global Instance AppContNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : + AppContNotation (F S) (cont S) (cont S) := { __app_cont e K := cont_compose K (AppContRK (__asSynExpr e) END) }. @@ -610,8 +623,10 @@ Global Instance AppContNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : A Notation of_val := Val (only parsing). -Notation "x '⋆' y" := (__app x%syn y%syn) (at level 40, y at next level, left associativity) : syn_scope. -Notation "x '@k' y" := (__app_cont x%syn y%syn) (at level 40, y at next level, left associativity) : syn_scope. +Notation "x '⋆' y" := (__app x%syn y%syn) (at level 40, y at next level + , left associativity) : syn_scope. +Notation "x '@k' y" := (__app_cont x%syn y%syn) (at level 40, y at next level + , left associativity) : syn_scope. Notation "x '+' y" := (__op x%syn Add y%syn) : syn_scope. Notation "x '-' y" := (__op x%syn Sub y%syn) : syn_scope. Notation "x '*' y" := (__op x%syn Mult y%syn) : syn_scope. diff --git a/theories/examples/delim_lang/logrel.v b/theories/examples/delim_lang/logrel.v new file mode 100644 index 0000000..2110b0a --- /dev/null +++ b/theories/examples/delim_lang/logrel.v @@ -0,0 +1,1159 @@ +From gitrees Require Import gitree lang_generic hom. +From gitrees.effects Require Import delim. +From gitrees.examples.delim_lang Require Import lang interp. +From iris.algebra Require Import list. +From iris.proofmode Require Import classes tactics. +From iris.base_logic Require Import algebra. + +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope syn. + +Inductive ty := +| Tnat : ty +| Tarr : ty -> ty -> ty -> ty -> ty +| Tcont : ty → ty → ty. + +Declare Scope types. + +Notation "τ '∕' α '→' σ '∕' β" := (Tarr τ α σ β) (at level 60) : types. +Notation "'Cont' τ σ" := (Tcont τ σ) (at level 60) : types. + +Reserved Notation "Γ ';' α '⊢ₑ' e ':' τ ';' β" + (at level 90, e at next level, τ at level 20, no associativity). + +Reserved Notation "Γ ';' α '⊢ᵥ' e ':' τ ';' β" + (at level 90, e at next level, τ at level 20, no associativity). + +Reserved Notation "Γ '⊢ᵪ' e ':' τ '⤞' σ" + (at level 90, e at next level, τ at level 20, no associativity). + +Inductive typed_expr {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := +| typed_Val v α τ β : + (Γ; α ⊢ᵥ v : τ; β) → + (Γ; α ⊢ₑ v : τ; β) +| typed_Var x τ α : + (Γ x = τ) → + (Γ; α ⊢ₑ (Var x) : τ; α) +| typed_App e₁ e₂ γ α β δ σ τ : + (Γ; γ ⊢ₑ e₁ : (Tarr σ α τ β); δ) → + (Γ; β ⊢ₑ e₂ : σ; γ) → + (Γ; α ⊢ₑ (App e₁ e₂) : τ; δ) +| typed_AppCont e₁ e₂ α β δ σ τ : + (Γ; σ ⊢ₑ e₁ : (Tcont τ α); δ) → + (Γ; δ ⊢ₑ e₂ : τ; β) → + (Γ; σ ⊢ₑ (AppCont e₁ e₂) : α; β) +| typed_NatOp o e₁ e₂ α β γ : + (Γ; α ⊢ₑ e₁ : Tnat; β) → + (Γ; β ⊢ₑ e₂ : Tnat; γ) → + (Γ; α ⊢ₑ NatOp o e₁ e₂ : Tnat; γ) +| typed_If e e₁ e₂ α β σ τ : + (Γ; β ⊢ₑ e : Tnat; α) → + (Γ; σ ⊢ₑ e₁ : τ; β) → + (Γ; σ ⊢ₑ e₂ : τ; β) → + (Γ; σ ⊢ₑ (if e then e₁ else e₂) : τ; α) +| typed_Shift (e : @expr (inc S)) τ α σ β : + (Γ ▹ (Tcont τ α); σ ⊢ₑ e : σ; β) → + (Γ; α ⊢ₑ Shift e : τ; β) +| typed_Reset e α σ τ : + (Γ; σ ⊢ₑ e : σ; τ) → + (Γ; α ⊢ₑ reset e : τ; α) +where "Γ ';' α '⊢ₑ' e ':' τ ';' β" := (typed_expr Γ α e τ β) : types +with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := +| typed_LitV n α : + (Γ; α ⊢ᵥ #n : Tnat; α) +| typed_RecV (e : expr (inc (inc S))) (δ σ τ α β : ty) : + ((Γ ▹ (Tarr σ α τ β) ▹ σ); α ⊢ₑ e : τ; β) -> + (Γ; δ ⊢ᵥ (RecV e) : (Tarr σ α τ β); δ) +where "Γ ';' α '⊢ᵥ' e ':' τ ';' β" := (typed_val Γ α e τ β) : types +. + +Module Example. + Open Scope types. + + Lemma typ_example1 α : + empty_env; α ⊢ₑ ((#1) + + (reset + ((#3) + + (shift/cc ((($0) @k #5) + (($0) @k #6)))))) + : Tnat; α. + Proof. + eapply typed_NatOp. + - apply typed_Val. + apply typed_LitV. + - eapply typed_Reset. + eapply typed_NatOp. + + apply typed_Val. + apply typed_LitV. + + eapply typed_Shift. + eapply typed_NatOp. + * eapply typed_AppCont. + -- apply typed_Var. + reflexivity. + -- apply typed_Val. + apply typed_LitV. + * eapply typed_AppCont. + -- apply typed_Var. + reflexivity. + -- apply typed_Val. + apply typed_LitV. + Qed. + +End Example. + +Open Scope stdpp_scope. + +Section logrel. + Context {sz : nat}. + Variable (rs : gReifiers CtxDep sz). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Context `{!subReifier reify_delim rs}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ}. + Context `{!stateG rs R Σ}. + Notation iProp := (iProp Σ). + Notation restO + := (gState_rest + (@sR_idx _ _ + (sReifier_NotCtxDep_CtxDep reify_delim)) rs ♯ IT). + + Canonical Structure exprO S := leibnizO (expr S). + Canonical Structure valO S := leibnizO (val S). + Canonical Structure contO S := leibnizO (cont S). + Canonical Structure mcontO S := leibnizO (Mcont S). + + Notation "'WP' α {{ β , Φ } }" + := (wp rs α notStuck ⊤ (λ β, Φ)) + (at level 20, α, Φ at level 200, + format "'WP' α {{ β , Φ } }") + : bi_scope. + + Notation "'WP' α {{ Φ } }" + := (wp rs α notStuck ⊤ Φ) + (at level 20, α, Φ at level 200, + format "'WP' α {{ Φ } }") : bi_scope. + + Definition logrel_nat' {S : Set} (βv : ITV) (v : valO S) : iProp := + (∃ (n : natO), βv ≡ RetV n ∧ v ≡ LitV n)%I. + Local Instance logrel_nat_ne {S : Set} : NonExpansive2 (@logrel_nat' S). + Proof. solve_proper. Qed. + Program Definition logrel_nat {S : Set} : ITV -n> valO S -n> iProp := + λne x y, @logrel_nat' S x y. + Solve All Obligations with solve_proper. + Fail Next Obligation. + + Definition obs_ref' {S : Set} + (t : IT) (κ : HOM) (σ : stateF ♯ IT) + (e : exprO S) (k : contO S) (m : mcontO S) + : iProp := + (has_substate σ + -∗ WP (𝒫 (`κ t)) {{ βv, has_substate [] + ∗ ∃ (v : valO S) (nm : nat * nat), + ⌜steps (Ceval e k m) (Cret v) nm⌝ }})%I. + Local Instance obs_ref_ne {S : Set} : + ∀ n, Proper (dist n ==> dist n ==> dist n ==> + dist n ==> dist n ==> dist n ==> dist n) + (@obs_ref' S). + Proof. solve_proper. Qed. + Local Instance obs_ref_proper {S : Set} : + Proper ((≡) ==> (≡) ==> (≡) ==> + (≡) ==> (≡) ==> (≡) ==> (≡)) + (@obs_ref' S). + Proof. solve_proper. Qed. + + Program Definition obs_ref {S : Set} + : IT -n> HOM -n> (stateF ♯ IT) + -n> exprO S -n> contO S -n> mcontO S -n> iProp := + λne x y z a b c, obs_ref' x y z a b c. + Solve All Obligations with try solve_proper. + Next Obligation. + intros. + intros ????????; simpl. + solve_proper. + Qed. + + Definition logrel_mcont' {S : Set} + (P : ITV -n> valO S -n> iProp) (F : stateF ♯ IT) (m : mcontO S) := + (∀ αv v, P αv v -∗ obs_ref (IT_of_V αv) HOM_id F (Val v) END m)%I. + Local Instance logrel_mcont_ne {S : Set} : + NonExpansive3 (@logrel_mcont' S). + Proof. solve_proper. Qed. + Local Instance logrel_mcont_proper {S : Set} : + Proper ((≡) ==> (≡) ==> (≡) ==> (≡)) + (@logrel_mcont' S). + Proof. solve_proper. Qed. + Program Definition logrel_mcont {S : Set} : + (ITV -n> valO S -n> iProp) + -n> (stateF ♯ IT) -n> mcontO S -n> iProp + := λne x y z, logrel_mcont' x y z. + Solve All Obligations with solve_proper. + + Program Definition logrel_ectx' {S : Set} + (Pτ Pα : ITV -n> valO S -n> iProp) (κ : HOM) (k : cont S) + : iProp := + (□ ∀ αv v, Pτ αv v -∗ ∀ σ (m : mcontO S), + logrel_mcont Pα σ m -∗ obs_ref (IT_of_V αv) κ σ (Val v) k m)%I. + Local Instance logrel_ectx_ne {S : Set} : + NonExpansive4 (@logrel_ectx' S). + Proof. solve_proper. Qed. + Local Instance logrel_ectx_proper {S : Set} : + Proper ((≡) ==> (≡) ==> (≡) ==> (≡) ==> (≡)) + (@logrel_ectx' S). + Proof. solve_proper. Qed. + Program Definition logrel_ectx {S : Set} + : (ITV -n> valO S -n> iProp) -n> (ITV -n> valO S -n> iProp) + -n> HOM -n> cont S -n> iProp + := λne x y z w, logrel_ectx' x y z w. + Solve All Obligations with solve_proper. + + Program Definition logrel_cont' {S : Set} + (V W : ITV -n> valO S -n> iProp) (βv : ITV) (v : valO S) : iProp := + (∃ (κ : HOM) K, (IT_of_V βv) ≡ + (Fun (Next (λne x, Tau (laterO_map (𝒫 ◎ `κ) (Next x))))) + ∧ ⌜v = ContV K⌝ + ∧ □ logrel_ectx V W κ K)%I. + Local Instance logrel_cont_ne {S : Set} : NonExpansive4 (@logrel_cont' S). + Proof. solve_proper. Qed. + Local Instance logrel_cont_proper {S : Set} : + Proper ((≡) ==> (≡) ==> (≡) ==> (≡) ==> (≡)) + (@logrel_cont' S). + Proof. solve_proper. Qed. + Program Definition logrel_cont {S : Set} + : (ITV -n> valO S -n> iProp) -n> (ITV -n> valO S -n> iProp) + -n> ITV -n> valO S -n> iProp + := λne x y z w, logrel_cont' x y z w. + Solve All Obligations with solve_proper. + + Program Definition logrel_arr' {S : Set} + (Pτ Pα Pσ Pβ : ITV -n> valO S -n> iProp) (f : ITV) (vf : valO S) + : iProp + := (∃ f', IT_of_V f ≡ Fun f' + ∧ □ ∀ (βv : ITV) (v : valO S), + Pτ βv v -∗ ∀ (κ : HOM) (K : cont S), + logrel_ectx Pσ Pα κ K -∗ ∀ σ m, + logrel_mcont Pβ σ m + -∗ obs_ref (APP' (Fun f') (IT_of_V βv)) κ σ + (App (Val vf) (Val v)) K m)%I. + Local Instance logrel_arr_ne {S : Set} + : (∀ n, Proper (dist n + ==> dist n + ==> dist n + ==> dist n + ==> dist n + ==> dist n + ==> dist n) + (@logrel_arr' S)). + Proof. solve_proper. Qed. + Local Instance logrel_arr_proper {S : Set} : + Proper ((≡) ==> (≡) ==> (≡) ==> + (≡) ==> (≡) ==> (≡) ==> (≡)) + (@logrel_arr' S). + Proof. solve_proper. Qed. + Program Definition logrel_arr {S : Set} + : (ITV -n> valO S -n> iProp) + -n> (ITV -n> valO S -n> iProp) + -n> (ITV -n> valO S -n> iProp) + -n> (ITV -n> valO S -n> iProp) -n> ITV -n> valO S -n> iProp := + λne x y z w v t, logrel_arr' x y z w v t. + Solve All Obligations with try solve_proper. + Next Obligation. + intros; intros ????????; simpl. + solve_proper. + Qed. + + Fixpoint interp_ty {S : Set} (τ : ty) : ITV -n> valO S -n> iProp := + match τ with + | Tnat => logrel_nat + | Tcont α β => logrel_cont (interp_ty α) (interp_ty β) + | Tarr τ α σ β => logrel_arr (interp_ty τ) (interp_ty α) + (interp_ty σ) (interp_ty β) + end. + + Local Instance interp_ty_persistent {S : Set} (τ : ty) α v : + Persistent (@interp_ty S τ α v). + Proof. + revert α. induction τ=> α; simpl. + - unfold logrel_nat. apply _. + - unfold logrel_arr. apply _. + - unfold logrel_cont. apply _. + Qed. + + Program Definition logrel_expr {S : Set} + (τ α δ : ITV -n> valO S -n> iProp) : IT -n> exprO S -n> iProp + := λne e e', (∀ E E', logrel_ectx τ α E E' + -∗ ∀ F F', logrel_mcont δ F F' + -∗ obs_ref e E F e' E' F')%I. + Solve All Obligations with try solve_proper. + Next Obligation. + intros; intros ????; simpl. + do 2 (f_equiv; intro; simpl). + f_equiv. + do 2 (f_equiv; intro; simpl). + f_equiv. + solve_proper. + Qed. + + Definition logrel {S : Set} (τ α β : ty) : IT -n> exprO S -n> iProp + := logrel_expr (interp_ty τ) (interp_ty α) (interp_ty β). + + Program Definition ssubst_valid {S : Set} + (Γ : S -> ty) + (ss : interp_scope S) (γ : S [⇒] Empty_set) : iProp := + (∀ x τ, □ logrel (Γ x) τ τ (ss x) (γ x))%I. + + Program Definition valid {S : Set} + (Γ : S -> ty) + (e : interp_scope S -n> IT) + (e' : exprO S) + (τ α σ : ty) : iProp := + (□ ∀ γ (γ' : S [⇒] Empty_set), ssubst_valid Γ γ γ' + -∗ @logrel Empty_set τ α σ (e γ) (bind (F := expr) γ' e'))%I. + + (* Lemma compat_empty {S : Set} P : *) + (* ⊢ @logrel_mcont S P [] []. *) + (* Proof. *) + (* iIntros (v v') "Pv HH". *) + (* iApply (wp_pop_end with "HH"). *) + (* iNext. *) + (* iIntros "_ HHH". *) + (* iApply wp_val. *) + (* iModIntro. *) + (* iFrame "HHH". *) + (* iExists v'. *) + (* iExists (1, 1). *) + (* iPureIntro. *) + (* eapply (steps_many _ _ _ 0 0 1 1 1 1); *) + (* [done | done | apply Ceval_val |]. *) + (* eapply (steps_many _ _ _ 0 0 1 1 1 1); *) + (* [done | done | apply Ccont_end |]. *) + (* eapply (steps_many _ _ _ 1 1 0 0 1 1); *) + (* [done | done | apply Cmcont_ret |]. *) + (* constructor. *) + (* Qed. *) + + (* Lemma compat_cons {S : Set} P Q (x : HOM) (x' : contO S) *) + (* (xs : list (later IT -n> later IT)) xs' : *) + (* ⊢ logrel_ectx P Q x x' *) + (* -∗ logrel_mcont Q xs xs' *) + (* -∗ logrel_mcont P (laterO_map (𝒫 ◎ `x) :: xs) (x' :: xs'). *) + (* Proof. *) + (* iIntros "#H G". *) + (* iIntros (v v') "Hv Hst". *) + (* iApply (wp_pop_cons with "Hst"). *) + (* iNext. *) + (* iIntros "_ Hst". *) + (* iSpecialize ("H" $! v with "Hv"). *) + (* iSpecialize ("H" $! xs xs' with "G Hst"). *) + (* iApply (wp_wand with "H"). *) + (* iIntros (_) "(H1 & (%w & %nm & %H2))". *) + (* destruct nm as [n m]. *) + (* iModIntro. *) + (* iFrame "H1". *) + (* iExists w, (n, m). *) + (* iPureIntro. *) + (* eapply (steps_many _ _ _ 0 0 n m n m); *) + (* [done | done | apply Ceval_val |]. *) + (* eapply (steps_many _ _ _ 0 0 n m n m); *) + (* [done | done | apply Ccont_end |]. *) + (* eapply (steps_many _ _ _ 1 1 0 0 1 1); *) + (* [done | done | apply Cmcont_ret |]. *) + (* constructor. *) + (* Qed. *) + + Lemma compat_HOM_id {S : Set} P : + ⊢ @logrel_ectx S P P HOM_id END. + Proof. + iIntros (v v'). + iModIntro. + iIntros "Pv". + iIntros (σ m) "Hσ HH". + iApply ("Hσ" with "Pv HH"). + Qed. + + Lemma logrel_of_val {S : Set} τ α v (v' : valO S) : + interp_ty α v v' -∗ logrel α τ τ (IT_of_V v) (Val v'). + Proof. + iIntros "#H". + iIntros (κ K) "Hκ". + iIntros (σ m) "Hσ Hown". + iApply ("Hκ" with "H Hσ Hown"). + Qed. + + Lemma compat_var {S : Set} (Γ : S -> ty) (x : S) : + ⊢ (∀ α, valid Γ (interp_var x) (Var x) (Γ x) α α). + Proof. + iIntros (α). + iModIntro. + iIntros (γ γ') "#Hss". + iIntros (E E') "HE". + iIntros (F F') "HF". + iIntros "Hσ". + iApply ("Hss" with "HE HF Hσ"). + Qed. + + Lemma compat_reset {S : Set} (Γ : S -> ty) e (e' : exprO S) σ τ : + ⊢ valid Γ e e' σ σ τ -∗ (∀ α, valid Γ (interp_reset rs e) (reset e') τ α α). + Proof. + iIntros "#H". + iIntros (α). + iModIntro. + iIntros (γ γ') "Hγ". + iIntros (κ κ') "Hκ". + iIntros (m m') "Hm Hst". + assert (𝒫 ((`κ) (interp_reset rs e γ)) + ≡ (𝒫 ◎ `κ) (interp_reset rs e γ)) as ->. + { reflexivity. } + iApply (wp_reset with "Hst"). + iNext. + iIntros "_ Hst". + iSpecialize ("H" $! γ with "Hγ"). + unshelve iSpecialize ("H" $! HOM_id END (compat_HOM_id _) + (laterO_map (𝒫 ◎ `κ) :: m) (κ' :: m')); + first apply _. + iAssert (logrel_mcont (interp_ty τ) (laterO_map (𝒫 ◎ `κ) :: m) (κ' :: m')) + with "[Hm Hκ]" as "Hm". + { + iIntros (v v') "Hv Hst". + iApply (wp_pop_cons with "Hst"). + iNext. + iIntros "_ Hst". + iSpecialize ("Hκ" $! v with "Hv"). + iSpecialize ("Hκ" $! m with "Hm"). + iSpecialize ("Hκ" with "Hst"). + iApply (wp_wand with "Hκ"). + iIntros (_) "(H1 & (%w & %nm & %H2))". + iModIntro. + iFrame "H1". + iExists w, nm. + iPureIntro. + admit. + } + iSpecialize ("H" with "Hm Hst"). + iApply (wp_wand with "H"). + iIntros (_) "(H1 & (%w & %nm & %H2))". + destruct nm as [a b]. + iModIntro. + iFrame "H1". + iExists w, ((a + 1)%nat, (b + 1)%nat). + iPureIntro. + term_simpl. + eapply (steps_many _ _ _ 1 1 a b (a + 1)%nat (b + 1)%nat); + [ lia | lia | apply Ceval_reset |]. + assumption. + Admitted. + + Program Definition 𝒫_HOM : @HOM sz CtxDep R _ rs := exist _ 𝒫 _. + Next Obligation. + apply _. + Qed. + + Lemma compat_shift {S : Set} (Γ : S -> ty) e (e' : exprO (inc S)) σ α τ β : + ⊢ valid (Γ ▹ (Tcont τ α)) e e' σ σ β -∗ valid Γ (interp_shift _ e) (Shift e') τ α β. + Proof. + iIntros "#H". + iModIntro. + iIntros (γ γ') "#Hγ". + iIntros (κ κ') "#Hκ". + iIntros (m m') "Hm Hst". + assert (𝒫 ((`κ) (interp_shift rs e γ)) + ≡ (𝒫 ◎ `κ) (interp_shift rs e γ)) as ->. + { reflexivity. } + iApply (wp_shift with "Hst"). + { rewrite laterO_map_Next; reflexivity. } + iNext. + iIntros "_ Hst". + match goal with + | |- context G [ofe_mor_car _ _ e ?a] => + set (γ_ := a) + end. + pose (γ_' := ((mk_subst (Val (ContV κ')%syn)) ∘ (γ' ↑)%bind)%bind : inc S [⇒] ∅). + iAssert (ssubst_valid (Γ ▹ Tcont τ α) γ_ γ_') with "[Hγ Hκ]" as "Hγ'". + { + iIntros (x τ'). + destruct x as [| x]. + - iModIntro. + subst γ_'. + iIntros (E E') "HE". + iIntros (F F') "HF Hst". + simpl. + match goal with + | |- context G [ofe_mor_car _ _ (`E) (ofe_mor_car _ _ Fun ?a)] => + set (f := a) + end. + iApply ("HE" $! (FunV f) with "[Hκ] HF Hst"). + iExists κ, κ'. + iSplit. + + subst f; iPureIntro. + reflexivity. + + iSplit; first done. + iApply "Hκ". + - subst γ_'. + term_simpl. + iApply "Hγ". + } + iSpecialize ("H" $! γ_ with "Hγ'"). + iSpecialize ("H" $! HOM_id END (compat_HOM_id _) m with "Hm Hst"). + iApply (wp_wand with "H"). + iIntros (_) "(H1 & (%w & %nm & %H2))". + destruct nm as [a b]. + iModIntro. + iFrame "H1". + iExists w, ((a + 1)%nat, (b + 1)%nat). + iPureIntro. + term_simpl. + eapply (steps_many _ _ _ 1 1 a b (a + 1)%nat (b + 1)%nat); + [ lia | lia | apply Ceval_shift |]. + subst γ_'. + Admitted. + + Lemma compat_nat {S : Set} (Γ : S → ty) n α : + ⊢ valid Γ (interp_nat rs n) (LitV n) Tnat α α. + Proof. + iModIntro. + iIntros (γ γ') "#Hγ". + assert ((interp_nat rs n γ) = IT_of_V (RetV n)) as ->. + { reflexivity. } + iApply logrel_of_val. + by iExists n. + Qed. + + (* Lemma compat_recV {S : Set} (Γ : S -> ty) *) + (* τ1 α τ2 β e (e' : expr (inc (inc S))) : *) + (* ⊢ valid ((Γ ▹ (Tarr τ1 α τ2 β) ▹ τ1)) e e' τ2 α β *) + (* -∗ (∀ θ, valid Γ (interp_rec rs e) (RecV e') (Tarr τ1 α τ2 β) θ θ). *) + (* Proof. *) + (* iIntros "#H". *) + (* iIntros (θ). *) + (* iModIntro. *) + (* iIntros (γ γ') "#Hγ". *) + (* set (f := (ir_unf rs e γ)). *) + (* iAssert (interp_rec rs e γ ≡ IT_of_V $ FunV (Next f))%I as "Hf". *) + (* { iPureIntro. apply interp_rec_unfold. } *) + (* iRewrite "Hf". *) + (* Opaque IT_of_V. *) + (* iApply logrel_of_val; term_simpl. *) + (* iExists _. iSplit. *) + (* { iPureIntro. apply into_val. } *) + (* iModIntro. *) + (* iLöb as "IH". *) + (* iIntros (v) "#Hw". *) + (* iIntros (κ) "#Hκ". *) + (* iIntros (σ) "Hσ Hst". *) + (* rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. *) + (* pose (γ' := *) + (* (extend_scope (extend_scope γ (interp_rec rs e γ)) (IT_of_V v))). *) + (* rewrite /logrel. *) + (* Opaque extend_scope. *) + (* simpl. *) + (* rewrite hom_tick. *) + (* rewrite hom_tick. *) + (* iApply wp_tick. *) + (* iNext. *) + (* iSpecialize ("H" $! γ' with "[Hw]"). *) + (* { *) + (* iIntros (x). *) + (* destruct x as [| [| x]]; iIntros (ξ); iModIntro. *) + (* * iApply logrel_of_val. *) + (* iApply "Hw". *) + (* * iIntros (κ') "Hκ'". *) + (* iIntros (σ') "Hσ' Hst". *) + (* Transparent extend_scope. *) + (* simpl. *) + (* iRewrite "Hf". *) + (* iSpecialize ("Hκ'" $! (FunV (Next f)) with "[IH]"). *) + (* { *) + (* iExists (Next f). *) + (* iSplit; first done. *) + (* iModIntro. *) + (* iIntros (βv) "Hβv". *) + (* iIntros (κ'') "Hκ''". *) + (* iIntros (σ'') "Hσ'' Hst". *) + (* iApply ("IH" $! βv with "Hβv Hκ'' Hσ'' Hst"). *) + (* } *) + (* iApply ("Hκ'" $! σ' with "Hσ' Hst"). *) + (* * iApply "Hγ". *) + (* } *) + (* subst γ'. *) + (* iApply ("H" with "Hκ Hσ Hst"). *) + (* Qed. *) + + Program Definition AppContRSCtx_HOM {S : Set} + (α : @interp_scope F R _ S -n> IT) + (env : @interp_scope F R _ S) + : HOM := exist _ (interp_app_contrk rs α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition AppContLSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F R _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_app_contlk rs (constO β) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - intros ???. + do 2 f_equiv. + intros ?; simpl. + solve_proper. + - rewrite get_val_ITV. + rewrite get_val_ITV. + simpl. + rewrite get_fun_tick. + reflexivity. + - rewrite get_val_ITV. + simpl. rewrite get_fun_vis. simpl. + f_equiv. + intros ?; simpl. + apply later_map_ext. + intros ?; simpl. + rewrite get_val_ITV. + simpl. + reflexivity. + - rewrite get_val_ITV. simpl. rewrite get_fun_err. reflexivity. + Qed. + + Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) + (α : @interp_scope F R _ S -n> IT) (env : @interp_scope F R _ S) + : HOM := exist _ (interp_natoprk rs op α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) + (α : IT) (env : @interp_scope F R _ S) + (Hv : AsVal α) + : HOM := exist _ (interp_natoplk rs op (constO α) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition AppLSCtx_HOM {S : Set} + (α : @interp_scope F R _ S -n> IT) + (env : @interp_scope F R _ S) + : HOM := exist _ (interp_applk rs α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Transparent LET. + Program Definition AppRSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F R _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_apprk rs (constO β) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - solve_proper_please. + - rewrite get_val_ITV. + simpl. + rewrite get_val_ITV. + simpl. + rewrite get_val_tick. + reflexivity. + - rewrite get_val_ITV. + simpl. + rewrite get_val_vis. + do 3 f_equiv. + intro; simpl. + rewrite get_val_ITV. + simpl. + reflexivity. + - rewrite get_val_ITV. + simpl. + rewrite get_val_err. + reflexivity. + Qed. + Opaque LET. + + Lemma compat_nat_op {S : Set} (Γ : S → ty) + D E F e1 e2 (e1' e2' : exprO S) op : + ⊢ valid Γ e1 e1' Tnat E F + -∗ valid Γ e2 e2' Tnat F D + -∗ valid Γ (interp_natop rs op e1 e2) (NatOp op e1' e2') Tnat E D. + Proof. + iIntros "#H #G". + iModIntro. + iIntros (γ γ') "#Hγ". + iIntros (κ κ') "#Hκ". + iIntros (m m') "Hm Hst". + rewrite /interp_natop //=. + + set (K' := (NatOpRSCtx_HOM op e1 γ)). + assert ((NATOP (do_natop op) (e1 γ) (e2 γ)) = ((`K') (e2 γ))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ K')). rewrite (HOM_compose_ccompose κ K' sss)//. + + iSpecialize ("G" $! γ with "Hγ"). + iSpecialize ("G" $! sss). + iSpecialize ("G" with "[H] Hm Hst"). + { + iIntros (w w'). + iModIntro. + iIntros "#Hw". + iIntros (M M') "Hm Hst". + subst sss. + subst K'. + simpl. + + pose (K' := (NatOpLSCtx_HOM op (IT_of_V w) γ _)). + assert ((NATOP (do_natop op) (e1 γ) (IT_of_V w)) = ((`K') (e1 γ))) + as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ K')). rewrite (HOM_compose_ccompose κ K' sss)//. + + iSpecialize ("H" $! γ with "Hγ"). + iSpecialize ("H" $! sss). + iSpecialize ("H" with "[] Hm Hst"). + { + iIntros (v v'). + iModIntro. + iIntros "#Hv". + iIntros (m'' M'') "Hm Hst". + subst sss. + subst K'. + simpl. + + iDestruct "Hw" as "(%n & #HEQ1 & #HEQ1')". + iDestruct "Hv" as "(%n' & #HEQ2 & #HEQ2')". + iSpecialize ("Hκ" $! (RetV (do_natop op n' n)) with "[]"). + { + iExists _. + iPureIntro. + split; reflexivity. + } + iSpecialize ("Hκ" $! m'' with "Hm Hst"). + rewrite IT_of_V_Ret. + + iAssert ((NATOP (do_natop op) (IT_of_V v) (IT_of_V w)) + ≡ (Ret (do_natop op n' n)))%I as "#HEQ". + { + iRewrite "HEQ1". + rewrite IT_of_V_Ret. + iAssert ((IT_of_V v) ≡ IT_of_V (RetV n'))%I as "#HEQ2''". + { + iApply f_equivI. + iApply "HEQ2". + } + rewrite IT_of_V_Ret. + iAssert (NATOP (do_natop op) (IT_of_V v) (Ret n) + ≡ NATOP (do_natop op) (Ret n') (Ret n))%I as "#HEQ2'''". + { + unshelve iApply (f_equivI (λne x, NATOP (do_natop op) x (Ret n))). + { solve_proper. } + { solve_proper. } + iApply "HEQ2''". + } + iRewrite "HEQ2'''". + rewrite NATOP_Ret. + done. + } + iRewrite "HEQ". + iApply (wp_wand with "Hκ"). + iIntros (_) "(H1 & (%t & %nm & H2))". + iModIntro. + iFrame "H1". + iRewrite "HEQ2'". + admit. + } + iApply (wp_wand with "H"). + iIntros (_) "(H1 & (%t & %nm & H2))". + iModIntro. + iFrame "H1". + admit. + } + iApply (wp_wand with "G"). + iIntros (_) "(H1 & (%t & %nm & H2))". + iModIntro. + iFrame "H1". + admit. + Admitted. + + (* Lemma compat_app {S : Set} (Γ : S → ty) *) + (* ξ α β δ η τ e1 e2 : *) + (* ⊢ valid Γ e1 (Tarr η α τ β) ξ δ *) + (* -∗ valid Γ e2 η β ξ *) + (* -∗ valid Γ (interp_app rs e1 e2) τ α δ. *) + (* Proof. *) + (* iIntros "#H #G". *) + (* iModIntro. *) + (* iIntros (γ) "#Hγ". *) + (* iIntros (κ) "#Hκ". *) + (* iIntros (σ) "Hσ Hst". *) + (* rewrite /interp_app //=. *) + + (* pose (κ' := (AppLSCtx_HOM e2 γ)). *) + (* match goal with *) + (* | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => *) + (* set (F := b) *) + (* end. *) + (* assert (LET (e1 γ) F = ((`κ') (e1 γ))) as ->. *) + (* { simpl; unfold AppLSCtx. reflexivity. } *) + (* clear F. *) + (* assert ((`κ) ((`κ') (e1 γ)) = ((`κ) ◎ (`κ')) (e1 γ)) as ->. *) + (* { reflexivity. } *) + (* pose (sss := (HOM_compose κ κ')). *) + (* assert ((`κ ◎ `κ') = (`sss)) as ->. *) + (* { reflexivity. } *) + + (* iSpecialize ("H" $! γ with "Hγ"). *) + (* iSpecialize ("H" $! sss). *) + (* iApply ("H" with "[H] Hσ Hst"). *) + + (* iIntros (w). *) + (* iModIntro. *) + (* iIntros "#Hw". *) + (* iIntros (m') "Hm Hst". *) + (* subst sss. *) + (* subst κ'. *) + (* simpl. *) + (* rewrite LET_Val. *) + (* cbn [ofe_mor_car]. *) + + (* match goal with *) + (* | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => *) + (* set (F := b) *) + (* end. *) + (* pose (κ'' := exist _ (LETCTX F) (LETCTX_Hom F) : HOM). *) + (* assert (((`κ) (LET (e2 γ) F)) = (((`κ) ◎ (`κ'')) (e2 γ))) as ->. *) + (* { reflexivity. } *) + (* pose (sss := (HOM_compose κ κ'')). *) + (* assert ((`κ ◎ `κ'') = (`sss)) as ->. *) + (* { reflexivity. } *) + (* iSpecialize ("G" $! γ with "Hγ"). *) + (* iSpecialize ("G" $! sss). *) + (* iApply ("G" with "[H] Hm Hst"). *) + (* iIntros (v). *) + (* iModIntro. *) + (* iIntros "#Hv". *) + (* iIntros (m'') "Hm Hst". *) + (* subst sss. *) + (* subst κ''. *) + (* simpl. *) + (* rewrite LET_Val. *) + (* subst F. *) + (* cbn [ofe_mor_car]. *) + + (* iDestruct "Hw" as "(%n' & #HEQ & Hw)". *) + (* iSpecialize ("Hw" $! v with "Hv"). *) + (* iSpecialize ("Hw" $! κ with "Hκ"). *) + (* iSpecialize ("Hw" $! m'' with "Hm Hst"). *) + (* iAssert ((IT_of_V w ⊙ (IT_of_V v)) *) + (* ≡ (Fun n' ⊙ (IT_of_V v)))%I as "#HEQ'". *) + (* { *) + (* iApply (f_equivI (λne x, (x ⊙ (IT_of_V v)))). *) + (* iApply "HEQ". *) + (* } *) + (* iRewrite "HEQ'". *) + (* iApply "Hw". *) + (* Qed. *) + + (* Lemma compat_appcont {S : Set} (Γ : S -> ty) e1 e2 τ α δ β σ : *) + (* valid Γ e1 (Tcont τ α) σ δ *) + (* -∗ valid Γ e2 τ δ β *) + (* -∗ valid Γ (interp_app_cont _ e1 e2) α σ β. *) + (* Proof. *) + (* iIntros "#H #G". *) + (* iModIntro. *) + (* iIntros (γ) "#Henv". *) + (* iIntros (κ) "#Hκ". *) + (* iIntros (σ') "Hm Hst". *) + + (* pose (κ' := (AppContRSCtx_HOM e1 γ)). *) + (* assert ((interp_app_cont rs e1 e2 γ) = ((`κ') (e2 γ))) as ->. *) + (* { simpl. reflexivity. } *) + (* assert ((`κ) ((`κ') (e2 γ)) = ((`κ) ◎ (`κ')) (e2 γ)) as ->. *) + (* { reflexivity. } *) + (* pose (sss := (HOM_compose κ κ')). *) + (* assert ((`κ ◎ `κ') = (`sss)) as ->. *) + (* { reflexivity. } *) + + (* iSpecialize ("G" $! γ with "Henv"). *) + (* iSpecialize ("G" $! sss). *) + (* iApply ("G" with "[H] Hm Hst"). *) + + (* iIntros (w). *) + (* iModIntro. *) + (* iIntros "#Hw". *) + (* iIntros (m') "Hm Hst". *) + (* subst sss. *) + (* subst κ'. *) + (* Opaque interp_app_cont. *) + (* simpl. *) + + (* pose (κ'' := (AppContLSCtx_HOM (IT_of_V w) γ _)). *) + (* set (F := (`κ) _). *) + (* assert (F ≡ (((`κ) ◎ (`κ'')) (e1 γ))) as ->. *) + (* { *) + (* subst F. simpl. Transparent interp_app_cont. simpl. *) + (* f_equiv. *) + (* rewrite ->2 get_val_ITV. *) + (* simpl. *) + (* reflexivity. *) + (* } *) + (* pose (sss := (HOM_compose κ κ'')). *) + (* assert ((`κ ◎ `κ'') = (`sss)) as ->. *) + (* { reflexivity. } *) + + (* iSpecialize ("H" $! γ with "Henv"). *) + (* iSpecialize ("H" $! sss). *) + (* iApply ("H" with "[] Hm Hst"). *) + + (* iIntros (v). *) + (* iModIntro. *) + (* iIntros "#Hv". *) + (* iIntros (m'') "Hm Hst". *) + (* subst sss. *) + (* subst κ''. *) + (* Opaque APP_CONT. *) + (* simpl. *) + + (* rewrite get_val_ITV. *) + (* simpl. *) + + (* iDestruct "Hv" as "(%n' & #HEQ & #Hv)". *) + (* iRewrite "HEQ". *) + (* rewrite get_fun_fun. *) + (* simpl. *) + + (* match goal with *) + (* | |- context G [ofe_mor_car _ _ *) + (* (ofe_mor_car _ _ APP_CONT ?a) ?b] => *) + (* set (T := APP_CONT a b) *) + (* end. *) + (* iAssert (𝒫 ((`κ) T) ≡ (𝒫 ◎ (`κ)) T)%I as "HEQ'". *) + (* { iPureIntro. reflexivity. } *) + (* iRewrite "HEQ'"; iClear "HEQ'". *) + (* subst T. *) + + (* iApply (wp_app_cont with "[Hst]"). *) + (* { reflexivity. } *) + (* - iFrame "Hst". *) + (* - simpl. *) + (* iNext. *) + (* iIntros "_ Hst". *) + (* rewrite later_map_Next. *) + (* rewrite <-Tick_eq. *) + (* iApply wp_tick. *) + (* iNext. *) + (* iSpecialize ("Hv" $! w with "Hw"). *) + + (* iApply ("Hv" $! (laterO_map (𝒫 ◎ `κ) :: m'') with "[Hm] Hst"). *) + (* { *) + (* iIntros (p) "#Hp Hst". *) + (* iApply (wp_pop_cons with "Hst"). *) + (* iNext. *) + (* iIntros "_ Hst". *) + (* iApply ("Hκ" with "Hp Hm Hst"). *) + (* } *) + (* Qed. *) + + (* Lemma compat_if {S : Set} (Γ : S -> ty) e e₁ e₂ τ σ α β : *) + (* ⊢ valid Γ e Tnat β α *) + (* -∗ valid Γ e₁ τ σ β *) + (* -∗ valid Γ e₂ τ σ β *) + (* -∗ valid Γ (interp_if rs e e₁ e₂) τ σ α. *) + (* Proof. *) + (* iIntros "#H #G #J". *) + (* iModIntro. *) + (* iIntros (γ) "#Henv". *) + (* iIntros (κ) "#Hκ". *) + (* iIntros (σ') "Hm Hst". *) + (* unfold interp_if. *) + (* cbn [ofe_mor_car]. *) + (* pose (κ' := (IFSCtx_HOM (e₁ γ) (e₂ γ))). *) + (* assert ((IF (e γ) (e₁ γ) (e₂ γ)) = ((`κ') (e γ))) as -> by reflexivity. *) + (* assert ((`κ) ((`κ') (e γ)) = ((`κ) ◎ (`κ')) (e γ)) *) + (* as -> by reflexivity. *) + (* pose (sss := (HOM_compose κ κ')). *) + (* rewrite (HOM_compose_ccompose κ κ' sss)//. *) + + (* iSpecialize ("H" $! γ with "Henv"). *) + (* iSpecialize ("H" $! sss). *) + (* iApply ("H" with "[] Hm Hst"). *) + + (* iIntros (v). *) + (* iModIntro. *) + (* iIntros "#Hv". *) + (* iIntros (σ'') "Hm Hst". *) + (* iDestruct "Hv" as "(%n & #Hv)". *) + (* iRewrite "Hv". *) + (* rewrite IT_of_V_Ret. *) + (* subst sss. *) + (* subst κ'. *) + (* simpl. *) + (* unfold IFSCtx. *) + (* destruct (decide (0 < n)) as [H|H]. *) + (* - rewrite IF_True//. *) + (* iApply ("G" $! γ with "Henv [Hκ] Hm Hst"). *) + (* iIntros (w). *) + (* iModIntro. *) + (* iIntros "#Hw". *) + (* iIntros (σ''') "Hm Hst". *) + (* iApply ("Hκ" with "Hw Hm Hst"). *) + (* - rewrite IF_False//; last lia. *) + (* iApply ("J" $! γ with "Henv [Hκ] Hm Hst"). *) + (* iIntros (w). *) + (* iModIntro. *) + (* iIntros "#Hw". *) + (* iIntros (σ''') "Hm Hst". *) + (* iApply ("Hκ" with "Hw Hm Hst"). *) + (* Qed. *) + + Open Scope types. + + Lemma fundamental_expr {S : Set} (Γ : S -> ty) τ α β e : + Γ; α ⊢ₑ e : τ; β → ⊢ valid Γ (interp_expr rs e) e τ α β + with fundamental_val {S : Set} (Γ : S -> ty) τ α β v : + Γ; α ⊢ᵥ v : τ; β → ⊢ valid Γ (interp_val rs v) v τ α β. + Proof. + - intros H. + destruct H. + + by apply fundamental_val. + + subst; iApply compat_var. + + (* iApply compat_app; *) + (* by iApply fundamental_expr. *) + admit. + + (* iApply compat_appcont; *) + (* by iApply fundamental_expr. *) + admit. + + iApply compat_nat_op; + by iApply fundamental_expr. + + (* iApply compat_if; *) + (* by iApply fundamental_expr. *) + admit. + + iApply compat_shift; + by iApply fundamental_expr. + + iApply (compat_reset with "[]"); + by iApply fundamental_expr. + - intros H. + destruct H. + + iApply compat_nat. + + (* iApply (compat_recV with "[]"); *) + (* by iApply fundamental_expr. *) + admit. + Admitted. + +End logrel. + +Definition κ {S} {E} : ITV E natO → val S := λ x, + match x with + | core.RetV n => LitV n + | _ => LitV 0 + end. +Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (LitV n : val S). +Proof. + Transparent RetV. unfold RetV. simpl. done. Opaque RetV. +Qed. + +Local Definition rs : gReifiers CtxDep 1 := + gReifiers_cons reify_delim gReifiers_nil. + +Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. + +Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} + (α : IT (gReifiers_ops rs) natO) + (e : expr S) (n : nat) σ' k : + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, + (⊢ logrel rs Tnat Tnat Tnat α e)%I) → + ssteps (gReifiers_sReifier rs) (𝒫 α) ([], ()) (Ret n) σ' k → + ∃ m, steps (Cexpr e) (Cret (LitV n)) m. +Proof. + intros Hlog Hst. + pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), + ∃ m, steps (Cexpr e) (Cret $ κ βv) m). + cut (ϕ (RetV n)). + { + destruct 1 as ( m' & Hm). + exists m'. revert Hm. by rewrite κ_Ret. + } + eapply (wp_adequacy 0); eauto. + Unshelve. + 2: { + intros ?. + apply False. + } + intros Hinv1 Hst1. + pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), + ∃ n, interp_ty rs (Σ := Σ) (S := S) Tnat βv (LitV n) + ∗ ⌜∃ m, steps (Cexpr e) (Cret $ LitV n) m⌝)%I). + assert (NonExpansive Φ). + { + unfold Φ. + intros l a1 a2 Ha. repeat f_equiv. done. + } + exists Φ. split; first assumption. split. + - iIntros (βv). iDestruct 1 as (n'') "[H %]". + iDestruct "H" as (n') "[#H %]". simplify_eq/=. + iAssert (IT_of_V βv ≡ Ret n')%I as "#Hb". + { iRewrite "H". iPureIntro. by rewrite IT_of_V_Ret. } + iAssert (⌜βv = RetV n'⌝)%I with "[-]" as %Hfoo. + { destruct βv as [r|f]; simpl. + - iPoseProof (Ret_inj' with "Hb") as "%Hr". + fold_leibniz. eauto. + - iExFalso. iApply (IT_ret_fun_ne). + iApply internal_eq_sym. iExact "Hb". } + iPureIntro. rewrite Hfoo. unfold ϕ. + eauto. + - iIntros "[_ Hs]". + iPoseProof (Hlog _ _) as "Hlog". + iAssert (has_substate _)%I with "[Hs]" as "Hs". + { + unfold has_substate, has_full_state. + admit. + } + iSpecialize ("Hlog" $! HOM_id END (compat_HOM_id _ _) [] [] with "[]"). + { + iIntros (αv v) "HHH GGG". + iApply (wp_pop_end with "GGG"). + iNext. + iIntros "_ GGG". + iApply wp_val. + iModIntro. + iFrame "GGG". + iExists v, (1, 1). + iPureIntro. + eapply (steps_many _ _ _ 0 0 1 1 1 1); + [done | done | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 1 1 1 1); + [done | done | apply Ccont_end |]. + eapply (steps_many _ _ _ 1 1 0 0 1 1); + [done | done | apply Cmcont_ret |]. + constructor. + } + simpl. + unfold obs_ref'. + iSpecialize ("Hlog" with "Hs"). + iApply (wp_wand with "Hlog"). + iIntros ( βv). iIntros "H". + iDestruct "H" as "[Hi Hsts]". + subst Φ. + admit. +Admitted. + +Theorem adequacy (e : expr ∅) (k : nat) σ' n : + (typed_expr empty_env Tnat e Tnat Tnat) → + ssteps (gReifiers_sReifier rs) (𝒫 (interp_expr rs e ı_scope)) ([], ()) + (Ret k : IT _ natO) σ' n → + ∃ mm, steps (Cexpr e) (Cret $ LitV k) mm. +Proof. + intros Hty Hst. + pose (Σ := gFunctors.app invΣ (gFunctors.app (stateΣ rs natO) gFunctors.nil)). + eapply (logrel_nat_adequacy Σ (interp_expr rs e ı_scope)); last eassumption. + intros ? ?. + iPoseProof (fundamental_expr rs _ _ _ _ _ Hty) as "#H". + unfold valid. + unshelve iSpecialize ("H" $! ı_scope _ with "[]"). + { apply ı%bind. } + { iIntros (x); destruct x. } + rewrite ebind_id; first last. + { intros ?; reflexivity. } + iApply "H". +Qed. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index a4c8340..494fd16 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -159,6 +159,19 @@ Section weakestpre. now do 3 f_equiv. - reflexivity. Qed. + #[export] Instance has_substate_proper {sR : sReifier a} `{!stateG Σ} + `{!subReifier sR rs} : Proper ((≡) ==> (≡)) (has_substate). + Proof. + intros ???. + unfold has_substate. + do 2 f_equiv. + intros i. + unfold of_idx, weakestpre.of_idx. + destruct (decide (i = sR_idx)). + - subst; simpl. + now do 3 f_equiv. + - reflexivity. + Qed. #[export] Instance state_interp_ne `{!stateG Σ} : NonExpansive state_interp. Proof. solve_proper. Qed. From 9a43123ad38dbb8155fa4a68fdccdc9e036e78ac Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Fri, 7 Jun 2024 15:59:45 +0200 Subject: [PATCH 07/14] delim logrel: shift/reset, adequacy --- theories/examples/delim_lang/lang.v | 24 +++ theories/examples/delim_lang/logrel.v | 223 ++++++++++++++++---------- 2 files changed, 158 insertions(+), 89 deletions(-) diff --git a/theories/examples/delim_lang/lang.v b/theories/examples/delim_lang/lang.v index b1b5c9b..13e9b8e 100644 --- a/theories/examples/delim_lang/lang.v +++ b/theories/examples/delim_lang/lang.v @@ -488,6 +488,30 @@ Inductive steps {S} : config S (* * state S *) -> config S (* * state S *) -> steps c2 c3 (n', m') -> steps c1 c3 (n'', m''). +Definition stepEx {S} : config S → config S → Prop := + λ a b, ∃ nm, Cred a b nm. + +Definition stepsEx {S} : config S → config S → Prop := + λ a b, ∃ nm, steps a b nm. + +Lemma stepsExNow {S} : ∀ (a : config S), stepsEx a a. +Proof. + intros a. + exists (0, 0). + constructor. +Qed. + +Lemma stepsExCons {S} (a b c : config S) : + stepEx a b → stepsEx b c → stepsEx a c. +Proof. + intros [[n m] H] [[n' m'] G]. + exists (n + n', m + m'). + econstructor; + [reflexivity | reflexivity | |]. + - apply H. + - apply G. +Qed. + Definition meta_fill {S} (mk : Mcont S) e := fold_left (λ e k, fill k e) mk e. diff --git a/theories/examples/delim_lang/logrel.v b/theories/examples/delim_lang/logrel.v index 2110b0a..49bdeb8 100644 --- a/theories/examples/delim_lang/logrel.v +++ b/theories/examples/delim_lang/logrel.v @@ -151,8 +151,9 @@ Section logrel. : iProp := (has_substate σ -∗ WP (𝒫 (`κ t)) {{ βv, has_substate [] - ∗ ∃ (v : valO S) (nm : nat * nat), - ⌜steps (Ceval e k m) (Cret v) nm⌝ }})%I. + ∗ ∃ (v : valO S), + ⌜∃ (nm : nat * nat), steps (Ceval e k m) (Cret v) nm⌝ + ∗ logrel_nat βv v }})%I. Local Instance obs_ref_ne {S : Set} : ∀ n, Proper (dist n ==> dist n ==> dist n ==> dist n ==> dist n ==> dist n ==> dist n) @@ -263,7 +264,7 @@ Section logrel. intros; intros ????????; simpl. solve_proper. Qed. - + Fixpoint interp_ty {S : Set} (τ : ty) : ITV -n> valO S -n> iProp := match τ with | Tnat => logrel_nat @@ -294,8 +295,8 @@ Section logrel. do 2 (f_equiv; intro; simpl). f_equiv. solve_proper. - Qed. - + Qed. + Definition logrel {S : Set} (τ α β : ty) : IT -n> exprO S -n> iProp := logrel_expr (interp_ty τ) (interp_ty α) (interp_ty β). @@ -312,57 +313,6 @@ Section logrel. (□ ∀ γ (γ' : S [⇒] Empty_set), ssubst_valid Γ γ γ' -∗ @logrel Empty_set τ α σ (e γ) (bind (F := expr) γ' e'))%I. - (* Lemma compat_empty {S : Set} P : *) - (* ⊢ @logrel_mcont S P [] []. *) - (* Proof. *) - (* iIntros (v v') "Pv HH". *) - (* iApply (wp_pop_end with "HH"). *) - (* iNext. *) - (* iIntros "_ HHH". *) - (* iApply wp_val. *) - (* iModIntro. *) - (* iFrame "HHH". *) - (* iExists v'. *) - (* iExists (1, 1). *) - (* iPureIntro. *) - (* eapply (steps_many _ _ _ 0 0 1 1 1 1); *) - (* [done | done | apply Ceval_val |]. *) - (* eapply (steps_many _ _ _ 0 0 1 1 1 1); *) - (* [done | done | apply Ccont_end |]. *) - (* eapply (steps_many _ _ _ 1 1 0 0 1 1); *) - (* [done | done | apply Cmcont_ret |]. *) - (* constructor. *) - (* Qed. *) - - (* Lemma compat_cons {S : Set} P Q (x : HOM) (x' : contO S) *) - (* (xs : list (later IT -n> later IT)) xs' : *) - (* ⊢ logrel_ectx P Q x x' *) - (* -∗ logrel_mcont Q xs xs' *) - (* -∗ logrel_mcont P (laterO_map (𝒫 ◎ `x) :: xs) (x' :: xs'). *) - (* Proof. *) - (* iIntros "#H G". *) - (* iIntros (v v') "Hv Hst". *) - (* iApply (wp_pop_cons with "Hst"). *) - (* iNext. *) - (* iIntros "_ Hst". *) - (* iSpecialize ("H" $! v with "Hv"). *) - (* iSpecialize ("H" $! xs xs' with "G Hst"). *) - (* iApply (wp_wand with "H"). *) - (* iIntros (_) "(H1 & (%w & %nm & %H2))". *) - (* destruct nm as [n m]. *) - (* iModIntro. *) - (* iFrame "H1". *) - (* iExists w, (n, m). *) - (* iPureIntro. *) - (* eapply (steps_many _ _ _ 0 0 n m n m); *) - (* [done | done | apply Ceval_val |]. *) - (* eapply (steps_many _ _ _ 0 0 n m n m); *) - (* [done | done | apply Ccont_end |]. *) - (* eapply (steps_many _ _ _ 1 1 0 0 1 1); *) - (* [done | done | apply Cmcont_ret |]. *) - (* constructor. *) - (* Qed. *) - Lemma compat_HOM_id {S : Set} P : ⊢ @logrel_ectx S P P HOM_id END. Proof. @@ -394,6 +344,43 @@ Section logrel. iApply ("Hss" with "HE HF Hσ"). Qed. + Lemma step_pack {S : Set} (a b : config S) : + ∀ nm, Cred a b nm → stepEx a b. + Proof. + intros nm H. + by exists nm. + Qed. + + Lemma steps_pack {S : Set} (a b : config S) : + ∀ nm, steps a b nm → stepsEx a b. + Proof. + intros nm H. + by exists nm. + Qed. + + Lemma step_det {S : Set} (c c' c'' : config S) + : stepEx c c' → stepEx c c'' → c' = c''. + Proof. + intros [nm H]. + revert c''. + inversion H; subst; intros c'' [nm' G]; + inversion G; subst; simplify_eq; reflexivity. + Qed. + + Lemma steps_det_val {S : Set} (c c' : config S) (v : val S) + : stepsEx c (Cret v) → stepEx c c' → stepsEx c' (Cret v). + Proof. + intros [n H]. + revert c'. + inversion H; subst; intros c' G. + - destruct G as [? G]. + inversion G. + - erewrite (step_det c c' c2). + + by eapply steps_pack. + + assumption. + + by eapply step_pack. + Qed. + Lemma compat_reset {S : Set} (Γ : S -> ty) e (e' : exprO S) σ τ : ⊢ valid Γ e e' σ σ τ -∗ (∀ α, valid Γ (interp_reset rs e) (reset e') τ α α). Proof. @@ -424,26 +411,38 @@ Section logrel. iSpecialize ("Hκ" $! m with "Hm"). iSpecialize ("Hκ" with "Hst"). iApply (wp_wand with "Hκ"). - iIntros (_) "(H1 & (%w & %nm & %H2))". + iIntros (?) "(H1 & (%w & %H2 & #H3))". iModIntro. iFrame "H1". - iExists w, nm. + iExists w. + iFrame "H3". iPureIntro. - admit. + edestruct (steps_det_val _ (Ccont κ' v' m') _ H2) as [[a b] H]; + first eapply step_pack; first econstructor. + exists (a + 1, b + 1)%nat. + eapply (steps_many _ _ _ 0 0 (a + 1)%nat (b + 1)%nat _ _); + [ reflexivity | reflexivity | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 (a + 1)%nat (b + 1)%nat _ _); + [ lia | lia | apply Ccont_end |]. + eapply (steps_many _ _ _ 1 1 a b (a + 1)%nat (b + 1)%nat); + [ lia | lia | apply Cmcont_cont |]. + apply H. } iSpecialize ("H" with "Hm Hst"). iApply (wp_wand with "H"). - iIntros (_) "(H1 & (%w & %nm & %H2))". - destruct nm as [a b]. + iIntros (?) "(H1 & (%w & %H2 & #H3))". + destruct H2 as [[a b] H2]. iModIntro. iFrame "H1". - iExists w, ((a + 1)%nat, (b + 1)%nat). + iExists w. + iFrame "H3". iPureIntro. + exists ((a + 1)%nat, (b + 1)%nat). term_simpl. eapply (steps_many _ _ _ 1 1 a b (a + 1)%nat (b + 1)%nat); [ lia | lia | apply Ceval_reset |]. assumption. - Admitted. + Qed. Program Definition 𝒫_HOM : @HOM sz CtxDep R _ rs := exist _ 𝒫 _. Next Obligation. @@ -497,17 +496,28 @@ Section logrel. iSpecialize ("H" $! γ_ with "Hγ'"). iSpecialize ("H" $! HOM_id END (compat_HOM_id _) m with "Hm Hst"). iApply (wp_wand with "H"). - iIntros (_) "(H1 & (%w & %nm & %H2))". - destruct nm as [a b]. + iIntros (?) "(H1 & (%w & %H2 & #H3))". + destruct H2 as [[a b] H2]. iModIntro. iFrame "H1". - iExists w, ((a + 1)%nat, (b + 1)%nat). + iExists w. + iFrame "H3". iPureIntro. + exists ((a + 1)%nat, (b + 1)%nat). term_simpl. eapply (steps_many _ _ _ 1 1 a b (a + 1)%nat (b + 1)%nat); [ lia | lia | apply Ceval_shift |]. subst γ_'. - Admitted. + match goal with + | H2 : ?G |- ?H => + assert (H = G) as -> + end; last done. + do 2 f_equal. + unfold subst. + erewrite bind_bind_comp; + first reflexivity. + reflexivity. + Qed. Lemma compat_nat {S : Set} (Γ : S → ty) n α : ⊢ valid Γ (interp_nat rs n) (LitV n) Tnat α α. @@ -692,8 +702,8 @@ Section logrel. pose (sss := (HOM_compose κ K')). rewrite (HOM_compose_ccompose κ K' sss)//. iSpecialize ("G" $! γ with "Hγ"). - iSpecialize ("G" $! sss). - iSpecialize ("G" with "[H] Hm Hst"). + iSpecialize ("G" $! sss). + iSpecialize ("G" $! (NatOpRK op (bind (F := expr) (BindCore := BindCore_expr) γ' e1' : exprO Empty_set) κ') with "[H] Hm Hst"). { iIntros (w w'). iModIntro. @@ -711,7 +721,7 @@ Section logrel. iSpecialize ("H" $! γ with "Hγ"). iSpecialize ("H" $! sss). - iSpecialize ("H" with "[] Hm Hst"). + iSpecialize ("H" $! (NatOpLK op w' END) with "[] Hm Hst"). { iIntros (v v'). iModIntro. @@ -757,20 +767,20 @@ Section logrel. } iRewrite "HEQ". iApply (wp_wand with "Hκ"). - iIntros (_) "(H1 & (%t & %nm & H2))". + iIntros (?) "(H1 & (%t & %H2 & #H3))". iModIntro. iFrame "H1". iRewrite "HEQ2'". admit. } iApply (wp_wand with "H"). - iIntros (_) "(H1 & (%t & %nm & H2))". + iIntros (?) "(H1 & (%t & %H2 & #H3))". iModIntro. iFrame "H1". admit. } iApply (wp_wand with "G"). - iIntros (_) "(H1 & (%t & %nm & H2))". + iIntros (?) "(H1 & (%t & %H2 & #H3))". iModIntro. iFrame "H1". admit. @@ -1083,14 +1093,15 @@ Proof. intros Hinv1 Hst1. pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), ∃ n, interp_ty rs (Σ := Σ) (S := S) Tnat βv (LitV n) - ∗ ⌜∃ m, steps (Cexpr e) (Cret $ LitV n) m⌝)%I). + ∗ ⌜∃ m, steps (Cexpr e) (Cret $ LitV n) m⌝ + ∗ logrel_nat rs (Σ := Σ) (S := S) βv (LitV n))%I). assert (NonExpansive Φ). { unfold Φ. - intros l a1 a2 Ha. repeat f_equiv. done. + intros l a1 a2 Ha. repeat f_equiv; done. } exists Φ. split; first assumption. split. - - iIntros (βv). iDestruct 1 as (n'') "[H %]". + - iIntros (βv). iDestruct 1 as (n'') "(H & %H' & #H'')". iDestruct "H" as (n') "[#H %]". simplify_eq/=. iAssert (IT_of_V βv ≡ Ret n')%I as "#Hb". { iRewrite "H". iPureIntro. by rewrite IT_of_V_Ret. } @@ -1107,9 +1118,23 @@ Proof. iAssert (has_substate _)%I with "[Hs]" as "Hs". { unfold has_substate, has_full_state. - admit. + eassert (of_state rs (IT (gReifiers_ops rs) _) (_,()) + ≡ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state _)) as -> + ; last done. + intro j. unfold sR_idx. simpl. + unfold of_state, of_idx. + destruct decide as [Heq|]; last first. + { inv_fin j; first done. + intros i. inversion i. } + inv_fin j; last done. + intros Heq. + rewrite (eq_pi _ _ Heq eq_refl)//. + simpl. + unfold iso_ofe_refl. + cbn. + reflexivity. } - iSpecialize ("Hlog" $! HOM_id END (compat_HOM_id _ _) [] [] with "[]"). + iSpecialize ("Hlog" $! HOM_id END (compat_HOM_id _ _) [] [] with "[]"). { iIntros (αv v) "HHH GGG". iApply (wp_pop_end with "GGG"). @@ -1118,15 +1143,18 @@ Proof. iApply wp_val. iModIntro. iFrame "GGG". - iExists v, (1, 1). - iPureIntro. - eapply (steps_many _ _ _ 0 0 1 1 1 1); - [done | done | apply Ceval_val |]. - eapply (steps_many _ _ _ 0 0 1 1 1 1); - [done | done | apply Ccont_end |]. - eapply (steps_many _ _ _ 1 1 0 0 1 1); - [done | done | apply Cmcont_ret |]. - constructor. + iExists v. + iSplitR "HHH". + - iPureIntro. + exists (1, 1). + eapply (steps_many _ _ _ 0 0 1 1 1 1); + [done | done | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 1 1 1 1); + [done | done | apply Ccont_end |]. + eapply (steps_many _ _ _ 1 1 0 0 1 1); + [done | done | apply Cmcont_ret |]. + constructor. + - iApply "HHH". } simpl. unfold obs_ref'. @@ -1135,8 +1163,25 @@ Proof. iIntros ( βv). iIntros "H". iDestruct "H" as "[Hi Hsts]". subst Φ. - admit. -Admitted. + iModIntro. + iDestruct "Hsts" as "(%w & %p & Hsts)". + iDestruct "Hsts" as "(%w' & #HEQ1 & #HEQ2)". + iExists w'. + iSplit. + + iExists _. + iSplit; done. + + iSplit. + * iRewrite - "HEQ2". + iPureIntro. + destruct p as [nm p]. + exists nm. + destruct nm as [a b]. + eapply (steps_many _ _ _ 0 0 a b a b); + [done | done | apply Ceval_init |]. + done. + * iExists _. + iSplit; done. +Qed. Theorem adequacy (e : expr ∅) (k : nat) σ' n : (typed_expr empty_env Tnat e Tnat Tnat) → From a13988582d000f8f3f70543958ee16c74a66cd53 Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Tue, 11 Jun 2024 16:49:25 +0200 Subject: [PATCH 08/14] adequacy --- theories/examples/delim_lang/logrel.v | 890 +++++++++++++++++--------- 1 file changed, 578 insertions(+), 312 deletions(-) diff --git a/theories/examples/delim_lang/logrel.v b/theories/examples/delim_lang/logrel.v index 49bdeb8..5e939b7 100644 --- a/theories/examples/delim_lang/logrel.v +++ b/theories/examples/delim_lang/logrel.v @@ -232,6 +232,7 @@ Section logrel. (Pτ Pα Pσ Pβ : ITV -n> valO S -n> iProp) (f : ITV) (vf : valO S) : iProp := (∃ f', IT_of_V f ≡ Fun f' + ∧ ⌜(∃ f'', vf = RecV f'')⌝ ∧ □ ∀ (βv : ITV) (v : valO S), Pτ βv v -∗ ∀ (κ : HOM) (K : cont S), logrel_ectx Pσ Pα κ K -∗ ∀ σ m, @@ -530,65 +531,124 @@ Section logrel. by iExists n. Qed. - (* Lemma compat_recV {S : Set} (Γ : S -> ty) *) - (* τ1 α τ2 β e (e' : expr (inc (inc S))) : *) - (* ⊢ valid ((Γ ▹ (Tarr τ1 α τ2 β) ▹ τ1)) e e' τ2 α β *) - (* -∗ (∀ θ, valid Γ (interp_rec rs e) (RecV e') (Tarr τ1 α τ2 β) θ θ). *) - (* Proof. *) - (* iIntros "#H". *) - (* iIntros (θ). *) - (* iModIntro. *) - (* iIntros (γ γ') "#Hγ". *) - (* set (f := (ir_unf rs e γ)). *) - (* iAssert (interp_rec rs e γ ≡ IT_of_V $ FunV (Next f))%I as "Hf". *) - (* { iPureIntro. apply interp_rec_unfold. } *) - (* iRewrite "Hf". *) - (* Opaque IT_of_V. *) - (* iApply logrel_of_val; term_simpl. *) - (* iExists _. iSplit. *) - (* { iPureIntro. apply into_val. } *) - (* iModIntro. *) - (* iLöb as "IH". *) - (* iIntros (v) "#Hw". *) - (* iIntros (κ) "#Hκ". *) - (* iIntros (σ) "Hσ Hst". *) - (* rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. *) - (* pose (γ' := *) - (* (extend_scope (extend_scope γ (interp_rec rs e γ)) (IT_of_V v))). *) - (* rewrite /logrel. *) - (* Opaque extend_scope. *) - (* simpl. *) - (* rewrite hom_tick. *) - (* rewrite hom_tick. *) - (* iApply wp_tick. *) - (* iNext. *) - (* iSpecialize ("H" $! γ' with "[Hw]"). *) - (* { *) - (* iIntros (x). *) - (* destruct x as [| [| x]]; iIntros (ξ); iModIntro. *) - (* * iApply logrel_of_val. *) - (* iApply "Hw". *) - (* * iIntros (κ') "Hκ'". *) - (* iIntros (σ') "Hσ' Hst". *) - (* Transparent extend_scope. *) - (* simpl. *) - (* iRewrite "Hf". *) - (* iSpecialize ("Hκ'" $! (FunV (Next f)) with "[IH]"). *) - (* { *) - (* iExists (Next f). *) - (* iSplit; first done. *) - (* iModIntro. *) - (* iIntros (βv) "Hβv". *) - (* iIntros (κ'') "Hκ''". *) - (* iIntros (σ'') "Hσ'' Hst". *) - (* iApply ("IH" $! βv with "Hβv Hκ'' Hσ'' Hst"). *) - (* } *) - (* iApply ("Hκ'" $! σ' with "Hσ' Hst"). *) - (* * iApply "Hγ". *) - (* } *) - (* subst γ'. *) - (* iApply ("H" with "Hκ Hσ Hst"). *) - (* Qed. *) + Lemma compat_recV {S : Set} (Γ : S -> ty) + τ1 α τ2 β e (e' : expr (inc (inc S))) : + ⊢ valid ((Γ ▹ (Tarr τ1 α τ2 β) ▹ τ1)) e e' τ2 α β + -∗ (∀ θ, valid Γ (interp_rec rs e) (RecV e') (Tarr τ1 α τ2 β) θ θ). + Proof. + iIntros "#H". + iIntros (θ). + iModIntro. + iIntros (γ γ') "#Hγ". + set (f := (ir_unf rs e γ)). + iAssert (interp_rec rs e γ ≡ IT_of_V $ FunV (Next f))%I as "Hf". + { iPureIntro. apply interp_rec_unfold. } + iAssert (logrel (Tarr τ1 α τ2 β) θ θ (interp_rec rs e γ) + (bind (F := expr) γ' (rec e')) + ≡ logrel (Tarr τ1 α τ2 β) θ θ (IT_of_V (FunV (Next f))) + (bind (F := expr) γ' (rec e')))%I as "Hf'". + { + iPureIntro. + do 2 f_equiv. + apply interp_rec_unfold. + } + iRewrite "Hf'". + Opaque IT_of_V. + iApply logrel_of_val; term_simpl. + iExists _. iSplit. + { iPureIntro. apply into_val. } + iSplit. + { iPureIntro. + eexists _. + reflexivity. + } + iModIntro. + iLöb as "IH". + iIntros (v v') "#Hw". + iIntros (κ κ') "#Hκ". + iIntros (σ σ') "Hσ Hst". + rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. + pose (γ'' := + (extend_scope (extend_scope γ (interp_rec rs e γ)) (IT_of_V v))). + rewrite /logrel. + Opaque extend_scope. + simpl. + rewrite hom_tick. + rewrite hom_tick. + iApply wp_tick. + iNext. + set (γ_' := ((mk_subst (Val (rec bind ((γ' ↑) ↑)%bind e')%syn)) + ∘ ((mk_subst (shift (Val v'))) ∘ ((γ' ↑) ↑)))%bind). + iSpecialize ("H" $! γ'' γ_' with "[Hw]"). + { + iIntros (x). + destruct x as [| [| x]]; iIntros (ξ); iModIntro. + * subst γ''. + iApply logrel_of_val. + term_simpl. + rewrite subst_shift_id. + iApply "Hw". + * iIntros (K' K'') "Hκ'". + iIntros (M' σ'') "Hσ' Hst". + Transparent extend_scope. + simpl. + iRewrite "Hf". + iSpecialize ("Hκ'" $! (FunV (Next f)) (bind (BindCore := BindCore_val) γ' (RecV e')) with "[IH]"). + { + iExists (Next f). + iSplit; first done. + iSplit. + { + iPureIntro. + eexists (bind (F := expr) (lift (G := inc) (lift γ'))%bind e'). + term_simpl. + reflexivity. + } + iModIntro. + iIntros (βv v'') "Hβv". + iIntros (κ'' P'') "Hκ''". + iIntros (σ''' M'') "Hσ'' Hst". + iApply ("IH" $! βv with "Hβv Hκ'' Hσ'' Hst"). + } + iApply ("Hκ'" with "Hσ' Hst"). + * subst γ_'. + term_simpl. + iApply "Hγ". + } + subst γ_'. + iSpecialize ("H" with "Hκ Hσ Hst"). + iApply (wp_wand with "H"). + iIntros (?) "(? & HHH)". + iModIntro. + iFrame. + iDestruct "HHH" as "(%v1 & %HHH & #GGG)". + iExists v1. + iFrame "GGG". + iPureIntro. + destruct HHH as [nm HHH]. + destruct nm as [a b]. + exists (a + 1, b)%nat. + eapply (steps_many _ _ _ 0 0 (a + 1)%nat b _ _); + [ reflexivity | reflexivity | apply Ceval_app |]. + eapply (steps_many _ _ _ 0 0 (a + 1)%nat b _ _); + [ reflexivity | reflexivity | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 (a + 1)%nat b _ _); + [ lia | lia | apply Ccont_appl |]. + eapply (steps_many _ _ _ 0 0 (a + 1)%nat b _ _); + [ reflexivity | reflexivity | apply Ceval_val |]. + eapply (steps_many _ _ _ 1 0 a b (a + 1)%nat b); + [ lia | lia | apply Ccont_appr |]. + unfold subst. + rewrite !bind_bind_comp'. + match goal with + | HHH : ?T |- ?Q => + assert (Q = T) as -> + end; last done. + do 2 f_equal. + fold_bind. + rewrite -!bind_bind_comp'. + reflexivity. + Qed. Program Definition AppContRSCtx_HOM {S : Set} (α : @interp_scope F R _ S -n> IT) @@ -721,7 +781,7 @@ Section logrel. iSpecialize ("H" $! γ with "Hγ"). iSpecialize ("H" $! sss). - iSpecialize ("H" $! (NatOpLK op w' END) with "[] Hm Hst"). + iSpecialize ("H" $! (NatOpLK op w' κ') with "[] Hm Hst"). { iIntros (v v'). iModIntro. @@ -771,251 +831,461 @@ Section logrel. iModIntro. iFrame "H1". iRewrite "HEQ2'". - admit. + iRewrite "HEQ1'". + iExists t. + iFrame "H3". + iPureIntro. + destruct H2 as [nm H2]. + destruct nm as [a b]. + exists (a, b). + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 a b _ _); + [ lia | lia | apply Ccont_natopl |]. + - reflexivity. + - apply H2. } iApply (wp_wand with "H"). iIntros (?) "(H1 & (%t & %H2 & #H3))". iModIntro. iFrame "H1". - admit. + iExists t. + iFrame "H3". + iPureIntro. + destruct H2 as [nm H2]. + destruct nm as [a b]. + exists (a, b). + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 a b _ _); + [ lia | lia | apply Ccont_natopr |]. + assumption. } iApply (wp_wand with "G"). iIntros (?) "(H1 & (%t & %H2 & #H3))". iModIntro. iFrame "H1". - admit. - Admitted. - - (* Lemma compat_app {S : Set} (Γ : S → ty) *) - (* ξ α β δ η τ e1 e2 : *) - (* ⊢ valid Γ e1 (Tarr η α τ β) ξ δ *) - (* -∗ valid Γ e2 η β ξ *) - (* -∗ valid Γ (interp_app rs e1 e2) τ α δ. *) - (* Proof. *) - (* iIntros "#H #G". *) - (* iModIntro. *) - (* iIntros (γ) "#Hγ". *) - (* iIntros (κ) "#Hκ". *) - (* iIntros (σ) "Hσ Hst". *) - (* rewrite /interp_app //=. *) - - (* pose (κ' := (AppLSCtx_HOM e2 γ)). *) - (* match goal with *) - (* | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => *) - (* set (F := b) *) - (* end. *) - (* assert (LET (e1 γ) F = ((`κ') (e1 γ))) as ->. *) - (* { simpl; unfold AppLSCtx. reflexivity. } *) - (* clear F. *) - (* assert ((`κ) ((`κ') (e1 γ)) = ((`κ) ◎ (`κ')) (e1 γ)) as ->. *) - (* { reflexivity. } *) - (* pose (sss := (HOM_compose κ κ')). *) - (* assert ((`κ ◎ `κ') = (`sss)) as ->. *) - (* { reflexivity. } *) - - (* iSpecialize ("H" $! γ with "Hγ"). *) - (* iSpecialize ("H" $! sss). *) - (* iApply ("H" with "[H] Hσ Hst"). *) - - (* iIntros (w). *) - (* iModIntro. *) - (* iIntros "#Hw". *) - (* iIntros (m') "Hm Hst". *) - (* subst sss. *) - (* subst κ'. *) - (* simpl. *) - (* rewrite LET_Val. *) - (* cbn [ofe_mor_car]. *) - - (* match goal with *) - (* | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => *) - (* set (F := b) *) - (* end. *) - (* pose (κ'' := exist _ (LETCTX F) (LETCTX_Hom F) : HOM). *) - (* assert (((`κ) (LET (e2 γ) F)) = (((`κ) ◎ (`κ'')) (e2 γ))) as ->. *) - (* { reflexivity. } *) - (* pose (sss := (HOM_compose κ κ'')). *) - (* assert ((`κ ◎ `κ'') = (`sss)) as ->. *) - (* { reflexivity. } *) - (* iSpecialize ("G" $! γ with "Hγ"). *) - (* iSpecialize ("G" $! sss). *) - (* iApply ("G" with "[H] Hm Hst"). *) - (* iIntros (v). *) - (* iModIntro. *) - (* iIntros "#Hv". *) - (* iIntros (m'') "Hm Hst". *) - (* subst sss. *) - (* subst κ''. *) - (* simpl. *) - (* rewrite LET_Val. *) - (* subst F. *) - (* cbn [ofe_mor_car]. *) - - (* iDestruct "Hw" as "(%n' & #HEQ & Hw)". *) - (* iSpecialize ("Hw" $! v with "Hv"). *) - (* iSpecialize ("Hw" $! κ with "Hκ"). *) - (* iSpecialize ("Hw" $! m'' with "Hm Hst"). *) - (* iAssert ((IT_of_V w ⊙ (IT_of_V v)) *) - (* ≡ (Fun n' ⊙ (IT_of_V v)))%I as "#HEQ'". *) - (* { *) - (* iApply (f_equivI (λne x, (x ⊙ (IT_of_V v)))). *) - (* iApply "HEQ". *) - (* } *) - (* iRewrite "HEQ'". *) - (* iApply "Hw". *) - (* Qed. *) - - (* Lemma compat_appcont {S : Set} (Γ : S -> ty) e1 e2 τ α δ β σ : *) - (* valid Γ e1 (Tcont τ α) σ δ *) - (* -∗ valid Γ e2 τ δ β *) - (* -∗ valid Γ (interp_app_cont _ e1 e2) α σ β. *) - (* Proof. *) - (* iIntros "#H #G". *) - (* iModIntro. *) - (* iIntros (γ) "#Henv". *) - (* iIntros (κ) "#Hκ". *) - (* iIntros (σ') "Hm Hst". *) - - (* pose (κ' := (AppContRSCtx_HOM e1 γ)). *) - (* assert ((interp_app_cont rs e1 e2 γ) = ((`κ') (e2 γ))) as ->. *) - (* { simpl. reflexivity. } *) - (* assert ((`κ) ((`κ') (e2 γ)) = ((`κ) ◎ (`κ')) (e2 γ)) as ->. *) - (* { reflexivity. } *) - (* pose (sss := (HOM_compose κ κ')). *) - (* assert ((`κ ◎ `κ') = (`sss)) as ->. *) - (* { reflexivity. } *) - - (* iSpecialize ("G" $! γ with "Henv"). *) - (* iSpecialize ("G" $! sss). *) - (* iApply ("G" with "[H] Hm Hst"). *) - - (* iIntros (w). *) - (* iModIntro. *) - (* iIntros "#Hw". *) - (* iIntros (m') "Hm Hst". *) - (* subst sss. *) - (* subst κ'. *) - (* Opaque interp_app_cont. *) - (* simpl. *) - - (* pose (κ'' := (AppContLSCtx_HOM (IT_of_V w) γ _)). *) - (* set (F := (`κ) _). *) - (* assert (F ≡ (((`κ) ◎ (`κ'')) (e1 γ))) as ->. *) - (* { *) - (* subst F. simpl. Transparent interp_app_cont. simpl. *) - (* f_equiv. *) - (* rewrite ->2 get_val_ITV. *) - (* simpl. *) - (* reflexivity. *) - (* } *) - (* pose (sss := (HOM_compose κ κ'')). *) - (* assert ((`κ ◎ `κ'') = (`sss)) as ->. *) - (* { reflexivity. } *) - - (* iSpecialize ("H" $! γ with "Henv"). *) - (* iSpecialize ("H" $! sss). *) - (* iApply ("H" with "[] Hm Hst"). *) - - (* iIntros (v). *) - (* iModIntro. *) - (* iIntros "#Hv". *) - (* iIntros (m'') "Hm Hst". *) - (* subst sss. *) - (* subst κ''. *) - (* Opaque APP_CONT. *) - (* simpl. *) - - (* rewrite get_val_ITV. *) - (* simpl. *) - - (* iDestruct "Hv" as "(%n' & #HEQ & #Hv)". *) - (* iRewrite "HEQ". *) - (* rewrite get_fun_fun. *) - (* simpl. *) - - (* match goal with *) - (* | |- context G [ofe_mor_car _ _ *) - (* (ofe_mor_car _ _ APP_CONT ?a) ?b] => *) - (* set (T := APP_CONT a b) *) - (* end. *) - (* iAssert (𝒫 ((`κ) T) ≡ (𝒫 ◎ (`κ)) T)%I as "HEQ'". *) - (* { iPureIntro. reflexivity. } *) - (* iRewrite "HEQ'"; iClear "HEQ'". *) - (* subst T. *) - - (* iApply (wp_app_cont with "[Hst]"). *) - (* { reflexivity. } *) - (* - iFrame "Hst". *) - (* - simpl. *) - (* iNext. *) - (* iIntros "_ Hst". *) - (* rewrite later_map_Next. *) - (* rewrite <-Tick_eq. *) - (* iApply wp_tick. *) - (* iNext. *) - (* iSpecialize ("Hv" $! w with "Hw"). *) - - (* iApply ("Hv" $! (laterO_map (𝒫 ◎ `κ) :: m'') with "[Hm] Hst"). *) - (* { *) - (* iIntros (p) "#Hp Hst". *) - (* iApply (wp_pop_cons with "Hst"). *) - (* iNext. *) - (* iIntros "_ Hst". *) - (* iApply ("Hκ" with "Hp Hm Hst"). *) - (* } *) - (* Qed. *) - - (* Lemma compat_if {S : Set} (Γ : S -> ty) e e₁ e₂ τ σ α β : *) - (* ⊢ valid Γ e Tnat β α *) - (* -∗ valid Γ e₁ τ σ β *) - (* -∗ valid Γ e₂ τ σ β *) - (* -∗ valid Γ (interp_if rs e e₁ e₂) τ σ α. *) - (* Proof. *) - (* iIntros "#H #G #J". *) - (* iModIntro. *) - (* iIntros (γ) "#Henv". *) - (* iIntros (κ) "#Hκ". *) - (* iIntros (σ') "Hm Hst". *) - (* unfold interp_if. *) - (* cbn [ofe_mor_car]. *) - (* pose (κ' := (IFSCtx_HOM (e₁ γ) (e₂ γ))). *) - (* assert ((IF (e γ) (e₁ γ) (e₂ γ)) = ((`κ') (e γ))) as -> by reflexivity. *) - (* assert ((`κ) ((`κ') (e γ)) = ((`κ) ◎ (`κ')) (e γ)) *) - (* as -> by reflexivity. *) - (* pose (sss := (HOM_compose κ κ')). *) - (* rewrite (HOM_compose_ccompose κ κ' sss)//. *) - - (* iSpecialize ("H" $! γ with "Henv"). *) - (* iSpecialize ("H" $! sss). *) - (* iApply ("H" with "[] Hm Hst"). *) - - (* iIntros (v). *) - (* iModIntro. *) - (* iIntros "#Hv". *) - (* iIntros (σ'') "Hm Hst". *) - (* iDestruct "Hv" as "(%n & #Hv)". *) - (* iRewrite "Hv". *) - (* rewrite IT_of_V_Ret. *) - (* subst sss. *) - (* subst κ'. *) - (* simpl. *) - (* unfold IFSCtx. *) - (* destruct (decide (0 < n)) as [H|H]. *) - (* - rewrite IF_True//. *) - (* iApply ("G" $! γ with "Henv [Hκ] Hm Hst"). *) - (* iIntros (w). *) - (* iModIntro. *) - (* iIntros "#Hw". *) - (* iIntros (σ''') "Hm Hst". *) - (* iApply ("Hκ" with "Hw Hm Hst"). *) - (* - rewrite IF_False//; last lia. *) - (* iApply ("J" $! γ with "Henv [Hκ] Hm Hst"). *) - (* iIntros (w). *) - (* iModIntro. *) - (* iIntros "#Hw". *) - (* iIntros (σ''') "Hm Hst". *) - (* iApply ("Hκ" with "Hw Hm Hst"). *) - (* Qed. *) + iExists t. + iFrame "H3". + iPureIntro. + destruct H2 as [nm H2]. + destruct nm as [a b]. + exists (a, b). + term_simpl. + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ceval_natop |]. + assumption. + Qed. + + Lemma compat_app {S : Set} (Γ : S → ty) + ξ α β δ η τ e1 e2 (e1' e2' : expr S) : + ⊢ valid Γ e1 e1' (Tarr η α τ β) ξ δ + -∗ valid Γ e2 e2' η β ξ + -∗ valid Γ (interp_app rs e1 e2) (e1' e2') τ α δ. + Proof. + iIntros "#H #G". + iModIntro. + iIntros (γ γ') "#Hγ". + iIntros (κ κ') "#Hκ". + iIntros (σ σ') "Hσ Hst". + rewrite /interp_app //=. + + pose (K' := (AppLSCtx_HOM e2 γ)). + match goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => + set (F := b) + end. + assert (LET (e1 γ) F = ((`K') (e1 γ))) as ->. + { simpl; unfold AppLSCtx. reflexivity. } + clear F. + assert ((`κ) ((`K') (e1 γ)) = ((`κ) ◎ (`K')) (e1 γ)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ K')). + assert ((`κ ◎ `K') = (`sss)) as ->. + { reflexivity. } + + iSpecialize ("H" $! γ with "Hγ"). + iSpecialize ("H" $! sss). + iSpecialize ("H" $! (AppLK (bind (F := expr) γ' e2') κ') with "[] Hσ Hst"). + { + iIntros (w w'). + iModIntro. + iIntros "#Hw". + iIntros (m' M') "Hm Hst". + subst sss. + subst K'. + simpl. + rewrite LET_Val. + cbn [ofe_mor_car]. + match goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => + set (F := b) + end. + pose (κ'' := exist _ (LETCTX F) (LETCTX_Hom F) : HOM). + assert (((`κ) (LET (e2 γ) F)) = (((`κ) ◎ (`κ'')) (e2 γ))) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ'')). + assert ((`κ ◎ `κ'') = (`sss)) as ->. + { reflexivity. } + iSpecialize ("G" $! γ with "Hγ"). + iSpecialize ("G" $! sss). + + iSpecialize ("G" $! (AppRK w' κ') with "[] Hm Hst"). + { + iIntros (v v'). + iModIntro. + iIntros "#Hv". + iIntros (m'' M'') "Hm Hst". + subst sss. + subst κ''. + simpl. + rewrite LET_Val. + subst F. + cbn [ofe_mor_car]. + + iDestruct "Hw" as "(%n' & #HEQ & %HEQ_ & Hw)". + iSpecialize ("Hw" $! v with "Hv"). + iSpecialize ("Hw" $! κ with "Hκ"). + iSpecialize ("Hw" $! m'' with "Hm Hst"). + iAssert ((IT_of_V w ⊙ (IT_of_V v)) + ≡ (Fun n' ⊙ (IT_of_V v)))%I as "#HEQ'". + { + iApply (f_equivI (λne x, (x ⊙ (IT_of_V v)))). + iApply "HEQ". + } + iRewrite "HEQ'". + iApply (wp_wand with "Hw"). + iIntros (u) "(Hst & (%y & %H1 & H2))". + iModIntro. + iFrame "Hst". + iExists y. + iFrame "H2". + iPureIntro. + unshelve epose proof (steps_det_val _ (Ceval w' (AppLK v' κ') M'') _ H1 _) as H. + { eapply step_pack; first econstructor. } + unshelve epose proof (steps_det_val _ (Ccont (AppLK v' κ') w' M'') _ H _) as H'. + { eapply step_pack; first econstructor. } + unshelve epose proof (steps_det_val _ (Ceval v' (AppRK w' κ') M'') _ H' _) as H''. + { eapply step_pack; first econstructor. } + apply H''. + } + iApply (wp_wand with "G"). + iIntros (u) "(Hst & (%y & %H1 & H2))". + iModIntro. + iFrame "Hst". + iExists y. + iFrame "H2". + iPureIntro. + destruct H1 as [nm H1]. + destruct nm as [a b]. + exists (a, b). + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ccont_appl |]. + apply H1. + } + iApply (wp_wand with "H"). + iIntros (u) "(Hst & (%y & %H1 & H2))". + iModIntro. + iFrame "Hst". + iExists y. + iFrame "H2". + iPureIntro. + destruct H1 as [nm H1]. + destruct nm as [a b]. + term_simpl. + exists (a, b). + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ceval_app |]. + apply H1. + Qed. + + Lemma compat_appcont {S : Set} (Γ : S -> ty) e1 e2 (e1' e2' : expr S) τ α δ β σ : + valid Γ e1 e1' (Tcont τ α) σ δ + -∗ valid Γ e2 e2' τ δ β + -∗ valid Γ (interp_app_cont _ e1 e2) (AppCont e1' e2') α σ β. + Proof. + iIntros "#H #G". + iModIntro. + iIntros (γ γ') "#Henv". + iIntros (κ κ') "#Hκ". + iIntros (σ' M') "Hm Hst". + + pose (K' := (AppContRSCtx_HOM e1 γ)). + assert ((interp_app_cont rs e1 e2 γ) = ((`K') (e2 γ))) as ->. + { simpl. reflexivity. } + assert ((`κ) ((`K') (e2 γ)) = ((`κ) ◎ (`K')) (e2 γ)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ K')). + assert ((`κ ◎ `K') = (`sss)) as ->. + { reflexivity. } + + iSpecialize ("G" $! γ with "Henv"). + iSpecialize ("G" $! sss). + iSpecialize ("G" $! (AppContRK (bind (F := expr) (BindCore := BindCore_expr) γ' e1') κ') with "[H] Hm Hst"). + { + iIntros (w w'). + iModIntro. + iIntros "#Hw". + iIntros (m' m'') "Hm Hst". + subst sss. + subst K'. + Opaque interp_app_cont. + simpl. + + pose (κ'' := (AppContLSCtx_HOM (IT_of_V w) γ _)). + set (F := (`κ) _). + assert (F ≡ (((`κ) ◎ (`κ'')) (e1 γ))) as ->. + { + subst F. simpl. Transparent interp_app_cont. simpl. + f_equiv. + rewrite ->2 get_val_ITV. + simpl. + reflexivity. + } + pose (sss := (HOM_compose κ κ'')). + assert ((`κ ◎ `κ'') = (`sss)) as ->. + { reflexivity. } + iSpecialize ("H" $! γ with "Henv"). + iSpecialize ("H" $! sss). + iSpecialize ("H" $! (AppContLK w' κ') with "[] Hm Hst"). + { + iIntros (v v'). + iModIntro. + iIntros "#Hv". + iIntros (σ'' M'') "Hm Hst". + subst sss. + subst κ''. + Opaque APP_CONT. + simpl. + + rewrite get_val_ITV. + simpl. + iDestruct "Hv" as "(%n' & %K'' & #HEQ & %HK & #Hv)". + iRewrite "HEQ". + rewrite get_fun_fun. + simpl. + + match goal with + | |- context G [ofe_mor_car _ _ + (ofe_mor_car _ _ APP_CONT ?a) ?b] => + set (T := APP_CONT a b) + end. + iAssert (𝒫 ((`κ) T) ≡ (𝒫 ◎ (`κ)) T)%I as "HEQ'". + { iPureIntro. reflexivity. } + iRewrite "HEQ'"; iClear "HEQ'". + subst T. + + iApply (wp_app_cont with "[Hst]"). + { reflexivity. } + - iFrame "Hst". + - simpl. + iNext. + iIntros "_ Hst". + rewrite later_map_Next. + rewrite <-Tick_eq. + iApply wp_tick. + iNext. + iSpecialize ("Hv" $! w with "Hw"). + + iSpecialize ("Hv" $! (laterO_map (𝒫 ◎ `κ) :: σ'') (κ' :: M'') with "[Hm] Hst"). + { + iIntros (p p') "#Hp Hst". + iApply (wp_pop_cons with "Hst"). + iNext. + iIntros "_ Hst". + iSpecialize ("Hκ" with "Hp Hm Hst"). + iApply (wp_wand with "Hκ"). + iIntros (?) "(T & (%v1 & %Q & R))". + iModIntro. + iFrame "T". + iExists v1. + iFrame "R". + iPureIntro. + unshelve epose proof (steps_det_val _ (Ccont κ' p' M'') _ Q _) as Q'. + { eapply step_pack; first econstructor. } + destruct Q' as [nm Q']. + destruct nm as [a b]. + exists ((a + 1)%nat, (b + 1)%nat). + eapply (steps_many _ _ _ 0 0 (a + 1)%nat (b + 1)%nat _ _); + [done | done | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 (a + 1)%nat (b + 1)%nat _ _); + [done | done | apply Ccont_end |]. + eapply (steps_many _ _ _ 1 1 a b _ _); + [lia | lia | apply Cmcont_cont |]. + apply Q'. + } + iApply (wp_wand with "Hv"). + iIntros (?) "(T & (%v1 & %Q & R))". + iModIntro. + iFrame "T". + iExists v1. + iFrame "R". + iPureIntro. + unshelve epose proof (steps_det_val _ (Ccont K'' w' (κ' :: M'')) _ Q _) as Q'. + { eapply step_pack; first econstructor. } + destruct Q' as [nm Q']. + destruct nm as [a b]. + exists ((a + 2)%nat, (b + 1)%nat). + eapply (steps_many _ _ _ 0 0 (a + 2)%nat (b + 1)%nat _ _); + [done | done | apply Ceval_val |]. + rewrite HK. + eapply (steps_many _ _ _ 2 1 a b _ _); + [lia | lia | apply Ccont_cont |]. + apply Q'. + } + iApply (wp_wand with "H"). + iIntros (?) "(T & (%v1 & %Q & R))". + iModIntro. + iFrame "T". + iExists v1. + iFrame "R". + iPureIntro. + destruct Q as [nm Q]. + destruct nm as [a b]. + exists (a, b). + eapply (steps_many _ _ _ 0 0 a b _ _); + [done | done | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 a b _ _); + [done | done | apply Ccont_app_contr |]. + apply Q. + } + iApply (wp_wand with "G"). + iIntros (?) "(T & (%v1 & %Q & R))". + iModIntro. + iFrame "T". + iExists v1. + iFrame "R". + iPureIntro. + destruct Q as [nm Q]. + destruct nm as [a b]. + exists (a, b). + term_simpl. + eapply (steps_many _ _ _ 0 0 a b _ _); + [done | done | apply Ceval_app_cont |]. + apply Q. + Qed. + + Lemma compat_if {S : Set} (Γ : S -> ty) e e' e₁ e₁' e₂ e₂' τ σ α β : + ⊢ valid Γ e e' Tnat β α + -∗ valid Γ e₁ e₁' τ σ β + -∗ valid Γ e₂ e₂' τ σ β + -∗ valid Γ (interp_if rs e e₁ e₂) + (if (e' : expr S) then (e₁' : expr S) else (e₂' : expr S)) τ σ α. + Proof. + iIntros "#H #G #J". + iModIntro. + iIntros (γ γ') "#Henv". + iIntros (κ K) "#Hκ". + iIntros (σ' M) "Hm Hst". + unfold interp_if. + cbn [ofe_mor_car]. + pose (κ' := (IFSCtx_HOM (e₁ γ) (e₂ γ))). + assert ((IF (e γ) (e₁ γ) (e₂ γ)) = ((`κ') (e γ))) as -> by reflexivity. + assert ((`κ) ((`κ') (e γ)) = ((`κ) ◎ (`κ')) (e γ)) + as -> by reflexivity. + pose (sss := (HOM_compose κ κ')). + rewrite (HOM_compose_ccompose κ κ' sss)//. + + iSpecialize ("H" $! γ with "Henv"). + iSpecialize ("H" $! sss). + + iSpecialize ("H" $! (IfK (bind (F := expr) (BindCore := BindCore_expr) γ' e₁') + (bind (F := expr) (BindCore := BindCore_expr) γ' e₂') K) + with "[] Hm Hst"). + { + iIntros (v v'). + iModIntro. + iIntros "#Hv". + iIntros (σ'' M'') "Hm Hst". + iDestruct "Hv" as "(%n & #Hv & #Hv')". + iRewrite "Hv". + rewrite IT_of_V_Ret. + subst sss. + subst κ'. + simpl. + unfold IFSCtx. + destruct (decide (0 < n)) as [H|H]. + - rewrite IF_True//. + iSpecialize ("G" $! γ with "Henv [Hκ] Hm Hst"). + { + iIntros (w w'). + iModIntro. + iIntros "#Hw". + iIntros (σ''' M''') "Hm Hst". + iApply ("Hκ" with "Hw Hm Hst"). + } + iApply (wp_wand with "G"). + iIntros (q) "(H1 & H2)". + iModIntro. + iFrame "H1". + iDestruct "H2" as "(%p & %H2 & H3)". + iExists p. + iFrame "H3". + iRewrite "Hv'". + iPureIntro. + destruct H2 as [nm H2]. + destruct nm as [a b]. + exists (a, b). + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ccont_if |]. + assert ((n =? 0)%nat = false) as ->. + { + apply Nat.eqb_neq. + lia. + } + assumption. + - rewrite IF_False//; last lia. + iSpecialize ("J" $! γ with "Henv [Hκ] Hm Hst"). + { + iIntros (w w'). + iModIntro. + iIntros "#Hw". + iIntros (σ''' M''') "Hm Hst". + iApply ("Hκ" with "Hw Hm Hst"). + } + iApply (wp_wand with "J"). + iIntros (q) "(H1 & H2)". + iModIntro. + iFrame "H1". + iDestruct "H2" as "(%p & %H2 & H3)". + iExists p. + iFrame "H3". + iRewrite "Hv'". + iPureIntro. + destruct H2 as [nm H2]. + destruct nm as [a b]. + exists (a, b). + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ceval_val |]. + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ccont_if |]. + assert ((n =? 0)%nat = true) as ->. + { + apply Nat.eqb_eq. + lia. + } + assumption. + } + iApply (wp_wand with "H"). + iIntros (q) "(H1 & H2)". + iModIntro. + iFrame "H1". + iDestruct "H2" as "(%p & %H2 & H3)". + iExists p. + iFrame "H3". + iPureIntro. + term_simpl. + destruct H2 as [nm H2]. + destruct nm as [a b]. + exists (a, b). + eapply (steps_many _ _ _ 0 0 a b _ _); + [ reflexivity | reflexivity | apply Ceval_if |]. + apply H2. + Qed. Open Scope types. @@ -1028,17 +1298,14 @@ Section logrel. destruct H. + by apply fundamental_val. + subst; iApply compat_var. - + (* iApply compat_app; *) - (* by iApply fundamental_expr. *) - admit. - + (* iApply compat_appcont; *) - (* by iApply fundamental_expr. *) - admit. + + iApply compat_app; + by iApply fundamental_expr. + + iApply compat_appcont; + by iApply fundamental_expr. + iApply compat_nat_op; by iApply fundamental_expr. - + (* iApply compat_if; *) - (* by iApply fundamental_expr. *) - admit. + + iApply compat_if; + by iApply fundamental_expr. + iApply compat_shift; by iApply fundamental_expr. + iApply (compat_reset with "[]"); @@ -1046,10 +1313,9 @@ Section logrel. - intros H. destruct H. + iApply compat_nat. - + (* iApply (compat_recV with "[]"); *) - (* by iApply fundamental_expr. *) - admit. - Admitted. + + iApply (compat_recV with "[]"); + by iApply fundamental_expr. + Qed. End logrel. @@ -1070,10 +1336,10 @@ Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) - (e : expr S) (n : nat) σ' k : + (e : expr S) (n : nat) σ k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (⊢ logrel rs Tnat Tnat Tnat α e)%I) → - ssteps (gReifiers_sReifier rs) (𝒫 α) ([], ()) (Ret n) σ' k → + ssteps (gReifiers_sReifier rs) (𝒫 α) ([], ()) (Ret n) σ k → ∃ m, steps (Cexpr e) (Cret (LitV n)) m. Proof. intros Hlog Hst. @@ -1183,10 +1449,10 @@ Proof. iSplit; done. Qed. -Theorem adequacy (e : expr ∅) (k : nat) σ' n : +Theorem adequacy (e : expr ∅) (k : nat) σ n : (typed_expr empty_env Tnat e Tnat Tnat) → ssteps (gReifiers_sReifier rs) (𝒫 (interp_expr rs e ı_scope)) ([], ()) - (Ret k : IT _ natO) σ' n → + (Ret k : IT _ natO) σ n → ∃ mm, steps (Cexpr e) (Cret $ LitV k) mm. Proof. intros Hty Hst. From 9f26c26cd0e37ca48f4d81749d0eb83d2088482f Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Tue, 11 Jun 2024 19:14:48 +0200 Subject: [PATCH 09/14] refactor delim --- _CoqProject | 2 + theories/examples/delim_lang/hom.v | 111 ++++ theories/examples/delim_lang/interp.v | 108 +--- theories/examples/delim_lang/lang.v | 265 +++------ theories/examples/delim_lang/logpred.v | 721 +------------------------ theories/examples/delim_lang/logrel.v | 255 +-------- theories/examples/delim_lang/typing.v | 95 ++++ 7 files changed, 318 insertions(+), 1239 deletions(-) create mode 100644 theories/examples/delim_lang/hom.v create mode 100644 theories/examples/delim_lang/typing.v diff --git a/_CoqProject b/_CoqProject index cd88e1e..f8241b5 100644 --- a/_CoqProject +++ b/_CoqProject @@ -40,7 +40,9 @@ theories/lib/factorial.v theories/lib/iter.v theories/examples/delim_lang/lang.v +theories/examples/delim_lang/typing.v theories/examples/delim_lang/interp.v +theories/examples/delim_lang/hom.v theories/examples/delim_lang/example.v theories/examples/delim_lang/logpred.v theories/examples/delim_lang/logrel.v diff --git a/theories/examples/delim_lang/hom.v b/theories/examples/delim_lang/hom.v new file mode 100644 index 0000000..1bce1e5 --- /dev/null +++ b/theories/examples/delim_lang/hom.v @@ -0,0 +1,111 @@ +From gitrees Require Import gitree lang_generic hom. +From gitrees.effects Require Import delim. +From gitrees.examples.delim_lang Require Import lang interp. + +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope stdpp_scope. + +Section hom. + Context {sz : nat}. + Context {rs : gReifiers CtxDep sz}. + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Context `{!subReifier reify_delim rs}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + + Program Definition AppContRSCtx_HOM {S : Set} + (α : @interp_scope F R _ S -n> IT) + (env : @interp_scope F R _ S) + : HOM := exist _ (interp_app_contrk rs α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition AppContLSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F R _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_app_contlk rs (constO β) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - intros ???. + do 2 f_equiv. + intros ?; simpl. + solve_proper. + - rewrite get_val_ITV. + rewrite get_val_ITV. + simpl. + rewrite get_fun_tick. + reflexivity. + - rewrite get_val_ITV. + simpl. rewrite get_fun_vis. simpl. + f_equiv. + intros ?; simpl. + apply later_map_ext. + intros ?; simpl. + rewrite get_val_ITV. + simpl. + reflexivity. + - rewrite get_val_ITV. simpl. rewrite get_fun_err. reflexivity. + Qed. + + Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) + (α : @interp_scope F R _ S -n> IT) (env : @interp_scope F R _ S) + : HOM := exist _ (interp_natoprk rs op α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) + (α : IT) (env : @interp_scope F R _ S) + (Hv : AsVal α) + : HOM := exist _ (interp_natoplk rs op (constO α) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition AppLSCtx_HOM {S : Set} + (α : @interp_scope F R _ S -n> IT) + (env : @interp_scope F R _ S) + : HOM := exist _ (interp_applk rs α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Transparent LET. + Program Definition AppRSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F R _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_apprk rs (constO β) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - solve_proper_please. + - rewrite get_val_ITV. + simpl. + rewrite get_val_ITV. + simpl. + rewrite get_val_tick. + reflexivity. + - rewrite get_val_ITV. + simpl. + rewrite get_val_vis. + do 3 f_equiv. + intro; simpl. + rewrite get_val_ITV. + simpl. + reflexivity. + - rewrite get_val_ITV. + simpl. + rewrite get_val_err. + reflexivity. + Qed. + Opaque LET. +End hom. diff --git a/theories/examples/delim_lang/interp.v b/theories/examples/delim_lang/interp.v index 18bbc53..dbc210d 100644 --- a/theories/examples/delim_lang/interp.v +++ b/theories/examples/delim_lang/interp.v @@ -112,50 +112,22 @@ Section interp. Qed. (** ** APP *) - (* Program Definition interp_app {A} (t1 t2 : A -n> IT) : A -n> IT := *) - (* λne env, get_fun *) - (* (λne (f : laterO (IT -n> IT)), *) - (* get_val (λne x, Tau (laterO_ap f (Next x))) (t2 env)) (t1 env). *) - (* Next Obligation. *) - (* solve_proper. *) - (* Qed. *) - (* Next Obligation. *) - (* intros ????????. *) - (* apply get_val_ne. *) - (* intros ?; simpl. *) - (* f_equiv. *) - (* apply Next_contractive. *) - (* destruct n as [| ?]. *) - (* - apply dist_later_0. *) - (* - apply dist_later_S in H. *) - (* apply dist_later_S. *) - (* by f_equiv. *) - (* Qed. *) - (* Next Obligation. *) - (* solve_proper_please. *) - (* Qed. *) Program Definition interp_app {A} (t1 t2 : A -n> IT) : A -n> IT := λne env, LET (t1 env) $ λne f, - LET (t2 env) $ λne x, + LET (t2 env) $ λne x, APP' f x. Solve All Obligations with solve_proper_please. - + Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). - Proof. + Proof. solve_proper_prepare. f_equiv. - by f_equiv. - intro; simpl. by do 2 f_equiv. Qed. - (* Proof. *) - (* solve_proper_prepare. *) - (* do 2 f_equiv; last done. *) - (* intro; simpl. *) - (* by f_equiv. *) - (* Qed. *) - Typeclasses Opaque interp_app. + Typeclasses Opaque interp_app. (** ** APP_CONT *) @@ -208,12 +180,6 @@ Section interp. intro; simpl. by do 2 f_equiv. Qed. - (* Next Obligation. *) - (* solve_proper_prepare. *) - (* do 3 f_equiv. *) - (* intro; simpl. *) - (* by f_equiv. *) - (* Qed. *) Next Obligation. solve_proper_prepare. f_equiv; first solve_proper. @@ -221,12 +187,6 @@ Section interp. intro; simpl. solve_proper. Qed. - (* Next Obligation. *) - (* solve_proper_prepare. *) - (* do 2 f_equiv; [done | | by f_equiv]. *) - (* f_equiv. *) - (* by intro; simpl. *) - (* Qed. *) Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : A -n> IT -n> IT := @@ -237,20 +197,11 @@ Section interp. Next Obligation. solve_proper. Qed. - (* Next Obligation. *) - (* intros ????????. *) - (* do 3 f_equiv. *) - (* intro; simpl. *) - (* done. *) - (* Qed. *) Next Obligation. solve_proper_prepare. f_equiv; first solve_proper. f_equiv; first solve_proper. - Qed. - (* Next Obligation. *) - (* solve_proper_please. *) - (* Qed. *) + Qed. Program Definition interp_app_contrk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : A -n> IT -n> IT := @@ -397,17 +348,15 @@ Section interp. + f_equiv; first by rewrite interp_expr_ren. intro; simpl. f_equiv; by rewrite interp_expr_ren. - (* f_equiv; last by rewrite interp_expr_ren. *) - (* f_equiv. intro. simpl. by f_equiv. *) + f_equiv; last by rewrite interp_expr_ren. f_equiv. intro. simpl. by f_equiv. + f_equiv; last eauto. f_equiv. intro. simpl. rewrite !laterO_map_Next. repeat f_equiv. rewrite interp_expr_ren. - f_equiv. + f_equiv. intros [| ?]; simpl; first done. - reflexivity. + reflexivity. - destruct e; simpl. + reflexivity. + clear -interp_expr_ren. @@ -433,15 +382,11 @@ Section interp. f_equiv; first by rewrite interp_val_ren. intro; simpl. reflexivity. - (* intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. *) - (* intro. simpl. by repeat f_equiv. *) + intro. simpl. f_equiv; eauto. f_equiv. intro; simpl. f_equiv. by rewrite interp_expr_ren. - (* intro. simpl. f_equiv; eauto. do 2 f_equiv. *) - (* intro. simpl. by repeat f_equiv. *) + simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. + simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. Qed. @@ -451,11 +396,10 @@ Section interp. Proof. elim : K e env; eauto. - intros. simpl. rewrite H. f_equiv. simpl. f_equiv. - intro; simpl. + intro; simpl. reflexivity. - (* do 2 f_equiv. intro. simpl. by repeat f_equiv. *) - intros. simpl. rewrite H. f_equiv. simpl. - do 2 f_equiv. intro. simpl. by repeat f_equiv. + do 2 f_equiv. intro. simpl. by repeat f_equiv. Qed. Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') @@ -488,13 +432,12 @@ Section interp. + f_equiv; first by rewrite interp_expr_subst. intro; simpl. f_equiv; first by rewrite interp_expr_subst. - (* f_equiv; last eauto. f_equiv. intro. simpl. by repeat f_equiv. *) + f_equiv; last eauto. f_equiv. intro. simpl. by repeat f_equiv. + f_equiv; last eauto. f_equiv. intro. simpl. rewrite !laterO_map_Next. repeat f_equiv. rewrite interp_expr_subst. - f_equiv. + f_equiv. intros [| ?]; simpl; first done. rewrite interp_expr_ren. f_equiv. @@ -528,13 +471,11 @@ Section interp. f_equiv; first by rewrite interp_cont_subst. f_equiv; first by rewrite interp_val_subst. intro; simpl; reflexivity. - (* simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. *) + intro; simpl. f_equiv; first by rewrite interp_cont_subst. f_equiv. intro; simpl. f_equiv; first by rewrite interp_expr_subst. - (* simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. *) + simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. + simpl. intro. simpl. f_equiv; eauto. f_equiv; eauto. f_equiv. intro. simpl. by repeat f_equiv. Qed. @@ -563,7 +504,7 @@ Section interp. by rewrite -hom_vis. - trans (interp_cont K env (Err e)); first (f_equiv; apply IF_Err). apply hom_err. - Qed. + Qed. Transparent LET. #[local] Instance interp_cont_hom_appr {S} (K : cont S) @@ -817,32 +758,6 @@ Section interp. | |- context G [ofe_mor_car _ _ (get_fun _) (ofe_mor_car _ _ Fun ?f)] => set (fin := f) end. - (* unfold POP. *) - (* match goal with *) - (* |- ofe_mor_car _ _ (ofe_mor_car _ _ _ ?a) _ ≡ _ => *) - (* set (T := a) *) - (* end. *) - (* eassert (T ≡ _). *) - (* { *) - (* subst T. *) - (* rewrite get_val_ITV. *) - (* simpl. *) - (* rewrite get_fun_fun. *) - (* subst fin. *) - (* simpl. *) - (* rewrite <-Tick_eq. *) - (* (* rewrite hom_tick. *) *) - (* (* rewrite hom_tick. *) *) - (* (* rewrite hom_tick. *) *) - (* (* rewrite hom_tick. *) *) - (* reflexivity. *) - (* } *) - (* trans (reify (gReifiers_sReifier rs) *) - (* (𝒫 (interp_cont k env (Tick (Tick (𝒫 (interp_cont k' env (interp_val v env))))))) *) - (* (gState_recomp σr (sR_state σ))). *) - (* { *) - (* now do 2 f_equiv. *) - (* } *) trans (reify (gReifiers_sReifier rs) (APP_CONT_ (Next (interp_val v env)) @@ -863,7 +778,6 @@ Section interp. repeat f_equiv; eauto. solve_proper. } f_equiv. by rewrite -!Tick_eq. - (* admit. *) - remember (map_meta_cont mk env) as σ. trans (reify (gReifiers_sReifier rs) (POP (interp_val v env)) (gState_recomp σr (sR_state (laterO_map (𝒫 ◎ interp_cont k env) :: σ)))). diff --git a/theories/examples/delim_lang/lang.v b/theories/examples/delim_lang/lang.v index 13e9b8e..4497332 100644 --- a/theories/examples/delim_lang/lang.v +++ b/theories/examples/delim_lang/lang.v @@ -1,10 +1,7 @@ From gitrees Require Export prelude. From stdpp Require Import gmap. -(* From iris.heap_lang Require Import locations. *) Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. -(* Definition loc : Set := locations.loc. *) -(* Global Instance loc_dec_eq (l l' : loc) : Decision (l = l') := _. *) Variant nat_op := Add | Sub | Mult. Inductive expr {X : Set} := @@ -21,15 +18,10 @@ Inductive expr {X : Set} := (* The effects *) | Shift (e : @expr (inc X)) : expr | Reset (e : expr) : expr -(* | Alloc (e : expr) : expr *) -(* | Deref (e : expr) : expr *) -(* | Assign (e₁ : expr) (e₂ : expr) : expr *) with val {X : Set} := | LitV (n : nat) : val | RecV (e : @expr (inc (inc X))) : val | ContV (k : cont) : val -(* | LocV (l : loc) : val *) -(* | UnitV : val *) with cont {X : Set} := | END : cont | IfK (e1 : expr) (e2 : expr) : cont -> cont @@ -39,10 +31,6 @@ with cont {X : Set} := | AppContRK (e : expr) : cont -> cont (* e ◻ *) | NatOpLK (op : nat_op) (v : val) : cont -> cont (* ◻ + v *) | NatOpRK (op : nat_op) (e : expr) : cont -> cont (* e + ◻ *) -(* | AllocK : cont → cont *) -(* | DerefK : cont → cont *) -(* | AssignRK (e : expr) : cont → cont (* E <- e *) *) -(* | AssignLK (v : val) : cont → cont (* v <- E *) *) . (* conts are inside-out contexts: eg IfK e1 e2 (AppLK v ◻) ==> App (if ◻ then e1 else e2) v*) @@ -63,9 +51,6 @@ Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) | Shift e => Shift (emap (f ↑) e) | Reset e => Reset (emap f e) - (* | Alloc e => Alloc (emap f e) *) - (* | Deref e => Deref (emap f e) *) - (* | Assign e₁ e₂ => Assign (emap f e₁) (emap f e₂) *) end with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := @@ -73,8 +58,6 @@ vmap {A B : Set} (f : A [→] B) (v : val A) : val B := | LitV n => LitV n | RecV e => RecV (emap ((f ↑) ↑) e) | ContV k => ContV (kmap f k) - (* | LocV l => LocV l *) - (* | UnitV => UnitV *) end with kmap {A B : Set} (f : A [→] B) (K : cont A) : cont B := match K with @@ -86,10 +69,6 @@ with kmap {A B : Set} (f : A [→] B) (K : cont A) : cont B := | AppContRK e k => AppContRK (emap f e) (kmap f k) | NatOpLK op v k => NatOpLK op (vmap f v) (kmap f k) | NatOpRK op e k => NatOpRK op (emap f e) (kmap f k) - (* | AllocK k => AllocK (kmap f k) *) - (* | DerefK k => DerefK (kmap f k) *) - (* | AssignRK e k => AssignRK (emap f e) (kmap f k) *) - (* | AssignLK v k => AssignLK (vmap f v) (kmap f k) *) end. @@ -109,9 +88,6 @@ Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) | Shift e => Shift (ebind (f ↑) e) | Reset e => Reset (ebind f e) - (* | Alloc e => Alloc (ebind f e) *) - (* | Deref e => Deref (ebind f e) *) - (* | Assign e₁ e₂ => Assign (ebind f e₁) (ebind f e₂) *) end with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := @@ -119,8 +95,6 @@ vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := | LitV n => LitV n | RecV e => RecV (ebind ((f ↑) ↑) e) | ContV k => ContV (kbind f k) - (* | LocV l => LocV l *) - (* | UnitV => UnitV *) end with kbind {A B : Set} (f : A [⇒] B) (K : cont A) : cont B := match K with @@ -132,10 +106,6 @@ with kbind {A B : Set} (f : A [⇒] B) (K : cont A) : cont B := | AppContRK e k => AppContRK (ebind f e) (kbind f k) | NatOpLK op v k => NatOpLK op (vbind f v) (kbind f k) | NatOpRK op e k => NatOpRK op (ebind f e) (kbind f k) - (* | AllocK k => AllocK (kbind f k) *) - (* | DerefK k => DerefK (kbind f k) *) - (* | AssignRK e k => AssignRK (ebind f e) (kbind f k) *) - (* | AssignLK v k => AssignLK (vbind f v) (kbind f k) *) end. #[export] Instance BindCore_expr : BindCore expr := @ebind. @@ -315,10 +285,6 @@ Fixpoint fill {X : Set} (K : cont X) (e : expr X) : expr X := | AppContRK el K => fill K (AppCont el e) | NatOpLK op v K => fill K (NatOp op e (Val v)) | NatOpRK op el K => fill K (NatOp op el e) - (* | AllocK K => fill K (Alloc e) *) - (* | DerefK K => fill K (Deref e) *) - (* | AssignRK e' K => fill K (Assign e e') *) - (* | AssignLK v K => fill K (Assign (Val v) e) *) end. (*** Continuation operations *) @@ -345,10 +311,6 @@ Fixpoint cont_compose {S} (K1 K2 : cont S) : cont S := | AppContRK e K => AppContRK e (cont_compose K1 K) | NatOpLK op v K => NatOpLK op v (cont_compose K1 K) | NatOpRK op e K => NatOpRK op e (cont_compose K1 K) - (* | AllocK K => AllocK (cont_compose K1 K) *) - (* | DerefK K => DerefK (cont_compose K1 K) *) - (* | AssignRK e' K => AssignRK e' (cont_compose K1 K) *) - (* | AssignLK v K => AssignLK v (cont_compose K1 K) *) end. Lemma fill_comp {S} (K1 K2 : cont S) e : fill (cont_compose K1 K2) e = fill K1 (fill K2 e). @@ -366,7 +328,6 @@ Qed. (*** Abstract Machine semantics *) Definition Mcont {S} := list $ cont S. -(* Definition state X := gmap loc (val X). *) Variant config {S} : Type := | Ceval : expr S -> cont S -> @Mcont S → config @@ -378,108 +339,80 @@ Variant config {S} : Type := Reserved Notation "c '===>' c' / nm" (at level 40, c', nm at level 30). -Variant Cred {S : Set} : config (* * state S *) -> config (* * state S *) - -> (nat * nat) -> Prop := +Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := (* init *) -| Ceval_init : forall (e : expr S) (* σ *), - (Cexpr e(* , σ *)) ===> (Ceval e END [](* , σ *)) / (0,0) +| Ceval_init : forall (e : expr S), + (Cexpr e) ===> (Ceval e END []) / (0,0) (* eval *) -| Ceval_val : forall v k mk (* σ *), - (Ceval (Val v) k mk(* , σ *)) ===> (Ccont k v mk(* , σ *)) / (0,0) +| Ceval_val : forall v k mk, + (Ceval (Val v) k mk) ===> (Ccont k v mk) / (0,0) -| Ceval_app : forall e0 e1 k mk (* σ *), - (Ceval (App e0 e1) k mk(* , σ *)) ===> (Ceval e0 (AppLK e1 k) mk(* , σ *)) / (0,0) +| Ceval_app : forall e0 e1 k mk, + (Ceval (App e0 e1) k mk) ===> (Ceval e0 (AppLK e1 k) mk) / (0,0) -| Ceval_app_cont : forall e0 e1 k mk (* σ *), - (Ceval (AppCont e0 e1) k mk(* , σ *)) ===> (Ceval e1 (AppContRK e0 k) mk(* , σ *)) / (0,0) +| Ceval_app_cont : forall e0 e1 k mk, + (Ceval (AppCont e0 e1) k mk) ===> (Ceval e1 (AppContRK e0 k) mk) / (0,0) -| Ceval_natop : forall op e0 e1 k mk (* σ *), - (Ceval (NatOp op e0 e1) k mk(* , σ *)) ===> (Ceval e1 (NatOpRK op e0 k) mk(* , σ *)) / (0,0) +| Ceval_natop : forall op e0 e1 k mk, + (Ceval (NatOp op e0 e1) k mk) ===> (Ceval e1 (NatOpRK op e0 k) mk) / (0,0) -| Ceval_if : forall eb et ef k mk (* σ *), - (Ceval (If eb et ef) k mk(* , σ *)) ===> (Ceval eb (IfK et ef k) mk(* , σ *)) / (0,0) +| Ceval_if : forall eb et ef k mk, + (Ceval (If eb et ef) k mk) ===> (Ceval eb (IfK et ef k) mk) / (0,0) -| Ceval_reset : forall e k mk (* σ *), - (Ceval (Reset e) k mk(* , σ *)) ===> (Ceval e END (k :: mk)(* , σ *)) / (1, 1) +| Ceval_reset : forall e k mk, + (Ceval (Reset e) k mk) ===> (Ceval e END (k :: mk)) / (1, 1) -| Ceval_shift : forall (e : expr $ inc S) k mk (* σ *), - (Ceval (Shift e) k mk(* , σ *)) ===> - (Ceval (subst (Inc := inc) e (Val $ ContV k)) END mk(* , σ *)) / (1, 1) +| Ceval_shift : forall (e : expr $ inc S) k mk, + (Ceval (Shift e) k mk) ===> + (Ceval (subst (Inc := inc) e (Val $ ContV k)) END mk) / (1, 1) (* cont *) -| Ccont_end : forall v mk (* σ *), - (Ccont END v mk(* , σ *)) ===> (Cmcont mk v(* , σ *)) / (0,0) +| Ccont_end : forall v mk, + (Ccont END v mk) ===> (Cmcont mk v) / (0,0) -| Ccont_appl : forall e v k mk (* σ *), - (Ccont (AppLK e k) v mk(* , σ *)) ===> (Ceval e (AppRK v k) mk(* , σ *)) / (0, 0) +| Ccont_appl : forall e v k mk, + (Ccont (AppLK e k) v mk) ===> (Ceval e (AppRK v k) mk) / (0, 0) -| Ccont_app_contr : forall e v k mk (* σ *), - (Ccont (AppContRK e k) v mk(* , σ *)) ===> (Ceval e (AppContLK v k) mk(* , σ *)) / (0, 0) +| Ccont_app_contr : forall e v k mk, + (Ccont (AppContRK e k) v mk) ===> (Ceval e (AppContLK v k) mk) / (0, 0) -| Ccont_appr : forall e v k mk (* σ *), - (Ccont (AppRK (RecV e) k) v mk(* , σ *)) ===> +| Ccont_appr : forall e v k mk, + (Ccont (AppRK (RecV e) k) v mk) ===> (Ceval (subst (Inc := inc) (subst (F := expr) (Inc := inc) e (Val (shift (Inc := inc) v))) - (Val (RecV e))) k mk(* , σ *)) / (1, 0) + (Val (RecV e))) k mk) / (1, 0) -| Ccont_cont : forall v k k' mk (* σ *), - (Ccont (AppContLK v k) (ContV k') mk(* , σ *)) ===> - (Ccont k' v (k :: mk)(* , σ *)) / (2, 1) +| Ccont_cont : forall v k k' mk, + (Ccont (AppContLK v k) (ContV k') mk) ===> + (Ccont k' v (k :: mk)) / (2, 1) -| Ccont_if : forall et ef n k mk (* σ *), - (Ccont (IfK et ef k) (LitV n) mk(* , σ *)) ===> - (Ceval (if (n =? 0) then ef else et) k mk(* , σ *)) / (0, 0) +| Ccont_if : forall et ef n k mk, + (Ccont (IfK et ef k) (LitV n) mk) ===> + (Ceval (if (n =? 0) then ef else et) k mk) / (0, 0) -| Ccont_natopr : forall op e v k mk (* σ *), - (Ccont (NatOpRK op e k) v mk(* , σ *)) ===> - (Ceval e (NatOpLK op v k) mk(* , σ *)) / (0, 0) +| Ccont_natopr : forall op e v k mk, + (Ccont (NatOpRK op e k) v mk) ===> + (Ceval e (NatOpLK op v k) mk) / (0, 0) -| Ccont_natopl : forall op v0 v1 v2 k mk (* σ *), +| Ccont_natopl : forall op v0 v1 v2 k mk, nat_op_interp op v0 v1 = Some v2 -> - (Ccont (NatOpLK op v1 k) v0 mk(* , σ *)) ===> - (Ceval (Val v2) k mk(* , σ *)) / (0,0) + (Ccont (NatOpLK op v1 k) v0 mk) ===> + (Ceval (Val v2) k mk) / (0,0) (* meta-cont *) -| Cmcont_cont : forall k mk v (* σ *), - (Cmcont (k :: mk) v(* , σ *)) ===> (Ccont k v mk(* , σ *)) / (1,1) +| Cmcont_cont : forall k mk v, + (Cmcont (k :: mk) v) ===> (Ccont k v mk) / (1,1) -| Cmcont_ret : forall v (* σ *), - (Cmcont [] v(* , σ *)) ===> (Cret v(* , σ *)) / (1, 1) - -(* | Ceval_assign : forall e0 e1 k mk σ, *) -(* (Ceval (Assign e0 e1) k mk, σ) ===> (Ceval e1 (AssignRK e0 k) mk, σ) / (0, 0) *) - -(* | Ccont_assignr : forall e v k mk σ, *) -(* (Ccont (AssignRK e k) v mk, σ) ===> (Ceval e (AssignLK v k) mk, σ) / (0, 0) *) - -(* | Ccont_assignl : forall l v' k mk σ, *) -(* (Ccont (AssignLK (LocV l) k) v' mk, σ) ===> *) -(* (Ceval (Val UnitV) k mk, <[l:=v']>σ) / (0, 1) *) - -(* | Ceval_alloc : forall e k mk σ, *) -(* (Ceval (Alloc e) k mk, σ) ===> (Ceval e (AllocK k) mk, σ) / (0, 0) *) - -(* | Ceval_allock : ∀ l v k mk σ, *) -(* σ !! l = None -> *) -(* (Ccont (AllocK k) v mk, σ) ===> *) -(* (Ceval (Val (LocV l)) k mk, <[l:=v]>σ) / (0, 1) *) - -(* | Ceval_deref : forall e k mk σ, *) -(* (Ceval (Deref e) k mk, σ) ===> (Ceval e (DerefK k) mk, σ) / (0, 0) *) - -(* | Ceval_derefk : ∀ l v k mk σ, *) -(* σ !! l = Some v -> *) -(* (Ccont (DerefK k) (LocV l) mk, σ) ===> *) -(* (Ceval (Val v) k mk, σ) / (0, 1) *) +| Cmcont_ret : forall v, + (Cmcont [] v) ===> (Cret v) / (1, 1) where "c ===> c' / nm" := (Cred c c' nm). Arguments Mcont S%bind : clear implicits. Arguments config S%bind : clear implicits. -Inductive steps {S} : config S (* * state S *) -> config S (* * state S *) -> - (nat * nat) -> Prop := +Inductive steps {S} : config S -> config S -> (nat * nat) -> Prop := | steps_zero : forall c, steps c c (0, 0) | steps_many : forall c1 c2 c3 n m n' m' n'' m'', @@ -512,6 +445,43 @@ Proof. - apply G. Qed. +Lemma step_pack {S : Set} (a b : config S) : + ∀ nm, Cred a b nm → stepEx a b. +Proof. + intros nm H. + by exists nm. +Qed. + +Lemma steps_pack {S : Set} (a b : config S) : + ∀ nm, steps a b nm → stepsEx a b. +Proof. + intros nm H. + by exists nm. +Qed. + +Lemma step_det {S : Set} (c c' c'' : config S) + : stepEx c c' → stepEx c c'' → c' = c''. +Proof. + intros [nm H]. + revert c''. + inversion H; subst; intros c'' [nm' G]; + inversion G; subst; simplify_eq; reflexivity. +Qed. + +Lemma steps_det_val {S : Set} (c c' : config S) (v : val S) + : stepsEx c (Cret v) → stepEx c c' → stepsEx c' (Cret v). +Proof. + intros [n H]. + revert c'. + inversion H; subst; intros c' G. + - destruct G as [? G]. + inversion G. + - erewrite (step_det c c' c2). + + by eapply steps_pack. + + assumption. + + by eapply step_pack. +Qed. + Definition meta_fill {S} (mk : Mcont S) e := fold_left (λ e k, fill k e) mk e. @@ -522,7 +492,6 @@ Coercion Val : val >-> expr. Declare Scope syn_scope. Delimit Scope syn_scope with syn. -(* Coercion LocV : loc >-> val. *) Coercion App : expr >-> Funclass. Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. @@ -606,45 +575,6 @@ Global Instance AppContNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : __app_cont e K := cont_compose K (AppContRK (__asSynExpr e) END) }. -(* Class AllocNotation (A B : Type) := { __alloc : A -> B }. *) -(* Notation "'alloc' e" := (__alloc e%syn) (at level 61) : syn_scope. *) - -(* Global Instance AllocNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : *) -(* AllocNotation (F S) (expr S) := { __alloc e := Alloc (__asSynExpr e) }. *) - -(* Global Instance AllocNotationK {S : Set} : AllocNotation (cont S) (cont S) := *) -(* { __alloc K := AllocK K }. *) - -(* Class DerefNotation (A B : Type) := { __deref : A -> B }. *) -(* Notation "'!' e" := (__deref e%syn) (at level 61) : syn_scope. *) - -(* Global Instance DerefNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : *) -(* DerefNotation (F S) (expr S) := { __deref e := Deref (__asSynExpr e) }. *) - -(* Global Instance DerefNotationK {S : Set} : DerefNotation (cont S) (cont S) := *) -(* { __deref K := DerefK K }. *) - -(* Class AssignNotation (A B C : Type) := { __assign : A -> B -> C }. *) -(* (* <- !!! *) *) -(* Notation "x '<-' y" := (__assign x%syn y%syn) *) -(* (at level 40, y at next level, left associativity) *) -(* : syn_scope. *) - -(* Global Instance AssignNotationExpr {S : Set} {F G : Set -> Type} *) -(* `{AsSynExpr F, AsSynExpr G} : AssignNotation (F S) (G S) (expr S) := { *) -(* __assign e₁ e₂ := Assign (__asSynExpr e₁) (__asSynExpr e₂) *) -(* }. *) - -(* Global Instance AssignNotationLK {S : Set} *) -(* : AssignNotation (cont S) (val S) (cont S) := { *) -(* __assign K v := AssignLK v K *) -(* }. *) - -(* Global Instance AssignNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} *) -(* : AssignNotation (F S) (cont S) (cont S) := { *) -(* __assign e K := AssignRK (__asSynExpr e) K *) -(* }. *) - Notation of_val := Val (only parsing). Notation "x '⋆' y" := (__app x%syn y%syn) (at level 40, y at next level @@ -663,7 +593,6 @@ Notation "'$' fn" := (set_pure_resolver fn) (at level 60) : syn_scope. Notation "K '⟪' e '⟫'" := (fill K%syn e%syn) (at level 60) : syn_scope. Module SynExamples. - Open Scope syn_scope. Example test1 : expr (inc ∅) := $0. @@ -671,38 +600,6 @@ Module SynExamples. Example test3 : expr ∅ := (rec (reset (shift/cc (($0) @k $1)))). Example test4 : expr ∅ := (rec (if ($0) then #1 else (($0) ⋆ (($0) - #1)))). - (* Example test5 : expr ∅ := *) - (* ((alloc #1) <- #2). *) - (* Example test6 : expr ∅ := *) - (* (! alloc #1). *) - (* Example test7 : *) - (* (∃ (ℓ : loc), *) - (* steps (Cexpr (! alloc #1), empty) (Cret (#1 : val ∅), <[ℓ:=#1]>∅%stdpp) (1, 3)). *) - (* Proof. *) - (* set (ℓ := (fresh (dom (∅%stdpp : state ∅)))). *) - (* exists ℓ. *) - (* eapply steps_many with _ 0 0 1 3; first reflexivity; first reflexivity; *) - (* first apply Ceval_init. *) - (* eapply steps_many with _ _ _ 1 3; [| | apply Ceval_deref |]; *) - (* first reflexivity; first reflexivity. *) - (* eapply steps_many with _ _ _ 1 3; [| | apply Ceval_alloc |]; *) - (* first reflexivity; first reflexivity. *) - (* eapply steps_many with _ _ _ 1 3; [| | apply Ceval_val |]; *) - (* first reflexivity; first reflexivity. *) - (* eapply steps_many with _ _ _ 1 2; [| | apply (Ceval_allock ℓ) |]; *) - (* first reflexivity; first reflexivity; first set_solver. *) - (* eapply steps_many with _ _ _ 1 2; [| | apply Ceval_val |]; *) - (* first reflexivity; first reflexivity. *) - (* eapply steps_many with _ _ _ 1 _; [| | eapply (Ceval_derefk ℓ (LitV 1)) |]; *) - (* first reflexivity; first reflexivity; first set_solver. *) - (* eapply steps_many with _ _ _ 1 1; [| | apply Ceval_val |]; *) - (* first reflexivity; first reflexivity. *) - (* eapply steps_many with _ _ _ 1 1; [| | apply Ccont_end |]; *) - (* first reflexivity; first reflexivity. *) - (* eapply steps_many with _ _ _ 0 0; [| | apply Cmcont_ret |]; *) - (* first reflexivity; first reflexivity. *) - (* apply steps_zero. *) - (* Qed. *) Example test8 : expr (inc ∅) := ($ 0). Example test9 : val ∅ := (rec (if ($ 1) then # 1 else # 0)). Example test10 : expr ∅ := (shift/cc (rec ($ 0))). diff --git a/theories/examples/delim_lang/logpred.v b/theories/examples/delim_lang/logpred.v index eb160a7..7401ef7 100644 --- a/theories/examples/delim_lang/logpred.v +++ b/theories/examples/delim_lang/logpred.v @@ -1,142 +1,12 @@ From gitrees Require Import gitree lang_generic hom. From gitrees.effects Require Import delim. -From gitrees.examples.delim_lang Require Import lang interp. +From gitrees.examples.delim_lang Require Import lang interp typing hom. From iris.algebra Require Import list. From iris.proofmode Require Import classes tactics. From iris.base_logic Require Import algebra. -(* TODO: typing rules (ctx variables), compat for contexts, binary relation *) - Require Import Binding.Lib Binding.Set Binding.Env. -Open Scope syn. - -Inductive ty := -| Tnat : ty -| Tarr : ty -> ty -> ty -> ty -> ty -| Tcont : ty → ty → ty. - -Declare Scope types. - -Notation "τ '∕' α '→' σ '∕' β" := (Tarr τ α σ β) (at level 60) : types. -Notation "'Cont' τ σ" := (Tcont τ σ) (at level 60) : types. - -Reserved Notation "Γ ';' α '⊢ₑ' e ':' τ ';' β" - (at level 90, e at next level, τ at level 20, no associativity). - -Reserved Notation "Γ ';' α '⊢ᵥ' e ':' τ ';' β" - (at level 90, e at next level, τ at level 20, no associativity). - -Reserved Notation "Γ '⊢ᵪ' e ':' τ '⤞' σ" - (at level 90, e at next level, τ at level 20, no associativity). - -Inductive typed_expr {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := -| typed_Val v α τ β : - (Γ; α ⊢ᵥ v : τ; β) → - (Γ; α ⊢ₑ v : τ; β) -| typed_Var x τ α : - (Γ x = τ) → - (Γ; α ⊢ₑ (Var x) : τ; α) -| typed_App e₁ e₂ γ α β δ σ τ : - (Γ; γ ⊢ₑ e₁ : (Tarr σ α τ β); δ) → - (Γ; β ⊢ₑ e₂ : σ; γ) → - (Γ; α ⊢ₑ (App e₁ e₂) : τ; δ) -| typed_AppCont e₁ e₂ α β δ σ τ : - (Γ; σ ⊢ₑ e₁ : (Tcont τ α); δ) → - (Γ; δ ⊢ₑ e₂ : τ; β) → - (Γ; σ ⊢ₑ (AppCont e₁ e₂) : α; β) -| typed_NatOp o e₁ e₂ α β γ : - (Γ; α ⊢ₑ e₁ : Tnat; β) → - (Γ; β ⊢ₑ e₂ : Tnat; γ) → - (Γ; α ⊢ₑ NatOp o e₁ e₂ : Tnat; γ) -| typed_If e e₁ e₂ α β σ τ : - (Γ; β ⊢ₑ e : Tnat; α) → - (Γ; σ ⊢ₑ e₁ : τ; β) → - (Γ; σ ⊢ₑ e₂ : τ; β) → - (Γ; σ ⊢ₑ (if e then e₁ else e₂) : τ; α) -| typed_Shift (e : @expr (inc S)) τ α σ β : - (Γ ▹ (Tcont τ α); σ ⊢ₑ e : σ; β) → - (Γ; α ⊢ₑ Shift e : τ; β) -| typed_Reset e α σ τ : - (Γ; σ ⊢ₑ e : σ; τ) → - (Γ; α ⊢ₑ reset e : τ; α) -where "Γ ';' α '⊢ₑ' e ':' τ ';' β" := (typed_expr Γ α e τ β) : types -with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := -| typed_LitV n α : - (Γ; α ⊢ᵥ #n : Tnat; α) -| typed_RecV (e : expr (inc (inc S))) (δ σ τ α β : ty) : - ((Γ ▹ (Tarr σ α τ β) ▹ σ); α ⊢ₑ e : τ; β) -> - (Γ; δ ⊢ᵥ (RecV e) : (Tarr σ α τ β); δ) -(* unnecessary *) -| typed_ContV (k : cont S) τ σ α : - (Γ ⊢ᵪ k : τ ⤞ σ) → - (Γ; α ⊢ᵥ (ContV k) : (Tcont τ σ); α) -where "Γ ';' α '⊢ᵥ' e ':' τ ';' β" := (typed_val Γ α e τ β) : types -(* unnecessary *) -with typed_cont {S : Set} (Γ : S -> ty) : cont S -> ty -> ty -> Prop := -| typed_END τ : - (Γ ⊢ᵪ END : τ ⤞ τ) -| typed_IfK k e₁ e₂ α β τ : - (Γ; α ⊢ₑ e₁ : τ; β) -> - (Γ; α ⊢ₑ e₂ : τ; β) -> - (Γ ⊢ᵪ k : τ ⤞ α) -> - (Γ ⊢ᵪ IfK e₁ e₂ k : Tnat ⤞ β) -| typed_NatOpLK op v k α τ : - (Γ; τ ⊢ᵥ v : Tnat; α) -> - (Γ ⊢ᵪ k : Tnat ⤞ τ) -> - (Γ ⊢ᵪ NatOpLK op v k : Tnat ⤞ α) -| typed_NatOpRK op e k α τ : - (Γ; τ ⊢ₑ e : Tnat; α) -> - (Γ ⊢ᵪ k : Tnat ⤞ τ) -> - (Γ ⊢ᵪ NatOpRK op e k : Tnat ⤞ α) -| typed_AppLK e k α β τ δ η : - (Γ; β ⊢ₑ e : δ; η) -> - (Γ ⊢ᵪ k : τ ⤞ α) -> - (Γ ⊢ᵪ AppLK e k : (Tarr δ α τ β) ⤞ η) -| typed_AppRK v k α β τ δ : - (∀ η, Γ; η ⊢ᵥ v : (Tarr τ α δ β); η) → - (Γ ⊢ᵪ k : δ ⤞ α) → - (Γ ⊢ᵪ AppRK v k : τ ⤞ β) -(* (* | typed_AppContLK v k τ : *) *) -(* (* (Γ; τ ⊢ᵪ AppContLK v k : τ; τ) *) *) -(* (* | typed_AppContRK e k τ : *) *) -(* (* (Γ; τ ⊢ᵪ AppContRK e k : τ; τ) *) *) -where "Γ '⊢ᵪ' e ':' τ '⤞' σ" := (typed_cont Γ e τ σ) : types -. - -Module Example. - Open Scope types. - - Lemma typ_example1 α : - empty_env; α ⊢ₑ ((#1) + - (reset - ((#3) - + (shift/cc ((($0) @k #5) + (($0) @k #6)))))) - : Tnat; α. - Proof. - eapply typed_NatOp. - - apply typed_Val. - apply typed_LitV. - - eapply typed_Reset. - eapply typed_NatOp. - + apply typed_Val. - apply typed_LitV. - + eapply typed_Shift. - eapply typed_NatOp. - * eapply typed_AppCont. - -- apply typed_Var. - reflexivity. - -- apply typed_Val. - apply typed_LitV. - * eapply typed_AppCont. - -- apply typed_Var. - reflexivity. - -- apply typed_Val. - apply typed_LitV. - Qed. - -End Example. - Open Scope stdpp_scope. Section logrel. @@ -279,30 +149,6 @@ Section logrel. (□ ∀ γ, ssubst_valid Γ γ -∗ logrel τ α σ (e γ))%I. - Lemma compat_empty P : - ⊢ logrel_mcont P []. - Proof. - iIntros (v) "Pv HH". - iApply (wp_pop_end with "HH"). - iNext. - iIntros "_ HHH". - by iApply wp_val. - Qed. - - Lemma compat_cons P Q (x : HOM) (xs : list (later IT -n> later IT)) : - ⊢ logrel_ectx P Q x - -∗ logrel_mcont Q xs - -∗ logrel_mcont P (laterO_map (𝒫 ◎ `x) :: xs). - Proof. - iIntros "#H G". - iIntros (v) "Hv Hst". - iApply (wp_pop_cons with "Hst"). - iNext. - iIntros "_ Hst". - iSpecialize ("H" $! v with "Hv"). - iApply ("H" $! xs with "G Hst"). - Qed. - Lemma compat_HOM_id P : ⊢ logrel_ectx P P HOM_id. Proof. @@ -488,99 +334,6 @@ Section logrel. iApply ("H" with "Hκ Hσ Hst"). Qed. - Program Definition AppContRSCtx_HOM {S : Set} - (α : @interp_scope F R _ S -n> IT) - (env : @interp_scope F R _ S) - : HOM := exist _ (interp_app_contrk rs α (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - - Program Definition AppContLSCtx_HOM {S : Set} - (β : IT) (env : @interp_scope F R _ S) - (Hv : AsVal β) - : HOM := exist _ (interp_app_contlk rs (constO β) (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - intros ???. - do 2 f_equiv. - intros ?; simpl. - solve_proper. - - rewrite get_val_ITV. - rewrite get_val_ITV. - simpl. - rewrite get_fun_tick. - reflexivity. - - rewrite get_val_ITV. - simpl. rewrite get_fun_vis. simpl. - f_equiv. - intros ?; simpl. - apply later_map_ext. - intros ?; simpl. - rewrite get_val_ITV. - simpl. - reflexivity. - - rewrite get_val_ITV. simpl. rewrite get_fun_err. reflexivity. - Qed. - - Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) - (α : @interp_scope F R _ S -n> IT) (env : @interp_scope F R _ S) - : HOM := exist _ (interp_natoprk rs op α (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - - Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) - (α : IT) (env : @interp_scope F R _ S) - (Hv : AsVal α) - : HOM := exist _ (interp_natoplk rs op (constO α) (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - - Program Definition AppLSCtx_HOM {S : Set} - (α : @interp_scope F R _ S -n> IT) - (env : @interp_scope F R _ S) - : HOM := exist _ (interp_applk rs α (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - - Transparent LET. - Program Definition AppRSCtx_HOM {S : Set} - (β : IT) (env : @interp_scope F R _ S) - (Hv : AsVal β) - : HOM := exist _ (interp_apprk rs (constO β) (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - solve_proper_please. - - rewrite get_val_ITV. - simpl. - rewrite get_val_ITV. - simpl. - rewrite get_val_tick. - reflexivity. - - rewrite get_val_ITV. - simpl. - rewrite get_val_vis. - do 3 f_equiv. - intro; simpl. - rewrite get_val_ITV. - simpl. - reflexivity. - - rewrite get_val_ITV. - simpl. - rewrite get_val_err. - reflexivity. - Qed. - Opaque LET. - Lemma compat_nat_op {S : Set} (Γ : S → ty) D E F e1 e2 op : ⊢ valid Γ e1 Tnat E F @@ -898,458 +651,12 @@ Section logrel. iApply ("Hκ" with "Hw Hm Hst"). Qed. - (* unnecessary *) - Program Definition valid_ectx {S : Set} - (Γ : S -> ty) - (e : interp_scope S -n> IT -n> IT) - `{∀ γ, IT_hom (e γ)} - (τ α : ty) : iProp := - (□ ∀ γ, ssubst_valid Γ γ - -∗ logrel_ectx (interp_ty τ) (interp_ty α) (exist _ (e γ) _))%I. - Next Obligation. - intros; apply _. - Qed. - - Lemma compat_end {S : Set} (Γ : S → ty) τ - : ⊢ valid_ectx Γ (interp_cont rs END) τ τ. - Proof. - iIntros (γ). - iModIntro. - iIntros "#H". - iApply compat_HOM_id. - Qed. - - Lemma compat_natop_r {S : Set} (Γ : S → ty) α τ - op t (E : interp_scope S -n> IT -n> IT) - `{∀ γ, IT_hom (E γ)} - `{∀ γ, IT_hom (interp_natoprk _ op t E γ)} : - ⊢ valid_ectx Γ E Tnat τ - -∗ valid Γ t Tnat τ α - -∗ valid_ectx Γ (interp_natoprk _ op t E) Tnat α. - Proof. - iIntros "#H #G". - iIntros (γ). - iModIntro. - iIntros "#Hγ". - iIntros (v). - iModIntro. - iIntros "#Hv". - iIntros (m) "Hm Hst". - - pose (κ' := (NatOpLSCtx_HOM op (IT_of_V v) γ _)). - simpl. - assert (E γ (NATOP (do_natop op) (t γ) (IT_of_V v)) = ((E γ ◎ `κ') (t γ))) - as -> by done. - iSpecialize ("G" $! γ with "Hγ"). - unshelve iApply ("G" $! (exist _ (E γ ◎ `κ') _) with "[] Hm Hst"). - { apply _. } - simpl. - - iIntros (w). - iModIntro. - iIntros "#Hw". - iIntros (m') "Hm Hst". - simpl. - - iDestruct "Hw" as "(%n & #HEQ1)". - iDestruct "Hv" as "(%n' & #HEQ2)". - iSpecialize ("H" $! γ with "Hγ"). - iSpecialize ("H" $! (RetV (do_natop op n n')) with "[]"). - { - iExists _. - iPureIntro. - reflexivity. - } - iSpecialize ("H" $! m' with "Hm Hst"). - rewrite IT_of_V_Ret. - - iAssert ((NATOP (do_natop op) (IT_of_V w) (IT_of_V v)) - ≡ (Ret (do_natop op n n')))%I as "#HEQ". - { - iRewrite "HEQ2". - rewrite IT_of_V_Ret. - iAssert ((IT_of_V w) ≡ IT_of_V (RetV n))%I as "#HEQ1'". - { - iApply f_equivI. - iApply "HEQ1". - } - rewrite IT_of_V_Ret. - iAssert (NATOP (do_natop op) (IT_of_V w) (Ret n') - ≡ NATOP (do_natop op) (Ret n) (Ret n'))%I as "#HEQ2''". - { - unshelve iApply (f_equivI (λne x, NATOP (do_natop op) x (Ret n'))). - { solve_proper. } - { solve_proper. } - iApply "HEQ1'". - } - iRewrite "HEQ2''". - rewrite NATOP_Ret. - done. - } - iRewrite "HEQ". - simpl. - iApply "H". - Qed. - - Lemma compat_natop_l {S : Set} (Γ : S → ty) α τ - op (t : interp_scope S -n> IT) (E : interp_scope S -n> IT -n> IT) - `{∀ γ, IT_hom (E γ)} - `{∀ γ, AsVal (t γ)} - `{∀ γ, IT_hom (interp_natoplk _ op t E γ)} : - ⊢ valid_ectx Γ E Tnat τ - -∗ valid Γ t Tnat τ α - -∗ valid_ectx Γ (interp_natoplk _ op t E) Tnat α. - Proof. - iIntros "#H #G". - iIntros (γ). - iModIntro. - iIntros "#Hγ". - iIntros (v). - iModIntro. - iIntros "#Hv". - iIntros (m) "Hm Hst". - simpl. - pose (κ' := (NATOP (do_natop op) (IT_of_V v))). - simpl. - assert (E γ (NATOP (do_natop op) (IT_of_V v) (t γ)) = ((E γ ◎ κ') (t γ))) - as -> by done. - iSpecialize ("G" $! γ with "Hγ"). - unshelve iApply ("G" $! (exist _ (E γ ◎ κ') _) with "[] Hm Hst"). - { apply _. } - subst κ'. - simpl. - - iIntros (w). - iModIntro. - iIntros "#Hw". - iIntros (m') "Hm Hst". - simpl. - - iSpecialize ("H" $! γ with "Hγ"). - - iDestruct "Hw" as "(%n & #HEQ1)". - iDestruct "Hv" as "(%n' & #HEQ2)". - iSpecialize ("H" $! (RetV (do_natop op n' n)) with "[]"). - { - iExists _. - iPureIntro. - reflexivity. - } - iSpecialize ("H" $! m' with "Hm Hst"). - rewrite IT_of_V_Ret. - - iAssert ((NATOP (do_natop op) (IT_of_V v) (IT_of_V w)) - ≡ (Ret (do_natop op n' n)))%I as "#HEQ". - { - iRewrite "HEQ1". - rewrite IT_of_V_Ret. - iAssert ((IT_of_V v) ≡ IT_of_V (RetV n'))%I as "#HEQ2'". - { - iApply f_equivI. - iApply "HEQ2". - } - rewrite IT_of_V_Ret. - iAssert (NATOP (do_natop op) (IT_of_V v) (Ret n) - ≡ NATOP (do_natop op) (Ret n') (Ret n))%I as "#HEQ2''". - { - unshelve iApply (f_equivI (λne x, NATOP (do_natop op) x (Ret n))). - { solve_proper. } - { solve_proper. } - iApply "HEQ2'". - } - iRewrite "HEQ2''". - rewrite NATOP_Ret. - done. - } - iRewrite "HEQ". - iApply "H". - Qed. - - Lemma compat_ifk {S : Set} (Γ : S -> ty) - (E : interp_scope S -n> IT -n> IT) - e₁ e₂ - `{∀ γ, IT_hom (E γ)} - `{∀ γ, IT_hom (interp_ifk rs e₁ e₂ E γ)} - (τ α β : ty) : - ⊢ valid_ectx Γ E τ α - -∗ valid Γ e₁ τ α β - -∗ valid Γ e₂ τ α β - -∗ valid_ectx Γ (interp_ifk rs e₁ e₂ E) Tnat β. - Proof. - iIntros "#H #G #J". - iModIntro. - iIntros (γ) "#Henv". - iSpecialize ("H" $! γ with "Henv"). - - iIntros (v). - iModIntro. - iIntros "#Hv". - iIntros (σ'') "Hm Hst". - iDestruct "Hv" as "(%n & #Hv)". - iRewrite "Hv". - rewrite IT_of_V_Ret. - simpl. - destruct (decide (0 < n)) as [?|?]. - - rewrite IF_True//. - iSpecialize ("G" $! γ with "Henv"). - unshelve iSpecialize ("G" $! (exist _ (E γ) _)). - { apply _. } - iApply ("G" with "H Hm Hst"). - - rewrite IF_False//; last lia. - iSpecialize ("J" $! γ with "Henv"). - unshelve iSpecialize ("J" $! (exist _ (E γ) _)). - { apply _. } - iApply ("J" with "H Hm Hst"). - Qed. - - Lemma compat_app_l {S : Set} (Γ : S → ty) τ δ α β η t - (E : interp_scope S -n> IT -n> IT) - `{∀ γ, IT_hom (E γ)} - `{∀ γ, IT_hom (interp_applk _ t E γ)} : - ⊢ valid_ectx Γ E τ α - -∗ valid Γ t δ β η - -∗ valid_ectx Γ (interp_applk _ t E) (Tarr δ α τ β) η. - Proof. - iIntros "#H #G". - iIntros (γ). - iModIntro. - iIntros "#Hγ". - iIntros (v). - iModIntro. - iIntros "#Hv". - iIntros (m) "Hm Hst". - - simpl. - rewrite LET_Val. - simpl. - - match goal with - | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ LET ?a) ?b] => - set (F := b) - end. - pose (κ'' := exist _ (LETCTX F) (LETCTX_Hom F) : HOM). - assert (((E γ) (LET (t γ) F)) = (((E γ) ◎ (`κ'')) (t γ))) as ->. - { reflexivity. } - pose (sss := (HOM_compose (exist _ (E γ) (H _)) κ'')). - assert ((E γ ◎ `κ'') = (`sss)) as ->. - { reflexivity. } - iSpecialize ("G" $! γ with "Hγ"). - iSpecialize ("G" $! sss). - iApply ("G" with "[H] Hm Hst"). - iIntros (w). - iModIntro. - iIntros "#Hw". - iIntros (m'') "Hm Hst". - subst sss. - subst κ''. - simpl. - rewrite LET_Val. - subst F. - cbn [ofe_mor_car]. - - iDestruct "Hv" as "(%n' & #HEQ & Hv)". - iSpecialize ("Hv" $! w with "Hw"). - iAssert ((IT_of_V v ⊙ (IT_of_V w)) - ≡ (Fun n' ⊙ (IT_of_V w)))%I as "#HEQ'". - { - iApply (f_equivI (λne x, (x ⊙ (IT_of_V w)))). - iApply "HEQ". - } - iRewrite "HEQ'". - unshelve iApply ("Hv" $! (exist _ (E γ) _) with "[H] Hm Hst"). - - apply _. - - by iApply "H". - Qed. - - Lemma compat_app_r {S : Set} (Γ : S → ty) τ δ α β - (t : interp_scope S -n> IT) - (E : interp_scope S -n> IT -n> IT) - `{∀ γ, IT_hom (E γ)} - `{∀ γ, AsVal (t γ)} - `{∀ γ, IT_hom (interp_apprk _ t E γ)} : - ⊢ valid_ectx Γ E δ α - -∗ (∀ η, valid Γ t (Tarr τ α δ β) η η) - -∗ valid_ectx Γ (interp_apprk _ t E) τ β. - Proof. - iIntros "#H #G". - iIntros (γ). - assert (AsVal (t γ)). - { apply _. } - iModIntro. - iIntros "#Hγ". - iIntros (v). - iModIntro. - iIntros "#Hv". - iIntros (m) "Hm Hst". - simpl. - rewrite LET_Val. - simpl. - rewrite LET_Val. - simpl. - - unshelve epose (κ := exist _ (flipO APP' (IT_of_V v)) _ : HOM); - first apply _. - assert (((E γ) (t γ ⊙ (IT_of_V v))) = (((E γ) ◎ (`κ)) (t γ))) as ->. - { reflexivity. } - unshelve epose (sss := (HOM_compose (exist _ (E γ) _) κ)); - first apply _. - assert ((E γ ◎ `κ) = (`sss)) as ->. - { reflexivity. } - iSpecialize ("G" $! β γ with "Hγ"). - iSpecialize ("G" $! sss). - iApply ("G" with "[H] Hm Hst"). - iIntros (w). - iModIntro. - iIntros "#Hw". - iIntros (m'') "Hm Hst". - subst sss. - subst κ. - simpl. - - iDestruct "Hw" as "(%n' & #HEQ & Hw)". - iSpecialize ("Hw" $! v with "Hv"). - unshelve iSpecialize ("Hw" $! (exist _ (E γ) _) with "[H]"); - first apply _. - - iIntros (q). - iModIntro. - iIntros "#Hq". - iIntros (m''') "Hm Hst". - simpl. - iApply ("H" with "Hγ Hq Hm Hst"). - - iSpecialize ("Hw" $! m'' with "Hm Hst"). - iAssert ((IT_of_V w ⊙ (IT_of_V v)) - ≡ (Fun n' ⊙ (IT_of_V v)))%I as "#HEQ'". - { - iApply (f_equivI (λne x, (x ⊙ (IT_of_V v)))). - iApply "HEQ". - } - iRewrite "HEQ'". - iApply "Hw". - Qed. - - (* Lemma compat_appk_r {S : Set} (Γ : S → ty) τ α η t *) - (* (E : interp_scope S -n> IT -n> IT) *) - (* `{∀ γ, IT_hom (E γ)} *) - (* `{∀ γ, IT_hom (interp_app_contrk _ t E γ)} : *) - (* ⊢ valid_ectx Γ E τ α *) - (* -∗ (∀ β, valid Γ t (Tcont α η) β β) *) - (* -∗ valid_ectx Γ (interp_app_contrk _ t E) τ η. *) - (* Proof. *) - (* iIntros "#H #G". *) - (* iIntros (γ). *) - (* iModIntro. *) - (* iIntros "#Hγ". *) - (* iIntros (v). *) - (* iModIntro. *) - (* iIntros "#Hv". *) - (* iIntros (m) "Hm Hst". *) - (* simpl. *) - (* rewrite get_val_ITV. *) - (* simpl. *) - (* match goal with *) - (* | |- context G [get_fun ?a] => *) - (* set (F := a) *) - (* end. *) - (* unshelve epose (FH := exist _ (E γ ◎ (get_fun F)) _ : HOM); *) - (* first apply _. *) - (* iSpecialize ("G" $! η γ with "Hγ"). *) - (* iApply ("G" $! FH with "[H] Hm Hst"). *) - (* iIntros (w). *) - (* iModIntro. *) - (* iIntros "#Hw". *) - (* iIntros (m') "Hm Hst". *) - (* simpl. *) - (* iDestruct "Hw" as "(%n' & #HEQ & #Hw)". *) - (* iRewrite "HEQ". *) - (* rewrite get_fun_fun. *) - (* simpl. *) - (* rewrite hom_vis. *) - (* rewrite get_val_vis. *) - (* iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ *) - (* (NextO (Tick ((𝒫 ◎ `n') (IT_of_V v)))) with "Hst"); *) - (* [| reflexivity |]. *) - (* - simpl. *) - (* do 2 f_equiv. *) - (* + rewrite later_map_Next. *) - (* f_equiv. *) - (* rewrite Tick_eq. *) - (* reflexivity. *) - (* + reflexivity. *) - (* - iNext. *) - (* iIntros "_ Hst". *) - (* simpl. *) - (* iApply wp_tick. *) - (* iNext. *) - (* iSpecialize ("Hw" with ""). *) - (* Admitted. *) - - (* Lemma compat_appk_l {S : Set} (Γ : S → ty) τ δ α β *) - (* (t : interp_scope S -n> IT) *) - (* (E : interp_scope S -n> IT -n> IT) *) - (* `{∀ γ, IT_hom (E γ)} *) - (* `{∀ γ, AsVal (t γ)} *) - (* `{∀ γ, IT_hom (interp_app_contlk _ t E γ)} : *) - (* ⊢ valid_ectx Γ E δ α *) - (* -∗ (∀ η, valid Γ t (Tarr τ α δ β) η η) *) - (* -∗ valid_ectx Γ (interp_app_contlk _ t E) τ β. *) - (* Proof. *) - (* iIntros "#H #G". *) - (* iIntros (γ). *) - (* iModIntro. *) - (* iIntros "#Hγ". *) - (* iIntros (v). *) - (* iModIntro. *) - (* iIntros "#Hv". *) - (* iIntros (m) "Hm Hst". *) - (* simpl. *) - (* rewrite get_val_ITV. *) - (* simpl. *) - (* Admitted. *) - - Lemma compat_cont {S : Set} (Γ : S -> ty) τ σ - (k : interp_scope S -n> IT -n> IT) - `{∀ γ : interp_scope S, IT_hom (k γ)} - : ⊢ valid_ectx Γ k τ σ - -∗ ∀ α, valid Γ (interp_cont_val rs k) (Tcont τ σ) α α. - Proof. - iIntros "#H". - iIntros (α γ). - iModIntro. - iIntros "#Hγ". - iIntros (κ) "Hκ". - iIntros (m) "Hm Hst". - iSpecialize ("H" $! γ with "Hγ"). - unfold interp_cont_val. - simpl. - match goal with - | |- context G [ofe_mor_car _ _ Fun ?a] => - set (F := a) - end. - iSpecialize ("Hκ" $! (FunV F)). - iApply ("Hκ" with "[] Hm Hst"). - iExists (exist _ (k γ) (H _)). - iSplit. - - subst F. - Transparent IT_of_V. - simpl. - iPureIntro. - do 2 f_equiv. - intros ?; simpl. - rewrite later_map_Next. - rewrite Tick_eq. - reflexivity. - - iModIntro. - iApply "H". - Qed. - Open Scope types. Lemma fundamental_expr {S : Set} (Γ : S -> ty) τ α β e : Γ; α ⊢ₑ e : τ; β → ⊢ valid Γ (interp_expr rs e) τ α β with fundamental_val {S : Set} (Γ : S -> ty) τ α β v : - Γ; α ⊢ᵥ v : τ; β → ⊢ valid Γ (interp_val rs v) τ α β - with fundamental_cont {S : Set} (Γ : S -> ty) τ σ κ : - Γ ⊢ᵪ κ : τ ⤞ σ → ⊢ valid_ectx Γ (interp_cont rs κ) τ σ. + Γ; α ⊢ᵥ v : τ; β → ⊢ valid Γ (interp_val rs v) τ α β. Proof. - intros H. destruct H. @@ -1372,30 +679,6 @@ Section logrel. + iApply compat_nat. + iApply (compat_recV with "[]"); by iApply fundamental_expr. - + iPoseProof (fundamental_cont _ _ _ _ _ H) as "H". - iDestruct (compat_cont with "H") as "G". - iSpecialize ("G" $! α). - iApply "G". - - (* unnecessary *) - intros H. - destruct H. - + iApply compat_end. - + iApply compat_ifk; - [ by iApply fundamental_cont - | by iApply fundamental_expr - | by iApply fundamental_expr]. - + iApply compat_natop_l; - [ by iApply fundamental_cont - | by iApply fundamental_val]. - + iApply compat_natop_r; - [ by iApply fundamental_cont - | by iApply fundamental_expr]. - + iApply compat_app_l; - [ by iApply fundamental_cont - | by iApply fundamental_expr]. - + iApply compat_app_r; - [ by iApply fundamental_cont - | iIntros (?); by iApply fundamental_val]. Qed. End logrel. diff --git a/theories/examples/delim_lang/logrel.v b/theories/examples/delim_lang/logrel.v index 5e939b7..5d5de35 100644 --- a/theories/examples/delim_lang/logrel.v +++ b/theories/examples/delim_lang/logrel.v @@ -1,6 +1,6 @@ From gitrees Require Import gitree lang_generic hom. From gitrees.effects Require Import delim. -From gitrees.examples.delim_lang Require Import lang interp. +From gitrees.examples.delim_lang Require Import lang interp typing hom. From iris.algebra Require Import list. From iris.proofmode Require Import classes tactics. From iris.base_logic Require Import algebra. @@ -8,99 +8,6 @@ From iris.base_logic Require Import algebra. Require Import Binding.Lib Binding.Set Binding.Env. Open Scope syn. - -Inductive ty := -| Tnat : ty -| Tarr : ty -> ty -> ty -> ty -> ty -| Tcont : ty → ty → ty. - -Declare Scope types. - -Notation "τ '∕' α '→' σ '∕' β" := (Tarr τ α σ β) (at level 60) : types. -Notation "'Cont' τ σ" := (Tcont τ σ) (at level 60) : types. - -Reserved Notation "Γ ';' α '⊢ₑ' e ':' τ ';' β" - (at level 90, e at next level, τ at level 20, no associativity). - -Reserved Notation "Γ ';' α '⊢ᵥ' e ':' τ ';' β" - (at level 90, e at next level, τ at level 20, no associativity). - -Reserved Notation "Γ '⊢ᵪ' e ':' τ '⤞' σ" - (at level 90, e at next level, τ at level 20, no associativity). - -Inductive typed_expr {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := -| typed_Val v α τ β : - (Γ; α ⊢ᵥ v : τ; β) → - (Γ; α ⊢ₑ v : τ; β) -| typed_Var x τ α : - (Γ x = τ) → - (Γ; α ⊢ₑ (Var x) : τ; α) -| typed_App e₁ e₂ γ α β δ σ τ : - (Γ; γ ⊢ₑ e₁ : (Tarr σ α τ β); δ) → - (Γ; β ⊢ₑ e₂ : σ; γ) → - (Γ; α ⊢ₑ (App e₁ e₂) : τ; δ) -| typed_AppCont e₁ e₂ α β δ σ τ : - (Γ; σ ⊢ₑ e₁ : (Tcont τ α); δ) → - (Γ; δ ⊢ₑ e₂ : τ; β) → - (Γ; σ ⊢ₑ (AppCont e₁ e₂) : α; β) -| typed_NatOp o e₁ e₂ α β γ : - (Γ; α ⊢ₑ e₁ : Tnat; β) → - (Γ; β ⊢ₑ e₂ : Tnat; γ) → - (Γ; α ⊢ₑ NatOp o e₁ e₂ : Tnat; γ) -| typed_If e e₁ e₂ α β σ τ : - (Γ; β ⊢ₑ e : Tnat; α) → - (Γ; σ ⊢ₑ e₁ : τ; β) → - (Γ; σ ⊢ₑ e₂ : τ; β) → - (Γ; σ ⊢ₑ (if e then e₁ else e₂) : τ; α) -| typed_Shift (e : @expr (inc S)) τ α σ β : - (Γ ▹ (Tcont τ α); σ ⊢ₑ e : σ; β) → - (Γ; α ⊢ₑ Shift e : τ; β) -| typed_Reset e α σ τ : - (Γ; σ ⊢ₑ e : σ; τ) → - (Γ; α ⊢ₑ reset e : τ; α) -where "Γ ';' α '⊢ₑ' e ':' τ ';' β" := (typed_expr Γ α e τ β) : types -with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := -| typed_LitV n α : - (Γ; α ⊢ᵥ #n : Tnat; α) -| typed_RecV (e : expr (inc (inc S))) (δ σ τ α β : ty) : - ((Γ ▹ (Tarr σ α τ β) ▹ σ); α ⊢ₑ e : τ; β) -> - (Γ; δ ⊢ᵥ (RecV e) : (Tarr σ α τ β); δ) -where "Γ ';' α '⊢ᵥ' e ':' τ ';' β" := (typed_val Γ α e τ β) : types -. - -Module Example. - Open Scope types. - - Lemma typ_example1 α : - empty_env; α ⊢ₑ ((#1) + - (reset - ((#3) - + (shift/cc ((($0) @k #5) + (($0) @k #6)))))) - : Tnat; α. - Proof. - eapply typed_NatOp. - - apply typed_Val. - apply typed_LitV. - - eapply typed_Reset. - eapply typed_NatOp. - + apply typed_Val. - apply typed_LitV. - + eapply typed_Shift. - eapply typed_NatOp. - * eapply typed_AppCont. - -- apply typed_Var. - reflexivity. - -- apply typed_Val. - apply typed_LitV. - * eapply typed_AppCont. - -- apply typed_Var. - reflexivity. - -- apply typed_Val. - apply typed_LitV. - Qed. - -End Example. - Open Scope stdpp_scope. Section logrel. @@ -345,43 +252,6 @@ Section logrel. iApply ("Hss" with "HE HF Hσ"). Qed. - Lemma step_pack {S : Set} (a b : config S) : - ∀ nm, Cred a b nm → stepEx a b. - Proof. - intros nm H. - by exists nm. - Qed. - - Lemma steps_pack {S : Set} (a b : config S) : - ∀ nm, steps a b nm → stepsEx a b. - Proof. - intros nm H. - by exists nm. - Qed. - - Lemma step_det {S : Set} (c c' c'' : config S) - : stepEx c c' → stepEx c c'' → c' = c''. - Proof. - intros [nm H]. - revert c''. - inversion H; subst; intros c'' [nm' G]; - inversion G; subst; simplify_eq; reflexivity. - Qed. - - Lemma steps_det_val {S : Set} (c c' : config S) (v : val S) - : stepsEx c (Cret v) → stepEx c c' → stepsEx c' (Cret v). - Proof. - intros [n H]. - revert c'. - inversion H; subst; intros c' G. - - destruct G as [? G]. - inversion G. - - erewrite (step_det c c' c2). - + by eapply steps_pack. - + assumption. - + by eapply step_pack. - Qed. - Lemma compat_reset {S : Set} (Γ : S -> ty) e (e' : exprO S) σ τ : ⊢ valid Γ e e' σ σ τ -∗ (∀ α, valid Γ (interp_reset rs e) (reset e') τ α α). Proof. @@ -451,7 +321,7 @@ Section logrel. Qed. Lemma compat_shift {S : Set} (Γ : S -> ty) e (e' : exprO (inc S)) σ α τ β : - ⊢ valid (Γ ▹ (Tcont τ α)) e e' σ σ β -∗ valid Γ (interp_shift _ e) (Shift e') τ α β. + ⊢ valid (Γ ▹ (τ ⤑ α)) e e' σ σ β -∗ valid Γ (interp_shift _ e) (shift/cc e') τ α β. Proof. iIntros "#H". iModIntro. @@ -521,7 +391,7 @@ Section logrel. Qed. Lemma compat_nat {S : Set} (Γ : S → ty) n α : - ⊢ valid Γ (interp_nat rs n) (LitV n) Tnat α α. + ⊢ valid Γ (interp_nat rs n) (#n) ℕ α α. Proof. iModIntro. iIntros (γ γ') "#Hγ". @@ -533,8 +403,8 @@ Section logrel. Lemma compat_recV {S : Set} (Γ : S -> ty) τ1 α τ2 β e (e' : expr (inc (inc S))) : - ⊢ valid ((Γ ▹ (Tarr τ1 α τ2 β) ▹ τ1)) e e' τ2 α β - -∗ (∀ θ, valid Γ (interp_rec rs e) (RecV e') (Tarr τ1 α τ2 β) θ θ). + ⊢ valid (Γ ▹ τ1 ∕ α → τ2 ∕ β ▹ τ1) e e' τ2 α β + -∗ (∀ θ, valid Γ (interp_rec rs e) (rec e') (τ1 ∕ α → τ2 ∕ β) θ θ). Proof. iIntros "#H". iIntros (θ). @@ -650,104 +520,11 @@ Section logrel. reflexivity. Qed. - Program Definition AppContRSCtx_HOM {S : Set} - (α : @interp_scope F R _ S -n> IT) - (env : @interp_scope F R _ S) - : HOM := exist _ (interp_app_contrk rs α (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - - Program Definition AppContLSCtx_HOM {S : Set} - (β : IT) (env : @interp_scope F R _ S) - (Hv : AsVal β) - : HOM := exist _ (interp_app_contlk rs (constO β) (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - intros ???. - do 2 f_equiv. - intros ?; simpl. - solve_proper. - - rewrite get_val_ITV. - rewrite get_val_ITV. - simpl. - rewrite get_fun_tick. - reflexivity. - - rewrite get_val_ITV. - simpl. rewrite get_fun_vis. simpl. - f_equiv. - intros ?; simpl. - apply later_map_ext. - intros ?; simpl. - rewrite get_val_ITV. - simpl. - reflexivity. - - rewrite get_val_ITV. simpl. rewrite get_fun_err. reflexivity. - Qed. - - Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) - (α : @interp_scope F R _ S -n> IT) (env : @interp_scope F R _ S) - : HOM := exist _ (interp_natoprk rs op α (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - - Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) - (α : IT) (env : @interp_scope F R _ S) - (Hv : AsVal α) - : HOM := exist _ (interp_natoplk rs op (constO α) (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - - Program Definition AppLSCtx_HOM {S : Set} - (α : @interp_scope F R _ S -n> IT) - (env : @interp_scope F R _ S) - : HOM := exist _ (interp_applk rs α (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - - Transparent LET. - Program Definition AppRSCtx_HOM {S : Set} - (β : IT) (env : @interp_scope F R _ S) - (Hv : AsVal β) - : HOM := exist _ (interp_apprk rs (constO β) (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - solve_proper_please. - - rewrite get_val_ITV. - simpl. - rewrite get_val_ITV. - simpl. - rewrite get_val_tick. - reflexivity. - - rewrite get_val_ITV. - simpl. - rewrite get_val_vis. - do 3 f_equiv. - intro; simpl. - rewrite get_val_ITV. - simpl. - reflexivity. - - rewrite get_val_ITV. - simpl. - rewrite get_val_err. - reflexivity. - Qed. - Opaque LET. - Lemma compat_nat_op {S : Set} (Γ : S → ty) - D E F e1 e2 (e1' e2' : exprO S) op : - ⊢ valid Γ e1 e1' Tnat E F - -∗ valid Γ e2 e2' Tnat F D - -∗ valid Γ (interp_natop rs op e1 e2) (NatOp op e1' e2') Tnat E D. + D E F e1 e2 (e1' e2' : expr S) op : + ⊢ valid Γ e1 e1' ℕ E F + -∗ valid Γ e2 e2' ℕ F D + -∗ valid Γ (interp_natop rs op e1 e2) (NatOp op e1' e2') ℕ E D. Proof. iIntros "#H #G". iModIntro. @@ -879,7 +656,7 @@ Section logrel. Lemma compat_app {S : Set} (Γ : S → ty) ξ α β δ η τ e1 e2 (e1' e2' : expr S) : - ⊢ valid Γ e1 e1' (Tarr η α τ β) ξ δ + ⊢ valid Γ e1 e1' (η ∕ α → τ ∕ β) ξ δ -∗ valid Γ e2 e2' η β ξ -∗ valid Γ (interp_app rs e1 e2) (e1' e2') τ α δ. Proof. @@ -1002,9 +779,9 @@ Section logrel. Qed. Lemma compat_appcont {S : Set} (Γ : S -> ty) e1 e2 (e1' e2' : expr S) τ α δ β σ : - valid Γ e1 e1' (Tcont τ α) σ δ + valid Γ e1 e1' (τ ⤑ α) σ δ -∗ valid Γ e2 e2' τ δ β - -∗ valid Γ (interp_app_cont _ e1 e2) (AppCont e1' e2') α σ β. + -∗ valid Γ (interp_app_cont _ e1 e2) (e1' @k e2') α σ β. Proof. iIntros "#H #G". iModIntro. @@ -1167,12 +944,12 @@ Section logrel. apply Q. Qed. - Lemma compat_if {S : Set} (Γ : S -> ty) e e' e₁ e₁' e₂ e₂' τ σ α β : - ⊢ valid Γ e e' Tnat β α + Lemma compat_if {S : Set} (Γ : S -> ty) e e₁ e₂ (e' e₁' e₂' : expr S) τ σ α β : + ⊢ valid Γ e e' ℕ β α -∗ valid Γ e₁ e₁' τ σ β -∗ valid Γ e₂ e₂' τ σ β -∗ valid Γ (interp_if rs e e₁ e₂) - (if (e' : expr S) then (e₁' : expr S) else (e₂' : expr S)) τ σ α. + (if e' then e₁' else e₂') τ σ α. Proof. iIntros "#H #G #J". iModIntro. @@ -1450,7 +1227,7 @@ Proof. Qed. Theorem adequacy (e : expr ∅) (k : nat) σ n : - (typed_expr empty_env Tnat e Tnat Tnat) → + (typed_expr □ Tnat e Tnat Tnat) → ssteps (gReifiers_sReifier rs) (𝒫 (interp_expr rs e ı_scope)) ([], ()) (Ret k : IT _ natO) σ n → ∃ mm, steps (Cexpr e) (Cret $ LitV k) mm. diff --git a/theories/examples/delim_lang/typing.v b/theories/examples/delim_lang/typing.v new file mode 100644 index 0000000..ccb17f9 --- /dev/null +++ b/theories/examples/delim_lang/typing.v @@ -0,0 +1,95 @@ +From gitrees.examples.delim_lang Require Import lang. + +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope syn. + +Inductive ty := +| Tnat : ty +| Tarr : ty -> ty -> ty -> ty -> ty +| Tcont : ty → ty → ty. + +Declare Scope types. + +Notation "'ℕ'" := (Tnat) : types. +Notation "τ '∕' α '→' σ '∕' β" := + (Tarr τ α σ β) + (at level 15 + , σ, α, β at level 10 + , no associativity) : types. +Notation "τ '⤑' σ" := (Tcont τ σ) (at level 10, left associativity) : types. + +Reserved Notation "Γ ';' α '⊢ₑ' e ':' τ ';' β" + (at level 70 + , e at level 60 + , τ, α, β at level 20 + , no associativity). + +Reserved Notation "Γ ';' α '⊢ᵥ' e ':' τ ';' β" + (at level 70 + , e at level 60 + , τ, α, β at level 20 + , no associativity). + +Open Scope types. + +Inductive typed_expr {S : Set} (Γ : S -> ty) : ty -> expr S -> ty -> ty -> Prop := +| typed_Val v α τ β : + (Γ; α ⊢ᵥ v : τ; β) → + (Γ; α ⊢ₑ v : τ; β) +| typed_Var x τ α : + (Γ x = τ) → + (Γ; α ⊢ₑ (Var x) : τ; α) +| typed_App e₁ e₂ γ α β δ σ τ : + (Γ; γ ⊢ₑ e₁ : σ ∕ α → τ ∕ β; δ) → + (Γ; β ⊢ₑ e₂ : σ; γ) → + (Γ; α ⊢ₑ e₁ ⋆ e₂ : τ; δ) +| typed_AppCont e₁ e₂ α β δ σ τ : + (Γ; σ ⊢ₑ e₁ : τ ⤑ α; δ) → + (Γ; δ ⊢ₑ e₂ : τ; β) → + (Γ; σ ⊢ₑ e₁ @k e₂ : α; β) +| typed_NatOp o e₁ e₂ α β γ : + (Γ; α ⊢ₑ e₁ : ℕ; β) → + (Γ; β ⊢ₑ e₂ : ℕ; γ) → + (Γ; α ⊢ₑ NatOp o e₁ e₂ : ℕ; γ) +| typed_If e e₁ e₂ α β σ τ : + (Γ; β ⊢ₑ e : ℕ; α) → + (Γ; σ ⊢ₑ e₁ : τ; β) → + (Γ; σ ⊢ₑ e₂ : τ; β) → + (Γ; σ ⊢ₑ (if e then e₁ else e₂) : τ; α) +| typed_Shift (e : @expr (inc S)) τ α σ β : + (Γ ▹ τ ⤑ α; σ ⊢ₑ e : σ; β) → + (Γ; α ⊢ₑ shift/cc e : τ; β) +| typed_Reset e α σ τ : + (Γ; σ ⊢ₑ e : σ; τ) → + (Γ; α ⊢ₑ reset e : τ; α) +where "Γ ';' α '⊢ₑ' e ':' τ ';' β" := (typed_expr Γ α e τ β) : types +with typed_val {S : Set} (Γ : S -> ty) : ty -> val S -> ty -> ty -> Prop := +| typed_LitV n α : + (Γ; α ⊢ᵥ #n : ℕ; α) +| typed_RecV (e : expr (inc (inc S))) (δ σ τ α β : ty) : + (Γ ▹ (σ ∕ α → τ ∕ β) ▹ σ; α ⊢ₑ e : τ; β) -> + (Γ; δ ⊢ᵥ rec e : σ ∕ α → τ ∕ β; δ) +where "Γ ';' α '⊢ᵥ' e ':' τ ';' β" := (typed_val Γ α e τ β) : types +. + +Module Example. + Open Scope types. + + Lemma typ_example1 α : + □; α ⊢ₑ ((#1) + (reset ((#3) + (shift/cc ((($0) @k #5) + (($0) @k #6)))))) : Tnat; α. + Proof. + econstructor. + - do 2 constructor. + - do 2 econstructor. + + do 2 constructor. + + do 2 econstructor. + * econstructor. + -- by constructor. + -- do 2 constructor. + * econstructor. + -- by constructor. + -- do 2 constructor. + Qed. + +End Example. From 39c6ddf1b1d27bc881b4542ab5399273243af5d6 Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Tue, 11 Jun 2024 19:28:10 +0200 Subject: [PATCH 10/14] minor fixes --- _CoqProject | 2 +- theories/examples/delim_lang/example.v | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/_CoqProject b/_CoqProject index f8241b5..0359382 100644 --- a/_CoqProject +++ b/_CoqProject @@ -24,7 +24,7 @@ theories/gitree/reify.v theories/gitree/greifiers.v theories/gitree/reductions.v theories/gitree/weakestpre.v -theories/gitree/hom.v +theories/hom.v theories/gitree.v theories/program_logic.v diff --git a/theories/examples/delim_lang/example.v b/theories/examples/delim_lang/example.v index 60d32fc..59f043d 100644 --- a/theories/examples/delim_lang/example.v +++ b/theories/examples/delim_lang/example.v @@ -1,4 +1,5 @@ From gitrees Require Import gitree lang_generic. +From gitrees.effects Require Import delim. From gitrees.examples.delim_lang Require Import lang interp. From iris.proofmode Require Import base classes tactics environments. From iris.base_logic Require Import algebra. From 179a0f0bb08e0b31862692b5bc7d5ca520184e66 Mon Sep 17 00:00:00 2001 From: Sergei Stepanenko Date: Wed, 12 Jun 2024 12:17:23 +0200 Subject: [PATCH 11/14] missing notation --- theories/examples/delim_lang/logrel.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/examples/delim_lang/logrel.v b/theories/examples/delim_lang/logrel.v index 5d5de35..f9e5106 100644 --- a/theories/examples/delim_lang/logrel.v +++ b/theories/examples/delim_lang/logrel.v @@ -1227,7 +1227,7 @@ Proof. Qed. Theorem adequacy (e : expr ∅) (k : nat) σ n : - (typed_expr □ Tnat e Tnat Tnat) → + (empty_env; ℕ ⊢ₑ e : ℕ; ℕ)%type → ssteps (gReifiers_sReifier rs) (𝒫 (interp_expr rs e ı_scope)) ([], ()) (Ret k : IT _ natO) σ n → ∃ mm, steps (Cexpr e) (Cret $ LitV k) mm. From b33aa397fbd8707bd529908c6f0b9b0f3555ea3d Mon Sep 17 00:00:00 2001 From: Dan Date: Tue, 18 Jun 2024 09:21:07 +0200 Subject: [PATCH 12/14] a bit of cleaning --- theories/examples/delim_lang/hom.v | 5 +---- theories/examples/delim_lang/interp.v | 2 +- theories/examples/delim_lang/logrel.v | 27 +++++++++++++-------------- theories/hom.v | 5 +---- 4 files changed, 16 insertions(+), 23 deletions(-) diff --git a/theories/examples/delim_lang/hom.v b/theories/examples/delim_lang/hom.v index 1bce1e5..74b28da 100644 --- a/theories/examples/delim_lang/hom.v +++ b/theories/examples/delim_lang/hom.v @@ -32,10 +32,7 @@ Section hom. Next Obligation. intros; simpl. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - intros ???. - do 2 f_equiv. - intros ?; simpl. - solve_proper. + - solve_proper_please. - rewrite get_val_ITV. rewrite get_val_ITV. simpl. diff --git a/theories/examples/delim_lang/interp.v b/theories/examples/delim_lang/interp.v index dbc210d..f111241 100644 --- a/theories/examples/delim_lang/interp.v +++ b/theories/examples/delim_lang/interp.v @@ -762,7 +762,7 @@ Section interp. trans (reify (gReifiers_sReifier rs) (APP_CONT_ (Next (interp_val v env)) fin kk) - (gState_recomp σr (sR_state (σ)))). + (gState_recomp σr (sR_state σ))). { repeat f_equiv. rewrite get_val_ITV. simpl. rewrite get_fun_fun. simpl. rewrite !hom_vis. f_equiv. subst kk. rewrite ccompose_id_l. intro. simpl. diff --git a/theories/examples/delim_lang/logrel.v b/theories/examples/delim_lang/logrel.v index f9e5106..f52634c 100644 --- a/theories/examples/delim_lang/logrel.v +++ b/theories/examples/delim_lang/logrel.v @@ -52,6 +52,15 @@ Section logrel. Solve All Obligations with solve_proper. Fail Next Obligation. + (** The configuration of the abstract machine (e, k, m) corresponds + to the "denotational configuration" tuple (t, κ, σ). + + The meta-continuation is stored in the state and the top-level + current continuation is explicitly invoked. + + At the top-level the refinement is explicitly about fully-evaluated + terms which compute to natural numbers. *) + Definition obs_ref' {S : Set} (t : IT) (κ : HOM) (σ : stateF ♯ IT) (e : exprO S) (k : contO S) (m : mcontO S) @@ -77,11 +86,8 @@ Section logrel. -n> exprO S -n> contO S -n> mcontO S -n> iProp := λne x y z a b c, obs_ref' x y z a b c. Solve All Obligations with try solve_proper. - Next Obligation. - intros. - intros ????????; simpl. - solve_proper. - Qed. + Next Obligation. solve_proper_please. Qed. + Definition logrel_mcont' {S : Set} (P : ITV -n> valO S -n> iProp) (F : stateF ♯ IT) (m : mcontO S) := @@ -196,14 +202,7 @@ Section logrel. -∗ ∀ F F', logrel_mcont δ F F' -∗ obs_ref e E F e' E' F')%I. Solve All Obligations with try solve_proper. - Next Obligation. - intros; intros ????; simpl. - do 2 (f_equiv; intro; simpl). - f_equiv. - do 2 (f_equiv; intro; simpl). - f_equiv. - solve_proper. - Qed. + Next Obligation. solve_proper_please. Qed. Definition logrel {S : Set} (τ α β : ty) : IT -n> exprO S -n> iProp := logrel_expr (interp_ty τ) (interp_ty α) (interp_ty β). @@ -219,7 +218,7 @@ Section logrel. (e' : exprO S) (τ α σ : ty) : iProp := (□ ∀ γ (γ' : S [⇒] Empty_set), ssubst_valid Γ γ γ' - -∗ @logrel Empty_set τ α σ (e γ) (bind (F := expr) γ' e'))%I. + -∗ logrel τ α σ (e γ) (bind (F := expr) γ' e'))%I. Lemma compat_HOM_id {S : Set} P : ⊢ @logrel_ectx S P P HOM_id END. diff --git a/theories/hom.v b/theories/hom.v index d6ce75f..fa20f10 100644 --- a/theories/hom.v +++ b/theories/hom.v @@ -4,12 +4,9 @@ Require Import Binding.Lib Binding.Set Binding.Env. Open Scope stdpp_scope. Section hom. - Context {sz : nat}. - Context {a : is_ctx_dep}. Context {A : ofe}. Context {CA : Cofe A}. - Context {rs : gReifiers a sz}. - Notation F := (gReifiers_ops rs). + Context {F : opsInterp}. Notation IT := (IT F A). Notation ITV := (ITV F A). From 63af67498fc83bd0654f2654c3c9b6b12b0c9793 Mon Sep 17 00:00:00 2001 From: Dan Date: Sun, 23 Jun 2024 19:13:07 +0200 Subject: [PATCH 13/14] more cleaning up --- README.md | 2 +- theories/effects/delim.v | 8 +- theories/effects/io_tape.v | 2 +- theories/examples/delim_lang/example.v | 179 +++++++++++++------------ theories/examples/delim_lang/interp.v | 1 + theories/examples/delim_lang/lang.v | 5 + theories/examples/delim_lang/typing.v | 5 + 7 files changed, 110 insertions(+), 92 deletions(-) diff --git a/README.md b/README.md index c74eddd..0724d9a 100644 --- a/README.md +++ b/README.md @@ -30,7 +30,7 @@ to the code structure. - `examples/input_lang/` -- formalization of the language with io, the soundness and adequacy - `examples/affine_lang/` -- formalization of the affine language, type safety of the language interoperability - `examples/input_lang_callcc/` -- formalization of the language with io, throw and call/cc, the soundness and adequacy -- `examples/delim_lang/` -- formalization shift/reset effects, of a language with delimited continuations and its soundness +- `examples/delim_lang/` -- formalization of the language with shift/reset and its soundness/adequacy wrt abstract machine semantics - `prelude.v` -- some stuff that is missing from Iris - `lang_generic.v` -- generic facts about languages with binders and their interpretations, shared by `input_lang` and `affine_lang` diff --git a/theories/effects/delim.v b/theories/effects/delim.v index 1a862e5..5862e8e 100644 --- a/theories/effects/delim.v +++ b/theories/effects/delim.v @@ -1,3 +1,4 @@ +(** * Representation of delimited continuations *) From gitrees Require Import prelude gitree. From iris.algebra Require Import list. @@ -14,26 +15,29 @@ Proof. apply _. Qed. (** * Signatures *) +(** Bind the innermost continuation *) Program Definition shiftE : opInterp := {| Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); Outs := (▶ ∙); |}. +(** Delimit the continuation *) Program Definition resetE : opInterp := {| Ins := (▶ ∙); Outs := (▶ ∙); |}. -(* to apply the head of the meta continuation *) +(** Explicitly pop a continuation from the meta-continuation and jump +to it *) Program Definition popE : opInterp := {| Ins := (▶ ∙); Outs := Empty_setO; |}. -(* apply continuation, pushes outer context in meta *) +(** Applies continuation, pushes outer context in meta *) Program Definition appContE : opInterp := {| Ins := (▶ ∙ * (▶ (∙ -n> ∙))); diff --git a/theories/effects/io_tape.v b/theories/effects/io_tape.v index fd34746..3436566 100644 --- a/theories/effects/io_tape.v +++ b/theories/effects/io_tape.v @@ -1,4 +1,4 @@ -(** I/O on a tape effect *) +(** * I/O on a tape effect *) From gitrees Require Import prelude gitree. Record state := State { diff --git a/theories/examples/delim_lang/example.v b/theories/examples/delim_lang/example.v index 59f043d..2885340 100644 --- a/theories/examples/delim_lang/example.v +++ b/theories/examples/delim_lang/example.v @@ -1,3 +1,4 @@ +(** * Example of a program in delim_lang and its symbolic execution *) From gitrees Require Import gitree lang_generic. From gitrees.effects Require Import delim. From gitrees.examples.delim_lang Require Import lang interp. @@ -6,105 +7,107 @@ From iris.base_logic Require Import algebra. Open Scope syn_scope. +(** The program captures the inner continuation, invokes it with 5 and +6, and adds the results to 1. The result is 1+(3+5)+(3+6)=18 *) Example p : expr Empty_set := ((#1) + (reset ((#3) + (shift/cc ((($0) @k #5) + (($0) @k #6)))))). -Local Definition rs : gReifiers _ _ := gReifiers_cons reify_delim gReifiers_nil. -(* Local Definition Hrs : subReifier reify_delim rs. *) -(* Proof. unfold rs. apply subReifier_here. Qed. *) -Notation F := (gReifiers_ops rs). -Context {R} `{!Cofe R}. -Context `{!SubOfe natO R, !SubOfe unitO R}. -Notation IT := (IT F R). -Notation ITV := (ITV F R). -Context (env : @interp_scope F R _ Empty_set). +Section example. + Local Definition rs : gReifiers _ _ := gReifiers_cons reify_delim gReifiers_nil. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R, !SubOfe unitO R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context (env : @interp_scope F R _ Empty_set). -Example ts := interp_config rs (Cexpr p) env. -Definition t := fst ts. -Definition σ := snd ts. + Definition ts := interp_config rs (Cexpr p) env. + Definition t := fst ts. + Definition σ := snd ts. -Context `{!invGS Σ, !stateG rs R Σ, !heapG rs R Σ}. -Notation iProp := (iProp Σ). + Context `{!invGS Σ, !stateG rs R Σ, !heapG rs R Σ}. + Notation iProp := (iProp Σ). -Ltac shift_hom := - match goal with - | |- envs_entails _ (wp _ (ofe_mor_car _ _ (λne x, ?k1 x) (?k2 ?t)) _ _ _) => - assert ((ofe_mor_car _ _ (λne x, k1 x) (k2 t)) ≡ (λne x, k1 (k2 x)) t) as -> by done - | |- envs_entails _ (wp _ (?k ?t) _ _ _) => - assert (k t ≡ (λne x, k x) t) as -> by done - end. + Ltac shift_hom := + match goal with + | |- envs_entails _ (wp _ (ofe_mor_car _ _ (λne x, ?k1 x) (?k2 ?t)) _ _ _) => + assert ((ofe_mor_car _ _ (λne x, k1 x) (k2 t)) ≡ (λne x, k1 (k2 x)) t) as -> by done + | |- envs_entails _ (wp _ (?k ?t) _ _ _) => + assert (k t ≡ (λne x, k x) t) as -> by done + end. -Ltac shift_natop_l := - match goal with - | |- envs_entails _ (wp _ (ofe_mor_car _ _ (λne x, ?k1 x) - (ofe_mor_car _ _ - (ofe_mor_car _ _ - (NATOP (do_natop lang.Add)) ?t) (IT_of_V ?e))) _ _ _) => - assert ((ofe_mor_car _ _ (λne x, k1 x) (NATOP (do_natop lang.Add) t (IT_of_V e))) ≡ - (λne x, k1 (NATOP (do_natop lang.Add) x (IT_of_V e))) t) as -> by done - end. + Ltac shift_natop_l := + match goal with + | |- envs_entails _ (wp _ (ofe_mor_car _ _ (λne x, ?k1 x) + (ofe_mor_car _ _ + (ofe_mor_car _ _ + (NATOP (do_natop lang.Add)) ?t) (IT_of_V ?e))) _ _ _) => + assert ((ofe_mor_car _ _ (λne x, k1 x) (NATOP (do_natop lang.Add) t (IT_of_V e))) ≡ + (λne x, k1 (NATOP (do_natop lang.Add) x (IT_of_V e))) t) as -> by done + end. -Lemma wp_t (s : gitree.weakestpre.stuckness) : - has_substate σ -∗ - WP@{rs} t @ s {{βv, βv ≡ RetV 18}}. -Proof. - Opaque SHIFT APP_CONT. - iIntros "Hσ". - cbn. - (* first, reset *) - do 2 shift_hom. - iApply (wp_reset with "Hσ"). - iIntros "!> _ Hσ". simpl. + Lemma wp_t (s : gitree.weakestpre.stuckness) : + has_substate σ -∗ + WP@{rs} t @ s {{βv, βv ≡ RetV 18}}. + Proof. + Opaque SHIFT APP_CONT. + iIntros "Hσ". + cbn. + (* first, reset *) + do 2 shift_hom. + iApply (wp_reset with "Hσ"). + iIntros "!> _ Hσ". simpl. - (* then, shift *) - do 2 shift_hom. - iApply (wp_shift with "Hσ"). - { rewrite laterO_map_Next. done. } - iIntros "!>_ Hσ". - simpl. + (* then, shift *) + do 2 shift_hom. + iApply (wp_shift with "Hσ"). + { rewrite laterO_map_Next. done. } + iIntros "!>_ Hσ". + simpl. - (* the rest *) - rewrite -(IT_of_V_Ret 6) get_val_ITV'. simpl. - rewrite get_fun_fun. simpl. - do 2 shift_hom. - iApply (wp_app_cont with "Hσ"); first done. - iIntros "!> _ Hσ". simpl. - rewrite later_map_Next -Tick_eq. - iApply wp_tick. iNext. - shift_hom. - rewrite IT_of_V_Ret NATOP_Ret. simpl. - rewrite -(IT_of_V_Ret 9). - iApply (wp_pop_cons with "Hσ"). - iIntros "!> _ Hσ". - simpl. + (* the rest *) + rewrite -(IT_of_V_Ret 6) get_val_ITV'. simpl. + rewrite get_fun_fun. simpl. + do 2 shift_hom. + iApply (wp_app_cont with "Hσ"); first done. + iIntros "!> _ Hσ". simpl. + rewrite later_map_Next -Tick_eq. + iApply wp_tick. iNext. + shift_hom. + rewrite IT_of_V_Ret NATOP_Ret. simpl. + rewrite -(IT_of_V_Ret 9). + iApply (wp_pop_cons with "Hσ"). + iIntros "!> _ Hσ". + simpl. - shift_hom. shift_natop_l. - rewrite -(IT_of_V_Ret 5) get_val_ITV'. simpl. - shift_hom. shift_natop_l. - rewrite get_fun_fun. simpl. - shift_hom. shift_natop_l. - iApply (wp_app_cont with "Hσ"); first done. - iIntros "!> _ Hσ". simpl. - rewrite later_map_Next -Tick_eq. - iApply wp_tick. iNext. - rewrite (IT_of_V_Ret 5) NATOP_Ret. simpl. - rewrite -(IT_of_V_Ret 8). - iApply (wp_pop_cons with "Hσ"). - iIntros "!> _ Hσ". - simpl. - shift_hom. - shift_natop_l. - rewrite (IT_of_V_Ret 8). - simpl. rewrite IT_of_V_Ret NATOP_Ret. - simpl. rewrite -(IT_of_V_Ret 17). - iApply (wp_pop_cons with "Hσ"). - iIntros "!> _ Hσ". simpl. - rewrite IT_of_V_Ret NATOP_Ret. - simpl. rewrite -(IT_of_V_Ret 18). - iApply (wp_pop_end with "Hσ"). - iIntros "!> _ _". - iApply wp_val. done. -Qed. + shift_hom. shift_natop_l. + rewrite -(IT_of_V_Ret 5) get_val_ITV'. simpl. + shift_hom. shift_natop_l. + rewrite get_fun_fun. simpl. + shift_hom. shift_natop_l. + iApply (wp_app_cont with "Hσ"); first done. + iIntros "!> _ Hσ". simpl. + rewrite later_map_Next -Tick_eq. + iApply wp_tick. iNext. + rewrite (IT_of_V_Ret 5) NATOP_Ret. simpl. + rewrite -(IT_of_V_Ret 8). + iApply (wp_pop_cons with "Hσ"). + iIntros "!> _ Hσ". + simpl. + shift_hom. + shift_natop_l. + rewrite (IT_of_V_Ret 8). + simpl. rewrite IT_of_V_Ret NATOP_Ret. + simpl. rewrite -(IT_of_V_Ret 17). + iApply (wp_pop_cons with "Hσ"). + iIntros "!> _ Hσ". simpl. + rewrite IT_of_V_Ret NATOP_Ret. + simpl. rewrite -(IT_of_V_Ret 18). + iApply (wp_pop_end with "Hσ"). + iIntros "!> _ _". + iApply wp_val. done. + Qed. +End example. diff --git a/theories/examples/delim_lang/interp.v b/theories/examples/delim_lang/interp.v index f111241..c049041 100644 --- a/theories/examples/delim_lang/interp.v +++ b/theories/examples/delim_lang/interp.v @@ -1,3 +1,4 @@ +(** Interpretation of delim_lang into gitrees *) From gitrees Require Import gitree lang_generic. From gitrees.effects Require Import delim. From gitrees.examples.delim_lang Require Import lang. diff --git a/theories/examples/delim_lang/lang.v b/theories/examples/delim_lang/lang.v index 4497332..0a1daf9 100644 --- a/theories/examples/delim_lang/lang.v +++ b/theories/examples/delim_lang/lang.v @@ -1,3 +1,8 @@ +(** * delim-lang: a language with shift/reset and the abstract machine semantics + +Based on Malgorzata Biernacka; Dariusz Biernacki; Olivier Danvy +An Operational Foundation for Delimited Continuations in the CPS Hierarchy + *) From gitrees Require Export prelude. From stdpp Require Import gmap. Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. diff --git a/theories/examples/delim_lang/typing.v b/theories/examples/delim_lang/typing.v index ccb17f9..fa98b2a 100644 --- a/theories/examples/delim_lang/typing.v +++ b/theories/examples/delim_lang/typing.v @@ -1,3 +1,8 @@ +(** * Type sytem for delim-lang + +The system is based on + O. Danvy and A. Filinski. A functional abstraction of typed contexts. +*) From gitrees.examples.delim_lang Require Import lang. Require Import Binding.Lib Binding.Set Binding.Env. From b91709c2be7aa0718e7e4c6f977cf9f39208a7c5 Mon Sep 17 00:00:00 2001 From: Dan Date: Sun, 23 Jun 2024 19:38:49 +0200 Subject: [PATCH 14/14] fix hom issues --- theories/examples/delim_lang/hom.v | 5 +++++ theories/examples/delim_lang/logpred.v | 5 ----- theories/examples/delim_lang/logrel.v | 5 ----- theories/examples/input_lang_callcc/hom.v | 7 +++---- theories/hom.v | 2 ++ 5 files changed, 10 insertions(+), 14 deletions(-) diff --git a/theories/examples/delim_lang/hom.v b/theories/examples/delim_lang/hom.v index 74b28da..7aad45a 100644 --- a/theories/examples/delim_lang/hom.v +++ b/theories/examples/delim_lang/hom.v @@ -16,6 +16,11 @@ Section hom. Notation IT := (IT F R). Notation ITV := (ITV F R). + Program Definition 𝒫_HOM : HOM (A:=natO) := exist _ 𝒫 _. + Next Obligation. + apply _. + Qed. + Program Definition AppContRSCtx_HOM {S : Set} (α : @interp_scope F R _ S -n> IT) (env : @interp_scope F R _ S) diff --git a/theories/examples/delim_lang/logpred.v b/theories/examples/delim_lang/logpred.v index 7401ef7..f1ae73e 100644 --- a/theories/examples/delim_lang/logpred.v +++ b/theories/examples/delim_lang/logpred.v @@ -213,11 +213,6 @@ Section logrel. iApply "H". Qed. - Program Definition 𝒫_HOM : @HOM sz CtxDep R _ rs := exist _ 𝒫 _. - Next Obligation. - apply _. - Qed. - Lemma compat_shift {S : Set} (Γ : S -> ty) e σ α τ β : ⊢ valid (Γ ▹ (Tcont τ α)) e σ σ β -∗ valid Γ (interp_shift _ e) τ α β. Proof. diff --git a/theories/examples/delim_lang/logrel.v b/theories/examples/delim_lang/logrel.v index f52634c..5d29269 100644 --- a/theories/examples/delim_lang/logrel.v +++ b/theories/examples/delim_lang/logrel.v @@ -314,11 +314,6 @@ Section logrel. assumption. Qed. - Program Definition 𝒫_HOM : @HOM sz CtxDep R _ rs := exist _ 𝒫 _. - Next Obligation. - apply _. - Qed. - Lemma compat_shift {S : Set} (Γ : S -> ty) e (e' : exprO (inc S)) σ α τ β : ⊢ valid (Γ ▹ (τ ⤑ α)) e e' σ σ β -∗ valid Γ (interp_shift _ e) (shift/cc e') τ α β. Proof. diff --git a/theories/examples/input_lang_callcc/hom.v b/theories/examples/input_lang_callcc/hom.v index 5b332f3..0b5e227 100644 --- a/theories/examples/input_lang_callcc/hom.v +++ b/theories/examples/input_lang_callcc/hom.v @@ -1,5 +1,4 @@ -(** In this module, we package up IT homomorphism in a sigma type, and -we will use it as a domain for logical relations on continuations *) +(** Particular homomorphisms for the call/cc lang *) From gitrees Require Import gitree lang_generic. From gitrees Require Export hom. From gitrees.examples.input_lang_callcc Require Import lang interp. @@ -74,8 +73,8 @@ Section hom. Qed. Program Definition OutputSCtx_HOM {S : Set} - (env : @interp_scope F A _ S) - : @HOM _ _ A _ _ := exist _ ((interp_outputk rs (λne env, idfun) env)) _. + (env : @interp_scope F A _ S) : HOM (A:=natO) + := exist _ ((interp_outputk rs (λne env, idfun) env)) _. Next Obligation. intros; simpl. apply _. diff --git a/theories/hom.v b/theories/hom.v index fa20f10..178179b 100644 --- a/theories/hom.v +++ b/theories/hom.v @@ -1,3 +1,5 @@ +(** In this module, we package up IT homomorphism in a sigma type, and +we will use it as a domain for logical relations on continuations *) From gitrees Require Import gitree lang_generic. Require Import Binding.Lib Binding.Set Binding.Env.