From 1fb93b4b0711d39998642116a8b80105fdb64e04 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 12 Oct 2023 21:14:47 +0200 Subject: [PATCH 001/114] flake --- flake.lock | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ flake.nix | 52 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 113 insertions(+) create mode 100644 flake.lock create mode 100644 flake.nix diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..99cdf3e --- /dev/null +++ b/flake.lock @@ -0,0 +1,61 @@ +{ + "nodes": { + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1694529238, + "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1696983906, + "narHash": "sha256-L7GyeErguS7Pg4h8nK0wGlcUTbfUMDu+HMf1UcyP72k=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "bd1cde45c77891214131cbbea5b1203e485a9d51", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-23.05", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..7dbec70 --- /dev/null +++ b/flake.nix @@ -0,0 +1,52 @@ +{ + description = "gitrees"; + inputs = { + nixpkgs.url = github:NixOS/nixpkgs/nixos-23.05; + flake-utils.url = github:numtide/flake-utils; + }; + outputs = { self, nixpkgs, flake-utils }: + with flake-utils.lib; eachSystem allSystems (system: + let + pkgs = nixpkgs.legacyPackages.${system}; + lib = pkgs.lib; + coq = pkgs.coq_8_17; + coqPkgs = pkgs.coqPackages_8_17; + ocamlPkgs = coq.ocamlPackages; + stdpp-dev = coqPkgs.lib.overrideCoqDerivation + { + defaultVersion = "1.9.0"; + release."1.9.0".sha256 = "sha256-OXeB+XhdyzWMp5Karsz8obp0rTeMKrtG7fu/tmc9aeI="; + } coqPkgs.stdpp; + iris-dev = coqPkgs.mkCoqDerivation rec { + pname = "iris"; + domain = "gitlab.mpi-sws.org"; + owner = "iris"; + defaultVersion = "4.1.0"; + release."4.1.0".sha256 = "sha256-nTZUeZOXiH7HsfGbMKDE7vGrNVCkbMaWxdMWUcTUNlo="; + releaseRev = v: "iris-${v}"; + + propagatedBuildInputs = [ stdpp-dev ]; + + preBuild = '' + if [[ -f coq-lint.sh ]] + then patchShebangs coq-lint.sh + fi + ''; + + meta = with lib; { + description = "The Coq development of the Iris Project"; + license = licenses.bsd3; + maintainers = [ maintainers.vbgl ]; + }; + }; + in { + devShell = pkgs.mkShell { + buildInputs = with pkgs; [ + coq + stdpp-dev + iris-dev + coqPkgs.equations + ]; + }; + }); +} From 1ab428c8ed8dfea18b3132d756d520f924551278 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Mon, 30 Oct 2023 16:23:43 +0100 Subject: [PATCH 002/114] init continuation-dependent effects --- flake.nix | 6 - theories/gitree/core.v | 326 +++++++++++++++++++++++++++------------- theories/gitree/reify.v | 3 +- 3 files changed, 225 insertions(+), 110 deletions(-) diff --git a/flake.nix b/flake.nix index 7dbec70..b8c5c45 100644 --- a/flake.nix +++ b/flake.nix @@ -32,12 +32,6 @@ then patchShebangs coq-lint.sh fi ''; - - meta = with lib; { - description = "The Coq development of the Iris Project"; - license = licenses.bsd3; - maintainers = [ maintainers.vbgl ]; - }; }; in { devShell = pkgs.mkShell { diff --git a/theories/gitree/core.v b/theories/gitree/core.v index 5a8d44e..42fd267 100644 --- a/theories/gitree/core.v +++ b/theories/gitree/core.v @@ -84,6 +84,11 @@ Inductive error := . Canonical Structure errorO := leibnizO error. +(* TODO: add continuations to function component, as they can yeet *) +(* Simple effects contain Next id as their continuations *) +(* Call/cc saves the current continuation *) +(* Throw applies the saved continuation *) + (** * Recursive domain equation *) Module IT_pre. Definition ITOF (Σ : opsInterp) (A : ofe) : oFunctor := @@ -91,7 +96,7 @@ Definition ITOF (Σ : opsInterp) (A : ofe) : oFunctor := + ▶ (∙ -n> ∙) (* function space *) + errorO (* explicit error state *) + ▶ ∙ (* silent step *) - + { op : opid Σ & (Ins (Σ op)) * ((Outs (Σ op)) -n> ▶ ∙ ) } + + { op : opid Σ & (Ins (Σ op)) * ((▶ (∙ -n> ∙)) * ((Outs (Σ op)) -n> ▶ ∙ )) } ). #[export] Instance ITOF_contractive Σ A : oFunctorContractive (ITOF Σ A). @@ -123,7 +128,7 @@ Module Export ITF_solution. errorO) (laterO (IT Σ A))) (sigTO (λ op : opid Σ, prodO (Ins (Σ op) ♯ (IT Σ A)) - ((Outs (Σ op) ♯ (IT Σ A)) -n> laterO (IT Σ A)))) + (prodO (laterO ((IT Σ A) -n> (IT Σ A))) ((Outs (Σ op) ♯ (IT Σ A)) -n> laterO (IT Σ A))))) := ofe_iso_2 (IT_result Σ A). Definition IT_fold {Σ A} `{!Cofe A} : @@ -131,7 +136,7 @@ Module Export ITF_solution. errorO) (laterO (IT Σ A))) (sigTO (λ op : opid Σ, prodO (Ins (Σ op) ♯ (IT Σ A)) - ((Outs (Σ op) ♯ (IT Σ A)) -n> laterO (IT Σ A)))) + (prodO (laterO ((IT Σ A) -n> (IT Σ A))) ((Outs (Σ op) ♯ (IT Σ A)) -n> laterO (IT Σ A))))) -n> IT Σ A := ofe_iso_1 (IT_result Σ A). @@ -167,26 +172,26 @@ Section smart. refine (IT_fold ◎ inlO ◎ inlO ◎ inlO ◎ inrO). Defined. - Definition Vis (op : opid E) (ins : oFunctor_apply (Ins (E op)) IT) + Definition Vis (op : opid E) (ins : oFunctor_apply (Ins (E op)) IT) (cont : laterO (IT -n> IT)) (k : oFunctor_apply (Outs (E op)) IT -n> laterO IT) : IT. Proof. refine (IT_fold (inr _)). - refine (existT op (ins, k)). + refine (existT op (ins, (cont, k))). Defined. Global Instance Vis_ne {op : opid E} n : - Proper ((dist n) ==> (dist n) ==> (dist n)) (Vis op). + Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (Vis op). Proof. rewrite /Vis. - intros i1 i2 Hi k1 k2 Hk. + intros i1 i2 Hi k1 k2 Hk j1 j2 Hj. f_equiv. f_equiv. - eapply existT_ne_2. eapply pair_ne; eauto. + eapply existT_ne_2. do 2 eapply pair_ne; eauto. Qed. Global Instance Vis_proper {op : opid E} : - Proper ((≡) ==> (≡) ==> (≡)) (Vis op). + Proper ((≡) ==> (≡) ==> (≡) ==> (≡)) (Vis op). Proof. rewrite /Vis. - intros i1 i2 Hi k1 k2 Hk. + intros i1 i2 Hi k1 k2 Hk j1 j2 Hj. f_equiv. f_equiv. eapply existT_proper_2. solve_proper. @@ -259,11 +264,11 @@ Section smart. done. Qed. - Lemma Vis_inj_op' op1 op2 i1 i2 k1 k2 {PROP : bi} `{!BiInternalEq PROP} : - (Vis op1 i1 k1 ≡ Vis op2 i2 k2 ⊢ ⌜op1 = op2⌝ : PROP)%I. + Lemma Vis_inj_op' op1 op2 i1 i2 k1 k2 j1 j2 {PROP : bi} `{!BiInternalEq PROP} : + (Vis op1 i1 k1 j1 ≡ Vis op2 i2 k2 j2 ⊢ ⌜op1 = op2⌝ : PROP)%I. Proof. iIntros "H". - iAssert (internal_eq (IT_unfold (Vis op1 i1 k1)) (IT_unfold (Vis op2 i2 k2))) with "[H]" as "H". + iAssert (internal_eq (IT_unfold (Vis op1 i1 k1 j1)) (IT_unfold (Vis op2 i2 k2 j2))) with "[H]" as "H". { iRewrite "H". done. } rewrite !IT_unfold_fold. iPoseProof (sum_equivI with "H") as "H". @@ -272,11 +277,11 @@ Section smart. done. Qed. - Lemma Vis_inj' op i1 i2 k1 k2 {PROP : bi} `{!BiInternalEq PROP} : - (Vis op i1 k1 ≡ Vis op i2 k2 ⊢ i1 ≡ i2 ∧ k1 ≡ k2 : PROP)%I. + Lemma Vis_inj' op i1 i2 k1 k2 j1 j2 {PROP : bi} `{!BiInternalEq PROP} : + (Vis op i1 k1 j1 ≡ Vis op i2 k2 j2 ⊢ i1 ≡ i2 ∧ k1 ≡ k2 ∧ j1 ≡ j2 : PROP)%I. Proof. iIntros "H". - iAssert (internal_eq (IT_unfold (Vis op i1 k1)) (IT_unfold (Vis op i2 k2))) with "[H]" as "H". + iAssert (internal_eq (IT_unfold (Vis op i1 k1 j1)) (IT_unfold (Vis op i2 k2 j2))) with "[H]" as "H". { iRewrite "H". done. } rewrite !IT_unfold_fold. simpl. iPoseProof (sum_equivI with "H") as "H". @@ -284,7 +289,7 @@ Section smart. iDestruct "H" as (eq) "H". simpl. simpl in eq. assert (eq = eq_refl) as ->. { apply eq_pi. apply _. } - simpl. iPoseProof (prod_equivI with "H") as "[$ $]". + simpl. do 2 iPoseProof (prod_equivI with "H") as "[$ H]"; iFrame "H". Qed. Lemma IT_ret_tau_ne k α {PROP : bi} `{!BiInternalEq PROP} : @@ -308,30 +313,30 @@ Section smart. iPoseProof (sum_equivI with "H2") as "H2". by iPoseProof (sum_equivI with "H2") as "H2". Qed. - Lemma IT_ret_vis_ne n op i k {PROP : bi} `{!BiInternalEq PROP} : - (Ret n ≡ Vis op i k ⊢ False : PROP)%I. + Lemma IT_ret_vis_ne n op i k j {PROP : bi} `{!BiInternalEq PROP} : + (Ret n ≡ Vis op i k j ⊢ False : PROP)%I. Proof. iIntros "H1". - iAssert (IT_unfold (Ret n) ≡ IT_unfold (Vis op i k))%I with "[H1]" as "H2". + iAssert (IT_unfold (Ret n) ≡ IT_unfold (Vis op i k j))%I with "[H1]" as "H2". { by iRewrite "H1". } rewrite !IT_unfold_fold. iPoseProof (sum_equivI with "H2") as "H". done. Qed. - Lemma IT_fun_vis_ne f op i ko {PROP : bi} `{!BiInternalEq PROP} : - (Fun f ≡ Vis op i ko ⊢ False : PROP)%I. + Lemma IT_fun_vis_ne f op i ko j {PROP : bi} `{!BiInternalEq PROP} : + (Fun f ≡ Vis op i ko j ⊢ False : PROP)%I. Proof. iIntros "H1". - iAssert (IT_unfold (Fun f) ≡ IT_unfold (Vis op i ko))%I with "[H1]" as "H2". + iAssert (IT_unfold (Fun f) ≡ IT_unfold (Vis op i ko j))%I with "[H1]" as "H2". { by iRewrite "H1". } rewrite !IT_unfold_fold. simpl. by iPoseProof (sum_equivI with "H2") as "H2". Qed. - Lemma IT_tau_vis_ne α op i k {PROP : bi} `{!BiInternalEq PROP} : - (Tau α ≡ Vis op i k ⊢ False : PROP)%I. + Lemma IT_tau_vis_ne α op i k j {PROP : bi} `{!BiInternalEq PROP} : + (Tau α ≡ Vis op i k j ⊢ False : PROP)%I. Proof. iIntros "H1". - iAssert (IT_unfold (Tau α) ≡ IT_unfold (Vis op i k))%I with "[H1]" as "H2". + iAssert (IT_unfold (Tau α) ≡ IT_unfold (Vis op i k j))%I with "[H1]" as "H2". { by iRewrite "H1". } rewrite !IT_unfold_fold /=. iPoseProof (sum_equivI with "H2") as "H2". @@ -373,11 +378,11 @@ Section smart. rewrite !IT_unfold_fold /=. by repeat iPoseProof (sum_equivI with "H2") as "H2". Qed. - Lemma IT_vis_err_ne op i k e {PROP : bi} `{!BiInternalEq PROP} : - (Vis op i k ≡ Err e ⊢ False : PROP)%I. + Lemma IT_vis_err_ne op i k j e {PROP : bi} `{!BiInternalEq PROP} : + (Vis op i k j ≡ Err e ⊢ False : PROP)%I. Proof. iIntros "H1". - iAssert (IT_unfold (Vis op i k) ≡ IT_unfold (Err e))%I with "[H1]" as "H2". + iAssert (IT_unfold (Vis op i k j) ≡ IT_unfold (Err e))%I with "[H1]" as "H2". { by iRewrite "H1". } rewrite !IT_unfold_fold /=. by iPoseProof (sum_equivI with "H2") as "H2". @@ -399,52 +404,123 @@ Section IT_rec. (Parr : laterO (sumO (IT E A) P -n> prodO (IT E A) P) -n> P) (Ptau : laterO (prodO (IT E A) P) -n> P) (Pvis : forall (op : opid E), - (oFunctor_car (Ins (E op)) (sumO (IT E A) P) (prodO (IT E A) P)) -n> - ((oFunctor_car (Outs (E op)) (prodO (IT E A) P) (sumO (IT E A) P)) -n> laterO (prodO (IT E A) P)) -n> + (oFunctor_car (Ins (E op)) (sumO (IT E A) P) (prodO (IT E A) P)) -n> + (laterO (sumO (IT E A) P -n> prodO (IT E A) P)) -n> + ((oFunctor_car (Outs (E op)) (prodO (IT E A) P) (sumO (IT E A) P)) -n> laterO (prodO (IT E A) P)) -n> P). Variable (Punfold : P -n> sumO (sumO (sumO (sumO A (laterO (P -n> P))) errorO) (laterO P)) - (sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) P) ((oFunctor_apply (Outs (E op)) P) -n> laterO P))%type)). + (sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) P) (prodO ((laterO (P -n> P))) ((oFunctor_apply (Outs (E op)) P) -n> laterO P)))%type)). (** XXX **) Opaque prod_in. (** otherwise it gets unfolded in the proofs of contractiveness *) + Program Definition sandwich : (IT E A -n> P) -n> (P -n> IT E A) -n> (IT E A -n> IT E A) -n> sumO (IT E A) P -n> prodO (IT E A) P := + λne self1 self2 f, prod_in idfun self1 ◎ f ◎ sumO_rec idfun self2. + Next Obligation. solve_proper. Defined. + Next Obligation. intros self1 n ? ? ? ? x; simpl; destruct x; solve_proper. Defined. + Next Obligation. solve_proper. Defined. + Program Definition unsandwich : (sumO (IT E A) P -n> prodO (IT E A) P) -n> IT E A -n> IT E A := + λne f, fstO ◎ f ◎ inlO. + Next Obligation. solve_proper. Defined. + + Lemma sandwich_unsandwich (self1 : IT E A -n> P) (self2 : P -n> IT E A) : + unsandwich ◎ (sandwich self1 self2) ≡ idfun. + Proof. intros f x; reflexivity. Qed. + Program Definition Pvis_rec (self : prodO (IT E A -n> P) (P -n> IT E A)) : - sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) (IT E A)) (oFunctor_apply (Outs (E op)) (IT E A) -n> laterO (IT E A))) -n> P + sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) (IT E A)) (prodO (laterO ((IT E A) -n> (IT E A))) (oFunctor_apply (Outs (E op)) (IT E A) -n> laterO (IT E A)))) -n> P := λne x, let op := projT1 x in - let inp := fst (projT2 x) in - let outp := snd (projT2 x) in - let self1 : IT E A -n> P := fst self in - let self2 : P -n> IT E A := snd self in - let s_in := oFunctor_map (Ins (E op)) (sumO_rec idfun self2,prod_in idfun self1) in - let s_out := oFunctor_map (Outs (E op)) (prod_in idfun self1, sumO_rec idfun self2) in - Pvis op (s_in inp) (laterO_map (prod_in idfun self1) ◎ outp ◎ s_out). + let inp := fst (projT2 x) in + let outp1 := fst (snd (projT2 x)) in + let outp2 := snd (snd (projT2 x)) in + let self1 : IT E A -n> P := fst self in + let self2 : P -n> IT E A := snd self in + let s_in := oFunctor_map (Ins (E op)) (sumO_rec idfun self2, prod_in idfun self1) in + let s_out := oFunctor_map (Outs (E op)) (prod_in idfun self1, sumO_rec idfun self2) in + Pvis op (s_in inp) (laterO_map (sandwich self1 self2) outp1) (laterO_map (prod_in idfun self1) ◎ outp2 ◎ s_out). Next Obligation. intros (self1, self2) n x1 x2 Hx. - destruct x1 as [R1 [q1 k1]]. - destruct x2 as [R2 [q2 k2]]. - destruct Hx as [Hx1 Hx2]. - simpl in *. - subst. simpl in *. - destruct Hx2 as [Hx1 Hx2]. simpl in *. + destruct x1 as [R1 [q1 [k1 j1]]]. + destruct x2 as [R2 [q2 [k2 j2]]]. + destruct Hx as [Hx1 [Hx2 [Hx3 Hx4]]]. + subst; simpl in *. solve_proper. - Qed. + Defined. Instance Pvis_rec_contractive : Contractive Pvis_rec. - Proof. solve_contractive. Qed. + Proof. + intros ? [x1 x2] [y1 y2] ? ?; simpl. + assert (H1 : dist_later n x1 y1). + { destruct H as [H]; constructor; intros; now apply H. } + assert (H2 : dist_later n x2 y2). + { destruct H as [H]; constructor; intros; now apply H. } + f_equiv. + - f_equiv. + + solve_contractive. + + apply laterO_map_contractive. + destruct n as [| n]. + * apply dist_later_0. + * apply dist_later_S. + apply dist_later_S in H1, H2. + intros ? [x3 | x3]; simpl; + f_equiv; solve_proper. + - intros ?; simpl. + solve_contractive. + Defined. + + Program Definition cccompose {X Y Z : ofe} + : (Y -n> Z) -n> (X -n> Y) -n> X -n> Z := λne g f, ccompose g f. + Next Obligation. + solve_proper. + Defined. + Next Obligation. + solve_proper. + Defined. + + Program Definition laterO_precompose {X Y Z : ofe} + : (X -n> Y) -n> laterO (Y -n> Z) -n> laterO (X -n> Z) + := λne f gl, laterO_ap (laterO_ap (Next cccompose) gl) (Next f). + Next Obligation. + intros ? ? ? ? ? ? ? ?. + apply later_ap_ne. + now f_equiv. + Defined. + Next Obligation. + solve_proper. + Defined. + + Program Definition laterO_postcompose {X Y Z : ofe} + : laterO (X -n> Y) -n> (Y -n> Z) -n> laterO (X -n> Z) + := λne fl g, laterO_ap (Next (cccompose g)) fl. + Next Obligation. + intros ? ? ? ? ? ? ? ?. + apply later_ap_ne. + now do 2 f_equiv. + Defined. + Next Obligation. + intros ? ? ? ? [x] [y] H ?; simpl. + apply Next_contractive. + destruct n as [| n]. + - apply dist_later_0. + - apply dist_later_S. + f_equiv. + apply H; constructor. + Defined. Program Definition ITvis_rec (self : prodO (IT E A -n> P) (P -n> IT E A)) : - sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) P) (oFunctor_apply (Outs (E op)) P -n> laterO P)) -n> IT E A + sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) P) (prodO ((laterO (P -n> P))) (oFunctor_apply (Outs (E op)) P -n> laterO P))) -n> IT E A := λne x, let op := projT1 x in let inp := fst (projT2 x) in - let outp := snd (projT2 x) in + let outp1 := fst (snd (projT2 x)) in + let outp2 := snd (snd (projT2 x)) in let self1 : IT E A -n> P := fst self in let self2 : P -n> IT E A := snd self in - let s_in := oFunctor_map (Ins (E op)) (self1,self2) in - let s_out := oFunctor_map (Outs (E op)) (self2,self1) in - Vis op (s_in inp) (laterO_map self2 ◎ outp ◎ s_out). + let s_in := oFunctor_map (Ins (E op)) (self1, self2) in + let s_out := oFunctor_map (Outs (E op)) (self2, self1) in + Vis op (s_in inp) (laterO_precompose self1 (laterO_postcompose outp1 self2)) (laterO_map self2 ◎ outp2 ◎ s_out). Next Obligation. intros (self1, self2) n x1 x2 Hx. destruct x1 as [R1 [q1 k1]]. @@ -453,7 +529,17 @@ Section IT_rec. simpl in *. subst. simpl in *. destruct Hx2 as [Hx1 Hx2]. simpl in *. - solve_proper. + f_equiv. + - solve_proper. + - destruct k1 as [k1 k1']. + destruct k2 as [k2 k2']. + apply Next_contractive. + destruct n as [| n]. + + apply dist_later_0. + + apply dist_later_S. + do 2 f_equiv. + apply Hx2; constructor. + - solve_proper. Qed. Instance ITvis_rec_contractive : Contractive ITvis_rec. Proof. solve_contractive. Qed. @@ -547,20 +633,8 @@ Section IT_rec. rewrite IT_unfold_fold; reflexivity. Qed. - Program Definition sandwich : (IT E A -n> IT E A) -n> sumO (IT E A) P -n> prodO (IT E A) P := - λne f, prod_in idfun IT_rec1 ◎ f ◎ sumO_rec idfun IT_rec2. - Next Obligation. solve_proper. Defined. - Program Definition unsandwich : (sumO (IT E A) P -n> prodO (IT E A) P) -n> IT E A -n> IT E A := - λne f, fstO ◎ f ◎ inlO. - Next Obligation. solve_proper. Defined. - - Lemma sandwich_unsandwich : - unsandwich ◎ sandwich ≡ idfun. - Proof. intros f x; reflexivity. Qed. - - Lemma IT_rec1_fun f : - IT_rec1 (Fun f) ≡ Parr (laterO_map sandwich f). + IT_rec1 (Fun f) ≡ Parr (laterO_map (sandwich IT_rec1 IT_rec2) f). Proof. rewrite IT_rec1_unfold. rewrite /IT_rec_pre. @@ -572,11 +646,35 @@ Section IT_rec. destruct x as [x|x]; simpl; eauto. Qed. - Lemma IT_rec1_vis op i k : - let s_in := oFunctor_map (Ins (E op)) (sumO_rec idfun IT_rec2,prod_in idfun IT_rec1) in - let s_out := oFunctor_map (Outs (E op)) (prod_in idfun IT_rec1,sumO_rec idfun IT_rec2) in - IT_rec1 (Vis op i k) ≡ - Pvis op (s_in i) (laterO_map (prod_in idfun IT_rec1) ◎ k ◎ s_out). + Program Definition sumO_rec' {A B C : ofe} : (A -n> C) -n> (B -n> C) -n> sumO A B -n> C := + λne f g x, sumO_rec f g x. + Next Obligation. + intros. intros x y Hxy. simpl. + destruct x as [a1|b1], y as [a2|b2]; try by inversion Hxy. + - apply inl_ne_inj in Hxy. by f_equiv. + - apply inr_ne_inj in Hxy. by f_equiv. + Qed. + Next Obligation. + intros ? ? ? f1 ? g1 g2 ? H; simpl; destruct H as [x|y]; simpl; eauto. + Qed. + Next Obligation. + intros ? ? ? ? g1 g2 ? f H; simpl; destruct H as [x|y]; simpl; eauto. + Qed. + + (* Program Definition factor_map : *) + (* (IT E A -n> IT E A) -n> (sumO (IT E A) P -n> prodO (IT E A) P) *) + (* := (λne f : IT E A -n> IT E A, (prod_in idfun IT_rec1) ◎ f ◎ sumO_rec idfun IT_rec2). *) + (* Next Obligation. *) + (* solve_proper. *) + (* Defined. *) + + Lemma IT_rec1_vis op i k j : + let s_in := oFunctor_map (Ins (E op)) (sumO_rec idfun IT_rec2, prod_in idfun IT_rec1) in + let s_out := oFunctor_map (Outs (E op)) (prod_in idfun IT_rec1, sumO_rec idfun IT_rec2) in + IT_rec1 (Vis op i k j) ≡ + Pvis op (s_in i) + (laterO_map (sandwich IT_rec1 IT_rec2) k) + (laterO_map (prod_in idfun IT_rec1) ◎ j ◎ s_out). Proof. simpl. rewrite IT_rec1_unfold. unfold IT_rec_pre. cbn-[sumO_rec]. @@ -585,8 +683,9 @@ Section IT_rec. Qed. End IT_rec. + Arguments IT_rec {_ _ _} P {_ _} _ _ _ _ _ _. -Arguments sandwich {_ _ _} _ {_ _ _ _ _ _ _ _}. +Arguments sandwich {_ _ _ _}. (* exercise: show that every P with the properties above must have a bottom element and that it_rec maps bottom to bottom *) (** XXX ***) Opaque prod_in. @@ -595,14 +694,24 @@ Global Instance Pvis_rec_ne {E A} `{!Cofe A} {P: ofe} `{!Cofe P, !Inhabited P} n Proper ((forall_relation (λ _, (dist n))) ==> (dist_later n) ==> (dist n)) (Pvis_rec (E:=E) (A:=A) P). Proof. intros v1 v2 Hv [h1 h2] [g1 g2] Hhg. - intros [op [i k]]. + intros [op [i [k j]]]. unfold Pvis_rec. simpl. specialize (Hv op). simpl in Hv. f_equiv; eauto. - - f_equiv; eauto. - apply opInterp_ins_contractive; eauto. - destruct n; first by eauto using dist_later_0. - apply dist_later_S. apply dist_later_S in Hhg. simpl in *; destruct Hhg; split; simpl; f_equiv; eauto. + - f_equiv. + + f_equiv; [assumption |]. + apply opInterp_ins_contractive; eauto. + destruct n; first by eauto using dist_later_0. + apply dist_later_S. apply dist_later_S in Hhg. simpl in *; destruct Hhg; split; simpl; f_equiv; eauto. + + apply laterO_map_contractive. + destruct n; first by eauto using dist_later_0. + apply dist_later_S. apply dist_later_S in Hhg. simpl in *; destruct Hhg; intros ? t; split; simpl; f_equiv; eauto. + * f_equiv; [solve_proper |]. + f_equiv. + destruct t as [t | t]; solve_proper. + * f_equiv; [solve_proper |]. + f_equiv. + destruct t as [t | t]; solve_proper. - intro a. simpl. repeat (f_contractive || f_equiv); simpl in *; destruct Hhg; eauto. Qed. @@ -610,9 +719,14 @@ Qed. Proper ((forall_relation (λ _, (equiv))) ==> (equiv) ==> (equiv)) (Pvis_rec (E:=E) (A:=A) P). Proof. intros v1 v2 Hv [h1 h2] [g1 g2] [Hhg1 Hhg2]. - intros [op [i k]]. + intros [op [i [k j]]]. unfold Pvis_rec. simpl. - specialize (Hv op). simpl in Hv. solve_proper. + specialize (Hv op). simpl in Hv. + do 3 f_equiv; try solve_proper. + f_equiv. + intros f. + simpl in *. + do 2 f_equiv; solve_proper. Qed. (** XXX ***) Transparent prod_in. @@ -762,8 +876,8 @@ Section ticks. Lemma IT_fun_tick_ne f α {PROP : bi} `{!BiInternalEq PROP} : (Fun f ≡ Tick α ⊢ False : PROP)%I. Proof. apply IT_fun_tau_ne. Qed. - Lemma IT_tick_vis_ne α op i k {PROP : bi} `{!BiInternalEq PROP} : - (Tick α ≡ Vis op i k ⊢ False : PROP)%I. + Lemma IT_tick_vis_ne α op i k j {PROP : bi} `{!BiInternalEq PROP} : + (Tick α ≡ Vis op i k j ⊢ False : PROP)%I. Proof. apply IT_tau_vis_ne. Qed. Lemma IT_tick_err_ne α e {PROP : bi} `{!BiInternalEq PROP} : (Tick α ≡ Err e ⊢ False : PROP)%I. @@ -794,19 +908,19 @@ Section ticks. ∨ (∃ n, α ≡ Ret n) ∨ (∃ f, α ≡ Fun f) ∨ (∃ β, α ≡ Tick β) - ∨ (∃ op i k, α ≡ Vis op i k). + ∨ (∃ op i k j, α ≡ Vis op i k j). Proof. remember (IT_unfold α) as ua. assert (IT_fold ua ≡ α) as Hfold. { rewrite Hequa. apply IT_fold_unfold. } - destruct ua as [ [ [ [ n | f ] | e ] | la ] | [op [i k] ]]. + destruct ua as [ [ [ [ n | f ] | e ] | la ] | [op [i [k j]] ]]. - right. left. exists n. done. - right. right. left. exists f. done. - left. exists e. done. - right. right. right. left. destruct (Next_uninj la) as [β Hb]. exists β. rewrite -Hfold Hb. done. - - right. right. right. right. exists op,i,k. done. + - right. right. right. right. exists op,i,k,j. done. Qed. Lemma IT_dont_confuse' (α : IT) {PROP : bi} `{!BiInternalEq PROP} : @@ -814,20 +928,20 @@ Section ticks. ∨ (∃ n, α ≡ Ret n) ∨ (∃ f, α ≡ Fun f) ∨ (∃ β, α ≡ Tick β) - ∨ (∃ op i k, α ≡ Vis op i k) + ∨ (∃ op i k j, α ≡ Vis op i k j) : PROP)%I. Proof. remember (IT_unfold α) as ua. assert (IT_fold ua ≡ α) as Hfold. { rewrite Hequa. apply IT_fold_unfold. } - destruct ua as [ [ [ [ n | f ] | e ] | la ] | [op [i k] ]]. + destruct ua as [ [ [ [ n | f ] | e ] | la ] | [op [i [k j]] ]]. - iRight. iLeft. iExists n. done. - iRight. iRight. iLeft. iExists f. done. - iLeft. iExists e. done. - iRight. iRight. iRight. iLeft. destruct (Next_uninj la) as [β Hb]. iExists β. rewrite -Hfold Hb. done. - - iRight. iRight. iRight. iRight. iExists op,i,k. done. + - iRight. iRight. iRight. iRight. iExists op,i,k,j. done. Qed. End ticks. @@ -982,7 +1096,7 @@ Section ITV. Program Definition None1 {A B} : A -n> optionO B := λne _, None. - Program Definition None2 {A B C} : A -n> B -n> optionO C := λne _ _, None. + Program Definition None2 {A B C D} : A -n> B -n> C -n> optionO D := λne _ _ _, None. Program Definition SomeO {A} : A -n> optionO A := OfeMor Some. Program Definition IT_to_V : IT -n> optionO ITV @@ -1013,7 +1127,7 @@ Section ITV. Proof. apply IT_rec1_tau. Qed. Lemma IT_to_V_Tick α : IT_to_V (Tick α) ≡ None. Proof. apply IT_to_V_Tau. Qed. - Lemma IT_to_V_Vis op i k : IT_to_V (Vis op i k) ≡ None. + Lemma IT_to_V_Vis op i k j : IT_to_V (Vis op i k j) ≡ None. Proof. apply IT_rec1_vis. Qed. Lemma IT_to_of_V v : IT_to_V (IT_of_V v) ≡ Some v. @@ -1043,7 +1157,7 @@ Section ITV. - iDestruct "Ha" as (lf) "Ha". iRewrite "Ha" in "H". rewrite IT_to_V_Tau. iPoseProof (option_equivI with "H") as "H". done. - - iDestruct "Ha" as (op i k) "Ha". + - iDestruct "Ha" as (op i k j) "Ha". iRewrite "Ha" in "H". rewrite IT_to_V_Vis. iPoseProof (option_equivI with "H") as "H". done. Qed. @@ -1051,7 +1165,7 @@ Section ITV. Lemma IT_of_to_V' α v : IT_to_V α ≡ Some v → IT_of_V v ≡ α. Proof. destruct (IT_dont_confuse α) - as [[e Ha2] | [[m Ha2] | [ [g Ha2] | [[la Ha2]|[op [i [k Ha2]]]] ]]]. + as [[e Ha2] | [[m Ha2] | [ [g Ha2] | [[la Ha2]|[op [i [k [j Ha2]]]]] ]]]. all: rewrite Ha2. - rewrite IT_to_V_Err. rewrite option_equiv_Forall2. inversion 1. @@ -1072,7 +1186,7 @@ Section ITV. Lemma IT_to_V_None α {PROP : bi} `{!BiInternalEq PROP} : (IT_to_V α ≡ None ⊢ (∃ e, α ≡ Err e) ∨ (∃ β, α ≡ Tick β) - ∨ (∃ op i k, α ≡ Vis op i k) + ∨ (∃ op i k j, α ≡ Vis op i k j) : PROP)%I. Proof. iIntros "H". @@ -1119,10 +1233,13 @@ Section IT_destructors. (** Don't touch the input, but recuse on the result of the continuation, this should be called Vis_iter or something *) Program Definition Vis_ (op : opid E) : (oFunctor_car (Ins (E op)) (sumO IT IT) (prodO IT IT)) -n> + laterO (sumO IT IT -n> prodO IT IT) -n> ((oFunctor_car (Outs (E op)) (prodO IT IT) (sumO IT IT)) -n> laterO (prodO IT IT)) -n> IT - := λne i k, Vis op + := λne i k j, Vis op (oFunctor_map _ (inlO,fstO) i) - (laterO_map sndO ◎ k ◎ oFunctor_map _ (fstO,inlO)). + (laterO_map (unsandwich _) k) + (laterO_map sndO ◎ j ◎ oFunctor_map _ (fstO,inlO)). + Next Obligation. solve_proper. Qed. Next Obligation. solve_proper. Qed. Next Obligation. solve_proper. Qed. @@ -1225,7 +1342,7 @@ Section IT_destructors. induction n; first reflexivity. rewrite get_ret_tick. by rewrite IHn. Qed. - Lemma get_ret_vis f op i k : get_ret f (Vis op i k) ≡ Vis op i (laterO_map (get_ret f) ◎ k). + Lemma get_ret_vis f op i k j : get_ret f (Vis op i k j) ≡ Vis op i k (laterO_map (get_ret f) ◎ j). Proof. rewrite IT_rec1_vis. cbn-[prod_in]. f_equiv. - rewrite -oFunctor_map_compose. @@ -1233,6 +1350,8 @@ Section IT_destructors. repeat f_equiv. + intro x. reflexivity. + intro x. reflexivity. + - intros x. cbn-[prod_in]. + f_equal. - intros x. cbn-[prod_in]. rewrite -laterO_map_compose. rewrite -oFunctor_map_compose. @@ -1276,7 +1395,7 @@ Section IT_destructors. induction n; first reflexivity. rewrite get_val_tick. by rewrite IHn. Qed. - Lemma get_val_vis f op i k : get_val f (Vis op i k) ≡ Vis op i (laterO_map (get_val f) ◎ k). + Lemma get_val_vis f op i k j : get_val f (Vis op i k j) ≡ Vis op i k (laterO_map (get_val f) ◎ j). Proof. rewrite IT_rec1_vis. cbn-[prod_in]. f_equiv. - rewrite -oFunctor_map_compose. @@ -1284,6 +1403,8 @@ Section IT_destructors. repeat f_equiv. + intro x. reflexivity. + intro x. reflexivity. + - intros x. cbn-[prod_in]. + f_equal. - intros x. cbn-[prod_in]. rewrite -laterO_map_compose. rewrite -oFunctor_map_compose. @@ -1309,7 +1430,7 @@ Section IT_destructors. Lemma get_fun_ret f n : get_fun f (Ret n) ≡ Err RuntimeErr. Proof. by rewrite IT_rec1_ret. Qed. - Lemma get_fun_vis f op i k : get_fun f (Vis op i k) ≡ Vis op i (laterO_map (get_fun f) ◎ k). + Lemma get_fun_vis f op i k j : get_fun f (Vis op i k j) ≡ Vis op i k (laterO_map (get_fun f) ◎ j). Proof. rewrite IT_rec1_vis. cbn-[prod_in]. f_equiv. - rewrite -oFunctor_map_compose. @@ -1317,6 +1438,7 @@ Section IT_destructors. repeat f_equiv. + intro x. reflexivity. + intro x. reflexivity. + - intros x; f_equal. - intros x. cbn-[prod_in]. rewrite -laterO_map_compose. rewrite -oFunctor_map_compose. @@ -1354,7 +1476,7 @@ Section it_hom. Class IT_hom (f : IT → IT) := IT_HOM { hom_ne :: NonExpansive f; hom_tick: ∀ α, f (Tick α) ≡ Tick (f α); - hom_vis : ∀ op i ko, f (Vis op i ko) ≡ Vis op i (laterO_map (OfeMor f) ◎ ko); + hom_vis : ∀ op i ko jo, f (Vis op i ko jo) ≡ Vis op i ko (laterO_map (OfeMor f) ◎ jo); hom_err : ∀ e, f (Err e) ≡ Err e }. #[export] Instance IT_hom_proper f `{!IT_hom f} : Proper ((≡) ==> (≡)) f. @@ -1364,14 +1486,14 @@ Section it_hom. Proof. intros Hf Hg. simple refine (IT_HOM _ _ _ _ _). - intros a. simpl. rewrite !hom_tick//. - - intros op i k. simpl. rewrite !hom_vis//. + - intros op i k j. simpl. rewrite !hom_vis//. f_equiv. intro x. simpl. rewrite -laterO_map_compose//. - intro e. cbn-[Err]. rewrite !hom_err//. Qed. #[export] Instance IT_hom_idfun : IT_hom idfun. Proof. simple refine (IT_HOM _ _ _ _ _); simpl; eauto. - intros op i k. f_equiv. intro x. simpl. + intros op i k j. f_equiv. intro x. simpl. by rewrite laterO_map_id. Qed. @@ -1385,7 +1507,7 @@ Section it_hom. is_Some (IT_to_V (f α)) → is_Some (IT_to_V α). Proof. destruct (IT_dont_confuse α) - as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. + as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k [j Ha]]]]] ]]]. - rewrite Ha hom_err. rewrite IT_to_V_Err. done. - rewrite Ha IT_to_V_Ret. done. - rewrite Ha IT_to_V_Fun. done. diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 63be7d0..ebd90a7 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -11,7 +11,7 @@ Section reifiers. { sReifier_ops : opsInterp; sReifier_state : oFunctor; sReifier_re {X} `{!Cofe X} : forall (op : opid sReifier_ops), - (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) + (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) * (X -n> X) -n> optionO ((Outs (sReifier_ops op) ♯ X) * (sReifier_state ♯ X)); sReifier_inhab :: Inhabited (sReifier_state ♯ unitO); sReifier_cofe X (HX : Cofe X) :: Cofe (sReifier_state ♯ X); @@ -265,4 +265,3 @@ Section reifiers. Qed. End reifiers. - From 74e9d27862ba126163791bae701d4840c90406e2 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 1 Nov 2023 15:58:01 +0100 Subject: [PATCH 003/114] lang --- _CoqProject | 13 +- theories/gitree/reify.v | 157 ++++++-- theories/input_lang/lang.v | 740 +++++++++++++++++++----------------- theories/lang_generic.v | 180 --------- theories/lang_generic_sem.v | 183 +++++++++ vendor/Binding/Auto.v | 251 ++++++++++++ vendor/Binding/Core.v | 295 ++++++++++++++ vendor/Binding/Env.v | 79 ++++ vendor/Binding/Inc.v | 25 ++ vendor/Binding/Intrinsic.v | 232 +++++++++++ vendor/Binding/LICENSE | 21 + vendor/Binding/Lib.v | 4 + vendor/Binding/Product.v | 130 +++++++ vendor/Binding/Properties.v | 197 ++++++++++ vendor/Binding/Set.v | 204 ++++++++++ vendor/Binding/TermSimpl.v | 206 ++++++++++ 16 files changed, 2351 insertions(+), 566 deletions(-) create mode 100644 theories/lang_generic_sem.v create mode 100644 vendor/Binding/Auto.v create mode 100644 vendor/Binding/Core.v create mode 100644 vendor/Binding/Env.v create mode 100644 vendor/Binding/Inc.v create mode 100644 vendor/Binding/Intrinsic.v create mode 100644 vendor/Binding/LICENSE create mode 100644 vendor/Binding/Lib.v create mode 100644 vendor/Binding/Product.v create mode 100644 vendor/Binding/Properties.v create mode 100644 vendor/Binding/Set.v create mode 100644 vendor/Binding/TermSimpl.v diff --git a/_CoqProject b/_CoqProject index 9553bcb..074125a 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,6 +1,18 @@ -Q theories gitrees +-Q vendor/Binding Binding -arg -w -arg -ssr-search-moved +vendor/Binding/Properties.v +vendor/Binding/Lib.v +vendor/Binding/Set.v +vendor/Binding/Auto.v +vendor/Binding/Core.v +vendor/Binding/Inc.v +vendor/Binding/Intrinsic.v +vendor/Binding/TermSimpl.v +vendor/Binding/Product.v +vendor/Binding/Env.v + theories/prelude.v theories/lang_generic.v @@ -28,4 +40,3 @@ theories/examples/store.v theories/examples/pairs.v theories/examples/while.v theories/examples/factorial.v - diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index ebd90a7..37d87f3 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -11,7 +11,7 @@ Section reifiers. { sReifier_ops : opsInterp; sReifier_state : oFunctor; sReifier_re {X} `{!Cofe X} : forall (op : opid sReifier_ops), - (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) * (X -n> X) + (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) * (laterO (X -n> X)) -n> optionO ((Outs (sReifier_ops op) ♯ X) * (sReifier_state ♯ X)); sReifier_inhab :: Inhabited (sReifier_state ♯ unitO); sReifier_cofe X (HX : Cofe X) :: Cofe (sReifier_state ♯ X); @@ -46,19 +46,23 @@ Section reifiers. Solve All Obligations with solve_proper. Program Definition reify_vis ( op : opid F ) : - oFunctor_car (Ins (F op)) (sumO IT stateM) (prodO IT stateM) -n> + oFunctor_car (Ins (F op)) (sumO IT stateM) (prodO IT stateM) -n> + (laterO (sumO IT (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) -n> + prodO IT (stateF ♯ IT -n> prodO (stateF ♯ IT) IT))) -n> (oFunctor_car (Outs (F op)) (prodO IT stateM) (sumO IT stateM) -n> laterO (prodO IT stateM)) -n> stateM. Proof. simpl. - simple refine (λne i (k : _ -n> _) (s : stateF ♯ IT), _). - - simple refine (let ns := sReifier_re r op (oFunctor_map _ (inlO,fstO) i, s) in _). - simple refine (from_option (λ ns, - let out2' := k $ oFunctor_map (Outs (F op)) (fstO,inlO) ns.1 in - (ns.2, Tau $ laterO_map fstO out2')) - (s, Err RuntimeErr) ns). + simple refine (λne i j (k : _ -n> _) (s : stateF ♯ IT), _). + - simple refine (let ns := sReifier_re r op ((oFunctor_map _ (inlO, fstO) i, s), _) in _). + + simple refine (laterO_map (unsandwich _) j). + + simple refine (from_option (λ ns, + let out2' := k $ oFunctor_map (Outs (F op)) (fstO, inlO) ns.1 in + (ns.2, Tau $ laterO_map fstO out2')) + (s, Err RuntimeErr) ns). - intros m s1 s2 Hs. simpl. eapply (from_option_ne (dist m)); solve_proper. - intros m k1 k2 Hk s. simpl. eapply (from_option_ne (dist m)); solve_proper. - intros m i1 i2 Hi k s. simpl. eapply (from_option_ne (dist m)); solve_proper. + - intros m i1 i2 Hi k j s. simpl. eapply (from_option_ne (dist m)); solve_proper. Defined. Program Definition reify_err : errorO -n> stateM := λne e s, (s, Err e). @@ -68,8 +72,18 @@ Section reifiers. Solve All Obligations with solve_proper. Program Definition unr : stateM -n> - sumO (sumO (sumO (sumO A (laterO (stateM -n> stateM))) errorO) (laterO stateM)) - (sigTO (λ op : opid F, prodO (oFunctor_apply (Ins (F op)) stateM) (oFunctor_apply (Outs (F op)) stateM -n> laterO stateM))). + sumO + (sumO + (sumO + (sumO A (laterO (stateM -n> stateM))) errorO) + (laterO stateM)) + (sigTO (λ op : opid F, + prodO (oFunctor_apply (Ins (F op)) stateM) + (prodO (laterO + ((stateF ♯ IT -n> prodO (stateF ♯ IT) IT) -n> + stateF ♯ IT -n> prodO (stateF ♯ IT) IT)) + (oFunctor_apply (Outs (F op)) stateM -n> + laterO stateM)))). Proof. simple refine (λne d, inl (inl (inr (RuntimeErr)))). Qed. Definition reify : IT -n> stateM @@ -93,10 +107,14 @@ Section reifiers. reify (Fun f) σ ≡ (σ, Fun f). Proof. rewrite /reify/=. - trans (reify_fun (laterO_map (sandwich (Perr:=reify_err) (Pret:=reify_ret) - (Parr:=reify_fun) (Ptau:=reify_tau) - (Pvis:=reify_vis) (Punfold:=unr) - stateM) f) σ). + trans (reify_fun (laterO_map + (sandwich + (IT_rec1 (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) + reify_err reify_ret reify_fun + reify_tau reify_vis unr) + (IT_rec2 (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) + reify_err reify_ret reify_fun + reify_tau reify_vis unr)) f) σ). { f_equiv. apply IT_rec1_fun. } simpl. repeat f_equiv. rewrite -laterO_map_compose. @@ -105,26 +123,44 @@ Section reifiers. apply laterO_map_id. Qed. - Lemma reify_vis_dist m op i o k σ σ' : - sReifier_re r op (i,σ) ≡{m}≡ Some (o,σ') → - reify (Vis op i k) σ ≡{m}≡ (σ', Tau $ k o). + Lemma reify_vis_dist m op i o k j σ σ' : + sReifier_re r op ((i, σ), k) ≡{m}≡ Some (o, σ') → + reify (Vis op i k j) σ ≡{m}≡ (σ', Tau $ j o). Proof. intros Hst. trans (reify_vis op - (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) - (laterO_map (prod_in idfun reify) ◎ k ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) + (oFunctor_map _ (sumO_rec idfun unreify, prod_in idfun reify) i) + (laterO_map (sandwich (IT_rec1 + (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) + reify_err + reify_ret + reify_fun + reify_tau + reify_vis + unr) + (IT_rec2 + (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) + reify_err + reify_ret + reify_fun + reify_tau + reify_vis + unr)) k) + (laterO_map (prod_in idfun reify) ◎ j ◎ (oFunctor_map _ (prod_in idfun reify, sumO_rec idfun unreify))) σ). { f_equiv. rewrite IT_rec1_vis//. } Opaque prod_in. simpl. - pose (rs := (sReifier_re r op - (oFunctor_map (Ins (F op)) (inlO, fstO) - (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). + pose (rs := sReifier_re r op ((oFunctor_map (Ins (F op)) (inlO, fstO) + (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ), k)). fold rs. - assert (rs ≡ sReifier_re r op (i,σ)) as Hr'. - { unfold rs. f_equiv. f_equiv. + assert (rs ≡ sReifier_re r op (i, σ, k)) as Hr'. + { + unfold rs. f_equiv. f_equiv. rewrite -oFunctor_map_compose. + repeat f_equiv. etrans; last by apply oFunctor_map_id. - repeat f_equiv; intro; done. } + repeat f_equiv; intro; done. + } assert (rs ≡{m}≡ Some (o,σ')) as Hr. { by rewrite Hr' Hst. } trans (from_option (λ ns, @@ -132,15 +168,27 @@ Section reifiers. Tau (laterO_map fstO (laterO_map (prod_in idfun reify) - (k + (j (oFunctor_map (Outs (F op)) (prod_in idfun reify, sumO_rec idfun unreify) (oFunctor_map (Outs (F op)) (fstO, inlO) ns.1))))))) (σ, Err RuntimeErr) (Some (o,σ'))). - { eapply (from_option_ne (dist m)); solve_proper. } + { + eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. + rewrite <-Hr. + subst rs. + repeat f_equiv. + rewrite -laterO_map_compose. + trans (laterO_map idfun k); last by rewrite laterO_map_id. + do 2 f_equiv. + intros x y; simpl. + Transparent prod_in. + unfold prod_in; simpl. + reflexivity. + } simpl. repeat f_equiv. rewrite -laterO_map_compose. rewrite -oFunctor_map_compose. - trans (laterO_map idfun (k o)); last first. + trans (laterO_map idfun (j o)); last first. { by rewrite laterO_map_id. } repeat f_equiv. { intro; done. } @@ -150,33 +198,48 @@ Section reifiers. repeat f_equiv; intro; done. Qed. - Lemma reify_vis_eq op i o k σ σ' : - sReifier_re r op (i,σ) ≡ Some (o,σ') → - reify (Vis op i k) σ ≡ (σ', Tau $ k o). + Lemma reify_vis_eq op i o k j σ σ' : + sReifier_re r op (i, σ, k) ≡ Some (o, σ') → + reify (Vis op i k j) σ ≡ (σ', Tau $ j o). Proof. intros H. apply equiv_dist=>m. apply reify_vis_dist. by apply equiv_dist. Qed. - Lemma reify_vis_None op i k σ : - sReifier_re r op (i,σ) ≡ None → - reify (Vis op i k) σ ≡ (σ, Err RuntimeErr). + Lemma reify_vis_None op i k j σ : + sReifier_re r op (i, σ, k) ≡ None → + reify (Vis op i k j) σ ≡ (σ, Err RuntimeErr). Proof. intros Hs. trans (reify_vis op (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) - (laterO_map (prod_in idfun reify) ◎ k ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) + (laterO_map (sandwich (IT_rec1 + (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) + reify_err + reify_ret + reify_fun + reify_tau + reify_vis + unr) + (IT_rec2 + (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) + reify_err + reify_ret + reify_fun + reify_tau + reify_vis + unr)) k) + (laterO_map (prod_in idfun reify) ◎ j ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) σ). { f_equiv. apply IT_rec1_vis. } simpl. - pose (rs := (sReifier_re r op - (oFunctor_map (Ins (F op)) (inlO, fstO) - (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). + pose (rs := sReifier_re r op ((oFunctor_map (Ins (F op)) (inlO, fstO) + (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ), k)). fold rs. - assert (rs ≡ sReifier_re r op (i,σ)) as Hr'. - { unfold rs. f_equiv. f_equiv. + assert (rs ≡ sReifier_re r op (i,σ,k)) as Hr'. + { unfold rs. f_equiv. f_equiv. f_equiv. rewrite -oFunctor_map_compose. etrans; last by apply oFunctor_map_id. repeat f_equiv; intro; done. } @@ -187,11 +250,21 @@ Section reifiers. Tau (laterO_map fstO (laterO_map (prod_in idfun reify) - (k + (j (oFunctor_map (Outs (F op)) (prod_in idfun reify, sumO_rec idfun unreify) (oFunctor_map (Outs (F op)) (fstO, inlO) ns.1))))))) (σ, Err RuntimeErr) None). - { apply from_option_proper; solve_proper. } + { apply from_option_proper; [solve_proper | solve_proper |]. + rewrite <-Hr. + subst rs. + repeat f_equiv. + - reflexivity. + - rewrite -laterO_map_compose. + trans (laterO_map idfun k); last by rewrite laterO_map_id. + do 2 f_equiv. + intros x y; simpl. + reflexivity. + } reflexivity. Qed. diff --git a/theories/input_lang/lang.v b/theories/input_lang/lang.v index 82fac6c..491acc6 100644 --- a/theories/input_lang/lang.v +++ b/theories/input_lang/lang.v @@ -1,35 +1,78 @@ From stdpp Require Export strings. -From gitrees Require Export prelude lang_generic. +From gitrees Require Export prelude. From Equations Require Import Equations. Require Import List. Import ListNotations. -Delimit Scope expr_scope with E. +Require Import Binding.Lib Binding.Set Binding.Auto Binding.Env. Inductive nat_op := Add | Sub | Mult. -Inductive expr : scope → Type := - (* Values *) - | Val : forall {S}, val S → expr S - (* Base lambda calculus *) - | Var : forall {S}, var S → expr S - | Rec : forall {S}, expr (()::()::S) → expr S - | App : forall {S}, expr S → expr S → expr S - (* Base types and their operations *) - | NatOp : forall {S}, - nat_op → expr S → expr S → expr S - | If : forall {S}, - expr S → expr S → expr S → expr S - (* The effects *) - | Input : forall {S}, expr S - | Output : forall {S}, expr S → expr S -with val : scope → Type := - | Lit : forall {S}, nat → val S - | RecV : forall {S}, expr (()::()::S) → val S. - -Bind Scope expr_scope with expr. +Inductive expr {X : Set} := +(* Values *) +| Val (v : val) : expr +(* Base lambda calculus *) +| App (e₁ : expr) (e₂ : expr) : expr +(* Base types and their operations *) +| NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr +| If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr +(* The effects *) +| Input : expr +| Output (e : expr) : expr +| Callcc (e : @expr (inc X)) : expr +| Throw (e₁ : expr) (e₂ : expr) : expr +with val {X : Set} := +| VarV (x : X) : val +| LitV (n : nat) : val +| RecV (e : @expr (inc (inc X))) : val +| ContV (K : ectx) : val +with ectx {X : Set} := +| EmptyK : ectx +| OutputK (K : ectx) : ectx +| IfK (K : ectx) (e₁ : expr) (e₂ : expr) : ectx +| AppLK (e : expr) (K : ectx) : ectx +| AppRK (K : ectx) (v : val) : ectx +| NatOpLK (op : nat_op) (e : expr) (K : ectx) : ectx +| NatOpRK (op : nat_op) (K : ectx) (v : val) : ectx +| ThrowLK (K : ectx) (e : expr) : ectx +| ThrowRK (v : val) (K : ectx) : ectx. + Notation of_val := Val (only parsing). +Arguments val X%bind : clear implicits. +Arguments expr X%bind : clear implicits. +Arguments ectx X%bind : clear implicits. + +Declare Scope syn_scope. +Declare Scope ectx_scope. +Delimit Scope syn_scope with syn. +Delimit Scope ectx_scope with ectx. + +Coercion Val : val >-> expr. +Coercion App : expr >-> Funclass. +Coercion AppLK : expr >-> Funclass. +Coercion AppRK : ectx >-> Funclass. + +Notation "+" := (Add) : syn_scope. +Notation "-" := (Sub) : syn_scope. +Notation "×" := (Mult) : syn_scope. +Notation "'⟨' e₁ op e₂ '⟩'" := (NatOp op e₁ e₂) (at level 45, right associativity) : syn_scope. +Notation "'if' e₁ 'then' e₂ 'else' e₃" := (If e₁ e₂ e₃) : syn_scope. +Notation "'#' n" := (LitV n) (at level 60) : syn_scope. +Notation "'input'" := (Input) : syn_scope. +Notation "'output' e" := (Output e) (at level 60) : syn_scope. +Notation "'rec' e" := (RecV e) (at level 60) : syn_scope. +Notation "'throw' e₁ e₂" := (Throw e₁ e₂) (at level 60) : syn_scope. +Notation "'cont' K" := (ContV K) (at level 60) : syn_scope. + +Notation "□" := (EmptyK) : ectx_scope. +Notation "'⟨' e₁ op K '⟩ᵣ'" := (NatOpLK op e₁ K) (at level 45, right associativity) : ectx_scope. +Notation "'⟨' K op v₂ '⟩ₗ'" := (NatOpRK op K v₂) (at level 45, right associativity) : ectx_scope. +Notation "'if' K 'then' e₂ 'else' e₃" := (IfK K e₂ e₃) : ectx_scope. +Notation "'output' K" := (OutputK K) (at level 60) : ectx_scope. +Notation "'throwₗ' K e₂" := (ThrowLK K e₂) (at level 60) : ectx_scope. +Notation "'throwᵣ' e₁ K" := (ThrowRK e₁ K) (at level 60) : ectx_scope. + Definition to_val {S} (e : expr S) : option (val S) := match e with | Val v => Some v @@ -38,244 +81,259 @@ Definition to_val {S} (e : expr S) : option (val S) := Definition do_natop (op : nat_op) (x y : nat) : nat := match op with - | Add => x+y - | Sub => x-y - | Mult => x+y + | Add => plus x y + | Sub => minus x y + | Mult => mult x y end. Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := match x, y with - | Lit x, Lit y => Some $ Lit $ do_natop n x y + | LitV x, LitV y => Some $ LitV $ do_natop n x y | _,_ => None end. -(** substitution stuff *) -Definition rens S S' := var S → var S'. -Definition subs S S' := var S → expr S'. - -Definition idren {S} : rens S S := fun v => v. -Definition idsub {S} : subs S S := Var. - -Equations conssub {S S' τ} (M : expr S') (s : subs S S') : subs (τ::S) S' := - conssub M s Vz := M; - conssub M s (Vs v) := s v. - -Notation "{/ e ; .. ; f /}" := (conssub e .. (conssub f idsub) ..). - -Definition tl_sub {S S' τ} : subs (τ::S) S' → subs S S' := λ s v, s (Vs v). -Definition hd_sub {S S' τ} : subs (τ::S) S' → expr S' := λ s, s Vz. -Definition tl_ren {S S' τ} : rens (τ::S) S' → rens S S' := λ s v, s (Vs v). -Definition hd_ren {S S' τ} : rens (τ::S) S' → var S' := λ s, s Vz. - -(* Lifting a renaming, renaming terms, and lifting substitutions *) -Equations rens_lift {S S'} (s : rens S S') : rens (()::S) (()::S') := - rens_lift s Vz := Vz; - rens_lift s (Vs v) := Vs $ s v. - -Equations ren_expr {S S'} (M : expr S) (r : rens S S') : expr S' := -ren_expr (Val v) r := Val $ ren_val v r; -ren_expr (Var v) r := Var (r v); -ren_expr (Rec M) r := Rec (ren_expr M (rens_lift (rens_lift r))); -ren_expr (App M N) r := App (ren_expr M r) (ren_expr N r); -ren_expr (NatOp op e1 e2) r := NatOp op (ren_expr e1 r) (ren_expr e2 r); -ren_expr (If e0 e1 e2) r := If (ren_expr e0 r) (ren_expr e1 r) (ren_expr e2 r); -ren_expr Input r := Input; -ren_expr (Output e) r := Output (ren_expr e r); -with ren_val {S S'} (M : val S) (r : rens S S') : val S' := -ren_val (Lit n) _ := Lit n; -ren_val (RecV e) r := RecV (ren_expr e (rens_lift (rens_lift r))). - - -Definition expr_lift {S} (M : expr S) : expr (()::S) := ren_expr M Vs. - -Equations subs_lift {S S'} (s : subs S S') : subs (()::S) (()::S') := - subs_lift s Vz := Var Vz; - subs_lift s (Vs v) := expr_lift $ s v. - -(* We can now define the substitution operation *) -Equations subst_expr {S S'} (M : expr S) (s : subs S S') : expr S' := -subst_expr (Val v) r := Val $ subst_val v r; -subst_expr (Var v) r := r v; -subst_expr (Rec M) r := Rec (subst_expr M (subs_lift (subs_lift r))); -subst_expr (App M N) r := App (subst_expr M r) (subst_expr N r); -subst_expr (NatOp op e1 e2) r := NatOp op (subst_expr e1 r) (subst_expr e2 r); -subst_expr (If e0 e1 e2) r := If (subst_expr e0 r) (subst_expr e1 r) (subst_expr e2 r); -subst_expr (Input) r := Input; -subst_expr (Output e) r := Output (subst_expr e r); -with subst_val {S S'} (M : val S) (r : subs S S') : val S' := -subst_val (Lit n) _ := Lit n; -subst_val (RecV e) r := RecV (subst_expr e (subs_lift (subs_lift r))). - -Definition subst1 {S : scope} {τ} (M : expr (τ::S)) (N : expr S) : expr S - := subst_expr M {/ N /}. -Definition subst2 {S : scope} {i j} (M : expr (i::j::S)) (N1 : expr S) (N2 : expr S) : expr S - := subst_expr M {/ N1; N2 /}. - -Definition appsub {S1 S2 S3} (s : subs S1 S2) (s' : subs S2 S3) : subs S1 S3 := - λ v, subst_expr (s v) s'. - -Global Instance rens_equiv S S' : Equiv (rens S S') := λ s1 s2, ∀ v, s1 v = s2 v. -Global Instance subs_equiv S S' : Equiv (subs S S') := λ s1 s2, ∀ v, s1 v = s2 v. - -Global Instance rens_lift_proper S S' : Proper ((≡) ==> (≡)) (@rens_lift S S'). +Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := + match K with + | EmptyK => e + | OutputK K => Output (fill K e) + | IfK K e₁ e₂ => If (fill K e) e₁ e₂ + | AppLK e' K => App e' (fill K e) + | AppRK K v => App (fill K e) (Val v) + | NatOpLK op e' K => NatOp op e' (fill K e) + | NatOpRK op K v => NatOp op (fill K e) (Val v) + | ThrowLK K e' => Throw (fill K e) e' + | ThrowRK v K => Throw (Val v) (fill K e) + end. + +Notation "K '[' e ']'" := (fill K e) (at level 60) : syn_scope. + +Local Open Scope bind_scope. + +Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := + match e with + | Val v => Val (vmap f v) + | App e₁ e₂ => App (emap f e₁) (emap f e₂) + | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) + | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) + | Input => Input + | Output e => Output (emap f e) + | Callcc e => Callcc (emap (f ↑) e) + | Throw e₁ e₂ => Throw (emap f e₁) (emap f e₂) + end +with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := + match v with + | VarV x => VarV (f x) + | LitV n => LitV n + | RecV e => RecV (emap ((f ↑) ↑) e) + | ContV K => ContV (kmap f K) + end +with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kmap f K) + | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) + | AppLK e K => AppLK (emap f e) (kmap f K) + | AppRK K v => AppRK (kmap f K) (vmap f v) + | NatOpLK op e K => NatOpLK op (emap f e) (kmap f K) + | NatOpRK op K v => NatOpRK op (kmap f K) (vmap f v) + | ThrowLK K e => ThrowLK (kmap f K) (emap f e) + | ThrowRK v K => ThrowRK (vmap f v) (kmap f K) + end. +#[export] Instance FMap_expr : FunctorCore expr := @emap. +#[export] Instance FMap_val : FunctorCore val := @vmap. +#[export] Instance FMap_ectx : FunctorCore ectx := @kmap. + +Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) + : fmap f (fill K e) = fill (fmap f K) (fmap f e). Proof. - intros s1 s2 Hs v. dependent elimination v; simp rens_lift; eauto. - f_equiv. apply Hs. + revert f. + induction K as [| ?? IH + | ?? IH + | ??? IH + | ?? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]; + intros f; term_simpl; first done; rewrite IH; reflexivity. Qed. -Lemma ren_expr_proper {S S'} (e : expr S) : Proper ((≡) ==> (=)) (@ren_expr S S' e) - with ren_val_proper {S S'} v : Proper ((≡) ==> (=)) (@ren_val S S' v). +#[export] Instance SPC_val : SetPureCore val := @VarV. + +Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := + match e with + | Val v => Val (vbind f v) + | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) + | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) + | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) + | Input => Input + | Output e => Output (ebind f e) + | Callcc e => Callcc (ebind (f ↑) e) + | Throw e₁ e₂ => Throw (ebind f e₁) (ebind f e₂) + end +with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := + match v with + | VarV x => f x + | LitV n => LitV n + | RecV e => RecV (ebind ((f ↑) ↑) e) + | ContV K => ContV (kbind f K) + end +with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kbind f K) + | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) + | AppLK e K => AppLK (ebind f e) (kbind f K) + | AppRK K v => AppRK (kbind f K) (vbind f v) + | NatOpLK op e K => NatOpLK op (ebind f e) (kbind f K) + | NatOpRK op K v => NatOpRK op (kbind f K) (vbind f v) + | ThrowLK K e => ThrowLK (kbind f K) (ebind f e) + | ThrowRK v K => ThrowRK (vbind f v) (kbind f K) + end. + +#[export] Instance BindCore_expr : BindCore expr := @ebind. +#[export] Instance BindCore_val : BindCore val := @vbind. +#[export] Instance BindCore_ectx : BindCore ectx := @kbind. + +#[export] Instance IP_typ : SetPure val. Proof. - - revert S'. - induction e; intros S' s1 s2 Hs; simp ren_expr; - f_equiv; try solve [eauto | apply ren_expr_proper; eauto ]. - + by apply ren_val_proper. - + apply ren_expr_proper. by repeat f_equiv. - - revert S'. - induction v; intros S' s1 s2 Hs; simp ren_expr; - f_equiv; try solve [eauto | apply ren_expr_proper; eauto ]. - apply ren_expr_proper. by repeat f_equiv. + split; intros; reflexivity. Qed. -#[export] Existing Instance ren_expr_proper. -#[export] Existing Instance ren_val_proper. - -#[export] Instance subs_lift_proper S S' : Proper ((≡) ==> (≡)) (@subs_lift S S'). +Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v +with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e +with kmap_id X (δ : X [→] X) (e : ectx X) : δ ≡ ı → fmap δ e = e. Proof. - intros s1 s2 Hs v. dependent elimination v; simp subs_lift; eauto. - f_equiv. apply Hs. + - auto_map_id. + - auto_map_id. + - auto_map_id. Qed. -Lemma subst_expr_proper {S S'} (e : expr S) : Proper ((≡) ==> (=)) (@subst_expr S S' e) - with subst_val_proper {S S'} v : Proper ((≡) ==> (=)) (@subst_val S S' v). +Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : + f ∘ g ≡ h → fmap f (fmap g v) = fmap h v +with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e +with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : ectx A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. Proof. - - revert S'. - induction e; intros S' s1 s2 Hs; simp subst_expr; - f_equiv; try solve [eauto | apply subst_expr_proper; eauto ]. - + by apply subst_val_proper. - + apply subst_expr_proper. by repeat f_equiv. - - revert S'. - induction v; intros S' s1 s2 Hs; simp subst_expr; - f_equiv; try solve [eauto | apply subst_expr_proper; eauto ]. - apply subst_expr_proper. by repeat f_equiv. + - auto_map_comp. + - auto_map_comp. + - auto_map_comp. Qed. -#[export] Existing Instance subst_expr_proper. -#[export] Existing Instance subst_val_proper. -Lemma subst_ren_expr {S1 S2 S3} e (s : subs S2 S3) (r : rens S1 S2) : - subst_expr (ren_expr e r) s = subst_expr e (compose s r) -with subst_ren_val {S1 S2 S3} v (s : subs S2 S3) (r : rens S1 S2) : - subst_val (ren_val v r) s = subst_val v (compose s r). +#[export] Instance Functor_val : Functor val. +Proof. + split; [exact vmap_id | exact vmap_comp]. +Qed. +#[export] Instance Functor_expr : Functor expr. +Proof. + split; [exact emap_id | exact emap_comp]. +Qed. +#[export] Instance Functor_ectx : Functor ectx. Proof. - - revert S2 S3 r s. - induction e=>S2 S3 r s; simp ren_expr; simp subst_expr; try f_equiv; eauto. - rewrite IHe. apply subst_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. - - revert S2 S3 r s. - induction v=>S2 S3 r s; simpl; simp ren_val; simp subst_val; try f_equiv. - rewrite subst_ren_expr. - apply subst_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. + split; [exact kmap_id | exact kmap_comp]. Qed. -Lemma ren_ren_expr {S1 S2 S3} e (s : rens S2 S3) (r : rens S1 S2) : - ren_expr (ren_expr e r) s = ren_expr e (compose s r) -with ren_ren_val {S1 S2 S3} v (s : rens S2 S3) (r : rens S1 S2) : - ren_val (ren_val v r) s = ren_val v (compose s r). +Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : + f ̂ ≡ g → fmap f v = bind g v +with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : + f ̂ ≡ g → fmap f e = bind g e +with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx A) : + f ̂ ≡ g → fmap f e = bind g e. Proof. - - revert S2 S3 r s. - induction e=>S2 S3 r s; simp ren_expr; try f_equiv; eauto. - rewrite IHe. apply ren_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. - - revert S2 S3 r s. - induction v=>S2 S3 r s; simpl; simp ren_val; simp subst_val; try f_equiv. - rewrite ren_ren_expr. - apply ren_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. + - auto_map_bind_pure. + erewrite emap_ebind_pure; [reflexivity |]. + intros [| [| x]]; term_simpl; [reflexivity | reflexivity |]. + rewrite <-(EQ x). + reflexivity. + - auto_map_bind_pure. + - auto_map_bind_pure. Qed. -Definition rcompose {S1 S2 S3} (r : rens S2 S3) (s : subs S1 S2) : subs S1 S3 := - λ v, ren_expr (s v) r. +#[export] Instance BindMapPure_val : BindMapPure val. +Proof. + split; intros; now apply vmap_vbind_pure. +Qed. +#[export] Instance BindMapPure_expr : BindMapPure expr. +Proof. + split; intros; now apply emap_ebind_pure. +Qed. +#[export] Instance BindMapPure_ectx : BindMapPure ectx. +Proof. + split; intros; now apply kmap_kbind_pure. +Qed. -Lemma ren_subst_expr {S1 S2 S3} e (s : subs S1 S2) (r : rens S2 S3) : - ren_expr (subst_expr e s) r = subst_expr e (rcompose r s) -with ren_subst_val {S1 S2 S3} v (s : subs S1 S2) (r : rens S2 S3) : - ren_val (subst_val v s) r = subst_val v (rcompose r s). +Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (v : val A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) +with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) +with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : ectx A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). Proof. - - revert S2 S3 r s. - induction e=>S2 S3 r s; simp subst_expr; simp ren_expr; try f_equiv; eauto. - rewrite IHe. apply subst_expr_proper. - intro v. simpl. unfold rcompose. - dependent elimination v; eauto. - dependent elimination v; eauto. - simp subs_lift. unfold expr_lift. - rewrite !ren_ren_expr. apply ren_expr_proper. - intro x. dependent elimination v; eauto. - - revert S2 S3 r s. - induction v=>S2 S3 r s; simp subst_expr; simp ren_expr; try f_equiv; eauto. - rewrite ren_subst_expr. apply subst_expr_proper. - intro v. simpl. unfold rcompose. - dependent elimination v; eauto. - dependent elimination v; eauto. - simp subs_lift. unfold expr_lift. - rewrite !ren_ren_expr. apply ren_expr_proper. - intro x. dependent elimination v; eauto. + - auto_map_bind_comm. + erewrite emap_ebind_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity | assumption]. + - auto_map_bind_comm. + - auto_map_bind_comm. Qed. -Lemma appsub_lift {S1 S2 S3} (s : subs S1 S2) (s' : subs S2 S3) : - subs_lift (appsub s s') ≡ appsub (subs_lift s) (subs_lift s'). +#[export] Instance BindMapComm_val : BindMapComm val. Proof. - unfold appsub. - intro v. dependent elimination v; simp subs_lift; eauto. - unfold expr_lift. rewrite subst_ren_expr. - rewrite ren_subst_expr. apply subst_expr_proper. - intro x. unfold rcompose. simpl. simp subs_lift. done. + split; intros; now apply vmap_vbind_comm. +Qed. +#[export] Instance BindMapComm_expr : BindMapComm expr. +Proof. + split; intros; now apply emap_ebind_comm. +Qed. +#[export] Instance BindMapComm_ectx : BindMapComm ectx. +Proof. + split; intros; now apply kmap_kbind_comm. Qed. -Lemma subst_expr_appsub {S1 S2 S3} (s1 : subs S1 S2) (s2 : subs S2 S3) e : - subst_expr (subst_expr e s1) s2 = subst_expr e (appsub s1 s2) -with subst_val_appsub {S1 S2 S3} (s1 : subs S1 S2) (s2 : subs S2 S3) v : - subst_val (subst_val v s1) s2 = subst_val v (appsub s1 s2). +Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : + f ≡ ı → bind f v = v +with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : + f ≡ ı → bind f e = e +with kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : + f ≡ ı → bind f e = e. Proof. - - revert S2 S3 s1 s2. - induction e=>S2 S3 s1 s2; simp subst_expr; try f_equiv; eauto. - rewrite !appsub_lift. apply IHe. - - revert S3 s2. - induction v=>S3 s2; simpl; f_equiv; eauto. - rewrite !appsub_lift. apply subst_expr_appsub. + - auto_bind_id. + rewrite ebind_id; [reflexivity |]. + apply lift_id, lift_id; assumption. + - auto_bind_id. + - auto_bind_id. Qed. -Lemma subst_expr_lift {S S'} e e1 (s : subs S S') : - subst_expr (expr_lift e) (conssub e1 s) = subst_expr e s. +Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : + f ∘ g ≡ h → bind f (bind g v) = bind h v +with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e +with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e. Proof. - unfold expr_lift. - rewrite subst_ren_expr. apply subst_expr_proper. - intro v. simpl. simp conssub. done. + - auto_bind_comp. + erewrite ebind_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity | assumption]. + - auto_bind_comp. + - auto_bind_comp. Qed. -Lemma subst_expr_idsub {S} (e : expr S) : - subst_expr e idsub = e -with subst_val_idsub {S} (v : val S) : - subst_val v idsub = v. +#[export] Instance Bind_val : Bind val. +Proof. + split; intros; [now apply vbind_id | now apply vbind_comp]. +Qed. +#[export] Instance Bind_expr : Bind expr. Proof. - - induction e; simp subst_expr; simpl; try f_equiv; eauto. - assert ((subs_lift (subs_lift idsub)) ≡ idsub) as ->; last auto. - intro v. - dependent elimination v; simp subs_lift; auto. - dependent elimination v; simp subs_lift; auto. - - induction v; simp subst_val; simpl; try f_equiv; eauto. - assert ((subs_lift (subs_lift idsub)) ≡ idsub) as ->; last auto. - intro v. - dependent elimination v; simp subs_lift; auto. - dependent elimination v; simp subs_lift; auto. + split; intros; [now apply ebind_id | now apply ebind_comp]. +Qed. +#[export] Instance Bind_ectx : Bind ectx. +Proof. + split; intros; [now apply kbind_id | now apply kbind_comp]. Qed. (*** Operational semantics *) @@ -286,7 +344,6 @@ Record state := State { }. #[export] Instance state_inhabited : Inhabited state := populate (State [] []). - Definition update_input (s : state) : nat * state := match s.(inputs) with | [] => (0, s) @@ -297,95 +354,93 @@ Definition update_output (n:nat) (s : state) : state := {| inputs := s.(inputs); outputs := n::s.(outputs) |}. -Inductive head_step {S} : expr S → state → expr S → state → nat*nat → Prop := -| RecS e σ : - head_step (Rec e) σ (Val $ RecV e) σ (0,0) -| BetaS e1 v2 e' σ : - e' = subst2 e1 (Val $ RecV e1) (Val v2) → - head_step (App (Val $ RecV e1) (Val v2)) σ e' σ (1,0) -| InputS σ n σ' : +Inductive head_step {S} : expr S → state → expr S → state → ectx S → nat * nat → Prop := +| BetaS e1 v2 σ K : + head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (Inc := inc) e1) (shift v2)) (RecV e1)) σ K (1,0) +| InputS σ n σ' K : update_input σ = (n,σ') → - head_step Input σ (Val (Lit n)) σ' (1,1) -| OutputS σ n σ' : + head_step Input σ (Val (LitV n)) σ' K (1,1) +| OutputS σ n σ' K : update_output n σ = σ' → - head_step (Output (Val (Lit n))) σ (Val (Lit 0)) σ' (1,1) -| NatOpS op v1 v2 v3 σ : + head_step (Output (Val (LitV n))) σ (Val (LitV 0)) σ' K (1,1) +| NatOpS op v1 v2 v3 σ K : nat_op_interp op v1 v2 = Some v3 → head_step (NatOp op (Val v1) (Val v2)) σ - (Val v3) σ (0,0) -| IfTrueS n e1 e2 σ : + (Val v3) σ K (0,0) +| IfTrueS n e1 e2 σ K : n > 0 → - head_step (If (Val (Lit n)) e1 e2) σ - e1 σ (0,0) -| IfFalseS n e1 e2 σ : + head_step (If (Val (LitV n)) e1 e2) σ + e1 σ K (0,0) +| IfFalseS n e1 e2 σ K : n = 0 → - head_step (If (Val (Lit n)) e1 e2) σ - e2 σ (0,0) + head_step (If (Val (LitV n)) e1 e2) σ + e2 σ K (0,0) +| CallccS e σ K : + head_step (Callcc e) σ (subst (Inc := inc) e (ContV K)) σ K (0, 0) . -Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 n m : - head_step e1 σ1 e2 σ2 (n,m) → m = 0 ∨ m = 1. +Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : + head_step e1 σ1 e2 σ2 K (n,m) → m = 0 ∨ m = 1. Proof. inversion 1; eauto. Qed. -Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 n m : - head_step e1 σ1 e2 σ2 (n,m) → n = 0 ∨ n = 1. +Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : + head_step e1 σ1 e2 σ2 K (n,m) → n = 0 ∨ n = 1. Proof. inversion 1; eauto. Qed. -Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 n : - head_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. +Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K n : + head_step e1 σ1 e2 σ2 K (n,0) → σ1 = σ2. Proof. inversion 1; eauto. Qed. -Inductive ectx_item {S} := - | AppLCtx (v2 : val S) - | AppRCtx (e1 : expr S) - | NatOpLCtx (op : nat_op) (v2 : val S) - | NatOpRCtx (op : nat_op) (e1 : expr S) - | IfCtx (e1 e2 : expr S) - | OutputCtx -. -Arguments ectx_item S : clear implicits. - -Definition fill_item {S} (Ki : ectx_item S) (e : expr S) : expr S := - match Ki with - | AppLCtx v2 => App e (of_val v2) - | AppRCtx e1 => App e1 e - | NatOpLCtx op v2 => NatOp op e (Val v2) - | NatOpRCtx op e1 => NatOp op e1 e - | IfCtx e1 e2 => If e e1 e2 - | OutputCtx => Output e - end. - (** Carbonara from heap lang *) -Global Instance fill_item_inj {S} (Ki : ectx_item S) : Inj (=) (=) (fill_item Ki). +Global Instance fill_item_inj {S} (Ki : ectx S) : Inj (=) (=) (fill Ki). Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. Lemma fill_item_val {S} Ki (e : expr S) : - is_Some (to_val (fill_item Ki e)) → is_Some (to_val e). + is_Some (to_val (fill Ki e)) → is_Some (to_val e). Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed. -Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 m : head_step e1 σ1 e2 σ2 m → to_val e1 = None. +Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K m : head_step e1 σ1 e2 σ2 K m → to_val e1 = None. Proof. destruct 1; naive_solver. Qed. -Lemma head_ctx_item_step_val {S} Ki (e : expr S) σ1 e2 σ2 m : - head_step (fill_item Ki e) σ1 e2 σ2 m → is_Some (to_val e). -Proof. revert m e2. induction Ki; simpl; inversion 1; simplify_option_eq; eauto. Qed. - -Lemma fill_item_no_val_inj {S} Ki1 Ki2 (e1 e2 : expr S) : - to_val e1 = None → to_val e2 = None → - fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2. +Fixpoint ectx_compose {S} (K1 K2 : ectx S) : ectx S + := match K1 with + | EmptyK => K2 + | OutputK K => OutputK (ectx_compose K K2) + | IfK K e₁ e₂ => IfK (ectx_compose K K2) e₁ e₂ + | AppLK e K => AppLK e (ectx_compose K K2) + | AppRK K v => AppRK (ectx_compose K K2) v + | NatOpLK op e K => NatOpLK op e (ectx_compose K K2) + | NatOpRK op K v => NatOpRK op (ectx_compose K K2) v + | ThrowLK K e => ThrowLK (ectx_compose K K2) e + | ThrowRK v K => ThrowRK v (ectx_compose K K2) + end. + +Lemma fill_app {S} (K1 K2 : ectx S) e : fill (ectx_compose K1 K2) e = fill K1 (fill K2 e). Proof. - revert Ki1. induction Ki2; intros Ki1; induction Ki1; naive_solver eauto with f_equal. + revert K2. + revert e. + induction K1 as [| ?? IH + | ?? IH + | ??? IH + | ?? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]; + simpl; first done; intros e' K2; rewrite IH; reflexivity. Qed. -(** Lifting the head step **) - -Definition ectx S := (list (ectx_item S)). -Definition fill {S} (K : ectx S) (e : expr S) : expr S := foldl (flip fill_item) e K. - -Lemma fill_app {S} (K1 K2 : ectx S) e : fill (K1 ++ K2) e = fill K2 (fill K1 e). -Proof. apply foldl_app. Qed. - - Lemma fill_val : ∀ {S} K (e : expr S), is_Some (to_val (fill K e)) → is_Some (to_val e). -Proof. intros S K. induction K as [|Ki K IH]=> e //=. by intros ?%IH%fill_item_val. Qed. +Proof. + intros S K. + induction K as [| ?? IH + | ?? IH + | ??? IH + | ?? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]=> e' //=; + inversion 1 as [? HH]; inversion HH. +Qed. Lemma fill_not_val : ∀ {S} K (e : expr S), to_val e = None → to_val (fill K e) = None. Proof. @@ -393,57 +448,57 @@ Proof. eauto using fill_val. Qed. -Lemma fill_empty {S} (e : expr S) : fill [] e = e. +Lemma fill_empty {S} (e : expr S) : fill EmptyK e = e. Proof. reflexivity. Qed. -Lemma fill_comp {S} K1 K2 (e : expr S) : fill K1 (fill K2 e) = fill (K2 ++ K1) e. +Lemma fill_comp {S} K1 K2 (e : expr S) : fill K2 (fill K1 e) = fill (ectx_compose K2 K1) e. Proof. by rewrite fill_app. Qed. -Global Instance fill_inj {S} (K:ectx S) : Inj (=) (=) (fill K). -Proof. induction K as [|Ki K IH]; rewrite /Inj; naive_solver. Qed. - +Global Instance fill_inj {S} (K : ectx S) : Inj (=) (=) (fill K). +Proof. + induction K as [| ?? IH + | ?? IH + | ??? IH + | ?? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]; + rewrite /Inj; naive_solver. +Qed. -Inductive prim_step {S} (e1 : expr S) (σ1 : state) - (e2 : expr S) (σ2 : state) (n : nat*nat) : Prop:= - Ectx_step (K : ectx S) e1' e2' : - e1 = fill K e1' → e2 = fill K e2' → - head_step e1' σ1 e2' σ2 n → prim_step e1 σ1 e2 σ2 n. +Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) + (e2 : expr S) (σ2 : state) (n : nat * nat), Prop := +| Ectx_step e1 σ1 e2 σ2 n (K : ectx S) e1' e2' : + e1 = fill K e1' → e2 = fill K e2' → + head_step e1' σ1 e2' σ2 K n → prim_step e1 σ1 e2 σ2 n +| Throw_step e1 σ e2 (K : ectx S) v K' : + e1 = (fill K (Throw (of_val v) (ContV K'))) -> + e2 = (fill K' v) -> + prim_step e1 σ e2 σ (0, 0). Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. Proof. inversion 1; simplify_eq/=. - inversion H2; eauto. + - inversion H2; eauto. + - reflexivity. Qed. -Inductive prim_steps {S} : expr S → state → expr S → state → nat*nat → Prop := +Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat → Prop := | prim_steps_zero e σ : - prim_steps e σ e σ (0,0) + prim_steps e σ e σ (0, 0) | prim_steps_abit e1 σ1 e2 σ2 e3 σ3 n1 m1 n2 m2 : - prim_step e1 σ1 e2 σ2 (n1,m1) → - prim_steps e2 σ2 e3 σ3 (n2,m2) → - prim_steps e1 σ1 e3 σ3 (n1+n2,m1+m2) + prim_step e1 σ1 e2 σ2 (n1, m1) → + prim_steps e2 σ2 e3 σ3 (n2, m2) → + prim_steps e1 σ1 e3 σ3 (plus n1 n2, plus m1 m2) . Lemma Ectx_step' {S} (K : ectx S) e1 σ1 e2 σ2 efs : - head_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. + head_step e1 σ1 e2 σ2 K efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. Proof. econstructor; eauto. Qed. -Lemma prim_step_ctx {S} (K : ectx S) e1 σ1 e2 σ2 efs : - prim_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. -Proof. - destruct 1 as [K2 u1 u2 HK2]. - subst e1 e2. rewrite -!fill_app. - by econstructor; eauto. -Qed. - -Lemma prim_steps_ctx {S} (K : ectx S) e1 σ1 e2 σ2 efs : - prim_steps e1 σ1 e2 σ2 efs → prim_steps (fill K e1) σ1 (fill K e2) σ2 efs. -Proof. - induction 1; econstructor; eauto using prim_step_ctx. -Qed. - Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : prim_steps e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 → - prim_steps e1 σ1 e3 σ3 (nm1.1 + nm2.1, nm1.2 + nm2.2). + prim_steps e1 σ1 e3 σ3 (plus nm1.1 nm2.1, plus nm1.2 nm2.2). Proof. intros Hst. revert nm2. induction Hst; intros [n' m']; simplify_eq/=; first done. @@ -462,48 +517,47 @@ Proof. by constructor. Qed. - (*** Type system *) - Inductive ty := - | Tnat : ty | Tarr : ty → ty → ty. - -Local Notation tyctx := (tyctx ty). + | Tnat : ty | Tarr : ty → ty → ty | Tcont : ty → ty. -Inductive typed : forall {S}, tyctx S → expr S → ty → Prop := -| typed_Val {S} (Γ : tyctx S) (τ : ty) (v : val S) : +Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := +| typed_Val (τ : ty) (v : val S) : typed_val Γ v τ → typed Γ (Val v) τ -| typed_Var {S} (Γ : tyctx S) (τ : ty) (v : var S) : - typed_var Γ v τ → - typed Γ (Var v) τ -| typed_Rec {S} (Γ : tyctx S) (τ1 τ2 : ty) (e : expr (()::()::S) ) : - typed (consC (Tarr τ1 τ2) (consC τ1 Γ)) e τ2 → - typed Γ (Rec e) (Tarr τ1 τ2) -| typed_App {S} (Γ : tyctx S) (τ1 τ2 : ty) e1 e2 : +| typed_App (τ1 τ2 : ty) e1 e2 : typed Γ e1 (Tarr τ1 τ2) → typed Γ e2 τ1 → typed Γ (App e1 e2) τ2 -| typed_NatOp {S} (Γ : tyctx S) e1 e2 op : +| typed_NatOp e1 e2 op : typed Γ e1 Tnat → typed Γ e2 Tnat → typed Γ (NatOp op e1 e2) Tnat -| typed_If {S} (Γ : tyctx S) e0 e1 e2 τ : +| typed_If e0 e1 e2 τ : typed Γ e0 Tnat → typed Γ e1 τ → typed Γ e2 τ → typed Γ (If e0 e1 e2) τ -| typed_Input {S} (Γ : tyctx S) : +| typed_Input : typed Γ Input Tnat -| typed_Output {S} (Γ : tyctx S) e : +| typed_Output e : typed Γ e Tnat → typed Γ (Output e) Tnat -with typed_val : forall {S}, tyctx S → val S → ty → Prop := -| typed_Lit {S} (Γ : tyctx S) n : - typed_val Γ (Lit n) Tnat -| typed_RecV {S} (Γ : tyctx S) (τ1 τ2 : ty) (e : expr (()::()::S) ) : - typed (consC (Tarr τ1 τ2) (consC τ1 Γ)) e τ2 → +| typed_Throw e1 e2 τ τ' : + typed Γ e1 τ -> + typed Γ e2 (Tcont τ) -> + typed Γ (Throw e1 e2) τ' +| typed_Callcc e τ : + typed (Γ ▹ Tcont τ) e τ -> + typed Γ (Callcc e) τ +with typed_val {S : Set} (Γ : S -> ty) : val S → ty → Prop := +| typed_Var (τ : ty) (v : S) : + Γ v = τ → + typed_val Γ (VarV v) τ +| typed_Lit n : + typed_val Γ (LitV n) Tnat +| typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : + typed (Γ ▹ (Tarr τ1 τ2) ▹ τ1) e τ2 → typed_val Γ (RecV e) (Tarr τ1 τ2) . - diff --git a/theories/lang_generic.v b/theories/lang_generic.v index bd40796..84cadee 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -1,5 +1,4 @@ From gitrees Require Import prelude. -From gitrees Require Import gitree. From Equations Require Import Equations. Require Import List. Import ListNotations. @@ -41,182 +40,3 @@ Inductive typed_var {ty : Type}: forall {S}, tyctx ty S → var S → ty → Pro typed_var Γ v τ → typed_var (consC τ' Γ) (Vs v) τ . - -Section interp. - Local Open Scope type. - Context {E: opsInterp}. - Context {R} `{!Cofe R}. - Notation IT := (IT E R). - Notation ITV := (ITV E R). - - Fixpoint interp_scope (S : scope) : ofe := - match S with - | [] => unitO - | τ::Sc => prodO IT (interp_scope Sc) - end. - - Instance interp_scope_cofe S : Cofe (interp_scope S). - Proof. induction S; simpl; apply _. Qed. - - Instance interp_scope_inhab S : Inhabited (interp_scope S). - Proof. induction S; simpl; apply _. Defined. - - Equations interp_var {S : scope} (v : var S) : interp_scope S -n> IT := - interp_var (S:=(_::_)) Vz := fstO; - interp_var (S:=(_::Sc)) (Vs v) := interp_var v ◎ sndO. - - Instance interp_var_ne S (v : var S) : NonExpansive (@interp_var S v). - Proof. - intros n D1 D2 HD12. induction v; simp interp_var. - - by f_equiv. - - eapply IHv. by f_equiv. - Qed. - - Global Instance interp_var_proper S (v : var S) : Proper ((≡) ==> (≡)) (interp_var v). - Proof. apply ne_proper. apply _. Qed. - - Definition interp_scope_split {S1 S2} : - interp_scope (S1 ++ S2) -n> interp_scope S1 * interp_scope S2. - Proof. - induction S1 as [|? S1]; simpl. - - simple refine (λne x, (tt, x)). - solve_proper. - - simple refine (λne xy, let ss := IHS1 xy.2 in ((xy.1, ss.1), ss.2)). - solve_proper. - Defined. - - (** scope substituions *) - Inductive ssubst : scope → Type := - | emp_ssubst : ssubst [] - | cons_ssubst {S} : ITV → ssubst S → ssubst (tt::S) - . - - Equations interp_ssubst {S} (ss : ssubst S) : interp_scope S := - interp_ssubst emp_ssubst := tt; - interp_ssubst (cons_ssubst αv ss) := (IT_of_V αv, interp_ssubst ss). - - Equations list_of_ssubst {S} (ss : ssubst S) : list ITV := - list_of_ssubst emp_ssubst := []; - list_of_ssubst (cons_ssubst αv ss) := αv::(list_of_ssubst ss). - - Equations ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : ssubst S1 * ssubst S2 := - ssubst_split (S1:=[]) αs := (emp_ssubst,αs); - ssubst_split (S1:=u::_) (cons_ssubst αv αs) := - (cons_ssubst αv (ssubst_split αs).1, (ssubst_split αs).2). - Lemma interp_scope_ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : - interp_scope_split (interp_ssubst αs) ≡ - (interp_ssubst (ssubst_split αs).1, interp_ssubst (ssubst_split αs).2). - Proof. - induction S1 as [|u S1]; simpl. - - simp ssubst_split. simpl. - simp interp_ssubst. done. - - dependent elimination αs as [cons_ssubst αv αs]. - simp ssubst_split. simpl. - simp interp_ssubst. repeat f_equiv; eauto; simpl. - + rewrite IHS1//. - + rewrite IHS1//. - Qed. - -End interp. - -(* Common definitions and lemmas for Kripke logical relations *) -Section kripke_logrel. - Variable s : stuckness. - - Context {sz : nat}. - Variable rs : gReifiers sz. - Context {R} `{!Cofe R}. - - Notation F := (gReifiers_ops rs). - Notation IT := (IT F R). - Notation ITV := (ITV F R). - Context `{!invGS Σ, !stateG rs R Σ}. - Notation iProp := (iProp Σ). - - Context {A:ofe}. (* The type & predicate for the explicit Kripke worlds *) - Variable (P : A → iProp). - Context `{!NonExpansive P}. - - Implicit Types α β : IT. - Implicit Types αv βv : ITV. - Implicit Types Φ Ψ : ITV -n> iProp. - - Program Definition expr_pred (α : IT) (Φ : ITV -n> iProp) : iProp := - (∀ x : A, P x -∗ WP@{rs} α @ s {{ v, ∃ y : A, Φ v ∗ P y }}). - #[export] Instance expr_pred_ne : NonExpansive2 expr_pred. - Proof. solve_proper. Qed. - #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . - Proof. solve_proper. Qed. - - Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : tyctx ty S) (ss : ssubst S) : iProp := - ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), - interp_ty (τx.1) (τx.2))%I. - - Lemma ssubst_valid_nil {ty} (interp_ty : ty → ITV -n> iProp) : - ⊢ ssubst_valid interp_ty empC emp_ssubst. - Proof. - unfold ssubst_valid. - by simp list_of_tyctx list_of_ssubst. - Qed. - - Lemma ssubst_valid_cons {ty} (interp_ty : ty → ITV -n> iProp) {S} - (Γ : tyctx ty S) (ss : ssubst S) τ αv : - ssubst_valid interp_ty (consC τ Γ) (cons_ssubst αv ss) - ⊣⊢ interp_ty τ αv ∗ ssubst_valid interp_ty Γ ss. - Proof. - unfold ssubst_valid. - by simp list_of_tyctx list_of_ssubst. - Qed. - - Lemma ssubst_valid_app {ty} (interp_ty : ty → ITV -n> iProp) - {S1 S2} (Ω1 : tyctx ty S1) (Ω2 : tyctx ty S2) αs : - ssubst_valid interp_ty (tyctx_app Ω1 Ω2) αs ⊢ - ssubst_valid interp_ty Ω1 (ssubst_split αs).1 - ∗ ssubst_valid interp_ty Ω2 (ssubst_split αs).2. - Proof. - iInduction Ω1 as [|τ Ω1] "IH" forall (Ω2); simp tyctx_app ssubst_split. - - simpl. iIntros "$". iApply ssubst_valid_nil. - - iIntros "H". - rewrite {4 5}/ssubst_valid. - simpl in αs. - dependent elimination αs as [cons_ssubst αv αs]. - simp ssubst_split. simpl. - simp list_of_ssubst list_of_tyctx. - simpl. iDestruct "H" as "[$ H]". - by iApply "IH". - Qed. - - Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : - Φ αv ⊢ expr_pred α Φ. - Proof. - iIntros "H". - iIntros (x) "Hx". iApply wp_val. - eauto with iFrame. - Qed. - - Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : - expr_pred α Ψ ⊢ - (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ - expr_pred (f α) Φ. - Proof. - iIntros "H1 H2". - iIntros (x) "Hx". - iApply wp_bind. - { solve_proper. } - iSpecialize ("H1" with "Hx"). - iApply (wp_wand with "H1"). - iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". - iModIntro. - iApply ("H2" with "Hb Hy"). - Qed. - - Lemma expr_pred_frame α Φ : - WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. - Proof. - iIntros "H". - iIntros (x) "Hx". - iApply (wp_wand with "H"). - eauto with iFrame. - Qed. -End kripke_logrel. -Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. diff --git a/theories/lang_generic_sem.v b/theories/lang_generic_sem.v new file mode 100644 index 0000000..fb0000c --- /dev/null +++ b/theories/lang_generic_sem.v @@ -0,0 +1,183 @@ +From gitrees Require Import prelude. +From gitrees Require Import gitree. +Require Import List. +Import ListNotations. + +Section interp. + Local Open Scope type. + Context {E: opsInterp}. + Context {R} `{!Cofe R}. + Notation IT := (IT E R). + Notation ITV := (ITV E R). + + Fixpoint interp_scope (S : scope) : ofe := + match S with + | [] => unitO + | τ::Sc => prodO IT (interp_scope Sc) + end. + + Instance interp_scope_cofe S : Cofe (interp_scope S). + Proof. induction S; simpl; apply _. Qed. + + Instance interp_scope_inhab S : Inhabited (interp_scope S). + Proof. induction S; simpl; apply _. Defined. + + Equations interp_var {S : scope} (v : var S) : interp_scope S -n> IT := + interp_var (S:=(_::_)) Vz := fstO; + interp_var (S:=(_::Sc)) (Vs v) := interp_var v ◎ sndO. + + Instance interp_var_ne S (v : var S) : NonExpansive (@interp_var S v). + Proof. + intros n D1 D2 HD12. induction v; simp interp_var. + - by f_equiv. + - eapply IHv. by f_equiv. + Qed. + + Global Instance interp_var_proper S (v : var S) : Proper ((≡) ==> (≡)) (interp_var v). + Proof. apply ne_proper. apply _. Qed. + + Definition interp_scope_split {S1 S2} : + interp_scope (S1 ++ S2) -n> interp_scope S1 * interp_scope S2. + Proof. + induction S1 as [|? S1]; simpl. + - simple refine (λne x, (tt, x)). + solve_proper. + - simple refine (λne xy, let ss := IHS1 xy.2 in ((xy.1, ss.1), ss.2)). + solve_proper. + Defined. + + (** scope substituions *) + Inductive ssubst : scope → Type := + | emp_ssubst : ssubst [] + | cons_ssubst {S} : ITV → ssubst S → ssubst (tt::S) + . + + Equations interp_ssubst {S} (ss : ssubst S) : interp_scope S := + interp_ssubst emp_ssubst := tt; + interp_ssubst (cons_ssubst αv ss) := (IT_of_V αv, interp_ssubst ss). + + Equations list_of_ssubst {S} (ss : ssubst S) : list ITV := + list_of_ssubst emp_ssubst := []; + list_of_ssubst (cons_ssubst αv ss) := αv::(list_of_ssubst ss). + + Equations ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : ssubst S1 * ssubst S2 := + ssubst_split (S1:=[]) αs := (emp_ssubst,αs); + ssubst_split (S1:=u::_) (cons_ssubst αv αs) := + (cons_ssubst αv (ssubst_split αs).1, (ssubst_split αs).2). + Lemma interp_scope_ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : + interp_scope_split (interp_ssubst αs) ≡ + (interp_ssubst (ssubst_split αs).1, interp_ssubst (ssubst_split αs).2). + Proof. + induction S1 as [|u S1]; simpl. + - simp ssubst_split. simpl. + simp interp_ssubst. done. + - dependent elimination αs as [cons_ssubst αv αs]. + simp ssubst_split. simpl. + simp interp_ssubst. repeat f_equiv; eauto; simpl. + + rewrite IHS1//. + + rewrite IHS1//. + Qed. + +End interp. + +(* Common definitions and lemmas for Kripke logical relations *) +Section kripke_logrel. + Variable s : stuckness. + + Context {sz : nat}. + Variable rs : gReifiers sz. + Context {R} `{!Cofe R}. + + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Context {A:ofe}. (* The type & predicate for the explicit Kripke worlds *) + Variable (P : A → iProp). + Context `{!NonExpansive P}. + + Implicit Types α β : IT. + Implicit Types αv βv : ITV. + Implicit Types Φ Ψ : ITV -n> iProp. + + Program Definition expr_pred (α : IT) (Φ : ITV -n> iProp) : iProp := + (∀ x : A, P x -∗ WP@{rs} α @ s {{ v, ∃ y : A, Φ v ∗ P y }}). + #[export] Instance expr_pred_ne : NonExpansive2 expr_pred. + Proof. solve_proper. Qed. + #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . + Proof. solve_proper. Qed. + + Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : tyctx ty S) (ss : ssubst S) : iProp := + ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), + interp_ty (τx.1) (τx.2))%I. + + Lemma ssubst_valid_nil {ty} (interp_ty : ty → ITV -n> iProp) : + ⊢ ssubst_valid interp_ty empC emp_ssubst. + Proof. + unfold ssubst_valid. + by simp list_of_tyctx list_of_ssubst. + Qed. + + Lemma ssubst_valid_cons {ty} (interp_ty : ty → ITV -n> iProp) {S} + (Γ : tyctx ty S) (ss : ssubst S) τ αv : + ssubst_valid interp_ty (consC τ Γ) (cons_ssubst αv ss) + ⊣⊢ interp_ty τ αv ∗ ssubst_valid interp_ty Γ ss. + Proof. + unfold ssubst_valid. + by simp list_of_tyctx list_of_ssubst. + Qed. + + Lemma ssubst_valid_app {ty} (interp_ty : ty → ITV -n> iProp) + {S1 S2} (Ω1 : tyctx ty S1) (Ω2 : tyctx ty S2) αs : + ssubst_valid interp_ty (tyctx_app Ω1 Ω2) αs ⊢ + ssubst_valid interp_ty Ω1 (ssubst_split αs).1 + ∗ ssubst_valid interp_ty Ω2 (ssubst_split αs).2. + Proof. + iInduction Ω1 as [|τ Ω1] "IH" forall (Ω2); simp tyctx_app ssubst_split. + - simpl. iIntros "$". iApply ssubst_valid_nil. + - iIntros "H". + rewrite {4 5}/ssubst_valid. + simpl in αs. + dependent elimination αs as [cons_ssubst αv αs]. + simp ssubst_split. simpl. + simp list_of_ssubst list_of_tyctx. + simpl. iDestruct "H" as "[$ H]". + by iApply "IH". + Qed. + + Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : + Φ αv ⊢ expr_pred α Φ. + Proof. + iIntros "H". + iIntros (x) "Hx". iApply wp_val. + eauto with iFrame. + Qed. + + Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : + expr_pred α Ψ ⊢ + (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ + expr_pred (f α) Φ. + Proof. + iIntros "H1 H2". + iIntros (x) "Hx". + iApply wp_bind. + { solve_proper. } + iSpecialize ("H1" with "Hx"). + iApply (wp_wand with "H1"). + iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". + iModIntro. + iApply ("H2" with "Hb Hy"). + Qed. + + Lemma expr_pred_frame α Φ : + WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. + Proof. + iIntros "H". + iIntros (x) "Hx". + iApply (wp_wand with "H"). + eauto with iFrame. + Qed. +End kripke_logrel. +Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. diff --git a/vendor/Binding/Auto.v b/vendor/Binding/Auto.v new file mode 100644 index 0000000..13347e3 --- /dev/null +++ b/vendor/Binding/Auto.v @@ -0,0 +1,251 @@ +Require Import Utf8. +Require Import Binding.Core. +Require Import Binding.Properties. +Require Import Binding.TermSimpl. + +Local Open Scope bind_scope. + +Ltac auto_map_id := + match goal with + | |- ?f ≡ ı → fmap ?f ?t = ?t => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_id with typeclass_instances) + || (f_equal; now apply EQ)) + end. + +Ltac auto_map_comp := + match goal with + | |- ?f ∘ ?g ≡ ?h → fmap ?f (fmap ?g ?t) = fmap ?h ?t => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_comp with typeclass_instances) + || (f_equal; now apply EQ)) + end. + +Ltac auto_map_bind_pure := + match goal with + | |- ?f ̂ ≡ ?g → fmap ?f ?t = bind ?g ?t => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_of with typeclass_instances) + || now apply EQ) + end. + +Ltac auto_map_bind_comm := + match goal with + | |- ?g₂ ∘ ?f₂ ̂ ≡ ?f₁ ̂ ∘ ?g₁ → bind ?g₂ (fmap ?f₂ ?t) = fmap ?f₁ (bind ?g₁ ?t) => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_comm with typeclass_instances) + || rewrite map_to_bind; now apply EQ) + end. + +Ltac auto_bind_id := + match goal with + | |- ?f ≡ ı → bind ?f ?t = ?t => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_id with typeclass_instances) + || now apply EQ) + end. + +Ltac auto_bind_comp := + match goal with + | |- ?f ∘ ?g ≡ ?h → bind ?f (bind ?g ?t) = bind ?h ?t => + let EQ := fresh "EQ" + in intros EQ; destruct t; term_simpl; + try ((progress f_equal; now eauto using @lift_comp with typeclass_instances) + || now apply EQ) + end. + +(* + +Lemma ap_equal {A B : Type} (f g : A → B) (x y : A) : + f = g → x = y → f x = g y. +Proof. +destruct 1; destruct 1; reflexivity. +Qed. + +Local Ltac solve_equal := + reflexivity || (apply ap_equal; [ solve_equal | try reflexivity ]). + +Local Open Scope bind_scope. + +Local Ltac auto_map_id_arrow_eq Heq := + exact Heq || (apply Heq; fail) || + match goal with + | |- (?f ↑) ≡ ı => + apply lift_id; auto_map_id_arrow_eq Heq + | _ => idtac + end. + +Ltac auto_map_id := + let Heq := fresh "Heq" in + intro Heq; + match goal with + | |- ?map _ _ ?f ?t = ?t => + destruct t; term_simpl; solve_equal; try (apply Heq; fail); + match goal with + | [ IH: ∀ (A : ?Obj) f (t : ?F A), + f ≡ ı → ?map A A f t = t + |- ?map _ _ _ ?t = ?t + ] => apply IH; auto_map_id_arrow_eq Heq + | |- ?fmap _ _ _ ?map _ _ _ _ ?t = ?t => + apply map_id; auto_map_id_arrow_eq Heq + | |- ?map _ _ _ ?t = ?t => + apply map_id; auto_map_id_arrow_eq Heq + | _ => idtac + end + end. + +Local Ltac auto_map_map_comp_arrow_eq Heq := + exact Heq || (apply Heq; fail) || + match goal with + | |- ?f ↑ ∘ ?g ↑ ≡ ?h ↑ => + apply lift_comp; auto_map_map_comp_arrow_eq Heq + | _ => idtac + end. + +Ltac auto_map_map_comp := + let Heq := fresh "Heq" in + intro Heq; + match goal with + | |- ?map _ _ ?f (?map _ _ ?g ?t) = ?map _ _ ?h ?t => + destruct t; term_simpl; solve_equal; try (apply Heq; fail); + match goal with + | [ IH: ∀ (A B C : ?Obj) f g h (t : ?F A), + f ∘ g ≡ h → + ?map B C f (?map A B g t) = ?map A C h t + |- ?map _ _ _ (?map _ _ _ ?t) = ?map _ _ _ ?t + ] => apply IH; auto_map_map_comp_arrow_eq Heq + | |- fmap _ (fmap _ ?t) = fmap _ ?t => + apply map_map_comp; auto_map_map_comp_arrow_eq Heq + | |- ?map _ _ _ (?map _ _ _ ?t) = ?map _ _ _ ?t => + apply map_map_comp; auto_map_map_comp_arrow_eq Heq + | _ => idtac + end + end. + +Create HintDb auto_bind_map_comp. +(* +Local Ltac auto_bind_map_comp_subst_eq Heq := + exact Heq || (apply Heq; fail) || + match goal with + | |- subst_eq + (subst_comp (liftS ?f) (subst_of_arr (liftA ?g))) + (arrow_subst_comp (liftA ?g') (liftS ?f')) => + apply liftS_liftA_comp; auto_bind_map_comp_subst_eq Heq + | _ => idtac + end. + +Ltac auto_bind_map_comp := + let Heq := fresh "Heq" in + intro Heq; + match goal with + | |- ?bnd _ _ ?f (?map _ _ ?g ?t) = ?map _ _ ?g' (?bnd _ _ ?f' ?t) => + destruct t; + simpl; try (autorewrite with auto_bind_map_comp; simpl); + try (apply Heq; fail); + try (solve_equal; try (apply Heq; fail); + match goal with + | [ IH: ∀ (A B B' C : ?Obj) f g g' f' (t : ?F A), + subst_eq (subst_comp f (of_arrow g)) (arrow_subst_comp g' f') → + ?bnd _ _ f (?map _ _ g t) = ?map _ _ g' (?bnd _ _ f' t) + |- ?bnd _ _ _ (?map _ _ _ ?t) = ?map _ _ _ (?bnd _ _ _ ?t) + ] => apply IH; auto_bind_map_comp_subst_eq Heq + | |- bind _ (fmap _ ?t) = fmap _ (bind _ ?t) => + apply bind_map_comp; auto_bind_map_comp_subst_eq Heq + | |- ?bind _ _ _ (?fmap _ _ _ ?t) = ?fmap _ _ _ (?bind _ _ _ ?t) => + apply bind_map_comp; auto_bind_map_comp_subst_eq Heq + | _ => idtac + end) + end. +*) +Local Ltac auto_bind_pure_subst_eq Heq := + exact Heq || + match goal with + | |- _ ↑ ≡ ı => + apply lift_id; auto_bind_pure_subst_eq Heq + | _ => idtac + end. + +Local Ltac auto_bind_pure_loop Heq := + match goal with + | [ IH: ∀ (A : ?Obj) f (t : ?F A), + f ≡ ı → ?bnd A A f t = t + |- context[ ?bnd _ _ _ ?t ] + ] => + rewrite IH; [ auto_bind_pure_loop Heq | auto_bind_pure_subst_eq Heq ] + | |- context[ bind _ ?t ] => + rewrite bind_pure; + [ auto_bind_pure_loop Heq | auto_bind_pure_subst_eq Heq ] + | _ => idtac + end. + +Ltac auto_bind_pure := + let Heq := fresh "Heq" in + intro Heq; + match goal with + | |- ?bnd _ _ ?f ?t = ?t => + destruct t; term_simpl; + try (apply Heq; fail); + ((solve_equal; + match goal with + | [ IH: ∀ (A : ?Obj) f (t : ?F A), + f ≡ ı → ?bnd A A f t = t + |- ?bnd _ _ _ ?t = ?t + ] => apply IH; auto_bind_pure_subst_eq Heq + | |- bind _ ?t = ?t => + apply bind_pure; auto_bind_pure_subst_eq Heq + | |- ?bind _ _ _ ?t = ?t => + apply bind_pure; auto_bind_pure_subst_eq Heq + | _ => idtac + end) + || auto_bind_pure_loop Heq) + end. + +Create HintDb auto_bind_bind_comp. + +Local Ltac auto_bind_bind_comp_subst_eq Heq := + exact Heq || (apply Heq; fail) || + match goal with + | |- _ ↑ ∘ _ ↑ ≡ _ ↑ => + apply lift_comp; auto_bind_bind_comp_subst_eq Heq + | _ => idtac + end. + +Ltac auto_bind_bind_comp := + let Heq := fresh "Heq" in + intro Heq; + match goal with + | |- ?bnd _ _ ?f (?bnd _ _ ?g ?t) = ?bnd _ _ ?h ?t => + destruct t; + term_simpl; try (autorewrite with auto_bind_bind_comp; simpl); + try (apply Heq; fail); + try (solve_equal; try (apply Heq; fail); + match goal with + | [ IH: ∀ (A B C : ?Obj) f g h (t : ?F A), + f ∘ g ≡ h → + ?bnd B C f (?bnd A B g t) = ?bnd A C h t + |- ?bnd _ _ _ (?bnd _ _ _ ?t) = ?bnd _ _ _ ?t + ] => apply IH; auto_bind_bind_comp_subst_eq Heq + | |- bind _ (bind _ ?t) = bind _ ?t => + apply bind_bind_comp; auto_bind_bind_comp_subst_eq Heq + | |- ?bind _ _ _ (?bind _ _ _ ?t) = ?bind _ _ _ ?t => + apply bind_bind_comp; auto_bind_bind_comp_subst_eq Heq + | _ => idtac + end) + end. + +(* +Ltac auto_ASLiftable := + unfold ASLiftable; intros; simpl; + unfold bind, fmap; simpl; fold_fmap; + rewrite fmap_liftA_shift_comm; + apply f_equal; + try match goal with + | H: subst_eq ?f ?g |- _ => apply H + end. +*) +*) diff --git a/vendor/Binding/Core.v b/vendor/Binding/Core.v new file mode 100644 index 0000000..a2c966d --- /dev/null +++ b/vendor/Binding/Core.v @@ -0,0 +1,295 @@ +Require Import Utf8. +Require Import RelationClasses Morphisms. +Require Vector. + +Declare Scope bind_scope. +Delimit Scope bind_scope with bind. +Local Open Scope bind_scope. + +Section EqualityIndexedTypes. + Context {Obj : Type}. + + Class EqIndCore (T : Obj → Obj → Type) := + equal A B : T A B → T A B → Prop. + + Class EqInd (T : Obj → Obj → Type) {EIC : EqIndCore T} := + { eq_equiv A B :> Equivalence (equal A B) }. + +End EqualityIndexedTypes. + +Notation " f ≡ g " := (equal _ _ f%bind g%bind) (at level 70, no associativity) : bind_scope. + +(** * Arrows and maps *) +Section Arrows. + Context {Obj : Type}. + + (** ** Arrows *) + Class ArrowCore (Arr : Obj → Obj → Type) : Type := + { arrow_id A : Arr A A; + arrow_comp {A B C} : Arr B C → Arr A B → Arr A C + }. + + Definition arrow {Arr} {ArrEq : EqIndCore Arr} {AC : ArrowCore Arr} := Arr. + + Notation " 'ı' " := (arrow_id _) : bind_scope. + Notation " f ∘ g " := (arrow_comp f%bind g%bind) (at level 40, left associativity) : bind_scope. + + Class Arrow (Arr : Obj → Obj → Type) {ArrEq : EqIndCore Arr} {AC : ArrowCore Arr} : Prop := + { arrow_comp_id_l {A B} (f : Arr A B) : ı ∘ f ≡ f; + arrow_comp_id_r {A B} (f : Arr A B) : f ∘ ı ≡ f; + arrow_comp_assoc {A B C D} (f : Arr C D) (g : Arr B C) (h : Arr A B) : + f ∘ g ∘ h ≡ f ∘ (g ∘ h); + arrow_comp_proper + A B C :> Proper (equal B C ==> equal A B ==> equal A C) arrow_comp}. + + Context {Arr : Obj → Obj → Type} {ArrEq : EqIndCore Arr} {AC : ArrowCore Arr}. + + (** ** Maps *) + + Class FunctorCore (F : Obj → Type) := + fmap : ∀ {A B}, (Arr A B) → F A → F B. + + (*Definition fmap {F : Obj → Type} + {FunCore : FunctorCore F} {A B : Obj} + (f : Arr A B) : F A → F B := fmap_core _ _ f.*) + + Class Functor (F : Obj → Type) {FunCore : FunctorCore F} : Prop := + { map_id {A} (f : Arr A A) (t : F A) (EQ : f ≡ ı) : + fmap f t = t; + map_map_comp {A B C} (f : Arr B C) (g : Arr A B) h (t : F A) + (EQ : f ∘ g ≡ h) : + fmap f (fmap g t) = fmap h t}. + +End Arrows. + +(* Repeat notations due to section locality nonsense *) +Module ArrowNotations. + Notation " A '[→]' B " := (arrow A B) (at level 100, no associativity) : type_scope. +End ArrowNotations. + +Notation " 'ı' " := (arrow_id _) : bind_scope. +Notation " f ∘ g " := (arrow_comp f%bind g%bind) (at level 40, left associativity) : bind_scope. + +(** * Substitutions and binds *) +Section Substitutions. + Context {Obj : Type}. + + (** ** Substitutions *) + Class SubstCore (Arr : Obj → Obj → Type) (Sub : Obj → Obj → Type) : Type := + subst_of_arr : ∀ {A B}, Arr A B → Sub A B. + + Definition sub {Arr Sub} {ASC : SubstCore Arr Sub} := Sub. + Definition subarr {Arr Sub} {ASC : SubstCore Arr Sub} := Arr. + + (*Notation " 'η' " := (subst_pure _) : bind_scope. + Notation " σ • ρ " := (subst_comp σ%bind ρ%bind) (at level 40, left associativity) : bind_scope.*) + Notation " f '̂' " := (subst_of_arr f%bind) (at level 30) : bind_scope. + + Class Subst + (Arr : Obj → Obj → Type) {ArrEq : EqIndCore Arr} {AC : ArrowCore Arr} + (Sub : Obj → Obj → Type) {SubEq : EqIndCore Sub} {SC : ArrowCore Sub} + {ASC : SubstCore Arr Sub} : Prop := + { arrow_subst_id {A} : ı ̂ ≡ (ı : Sub A A); + arrow_subst_comp {A B C} (f : Arr B C) (g : Arr A B) : + (f ∘ g)̂ ≡ f ̂ ∘ g ̂; + arrow_subst_proper A B :> Proper (equal A B ==> equal A B) subst_of_arr}. + + (** ** Binding *) + + Context {Arr : Obj → Obj → Type} {EqArr : EqIndCore Arr} {AC : ArrowCore Arr}. + Context {Sub : Obj → Obj → Type} {EqSub : EqIndCore Sub} {SC : ArrowCore Sub}. + Context {ASC : SubstCore Arr Sub}. + + Class BindCore (F : Obj → Type) := + bind : ∀ {A B}, (Sub A B) → F A → F B. + + (*Definition bind {F : Obj → Type} + {BindF : BindCore F} {A B : Obj} + (f : Sub A B) : F A → F B := bind_core _ _ f.*) + + Class BindMapPure (F : Obj → Type) {MapF : FunctorCore F} {BindF : BindCore F} : Prop := + { bind_map {A B} (f : Arr A B) g t + (EQ : f ̂ ≡ g) : + fmap f t = bind g t + }. + + Class BindMapComm (F : Obj → Type) {MapF : FunctorCore F} {BindF : BindCore F} : Prop := + { bind_map_comm {A B₁ B₂ C} (f₁ : Arr B₁ C) (f₂ : Arr A B₂) (g₁ : Sub A B₁) g₂ t + (EQ : g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁) : + bind g₂ (fmap f₂ t) = fmap f₁ (bind g₁ t) + }. + + Class Bind (F : Obj → Type) {BindF : BindCore F} : Prop := + { bind_pure {A} (f : Sub A A) (t : F A) (EQ : f ≡ ı) : + bind f t = t; + bind_bind_comp {A B C} (f : Sub B C) (g : Sub A B) h (t : F A) + (EQ : f ∘ g ≡ h) : + bind f (bind g t) = bind h t + }. + +End Substitutions. + +Arguments arrow {Obj Arr ArrEq AC} /. +Arguments sub {Obj Arr Sub ASC } /. +Arguments subarr {Obj Arr Sub ASC } /. + +Module SubNotations. + Notation " A '[⇒]' B " := (sub A B) (at level 100, no associativity) : type_scope. + Notation " A '[→]' B " := (subarr A B) (at level 100, no associativity) : type_scope. +End SubNotations. +Notation " f '̂' " := (subst_of_arr f%bind) (at level 30) : bind_scope. + +(** * Lifting *) +Section Lifting. + Context {Obj : Type}. + + Class LiftableCore (Arr : Obj → Obj → Type) (G : Obj → Obj) := + lift : ∀ {A B}, Arr A B → Arr (G A) (G B). + + Notation " f ↑ " := (lift f%bind) (at level 30) : bind_scope. + + Fixpoint liftn {Arr G} {LC : LiftableCore Arr G} {A B : Obj} + n (f : Arr A B) : Arr (Nat.iter n G A) (Nat.iter n G B) := + match n with + | O => f + | S n => (liftn n f) ↑ + end. + + Class Liftable {Arr} {EqArr : EqIndCore Arr} {AC : ArrowCore Arr} + (G : Obj → Obj) {LC : LiftableCore Arr G} : Prop := + { lift_id {A} (f : Arr A A) (EQ : f ≡ ı) : f ↑ ≡ ı; + lift_comp {A B C} (f : Arr B C) (g : Arr A B) h (EQ : f ∘ g ≡ h) : + f ↑ ∘ g ↑ ≡ h ↑ ; + lift_proper A B :> Proper (equal A B ==> equal (G A) (G B)) lift + }. + + Context {Arr : Obj → Obj → Type} {EqArr : EqIndCore Arr} {AC : ArrowCore Arr}. + Context {Sub : Obj → Obj → Type} {EqSub : EqIndCore Sub} {SC : ArrowCore Sub}. + Context {ASC : SubstCore Arr Sub}. + + Class ASLiftInj (G : Obj → Obj) {ALC : LiftableCore Arr G} {SLC : LiftableCore Sub G} : Prop := + lift_of : ∀ {A B} (f : Arr A B) g (EQ : f ̂ ≡ g), f ↑ ̂ ≡ g ↑. + + Class ASLiftComm (G : Obj → Obj) + {ALC : LiftableCore Arr G} {SLC : LiftableCore Sub G} : Prop := + lift_comm : ∀ {A B₁ B₂ C} (f₁ : Arr B₁ C) (f₂ : Arr A B₂) (g₁ : Sub A B₁) (g₂ : Sub B₂ C) + (EQ : g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁), + g₂ ↑ ∘ f₂ ↑ ̂ ≡ f₁ ↑ ̂ ∘ g₁ ↑ . + +End Lifting. + +Arguments Liftable {Obj} Arr {EqArr AC} G {LC}. +Arguments ASLiftInj {Obj} Arr Sub {EqSub ASC} G {ALC SLC}. +Arguments ASLiftComm {Obj} Arr Sub {EqSub SC ASC} G {ALC SLC}. + +Notation " f ↑ " := (lift f%bind) (at level 30) : bind_scope. + +(** * Shifting *) +Section Shifting. + Context {Obj : Type}. + + Class ShiftableCore (Arr : Obj → Obj → Type) (Inc : Obj → Obj) : Type := + mk_shift : ∀ A : Obj, Arr A (Inc A). + + Global Arguments mk_shift {Arr Inc _ A}. + + Definition shift + {Arr : Obj → Obj → Type} + {F : Obj → Type} {MapF : FunctorCore F} + {Inc : Obj → Obj} {Sh : ShiftableCore Arr Inc} + {A : Obj} + (a : F A) : F (Inc A) := fmap mk_shift a. + + (*Fixpoint mk_shiftn + {Arr : Obj → Obj → Type} + {F : Obj → Type} {map} {MapF : FunctorCore (F:=F) (Arr:=Arr) map} + {Inc : Obj → Obj} {AC : ArrowCore Arr} {ALC : ALiftableCore Arr Inc} {Sh : ShiftableCore Arr Inc} + {A : Obj} n : Arr A (Nat.iter n Inc A) := + match n with + | O => ı + | S n' => (liftA (G := Inc) (mk_shiftn (Inc := Inc) n')) ∘ mk_shift + end. + + Definition shiftn {Arr : Obj → Obj → Type} + {F : Obj → Type} {map} {MapF : FunctorCore (F:=F) (Arr:=Arr) map} + {Inc : Obj → Obj} {AC : ArrowCore Arr} {ALC : ALiftableCore Arr Inc} {Sh : ShiftableCore Arr Inc} + n {A : Obj} (a : F A) := fmap (mk_shiftn n) a.*) + + Context (Arr : Obj → Obj → Type) {EqArr : EqIndCore Arr} {AC : ArrowCore Arr}. + Context (Sub : Obj → Obj → Type) {EqSub : EqIndCore Sub} {SC : ArrowCore Sub}. + Context {ASC : SubstCore Arr Sub}. + Context (Inc : Obj → Obj) {Sh : ShiftableCore Arr Inc}. + + Class LiftAShift {ALC : LiftableCore Arr Inc} : Prop := + liftA_mk_shift_comm : ∀ {A B : Obj} (f : Arr A B), + f ↑ ∘ mk_shift ≡ mk_shift ∘ f. + + Class LiftSShift {SLC : LiftableCore Sub Inc} : Prop := + liftS_mk_shift_comm : ∀ {A B : Obj} (f : Sub A B), + f ↑ ∘ mk_shift ̂ ≡ mk_shift ̂ ∘ f. + +End Shifting. + +Arguments liftA_mk_shift_comm {Obj Arr EqArr AC Inc Sh ALC _ A B} f. +Arguments liftS_mk_shift_comm {Obj Arr Sub EqSub SC ASC Inc Sh SLC _ A B} f. + +(** * Substituting *) +Section Substituting. + Context {Obj : Type}. + + Class SubstitutableCore + (Sub : Obj → Obj → Type) (F : Obj → Type) (Inc : Obj → Obj) : Type := + mk_subst : ∀ {A : Obj} (x : F A), Sub (Inc A) A. + + Definition subst + {Sub : Obj → Obj → Type} + {G : Obj → Type} {BindG : BindCore G} + {F : Obj → Type} {Inc : Obj → Obj} {Sb : SubstitutableCore Sub F Inc} + {A : Obj} + (a : G (Inc A)) (v : F A) : G A := bind (mk_subst v) a. + + (* + Fixpoint mk_substV + {Sub : Obj → Obj → Type} {Arr : Obj → Obj → Type} + {G : Obj → Type} {bnd} {BindG : BindCore (F:=G) (Sub:=Sub) bnd} + {F : Obj → Type} {Inc : Obj → Obj} {PSC : PreSubstCore Sub} {AC : ArrowCore Arr} + {SC : SubstCore Arr Sub} {SLC : SLiftableCore Sub Inc} {Sb : SubstitutableCore Sub F Inc} + {A : Obj} {n} (xs : Vector.t (F A) n) : Sub (Nat.iter n Inc A) A := + match xs with + | Vector.nil _ => η + | Vector.cons _ x _ xs => (mk_subst (Inc := Inc) x) • (mk_substV (Inc := Inc) xs) ⇑ + end. + + Definition substV + {Sub : Obj → Obj → Type} {Arr : Obj → Obj → Type} {AC : ArrowCore Arr} + {G : Obj → Type} {bnd} {BindG : BindCore (F:=G) (Sub:=Sub) bnd} + {F : Obj → Type} {Inc : Obj → Obj} {PSC : PreSubstCore Sub} {SC : SubstCore Arr Sub} + {SLC : SLiftableCore Sub Inc} {Sb : SubstitutableCore Sub F Inc} + {A : Obj} {n} (xs : Vector.t (F A) n) (a : G (Nat.iter n Inc A)) : G A := + bind (mk_substV xs) a. + *) + + Context (Arr : Obj → Obj → Type) {EqArr : EqIndCore Arr} {AC : ArrowCore Arr}. + Context (Sub : Obj → Obj → Type) {EqSub : EqIndCore Sub} {SC : ArrowCore Sub}. + Context {ASC : SubstCore Arr Sub}. + Context (F : Obj → Type) (Inc : Obj → Obj) {Sb : SubstitutableCore Sub F Inc}. + + Class SubstShift {Sh : ShiftableCore Arr Inc} : Prop := + subst_shift_pure : ∀ {A : Obj} (v : F A), + mk_subst v ∘ mk_shift ̂ ≡ ı. + + Class SubstFMap {MapF : FunctorCore F} + {ALC : LiftableCore Arr Inc} : Prop := + map_mk_subst_comm : ∀ {A B : Obj} (f : Arr A B) (v : F A), + f ̂ ∘ mk_subst v ≡ mk_subst (fmap f v) ∘ f ↑ ̂. + + Class SubstBind {BndF : BindCore F} + {SLC : LiftableCore Sub Inc} : Prop := + bind_mk_subst_comm : ∀ {A B : Obj} (f : Sub A B) (v : F A), + f ∘ mk_subst v ≡ mk_subst (bind f v) ∘ f ↑. + +End Substituting. + +Arguments subst_shift_pure {Obj Arr Sub EqSub SC ASC F Inc Sb Sh _ A} v. +Arguments map_mk_subst_comm {Obj Arr Sub EqSub SC ASC F Inc Sb MapF ALC _ A B} f v. +Arguments bind_mk_subst_comm {Obj Sub EqSub SC F Inc Sb BndF SLC _ A B} f v. diff --git a/vendor/Binding/Env.v b/vendor/Binding/Env.v new file mode 100644 index 0000000..bc5f17a --- /dev/null +++ b/vendor/Binding/Env.v @@ -0,0 +1,79 @@ +Require Import Utf8. +Require Import Binding.Lib. +Require Import SetoidClass Morphisms. + +Definition eq_ext {A B} (f g : A → B) := ∀ x, f x = g x. + +Lemma Equivalence_eq_ext {A B} : Equivalence (@eq_ext A B). +Proof. + split. + - intros Γ x; reflexivity. + - intros Γ₁ Γ₂ HEq x; symmetry; apply HEq. + - intros Γ₁ Γ₂ Γ₃ HEq₁ HEq₂ x; etransitivity; [apply HEq₁ | apply HEq₂]. +Qed. + +Global Instance Setoid_equiv {A B} : Setoid (A → B) := Build_Setoid Equivalence_eq_ext. + +Definition empty_env {A} : ∀ (x : ∅), A := λ x, match x with end. + +Definition extend {V : Set} {A} (Γ : V → A) (τ : A) : inc V → A := + λ x, match x with VZ => τ | VS x => Γ x end. + +Definition compose {A B C} (f : B → C) (g : A → B) (x : A) := f (g x). + +Notation "f • g" := (compose f g) (at level 40, left associativity). +Notation "f ▹ v" := (extend f v) (at level 40, v at next level, left associativity). +Notation "□" := empty_env. +Notation "x ≡ y" := (equiv x y) (at level 70, no associativity). + +Arguments compose {A B C} f g x /. + +Ltac destr_refl x := + match type of x with + | inc _ => destruct x as [| x]; [term_simpl; reflexivity | destr_refl x] + | _ => term_simpl + end. + +Ltac solve_simple_eq := + match goal with + | [ H: ?X ≡ ?Y |- ?X ?x = ?Y ?x ] => apply H + | [ |- ?f ?v1 = ?f ?v2 ] => f_equal; solve_simple_eq + | _ => now eauto + end. + +Ltac solve_equiv := + match goal with + | [|- ?X ≡ ?Y] => + let x := fresh "x" + in intros x; destr_refl x; solve_simple_eq + | _ => eassumption || reflexivity + end. + +Global Instance equiv_extend {A B : Set} : Proper (equiv ==> eq ==> equiv) (@extend A B). +Proof. + intros f g EQ v₁ v₂ EQv; subst; solve_equiv. +Qed. + +Global Instance equiv_compose {A B C : Set} : Proper (equiv ==> equiv ==> equiv) (@compose A B C). +Proof. + intros f₁ f₂ EQf g₁ g₂ EQg x; simpl; now rewrite EQf, EQg. +Qed. + +Require Import Binding.Set. +Import ArrowNotations. + +Lemma env_extend_equiv (V : Type) (A B : Set) (Δ₁ : A → V) Δ₂ (δ : B [→] A) (κ : V) + (HEq : Δ₂ ≡ Δ₁ • δ) : + Δ₂ ▹ κ ≡ (Δ₁ ▹ κ) • ( δ ↑ : inc B [→] inc A)%bind. +Proof. + solve_equiv. +Qed. + +Global Hint Extern 4 (_ ≡ _) => solve_equiv. + +Ltac simpl_HFInd := + subst; try discriminate; + repeat match goal with + | [ G : ?x = ?x → _ |- _ ] => specialize (G eq_refl) + | [ G : inc ?x = ?x → _ |- _ ] => clear G + end. diff --git a/vendor/Binding/Inc.v b/vendor/Binding/Inc.v new file mode 100644 index 0000000..515ae5e --- /dev/null +++ b/vendor/Binding/Inc.v @@ -0,0 +1,25 @@ +Require Import Utf8. + +Notation "∅" := Empty_set. + +Inductive inc (V : Set) : Set := +| VZ : inc V +| VS : V → inc V +. + +Arguments VZ {V}. +Arguments VS {V}. + +Definition inc_map {A B : Set} (f : A → B) (m : inc A) : inc B := + match m with + | VZ => VZ + | VS x => VS (f x) + end. + +Fixpoint nth_inc n {A : Set} : Nat.iter n inc (inc A) := + match n with + | O => VZ + | S n => VS (nth_inc n) + end. + +Notation "& n" := (nth_inc n) (at level 5). diff --git a/vendor/Binding/Intrinsic.v b/vendor/Binding/Intrinsic.v new file mode 100644 index 0000000..643eecd --- /dev/null +++ b/vendor/Binding/Intrinsic.v @@ -0,0 +1,232 @@ +Require Import Utf8. +Require Import Binding.Core. +Require Import Binding.Inc. +Require Import Binding.Properties. +Require Import Morphisms. + +Record Ctx {V : Type} := + {dom : Set; + arr :> dom -> V + }. +Arguments Ctx V : clear implicits. + +Definition mtC {V : Type} : Ctx V := + {| dom := Empty_set; + arr x := match x with end + |}. + +Definition extC {V : Type} (v : V) (Γ : Ctx V) : Ctx V := + {| dom := inc (dom Γ); + arr x := match x with + | VZ => v + | VS x => Γ x + end + |}. + +Notation "'ε'" := mtC. +Notation "Γ ▹ v" := (extC v Γ) (at level 40, left associativity). + +Class IntPureCore {V : Type} (F : V → Ctx V → Type) : Type := + int_pure : ∀ (Γ : Ctx V) v (x : dom Γ) (EQ : Γ x = v) , F v Γ. + +Arguments int_pure {V F _ Γ}. + +Record Arr {V : Type} {Γ Δ : Ctx V} : Type := + { apply_arr : dom Γ → dom Δ; + arr_hom : ∀ x : dom Γ, Δ (apply_arr x) = Γ x + }. +Arguments Arr {V} Γ Δ. +Notation " A '[→]' B " := (Arr A B) (at level 100, no associativity) : type_scope. +Coercion apply_arr : Arr >-> Funclass. + +Record Sub {V} {F : V → Ctx V → Type} {FP : IntPureCore F} (Γ Δ : Ctx V) : Type := + { apply_sub : ∀ v (x : dom Γ) (EQ : Γ x = v), F v Δ + }. +Notation " A '[⇒]' B " := (Sub A B) (at level 100, no associativity) : type_scope. + +Arguments apply_sub {V F FP Γ Δ}. +Coercion apply_sub : Sub >-> Funclass. + +Global Instance ArrEqC {V} : EqIndCore (Arr (V := V)) := + λ A B f g, ∀ x, f x = g x. + +Global Instance ArrEq {V} : EqInd (Arr (V := V)). +Proof. + split; intros; split; intros; congruence. +Qed. + +Global Instance SubEqC {V F} {FP : IntPureCore (V := V) F} : EqIndCore Sub := + λ A B f g, ∀ v x EQ, f v x EQ = g v x EQ. + +Global Instance SubEq {V F} {FP : IntPureCore (V := V) F} : EqInd Sub. +Proof. + split; split; intros; congruence. +Qed. + +Global Program Instance ArrowCore_Set {V} : ArrowCore (Arr (V := V)) := + { arrow_id := λ _, {| apply_arr := λ x, x |} + ; arrow_comp := λ _ _ _ f g, {| apply_arr := λ x, f (g x) |} + }. +Next Obligation. + etransitivity; apply arr_hom. +Defined. + +Class IntPure {V} (F : V → Ctx V → Type) {FP : IntPureCore (V := V) F} + {MapF : ∀ v, FunctorCore (F v)} + {BndF : ∀ v, BindCore (Sub := Sub) (F v)} : Prop := + { fmap_int_pure : ∀ (Γ Δ : Ctx V) (f : Arr Γ Δ) v (x : dom Γ) (EQ : Γ x = v), + fmap f (int_pure v x EQ) = int_pure v (f x) (eq_trans (arr_hom f x) EQ) + ; bind_set_pure : ∀ (Γ Δ : Ctx V) (f : Sub Γ Δ) v (x : dom Γ) (EQ : Γ x = v), + bind f (int_pure (IntPureCore := FP) v x EQ) = f v x EQ + }. + +Section IntInstances. + Context {V} {F : V → Ctx V → Type} {FP : IntPureCore F}. + Context {MapF : ∀ v, FunctorCore (Arr := Arr) (F v)}. + Context {BndF : ∀ v, BindCore (Sub := Sub) (F v)}. + Context {SPF : IntPure F}. + + Global Instance Arrow_Int : Arrow (Arr (V := V)). + Proof. + split; [unfold equal, ArrEqC; simpl; congruence .. |]. + intros A B C f₁ f₂ EQf g₁ g₂ EQg x; simpl; congruence. + Qed. + + Global Instance SubstArrCore_Set : ArrowCore (Sub (V := V)) := + { arrow_id A := {| apply_sub := int_pure |}; + arrow_comp A B C f g := {| apply_sub := λ v x EQ, bind f (g v x EQ) |} }. + + Global Instance SubstCore_Set : SubstCore Arr Sub := + λ Γ Δ f, {| apply_sub := λ v x EQ, int_pure v (f x) (eq_trans (arr_hom f x) EQ) |}. + + Program Definition extFun v (Γ Δ : Ctx V) (f : Arr Γ Δ) : Arr (Γ ▹ v) (Δ ▹ v) := + {| apply_arr := inc_map f |}. + Next Obligation. + destruct x as [| x]; simpl; [reflexivity | apply arr_hom]. + Defined. + + Context {MF : ∀ v, Functor (F v)} {BF : ∀ v, Bind (F v)}. + Context {BMPF : ∀ v, BindMapPure (F v)} {BMCF : ∀ v, BindMapComm (F v)}. + + Global Instance SubArrow_Set : Arrow Sub. + Proof. + split; simpl; intros. + - intros v x EQ; simpl; apply bind_pure; reflexivity. + - intros v x EQ; simpl; apply bind_set_pure. + - intros v x EQ; simpl; symmetry; apply bind_bind_comp; reflexivity. + - intros ρ₁ ρ₂ EQρ σ₁ σ₂ EQσ v x EQ; simpl; rewrite EQσ; clear EQσ. + etransitivity; [| apply bind_pure; reflexivity]. + symmetry; apply bind_bind_comp. + intros u y EQ'; rewrite EQρ; apply bind_pure; reflexivity. + Qed. + + Global Instance Subst_Set : Subst Arr Sub. + Proof. + split; intros. + - intros v x []; simpl; reflexivity. + - intros v x []; simpl; symmetry; unfold ArrowCore_Set_obligation_2. + generalize (g x) as y, (arr_hom g x). + intros y []; simpl; apply bind_set_pure. + - intros f g EQ v x EQ'; simpl. + rewrite <- !fmap_int_pure, EQ; reflexivity. + Qed. + + Global Instance ALiftableCore_ext {v : V} : LiftableCore Arr (extC v) := + { lift := extFun v }. + + Global Instance ALiftable_ext {v : V} : Liftable Arr (extC v). + Proof. + split; intros. + - intros [| x]; simpl; [reflexivity | f_equal; apply EQ]. + - intros [| x]; simpl; [reflexivity | f_equal; apply EQ]. + - intros f₁ f₂ EQf [| x]; simpl; [reflexivity | f_equal; apply EQf]. + Qed. + + Global Program Instance ShiftableCore_ext {v : V} : ShiftableCore Arr (extC v) := + λ A, {| apply_arr := VS : dom A → dom (A ▹ v) |}. + + Global Instance LiftAShift_ext {v : V} : LiftAShift Arr (extC v). + Proof. + unfold LiftAShift; intros Γ Δ f x; reflexivity. + Qed. + + Global Instance SLiftableCore_ext {v : V} : LiftableCore Sub (extC v) := + { lift Γ Δ ρ := + {| apply_sub := λ u (x : dom (Γ ▹ v)), + match x with + | VZ => λ EQ, int_pure u (VZ : dom (Δ ▹ v)) EQ + | VS y => λ EQ, shift (ρ u y EQ) + end + |} + }. + + Global Instance LiftSShift_ext {v : V} : LiftSShift Arr Sub (extC v). + Proof. + intros A B f u x []; simpl. + rewrite bind_set_pure. + apply map_to_bind. + Qed. + + Global Instance SLiftable_ext {v : V} : Liftable Sub (extC v). + Proof. + split; intros. + - intros u [| x] []; simpl; [reflexivity | unfold shift; simpl]. + rewrite EQ; simpl. + rewrite fmap_int_pure; simpl; reflexivity. + - intros u [| x] []; simpl; [now apply bind_set_pure |]. + rewrite bind_liftS_shift_comm, <- EQ; reflexivity. + - intros f₁ f₂ EQf u [| x] []; simpl; [reflexivity | now rewrite EQf]. + Qed. + + Global Instance ASLiftInj_ext {v : V} : ASLiftInj Arr Sub (extC v). + Proof. + intros A B f g EQ u [| x] []; simpl; [reflexivity |]. + rewrite <- EQ; simpl; symmetry. + generalize (f x) as y, (arr_hom f x); intros y []; simpl. + unfold shift; rewrite fmap_int_pure; reflexivity. + Qed. + + Global Instance ASLiftComm_ext {v : V} : ASLiftComm Arr Sub (extC v). + Proof. + intros A B₁ B₂ C f₁ f₂ g₁ g₂ EQ u [| x] []; simpl. + - etransitivity; [apply bind_set_pure |]. + rewrite bind_set_pure; reflexivity. + - unfold shift; erewrite <- map_to_bind, map_map_comp by apply liftA_mk_shift_comm. + rewrite <- map_map_comp'; specialize (EQ _ x eq_refl); simpl in EQ; rewrite <- map_to_bind in EQ. + rewrite <- EQ; clear EQ. + generalize (f₂ x) as y, (arr_hom f₂ x); intros y []; simpl. + rewrite !bind_set_pure; reflexivity. + Qed. + + Global Instance SubstitutableCore_ext {v : V} : SubstitutableCore Sub (F v) (extC v) := + λ A u, + {| apply_sub := λ w (x : dom (A ▹ v)), + match x with + | VZ => λ EQ, match EQ with eq_refl => u end + | VS y => int_pure w y + end + |}. + + Global Instance SubstShift_ext {v : V} : SubstShift Arr Sub (F v) (extC v). + Proof. + intros A u w x []; simpl. + apply bind_set_pure. + Qed. + + Global Instance SubstFMap_ext {v : V} : SubstFMap Arr Sub (F v) (extC v). + Proof. + intros A B f u w [ | x ] []; simpl. + - rewrite <- map_to_bind, bind_set_pure; simpl; reflexivity. + - rewrite !bind_set_pure; simpl; reflexivity. + Qed. + + Global Instance SubstBind_ext {v : V} : SubstBind Sub (F v) (extC v). + Proof. + intros A B f u w [| x] []; simpl. + - rewrite bind_set_pure; reflexivity. + - rewrite bind_set_pure; symmetry; apply subst_shift_id. + Qed. + +End IntInstances. + +Arguments int_pure {V F _ Γ v} /. diff --git a/vendor/Binding/LICENSE b/vendor/Binding/LICENSE new file mode 100644 index 0000000..ad3536c --- /dev/null +++ b/vendor/Binding/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2022,2023 Filip Sieczkowski, Piotr Polesiuk + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/vendor/Binding/Lib.v b/vendor/Binding/Lib.v new file mode 100644 index 0000000..6ed5b87 --- /dev/null +++ b/vendor/Binding/Lib.v @@ -0,0 +1,4 @@ +Require Export Binding.Core. +Require Export Binding.Inc. +Require Export Binding.Properties. +Require Export Binding.TermSimpl. diff --git a/vendor/Binding/Product.v b/vendor/Binding/Product.v new file mode 100644 index 0000000..706e45d --- /dev/null +++ b/vendor/Binding/Product.v @@ -0,0 +1,130 @@ +Require Import Utf8. +Require Import Binding.Lib. + +Record sprod (U₁ U₂ : Type) : Type := + { π₁ : U₁ + ; π₂ : U₂ + }. + +Arguments π₁ {U₁ U₂}. +Arguments π₂ {U₁ U₂}. + +Notation "U₁ × U₂" := (sprod U₁ U₂) (at level 40) : type_scope. +Notation "⟨ A , B ⟩" := {| π₁ := A ; π₂ := B |} : bind_scope. + +Section Defs. + Context {U₁ U₂ : Type} {Arr₁ : U₁ → U₁ → Type} {Arr₂ : U₂ → U₂ → Type} + {EA₁ : EqIndCore Arr₁} {EA₂ : EqIndCore Arr₂} {EqA₁ : EqInd Arr₁} {EqA₂ : EqInd Arr₂} + {AC₁ : ArrowCore Arr₁} {AC₂ : ArrowCore Arr₂} {AR₁ : Arrow Arr₁} {AR₂ : Arrow Arr₂}. + + Local Open Scope bind_scope. + Import ArrowNotations. + + Record prod_arr {X Y : U₁ × U₂} : Type := + { arr₁ : Arr₁ (π₁ X) (π₁ Y); + arr₂ : Arr₂ (π₂ X) (π₂ Y) + }. + Global Arguments prod_arr X Y : clear implicits. + + Notation " f × g " := {| arr₁ := f ; arr₂ := g |} (at level 40) : bind_scope. + + Global Instance EIC_prod : EqIndCore prod_arr := + λ A B f g, arr₁ f ≡ arr₁ g ∧ arr₂ f ≡ arr₂ g. + + Global Instance ArrowCore_vsig_arr : ArrowCore prod_arr := + {| arrow_id A := ı × ı; + arrow_comp A B C f g := (arr₁ f ∘ arr₁ g) × (arr₂ f ∘ arr₂ g) |}. + + Global Instance Eq_prod : EqInd prod_arr. + Proof. + split; split; intros. + - split; reflexivity. + - split; symmetry; apply H. + - split; etransitivity; now (apply H || apply H0). + Qed. + + Global Instance Arrow_prod_arr : Arrow prod_arr. + Proof. + split; intros. + - split; apply arrow_comp_id_l. + - split; apply arrow_comp_id_r. + - split; apply arrow_comp_assoc. + - split; eapply arrow_comp_proper; now (apply H0 || apply H). + Qed. + + Definition at₁ {A B : U₁} {C : U₂} (f : A [→] B) : ⟨A, C⟩ [→] ⟨B, C⟩ := + (f : π₁ ⟨A, C⟩ [→] π₁ ⟨B, C⟩) × ı. + Definition at₂ {A : U₁} {B C : U₂} (f : B [→] C) : ⟨A, B⟩ [→] ⟨A, C⟩ := + ı × (f : π₂ ⟨A, B⟩ [→] π₂ ⟨A, C⟩). + + Section ALift. + Context (F₁ : U₁ → U₁) (F₂ : U₂ → U₂) {ALC₁ : LiftableCore Arr₁ F₁} + {ALC₂ : LiftableCore Arr₂ F₂} {AL₁ : Liftable Arr₁ F₁} {AL₂ : Liftable Arr₂ F₂}. + + Definition on₁ (X : U₁ × U₂) := ⟨ F₁ (π₁ X), π₂ X ⟩. + Definition on₂ (X : U₁ × U₂) := ⟨ π₁ X, F₂ (π₂ X) ⟩. + + Global Instance ALC_prod_left : LiftableCore prod_arr on₁ := + { lift A B f := (arr₁ f) ↑ × (arr₂ f : π₂ (on₁ A) [→] π₂ (on₁ B))}. + + Global Instance AL_prod_left : Liftable prod_arr on₁. + Proof. + split; intros. + - split; simpl; [apply lift_id |]; apply EQ. + - split; simpl; [apply lift_comp |]; apply EQ. + - split; simpl; [apply lift_proper |]; apply H. + Qed. + + Global Instance ALC_prod_right : LiftableCore prod_arr on₂ := + { lift A B f := (arr₁ f : π₁ (on₂ A) [→] π₁ (on₂ B)) × (arr₂ f) ↑}. + + Global Instance AL_prod_right : Liftable prod_arr on₂. + Proof. + split; intros. + - split; simpl; [| apply lift_id]; apply EQ. + - split; simpl; [| apply lift_comp]; apply EQ. + - split; simpl; [| apply lift_proper]; apply H. + Qed. + + End ALift. + + Section Shift. + Context (Inc₁ : U₁ → U₁) (Inc₂ : U₂ → U₂) + {SC₁ : ShiftableCore Arr₁ Inc₁} {SC₂ : ShiftableCore Arr₂ Inc₂}. + + Global Instance SC_prod_left : ShiftableCore prod_arr (on₁ Inc₁) := + { mk_shift := λ A, mk_shift × ı }. + + Global Instance SC_prod_right : ShiftableCore prod_arr (on₂ Inc₂) := + { mk_shift := λ A, ı × mk_shift }. + + End Shift. + + Section LiftA_Shift. + Context (F₁ : U₁ → U₁) (F₂ : U₂ → U₂) + {ALC₁ : LiftableCore Arr₁ F₁} {ALC₂ : LiftableCore Arr₂ F₂} + {AL₁ : Liftable Arr₁ F₁} {AL₂ : Liftable Arr₂ F₂} + {SC₁ : ShiftableCore Arr₁ F₁} {SC₂ : ShiftableCore Arr₂ F₂} + {LAS₁ : LiftAShift Arr₁ F₁} {LAS₂ : LiftAShift Arr₂ F₂}. + + Global Instance LiftAShift_prod_left : LiftAShift prod_arr (on₁ F₁). + Proof. + intros A B f; split; simpl. + - apply LAS₁. + - etransitivity; [ apply arrow_comp_id_r | ]. + symmetry; apply arrow_comp_id_l. + Qed. + + + Global Instance LiftAShift_prod_right : LiftAShift prod_arr (on₂ F₂). + Proof. + intros A B f; split; simpl. + - etransitivity; [ apply arrow_comp_id_r | ]. + symmetry; apply arrow_comp_id_l. + - apply LAS₂. + Qed. + End LiftA_Shift. + +End Defs. + +Notation " f × g " := {| arr₁ := f ; arr₂ := g |} (at level 40) : bind_scope. diff --git a/vendor/Binding/Properties.v b/vendor/Binding/Properties.v new file mode 100644 index 0000000..7c82dc1 --- /dev/null +++ b/vendor/Binding/Properties.v @@ -0,0 +1,197 @@ +Require Import Utf8. +Require Import Binding.Core. +Require Vector. +Require Import Morphisms. + +Section Properties. + Context {Obj : Type}. + Context {Arr : Obj → Obj → Type} {EqArr : EqIndCore Arr} {AC : ArrowCore Arr}. + Context {ArrEq : EqInd Arr} {AA : Arrow Arr}. + Context {Sub : Obj → Obj → Type} {EqSub : EqIndCore Sub} {SC : ArrowCore Sub}. + Context {ASC : SubstCore Arr Sub} {SubEq : EqInd Sub} {AS : Arrow Sub} {SS : Subst Arr Sub}. + Context {F G : Obj → Type}. + Context {Inc : Obj → Obj}. + Context {Sh : ShiftableCore Arr Inc}. + Context {ALC : LiftableCore Arr Inc}. + Context {SLC : LiftableCore Sub Inc}. + Context {Sb : SubstitutableCore Sub F Inc}. + Context {LAS : LiftAShift Arr Inc}. + Context {LSS : LiftSShift Arr Sub Inc}. + Context {MapF : FunctorCore (Arr := Arr) F}. + Context {MapG : FunctorCore (Arr := Arr) G} + {MG : Functor G}. + Context {BindF : BindCore (Sub := Sub) F}. + Context {BindG : BindCore (Sub := Sub) G} + {BMPG : BindMapPure G} {BMCG : BindMapComm G} {BG : Bind G}. + Context {SbShF : SubstShift Arr Sub F Inc}. + Context {SbMapF : SubstFMap Arr Sub F Inc}. + Context {SbBndF : SubstBind Sub F Inc}. + Context {AL : Liftable Arr Inc}. + Context {SL : Liftable Sub Inc}. + Context {ASLI : ASLiftInj Arr Sub Inc} {ASLC : ASLiftComm Arr Sub Inc}. + + + Local Open Scope bind_scope. + + Lemma map_id' {A : Obj} (t : G A) : + fmap ı t = t. + Proof. + apply map_id; reflexivity. + Qed. + + Lemma map_map_comp' {A B C : Obj} (f : Arr B C) (g : Arr A B) (t : G A) : + fmap f (fmap g t) = fmap (f ∘ g) t. + Proof. + apply map_map_comp; reflexivity. + Qed. + + Global Instance fmap_proper A B : Proper (equal A B ==> eq ==> eq) fmap. + Proof. + intros f g EQ t t' EQ'; subst t'. + erewrite <- map_id', map_map_comp; [reflexivity |]. + rewrite arrow_comp_id_l, EQ; reflexivity. + Qed. + + Lemma bind_pure' {A : Obj} (t : G A) : + bind ı t = t. + Proof. + apply bind_pure; reflexivity. + Qed. + + Lemma bind_bind_comp' {A B C : Obj} (f : Sub B C) (g : Sub A B) (t : G A) : + bind f (bind g t) = bind (f ∘ g) t. + Proof. + apply bind_bind_comp; reflexivity. + Qed. + + Global Instance bind_proper A B : Proper (equal A B ==> eq ==> eq) bind. + Proof. + intros f g EQ t t' EQ'; subst t'. + erewrite <- bind_pure', bind_bind_comp; [reflexivity |]. + now rewrite EQ, arrow_comp_id_l. + Qed. + + Lemma map_to_bind {A B : Obj} (f : Arr A B) (t : G A) : + fmap f t = bind (f ̂) t. + Proof. + now apply bind_map. + Qed. + + Lemma fmap_liftA_shift_comm {A B : Obj} (f : Arr A B) (t : G A) : + fmap (f ↑) (shift t) = shift (fmap f t). + Proof. + unfold shift; now rewrite !map_map_comp', liftA_mk_shift_comm. + Qed. + + Lemma bind_liftS_shift_comm {A B : Obj} (f : Sub A B) (a : G A) : + bind (f ↑) (shift a) = shift (bind f a). + Proof. + unfold shift; apply bind_map_comm, liftS_mk_shift_comm. + Qed. + + Lemma bind_map_id {A B : Obj} (g : Sub B A) (f : Arr A B) (a : G A) + (EQ : g ∘ f ̂ ≡ ı) : + bind g (fmap f a) = a. + Proof. + rewrite bind_map_comm with (f₁ := ı) (g₁ := ı), map_id', bind_pure'; [reflexivity |]. + now rewrite EQ, arrow_comp_id_r, arrow_subst_id. + Qed. + + Lemma subst_shift_id {A : Obj} (t : G A) (v : F A): + subst (shift t) v = t. + Proof. + unfold shift, subst; apply bind_map_id, subst_shift_pure. + Qed. + + Lemma lift_of_arrow {A B : Obj} (δ : Arr A B) : + δ ↑ ̂ ≡ δ ̂ ↑. + Proof. + now apply lift_of. + Qed. + + Lemma subst_shift_id_lifted {A : Obj} (t : G (Inc A)) (v : F A) : + bind (mk_subst v ↑) (fmap (mk_shift ↑) t) = t. + Proof. + apply bind_map_id; rewrite lift_of_arrow, lift_comp by reflexivity. + apply lift_id, subst_shift_pure. + Qed. + + Lemma subst_shift_id_lifted2 {A : Obj} (t : G (Inc (Inc A))) (v : F A) : + bind ((mk_subst v) ↑ ↑) (fmap (mk_shift ↑ ↑) t) = t. + Proof. + apply bind_map_id; rewrite lift_of_arrow, lift_comp by reflexivity. + apply lift_id; rewrite lift_of_arrow, lift_comp by reflexivity. + apply lift_id, subst_shift_pure. + Qed. + + Lemma fmap_subst {A B : Obj} (f : Arr A B) (t : G (Inc A)) (v : F A) : + fmap f (subst t v) = subst (fmap (f ↑) t) (fmap f v). + Proof. + unfold subst; symmetry; erewrite bind_map_comm; [reflexivity |]. + symmetry; apply map_mk_subst_comm. + Qed. + + Lemma shift_subst {Inc' : Obj → Obj} {Sh' : ShiftableCore Arr Inc'} + {A : Obj} (t : G (Inc A)) (v : F A) : + shift (subst t v) = subst (fmap (mk_shift ↑) t) (shift v). + Proof. + apply fmap_subst. + Qed. + + Lemma bind_subst {A B : Obj} (f : Sub A B) (t : G (Inc A)) (v : F A) : + bind f (subst t v) = subst (bind (f ↑) t) (bind f v). + Proof. + unfold subst; now rewrite !bind_bind_comp', bind_mk_subst_comm. + Qed. + + (* + Lemma shiftn_map {A B : Obj} n (δ : Arr A B) : + mk_shiftn n ∘ δ ≡ₐ liftAn n δ ∘ mk_shiftn n. + Proof. + induction n; simpl; [now rewrite arrow_comp_id_l, arrow_comp_id_r |]. + rewrite arrow_comp_assoc, <- liftA_mk_shift_comm, <- arrow_comp_assoc, liftA_comp; [| apply IHn]. + erewrite <- liftA_comp, arrow_comp_assoc; reflexivity. + Qed. + + Lemma shiftn_bind {A B : Obj} n (ρ : Sub A B) : + mk_shiftn n ̂ • ρ ≡ₛ liftSn n ρ • mk_shiftn n ̂. + Proof. + induction n; simpl. + - now rewrite !arrow_subst_id, subst_comp_pure_r, subst_comp_pure_l. + - rewrite !arrow_subst_comp, subst_comp_assoc, <- liftS_mk_shift_comm, <- !subst_comp_assoc. + rewrite <- !lift_of_arrow, liftS_comp; [| eassumption]. + rewrite liftS_comp; reflexivity. + Qed. + + Lemma substV_map {A B : Obj} n (xs : Vector.t (F A) n) (δ : Arr A B) : + mk_substV (Vector.map (fmap δ) xs) • liftAn n δ ̂ ≡ₛ δ ̂ • mk_substV xs. + Proof. + induction xs; simpl; [now rewrite subst_comp_pure_l, subst_comp_pure_r |]. + rewrite subst_comp_assoc, <- lift_of_arrow, liftS_comp by apply IHxs. + erewrite <- liftS_comp by reflexivity; rewrite lift_of_arrow, <- subst_comp_assoc. + now rewrite <- map_mk_subst_comm, subst_comp_assoc. + Qed. + + Lemma substV_bind {A B : Obj} n (xs : Vector.t (F A) n) (ρ : Sub A B) : + mk_substV (Vector.map (bind ρ) xs) • liftSn n ρ ≡ₛ ρ • mk_substV xs. + Proof. + induction xs; simpl; [now rewrite subst_comp_pure_l, subst_comp_pure_r |]. + rewrite <- subst_comp_assoc, bind_mk_subst_comm, !subst_comp_assoc. + rewrite liftS_comp by apply IHxs. + now rewrite liftS_comp by reflexivity. + Qed. + + Lemma substV_shiftn_id {A : Obj} {n} (xs : Vector.t (F A) n) (t : G A) : + substV xs (shiftn n t) = t. + Proof. + unfold substV, shiftn; rewrite map_to_bind, bind_bind_comp', bind_pure; [reflexivity | clear t]. + induction xs; simpl. + - now rewrite subst_comp_pure_l, arrow_subst_id. + - rewrite arrow_subst_comp, <- lift_of_arrow, <- subst_comp_assoc. + rewrite subst_comp_assoc with (f := mk_subst h), liftS_comp by apply IHxs. + rewrite liftS_pure, subst_comp_pure_r by reflexivity. + apply subst_shift_pure. + Qed. + *) + +End Properties. diff --git a/vendor/Binding/Set.v b/vendor/Binding/Set.v new file mode 100644 index 0000000..ff35dd8 --- /dev/null +++ b/vendor/Binding/Set.v @@ -0,0 +1,204 @@ +Require Import Utf8. +Require Import Binding.Core. +Require Import Binding.Inc. +Require Import Binding.Properties. +Require Import Morphisms. + +Class SetPureCore (F : Set → Type) : Type := + set_pure : ∀ A : Set, A → F A. + +Arguments set_pure {F _ A}. + +Record Arr (A B : Set) : Type := + { apply_arr : A → B + }. +Notation " A '[→]' B " := (Arr A B) (at level 100, no associativity) : type_scope. + +Arguments apply_arr {A B}. +Coercion apply_arr : Arr >-> Funclass. + +Record Sub {F : Set → Type} {FP : SetPureCore F} (A B : Set) : Type := + { apply_sub : A → F B + }. +Notation " A '[⇒]' B " := (Sub A B) (at level 100, no associativity) : type_scope. + +Arguments apply_sub {F FP A B}. +Coercion apply_sub : Sub >-> Funclass. + +Global Instance ArrEqC : EqIndCore Arr := + λ A B f g, ∀ x, f x = g x. + +Global Instance ArrEq : EqInd Arr. +Proof. + split; intros; split; intros; congruence. +Qed. + +Global Instance SubEqC {F} {FP : SetPureCore F} : EqIndCore Sub := + λ A B f g, ∀ x, f x = g x. + +Global Instance SubEq {F} {FP : SetPureCore F} : EqInd Sub. +Proof. + split; split; intros; congruence. +Qed. + +Global Instance ArrowCore_Set : ArrowCore Arr := + { arrow_id := λ _, {| apply_arr := λ x, x |} + ; arrow_comp := λ _ _ _ f g, {| apply_arr := λ x, f (g x) |} + }. + +Class SetPure (F : Set → Type) {FP : SetPureCore F} + {MapF : FunctorCore F} + {BndF : BindCore F} : Prop := + { fmap_set_pure : ∀ (A B : Set) (f : Arr A B) (x : A), + fmap f (set_pure x) = set_pure (f x) + ; bind_set_pure : ∀ (A B : Set) (f : Sub A B) (x : A), + bind f (set_pure x) = f x + }. + +Section SetInstances. + Context {F : Set → Type} {FP : SetPureCore F}. + Context {MapF : FunctorCore (Arr := Arr) F}. + Context {BndF : BindCore (Sub := Sub) F}. + Context {SPF : SetPure F}. + + Global Instance Arrow_Set : Arrow Arr. + Proof. + split; [unfold equal, ArrEqC; simpl; congruence .. |]. + intros A B C f₁ f₂ EQf g₁ g₂ EQg x; simpl; congruence. + Qed. + + Global Instance SubstArrCore_Set : ArrowCore Sub := + { arrow_id A := {| apply_sub := set_pure |}; + arrow_comp A B C f g := {| apply_sub := λ x, bind f (g x) |} }. + + Global Instance SubstCore_Set : SubstCore Arr Sub := + λ A B f, {| apply_sub := λ x, set_pure (f x) |}. + + Definition incFun (A B : Set) (f : Arr A B) : inc A → inc B := inc_map f. + + Global Instance IncMap : FunctorCore inc := incFun. + Global Instance IncFun : Functor inc. + Proof. + split; intros. + - destruct t as [| x]; unfold fmap; simpl; f_equal; apply EQ. + - destruct t as [| x]; unfold fmap; simpl; f_equal; apply EQ. + Qed. + + Context {MF : Functor F} {BF : Bind F}. + Context {BMPF : BindMapPure F} {BMCF : BindMapComm F}. + + Global Instance SubArrow_Set : Arrow Sub. + Proof. + split; simpl; intros. + - intros x; simpl; apply bind_pure; reflexivity. + - intros x; simpl; apply bind_set_pure. + - intros x; simpl; symmetry; apply bind_bind_comp; reflexivity. + - intros ρ₁ ρ₂ EQρ σ₁ σ₂ EQσ x; simpl; rewrite EQσ; clear EQσ. + etransitivity; [| apply bind_pure; reflexivity]. + symmetry; apply bind_bind_comp. + intros y; rewrite EQρ; apply bind_pure; reflexivity. + Qed. + + Global Instance Subst_Set : Subst Arr Sub. + Proof. + split; intros. + - reflexivity. + - intros x; simpl; symmetry; apply bind_set_pure. + - intros f g EQ x; simpl; congruence. + Qed. + + Global Instance ALiftableCore_inc : LiftableCore Arr inc := + { lift A B f := {| apply_arr := fmap f |} }. + + Global Instance ALiftable_inc : Liftable Arr inc. + Proof. + split; intros. + - intros x; simpl; apply map_id, EQ. + - intros x; simpl; apply map_map_comp, EQ. + - intros f₁ f₂ EQf x; simpl; now rewrite EQf. + Qed. + + Global Instance ShiftableCore_inc : ShiftableCore Arr inc := + λ A, {| apply_arr := VS |}. + + Global Instance LiftAShift_inc : LiftAShift Arr inc. + Proof. + unfold LiftAShift; reflexivity. + Qed. + + Global Instance SLiftableCore_inc : LiftableCore Sub inc := + { lift A B f := + {| apply_sub := λ x, + match x with + | VZ => set_pure VZ + | VS y => shift (f y) + end + |} + }. + + Global Instance LiftSShift_inc : LiftSShift Arr Sub inc. + Proof. + intros A B f x; simpl. + rewrite bind_set_pure; simpl. + unfold shift; simpl; rewrite map_to_bind; reflexivity. + Qed. + + Global Instance SLiftable_inc : Liftable Sub inc. + Proof. + split; intros. + - intros [| x]; simpl; [reflexivity | unfold shift; simpl]. + rewrite EQ; apply fmap_set_pure. + - intros [| x]; simpl; [now apply bind_set_pure |]. + rewrite bind_liftS_shift_comm, <- EQ; reflexivity. + - intros f₁ f₂ EQf [| x]; simpl; [reflexivity | now rewrite EQf]. + Qed. + + Global Instance ASLiftInj_inc : ASLiftInj Arr Sub inc. + Proof. + intros A B f g EQ [| x]; simpl; [reflexivity |]. + rewrite <- EQ; simpl; symmetry; apply fmap_set_pure. + Qed. + + Global Instance ASLiftComm_inc : ASLiftComm Arr Sub inc. + Proof. + intros A B₁ B₂ C f₁ f₂ g₁ g₂ EQ [| x]; simpl. + - rewrite !bind_set_pure; simpl; reflexivity. + - rewrite bind_set_pure; simpl. + unfold shift; erewrite <- map_to_bind, map_map_comp by apply liftA_mk_shift_comm. + rewrite <- map_map_comp'; f_equal. + specialize (EQ x); simpl in EQ. + now rewrite bind_set_pure, <- map_to_bind in EQ. + Qed. + + Global Instance SubstitutableCore_inc : SubstitutableCore Sub F inc := + λ A v, + {| apply_sub := λ x, + match x with + | VZ => v + | VS y => set_pure y + end + |}. + + Global Instance SubstShift_inc : SubstShift Arr Sub F inc. + Proof. + intros A v x; simpl. + rewrite bind_set_pure; reflexivity. + Qed. + + Global Instance SubstFMap_inc : SubstFMap Arr Sub F inc. + Proof. + intros A B f v [ | x ]; simpl. + - rewrite bind_set_pure; simpl; rewrite <- map_to_bind; reflexivity. + - rewrite !bind_set_pure; reflexivity. + Qed. + + Global Instance SubstBind_inc : SubstBind Sub F inc. + Proof. + intros A B f v [| x]; simpl. + - rewrite bind_set_pure; reflexivity. + - rewrite bind_set_pure; symmetry; apply subst_shift_id. + Qed. + +End SetInstances. + +Arguments set_pure {F _ A} /. diff --git a/vendor/Binding/TermSimpl.v b/vendor/Binding/TermSimpl.v new file mode 100644 index 0000000..ca1a5f8 --- /dev/null +++ b/vendor/Binding/TermSimpl.v @@ -0,0 +1,206 @@ +Require Import Utf8. +Require Import Binding.Core. +Require Import Binding.Properties. + +Create HintDb term_simpl. +Create HintDb term_simpl_raw. + +Ltac fold_fmap_goal := + repeat match goal with + | |- context[ ?map ?A ?B ?f ?t ] => + match map with + | @fmap ?Obj ?Arr ?F ?m => fail 1 + | _ => + match type of map with + | ∀ A B : ?Obj, ?Arr A B → ?F A → ?F B => + change (map A B f t) with (fmap f t) || + change (map A B f t) with (fmap (Obj := Obj) (F := F) f t) + | FunctorCore _ => + change (map A B f t) with (fmap (FunctorCore := map) f t) + end + end + end. + +Ltac fold_fmap_in H := + repeat match type of H with + | context[ ?map ?A ?B ?f ?t ] => + match map with + | @fmap ?Obj ?Arr ?F ?m => fail 1 + | _ => + match type of map with + | ∀ A B : ?Obj, ?Arr A B → ?F A → ?F B => + change (map A B f t) with (fmap f t) in H || + change (map A B f t) with (fmap (Obj := Obj) (F := F) f t) in H + | FunctorCore _ => + change (map A B f t) with (fmap (FunctorCore := map) f t) in H + end + end + end. + +Tactic Notation "fold_fmap" := fold_fmap_goal. +Tactic Notation "fold_fmap" "in" hyp(H) := fold_fmap_in H. + +Ltac fold_bind_goal := + repeat match goal with + | |- context[ ?bnd ?A ?B ?f ?t ] => + match bnd with + | @bind ?Obj ?Sub ?F ?b => fail 1 + | _ => + match type of bnd with + | ∀ A B : ?Obj, _ → ?F A → ?F B => + change (bnd A B f t) with (bind f t) || + change (bnd A B f t) with (bind (Obj := Obj) (F := F) f t) + | BindCore _ => + change (bnd A B f t) with (bind (BindCore := bnd) f t) + end + end + end. + +Ltac fold_bind_in H := + repeat match type of H with + | context[ ?bnd ?A ?B ?f ?t ] => + match bnd with + | @bind ?Obj ?Sub ?F ?b => fail 1 + | _ => + match type of bnd with + | ∀ A B : ?Obj, _ → ?F A → ?F B => + change (bnd A B f t) with (bind f t) in H || + change (bnd A B f t) with (bind (Obj := Obj) (F := F) f t) in H + | BindCore _ => + change (bnd A B f t) with (bind (BindCore := bnd) f t) in H + end + end + end. + +Tactic Notation "fold_bind" := fold_bind_goal. +Tactic Notation "fold_bind" "in" hyp(H) := fold_bind_in H. + +Ltac fold_fmap_and_bind_goal := + repeat match goal with + | |- context[ ?ff ?A ?B ?f ?t ] => + match ff with + | @fmap ?Obj ?Arr ?F ?m => fail 1 + | @bind ?Obj ?Sub ?F ?m => fail 1 + | _ => + match type of ff with + | ∀ A B : ?Obj, _ → ?F A → ?F B => + change (ff A B f t) with (fmap f t) || + change (ff A B f t) with (fmap (Obj := Obj) (F := F) f t) || + change (ff A B f t) with (bind f t) || + change (ff A B f t) with (bind (Obj := Obj) (F := F) f t) + | FunctorCore _ => + change (ff A B f t) with (fmap (FunctorCore := ff) f t) + | BindCore _ => + change (ff A B f t) with (bind (BindCore := ff) f t) + end + end + end. + +Ltac fold_fmap_and_bind_in H := + repeat match type of H with + | context[ ?ff ?A ?B ?f ?t ] => + match ff with + | @fmap ?Obj ?Arr ?F ?m => fail 1 + | @bind ?Obj ?Sub ?F ?m => fail 1 + | _ => + match type of ff with + | ∀ A B : ?Obj, _ → ?F A → ?F B => + change (ff A B f t) with (fmap f t) in H || + change (ff A B f t) with (fmap (Obj := Obj) (F := F) f t) in H || + change (ff A B f t) with (bind f t) in H || + change (ff A B f t) with (bind (Obj := Obj) (F := F) f t) in H + | FunctorCore _ => + change (ff A B f t) with (fmap (FunctorCore := ff) f t) in H + | BindCore _ => + change (ff A B f t) with (bind (BindCore := ff) f t) in H + end + end + end. + +Tactic Notation "fold_fmap_and_bind" := fold_fmap_and_bind_goal. +Tactic Notation "fold_fmap_and_bind" "in" hyp(H) := fold_fmap_and_bind_in H. + +Ltac fold_shift_goal := + repeat match goal with + | |- context[ @fmap ?Obj ?Arr ?G ?MF ?A _ + (@mk_shift ?Obj _ ?Inc ?Sh ?A) + ?t + ] => + change (@fmap Obj Arr G MF A _ (@mk_shift Obj _ Inc Sh A) t) + with (@shift Obj Arr G MF Inc Sh A t) + end. + +Ltac fold_shift_in H := + repeat match type of H with + | context[ @fmap ?Obj ?Arr ?G ?MF ?A _ + (@mk_shift ?Obj _ ?Inc ?Sh ?A) + ?t + ] => + change (@fmap Obj Arr G MF A _ (@mk_shift Obj _ Inc Sh A) t) + with (@shift Obj Arr G MF Inc Sh A t) in H + end. + +Tactic Notation "fold_shift" := fold_shift_goal. +Tactic Notation "fold_shift" "in" hyp(H) := fold_shift_in H. + +Ltac fold_subst_goal := + repeat match goal with + | |- context[ @bind ?Obj ?Sub ?G ?BF _ ?A + (@mk_subst ?Obj _ ?F ?Inc ?Sb ?A ?v) + ?t + ] => + change (@bind Obj Sub G BF _ A (@mk_subst Obj _ F Inc Sb A v) t) + with (@subst Obj Sub G BF F Inc Sb A t v) + end. + +Ltac fold_subst_in H := + repeat match type of H with + | context[ @bind ?Obj ?Sub ?G ?BF _ ?A + (@mk_subst ?Obj _ ?F ?Inc ?Sb ?A ?v) + ?t + ] => + change (@bind Obj Sub G BF _ A (@mk_subst Obj _ F Inc Sb A v) t) + with (@subst Obj Sub G BF F Inc Sb A t v) in H + end. + +Tactic Notation "fold_subst" := fold_subst_goal. +Tactic Notation "fold_subst" "in" hyp(H) := fold_subst_in H. + +Ltac term_simpl_goal := + repeat ( + unfold subst, shift, bind, fmap; simpl; + repeat (autorewrite with term_simpl_raw; simpl); + fold_fmap_and_bind; fold_shift; fold_subst; + repeat match goal with + | |- context[ fmap ?f (subst ?t ?v) ] => rewrite (fmap_subst f t v) + | |- context[ fmap (lift (G:=?Inc) ?f) (shift (Inc:=?Inc) ?t) ] => + rewrite (fmap_liftA_shift_comm f t) + | |- context[ bind ?f (subst ?t ?v) ] => rewrite (bind_subst f t v) + | |- context[ bind (lift (G:=?Inc) ?f) (shift (Inc:=?Inc) ?t) ] => + rewrite (bind_liftS_shift_comm f t) + | |- context[ subst (Inc:=?Inc) (shift (Inc:=?Inc) ?t) ?v ] => + rewrite (subst_shift_id t v) + end; + try autorewrite with term_simpl + ). + +Ltac term_simpl_in H := + repeat ( + unfold subst, shift, bind, fmap in H; simpl in H; + repeat (autorewrite with term_simpl_raw in H; simpl in H); + fold_fmap_and_bind in H; fold_shift in H; fold_subst in H; + repeat match type of H with + | context[ fmap ?f (subst ?t ?v) ] => rewrite (fmap_subst f t v) in H + | context[ fmap (lift (G:=?Inc) ?f) (shift (Inc:=?Inc) ?t) ] => + rewrite (fmap_liftA_shift_comm f t) in H + | context[ bind ?f (subst ?t ?v) ] => rewrite (bind_subst f t v) in H + | context[ bind (lift (G:=?Inc) ?f) (shift (Inc:=?Inc) ?t) ] => + rewrite (bind_liftS_shift_comm f t) in H + | context[ subst (Inc:=?Inc) (shift (Inc:=?Inc) ?t) ?v ] => + rewrite (subst_shift_id t v) in H + end; + try autorewrite with term_simpl in H + ). + +Tactic Notation "term_simpl" := term_simpl_goal. +Tactic Notation "term_simpl" "in" hyp(H) := term_simpl_in H. From e98cfa7a190c7002a5b843470b4c75c591682be4 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 1 Nov 2023 16:08:50 +0100 Subject: [PATCH 004/114] revert --- theories/gitree/core.v | 326 +++++++++++++---------------------------- 1 file changed, 102 insertions(+), 224 deletions(-) diff --git a/theories/gitree/core.v b/theories/gitree/core.v index 42fd267..5a8d44e 100644 --- a/theories/gitree/core.v +++ b/theories/gitree/core.v @@ -84,11 +84,6 @@ Inductive error := . Canonical Structure errorO := leibnizO error. -(* TODO: add continuations to function component, as they can yeet *) -(* Simple effects contain Next id as their continuations *) -(* Call/cc saves the current continuation *) -(* Throw applies the saved continuation *) - (** * Recursive domain equation *) Module IT_pre. Definition ITOF (Σ : opsInterp) (A : ofe) : oFunctor := @@ -96,7 +91,7 @@ Definition ITOF (Σ : opsInterp) (A : ofe) : oFunctor := + ▶ (∙ -n> ∙) (* function space *) + errorO (* explicit error state *) + ▶ ∙ (* silent step *) - + { op : opid Σ & (Ins (Σ op)) * ((▶ (∙ -n> ∙)) * ((Outs (Σ op)) -n> ▶ ∙ )) } + + { op : opid Σ & (Ins (Σ op)) * ((Outs (Σ op)) -n> ▶ ∙ ) } ). #[export] Instance ITOF_contractive Σ A : oFunctorContractive (ITOF Σ A). @@ -128,7 +123,7 @@ Module Export ITF_solution. errorO) (laterO (IT Σ A))) (sigTO (λ op : opid Σ, prodO (Ins (Σ op) ♯ (IT Σ A)) - (prodO (laterO ((IT Σ A) -n> (IT Σ A))) ((Outs (Σ op) ♯ (IT Σ A)) -n> laterO (IT Σ A))))) + ((Outs (Σ op) ♯ (IT Σ A)) -n> laterO (IT Σ A)))) := ofe_iso_2 (IT_result Σ A). Definition IT_fold {Σ A} `{!Cofe A} : @@ -136,7 +131,7 @@ Module Export ITF_solution. errorO) (laterO (IT Σ A))) (sigTO (λ op : opid Σ, prodO (Ins (Σ op) ♯ (IT Σ A)) - (prodO (laterO ((IT Σ A) -n> (IT Σ A))) ((Outs (Σ op) ♯ (IT Σ A)) -n> laterO (IT Σ A))))) + ((Outs (Σ op) ♯ (IT Σ A)) -n> laterO (IT Σ A)))) -n> IT Σ A := ofe_iso_1 (IT_result Σ A). @@ -172,26 +167,26 @@ Section smart. refine (IT_fold ◎ inlO ◎ inlO ◎ inlO ◎ inrO). Defined. - Definition Vis (op : opid E) (ins : oFunctor_apply (Ins (E op)) IT) (cont : laterO (IT -n> IT)) + Definition Vis (op : opid E) (ins : oFunctor_apply (Ins (E op)) IT) (k : oFunctor_apply (Outs (E op)) IT -n> laterO IT) : IT. Proof. refine (IT_fold (inr _)). - refine (existT op (ins, (cont, k))). + refine (existT op (ins, k)). Defined. Global Instance Vis_ne {op : opid E} n : - Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (Vis op). + Proper ((dist n) ==> (dist n) ==> (dist n)) (Vis op). Proof. rewrite /Vis. - intros i1 i2 Hi k1 k2 Hk j1 j2 Hj. + intros i1 i2 Hi k1 k2 Hk. f_equiv. f_equiv. - eapply existT_ne_2. do 2 eapply pair_ne; eauto. + eapply existT_ne_2. eapply pair_ne; eauto. Qed. Global Instance Vis_proper {op : opid E} : - Proper ((≡) ==> (≡) ==> (≡) ==> (≡)) (Vis op). + Proper ((≡) ==> (≡) ==> (≡)) (Vis op). Proof. rewrite /Vis. - intros i1 i2 Hi k1 k2 Hk j1 j2 Hj. + intros i1 i2 Hi k1 k2 Hk. f_equiv. f_equiv. eapply existT_proper_2. solve_proper. @@ -264,11 +259,11 @@ Section smart. done. Qed. - Lemma Vis_inj_op' op1 op2 i1 i2 k1 k2 j1 j2 {PROP : bi} `{!BiInternalEq PROP} : - (Vis op1 i1 k1 j1 ≡ Vis op2 i2 k2 j2 ⊢ ⌜op1 = op2⌝ : PROP)%I. + Lemma Vis_inj_op' op1 op2 i1 i2 k1 k2 {PROP : bi} `{!BiInternalEq PROP} : + (Vis op1 i1 k1 ≡ Vis op2 i2 k2 ⊢ ⌜op1 = op2⌝ : PROP)%I. Proof. iIntros "H". - iAssert (internal_eq (IT_unfold (Vis op1 i1 k1 j1)) (IT_unfold (Vis op2 i2 k2 j2))) with "[H]" as "H". + iAssert (internal_eq (IT_unfold (Vis op1 i1 k1)) (IT_unfold (Vis op2 i2 k2))) with "[H]" as "H". { iRewrite "H". done. } rewrite !IT_unfold_fold. iPoseProof (sum_equivI with "H") as "H". @@ -277,11 +272,11 @@ Section smart. done. Qed. - Lemma Vis_inj' op i1 i2 k1 k2 j1 j2 {PROP : bi} `{!BiInternalEq PROP} : - (Vis op i1 k1 j1 ≡ Vis op i2 k2 j2 ⊢ i1 ≡ i2 ∧ k1 ≡ k2 ∧ j1 ≡ j2 : PROP)%I. + Lemma Vis_inj' op i1 i2 k1 k2 {PROP : bi} `{!BiInternalEq PROP} : + (Vis op i1 k1 ≡ Vis op i2 k2 ⊢ i1 ≡ i2 ∧ k1 ≡ k2 : PROP)%I. Proof. iIntros "H". - iAssert (internal_eq (IT_unfold (Vis op i1 k1 j1)) (IT_unfold (Vis op i2 k2 j2))) with "[H]" as "H". + iAssert (internal_eq (IT_unfold (Vis op i1 k1)) (IT_unfold (Vis op i2 k2))) with "[H]" as "H". { iRewrite "H". done. } rewrite !IT_unfold_fold. simpl. iPoseProof (sum_equivI with "H") as "H". @@ -289,7 +284,7 @@ Section smart. iDestruct "H" as (eq) "H". simpl. simpl in eq. assert (eq = eq_refl) as ->. { apply eq_pi. apply _. } - simpl. do 2 iPoseProof (prod_equivI with "H") as "[$ H]"; iFrame "H". + simpl. iPoseProof (prod_equivI with "H") as "[$ $]". Qed. Lemma IT_ret_tau_ne k α {PROP : bi} `{!BiInternalEq PROP} : @@ -313,30 +308,30 @@ Section smart. iPoseProof (sum_equivI with "H2") as "H2". by iPoseProof (sum_equivI with "H2") as "H2". Qed. - Lemma IT_ret_vis_ne n op i k j {PROP : bi} `{!BiInternalEq PROP} : - (Ret n ≡ Vis op i k j ⊢ False : PROP)%I. + Lemma IT_ret_vis_ne n op i k {PROP : bi} `{!BiInternalEq PROP} : + (Ret n ≡ Vis op i k ⊢ False : PROP)%I. Proof. iIntros "H1". - iAssert (IT_unfold (Ret n) ≡ IT_unfold (Vis op i k j))%I with "[H1]" as "H2". + iAssert (IT_unfold (Ret n) ≡ IT_unfold (Vis op i k))%I with "[H1]" as "H2". { by iRewrite "H1". } rewrite !IT_unfold_fold. iPoseProof (sum_equivI with "H2") as "H". done. Qed. - Lemma IT_fun_vis_ne f op i ko j {PROP : bi} `{!BiInternalEq PROP} : - (Fun f ≡ Vis op i ko j ⊢ False : PROP)%I. + Lemma IT_fun_vis_ne f op i ko {PROP : bi} `{!BiInternalEq PROP} : + (Fun f ≡ Vis op i ko ⊢ False : PROP)%I. Proof. iIntros "H1". - iAssert (IT_unfold (Fun f) ≡ IT_unfold (Vis op i ko j))%I with "[H1]" as "H2". + iAssert (IT_unfold (Fun f) ≡ IT_unfold (Vis op i ko))%I with "[H1]" as "H2". { by iRewrite "H1". } rewrite !IT_unfold_fold. simpl. by iPoseProof (sum_equivI with "H2") as "H2". Qed. - Lemma IT_tau_vis_ne α op i k j {PROP : bi} `{!BiInternalEq PROP} : - (Tau α ≡ Vis op i k j ⊢ False : PROP)%I. + Lemma IT_tau_vis_ne α op i k {PROP : bi} `{!BiInternalEq PROP} : + (Tau α ≡ Vis op i k ⊢ False : PROP)%I. Proof. iIntros "H1". - iAssert (IT_unfold (Tau α) ≡ IT_unfold (Vis op i k j))%I with "[H1]" as "H2". + iAssert (IT_unfold (Tau α) ≡ IT_unfold (Vis op i k))%I with "[H1]" as "H2". { by iRewrite "H1". } rewrite !IT_unfold_fold /=. iPoseProof (sum_equivI with "H2") as "H2". @@ -378,11 +373,11 @@ Section smart. rewrite !IT_unfold_fold /=. by repeat iPoseProof (sum_equivI with "H2") as "H2". Qed. - Lemma IT_vis_err_ne op i k j e {PROP : bi} `{!BiInternalEq PROP} : - (Vis op i k j ≡ Err e ⊢ False : PROP)%I. + Lemma IT_vis_err_ne op i k e {PROP : bi} `{!BiInternalEq PROP} : + (Vis op i k ≡ Err e ⊢ False : PROP)%I. Proof. iIntros "H1". - iAssert (IT_unfold (Vis op i k j) ≡ IT_unfold (Err e))%I with "[H1]" as "H2". + iAssert (IT_unfold (Vis op i k) ≡ IT_unfold (Err e))%I with "[H1]" as "H2". { by iRewrite "H1". } rewrite !IT_unfold_fold /=. by iPoseProof (sum_equivI with "H2") as "H2". @@ -404,123 +399,52 @@ Section IT_rec. (Parr : laterO (sumO (IT E A) P -n> prodO (IT E A) P) -n> P) (Ptau : laterO (prodO (IT E A) P) -n> P) (Pvis : forall (op : opid E), - (oFunctor_car (Ins (E op)) (sumO (IT E A) P) (prodO (IT E A) P)) -n> - (laterO (sumO (IT E A) P -n> prodO (IT E A) P)) -n> - ((oFunctor_car (Outs (E op)) (prodO (IT E A) P) (sumO (IT E A) P)) -n> laterO (prodO (IT E A) P)) -n> + (oFunctor_car (Ins (E op)) (sumO (IT E A) P) (prodO (IT E A) P)) -n> + ((oFunctor_car (Outs (E op)) (prodO (IT E A) P) (sumO (IT E A) P)) -n> laterO (prodO (IT E A) P)) -n> P). Variable (Punfold : P -n> sumO (sumO (sumO (sumO A (laterO (P -n> P))) errorO) (laterO P)) - (sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) P) (prodO ((laterO (P -n> P))) ((oFunctor_apply (Outs (E op)) P) -n> laterO P)))%type)). + (sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) P) ((oFunctor_apply (Outs (E op)) P) -n> laterO P))%type)). (** XXX **) Opaque prod_in. (** otherwise it gets unfolded in the proofs of contractiveness *) - Program Definition sandwich : (IT E A -n> P) -n> (P -n> IT E A) -n> (IT E A -n> IT E A) -n> sumO (IT E A) P -n> prodO (IT E A) P := - λne self1 self2 f, prod_in idfun self1 ◎ f ◎ sumO_rec idfun self2. - Next Obligation. solve_proper. Defined. - Next Obligation. intros self1 n ? ? ? ? x; simpl; destruct x; solve_proper. Defined. - Next Obligation. solve_proper. Defined. - Program Definition unsandwich : (sumO (IT E A) P -n> prodO (IT E A) P) -n> IT E A -n> IT E A := - λne f, fstO ◎ f ◎ inlO. - Next Obligation. solve_proper. Defined. - - Lemma sandwich_unsandwich (self1 : IT E A -n> P) (self2 : P -n> IT E A) : - unsandwich ◎ (sandwich self1 self2) ≡ idfun. - Proof. intros f x; reflexivity. Qed. - Program Definition Pvis_rec (self : prodO (IT E A -n> P) (P -n> IT E A)) : - sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) (IT E A)) (prodO (laterO ((IT E A) -n> (IT E A))) (oFunctor_apply (Outs (E op)) (IT E A) -n> laterO (IT E A)))) -n> P + sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) (IT E A)) (oFunctor_apply (Outs (E op)) (IT E A) -n> laterO (IT E A))) -n> P := λne x, let op := projT1 x in - let inp := fst (projT2 x) in - let outp1 := fst (snd (projT2 x)) in - let outp2 := snd (snd (projT2 x)) in - let self1 : IT E A -n> P := fst self in - let self2 : P -n> IT E A := snd self in - let s_in := oFunctor_map (Ins (E op)) (sumO_rec idfun self2, prod_in idfun self1) in - let s_out := oFunctor_map (Outs (E op)) (prod_in idfun self1, sumO_rec idfun self2) in - Pvis op (s_in inp) (laterO_map (sandwich self1 self2) outp1) (laterO_map (prod_in idfun self1) ◎ outp2 ◎ s_out). + let inp := fst (projT2 x) in + let outp := snd (projT2 x) in + let self1 : IT E A -n> P := fst self in + let self2 : P -n> IT E A := snd self in + let s_in := oFunctor_map (Ins (E op)) (sumO_rec idfun self2,prod_in idfun self1) in + let s_out := oFunctor_map (Outs (E op)) (prod_in idfun self1, sumO_rec idfun self2) in + Pvis op (s_in inp) (laterO_map (prod_in idfun self1) ◎ outp ◎ s_out). Next Obligation. intros (self1, self2) n x1 x2 Hx. - destruct x1 as [R1 [q1 [k1 j1]]]. - destruct x2 as [R2 [q2 [k2 j2]]]. - destruct Hx as [Hx1 [Hx2 [Hx3 Hx4]]]. - subst; simpl in *. + destruct x1 as [R1 [q1 k1]]. + destruct x2 as [R2 [q2 k2]]. + destruct Hx as [Hx1 Hx2]. + simpl in *. + subst. simpl in *. + destruct Hx2 as [Hx1 Hx2]. simpl in *. solve_proper. - Defined. + Qed. Instance Pvis_rec_contractive : Contractive Pvis_rec. - Proof. - intros ? [x1 x2] [y1 y2] ? ?; simpl. - assert (H1 : dist_later n x1 y1). - { destruct H as [H]; constructor; intros; now apply H. } - assert (H2 : dist_later n x2 y2). - { destruct H as [H]; constructor; intros; now apply H. } - f_equiv. - - f_equiv. - + solve_contractive. - + apply laterO_map_contractive. - destruct n as [| n]. - * apply dist_later_0. - * apply dist_later_S. - apply dist_later_S in H1, H2. - intros ? [x3 | x3]; simpl; - f_equiv; solve_proper. - - intros ?; simpl. - solve_contractive. - Defined. - - Program Definition cccompose {X Y Z : ofe} - : (Y -n> Z) -n> (X -n> Y) -n> X -n> Z := λne g f, ccompose g f. - Next Obligation. - solve_proper. - Defined. - Next Obligation. - solve_proper. - Defined. - - Program Definition laterO_precompose {X Y Z : ofe} - : (X -n> Y) -n> laterO (Y -n> Z) -n> laterO (X -n> Z) - := λne f gl, laterO_ap (laterO_ap (Next cccompose) gl) (Next f). - Next Obligation. - intros ? ? ? ? ? ? ? ?. - apply later_ap_ne. - now f_equiv. - Defined. - Next Obligation. - solve_proper. - Defined. - - Program Definition laterO_postcompose {X Y Z : ofe} - : laterO (X -n> Y) -n> (Y -n> Z) -n> laterO (X -n> Z) - := λne fl g, laterO_ap (Next (cccompose g)) fl. - Next Obligation. - intros ? ? ? ? ? ? ? ?. - apply later_ap_ne. - now do 2 f_equiv. - Defined. - Next Obligation. - intros ? ? ? ? [x] [y] H ?; simpl. - apply Next_contractive. - destruct n as [| n]. - - apply dist_later_0. - - apply dist_later_S. - f_equiv. - apply H; constructor. - Defined. + Proof. solve_contractive. Qed. Program Definition ITvis_rec (self : prodO (IT E A -n> P) (P -n> IT E A)) : - sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) P) (prodO ((laterO (P -n> P))) (oFunctor_apply (Outs (E op)) P -n> laterO P))) -n> IT E A + sigTO (λ op : opid E, prodO (oFunctor_apply (Ins (E op)) P) (oFunctor_apply (Outs (E op)) P -n> laterO P)) -n> IT E A := λne x, let op := projT1 x in let inp := fst (projT2 x) in - let outp1 := fst (snd (projT2 x)) in - let outp2 := snd (snd (projT2 x)) in + let outp := snd (projT2 x) in let self1 : IT E A -n> P := fst self in let self2 : P -n> IT E A := snd self in - let s_in := oFunctor_map (Ins (E op)) (self1, self2) in - let s_out := oFunctor_map (Outs (E op)) (self2, self1) in - Vis op (s_in inp) (laterO_precompose self1 (laterO_postcompose outp1 self2)) (laterO_map self2 ◎ outp2 ◎ s_out). + let s_in := oFunctor_map (Ins (E op)) (self1,self2) in + let s_out := oFunctor_map (Outs (E op)) (self2,self1) in + Vis op (s_in inp) (laterO_map self2 ◎ outp ◎ s_out). Next Obligation. intros (self1, self2) n x1 x2 Hx. destruct x1 as [R1 [q1 k1]]. @@ -529,17 +453,7 @@ Section IT_rec. simpl in *. subst. simpl in *. destruct Hx2 as [Hx1 Hx2]. simpl in *. - f_equiv. - - solve_proper. - - destruct k1 as [k1 k1']. - destruct k2 as [k2 k2']. - apply Next_contractive. - destruct n as [| n]. - + apply dist_later_0. - + apply dist_later_S. - do 2 f_equiv. - apply Hx2; constructor. - - solve_proper. + solve_proper. Qed. Instance ITvis_rec_contractive : Contractive ITvis_rec. Proof. solve_contractive. Qed. @@ -633,8 +547,20 @@ Section IT_rec. rewrite IT_unfold_fold; reflexivity. Qed. + Program Definition sandwich : (IT E A -n> IT E A) -n> sumO (IT E A) P -n> prodO (IT E A) P := + λne f, prod_in idfun IT_rec1 ◎ f ◎ sumO_rec idfun IT_rec2. + Next Obligation. solve_proper. Defined. + Program Definition unsandwich : (sumO (IT E A) P -n> prodO (IT E A) P) -n> IT E A -n> IT E A := + λne f, fstO ◎ f ◎ inlO. + Next Obligation. solve_proper. Defined. + + Lemma sandwich_unsandwich : + unsandwich ◎ sandwich ≡ idfun. + Proof. intros f x; reflexivity. Qed. + + Lemma IT_rec1_fun f : - IT_rec1 (Fun f) ≡ Parr (laterO_map (sandwich IT_rec1 IT_rec2) f). + IT_rec1 (Fun f) ≡ Parr (laterO_map sandwich f). Proof. rewrite IT_rec1_unfold. rewrite /IT_rec_pre. @@ -646,35 +572,11 @@ Section IT_rec. destruct x as [x|x]; simpl; eauto. Qed. - Program Definition sumO_rec' {A B C : ofe} : (A -n> C) -n> (B -n> C) -n> sumO A B -n> C := - λne f g x, sumO_rec f g x. - Next Obligation. - intros. intros x y Hxy. simpl. - destruct x as [a1|b1], y as [a2|b2]; try by inversion Hxy. - - apply inl_ne_inj in Hxy. by f_equiv. - - apply inr_ne_inj in Hxy. by f_equiv. - Qed. - Next Obligation. - intros ? ? ? f1 ? g1 g2 ? H; simpl; destruct H as [x|y]; simpl; eauto. - Qed. - Next Obligation. - intros ? ? ? ? g1 g2 ? f H; simpl; destruct H as [x|y]; simpl; eauto. - Qed. - - (* Program Definition factor_map : *) - (* (IT E A -n> IT E A) -n> (sumO (IT E A) P -n> prodO (IT E A) P) *) - (* := (λne f : IT E A -n> IT E A, (prod_in idfun IT_rec1) ◎ f ◎ sumO_rec idfun IT_rec2). *) - (* Next Obligation. *) - (* solve_proper. *) - (* Defined. *) - - Lemma IT_rec1_vis op i k j : - let s_in := oFunctor_map (Ins (E op)) (sumO_rec idfun IT_rec2, prod_in idfun IT_rec1) in - let s_out := oFunctor_map (Outs (E op)) (prod_in idfun IT_rec1, sumO_rec idfun IT_rec2) in - IT_rec1 (Vis op i k j) ≡ - Pvis op (s_in i) - (laterO_map (sandwich IT_rec1 IT_rec2) k) - (laterO_map (prod_in idfun IT_rec1) ◎ j ◎ s_out). + Lemma IT_rec1_vis op i k : + let s_in := oFunctor_map (Ins (E op)) (sumO_rec idfun IT_rec2,prod_in idfun IT_rec1) in + let s_out := oFunctor_map (Outs (E op)) (prod_in idfun IT_rec1,sumO_rec idfun IT_rec2) in + IT_rec1 (Vis op i k) ≡ + Pvis op (s_in i) (laterO_map (prod_in idfun IT_rec1) ◎ k ◎ s_out). Proof. simpl. rewrite IT_rec1_unfold. unfold IT_rec_pre. cbn-[sumO_rec]. @@ -683,9 +585,8 @@ Section IT_rec. Qed. End IT_rec. - Arguments IT_rec {_ _ _} P {_ _} _ _ _ _ _ _. -Arguments sandwich {_ _ _ _}. +Arguments sandwich {_ _ _} _ {_ _ _ _ _ _ _ _}. (* exercise: show that every P with the properties above must have a bottom element and that it_rec maps bottom to bottom *) (** XXX ***) Opaque prod_in. @@ -694,24 +595,14 @@ Global Instance Pvis_rec_ne {E A} `{!Cofe A} {P: ofe} `{!Cofe P, !Inhabited P} n Proper ((forall_relation (λ _, (dist n))) ==> (dist_later n) ==> (dist n)) (Pvis_rec (E:=E) (A:=A) P). Proof. intros v1 v2 Hv [h1 h2] [g1 g2] Hhg. - intros [op [i [k j]]]. + intros [op [i k]]. unfold Pvis_rec. simpl. specialize (Hv op). simpl in Hv. f_equiv; eauto. - - f_equiv. - + f_equiv; [assumption |]. - apply opInterp_ins_contractive; eauto. - destruct n; first by eauto using dist_later_0. - apply dist_later_S. apply dist_later_S in Hhg. simpl in *; destruct Hhg; split; simpl; f_equiv; eauto. - + apply laterO_map_contractive. - destruct n; first by eauto using dist_later_0. - apply dist_later_S. apply dist_later_S in Hhg. simpl in *; destruct Hhg; intros ? t; split; simpl; f_equiv; eauto. - * f_equiv; [solve_proper |]. - f_equiv. - destruct t as [t | t]; solve_proper. - * f_equiv; [solve_proper |]. - f_equiv. - destruct t as [t | t]; solve_proper. + - f_equiv; eauto. + apply opInterp_ins_contractive; eauto. + destruct n; first by eauto using dist_later_0. + apply dist_later_S. apply dist_later_S in Hhg. simpl in *; destruct Hhg; split; simpl; f_equiv; eauto. - intro a. simpl. repeat (f_contractive || f_equiv); simpl in *; destruct Hhg; eauto. Qed. @@ -719,14 +610,9 @@ Qed. Proper ((forall_relation (λ _, (equiv))) ==> (equiv) ==> (equiv)) (Pvis_rec (E:=E) (A:=A) P). Proof. intros v1 v2 Hv [h1 h2] [g1 g2] [Hhg1 Hhg2]. - intros [op [i [k j]]]. + intros [op [i k]]. unfold Pvis_rec. simpl. - specialize (Hv op). simpl in Hv. - do 3 f_equiv; try solve_proper. - f_equiv. - intros f. - simpl in *. - do 2 f_equiv; solve_proper. + specialize (Hv op). simpl in Hv. solve_proper. Qed. (** XXX ***) Transparent prod_in. @@ -876,8 +762,8 @@ Section ticks. Lemma IT_fun_tick_ne f α {PROP : bi} `{!BiInternalEq PROP} : (Fun f ≡ Tick α ⊢ False : PROP)%I. Proof. apply IT_fun_tau_ne. Qed. - Lemma IT_tick_vis_ne α op i k j {PROP : bi} `{!BiInternalEq PROP} : - (Tick α ≡ Vis op i k j ⊢ False : PROP)%I. + Lemma IT_tick_vis_ne α op i k {PROP : bi} `{!BiInternalEq PROP} : + (Tick α ≡ Vis op i k ⊢ False : PROP)%I. Proof. apply IT_tau_vis_ne. Qed. Lemma IT_tick_err_ne α e {PROP : bi} `{!BiInternalEq PROP} : (Tick α ≡ Err e ⊢ False : PROP)%I. @@ -908,19 +794,19 @@ Section ticks. ∨ (∃ n, α ≡ Ret n) ∨ (∃ f, α ≡ Fun f) ∨ (∃ β, α ≡ Tick β) - ∨ (∃ op i k j, α ≡ Vis op i k j). + ∨ (∃ op i k, α ≡ Vis op i k). Proof. remember (IT_unfold α) as ua. assert (IT_fold ua ≡ α) as Hfold. { rewrite Hequa. apply IT_fold_unfold. } - destruct ua as [ [ [ [ n | f ] | e ] | la ] | [op [i [k j]] ]]. + destruct ua as [ [ [ [ n | f ] | e ] | la ] | [op [i k] ]]. - right. left. exists n. done. - right. right. left. exists f. done. - left. exists e. done. - right. right. right. left. destruct (Next_uninj la) as [β Hb]. exists β. rewrite -Hfold Hb. done. - - right. right. right. right. exists op,i,k,j. done. + - right. right. right. right. exists op,i,k. done. Qed. Lemma IT_dont_confuse' (α : IT) {PROP : bi} `{!BiInternalEq PROP} : @@ -928,20 +814,20 @@ Section ticks. ∨ (∃ n, α ≡ Ret n) ∨ (∃ f, α ≡ Fun f) ∨ (∃ β, α ≡ Tick β) - ∨ (∃ op i k j, α ≡ Vis op i k j) + ∨ (∃ op i k, α ≡ Vis op i k) : PROP)%I. Proof. remember (IT_unfold α) as ua. assert (IT_fold ua ≡ α) as Hfold. { rewrite Hequa. apply IT_fold_unfold. } - destruct ua as [ [ [ [ n | f ] | e ] | la ] | [op [i [k j]] ]]. + destruct ua as [ [ [ [ n | f ] | e ] | la ] | [op [i k] ]]. - iRight. iLeft. iExists n. done. - iRight. iRight. iLeft. iExists f. done. - iLeft. iExists e. done. - iRight. iRight. iRight. iLeft. destruct (Next_uninj la) as [β Hb]. iExists β. rewrite -Hfold Hb. done. - - iRight. iRight. iRight. iRight. iExists op,i,k,j. done. + - iRight. iRight. iRight. iRight. iExists op,i,k. done. Qed. End ticks. @@ -1096,7 +982,7 @@ Section ITV. Program Definition None1 {A B} : A -n> optionO B := λne _, None. - Program Definition None2 {A B C D} : A -n> B -n> C -n> optionO D := λne _ _ _, None. + Program Definition None2 {A B C} : A -n> B -n> optionO C := λne _ _, None. Program Definition SomeO {A} : A -n> optionO A := OfeMor Some. Program Definition IT_to_V : IT -n> optionO ITV @@ -1127,7 +1013,7 @@ Section ITV. Proof. apply IT_rec1_tau. Qed. Lemma IT_to_V_Tick α : IT_to_V (Tick α) ≡ None. Proof. apply IT_to_V_Tau. Qed. - Lemma IT_to_V_Vis op i k j : IT_to_V (Vis op i k j) ≡ None. + Lemma IT_to_V_Vis op i k : IT_to_V (Vis op i k) ≡ None. Proof. apply IT_rec1_vis. Qed. Lemma IT_to_of_V v : IT_to_V (IT_of_V v) ≡ Some v. @@ -1157,7 +1043,7 @@ Section ITV. - iDestruct "Ha" as (lf) "Ha". iRewrite "Ha" in "H". rewrite IT_to_V_Tau. iPoseProof (option_equivI with "H") as "H". done. - - iDestruct "Ha" as (op i k j) "Ha". + - iDestruct "Ha" as (op i k) "Ha". iRewrite "Ha" in "H". rewrite IT_to_V_Vis. iPoseProof (option_equivI with "H") as "H". done. Qed. @@ -1165,7 +1051,7 @@ Section ITV. Lemma IT_of_to_V' α v : IT_to_V α ≡ Some v → IT_of_V v ≡ α. Proof. destruct (IT_dont_confuse α) - as [[e Ha2] | [[m Ha2] | [ [g Ha2] | [[la Ha2]|[op [i [k [j Ha2]]]]] ]]]. + as [[e Ha2] | [[m Ha2] | [ [g Ha2] | [[la Ha2]|[op [i [k Ha2]]]] ]]]. all: rewrite Ha2. - rewrite IT_to_V_Err. rewrite option_equiv_Forall2. inversion 1. @@ -1186,7 +1072,7 @@ Section ITV. Lemma IT_to_V_None α {PROP : bi} `{!BiInternalEq PROP} : (IT_to_V α ≡ None ⊢ (∃ e, α ≡ Err e) ∨ (∃ β, α ≡ Tick β) - ∨ (∃ op i k j, α ≡ Vis op i k j) + ∨ (∃ op i k, α ≡ Vis op i k) : PROP)%I. Proof. iIntros "H". @@ -1233,13 +1119,10 @@ Section IT_destructors. (** Don't touch the input, but recuse on the result of the continuation, this should be called Vis_iter or something *) Program Definition Vis_ (op : opid E) : (oFunctor_car (Ins (E op)) (sumO IT IT) (prodO IT IT)) -n> - laterO (sumO IT IT -n> prodO IT IT) -n> ((oFunctor_car (Outs (E op)) (prodO IT IT) (sumO IT IT)) -n> laterO (prodO IT IT)) -n> IT - := λne i k j, Vis op + := λne i k, Vis op (oFunctor_map _ (inlO,fstO) i) - (laterO_map (unsandwich _) k) - (laterO_map sndO ◎ j ◎ oFunctor_map _ (fstO,inlO)). - Next Obligation. solve_proper. Qed. + (laterO_map sndO ◎ k ◎ oFunctor_map _ (fstO,inlO)). Next Obligation. solve_proper. Qed. Next Obligation. solve_proper. Qed. @@ -1342,7 +1225,7 @@ Section IT_destructors. induction n; first reflexivity. rewrite get_ret_tick. by rewrite IHn. Qed. - Lemma get_ret_vis f op i k j : get_ret f (Vis op i k j) ≡ Vis op i k (laterO_map (get_ret f) ◎ j). + Lemma get_ret_vis f op i k : get_ret f (Vis op i k) ≡ Vis op i (laterO_map (get_ret f) ◎ k). Proof. rewrite IT_rec1_vis. cbn-[prod_in]. f_equiv. - rewrite -oFunctor_map_compose. @@ -1350,8 +1233,6 @@ Section IT_destructors. repeat f_equiv. + intro x. reflexivity. + intro x. reflexivity. - - intros x. cbn-[prod_in]. - f_equal. - intros x. cbn-[prod_in]. rewrite -laterO_map_compose. rewrite -oFunctor_map_compose. @@ -1395,7 +1276,7 @@ Section IT_destructors. induction n; first reflexivity. rewrite get_val_tick. by rewrite IHn. Qed. - Lemma get_val_vis f op i k j : get_val f (Vis op i k j) ≡ Vis op i k (laterO_map (get_val f) ◎ j). + Lemma get_val_vis f op i k : get_val f (Vis op i k) ≡ Vis op i (laterO_map (get_val f) ◎ k). Proof. rewrite IT_rec1_vis. cbn-[prod_in]. f_equiv. - rewrite -oFunctor_map_compose. @@ -1403,8 +1284,6 @@ Section IT_destructors. repeat f_equiv. + intro x. reflexivity. + intro x. reflexivity. - - intros x. cbn-[prod_in]. - f_equal. - intros x. cbn-[prod_in]. rewrite -laterO_map_compose. rewrite -oFunctor_map_compose. @@ -1430,7 +1309,7 @@ Section IT_destructors. Lemma get_fun_ret f n : get_fun f (Ret n) ≡ Err RuntimeErr. Proof. by rewrite IT_rec1_ret. Qed. - Lemma get_fun_vis f op i k j : get_fun f (Vis op i k j) ≡ Vis op i k (laterO_map (get_fun f) ◎ j). + Lemma get_fun_vis f op i k : get_fun f (Vis op i k) ≡ Vis op i (laterO_map (get_fun f) ◎ k). Proof. rewrite IT_rec1_vis. cbn-[prod_in]. f_equiv. - rewrite -oFunctor_map_compose. @@ -1438,7 +1317,6 @@ Section IT_destructors. repeat f_equiv. + intro x. reflexivity. + intro x. reflexivity. - - intros x; f_equal. - intros x. cbn-[prod_in]. rewrite -laterO_map_compose. rewrite -oFunctor_map_compose. @@ -1476,7 +1354,7 @@ Section it_hom. Class IT_hom (f : IT → IT) := IT_HOM { hom_ne :: NonExpansive f; hom_tick: ∀ α, f (Tick α) ≡ Tick (f α); - hom_vis : ∀ op i ko jo, f (Vis op i ko jo) ≡ Vis op i ko (laterO_map (OfeMor f) ◎ jo); + hom_vis : ∀ op i ko, f (Vis op i ko) ≡ Vis op i (laterO_map (OfeMor f) ◎ ko); hom_err : ∀ e, f (Err e) ≡ Err e }. #[export] Instance IT_hom_proper f `{!IT_hom f} : Proper ((≡) ==> (≡)) f. @@ -1486,14 +1364,14 @@ Section it_hom. Proof. intros Hf Hg. simple refine (IT_HOM _ _ _ _ _). - intros a. simpl. rewrite !hom_tick//. - - intros op i k j. simpl. rewrite !hom_vis//. + - intros op i k. simpl. rewrite !hom_vis//. f_equiv. intro x. simpl. rewrite -laterO_map_compose//. - intro e. cbn-[Err]. rewrite !hom_err//. Qed. #[export] Instance IT_hom_idfun : IT_hom idfun. Proof. simple refine (IT_HOM _ _ _ _ _); simpl; eauto. - intros op i k j. f_equiv. intro x. simpl. + intros op i k. f_equiv. intro x. simpl. by rewrite laterO_map_id. Qed. @@ -1507,7 +1385,7 @@ Section it_hom. is_Some (IT_to_V (f α)) → is_Some (IT_to_V α). Proof. destruct (IT_dont_confuse α) - as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k [j Ha]]]]] ]]]. + as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. - rewrite Ha hom_err. rewrite IT_to_V_Err. done. - rewrite Ha IT_to_V_Ret. done. - rewrite Ha IT_to_V_Fun. done. From 361676848eb6584867aad7caece14e9438ae9633 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 1 Nov 2023 16:09:45 +0100 Subject: [PATCH 005/114] revert --- theories/gitree/reify.v | 158 +++++++++++----------------------------- 1 file changed, 43 insertions(+), 115 deletions(-) diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 37d87f3..63be7d0 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -11,7 +11,7 @@ Section reifiers. { sReifier_ops : opsInterp; sReifier_state : oFunctor; sReifier_re {X} `{!Cofe X} : forall (op : opid sReifier_ops), - (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) * (laterO (X -n> X)) + (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) -n> optionO ((Outs (sReifier_ops op) ♯ X) * (sReifier_state ♯ X)); sReifier_inhab :: Inhabited (sReifier_state ♯ unitO); sReifier_cofe X (HX : Cofe X) :: Cofe (sReifier_state ♯ X); @@ -46,23 +46,19 @@ Section reifiers. Solve All Obligations with solve_proper. Program Definition reify_vis ( op : opid F ) : - oFunctor_car (Ins (F op)) (sumO IT stateM) (prodO IT stateM) -n> - (laterO (sumO IT (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) -n> - prodO IT (stateF ♯ IT -n> prodO (stateF ♯ IT) IT))) -n> + oFunctor_car (Ins (F op)) (sumO IT stateM) (prodO IT stateM) -n> (oFunctor_car (Outs (F op)) (prodO IT stateM) (sumO IT stateM) -n> laterO (prodO IT stateM)) -n> stateM. Proof. simpl. - simple refine (λne i j (k : _ -n> _) (s : stateF ♯ IT), _). - - simple refine (let ns := sReifier_re r op ((oFunctor_map _ (inlO, fstO) i, s), _) in _). - + simple refine (laterO_map (unsandwich _) j). - + simple refine (from_option (λ ns, - let out2' := k $ oFunctor_map (Outs (F op)) (fstO, inlO) ns.1 in - (ns.2, Tau $ laterO_map fstO out2')) - (s, Err RuntimeErr) ns). + simple refine (λne i (k : _ -n> _) (s : stateF ♯ IT), _). + - simple refine (let ns := sReifier_re r op (oFunctor_map _ (inlO,fstO) i, s) in _). + simple refine (from_option (λ ns, + let out2' := k $ oFunctor_map (Outs (F op)) (fstO,inlO) ns.1 in + (ns.2, Tau $ laterO_map fstO out2')) + (s, Err RuntimeErr) ns). - intros m s1 s2 Hs. simpl. eapply (from_option_ne (dist m)); solve_proper. - intros m k1 k2 Hk s. simpl. eapply (from_option_ne (dist m)); solve_proper. - intros m i1 i2 Hi k s. simpl. eapply (from_option_ne (dist m)); solve_proper. - - intros m i1 i2 Hi k j s. simpl. eapply (from_option_ne (dist m)); solve_proper. Defined. Program Definition reify_err : errorO -n> stateM := λne e s, (s, Err e). @@ -72,18 +68,8 @@ Section reifiers. Solve All Obligations with solve_proper. Program Definition unr : stateM -n> - sumO - (sumO - (sumO - (sumO A (laterO (stateM -n> stateM))) errorO) - (laterO stateM)) - (sigTO (λ op : opid F, - prodO (oFunctor_apply (Ins (F op)) stateM) - (prodO (laterO - ((stateF ♯ IT -n> prodO (stateF ♯ IT) IT) -n> - stateF ♯ IT -n> prodO (stateF ♯ IT) IT)) - (oFunctor_apply (Outs (F op)) stateM -n> - laterO stateM)))). + sumO (sumO (sumO (sumO A (laterO (stateM -n> stateM))) errorO) (laterO stateM)) + (sigTO (λ op : opid F, prodO (oFunctor_apply (Ins (F op)) stateM) (oFunctor_apply (Outs (F op)) stateM -n> laterO stateM))). Proof. simple refine (λne d, inl (inl (inr (RuntimeErr)))). Qed. Definition reify : IT -n> stateM @@ -107,14 +93,10 @@ Section reifiers. reify (Fun f) σ ≡ (σ, Fun f). Proof. rewrite /reify/=. - trans (reify_fun (laterO_map - (sandwich - (IT_rec1 (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) - reify_err reify_ret reify_fun - reify_tau reify_vis unr) - (IT_rec2 (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) - reify_err reify_ret reify_fun - reify_tau reify_vis unr)) f) σ). + trans (reify_fun (laterO_map (sandwich (Perr:=reify_err) (Pret:=reify_ret) + (Parr:=reify_fun) (Ptau:=reify_tau) + (Pvis:=reify_vis) (Punfold:=unr) + stateM) f) σ). { f_equiv. apply IT_rec1_fun. } simpl. repeat f_equiv. rewrite -laterO_map_compose. @@ -123,44 +105,26 @@ Section reifiers. apply laterO_map_id. Qed. - Lemma reify_vis_dist m op i o k j σ σ' : - sReifier_re r op ((i, σ), k) ≡{m}≡ Some (o, σ') → - reify (Vis op i k j) σ ≡{m}≡ (σ', Tau $ j o). + Lemma reify_vis_dist m op i o k σ σ' : + sReifier_re r op (i,σ) ≡{m}≡ Some (o,σ') → + reify (Vis op i k) σ ≡{m}≡ (σ', Tau $ k o). Proof. intros Hst. trans (reify_vis op - (oFunctor_map _ (sumO_rec idfun unreify, prod_in idfun reify) i) - (laterO_map (sandwich (IT_rec1 - (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) - reify_err - reify_ret - reify_fun - reify_tau - reify_vis - unr) - (IT_rec2 - (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) - reify_err - reify_ret - reify_fun - reify_tau - reify_vis - unr)) k) - (laterO_map (prod_in idfun reify) ◎ j ◎ (oFunctor_map _ (prod_in idfun reify, sumO_rec idfun unreify))) + (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) + (laterO_map (prod_in idfun reify) ◎ k ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) σ). { f_equiv. rewrite IT_rec1_vis//. } Opaque prod_in. simpl. - pose (rs := sReifier_re r op ((oFunctor_map (Ins (F op)) (inlO, fstO) - (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ), k)). + pose (rs := (sReifier_re r op + (oFunctor_map (Ins (F op)) (inlO, fstO) + (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). fold rs. - assert (rs ≡ sReifier_re r op (i, σ, k)) as Hr'. - { - unfold rs. f_equiv. f_equiv. + assert (rs ≡ sReifier_re r op (i,σ)) as Hr'. + { unfold rs. f_equiv. f_equiv. rewrite -oFunctor_map_compose. - repeat f_equiv. etrans; last by apply oFunctor_map_id. - repeat f_equiv; intro; done. - } + repeat f_equiv; intro; done. } assert (rs ≡{m}≡ Some (o,σ')) as Hr. { by rewrite Hr' Hst. } trans (from_option (λ ns, @@ -168,27 +132,15 @@ Section reifiers. Tau (laterO_map fstO (laterO_map (prod_in idfun reify) - (j + (k (oFunctor_map (Outs (F op)) (prod_in idfun reify, sumO_rec idfun unreify) (oFunctor_map (Outs (F op)) (fstO, inlO) ns.1))))))) (σ, Err RuntimeErr) (Some (o,σ'))). - { - eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. - rewrite <-Hr. - subst rs. - repeat f_equiv. - rewrite -laterO_map_compose. - trans (laterO_map idfun k); last by rewrite laterO_map_id. - do 2 f_equiv. - intros x y; simpl. - Transparent prod_in. - unfold prod_in; simpl. - reflexivity. - } + { eapply (from_option_ne (dist m)); solve_proper. } simpl. repeat f_equiv. rewrite -laterO_map_compose. rewrite -oFunctor_map_compose. - trans (laterO_map idfun (j o)); last first. + trans (laterO_map idfun (k o)); last first. { by rewrite laterO_map_id. } repeat f_equiv. { intro; done. } @@ -198,48 +150,33 @@ Section reifiers. repeat f_equiv; intro; done. Qed. - Lemma reify_vis_eq op i o k j σ σ' : - sReifier_re r op (i, σ, k) ≡ Some (o, σ') → - reify (Vis op i k j) σ ≡ (σ', Tau $ j o). + Lemma reify_vis_eq op i o k σ σ' : + sReifier_re r op (i,σ) ≡ Some (o,σ') → + reify (Vis op i k) σ ≡ (σ', Tau $ k o). Proof. intros H. apply equiv_dist=>m. apply reify_vis_dist. by apply equiv_dist. Qed. - Lemma reify_vis_None op i k j σ : - sReifier_re r op (i, σ, k) ≡ None → - reify (Vis op i k j) σ ≡ (σ, Err RuntimeErr). + Lemma reify_vis_None op i k σ : + sReifier_re r op (i,σ) ≡ None → + reify (Vis op i k) σ ≡ (σ, Err RuntimeErr). Proof. intros Hs. trans (reify_vis op (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) - (laterO_map (sandwich (IT_rec1 - (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) - reify_err - reify_ret - reify_fun - reify_tau - reify_vis - unr) - (IT_rec2 - (stateF ♯ IT -n> prodO (stateF ♯ IT) IT) - reify_err - reify_ret - reify_fun - reify_tau - reify_vis - unr)) k) - (laterO_map (prod_in idfun reify) ◎ j ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) + (laterO_map (prod_in idfun reify) ◎ k ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) σ). { f_equiv. apply IT_rec1_vis. } simpl. - pose (rs := sReifier_re r op ((oFunctor_map (Ins (F op)) (inlO, fstO) - (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ), k)). + pose (rs := (sReifier_re r op + (oFunctor_map (Ins (F op)) (inlO, fstO) + (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). fold rs. - assert (rs ≡ sReifier_re r op (i,σ,k)) as Hr'. - { unfold rs. f_equiv. f_equiv. f_equiv. + assert (rs ≡ sReifier_re r op (i,σ)) as Hr'. + { unfold rs. f_equiv. f_equiv. rewrite -oFunctor_map_compose. etrans; last by apply oFunctor_map_id. repeat f_equiv; intro; done. } @@ -250,21 +187,11 @@ Section reifiers. Tau (laterO_map fstO (laterO_map (prod_in idfun reify) - (j + (k (oFunctor_map (Outs (F op)) (prod_in idfun reify, sumO_rec idfun unreify) (oFunctor_map (Outs (F op)) (fstO, inlO) ns.1))))))) (σ, Err RuntimeErr) None). - { apply from_option_proper; [solve_proper | solve_proper |]. - rewrite <-Hr. - subst rs. - repeat f_equiv. - - reflexivity. - - rewrite -laterO_map_compose. - trans (laterO_map idfun k); last by rewrite laterO_map_id. - do 2 f_equiv. - intros x y; simpl. - reflexivity. - } + { apply from_option_proper; solve_proper. } reflexivity. Qed. @@ -338,3 +265,4 @@ Section reifiers. Qed. End reifiers. + From 277b50944630a81b7af0b872377115f61852e654 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Fri, 3 Nov 2023 10:17:50 +0100 Subject: [PATCH 006/114] reifiers change --- _CoqProject | 1 + theories/gitree/greifiers.v | 256 ++++---- theories/gitree/reductions.v | 219 ++++--- theories/gitree/reify.v | 215 ++++--- theories/gitree/weakestpre.v | 364 +++++------ theories/input_lang/interp.v | 1099 ++++++++++++++++++++-------------- theories/input_lang/lang.v | 12 +- theories/lang_generic.v | 84 +-- theories/lang_generic_sem.v | 224 ++++--- 9 files changed, 1372 insertions(+), 1102 deletions(-) diff --git a/_CoqProject b/_CoqProject index 074125a..5c14b03 100644 --- a/_CoqProject +++ b/_CoqProject @@ -15,6 +15,7 @@ vendor/Binding/Env.v theories/prelude.v theories/lang_generic.v +theories/lang_generic_sem.v theories/gitree/core.v theories/gitree/subofe.v diff --git a/theories/gitree/greifiers.v b/theories/gitree/greifiers.v index 6e224d7..ba07b0b 100644 --- a/theories/gitree/greifiers.v +++ b/theories/gitree/greifiers.v @@ -115,17 +115,18 @@ Section greifiers. Program Definition gReifiers_re {n} (rs : gReifiers n) {X} `{!Cofe X} (op : opid (gReifiers_ops rs)) : - (Ins (gReifiers_ops rs op) ♯ X) * (gReifiers_state rs ♯ X) -n> + (Ins (gReifiers_ops rs op) ♯ X) * (gReifiers_state rs ♯ X) * ((Outs (gReifiers_ops rs op) ♯ X) -n> laterO X) -n> optionO ((Outs (gReifiers_ops rs op) ♯ X) * (gReifiers_state rs ♯ X)) := λne xst, let i := projT1 op in let op' := projT2 op in - let x := xst.1 in - let st := xst.2 in - let fs := gState_decomp i st in + let a := xst.1.1 in + let b := xst.1.2 in + let c := xst.2 in + let fs := gState_decomp i b in let σ := fs.1 in let rest := fs.2 in - let rx := sReifier_re (rs !!! i) op' (x, σ) in + let rx := sReifier_re (rs !!! i) op' (a, σ, c) in optionO_map (prodO_map idfun (gState_recomp rest)) rx. Next Obligation. solve_proper_please. Qed. @@ -136,103 +137,104 @@ Section greifiers. sReifier_re := @gReifiers_re n rs; |}. - Lemma gReifiers_re_idx {n} (i : fin n) (rs : gReifiers n) - {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) - (x : Ins (sReifier_ops _ op) ♯ X) - (σ : sReifier_state (rs !!! i) ♯ X) (rest : gState_rest i rs ♯ X) : - gReifiers_re rs (existT i op) (x, gState_recomp rest σ) ≡ - optionO_map (prodO_map idfun (gState_recomp rest)) - (sReifier_re (rs !!! i) op (x,σ)). - Proof. - unfold gReifiers_re. cbn-[prodO_map optionO_map]. - f_equiv; last repeat f_equiv. - - eapply optionO_map_proper. - intros [x1 x2]; simpl. f_equiv. - f_equiv. f_equiv. - rewrite gState_decomp_recomp//. - - rewrite gState_decomp_recomp//. - Qed. + (* Lemma gReifiers_re_idx {n} (i : fin n) (rs : gReifiers n) *) + (* {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) *) + (* (x : Ins (sReifier_ops _ op) ♯ X) *) + (* (σ : sReifier_state (rs !!! i) ♯ X) (rest : gState_rest i rs ♯ X) : *) + (* gReifiers_re rs (existT i op) (x, gState_recomp rest σ) ≡ *) + (* optionO_map (prodO_map idfun (gState_recomp rest)) *) + (* (sReifier_re (rs !!! i) op (x,σ)). *) + (* Proof. *) + (* unfold gReifiers_re. cbn-[prodO_map optionO_map]. *) + (* f_equiv; last repeat f_equiv. *) + (* - eapply optionO_map_proper. *) + (* intros [x1 x2]; simpl. f_equiv. *) + (* f_equiv. f_equiv. *) + (* rewrite gState_decomp_recomp//. *) + (* - rewrite gState_decomp_recomp//. *) + (* Qed. *) - Class subReifier {n} (r : sReifier) (rs : gReifiers n) := - { sR_idx : fin n; - sR_ops :: subEff (sReifier_ops r) (sReifier_ops (rs !!! sR_idx)); - sR_state {X} `{!Cofe X} : - sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X; - sR_re (m : nat) {X} `{!Cofe X} (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) - (y : Outs (sReifier_ops _ op) ♯ X) - (s1 s2 : sReifier_state r ♯ X) : - sReifier_re r op (x, s1) ≡{m}≡ Some (y, s2) → - sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1) ≡{m}≡ - Some (subEff_outs y, sR_state s2) }. + (* Class subReifier {n} (r : sReifier) (rs : gReifiers n) := *) + (* { sR_idx : fin n; *) + (* sR_ops :: subEff (sReifier_ops r) (sReifier_ops (rs !!! sR_idx)); *) + (* sR_state {X} `{!Cofe X} : *) + (* sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X; *) + (* sR_re (m : nat) {X} `{!Cofe X} (op : opid (sReifier_ops r)) *) + (* (x : Ins (sReifier_ops _ op) ♯ X) *) + (* (y : Outs (sReifier_ops _ op) ♯ X) *) + (* (s1 s2 : sReifier_state r ♯ X) *) + (* (k : (Outs (sReifier_ops _ op) ♯ X -n> laterO X)) : *) + (* sReifier_re r op (x, s1, k) ≡{m}≡ Some (y, s2) → *) + (* sReifier_re (rs !!! sR_idx) (subEff_opid op) *) + (* (subEff_ins x, sR_state s1, _) ≡{m}≡ *) + (* Some (subEff_outs y, sR_state s2) }. *) - #[global] Instance subReifier_here {n} (r : sReifier) (rs : gReifiers n) : - subReifier r (gReifiers_cons r rs). - Proof. - simple refine ({| sR_idx := 0%fin |}). - - simpl. apply subEff_id. - - simpl. intros. apply iso_ofe_refl. - - intros X ? op x y s1 s2. - simpl. eauto. - Defined. - #[global] Instance subReifier_there {n} (r r' : sReifier) (rs : gReifiers n) : - subReifier r rs → - subReifier r (gReifiers_cons r' rs). - Proof. - intros SR. - simple refine ({| sR_idx := FS sR_idx |}). - - simpl. intros. apply sR_state. - - intros X ? op x y s1 s2. - simpl. apply sR_re. - Defined. + (* #[global] Instance subReifier_here {n} (r : sReifier) (rs : gReifiers n) : *) + (* subReifier r (gReifiers_cons r rs). *) + (* Proof. *) + (* simple refine ({| sR_idx := 0%fin |}). *) + (* - simpl. apply subEff_id. *) + (* - simpl. intros. apply iso_ofe_refl. *) + (* - intros X ? op x y s1 s2. *) + (* simpl. eauto. *) + (* Defined. *) + (* #[global] Instance subReifier_there {n} (r r' : sReifier) (rs : gReifiers n) : *) + (* subReifier r rs → *) + (* subReifier r (gReifiers_cons r' rs). *) + (* Proof. *) + (* intros SR. *) + (* simple refine ({| sR_idx := FS sR_idx |}). *) + (* - simpl. intros. apply sR_state. *) + (* - intros X ? op x y s1 s2. *) + (* simpl. apply sR_re. *) + (* Defined. *) - #[local] Definition subR_op {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : - opid (sReifier_ops r) → opid (gReifiers_ops rs). - Proof. - intros op. - simpl. - refine (existT sR_idx (subEff_opid op)). - Defined. - #[export] Instance subReifier_subEff {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : - subEff (sReifier_ops r) (gReifiers_ops rs). - Proof. - simple refine {| subEff_opid := subR_op |}. - - intros op X ?. simpl. - apply subEff_ins. - - intros op X ?. simpl. - apply subEff_outs. - Defined. + (* #[local] Definition subR_op {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : *) + (* opid (sReifier_ops r) → opid (gReifiers_ops rs). *) + (* Proof. *) + (* intros op. *) + (* simpl. *) + (* refine (existT sR_idx (subEff_opid op)). *) + (* Defined. *) + (* #[export] Instance subReifier_subEff {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : *) + (* subEff (sReifier_ops r) (gReifiers_ops rs). *) + (* Proof. *) + (* simple refine {| subEff_opid := subR_op |}. *) + (* - intros op X ?. simpl. *) + (* apply subEff_ins. *) + (* - intros op X ?. simpl. *) + (* apply subEff_outs. *) + (* Defined. *) - Lemma subReifier_reify_idx {n} (r : sReifier) (rs : gReifiers n) - `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) - (y : Outs (sReifier_ops _ op) ♯ X) - (s1 s2 : sReifier_state r ♯ X) : - sReifier_re r op (x, s1) ≡ Some (y, s2) → - sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1) ≡ - Some (subEff_outs y, sR_state s2). - Proof. - intros Hx. apply equiv_dist=>m. - apply sR_re. by apply equiv_dist. - Qed. + (* Lemma subReifier_reify_idx {n} (r : sReifier) (rs : gReifiers n) *) + (* `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) *) + (* (x : Ins (sReifier_ops _ op) ♯ X) *) + (* (y : Outs (sReifier_ops _ op) ♯ X) *) + (* (s1 s2 : sReifier_state r ♯ X) : *) + (* sReifier_re r op (x, s1) ≡ Some (y, s2) → *) + (* sReifier_re (rs !!! sR_idx) (subEff_opid op) *) + (* (subEff_ins x, sR_state s1) ≡ *) + (* Some (subEff_outs y, sR_state s2). *) + (* Proof. *) + (* intros Hx. apply equiv_dist=>m. *) + (* apply sR_re. by apply equiv_dist. *) + (* Qed. *) - Lemma subReifier_reify {n} (r : sReifier) - (rs : gReifiers n) `{!subReifier r rs} {X} `{!Cofe X} - (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) - (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : - sReifier_re r op (x,σ) ≡ Some (y, σ') → - gReifiers_re rs (subEff_opid op) - (subEff_ins x, gState_recomp rest (sR_state σ)) - ≡ Some (subEff_outs y, gState_recomp rest (sR_state σ')). - Proof. - intros Hre. - eapply subReifier_reify_idx in Hre. - rewrite gReifiers_re_idx//. - rewrite Hre. simpl. reflexivity. - Qed. + (* Lemma subReifier_reify {n} (r : sReifier) *) + (* (rs : gReifiers n) `{!subReifier r rs} {X} `{!Cofe X} *) + (* (op : opid (sReifier_ops r)) *) + (* (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) *) + (* (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : *) + (* sReifier_re r op (x,σ) ≡ Some (y, σ') → *) + (* gReifiers_re rs (subEff_opid op) *) + (* (subEff_ins x, gState_recomp rest (sR_state σ)) *) + (* ≡ Some (subEff_outs y, gState_recomp rest (sR_state σ')). *) + (* Proof. *) + (* intros Hre. *) + (* eapply subReifier_reify_idx in Hre. *) + (* rewrite gReifiers_re_idx//. *) + (* rewrite Hre. simpl. reflexivity. *) + (* Qed. *) (** Lemma for reasoning internally in iProp *) Context `{!invGS_gen hlc Σ}. @@ -242,40 +244,40 @@ Section greifiers. Notation sr := (gReifiers_sReifier rs). Lemma reify_vis_eqI {A} `{!Cofe A} op i k o σ σ' : - (gReifiers_re rs op (i,σ) ≡ Some (o,σ') ⊢@{iProp} reify sr (Vis op i k : IT _ A) σ ≡ (σ', Tau $ k o))%I. + (gReifiers_re rs op (i,σ,k) ≡ Some (o,σ') ⊢@{iProp} reify sr (Vis op i k : IT _ A) σ ≡ (σ', Tau $ k o))%I. Proof. apply uPred.internal_eq_entails=>m. intros H. apply reify_vis_dist. exact H. Qed. - Lemma subReifier_reify_idxI (r : sReifier) - `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) - (y : Outs (sReifier_ops _ op) ♯ X) - (s1 s2 : sReifier_state r ♯ X) : - sReifier_re r op (x, s1) ≡ Some (y, s2) ⊢@{iProp} - sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1) ≡ - Some (subEff_outs y, sR_state s2). - Proof. - apply uPred.internal_eq_entails=>m. - apply sR_re. - Qed. + (* Lemma subReifier_reify_idxI (r : sReifier) *) + (* `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) *) + (* (x : Ins (sReifier_ops _ op) ♯ X) *) + (* (y : Outs (sReifier_ops _ op) ♯ X) *) + (* (s1 s2 : sReifier_state r ♯ X) : *) + (* sReifier_re r op (x, s1) ≡ Some (y, s2) ⊢@{iProp} *) + (* sReifier_re (rs !!! sR_idx) (subEff_opid op) *) + (* (subEff_ins x, sR_state s1) ≡ *) + (* Some (subEff_outs y, sR_state s2). *) + (* Proof. *) + (* apply uPred.internal_eq_entails=>m. *) + (* apply sR_re. *) + (* Qed. *) - Lemma subReifier_reifyI (r : sReifier) - `{!subReifier r rs} {X} `{!Cofe X} - (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) - (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : - sReifier_re r op (x,σ) ≡ Some (y, σ') ⊢@{iProp} - gReifiers_re rs (subEff_opid op) - (subEff_ins x, gState_recomp rest (sR_state σ)) - ≡ Some (subEff_outs y, gState_recomp rest (sR_state σ')). - Proof. - apply uPred.internal_eq_entails=>m. - intros He. - eapply sR_re in He. - rewrite gReifiers_re_idx//. - rewrite He. simpl. reflexivity. - Qed. + (* Lemma subReifier_reifyI (r : sReifier) *) + (* `{!subReifier r rs} {X} `{!Cofe X} *) + (* (op : opid (sReifier_ops r)) *) + (* (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) *) + (* (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : *) + (* sReifier_re r op (x,σ) ≡ Some (y, σ') ⊢@{iProp} *) + (* gReifiers_re rs (subEff_opid op) *) + (* (subEff_ins x, gState_recomp rest (sR_state σ)) *) + (* ≡ Some (subEff_outs y, gState_recomp rest (sR_state σ')). *) + (* Proof. *) + (* apply uPred.internal_eq_entails=>m. *) + (* intros He. *) + (* eapply sR_re in He. *) + (* rewrite gReifiers_re_idx//. *) + (* rewrite He. simpl. reflexivity. *) + (* Qed. *) End greifiers. diff --git a/theories/gitree/reductions.v b/theories/gitree/reductions.v index fbb86f1..47e91c2 100644 --- a/theories/gitree/reductions.v +++ b/theories/gitree/reductions.v @@ -200,47 +200,47 @@ Section istep. iApply (IT_tick_vis_ne). by iApply (internal_eq_sym with "Ha"). Qed. - Local Lemma effect_safe_externalize (α : IT) σ : - (⊢ ∃ β σ', (∃ op i k, α ≡ Vis op i k ∧ reify r α σ ≡ (σ', Tick β)) : iProp) → - ∃ β σ', sstep r α σ β σ'. - Proof. - intros Hprf. - destruct (IT_dont_confuse α) - as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. - iApply (IT_vis_err_ne). iApply internal_eq_sym. - by iApply "Ha". - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. - iApply (IT_ret_vis_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. - iApply (IT_fun_vis_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. - iApply (IT_tick_vis_ne with "Ha"). - + destruct (reify r (Vis op i k) σ) as [σ1 α1] eqn:Hr. - assert ((∃ α' : IT, α1 ≡ Tick α') ∨ (α1 ≡ Err RuntimeErr)) as [[α' Ha']| Ha']. - { eapply (reify_is_always_a_tick r op i k σ). - by rewrite Hr. } - * exists α',σ1. eapply sstep_reify; eauto. - rewrite -Ha' -Hr; repeat f_equiv; eauto. - * exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (β σ' op' i' k') "[_ Hb]". - assert (reify r (Vis op i k) σ ≡ reify r α σ) as Har. - { f_equiv. by rewrite Ha. } - iEval (rewrite -Har) in "Hb". - iEval (rewrite Hr) in "Hb". - iPoseProof (prod_equivI with "Hb") as "[_ Hb']". - simpl. rewrite Ha'. - iApply (IT_tick_err_ne). iApply (internal_eq_sym with "Hb'"). - Qed. + (* Local Lemma effect_safe_externalize (α : IT) σ : *) + (* (⊢ ∃ β σ', (∃ op i k, α ≡ Vis op i k ∧ reify r α σ ≡ (σ', Tick β)) : iProp) → *) + (* ∃ β σ', sstep r α σ β σ'. *) + (* Proof. *) + (* intros Hprf. *) + (* destruct (IT_dont_confuse α) *) + (* as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. *) + (* + exfalso. eapply uPred.pure_soundness. *) + (* iPoseProof (Hprf) as "H". *) + (* iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. *) + (* iApply (IT_vis_err_ne). iApply internal_eq_sym. *) + (* by iApply "Ha". *) + (* + exfalso. eapply uPred.pure_soundness. *) + (* iPoseProof (Hprf) as "H". *) + (* iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. *) + (* iApply (IT_ret_vis_ne with "Ha"). *) + (* + exfalso. eapply uPred.pure_soundness. *) + (* iPoseProof (Hprf) as "H". *) + (* iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. *) + (* iApply (IT_fun_vis_ne with "Ha"). *) + (* + exfalso. eapply uPred.pure_soundness. *) + (* iPoseProof (Hprf) as "H". *) + (* iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. *) + (* iApply (IT_tick_vis_ne with "Ha"). *) + (* + destruct (reify r (Vis op i k) σ) as [σ1 α1] eqn:Hr. *) + (* assert ((∃ α' : IT, α1 ≡ Tick α') ∨ (α1 ≡ Err RuntimeErr)) as [[α' Ha']| Ha']. *) + (* { eapply (reify_is_always_a_tick r op i k σ). *) + (* by rewrite Hr. } *) + (* * exists α',σ1. eapply sstep_reify; eauto. *) + (* rewrite -Ha' -Hr; repeat f_equiv; eauto. *) + (* * exfalso. eapply uPred.pure_soundness. *) + (* iPoseProof (Hprf) as "H". *) + (* iDestruct "H" as (β σ' op' i' k') "[_ Hb]". *) + (* assert (reify r (Vis op i k) σ ≡ reify r α σ) as Har. *) + (* { f_equiv. by rewrite Ha. } *) + (* iEval (rewrite -Har) in "Hb". *) + (* iEval (rewrite Hr) in "Hb". *) + (* iPoseProof (prod_equivI with "Hb") as "[_ Hb']". *) + (* simpl. rewrite Ha'. *) + (* iApply (IT_tick_err_ne). iApply (internal_eq_sym with "Hb'"). *) + (* Qed. *) Local Lemma istep_safe_disj α σ : (∃ β σ', istep α σ β σ') @@ -255,16 +255,16 @@ Section istep. (* this is true only for iProp/uPred? *) Definition disjunction_property (P Q : iProp) := (⊢ P ∨ Q) → (⊢ P) ∨ (⊢ Q). - Lemma istep_safe_sstep α σ : - (∀ P Q, disjunction_property P Q) → - (⊢ ∃ β σ', istep α σ β σ') → ∃ β σ', sstep r α σ β σ'. - Proof. - intros Hdisj. - rewrite istep_safe_disj. - intros [H|H]%Hdisj. - - by apply tick_safe_externalize. - - by apply effect_safe_externalize. - Qed. + (* Lemma istep_safe_sstep α σ : *) + (* (∀ P Q, disjunction_property P Q) → *) + (* (⊢ ∃ β σ', istep α σ β σ') → ∃ β σ', sstep r α σ β σ'. *) + (* Proof. *) + (* intros Hdisj. *) + (* rewrite istep_safe_disj. *) + (* intros [H|H]%Hdisj. *) + (* - by apply tick_safe_externalize. *) + (* - by apply effect_safe_externalize. *) + (* Qed. *) Lemma istep_ITV α αv β σ σ' : (IT_to_V α ≡ Some αv ⊢ istep α σ β σ' -∗ False : iProp)%I. @@ -335,66 +335,65 @@ Section istep. iRewrite -"Ha". iRewrite "Hs". done. Qed. - Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' : - istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. - Proof. - iDestruct 1 as "[[Ha Hs]|H]". - - iRewrite "Ha". iLeft. iSplit; eauto. iPureIntro. apply hom_tick. - - iDestruct "H" as (op i k) "[#Ha Hr]". - pose (f' := OfeMor f). - iRight. iExists op,i,(laterO_map f' ◎ k). - iAssert (f (Vis op i k) ≡ Vis op i (laterO_map f' ◎ k))%I as "Hf". - { iPureIntro. apply hom_vis. } - iRewrite "Ha". iRewrite "Ha" in "Hr". iRewrite "Hf". - iSplit; first done. - iApply (reify_vis_cont with "Hr"). - Qed. + (* Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' : *) + (* istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. *) + (* Proof. *) + (* iDestruct 1 as "[[Ha Hs]|H]". *) + (* - iRewrite "Ha". iLeft. iSplit; eauto. iPureIntro. apply hom_tick. *) + (* - iDestruct "H" as (op i k) "[#Ha Hr]". *) + (* pose (f' := OfeMor f). *) + (* iRight. iExists op,i,(laterO_map f' ◎ k). *) + (* iAssert (f (Vis op i k) ≡ Vis op i (laterO_map f' ◎ k))%I as "Hf". *) + (* { iPureIntro. apply hom_vis. } *) + (* iRewrite "Ha". iRewrite "Ha" in "Hr". iRewrite "Hf". *) + (* iSplit; first done. *) + (* iApply (reify_vis_cont with "Hr"). *) + (* Qed. *) - Lemma istep_hom_inv α σ β σ' `{!IT_hom f} : - istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ - ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). - Proof. - iIntros "H". - destruct (IT_dont_confuse α) - as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. - - iExFalso. iApply (istep_err σ e β σ'). - iAssert (f α ≡ Err e)%I as "Hf". - { iPureIntro. by rewrite Ha hom_err. } - iRewrite "Hf" in "H". done. - - iLeft. iPureIntro. rewrite Ha IT_to_V_Ret. done. - - iLeft. iPureIntro. rewrite Ha IT_to_V_Fun. done. - - iAssert (α ≡ Tick la)%I as "Ha"; first by eauto. - iAssert (f (Tick la) ≡ Tick (f la))%I as "Hf". - { iPureIntro. rewrite hom_tick. done. } - iRight. iRewrite "Ha". iRewrite "Ha" in "H". - iRewrite "Hf" in "H". rewrite istep_tick. - iDestruct "H" as "[Hb Hs]". iSplit. - { by rewrite IT_to_V_Tau. } - iExists la. iSplit; last eauto. - unfold istep. iLeft. iSplit; eauto. - - iRight. - pose (fi:=OfeMor f). - iAssert (f α ≡ Vis op i (laterO_map fi ◎ k))%I as "Hf". - { iPureIntro. by rewrite Ha hom_vis. } - iRewrite "Hf" in "H". - rewrite {1}/istep. iSimpl in "H". - iDestruct "H" as "[[H _]|H]". - + iExFalso. iApply (IT_tick_vis_ne). - iApply internal_eq_sym. done. - + iDestruct "H" as (op' i' k') "[#Ha Hr]". - iPoseProof (Vis_inj_op' with "Ha") as "<-". - iPoseProof (Vis_inj' with "Ha") as "[Hi Hk]". - iPoseProof (reify_input_cont_inv r op i k fi with "Hr") as (α') "[Hr Ha']". - iAssert (reify r α σ ≡ (σ', Tick α'))%I with "[Hr]" as "Hr". - { iRewrite -"Hr". iPureIntro. repeat f_equiv. - apply Ha. } - iSplit. { iPureIntro. by rewrite Ha IT_to_V_Vis. } - iExists α'. iFrame "Ha'". - rewrite /istep. iRight. - iExists op,i,k. iFrame "Hr". - iPureIntro. apply Ha. - Qed. + (* Lemma istep_hom_inv α σ β σ' `{!IT_hom f} : *) + (* istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ *) + (* ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). *) + (* Proof. *) + (* iIntros "H". *) + (* destruct (IT_dont_confuse α) *) + (* as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. *) + (* - iExFalso. iApply (istep_err σ e β σ'). *) + (* iAssert (f α ≡ Err e)%I as "Hf". *) + (* { iPureIntro. by rewrite Ha hom_err. } *) + (* iRewrite "Hf" in "H". done. *) + (* - iLeft. iPureIntro. rewrite Ha IT_to_V_Ret. done. *) + (* - iLeft. iPureIntro. rewrite Ha IT_to_V_Fun. done. *) + (* - iAssert (α ≡ Tick la)%I as "Ha"; first by eauto. *) + (* iAssert (f (Tick la) ≡ Tick (f la))%I as "Hf". *) + (* { iPureIntro. rewrite hom_tick. done. } *) + (* iRight. iRewrite "Ha". iRewrite "Ha" in "H". *) + (* iRewrite "Hf" in "H". rewrite istep_tick. *) + (* iDestruct "H" as "[Hb Hs]". iSplit. *) + (* { by rewrite IT_to_V_Tau. } *) + (* iExists la. iSplit; last eauto. *) + (* unfold istep. iLeft. iSplit; eauto. *) + (* - iRight. *) + (* pose (fi:=OfeMor f). *) + (* iAssert (f α ≡ Vis op i (laterO_map fi ◎ k))%I as "Hf". *) + (* { iPureIntro. by rewrite Ha hom_vis. } *) + (* iRewrite "Hf" in "H". *) + (* rewrite {1}/istep. iSimpl in "H". *) + (* iDestruct "H" as "[[H _]|H]". *) + (* + iExFalso. iApply (IT_tick_vis_ne). *) + (* iApply internal_eq_sym. done. *) + (* + iDestruct "H" as (op' i' k') "[#Ha Hr]". *) + (* iPoseProof (Vis_inj_op' with "Ha") as "<-". *) + (* iPoseProof (Vis_inj' with "Ha") as "[Hi Hk]". *) + (* iPoseProof (reify_input_cont_inv r op i k fi with "Hr") as (α') "[Hr Ha']". *) + (* iAssert (reify r α σ ≡ (σ', Tick α'))%I with "[Hr]" as "Hr". *) + (* { iRewrite -"Hr". iPureIntro. repeat f_equiv. *) + (* apply Ha. } *) + (* iSplit. { iPureIntro. by rewrite Ha IT_to_V_Vis. } *) + (* iExists α'. iFrame "Ha'". *) + (* rewrite /istep. iRight. *) + (* iExists op,i,k. iFrame "Hr". *) + (* iPureIntro. apply Ha. *) + (* Qed. *) End istep. - diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 63be7d0..480dfe8 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -11,7 +11,7 @@ Section reifiers. { sReifier_ops : opsInterp; sReifier_state : oFunctor; sReifier_re {X} `{!Cofe X} : forall (op : opid sReifier_ops), - (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) + (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) * ((Outs (sReifier_ops op) ♯ X) -n> laterO X) -n> optionO ((Outs (sReifier_ops op) ♯ X) * (sReifier_state ♯ X)); sReifier_inhab :: Inhabited (sReifier_state ♯ unitO); sReifier_cofe X (HX : Cofe X) :: Cofe (sReifier_state ♯ X); @@ -51,13 +51,16 @@ Section reifiers. Proof. simpl. simple refine (λne i (k : _ -n> _) (s : stateF ♯ IT), _). - - simple refine (let ns := sReifier_re r op (oFunctor_map _ (inlO,fstO) i, s) in _). - simple refine (from_option (λ ns, - let out2' := k $ oFunctor_map (Outs (F op)) (fstO,inlO) ns.1 in - (ns.2, Tau $ laterO_map fstO out2')) - (s, Err RuntimeErr) ns). + - simple refine (let ns := sReifier_re r op (oFunctor_map _ (inlO,fstO) i, s, (λne o, (laterO_map fstO $ k $ oFunctor_map (Outs (F op)) (fstO, inlO) o))) in _). + + intros m s1 s2 Hs. solve_proper. + + simple refine (from_option (λ ns, + let out2' := k $ oFunctor_map (Outs (F op)) (fstO,inlO) ns.1 in + (ns.2, Tau $ laterO_map fstO out2')) + (s, Err RuntimeErr) ns). - intros m s1 s2 Hs. simpl. eapply (from_option_ne (dist m)); solve_proper. - - intros m k1 k2 Hk s. simpl. eapply (from_option_ne (dist m)); solve_proper. + - intros m k1 k2 Hk s. simpl. eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. + do 2 f_equiv. + solve_proper. - intros m i1 i2 Hi k s. simpl. eapply (from_option_ne (dist m)); solve_proper. Defined. @@ -106,7 +109,7 @@ Section reifiers. Qed. Lemma reify_vis_dist m op i o k σ σ' : - sReifier_re r op (i,σ) ≡{m}≡ Some (o,σ') → + sReifier_re r op (i,σ,k) ≡{m}≡ Some (o,σ') → reify (Vis op i k) σ ≡{m}≡ (σ', Tau $ k o). Proof. intros Hst. @@ -118,14 +121,15 @@ Section reifiers. Opaque prod_in. simpl. pose (rs := (sReifier_re r op (oFunctor_map (Ins (F op)) (inlO, fstO) - (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). + (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ, k))). fold rs. - assert (rs ≡ sReifier_re r op (i,σ)) as Hr'. + assert (rs ≡ sReifier_re r op (i,σ, k)) as Hr'. { unfold rs. f_equiv. f_equiv. rewrite -oFunctor_map_compose. + f_equiv. etrans; last by apply oFunctor_map_id. repeat f_equiv; intro; done. } - assert (rs ≡{m}≡ Some (o,σ')) as Hr. + assert (rs ≡{m}≡ Some (o, σ')) as Hr. { by rewrite Hr' Hst. } trans (from_option (λ ns, (ns.2, @@ -136,7 +140,25 @@ Section reifiers. (oFunctor_map (Outs (F op)) (prod_in idfun reify, sumO_rec idfun unreify) (oFunctor_map (Outs (F op)) (fstO, inlO) ns.1))))))) (σ, Err RuntimeErr) (Some (o,σ'))). - { eapply (from_option_ne (dist m)); solve_proper. } + { + eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. + rewrite <-Hr. + subst rs. + do 2 f_equiv. + intros x; simpl. + rewrite -laterO_map_compose. + etrans; first (rewrite laterO_map_id; reflexivity). + f_equiv. + rewrite -oFunctor_map_compose. + trans (oFunctor_map _ (idfun, idfun) x). + - do 3 f_equiv. + + intros y; simpl. + Transparent prod_in. + by unfold prod_in. + + intros y; simpl. + reflexivity. + - by rewrite oFunctor_map_id. + } simpl. repeat f_equiv. rewrite -laterO_map_compose. rewrite -oFunctor_map_compose. @@ -151,7 +173,7 @@ Section reifiers. Qed. Lemma reify_vis_eq op i o k σ σ' : - sReifier_re r op (i,σ) ≡ Some (o,σ') → + sReifier_re r op (i,σ,k) ≡ Some (o,σ') → reify (Vis op i k) σ ≡ (σ', Tau $ k o). Proof. intros H. apply equiv_dist=>m. @@ -160,7 +182,7 @@ Section reifiers. Qed. Lemma reify_vis_None op i k σ : - sReifier_re r op (i,σ) ≡ None → + sReifier_re r op (i,σ,k) ≡ None → reify (Vis op i k) σ ≡ (σ, Err RuntimeErr). Proof. intros Hs. @@ -173,11 +195,12 @@ Section reifiers. simpl. pose (rs := (sReifier_re r op (oFunctor_map (Ins (F op)) (inlO, fstO) - (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). + (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ, k))). fold rs. - assert (rs ≡ sReifier_re r op (i,σ)) as Hr'. + assert (rs ≡ sReifier_re r op (i,σ, k)) as Hr'. { unfold rs. f_equiv. f_equiv. rewrite -oFunctor_map_compose. + f_equiv. etrans; last by apply oFunctor_map_id. repeat f_equiv; intro; done. } assert (rs ≡ None) as Hr. @@ -191,78 +214,102 @@ Section reifiers. (oFunctor_map (Outs (F op)) (prod_in idfun reify, sumO_rec idfun unreify) (oFunctor_map (Outs (F op)) (fstO, inlO) ns.1))))))) (σ, Err RuntimeErr) None). - { apply from_option_proper; solve_proper. } + { + apply from_option_proper; [solve_proper | solve_proper |]. + rewrite -Hr Hr'. + do 2 f_equiv. + - rewrite -oFunctor_map_compose. + f_equiv. + trans (oFunctor_map _ (idfun, idfun) i). + + do 3 f_equiv. + * intros y; simpl. + Transparent prod_in. + by unfold prod_in. + * intros y; simpl. + reflexivity. + + by rewrite oFunctor_map_id. + - intros x; simpl. + rewrite -laterO_map_compose. + trans (laterO_map idfun (k x)); last first. + { by rewrite laterO_map_id. } + repeat f_equiv. + { intro; done. } + trans (oFunctor_map _ (idfun, idfun) x); last first. + { by rewrite oFunctor_map_id. } + simpl. + rewrite -oFunctor_map_compose. + repeat f_equiv; intro; done. + } reflexivity. Qed. - Lemma reify_vis_cont op i k1 k2 σ1 σ2 β - {PROP : bi} `{!BiInternalEq PROP} : - (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ - reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. - Proof. - destruct (sReifier_re r op (i,σ1)) as [[o σ2']|] eqn:Hre; last first. - - rewrite reify_vis_None; last by rewrite Hre//. - iIntros "Hr". iExFalso. - iPoseProof (prod_equivI with "Hr") as "[_ Hk]". - simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. - - rewrite reify_vis_eq; last first. - { by rewrite Hre. } - rewrite reify_vis_eq; last first. - { by rewrite Hre. } - iIntros "Hr". - iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". - iApply prod_equivI. simpl. iSplit; eauto. - iPoseProof (Tau_inj' with "Hk") as "Hk". - iApply Tau_inj'. iRewrite "Hk". - rewrite laterO_map_Next. done. - Qed. + (* Lemma reify_vis_cont op i k1 k2 σ1 σ2 β *) + (* {PROP : bi} `{!BiInternalEq PROP} : *) + (* (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) ⊢ *) + (* reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. *) + (* Proof. *) + (* destruct (sReifier_re r op (i,σ1, laterO_map k2 ◎ k1)) as [[o σ2']|] eqn:Hre; last first. *) + (* - rewrite (reify_vis_None _ _ (laterO_map k2 ◎ k1)); last by rewrite Hre//. *) + (* iIntros "Hr". iExFalso. *) + (* iPoseProof (prod_equivI with "Hr") as "[_ Hk]". *) + (* simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. *) + (* - rewrite reify_vis_eq; last first. *) + (* { by rewrite Hre. } *) + (* rewrite reify_vis_eq; last first. *) + (* { by rewrite Hre. } *) + (* iIntros "Hr". *) + (* iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". *) + (* iApply prod_equivI. simpl. iSplit; eauto. *) + (* iPoseProof (Tau_inj' with "Hk") as "Hk". *) + (* iApply Tau_inj'. iRewrite "Hk". *) + (* rewrite laterO_map_Next. done. *) + (* Qed. *) - Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β - {PROP : bi} `{!BiInternalEq PROP} : - (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) - ⊢ ∃ α, reify (Vis op i k1) σ1 ≡ (σ2, Tick α) ∧ ▷ (β ≡ k2 α) - : PROP)%I. - Proof. - destruct (sReifier_re r op (i,σ1)) as [[o σ2']|] eqn:Hre; last first. - - rewrite reify_vis_None; last by rewrite Hre//. - iIntros "Hr". iExFalso. - iPoseProof (prod_equivI with "Hr") as "[_ Hk]". - simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. - - rewrite reify_vis_eq; last first. - { by rewrite Hre. } - iIntros "Hr". simpl. - iPoseProof (prod_equivI with "Hr") as "[#Hs #Hk]". - simpl. - iPoseProof (Tau_inj' with "Hk") as "Hk'". - destruct (Next_uninj (k1 o)) as [a Hk1]. - iExists (a). - rewrite reify_vis_eq; last first. - { by rewrite Hre. } - iSplit. - + iApply prod_equivI. simpl. iSplit; eauto. - iApply Tau_inj'. done. - + iAssert (laterO_map k2 (Next a) ≡ Next β)%I as "Ha". - { iSimpl in "Hk'". iRewrite -"Hk'". - iPureIntro. rewrite -Hk1. done. } - iAssert (Next (k2 a) ≡ Next β)%I as "Hb". - { iRewrite -"Ha". iPureIntro. - rewrite laterO_map_Next. done. } - iNext. by iApply internal_eq_sym. - Qed. + (* Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β *) + (* {PROP : bi} `{!BiInternalEq PROP} : *) + (* (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) *) + (* ⊢ ∃ α, reify (Vis op i k1) σ1 ≡ (σ2, Tick α) ∧ ▷ (β ≡ k2 α) *) + (* : PROP)%I. *) + (* Proof. *) + (* destruct (sReifier_re r op (i,σ1)) as [[o σ2']|] eqn:Hre; last first. *) + (* - rewrite reify_vis_None; last by rewrite Hre//. *) + (* iIntros "Hr". iExFalso. *) + (* iPoseProof (prod_equivI with "Hr") as "[_ Hk]". *) + (* simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. *) + (* - rewrite reify_vis_eq; last first. *) + (* { by rewrite Hre. } *) + (* iIntros "Hr". simpl. *) + (* iPoseProof (prod_equivI with "Hr") as "[#Hs #Hk]". *) + (* simpl. *) + (* iPoseProof (Tau_inj' with "Hk") as "Hk'". *) + (* destruct (Next_uninj (k1 o)) as [a Hk1]. *) + (* iExists (a). *) + (* rewrite reify_vis_eq; last first. *) + (* { by rewrite Hre. } *) + (* iSplit. *) + (* + iApply prod_equivI. simpl. iSplit; eauto. *) + (* iApply Tau_inj'. done. *) + (* + iAssert (laterO_map k2 (Next a) ≡ Next β)%I as "Ha". *) + (* { iSimpl in "Hk'". iRewrite -"Hk'". *) + (* iPureIntro. rewrite -Hk1. done. } *) + (* iAssert (Next (k2 a) ≡ Next β)%I as "Hb". *) + (* { iRewrite -"Ha". iPureIntro. *) + (* rewrite laterO_map_Next. done. } *) + (* iNext. by iApply internal_eq_sym. *) + (* Qed. *) - Lemma reify_is_always_a_tick op x k σ β σ' : - reify (Vis op x k) σ ≡ (σ', β) → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). - Proof. - destruct (sReifier_re r op (x, σ)) as [[o σ'']|] eqn:Hre; last first. - - rewrite reify_vis_None; last by rewrite Hre//. - intros [_ ?]. by right. - - rewrite reify_vis_eq;last by rewrite Hre. - intros [? Ho]. - destruct (Next_uninj (k o)) as [lβ Hlb]. - left. exists (lβ). - rewrite Tick_eq. - rewrite -Hlb. symmetry. apply Ho. - Qed. + (* Lemma reify_is_always_a_tick op x k σ β σ' : *) + (* reify (Vis op x k) σ ≡ (σ', β) → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). *) + (* Proof. *) + (* destruct (sReifier_re r op (x, σ)) as [[o σ'']|] eqn:Hre; last first. *) + (* - rewrite reify_vis_None; last by rewrite Hre//. *) + (* intros [_ ?]. by right. *) + (* - rewrite reify_vis_eq;last by rewrite Hre. *) + (* intros [? Ho]. *) + (* destruct (Next_uninj (k o)) as [lβ Hlb]. *) + (* left. exists (lβ). *) + (* rewrite Tick_eq. *) + (* rewrite -Hlb. symmetry. apply Ho. *) + (* Qed. *) End reifiers. - diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index 873cf74..99e3dce 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -137,9 +137,9 @@ Section weakestpre. Definition has_state_idx `{!stateG Σ} (i : fin n) (σ : sReifier_state (rs !!! i) ♯ IT) : iProp Σ := (own stateG_name (◯ (of_idx i σ)))%I. - Definition has_substate {sR : sReifier} `{!stateG Σ} `{!subReifier sR rs} - (σ : sReifier_state sR ♯ IT) : iProp Σ := - (own stateG_name (◯ (of_idx sR_idx (sR_state σ))))%I. + (* Definition has_substate {sR : sReifier} `{!stateG Σ} `{!subReifier sR rs} *) + (* (σ : sReifier_state sR ♯ IT) : iProp Σ := *) + (* (own stateG_name (◯ (of_idx sR_idx (sR_state σ))))%I. *) #[export] Instance state_interp_ne `{!stateG Σ} : NonExpansive state_interp. Proof. solve_proper. Qed. @@ -371,61 +371,61 @@ Section weakestpre. iIntros "H". iApply (wp_wand with "H"); auto. Qed. - Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 : - WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. - Proof. - assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). - { solve_proper. } - iIntros "H". iLöb as "IH" forall (α). - rewrite (wp_unfold (f _)). - destruct (IT_to_V (f α)) as [βv|] eqn:Hfa. - - iLeft. iExists βv. iSplit; first done. - assert (is_Some (IT_to_V α)) as [αv Ha]. - { apply (IT_hom_val_inv _ f). rewrite Hfa. - done. } - assert (IntoVal α αv). - { apply IT_of_to_V'. by rewrite Ha. } - rewrite wp_val_inv. - iApply wp_val_inv. - rewrite IT_of_to_V'; last by rewrite -Ha. - rewrite IT_of_to_V'; last by rewrite -Hfa. - by iApply fupd_wp. - - iRight. iSplit; eauto. - iIntros (σ) "Hs". - rewrite wp_unfold. - iDestruct "H" as "[H | H]". - + iDestruct "H" as (αv) "[Hav H]". - iPoseProof (IT_of_to_V with "Hav") as "Hav". - iMod "H" as "H". rewrite wp_unfold. - iDestruct "H" as "[H|H]". - { iExFalso. iDestruct "H" as (βv) "[H _]". - iRewrite "Hav" in "H". rewrite Hfa. - iApply (option_equivI with "H"). } - iDestruct "H" as "[_ H]". - iMod ("H" with "Hs") as "H". iModIntro. - iRewrite "Hav" in "H". done. - + iDestruct "H" as "[Hav H]". - iMod ("H" with "Hs") as "[Hsafe H]". iModIntro. - iSplit. - { (* safety *) - iDestruct "Hsafe" as "[Hsafe|Herr]". - - iDestruct "Hsafe" as (α' σ') "Hsafe". iLeft. - iExists (f α'), σ'. iApply (istep_hom with "Hsafe"). - - iDestruct "Herr" as (e) "[Herr %]". - iRight. iExists e. iSplit; last done. - iRewrite "Herr". rewrite hom_err//. } - iIntros (σ' β) "Hst". - rewrite {1}istep_hom_inv. iDestruct "Hst" as "[%Ha | [_ Hst]]". - { destruct Ha as [αv Ha]. rewrite Ha. - iExFalso. - iApply (option_equivI with "Hav"). } - iDestruct "Hst" as (α') "[Hst Hb]". - iIntros "Hlc". - iMod ("H" with "Hst Hlc") as "H". iModIntro. - iNext. iMod "H" as "H". iModIntro. - iMod "H" as "[$ H]". - iModIntro. iRewrite "Hb". by iApply "IH". - Qed. + (* Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 : *) + (* WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. *) + (* Proof. *) + (* assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). *) + (* { solve_proper. } *) + (* iIntros "H". iLöb as "IH" forall (α). *) + (* rewrite (wp_unfold (f _)). *) + (* destruct (IT_to_V (f α)) as [βv|] eqn:Hfa. *) + (* - iLeft. iExists βv. iSplit; first done. *) + (* assert (is_Some (IT_to_V α)) as [αv Ha]. *) + (* { apply (IT_hom_val_inv _ f). rewrite Hfa. *) + (* done. } *) + (* assert (IntoVal α αv). *) + (* { apply IT_of_to_V'. by rewrite Ha. } *) + (* rewrite wp_val_inv. *) + (* iApply wp_val_inv. *) + (* rewrite IT_of_to_V'; last by rewrite -Ha. *) + (* rewrite IT_of_to_V'; last by rewrite -Hfa. *) + (* by iApply fupd_wp. *) + (* - iRight. iSplit; eauto. *) + (* iIntros (σ) "Hs". *) + (* rewrite wp_unfold. *) + (* iDestruct "H" as "[H | H]". *) + (* + iDestruct "H" as (αv) "[Hav H]". *) + (* iPoseProof (IT_of_to_V with "Hav") as "Hav". *) + (* iMod "H" as "H". rewrite wp_unfold. *) + (* iDestruct "H" as "[H|H]". *) + (* { iExFalso. iDestruct "H" as (βv) "[H _]". *) + (* iRewrite "Hav" in "H". rewrite Hfa. *) + (* iApply (option_equivI with "H"). } *) + (* iDestruct "H" as "[_ H]". *) + (* iMod ("H" with "Hs") as "H". iModIntro. *) + (* iRewrite "Hav" in "H". done. *) + (* + iDestruct "H" as "[Hav H]". *) + (* iMod ("H" with "Hs") as "[Hsafe H]". iModIntro. *) + (* iSplit. *) + (* { (* safety *) *) + (* iDestruct "Hsafe" as "[Hsafe|Herr]". *) + (* - iDestruct "Hsafe" as (α' σ') "Hsafe". iLeft. *) + (* iExists (f α'), σ'. iApply (istep_hom with "Hsafe"). *) + (* - iDestruct "Herr" as (e) "[Herr %]". *) + (* iRight. iExists e. iSplit; last done. *) + (* iRewrite "Herr". rewrite hom_err//. } *) + (* iIntros (σ' β) "Hst". *) + (* rewrite {1}istep_hom_inv. iDestruct "Hst" as "[%Ha | [_ Hst]]". *) + (* { destruct Ha as [αv Ha]. rewrite Ha. *) + (* iExFalso. *) + (* iApply (option_equivI with "Hav"). } *) + (* iDestruct "Hst" as (α') "[Hst Hb]". *) + (* iIntros "Hlc". *) + (* iMod ("H" with "Hst Hlc") as "H". iModIntro. *) + (* iNext. iMod "H" as "H". iModIntro. *) + (* iMod "H" as "[$ H]". *) + (* iModIntro. iRewrite "Hb". by iApply "IH". *) + (* Qed. *) (* XXX: strengthen it with later credits *) Lemma wp_tick α s E1 Φ : @@ -497,34 +497,34 @@ Section weakestpre. iRewrite -"Hb". by iFrame. Qed. - Lemma wp_reify_idx' E1 E2 s Φ i (lop : opid (sReifier_ops (rs !!! i))) : - let op : opid F := (existT i lop) in - forall (x : Ins (F op) ♯ IT) - (k : Outs (F op) ♯ IT -n> laterO IT), - (|={E1,E2}=> ∃ σ y σ' β, has_state_idx i σ ∗ - sReifier_re (rs !!! i) lop (x, σ) ≡ Some (y, σ') ∗ - k y ≡ Next β ∗ - ▷ (£ 1 -∗ has_state_idx i σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) - -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. - Proof. - intros op x k. - iIntros "H". - iApply wp_reify_idx. - iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". - iModIntro. iExists σ, σ', β. - iFrame "Hlst". - iIntros (rest). iFrame "H". - iAssert (gReifiers_re rs op (x, gState_recomp rest σ) ≡ Some (y,gState_recomp rest σ'))%I - with "[Hreify]" as "Hgreify". - { rewrite gReifiers_re_idx. - iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) (sReifier_re (rs !!! i) lop (x, σ)) ≡ optionO_map (prodO_map idfun (gState_recomp rest)) (Some (y, σ')))%I with "[Hreify]" as "H". - - iApply (f_equivI with "Hreify"). - - simpl. iExact "H". - } - iPoseProof (reify_vis_eqI _ _ _ k with "Hgreify") as "Hreify". - iRewrite "Hk" in "Hreify". - by rewrite -Tick_eq. - Qed. + (* Lemma wp_reify_idx' E1 E2 s Φ i (lop : opid (sReifier_ops (rs !!! i))) : *) + (* let op : opid F := (existT i lop) in *) + (* forall (x : Ins (F op) ♯ IT) *) + (* (k : Outs (F op) ♯ IT -n> laterO IT), *) + (* (|={E1,E2}=> ∃ σ y σ' β, has_state_idx i σ ∗ *) + (* sReifier_re (rs !!! i) lop (x, σ, k) ≡ Some (y, σ') ∗ *) + (* k y ≡ Next β ∗ *) + (* ▷ (£ 1 -∗ has_state_idx i σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) *) + (* -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. *) + (* Proof. *) + (* intros op x k. *) + (* iIntros "H". *) + (* iApply wp_reify_idx. *) + (* iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". *) + (* iModIntro. iExists σ, σ', β. *) + (* iFrame "Hlst". *) + (* iIntros (rest). iFrame "H". *) + (* iAssert (gReifiers_re rs op (x, gState_recomp rest σ) ≡ Some (y,gState_recomp rest σ'))%I *) + (* with "[Hreify]" as "Hgreify". *) + (* { rewrite gReifiers_re_idx. *) + (* iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) (sReifier_re (rs !!! i) lop (x, σ)) ≡ optionO_map (prodO_map idfun (gState_recomp rest)) (Some (y, σ')))%I with "[Hreify]" as "H". *) + (* - iApply (f_equivI with "Hreify"). *) + (* - simpl. iExact "H". *) + (* } *) + (* iPoseProof (reify_vis_eqI _ _ _ k with "Hgreify") as "Hreify". *) + (* iRewrite "Hk" in "Hreify". *) + (* by rewrite -Tick_eq. *) + (* Qed. *) Lemma wp_reify E1 s Φ i (lop : opid (sReifier_ops (rs !!! i))) x k σ σ' β : @@ -545,42 +545,42 @@ Section weakestpre. iModIntro. by iApply ("H" with "Hlc Hs"). Qed. - Lemma wp_subreify' E1 E2 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ IT) - (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) : - (|={E1,E2}=> ∃ σ y σ' β, has_substate σ ∗ - sReifier_re sR op (x, σ) ≡ Some (y, σ') ∗ - k (subEff_outs y) ≡ Next β ∗ - ▷ (£ 1 -∗ has_substate σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) - -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. - Proof. - iIntros "H". - iApply wp_reify_idx'. - iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". - iModIntro. - iExists (sR_state σ),(subEff_outs y), (sR_state σ'), β. - iFrame "Hlst H Hk". - by iApply subReifier_reify_idxI. - Qed. - Lemma wp_subreify E1 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops sR)) - (x : Ins (sReifier_ops sR op) ♯ IT) (y : Outs (sReifier_ops sR op) ♯ IT) - (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) - (σ σ' : sReifier_state sR ♯ IT) β : - sReifier_re sR op (x, σ) ≡ Some (y, σ') → - k (subEff_outs y) ≡ Next β → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP β @ s;E1 {{ Φ }}) - -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. - Proof. - intros HSR Hk. - iIntros "Hlst H". - iApply (wp_reify with "Hlst H"). - intros rest. - rewrite Tick_eq. rewrite -Hk. - rewrite reify_vis_eq //. - by apply subReifier_reify. - Qed. + (* Lemma wp_subreify' E1 E2 s Φ sR `{!subReifier sR rs} *) + (* (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ IT) *) + (* (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) : *) + (* (|={E1,E2}=> ∃ σ y σ' β, has_substate σ ∗ *) + (* sReifier_re sR op (x, σ) ≡ Some (y, σ') ∗ *) + (* k (subEff_outs y) ≡ Next β ∗ *) + (* ▷ (£ 1 -∗ has_substate σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) *) + (* -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. *) + (* Proof. *) + (* iIntros "H". *) + (* iApply wp_reify_idx'. *) + (* iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". *) + (* iModIntro. *) + (* iExists (sR_state σ),(subEff_outs y), (sR_state σ'), β. *) + (* iFrame "Hlst H Hk". *) + (* by iApply subReifier_reify_idxI. *) + (* Qed. *) + (* Lemma wp_subreify E1 s Φ sR `{!subReifier sR rs} *) + (* (op : opid (sReifier_ops sR)) *) + (* (x : Ins (sReifier_ops sR op) ♯ IT) (y : Outs (sReifier_ops sR op) ♯ IT) *) + (* (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) *) + (* (σ σ' : sReifier_state sR ♯ IT) β : *) + (* sReifier_re sR op (x, σ) ≡ Some (y, σ') → *) + (* k (subEff_outs y) ≡ Next β → *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ has_substate σ' -∗ WP β @ s;E1 {{ Φ }}) *) + (* -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. *) + (* Proof. *) + (* intros HSR Hk. *) + (* iIntros "Hlst H". *) + (* iApply (wp_reify with "Hlst H"). *) + (* intros rest. *) + (* rewrite Tick_eq. rewrite -Hk. *) + (* rewrite reify_vis_eq //. *) + (* by apply subReifier_reify. *) + (* Qed. *) Lemma wp_err E1 e (s : error → Prop) Φ : s e → @@ -761,7 +761,7 @@ End weakestpre. Arguments wp {_} rs {_ _ _ _ _} α s E Φ. Arguments has_full_state {n _ _ _ _ _} σ. Arguments has_state_idx {n _ _ _ _ _} i σ. -Arguments has_substate {n _ _ _ _ _ _ _} σ. +(* Arguments has_substate {n _ _ _ _ _ _ _} σ. *) Arguments stateG {n} rs A {_} Σ. Arguments statePreG {n} rs A {_} Σ. Arguments stateΣ {n} rs A {_}. @@ -817,62 +817,62 @@ Proof. by iApply fupd_mask_intro_discard. Qed. -Lemma wp_safety cr Σ `{!invGpreS Σ} n (rs : gReifiers n) - {A} `{!Cofe A} `{!statePreG rs A Σ} s k - (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : - (∀ Σ P Q, @disjunction_property Σ P Q) → - ssteps (gReifiers_sReifier rs) α σ β σ' k → - IT_to_V β ≡ None → - (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, - ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → - ((∃ β1 σ1, sstep (gReifiers_sReifier rs) β σ' β1 σ1) - ∨ (∃ e, β ≡ Err e ∧ s e)). -Proof. - Opaque istep. - intros Hdisj Hstep Hbv Hwp. - cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier rs) β σ' β1 σ1) - ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. - { intros [Hprf | Hprf]%Hdisj. - - left. - apply (istep_safe_sstep _ (Σ:=Σ)). - { apply Hdisj. } - done. - - right. - destruct (IT_dont_confuse β) - as [[e Ha] | [[m Ha] | [ [g Ha] | [[α' Ha]|[op [i [ko Ha]]]] ]]]. - + exists e. split; eauto. - eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[He %Hs]". rewrite Ha. - iPoseProof (Err_inj' with "He") as "%He". - iPureIntro. rewrite He//. - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_ret_err_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_fun_err_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_tick_err_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_vis_err_ne with "Ha"). } - eapply (step_fupdN_soundness_lc _ 0 (cr + (3*k+2))). - intros Hinv. iIntros "[Hcr Hlc]". - iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". - destruct (Hwp Hinv sg) as (Φ & HΦ & Hprf'). - iPoseProof (Hprf' with "[$Hs2 $Hcr]") as "Hic". - iPoseProof (wp_ssteps_isafe with "[$Hs $Hic]") as "H". - { eassumption. } - iMod ("H" with "Hlc") as "[H | H]". - { iDestruct "H" as (βv) "%Hbeta". - exfalso. rewrite Hbeta in Hbv. - inversion Hbv. } - iFrame "H". - by iApply fupd_mask_intro_discard. -Qed. +(* Lemma wp_safety cr Σ `{!invGpreS Σ} n (rs : gReifiers n) *) +(* {A} `{!Cofe A} `{!statePreG rs A Σ} s k *) +(* (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : *) +(* (∀ Σ P Q, @disjunction_property Σ P Q) → *) +(* ssteps (gReifiers_sReifier rs) α σ β σ' k → *) +(* IT_to_V β ≡ None → *) +(* (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, *) +(* ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → *) +(* ((∃ β1 σ1, sstep (gReifiers_sReifier rs) β σ' β1 σ1) *) +(* ∨ (∃ e, β ≡ Err e ∧ s e)). *) +(* Proof. *) +(* Opaque istep. *) +(* intros Hdisj Hstep Hbv Hwp. *) +(* cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier rs) β σ' β1 σ1) *) +(* ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. *) +(* { intros [Hprf | Hprf]%Hdisj. *) +(* - left. *) +(* apply (istep_safe_sstep _ (Σ:=Σ)). *) +(* { apply Hdisj. } *) +(* done. *) +(* - right. *) +(* destruct (IT_dont_confuse β) *) +(* as [[e Ha] | [[m Ha] | [ [g Ha] | [[α' Ha]|[op [i [ko Ha]]]] ]]]. *) +(* + exists e. split; eauto. *) +(* eapply uPred.pure_soundness. *) +(* iPoseProof (Hprf) as "H". *) +(* iDestruct "H" as (e') "[He %Hs]". rewrite Ha. *) +(* iPoseProof (Err_inj' with "He") as "%He". *) +(* iPureIntro. rewrite He//. *) +(* + exfalso. eapply uPred.pure_soundness. *) +(* iPoseProof (Hprf) as "H". *) +(* iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. *) +(* iApply (IT_ret_err_ne with "Ha"). *) +(* + exfalso. eapply uPred.pure_soundness. *) +(* iPoseProof (Hprf) as "H". *) +(* iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. *) +(* iApply (IT_fun_err_ne with "Ha"). *) +(* + exfalso. eapply uPred.pure_soundness. *) +(* iPoseProof (Hprf) as "H". *) +(* iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. *) +(* iApply (IT_tick_err_ne with "Ha"). *) +(* + exfalso. eapply uPred.pure_soundness. *) +(* iPoseProof (Hprf) as "H". *) +(* iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. *) +(* iApply (IT_vis_err_ne with "Ha"). } *) +(* eapply (step_fupdN_soundness_lc _ 0 (cr + (3*k+2))). *) +(* intros Hinv. iIntros "[Hcr Hlc]". *) +(* iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". *) +(* destruct (Hwp Hinv sg) as (Φ & HΦ & Hprf'). *) +(* iPoseProof (Hprf' with "[$Hs2 $Hcr]") as "Hic". *) +(* iPoseProof (wp_ssteps_isafe with "[$Hs $Hic]") as "H". *) +(* { eassumption. } *) +(* iMod ("H" with "Hlc") as "[H | H]". *) +(* { iDestruct "H" as (βv) "%Hbeta". *) +(* exfalso. rewrite Hbeta in Hbv. *) +(* inversion Hbv. } *) +(* iFrame "H". *) +(* by iApply fupd_mask_intro_discard. *) +(* Qed. *) diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index b167ae7..cf9ef1c 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -1,34 +1,141 @@ From Equations Require Import Equations. From gitrees Require Import gitree. From gitrees.input_lang Require Import lang. +Require Import gitrees.lang_generic_sem. + +Require Import Binding.Lib. Notation stateO := (leibnizO state). Program Definition inputE : opInterp := {| - Ins := unitO; - Outs := natO; -|}. + Ins := unitO; + Outs := natO; + |}. Program Definition outputE : opInterp := {| - Ins := natO; - Outs := unitO; -|}. -Definition ioE := @[inputE;outputE]. -Canonical Structure reify_io : sReifier. + Ins := natO; + Outs := unitO; + |}. + +Definition callccIF : oFunctor := (▶ ∙)%OF. + +#[local] Instance callccIF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (callccIF ♯ X). +Proof. + constructor. + unshelve refine (Next inhabitant). +Qed. +#[local] Instance callccIF_cofe X `{!Cofe X} : Cofe (callccIF ♯ X). +Proof. apply _. Qed. +#[local] Instance callccIF_contr : oFunctorContractive callccIF. +Proof. + intros ???????? n [a b] [c d] H. + apply laterO_map_contractive. + destruct n as [| n]. + - apply dist_later_0. + - apply dist_later_S. + apply dist_later_S in H. + destruct H as [H1 H2]; simpl in H1, H2. + by f_equiv. +Qed. + +Definition callccOF : oFunctor := unitO. + +#[local] Instance callccOF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (callccOF ♯ X). +Proof. + constructor. + simpl. + constructor. +Qed. +#[local] Instance callccOF_cofe X `{!Cofe X} : Cofe (callccOF ♯ X). +Proof. apply _. Qed. +#[local] Instance callccOF_contr : oFunctorContractive callccOF. +Proof. + intros ???????? n [a b] [c d] H. + solve_proper. +Qed. + +Program Definition callccE : opInterp := {| + Ins := callccIF; + Outs := callccOF; + |}. + +Definition throwIF : oFunctor := (▶ ∙ * ▶ ∙)%OF. + +#[local] Instance throwIF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (throwIF ♯ X). +Proof. + constructor. + unshelve refine (Next inhabitant, Next inhabitant). +Qed. +#[local] Instance throwIF_cofe X `{!Cofe X} : Cofe (throwIF ♯ X). +Proof. apply _. Qed. +#[local] Instance throwIF_contr : oFunctorContractive throwIF. +Proof. + intros ???????? n [a b] [c d] H. + simpl. + f_equiv. + { + apply laterO_map_contractive. + destruct n as [| n]. + - apply dist_later_0. + - apply dist_later_S. + apply dist_later_S in H. + destruct H as [H1 H2]; simpl in H1, H2. + assumption. + } + { + apply laterO_map_contractive. + destruct n as [| n]. + - apply dist_later_0. + - apply dist_later_S. + apply dist_later_S in H. + destruct H as [H1 H2]; simpl in H1, H2. + assumption. + } +Qed. + +Definition throwOF : oFunctor := unitO. + +#[local] Instance throwOF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (throwOF ♯ X). +Proof. + constructor. + apply (Next inhabitant). +Qed. +#[local] Instance throwOF_cofe X `{!Cofe X} : Cofe (throwOF ♯ X). +Proof. apply _. Qed. +#[local] Instance throwOF_contr : oFunctorContractive throwOF. Proof. - simple refine {| sReifier_ops := ioE; - sReifier_state := stateO - |}. - intros X HX op. - destruct op as [[] | [ | []]]; simpl. - - simple refine (λne (us : prodO unitO stateO), - Some $ update_input (sndO us) : optionO (prodO natO stateO)). - intros n [[] s1] [[] s2] [_ Hs]. - repeat f_equiv. apply Hs. - - simple refine (λne (us : prodO natO stateO), - Some $ ((), update_output (fstO us) (sndO us)) : optionO (prodO unitO stateO)). - intros n [m s1] [m' s2] [-> Hs]. solve_proper. -Defined. + intros ???????? n [a b] [c d] H. + unfold throwOF; simpl. + reflexivity. +Qed. + +Program Definition throwE : opInterp := {| + Ins := throwIF; + Outs := throwOF; +|}. +Definition ioE := @[inputE;outputE;callccE;throwE]. +(* Canonical Structure reify_io : sReifier. *) +(* Proof. *) +(* simple refine {| sReifier_ops := ioE; *) +(* sReifier_state := stateO *) +(* |}. *) +(* intros X HX op. *) +(* destruct op as [ | [ | [ | [| []]]]]; simpl. *) +(* - simple refine (λne (us : prodO (prodO unitO stateO) (natO -n> laterO X)), *) +(* Some $ update_input (sndO (fstO us)) : optionO (prodO natO stateO)). *) +(* intros n [[] s1] [[] s2] [[Hs1 Hs2] Hs]; simpl in *. *) +(* repeat f_equiv. apply Hs2. *) +(* - simple refine (λne (us : prodO (prodO natO stateO) (unitO -n> laterO X)), *) +(* Some $ ((), update_output (fstO (fstO us)) (sndO (fstO us))) : optionO (prodO unitO stateO)). *) +(* intros n [m s1] [m' s2] [-> Hs]. solve_proper. *) +(* - simple refine (λne (us : prodO (prodO (laterO X) stateO) (unitO -n> laterO X)), Some $ ((), sndO (fstO us))). *) +(* solve_proper. *) +(* - simple refine (λne (us : prodO (prodO (prodO (laterO X) (laterO X)) stateO) (unitO -n> laterO X)), _). *) +(* + destruct us as [[[us0 us1] us2] us3]. *) +(* (* if us1 is next(fun(k)) some k(us0) else none *) *) +(* admit. *) +(* + admit. *) +(* Admitted. *) Section constructors. Context {E : opsInterp} {A} `{!Cofe A}. @@ -63,12 +170,35 @@ Section constructors. done. Qed. + (* Program Definition CALLCC : (IT -n> IT) -n> IT -n> IT := *) + (* λne k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) *) + (* (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) (Next k)) *) + (* (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1). *) + (* Next Obligation. *) + (* intros. *) + (* simpl. *) + (* Admit Obligations. *) + + (* Program Definition THROW : IT -n> IT -n> IT := *) + (* λne m α, Vis (E:=E) (subEff_opid (inr (inr (inr (inl ()))))) *) + (* (subEff_ins (F:=ioE) (op:=(inr (inr (inr (inl ()))))) _) *) + (* (λne _, NextO α). *) + (* Admit Obligations. *) + + (* Lemma hom_CALLCC e k f `{!IT_hom f} : f (CALLCC k e) ≡ CALLCC (OfeMor f ◎ k) (f e). *) + (* Proof. *) + (* unfold CALLCC. *) + (* Admitted. *) + (* Lemma hom_THROW m n f `{!IT_hom f} : f (THROW m n) ≡ THROW (f m) (f n). *) + (* Proof. *) + (* Admitted. *) + End constructors. Section weakestpre. Context {sz : nat}. Variable (rs : gReifiers sz). - Context {subR : subReifier reify_io rs}. + (* Context {subR : subReifier reify_io rs}. *) Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. @@ -77,46 +207,61 @@ Section weakestpre. Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : - update_input σ = (n, σ') → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ - WP@{rs} (INPUT k) @ s {{ Φ }}. - Proof. - intros Hs. iIntros "Hs Ha". - unfold INPUT. simpl. - iApply (wp_subreify with "Hs"). - { simpl. by rewrite Hs. } - { simpl. by rewrite ofe_iso_21. } - iModIntro. done. - Qed. - Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : - update_output n σ = σ' → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ - WP@{rs} (OUTPUT n) @ s {{ Φ }}. - Proof. - intros Hs. iIntros "Hs Ha". - unfold OUTPUT. simpl. - iApply (wp_subreify with "Hs"). - { simpl. by rewrite Hs. } - { simpl. done. } - iModIntro. iIntros "H1 H2". - iApply wp_val. by iApply ("Ha" with "H1 H2"). - Qed. + (* Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : *) + (* update_input σ = (n, σ') → *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ *) + (* WP@{rs} (INPUT k) @ s {{ Φ }}. *) + (* Proof. *) + (* intros Hs. iIntros "Hs Ha". *) + (* unfold INPUT. simpl. *) + (* iApply (wp_subreify with "Hs"). *) + (* { simpl. by rewrite Hs. } *) + (* { simpl. by rewrite ofe_iso_21. } *) + (* iModIntro. done. *) + (* Qed. *) + (* Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : *) + (* update_output n σ = σ' → *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ *) + (* WP@{rs} (OUTPUT n) @ s {{ Φ }}. *) + (* Proof. *) + (* intros Hs. iIntros "Hs Ha". *) + (* unfold OUTPUT. simpl. *) + (* iApply (wp_subreify with "Hs"). *) + (* { simpl. by rewrite Hs. } *) + (* { simpl. done. } *) + (* iModIntro. iIntros "H1 H2". *) + (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) + (* Qed. *) + + (* Lemma wp_callcc (σ : stateO) (n : nat) Φ s : *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ Φ (RetV 0)) -∗ *) + (* WP@{rs} (CALLCC n) @ s {{ Φ }}. *) + (* Proof. *) + (* intros Hs. iIntros "Hs Ha". *) + (* unfold OUTPUT. simpl. *) + (* iApply (wp_subreify with "Hs"). *) + (* { simpl. by rewrite Hs. } *) + (* { simpl. done. } *) + (* iModIntro. iIntros "H1 H2". *) + (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) + (* Qed. *) End weakestpre. Section interp. Context {sz : nat}. Variable (rs : gReifiers sz). - Context {subR : subReifier reify_io rs}. + (* Context {subR : subReifier reify_io rs}. *) Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). + Context {subEff0 : subEff ioE F}. (** Interpreting individual operators *) Program Definition interp_input {A} : A -n> IT := λne env, INPUT Ret. @@ -125,6 +270,22 @@ Section interp. Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). Proof. solve_proper. Qed. + (* Program Definition interp_callcc {A} (t : A -n> ((IT -n> IT))) (n : A -n> IT) *) + (* : A -n> IT := λne env, CALLCC (t env) (n env). *) + (* Next Obligation. *) + (* intros ???. *) + (* intros n' x y H. *) + (* do 2 f_equiv; solve_proper. *) + (* Qed. *) + + (* Program Definition interp_throw {A} (n : A -n> IT) (m : A -n> IT) *) + (* : A -n> IT := λne env, THROW (n env) (m env). *) + (* Next Obligation. *) + (* intros ???. *) + (* intros n' x y H. *) + (* do 2 f_equiv; solve_proper. *) + (* Qed. *) + 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). Solve All Obligations with solve_proper_please. @@ -134,18 +295,43 @@ Section interp. Typeclasses Opaque interp_natop. Opaque laterO_map. - Program Definition interp_rec_pre {A} (body : prodO IT (prodO IT A) -n> IT) - : laterO (A -n> IT) -n> A -n> IT := - λne self env, Fun $ laterO_map (λne (self : A -n> IT) (a : IT), - body (self env,(a,env))) self. - Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) + : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := + λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), + body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + do 3 f_equiv; intros ??; simpl; f_equiv; + intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + by do 2 f_equiv. + Qed. - Definition interp_rec {A} body : A -n> IT := mmuu (interp_rec_pre body). - Program Definition ir_unf {A} (body : prodO IT (prodO IT A) -n> IT) env : IT -n> IT := - λne a, body (interp_rec body env, (a,env)). - Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Program Definition interp_rec {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) : @interp_scope F R _ S -n> IT := mmuu (interp_rec_pre body). + + Program Definition ir_unf {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (@extend_scope F R _ _ (@extend_scope F R _ _ env (interp_rec body env)) a). + Next Obligation. + intros. + solve_proper_prepare. + f_equiv. intros [| [| y']]; simpl; solve_proper. + Qed. - Lemma interp_rec_unfold {A} (body : prodO IT (prodO IT A) -n> IT) env : + Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : interp_rec body env ≡ Fun $ Next $ ir_unf body env. Proof. trans (interp_rec_pre body (Next (interp_rec body)) env). @@ -171,396 +357,433 @@ Section interp. Program Definition interp_nat (n : nat) {A} : A -n> IT := λne env, Ret n. - (** Interpretation for all the syntactic categories: values, expressions, contexts *) - Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := - match v with - | Lit n => interp_nat n - | RecV e => interp_rec (interp_expr e) - end - with interp_expr {S} (e : expr S) : interp_scope S -n> IT := - match e with - | Val v => interp_val v - | Var x => interp_var x - | Rec e => interp_rec (interp_expr e) - | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) - | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) - | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) - | Input => interp_input - | Output e => interp_output (interp_expr e) - end. - - Program Definition interp_ctx_item {S : scope} (K : ectx_item S) : interp_scope S -n> IT -n> IT := - match K with - | AppLCtx v2 => λne env t, interp_app (constO t) (interp_val v2) env - | AppRCtx e1 => λne env t, interp_app (interp_expr e1) (constO t) env - | NatOpLCtx op v2 => λne env t, interp_natop op (constO t) (interp_val v2) env - | NatOpRCtx op e1 => λne env t, interp_natop op (interp_expr e1) (constO t) env - | IfCtx e1 e2 => λne env t, interp_if (constO t) (interp_expr e1) (interp_expr e2) env - | OutputCtx => λne env t, interp_output (constO t) env - end. - Solve All Obligations with first [ solve_proper | solve_proper_please ]. - - #[global] Instance interp_val_asval {S} (v : val S) D : AsVal (interp_val v D). - Proof. - destruct v; simpl; first apply _. - rewrite interp_rec_unfold. apply _. - Qed. - Program Fixpoint interp_ectx {S} (K : ectx S) : interp_scope S -n> IT -n> IT - := - match K with - | [] => λne env, idfun - | Ki::K => λne env, interp_ectx K env ◎ interp_ctx_item Ki env - end. - Next Obligation. solve_proper. Defined. (* XXX why can't i qed here? *) - - Lemma interp_ctx_item_fill {S} (Ki : ectx_item S) e env : - interp_expr (fill_item Ki e) env ≡ interp_ctx_item Ki env (interp_expr e env). - Proof. destruct Ki; reflexivity. Qed. - - Lemma interp_ectx_fill {S} (K : ectx S) e env : - interp_expr (fill K e) env ≡ interp_ectx K env (interp_expr e env). - Proof. - revert e; induction K as [|Ki K]=>e; first done. - rewrite IHK. simpl. rewrite interp_ctx_item_fill. done. - Qed. - - (** Applying renamings and subsitutions to the interpretation of scopes *) - Equations interp_rens_scope {S S' : scope} - (E : interp_scope (E:=F) (R:=R) S') (s : rens S S') : interp_scope (E:=F) (R:=R) S := - interp_rens_scope (S:=[]) E s := tt : interp_scope []; - interp_rens_scope (S:=_::_) E s := - (interp_var (hd_ren s) E, interp_rens_scope E (tl_ren s)). - - Equations interp_subs_scope {S S' : scope} - (E : interp_scope (E:=F) (R:=R) S') (s : subs S S') : interp_scope (E:=F) (R:=R) S := - interp_subs_scope (S:=[]) E s := tt : interp_scope []; - interp_subs_scope (S:=_::_) E s := - (interp_expr (hd_sub s) E, interp_subs_scope E (tl_sub s)). - - - Global Instance interp_rens_scope_ne S S2 n : - Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_rens_scope S S2). - Proof. - intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_rens_scope; auto. - f_equiv. - - unfold hd_ren; rewrite Hs. by f_equiv. - - apply IHS. intros v. unfold tl_ren; by rewrite Hs. - Qed. - Global Instance interp_subs_scope_ne S S2 n : - Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_subs_scope S S2). - Proof. - intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_subs_scope; auto. - f_equiv. - - unfold hd_sub; by rewrite Hs HE. - - apply IHS. intros v. unfold tl_sub; by rewrite Hs. - Qed. - Global Instance interp_rens_scope_proper S S2 : - Proper ((≡) ==> (≡) ==> (≡)) (@interp_rens_scope S S2). - Proof. - intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_rens_scope; auto. - f_equiv. - - unfold hd_ren; rewrite Hs. - by rewrite HE. - - apply IHS. intros v. unfold tl_ren; by rewrite Hs. - Qed. - Global Instance interp_subs_scope_proper S S2 : - Proper ((≡) ==> (≡) ==> (≡)) (@interp_subs_scope S S2). - Proof. - intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_subs_scope; auto. - f_equiv. - - unfold hd_sub; by rewrite Hs HE. - - apply IHS. intros v. unfold tl_sub; by rewrite Hs. - Qed. - - (** ** The substituion lemma, for renamings and substitutions *) - Lemma interp_rens_scope_tl_ren {S S2} x D (r : rens S S2) : - interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift r)) - ≡ interp_rens_scope D r. - Proof. - induction S as [|τ' S]; simp interp_rens_scope; eauto. - f_equiv. - { unfold hd_ren, tl_ren. simp rens_lift interp_var. - done. } - { rewrite -IHS. f_equiv. clear. - intros v. dependent elimination v; - unfold hd_ren, tl_ren; simp rens_lift; auto. } + Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := λne env, Fun (Next (K env)). + Next Obligation. + solve_proper. Qed. - Lemma interp_rens_scope_idren {S} (D : interp_scope S) : - interp_rens_scope D (@idren S) ≡ D. - Proof. - induction S as [|[] S]; simp interp_rens_scope. - { by destruct D. } - destruct D as [x D]. simp interp_var. simpl. - f_equiv. - trans (interp_rens_scope ((x, D) : interp_scope (()::S)) (tl_ren (rens_lift idren))). - { f_equiv. intros v. unfold tl_ren. - reflexivity. } - rewrite interp_rens_scope_tl_ren. - apply IHS. - Qed. - - Lemma interp_expr_ren {S D : scope} (M : expr S) (r : rens S D) : - ∀ (E : interp_scope D), - interp_expr (ren_expr M r) E ≡ interp_expr M (interp_rens_scope E r) - with interp_val_ren {S D : scope} (v : val S) (r : rens S D) : - ∀ (E : interp_scope D), - interp_val (ren_val v r) E ≡ interp_val v (interp_rens_scope E r). - Proof. - - revert D r. induction M=> D r D2; simpl; simp ren_expr. - all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). - + (* variable *) revert r. - induction v=>r. - * simp interp_var interp_rens_scope. done. - * simp interp_var interp_rens_scope. simpl. - apply (IHv (tl_ren r)). - + (* recursive functions *) simp ren_expr. simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr M)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_ren. - iApply f_equivI. - simp interp_rens_scope interp_var. simpl. - rewrite !interp_rens_scope_tl_ren. - iRewrite "IH". - done. - - revert D r. induction v=> D r D2; simpl; simp ren_val; eauto. - (* recursive functions *) - simp ren_expr. simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr e)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_ren. - iApply f_equivI. - simp interp_rens_scope interp_var. simpl. - rewrite !interp_rens_scope_tl_ren. - iRewrite "IH". - done. + Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_app q (λne env, K env t) env. + Next Obligation. + solve_proper. Qed. - - Lemma interp_subs_scope_tl_sub {S S2} x D (s : subs S S2) : - interp_subs_scope ((x, D) : interp_scope (()::S2)) (tl_sub (subs_lift s)) - ≡ interp_subs_scope D s. - Proof. - induction S as [|[] S]; simp interp_subs_scope; first done. - f_equiv. - { unfold hd_sub, tl_sub. simp subs_lift interp_var. - unfold expr_lift. rewrite interp_expr_ren. f_equiv. - trans (interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift idren))). - { f_equiv. intros v. unfold tl_ren. - simp rens_lift idren. done. } - rewrite interp_rens_scope_tl_ren. - apply interp_rens_scope_idren. } - { rewrite -IHS. f_equiv. clear. - intros v. dependent elimination v; - unfold hd_sub, tl_sub; simp subs_lift; auto. } + Next Obligation. + solve_proper. Qed. - - Lemma interp_subs_scope_idsub {S} (env : interp_scope S) : - interp_subs_scope env idsub ≡ env. - Proof. - induction S as [|[] S]; simp interp_subs_scope. - { by destruct env. } - destruct env as [x env]. - unfold hd_sub, idsub. simpl. - simp interp_var. simpl. f_equiv. - etrans; last first. - { apply IHS. } - rewrite -(interp_subs_scope_tl_sub x env idsub). - repeat f_equiv. intro v. unfold tl_sub, idsub; simpl. - simp subs_lift. unfold expr_lift. simp ren_expr. done. + Next Obligation. + solve_proper. Qed. - Lemma interp_expr_subst {S D : scope} (M : expr S) (s : subs S D) : - ∀ (E : interp_scope D), - interp_expr (subst_expr M s) E ≡ interp_expr M (interp_subs_scope E s) - with interp_val_subst {S D : scope} (v : val S) (s : subs S D) : - ∀ (E : interp_scope D), - interp_val (subst_val v s) E ≡ interp_val v (interp_subs_scope E s). - Proof. - - revert D s. induction M=> D r D2; simpl; simp subst_expr. - all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). - + (* variable *) revert r. - induction v=>r. - * simp interp_var interp_rens_scope. done. - * simp interp_var interp_rens_scope. simpl. - apply (IHv (tl_sub r)). - + (* recursive functions *) simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr M)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_subst. - iApply f_equivI. - simp interp_subs_scope interp_var. simpl. - rewrite !interp_subs_scope_tl_sub. - iRewrite "IH". - done. - - revert D s. induction v=> D r D2; simpl; simp subst_val; eauto. - (* recursive functions *) - simp subst_expr. simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr e)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_subst. - iApply f_equivI. - simp interp_subs_scope interp_var. simpl. - rewrite !interp_subs_scope_tl_sub. - iRewrite "IH". - done. + Program Definition interp_apprk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_app (λne env, K env t) q env. + Next Obligation. + solve_proper. Qed. - - (** ** Interpretation is a homomorphism *) - #[global] Instance interp_ectx_item_hom {S} (Ki : ectx_item S) env : - IT_hom (interp_ctx_item Ki env). - Proof. destruct Ki; simpl; apply _. Qed. - #[global] Instance interp_ectx_hom {S} (K : ectx S) env : - IT_hom (interp_ectx K env). - Proof. induction K; simpl; apply _. Qed. - - (** ** Finally, preservation of reductions *) - Lemma interp_expr_head_step {S} env (e : expr S) e' σ σ' n : - head_step e σ e' σ' (n,0) → - interp_expr e env ≡ Tick_n n $ interp_expr e' env. - Proof. - inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. - - (*fun->val*) - reflexivity. - - (* app lemma *) - rewrite APP_APP'_ITV. - trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). - { repeat f_equiv. apply interp_rec_unfold. } - rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. - simplify_eq. - rewrite interp_expr_subst. f_equiv. - simp interp_subs_scope. unfold hd_sub, tl_sub. simp conssub. - simpl. repeat f_equiv. - generalize (Val (RecV e1)). - generalize (Val v2). - clear. - intros e1 e2. - trans (interp_subs_scope env idsub); last first. - { f_equiv. intro v. simp conssub. done. } - symmetry. - apply interp_subs_scope_idsub. - - (* the natop stuff *) - simplify_eq. - destruct v1,v2; try naive_solver. simpl in *. - rewrite NATOP_Ret. - destruct op; simplify_eq/=; done. - - by rewrite IF_True. - - rewrite IF_False; eauto. lia. + Next Obligation. + solve_proper. Qed. - - Lemma interp_expr_fill_no_reify {S} K env (e e' : expr S) σ σ' n : - head_step e σ e' σ' (n,0) → - interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. - Proof. - intros He. - trans (interp_ectx K env (interp_expr e env)). - { apply interp_ectx_fill. } - trans (interp_ectx K env (Tick_n n (interp_expr e' env))). - { f_equiv. apply (interp_expr_head_step env) in He. apply He. } - trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. - { f_equiv. symmetry. apply interp_ectx_fill. } - apply hom_tick_n. apply _. + Next Obligation. + solve_proper. Qed. - Opaque INPUT OUTPUT_. - Opaque Ret. + Axiom falso : False. - Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) - (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : - head_step e σ e' σ' (n,1) → - reify (gReifiers_sReifier rs) - (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) - ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). - Proof. - intros Hst. - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) - (gState_recomp σr (sR_state σ))). - { f_equiv. by rewrite interp_ectx_fill. } - inversion Hst; simplify_eq; cbn-[gState_recomp]. - - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). - { repeat f_equiv; eauto. - rewrite hom_INPUT. f_equiv. by intro. } - rewrite reify_vis_eq //; last first. - { rewrite subReifier_reify/=//. - rewrite H4. done. } - repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. - rewrite interp_ectx_fill. - by rewrite ofe_iso_21. - - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). - { do 3 f_equiv; eauto. - rewrite get_ret_ret//. } - trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). - { do 2 f_equiv; eauto. - rewrite hom_OUTPUT_//. } - rewrite reify_vis_eq //; last first. - { rewrite subReifier_reify/=//. } - repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. - rewrite interp_ectx_fill. - simpl. done. - Qed. + (** Interpretation for all the syntactic categories: values, expressions, contexts *) + Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := + match v with + | LitV n => interp_nat n + | VarV x => interp_var x + | RecV e => interp_rec (interp_expr e) + | ContV K => interp_cont (interp_ectx K) + end + with interp_expr {S} (e : expr S) : interp_scope S -n> IT := + match e with + | Val v => interp_val v + | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) + | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) + | Input => interp_input + | Output e => interp_output (interp_expr e) + | Callcc e => + (* interp_callcc _ (interp_expr e) *) + False_rect _ falso + | Throw e1 e2 => + (* interp_throw e1 e2 *) + False_rect _ falso + end + with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := + match K with + | EmptyK => + λne env, λne t, t + | AppLK e1 K => interp_applk (interp_expr e1) (interp_ectx K) + | AppRK K v2 => interp_apprk (interp_ectx K) (interp_val v2) + | NatOpLK op e1 K => + False_rect _ falso + | NatOpRK op K v2 => + False_rect _ falso + | IfK K e1 e2 => + False_rect _ falso + | OutputK K => + False_rect _ falso + | ThrowLK K e => + False_rect _ falso + | ThrowRK v K => + False_rect _ falso + end. + Solve All Obligations with first [ solve_proper | solve_proper_please ]. - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m env : - prim_step e1 σ1 e2 σ2 (n,m) → - ssteps (gReifiers_sReifier rs) - (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) - (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. - Proof. - Opaque gState_decomp gState_recomp. - inversion 1; simplify_eq/=. - destruct (head_step_io_01 _ _ _ _ _ _ H2); subst. - - assert (σ1 = σ2) as ->. - { eapply head_step_no_io; eauto. } - eapply (interp_expr_fill_no_reify K) in H2. - rewrite H2. eapply ssteps_tick_n. - - inversion H2;subst. - + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. - rewrite interp_ectx_fill. - rewrite hom_INPUT. - change 1 with (1+0). econstructor; last first. - { apply ssteps_zero; reflexivity. } - eapply sstep_reify. - { Transparent INPUT. unfold INPUT. simpl. - f_equiv. reflexivity. } - simpl in H2. - rewrite -H2. - repeat f_equiv; eauto. - rewrite interp_ectx_fill hom_INPUT. - eauto. - + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. - rewrite interp_ectx_fill. simpl. - rewrite get_ret_ret. - rewrite hom_OUTPUT_. - change 1 with (1+0). econstructor; last first. - { apply ssteps_zero; reflexivity. } - eapply sstep_reify. - { Transparent OUTPUT_. unfold OUTPUT_. simpl. - f_equiv. reflexivity. } - simpl in H2. - rewrite -H2. - repeat f_equiv; eauto. - Opaque OUTPUT_. - rewrite interp_ectx_fill /= get_ret_ret hom_OUTPUT_. - eauto. - Qed. + (* #[global] Instance interp_val_asval {S} (v : val S) D : AsVal (interp_val v D). *) + (* Proof. *) + (* destruct v; simpl; first apply _. *) + (* rewrite interp_rec_unfold. apply _. *) + (* Qed. *) + + (* Lemma interp_ctx_item_fill {S} (Ki : ectx_item S) e env : *) + (* interp_expr (fill_item Ki e) env ≡ interp_ctx_item Ki env (interp_expr e env). *) + (* Proof. destruct Ki; reflexivity. Qed. *) + + (* Lemma interp_ectx_fill {S} (K : ectx S) e env : *) + (* interp_expr (fill K e) env ≡ interp_ectx K env (interp_expr e env). *) + (* Proof. *) + (* revert e; induction K as [|Ki K]=>e; first done. *) + (* rewrite IHK. simpl. rewrite interp_ctx_item_fill. done. *) + (* Qed. *) + + (* (** Applying renamings and subsitutions to the interpretation of scopes *) *) + (* Equations interp_rens_scope {S S' : scope} *) + (* (E : interp_scope (E:=F) (R:=R) S') (s : rens S S') : interp_scope (E:=F) (R:=R) S := *) + (* interp_rens_scope (S:=[]) E s := tt : interp_scope []; *) + (* interp_rens_scope (S:=_::_) E s := *) + (* (interp_var (hd_ren s) E, interp_rens_scope E (tl_ren s)). *) + + (* Equations interp_subs_scope {S S' : scope} *) + (* (E : interp_scope (E:=F) (R:=R) S') (s : subs S S') : interp_scope (E:=F) (R:=R) S := *) + (* interp_subs_scope (S:=[]) E s := tt : interp_scope []; *) + (* interp_subs_scope (S:=_::_) E s := *) + (* (interp_expr (hd_sub s) E, interp_subs_scope E (tl_sub s)). *) + + + (* Global Instance interp_rens_scope_ne S S2 n : *) + (* Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_rens_scope S S2). *) + (* Proof. *) + (* intros D D' HE s1 s2 Hs. *) + (* induction S as [|τ' S]; simp interp_rens_scope; auto. *) + (* f_equiv. *) + (* - unfold hd_ren; rewrite Hs. by f_equiv. *) + (* - apply IHS. intros v. unfold tl_ren; by rewrite Hs. *) + (* Qed. *) + (* Global Instance interp_subs_scope_ne S S2 n : *) + (* Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_subs_scope S S2). *) + (* Proof. *) + (* intros D D' HE s1 s2 Hs. *) + (* induction S as [|τ' S]; simp interp_subs_scope; auto. *) + (* f_equiv. *) + (* - unfold hd_sub; by rewrite Hs HE. *) + (* - apply IHS. intros v. unfold tl_sub; by rewrite Hs. *) + (* Qed. *) + (* Global Instance interp_rens_scope_proper S S2 : *) + (* Proper ((≡) ==> (≡) ==> (≡)) (@interp_rens_scope S S2). *) + (* Proof. *) + (* intros D D' HE s1 s2 Hs. *) + (* induction S as [|τ' S]; simp interp_rens_scope; auto. *) + (* f_equiv. *) + (* - unfold hd_ren; rewrite Hs. *) + (* by rewrite HE. *) + (* - apply IHS. intros v. unfold tl_ren; by rewrite Hs. *) + (* Qed. *) + (* Global Instance interp_subs_scope_proper S S2 : *) + (* Proper ((≡) ==> (≡) ==> (≡)) (@interp_subs_scope S S2). *) + (* Proof. *) + (* intros D D' HE s1 s2 Hs. *) + (* induction S as [|τ' S]; simp interp_subs_scope; auto. *) + (* f_equiv. *) + (* - unfold hd_sub; by rewrite Hs HE. *) + (* - apply IHS. intros v. unfold tl_sub; by rewrite Hs. *) + (* Qed. *) + + (* (** ** The substituion lemma, for renamings and substitutions *) *) + (* Lemma interp_rens_scope_tl_ren {S S2} x D (r : rens S S2) : *) + (* interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift r)) *) + (* ≡ interp_rens_scope D r. *) + (* Proof. *) + (* induction S as [|τ' S]; simp interp_rens_scope; eauto. *) + (* f_equiv. *) + (* { unfold hd_ren, tl_ren. simp rens_lift interp_var. *) + (* done. } *) + (* { rewrite -IHS. f_equiv. clear. *) + (* intros v. dependent elimination v; *) + (* unfold hd_ren, tl_ren; simp rens_lift; auto. } *) + (* Qed. *) + + (* Lemma interp_rens_scope_idren {S} (D : interp_scope S) : *) + (* interp_rens_scope D (@idren S) ≡ D. *) + (* Proof. *) + (* induction S as [|[] S]; simp interp_rens_scope. *) + (* { by destruct D. } *) + (* destruct D as [x D]. simp interp_var. simpl. *) + (* f_equiv. *) + (* trans (interp_rens_scope ((x, D) : interp_scope (()::S)) (tl_ren (rens_lift idren))). *) + (* { f_equiv. intros v. unfold tl_ren. *) + (* reflexivity. } *) + (* rewrite interp_rens_scope_tl_ren. *) + (* apply IHS. *) + (* Qed. *) + + (* Lemma interp_expr_ren {S D : scope} (M : expr S) (r : rens S D) : *) + (* ∀ (E : interp_scope D), *) + (* interp_expr (ren_expr M r) E ≡ interp_expr M (interp_rens_scope E r) *) + (* with interp_val_ren {S D : scope} (v : val S) (r : rens S D) : *) + (* ∀ (E : interp_scope D), *) + (* interp_val (ren_val v r) E ≡ interp_val v (interp_rens_scope E r). *) + (* Proof. *) + (* - revert D r. induction M=> D r D2; simpl; simp ren_expr. *) + (* all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). *) + (* + (* variable *) revert r. *) + (* induction v=>r. *) + (* * simp interp_var interp_rens_scope. done. *) + (* * simp interp_var interp_rens_scope. simpl. *) + (* apply (IHv (tl_ren r)). *) + (* + (* recursive functions *) simp ren_expr. simpl. *) + (* apply bi.siProp.internal_eq_soundness. *) + (* iLöb as "IH". *) + (* rewrite {2}interp_rec_unfold. *) + (* rewrite {2}(interp_rec_unfold (interp_expr M)). *) + (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) + (* rewrite /ir_unf. iIntros (x). simpl. *) + (* rewrite interp_expr_ren. *) + (* iApply f_equivI. *) + (* simp interp_rens_scope interp_var. simpl. *) + (* rewrite !interp_rens_scope_tl_ren. *) + (* iRewrite "IH". *) + (* done. *) + (* - revert D r. induction v=> D r D2; simpl; simp ren_val; eauto. *) + (* (* recursive functions *) *) + (* simp ren_expr. simpl. *) + (* apply bi.siProp.internal_eq_soundness. *) + (* iLöb as "IH". *) + (* rewrite {2}interp_rec_unfold. *) + (* rewrite {2}(interp_rec_unfold (interp_expr e)). *) + (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) + (* rewrite /ir_unf. iIntros (x). simpl. *) + (* rewrite interp_expr_ren. *) + (* iApply f_equivI. *) + (* simp interp_rens_scope interp_var. simpl. *) + (* rewrite !interp_rens_scope_tl_ren. *) + (* iRewrite "IH". *) + (* done. *) + (* Qed. *) + + (* Lemma interp_subs_scope_tl_sub {S S2} x D (s : subs S S2) : *) + (* interp_subs_scope ((x, D) : interp_scope (()::S2)) (tl_sub (subs_lift s)) *) + (* ≡ interp_subs_scope D s. *) + (* Proof. *) + (* induction S as [|[] S]; simp interp_subs_scope; first done. *) + (* f_equiv. *) + (* { unfold hd_sub, tl_sub. simp subs_lift interp_var. *) + (* unfold expr_lift. rewrite interp_expr_ren. f_equiv. *) + (* trans (interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift idren))). *) + (* { f_equiv. intros v. unfold tl_ren. *) + (* simp rens_lift idren. done. } *) + (* rewrite interp_rens_scope_tl_ren. *) + (* apply interp_rens_scope_idren. } *) + (* { rewrite -IHS. f_equiv. clear. *) + (* intros v. dependent elimination v; *) + (* unfold hd_sub, tl_sub; simp subs_lift; auto. } *) + (* Qed. *) + + (* Lemma interp_subs_scope_idsub {S} (env : interp_scope S) : *) + (* interp_subs_scope env idsub ≡ env. *) + (* Proof. *) + (* induction S as [|[] S]; simp interp_subs_scope. *) + (* { by destruct env. } *) + (* destruct env as [x env]. *) + (* unfold hd_sub, idsub. simpl. *) + (* simp interp_var. simpl. f_equiv. *) + (* etrans; last first. *) + (* { apply IHS. } *) + (* rewrite -(interp_subs_scope_tl_sub x env idsub). *) + (* repeat f_equiv. intro v. unfold tl_sub, idsub; simpl. *) + (* simp subs_lift. unfold expr_lift. simp ren_expr. done. *) + (* Qed. *) + + (* Lemma interp_expr_subst {S D : scope} (M : expr S) (s : subs S D) : *) + (* ∀ (E : interp_scope D), *) + (* interp_expr (subst_expr M s) E ≡ interp_expr M (interp_subs_scope E s) *) + (* with interp_val_subst {S D : scope} (v : val S) (s : subs S D) : *) + (* ∀ (E : interp_scope D), *) + (* interp_val (subst_val v s) E ≡ interp_val v (interp_subs_scope E s). *) + (* Proof. *) + (* - revert D s. induction M=> D r D2; simpl; simp subst_expr. *) + (* all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). *) + (* + (* variable *) revert r. *) + (* induction v=>r. *) + (* * simp interp_var interp_rens_scope. done. *) + (* * simp interp_var interp_rens_scope. simpl. *) + (* apply (IHv (tl_sub r)). *) + (* + (* recursive functions *) simpl. *) + (* apply bi.siProp.internal_eq_soundness. *) + (* iLöb as "IH". *) + (* rewrite {2}interp_rec_unfold. *) + (* rewrite {2}(interp_rec_unfold (interp_expr M)). *) + (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) + (* rewrite /ir_unf. iIntros (x). simpl. *) + (* rewrite interp_expr_subst. *) + (* iApply f_equivI. *) + (* simp interp_subs_scope interp_var. simpl. *) + (* rewrite !interp_subs_scope_tl_sub. *) + (* iRewrite "IH". *) + (* done. *) + (* - revert D s. induction v=> D r D2; simpl; simp subst_val; eauto. *) + (* (* recursive functions *) *) + (* simp subst_expr. simpl. *) + (* apply bi.siProp.internal_eq_soundness. *) + (* iLöb as "IH". *) + (* rewrite {2}interp_rec_unfold. *) + (* rewrite {2}(interp_rec_unfold (interp_expr e)). *) + (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) + (* rewrite /ir_unf. iIntros (x). simpl. *) + (* rewrite interp_expr_subst. *) + (* iApply f_equivI. *) + (* simp interp_subs_scope interp_var. simpl. *) + (* rewrite !interp_subs_scope_tl_sub. *) + (* iRewrite "IH". *) + (* done. *) + (* Qed. *) + + (* (** ** Interpretation is a homomorphism *) *) + (* #[global] Instance interp_ectx_item_hom {S} (Ki : ectx_item S) env : *) + (* IT_hom (interp_ctx_item Ki env). *) + (* Proof. destruct Ki; simpl; apply _. Qed. *) + (* #[global] Instance interp_ectx_hom {S} (K : ectx S) env : *) + (* IT_hom (interp_ectx K env). *) + (* Proof. induction K; simpl; apply _. Qed. *) + + (* (** ** Finally, preservation of reductions *) *) + (* Lemma interp_expr_head_step {S} env (e : expr S) e' σ σ' n : *) + (* head_step e σ e' σ' (n,0) → *) + (* interp_expr e env ≡ Tick_n n $ interp_expr e' env. *) + (* Proof. *) + (* inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. *) + (* - (*fun->val*) *) + (* reflexivity. *) + (* - (* app lemma *) *) + (* rewrite APP_APP'_ITV. *) + (* trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). *) + (* { repeat f_equiv. apply interp_rec_unfold. } *) + (* rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. *) + (* simplify_eq. *) + (* rewrite interp_expr_subst. f_equiv. *) + (* simp interp_subs_scope. unfold hd_sub, tl_sub. simp conssub. *) + (* simpl. repeat f_equiv. *) + (* generalize (Val (RecV e1)). *) + (* generalize (Val v2). *) + (* clear. *) + (* intros e1 e2. *) + (* trans (interp_subs_scope env idsub); last first. *) + (* { f_equiv. intro v. simp conssub. done. } *) + (* symmetry. *) + (* apply interp_subs_scope_idsub. *) + (* - (* the natop stuff *) *) + (* simplify_eq. *) + (* destruct v1,v2; try naive_solver. simpl in *. *) + (* rewrite NATOP_Ret. *) + (* destruct op; simplify_eq/=; done. *) + (* - by rewrite IF_True. *) + (* - rewrite IF_False; eauto. lia. *) + (* Qed. *) + + (* Lemma interp_expr_fill_no_reify {S} K env (e e' : expr S) σ σ' n : *) + (* head_step e σ e' σ' (n,0) → *) + (* interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. *) + (* Proof. *) + (* intros He. *) + (* trans (interp_ectx K env (interp_expr e env)). *) + (* { apply interp_ectx_fill. } *) + (* trans (interp_ectx K env (Tick_n n (interp_expr e' env))). *) + (* { f_equiv. apply (interp_expr_head_step env) in He. apply He. } *) + (* trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. *) + (* { f_equiv. symmetry. apply interp_ectx_fill. } *) + (* apply hom_tick_n. apply _. *) + (* Qed. *) + + (* Opaque INPUT OUTPUT_. *) + (* Opaque Ret. *) + + (* Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) *) + (* (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : *) + (* head_step e σ e' σ' (n,1) → *) + (* reify (gReifiers_sReifier rs) *) + (* (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) *) + (* ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). *) + (* Proof. *) + (* intros Hst. *) + (* trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) *) + (* (gState_recomp σr (sR_state σ))). *) + (* { f_equiv. by rewrite interp_ectx_fill. } *) + (* inversion Hst; simplify_eq; cbn-[gState_recomp]. *) + (* - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). *) + (* { repeat f_equiv; eauto. *) + (* rewrite hom_INPUT. f_equiv. by intro. } *) + (* rewrite reify_vis_eq //; last first. *) + (* { rewrite subReifier_reify/=//. *) + (* rewrite H4. done. } *) + (* repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. *) + (* rewrite interp_ectx_fill. *) + (* by rewrite ofe_iso_21. *) + (* - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). *) + (* { do 3 f_equiv; eauto. *) + (* rewrite get_ret_ret//. } *) + (* trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). *) + (* { do 2 f_equiv; eauto. *) + (* rewrite hom_OUTPUT_//. } *) + (* rewrite reify_vis_eq //; last first. *) + (* { rewrite subReifier_reify/=//. } *) + (* repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. *) + (* rewrite interp_ectx_fill. *) + (* simpl. done. *) + (* Qed. *) + + (* Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m env : *) + (* prim_step e1 σ1 e2 σ2 (n,m) → *) + (* ssteps (gReifiers_sReifier rs) *) + (* (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) *) + (* (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. *) + (* Proof. *) + (* Opaque gState_decomp gState_recomp. *) + (* inversion 1; simplify_eq/=. *) + (* destruct (head_step_io_01 _ _ _ _ _ _ H2); subst. *) + (* - assert (σ1 = σ2) as ->. *) + (* { eapply head_step_no_io; eauto. } *) + (* eapply (interp_expr_fill_no_reify K) in H2. *) + (* rewrite H2. eapply ssteps_tick_n. *) + (* - inversion H2;subst. *) + (* + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) + (* rewrite interp_ectx_fill. *) + (* rewrite hom_INPUT. *) + (* change 1 with (1+0). econstructor; last first. *) + (* { apply ssteps_zero; reflexivity. } *) + (* eapply sstep_reify. *) + (* { Transparent INPUT. unfold INPUT. simpl. *) + (* f_equiv. reflexivity. } *) + (* simpl in H2. *) + (* rewrite -H2. *) + (* repeat f_equiv; eauto. *) + (* rewrite interp_ectx_fill hom_INPUT. *) + (* eauto. *) + (* + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) + (* rewrite interp_ectx_fill. simpl. *) + (* rewrite get_ret_ret. *) + (* rewrite hom_OUTPUT_. *) + (* change 1 with (1+0). econstructor; last first. *) + (* { apply ssteps_zero; reflexivity. } *) + (* eapply sstep_reify. *) + (* { Transparent OUTPUT_. unfold OUTPUT_. simpl. *) + (* f_equiv. reflexivity. } *) + (* simpl in H2. *) + (* rewrite -H2. *) + (* repeat f_equiv; eauto. *) + (* Opaque OUTPUT_. *) + (* rewrite interp_ectx_fill /= get_ret_ret hom_OUTPUT_. *) + (* eauto. *) + (* Qed. *) End interp. #[global] Opaque INPUT OUTPUT_. diff --git a/theories/input_lang/lang.v b/theories/input_lang/lang.v index 491acc6..5dc84c8 100644 --- a/theories/input_lang/lang.v +++ b/theories/input_lang/lang.v @@ -358,23 +358,23 @@ Inductive head_step {S} : expr S → state → expr S → state → ectx S → n | BetaS e1 v2 σ K : head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (Inc := inc) e1) (shift v2)) (RecV e1)) σ K (1,0) | InputS σ n σ' K : - update_input σ = (n,σ') → - head_step Input σ (Val (LitV n)) σ' K (1,1) + update_input σ = (n, σ') → + head_step Input σ (Val (LitV n)) σ' K (1, 1) | OutputS σ n σ' K : update_output n σ = σ' → - head_step (Output (Val (LitV n))) σ (Val (LitV 0)) σ' K (1,1) + head_step (Output (Val (LitV n))) σ (Val (LitV 0)) σ' K (1, 1) | NatOpS op v1 v2 v3 σ K : nat_op_interp op v1 v2 = Some v3 → head_step (NatOp op (Val v1) (Val v2)) σ - (Val v3) σ K (0,0) + (Val v3) σ K (0, 0) | IfTrueS n e1 e2 σ K : n > 0 → head_step (If (Val (LitV n)) e1 e2) σ - e1 σ K (0,0) + e1 σ K (0, 0) | IfFalseS n e1 e2 σ K : n = 0 → head_step (If (Val (LitV n)) e1 e2) σ - e2 σ K (0,0) + e2 σ K (0, 0) | CallccS e σ K : head_step (Callcc e) σ (subst (Inc := inc) e (ContV K)) σ K (0, 0) . diff --git a/theories/lang_generic.v b/theories/lang_generic.v index 84cadee..e8fe352 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -1,42 +1,42 @@ -From gitrees Require Import prelude. -From Equations Require Import Equations. -Require Import List. -Import ListNotations. - -(** XXX: We /NEED/ this line for [Equations Derive] to work, - this flag is globally unset by std++, but Equations need obligations to be transparent. *) -Set Transparent Obligations. - -Derive NoConfusion NoConfusionHom for list. - -Definition scope := (list unit). - -(** Variables in a context *) -Inductive var : scope → Type := -| Vz : forall {S : scope} {s}, var (s::S) -| Vs : forall {S : scope} {s}, var S -> var (s::S) -. -Derive Signature NoConfusion for var. - -Inductive tyctx (ty : Type) : scope → Type := -| empC : tyctx ty [] -| consC : forall{Γ}, ty → tyctx ty Γ → tyctx ty (()::Γ) -. -Arguments empC {_}. -Arguments consC {_ _} _ _. - -Equations list_of_tyctx {S ty} (Γ : tyctx ty S) : list ty := - list_of_tyctx empC := []; - list_of_tyctx (consC τ Γ') := τ::list_of_tyctx Γ'. - -Equations tyctx_app {S1 S2 ty} (c1 : tyctx ty S1) (c2 : tyctx ty S2) : tyctx ty (S1++S2) := - tyctx_app empC c2 := c2; - tyctx_app (consC τ c1) c2 := consC τ (tyctx_app c1 c2). - -Inductive typed_var {ty : Type}: forall {S}, tyctx ty S → var S → ty → Prop := -| typed_var_Z S (τ : ty) (Γ : tyctx ty S) : - typed_var (consC τ Γ) Vz τ -| typed_var_S S (τ τ' : ty) (Γ : tyctx ty S) v : - typed_var Γ v τ → - typed_var (consC τ' Γ) (Vs v) τ -. +(* From gitrees Require Import prelude. *) +(* From Equations Require Import Equations. *) +(* Require Import List. *) +(* Import ListNotations. *) + +(* (** XXX: We /NEED/ this line for [Equations Derive] to work, *) +(* this flag is globally unset by std++, but Equations need obligations to be transparent. *) *) +(* Set Transparent Obligations. *) + +(* Derive NoConfusion NoConfusionHom for list. *) + +(* Definition scope := (list unit). *) + +(* (** Variables in a context *) *) +(* Inductive var : scope → Type := *) +(* | Vz : forall {S : scope} {s}, var (s::S) *) +(* | Vs : forall {S : scope} {s}, var S -> var (s::S) *) +(* . *) +(* Derive Signature NoConfusion for var. *) + +(* Inductive tyctx (ty : Type) : scope → Type := *) +(* | empC : tyctx ty [] *) +(* | consC : forall{Γ}, ty → tyctx ty Γ → tyctx ty (()::Γ) *) +(* . *) +(* Arguments empC {_}. *) +(* Arguments consC {_ _} _ _. *) + +(* Equations list_of_tyctx {S ty} (Γ : tyctx ty S) : list ty := *) +(* list_of_tyctx empC := []; *) +(* list_of_tyctx (consC τ Γ') := τ::list_of_tyctx Γ'. *) + +(* Equations tyctx_app {S1 S2 ty} (c1 : tyctx ty S1) (c2 : tyctx ty S2) : tyctx ty (S1++S2) := *) +(* tyctx_app empC c2 := c2; *) +(* tyctx_app (consC τ c1) c2 := consC τ (tyctx_app c1 c2). *) + +(* Inductive typed_var {ty : Type}: forall {S}, tyctx ty S → var S → ty → Prop := *) +(* | typed_var_Z S (τ : ty) (Γ : tyctx ty S) : *) +(* typed_var (consC τ Γ) Vz τ *) +(* | typed_var_S S (τ τ' : ty) (Γ : tyctx ty S) v : *) +(* typed_var Γ v τ → *) +(* typed_var (consC τ' Γ) (Vs v) τ *) +(* . *) diff --git a/theories/lang_generic_sem.v b/theories/lang_generic_sem.v index fb0000c..22caf4b 100644 --- a/theories/lang_generic_sem.v +++ b/theories/lang_generic_sem.v @@ -3,6 +3,9 @@ From gitrees Require Import gitree. Require Import List. Import ListNotations. +Require Import Binding.Lib. +From Equations Require Import Equations. + Section interp. Local Open Scope type. Context {E: opsInterp}. @@ -10,74 +13,67 @@ Section interp. Notation IT := (IT E R). Notation ITV := (ITV E R). - Fixpoint interp_scope (S : scope) : ofe := - match S with - | [] => unitO - | τ::Sc => prodO IT (interp_scope Sc) - end. - - Instance interp_scope_cofe S : Cofe (interp_scope S). - Proof. induction S; simpl; apply _. Qed. + Definition interp_scope (S : Set) : ofe := (leibnizO S) -n> IT. - Instance interp_scope_inhab S : Inhabited (interp_scope S). - Proof. induction S; simpl; apply _. Defined. + Global Instance interp_scope_cofe S : Cofe (interp_scope S). + Proof. apply _. Qed. - Equations interp_var {S : scope} (v : var S) : interp_scope S -n> IT := - interp_var (S:=(_::_)) Vz := fstO; - interp_var (S:=(_::Sc)) (Vs v) := interp_var v ◎ sndO. + Global Instance interp_scope_inhab S : Inhabited (interp_scope S). + Proof. apply _. Defined. - Instance interp_var_ne S (v : var S) : NonExpansive (@interp_var S v). - Proof. - intros n D1 D2 HD12. induction v; simp interp_var. - - by f_equiv. - - eapply IHv. by f_equiv. - Qed. + Program Definition interp_var {S : Set} (v : S) : interp_scope S -n> IT := + λne (f : interp_scope S), f v. - Global Instance interp_var_proper S (v : var S) : Proper ((≡) ==> (≡)) (interp_var v). + Global Instance interp_var_proper {S : Set} (v : S) : Proper ((≡) ==> (≡)) (interp_var v). Proof. apply ne_proper. apply _. Qed. - Definition interp_scope_split {S1 S2} : - interp_scope (S1 ++ S2) -n> interp_scope S1 * interp_scope S2. - Proof. - induction S1 as [|? S1]; simpl. - - simple refine (λne x, (tt, x)). - solve_proper. - - simple refine (λne xy, let ss := IHS1 xy.2 in ((xy.1, ss.1), ss.2)). - solve_proper. - Defined. - - (** scope substituions *) - Inductive ssubst : scope → Type := - | emp_ssubst : ssubst [] - | cons_ssubst {S} : ITV → ssubst S → ssubst (tt::S) - . - - Equations interp_ssubst {S} (ss : ssubst S) : interp_scope S := - interp_ssubst emp_ssubst := tt; - interp_ssubst (cons_ssubst αv ss) := (IT_of_V αv, interp_ssubst ss). - - Equations list_of_ssubst {S} (ss : ssubst S) : list ITV := - list_of_ssubst emp_ssubst := []; - list_of_ssubst (cons_ssubst αv ss) := αv::(list_of_ssubst ss). - - Equations ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : ssubst S1 * ssubst S2 := - ssubst_split (S1:=[]) αs := (emp_ssubst,αs); - ssubst_split (S1:=u::_) (cons_ssubst αv αs) := - (cons_ssubst αv (ssubst_split αs).1, (ssubst_split αs).2). - Lemma interp_scope_ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : - interp_scope_split (interp_ssubst αs) ≡ - (interp_ssubst (ssubst_split αs).1, interp_ssubst (ssubst_split αs).2). - Proof. - induction S1 as [|u S1]; simpl. - - simp ssubst_split. simpl. - simp interp_ssubst. done. - - dependent elimination αs as [cons_ssubst αv αs]. - simp ssubst_split. simpl. - simp interp_ssubst. repeat f_equiv; eauto; simpl. - + rewrite IHS1//. - + rewrite IHS1//. + (* TODO: rewrite in normal-human-being style *) + Program Definition extend_scope {S : Set} : interp_scope S -n> IT -n> interp_scope (inc S) + := λne γ μ x, let x' : inc S := x in match x' with | VZ => μ | VS x'' => γ x'' end. + Next Obligation. + match goal with + | H : context G [(inc S)] |- _ => revert H + end. + intros [| a]; simpl; solve_proper. + Qed. + Next Obligation. + match goal with + | H : context G [(inc S)] |- _ => revert H + end. + intros [| a]; simpl; solve_proper. Qed. + (* (** scope substituions *) *) + (* Inductive ssubst : Set → Type := *) + (* | emp_ssubst : ssubst ∅ *) + (* | cons_ssubst {S} : ITV → ssubst S → ssubst (inc S) *) + (* . *) + + (* Equations interp_ssubst {S} (ss : ssubst S) : interp_scope S := *) + (* interp_ssubst emp_ssubst := tt; *) + (* interp_ssubst (cons_ssubst αv ss) := (IT_of_V αv, interp_ssubst ss). *) + + (* Equations list_of_ssubst {S} (ss : ssubst S) : list ITV := *) + (* list_of_ssubst emp_ssubst := []; *) + (* list_of_ssubst (cons_ssubst αv ss) := αv::(list_of_ssubst ss). *) + + (* Equations ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : ssubst S1 * ssubst S2 := *) + (* ssubst_split (S1:=[]) αs := (emp_ssubst,αs); *) + (* ssubst_split (S1:=u::_) (cons_ssubst αv αs) := *) + (* (cons_ssubst αv (ssubst_split αs).1, (ssubst_split αs).2). *) + (* Lemma interp_scope_ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : *) + (* interp_scope_split (interp_ssubst αs) ≡ *) + (* (interp_ssubst (ssubst_split αs).1, interp_ssubst (ssubst_split αs).2). *) + (* Proof. *) + (* induction S1 as [|u S1]; simpl. *) + (* - simp ssubst_split. simpl. *) + (* simp interp_ssubst. done. *) + (* - dependent elimination αs as [cons_ssubst αv αs]. *) + (* simp ssubst_split. simpl. *) + (* simp interp_ssubst. repeat f_equiv; eauto; simpl. *) + (* + rewrite IHS1//. *) + (* + rewrite IHS1//. *) + (* Qed. *) End interp. (* Common definitions and lemmas for Kripke logical relations *) @@ -109,43 +105,43 @@ Section kripke_logrel. #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . Proof. solve_proper. Qed. - Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : tyctx ty S) (ss : ssubst S) : iProp := - ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), - interp_ty (τx.1) (τx.2))%I. - - Lemma ssubst_valid_nil {ty} (interp_ty : ty → ITV -n> iProp) : - ⊢ ssubst_valid interp_ty empC emp_ssubst. - Proof. - unfold ssubst_valid. - by simp list_of_tyctx list_of_ssubst. - Qed. - - Lemma ssubst_valid_cons {ty} (interp_ty : ty → ITV -n> iProp) {S} - (Γ : tyctx ty S) (ss : ssubst S) τ αv : - ssubst_valid interp_ty (consC τ Γ) (cons_ssubst αv ss) - ⊣⊢ interp_ty τ αv ∗ ssubst_valid interp_ty Γ ss. - Proof. - unfold ssubst_valid. - by simp list_of_tyctx list_of_ssubst. - Qed. - - Lemma ssubst_valid_app {ty} (interp_ty : ty → ITV -n> iProp) - {S1 S2} (Ω1 : tyctx ty S1) (Ω2 : tyctx ty S2) αs : - ssubst_valid interp_ty (tyctx_app Ω1 Ω2) αs ⊢ - ssubst_valid interp_ty Ω1 (ssubst_split αs).1 - ∗ ssubst_valid interp_ty Ω2 (ssubst_split αs).2. - Proof. - iInduction Ω1 as [|τ Ω1] "IH" forall (Ω2); simp tyctx_app ssubst_split. - - simpl. iIntros "$". iApply ssubst_valid_nil. - - iIntros "H". - rewrite {4 5}/ssubst_valid. - simpl in αs. - dependent elimination αs as [cons_ssubst αv αs]. - simp ssubst_split. simpl. - simp list_of_ssubst list_of_tyctx. - simpl. iDestruct "H" as "[$ H]". - by iApply "IH". - Qed. + (* Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : tyctx ty S) (ss : ssubst S) : iProp := *) + (* ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), *) + (* interp_ty (τx.1) (τx.2))%I. *) + + (* Lemma ssubst_valid_nil {ty} (interp_ty : ty → ITV -n> iProp) : *) + (* ⊢ ssubst_valid interp_ty empC emp_ssubst. *) + (* Proof. *) + (* unfold ssubst_valid. *) + (* by simp list_of_tyctx list_of_ssubst. *) + (* Qed. *) + + (* Lemma ssubst_valid_cons {ty} (interp_ty : ty → ITV -n> iProp) {S} *) + (* (Γ : tyctx ty S) (ss : ssubst S) τ αv : *) + (* ssubst_valid interp_ty (consC τ Γ) (cons_ssubst αv ss) *) + (* ⊣⊢ interp_ty τ αv ∗ ssubst_valid interp_ty Γ ss. *) + (* Proof. *) + (* unfold ssubst_valid. *) + (* by simp list_of_tyctx list_of_ssubst. *) + (* Qed. *) + + (* Lemma ssubst_valid_app {ty} (interp_ty : ty → ITV -n> iProp) *) + (* {S1 S2} (Ω1 : tyctx ty S1) (Ω2 : tyctx ty S2) αs : *) + (* ssubst_valid interp_ty (tyctx_app Ω1 Ω2) αs ⊢ *) + (* ssubst_valid interp_ty Ω1 (ssubst_split αs).1 *) + (* ∗ ssubst_valid interp_ty Ω2 (ssubst_split αs).2. *) + (* Proof. *) + (* iInduction Ω1 as [|τ Ω1] "IH" forall (Ω2); simp tyctx_app ssubst_split. *) + (* - simpl. iIntros "$". iApply ssubst_valid_nil. *) + (* - iIntros "H". *) + (* rewrite {4 5}/ssubst_valid. *) + (* simpl in αs. *) + (* dependent elimination αs as [cons_ssubst αv αs]. *) + (* simp ssubst_split. simpl. *) + (* simp list_of_ssubst list_of_tyctx. *) + (* simpl. iDestruct "H" as "[$ H]". *) + (* by iApply "IH". *) + (* Qed. *) Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : Φ αv ⊢ expr_pred α Φ. @@ -155,21 +151,21 @@ Section kripke_logrel. eauto with iFrame. Qed. - Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : - expr_pred α Ψ ⊢ - (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ - expr_pred (f α) Φ. - Proof. - iIntros "H1 H2". - iIntros (x) "Hx". - iApply wp_bind. - { solve_proper. } - iSpecialize ("H1" with "Hx"). - iApply (wp_wand with "H1"). - iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". - iModIntro. - iApply ("H2" with "Hb Hy"). - Qed. + (* Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : *) + (* expr_pred α Ψ ⊢ *) + (* (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ *) + (* expr_pred (f α) Φ. *) + (* Proof. *) + (* iIntros "H1 H2". *) + (* iIntros (x) "Hx". *) + (* iApply wp_bind. *) + (* { solve_proper. } *) + (* iSpecialize ("H1" with "Hx"). *) + (* iApply (wp_wand with "H1"). *) + (* iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". *) + (* iModIntro. *) + (* iApply ("H2" with "Hb Hy"). *) + (* Qed. *) Lemma expr_pred_frame α Φ : WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. @@ -179,5 +175,7 @@ Section kripke_logrel. iApply (wp_wand with "H"). eauto with iFrame. Qed. + End kripke_logrel. -Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. + +(* Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. *) From 9ab561b145b8882be77911d418fa91c8016f5175 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Tue, 7 Nov 2023 18:11:12 +0100 Subject: [PATCH 007/114] minor reifier changes --- theories/gitree/greifiers.v | 285 +++++++++++++++++++---------------- theories/gitree/reify.v | 124 +++++++-------- theories/input_lang/interp.v | 4 + 3 files changed, 215 insertions(+), 198 deletions(-) diff --git a/theories/gitree/greifiers.v b/theories/gitree/greifiers.v index ba07b0b..b6735f3 100644 --- a/theories/gitree/greifiers.v +++ b/theories/gitree/greifiers.v @@ -116,7 +116,7 @@ Section greifiers. Program Definition gReifiers_re {n} (rs : gReifiers n) {X} `{!Cofe X} (op : opid (gReifiers_ops rs)) : (Ins (gReifiers_ops rs op) ♯ X) * (gReifiers_state rs ♯ X) * ((Outs (gReifiers_ops rs op) ♯ X) -n> laterO X) -n> - optionO ((Outs (gReifiers_ops rs op) ♯ X) * (gReifiers_state rs ♯ X)) + optionO (laterO X * (gReifiers_state rs ♯ X)) := λne xst, let i := projT1 op in let op' := projT2 op in @@ -137,104 +137,127 @@ Section greifiers. sReifier_re := @gReifiers_re n rs; |}. - (* Lemma gReifiers_re_idx {n} (i : fin n) (rs : gReifiers n) *) - (* {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) *) - (* (x : Ins (sReifier_ops _ op) ♯ X) *) - (* (σ : sReifier_state (rs !!! i) ♯ X) (rest : gState_rest i rs ♯ X) : *) - (* gReifiers_re rs (existT i op) (x, gState_recomp rest σ) ≡ *) - (* optionO_map (prodO_map idfun (gState_recomp rest)) *) - (* (sReifier_re (rs !!! i) op (x,σ)). *) - (* Proof. *) - (* unfold gReifiers_re. cbn-[prodO_map optionO_map]. *) - (* f_equiv; last repeat f_equiv. *) - (* - eapply optionO_map_proper. *) - (* intros [x1 x2]; simpl. f_equiv. *) - (* f_equiv. f_equiv. *) - (* rewrite gState_decomp_recomp//. *) - (* - rewrite gState_decomp_recomp//. *) - (* Qed. *) + Lemma gReifiers_re_idx {n} (i : fin n) (rs : gReifiers n) + {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) + (x : Ins (sReifier_ops _ op) ♯ X) + (σ : sReifier_state (rs !!! i) ♯ X) + (κ : (Outs (sReifier_ops (rs !!! i) op) ♯ X -n> laterO X)) + (rest : gState_rest i rs ♯ X) : + gReifiers_re rs (existT i op) (x, gState_recomp rest σ, κ) ≡ + optionO_map (prodO_map idfun (gState_recomp rest)) + (sReifier_re (rs !!! i) op (x, σ, κ)). + Proof. + unfold gReifiers_re. cbn-[prodO_map optionO_map]. + f_equiv; last repeat f_equiv. + - eapply optionO_map_proper. + intros [x1 x2]; simpl. f_equiv. + f_equiv. f_equiv. + rewrite gState_decomp_recomp//. + - rewrite gState_decomp_recomp//. + Qed. - (* Class subReifier {n} (r : sReifier) (rs : gReifiers n) := *) - (* { sR_idx : fin n; *) - (* sR_ops :: subEff (sReifier_ops r) (sReifier_ops (rs !!! sR_idx)); *) - (* sR_state {X} `{!Cofe X} : *) - (* sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X; *) - (* sR_re (m : nat) {X} `{!Cofe X} (op : opid (sReifier_ops r)) *) - (* (x : Ins (sReifier_ops _ op) ♯ X) *) - (* (y : Outs (sReifier_ops _ op) ♯ X) *) - (* (s1 s2 : sReifier_state r ♯ X) *) - (* (k : (Outs (sReifier_ops _ op) ♯ X -n> laterO X)) : *) - (* sReifier_re r op (x, s1, k) ≡{m}≡ Some (y, s2) → *) - (* sReifier_re (rs !!! sR_idx) (subEff_opid op) *) - (* (subEff_ins x, sR_state s1, _) ≡{m}≡ *) - (* Some (subEff_outs y, sR_state s2) }. *) + Class subReifier {n} (r : sReifier) (rs : gReifiers n) := + { sR_idx : fin n; + sR_ops :: subEff (sReifier_ops r) (sReifier_ops (rs !!! sR_idx)); + sR_state {X} `{!Cofe X} : + sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X; + sR_re (m : nat) {X} `{!Cofe X} (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops r op) ♯ X) + (y : Outs (sReifier_ops r op) ♯ X) + (s1 s2 : sReifier_state r ♯ X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) : + sReifier_re r op (x, s1, k) ≡{m}≡ Some ((prodO_map k idfun (y, s2))) → + sReifier_re (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1, ccompose k (subEff_outs ^-1)) ≡{m}≡ + Some (k y, sR_state s2) + }. - (* #[global] Instance subReifier_here {n} (r : sReifier) (rs : gReifiers n) : *) - (* subReifier r (gReifiers_cons r rs). *) - (* Proof. *) - (* simple refine ({| sR_idx := 0%fin |}). *) - (* - simpl. apply subEff_id. *) - (* - simpl. intros. apply iso_ofe_refl. *) - (* - intros X ? op x y s1 s2. *) - (* simpl. eauto. *) - (* Defined. *) - (* #[global] Instance subReifier_there {n} (r r' : sReifier) (rs : gReifiers n) : *) - (* subReifier r rs → *) - (* subReifier r (gReifiers_cons r' rs). *) - (* Proof. *) - (* intros SR. *) - (* simple refine ({| sR_idx := FS sR_idx |}). *) - (* - simpl. intros. apply sR_state. *) - (* - intros X ? op x y s1 s2. *) - (* simpl. apply sR_re. *) - (* Defined. *) + Lemma ccompose_id_l {A B : ofe} (f : A -n> B) : + cid ◎ f ≡ f. + Proof. + intros x; reflexivity. + Qed. - (* #[local] Definition subR_op {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : *) - (* opid (sReifier_ops r) → opid (gReifiers_ops rs). *) - (* Proof. *) - (* intros op. *) - (* simpl. *) - (* refine (existT sR_idx (subEff_opid op)). *) - (* Defined. *) - (* #[export] Instance subReifier_subEff {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : *) - (* subEff (sReifier_ops r) (gReifiers_ops rs). *) - (* Proof. *) - (* simple refine {| subEff_opid := subR_op |}. *) - (* - intros op X ?. simpl. *) - (* apply subEff_ins. *) - (* - intros op X ?. simpl. *) - (* apply subEff_outs. *) - (* Defined. *) + Lemma ccompose_id_r {A B : ofe} (f : A -n> B) : + f ◎ cid ≡ f. + Proof. + intros x; reflexivity. + Qed. - (* Lemma subReifier_reify_idx {n} (r : sReifier) (rs : gReifiers n) *) - (* `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) *) - (* (x : Ins (sReifier_ops _ op) ♯ X) *) - (* (y : Outs (sReifier_ops _ op) ♯ X) *) - (* (s1 s2 : sReifier_state r ♯ X) : *) - (* sReifier_re r op (x, s1) ≡ Some (y, s2) → *) - (* sReifier_re (rs !!! sR_idx) (subEff_opid op) *) - (* (subEff_ins x, sR_state s1) ≡ *) - (* Some (subEff_outs y, sR_state s2). *) - (* Proof. *) - (* intros Hx. apply equiv_dist=>m. *) - (* apply sR_re. by apply equiv_dist. *) - (* Qed. *) + #[global] Instance subReifier_here {n} (r : sReifier) (rs : gReifiers n) : + subReifier r (gReifiers_cons r rs). + Proof. + simple refine ({| sR_idx := 0%fin |}). + - simpl. apply subEff_id. + - simpl. intros. apply iso_ofe_refl. + - intros X ? op x y ? s1 s2 k HEQ; simpl. + unfold ofe_iso_1'; simpl. + rewrite ccompose_id_r HEQ. + reflexivity. + Defined. - (* Lemma subReifier_reify {n} (r : sReifier) *) - (* (rs : gReifiers n) `{!subReifier r rs} {X} `{!Cofe X} *) - (* (op : opid (sReifier_ops r)) *) - (* (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) *) - (* (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : *) - (* sReifier_re r op (x,σ) ≡ Some (y, σ') → *) - (* gReifiers_re rs (subEff_opid op) *) - (* (subEff_ins x, gState_recomp rest (sR_state σ)) *) - (* ≡ Some (subEff_outs y, gState_recomp rest (sR_state σ')). *) - (* Proof. *) - (* intros Hre. *) - (* eapply subReifier_reify_idx in Hre. *) - (* rewrite gReifiers_re_idx//. *) - (* rewrite Hre. simpl. reflexivity. *) - (* Qed. *) + #[global] Instance subReifier_there {n} (r r' : sReifier) (rs : gReifiers n) : + subReifier r rs → + subReifier r (gReifiers_cons r' rs). + Proof. + intros SR. + simple refine ({| sR_idx := FS sR_idx |}). + - simpl. intros. apply sR_state. + - intros X ? op x y s1 s2. + simpl. apply sR_re. + Defined. + + #[local] Definition subR_op {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : + opid (sReifier_ops r) → opid (gReifiers_ops rs). + Proof. + intros op. + simpl. + refine (existT sR_idx (subEff_opid op)). + Defined. + #[export] Instance subReifier_subEff {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : + subEff (sReifier_ops r) (gReifiers_ops rs). + Proof. + simple refine {| subEff_opid := subR_op |}. + - intros op X ?. simpl. + apply subEff_ins. + - intros op X ?. simpl. + apply subEff_outs. + Defined. + + Lemma subReifier_reify_idx {n} (r : sReifier) (rs : gReifiers n) + `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops _ op) ♯ X) + (y : Outs (sReifier_ops _ op) ♯ X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) + (s1 s2 : sReifier_state r ♯ X) : + sReifier_re r op (x, s1, k) ≡ Some ((prodO_map k idfun (y, s2))) → + sReifier_re (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1, ccompose k (subEff_outs ^-1)) ≡ + Some (k y, sR_state s2). + Proof. + intros Hx. apply equiv_dist=>m. + apply sR_re. by apply equiv_dist. + Qed. + + Lemma subReifier_reify {n} (r : sReifier) + (rs : gReifiers n) `{!subReifier r rs} {X} `{!Cofe X} + (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) + (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : + sReifier_re r op (x, σ, k) ≡ Some (prodO_map k idfun (y, σ')) → + gReifiers_re rs (subEff_opid op) + (subEff_ins x, gState_recomp rest (sR_state σ), ccompose k (subEff_outs ^-1)) + ≡ Some ((ccompose k (subEff_outs ^-1)) (subEff_outs y), gState_recomp rest (sR_state σ')). + Proof. + intros Hre. + eapply subReifier_reify_idx in Hre. + rewrite gReifiers_re_idx//. + rewrite Hre. simpl. + do 3 f_equiv. + unfold ofe_iso_1'; simpl. + by rewrite ofe_iso_21. + Qed. (** Lemma for reasoning internally in iProp *) Context `{!invGS_gen hlc Σ}. @@ -243,41 +266,51 @@ Section greifiers. Variable (rs : gReifiers sz). Notation sr := (gReifiers_sReifier rs). - Lemma reify_vis_eqI {A} `{!Cofe A} op i k o σ σ' : - (gReifiers_re rs op (i,σ,k) ≡ Some (o,σ') ⊢@{iProp} reify sr (Vis op i k : IT _ A) σ ≡ (σ', Tau $ k o))%I. - Proof. - apply uPred.internal_eq_entails=>m. - intros H. apply reify_vis_dist. exact H. - Qed. - (* Lemma subReifier_reify_idxI (r : sReifier) *) - (* `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) *) - (* (x : Ins (sReifier_ops _ op) ♯ X) *) - (* (y : Outs (sReifier_ops _ op) ♯ X) *) - (* (s1 s2 : sReifier_state r ♯ X) : *) - (* sReifier_re r op (x, s1) ≡ Some (y, s2) ⊢@{iProp} *) - (* sReifier_re (rs !!! sR_idx) (subEff_opid op) *) - (* (subEff_ins x, sR_state s1) ≡ *) - (* Some (subEff_outs y, sR_state s2). *) + (* Lemma reify_vis_eqI {A} `{!Cofe A} op i k o σ σ' : *) + (* (gReifiers_re rs op (i, σ, k) ≡ Some (o,σ') ⊢@{iProp} reify sr (Vis op i k : IT _ A) σ ≡ (σ', Tau $ k o))%I. *) (* Proof. *) (* apply uPred.internal_eq_entails=>m. *) - (* apply sR_re. *) + (* intros H. apply reify_vis_dist. exact H. *) (* Qed. *) - (* Lemma subReifier_reifyI (r : sReifier) *) - (* `{!subReifier r rs} {X} `{!Cofe X} *) - (* (op : opid (sReifier_ops r)) *) - (* (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) *) - (* (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : *) - (* sReifier_re r op (x,σ) ≡ Some (y, σ') ⊢@{iProp} *) - (* gReifiers_re rs (subEff_opid op) *) - (* (subEff_ins x, gState_recomp rest (sR_state σ)) *) - (* ≡ Some (subEff_outs y, gState_recomp rest (sR_state σ')). *) - (* Proof. *) - (* apply uPred.internal_eq_entails=>m. *) - (* intros He. *) - (* eapply sR_re in He. *) - (* rewrite gReifiers_re_idx//. *) - (* rewrite He. simpl. reflexivity. *) - (* Qed. *) + Lemma subReifier_reify_idxI (r : sReifier) + `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops _ op) ♯ X) + (y : Outs (sReifier_ops _ op) ♯ X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) + (s1 s2 : sReifier_state r ♯ X) : + sReifier_re r op (x, s1, k) ≡ Some (prodO_map k idfun (y, s2)) ⊢@{iProp} + sReifier_re (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1, ccompose k (subEff_outs ^-1)) ≡ + Some ((ccompose k (subEff_outs ^-1)) (subEff_outs y), sR_state s2). + Proof. + apply uPred.internal_eq_entails=>m. + intros H. + rewrite sR_re; last first. + - rewrite H. + reflexivity. + - simpl; rewrite ofe_iso_21. + reflexivity. + Qed. + + Lemma subReifier_reifyI (r : sReifier) + `{!subReifier r rs} {X} `{!Cofe X} + (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) + (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : + sReifier_re r op (x,σ, k) ≡ Some (prodO_map k idfun (y, σ')) ⊢@{iProp} + gReifiers_re rs (subEff_opid op) + (subEff_ins x, gState_recomp rest (sR_state σ), ccompose k (subEff_outs ^-1)) + ≡ Some ((ccompose k (subEff_outs ^-1)) (subEff_outs y), gState_recomp rest (sR_state σ')). + Proof. + apply uPred.internal_eq_entails=>m. + intros He. + eapply sR_re in He. + rewrite gReifiers_re_idx//. + rewrite He. simpl. + rewrite ofe_iso_21. + reflexivity. + Qed. End greifiers. diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 480dfe8..df77ee8 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -12,7 +12,7 @@ Section reifiers. sReifier_state : oFunctor; sReifier_re {X} `{!Cofe X} : forall (op : opid sReifier_ops), (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) * ((Outs (sReifier_ops op) ♯ X) -n> laterO X) - -n> optionO ((Outs (sReifier_ops op) ♯ X) * (sReifier_state ♯ X)); + -n> optionO (laterO X * (sReifier_state ♯ X)); sReifier_inhab :: Inhabited (sReifier_state ♯ unitO); sReifier_cofe X (HX : Cofe X) :: Cofe (sReifier_state ♯ X); }. @@ -51,11 +51,13 @@ Section reifiers. Proof. simpl. simple refine (λne i (k : _ -n> _) (s : stateF ♯ IT), _). - - simple refine (let ns := sReifier_re r op (oFunctor_map _ (inlO,fstO) i, s, (λne o, (laterO_map fstO $ k $ oFunctor_map (Outs (F op)) (fstO, inlO) o))) in _). + - simple refine + (let ns := sReifier_re r op + (oFunctor_map _ (inlO,fstO) i, s, + (λne o, (laterO_map fstO $ k $ oFunctor_map (Outs (F op)) (fstO, inlO) o))) in _). + intros m s1 s2 Hs. solve_proper. + simple refine (from_option (λ ns, - let out2' := k $ oFunctor_map (Outs (F op)) (fstO,inlO) ns.1 in - (ns.2, Tau $ laterO_map fstO out2')) + (ns.2, Tau $ ns.1)) (s, Err RuntimeErr) ns). - intros m s1 s2 Hs. simpl. eapply (from_option_ne (dist m)); solve_proper. - intros m k1 k2 Hk s. simpl. eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. @@ -109,8 +111,8 @@ Section reifiers. Qed. Lemma reify_vis_dist m op i o k σ σ' : - sReifier_re r op (i,σ,k) ≡{m}≡ Some (o,σ') → - reify (Vis op i k) σ ≡{m}≡ (σ', Tau $ k o). + sReifier_re r op (i, σ, k) ≡{m}≡ Some (o, σ') → + reify (Vis op i k) σ ≡{m}≡ (σ', Tau o). Proof. intros Hst. trans (reify_vis op @@ -131,50 +133,37 @@ Section reifiers. repeat f_equiv; intro; done. } assert (rs ≡{m}≡ Some (o, σ')) as Hr. { by rewrite Hr' Hst. } - trans (from_option (λ ns, - (ns.2, - Tau - (laterO_map fstO - (laterO_map (prod_in idfun reify) - (k - (oFunctor_map (Outs (F op)) (prod_in idfun reify, sumO_rec idfun unreify) - (oFunctor_map (Outs (F op)) (fstO, inlO) ns.1))))))) - (σ, Err RuntimeErr) (Some (o,σ'))). - { + trans (from_option (λ ns : laterO IT * stateF ♯ IT, (ns.2, Tau ns.1)) + (σ, Err RuntimeErr) + rs). + - subst rs. eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. - rewrite <-Hr. - subst rs. do 2 f_equiv. - intros x; simpl. + intros ?; simpl. rewrite -laterO_map_compose. + rewrite -oFunctor_map_compose. etrans; first (rewrite laterO_map_id; reflexivity). f_equiv. - rewrite -oFunctor_map_compose. trans (oFunctor_map _ (idfun, idfun) x). - - do 3 f_equiv. - + intros y; simpl. + + do 3 f_equiv. + * intros y; simpl. Transparent prod_in. by unfold prod_in. - + intros y; simpl. + * intros y; simpl. reflexivity. - - by rewrite oFunctor_map_id. - } - simpl. repeat f_equiv. - rewrite -laterO_map_compose. - rewrite -oFunctor_map_compose. - trans (laterO_map idfun (k o)); last first. - { by rewrite laterO_map_id. } - repeat f_equiv. - { intro; done. } - trans (oFunctor_map _ (idfun, idfun) o); last first. - { by rewrite oFunctor_map_id. } - simpl. - repeat f_equiv; intro; done. + + by rewrite oFunctor_map_id. + - subst rs. + trans (from_option (λ ns : laterO IT * stateF ♯ IT, (ns.2, Tau ns.1)) + (σ, Err RuntimeErr) + (Some (o, σ'))). + + eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. + by rewrite Hr. + + reflexivity. Qed. Lemma reify_vis_eq op i o k σ σ' : sReifier_re r op (i,σ,k) ≡ Some (o,σ') → - reify (Vis op i k) σ ≡ (σ', Tau $ k o). + reify (Vis op i k) σ ≡ (σ', Tau $ o). Proof. intros H. apply equiv_dist=>m. apply reify_vis_dist. @@ -205,51 +194,42 @@ Section reifiers. repeat f_equiv; intro; done. } assert (rs ≡ None) as Hr. { by rewrite Hr' Hs. } - trans (from_option (λ ns, - (ns.2, - Tau - (laterO_map fstO - (laterO_map (prod_in idfun reify) - (k - (oFunctor_map (Outs (F op)) (prod_in idfun reify, sumO_rec idfun unreify) - (oFunctor_map (Outs (F op)) (fstO, inlO) ns.1))))))) - (σ, Err RuntimeErr) None). + trans (from_option (λ ns : laterO IT * stateF ♯ IT, (ns.2, Tau ns.1)) + (σ, Err RuntimeErr) + rs). { apply from_option_proper; [solve_proper | solve_proper |]. - rewrite -Hr Hr'. + subst rs. do 2 f_equiv. - - rewrite -oFunctor_map_compose. - f_equiv. - trans (oFunctor_map _ (idfun, idfun) i). - + do 3 f_equiv. - * intros y; simpl. - Transparent prod_in. - by unfold prod_in. - * intros y; simpl. - reflexivity. - + by rewrite oFunctor_map_id. - - intros x; simpl. - rewrite -laterO_map_compose. - trans (laterO_map idfun (k x)); last first. - { by rewrite laterO_map_id. } - repeat f_equiv. - { intro; done. } - trans (oFunctor_map _ (idfun, idfun) x); last first. - { by rewrite oFunctor_map_id. } - simpl. - rewrite -oFunctor_map_compose. - repeat f_equiv; intro; done. + intros x; simpl. + rewrite -laterO_map_compose -oFunctor_map_compose. + trans (laterO_map idfun (k x)); last first. + { by rewrite laterO_map_id. } + f_equiv; first (f_equiv; intros ?; reflexivity). + f_equiv. + trans (oFunctor_map _ (idfun, idfun) x). + - do 3 f_equiv. + + intros y; simpl. + Transparent prod_in. + by unfold prod_in. + + intros y; simpl. + reflexivity. + - by rewrite oFunctor_map_id. } - reflexivity. + trans (from_option (λ ns : laterO IT * stateF ♯ IT, (ns.2, Tau ns.1)) (σ, Err RuntimeErr) None). + - f_equiv; [| assumption]. + intros [? ?] [? ?] [? ?]; simpl in *; f_equiv; [assumption | f_equiv; assumption]. + - reflexivity. Qed. + (* true only for ctx-independent effects *) (* Lemma reify_vis_cont op i k1 k2 σ1 σ2 β *) (* {PROP : bi} `{!BiInternalEq PROP} : *) - (* (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) ⊢ *) + (* (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ *) (* reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. *) (* Proof. *) - (* destruct (sReifier_re r op (i,σ1, laterO_map k2 ◎ k1)) as [[o σ2']|] eqn:Hre; last first. *) - (* - rewrite (reify_vis_None _ _ (laterO_map k2 ◎ k1)); last by rewrite Hre//. *) + (* destruct (sReifier_re r op (i, σ1, k1)) as [[o σ2']|] eqn:Hre; last first. *) + (* - rewrite (reify_vis_None _ _ k1); last by rewrite Hre//. *) (* iIntros "Hr". iExFalso. *) (* iPoseProof (prod_equivI with "Hr") as "[_ Hk]". *) (* simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. *) diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index cf9ef1c..a36f770 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -114,6 +114,7 @@ Program Definition throwE : opInterp := {| |}. Definition ioE := @[inputE;outputE;callccE;throwE]. + (* Canonical Structure reify_io : sReifier. *) (* Proof. *) (* simple refine {| sReifier_ops := ioE; *) @@ -137,6 +138,9 @@ Definition ioE := @[inputE;outputE;callccE;throwE]. (* + admit. *) (* Admitted. *) +(* reify throw (x, next(fun(κ))) σ _ = (κ x) *) +(* reify throw _ _ _ = Error *) + Section constructors. Context {E : opsInterp} {A} `{!Cofe A}. Context {subEff0 : subEff ioE E}. From f746be4dddc2cb5afa11d04ac6a4ec05e8b6b159 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Tue, 7 Nov 2023 18:14:51 +0100 Subject: [PATCH 008/114] missed lemma --- theories/gitree/greifiers.v | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/theories/gitree/greifiers.v b/theories/gitree/greifiers.v index b6735f3..c1533c4 100644 --- a/theories/gitree/greifiers.v +++ b/theories/gitree/greifiers.v @@ -266,12 +266,12 @@ Section greifiers. Variable (rs : gReifiers sz). Notation sr := (gReifiers_sReifier rs). - (* Lemma reify_vis_eqI {A} `{!Cofe A} op i k o σ σ' : *) - (* (gReifiers_re rs op (i, σ, k) ≡ Some (o,σ') ⊢@{iProp} reify sr (Vis op i k : IT _ A) σ ≡ (σ', Tau $ k o))%I. *) - (* Proof. *) - (* apply uPred.internal_eq_entails=>m. *) - (* intros H. apply reify_vis_dist. exact H. *) - (* Qed. *) + Lemma reify_vis_eqI {A} `{!Cofe A} op i k o σ σ' : + (gReifiers_re rs op (i, σ, k) ≡ Some (o,σ') ⊢@{iProp} reify sr (Vis op i k : IT _ A) σ ≡ (σ', Tau $ o))%I. + Proof. + apply uPred.internal_eq_entails=>m. + intros H. apply reify_vis_dist. exact H. + Qed. Lemma subReifier_reify_idxI (r : sReifier) `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) From 4146d461f1b22de50e50ccba0461ed6928282848 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 8 Nov 2023 16:01:15 +0100 Subject: [PATCH 009/114] Merge --- theories/input_lang/interp.v | 65 ++++++++++++++++++++++++++++++++++-- 1 file changed, 62 insertions(+), 3 deletions(-) diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index a36f770..6cad894 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -12,9 +12,44 @@ Program Definition inputE : opInterp := {| Outs := natO; |}. Program Definition outputE : opInterp := {| - Ins := natO; - Outs := unitO; - |}. + Ins := natO; + Outs := unitO; +|}. + +Program Definition callccE : opInterp := + {| + Ins := (▶ ∙ -n> ▶ ∙)%OF; + Outs := unitO; + (* Outs := (▶ ∙)%OF; *) + |}. +Program Definition throwE : opInterp := + {| + Ins := (▶ ∙ * ▶ ∙)%OF; + Outs := unitO; + (* Outs := (▶ ∙)%OF; *) + |}. +Definition ioE := @[inputE;outputE;callccE;throwE]. +Canonical Structure reify_io : sReifier. +Proof. + simple refine {| sReifier_ops := ioE; + sReifier_state := stateO + |}. + intros X HX op. + destruct op as [[] | [ | [ | [ | []]]]]; simpl. + - simple refine (λne (us : prodO unitO stateO), + Some $ update_input (sndO us) : optionO (prodO natO stateO)). + intros n [[] s1] [[] s2] [_ Hs]. + repeat f_equiv. apply Hs. + - simple refine (λne (us : prodO natO stateO), + Some $ ((), update_output (fstO us) (sndO us)) : optionO (prodO unitO stateO)). + intros n [m s1] [m' s2] [-> Hs]. solve_proper. + - simple refine (λne (us : prodO (laterO X -n> laterO X) stateO), + Some $ ((), (sndO us)) : optionO (prodO unitO stateO)). + intros n f1 f2 HR. solve_proper. + - simple refine (λne (us : prodO (prodO (laterO X) (laterO X)) stateO), + Some $ ((), (snd us)) : optionO (prodO unitO stateO)). + intros ????. solve_proper. +Defined. Definition callccIF : oFunctor := (▶ ∙)%OF. @@ -159,6 +194,30 @@ Section constructors. Solve All Obligations with solve_proper_please. Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). + Program Definition CALLCC : (laterO IT -n> laterO IT) -n> (IT -n> IT) -n> IT := + λne f k, Vis (E := E) (subEff_opid (inr (inr (inl ())))) + (subEff_ins (F := ioE) (op :=(inr (inr (inl ())))) f) + (λne _, NextO (Fun (NextO k))). + Next Obligation. solve_proper_please. Qed. + Next Obligation. + intros. intros f1 f2 R. + repeat f_equiv. solve_proper. + Qed. + Next Obligation. solve_proper. Qed. + + Program Definition THROW : (laterO IT) -n> (IT -n> IT) -n> IT := + λne e k, Vis (E := E) (subEff_opid (inr (inr (inr (inl ()))))) + (subEff_ins (F := ioE) (op := (inr (inr (inr (inl ()))))) + (e, NextO (Fun (NextO k)))) + (λne _, NextO (APP (Fun (NextO k)) e)). + Next Obligation. solve_proper_please. Qed. + Next Obligation. + intros. intros f1 f2 R. + repeat f_equiv; first done. + solve_proper. + Qed. + Next Obligation. solve_proper_please. Qed. + Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). Proof. unfold INPUT. From 167583c6a35777f323f4bbaf1dc0fe341f4a0c1c Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 9 Nov 2023 09:59:05 +0100 Subject: [PATCH 010/114] Ins and Outs for callcc/throw, reify_io ok & comment out old work --- theories/input_lang/interp.v | 216 ++++++++++++++++++----------------- 1 file changed, 112 insertions(+), 104 deletions(-) diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index 6cad894..b304a5d 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -36,119 +36,127 @@ Proof. |}. intros X HX op. destruct op as [[] | [ | [ | [ | []]]]]; simpl. - - simple refine (λne (us : prodO unitO stateO), - Some $ update_input (sndO us) : optionO (prodO natO stateO)). - intros n [[] s1] [[] s2] [_ Hs]. - repeat f_equiv. apply Hs. - - simple refine (λne (us : prodO natO stateO), - Some $ ((), update_output (fstO us) (sndO us)) : optionO (prodO unitO stateO)). - intros n [m s1] [m' s2] [-> Hs]. solve_proper. - - simple refine (λne (us : prodO (laterO X -n> laterO X) stateO), - Some $ ((), (sndO us)) : optionO (prodO unitO stateO)). + - simple refine (λne (us : (unitO * stateO * (natO -n> laterO X))%type), + let out : (natO * stateO)%type := (update_input (sndO (fstO us))) in + Some $ (us.2 out.1, out.2) : + optionO (laterO X * stateO)%type). + intros n [[? σ1] k1] [[? σ2] k2] [[_ HR1] HR2]. cbn in HR1, HR2 |- *. + rewrite HR1. by repeat f_equiv. + - simple refine (λne (us : (natO * stateO * (unitO -n> laterO X))%type ), + Some $ (us.2 (() : unitO), update_output us.1.1 us.1.2) : + optionO (prodO (laterO X) stateO)). + intros n [[n1 σ1] k1] [[n2 σ2] k2] [[HRn HRσ] HR]. + cbn in HRn, HRσ, HR |-*. + rewrite HRn HRσ. apply (@Some_ne (prodO (laterO X) stateO)). + apply pair_dist_inj; solve_proper. + - simple refine (λne (us : ((laterO X -n> laterO X) * stateO * + (unitO -n> laterO X))%type), + Some $ (us.2 (), us.1.2) : optionO (prodO (laterO X) stateO)). intros n f1 f2 HR. solve_proper. - - simple refine (λne (us : prodO (prodO (laterO X) (laterO X)) stateO), - Some $ ((), (snd us)) : optionO (prodO unitO stateO)). + - simple refine (λne (us : ((laterO X * laterO X) * stateO * + (unitO -n> laterO X))%type), + Some $ (us.2 (), us.1.2 ) : optionO (prodO (laterO X) stateO)). intros ????. solve_proper. Defined. -Definition callccIF : oFunctor := (▶ ∙)%OF. +(* Definition callccIF : oFunctor := (▶ ∙)%OF. *) -#[local] Instance callccIF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (callccIF ♯ X). -Proof. - constructor. - unshelve refine (Next inhabitant). -Qed. -#[local] Instance callccIF_cofe X `{!Cofe X} : Cofe (callccIF ♯ X). -Proof. apply _. Qed. -#[local] Instance callccIF_contr : oFunctorContractive callccIF. -Proof. - intros ???????? n [a b] [c d] H. - apply laterO_map_contractive. - destruct n as [| n]. - - apply dist_later_0. - - apply dist_later_S. - apply dist_later_S in H. - destruct H as [H1 H2]; simpl in H1, H2. - by f_equiv. -Qed. - -Definition callccOF : oFunctor := unitO. - -#[local] Instance callccOF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (callccOF ♯ X). -Proof. - constructor. - simpl. - constructor. -Qed. -#[local] Instance callccOF_cofe X `{!Cofe X} : Cofe (callccOF ♯ X). -Proof. apply _. Qed. -#[local] Instance callccOF_contr : oFunctorContractive callccOF. -Proof. - intros ???????? n [a b] [c d] H. - solve_proper. -Qed. +(* #[local] Instance callccIF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (callccIF ♯ X). *) +(* Proof. *) +(* constructor. *) +(* unshelve refine (Next inhabitant). *) +(* Qed. *) +(* #[local] Instance callccIF_cofe X `{!Cofe X} : Cofe (callccIF ♯ X). *) +(* Proof. apply _. Qed. *) +(* #[local] Instance callccIF_contr : oFunctorContractive callccIF. *) +(* Proof. *) +(* intros ???????? n [a b] [c d] H. *) +(* apply laterO_map_contractive. *) +(* destruct n as [| n]. *) +(* - apply dist_later_0. *) +(* - apply dist_later_S. *) +(* apply dist_later_S in H. *) +(* destruct H as [H1 H2]; simpl in H1, H2. *) +(* by f_equiv. *) +(* Qed. *) + +(* Definition callccOF : oFunctor := unitO. *) + +(* #[local] Instance callccOF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (callccOF ♯ X). *) +(* Proof. *) +(* constructor. *) +(* simpl. *) +(* constructor. *) +(* Qed. *) +(* #[local] Instance callccOF_cofe X `{!Cofe X} : Cofe (callccOF ♯ X). *) +(* Proof. apply _. Qed. *) +(* #[local] Instance callccOF_contr : oFunctorContractive callccOF. *) +(* Proof. *) +(* intros ???????? n [a b] [c d] H. *) +(* solve_proper. *) +(* Qed. *) -Program Definition callccE : opInterp := {| - Ins := callccIF; - Outs := callccOF; - |}. +(* Program Definition callccE : opInterp := {| *) +(* Ins := callccIF; *) +(* Outs := callccOF; *) +(* |}. *) -Definition throwIF : oFunctor := (▶ ∙ * ▶ ∙)%OF. +(* Definition throwIF : oFunctor := (▶ ∙ * ▶ ∙)%OF. *) -#[local] Instance throwIF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (throwIF ♯ X). -Proof. - constructor. - unshelve refine (Next inhabitant, Next inhabitant). -Qed. -#[local] Instance throwIF_cofe X `{!Cofe X} : Cofe (throwIF ♯ X). -Proof. apply _. Qed. -#[local] Instance throwIF_contr : oFunctorContractive throwIF. -Proof. - intros ???????? n [a b] [c d] H. - simpl. - f_equiv. - { - apply laterO_map_contractive. - destruct n as [| n]. - - apply dist_later_0. - - apply dist_later_S. - apply dist_later_S in H. - destruct H as [H1 H2]; simpl in H1, H2. - assumption. - } - { - apply laterO_map_contractive. - destruct n as [| n]. - - apply dist_later_0. - - apply dist_later_S. - apply dist_later_S in H. - destruct H as [H1 H2]; simpl in H1, H2. - assumption. - } -Qed. - -Definition throwOF : oFunctor := unitO. - -#[local] Instance throwOF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (throwOF ♯ X). -Proof. - constructor. - apply (Next inhabitant). -Qed. -#[local] Instance throwOF_cofe X `{!Cofe X} : Cofe (throwOF ♯ X). -Proof. apply _. Qed. -#[local] Instance throwOF_contr : oFunctorContractive throwOF. -Proof. - intros ???????? n [a b] [c d] H. - unfold throwOF; simpl. - reflexivity. -Qed. - -Program Definition throwE : opInterp := {| - Ins := throwIF; - Outs := throwOF; -|}. +(* #[local] Instance throwIF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (throwIF ♯ X). *) +(* Proof. *) +(* constructor. *) +(* unshelve refine (Next inhabitant, Next inhabitant). *) +(* Qed. *) +(* #[local] Instance throwIF_cofe X `{!Cofe X} : Cofe (throwIF ♯ X). *) +(* Proof. apply _. Qed. *) +(* #[local] Instance throwIF_contr : oFunctorContractive throwIF. *) +(* Proof. *) +(* intros ???????? n [a b] [c d] H. *) +(* simpl. *) +(* f_equiv. *) +(* { *) +(* apply laterO_map_contractive. *) +(* destruct n as [| n]. *) +(* - apply dist_later_0. *) +(* - apply dist_later_S. *) +(* apply dist_later_S in H. *) +(* destruct H as [H1 H2]; simpl in H1, H2. *) +(* assumption. *) +(* } *) +(* { *) +(* apply laterO_map_contractive. *) +(* destruct n as [| n]. *) +(* - apply dist_later_0. *) +(* - apply dist_later_S. *) +(* apply dist_later_S in H. *) +(* destruct H as [H1 H2]; simpl in H1, H2. *) +(* assumption. *) +(* } *) +(* Qed. *) + +(* Definition throwOF : oFunctor := unitO. *) + +(* #[local] Instance throwOF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (throwOF ♯ X). *) +(* Proof. *) +(* constructor. *) +(* apply (Next inhabitant). *) +(* Qed. *) +(* #[local] Instance throwOF_cofe X `{!Cofe X} : Cofe (throwOF ♯ X). *) +(* Proof. apply _. Qed. *) +(* #[local] Instance throwOF_contr : oFunctorContractive throwOF. *) +(* Proof. *) +(* intros ???????? n [a b] [c d] H. *) +(* unfold throwOF; simpl. *) +(* reflexivity. *) +(* Qed. *) -Definition ioE := @[inputE;outputE;callccE;throwE]. +(* Program Definition throwE : opInterp := {| *) +(* Ins := throwIF; *) +(* Outs := throwOF; *) +(* |}. *) + +(* Definition ioE := @[inputE;outputE;callccE;throwE]. *) (* Canonical Structure reify_io : sReifier. *) (* Proof. *) From 4e4acef1d5ae78afff33d5906559eecb99b83d2d Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 9 Nov 2023 14:25:01 +0100 Subject: [PATCH 011/114] Now with good reifiers + signatures --- theories/input_lang/interp.v | 103 ++++++++++++++++++++++++----------- 1 file changed, 70 insertions(+), 33 deletions(-) diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index b304a5d..15df6b6 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -18,15 +18,13 @@ Program Definition outputE : opInterp := {| Program Definition callccE : opInterp := {| - Ins := (▶ ∙ -n> ▶ ∙)%OF; - Outs := unitO; - (* Outs := (▶ ∙)%OF; *) + Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙)%OF; + Outs := (▶ ∙)%OF; |}. Program Definition throwE : opInterp := {| - Ins := (▶ ∙ * ▶ ∙)%OF; - Outs := unitO; - (* Outs := (▶ ∙)%OF; *) + Ins := ((▶∙ -n> ▶∙) * ▶ ∙)%OF; + Outs := Empty_setO; |}. Definition ioE := @[inputE;outputE;callccE;throwE]. Canonical Structure reify_io : sReifier. @@ -49,15 +47,22 @@ Proof. cbn in HRn, HRσ, HR |-*. rewrite HRn HRσ. apply (@Some_ne (prodO (laterO X) stateO)). apply pair_dist_inj; solve_proper. - - simple refine (λne (us : ((laterO X -n> laterO X) * stateO * - (unitO -n> laterO X))%type), - Some $ (us.2 (), us.1.2) : optionO (prodO (laterO X) stateO)). - intros n f1 f2 HR. solve_proper. - - simple refine (λne (us : ((laterO X * laterO X) * stateO * - (unitO -n> laterO X))%type), - Some $ (us.2 (), us.1.2 ) : optionO (prodO (laterO X) stateO)). - intros ????. solve_proper. -Defined. + - simple refine (λne (us : (((laterO X -n> laterO X) -n> laterO X) * stateO * + (laterO X -n> laterO X))%type), + let '(f, σ, k) := us in + Some $ (k (f k), σ) : optionO (laterO X * stateO)%type). + intros n [[f1 σ1] k1] [[f2 σ2] k2] [[Hf Hσ] Hk]. + cbn in Hf, Hσ, Hk |-*. + solve_proper. + - simple refine (λne ( us : (prodO (laterO X -n> laterO X) (laterO X) * + stateO * (Empty_setO -n> laterO X))%type), + let '((k', e), σ, _) := us in + Some $ (k' e, σ) : optionO (laterO X * stateO)%type + ). + intros n [[[k1 e1] σ1] ĸ] [[[k2 e2] σ2] ĸ2] [[[Hk He] Hσ] _]. + cbn in *|-*. + solve_proper. + Defined. (* Definition callccIF : oFunctor := (▶ ∙)%OF. *) @@ -191,9 +196,10 @@ Section constructors. Notation IT := (IT E A). Notation ITV := (ITV E A). - Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) - (subEff_ins (F:=ioE) (op:=(inl ())) ()) - (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). + Program Definition INPUT : (nat -n> IT) -n> IT := + λne k, Vis (E:=E) (subEff_opid (inl ())) + (subEff_ins (F:=ioE) (op:=(inl ())) ()) + (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). Solve Obligations with solve_proper. Program Definition OUTPUT_ : nat -n> IT -n> IT := λne m α, Vis (E:=E) (subEff_opid (inr (inl ()))) @@ -202,29 +208,60 @@ Section constructors. Solve All Obligations with solve_proper_please. Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). - Program Definition CALLCC : (laterO IT -n> laterO IT) -n> (IT -n> IT) -n> IT := - λne f k, Vis (E := E) (subEff_opid (inr (inr (inl ())))) - (subEff_ins (F := ioE) (op :=(inr (inr (inl ())))) f) - (λne _, NextO (Fun (NextO k))). + Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> + IT := + λne f, Vis (E := E) (subEff_opid (inr (inr (inl ())))) + (subEff_ins (F := ioE) (op :=(inr (inr (inl ())))) f) + (λne x, (subEff_outs (F := ioE) (op := inr (inr (inl ()))))^-1 x). + (* (λne _, NextO (Fun (NextO k))). *) Next Obligation. solve_proper_please. Qed. Next Obligation. intros. intros f1 f2 R. - repeat f_equiv. solve_proper. + by repeat f_equiv. Qed. - Next Obligation. solve_proper. Qed. - Program Definition THROW : (laterO IT) -n> (IT -n> IT) -n> IT := + (* THROW (e : expression) (k : continuation argument) *) + Program Definition THROW : (laterO IT) -n> laterO (IT -n> IT) -n> IT := λne e k, Vis (E := E) (subEff_opid (inr (inr (inr (inl ()))))) (subEff_ins (F := ioE) (op := (inr (inr (inr (inl ()))))) - (e, NextO (Fun (NextO k)))) - (λne _, NextO (APP (Fun (NextO k)) e)). - Next Obligation. solve_proper_please. Qed. + (laterO_ap k, e)) + (λne x, match + (subEff_outs (F := ioE) + (op := (inr (inr (inr (inl ()))))))^-1 + x with end). Next Obligation. - intros. intros f1 f2 R. - repeat f_equiv; first done. - solve_proper. + intros. intros f1 f2 R. cbn. destruct ((subEff_outs ^-1) f1). Qed. - Next Obligation. solve_proper_please. Qed. + Solve All Obligations with solve_proper. + + (* Let's see which one is easier to work with *) + Program Definition THROW' : IT -n> IT -n> IT := + λne e k, get_fun + (λne f, Vis (E := E) (subEff_opid (E := E) (F := ioE) + (inr (inr (inr (inl ()))))) + (subEff_ins (F := ioE) (op := (inr (inr (inr (inl ()))))) + (laterO_ap f, NextO e)) + (λne x, match + (subEff_outs (F := ioE) + (op := (inr (inr (inr (inl ()))))))^-1 + x with end) + ) k. + Next Obligation. intros. intros f1. destruct (subEff_outs^-1 f1). Qed. + Solve Obligations with try solve_proper. + Next Obligation. intros n f1 f2 R. solve_proper_please. Qed. + + (* Program Definition THROW : (laterO IT) -n> (IT -n> IT) -n> IT := *) + (* λne e k, Vis (E := E) (subEff_opid (inr (inr (inr (inl ()))))) *) + (* (subEff_ins (F := ioE) (op := (inr (inr (inr (inl ()))))) *) + (* (e, NextO (Fun (NextO k)))) *) + (* (λne _, NextO (APP (Fun (NextO k)) e)). *) + (* Next Obligation. solve_proper_please. Qed. *) + (* Next Obligation. *) + (* intros. intros f1 f2 R. *) + (* repeat f_equiv; first done. *) + (* solve_proper. *) + (* Qed. *) + (* Next Obligation. solve_proper_please. Qed. *) Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). Proof. @@ -455,7 +492,7 @@ Section interp. solve_proper. Qed. - Axiom falso : False. + (* Axiom falso : False. *) (** Interpretation for all the syntactic categories: values, expressions, contexts *) Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := From 74edd87ceb9812570a925eed9b468c35a6573301 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 9 Nov 2023 16:57:52 +0100 Subject: [PATCH 012/114] backwards comp --- _CoqProject | 5 + theories/gitree/reductions.v | 1 + theories/gitree/reify.v | 201 +++++--- theories/gitree/weakestpre.v | 71 +-- theories/input_lang/lang.v | 742 +++++++++++++-------------- theories/input_lang_callcc/interp.v | 707 +++++++++++++++++++++++++ theories/input_lang_callcc/lang.v | 563 ++++++++++++++++++++ theories/input_lang_callcc/logpred.v | 299 +++++++++++ theories/input_lang_callcc/logrel.v | 488 ++++++++++++++++++ theories/lang_generic.v | 265 ++++++++-- 10 files changed, 2801 insertions(+), 541 deletions(-) create mode 100644 theories/input_lang_callcc/interp.v create mode 100644 theories/input_lang_callcc/lang.v create mode 100644 theories/input_lang_callcc/logpred.v create mode 100644 theories/input_lang_callcc/logrel.v diff --git a/_CoqProject b/_CoqProject index 5c14b03..1281e79 100644 --- a/_CoqProject +++ b/_CoqProject @@ -28,6 +28,11 @@ theories/gitree.v theories/program_logic.v +theories/input_lang_callcc/lang.v +theories/input_lang_callcc/interp.v +theories/input_lang_callcc/logpred.v +theories/input_lang_callcc/logrel.v + theories/input_lang/lang.v theories/input_lang/interp.v theories/input_lang/logpred.v diff --git a/theories/gitree/reductions.v b/theories/gitree/reductions.v index 47e91c2..c1b04f6 100644 --- a/theories/gitree/reductions.v +++ b/theories/gitree/reductions.v @@ -200,6 +200,7 @@ Section istep. iApply (IT_tick_vis_ne). by iApply (internal_eq_sym with "Ha"). Qed. + (* ctx-free steps *) (* Local Lemma effect_safe_externalize (α : IT) σ : *) (* (⊢ ∃ β σ', (∃ op i k, α ≡ Vis op i k ∧ reify r α σ ≡ (σ', Tick β)) : iProp) → *) (* ∃ β σ', sstep r α σ β σ'. *) diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index df77ee8..3e6862a 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -25,6 +25,13 @@ Section reifiers. Implicit Type op : opid F. Implicit Type α β : IT. + Class CtxIndep (X : ofe) `{!Cofe X} (op : opid F) := { + cont_irrelev : + (∃ f : (prodO (Ins (sReifier_ops r _) ♯ X) ((sReifier_state r) ♯ X)) -n> + optionO (prodO (Outs (sReifier_ops r _) ♯ X) (sReifier_state r ♯ X)), + ∀ i σ κ, @sReifier_re _ X _ op (i, σ, κ) ≡ fmap (prodO_map κ idfun) (f (i, σ))); + }. + Notation stateM := ((stateF ♯ IT -n> (stateF ♯ IT) * IT)). #[local] Instance stateT_inhab : Inhabited stateM. Proof. @@ -223,73 +230,135 @@ Section reifiers. Qed. (* true only for ctx-independent effects *) - (* Lemma reify_vis_cont op i k1 k2 σ1 σ2 β *) - (* {PROP : bi} `{!BiInternalEq PROP} : *) - (* (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ *) - (* reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. *) - (* Proof. *) - (* destruct (sReifier_re r op (i, σ1, k1)) as [[o σ2']|] eqn:Hre; last first. *) - (* - rewrite (reify_vis_None _ _ k1); last by rewrite Hre//. *) - (* iIntros "Hr". iExFalso. *) - (* iPoseProof (prod_equivI with "Hr") as "[_ Hk]". *) - (* simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. *) - (* - rewrite reify_vis_eq; last first. *) - (* { by rewrite Hre. } *) - (* rewrite reify_vis_eq; last first. *) - (* { by rewrite Hre. } *) - (* iIntros "Hr". *) - (* iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". *) - (* iApply prod_equivI. simpl. iSplit; eauto. *) - (* iPoseProof (Tau_inj' with "Hk") as "Hk". *) - (* iApply Tau_inj'. iRewrite "Hk". *) - (* rewrite laterO_map_Next. done. *) - (* Qed. *) + Lemma reify_vis_cont op i k1 k2 σ1 σ2 β + {PROP : bi} `{!BiInternalEq PROP} `{H : !(@CtxIndep IT _ op)} : + (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ + reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. + Proof. + destruct (sReifier_re r op (i, σ1, k1)) as [[o σ2']|] eqn:Hre; last first. + - rewrite (reify_vis_None _ _ k1); last by rewrite Hre//. + iIntros "Hr". iExFalso. + iPoseProof (prod_equivI with "Hr") as "[_ Hk]". + simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. + - destruct H as [[f H]]. + pose proof (H i σ1 k1) as H1. + pose proof (H i σ1 (laterO_map k2 ◎ k1)) as H2. + assert (∃ o σ', f (i, σ1) = Some (o, σ')) as [o' [σ' H3]]. + { + destruct (f (i, σ1)) as [[? ?] | ?]; first (do 2 eexists; reflexivity). + simpl in H1. rewrite Hre in H1; inversion H1. + } + rewrite H3 in H1. + simpl in H1. + rewrite H3 in H2. + simpl in H2. + clear f H H3 Hre. + rewrite reify_vis_eq; last first. + { by rewrite H1. } + rewrite reify_vis_eq; last first. + { by rewrite H2. } + iIntros "Hr". + iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". + iApply prod_equivI. simpl. iSplit; eauto. + iPoseProof (Tau_inj' with "Hk") as "Hk". + iApply Tau_inj'. iRewrite "Hk". + rewrite laterO_map_Next. done. + Qed. - (* Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β *) - (* {PROP : bi} `{!BiInternalEq PROP} : *) - (* (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) *) - (* ⊢ ∃ α, reify (Vis op i k1) σ1 ≡ (σ2, Tick α) ∧ ▷ (β ≡ k2 α) *) - (* : PROP)%I. *) - (* Proof. *) - (* destruct (sReifier_re r op (i,σ1)) as [[o σ2']|] eqn:Hre; last first. *) - (* - rewrite reify_vis_None; last by rewrite Hre//. *) - (* iIntros "Hr". iExFalso. *) - (* iPoseProof (prod_equivI with "Hr") as "[_ Hk]". *) - (* simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. *) - (* - rewrite reify_vis_eq; last first. *) - (* { by rewrite Hre. } *) - (* iIntros "Hr". simpl. *) - (* iPoseProof (prod_equivI with "Hr") as "[#Hs #Hk]". *) - (* simpl. *) - (* iPoseProof (Tau_inj' with "Hk") as "Hk'". *) - (* destruct (Next_uninj (k1 o)) as [a Hk1]. *) - (* iExists (a). *) - (* rewrite reify_vis_eq; last first. *) - (* { by rewrite Hre. } *) - (* iSplit. *) - (* + iApply prod_equivI. simpl. iSplit; eauto. *) - (* iApply Tau_inj'. done. *) - (* + iAssert (laterO_map k2 (Next a) ≡ Next β)%I as "Ha". *) - (* { iSimpl in "Hk'". iRewrite -"Hk'". *) - (* iPureIntro. rewrite -Hk1. done. } *) - (* iAssert (Next (k2 a) ≡ Next β)%I as "Hb". *) - (* { iRewrite -"Ha". iPureIntro. *) - (* rewrite laterO_map_Next. done. } *) - (* iNext. by iApply internal_eq_sym. *) - (* Qed. *) + Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β + {PROP : bi} `{!BiInternalEq PROP} `{H : !(@CtxIndep IT _ op)} : + (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) + ⊢ ∃ α, reify (Vis op i k1) σ1 ≡ (σ2, Tick α) ∧ ▷ (β ≡ k2 α) + : PROP)%I. + Proof. + destruct (sReifier_re r op (i, σ1, (laterO_map k2 ◎ k1))) as [[o σ2']|] eqn:Hre; last first. + - rewrite reify_vis_None; last by rewrite Hre//. + iIntros "Hr". iExFalso. + iPoseProof (prod_equivI with "Hr") as "[_ Hk]". + simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. + - rewrite reify_vis_eq; last first. + { by rewrite Hre. } + iIntros "Hr". simpl. + iPoseProof (prod_equivI with "Hr") as "[#Hs #Hk]". + simpl. + iPoseProof (Tau_inj' with "Hk") as "Hk'". + destruct H as [[f H]]. + pose proof (H i σ1 k1) as H1. + pose proof (H i σ1 (laterO_map k2 ◎ k1)) as H2. + assert (∃ o, f (i, σ1) ≡ Some (o, σ2')) as [o' H3]. + { + destruct (f (i, σ1)) as [[? ?] | ?]. + - simpl in H2. + rewrite Hre in H2. + inversion H2 as [? ? H2' |]; subst; inversion H2'; simpl in *; subst. + eexists _; do 2 f_equiv; first reflexivity; symmetry; assumption. + - simpl in H2. + rewrite Hre in H2. + inversion H2. + } + rewrite H3 in H1. + simpl in H1. + rewrite H3 in H2. + simpl in H2. + destruct (Next_uninj (k1 o')) as [a Hk1]. + iExists (a). + rewrite reify_vis_eq; last first. + { by rewrite H1. } + iSplit. + + iApply prod_equivI. simpl. iSplit; eauto. + iApply Tau_inj'. done. + + iAssert (laterO_map k2 (Next a) ≡ Next β)%I as "Ha". + { + iSimpl in "Hk'". iRewrite -"Hk'". + iPureIntro. rewrite -Hk1. + rewrite Hre in H2. + inversion H2 as [? ? H2' |]; subst; inversion H2'; simpl in *; subst. + symmetry; assumption. + } + iAssert (Next (k2 a) ≡ Next β)%I as "Hb". + { iRewrite -"Ha". iPureIntro. + rewrite laterO_map_Next. done. } + iNext. by iApply internal_eq_sym. + Qed. - (* Lemma reify_is_always_a_tick op x k σ β σ' : *) - (* reify (Vis op x k) σ ≡ (σ', β) → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). *) - (* Proof. *) - (* destruct (sReifier_re r op (x, σ)) as [[o σ'']|] eqn:Hre; last first. *) - (* - rewrite reify_vis_None; last by rewrite Hre//. *) - (* intros [_ ?]. by right. *) - (* - rewrite reify_vis_eq;last by rewrite Hre. *) - (* intros [? Ho]. *) - (* destruct (Next_uninj (k o)) as [lβ Hlb]. *) - (* left. exists (lβ). *) - (* rewrite Tick_eq. *) - (* rewrite -Hlb. symmetry. apply Ho. *) - (* Qed. *) + Lemma reify_is_always_a_tick op x k σ β σ' `{H : !(@CtxIndep IT _ op)} : + reify (Vis op x k) σ ≡ (σ', β) → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). + Proof. + destruct (sReifier_re r op (x, σ, k)) as [[o σ'']|] eqn:Hre; last first. + - rewrite reify_vis_None; last by rewrite Hre//. + intros [_ ?]. by right. + - destruct H as [[f H]]. + specialize (H x σ k). + rewrite reify_vis_eq; last by rewrite Hre. + intros [? Ho]. + simpl in *. + assert (∃ o, f (x, σ) ≡ Some (o, σ'')) as [o' H']. + { + destruct (f (x, σ)) as [[? ?] | ?]. + - simpl in H. + rewrite Hre in H. + inversion H as [? ? H' |]; subst; inversion H'; simpl in *; subst. + eexists _; do 2 f_equiv; first reflexivity; symmetry; assumption. + - simpl in H. + rewrite Hre in H. + inversion H. + } + assert (H'' : sReifier_re r op (x, σ, k) ≡ (prodO_map k idfun) <$> (Some (o', σ''))). + { + rewrite H. + f_equiv. + - intros ???; simpl. + solve_proper. + - assumption. + } + simpl in H''. + rewrite Hre in H''. + inversion H'' as [? ? H''' |]; subst; inversion H''' as [H1 ?]; simpl in *; subst. + rewrite <-!Ho, H1. + destruct (Next_uninj (k o')) as [lβ Hlb]. + left. exists (lβ). + rewrite Tick_eq. + rewrite -Hlb. symmetry. rewrite -H1. apply Ho. + Qed. End reifiers. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index 99e3dce..d3ba056 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -137,9 +137,9 @@ Section weakestpre. Definition has_state_idx `{!stateG Σ} (i : fin n) (σ : sReifier_state (rs !!! i) ♯ IT) : iProp Σ := (own stateG_name (◯ (of_idx i σ)))%I. - (* Definition has_substate {sR : sReifier} `{!stateG Σ} `{!subReifier sR rs} *) - (* (σ : sReifier_state sR ♯ IT) : iProp Σ := *) - (* (own stateG_name (◯ (of_idx sR_idx (sR_state σ))))%I. *) + Definition has_substate {sR : sReifier} `{!stateG Σ} `{!subReifier sR rs} + (σ : sReifier_state sR ♯ IT) : iProp Σ := + (own stateG_name (◯ (of_idx sR_idx (sR_state σ))))%I. #[export] Instance state_interp_ne `{!stateG Σ} : NonExpansive state_interp. Proof. solve_proper. Qed. @@ -497,34 +497,34 @@ Section weakestpre. iRewrite -"Hb". by iFrame. Qed. - (* Lemma wp_reify_idx' E1 E2 s Φ i (lop : opid (sReifier_ops (rs !!! i))) : *) - (* let op : opid F := (existT i lop) in *) - (* forall (x : Ins (F op) ♯ IT) *) - (* (k : Outs (F op) ♯ IT -n> laterO IT), *) - (* (|={E1,E2}=> ∃ σ y σ' β, has_state_idx i σ ∗ *) - (* sReifier_re (rs !!! i) lop (x, σ, k) ≡ Some (y, σ') ∗ *) - (* k y ≡ Next β ∗ *) - (* ▷ (£ 1 -∗ has_state_idx i σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) *) - (* -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. *) - (* Proof. *) - (* intros op x k. *) - (* iIntros "H". *) - (* iApply wp_reify_idx. *) - (* iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". *) - (* iModIntro. iExists σ, σ', β. *) - (* iFrame "Hlst". *) - (* iIntros (rest). iFrame "H". *) - (* iAssert (gReifiers_re rs op (x, gState_recomp rest σ) ≡ Some (y,gState_recomp rest σ'))%I *) - (* with "[Hreify]" as "Hgreify". *) - (* { rewrite gReifiers_re_idx. *) - (* iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) (sReifier_re (rs !!! i) lop (x, σ)) ≡ optionO_map (prodO_map idfun (gState_recomp rest)) (Some (y, σ')))%I with "[Hreify]" as "H". *) - (* - iApply (f_equivI with "Hreify"). *) - (* - simpl. iExact "H". *) - (* } *) - (* iPoseProof (reify_vis_eqI _ _ _ k with "Hgreify") as "Hreify". *) - (* iRewrite "Hk" in "Hreify". *) - (* by rewrite -Tick_eq. *) - (* Qed. *) + Lemma wp_reify_idx' E1 E2 s Φ i (lop : opid (sReifier_ops (rs !!! i))) : + let op : opid F := (existT i lop) in + forall (x : Ins (F op) ♯ IT) + (k : Outs (F op) ♯ IT -n> laterO IT), + (|={E1,E2}=> ∃ σ y σ' β, has_state_idx i σ ∗ + sReifier_re (rs !!! i) lop (x, σ, k) ≡ Some (k y, σ') ∗ + k y ≡ Next β ∗ + ▷ (£ 1 -∗ has_state_idx i σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) + -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. + Proof. + intros op x k. + iIntros "H". + iApply wp_reify_idx. + iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". + iModIntro. iExists σ, σ', β. + iFrame "Hlst". + iIntros (rest). iFrame "H". + iAssert (gReifiers_re rs op (x, gState_recomp rest σ, _) ≡ Some (k y, gState_recomp rest σ'))%I + with "[Hreify]" as "Hgreify". + { rewrite gReifiers_re_idx. + iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) (sReifier_re (rs !!! i) lop (x, σ, k)) ≡ optionO_map (prodO_map idfun (gState_recomp rest)) (Some (k y, σ')))%I with "[Hreify]" as "H". + - iApply (f_equivI with "Hreify"). + - simpl. iExact "H". + } + iPoseProof (reify_vis_eqI _ _ _ k with "Hgreify") as "Hreify". + iRewrite "Hk" in "Hreify". + by rewrite -Tick_eq. + Qed. Lemma wp_reify E1 s Φ i (lop : opid (sReifier_ops (rs !!! i))) x k σ σ' β : @@ -547,10 +547,10 @@ Section weakestpre. (* Lemma wp_subreify' E1 E2 s Φ sR `{!subReifier sR rs} *) (* (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ IT) *) - (* (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) : *) + (* (k : Outs (sReifier_ops sR op) ♯ IT -n> laterO IT) : *) (* (|={E1,E2}=> ∃ σ y σ' β, has_substate σ ∗ *) - (* sReifier_re sR op (x, σ) ≡ Some (y, σ') ∗ *) - (* k (subEff_outs y) ≡ Next β ∗ *) + (* sReifier_re sR op (x, σ, k) ≡ Some (k y, σ') ∗ *) + (* k y ≡ Next β ∗ *) (* ▷ (£ 1 -∗ has_substate σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) *) (* -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. *) (* Proof. *) @@ -562,6 +562,7 @@ Section weakestpre. (* iFrame "Hlst H Hk". *) (* by iApply subReifier_reify_idxI. *) (* Qed. *) + (* Lemma wp_subreify E1 s Φ sR `{!subReifier sR rs} *) (* (op : opid (sReifier_ops sR)) *) (* (x : Ins (sReifier_ops sR op) ♯ IT) (y : Outs (sReifier_ops sR op) ♯ IT) *) @@ -761,7 +762,7 @@ End weakestpre. Arguments wp {_} rs {_ _ _ _ _} α s E Φ. Arguments has_full_state {n _ _ _ _ _} σ. Arguments has_state_idx {n _ _ _ _ _} i σ. -(* Arguments has_substate {n _ _ _ _ _ _ _} σ. *) +Arguments has_substate {n _ _ _ _ _ _ _} σ. Arguments stateG {n} rs A {_} Σ. Arguments statePreG {n} rs A {_} Σ. Arguments stateΣ {n} rs A {_}. diff --git a/theories/input_lang/lang.v b/theories/input_lang/lang.v index 5dc84c8..82fac6c 100644 --- a/theories/input_lang/lang.v +++ b/theories/input_lang/lang.v @@ -1,78 +1,35 @@ From stdpp Require Export strings. -From gitrees Require Export prelude. +From gitrees Require Export prelude lang_generic. From Equations Require Import Equations. Require Import List. Import ListNotations. -Require Import Binding.Lib Binding.Set Binding.Auto Binding.Env. +Delimit Scope expr_scope with E. Inductive nat_op := Add | Sub | Mult. -Inductive expr {X : Set} := -(* Values *) -| Val (v : val) : expr -(* Base lambda calculus *) -| App (e₁ : expr) (e₂ : expr) : expr -(* Base types and their operations *) -| NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr -| If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr -(* The effects *) -| Input : expr -| Output (e : expr) : expr -| Callcc (e : @expr (inc X)) : expr -| Throw (e₁ : expr) (e₂ : expr) : expr -with val {X : Set} := -| VarV (x : X) : val -| LitV (n : nat) : val -| RecV (e : @expr (inc (inc X))) : val -| ContV (K : ectx) : val -with ectx {X : Set} := -| EmptyK : ectx -| OutputK (K : ectx) : ectx -| IfK (K : ectx) (e₁ : expr) (e₂ : expr) : ectx -| AppLK (e : expr) (K : ectx) : ectx -| AppRK (K : ectx) (v : val) : ectx -| NatOpLK (op : nat_op) (e : expr) (K : ectx) : ectx -| NatOpRK (op : nat_op) (K : ectx) (v : val) : ectx -| ThrowLK (K : ectx) (e : expr) : ectx -| ThrowRK (v : val) (K : ectx) : ectx. - +Inductive expr : scope → Type := + (* Values *) + | Val : forall {S}, val S → expr S + (* Base lambda calculus *) + | Var : forall {S}, var S → expr S + | Rec : forall {S}, expr (()::()::S) → expr S + | App : forall {S}, expr S → expr S → expr S + (* Base types and their operations *) + | NatOp : forall {S}, + nat_op → expr S → expr S → expr S + | If : forall {S}, + expr S → expr S → expr S → expr S + (* The effects *) + | Input : forall {S}, expr S + | Output : forall {S}, expr S → expr S +with val : scope → Type := + | Lit : forall {S}, nat → val S + | RecV : forall {S}, expr (()::()::S) → val S. + +Bind Scope expr_scope with expr. Notation of_val := Val (only parsing). -Arguments val X%bind : clear implicits. -Arguments expr X%bind : clear implicits. -Arguments ectx X%bind : clear implicits. - -Declare Scope syn_scope. -Declare Scope ectx_scope. -Delimit Scope syn_scope with syn. -Delimit Scope ectx_scope with ectx. - -Coercion Val : val >-> expr. -Coercion App : expr >-> Funclass. -Coercion AppLK : expr >-> Funclass. -Coercion AppRK : ectx >-> Funclass. - -Notation "+" := (Add) : syn_scope. -Notation "-" := (Sub) : syn_scope. -Notation "×" := (Mult) : syn_scope. -Notation "'⟨' e₁ op e₂ '⟩'" := (NatOp op e₁ e₂) (at level 45, right associativity) : syn_scope. -Notation "'if' e₁ 'then' e₂ 'else' e₃" := (If e₁ e₂ e₃) : syn_scope. -Notation "'#' n" := (LitV n) (at level 60) : syn_scope. -Notation "'input'" := (Input) : syn_scope. -Notation "'output' e" := (Output e) (at level 60) : syn_scope. -Notation "'rec' e" := (RecV e) (at level 60) : syn_scope. -Notation "'throw' e₁ e₂" := (Throw e₁ e₂) (at level 60) : syn_scope. -Notation "'cont' K" := (ContV K) (at level 60) : syn_scope. - -Notation "□" := (EmptyK) : ectx_scope. -Notation "'⟨' e₁ op K '⟩ᵣ'" := (NatOpLK op e₁ K) (at level 45, right associativity) : ectx_scope. -Notation "'⟨' K op v₂ '⟩ₗ'" := (NatOpRK op K v₂) (at level 45, right associativity) : ectx_scope. -Notation "'if' K 'then' e₂ 'else' e₃" := (IfK K e₂ e₃) : ectx_scope. -Notation "'output' K" := (OutputK K) (at level 60) : ectx_scope. -Notation "'throwₗ' K e₂" := (ThrowLK K e₂) (at level 60) : ectx_scope. -Notation "'throwᵣ' e₁ K" := (ThrowRK e₁ K) (at level 60) : ectx_scope. - Definition to_val {S} (e : expr S) : option (val S) := match e with | Val v => Some v @@ -81,259 +38,244 @@ Definition to_val {S} (e : expr S) : option (val S) := Definition do_natop (op : nat_op) (x y : nat) : nat := match op with - | Add => plus x y - | Sub => minus x y - | Mult => mult x y + | Add => x+y + | Sub => x-y + | Mult => x+y end. Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := match x, y with - | LitV x, LitV y => Some $ LitV $ do_natop n x y + | Lit x, Lit y => Some $ Lit $ do_natop n x y | _,_ => None end. -Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := - match K with - | EmptyK => e - | OutputK K => Output (fill K e) - | IfK K e₁ e₂ => If (fill K e) e₁ e₂ - | AppLK e' K => App e' (fill K e) - | AppRK K v => App (fill K e) (Val v) - | NatOpLK op e' K => NatOp op e' (fill K e) - | NatOpRK op K v => NatOp op (fill K e) (Val v) - | ThrowLK K e' => Throw (fill K e) e' - | ThrowRK v K => Throw (Val v) (fill K e) - end. - -Notation "K '[' e ']'" := (fill K e) (at level 60) : syn_scope. - -Local Open Scope bind_scope. - -Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := - match e with - | Val v => Val (vmap f v) - | App e₁ e₂ => App (emap f e₁) (emap f e₂) - | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) - | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) - | Input => Input - | Output e => Output (emap f e) - | Callcc e => Callcc (emap (f ↑) e) - | Throw e₁ e₂ => Throw (emap f e₁) (emap f e₂) - end -with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := - match v with - | VarV x => VarV (f x) - | LitV n => LitV n - | RecV e => RecV (emap ((f ↑) ↑) e) - | ContV K => ContV (kmap f K) - end -with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := - match K with - | EmptyK => EmptyK - | OutputK K => OutputK (kmap f K) - | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) - | AppLK e K => AppLK (emap f e) (kmap f K) - | AppRK K v => AppRK (kmap f K) (vmap f v) - | NatOpLK op e K => NatOpLK op (emap f e) (kmap f K) - | NatOpRK op K v => NatOpRK op (kmap f K) (vmap f v) - | ThrowLK K e => ThrowLK (kmap f K) (emap f e) - | ThrowRK v K => ThrowRK (vmap f v) (kmap f K) - end. -#[export] Instance FMap_expr : FunctorCore expr := @emap. -#[export] Instance FMap_val : FunctorCore val := @vmap. -#[export] Instance FMap_ectx : FunctorCore ectx := @kmap. - -Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) - : fmap f (fill K e) = fill (fmap f K) (fmap f e). +(** substitution stuff *) +Definition rens S S' := var S → var S'. +Definition subs S S' := var S → expr S'. + +Definition idren {S} : rens S S := fun v => v. +Definition idsub {S} : subs S S := Var. + +Equations conssub {S S' τ} (M : expr S') (s : subs S S') : subs (τ::S) S' := + conssub M s Vz := M; + conssub M s (Vs v) := s v. + +Notation "{/ e ; .. ; f /}" := (conssub e .. (conssub f idsub) ..). + +Definition tl_sub {S S' τ} : subs (τ::S) S' → subs S S' := λ s v, s (Vs v). +Definition hd_sub {S S' τ} : subs (τ::S) S' → expr S' := λ s, s Vz. +Definition tl_ren {S S' τ} : rens (τ::S) S' → rens S S' := λ s v, s (Vs v). +Definition hd_ren {S S' τ} : rens (τ::S) S' → var S' := λ s, s Vz. + +(* Lifting a renaming, renaming terms, and lifting substitutions *) +Equations rens_lift {S S'} (s : rens S S') : rens (()::S) (()::S') := + rens_lift s Vz := Vz; + rens_lift s (Vs v) := Vs $ s v. + +Equations ren_expr {S S'} (M : expr S) (r : rens S S') : expr S' := +ren_expr (Val v) r := Val $ ren_val v r; +ren_expr (Var v) r := Var (r v); +ren_expr (Rec M) r := Rec (ren_expr M (rens_lift (rens_lift r))); +ren_expr (App M N) r := App (ren_expr M r) (ren_expr N r); +ren_expr (NatOp op e1 e2) r := NatOp op (ren_expr e1 r) (ren_expr e2 r); +ren_expr (If e0 e1 e2) r := If (ren_expr e0 r) (ren_expr e1 r) (ren_expr e2 r); +ren_expr Input r := Input; +ren_expr (Output e) r := Output (ren_expr e r); +with ren_val {S S'} (M : val S) (r : rens S S') : val S' := +ren_val (Lit n) _ := Lit n; +ren_val (RecV e) r := RecV (ren_expr e (rens_lift (rens_lift r))). + + +Definition expr_lift {S} (M : expr S) : expr (()::S) := ren_expr M Vs. + +Equations subs_lift {S S'} (s : subs S S') : subs (()::S) (()::S') := + subs_lift s Vz := Var Vz; + subs_lift s (Vs v) := expr_lift $ s v. + +(* We can now define the substitution operation *) +Equations subst_expr {S S'} (M : expr S) (s : subs S S') : expr S' := +subst_expr (Val v) r := Val $ subst_val v r; +subst_expr (Var v) r := r v; +subst_expr (Rec M) r := Rec (subst_expr M (subs_lift (subs_lift r))); +subst_expr (App M N) r := App (subst_expr M r) (subst_expr N r); +subst_expr (NatOp op e1 e2) r := NatOp op (subst_expr e1 r) (subst_expr e2 r); +subst_expr (If e0 e1 e2) r := If (subst_expr e0 r) (subst_expr e1 r) (subst_expr e2 r); +subst_expr (Input) r := Input; +subst_expr (Output e) r := Output (subst_expr e r); +with subst_val {S S'} (M : val S) (r : subs S S') : val S' := +subst_val (Lit n) _ := Lit n; +subst_val (RecV e) r := RecV (subst_expr e (subs_lift (subs_lift r))). + +Definition subst1 {S : scope} {τ} (M : expr (τ::S)) (N : expr S) : expr S + := subst_expr M {/ N /}. +Definition subst2 {S : scope} {i j} (M : expr (i::j::S)) (N1 : expr S) (N2 : expr S) : expr S + := subst_expr M {/ N1; N2 /}. + +Definition appsub {S1 S2 S3} (s : subs S1 S2) (s' : subs S2 S3) : subs S1 S3 := + λ v, subst_expr (s v) s'. + +Global Instance rens_equiv S S' : Equiv (rens S S') := λ s1 s2, ∀ v, s1 v = s2 v. +Global Instance subs_equiv S S' : Equiv (subs S S') := λ s1 s2, ∀ v, s1 v = s2 v. + +Global Instance rens_lift_proper S S' : Proper ((≡) ==> (≡)) (@rens_lift S S'). Proof. - revert f. - induction K as [| ?? IH - | ?? IH - | ??? IH - | ?? IH - | ???? IH - | ??? IH - | ?? IH - | ??? IH]; - intros f; term_simpl; first done; rewrite IH; reflexivity. + intros s1 s2 Hs v. dependent elimination v; simp rens_lift; eauto. + f_equiv. apply Hs. Qed. -#[export] Instance SPC_val : SetPureCore val := @VarV. - -Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := - match e with - | Val v => Val (vbind f v) - | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) - | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) - | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) - | Input => Input - | Output e => Output (ebind f e) - | Callcc e => Callcc (ebind (f ↑) e) - | Throw e₁ e₂ => Throw (ebind f e₁) (ebind f e₂) - end -with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := - match v with - | VarV x => f x - | LitV n => LitV n - | RecV e => RecV (ebind ((f ↑) ↑) e) - | ContV K => ContV (kbind f K) - end -with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := - match K with - | EmptyK => EmptyK - | OutputK K => OutputK (kbind f K) - | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) - | AppLK e K => AppLK (ebind f e) (kbind f K) - | AppRK K v => AppRK (kbind f K) (vbind f v) - | NatOpLK op e K => NatOpLK op (ebind f e) (kbind f K) - | NatOpRK op K v => NatOpRK op (kbind f K) (vbind f v) - | ThrowLK K e => ThrowLK (kbind f K) (ebind f e) - | ThrowRK v K => ThrowRK (vbind f v) (kbind f K) - end. - -#[export] Instance BindCore_expr : BindCore expr := @ebind. -#[export] Instance BindCore_val : BindCore val := @vbind. -#[export] Instance BindCore_ectx : BindCore ectx := @kbind. - -#[export] Instance IP_typ : SetPure val. +Lemma ren_expr_proper {S S'} (e : expr S) : Proper ((≡) ==> (=)) (@ren_expr S S' e) + with ren_val_proper {S S'} v : Proper ((≡) ==> (=)) (@ren_val S S' v). Proof. - split; intros; reflexivity. + - revert S'. + induction e; intros S' s1 s2 Hs; simp ren_expr; + f_equiv; try solve [eauto | apply ren_expr_proper; eauto ]. + + by apply ren_val_proper. + + apply ren_expr_proper. by repeat f_equiv. + - revert S'. + induction v; intros S' s1 s2 Hs; simp ren_expr; + f_equiv; try solve [eauto | apply ren_expr_proper; eauto ]. + apply ren_expr_proper. by repeat f_equiv. Qed. -Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v -with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e -with kmap_id X (δ : X [→] X) (e : ectx X) : δ ≡ ı → fmap δ e = e. -Proof. - - auto_map_id. - - auto_map_id. - - auto_map_id. -Qed. +#[export] Existing Instance ren_expr_proper. +#[export] Existing Instance ren_val_proper. -Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : - f ∘ g ≡ h → fmap f (fmap g v) = fmap h v -with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : - f ∘ g ≡ h → fmap f (fmap g e) = fmap h e -with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : ectx A) : - f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. +#[export] Instance subs_lift_proper S S' : Proper ((≡) ==> (≡)) (@subs_lift S S'). Proof. - - auto_map_comp. - - auto_map_comp. - - auto_map_comp. + intros s1 s2 Hs v. dependent elimination v; simp subs_lift; eauto. + f_equiv. apply Hs. Qed. -#[export] Instance Functor_val : Functor val. -Proof. - split; [exact vmap_id | exact vmap_comp]. -Qed. -#[export] Instance Functor_expr : Functor expr. +Lemma subst_expr_proper {S S'} (e : expr S) : Proper ((≡) ==> (=)) (@subst_expr S S' e) + with subst_val_proper {S S'} v : Proper ((≡) ==> (=)) (@subst_val S S' v). Proof. - split; [exact emap_id | exact emap_comp]. -Qed. -#[export] Instance Functor_ectx : Functor ectx. -Proof. - split; [exact kmap_id | exact kmap_comp]. + - revert S'. + induction e; intros S' s1 s2 Hs; simp subst_expr; + f_equiv; try solve [eauto | apply subst_expr_proper; eauto ]. + + by apply subst_val_proper. + + apply subst_expr_proper. by repeat f_equiv. + - revert S'. + induction v; intros S' s1 s2 Hs; simp subst_expr; + f_equiv; try solve [eauto | apply subst_expr_proper; eauto ]. + apply subst_expr_proper. by repeat f_equiv. Qed. +#[export] Existing Instance subst_expr_proper. +#[export] Existing Instance subst_val_proper. -Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : - f ̂ ≡ g → fmap f v = bind g v -with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : - f ̂ ≡ g → fmap f e = bind g e -with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx A) : - f ̂ ≡ g → fmap f e = bind g e. +Lemma subst_ren_expr {S1 S2 S3} e (s : subs S2 S3) (r : rens S1 S2) : + subst_expr (ren_expr e r) s = subst_expr e (compose s r) +with subst_ren_val {S1 S2 S3} v (s : subs S2 S3) (r : rens S1 S2) : + subst_val (ren_val v r) s = subst_val v (compose s r). Proof. - - auto_map_bind_pure. - erewrite emap_ebind_pure; [reflexivity |]. - intros [| [| x]]; term_simpl; [reflexivity | reflexivity |]. - rewrite <-(EQ x). - reflexivity. - - auto_map_bind_pure. - - auto_map_bind_pure. + - revert S2 S3 r s. + induction e=>S2 S3 r s; simp ren_expr; simp subst_expr; try f_equiv; eauto. + rewrite IHe. apply subst_expr_proper. + intro v. simpl. + dependent elimination v; simp rens_lift; simp subs_lift; eauto. + f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. + - revert S2 S3 r s. + induction v=>S2 S3 r s; simpl; simp ren_val; simp subst_val; try f_equiv. + rewrite subst_ren_expr. + apply subst_expr_proper. + intro v. simpl. + dependent elimination v; simp rens_lift; simp subs_lift; eauto. + f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. Qed. -#[export] Instance BindMapPure_val : BindMapPure val. -Proof. - split; intros; now apply vmap_vbind_pure. -Qed. -#[export] Instance BindMapPure_expr : BindMapPure expr. +Lemma ren_ren_expr {S1 S2 S3} e (s : rens S2 S3) (r : rens S1 S2) : + ren_expr (ren_expr e r) s = ren_expr e (compose s r) +with ren_ren_val {S1 S2 S3} v (s : rens S2 S3) (r : rens S1 S2) : + ren_val (ren_val v r) s = ren_val v (compose s r). Proof. - split; intros; now apply emap_ebind_pure. -Qed. -#[export] Instance BindMapPure_ectx : BindMapPure ectx. -Proof. - split; intros; now apply kmap_kbind_pure. + - revert S2 S3 r s. + induction e=>S2 S3 r s; simp ren_expr; try f_equiv; eauto. + rewrite IHe. apply ren_expr_proper. + intro v. simpl. + dependent elimination v; simp rens_lift; simp subs_lift; eauto. + f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. + - revert S2 S3 r s. + induction v=>S2 S3 r s; simpl; simp ren_val; simp subst_val; try f_equiv. + rewrite ren_ren_expr. + apply ren_expr_proper. + intro v. simpl. + dependent elimination v; simp rens_lift; simp subs_lift; eauto. + f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. Qed. -Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) - (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (v : val A) : - g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) -with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) - (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : - g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) -with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) - (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : ectx A) : - g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). -Proof. - - auto_map_bind_comm. - erewrite emap_ebind_comm; [reflexivity |]. - erewrite lift_comm; [reflexivity |]. - erewrite lift_comm; [reflexivity | assumption]. - - auto_map_bind_comm. - - auto_map_bind_comm. -Qed. +Definition rcompose {S1 S2 S3} (r : rens S2 S3) (s : subs S1 S2) : subs S1 S3 := + λ v, ren_expr (s v) r. -#[export] Instance BindMapComm_val : BindMapComm val. -Proof. - split; intros; now apply vmap_vbind_comm. -Qed. -#[export] Instance BindMapComm_expr : BindMapComm expr. +Lemma ren_subst_expr {S1 S2 S3} e (s : subs S1 S2) (r : rens S2 S3) : + ren_expr (subst_expr e s) r = subst_expr e (rcompose r s) +with ren_subst_val {S1 S2 S3} v (s : subs S1 S2) (r : rens S2 S3) : + ren_val (subst_val v s) r = subst_val v (rcompose r s). Proof. - split; intros; now apply emap_ebind_comm. -Qed. -#[export] Instance BindMapComm_ectx : BindMapComm ectx. -Proof. - split; intros; now apply kmap_kbind_comm. + - revert S2 S3 r s. + induction e=>S2 S3 r s; simp subst_expr; simp ren_expr; try f_equiv; eauto. + rewrite IHe. apply subst_expr_proper. + intro v. simpl. unfold rcompose. + dependent elimination v; eauto. + dependent elimination v; eauto. + simp subs_lift. unfold expr_lift. + rewrite !ren_ren_expr. apply ren_expr_proper. + intro x. dependent elimination v; eauto. + - revert S2 S3 r s. + induction v=>S2 S3 r s; simp subst_expr; simp ren_expr; try f_equiv; eauto. + rewrite ren_subst_expr. apply subst_expr_proper. + intro v. simpl. unfold rcompose. + dependent elimination v; eauto. + dependent elimination v; eauto. + simp subs_lift. unfold expr_lift. + rewrite !ren_ren_expr. apply ren_expr_proper. + intro x. dependent elimination v; eauto. Qed. -Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : - f ≡ ı → bind f v = v -with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : - f ≡ ı → bind f e = e -with kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : - f ≡ ı → bind f e = e. +Lemma appsub_lift {S1 S2 S3} (s : subs S1 S2) (s' : subs S2 S3) : + subs_lift (appsub s s') ≡ appsub (subs_lift s) (subs_lift s'). Proof. - - auto_bind_id. - rewrite ebind_id; [reflexivity |]. - apply lift_id, lift_id; assumption. - - auto_bind_id. - - auto_bind_id. + unfold appsub. + intro v. dependent elimination v; simp subs_lift; eauto. + unfold expr_lift. rewrite subst_ren_expr. + rewrite ren_subst_expr. apply subst_expr_proper. + intro x. unfold rcompose. simpl. simp subs_lift. done. Qed. -Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : - f ∘ g ≡ h → bind f (bind g v) = bind h v -with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : - f ∘ g ≡ h → bind f (bind g e) = bind h e -with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx A) : - f ∘ g ≡ h → bind f (bind g e) = bind h e. +Lemma subst_expr_appsub {S1 S2 S3} (s1 : subs S1 S2) (s2 : subs S2 S3) e : + subst_expr (subst_expr e s1) s2 = subst_expr e (appsub s1 s2) +with subst_val_appsub {S1 S2 S3} (s1 : subs S1 S2) (s2 : subs S2 S3) v : + subst_val (subst_val v s1) s2 = subst_val v (appsub s1 s2). Proof. - - auto_bind_comp. - erewrite ebind_comp; [reflexivity |]. - erewrite lift_comp; [reflexivity |]. - erewrite lift_comp; [reflexivity | assumption]. - - auto_bind_comp. - - auto_bind_comp. + - revert S2 S3 s1 s2. + induction e=>S2 S3 s1 s2; simp subst_expr; try f_equiv; eauto. + rewrite !appsub_lift. apply IHe. + - revert S3 s2. + induction v=>S3 s2; simpl; f_equiv; eauto. + rewrite !appsub_lift. apply subst_expr_appsub. Qed. -#[export] Instance Bind_val : Bind val. -Proof. - split; intros; [now apply vbind_id | now apply vbind_comp]. -Qed. -#[export] Instance Bind_expr : Bind expr. +Lemma subst_expr_lift {S S'} e e1 (s : subs S S') : + subst_expr (expr_lift e) (conssub e1 s) = subst_expr e s. Proof. - split; intros; [now apply ebind_id | now apply ebind_comp]. + unfold expr_lift. + rewrite subst_ren_expr. apply subst_expr_proper. + intro v. simpl. simp conssub. done. Qed. -#[export] Instance Bind_ectx : Bind ectx. + +Lemma subst_expr_idsub {S} (e : expr S) : + subst_expr e idsub = e +with subst_val_idsub {S} (v : val S) : + subst_val v idsub = v. Proof. - split; intros; [now apply kbind_id | now apply kbind_comp]. + - induction e; simp subst_expr; simpl; try f_equiv; eauto. + assert ((subs_lift (subs_lift idsub)) ≡ idsub) as ->; last auto. + intro v. + dependent elimination v; simp subs_lift; auto. + dependent elimination v; simp subs_lift; auto. + - induction v; simp subst_val; simpl; try f_equiv; eauto. + assert ((subs_lift (subs_lift idsub)) ≡ idsub) as ->; last auto. + intro v. + dependent elimination v; simp subs_lift; auto. + dependent elimination v; simp subs_lift; auto. Qed. (*** Operational semantics *) @@ -344,6 +286,7 @@ Record state := State { }. #[export] Instance state_inhabited : Inhabited state := populate (State [] []). + Definition update_input (s : state) : nat * state := match s.(inputs) with | [] => (0, s) @@ -354,93 +297,95 @@ Definition update_output (n:nat) (s : state) : state := {| inputs := s.(inputs); outputs := n::s.(outputs) |}. -Inductive head_step {S} : expr S → state → expr S → state → ectx S → nat * nat → Prop := -| BetaS e1 v2 σ K : - head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (Inc := inc) e1) (shift v2)) (RecV e1)) σ K (1,0) -| InputS σ n σ' K : - update_input σ = (n, σ') → - head_step Input σ (Val (LitV n)) σ' K (1, 1) -| OutputS σ n σ' K : +Inductive head_step {S} : expr S → state → expr S → state → nat*nat → Prop := +| RecS e σ : + head_step (Rec e) σ (Val $ RecV e) σ (0,0) +| BetaS e1 v2 e' σ : + e' = subst2 e1 (Val $ RecV e1) (Val v2) → + head_step (App (Val $ RecV e1) (Val v2)) σ e' σ (1,0) +| InputS σ n σ' : + update_input σ = (n,σ') → + head_step Input σ (Val (Lit n)) σ' (1,1) +| OutputS σ n σ' : update_output n σ = σ' → - head_step (Output (Val (LitV n))) σ (Val (LitV 0)) σ' K (1, 1) -| NatOpS op v1 v2 v3 σ K : + head_step (Output (Val (Lit n))) σ (Val (Lit 0)) σ' (1,1) +| NatOpS op v1 v2 v3 σ : nat_op_interp op v1 v2 = Some v3 → head_step (NatOp op (Val v1) (Val v2)) σ - (Val v3) σ K (0, 0) -| IfTrueS n e1 e2 σ K : + (Val v3) σ (0,0) +| IfTrueS n e1 e2 σ : n > 0 → - head_step (If (Val (LitV n)) e1 e2) σ - e1 σ K (0, 0) -| IfFalseS n e1 e2 σ K : + head_step (If (Val (Lit n)) e1 e2) σ + e1 σ (0,0) +| IfFalseS n e1 e2 σ : n = 0 → - head_step (If (Val (LitV n)) e1 e2) σ - e2 σ K (0, 0) -| CallccS e σ K : - head_step (Callcc e) σ (subst (Inc := inc) e (ContV K)) σ K (0, 0) + head_step (If (Val (Lit n)) e1 e2) σ + e2 σ (0,0) . -Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : - head_step e1 σ1 e2 σ2 K (n,m) → m = 0 ∨ m = 1. +Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 n m : + head_step e1 σ1 e2 σ2 (n,m) → m = 0 ∨ m = 1. Proof. inversion 1; eauto. Qed. -Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : - head_step e1 σ1 e2 σ2 K (n,m) → n = 0 ∨ n = 1. +Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 n m : + head_step e1 σ1 e2 σ2 (n,m) → n = 0 ∨ n = 1. Proof. inversion 1; eauto. Qed. -Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K n : - head_step e1 σ1 e2 σ2 K (n,0) → σ1 = σ2. +Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 n : + head_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. Proof. inversion 1; eauto. Qed. +Inductive ectx_item {S} := + | AppLCtx (v2 : val S) + | AppRCtx (e1 : expr S) + | NatOpLCtx (op : nat_op) (v2 : val S) + | NatOpRCtx (op : nat_op) (e1 : expr S) + | IfCtx (e1 e2 : expr S) + | OutputCtx +. +Arguments ectx_item S : clear implicits. + +Definition fill_item {S} (Ki : ectx_item S) (e : expr S) : expr S := + match Ki with + | AppLCtx v2 => App e (of_val v2) + | AppRCtx e1 => App e1 e + | NatOpLCtx op v2 => NatOp op e (Val v2) + | NatOpRCtx op e1 => NatOp op e1 e + | IfCtx e1 e2 => If e e1 e2 + | OutputCtx => Output e + end. + (** Carbonara from heap lang *) -Global Instance fill_item_inj {S} (Ki : ectx S) : Inj (=) (=) (fill Ki). +Global Instance fill_item_inj {S} (Ki : ectx_item S) : Inj (=) (=) (fill_item Ki). Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. Lemma fill_item_val {S} Ki (e : expr S) : - is_Some (to_val (fill Ki e)) → is_Some (to_val e). + is_Some (to_val (fill_item Ki e)) → is_Some (to_val e). Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed. -Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K m : head_step e1 σ1 e2 σ2 K m → to_val e1 = None. +Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 m : head_step e1 σ1 e2 σ2 m → to_val e1 = None. Proof. destruct 1; naive_solver. Qed. -Fixpoint ectx_compose {S} (K1 K2 : ectx S) : ectx S - := match K1 with - | EmptyK => K2 - | OutputK K => OutputK (ectx_compose K K2) - | IfK K e₁ e₂ => IfK (ectx_compose K K2) e₁ e₂ - | AppLK e K => AppLK e (ectx_compose K K2) - | AppRK K v => AppRK (ectx_compose K K2) v - | NatOpLK op e K => NatOpLK op e (ectx_compose K K2) - | NatOpRK op K v => NatOpRK op (ectx_compose K K2) v - | ThrowLK K e => ThrowLK (ectx_compose K K2) e - | ThrowRK v K => ThrowRK v (ectx_compose K K2) - end. - -Lemma fill_app {S} (K1 K2 : ectx S) e : fill (ectx_compose K1 K2) e = fill K1 (fill K2 e). +Lemma head_ctx_item_step_val {S} Ki (e : expr S) σ1 e2 σ2 m : + head_step (fill_item Ki e) σ1 e2 σ2 m → is_Some (to_val e). +Proof. revert m e2. induction Ki; simpl; inversion 1; simplify_option_eq; eauto. Qed. + +Lemma fill_item_no_val_inj {S} Ki1 Ki2 (e1 e2 : expr S) : + to_val e1 = None → to_val e2 = None → + fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2. Proof. - revert K2. - revert e. - induction K1 as [| ?? IH - | ?? IH - | ??? IH - | ?? IH - | ???? IH - | ??? IH - | ?? IH - | ??? IH]; - simpl; first done; intros e' K2; rewrite IH; reflexivity. + revert Ki1. induction Ki2; intros Ki1; induction Ki1; naive_solver eauto with f_equal. Qed. +(** Lifting the head step **) + +Definition ectx S := (list (ectx_item S)). +Definition fill {S} (K : ectx S) (e : expr S) : expr S := foldl (flip fill_item) e K. + +Lemma fill_app {S} (K1 K2 : ectx S) e : fill (K1 ++ K2) e = fill K2 (fill K1 e). +Proof. apply foldl_app. Qed. + + Lemma fill_val : ∀ {S} K (e : expr S), is_Some (to_val (fill K e)) → is_Some (to_val e). -Proof. - intros S K. - induction K as [| ?? IH - | ?? IH - | ??? IH - | ?? IH - | ???? IH - | ??? IH - | ?? IH - | ??? IH]=> e' //=; - inversion 1 as [? HH]; inversion HH. -Qed. +Proof. intros S K. induction K as [|Ki K IH]=> e //=. by intros ?%IH%fill_item_val. Qed. Lemma fill_not_val : ∀ {S} K (e : expr S), to_val e = None → to_val (fill K e) = None. Proof. @@ -448,57 +393,57 @@ Proof. eauto using fill_val. Qed. -Lemma fill_empty {S} (e : expr S) : fill EmptyK e = e. +Lemma fill_empty {S} (e : expr S) : fill [] e = e. Proof. reflexivity. Qed. -Lemma fill_comp {S} K1 K2 (e : expr S) : fill K2 (fill K1 e) = fill (ectx_compose K2 K1) e. +Lemma fill_comp {S} K1 K2 (e : expr S) : fill K1 (fill K2 e) = fill (K2 ++ K1) e. Proof. by rewrite fill_app. Qed. -Global Instance fill_inj {S} (K : ectx S) : Inj (=) (=) (fill K). -Proof. - induction K as [| ?? IH - | ?? IH - | ??? IH - | ?? IH - | ???? IH - | ??? IH - | ?? IH - | ??? IH]; - rewrite /Inj; naive_solver. -Qed. +Global Instance fill_inj {S} (K:ectx S) : Inj (=) (=) (fill K). +Proof. induction K as [|Ki K IH]; rewrite /Inj; naive_solver. Qed. -Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) - (e2 : expr S) (σ2 : state) (n : nat * nat), Prop := -| Ectx_step e1 σ1 e2 σ2 n (K : ectx S) e1' e2' : - e1 = fill K e1' → e2 = fill K e2' → - head_step e1' σ1 e2' σ2 K n → prim_step e1 σ1 e2 σ2 n -| Throw_step e1 σ e2 (K : ectx S) v K' : - e1 = (fill K (Throw (of_val v) (ContV K'))) -> - e2 = (fill K' v) -> - prim_step e1 σ e2 σ (0, 0). + +Inductive prim_step {S} (e1 : expr S) (σ1 : state) + (e2 : expr S) (σ2 : state) (n : nat*nat) : Prop:= + Ectx_step (K : ectx S) e1' e2' : + e1 = fill K e1' → e2 = fill K e2' → + head_step e1' σ1 e2' σ2 n → prim_step e1 σ1 e2 σ2 n. Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. Proof. inversion 1; simplify_eq/=. - - inversion H2; eauto. - - reflexivity. + inversion H2; eauto. Qed. -Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat → Prop := +Inductive prim_steps {S} : expr S → state → expr S → state → nat*nat → Prop := | prim_steps_zero e σ : - prim_steps e σ e σ (0, 0) + prim_steps e σ e σ (0,0) | prim_steps_abit e1 σ1 e2 σ2 e3 σ3 n1 m1 n2 m2 : - prim_step e1 σ1 e2 σ2 (n1, m1) → - prim_steps e2 σ2 e3 σ3 (n2, m2) → - prim_steps e1 σ1 e3 σ3 (plus n1 n2, plus m1 m2) + prim_step e1 σ1 e2 σ2 (n1,m1) → + prim_steps e2 σ2 e3 σ3 (n2,m2) → + prim_steps e1 σ1 e3 σ3 (n1+n2,m1+m2) . Lemma Ectx_step' {S} (K : ectx S) e1 σ1 e2 σ2 efs : - head_step e1 σ1 e2 σ2 K efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. + head_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. Proof. econstructor; eauto. Qed. +Lemma prim_step_ctx {S} (K : ectx S) e1 σ1 e2 σ2 efs : + prim_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. +Proof. + destruct 1 as [K2 u1 u2 HK2]. + subst e1 e2. rewrite -!fill_app. + by econstructor; eauto. +Qed. + +Lemma prim_steps_ctx {S} (K : ectx S) e1 σ1 e2 σ2 efs : + prim_steps e1 σ1 e2 σ2 efs → prim_steps (fill K e1) σ1 (fill K e2) σ2 efs. +Proof. + induction 1; econstructor; eauto using prim_step_ctx. +Qed. + Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : prim_steps e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 → - prim_steps e1 σ1 e3 σ3 (plus nm1.1 nm2.1, plus nm1.2 nm2.2). + prim_steps e1 σ1 e3 σ3 (nm1.1 + nm2.1, nm1.2 + nm2.2). Proof. intros Hst. revert nm2. induction Hst; intros [n' m']; simplify_eq/=; first done. @@ -517,47 +462,48 @@ Proof. by constructor. Qed. + (*** Type system *) + Inductive ty := - | Tnat : ty | Tarr : ty → ty → ty | Tcont : ty → ty. + | Tnat : ty | Tarr : ty → ty → ty. + +Local Notation tyctx := (tyctx ty). -Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := -| typed_Val (τ : ty) (v : val S) : +Inductive typed : forall {S}, tyctx S → expr S → ty → Prop := +| typed_Val {S} (Γ : tyctx S) (τ : ty) (v : val S) : typed_val Γ v τ → typed Γ (Val v) τ -| typed_App (τ1 τ2 : ty) e1 e2 : +| typed_Var {S} (Γ : tyctx S) (τ : ty) (v : var S) : + typed_var Γ v τ → + typed Γ (Var v) τ +| typed_Rec {S} (Γ : tyctx S) (τ1 τ2 : ty) (e : expr (()::()::S) ) : + typed (consC (Tarr τ1 τ2) (consC τ1 Γ)) e τ2 → + typed Γ (Rec e) (Tarr τ1 τ2) +| typed_App {S} (Γ : tyctx S) (τ1 τ2 : ty) e1 e2 : typed Γ e1 (Tarr τ1 τ2) → typed Γ e2 τ1 → typed Γ (App e1 e2) τ2 -| typed_NatOp e1 e2 op : +| typed_NatOp {S} (Γ : tyctx S) e1 e2 op : typed Γ e1 Tnat → typed Γ e2 Tnat → typed Γ (NatOp op e1 e2) Tnat -| typed_If e0 e1 e2 τ : +| typed_If {S} (Γ : tyctx S) e0 e1 e2 τ : typed Γ e0 Tnat → typed Γ e1 τ → typed Γ e2 τ → typed Γ (If e0 e1 e2) τ -| typed_Input : +| typed_Input {S} (Γ : tyctx S) : typed Γ Input Tnat -| typed_Output e : +| typed_Output {S} (Γ : tyctx S) e : typed Γ e Tnat → typed Γ (Output e) Tnat -| typed_Throw e1 e2 τ τ' : - typed Γ e1 τ -> - typed Γ e2 (Tcont τ) -> - typed Γ (Throw e1 e2) τ' -| typed_Callcc e τ : - typed (Γ ▹ Tcont τ) e τ -> - typed Γ (Callcc e) τ -with typed_val {S : Set} (Γ : S -> ty) : val S → ty → Prop := -| typed_Var (τ : ty) (v : S) : - Γ v = τ → - typed_val Γ (VarV v) τ -| typed_Lit n : - typed_val Γ (LitV n) Tnat -| typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : - typed (Γ ▹ (Tarr τ1 τ2) ▹ τ1) e τ2 → +with typed_val : forall {S}, tyctx S → val S → ty → Prop := +| typed_Lit {S} (Γ : tyctx S) n : + typed_val Γ (Lit n) Tnat +| typed_RecV {S} (Γ : tyctx S) (τ1 τ2 : ty) (e : expr (()::()::S) ) : + typed (consC (Tarr τ1 τ2) (consC τ1 Γ)) e τ2 → typed_val Γ (RecV e) (Tarr τ1 τ2) . + diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v new file mode 100644 index 0000000..3781420 --- /dev/null +++ b/theories/input_lang_callcc/interp.v @@ -0,0 +1,707 @@ +From Equations Require Import Equations. +From gitrees Require Import gitree. +From gitrees.input_lang_callcc Require Import lang. +Require Import gitrees.lang_generic_sem. + +Require Import Binding.Lib. + +Notation stateO := (leibnizO state). + +Program Definition inputE : opInterp := {| + Ins := unitO; + Outs := natO; + |}. +Program Definition outputE : opInterp := {| + Ins := natO; + Outs := unitO; + |}. + +Program Definition callccE : opInterp := {| + Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); + Outs := (▶ ∙); + |}. + +Program Definition throwE : opInterp := {| + Ins := (▶ ∙ * (▶ (∙ -n> ∙))); + Outs := Empty_setO; + |}. + +Definition ioE := @[inputE;outputE;callccE;throwE]. + +Canonical Structure reify_io : sReifier. +Proof. + simple refine {| sReifier_ops := ioE; + sReifier_state := stateO + |}. + intros X HX op. + destruct op as [ | [ | [ | [| []]]]]; simpl. + - simple refine (λne (us : prodO (prodO unitO stateO) (natO -n> laterO X)), + let a : (prodO natO stateO) := (update_input (sndO (fstO us))) in + Some $ ((sndO us) (fstO a), sndO a) : optionO (prodO (laterO X) stateO)). + intros n [[] s1] [[] s2] [[Hs1 Hs2] Hs]; simpl in *. + repeat f_equiv; assumption. + - simple refine (λne (us : prodO (prodO natO stateO) (unitO -n> laterO X)), + let a : stateO := update_output (fstO (fstO us)) (sndO (fstO us)) in + Some $ ((sndO us) (), a) : optionO (prodO (laterO X) stateO)). + intros n [[t1 t2] s1] [[y1 y2] s2] [Hs' Hs]. simpl in *. + repeat f_equiv. + + apply Hs. + + apply Hs'. + + apply Hs'. + - simple refine (λne (us : prodO (prodO ((laterO X -n> laterO X) -n> laterO X) stateO) (laterO X -n> laterO X)), Some $ ((fstO (fstO us)) (sndO us), sndO (fstO us))). + solve_proper. + - simple refine (λne (us : prodO (prodO (prodO (laterO X) (laterO (X -n> X))) stateO) (Empty_setO -n> laterO X)), Some (laterO_ap us.1.1.2 us.1.1.1, sndO (fstO us))). + intros ????. + repeat f_equiv; assumption. +Defined. + +Section constructors. + Context {E : opsInterp} {A} `{!Cofe A}. + Context {subEff0 : subEff ioE E}. + Context {subOfe0 : SubOfe natO A}. + Notation IT := (IT E A). + Notation ITV := (ITV E A). + + Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := + λne k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) + (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) k) + (λne o, (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o). + Solve All Obligations with solve_proper. + + Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) + (subEff_ins (F:=ioE) (op:=(inl ())) ()) + (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). + Solve Obligations with solve_proper. + Program Definition OUTPUT_ : nat -n> IT -n> IT := + λne m α, Vis (E:=E) (subEff_opid (inr (inl ()))) + (subEff_ins (F:=ioE) (op:=(inr (inl ()))) m) + (λne _, NextO α). + Solve All Obligations with solve_proper_please. + Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). + + Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). + Proof. + unfold INPUT. + rewrite hom_vis/=. repeat f_equiv. + intro x. cbn-[laterO_map]. rewrite laterO_map_Next. + done. + Qed. + Lemma hom_OUTPUT_ m α f `{!IT_hom f} : f (OUTPUT_ m α) ≡ OUTPUT_ m (f α). + Proof. + unfold OUTPUT. + rewrite hom_vis/=. repeat f_equiv. + intro x. cbn-[laterO_map]. rewrite laterO_map_Next. + done. + Qed. + + Program Definition THROW : IT -n> (laterO (IT -n> IT)) -n> IT := + λne m α, Vis (E:=E) (subEff_opid (inr (inr (inr (inl ()))))) + (subEff_ins (F:=ioE) (op:=(inr (inr (inr (inl ()))))) (NextO m, α)) + (λne _, laterO_ap α (NextO m)). + Next Obligation. + solve_proper. + Qed. + Next Obligation. + intros; intros ???; simpl. + repeat f_equiv; [assumption |]. + intros ?; simpl. + apply Next_contractive. + destruct n as [| n]. + - apply dist_later_0. + - apply dist_later_S. + apply dist_later_S in H. + apply H. + Qed. + Next Obligation. + intros ?????; simpl. + repeat f_equiv; [assumption |]. + intros ?; simpl. + repeat f_equiv; assumption. + Qed. + +End constructors. + +Section weakestpre. + Context {sz : nat}. + Variable (rs : gReifiers sz). + Context {subR : subReifier reify_io rs}. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + (* Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : *) + (* update_input σ = (n, σ') → *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ *) + (* WP@{rs} (INPUT k) @ s {{ Φ }}. *) + (* Proof. *) + (* intros Hs. iIntros "Hs Ha". *) + (* unfold INPUT. simpl. *) + (* iApply (wp_subreify with "Hs"). *) + (* { simpl. by rewrite Hs. } *) + (* { simpl. by rewrite ofe_iso_21. } *) + (* iModIntro. done. *) + (* Qed. *) + (* Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : *) + (* update_output n σ = σ' → *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ *) + (* WP@{rs} (OUTPUT n) @ s {{ Φ }}. *) + (* Proof. *) + (* intros Hs. iIntros "Hs Ha". *) + (* unfold OUTPUT. simpl. *) + (* iApply (wp_subreify with "Hs"). *) + (* { simpl. by rewrite Hs. } *) + (* { simpl. done. } *) + (* iModIntro. iIntros "H1 H2". *) + (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) + (* Qed. *) + + (* Lemma wp_callcc (σ : stateO) (n : nat) Φ s : *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ Φ (RetV 0)) -∗ *) + (* WP@{rs} (CALLCC n) @ s {{ Φ }}. *) + (* Proof. *) + (* intros Hs. iIntros "Hs Ha". *) + (* unfold OUTPUT. simpl. *) + (* iApply (wp_subreify with "Hs"). *) + (* { simpl. by rewrite Hs. } *) + (* { simpl. done. } *) + (* iModIntro. iIntros "H1 H2". *) + (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) + (* Qed. *) + +End weakestpre. + +Section interp. + Context {sz : nat}. + Variable (rs : gReifiers sz). + Context {subR : subReifier reify_io rs}. + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + + Context {subEff0 : subEff ioE F}. + (** Interpreting individual operators *) + Program Definition interp_input {A} : A -n> IT := + λne env, INPUT Ret. + Program Definition interp_output {A} (t : A -n> IT) : A -n> IT := + get_ret OUTPUT ◎ t. + Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). + Proof. solve_proper. Qed. + + Program Definition interp_callcc {A} (t : A -n> ((laterO IT -n> laterO IT) -n> IT)) + : A -n> IT := λne env, CALLCC (λne f, Next (t env f)). + Next Obligation. + solve_proper. + Qed. + Next Obligation. + intros; intros ???. + repeat f_equiv; intros a; simpl. + do 3 f_equiv; assumption. + Qed. + + Program Definition interp_throw {A} (n : A -n> IT) (m : A -n> IT) + : A -n> IT := λne env, get_fun (λne (f : laterO (IT -n> IT)), THROW (n env) f) (m env). + Next Obligation. + intros ????. + intros n' x y H. + f_equiv; assumption. + Qed. + + 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). + Solve All Obligations with solve_proper_please. + + Global Instance interp_natop_ne A op : NonExpansive2 (@interp_natop A op). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_natop. + + Opaque laterO_map. + Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) + : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := + λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), + body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + do 3 f_equiv; intros ??; simpl; f_equiv; + intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + by do 2 f_equiv. + Qed. + + Program Definition interp_rec {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) : @interp_scope F R _ S -n> IT := mmuu (interp_rec_pre body). + + Program Definition ir_unf {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (@extend_scope F R _ _ (@extend_scope F R _ _ env (interp_rec body env)) a). + Next Obligation. + intros. + solve_proper_prepare. + f_equiv. intros [| [| y']]; simpl; solve_proper. + Qed. + + Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : + interp_rec body env ≡ Fun $ Next $ ir_unf body env. + Proof. + trans (interp_rec_pre body (Next (interp_rec body)) env). + { f_equiv. rewrite /interp_rec. apply mmuu_unfold. } + simpl. rewrite laterO_map_Next. repeat f_equiv. + simpl. unfold ir_unf. intro. simpl. reflexivity. + 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 ]. + Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_app. + + Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := + λne env, IF (t0 env) (t1 env) (t2 env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_if_ne A n : + Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). + Proof. solve_proper. Qed. + + Program Definition interp_nat (n : nat) {A} : A -n> IT := + λne env, Ret n. + + Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := λne env, Fun (Next (K env)). + Solve All Obligations with solve_proper. + + Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_app q (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_apprk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_app (λne env, K env t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_natop op q (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoprk {A} (op : nat_op) (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_natop op (λne env, K env t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) (p : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_if (λne env, K env t) p q env. + Solve All Obligations with solve_proper. + + Program Definition interp_outputk {A} (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_output (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Axiom falso : False. + + (** Interpretation for all the syntactic categories: values, expressions, contexts *) + Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := + match v with + | LitV n => interp_nat n + | VarV x => interp_var x + | RecV e => interp_rec (interp_expr e) + | ContV K => interp_cont (interp_ectx K) + end + with interp_expr {S} (e : expr S) : interp_scope S -n> IT := + match e with + | Val v => interp_val v + | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) + | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) + | Input => interp_input + | Output e => interp_output (interp_expr e) + | Callcc e => + (* interp_callcc _ (interp_expr e) *) + False_rect _ falso + | Throw e1 e2 => + interp_throw (interp_expr e1) (interp_expr e2) + end + with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := + match K with + | EmptyK => + λne env, λne t, t + | AppLK e1 K => interp_applk (interp_expr e1) (interp_ectx K) + | AppRK K v2 => interp_apprk (interp_ectx K) (interp_val v2) + | NatOpLK op e1 K => interp_natoplk op (interp_expr e1) (interp_ectx K) + | NatOpRK op K v2 => interp_natoprk op (interp_ectx K) (interp_val v2) + | IfK K e1 e2 => interp_ifk (interp_ectx K) (interp_expr e1) (interp_expr e2) + | OutputK K => interp_outputk (interp_ectx K) + | ThrowLK K e => + False_rect _ falso + | ThrowRK v K => + False_rect _ falso + end. + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + + (* #[global] Instance interp_val_asval {S} (v : val S) D : AsVal (interp_val v D). *) + (* Proof. *) + (* destruct v; simpl; first apply _. *) + (* rewrite interp_rec_unfold. apply _. *) + (* Qed. *) + + (* Lemma interp_ctx_item_fill {S} (Ki : ectx_item S) e env : *) + (* interp_expr (fill_item Ki e) env ≡ interp_ctx_item Ki env (interp_expr e env). *) + (* Proof. destruct Ki; reflexivity. Qed. *) + + (* Lemma interp_ectx_fill {S} (K : ectx S) e env : *) + (* interp_expr (fill K e) env ≡ interp_ectx K env (interp_expr e env). *) + (* Proof. *) + (* revert e; induction K as [|Ki K]=>e; first done. *) + (* rewrite IHK. simpl. rewrite interp_ctx_item_fill. done. *) + (* Qed. *) + + (* (** Applying renamings and subsitutions to the interpretation of scopes *) *) + (* Equations interp_rens_scope {S S' : scope} *) + (* (E : interp_scope (E:=F) (R:=R) S') (s : rens S S') : interp_scope (E:=F) (R:=R) S := *) + (* interp_rens_scope (S:=[]) E s := tt : interp_scope []; *) + (* interp_rens_scope (S:=_::_) E s := *) + (* (interp_var (hd_ren s) E, interp_rens_scope E (tl_ren s)). *) + + (* Equations interp_subs_scope {S S' : scope} *) + (* (E : interp_scope (E:=F) (R:=R) S') (s : subs S S') : interp_scope (E:=F) (R:=R) S := *) + (* interp_subs_scope (S:=[]) E s := tt : interp_scope []; *) + (* interp_subs_scope (S:=_::_) E s := *) + (* (interp_expr (hd_sub s) E, interp_subs_scope E (tl_sub s)). *) + + + (* Global Instance interp_rens_scope_ne S S2 n : *) + (* Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_rens_scope S S2). *) + (* Proof. *) + (* intros D D' HE s1 s2 Hs. *) + (* induction S as [|τ' S]; simp interp_rens_scope; auto. *) + (* f_equiv. *) + (* - unfold hd_ren; rewrite Hs. by f_equiv. *) + (* - apply IHS. intros v. unfold tl_ren; by rewrite Hs. *) + (* Qed. *) + (* Global Instance interp_subs_scope_ne S S2 n : *) + (* Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_subs_scope S S2). *) + (* Proof. *) + (* intros D D' HE s1 s2 Hs. *) + (* induction S as [|τ' S]; simp interp_subs_scope; auto. *) + (* f_equiv. *) + (* - unfold hd_sub; by rewrite Hs HE. *) + (* - apply IHS. intros v. unfold tl_sub; by rewrite Hs. *) + (* Qed. *) + (* Global Instance interp_rens_scope_proper S S2 : *) + (* Proper ((≡) ==> (≡) ==> (≡)) (@interp_rens_scope S S2). *) + (* Proof. *) + (* intros D D' HE s1 s2 Hs. *) + (* induction S as [|τ' S]; simp interp_rens_scope; auto. *) + (* f_equiv. *) + (* - unfold hd_ren; rewrite Hs. *) + (* by rewrite HE. *) + (* - apply IHS. intros v. unfold tl_ren; by rewrite Hs. *) + (* Qed. *) + (* Global Instance interp_subs_scope_proper S S2 : *) + (* Proper ((≡) ==> (≡) ==> (≡)) (@interp_subs_scope S S2). *) + (* Proof. *) + (* intros D D' HE s1 s2 Hs. *) + (* induction S as [|τ' S]; simp interp_subs_scope; auto. *) + (* f_equiv. *) + (* - unfold hd_sub; by rewrite Hs HE. *) + (* - apply IHS. intros v. unfold tl_sub; by rewrite Hs. *) + (* Qed. *) + + (* (** ** The substituion lemma, for renamings and substitutions *) *) + (* Lemma interp_rens_scope_tl_ren {S S2} x D (r : rens S S2) : *) + (* interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift r)) *) + (* ≡ interp_rens_scope D r. *) + (* Proof. *) + (* induction S as [|τ' S]; simp interp_rens_scope; eauto. *) + (* f_equiv. *) + (* { unfold hd_ren, tl_ren. simp rens_lift interp_var. *) + (* done. } *) + (* { rewrite -IHS. f_equiv. clear. *) + (* intros v. dependent elimination v; *) + (* unfold hd_ren, tl_ren; simp rens_lift; auto. } *) + (* Qed. *) + + (* Lemma interp_rens_scope_idren {S} (D : interp_scope S) : *) + (* interp_rens_scope D (@idren S) ≡ D. *) + (* Proof. *) + (* induction S as [|[] S]; simp interp_rens_scope. *) + (* { by destruct D. } *) + (* destruct D as [x D]. simp interp_var. simpl. *) + (* f_equiv. *) + (* trans (interp_rens_scope ((x, D) : interp_scope (()::S)) (tl_ren (rens_lift idren))). *) + (* { f_equiv. intros v. unfold tl_ren. *) + (* reflexivity. } *) + (* rewrite interp_rens_scope_tl_ren. *) + (* apply IHS. *) + (* Qed. *) + + (* Lemma interp_expr_ren {S D : scope} (M : expr S) (r : rens S D) : *) + (* ∀ (E : interp_scope D), *) + (* interp_expr (ren_expr M r) E ≡ interp_expr M (interp_rens_scope E r) *) + (* with interp_val_ren {S D : scope} (v : val S) (r : rens S D) : *) + (* ∀ (E : interp_scope D), *) + (* interp_val (ren_val v r) E ≡ interp_val v (interp_rens_scope E r). *) + (* Proof. *) + (* - revert D r. induction M=> D r D2; simpl; simp ren_expr. *) + (* all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). *) + (* + (* variable *) revert r. *) + (* induction v=>r. *) + (* * simp interp_var interp_rens_scope. done. *) + (* * simp interp_var interp_rens_scope. simpl. *) + (* apply (IHv (tl_ren r)). *) + (* + (* recursive functions *) simp ren_expr. simpl. *) + (* apply bi.siProp.internal_eq_soundness. *) + (* iLöb as "IH". *) + (* rewrite {2}interp_rec_unfold. *) + (* rewrite {2}(interp_rec_unfold (interp_expr M)). *) + (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) + (* rewrite /ir_unf. iIntros (x). simpl. *) + (* rewrite interp_expr_ren. *) + (* iApply f_equivI. *) + (* simp interp_rens_scope interp_var. simpl. *) + (* rewrite !interp_rens_scope_tl_ren. *) + (* iRewrite "IH". *) + (* done. *) + (* - revert D r. induction v=> D r D2; simpl; simp ren_val; eauto. *) + (* (* recursive functions *) *) + (* simp ren_expr. simpl. *) + (* apply bi.siProp.internal_eq_soundness. *) + (* iLöb as "IH". *) + (* rewrite {2}interp_rec_unfold. *) + (* rewrite {2}(interp_rec_unfold (interp_expr e)). *) + (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) + (* rewrite /ir_unf. iIntros (x). simpl. *) + (* rewrite interp_expr_ren. *) + (* iApply f_equivI. *) + (* simp interp_rens_scope interp_var. simpl. *) + (* rewrite !interp_rens_scope_tl_ren. *) + (* iRewrite "IH". *) + (* done. *) + (* Qed. *) + + (* Lemma interp_subs_scope_tl_sub {S S2} x D (s : subs S S2) : *) + (* interp_subs_scope ((x, D) : interp_scope (()::S2)) (tl_sub (subs_lift s)) *) + (* ≡ interp_subs_scope D s. *) + (* Proof. *) + (* induction S as [|[] S]; simp interp_subs_scope; first done. *) + (* f_equiv. *) + (* { unfold hd_sub, tl_sub. simp subs_lift interp_var. *) + (* unfold expr_lift. rewrite interp_expr_ren. f_equiv. *) + (* trans (interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift idren))). *) + (* { f_equiv. intros v. unfold tl_ren. *) + (* simp rens_lift idren. done. } *) + (* rewrite interp_rens_scope_tl_ren. *) + (* apply interp_rens_scope_idren. } *) + (* { rewrite -IHS. f_equiv. clear. *) + (* intros v. dependent elimination v; *) + (* unfold hd_sub, tl_sub; simp subs_lift; auto. } *) + (* Qed. *) + + (* Lemma interp_subs_scope_idsub {S} (env : interp_scope S) : *) + (* interp_subs_scope env idsub ≡ env. *) + (* Proof. *) + (* induction S as [|[] S]; simp interp_subs_scope. *) + (* { by destruct env. } *) + (* destruct env as [x env]. *) + (* unfold hd_sub, idsub. simpl. *) + (* simp interp_var. simpl. f_equiv. *) + (* etrans; last first. *) + (* { apply IHS. } *) + (* rewrite -(interp_subs_scope_tl_sub x env idsub). *) + (* repeat f_equiv. intro v. unfold tl_sub, idsub; simpl. *) + (* simp subs_lift. unfold expr_lift. simp ren_expr. done. *) + (* Qed. *) + + (* Lemma interp_expr_subst {S D : scope} (M : expr S) (s : subs S D) : *) + (* ∀ (E : interp_scope D), *) + (* interp_expr (subst_expr M s) E ≡ interp_expr M (interp_subs_scope E s) *) + (* with interp_val_subst {S D : scope} (v : val S) (s : subs S D) : *) + (* ∀ (E : interp_scope D), *) + (* interp_val (subst_val v s) E ≡ interp_val v (interp_subs_scope E s). *) + (* Proof. *) + (* - revert D s. induction M=> D r D2; simpl; simp subst_expr. *) + (* all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). *) + (* + (* variable *) revert r. *) + (* induction v=>r. *) + (* * simp interp_var interp_rens_scope. done. *) + (* * simp interp_var interp_rens_scope. simpl. *) + (* apply (IHv (tl_sub r)). *) + (* + (* recursive functions *) simpl. *) + (* apply bi.siProp.internal_eq_soundness. *) + (* iLöb as "IH". *) + (* rewrite {2}interp_rec_unfold. *) + (* rewrite {2}(interp_rec_unfold (interp_expr M)). *) + (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) + (* rewrite /ir_unf. iIntros (x). simpl. *) + (* rewrite interp_expr_subst. *) + (* iApply f_equivI. *) + (* simp interp_subs_scope interp_var. simpl. *) + (* rewrite !interp_subs_scope_tl_sub. *) + (* iRewrite "IH". *) + (* done. *) + (* - revert D s. induction v=> D r D2; simpl; simp subst_val; eauto. *) + (* (* recursive functions *) *) + (* simp subst_expr. simpl. *) + (* apply bi.siProp.internal_eq_soundness. *) + (* iLöb as "IH". *) + (* rewrite {2}interp_rec_unfold. *) + (* rewrite {2}(interp_rec_unfold (interp_expr e)). *) + (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) + (* rewrite /ir_unf. iIntros (x). simpl. *) + (* rewrite interp_expr_subst. *) + (* iApply f_equivI. *) + (* simp interp_subs_scope interp_var. simpl. *) + (* rewrite !interp_subs_scope_tl_sub. *) + (* iRewrite "IH". *) + (* done. *) + (* Qed. *) + + (* (** ** Interpretation is a homomorphism *) *) + (* #[global] Instance interp_ectx_item_hom {S} (Ki : ectx_item S) env : *) + (* IT_hom (interp_ctx_item Ki env). *) + (* Proof. destruct Ki; simpl; apply _. Qed. *) + (* #[global] Instance interp_ectx_hom {S} (K : ectx S) env : *) + (* IT_hom (interp_ectx K env). *) + (* Proof. induction K; simpl; apply _. Qed. *) + + (* (** ** Finally, preservation of reductions *) *) + (* Lemma interp_expr_head_step {S} env (e : expr S) e' σ σ' n : *) + (* head_step e σ e' σ' (n,0) → *) + (* interp_expr e env ≡ Tick_n n $ interp_expr e' env. *) + (* Proof. *) + (* inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. *) + (* - (*fun->val*) *) + (* reflexivity. *) + (* - (* app lemma *) *) + (* rewrite APP_APP'_ITV. *) + (* trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). *) + (* { repeat f_equiv. apply interp_rec_unfold. } *) + (* rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. *) + (* simplify_eq. *) + (* rewrite interp_expr_subst. f_equiv. *) + (* simp interp_subs_scope. unfold hd_sub, tl_sub. simp conssub. *) + (* simpl. repeat f_equiv. *) + (* generalize (Val (RecV e1)). *) + (* generalize (Val v2). *) + (* clear. *) + (* intros e1 e2. *) + (* trans (interp_subs_scope env idsub); last first. *) + (* { f_equiv. intro v. simp conssub. done. } *) + (* symmetry. *) + (* apply interp_subs_scope_idsub. *) + (* - (* the natop stuff *) *) + (* simplify_eq. *) + (* destruct v1,v2; try naive_solver. simpl in *. *) + (* rewrite NATOP_Ret. *) + (* destruct op; simplify_eq/=; done. *) + (* - by rewrite IF_True. *) + (* - rewrite IF_False; eauto. lia. *) + (* Qed. *) + + (* Lemma interp_expr_fill_no_reify {S} K env (e e' : expr S) σ σ' n : *) + (* head_step e σ e' σ' (n,0) → *) + (* interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. *) + (* Proof. *) + (* intros He. *) + (* trans (interp_ectx K env (interp_expr e env)). *) + (* { apply interp_ectx_fill. } *) + (* trans (interp_ectx K env (Tick_n n (interp_expr e' env))). *) + (* { f_equiv. apply (interp_expr_head_step env) in He. apply He. } *) + (* trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. *) + (* { f_equiv. symmetry. apply interp_ectx_fill. } *) + (* apply hom_tick_n. apply _. *) + (* Qed. *) + + (* Opaque INPUT OUTPUT_. *) + (* Opaque Ret. *) + + (* Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) *) + (* (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : *) + (* head_step e σ e' σ' (n,1) → *) + (* reify (gReifiers_sReifier rs) *) + (* (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) *) + (* ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). *) + (* Proof. *) + (* intros Hst. *) + (* trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) *) + (* (gState_recomp σr (sR_state σ))). *) + (* { f_equiv. by rewrite interp_ectx_fill. } *) + (* inversion Hst; simplify_eq; cbn-[gState_recomp]. *) + (* - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). *) + (* { repeat f_equiv; eauto. *) + (* rewrite hom_INPUT. f_equiv. by intro. } *) + (* rewrite reify_vis_eq //; last first. *) + (* { rewrite subReifier_reify/=//. *) + (* rewrite H4. done. } *) + (* repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. *) + (* rewrite interp_ectx_fill. *) + (* by rewrite ofe_iso_21. *) + (* - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). *) + (* { do 3 f_equiv; eauto. *) + (* rewrite get_ret_ret//. } *) + (* trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). *) + (* { do 2 f_equiv; eauto. *) + (* rewrite hom_OUTPUT_//. } *) + (* rewrite reify_vis_eq //; last first. *) + (* { rewrite subReifier_reify/=//. } *) + (* repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. *) + (* rewrite interp_ectx_fill. *) + (* simpl. done. *) + (* Qed. *) + + (* Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m env : *) + (* prim_step e1 σ1 e2 σ2 (n,m) → *) + (* ssteps (gReifiers_sReifier rs) *) + (* (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) *) + (* (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. *) + (* Proof. *) + (* Opaque gState_decomp gState_recomp. *) + (* inversion 1; simplify_eq/=. *) + (* destruct (head_step_io_01 _ _ _ _ _ _ H2); subst. *) + (* - assert (σ1 = σ2) as ->. *) + (* { eapply head_step_no_io; eauto. } *) + (* eapply (interp_expr_fill_no_reify K) in H2. *) + (* rewrite H2. eapply ssteps_tick_n. *) + (* - inversion H2;subst. *) + (* + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) + (* rewrite interp_ectx_fill. *) + (* rewrite hom_INPUT. *) + (* change 1 with (1+0). econstructor; last first. *) + (* { apply ssteps_zero; reflexivity. } *) + (* eapply sstep_reify. *) + (* { Transparent INPUT. unfold INPUT. simpl. *) + (* f_equiv. reflexivity. } *) + (* simpl in H2. *) + (* rewrite -H2. *) + (* repeat f_equiv; eauto. *) + (* rewrite interp_ectx_fill hom_INPUT. *) + (* eauto. *) + (* + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) + (* rewrite interp_ectx_fill. simpl. *) + (* rewrite get_ret_ret. *) + (* rewrite hom_OUTPUT_. *) + (* change 1 with (1+0). econstructor; last first. *) + (* { apply ssteps_zero; reflexivity. } *) + (* eapply sstep_reify. *) + (* { Transparent OUTPUT_. unfold OUTPUT_. simpl. *) + (* f_equiv. reflexivity. } *) + (* simpl in H2. *) + (* rewrite -H2. *) + (* repeat f_equiv; eauto. *) + (* Opaque OUTPUT_. *) + (* rewrite interp_ectx_fill /= get_ret_ret hom_OUTPUT_. *) + (* eauto. *) + (* Qed. *) + +End interp. +#[global] Opaque INPUT OUTPUT_. diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v new file mode 100644 index 0000000..5dc84c8 --- /dev/null +++ b/theories/input_lang_callcc/lang.v @@ -0,0 +1,563 @@ +From stdpp Require Export strings. +From gitrees Require Export prelude. +From Equations Require Import Equations. +Require Import List. +Import ListNotations. + +Require Import Binding.Lib Binding.Set Binding.Auto Binding.Env. + +Inductive nat_op := Add | Sub | Mult. + +Inductive expr {X : Set} := +(* Values *) +| Val (v : val) : expr +(* Base lambda calculus *) +| App (e₁ : expr) (e₂ : expr) : expr +(* Base types and their operations *) +| NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr +| If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr +(* The effects *) +| Input : expr +| Output (e : expr) : expr +| Callcc (e : @expr (inc X)) : expr +| Throw (e₁ : expr) (e₂ : expr) : expr +with val {X : Set} := +| VarV (x : X) : val +| LitV (n : nat) : val +| RecV (e : @expr (inc (inc X))) : val +| ContV (K : ectx) : val +with ectx {X : Set} := +| EmptyK : ectx +| OutputK (K : ectx) : ectx +| IfK (K : ectx) (e₁ : expr) (e₂ : expr) : ectx +| AppLK (e : expr) (K : ectx) : ectx +| AppRK (K : ectx) (v : val) : ectx +| NatOpLK (op : nat_op) (e : expr) (K : ectx) : ectx +| NatOpRK (op : nat_op) (K : ectx) (v : val) : ectx +| ThrowLK (K : ectx) (e : expr) : ectx +| ThrowRK (v : val) (K : ectx) : ectx. + +Notation of_val := Val (only parsing). + +Arguments val X%bind : clear implicits. +Arguments expr X%bind : clear implicits. +Arguments ectx X%bind : clear implicits. + +Declare Scope syn_scope. +Declare Scope ectx_scope. +Delimit Scope syn_scope with syn. +Delimit Scope ectx_scope with ectx. + +Coercion Val : val >-> expr. +Coercion App : expr >-> Funclass. +Coercion AppLK : expr >-> Funclass. +Coercion AppRK : ectx >-> Funclass. + +Notation "+" := (Add) : syn_scope. +Notation "-" := (Sub) : syn_scope. +Notation "×" := (Mult) : syn_scope. +Notation "'⟨' e₁ op e₂ '⟩'" := (NatOp op e₁ e₂) (at level 45, right associativity) : syn_scope. +Notation "'if' e₁ 'then' e₂ 'else' e₃" := (If e₁ e₂ e₃) : syn_scope. +Notation "'#' n" := (LitV n) (at level 60) : syn_scope. +Notation "'input'" := (Input) : syn_scope. +Notation "'output' e" := (Output e) (at level 60) : syn_scope. +Notation "'rec' e" := (RecV e) (at level 60) : syn_scope. +Notation "'throw' e₁ e₂" := (Throw e₁ e₂) (at level 60) : syn_scope. +Notation "'cont' K" := (ContV K) (at level 60) : syn_scope. + +Notation "□" := (EmptyK) : ectx_scope. +Notation "'⟨' e₁ op K '⟩ᵣ'" := (NatOpLK op e₁ K) (at level 45, right associativity) : ectx_scope. +Notation "'⟨' K op v₂ '⟩ₗ'" := (NatOpRK op K v₂) (at level 45, right associativity) : ectx_scope. +Notation "'if' K 'then' e₂ 'else' e₃" := (IfK K e₂ e₃) : ectx_scope. +Notation "'output' K" := (OutputK K) (at level 60) : ectx_scope. +Notation "'throwₗ' K e₂" := (ThrowLK K e₂) (at level 60) : ectx_scope. +Notation "'throwᵣ' e₁ K" := (ThrowRK e₁ K) (at level 60) : ectx_scope. + +Definition to_val {S} (e : expr S) : option (val S) := + match e with + | Val v => Some v + | _ => None + end. + +Definition do_natop (op : nat_op) (x y : nat) : nat := + match op with + | Add => plus x y + | Sub => minus x y + | Mult => mult x y + end. + +Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := + match x, y with + | LitV x, LitV y => Some $ LitV $ do_natop n x y + | _,_ => None + end. + +Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := + match K with + | EmptyK => e + | OutputK K => Output (fill K e) + | IfK K e₁ e₂ => If (fill K e) e₁ e₂ + | AppLK e' K => App e' (fill K e) + | AppRK K v => App (fill K e) (Val v) + | NatOpLK op e' K => NatOp op e' (fill K e) + | NatOpRK op K v => NatOp op (fill K e) (Val v) + | ThrowLK K e' => Throw (fill K e) e' + | ThrowRK v K => Throw (Val v) (fill K e) + end. + +Notation "K '[' e ']'" := (fill K e) (at level 60) : syn_scope. + +Local Open Scope bind_scope. + +Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := + match e with + | Val v => Val (vmap f v) + | App e₁ e₂ => App (emap f e₁) (emap f e₂) + | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) + | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) + | Input => Input + | Output e => Output (emap f e) + | Callcc e => Callcc (emap (f ↑) e) + | Throw e₁ e₂ => Throw (emap f e₁) (emap f e₂) + end +with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := + match v with + | VarV x => VarV (f x) + | LitV n => LitV n + | RecV e => RecV (emap ((f ↑) ↑) e) + | ContV K => ContV (kmap f K) + end +with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kmap f K) + | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) + | AppLK e K => AppLK (emap f e) (kmap f K) + | AppRK K v => AppRK (kmap f K) (vmap f v) + | NatOpLK op e K => NatOpLK op (emap f e) (kmap f K) + | NatOpRK op K v => NatOpRK op (kmap f K) (vmap f v) + | ThrowLK K e => ThrowLK (kmap f K) (emap f e) + | ThrowRK v K => ThrowRK (vmap f v) (kmap f K) + end. +#[export] Instance FMap_expr : FunctorCore expr := @emap. +#[export] Instance FMap_val : FunctorCore val := @vmap. +#[export] Instance FMap_ectx : FunctorCore ectx := @kmap. + +Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) + : fmap f (fill K e) = fill (fmap f K) (fmap f e). +Proof. + revert f. + induction K as [| ?? IH + | ?? IH + | ??? IH + | ?? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]; + intros f; term_simpl; first done; rewrite IH; reflexivity. +Qed. + +#[export] Instance SPC_val : SetPureCore val := @VarV. + +Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := + match e with + | Val v => Val (vbind f v) + | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) + | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) + | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) + | Input => Input + | Output e => Output (ebind f e) + | Callcc e => Callcc (ebind (f ↑) e) + | Throw e₁ e₂ => Throw (ebind f e₁) (ebind f e₂) + end +with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := + match v with + | VarV x => f x + | LitV n => LitV n + | RecV e => RecV (ebind ((f ↑) ↑) e) + | ContV K => ContV (kbind f K) + end +with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kbind f K) + | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) + | AppLK e K => AppLK (ebind f e) (kbind f K) + | AppRK K v => AppRK (kbind f K) (vbind f v) + | NatOpLK op e K => NatOpLK op (ebind f e) (kbind f K) + | NatOpRK op K v => NatOpRK op (kbind f K) (vbind f v) + | ThrowLK K e => ThrowLK (kbind f K) (ebind f e) + | ThrowRK v K => ThrowRK (vbind f v) (kbind f K) + end. + +#[export] Instance BindCore_expr : BindCore expr := @ebind. +#[export] Instance BindCore_val : BindCore val := @vbind. +#[export] Instance BindCore_ectx : BindCore ectx := @kbind. + +#[export] Instance IP_typ : SetPure val. +Proof. + split; intros; reflexivity. +Qed. + +Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v +with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e +with kmap_id X (δ : X [→] X) (e : ectx X) : δ ≡ ı → fmap δ e = e. +Proof. + - auto_map_id. + - auto_map_id. + - auto_map_id. +Qed. + +Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : + f ∘ g ≡ h → fmap f (fmap g v) = fmap h v +with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e +with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : ectx A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. +Proof. + - auto_map_comp. + - auto_map_comp. + - auto_map_comp. +Qed. + +#[export] Instance Functor_val : Functor val. +Proof. + split; [exact vmap_id | exact vmap_comp]. +Qed. +#[export] Instance Functor_expr : Functor expr. +Proof. + split; [exact emap_id | exact emap_comp]. +Qed. +#[export] Instance Functor_ectx : Functor ectx. +Proof. + split; [exact kmap_id | exact kmap_comp]. +Qed. + +Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : + f ̂ ≡ g → fmap f v = bind g v +with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : + f ̂ ≡ g → fmap f e = bind g e +with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx A) : + f ̂ ≡ g → fmap f e = bind g e. +Proof. + - auto_map_bind_pure. + erewrite emap_ebind_pure; [reflexivity |]. + intros [| [| x]]; term_simpl; [reflexivity | reflexivity |]. + rewrite <-(EQ x). + reflexivity. + - auto_map_bind_pure. + - auto_map_bind_pure. +Qed. + +#[export] Instance BindMapPure_val : BindMapPure val. +Proof. + split; intros; now apply vmap_vbind_pure. +Qed. +#[export] Instance BindMapPure_expr : BindMapPure expr. +Proof. + split; intros; now apply emap_ebind_pure. +Qed. +#[export] Instance BindMapPure_ectx : BindMapPure ectx. +Proof. + split; intros; now apply kmap_kbind_pure. +Qed. + +Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (v : val A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) +with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) +with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : ectx A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). +Proof. + - auto_map_bind_comm. + erewrite emap_ebind_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity | assumption]. + - auto_map_bind_comm. + - auto_map_bind_comm. +Qed. + +#[export] Instance BindMapComm_val : BindMapComm val. +Proof. + split; intros; now apply vmap_vbind_comm. +Qed. +#[export] Instance BindMapComm_expr : BindMapComm expr. +Proof. + split; intros; now apply emap_ebind_comm. +Qed. +#[export] Instance BindMapComm_ectx : BindMapComm ectx. +Proof. + split; intros; now apply kmap_kbind_comm. +Qed. + +Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : + f ≡ ı → bind f v = v +with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : + f ≡ ı → bind f e = e +with kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : + f ≡ ı → bind f e = e. +Proof. + - auto_bind_id. + rewrite ebind_id; [reflexivity |]. + apply lift_id, lift_id; assumption. + - auto_bind_id. + - auto_bind_id. +Qed. + +Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : + f ∘ g ≡ h → bind f (bind g v) = bind h v +with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e +with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e. +Proof. + - auto_bind_comp. + erewrite ebind_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity | assumption]. + - auto_bind_comp. + - auto_bind_comp. +Qed. + +#[export] Instance Bind_val : Bind val. +Proof. + split; intros; [now apply vbind_id | now apply vbind_comp]. +Qed. +#[export] Instance Bind_expr : Bind expr. +Proof. + split; intros; [now apply ebind_id | now apply ebind_comp]. +Qed. +#[export] Instance Bind_ectx : Bind ectx. +Proof. + split; intros; [now apply kbind_id | now apply kbind_comp]. +Qed. + +(*** Operational semantics *) + +Record state := State { + inputs : list nat; + outputs : list nat; + }. +#[export] Instance state_inhabited : Inhabited state := populate (State [] []). + +Definition update_input (s : state) : nat * state := + match s.(inputs) with + | [] => (0, s) + | n::ns => + (n, {| inputs := ns; outputs := s.(outputs) |}) + end. +Definition update_output (n:nat) (s : state) : state := + {| inputs := s.(inputs); outputs := n::s.(outputs) |}. + + +Inductive head_step {S} : expr S → state → expr S → state → ectx S → nat * nat → Prop := +| BetaS e1 v2 σ K : + head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (Inc := inc) e1) (shift v2)) (RecV e1)) σ K (1,0) +| InputS σ n σ' K : + update_input σ = (n, σ') → + head_step Input σ (Val (LitV n)) σ' K (1, 1) +| OutputS σ n σ' K : + update_output n σ = σ' → + head_step (Output (Val (LitV n))) σ (Val (LitV 0)) σ' K (1, 1) +| NatOpS op v1 v2 v3 σ K : + nat_op_interp op v1 v2 = Some v3 → + head_step (NatOp op (Val v1) (Val v2)) σ + (Val v3) σ K (0, 0) +| IfTrueS n e1 e2 σ K : + n > 0 → + head_step (If (Val (LitV n)) e1 e2) σ + e1 σ K (0, 0) +| IfFalseS n e1 e2 σ K : + n = 0 → + head_step (If (Val (LitV n)) e1 e2) σ + e2 σ K (0, 0) +| CallccS e σ K : + head_step (Callcc e) σ (subst (Inc := inc) e (ContV K)) σ K (0, 0) +. + +Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : + head_step e1 σ1 e2 σ2 K (n,m) → m = 0 ∨ m = 1. +Proof. inversion 1; eauto. Qed. +Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : + head_step e1 σ1 e2 σ2 K (n,m) → n = 0 ∨ n = 1. +Proof. inversion 1; eauto. Qed. +Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K n : + head_step e1 σ1 e2 σ2 K (n,0) → σ1 = σ2. +Proof. inversion 1; eauto. Qed. + +(** Carbonara from heap lang *) +Global Instance fill_item_inj {S} (Ki : ectx S) : Inj (=) (=) (fill Ki). +Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. + +Lemma fill_item_val {S} Ki (e : expr S) : + is_Some (to_val (fill Ki e)) → is_Some (to_val e). +Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed. + +Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K m : head_step e1 σ1 e2 σ2 K m → to_val e1 = None. +Proof. destruct 1; naive_solver. Qed. + +Fixpoint ectx_compose {S} (K1 K2 : ectx S) : ectx S + := match K1 with + | EmptyK => K2 + | OutputK K => OutputK (ectx_compose K K2) + | IfK K e₁ e₂ => IfK (ectx_compose K K2) e₁ e₂ + | AppLK e K => AppLK e (ectx_compose K K2) + | AppRK K v => AppRK (ectx_compose K K2) v + | NatOpLK op e K => NatOpLK op e (ectx_compose K K2) + | NatOpRK op K v => NatOpRK op (ectx_compose K K2) v + | ThrowLK K e => ThrowLK (ectx_compose K K2) e + | ThrowRK v K => ThrowRK v (ectx_compose K K2) + end. + +Lemma fill_app {S} (K1 K2 : ectx S) e : fill (ectx_compose K1 K2) e = fill K1 (fill K2 e). +Proof. + revert K2. + revert e. + induction K1 as [| ?? IH + | ?? IH + | ??? IH + | ?? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]; + simpl; first done; intros e' K2; rewrite IH; reflexivity. +Qed. + +Lemma fill_val : ∀ {S} K (e : expr S), is_Some (to_val (fill K e)) → is_Some (to_val e). +Proof. + intros S K. + induction K as [| ?? IH + | ?? IH + | ??? IH + | ?? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]=> e' //=; + inversion 1 as [? HH]; inversion HH. +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. + +Lemma fill_empty {S} (e : expr S) : fill EmptyK e = e. +Proof. reflexivity. Qed. +Lemma fill_comp {S} K1 K2 (e : expr S) : fill K2 (fill K1 e) = fill (ectx_compose K2 K1) e. +Proof. by rewrite fill_app. Qed. +Global Instance fill_inj {S} (K : ectx S) : Inj (=) (=) (fill K). +Proof. + induction K as [| ?? IH + | ?? IH + | ??? IH + | ?? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]; + rewrite /Inj; naive_solver. +Qed. + +Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) + (e2 : expr S) (σ2 : state) (n : nat * nat), Prop := +| Ectx_step e1 σ1 e2 σ2 n (K : ectx S) e1' e2' : + e1 = fill K e1' → e2 = fill K e2' → + head_step e1' σ1 e2' σ2 K n → prim_step e1 σ1 e2 σ2 n +| Throw_step e1 σ e2 (K : ectx S) v K' : + e1 = (fill K (Throw (of_val v) (ContV K'))) -> + e2 = (fill K' v) -> + prim_step e1 σ e2 σ (0, 0). + +Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : + prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. +Proof. + inversion 1; simplify_eq/=. + - inversion H2; eauto. + - reflexivity. +Qed. + +Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat → Prop := +| prim_steps_zero e σ : + prim_steps e σ e σ (0, 0) +| prim_steps_abit e1 σ1 e2 σ2 e3 σ3 n1 m1 n2 m2 : + prim_step e1 σ1 e2 σ2 (n1, m1) → + prim_steps e2 σ2 e3 σ3 (n2, m2) → + prim_steps e1 σ1 e3 σ3 (plus n1 n2, plus m1 m2) +. + +Lemma Ectx_step' {S} (K : ectx S) e1 σ1 e2 σ2 efs : + head_step e1 σ1 e2 σ2 K efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. +Proof. econstructor; eauto. Qed. + +Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : + prim_steps e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 → + prim_steps e1 σ1 e3 σ3 (plus nm1.1 nm2.1, plus nm1.2 nm2.2). +Proof. + intros Hst. revert nm2. + induction Hst; intros [n' m']; simplify_eq/=; first done. + rewrite -!Nat.add_assoc. intros Hsts. + econstructor; eauto. + by apply (IHHst (n',m')). +Qed. + +Lemma prim_step_steps {S} nm (e1 e2 : expr S) σ1 σ2 : + prim_step e1 σ1 e2 σ2 nm → prim_steps e1 σ1 e2 σ2 nm. +Proof. + destruct nm as [n m]. intro Hs. + rewrite -(Nat.add_0_r n). + rewrite -(Nat.add_0_r m). + econstructor; eauto. + by constructor. +Qed. + +(*** Type system *) + +Inductive ty := + | Tnat : ty | Tarr : ty → ty → ty | Tcont : ty → ty. + +Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := +| typed_Val (τ : ty) (v : val S) : + typed_val Γ v τ → + typed Γ (Val 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_Input : + typed Γ Input Tnat +| typed_Output e : + typed Γ e Tnat → + typed Γ (Output e) Tnat +| typed_Throw e1 e2 τ τ' : + typed Γ e1 τ -> + typed Γ e2 (Tcont τ) -> + typed Γ (Throw e1 e2) τ' +| typed_Callcc e τ : + typed (Γ ▹ Tcont τ) e τ -> + typed Γ (Callcc e) τ +with typed_val {S : Set} (Γ : S -> ty) : val S → ty → Prop := +| typed_Var (τ : ty) (v : S) : + Γ v = τ → + typed_val Γ (VarV v) τ +| typed_Lit n : + typed_val Γ (LitV n) Tnat +| typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : + typed (Γ ▹ (Tarr τ1 τ2) ▹ τ1) e τ2 → + typed_val Γ (RecV e) (Tarr τ1 τ2) +. diff --git a/theories/input_lang_callcc/logpred.v b/theories/input_lang_callcc/logpred.v new file mode 100644 index 0000000..eb1da93 --- /dev/null +++ b/theories/input_lang_callcc/logpred.v @@ -0,0 +1,299 @@ +(** Unary (Kripke) logical relation for the IO lang *) +From Equations Require Import Equations. +From gitrees Require Import gitree program_logic. +From gitrees.input_lang Require Import lang interp. + +Section io_lang. + Context {sz : nat}. + Variable rs : gReifiers sz. + Context `{!subReifier reify_io rs}. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ, !na_invG Σ}. + Notation iProp := (iProp Σ). + + Variable s : stuckness. + Context {A:ofe}. + Variable (P : A → iProp). + Context `{!NonExpansive P}. + + Local Notation tyctx := (tyctx ty). + Local Notation expr_pred := (expr_pred s rs P). + + Program Definition interp_tnat : ITV -n> iProp := λne αv, + (∃ n : nat, αv ≡ RetV n)%I. + Solve All Obligations with solve_proper. + Program Definition interp_tarr (Φ1 Φ2 : ITV -n> iProp) := λne αv, + (□ ∀ σ βv, has_substate σ -∗ + Φ1 βv -∗ + expr_pred (IT_of_V αv ⊙ (IT_of_V βv)) (λne v, ∃ σ', Φ2 v ∗ has_substate σ'))%I. + Solve All Obligations with solve_proper. + + Fixpoint interp_ty (τ : ty) : ITV -n> iProp := + match τ with + | Tnat => interp_tnat + | Tarr τ1 τ2 => interp_tarr (interp_ty τ1) (interp_ty τ2) + end. + + Definition ssubst_valid {S} (Γ : tyctx S) ss := ssubst_valid rs interp_ty Γ ss. + + #[global] Instance io_lang_interp_ty_pers τ βv : Persistent (io_lang.interp_ty τ βv). + Proof. induction τ; apply _. Qed. + #[global] Instance ssubst_valid_pers {S} (Γ : tyctx S) ss : Persistent (ssubst_valid Γ ss). + Proof. apply _. Qed. + + Program Definition valid1 {S} (Γ : tyctx S) (α : interp_scope S -n> IT) (τ : ty) : iProp := + (∀ σ ss, has_substate σ -∗ ssubst_valid Γ ss -∗ + expr_pred (α (interp_ssubst ss)) (λne v, ∃ σ', interp_ty τ v ∗ has_substate σ'))%I. + Solve Obligations with solve_proper. + + Lemma compat_nat {S} n (Ω : tyctx S) : + ⊢ valid1 Ω (interp_nat rs n) Tnat. + Proof. + iIntros (σ αs) "Hs Has". + simpl. iApply expr_pred_ret. simpl. + eauto with iFrame. + Qed. + Lemma compat_var {S} Ω τ (v : var S) : + typed_var Ω v τ → + ⊢ valid1 Ω (interp_var v) τ. + Proof. + intros Hv. + iIntros (σ ss) "Hs Has". simpl. + unfold ssubst_valid. + iInduction Hv as [|? ? ? Ω v] "IH" forall (ss); simpl. + - dependent elimination ss as [cons_ssubst αv ss]. + rewrite ssubst_valid_cons. + simp interp_var. simpl. + iDestruct "Has" as "[H _]". + iApply expr_pred_ret; simpl; eauto with iFrame. + - dependent elimination ss as [cons_ssubst αv ss]. + rewrite ssubst_valid_cons. + simp interp_var. simpl. + iDestruct "Has" as "[_ H]". + by iApply ("IH" with "Hs H"). + Qed. + Lemma compat_if {S} (Γ : tyctx S) τ α β1 β2 : + ⊢ valid1 Γ α Tnat -∗ + valid1 Γ β1 τ -∗ + valid1 Γ β2 τ -∗ + valid1 Γ (interp_if rs α β1 β2) τ. + Proof. + iIntros "H0 H1 H2". + iIntros (σ ss) "Hs #Has". + iSpecialize ("H0" with "Hs Has"). + simpl. iApply (expr_pred_bind (IFSCtx _ _) with "H0"). + iIntros (αv) "Ha/=". + iDestruct "Ha" as (σ') "[Ha Hs]". + iDestruct "Ha" as (n) "Hn". + unfold IFSCtx. iIntros (x) "Hx". + iRewrite "Hn". + destruct n as [|n]. + - rewrite IF_False; last lia. + iApply ("H2" with "Hs Has Hx"). + - rewrite IF_True; last lia. + iApply ("H1" with "Hs Has Hx"). + Qed. + Lemma compat_input {S} (Γ : tyctx S) : + ⊢ valid1 Γ (interp_input rs) Tnat. + Proof. + iIntros (σ ss) "Hs #Has". + iApply expr_pred_frame. + destruct (update_input σ) as [n σ'] eqn:Hinp. + iApply (wp_input with "Hs") . + { eauto. } + iNext. iIntros "_ Hs". + iApply wp_val. simpl. eauto with iFrame. + Qed. + Lemma compat_output {S} (Γ : tyctx S) α : + ⊢ valid1 Γ α Tnat → valid1 Γ (interp_output rs α) Tnat. + Proof. + iIntros "H". + iIntros (σ ss) "Hs #Has". + iSpecialize ("H" with "Hs Has"). + simpl. + iApply (expr_pred_bind (get_ret _) with "H"). + iIntros (αv) "Ha". + iDestruct "Ha" as (σ') "[Ha Hs]". + iDestruct "Ha" as (n) "Hn". + iApply expr_pred_frame. + iRewrite "Hn". + rewrite get_ret_ret. + iApply (wp_output with "Hs"). + { reflexivity. } + iNext. iIntros "_ Hs /=". + eauto with iFrame. + Qed. + Lemma compat_app {S} (Γ : tyctx S) α β τ1 τ2 : + ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ + valid1 Γ β τ1 -∗ + valid1 Γ (interp_app rs α β) τ2. + Proof. + iIntros "H1 H2". + iIntros (σ ss) "Hs #Has". simpl. + iSpecialize ("H2" with "Hs Has"). + iApply (expr_pred_bind (AppRSCtx _) with "H2"). + iIntros (βv) "Hb/=". + iDestruct "Hb" as (σ') "[Hb Hs]". + unfold AppRSCtx. + iSpecialize ("H1" with "Hs Has"). + iApply (expr_pred_bind (AppLSCtx (IT_of_V βv)) with "H1"). + iIntros (αv) "Ha". + iDestruct "Ha" as (σ'') "[Ha Hs]". + unfold AppLSCtx. + iApply ("Ha" with "Hs Hb"). + Qed. + + Lemma compat_rec {S} (Γ : tyctx S) τ1 τ2 α : + ⊢ □ valid1 (consC (Tarr τ1 τ2) (consC τ1 Γ)) α τ2 -∗ + valid1 Γ (interp_rec rs α) (Tarr τ1 τ2). + Proof. + iIntros "#H". iIntros (σ ss) "Hs #Hss". + pose (env := (interp_ssubst ss)). fold env. + simp subst_expr. + pose (f := (ir_unf rs α env)). + iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". + { iPureIntro. apply interp_rec_unfold. } + iRewrite "Hf". iApply expr_pred_ret. simpl. + iExists _. iFrame. iModIntro. + iLöb as "IH". iSimpl. + clear σ. + iIntros (σ βv) "Hs #Hw". + iIntros (x) "Hx". + iApply wp_lam. + iNext. + pose (ss' := cons_ssubst (FunV (Next f)) (cons_ssubst βv ss)). + iSpecialize ("H" $! _ ss' with "Hs []"). + { unfold ssubst_valid. + unfold ss'. + rewrite !ssubst_valid_cons. + by iFrame "IH Hw Hss". } + unfold f. simpl. + unfold ss'. simp interp_ssubst. + iAssert (IT_of_V (FunV (Next f)) ≡ interp_rec rs α env)%I as "Heq". + { rewrite interp_rec_unfold. done. } + iRewrite -"Heq". by iApply "H". + Qed. + + Lemma compat_natop {S} (Γ : tyctx S) op α β : + ⊢ valid1 Γ α Tnat -∗ + valid1 Γ β Tnat -∗ + valid1 Γ (interp_natop _ op α β) Tnat. + Proof. + iIntros "H1 H2". + iIntros (σ ss) "Hs #Has". simpl. + iSpecialize ("H2" with "Hs Has"). + iApply (expr_pred_bind (NatOpRSCtx _ _) with "H2"). + iIntros (βv) "Hb/=". + iDestruct "Hb" as (σ') "[Hb Hs]". + unfold NatOpRSCtx. + iSpecialize ("H1" with "Hs Has"). + iApply (expr_pred_bind (NatOpLSCtx _ (IT_of_V βv)) with "H1"). + iIntros (αv) "Ha". + iDestruct "Ha" as (σ'') "[Ha Hs]". + unfold NatOpLSCtx. + iDestruct "Hb" as (n1) "Hb". + iDestruct "Ha" as (n2) "Ha". + iRewrite "Hb". iRewrite "Ha". + simpl. iApply expr_pred_frame. + rewrite NATOP_Ret. iApply wp_val. simpl. + eauto with iFrame. + Qed. + + Lemma fundamental {S} (Γ : tyctx S) e τ : + typed Γ e τ → ⊢ valid1 Γ (interp_expr rs e) τ + with fundamental_val {S} (Γ : tyctx S) v τ : + typed_val Γ v τ → ⊢ valid1 Γ (interp_val rs v) τ. + Proof. + - destruct 1. + + by iApply fundamental_val. + + by iApply compat_var. + + iApply compat_rec; iApply fundamental; eauto. + + iApply compat_app; iApply fundamental; eauto. + + iApply compat_natop; iApply fundamental; eauto. + + iApply compat_if; iApply fundamental; eauto. + + iApply compat_input. + + iApply compat_output; iApply fundamental; eauto. + - destruct 1. + + iApply compat_nat. + + iApply compat_rec; iApply fundamental; eauto. + Qed. + Lemma fundmanetal_closed (e : expr []) (τ : ty) : + typed empC e τ → + ⊢ valid1 empC (interp_expr rs e) τ. + Proof. apply fundamental. Qed. + +End io_lang. + +Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _} τ. +Arguments interp_tarr {_ _ _ _ _ _ _ _ _ _ _} Φ1 Φ2. + +Local Definition rs : gReifiers _ := gReifiers_cons reify_io 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 Σ} τ (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ}, + (£ cr ⊢ valid1 rs notStuck (λ _:unitO, True)%I empC α τ)%I) → + ssteps (gReifiers_sReifier rs) (α ()) 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 (interp_ty (s:=notStuck) (P:=(λ _:unitO, True)) τ)%I. split. + { 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" $! σ with "Hs []"). + { iApply ssubst_valid_nil. } + iSpecialize ("Hlog" $! tt with "[//]"). + iApply (wp_wand with"Hlog"). + iIntros ( βv). simpl. iDestruct 1 as (_) "[H _]". + iDestruct "H" as (σ1') "[$ Hsts]". + done. +Qed. + +Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : + typed empC e τ → + ssteps (gReifiers_sReifier rs) (interp_expr _ e ()) (σ,()) β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) + ∨ (∃ βv, IT_of_V βv ≡ β). +Proof. + intros Htyped Hsteps. + pose (Σ:=#[invΣ;stateΣ rs natO]). + assert (invGpreS Σ). + { apply _. } + assert (statePreG rs natO Σ). + { apply _. } + eapply (logpred_adequacy 0 Σ); eauto. + intros ? ?. iIntros "_". + by iApply fundamental. +Qed. diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v new file mode 100644 index 0000000..534a185 --- /dev/null +++ b/theories/input_lang_callcc/logrel.v @@ -0,0 +1,488 @@ +(** Logical relation for adequacy for the IO lang *) +From Equations Require Import Equations. +From gitrees Require Import gitree. +From gitrees.input_lang Require Import lang interp. + +Section logrel. + Context {sz : nat}. + Variable (rs : gReifiers sz). + Context {subR : subReifier reify_io rs}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F natO). + Notation ITV := (ITV F natO). + Context `{!invGS Σ, !stateG rs natO Σ}. + Notation iProp := (iProp Σ). + Notation restO := (gState_rest sR_idx rs ♯ IT). + + Canonical Structure exprO S := leibnizO (expr S). + Canonical Structure valO S := leibnizO (val S). + Local Notation tyctx := (tyctx ty). + + 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_expr {S} V (α : IT) (e : expr S) : iProp := + (∀ (σ : stateO), + has_substate σ -∗ + WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ + ∗ V βv v ∗ has_substate σ' }})%I. + Definition logrel_nat {S} (βv : ITV) (v : val S) : iProp := + (∃ n, βv ≡ RetV n ∧ ⌜v = Lit n⌝)%I. + Definition logrel_arr {S} V1 V2 (βv : ITV) (vf : val S) : iProp := + (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. + + Fixpoint logrel_val (τ : ty) {S} : ITV → (val S) → iProp + := match τ with + | Tnat => logrel_nat + | Tarr τ1 τ2 => logrel_arr (logrel_val τ1) (logrel_val τ2) + end. + + Definition logrel (τ : ty) {S} : IT → (expr S) → iProp + := logrel_expr (logrel_val τ). + + #[export] Instance logrel_expr_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V → NonExpansive2 (logrel_expr V). + Proof. solve_proper. Qed. + #[export] Instance logrel_nat_ne {S} : NonExpansive2 (@logrel_nat S). + Proof. solve_proper. Qed. + #[export] Instance logrel_val_ne (τ : ty) {S} : NonExpansive2 (@logrel_val τ S). + Proof. induction τ; simpl; solve_proper. Qed. + #[export] Instance logrel_expr_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_expr V). + Proof. solve_proper. Qed. + #[export] Instance logrel_val_proper (τ : ty) {S} : + Proper ((≡) ==> (≡) ==> (≡)) (@logrel_val τ S). + Proof. induction τ; simpl; solve_proper. Qed. + #[export] Instance logrel_persistent (τ : ty) {S} α v : + Persistent (@logrel_val τ S α v). + Proof. + revert α v. induction τ=> α v; simpl. + - unfold logrel_nat. apply _. + - unfold logrel_arr. apply _. + Qed. + + Lemma logrel_bind {S} (f : IT → IT) (K : ectx S) `{!IT_hom f} + e α τ1 V2 `{!NonExpansive2 V2} : + ⊢ logrel_expr (logrel_val τ1) α e -∗ + (∀ v βv, logrel_val τ1 βv v -∗ + logrel_expr V2 (f (IT_of_V βv)) (fill K (Val v))) -∗ + logrel_expr V2 (f α) (fill K e). + Proof. + iIntros "H1 H2". + iLöb as "IH" forall (α e). + iIntros (σ) "Hs". + iApply wp_bind. + { solve_proper. } + iSpecialize ("H1" with "Hs"). + iApply (wp_wand with "H1"). + iIntros (αv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H1 Hs]". + apply (prim_steps_ctx K) in Hsteps. + iSpecialize ("H2" with "H1 Hs"). + iApply (wp_wand with "H2"). iModIntro. + iIntros (βv). iDestruct 1 as ([m2 m2'] v2 σ2' Hsteps2) "[H2 Hs]". + iExists (m + m2, m' + m2'),v2,σ2'. iFrame "H2 Hs". + iPureIntro. eapply (prim_steps_app (m,m') (m2,m2')); eauto. + Qed. + + Lemma logrel_of_val {S} αv (v : val S) V : + V αv v -∗ logrel_expr V (IT_of_V αv) (Val v). + Proof. + iIntros "H1". iIntros (σ) "Hs". + iApply wp_val. + iExists (0,0),v,σ. iFrame. iPureIntro. + by econstructor. + Qed. + + Lemma logrel_step_pure {S} (e' e : expr S) α V : + (∀ σ, prim_step e σ e' σ (0,0)) → + logrel_expr V α e' ⊢ logrel_expr V α e. + Proof. + intros Hpure. + iIntros "H". + iIntros (σ) "Hs". + iSpecialize ("H" with "Hs"). + iApply (wp_wand with "H"). + iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". + iExists (m,m'),v,σ'. iFrame "H2 Hs". + iPureIntro. + eapply (prim_steps_app (0,0) (m,m')); eauto. + { eapply prim_step_steps, Hpure. } + Qed. + + (* a matching list of closing substitutions *) + Inductive subs2 : scope → Type := + | emp_subs2 : subs2 [] + | cons_subs2 {S} : val [] → ITV → subs2 S → subs2 (()::S) + . + + Equations subs_of_subs2 {S} (ss : subs2 S) : subs S [] := + subs_of_subs2 emp_subs2 v => idsub v; + subs_of_subs2 (cons_subs2 t α ss) Vz := Val t; + subs_of_subs2 (cons_subs2 t α ss) (Vs v) := subs_of_subs2 ss v. + + Equations its_of_subs2 {S} (ss : subs2 S) : interp_scope (E:=F) (R:=natO) S := + its_of_subs2 emp_subs2 := (); + its_of_subs2 (cons_subs2 t α ss) := (IT_of_V α, its_of_subs2 ss). + + Equations list_of_subs2 {S} (ss : subs2 S) : list (val []*ITV) := + list_of_subs2 emp_subs2 := []; + list_of_subs2 (cons_subs2 v α ss) := (v,α)::(list_of_subs2 ss). + + Lemma subs_of_emp_subs2 : subs_of_subs2 emp_subs2 ≡ idsub. + Proof. intros v. dependent elimination v. Qed. + + Definition subs2_valid {S} (Γ : tyctx S) (ss : subs2 S) : iProp := + ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_subs2 ss), + logrel_val (τx.1) (τx.2.2) (τx.2.1))%I. + + Definition logrel_valid {S} (Γ : tyctx S) (e : expr S) (α : interp_scope S -n> IT) (τ : ty) : iProp := + (∀ ss, subs2_valid Γ ss → logrel τ + (α (its_of_subs2 ss)) + (subst_expr e (subs_of_subs2 ss)))%I. + + Lemma compat_var {S} (Γ : tyctx S) (x : var S) τ : + typed_var Γ x τ → ⊢ logrel_valid Γ (Var x) (interp_var x) τ. + Proof. + intros Hx. iIntros (ss) "Hss". + simp subst_expr. + iInduction Hx as [|Hx] "IH". + - dependent elimination ss. simp subs_of_subs2. + simp interp_var. rewrite /subs2_valid. + simp list_of_tyctx list_of_subs2 its_of_subs2. simpl. + iDestruct "Hss" as "[Hv Hss]". + iApply (logrel_of_val with "Hv"). + - dependent elimination ss. simp subs_of_subs2. + simp interp_var. rewrite /subs2_valid. + simp list_of_tyctx list_of_subs2 its_of_subs2. simpl. + iDestruct "Hss" as "[Hv Hss]". by iApply "IH". + Qed. + + Lemma compat_if {S} (Γ : tyctx S) (e0 e1 e2 : expr S) α0 α1 α2 τ : + ⊢ logrel_valid Γ e0 α0 Tnat -∗ + logrel_valid Γ e1 α1 τ -∗ + logrel_valid Γ e2 α2 τ -∗ + logrel_valid Γ (If e0 e1 e2) (interp_if rs α0 α1 α2) τ. + Proof. + iIntros "H0 H1 H2". iIntros (ss) "#Hss". + simpl. simp subst_expr. + pose (s := (subs_of_subs2 ss)). fold s. + iSpecialize ("H0" with "Hss"). + iApply (logrel_bind (IFSCtx (α1 (its_of_subs2 ss)) (α2 (its_of_subs2 ss))) + [IfCtx (subst_expr e1 s) (subst_expr e2 s)] + with "H0"). + iIntros (v βv). iDestruct 1 as (n) "[Hb ->]". + iRewrite "Hb". simpl. + unfold IFSCtx. + destruct (decide (0 < n)). + - rewrite IF_True//. + iSpecialize ("H1" with "Hss"). + iApply (logrel_step_pure with "H1"). + intros ?. apply (Ectx_step' []). + econstructor; eauto. + - rewrite IF_False; last lia. + iSpecialize ("H2" with "Hss"). + iApply (logrel_step_pure with "H2"). + intros ?. apply (Ectx_step' []). + econstructor; eauto. lia. + Qed. + + Lemma compat_recV {S} Γ (e : expr (()::()::S)) τ1 τ2 α : + ⊢ □ logrel_valid (consC (Tarr τ1 τ2) (consC τ1 Γ)) e α τ2 -∗ + logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). + Proof. + iIntros "#H". iIntros (ss) "#Hss". + pose (s := (subs_of_subs2 ss)). fold s. + pose (env := (its_of_subs2 ss)). fold env. + simp subst_expr. + pose (f := (ir_unf rs α env)). + iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". + { iPureIntro. apply interp_rec_unfold. } + iRewrite "Hf". + iApply logrel_of_val. iLöb as "IH". iSimpl. + iExists (Next f). iSplit; eauto. + iModIntro. + iIntros (βv w) "#Hw". + iAssert ((APP' (Fun $ Next f) (IT_of_V βv)) ≡ (Tick (ir_unf rs α env (IT_of_V βv))))%I + as "Htick". + { iPureIntro. rewrite APP_APP'_ITV. + rewrite APP_Fun. simpl. done. } + iRewrite "Htick". iClear "Htick". + iIntros (σ) "Hs". + iApply wp_tick. iNext. simpl. + pose (ss' := cons_subs2 (RecV (subst_expr e (subs_lift (subs_lift s)))) (FunV (Next (ir_unf rs α env))) (cons_subs2 w βv ss)). + iSpecialize ("H" $! ss' with "[Hss]"). + { rewrite {2}/subs2_valid /ss'. simp list_of_tyctx list_of_subs2. + cbn-[logrel_val]. iFrame "Hss Hw". fold f. iRewrite -"Hf". + by iApply "IH". } + iSpecialize ("H" with "Hs"). + iClear "IH Hss Hw". + unfold ss'. simpl. simp its_of_subs2. fold f env. + iRewrite "Hf". simpl. + iApply (wp_wand with "H"). + iIntros (v). + iDestruct 1 as ([m m'] v0 σ0 Hsteps) "[Hv Hs]". + iExists (1+m,0+m'),v0,σ0. iFrame "Hv Hs". + iPureIntro. econstructor; eauto. + apply (Ectx_step' []). + apply BetaS. + clear. + unfold subst2. + rewrite subst_expr_appsub. + apply subst_expr_proper. + intro v. + dependent elimination v. + { simp subs_of_subs2. unfold appsub. + simp subs_lift. simp subst_expr. + simp conssub. reflexivity. } + dependent elimination v. + { simp subs_of_subs2. unfold appsub. + simp subs_lift. unfold expr_lift. + simp ren_expr. simp subst_expr. + simp conssub. reflexivity. } + { simp subs_of_subs2. unfold appsub. + simp subs_lift. unfold expr_lift. + fold s. remember (s v) as e1. + rewrite ren_ren_expr. + rewrite subst_ren_expr. + trans (subst_expr e1 idsub). + - symmetry. apply subst_expr_idsub. + - apply subst_expr_proper. + intro v'. simpl. simp conssub. + reflexivity. } + Qed. + + Lemma compat_rec {S} Γ (e : expr (()::()::S)) τ1 τ2 α : + ⊢ □ logrel_valid (consC (Tarr τ1 τ2) (consC τ1 Γ)) e α τ2 -∗ + logrel_valid Γ (Rec e) (interp_rec rs α) (Tarr τ1 τ2). + Proof. + iIntros "#H". iIntros (ss) "#Hss". + pose (s := (subs_of_subs2 ss)). fold s. + pose (env := (its_of_subs2 ss)). fold env. + simp subst_expr. + iApply (logrel_step_pure (Val (RecV (subst_expr e (subs_lift (subs_lift s)))))). + { intros ?. eapply (Ectx_step' []). econstructor. } + iPoseProof (compat_recV with "H") as "H2". + iSpecialize ("H2" with "Hss"). + simp subst_expr. iApply "H2". + Qed. + + Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : + ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ + logrel_valid Γ e2 α2 τ1 -∗ + logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. + Proof. + iIntros "H1 H2". iIntros (ss) "#Hss". + iSpecialize ("H1" with "Hss"). + iSpecialize ("H2" with "Hss"). + pose (s := (subs_of_subs2 ss)). fold s. + pose (env := its_of_subs2 ss). fold env. + simp subst_expr. simpl. + iApply (logrel_bind (AppRSCtx (α1 env)) [AppRCtx (subst_expr e1 s)] with "H2"). + iIntros (v2 β2) "H2". iSimpl. + iApply (logrel_bind (AppLSCtx (IT_of_V β2)) [AppLCtx v2] with "H1"). + iIntros (v1 β1) "H1". simpl. + iDestruct "H1" as (f) "[Hα H1]". + simpl. + unfold AppLSCtx. iRewrite "Hα". (** XXX why doesn't simpl work here? *) + iApply ("H1" with "H2"). + Qed. + + Lemma compat_input {S} Γ : + ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. + Proof. + iIntros (ss) "Hss". + iIntros (σ) "Hs". + destruct (update_input σ) as [n σ'] eqn:Hinp. + iApply (wp_input with "Hs []"); first eauto. + iNext. iIntros "Hlc Hs". + iApply wp_val. + iExists (1,1),(Lit n),σ'. + iFrame "Hs". iModIntro. iSplit. + { iPureIntro. + simp subst_expr. + apply prim_step_steps. + apply (Ectx_step' []). + by constructor. } + iExists n. eauto. + Qed. + Lemma compat_output {S} Γ (e: expr S) α : + ⊢ logrel_valid Γ e α Tnat -∗ + logrel_valid Γ (Output e) (interp_output rs α) Tnat. + Proof. + iIntros "H1". + iIntros (ss) "Hss". + iSpecialize ("H1" with "Hss"). + pose (s := (subs_of_subs2 ss)). fold s. + pose (env := its_of_subs2 ss). fold env. + simp subst_expr. simpl. + iApply (logrel_bind (get_ret _) [OutputCtx] with "H1"). + iIntros (v βv). + iDestruct 1 as (m) "[Hb ->]". + iRewrite "Hb". simpl. + iIntros (σ) "Hs". + rewrite get_ret_ret. + iApply (wp_output with "Hs []"); first done. + iNext. iIntros "Hlc Hs". + iExists (1,1),(Lit 0),_. + iFrame "Hs". iSplit. + { iPureIntro. + apply prim_step_steps. + apply (Ectx_step' []). + by constructor. } + iExists 0. eauto. + Qed. + + Lemma compat_natop {S} (Γ : tyctx S) e1 e2 α1 α2 op : + ⊢ logrel_valid Γ e1 α1 Tnat -∗ + logrel_valid Γ e2 α2 Tnat -∗ + logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. + Proof. + iIntros "H1 H2". iIntros (ss) "#Hss". + iSpecialize ("H1" with "Hss"). + iSpecialize ("H2" with "Hss"). + pose (s := (subs_of_subs2 ss)). fold s. + pose (env := its_of_subs2 ss). fold env. + simp subst_expr. simpl. + iApply (logrel_bind (NatOpRSCtx (do_natop op) (α1 env)) [NatOpRCtx op (subst_expr e1 s)] with "H2"). + iIntros (v2 β2) "H2". iSimpl. + iApply (logrel_bind (NatOpLSCtx (do_natop op) (IT_of_V β2)) [NatOpLCtx op v2] with "H1"). + iIntros (v1 β1) "H1". simpl. + iDestruct "H1" as (n1) "[Hn1 ->]". + iDestruct "H2" as (n2) "[Hn2 ->]". + unfold NatOpLSCtx. + iAssert ((NATOP (do_natop op) (IT_of_V β1) (IT_of_V β2)) ≡ Ret (do_natop op n1 n2))%I with "[Hn1 Hn2]" as "Hr". + { iRewrite "Hn1". simpl. + iRewrite "Hn2". simpl. + iPureIntro. + by rewrite NATOP_Ret. } + iApply (logrel_step_pure (Val (Lit (do_natop op n1 n2)))). + { intro. apply (Ectx_step' []). constructor. + destruct op; simpl; eauto. } + iRewrite "Hr". + iApply (logrel_of_val (RetV $ do_natop op n1 n2)). + iExists _. iSplit; eauto. + Qed. + + Lemma fundamental {S} (Γ : tyctx S) τ e : + typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ + with fundamental_val {S} (Γ : tyctx S) τ v : + typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. + Proof. + - induction 1; simpl. + + by apply fundamental_val. + + by apply compat_var. + + iApply compat_rec. iApply IHtyped. + + iApply compat_app. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_natop. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_if. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + ++ iApply IHtyped3. + + iApply compat_input. + + iApply compat_output. + iApply IHtyped. + - induction 1; simpl. + + iIntros (ss) "Hss". simp subst_expr. simpl. + iApply (logrel_of_val (RetV n)). iExists n. eauto. + + iApply compat_recV. by iApply fundamental. + Qed. + +End logrel. + +Definition κ {S} {E} : ITV E natO → val S := λ x, + match x with + | core.RetV n => Lit n + | _ => Lit 0 + end. +Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (Lit n : val S). +Proof. + Transparent RetV. unfold RetV. simpl. done. Opaque RetV. +Qed. +Definition rs : gReifiers 1 := gReifiers_cons reify_io gReifiers_nil. + +Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, + (True ⊢ logrel rs Tnat α e)%I) → + ssteps (gReifiers_sReifier rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ Lit n) σ' m. +Proof. + intros Hlog Hst. + pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), + ∃ m σ', prim_steps e σ (Val $ κ βv) σ' m). + cut (ϕ (RetV n)). + { destruct 1 as ( m' & σ2 & Hm). + exists m', σ2. revert Hm. by rewrite κ_Ret. } + eapply (wp_adequacy 0); eauto. + intros Hinv1 Hst1. + pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (Lit n) + ∗ ⌜∃ m σ', prim_steps e σ (Val $ Lit 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 with "[//]") as "Hlog". + iAssert (has_substate σ) with "[Hs]" as "Hs". + { unfold has_substate, has_full_state. + assert (of_state rs (IT (gReifiers_ops rs) natO) (σ, ()) ≡ + of_idx rs (IT (gReifiers_ops rs) natO) 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" $! σ with "Hs"). + iApply (wp_wand with"Hlog"). + iIntros ( βv). iIntros "H". + iDestruct "H" as (m' v σ1' Hsts) "[Hi Hsts]". + unfold Φ. iDestruct "Hi" as (l) "[Hβ %]". simplify_eq/=. + iExists l. iModIntro. iSplit; eauto. + iExists l. iSplit; eauto. +Qed. + + +Theorem adequacy (e : expr []) (k : nat) σ σ' n : + typed empC e Tnat → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) (σ,()) (Ret k : IT _ natO) σ' n → + ∃ mm σ', prim_steps e σ (Val $ Lit k) σ' mm. +Proof. + intros Hty Hst. + pose (Σ:=#[invΣ;stateΣ rs natO]). + eapply (logrel_nat_adequacy Σ (interp_expr rs e ())); last eassumption. + intros ? ?. + iPoseProof (fundamental rs) as "H". + { apply Hty. } + unfold logrel_valid. + iIntros "_". + iSpecialize ("H" $! (emp_subs2 rs)). + simp its_of_subs2. + rewrite subs_of_emp_subs2. + rewrite subst_expr_idsub. + iApply "H". + unfold subs2_valid. done. +Qed. diff --git a/theories/lang_generic.v b/theories/lang_generic.v index e8fe352..535a89f 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -1,42 +1,223 @@ -(* From gitrees Require Import prelude. *) -(* From Equations Require Import Equations. *) -(* Require Import List. *) -(* Import ListNotations. *) - -(* (** XXX: We /NEED/ this line for [Equations Derive] to work, *) -(* this flag is globally unset by std++, but Equations need obligations to be transparent. *) *) -(* Set Transparent Obligations. *) - -(* Derive NoConfusion NoConfusionHom for list. *) - -(* Definition scope := (list unit). *) - -(* (** Variables in a context *) *) -(* Inductive var : scope → Type := *) -(* | Vz : forall {S : scope} {s}, var (s::S) *) -(* | Vs : forall {S : scope} {s}, var S -> var (s::S) *) -(* . *) -(* Derive Signature NoConfusion for var. *) - -(* Inductive tyctx (ty : Type) : scope → Type := *) -(* | empC : tyctx ty [] *) -(* | consC : forall{Γ}, ty → tyctx ty Γ → tyctx ty (()::Γ) *) -(* . *) -(* Arguments empC {_}. *) -(* Arguments consC {_ _} _ _. *) - -(* Equations list_of_tyctx {S ty} (Γ : tyctx ty S) : list ty := *) -(* list_of_tyctx empC := []; *) -(* list_of_tyctx (consC τ Γ') := τ::list_of_tyctx Γ'. *) - -(* Equations tyctx_app {S1 S2 ty} (c1 : tyctx ty S1) (c2 : tyctx ty S2) : tyctx ty (S1++S2) := *) -(* tyctx_app empC c2 := c2; *) -(* tyctx_app (consC τ c1) c2 := consC τ (tyctx_app c1 c2). *) - -(* Inductive typed_var {ty : Type}: forall {S}, tyctx ty S → var S → ty → Prop := *) -(* | typed_var_Z S (τ : ty) (Γ : tyctx ty S) : *) -(* typed_var (consC τ Γ) Vz τ *) -(* | typed_var_S S (τ τ' : ty) (Γ : tyctx ty S) v : *) -(* typed_var Γ v τ → *) -(* typed_var (consC τ' Γ) (Vs v) τ *) -(* . *) +From gitrees Require Import prelude. +From gitrees Require Import gitree. +From Equations Require Import Equations. +Require Import List. +Import ListNotations. + +(** XXX: We /NEED/ this line for [Equations Derive] to work, + this flag is globally unset by std++, but Equations need obligations to be transparent. *) +Set Transparent Obligations. + +Derive NoConfusion NoConfusionHom for list. + +Definition scope := (list unit). + +(** Variables in a context *) +Inductive var : scope → Type := +| Vz : forall {S : scope} {s}, var (s::S) +| Vs : forall {S : scope} {s}, var S -> var (s::S) +. +Derive Signature NoConfusion for var. + +Inductive tyctx (ty : Type) : scope → Type := +| empC : tyctx ty [] +| consC : forall{Γ}, ty → tyctx ty Γ → tyctx ty (()::Γ) +. +Arguments empC {_}. +Arguments consC {_ _} _ _. + +Equations list_of_tyctx {S ty} (Γ : tyctx ty S) : list ty := + list_of_tyctx empC := []; + list_of_tyctx (consC τ Γ') := τ::list_of_tyctx Γ'. + +Equations tyctx_app {S1 S2 ty} (c1 : tyctx ty S1) (c2 : tyctx ty S2) : tyctx ty (S1++S2) := + tyctx_app empC c2 := c2; + tyctx_app (consC τ c1) c2 := consC τ (tyctx_app c1 c2). + +Inductive typed_var {ty : Type}: forall {S}, tyctx ty S → var S → ty → Prop := +| typed_var_Z S (τ : ty) (Γ : tyctx ty S) : + typed_var (consC τ Γ) Vz τ +| typed_var_S S (τ τ' : ty) (Γ : tyctx ty S) v : + typed_var Γ v τ → + typed_var (consC τ' Γ) (Vs v) τ +. + +Section interp. + Local Open Scope type. + Context {E: opsInterp}. + Context {R} `{!Cofe R}. + Notation IT := (IT E R). + Notation ITV := (ITV E R). + + Fixpoint interp_scope (S : scope) : ofe := + match S with + | [] => unitO + | τ::Sc => prodO IT (interp_scope Sc) + end. + + Instance interp_scope_cofe S : Cofe (interp_scope S). + Proof. induction S; simpl; apply _. Qed. + + Instance interp_scope_inhab S : Inhabited (interp_scope S). + Proof. induction S; simpl; apply _. Defined. + + Equations interp_var {S : scope} (v : var S) : interp_scope S -n> IT := + interp_var (S:=(_::_)) Vz := fstO; + interp_var (S:=(_::Sc)) (Vs v) := interp_var v ◎ sndO. + + Instance interp_var_ne S (v : var S) : NonExpansive (@interp_var S v). + Proof. + intros n D1 D2 HD12. induction v; simp interp_var. + - by f_equiv. + - eapply IHv. by f_equiv. + Qed. + + Global Instance interp_var_proper S (v : var S) : Proper ((≡) ==> (≡)) (interp_var v). + Proof. apply ne_proper. apply _. Qed. + + Definition interp_scope_split {S1 S2} : + interp_scope (S1 ++ S2) -n> interp_scope S1 * interp_scope S2. + Proof. + induction S1 as [|? S1]; simpl. + - simple refine (λne x, (tt, x)). + solve_proper. + - simple refine (λne xy, let ss := IHS1 xy.2 in ((xy.1, ss.1), ss.2)). + solve_proper. + Defined. + + (** scope substituions *) + Inductive ssubst : scope → Type := + | emp_ssubst : ssubst [] + | cons_ssubst {S} : ITV → ssubst S → ssubst (tt::S) + . + + Equations interp_ssubst {S} (ss : ssubst S) : interp_scope S := + interp_ssubst emp_ssubst := tt; + interp_ssubst (cons_ssubst αv ss) := (IT_of_V αv, interp_ssubst ss). + + Equations list_of_ssubst {S} (ss : ssubst S) : list ITV := + list_of_ssubst emp_ssubst := []; + list_of_ssubst (cons_ssubst αv ss) := αv::(list_of_ssubst ss). + + Equations ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : ssubst S1 * ssubst S2 := + ssubst_split (S1:=[]) αs := (emp_ssubst,αs); + ssubst_split (S1:=u::_) (cons_ssubst αv αs) := + (cons_ssubst αv (ssubst_split αs).1, (ssubst_split αs).2). + Lemma interp_scope_ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : + interp_scope_split (interp_ssubst αs) ≡ + (interp_ssubst (ssubst_split αs).1, interp_ssubst (ssubst_split αs).2). + Proof. + induction S1 as [|u S1]; simpl. + - simp ssubst_split. simpl. + simp interp_ssubst. done. + - dependent elimination αs as [cons_ssubst αv αs]. + simp ssubst_split. simpl. + simp interp_ssubst. repeat f_equiv; eauto; simpl. + + rewrite IHS1//. + + rewrite IHS1//. + Qed. + +End interp. + +(* Common definitions and lemmas for Kripke logical relations *) +Section kripke_logrel. + Variable s : stuckness. + + Context {sz : nat}. + Variable rs : gReifiers sz. + Context {R} `{!Cofe R}. + + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Context {A:ofe}. (* The type & predicate for the explicit Kripke worlds *) + Variable (P : A → iProp). + Context `{!NonExpansive P}. + + Implicit Types α β : IT. + Implicit Types αv βv : ITV. + Implicit Types Φ Ψ : ITV -n> iProp. + + Program Definition expr_pred (α : IT) (Φ : ITV -n> iProp) : iProp := + (∀ x : A, P x -∗ WP@{rs} α @ s {{ v, ∃ y : A, Φ v ∗ P y }}). + #[export] Instance expr_pred_ne : NonExpansive2 expr_pred. + Proof. solve_proper. Qed. + #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . + Proof. solve_proper. Qed. + + Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : tyctx ty S) (ss : ssubst S) : iProp := + ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), + interp_ty (τx.1) (τx.2))%I. + + Lemma ssubst_valid_nil {ty} (interp_ty : ty → ITV -n> iProp) : + ⊢ ssubst_valid interp_ty empC emp_ssubst. + Proof. + unfold ssubst_valid. + by simp list_of_tyctx list_of_ssubst. + Qed. + + Lemma ssubst_valid_cons {ty} (interp_ty : ty → ITV -n> iProp) {S} + (Γ : tyctx ty S) (ss : ssubst S) τ αv : + ssubst_valid interp_ty (consC τ Γ) (cons_ssubst αv ss) + ⊣⊢ interp_ty τ αv ∗ ssubst_valid interp_ty Γ ss. + Proof. + unfold ssubst_valid. + by simp list_of_tyctx list_of_ssubst. + Qed. + + Lemma ssubst_valid_app {ty} (interp_ty : ty → ITV -n> iProp) + {S1 S2} (Ω1 : tyctx ty S1) (Ω2 : tyctx ty S2) αs : + ssubst_valid interp_ty (tyctx_app Ω1 Ω2) αs ⊢ + ssubst_valid interp_ty Ω1 (ssubst_split αs).1 + ∗ ssubst_valid interp_ty Ω2 (ssubst_split αs).2. + Proof. + iInduction Ω1 as [|τ Ω1] "IH" forall (Ω2); simp tyctx_app ssubst_split. + - simpl. iIntros "$". iApply ssubst_valid_nil. + - iIntros "H". + rewrite {4 5}/ssubst_valid. + simpl in αs. + dependent elimination αs as [cons_ssubst αv αs]. + simp ssubst_split. simpl. + simp list_of_ssubst list_of_tyctx. + simpl. iDestruct "H" as "[$ H]". + by iApply "IH". + Qed. + + Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : + Φ αv ⊢ expr_pred α Φ. + Proof. + iIntros "H". + iIntros (x) "Hx". iApply wp_val. + eauto with iFrame. + Qed. + + (* Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : *) + (* expr_pred α Ψ ⊢ *) + (* (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ *) + (* expr_pred (f α) Φ. *) + (* Proof. *) + (* iIntros "H1 H2". *) + (* iIntros (x) "Hx". *) + (* iApply wp_bind. *) + (* { solve_proper. } *) + (* iSpecialize ("H1" with "Hx"). *) + (* iApply (wp_wand with "H1"). *) + (* iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". *) + (* iModIntro. *) + (* iApply ("H2" with "Hb Hy"). *) + (* Qed. *) + + Lemma expr_pred_frame α Φ : + WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. + Proof. + iIntros "H". + iIntros (x) "Hx". + iApply (wp_wand with "H"). + eauto with iFrame. + Qed. +End kripke_logrel. + +(* Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. *) From 16ffc7314d43c400a5d83b609ede5f873a736b5e Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 9 Nov 2023 20:45:01 +0100 Subject: [PATCH 013/114] backwards comp --- theories/gitree/reductions.v | 221 +++---- theories/gitree/weakestpre.v | 322 +++++----- theories/input_lang/interp.v | 1144 ++++++++++++++------------------- theories/input_lang/logpred.v | 17 +- theories/lang_generic.v | 35 +- theories/program_logic.v | 13 +- 6 files changed, 801 insertions(+), 951 deletions(-) diff --git a/theories/gitree/reductions.v b/theories/gitree/reductions.v index c1b04f6..3a34e9b 100644 --- a/theories/gitree/reductions.v +++ b/theories/gitree/reductions.v @@ -201,47 +201,49 @@ Section istep. Qed. (* ctx-free steps *) - (* Local Lemma effect_safe_externalize (α : IT) σ : *) - (* (⊢ ∃ β σ', (∃ op i k, α ≡ Vis op i k ∧ reify r α σ ≡ (σ', Tick β)) : iProp) → *) - (* ∃ β σ', sstep r α σ β σ'. *) - (* Proof. *) - (* intros Hprf. *) - (* destruct (IT_dont_confuse α) *) - (* as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. *) - (* + exfalso. eapply uPred.pure_soundness. *) - (* iPoseProof (Hprf) as "H". *) - (* iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. *) - (* iApply (IT_vis_err_ne). iApply internal_eq_sym. *) - (* by iApply "Ha". *) - (* + exfalso. eapply uPred.pure_soundness. *) - (* iPoseProof (Hprf) as "H". *) - (* iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. *) - (* iApply (IT_ret_vis_ne with "Ha"). *) - (* + exfalso. eapply uPred.pure_soundness. *) - (* iPoseProof (Hprf) as "H". *) - (* iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. *) - (* iApply (IT_fun_vis_ne with "Ha"). *) - (* + exfalso. eapply uPred.pure_soundness. *) - (* iPoseProof (Hprf) as "H". *) - (* iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. *) - (* iApply (IT_tick_vis_ne with "Ha"). *) - (* + destruct (reify r (Vis op i k) σ) as [σ1 α1] eqn:Hr. *) - (* assert ((∃ α' : IT, α1 ≡ Tick α') ∨ (α1 ≡ Err RuntimeErr)) as [[α' Ha']| Ha']. *) - (* { eapply (reify_is_always_a_tick r op i k σ). *) - (* by rewrite Hr. } *) - (* * exists α',σ1. eapply sstep_reify; eauto. *) - (* rewrite -Ha' -Hr; repeat f_equiv; eauto. *) - (* * exfalso. eapply uPred.pure_soundness. *) - (* iPoseProof (Hprf) as "H". *) - (* iDestruct "H" as (β σ' op' i' k') "[_ Hb]". *) - (* assert (reify r (Vis op i k) σ ≡ reify r α σ) as Har. *) - (* { f_equiv. by rewrite Ha. } *) - (* iEval (rewrite -Har) in "Hb". *) - (* iEval (rewrite Hr) in "Hb". *) - (* iPoseProof (prod_equivI with "Hb") as "[_ Hb']". *) - (* simpl. rewrite Ha'. *) - (* iApply (IT_tick_err_ne). iApply (internal_eq_sym with "Hb'"). *) - (* Qed. *) + Local Lemma effect_safe_externalize (α : IT) σ {G : ∀ o, CtxIndep r IT o} : + (⊢ ∃ β σ', (∃ op i k, α ≡ Vis op i k ∧ reify r α σ ≡ (σ', Tick β)) : iProp) → + ∃ β σ', sstep r α σ β σ'. + Proof. + intros Hprf. + destruct (IT_dont_confuse α) + as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. + iApply (IT_vis_err_ne). iApply internal_eq_sym. + by iApply "Ha". + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. + iApply (IT_ret_vis_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. + iApply (IT_fun_vis_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. + iApply (IT_tick_vis_ne with "Ha"). + + destruct (reify r (Vis op i k) σ) as [σ1 α1] eqn:Hr. + assert ((∃ α' : IT, α1 ≡ Tick α') ∨ (α1 ≡ Err RuntimeErr)) as [[α' Ha']| Ha']. + { eapply (reify_is_always_a_tick r op i k σ). + - apply G. + - by rewrite Hr. + } + * exists α',σ1. eapply sstep_reify; eauto. + rewrite -Ha' -Hr; repeat f_equiv; eauto. + * exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (β σ' op' i' k') "[_ Hb]". + assert (reify r (Vis op i k) σ ≡ reify r α σ) as Har. + { f_equiv. by rewrite Ha. } + iEval (rewrite -Har) in "Hb". + iEval (rewrite Hr) in "Hb". + iPoseProof (prod_equivI with "Hb") as "[_ Hb']". + simpl. rewrite Ha'. + iApply (IT_tick_err_ne). iApply (internal_eq_sym with "Hb'"). + Qed. Local Lemma istep_safe_disj α σ : (∃ β σ', istep α σ β σ') @@ -256,16 +258,16 @@ Section istep. (* this is true only for iProp/uPred? *) Definition disjunction_property (P Q : iProp) := (⊢ P ∨ Q) → (⊢ P) ∨ (⊢ Q). - (* Lemma istep_safe_sstep α σ : *) - (* (∀ P Q, disjunction_property P Q) → *) - (* (⊢ ∃ β σ', istep α σ β σ') → ∃ β σ', sstep r α σ β σ'. *) - (* Proof. *) - (* intros Hdisj. *) - (* rewrite istep_safe_disj. *) - (* intros [H|H]%Hdisj. *) - (* - by apply tick_safe_externalize. *) - (* - by apply effect_safe_externalize. *) - (* Qed. *) + Lemma istep_safe_sstep α σ {G : ∀ o, CtxIndep r IT o} : + (∀ P Q, disjunction_property P Q) → + (⊢ ∃ β σ', istep α σ β σ') → ∃ β σ', sstep r α σ β σ'. + Proof. + intros Hdisj. + rewrite istep_safe_disj. + intros [H|H]%Hdisj. + - by apply tick_safe_externalize. + - by apply effect_safe_externalize. + Qed. Lemma istep_ITV α αv β σ σ' : (IT_to_V α ≡ Some αv ⊢ istep α σ β σ' -∗ False : iProp)%I. @@ -336,65 +338,64 @@ Section istep. iRewrite -"Ha". iRewrite "Hs". done. Qed. - (* Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' : *) - (* istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. *) - (* Proof. *) - (* iDestruct 1 as "[[Ha Hs]|H]". *) - (* - iRewrite "Ha". iLeft. iSplit; eauto. iPureIntro. apply hom_tick. *) - (* - iDestruct "H" as (op i k) "[#Ha Hr]". *) - (* pose (f' := OfeMor f). *) - (* iRight. iExists op,i,(laterO_map f' ◎ k). *) - (* iAssert (f (Vis op i k) ≡ Vis op i (laterO_map f' ◎ k))%I as "Hf". *) - (* { iPureIntro. apply hom_vis. } *) - (* iRewrite "Ha". iRewrite "Ha" in "Hr". iRewrite "Hf". *) - (* iSplit; first done. *) - (* iApply (reify_vis_cont with "Hr"). *) - (* Qed. *) - - (* Lemma istep_hom_inv α σ β σ' `{!IT_hom f} : *) - (* istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ *) - (* ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). *) - (* Proof. *) - (* iIntros "H". *) - (* destruct (IT_dont_confuse α) *) - (* as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. *) - (* - iExFalso. iApply (istep_err σ e β σ'). *) - (* iAssert (f α ≡ Err e)%I as "Hf". *) - (* { iPureIntro. by rewrite Ha hom_err. } *) - (* iRewrite "Hf" in "H". done. *) - (* - iLeft. iPureIntro. rewrite Ha IT_to_V_Ret. done. *) - (* - iLeft. iPureIntro. rewrite Ha IT_to_V_Fun. done. *) - (* - iAssert (α ≡ Tick la)%I as "Ha"; first by eauto. *) - (* iAssert (f (Tick la) ≡ Tick (f la))%I as "Hf". *) - (* { iPureIntro. rewrite hom_tick. done. } *) - (* iRight. iRewrite "Ha". iRewrite "Ha" in "H". *) - (* iRewrite "Hf" in "H". rewrite istep_tick. *) - (* iDestruct "H" as "[Hb Hs]". iSplit. *) - (* { by rewrite IT_to_V_Tau. } *) - (* iExists la. iSplit; last eauto. *) - (* unfold istep. iLeft. iSplit; eauto. *) - (* - iRight. *) - (* pose (fi:=OfeMor f). *) - (* iAssert (f α ≡ Vis op i (laterO_map fi ◎ k))%I as "Hf". *) - (* { iPureIntro. by rewrite Ha hom_vis. } *) - (* iRewrite "Hf" in "H". *) - (* rewrite {1}/istep. iSimpl in "H". *) - (* iDestruct "H" as "[[H _]|H]". *) - (* + iExFalso. iApply (IT_tick_vis_ne). *) - (* iApply internal_eq_sym. done. *) - (* + iDestruct "H" as (op' i' k') "[#Ha Hr]". *) - (* iPoseProof (Vis_inj_op' with "Ha") as "<-". *) - (* iPoseProof (Vis_inj' with "Ha") as "[Hi Hk]". *) - (* iPoseProof (reify_input_cont_inv r op i k fi with "Hr") as (α') "[Hr Ha']". *) - (* iAssert (reify r α σ ≡ (σ', Tick α'))%I with "[Hr]" as "Hr". *) - (* { iRewrite -"Hr". iPureIntro. repeat f_equiv. *) - (* apply Ha. } *) - (* iSplit. { iPureIntro. by rewrite Ha IT_to_V_Vis. } *) - (* iExists α'. iFrame "Ha'". *) - (* rewrite /istep. iRight. *) - (* iExists op,i,k. iFrame "Hr". *) - (* iPureIntro. apply Ha. *) - (* Qed. *) + Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' {G : ∀ o, CtxIndep r IT o} : + istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. + Proof. + iDestruct 1 as "[[Ha Hs]|H]". + - iRewrite "Ha". iLeft. iSplit; eauto. iPureIntro. apply hom_tick. + - iDestruct "H" as (op i k) "[#Ha Hr]". + pose (f' := OfeMor f). + iRight. iExists op,i,(laterO_map f' ◎ k). + iAssert (f (Vis op i k) ≡ Vis op i (laterO_map f' ◎ k))%I as "Hf". + { iPureIntro. apply hom_vis. } + iRewrite "Ha". iRewrite "Ha" in "Hr". iRewrite "Hf". + iSplit; first done. + iApply (reify_vis_cont with "Hr"). + Qed. + Lemma istep_hom_inv α σ β σ' `{!IT_hom f} {G : ∀ o, CtxIndep r IT o} : + istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ + ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). + Proof. + iIntros "H". + destruct (IT_dont_confuse α) + as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. + - iExFalso. iApply (istep_err σ e β σ'). + iAssert (f α ≡ Err e)%I as "Hf". + { iPureIntro. by rewrite Ha hom_err. } + iRewrite "Hf" in "H". done. + - iLeft. iPureIntro. rewrite Ha IT_to_V_Ret. done. + - iLeft. iPureIntro. rewrite Ha IT_to_V_Fun. done. + - iAssert (α ≡ Tick la)%I as "Ha"; first by eauto. + iAssert (f (Tick la) ≡ Tick (f la))%I as "Hf". + { iPureIntro. rewrite hom_tick. done. } + iRight. iRewrite "Ha". iRewrite "Ha" in "H". + iRewrite "Hf" in "H". rewrite istep_tick. + iDestruct "H" as "[Hb Hs]". iSplit. + { by rewrite IT_to_V_Tau. } + iExists la. iSplit; last eauto. + unfold istep. iLeft. iSplit; eauto. + - iRight. + pose (fi:=OfeMor f). + iAssert (f α ≡ Vis op i (laterO_map fi ◎ k))%I as "Hf". + { iPureIntro. by rewrite Ha hom_vis. } + iRewrite "Hf" in "H". + rewrite {1}/istep. iSimpl in "H". + iDestruct "H" as "[[H _]|H]". + + iExFalso. iApply (IT_tick_vis_ne). + iApply internal_eq_sym. done. + + iDestruct "H" as (op' i' k') "[#Ha Hr]". + iPoseProof (Vis_inj_op' with "Ha") as "<-". + iPoseProof (Vis_inj' with "Ha") as "[Hi Hk]". + iPoseProof (reify_input_cont_inv r op i k fi with "Hr") as (α') "[Hr Ha']". + iAssert (reify r α σ ≡ (σ', Tick α'))%I with "[Hr]" as "Hr". + { iRewrite -"Hr". iPureIntro. repeat f_equiv. + apply Ha. } + iSplit. { iPureIntro. by rewrite Ha IT_to_V_Vis. } + iExists α'. iFrame "Ha'". + rewrite /istep. iRight. + iExists op,i,k. iFrame "Hr". + iPureIntro. apply Ha. + Qed. End istep. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index d3ba056..1d45dba 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -371,61 +371,61 @@ Section weakestpre. iIntros "H". iApply (wp_wand with "H"); auto. Qed. - (* Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 : *) - (* WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. *) - (* Proof. *) - (* assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). *) - (* { solve_proper. } *) - (* iIntros "H". iLöb as "IH" forall (α). *) - (* rewrite (wp_unfold (f _)). *) - (* destruct (IT_to_V (f α)) as [βv|] eqn:Hfa. *) - (* - iLeft. iExists βv. iSplit; first done. *) - (* assert (is_Some (IT_to_V α)) as [αv Ha]. *) - (* { apply (IT_hom_val_inv _ f). rewrite Hfa. *) - (* done. } *) - (* assert (IntoVal α αv). *) - (* { apply IT_of_to_V'. by rewrite Ha. } *) - (* rewrite wp_val_inv. *) - (* iApply wp_val_inv. *) - (* rewrite IT_of_to_V'; last by rewrite -Ha. *) - (* rewrite IT_of_to_V'; last by rewrite -Hfa. *) - (* by iApply fupd_wp. *) - (* - iRight. iSplit; eauto. *) - (* iIntros (σ) "Hs". *) - (* rewrite wp_unfold. *) - (* iDestruct "H" as "[H | H]". *) - (* + iDestruct "H" as (αv) "[Hav H]". *) - (* iPoseProof (IT_of_to_V with "Hav") as "Hav". *) - (* iMod "H" as "H". rewrite wp_unfold. *) - (* iDestruct "H" as "[H|H]". *) - (* { iExFalso. iDestruct "H" as (βv) "[H _]". *) - (* iRewrite "Hav" in "H". rewrite Hfa. *) - (* iApply (option_equivI with "H"). } *) - (* iDestruct "H" as "[_ H]". *) - (* iMod ("H" with "Hs") as "H". iModIntro. *) - (* iRewrite "Hav" in "H". done. *) - (* + iDestruct "H" as "[Hav H]". *) - (* iMod ("H" with "Hs") as "[Hsafe H]". iModIntro. *) - (* iSplit. *) - (* { (* safety *) *) - (* iDestruct "Hsafe" as "[Hsafe|Herr]". *) - (* - iDestruct "Hsafe" as (α' σ') "Hsafe". iLeft. *) - (* iExists (f α'), σ'. iApply (istep_hom with "Hsafe"). *) - (* - iDestruct "Herr" as (e) "[Herr %]". *) - (* iRight. iExists e. iSplit; last done. *) - (* iRewrite "Herr". rewrite hom_err//. } *) - (* iIntros (σ' β) "Hst". *) - (* rewrite {1}istep_hom_inv. iDestruct "Hst" as "[%Ha | [_ Hst]]". *) - (* { destruct Ha as [αv Ha]. rewrite Ha. *) - (* iExFalso. *) - (* iApply (option_equivI with "Hav"). } *) - (* iDestruct "Hst" as (α') "[Hst Hb]". *) - (* iIntros "Hlc". *) - (* iMod ("H" with "Hst Hlc") as "H". iModIntro. *) - (* iNext. iMod "H" as "H". iModIntro. *) - (* iMod "H" as "[$ H]". *) - (* iModIntro. iRewrite "Hb". by iApply "IH". *) - (* Qed. *) + Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 {G : ∀ o : opid F, CtxIndep rG IT o} : + WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. + Proof. + assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). + { solve_proper. } + iIntros "H". iLöb as "IH" forall (α). + rewrite (wp_unfold (f _)). + destruct (IT_to_V (f α)) as [βv|] eqn:Hfa. + - iLeft. iExists βv. iSplit; first done. + assert (is_Some (IT_to_V α)) as [αv Ha]. + { apply (IT_hom_val_inv _ f). rewrite Hfa. + done. } + assert (IntoVal α αv). + { apply IT_of_to_V'. by rewrite Ha. } + rewrite wp_val_inv. + iApply wp_val_inv. + rewrite IT_of_to_V'; last by rewrite -Ha. + rewrite IT_of_to_V'; last by rewrite -Hfa. + by iApply fupd_wp. + - iRight. iSplit; eauto. + iIntros (σ) "Hs". + rewrite wp_unfold. + iDestruct "H" as "[H | H]". + + iDestruct "H" as (αv) "[Hav H]". + iPoseProof (IT_of_to_V with "Hav") as "Hav". + iMod "H" as "H". rewrite wp_unfold. + iDestruct "H" as "[H|H]". + { iExFalso. iDestruct "H" as (βv) "[H _]". + iRewrite "Hav" in "H". rewrite Hfa. + iApply (option_equivI with "H"). } + iDestruct "H" as "[_ H]". + iMod ("H" with "Hs") as "H". iModIntro. + iRewrite "Hav" in "H". done. + + iDestruct "H" as "[Hav H]". + iMod ("H" with "Hs") as "[Hsafe H]". iModIntro. + iSplit. + { (* safety *) + iDestruct "Hsafe" as "[Hsafe|Herr]". + - iDestruct "Hsafe" as (α' σ') "Hsafe". iLeft. + iExists (f α'), σ'. iApply (istep_hom with "Hsafe"). + - iDestruct "Herr" as (e) "[Herr %]". + iRight. iExists e. iSplit; last done. + iRewrite "Herr". rewrite hom_err//. } + iIntros (σ' β) "Hst". + rewrite {1}istep_hom_inv. iDestruct "Hst" as "[%Ha | [_ Hst]]". + { destruct Ha as [αv Ha]. rewrite Ha. + iExFalso. + iApply (option_equivI with "Hav"). } + iDestruct "Hst" as (α') "[Hst Hb]". + iIntros "Hlc". + iMod ("H" with "Hst Hlc") as "H". iModIntro. + iNext. iMod "H" as "H". iModIntro. + iMod "H" as "[$ H]". + iModIntro. iRewrite "Hb". by iApply "IH". + Qed. (* XXX: strengthen it with later credits *) Lemma wp_tick α s E1 Φ : @@ -545,43 +545,61 @@ Section weakestpre. iModIntro. by iApply ("H" with "Hlc Hs"). Qed. - (* Lemma wp_subreify' E1 E2 s Φ sR `{!subReifier sR rs} *) - (* (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ IT) *) - (* (k : Outs (sReifier_ops sR op) ♯ IT -n> laterO IT) : *) - (* (|={E1,E2}=> ∃ σ y σ' β, has_substate σ ∗ *) - (* sReifier_re sR op (x, σ, k) ≡ Some (k y, σ') ∗ *) - (* k y ≡ Next β ∗ *) - (* ▷ (£ 1 -∗ has_substate σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) *) - (* -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. *) - (* Proof. *) - (* iIntros "H". *) - (* iApply wp_reify_idx'. *) - (* iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". *) - (* iModIntro. *) - (* iExists (sR_state σ),(subEff_outs y), (sR_state σ'), β. *) - (* iFrame "Hlst H Hk". *) - (* by iApply subReifier_reify_idxI. *) - (* Qed. *) - - (* Lemma wp_subreify E1 s Φ sR `{!subReifier sR rs} *) - (* (op : opid (sReifier_ops sR)) *) - (* (x : Ins (sReifier_ops sR op) ♯ IT) (y : Outs (sReifier_ops sR op) ♯ IT) *) - (* (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) *) - (* (σ σ' : sReifier_state sR ♯ IT) β : *) - (* sReifier_re sR op (x, σ) ≡ Some (y, σ') → *) - (* k (subEff_outs y) ≡ Next β → *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ has_substate σ' -∗ WP β @ s;E1 {{ Φ }}) *) - (* -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. *) - (* Proof. *) - (* intros HSR Hk. *) - (* iIntros "Hlst H". *) - (* iApply (wp_reify with "Hlst H"). *) - (* intros rest. *) - (* rewrite Tick_eq. rewrite -Hk. *) - (* rewrite reify_vis_eq //. *) - (* by apply subReifier_reify. *) - (* Qed. *) + Lemma wp_subreify' E1 E2 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ IT) + (k : Outs (sReifier_ops sR op) ♯ IT -n> laterO IT) : + (|={E1,E2}=> ∃ σ y σ' β, has_substate σ ∗ + sReifier_re sR op (x, σ, k) ≡ Some (k y, σ') ∗ + k y ≡ Next β ∗ + ▷ (£ 1 -∗ has_substate σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) + -∗ WP (Vis (subEff_opid op) (subEff_ins x) (k ◎ (subEff_outs)^-1)) @ s;E1 {{ Φ }}. + Proof. + iIntros "H". + iApply wp_reify_idx'. + iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". + iModIntro. + iExists (sR_state σ), (subEff_outs y), (sR_state σ'), β. + simpl. + iFrame "Hlst H". + rewrite subReifier_reify_idxI. + iRewrite "Hreify". + simpl. + rewrite ofe_iso_21. + by iFrame "Hk". + Qed. + + Lemma wp_subreify E1 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops sR)) + (x : Ins (sReifier_ops sR op) ♯ IT) (y : Outs (sReifier_ops sR op) ♯ IT) + (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) + (σ σ' : sReifier_state sR ♯ IT) β : + sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (k ((subEff_outs) y), σ') → + k (subEff_outs y) ≡ Next β → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP β @ s;E1 {{ Φ }}) + -∗ + WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. + Proof. + intros HSR Hk. + iIntros "Hlst H". + iApply (wp_reify with "Hlst H"). + intros rest. + rewrite Tick_eq. rewrite -Hk. + rewrite reify_vis_eq //. + pose proof (@subReifier_reify n sR rs _ IT _ op x y (k ◎ subEff_outs) σ σ' rest) as H. + simpl in H. + rewrite ofe_iso_12 in H. + rewrite <-H. + - simpl. + repeat f_equiv. + + intros ???. + solve_proper. + + intros ?; simpl. + rewrite ofe_iso_12. + reflexivity. + - rewrite HSR. + reflexivity. + Qed. Lemma wp_err E1 e (s : error → Prop) Φ : s e → @@ -818,62 +836,64 @@ Proof. by iApply fupd_mask_intro_discard. Qed. -(* Lemma wp_safety cr Σ `{!invGpreS Σ} n (rs : gReifiers n) *) -(* {A} `{!Cofe A} `{!statePreG rs A Σ} s k *) -(* (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : *) -(* (∀ Σ P Q, @disjunction_property Σ P Q) → *) -(* ssteps (gReifiers_sReifier rs) α σ β σ' k → *) -(* IT_to_V β ≡ None → *) -(* (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, *) -(* ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → *) -(* ((∃ β1 σ1, sstep (gReifiers_sReifier rs) β σ' β1 σ1) *) -(* ∨ (∃ e, β ≡ Err e ∧ s e)). *) -(* Proof. *) -(* Opaque istep. *) -(* intros Hdisj Hstep Hbv Hwp. *) -(* cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier rs) β σ' β1 σ1) *) -(* ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. *) -(* { intros [Hprf | Hprf]%Hdisj. *) -(* - left. *) -(* apply (istep_safe_sstep _ (Σ:=Σ)). *) -(* { apply Hdisj. } *) -(* done. *) -(* - right. *) -(* destruct (IT_dont_confuse β) *) -(* as [[e Ha] | [[m Ha] | [ [g Ha] | [[α' Ha]|[op [i [ko Ha]]]] ]]]. *) -(* + exists e. split; eauto. *) -(* eapply uPred.pure_soundness. *) -(* iPoseProof (Hprf) as "H". *) -(* iDestruct "H" as (e') "[He %Hs]". rewrite Ha. *) -(* iPoseProof (Err_inj' with "He") as "%He". *) -(* iPureIntro. rewrite He//. *) -(* + exfalso. eapply uPred.pure_soundness. *) -(* iPoseProof (Hprf) as "H". *) -(* iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. *) -(* iApply (IT_ret_err_ne with "Ha"). *) -(* + exfalso. eapply uPred.pure_soundness. *) -(* iPoseProof (Hprf) as "H". *) -(* iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. *) -(* iApply (IT_fun_err_ne with "Ha"). *) -(* + exfalso. eapply uPred.pure_soundness. *) -(* iPoseProof (Hprf) as "H". *) -(* iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. *) -(* iApply (IT_tick_err_ne with "Ha"). *) -(* + exfalso. eapply uPred.pure_soundness. *) -(* iPoseProof (Hprf) as "H". *) -(* iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. *) -(* iApply (IT_vis_err_ne with "Ha"). } *) -(* eapply (step_fupdN_soundness_lc _ 0 (cr + (3*k+2))). *) -(* intros Hinv. iIntros "[Hcr Hlc]". *) -(* iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". *) -(* destruct (Hwp Hinv sg) as (Φ & HΦ & Hprf'). *) -(* iPoseProof (Hprf' with "[$Hs2 $Hcr]") as "Hic". *) -(* iPoseProof (wp_ssteps_isafe with "[$Hs $Hic]") as "H". *) -(* { eassumption. } *) -(* iMod ("H" with "Hlc") as "[H | H]". *) -(* { iDestruct "H" as (βv) "%Hbeta". *) -(* exfalso. rewrite Hbeta in Hbv. *) -(* inversion Hbv. } *) -(* iFrame "H". *) -(* by iApply fupd_mask_intro_discard. *) -(* Qed. *) +Lemma wp_safety cr Σ `{!invGpreS Σ} n (rs : gReifiers n) + {A} `{!Cofe A} `{!statePreG rs A Σ} s k {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) (IT (sReifier_ops (gReifiers_sReifier rs)) A) o} + (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : + (∀ Σ P Q, @disjunction_property Σ P Q) → + ssteps (gReifiers_sReifier rs) α σ β σ' k → + IT_to_V β ≡ None → + (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, + ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → + ((∃ β1 σ1, sstep (gReifiers_sReifier rs) β σ' β1 σ1) + ∨ (∃ e, β ≡ Err e ∧ s e)). +Proof. + Opaque istep. + intros Hdisj Hstep Hbv Hwp. + cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier rs) β σ' β1 σ1) + ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. + { intros [Hprf | Hprf]%Hdisj. + - left. + apply (istep_safe_sstep _ (Σ:=Σ)). + { apply G. } + { apply Hdisj. } + done. + - right. + destruct (IT_dont_confuse β) + as [[e Ha] | [[m Ha] | [ [g Ha] | [[α' Ha]|[op [i [ko Ha]]]] ]]]. + + exists e. split; eauto. + eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[He %Hs]". rewrite Ha. + iPoseProof (Err_inj' with "He") as "%He". + iPureIntro. rewrite He//. + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_ret_err_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_fun_err_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_tick_err_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_vis_err_ne with "Ha"). } + eapply (step_fupdN_soundness_lc _ 0 (cr + (3*k+2))). + intros Hinv. iIntros "[Hcr Hlc]". + iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". + destruct (Hwp Hinv sg) as (Φ & HΦ & Hprf'). + iPoseProof (Hprf' with "[$Hs2 $Hcr]") as "Hic". + iPoseProof (wp_ssteps_isafe with "[$Hs $Hic]") as "H". + { eassumption. } + iMod ("H" with "Hlc") as "[H | H]". + { iDestruct "H" as (βv) "%Hbeta". + exfalso. rewrite Hbeta in Hbv. + inversion Hbv. } + iFrame "H". + by iApply fupd_mask_intro_discard. +Qed. diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index a36f770..08088c1 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -1,145 +1,34 @@ From Equations Require Import Equations. From gitrees Require Import gitree. From gitrees.input_lang Require Import lang. -Require Import gitrees.lang_generic_sem. - -Require Import Binding.Lib. Notation stateO := (leibnizO state). Program Definition inputE : opInterp := {| - Ins := unitO; - Outs := natO; - |}. + Ins := unitO; + Outs := natO; +|}. Program Definition outputE : opInterp := {| - Ins := natO; - Outs := unitO; - |}. - -Definition callccIF : oFunctor := (▶ ∙)%OF. - -#[local] Instance callccIF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (callccIF ♯ X). -Proof. - constructor. - unshelve refine (Next inhabitant). -Qed. -#[local] Instance callccIF_cofe X `{!Cofe X} : Cofe (callccIF ♯ X). -Proof. apply _. Qed. -#[local] Instance callccIF_contr : oFunctorContractive callccIF. -Proof. - intros ???????? n [a b] [c d] H. - apply laterO_map_contractive. - destruct n as [| n]. - - apply dist_later_0. - - apply dist_later_S. - apply dist_later_S in H. - destruct H as [H1 H2]; simpl in H1, H2. - by f_equiv. -Qed. - -Definition callccOF : oFunctor := unitO. - -#[local] Instance callccOF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (callccOF ♯ X). -Proof. - constructor. - simpl. - constructor. -Qed. -#[local] Instance callccOF_cofe X `{!Cofe X} : Cofe (callccOF ♯ X). -Proof. apply _. Qed. -#[local] Instance callccOF_contr : oFunctorContractive callccOF. -Proof. - intros ???????? n [a b] [c d] H. - solve_proper. -Qed. - -Program Definition callccE : opInterp := {| - Ins := callccIF; - Outs := callccOF; - |}. - -Definition throwIF : oFunctor := (▶ ∙ * ▶ ∙)%OF. - -#[local] Instance throwIF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (throwIF ♯ X). -Proof. - constructor. - unshelve refine (Next inhabitant, Next inhabitant). -Qed. -#[local] Instance throwIF_cofe X `{!Cofe X} : Cofe (throwIF ♯ X). -Proof. apply _. Qed. -#[local] Instance throwIF_contr : oFunctorContractive throwIF. -Proof. - intros ???????? n [a b] [c d] H. - simpl. - f_equiv. - { - apply laterO_map_contractive. - destruct n as [| n]. - - apply dist_later_0. - - apply dist_later_S. - apply dist_later_S in H. - destruct H as [H1 H2]; simpl in H1, H2. - assumption. - } - { - apply laterO_map_contractive. - destruct n as [| n]. - - apply dist_later_0. - - apply dist_later_S. - apply dist_later_S in H. - destruct H as [H1 H2]; simpl in H1, H2. - assumption. - } -Qed. - -Definition throwOF : oFunctor := unitO. - -#[local] Instance throwOF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (throwOF ♯ X). -Proof. - constructor. - apply (Next inhabitant). -Qed. -#[local] Instance throwOF_cofe X `{!Cofe X} : Cofe (throwOF ♯ X). -Proof. apply _. Qed. -#[local] Instance throwOF_contr : oFunctorContractive throwOF. -Proof. - intros ???????? n [a b] [c d] H. - unfold throwOF; simpl. - reflexivity. -Qed. - -Program Definition throwE : opInterp := {| - Ins := throwIF; - Outs := throwOF; + Ins := natO; + Outs := unitO; |}. - -Definition ioE := @[inputE;outputE;callccE;throwE]. - -(* Canonical Structure reify_io : sReifier. *) -(* Proof. *) -(* simple refine {| sReifier_ops := ioE; *) -(* sReifier_state := stateO *) -(* |}. *) -(* intros X HX op. *) -(* destruct op as [ | [ | [ | [| []]]]]; simpl. *) -(* - simple refine (λne (us : prodO (prodO unitO stateO) (natO -n> laterO X)), *) -(* Some $ update_input (sndO (fstO us)) : optionO (prodO natO stateO)). *) -(* intros n [[] s1] [[] s2] [[Hs1 Hs2] Hs]; simpl in *. *) -(* repeat f_equiv. apply Hs2. *) -(* - simple refine (λne (us : prodO (prodO natO stateO) (unitO -n> laterO X)), *) -(* Some $ ((), update_output (fstO (fstO us)) (sndO (fstO us))) : optionO (prodO unitO stateO)). *) -(* intros n [m s1] [m' s2] [-> Hs]. solve_proper. *) -(* - simple refine (λne (us : prodO (prodO (laterO X) stateO) (unitO -n> laterO X)), Some $ ((), sndO (fstO us))). *) -(* solve_proper. *) -(* - simple refine (λne (us : prodO (prodO (prodO (laterO X) (laterO X)) stateO) (unitO -n> laterO X)), _). *) -(* + destruct us as [[[us0 us1] us2] us3]. *) -(* (* if us1 is next(fun(k)) some k(us0) else none *) *) -(* admit. *) -(* + admit. *) -(* Admitted. *) - -(* reify throw (x, next(fun(κ))) σ _ = (κ x) *) -(* reify throw _ _ _ = Error *) +Definition ioE := @[inputE;outputE]. +Canonical Structure reify_io : sReifier. +Proof. + simple refine {| sReifier_ops := ioE; + sReifier_state := stateO + |}. + intros X HX op. + destruct op as [[] | [ | []]]; simpl. + - simple refine (λne (us : prodO (prodO unitO stateO) (natO -n> laterO X)), + let u : prodO natO stateO := update_input (sndO (fstO us)) in + Some $ ((sndO us) (fstO u), sndO u) : optionO (prodO (laterO X) stateO)). + intros n [[] s1] [[] s2] [[Hs1 Hs2] Hs]; solve_proper. + - simple refine (λne (us : prodO (prodO natO stateO) (unitO -n> laterO X)), + let u : stateO := update_output (fstO (fstO us)) (sndO (fstO us)) in + Some $ ((sndO us) (), u) : optionO (prodO (laterO X) stateO)). + intros n [m s1] [m' s2] [[Hs1 Hs2] Hs]; solve_proper. +Defined. Section constructors. Context {E : opsInterp} {A} `{!Cofe A}. @@ -148,6 +37,25 @@ Section constructors. Notation IT := (IT E A). Notation ITV := (ITV E A). + Global Instance ioEctx_indep : + ∀ (o : opid ioE), CtxIndep reify_io IT o. + Proof. + intros op. + destruct op as [[] | [ | []]]; simpl. + - constructor. + unshelve eexists (λne (x : prodO (Ins (sReifier_ops reify_io (inl ())) ♯ IT) (sReifier_state reify_io ♯ IT)), Some ((update_input (sndO x)).1, (update_input (sndO x)).2) : optionO (prodO (Outs (sReifier_ops reify_io (inl ())) ♯ IT) (sReifier_state reify_io ♯ IT))). + + intros ? [? ?] [? ?] [? ?]; simpl in *; solve_proper. + + intros i σ κ. + simpl in *. + reflexivity. + - constructor. + unshelve eexists (λne (x : prodO (Ins (sReifier_ops reify_io (inr (inl o))) ♯ IT) (sReifier_state reify_io ♯ IT)), Some ((), update_output (fstO x) (sndO x)) : optionO (prodO (Outs (sReifier_ops reify_io (inr (inl o))) ♯ IT) (sReifier_state reify_io ♯ IT))). + + intros ? [? ?] [? ?] [? ?]; simpl in *; solve_proper. + + intros i σ κ. + simpl. + reflexivity. + Qed. + Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) (subEff_ins (F:=ioE) (op:=(inl ())) ()) (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). @@ -174,35 +82,12 @@ Section constructors. done. Qed. - (* Program Definition CALLCC : (IT -n> IT) -n> IT -n> IT := *) - (* λne k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) *) - (* (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) (Next k)) *) - (* (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1). *) - (* Next Obligation. *) - (* intros. *) - (* simpl. *) - (* Admit Obligations. *) - - (* Program Definition THROW : IT -n> IT -n> IT := *) - (* λne m α, Vis (E:=E) (subEff_opid (inr (inr (inr (inl ()))))) *) - (* (subEff_ins (F:=ioE) (op:=(inr (inr (inr (inl ()))))) _) *) - (* (λne _, NextO α). *) - (* Admit Obligations. *) - - (* Lemma hom_CALLCC e k f `{!IT_hom f} : f (CALLCC k e) ≡ CALLCC (OfeMor f ◎ k) (f e). *) - (* Proof. *) - (* unfold CALLCC. *) - (* Admitted. *) - (* Lemma hom_THROW m n f `{!IT_hom f} : f (THROW m n) ≡ THROW (f m) (f n). *) - (* Proof. *) - (* Admitted. *) - End constructors. Section weakestpre. Context {sz : nat}. Variable (rs : gReifiers sz). - (* Context {subR : subReifier reify_io rs}. *) + Context {subR : subReifier reify_io rs}. Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. @@ -211,61 +96,49 @@ Section weakestpre. Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - (* Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : *) - (* update_input σ = (n, σ') → *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ *) - (* WP@{rs} (INPUT k) @ s {{ Φ }}. *) - (* Proof. *) - (* intros Hs. iIntros "Hs Ha". *) - (* unfold INPUT. simpl. *) - (* iApply (wp_subreify with "Hs"). *) - (* { simpl. by rewrite Hs. } *) - (* { simpl. by rewrite ofe_iso_21. } *) - (* iModIntro. done. *) - (* Qed. *) - (* Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : *) - (* update_output n σ = σ' → *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ *) - (* WP@{rs} (OUTPUT n) @ s {{ Φ }}. *) - (* Proof. *) - (* intros Hs. iIntros "Hs Ha". *) - (* unfold OUTPUT. simpl. *) - (* iApply (wp_subreify with "Hs"). *) - (* { simpl. by rewrite Hs. } *) - (* { simpl. done. } *) - (* iModIntro. iIntros "H1 H2". *) - (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) - (* Qed. *) - - (* Lemma wp_callcc (σ : stateO) (n : nat) Φ s : *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ Φ (RetV 0)) -∗ *) - (* WP@{rs} (CALLCC n) @ s {{ Φ }}. *) - (* Proof. *) - (* intros Hs. iIntros "Hs Ha". *) - (* unfold OUTPUT. simpl. *) - (* iApply (wp_subreify with "Hs"). *) - (* { simpl. by rewrite Hs. } *) - (* { simpl. done. } *) - (* iModIntro. iIntros "H1 H2". *) - (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) - (* Qed. *) + Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : + update_input σ = (n, σ') → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ + WP@{rs} (INPUT k) @ s {{ Φ }}. + Proof. + intros Hs. iIntros "Hs Ha". + unfold INPUT. simpl. + iApply (wp_subreify with "Hs"). + { simpl. by rewrite Hs. } + { simpl. by rewrite ofe_iso_21. } + iModIntro. done. + Qed. + + Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : + update_output n σ = σ' → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ + WP@{rs} (OUTPUT n) @ s {{ Φ }}. + Proof. + intros Hs. iIntros "Hs Ha". + unfold OUTPUT. simpl. + iApply (wp_subreify rs _ _ _ _ _ _ _ with "Hs"). + { simpl. by rewrite Hs. } + { simpl. done. } + iModIntro. iIntros "H1 H2". + iApply wp_val. by iApply ("Ha" with "H1 H2"). + Unshelve. + constructor. + Qed. End weakestpre. Section interp. Context {sz : nat}. Variable (rs : gReifiers sz). - (* Context {subR : subReifier reify_io rs}. *) + Context {subR : subReifier reify_io rs}. Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). - Context {subEff0 : subEff ioE F}. (** Interpreting individual operators *) Program Definition interp_input {A} : A -n> IT := λne env, INPUT Ret. @@ -274,22 +147,6 @@ Section interp. Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). Proof. solve_proper. Qed. - (* Program Definition interp_callcc {A} (t : A -n> ((IT -n> IT))) (n : A -n> IT) *) - (* : A -n> IT := λne env, CALLCC (t env) (n env). *) - (* Next Obligation. *) - (* intros ???. *) - (* intros n' x y H. *) - (* do 2 f_equiv; solve_proper. *) - (* Qed. *) - - (* Program Definition interp_throw {A} (n : A -n> IT) (m : A -n> IT) *) - (* : A -n> IT := λne env, THROW (n env) (m env). *) - (* Next Obligation. *) - (* intros ???. *) - (* intros n' x y H. *) - (* do 2 f_equiv; solve_proper. *) - (* Qed. *) - 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). Solve All Obligations with solve_proper_please. @@ -299,43 +156,18 @@ Section interp. Typeclasses Opaque interp_natop. Opaque laterO_map. - Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) - : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := - λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), - body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. - Next Obligation. - intros. - solve_proper_prepare. - f_equiv; intros [| [| y']]; simpl; solve_proper. - Qed. - Next Obligation. - intros. - solve_proper_prepare. - f_equiv; intros [| [| y']]; simpl; solve_proper. - Qed. - Next Obligation. - intros. - solve_proper_prepare. - do 3 f_equiv; intros ??; simpl; f_equiv; - intros [| [| y']]; simpl; solve_proper. - Qed. - Next Obligation. - intros. - solve_proper_prepare. - by do 2 f_equiv. - Qed. - - Program Definition interp_rec {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) : @interp_scope F R _ S -n> IT := mmuu (interp_rec_pre body). + Program Definition interp_rec_pre {A} (body : prodO IT (prodO IT A) -n> IT) + : laterO (A -n> IT) -n> A -n> IT := + λne self env, Fun $ laterO_map (λne (self : A -n> IT) (a : IT), + body (self env,(a,env))) self. + Solve All Obligations with first [ solve_proper | solve_proper_please ]. - Program Definition ir_unf {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := - λne a, body (@extend_scope F R _ _ (@extend_scope F R _ _ env (interp_rec body env)) a). - Next Obligation. - intros. - solve_proper_prepare. - f_equiv. intros [| [| y']]; simpl; solve_proper. - Qed. + Definition interp_rec {A} body : A -n> IT := mmuu (interp_rec_pre body). + Program Definition ir_unf {A} (body : prodO IT (prodO IT A) -n> IT) env : IT -n> IT := + λne a, body (interp_rec body env, (a,env)). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. - Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : + Lemma interp_rec_unfold {A} (body : prodO IT (prodO IT A) -n> IT) env : interp_rec body env ≡ Fun $ Next $ ir_unf body env. Proof. trans (interp_rec_pre body (Next (interp_rec body)) env). @@ -361,433 +193,413 @@ Section interp. Program Definition interp_nat (n : nat) {A} : A -n> IT := λne env, Ret n. - Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := λne env, Fun (Next (K env)). - Next Obligation. - solve_proper. + (** Interpretation for all the syntactic categories: values, expressions, contexts *) + Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := + match v with + | Lit n => interp_nat n + | RecV e => interp_rec (interp_expr e) + end + with interp_expr {S} (e : expr S) : interp_scope S -n> IT := + match e with + | Val v => interp_val v + | Var x => interp_var x + | Rec e => interp_rec (interp_expr e) + | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) + | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) + | Input => interp_input + | Output e => interp_output (interp_expr e) + end. + + Program Definition interp_ctx_item {S : scope} (K : ectx_item S) : interp_scope S -n> IT -n> IT := + match K with + | AppLCtx v2 => λne env t, interp_app (constO t) (interp_val v2) env + | AppRCtx e1 => λne env t, interp_app (interp_expr e1) (constO t) env + | NatOpLCtx op v2 => λne env t, interp_natop op (constO t) (interp_val v2) env + | NatOpRCtx op e1 => λne env t, interp_natop op (interp_expr e1) (constO t) env + | IfCtx e1 e2 => λne env t, interp_if (constO t) (interp_expr e1) (interp_expr e2) env + | OutputCtx => λne env t, interp_output (constO t) env + end. + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + + #[global] Instance interp_val_asval {S} (v : val S) D : AsVal (interp_val v D). + Proof. + destruct v; simpl; first apply _. + rewrite interp_rec_unfold. apply _. + Qed. + Program Fixpoint interp_ectx {S} (K : ectx S) : interp_scope S -n> IT -n> IT + := + match K with + | [] => λne env, idfun + | Ki::K => λne env, interp_ectx K env ◎ interp_ctx_item Ki env + end. + Next Obligation. solve_proper. Defined. (* XXX why can't i qed here? *) + + Lemma interp_ctx_item_fill {S} (Ki : ectx_item S) e env : + interp_expr (fill_item Ki e) env ≡ interp_ctx_item Ki env (interp_expr e env). + Proof. destruct Ki; reflexivity. Qed. + + Lemma interp_ectx_fill {S} (K : ectx S) e env : + interp_expr (fill K e) env ≡ interp_ectx K env (interp_expr e env). + Proof. + revert e; induction K as [|Ki K]=>e; first done. + rewrite IHK. simpl. rewrite interp_ctx_item_fill. done. Qed. - Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_app q (λne env, K env t) env. - Next Obligation. - solve_proper. + (** Applying renamings and subsitutions to the interpretation of scopes *) + Equations interp_rens_scope {S S' : scope} + (E : interp_scope (E:=F) (R:=R) S') (s : rens S S') : interp_scope (E:=F) (R:=R) S := + interp_rens_scope (S:=[]) E s := tt : interp_scope []; + interp_rens_scope (S:=_::_) E s := + (interp_var (hd_ren s) E, interp_rens_scope E (tl_ren s)). + + Equations interp_subs_scope {S S' : scope} + (E : interp_scope (E:=F) (R:=R) S') (s : subs S S') : interp_scope (E:=F) (R:=R) S := + interp_subs_scope (S:=[]) E s := tt : interp_scope []; + interp_subs_scope (S:=_::_) E s := + (interp_expr (hd_sub s) E, interp_subs_scope E (tl_sub s)). + + + Global Instance interp_rens_scope_ne S S2 n : + Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_rens_scope S S2). + Proof. + intros D D' HE s1 s2 Hs. + induction S as [|τ' S]; simp interp_rens_scope; auto. + f_equiv. + - unfold hd_ren; rewrite Hs. by f_equiv. + - apply IHS. intros v. unfold tl_ren; by rewrite Hs. Qed. - Next Obligation. - solve_proper. + Global Instance interp_subs_scope_ne S S2 n : + Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_subs_scope S S2). + Proof. + intros D D' HE s1 s2 Hs. + induction S as [|τ' S]; simp interp_subs_scope; auto. + f_equiv. + - unfold hd_sub; by rewrite Hs HE. + - apply IHS. intros v. unfold tl_sub; by rewrite Hs. Qed. - Next Obligation. - solve_proper. + Global Instance interp_rens_scope_proper S S2 : + Proper ((≡) ==> (≡) ==> (≡)) (@interp_rens_scope S S2). + Proof. + intros D D' HE s1 s2 Hs. + induction S as [|τ' S]; simp interp_rens_scope; auto. + f_equiv. + - unfold hd_ren; rewrite Hs. + by rewrite HE. + - apply IHS. intros v. unfold tl_ren; by rewrite Hs. + Qed. + Global Instance interp_subs_scope_proper S S2 : + Proper ((≡) ==> (≡) ==> (≡)) (@interp_subs_scope S S2). + Proof. + intros D D' HE s1 s2 Hs. + induction S as [|τ' S]; simp interp_subs_scope; auto. + f_equiv. + - unfold hd_sub; by rewrite Hs HE. + - apply IHS. intros v. unfold tl_sub; by rewrite Hs. Qed. - Program Definition interp_apprk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_app (λne env, K env t) q env. - Next Obligation. - solve_proper. + (** ** The substituion lemma, for renamings and substitutions *) + Lemma interp_rens_scope_tl_ren {S S2} x D (r : rens S S2) : + interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift r)) + ≡ interp_rens_scope D r. + Proof. + induction S as [|τ' S]; simp interp_rens_scope; eauto. + f_equiv. + { unfold hd_ren, tl_ren. simp rens_lift interp_var. + done. } + { rewrite -IHS. f_equiv. clear. + intros v. dependent elimination v; + unfold hd_ren, tl_ren; simp rens_lift; auto. } Qed. - Next Obligation. - solve_proper. + + Lemma interp_rens_scope_idren {S} (D : interp_scope S) : + interp_rens_scope D (@idren S) ≡ D. + Proof. + induction S as [|[] S]; simp interp_rens_scope. + { by destruct D. } + destruct D as [x D]. simp interp_var. simpl. + f_equiv. + trans (interp_rens_scope ((x, D) : interp_scope (()::S)) (tl_ren (rens_lift idren))). + { f_equiv. intros v. unfold tl_ren. + reflexivity. } + rewrite interp_rens_scope_tl_ren. + apply IHS. Qed. - Next Obligation. - solve_proper. + + Lemma interp_expr_ren {S D : scope} (M : expr S) (r : rens S D) : + ∀ (E : interp_scope D), + interp_expr (ren_expr M r) E ≡ interp_expr M (interp_rens_scope E r) + with interp_val_ren {S D : scope} (v : val S) (r : rens S D) : + ∀ (E : interp_scope D), + interp_val (ren_val v r) E ≡ interp_val v (interp_rens_scope E r). + Proof. + - revert D r. induction M=> D r D2; simpl; simp ren_expr. + all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). + + (* variable *) revert r. + induction v=>r. + * simp interp_var interp_rens_scope. done. + * simp interp_var interp_rens_scope. simpl. + apply (IHv (tl_ren r)). + + (* recursive functions *) simp ren_expr. simpl. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr M)). + iApply f_equivI. iNext. iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_ren. + iApply f_equivI. + simp interp_rens_scope interp_var. simpl. + rewrite !interp_rens_scope_tl_ren. + iRewrite "IH". + done. + - revert D r. induction v=> D r D2; simpl; simp ren_val; eauto. + (* recursive functions *) + simp ren_expr. simpl. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + iApply f_equivI. iNext. iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_ren. + iApply f_equivI. + simp interp_rens_scope interp_var. simpl. + rewrite !interp_rens_scope_tl_ren. + iRewrite "IH". + done. Qed. - Axiom falso : False. + Lemma interp_subs_scope_tl_sub {S S2} x D (s : subs S S2) : + interp_subs_scope ((x, D) : interp_scope (()::S2)) (tl_sub (subs_lift s)) + ≡ interp_subs_scope D s. + Proof. + induction S as [|[] S]; simp interp_subs_scope; first done. + f_equiv. + { unfold hd_sub, tl_sub. simp subs_lift interp_var. + unfold expr_lift. rewrite interp_expr_ren. f_equiv. + trans (interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift idren))). + { f_equiv. intros v. unfold tl_ren. + simp rens_lift idren. done. } + rewrite interp_rens_scope_tl_ren. + apply interp_rens_scope_idren. } + { rewrite -IHS. f_equiv. clear. + intros v. dependent elimination v; + unfold hd_sub, tl_sub; simp subs_lift; auto. } + Qed. - (** Interpretation for all the syntactic categories: values, expressions, contexts *) - Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := - match v with - | LitV n => interp_nat n - | VarV x => interp_var x - | RecV e => interp_rec (interp_expr e) - | ContV K => interp_cont (interp_ectx K) - end - with interp_expr {S} (e : expr S) : interp_scope S -n> IT := - match e with - | Val v => interp_val v - | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) - | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) - | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) - | Input => interp_input - | Output e => interp_output (interp_expr e) - | Callcc e => - (* interp_callcc _ (interp_expr e) *) - False_rect _ falso - | Throw e1 e2 => - (* interp_throw e1 e2 *) - False_rect _ falso - end - with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := - match K with - | EmptyK => - λne env, λne t, t - | AppLK e1 K => interp_applk (interp_expr e1) (interp_ectx K) - | AppRK K v2 => interp_apprk (interp_ectx K) (interp_val v2) - | NatOpLK op e1 K => - False_rect _ falso - | NatOpRK op K v2 => - False_rect _ falso - | IfK K e1 e2 => - False_rect _ falso - | OutputK K => - False_rect _ falso - | ThrowLK K e => - False_rect _ falso - | ThrowRK v K => - False_rect _ falso - end. - Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Lemma interp_subs_scope_idsub {S} (env : interp_scope S) : + interp_subs_scope env idsub ≡ env. + Proof. + induction S as [|[] S]; simp interp_subs_scope. + { by destruct env. } + destruct env as [x env]. + unfold hd_sub, idsub. simpl. + simp interp_var. simpl. f_equiv. + etrans; last first. + { apply IHS. } + rewrite -(interp_subs_scope_tl_sub x env idsub). + repeat f_equiv. intro v. unfold tl_sub, idsub; simpl. + simp subs_lift. unfold expr_lift. simp ren_expr. done. + Qed. - (* #[global] Instance interp_val_asval {S} (v : val S) D : AsVal (interp_val v D). *) - (* Proof. *) - (* destruct v; simpl; first apply _. *) - (* rewrite interp_rec_unfold. apply _. *) - (* Qed. *) - - (* Lemma interp_ctx_item_fill {S} (Ki : ectx_item S) e env : *) - (* interp_expr (fill_item Ki e) env ≡ interp_ctx_item Ki env (interp_expr e env). *) - (* Proof. destruct Ki; reflexivity. Qed. *) - - (* Lemma interp_ectx_fill {S} (K : ectx S) e env : *) - (* interp_expr (fill K e) env ≡ interp_ectx K env (interp_expr e env). *) - (* Proof. *) - (* revert e; induction K as [|Ki K]=>e; first done. *) - (* rewrite IHK. simpl. rewrite interp_ctx_item_fill. done. *) - (* Qed. *) - - (* (** Applying renamings and subsitutions to the interpretation of scopes *) *) - (* Equations interp_rens_scope {S S' : scope} *) - (* (E : interp_scope (E:=F) (R:=R) S') (s : rens S S') : interp_scope (E:=F) (R:=R) S := *) - (* interp_rens_scope (S:=[]) E s := tt : interp_scope []; *) - (* interp_rens_scope (S:=_::_) E s := *) - (* (interp_var (hd_ren s) E, interp_rens_scope E (tl_ren s)). *) - - (* Equations interp_subs_scope {S S' : scope} *) - (* (E : interp_scope (E:=F) (R:=R) S') (s : subs S S') : interp_scope (E:=F) (R:=R) S := *) - (* interp_subs_scope (S:=[]) E s := tt : interp_scope []; *) - (* interp_subs_scope (S:=_::_) E s := *) - (* (interp_expr (hd_sub s) E, interp_subs_scope E (tl_sub s)). *) - - - (* Global Instance interp_rens_scope_ne S S2 n : *) - (* Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_rens_scope S S2). *) - (* Proof. *) - (* intros D D' HE s1 s2 Hs. *) - (* induction S as [|τ' S]; simp interp_rens_scope; auto. *) - (* f_equiv. *) - (* - unfold hd_ren; rewrite Hs. by f_equiv. *) - (* - apply IHS. intros v. unfold tl_ren; by rewrite Hs. *) - (* Qed. *) - (* Global Instance interp_subs_scope_ne S S2 n : *) - (* Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_subs_scope S S2). *) - (* Proof. *) - (* intros D D' HE s1 s2 Hs. *) - (* induction S as [|τ' S]; simp interp_subs_scope; auto. *) - (* f_equiv. *) - (* - unfold hd_sub; by rewrite Hs HE. *) - (* - apply IHS. intros v. unfold tl_sub; by rewrite Hs. *) - (* Qed. *) - (* Global Instance interp_rens_scope_proper S S2 : *) - (* Proper ((≡) ==> (≡) ==> (≡)) (@interp_rens_scope S S2). *) - (* Proof. *) - (* intros D D' HE s1 s2 Hs. *) - (* induction S as [|τ' S]; simp interp_rens_scope; auto. *) - (* f_equiv. *) - (* - unfold hd_ren; rewrite Hs. *) - (* by rewrite HE. *) - (* - apply IHS. intros v. unfold tl_ren; by rewrite Hs. *) - (* Qed. *) - (* Global Instance interp_subs_scope_proper S S2 : *) - (* Proper ((≡) ==> (≡) ==> (≡)) (@interp_subs_scope S S2). *) - (* Proof. *) - (* intros D D' HE s1 s2 Hs. *) - (* induction S as [|τ' S]; simp interp_subs_scope; auto. *) - (* f_equiv. *) - (* - unfold hd_sub; by rewrite Hs HE. *) - (* - apply IHS. intros v. unfold tl_sub; by rewrite Hs. *) - (* Qed. *) - - (* (** ** The substituion lemma, for renamings and substitutions *) *) - (* Lemma interp_rens_scope_tl_ren {S S2} x D (r : rens S S2) : *) - (* interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift r)) *) - (* ≡ interp_rens_scope D r. *) - (* Proof. *) - (* induction S as [|τ' S]; simp interp_rens_scope; eauto. *) - (* f_equiv. *) - (* { unfold hd_ren, tl_ren. simp rens_lift interp_var. *) - (* done. } *) - (* { rewrite -IHS. f_equiv. clear. *) - (* intros v. dependent elimination v; *) - (* unfold hd_ren, tl_ren; simp rens_lift; auto. } *) - (* Qed. *) - - (* Lemma interp_rens_scope_idren {S} (D : interp_scope S) : *) - (* interp_rens_scope D (@idren S) ≡ D. *) - (* Proof. *) - (* induction S as [|[] S]; simp interp_rens_scope. *) - (* { by destruct D. } *) - (* destruct D as [x D]. simp interp_var. simpl. *) - (* f_equiv. *) - (* trans (interp_rens_scope ((x, D) : interp_scope (()::S)) (tl_ren (rens_lift idren))). *) - (* { f_equiv. intros v. unfold tl_ren. *) - (* reflexivity. } *) - (* rewrite interp_rens_scope_tl_ren. *) - (* apply IHS. *) - (* Qed. *) - - (* Lemma interp_expr_ren {S D : scope} (M : expr S) (r : rens S D) : *) - (* ∀ (E : interp_scope D), *) - (* interp_expr (ren_expr M r) E ≡ interp_expr M (interp_rens_scope E r) *) - (* with interp_val_ren {S D : scope} (v : val S) (r : rens S D) : *) - (* ∀ (E : interp_scope D), *) - (* interp_val (ren_val v r) E ≡ interp_val v (interp_rens_scope E r). *) - (* Proof. *) - (* - revert D r. induction M=> D r D2; simpl; simp ren_expr. *) - (* all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). *) - (* + (* variable *) revert r. *) - (* induction v=>r. *) - (* * simp interp_var interp_rens_scope. done. *) - (* * simp interp_var interp_rens_scope. simpl. *) - (* apply (IHv (tl_ren r)). *) - (* + (* recursive functions *) simp ren_expr. simpl. *) - (* apply bi.siProp.internal_eq_soundness. *) - (* iLöb as "IH". *) - (* rewrite {2}interp_rec_unfold. *) - (* rewrite {2}(interp_rec_unfold (interp_expr M)). *) - (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) - (* rewrite /ir_unf. iIntros (x). simpl. *) - (* rewrite interp_expr_ren. *) - (* iApply f_equivI. *) - (* simp interp_rens_scope interp_var. simpl. *) - (* rewrite !interp_rens_scope_tl_ren. *) - (* iRewrite "IH". *) - (* done. *) - (* - revert D r. induction v=> D r D2; simpl; simp ren_val; eauto. *) - (* (* recursive functions *) *) - (* simp ren_expr. simpl. *) - (* apply bi.siProp.internal_eq_soundness. *) - (* iLöb as "IH". *) - (* rewrite {2}interp_rec_unfold. *) - (* rewrite {2}(interp_rec_unfold (interp_expr e)). *) - (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) - (* rewrite /ir_unf. iIntros (x). simpl. *) - (* rewrite interp_expr_ren. *) - (* iApply f_equivI. *) - (* simp interp_rens_scope interp_var. simpl. *) - (* rewrite !interp_rens_scope_tl_ren. *) - (* iRewrite "IH". *) - (* done. *) - (* Qed. *) - - (* Lemma interp_subs_scope_tl_sub {S S2} x D (s : subs S S2) : *) - (* interp_subs_scope ((x, D) : interp_scope (()::S2)) (tl_sub (subs_lift s)) *) - (* ≡ interp_subs_scope D s. *) - (* Proof. *) - (* induction S as [|[] S]; simp interp_subs_scope; first done. *) - (* f_equiv. *) - (* { unfold hd_sub, tl_sub. simp subs_lift interp_var. *) - (* unfold expr_lift. rewrite interp_expr_ren. f_equiv. *) - (* trans (interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift idren))). *) - (* { f_equiv. intros v. unfold tl_ren. *) - (* simp rens_lift idren. done. } *) - (* rewrite interp_rens_scope_tl_ren. *) - (* apply interp_rens_scope_idren. } *) - (* { rewrite -IHS. f_equiv. clear. *) - (* intros v. dependent elimination v; *) - (* unfold hd_sub, tl_sub; simp subs_lift; auto. } *) - (* Qed. *) - - (* Lemma interp_subs_scope_idsub {S} (env : interp_scope S) : *) - (* interp_subs_scope env idsub ≡ env. *) - (* Proof. *) - (* induction S as [|[] S]; simp interp_subs_scope. *) - (* { by destruct env. } *) - (* destruct env as [x env]. *) - (* unfold hd_sub, idsub. simpl. *) - (* simp interp_var. simpl. f_equiv. *) - (* etrans; last first. *) - (* { apply IHS. } *) - (* rewrite -(interp_subs_scope_tl_sub x env idsub). *) - (* repeat f_equiv. intro v. unfold tl_sub, idsub; simpl. *) - (* simp subs_lift. unfold expr_lift. simp ren_expr. done. *) - (* Qed. *) - - (* Lemma interp_expr_subst {S D : scope} (M : expr S) (s : subs S D) : *) - (* ∀ (E : interp_scope D), *) - (* interp_expr (subst_expr M s) E ≡ interp_expr M (interp_subs_scope E s) *) - (* with interp_val_subst {S D : scope} (v : val S) (s : subs S D) : *) - (* ∀ (E : interp_scope D), *) - (* interp_val (subst_val v s) E ≡ interp_val v (interp_subs_scope E s). *) - (* Proof. *) - (* - revert D s. induction M=> D r D2; simpl; simp subst_expr. *) - (* all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). *) - (* + (* variable *) revert r. *) - (* induction v=>r. *) - (* * simp interp_var interp_rens_scope. done. *) - (* * simp interp_var interp_rens_scope. simpl. *) - (* apply (IHv (tl_sub r)). *) - (* + (* recursive functions *) simpl. *) - (* apply bi.siProp.internal_eq_soundness. *) - (* iLöb as "IH". *) - (* rewrite {2}interp_rec_unfold. *) - (* rewrite {2}(interp_rec_unfold (interp_expr M)). *) - (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) - (* rewrite /ir_unf. iIntros (x). simpl. *) - (* rewrite interp_expr_subst. *) - (* iApply f_equivI. *) - (* simp interp_subs_scope interp_var. simpl. *) - (* rewrite !interp_subs_scope_tl_sub. *) - (* iRewrite "IH". *) - (* done. *) - (* - revert D s. induction v=> D r D2; simpl; simp subst_val; eauto. *) - (* (* recursive functions *) *) - (* simp subst_expr. simpl. *) - (* apply bi.siProp.internal_eq_soundness. *) - (* iLöb as "IH". *) - (* rewrite {2}interp_rec_unfold. *) - (* rewrite {2}(interp_rec_unfold (interp_expr e)). *) - (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) - (* rewrite /ir_unf. iIntros (x). simpl. *) - (* rewrite interp_expr_subst. *) - (* iApply f_equivI. *) - (* simp interp_subs_scope interp_var. simpl. *) - (* rewrite !interp_subs_scope_tl_sub. *) - (* iRewrite "IH". *) - (* done. *) - (* Qed. *) - - (* (** ** Interpretation is a homomorphism *) *) - (* #[global] Instance interp_ectx_item_hom {S} (Ki : ectx_item S) env : *) - (* IT_hom (interp_ctx_item Ki env). *) - (* Proof. destruct Ki; simpl; apply _. Qed. *) - (* #[global] Instance interp_ectx_hom {S} (K : ectx S) env : *) - (* IT_hom (interp_ectx K env). *) - (* Proof. induction K; simpl; apply _. Qed. *) - - (* (** ** Finally, preservation of reductions *) *) - (* Lemma interp_expr_head_step {S} env (e : expr S) e' σ σ' n : *) - (* head_step e σ e' σ' (n,0) → *) - (* interp_expr e env ≡ Tick_n n $ interp_expr e' env. *) - (* Proof. *) - (* inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. *) - (* - (*fun->val*) *) - (* reflexivity. *) - (* - (* app lemma *) *) - (* rewrite APP_APP'_ITV. *) - (* trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). *) - (* { repeat f_equiv. apply interp_rec_unfold. } *) - (* rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. *) - (* simplify_eq. *) - (* rewrite interp_expr_subst. f_equiv. *) - (* simp interp_subs_scope. unfold hd_sub, tl_sub. simp conssub. *) - (* simpl. repeat f_equiv. *) - (* generalize (Val (RecV e1)). *) - (* generalize (Val v2). *) - (* clear. *) - (* intros e1 e2. *) - (* trans (interp_subs_scope env idsub); last first. *) - (* { f_equiv. intro v. simp conssub. done. } *) - (* symmetry. *) - (* apply interp_subs_scope_idsub. *) - (* - (* the natop stuff *) *) - (* simplify_eq. *) - (* destruct v1,v2; try naive_solver. simpl in *. *) - (* rewrite NATOP_Ret. *) - (* destruct op; simplify_eq/=; done. *) - (* - by rewrite IF_True. *) - (* - rewrite IF_False; eauto. lia. *) - (* Qed. *) - - (* Lemma interp_expr_fill_no_reify {S} K env (e e' : expr S) σ σ' n : *) - (* head_step e σ e' σ' (n,0) → *) - (* interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. *) - (* Proof. *) - (* intros He. *) - (* trans (interp_ectx K env (interp_expr e env)). *) - (* { apply interp_ectx_fill. } *) - (* trans (interp_ectx K env (Tick_n n (interp_expr e' env))). *) - (* { f_equiv. apply (interp_expr_head_step env) in He. apply He. } *) - (* trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. *) - (* { f_equiv. symmetry. apply interp_ectx_fill. } *) - (* apply hom_tick_n. apply _. *) - (* Qed. *) - - (* Opaque INPUT OUTPUT_. *) - (* Opaque Ret. *) - - (* Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) *) - (* (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : *) - (* head_step e σ e' σ' (n,1) → *) - (* reify (gReifiers_sReifier rs) *) - (* (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) *) - (* ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). *) - (* Proof. *) - (* intros Hst. *) - (* trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) *) - (* (gState_recomp σr (sR_state σ))). *) - (* { f_equiv. by rewrite interp_ectx_fill. } *) - (* inversion Hst; simplify_eq; cbn-[gState_recomp]. *) - (* - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). *) - (* { repeat f_equiv; eauto. *) - (* rewrite hom_INPUT. f_equiv. by intro. } *) - (* rewrite reify_vis_eq //; last first. *) - (* { rewrite subReifier_reify/=//. *) - (* rewrite H4. done. } *) - (* repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. *) - (* rewrite interp_ectx_fill. *) - (* by rewrite ofe_iso_21. *) - (* - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). *) - (* { do 3 f_equiv; eauto. *) - (* rewrite get_ret_ret//. } *) - (* trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). *) - (* { do 2 f_equiv; eauto. *) - (* rewrite hom_OUTPUT_//. } *) - (* rewrite reify_vis_eq //; last first. *) - (* { rewrite subReifier_reify/=//. } *) - (* repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. *) - (* rewrite interp_ectx_fill. *) - (* simpl. done. *) - (* Qed. *) - - (* Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m env : *) - (* prim_step e1 σ1 e2 σ2 (n,m) → *) - (* ssteps (gReifiers_sReifier rs) *) - (* (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) *) - (* (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. *) - (* Proof. *) - (* Opaque gState_decomp gState_recomp. *) - (* inversion 1; simplify_eq/=. *) - (* destruct (head_step_io_01 _ _ _ _ _ _ H2); subst. *) - (* - assert (σ1 = σ2) as ->. *) - (* { eapply head_step_no_io; eauto. } *) - (* eapply (interp_expr_fill_no_reify K) in H2. *) - (* rewrite H2. eapply ssteps_tick_n. *) - (* - inversion H2;subst. *) - (* + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) - (* rewrite interp_ectx_fill. *) - (* rewrite hom_INPUT. *) - (* change 1 with (1+0). econstructor; last first. *) - (* { apply ssteps_zero; reflexivity. } *) - (* eapply sstep_reify. *) - (* { Transparent INPUT. unfold INPUT. simpl. *) - (* f_equiv. reflexivity. } *) - (* simpl in H2. *) - (* rewrite -H2. *) - (* repeat f_equiv; eauto. *) - (* rewrite interp_ectx_fill hom_INPUT. *) - (* eauto. *) - (* + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) - (* rewrite interp_ectx_fill. simpl. *) - (* rewrite get_ret_ret. *) - (* rewrite hom_OUTPUT_. *) - (* change 1 with (1+0). econstructor; last first. *) - (* { apply ssteps_zero; reflexivity. } *) - (* eapply sstep_reify. *) - (* { Transparent OUTPUT_. unfold OUTPUT_. simpl. *) - (* f_equiv. reflexivity. } *) - (* simpl in H2. *) - (* rewrite -H2. *) - (* repeat f_equiv; eauto. *) - (* Opaque OUTPUT_. *) - (* rewrite interp_ectx_fill /= get_ret_ret hom_OUTPUT_. *) - (* eauto. *) - (* Qed. *) + Lemma interp_expr_subst {S D : scope} (M : expr S) (s : subs S D) : + ∀ (E : interp_scope D), + interp_expr (subst_expr M s) E ≡ interp_expr M (interp_subs_scope E s) + with interp_val_subst {S D : scope} (v : val S) (s : subs S D) : + ∀ (E : interp_scope D), + interp_val (subst_val v s) E ≡ interp_val v (interp_subs_scope E s). + Proof. + - revert D s. induction M=> D r D2; simpl; simp subst_expr. + all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). + + (* variable *) revert r. + induction v=>r. + * simp interp_var interp_rens_scope. done. + * simp interp_var interp_rens_scope. simpl. + apply (IHv (tl_sub r)). + + (* recursive functions *) simpl. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr M)). + iApply f_equivI. iNext. iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_subst. + iApply f_equivI. + simp interp_subs_scope interp_var. simpl. + rewrite !interp_subs_scope_tl_sub. + iRewrite "IH". + done. + - revert D s. induction v=> D r D2; simpl; simp subst_val; eauto. + (* recursive functions *) + simp subst_expr. simpl. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + iApply f_equivI. iNext. iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_subst. + iApply f_equivI. + simp interp_subs_scope interp_var. simpl. + rewrite !interp_subs_scope_tl_sub. + iRewrite "IH". + done. + Qed. + + (** ** Interpretation is a homomorphism *) + #[global] Instance interp_ectx_item_hom {S} (Ki : ectx_item S) env : + IT_hom (interp_ctx_item Ki env). + Proof. destruct Ki; simpl; apply _. Qed. + #[global] Instance interp_ectx_hom {S} (K : ectx S) env : + IT_hom (interp_ectx K env). + Proof. induction K; simpl; apply _. Qed. + + (** ** Finally, preservation of reductions *) + Lemma interp_expr_head_step {S} env (e : expr S) e' σ σ' n : + head_step e σ e' σ' (n,0) → + interp_expr e env ≡ Tick_n n $ interp_expr e' env. + Proof. + inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. + - (*fun->val*) + reflexivity. + - (* app lemma *) + rewrite APP_APP'_ITV. + trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). + { repeat f_equiv. apply interp_rec_unfold. } + rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. + simplify_eq. + rewrite interp_expr_subst. f_equiv. + simp interp_subs_scope. unfold hd_sub, tl_sub. simp conssub. + simpl. repeat f_equiv. + generalize (Val (RecV e1)). + generalize (Val v2). + clear. + intros e1 e2. + trans (interp_subs_scope env idsub); last first. + { f_equiv. intro v. simp conssub. done. } + symmetry. + apply interp_subs_scope_idsub. + - (* the natop stuff *) + simplify_eq. + destruct v1,v2; try naive_solver. simpl in *. + rewrite NATOP_Ret. + destruct op; simplify_eq/=; done. + - by rewrite IF_True. + - rewrite IF_False; eauto. lia. + Qed. + + Lemma interp_expr_fill_no_reify {S} K env (e e' : expr S) σ σ' n : + head_step e σ e' σ' (n,0) → + interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. + Proof. + intros He. + trans (interp_ectx K env (interp_expr e env)). + { apply interp_ectx_fill. } + trans (interp_ectx K env (Tick_n n (interp_expr e' env))). + { f_equiv. apply (interp_expr_head_step env) in He. apply He. } + trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. + { f_equiv. symmetry. apply interp_ectx_fill. } + apply hom_tick_n. apply _. + Qed. + + Opaque INPUT OUTPUT_. + Opaque Ret. + + Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) + (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : + head_step e σ e' σ' (n,1) → + reify (gReifiers_sReifier rs) + (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). + Proof. + intros Hst. + trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) + (gState_recomp σr (sR_state σ))). + { f_equiv. by rewrite interp_ectx_fill. } + inversion Hst; simplify_eq; cbn-[gState_recomp]. + - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). + { repeat f_equiv; eauto. + rewrite hom_INPUT. f_equiv. by intro. } + rewrite reify_vis_eq //; last first. + { rewrite subReifier_reify/=//. + } + repeat f_equiv. + { simpl. f_equiv. by rewrite H4. } + rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_ectx_fill. + simpl. + rewrite ofe_iso_21. + rewrite H4; simpl. + done. + - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). + { do 3 f_equiv; eauto. + rewrite get_ret_ret//. } + trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). + { do 2 f_equiv; eauto. + rewrite hom_OUTPUT_//. } + rewrite reify_vis_eq //; last first. + { + simpl. + pose proof (@subReifier_reify sz reify_io rs subR IT _ ((inr (inl ()))) n0 ()) as H. + simpl in H. + specialize (H (λne _, Next (interp_ectx K env (Ret 0))) σ (update_output n0 σ) σr). + rewrite <-H; last done. + f_equiv. + - intros [? ?] [? ?] [? ?]; simpl in *. + solve_proper. + - do 2 f_equiv. + intros ?; simpl. + reflexivity. + } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_ectx_fill. + simpl. done. + Qed. + + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m env : + prim_step e1 σ1 e2 σ2 (n,m) → + ssteps (gReifiers_sReifier rs) + (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. + Proof. + Opaque gState_decomp gState_recomp. + inversion 1; simplify_eq/=. + destruct (head_step_io_01 _ _ _ _ _ _ H2); subst. + - assert (σ1 = σ2) as ->. + { eapply head_step_no_io; eauto. } + eapply (interp_expr_fill_no_reify K) in H2. + rewrite H2. eapply ssteps_tick_n. + - inversion H2;subst. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite interp_ectx_fill. + rewrite hom_INPUT. + change 1 with (1+0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify. + { Transparent INPUT. unfold INPUT. simpl. + f_equiv. reflexivity. } + simpl in H2. + rewrite -H2. + repeat f_equiv; eauto. + rewrite interp_ectx_fill hom_INPUT. + eauto. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite interp_ectx_fill. simpl. + rewrite get_ret_ret. + rewrite hom_OUTPUT_. + change 1 with (1+0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify. + { Transparent OUTPUT_. unfold OUTPUT_. simpl. + f_equiv. reflexivity. } + simpl in H2. + rewrite -H2. + repeat f_equiv; eauto. + Opaque OUTPUT_. + rewrite interp_ectx_fill /= get_ret_ret hom_OUTPUT_. + eauto. + Qed. End interp. #[global] Opaque INPUT OUTPUT_. diff --git a/theories/input_lang/logpred.v b/theories/input_lang/logpred.v index eb1da93..4ed1bf7 100644 --- a/theories/input_lang/logpred.v +++ b/theories/input_lang/logpred.v @@ -86,6 +86,7 @@ Section io_lang. iIntros (σ ss) "Hs #Has". iSpecialize ("H0" with "Hs Has"). simpl. iApply (expr_pred_bind (IFSCtx _ _) with "H0"). + { admit. } iIntros (αv) "Ha/=". iDestruct "Ha" as (σ') "[Ha Hs]". iDestruct "Ha" as (n) "Hn". @@ -96,7 +97,7 @@ Section io_lang. iApply ("H2" with "Hs Has Hx"). - rewrite IF_True; last lia. iApply ("H1" with "Hs Has Hx"). - Qed. + Admitted. Lemma compat_input {S} (Γ : tyctx S) : ⊢ valid1 Γ (interp_input rs) Tnat. Proof. @@ -116,6 +117,7 @@ Section io_lang. iSpecialize ("H" with "Hs Has"). simpl. iApply (expr_pred_bind (get_ret _) with "H"). + { admit. } iIntros (αv) "Ha". iDestruct "Ha" as (σ') "[Ha Hs]". iDestruct "Ha" as (n) "Hn". @@ -126,7 +128,7 @@ Section io_lang. { reflexivity. } iNext. iIntros "_ Hs /=". eauto with iFrame. - Qed. + Admitted. Lemma compat_app {S} (Γ : tyctx S) α β τ1 τ2 : ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ valid1 Γ β τ1 -∗ @@ -136,16 +138,18 @@ Section io_lang. iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). iApply (expr_pred_bind (AppRSCtx _) with "H2"). + { admit. } iIntros (βv) "Hb/=". iDestruct "Hb" as (σ') "[Hb Hs]". unfold AppRSCtx. iSpecialize ("H1" with "Hs Has"). iApply (expr_pred_bind (AppLSCtx (IT_of_V βv)) with "H1"). + { admit. } iIntros (αv) "Ha". iDestruct "Ha" as (σ'') "[Ha Hs]". unfold AppLSCtx. iApply ("Ha" with "Hs Hb"). - Qed. + Admitted. Lemma compat_rec {S} (Γ : tyctx S) τ1 τ2 α : ⊢ □ valid1 (consC (Tarr τ1 τ2) (consC τ1 Γ)) α τ2 -∗ @@ -187,11 +191,13 @@ Section io_lang. iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). iApply (expr_pred_bind (NatOpRSCtx _ _) with "H2"). + { admit. } iIntros (βv) "Hb/=". iDestruct "Hb" as (σ') "[Hb Hs]". unfold NatOpRSCtx. iSpecialize ("H1" with "Hs Has"). iApply (expr_pred_bind (NatOpLSCtx _ (IT_of_V βv)) with "H1"). + { admit. } iIntros (αv) "Ha". iDestruct "Ha" as (σ'') "[Ha Hs]". unfold NatOpLSCtx. @@ -201,7 +207,7 @@ Section io_lang. simpl. iApply expr_pred_frame. rewrite NATOP_Ret. iApply wp_val. simpl. eauto with iFrame. - Qed. + Admitted. Lemma fundamental {S} (Γ : tyctx S) e τ : typed Γ e τ → ⊢ valid1 Γ (interp_expr rs e) τ @@ -251,6 +257,7 @@ Proof. { intros [?|He]; first done. destruct He as [? [? []]]. } eapply (wp_safety cr); eauto. + { admit. } { apply Hdisj. } { by rewrite Hb. } intros H1 H2. @@ -279,7 +286,7 @@ Proof. iIntros ( βv). simpl. iDestruct 1 as (_) "[H _]". iDestruct "H" as (σ1') "[$ Hsts]". done. -Qed. +Admitted. Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : typed empC e τ → diff --git a/theories/lang_generic.v b/theories/lang_generic.v index 535a89f..be8b2fd 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -194,21 +194,24 @@ Section kripke_logrel. eauto with iFrame. Qed. - (* Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : *) - (* expr_pred α Ψ ⊢ *) - (* (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ *) - (* expr_pred (f α) Φ. *) - (* Proof. *) - (* iIntros "H1 H2". *) - (* iIntros (x) "Hx". *) - (* iApply wp_bind. *) - (* { solve_proper. } *) - (* iSpecialize ("H1" with "Hx"). *) - (* iApply (wp_wand with "H1"). *) - (* iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". *) - (* iModIntro. *) - (* iApply ("H2" with "Hb Hy"). *) - (* Qed. *) + Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} + {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} : + expr_pred α Ψ ⊢ + (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ + expr_pred (f α) Φ. + Proof. + iIntros "H1 H2". + iIntros (x) "Hx". + iApply wp_bind. + { solve_proper. } + iSpecialize ("H1" with "Hx"). + iApply (wp_wand with "H1"). + iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". + iModIntro. + iApply ("H2" with "Hb Hy"). + Qed. Lemma expr_pred_frame α Φ : WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. @@ -220,4 +223,4 @@ Section kripke_logrel. Qed. End kripke_logrel. -(* Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. *) +Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. diff --git a/theories/program_logic.v b/theories/program_logic.v index 476157d..a492cf2 100644 --- a/theories/program_logic.v +++ b/theories/program_logic.v @@ -12,7 +12,11 @@ Section program_logic. Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - Lemma wp_seq α β s Φ `{!NonExpansive Φ} : + Lemma wp_seq α β s Φ `{!NonExpansive Φ} + {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} + : WP@{rs} α @ s {{ _, WP@{rs} β @ s {{ Φ }} }} ⊢ WP@{rs} SEQ α β @ s {{ Φ }}. Proof. iIntros "H". @@ -22,7 +26,11 @@ Section program_logic. by rewrite SEQ_Val. Qed. - Lemma wp_let α (f : IT -n> IT) s Φ `{!NonExpansive Φ} : + Lemma wp_let α (f : IT -n> IT) s Φ `{!NonExpansive Φ} + {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} + : WP@{rs} α @ s {{ αv, WP@{rs} f (IT_of_V αv) @ s {{ Φ }} }} ⊢ WP@{rs} (LET α f) @ s {{ Φ }}. Proof. iIntros "H". @@ -41,4 +49,3 @@ Section program_logic. End program_logic. - From b3efae3851d538a5cab5c7d6df83a5741dda818b Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 9 Nov 2023 23:33:17 +0100 Subject: [PATCH 014/114] backward comp + todos --- TODO.md | 4 ++++ _CoqProject | 18 +++++++------- theories/input_lang/logpred.v | 44 +++++++++++++++++++---------------- theories/input_lang/logrel.v | 22 +++++++++++------- 4 files changed, 51 insertions(+), 37 deletions(-) create mode 100644 TODO.md diff --git a/TODO.md b/TODO.md new file mode 100644 index 0000000..80b188d --- /dev/null +++ b/TODO.md @@ -0,0 +1,4 @@ +- Backward compatibility (affine lang, examples) +- Reification for callcc +- Denotation for input lang + callcc +- Rules for context-dependent effects diff --git a/_CoqProject b/_CoqProject index 1281e79..7c096e8 100644 --- a/_CoqProject +++ b/_CoqProject @@ -30,19 +30,19 @@ theories/program_logic.v theories/input_lang_callcc/lang.v theories/input_lang_callcc/interp.v -theories/input_lang_callcc/logpred.v -theories/input_lang_callcc/logrel.v +# theories/input_lang_callcc/logpred.v +# theories/input_lang_callcc/logrel.v theories/input_lang/lang.v theories/input_lang/interp.v theories/input_lang/logpred.v theories/input_lang/logrel.v -theories/affine_lang/lang.v -theories/affine_lang/logrel1.v -theories/affine_lang/logrel2.v +# theories/affine_lang/lang.v +# theories/affine_lang/logrel1.v +# theories/affine_lang/logrel2.v -theories/examples/store.v -theories/examples/pairs.v -theories/examples/while.v -theories/examples/factorial.v +# theories/examples/store.v +# theories/examples/pairs.v +# theories/examples/while.v +# theories/examples/factorial.v diff --git a/theories/input_lang/logpred.v b/theories/input_lang/logpred.v index 4ed1bf7..154aa7d 100644 --- a/theories/input_lang/logpred.v +++ b/theories/input_lang/logpred.v @@ -14,6 +14,9 @@ Section io_lang. Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ, !na_invG Σ}. Notation iProp := (iProp Σ). + Context {CtxI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. Variable s : stuckness. Context {A:ofe}. @@ -81,12 +84,11 @@ Section io_lang. valid1 Γ β1 τ -∗ valid1 Γ β2 τ -∗ valid1 Γ (interp_if rs α β1 β2) τ. - Proof. + Proof using CtxI. iIntros "H0 H1 H2". iIntros (σ ss) "Hs #Has". iSpecialize ("H0" with "Hs Has"). simpl. iApply (expr_pred_bind (IFSCtx _ _) with "H0"). - { admit. } iIntros (αv) "Ha/=". iDestruct "Ha" as (σ') "[Ha Hs]". iDestruct "Ha" as (n) "Hn". @@ -97,7 +99,8 @@ Section io_lang. iApply ("H2" with "Hs Has Hx"). - rewrite IF_True; last lia. iApply ("H1" with "Hs Has Hx"). - Admitted. + Qed. + Lemma compat_input {S} (Γ : tyctx S) : ⊢ valid1 Γ (interp_input rs) Tnat. Proof. @@ -109,15 +112,15 @@ Section io_lang. iNext. iIntros "_ Hs". iApply wp_val. simpl. eauto with iFrame. Qed. + Lemma compat_output {S} (Γ : tyctx S) α : ⊢ valid1 Γ α Tnat → valid1 Γ (interp_output rs α) Tnat. - Proof. + Proof using CtxI. iIntros "H". iIntros (σ ss) "Hs #Has". iSpecialize ("H" with "Hs Has"). simpl. iApply (expr_pred_bind (get_ret _) with "H"). - { admit. } iIntros (αv) "Ha". iDestruct "Ha" as (σ') "[Ha Hs]". iDestruct "Ha" as (n) "Hn". @@ -128,28 +131,27 @@ Section io_lang. { reflexivity. } iNext. iIntros "_ Hs /=". eauto with iFrame. - Admitted. + Qed. + Lemma compat_app {S} (Γ : tyctx S) α β τ1 τ2 : ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ valid1 Γ β τ1 -∗ valid1 Γ (interp_app rs α β) τ2. - Proof. + Proof using CtxI. iIntros "H1 H2". iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). iApply (expr_pred_bind (AppRSCtx _) with "H2"). - { admit. } iIntros (βv) "Hb/=". iDestruct "Hb" as (σ') "[Hb Hs]". unfold AppRSCtx. iSpecialize ("H1" with "Hs Has"). iApply (expr_pred_bind (AppLSCtx (IT_of_V βv)) with "H1"). - { admit. } iIntros (αv) "Ha". iDestruct "Ha" as (σ'') "[Ha Hs]". unfold AppLSCtx. iApply ("Ha" with "Hs Hb"). - Admitted. + Qed. Lemma compat_rec {S} (Γ : tyctx S) τ1 τ2 α : ⊢ □ valid1 (consC (Tarr τ1 τ2) (consC τ1 Γ)) α τ2 -∗ @@ -186,18 +188,16 @@ Section io_lang. ⊢ valid1 Γ α Tnat -∗ valid1 Γ β Tnat -∗ valid1 Γ (interp_natop _ op α β) Tnat. - Proof. + Proof using CtxI. iIntros "H1 H2". iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). iApply (expr_pred_bind (NatOpRSCtx _ _) with "H2"). - { admit. } iIntros (βv) "Hb/=". iDestruct "Hb" as (σ') "[Hb Hs]". unfold NatOpRSCtx. iSpecialize ("H1" with "Hs Has"). iApply (expr_pred_bind (NatOpLSCtx _ (IT_of_V βv)) with "H1"). - { admit. } iIntros (αv) "Ha". iDestruct "Ha" as (σ'') "[Ha Hs]". unfold NatOpLSCtx. @@ -207,13 +207,13 @@ Section io_lang. simpl. iApply expr_pred_frame. rewrite NATOP_Ret. iApply wp_val. simpl. eauto with iFrame. - Admitted. + Qed. Lemma fundamental {S} (Γ : tyctx S) e τ : typed Γ e τ → ⊢ valid1 Γ (interp_expr rs e) τ with fundamental_val {S} (Γ : tyctx S) v τ : typed_val Γ v τ → ⊢ valid1 Γ (interp_val rs v) τ. - Proof. + Proof using CtxI. - destruct 1. + by iApply fundamental_val. + by iApply compat_var. @@ -230,7 +230,7 @@ Section io_lang. Lemma fundmanetal_closed (e : expr []) (τ : ty) : typed empC e τ → ⊢ valid1 empC (interp_expr rs e) τ. - Proof. apply fundamental. Qed. + Proof using CtxI. apply fundamental. Qed. End io_lang. @@ -241,7 +241,10 @@ Local Definition rs : gReifiers _ := gReifiers_cons reify_io 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 Σ} τ (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : +Lemma logpred_adequacy cr Σ R `{!Cofe R, SubOfe natO R}`{!invGpreS Σ}`{!statePreG rs R Σ} τ (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k + (HCi : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) (IT (sReifier_ops (gReifiers_sReifier rs)) R) o) + : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ}, (£ cr ⊢ valid1 rs notStuck (λ _:unitO, True)%I empC α τ)%I) → ssteps (gReifiers_sReifier rs) (α ()) st β st' k → @@ -257,7 +260,6 @@ Proof. { intros [?|He]; first done. destruct He as [? [? []]]. } eapply (wp_safety cr); eauto. - { admit. } { apply Hdisj. } { by rewrite Hb. } intros H1 H2. @@ -286,9 +288,11 @@ Proof. iIntros ( βv). simpl. iDestruct 1 as (_) "[H _]". iDestruct "H" as (σ1') "[$ Hsts]". done. -Admitted. +Qed. -Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : +Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k + (HCi : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) (IT (sReifier_ops (gReifiers_sReifier rs)) natO) o) : typed empC e τ → ssteps (gReifiers_sReifier rs) (interp_expr _ e ()) (σ,()) β st' k → (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) diff --git a/theories/input_lang/logrel.v b/theories/input_lang/logrel.v index 534a185..5ff4c60 100644 --- a/theories/input_lang/logrel.v +++ b/theories/input_lang/logrel.v @@ -13,6 +13,9 @@ Section logrel. Context `{!invGS Σ, !stateG rs natO Σ}. Notation iProp := (iProp Σ). Notation restO := (gState_rest sR_idx rs ♯ IT). + Variable (HCi : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) natO) o). Canonical Structure exprO S := leibnizO (expr S). Canonical Structure valO S := leibnizO (val S). @@ -73,7 +76,7 @@ Section logrel. (∀ v βv, logrel_val τ1 βv v -∗ logrel_expr V2 (f (IT_of_V βv)) (fill K (Val v))) -∗ logrel_expr V2 (f α) (fill K e). - Proof. + Proof using HCi. iIntros "H1 H2". iLöb as "IH" forall (α e). iIntros (σ) "Hs". @@ -168,7 +171,7 @@ Section logrel. logrel_valid Γ e1 α1 τ -∗ logrel_valid Γ e2 α2 τ -∗ logrel_valid Γ (If e0 e1 e2) (interp_if rs α0 α1 α2) τ. - Proof. + Proof using HCi. iIntros "H0 H1 H2". iIntros (ss) "#Hss". simpl. simp subst_expr. pose (s := (subs_of_subs2 ss)). fold s. @@ -276,7 +279,7 @@ Section logrel. ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ logrel_valid Γ e2 α2 τ1 -∗ logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. - Proof. + Proof using HCi. iIntros "H1 H2". iIntros (ss) "#Hss". iSpecialize ("H1" with "Hss"). iSpecialize ("H2" with "Hss"). @@ -314,7 +317,7 @@ Section logrel. Lemma compat_output {S} Γ (e: expr S) α : ⊢ logrel_valid Γ e α Tnat -∗ logrel_valid Γ (Output e) (interp_output rs α) Tnat. - Proof. + Proof using HCi. iIntros "H1". iIntros (ss) "Hss". iSpecialize ("H1" with "Hss"). @@ -342,7 +345,7 @@ Section logrel. ⊢ logrel_valid Γ e1 α1 Tnat -∗ logrel_valid Γ e2 α2 Tnat -∗ logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. - Proof. + Proof using HCi. iIntros "H1 H2". iIntros (ss) "#Hss". iSpecialize ("H1" with "Hss"). iSpecialize ("H2" with "Hss"). @@ -373,7 +376,7 @@ Section logrel. typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ with fundamental_val {S} (Γ : tyctx S) τ v : typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. - Proof. + Proof using HCi. - induction 1; simpl. + by apply fundamental_val. + by apply compat_var. @@ -446,7 +449,7 @@ Proof. iAssert (has_substate σ) with "[Hs]" as "Hs". { unfold has_substate, has_full_state. assert (of_state rs (IT (gReifiers_ops rs) natO) (σ, ()) ≡ - of_idx rs (IT (gReifiers_ops rs) natO) sR_idx (sR_state σ)) as -> ; last done. + of_idx rs (IT (gReifiers_ops rs) natO) sR_idx (sR_state σ)) as -> ; last done. intro j. unfold sR_idx. simpl. unfold of_state, of_idx. destruct decide as [Heq|]; last first. @@ -466,7 +469,10 @@ Proof. Qed. -Theorem adequacy (e : expr []) (k : nat) σ σ' n : +Theorem adequacy (e : expr []) (k : nat) σ σ' n + (HCi : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) (IT (sReifier_ops (gReifiers_sReifier rs)) natO) o) + : typed empC e Tnat → ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) (σ,()) (Ret k : IT _ natO) σ' n → ∃ mm σ', prim_steps e σ (Val $ Lit k) σ' mm. From 8cf5cc29fd1c7a6ec6e47b604de4f6fc824d7ad6 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Mon, 13 Nov 2023 14:32:43 +0100 Subject: [PATCH 015/114] Changed a possibly non-terminating `rewrite` --- theories/gitree/weakestpre.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index 1d45dba..da0a3e5 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -588,7 +588,7 @@ Section weakestpre. rewrite reify_vis_eq //. pose proof (@subReifier_reify n sR rs _ IT _ op x y (k ◎ subEff_outs) σ σ' rest) as H. simpl in H. - rewrite ofe_iso_12 in H. + rewrite (ofe_iso_12 (subEff_outs)) in H. rewrite <-H. - simpl. repeat f_equiv. From 1a26bb4d04d27733354698e29dbf8b77705c57ee Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 16 Nov 2023 19:32:42 +0100 Subject: [PATCH 016/114] denot callcc wip --- theories/input_lang/interp.v | 211 +---- theories/input_lang_callcc/interp.v | 1212 +++++++++++++++++---------- theories/input_lang_callcc/lang.v | 2 +- theories/lang_generic_sem.v | 5 +- 4 files changed, 796 insertions(+), 634 deletions(-) diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index 32db4a5..e9ec2d0 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -13,24 +13,14 @@ Program Definition outputE : opInterp := {| Outs := unitO; |}. -Program Definition callccE : opInterp := - {| - Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙)%OF; - Outs := (▶ ∙)%OF; - |}. -Program Definition throwE : opInterp := - {| - Ins := ((▶∙ -n> ▶∙) * ▶ ∙)%OF; - Outs := Empty_setO; - |}. -Definition ioE := @[inputE;outputE;callccE;throwE]. +Definition ioE := @[inputE;outputE]. Canonical Structure reify_io : sReifier. Proof. simple refine {| sReifier_ops := ioE; sReifier_state := stateO |}. intros X HX op. - destruct op as [[] | [ | [ | [ | []]]]]; simpl. + destruct op as [[] | [ | []]]; simpl. - simple refine (λne (us : (unitO * stateO * (natO -n> laterO X))%type), let out : (natO * stateO)%type := (update_input (sndO (fstO us))) in Some $ (us.2 out.1, out.2) : @@ -44,147 +34,7 @@ Proof. cbn in HRn, HRσ, HR |-*. rewrite HRn HRσ. apply (@Some_ne (prodO (laterO X) stateO)). apply pair_dist_inj; solve_proper. - - simple refine (λne (us : (((laterO X -n> laterO X) -n> laterO X) * stateO * - (laterO X -n> laterO X))%type), - let '(f, σ, k) := us in - Some $ (k (f k), σ) : optionO (laterO X * stateO)%type). - intros n [[f1 σ1] k1] [[f2 σ2] k2] [[Hf Hσ] Hk]. - cbn in Hf, Hσ, Hk |-*. - solve_proper. - - simple refine (λne ( us : (prodO (laterO X -n> laterO X) (laterO X) * - stateO * (Empty_setO -n> laterO X))%type), - let '((k', e), σ, _) := us in - Some $ (k' e, σ) : optionO (laterO X * stateO)%type - ). - intros n [[[k1 e1] σ1] ĸ] [[[k2 e2] σ2] ĸ2] [[[Hk He] Hσ] _]. - cbn in *|-*. - solve_proper. - Defined. - -(* Definition callccIF : oFunctor := (▶ ∙)%OF. *) - -(* #[local] Instance callccIF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (callccIF ♯ X). *) -(* Proof. *) -(* constructor. *) -(* unshelve refine (Next inhabitant). *) -(* Qed. *) -(* #[local] Instance callccIF_cofe X `{!Cofe X} : Cofe (callccIF ♯ X). *) -(* Proof. apply _. Qed. *) -(* #[local] Instance callccIF_contr : oFunctorContractive callccIF. *) -(* Proof. *) -(* intros ???????? n [a b] [c d] H. *) -(* apply laterO_map_contractive. *) -(* destruct n as [| n]. *) -(* - apply dist_later_0. *) -(* - apply dist_later_S. *) -(* apply dist_later_S in H. *) -(* destruct H as [H1 H2]; simpl in H1, H2. *) -(* by f_equiv. *) -(* Qed. *) - -(* Definition callccOF : oFunctor := unitO. *) - -(* #[local] Instance callccOF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (callccOF ♯ X). *) -(* Proof. *) -(* constructor. *) -(* simpl. *) -(* constructor. *) -(* Qed. *) -(* #[local] Instance callccOF_cofe X `{!Cofe X} : Cofe (callccOF ♯ X). *) -(* Proof. apply _. Qed. *) -(* #[local] Instance callccOF_contr : oFunctorContractive callccOF. *) -(* Proof. *) -(* intros ???????? n [a b] [c d] H. *) -(* solve_proper. *) -(* Qed. *) - -(* Program Definition callccE : opInterp := {| *) -(* Ins := callccIF; *) -(* Outs := callccOF; *) -(* |}. *) - -(* Definition throwIF : oFunctor := (▶ ∙ * ▶ ∙)%OF. *) - -(* #[local] Instance throwIF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (throwIF ♯ X). *) -(* Proof. *) -(* constructor. *) -(* unshelve refine (Next inhabitant, Next inhabitant). *) -(* Qed. *) -(* #[local] Instance throwIF_cofe X `{!Cofe X} : Cofe (throwIF ♯ X). *) -(* Proof. apply _. Qed. *) -(* #[local] Instance throwIF_contr : oFunctorContractive throwIF. *) -(* Proof. *) -(* intros ???????? n [a b] [c d] H. *) -(* simpl. *) -(* f_equiv. *) -(* { *) -(* apply laterO_map_contractive. *) -(* destruct n as [| n]. *) -(* - apply dist_later_0. *) -(* - apply dist_later_S. *) -(* apply dist_later_S in H. *) -(* destruct H as [H1 H2]; simpl in H1, H2. *) -(* assumption. *) -(* } *) -(* { *) -(* apply laterO_map_contractive. *) -(* destruct n as [| n]. *) -(* - apply dist_later_0. *) -(* - apply dist_later_S. *) -(* apply dist_later_S in H. *) -(* destruct H as [H1 H2]; simpl in H1, H2. *) -(* assumption. *) -(* } *) -(* Qed. *) - -(* Definition throwOF : oFunctor := unitO. *) - -(* #[local] Instance throwOF_inhabited X `{!Cofe X, !Inhabited X} : Inhabited (throwOF ♯ X). *) -(* Proof. *) -(* constructor. *) -(* apply (Next inhabitant). *) -(* Qed. *) -(* #[local] Instance throwOF_cofe X `{!Cofe X} : Cofe (throwOF ♯ X). *) -(* Proof. apply _. Qed. *) -(* #[local] Instance throwOF_contr : oFunctorContractive throwOF. *) -(* Proof. *) -(* intros ???????? n [a b] [c d] H. *) -(* unfold throwOF; simpl. *) -(* reflexivity. *) -(* Qed. *) - -(* Program Definition throwE : opInterp := {| *) -(* Ins := throwIF; *) -(* Outs := throwOF; *) -(* |}. *) - -(* Definition ioE := @[inputE;outputE;callccE;throwE]. *) - -(* Canonical Structure reify_io : sReifier. *) -(* Proof. *) -(* simple refine {| sReifier_ops := ioE; *) -(* sReifier_state := stateO *) -(* |}. *) -(* intros X HX op. *) -(* destruct op as [ | [ | [ | [| []]]]]; simpl. *) -(* - simple refine (λne (us : prodO (prodO unitO stateO) (natO -n> laterO X)), *) -(* Some $ update_input (sndO (fstO us)) : optionO (prodO natO stateO)). *) -(* intros n [[] s1] [[] s2] [[Hs1 Hs2] Hs]; simpl in *. *) -(* repeat f_equiv. apply Hs2. *) -(* - simple refine (λne (us : prodO (prodO natO stateO) (unitO -n> laterO X)), *) -(* Some $ ((), update_output (fstO (fstO us)) (sndO (fstO us))) : optionO (prodO unitO stateO)). *) -(* intros n [m s1] [m' s2] [-> Hs]. solve_proper. *) -(* - simple refine (λne (us : prodO (prodO (laterO X) stateO) (unitO -n> laterO X)), Some $ ((), sndO (fstO us))). *) -(* solve_proper. *) -(* - simple refine (λne (us : prodO (prodO (prodO (laterO X) (laterO X)) stateO) (unitO -n> laterO X)), _). *) -(* + destruct us as [[[us0 us1] us2] us3]. *) -(* (* if us1 is next(fun(k)) some k(us0) else none *) *) -(* admit. *) -(* + admit. *) -(* Admitted. *) - -(* reify throw (x, next(fun(κ))) σ _ = (κ x) *) -(* reify throw _ _ _ = Error *) +Defined. Section constructors. Context {E : opsInterp} {A} `{!Cofe A}. @@ -223,61 +73,6 @@ Section constructors. Solve All Obligations with solve_proper_please. Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). - Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> - IT := - λne f, Vis (E := E) (subEff_opid (inr (inr (inl ())))) - (subEff_ins (F := ioE) (op :=(inr (inr (inl ())))) f) - (λne x, (subEff_outs (F := ioE) (op := inr (inr (inl ()))))^-1 x). - (* (λne _, NextO (Fun (NextO k))). *) - Next Obligation. solve_proper_please. Qed. - Next Obligation. - intros. intros f1 f2 R. - by repeat f_equiv. - Qed. - - (* THROW (e : expression) (k : continuation argument) *) - Program Definition THROW : (laterO IT) -n> laterO (IT -n> IT) -n> IT := - λne e k, Vis (E := E) (subEff_opid (inr (inr (inr (inl ()))))) - (subEff_ins (F := ioE) (op := (inr (inr (inr (inl ()))))) - (laterO_ap k, e)) - (λne x, match - (subEff_outs (F := ioE) - (op := (inr (inr (inr (inl ()))))))^-1 - x with end). - Next Obligation. - intros. intros f1 f2 R. cbn. destruct ((subEff_outs ^-1) f1). - Qed. - Solve All Obligations with solve_proper. - - (* Let's see which one is easier to work with *) - Program Definition THROW' : IT -n> IT -n> IT := - λne e k, get_fun - (λne f, Vis (E := E) (subEff_opid (E := E) (F := ioE) - (inr (inr (inr (inl ()))))) - (subEff_ins (F := ioE) (op := (inr (inr (inr (inl ()))))) - (laterO_ap f, NextO e)) - (λne x, match - (subEff_outs (F := ioE) - (op := (inr (inr (inr (inl ()))))))^-1 - x with end) - ) k. - Next Obligation. intros. intros f1. destruct (subEff_outs^-1 f1). Qed. - Solve Obligations with try solve_proper. - Next Obligation. intros n f1 f2 R. solve_proper_please. Qed. - - (* Program Definition THROW : (laterO IT) -n> (IT -n> IT) -n> IT := *) - (* λne e k, Vis (E := E) (subEff_opid (inr (inr (inr (inl ()))))) *) - (* (subEff_ins (F := ioE) (op := (inr (inr (inr (inl ()))))) *) - (* (e, NextO (Fun (NextO k)))) *) - (* (λne _, NextO (APP (Fun (NextO k)) e)). *) - (* Next Obligation. solve_proper_please. Qed. *) - (* Next Obligation. *) - (* intros. intros f1 f2 R. *) - (* repeat f_equiv; first done. *) - (* solve_proper. *) - (* Qed. *) - (* Next Obligation. solve_proper_please. Qed. *) - Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). Proof. unfold INPUT. diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 3781420..c3a71d6 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -4,6 +4,7 @@ From gitrees.input_lang_callcc Require Import lang. Require Import gitrees.lang_generic_sem. Require Import Binding.Lib. +Require Import Binding.Set. Notation stateO := (leibnizO state). @@ -23,7 +24,7 @@ Program Definition callccE : opInterp := {| Program Definition throwE : opInterp := {| Ins := (▶ ∙ * (▶ (∙ -n> ∙))); - Outs := Empty_setO; + Outs := unitO; |}. Definition ioE := @[inputE;outputE;callccE;throwE]. @@ -50,7 +51,7 @@ Proof. + apply Hs'. - simple refine (λne (us : prodO (prodO ((laterO X -n> laterO X) -n> laterO X) stateO) (laterO X -n> laterO X)), Some $ ((fstO (fstO us)) (sndO us), sndO (fstO us))). solve_proper. - - simple refine (λne (us : prodO (prodO (prodO (laterO X) (laterO (X -n> X))) stateO) (Empty_setO -n> laterO X)), Some (laterO_ap us.1.1.2 us.1.1.1, sndO (fstO us))). + - simple refine (λne (us : prodO (prodO (prodO (laterO X) (laterO (X -n> X))) stateO) (unitO -n> laterO X)), Some (laterO_ap us.1.1.2 us.1.1.1, sndO (fstO us))). intros ????. repeat f_equiv; assumption. Defined. @@ -62,11 +63,34 @@ Section constructors. Notation IT := (IT E A). Notation ITV := (ITV E A). - Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := - λne k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) - (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) k) - (λne o, (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o). - Solve All Obligations with solve_proper. + Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> (laterO IT -n> laterO IT) -n> IT := + λne e k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) + (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) e) + (λne o, (k ((subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o))). + Next Obligation. + intros. + intros ???. + by do 2 f_equiv. + Qed. + Next Obligation. + intros. + intros ???. + f_equiv. + intros ?; simpl. + by do 1 f_equiv. + Qed. + Next Obligation. + intros ?????; simpl. + by do 2 f_equiv. + Qed. + + Lemma hom_CALLCC e k f `{!IT_hom f} : f (CALLCC e k) ≡ CALLCC e (laterO_map (OfeMor f) ◎ k). + Proof. + unfold CALLCC. + rewrite hom_vis/=. repeat f_equiv. + intro x. cbn-[laterO_map]. + f_equiv. + Qed. Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) (subEff_ins (F:=ioE) (op:=(inl ())) ()) @@ -133,47 +157,87 @@ Section weakestpre. Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - (* Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : *) - (* update_input σ = (n, σ') → *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ *) - (* WP@{rs} (INPUT k) @ s {{ Φ }}. *) - (* Proof. *) - (* intros Hs. iIntros "Hs Ha". *) - (* unfold INPUT. simpl. *) - (* iApply (wp_subreify with "Hs"). *) - (* { simpl. by rewrite Hs. } *) - (* { simpl. by rewrite ofe_iso_21. } *) - (* iModIntro. done. *) - (* Qed. *) - (* Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : *) - (* update_output n σ = σ' → *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ *) - (* WP@{rs} (OUTPUT n) @ s {{ Φ }}. *) - (* Proof. *) - (* intros Hs. iIntros "Hs Ha". *) - (* unfold OUTPUT. simpl. *) - (* iApply (wp_subreify with "Hs"). *) - (* { simpl. by rewrite Hs. } *) - (* { simpl. done. } *) - (* iModIntro. iIntros "H1 H2". *) - (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) - (* Qed. *) + Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : + update_input σ = (n, σ') → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ + WP@{rs} (INPUT k) @ s {{ Φ }}. + Proof. + intros Hs. iIntros "Hs Ha". + unfold INPUT. simpl. + iApply (wp_subreify with "Hs"). + { simpl. by rewrite Hs. } + { simpl. by rewrite ofe_iso_21. } + iModIntro. done. + Qed. + + Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : + update_output n σ = σ' → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ + WP@{rs} (OUTPUT n) @ s {{ Φ }}. + Proof. + intros Hs. iIntros "Hs Ha". + unfold OUTPUT. simpl. + iApply (wp_subreify with "Hs"). + { simpl. by rewrite Hs. } + { simpl. done. } + iModIntro. iIntros "H1 H2". + iApply wp_val. by iApply ("Ha" with "H1 H2"). + Unshelve. + simpl; constructor. + Qed. - (* Lemma wp_callcc (σ : stateO) (n : nat) Φ s : *) + (* wp_subreify *) + (* Lemma wp_callcc (σ : stateO) (e : (laterO IT -n> laterO IT) -n> laterO IT) (k : laterO IT -n> laterO IT) Φ s : *) (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ Φ (RetV 0)) -∗ *) - (* WP@{rs} (CALLCC n) @ s {{ Φ }}. *) + (* ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} (later_car (k (e k))) @ s {{ Φ }}) -∗ *) + (* WP@{rs} (CALLCC e k) @ s {{ Φ }}. *) (* Proof. *) - (* intros Hs. iIntros "Hs Ha". *) - (* unfold OUTPUT. simpl. *) + (* iIntros "Hs Ha". *) + (* unfold CALLCC. simpl. *) (* iApply (wp_subreify with "Hs"). *) - (* { simpl. by rewrite Hs. } *) - (* { simpl. done. } *) - (* iModIntro. iIntros "H1 H2". *) - (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) - (* Qed. *) + (* { *) + (* simpl. *) + (* do 2 f_equiv; last reflexivity. *) + (* Unshelve. *) + (* 3: apply (k (e k)). *) + (* 2: simpl; apply (e k). *) + (* simpl. *) + (* rewrite ofe_iso_21. *) + (* admit. *) + (* } *) + (* { *) + (* simpl. *) + (* rewrite ofe_iso_21. *) + (* f_equiv. *) + (* } *) + (* iModIntro. *) + (* iApply "Ha". *) + (* Admitted. *) + + Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ + WP@{rs} (THROW x f) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + unfold THROW. simpl. + iApply (wp_subreify with "Hs"). + { + simpl. + do 2 f_equiv; reflexivity. + } + { + simpl. + reflexivity. + } + iModIntro. + iApply "Ha". + Unshelve. + simpl. + constructor. + Qed. End weakestpre. @@ -188,136 +252,448 @@ Section interp. Notation ITV := (ITV F R). Context {subEff0 : subEff ioE F}. + (** Interpreting individual operators *) - Program Definition interp_input {A} : A -n> IT := - λne env, INPUT Ret. - Program Definition interp_output {A} (t : A -n> IT) : A -n> IT := - get_ret OUTPUT ◎ t. - Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). - Proof. solve_proper. Qed. + Program Definition interp_input {A} : A -n> (IT -n> IT) -n> IT := + λne env κ, κ (INPUT Ret). + Solve All Obligations with solve_proper. + + Program Definition interp_output {A} (t : A -n> (IT -n> IT) -n> IT) : A -n> (IT -n> IT) -n> IT := + λne env κ, t env (λne x, κ ((get_ret OUTPUT x))). + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + by repeat f_equiv. + Qed. - Program Definition interp_callcc {A} (t : A -n> ((laterO IT -n> laterO IT) -n> IT)) - : A -n> IT := λne env, CALLCC (λne f, Next (t env f)). + Program Definition interp_callcc {S} (e : @interp_scope F R _ (inc S) -n> (IT -n> IT) -n> IT) + : interp_scope S -n> (IT -n> IT) -n> IT := λne env κ, CALLCC (λne (f : laterO IT -n> laterO IT), f (Next (e (@extend_scope F R _ _ env (Fun (Next κ))) κ))) (laterO_ap (Next κ)). Next Obligation. solve_proper. Qed. Next Obligation. intros; intros ???. - repeat f_equiv; intros a; simpl. - do 3 f_equiv; assumption. + repeat f_equiv. + - intros a; simpl. + repeat f_equiv; [| assumption]. + intros [| ?]; simpl; solve_proper. + - assumption. + Qed. + Next Obligation. + intros; intros ????; simpl. + repeat f_equiv; intros ?; simpl. + repeat f_equiv. + intros [| ?]; simpl; solve_proper. Qed. - Program Definition interp_throw {A} (n : A -n> IT) (m : A -n> IT) - : A -n> IT := λne env, get_fun (λne (f : laterO (IT -n> IT)), THROW (n env) f) (m env). + Program Definition interp_throw {A} (n : A -n> (IT -n> IT) -n> IT) (m : A -n> (IT -n> IT) -n> IT) + : A -n> (IT -n> IT) -n> IT := λne env κ, n env (λne n', m env (λne m', get_fun (λne (f : laterO (IT -n> IT)), THROW n' f) m')). Next Obligation. - intros ????. - intros n' x y H. + intros ???????????. f_equiv; assumption. Qed. - - 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). - Solve All Obligations with solve_proper_please. - - Global Instance interp_natop_ne A op : NonExpansive2 (@interp_natop A op). - Proof. solve_proper. Qed. - Typeclasses Opaque interp_natop. - - Opaque laterO_map. - Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) - : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := - λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), - body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. Next Obligation. - intros. solve_proper_prepare. - f_equiv; intros [| [| y']]; simpl; solve_proper. + repeat f_equiv; last done. Qed. Next Obligation. - intros. solve_proper_prepare. - f_equiv; intros [| [| y']]; simpl; solve_proper. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. Qed. Next Obligation. - intros. solve_proper_prepare. - do 3 f_equiv; intros ??; simpl; f_equiv; - intros [| [| y']]; simpl; solve_proper. + repeat f_equiv. Qed. Next Obligation. - intros. solve_proper_prepare. - by do 2 f_equiv. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. Qed. - Program Definition interp_rec {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) : @interp_scope F R _ S -n> IT := mmuu (interp_rec_pre body). + Global Instance interp_throw_ne A : NonExpansive2 (@interp_throw A). + Proof. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + repeat f_equiv; first done. + Qed. + Typeclasses Opaque interp_throw. - Program Definition ir_unf {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := - λne a, body (@extend_scope F R _ _ (@extend_scope F R _ _ env (interp_rec body env)) a). + Program Definition interp_natop {A} (op : nat_op) (t1 t2 : A -n> (IT -n> IT) -n> IT) : A -n> (IT -n> IT) -n> IT := + λne env κ, (t1 env (λne n, t2 env (λne m, κ (NATOP (do_natop op) n m)))). + Solve All Obligations with try solve_proper. Next Obligation. - intros. solve_proper_prepare. - f_equiv. intros [| [| y']]; simpl; solve_proper. + f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. Qed. - Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : - interp_rec body env ≡ Fun $ Next $ ir_unf body env. + Global Instance interp_natop_ne A op : NonExpansive2 (@interp_natop A op). Proof. - trans (interp_rec_pre body (Next (interp_rec body)) env). - { f_equiv. rewrite /interp_rec. apply mmuu_unfold. } - simpl. rewrite laterO_map_Next. repeat f_equiv. - simpl. unfold ir_unf. intro. simpl. reflexivity. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. + Qed. + Typeclasses Opaque interp_natop. + + Opaque laterO_map. + + Program Definition interp_app {A} (t1 t2 : A -n> (IT -n> IT) -n> IT) : A -n> (IT -n> IT) -n> IT := + λne env κ, t1 env (λne m, t2 env (λne n, κ (APP' m n))). + Next Obligation. + solve_proper. + Qed. + Next Obligation. + solve_proper_please. + Qed. + Next Obligation. + intros; intros ???. + f_equiv; intros ?; simpl. + f_equiv; intros ?; simpl. + 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 ]. - Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). - Proof. solve_proper. Qed. Typeclasses Opaque interp_app. - Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := - λne env, IF (t0 env) (t1 env) (t2 env). - Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Program Definition interp_if {A} (t0 t1 t2 : A -n> (IT -n> IT) -n> IT) : A -n> (IT -n> IT) -n> IT := + λne env κ, (t0 env (λne b, (IF b (t1 env κ) (t2 env κ)))). + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + f_equiv. + intros ?; simpl; solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. + Qed. + Global Instance interp_if_ne A n : Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). - Proof. solve_proper. Qed. - - Program Definition interp_nat (n : nat) {A} : A -n> IT := - λne env, Ret n. + Proof. + solve_proper_prepare. + repeat f_equiv; first solve_proper. + intros ?; simpl. + repeat f_equiv; solve_proper. + Qed. - Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := λne env, Fun (Next (K env)). + Program Definition interp_nat (n : nat) {A} : A -n> (IT -n> IT) -n> IT := + λne env κ, κ (Ret n). Solve All Obligations with solve_proper. - Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_app q (λne env, K env t) env. + Program Definition interp_var' {S : Set} (v : S) : interp_scope S -n> (IT -n> IT) -n> IT := + λne (f : interp_scope S) κ, κ (interp_var v f). Solve All Obligations with solve_proper. - Program Definition interp_apprk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_app (λne env, K env t) q env. - Solve All Obligations with solve_proper. + Program Definition interp_emptyk {A} : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) := λne φ env κ, φ env κ. + Solve All Obligations with try solve_proper. - Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_natop op q (λne env, K env t) env. - Solve All Obligations with solve_proper. + Program Definition interp_outputk {A} (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) := λne φ env κ, interp_output (K φ) env κ. + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + by repeat f_equiv. + Qed. - Program Definition interp_natoprk {A} (op : nat_op) (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_natop op (λne env, K env t) q env. - Solve All Obligations with solve_proper. + Program Definition interp_ifk {A} (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) + (q : A -n> (IT -n> IT) -n> IT) + (p : A -n> (IT -n> IT) -n> IT) + : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) + := λne φ env κ, interp_if (K φ) q p env κ. + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + by repeat f_equiv. + Qed. - Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) (p : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_if (λne env, K env t) p q env. - Solve All Obligations with solve_proper. + Program Definition interp_applk {A} (q : A -n> (IT -n> IT) -n> IT) + (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) + : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) + := λne φ env κ, interp_app q (K φ) env κ. + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. - Program Definition interp_outputk {A} (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_output (λne env, K env t) env. - Solve All Obligations with solve_proper. + Program Definition interp_apprk {A} (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) + (q : A -n> (IT -n> IT) -n> IT) + : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) + := λne φ env κ, interp_app (K φ) q env κ. + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + by repeat f_equiv. + Qed. + + Program Definition interp_natoplk {A} (op : nat_op) + (q : A -n> (IT -n> IT) -n> IT) + (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) + : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) + := λne φ env κ, interp_natop op q (K φ) env κ. + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + + Program Definition interp_natoprk {A} (op : nat_op) + (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) + (q : A -n> (IT -n> IT) -n> IT) + : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) + := λne φ env κ, interp_natop op (K φ) q env κ. + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + by repeat f_equiv. + Qed. - Axiom falso : False. + Program Definition interp_throwlk {A} + (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) + (q : A -n> (IT -n> IT) -n> IT) + : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) + := λne φ env κ, interp_throw (K φ) q env κ. + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + by repeat f_equiv. + Qed. + + Program Definition interp_throwrk {A} + (q : A -n> (IT -n> IT) -n> IT) + (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) + : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) + := λne φ env κ, interp_throw q (K φ) env κ. + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; first done. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + + (* Wrong *) + Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> (IT -n> IT) -n> IT) + : laterO (@interp_scope F R _ S -n> (IT -n> IT) -n> IT) -n> @interp_scope F R _ S -n> (IT -n> IT) -n> IT := + λne self env κ, + κ (Fun $ laterO_map (λne + (self : @interp_scope F R _ S -n> (IT -n> IT) -n> IT) + (a : IT), + body + (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env κ)) a) + κ + ) self). + Next Obligation. + intros. + solve_proper_prepare. + do 2 f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + do 2 f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; [assumption |]. + do 3 f_equiv; intros ??; simpl; f_equiv. + - f_equiv; intros [| [| y']]; simpl; solve_proper. + - assumption. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + do 4 f_equiv; intros ??; simpl. + do 2 f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + by do 3 f_equiv. + Qed. + + Program Definition interp_rec {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> (IT -n> IT) -n> IT) : @interp_scope F R _ S -n> (IT -n> IT) -n> IT := mmuu (interp_rec_pre body). + + Program Definition ir_unf {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> (IT -n> IT) -n> IT) env κ : IT -n> IT := + λne a, body (@extend_scope F R _ _ (@extend_scope F R _ _ env (interp_rec body env κ)) a) κ. + Next Obligation. + intros. + solve_proper_prepare. + repeat f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + + Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> (IT -n> IT) -n> IT) env κ : + interp_rec body env κ ≡ κ $ Fun $ Next $ ir_unf body env κ. + Proof. + trans (interp_rec_pre body (Next (interp_rec body)) env κ). + { do 2 f_equiv. rewrite /interp_rec. apply mmuu_unfold. } + simpl. rewrite laterO_map_Next. repeat f_equiv. + simpl. unfold ir_unf. simpl. + intro. simpl. reflexivity. + Qed. + + (* Wrong *) + Program Definition interp_cont {A} + (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) + : A -n> (IT -n> IT) -n> IT + := λne env κ, Fun (Next (λne e, K (λne _ _, e) env κ)). + Solve All Obligations with try solve_proper. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + by intros ??; simpl. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. (** Interpretation for all the syntactic categories: values, expressions, contexts *) - Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := + Fixpoint interp_val {S} (v : val S) : interp_scope S -n> (IT -n> IT) -n> IT := match v with | LitV n => interp_nat n - | VarV x => interp_var x + | VarV x => interp_var' x | RecV e => interp_rec (interp_expr e) | ContV K => interp_cont (interp_ectx K) end - with interp_expr {S} (e : expr S) : interp_scope S -n> IT := + with interp_expr {S} (e : expr S) : interp_scope S -n> (IT -n> IT) -n> IT := match e with | Val v => interp_val v | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) @@ -325,291 +701,271 @@ Section interp. | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) | Input => interp_input | Output e => interp_output (interp_expr e) - | Callcc e => - (* interp_callcc _ (interp_expr e) *) - False_rect _ falso - | Throw e1 e2 => - interp_throw (interp_expr e1) (interp_expr e2) + | Callcc e => interp_callcc (interp_expr e) + | Throw e1 e2 => interp_throw (interp_expr e1) (interp_expr e2) end - with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := + with interp_ectx {S} (K : ectx S) : (interp_scope S -n> (IT -n> IT) -n> IT) -n> (interp_scope S -n> (IT -n> IT) -n> IT) := match K with - | EmptyK => - λne env, λne t, t + | EmptyK => interp_emptyk | AppLK e1 K => interp_applk (interp_expr e1) (interp_ectx K) | AppRK K v2 => interp_apprk (interp_ectx K) (interp_val v2) | NatOpLK op e1 K => interp_natoplk op (interp_expr e1) (interp_ectx K) | NatOpRK op K v2 => interp_natoprk op (interp_ectx K) (interp_val v2) | IfK K e1 e2 => interp_ifk (interp_ectx K) (interp_expr e1) (interp_expr e2) | OutputK K => interp_outputk (interp_ectx K) - | ThrowLK K e => - False_rect _ falso - | ThrowRK v K => - False_rect _ falso + | ThrowLK K e => interp_throwlk (interp_ectx K) (interp_expr e) + | ThrowRK v K => interp_throwrk (interp_val v) (interp_ectx K) end. Solve All Obligations with first [ solve_proper | solve_proper_please ]. - (* #[global] Instance interp_val_asval {S} (v : val S) D : AsVal (interp_val v D). *) - (* Proof. *) - (* destruct v; simpl; first apply _. *) - (* rewrite interp_rec_unfold. apply _. *) - (* Qed. *) - - (* Lemma interp_ctx_item_fill {S} (Ki : ectx_item S) e env : *) - (* interp_expr (fill_item Ki e) env ≡ interp_ctx_item Ki env (interp_expr e env). *) - (* Proof. destruct Ki; reflexivity. Qed. *) - - (* Lemma interp_ectx_fill {S} (K : ectx S) e env : *) - (* interp_expr (fill K e) env ≡ interp_ectx K env (interp_expr e env). *) - (* Proof. *) - (* revert e; induction K as [|Ki K]=>e; first done. *) - (* rewrite IHK. simpl. rewrite interp_ctx_item_fill. done. *) - (* Qed. *) - - (* (** Applying renamings and subsitutions to the interpretation of scopes *) *) - (* Equations interp_rens_scope {S S' : scope} *) - (* (E : interp_scope (E:=F) (R:=R) S') (s : rens S S') : interp_scope (E:=F) (R:=R) S := *) - (* interp_rens_scope (S:=[]) E s := tt : interp_scope []; *) - (* interp_rens_scope (S:=_::_) E s := *) - (* (interp_var (hd_ren s) E, interp_rens_scope E (tl_ren s)). *) - - (* Equations interp_subs_scope {S S' : scope} *) - (* (E : interp_scope (E:=F) (R:=R) S') (s : subs S S') : interp_scope (E:=F) (R:=R) S := *) - (* interp_subs_scope (S:=[]) E s := tt : interp_scope []; *) - (* interp_subs_scope (S:=_::_) E s := *) - (* (interp_expr (hd_sub s) E, interp_subs_scope E (tl_sub s)). *) - - - (* Global Instance interp_rens_scope_ne S S2 n : *) - (* Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_rens_scope S S2). *) - (* Proof. *) - (* intros D D' HE s1 s2 Hs. *) - (* induction S as [|τ' S]; simp interp_rens_scope; auto. *) - (* f_equiv. *) - (* - unfold hd_ren; rewrite Hs. by f_equiv. *) - (* - apply IHS. intros v. unfold tl_ren; by rewrite Hs. *) - (* Qed. *) - (* Global Instance interp_subs_scope_ne S S2 n : *) - (* Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_subs_scope S S2). *) - (* Proof. *) - (* intros D D' HE s1 s2 Hs. *) - (* induction S as [|τ' S]; simp interp_subs_scope; auto. *) - (* f_equiv. *) - (* - unfold hd_sub; by rewrite Hs HE. *) - (* - apply IHS. intros v. unfold tl_sub; by rewrite Hs. *) - (* Qed. *) - (* Global Instance interp_rens_scope_proper S S2 : *) - (* Proper ((≡) ==> (≡) ==> (≡)) (@interp_rens_scope S S2). *) - (* Proof. *) - (* intros D D' HE s1 s2 Hs. *) - (* induction S as [|τ' S]; simp interp_rens_scope; auto. *) - (* f_equiv. *) - (* - unfold hd_ren; rewrite Hs. *) - (* by rewrite HE. *) - (* - apply IHS. intros v. unfold tl_ren; by rewrite Hs. *) - (* Qed. *) - (* Global Instance interp_subs_scope_proper S S2 : *) - (* Proper ((≡) ==> (≡) ==> (≡)) (@interp_subs_scope S S2). *) - (* Proof. *) - (* intros D D' HE s1 s2 Hs. *) - (* induction S as [|τ' S]; simp interp_subs_scope; auto. *) - (* f_equiv. *) - (* - unfold hd_sub; by rewrite Hs HE. *) - (* - apply IHS. intros v. unfold tl_sub; by rewrite Hs. *) - (* Qed. *) - - (* (** ** The substituion lemma, for renamings and substitutions *) *) - (* Lemma interp_rens_scope_tl_ren {S S2} x D (r : rens S S2) : *) - (* interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift r)) *) - (* ≡ interp_rens_scope D r. *) - (* Proof. *) - (* induction S as [|τ' S]; simp interp_rens_scope; eauto. *) - (* f_equiv. *) - (* { unfold hd_ren, tl_ren. simp rens_lift interp_var. *) - (* done. } *) - (* { rewrite -IHS. f_equiv. clear. *) - (* intros v. dependent elimination v; *) - (* unfold hd_ren, tl_ren; simp rens_lift; auto. } *) - (* Qed. *) + #[global] Instance interp_val_asval {S} (v : val S) (D : interp_scope S) + (H : ∀ (x : S), AsVal (D x)) + : AsVal (interp_val v D idfun). + Proof. + destruct v; simpl. + - apply H. + - apply _. + - rewrite interp_rec_unfold. apply _. + - apply _. + Qed. - (* Lemma interp_rens_scope_idren {S} (D : interp_scope S) : *) - (* interp_rens_scope D (@idren S) ≡ D. *) - (* Proof. *) - (* induction S as [|[] S]; simp interp_rens_scope. *) - (* { by destruct D. } *) - (* destruct D as [x D]. simp interp_var. simpl. *) - (* f_equiv. *) - (* trans (interp_rens_scope ((x, D) : interp_scope (()::S)) (tl_ren (rens_lift idren))). *) - (* { f_equiv. intros v. unfold tl_ren. *) - (* reflexivity. } *) - (* rewrite interp_rens_scope_tl_ren. *) - (* apply IHS. *) - (* Qed. *) + Lemma interp_expr_ren {S S'} env env' κ + (δ : S [→] S') (H : env' ≡ (ren_scope δ env)) e : + interp_expr (fmap δ e) env κ ≡ interp_expr e env' κ + with interp_val_ren {S S'} env env' κ + (δ : S [→] S') (H : env' ≡ (ren_scope δ env)) e : + interp_val (fmap δ e) env κ ≡ interp_val e env' κ + with interp_ectx_ren {S S'} env env' κ φ φ' + (δ : S [→] S') (H : env' ≡ (ren_scope δ env)) e : + interp_ectx (fmap δ e) φ env κ ≡ interp_ectx e φ' env' κ. + Proof. + - destruct e; simpl. + + by apply interp_val_ren. + + f_equiv. + * intros ?; by apply interp_expr_ren. + * intros ?; simpl; by apply interp_expr_ren. + + repeat f_equiv. + * intros ?; simpl; by apply interp_expr_ren. + * intros ?; simpl; by apply interp_expr_ren. + + repeat f_equiv. + * intros ?; by apply interp_expr_ren. + * intros ?; simpl. + repeat f_equiv. + -- intros ?; simpl; by apply interp_expr_ren. + -- intros ?; simpl; by apply interp_expr_ren. + + f_equiv. + + repeat f_equiv. + intros ?; simpl; by apply interp_expr_ren. + + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros ?; simpl; apply interp_expr_ren. + intros [| y]; simpl. + * reflexivity. + * specialize (H y). + apply H. + + repeat f_equiv. + * intros ?; simpl. + repeat f_equiv. + intros ?; simpl; by apply interp_expr_ren. + * intros ?; simpl; by apply interp_expr_ren. + - destruct e; simpl. + + f_equiv. + rewrite (H _). + reflexivity. + + reflexivity. + + clear -interp_expr_ren H. + apply bi.siProp.internal_eq_soundness. + iAssert (∀ (S S' : Set) (env : interp_scope S') (env' : interp_scope S) (κ : IT -n> IT) (δ : S [→] S'), + env' ≡ ren_scope δ env -∗ ∀ e : expr S, interp_expr (fmap δ e) env κ ≡ interp_expr e env' κ)%I as "H". + { + iIntros (? ? ? ? ? ?) "G". + iIntros (?). + iRewrite "G". + iPureIntro. + apply interp_expr_ren. + reflexivity. + } + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 2 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + unshelve iApply ("H" $! (inc (inc S)) (inc (inc S')) _ _ κ _ with "[H]"). + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * by rewrite (H _). + + repeat f_equiv. + intros ?; simpl; by apply interp_ectx_ren. + - admit. + Admitted. - (* Lemma interp_expr_ren {S D : scope} (M : expr S) (r : rens S D) : *) - (* ∀ (E : interp_scope D), *) - (* interp_expr (ren_expr M r) E ≡ interp_expr M (interp_rens_scope E r) *) - (* with interp_val_ren {S D : scope} (v : val S) (r : rens S D) : *) - (* ∀ (E : interp_scope D), *) - (* interp_val (ren_val v r) E ≡ interp_val v (interp_rens_scope E r). *) - (* Proof. *) - (* - revert D r. induction M=> D r D2; simpl; simp ren_expr. *) - (* all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). *) - (* + (* variable *) revert r. *) - (* induction v=>r. *) - (* * simp interp_var interp_rens_scope. done. *) - (* * simp interp_var interp_rens_scope. simpl. *) - (* apply (IHv (tl_ren r)). *) - (* + (* recursive functions *) simp ren_expr. simpl. *) - (* apply bi.siProp.internal_eq_soundness. *) - (* iLöb as "IH". *) - (* rewrite {2}interp_rec_unfold. *) - (* rewrite {2}(interp_rec_unfold (interp_expr M)). *) - (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) - (* rewrite /ir_unf. iIntros (x). simpl. *) - (* rewrite interp_expr_ren. *) - (* iApply f_equivI. *) - (* simp interp_rens_scope interp_var. simpl. *) - (* rewrite !interp_rens_scope_tl_ren. *) - (* iRewrite "IH". *) - (* done. *) - (* - revert D r. induction v=> D r D2; simpl; simp ren_val; eauto. *) - (* (* recursive functions *) *) - (* simp ren_expr. simpl. *) - (* apply bi.siProp.internal_eq_soundness. *) - (* iLöb as "IH". *) - (* rewrite {2}interp_rec_unfold. *) - (* rewrite {2}(interp_rec_unfold (interp_expr e)). *) - (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) - (* rewrite /ir_unf. iIntros (x). simpl. *) - (* rewrite interp_expr_ren. *) - (* iApply f_equivI. *) - (* simp interp_rens_scope interp_var. simpl. *) - (* rewrite !interp_rens_scope_tl_ren. *) - (* iRewrite "IH". *) - (* done. *) - (* Qed. *) + Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S) κ : + interp_expr (fill K e) env κ ≡ (interp_ectx K) (interp_expr e) env κ. + Proof. + revert env. + revert κ. + induction K; simpl; intros κ env; first reflexivity; try (by rewrite IHK). + - f_equiv. + intros ?; simpl. + by rewrite IHK. + - f_equiv. + intros ?; simpl. + by rewrite IHK. + - f_equiv. + intros ?; simpl. + by rewrite IHK. + Qed. - (* Lemma interp_subs_scope_tl_sub {S S2} x D (s : subs S S2) : *) - (* interp_subs_scope ((x, D) : interp_scope (()::S2)) (tl_sub (subs_lift s)) *) - (* ≡ interp_subs_scope D s. *) + (* Lemma interp_val_push {S} v (env : interp_scope S) κ: *) + (* interp_val v env κ ≡ κ (interp_val v env idfun) *) + (* (* with interp_ectx_push {S} k (env : interp_scope S) κ: *) *) + (* (* (λit e : IT, interp_ectx k env κ e) ≡ (κ (λit e : IT, interp_ectx k env idfun e)) *). *) (* Proof. *) - (* induction S as [|[] S]; simp interp_subs_scope; first done. *) - (* f_equiv. *) - (* { unfold hd_sub, tl_sub. simp subs_lift interp_var. *) - (* unfold expr_lift. rewrite interp_expr_ren. f_equiv. *) - (* trans (interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift idren))). *) - (* { f_equiv. intros v. unfold tl_ren. *) - (* simp rens_lift idren. done. } *) - (* rewrite interp_rens_scope_tl_ren. *) - (* apply interp_rens_scope_idren. } *) - (* { rewrite -IHS. f_equiv. clear. *) - (* intros v. dependent elimination v; *) - (* unfold hd_sub, tl_sub; simp subs_lift; auto. } *) - (* Qed. *) + (* { *) + (* destruct v. *) + (* - reflexivity. *) + (* - reflexivity. *) + (* - simpl. *) + (* rewrite !interp_rec_unfold. *) + (* f_equiv. *) + (* simpl. *) + (* repeat f_equiv. *) + (* admit. *) + (* - simpl. *) + (* apply interp_ectx_push. *) - (* Lemma interp_subs_scope_idsub {S} (env : interp_scope S) : *) - (* interp_subs_scope env idsub ≡ env. *) - (* Proof. *) - (* induction S as [|[] S]; simp interp_subs_scope. *) - (* { by destruct env. } *) - (* destruct env as [x env]. *) - (* unfold hd_sub, idsub. simpl. *) - (* simp interp_var. simpl. f_equiv. *) - (* etrans; last first. *) - (* { apply IHS. } *) - (* rewrite -(interp_subs_scope_tl_sub x env idsub). *) - (* repeat f_equiv. intro v. unfold tl_sub, idsub; simpl. *) - (* simp subs_lift. unfold expr_lift. simp ren_expr. done. *) - (* Qed. *) + (* Wrong *) + (* Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') *) + (* : interp_scope S := λne x, interp_val (δ x) env idfun. *) - (* Lemma interp_expr_subst {S D : scope} (M : expr S) (s : subs S D) : *) - (* ∀ (E : interp_scope D), *) - (* interp_expr (subst_expr M s) E ≡ interp_expr M (interp_subs_scope E s) *) - (* with interp_val_subst {S D : scope} (v : val S) (s : subs S D) : *) - (* ∀ (E : interp_scope D), *) - (* interp_val (subst_val v s) E ≡ interp_val v (interp_subs_scope E s). *) + (* Lemma interp_expr_subst {S S'} (env : interp_scope S') (env' : interp_scope S) κ *) + (* (δ : S [⇒] S') (H : env' ≡ sub_scope δ env) e : *) + (* interp_expr (bind δ e) env κ ≡ interp_expr e env' κ *) + (* with interp_val_subst {S S'} (env : interp_scope S') (env' : interp_scope S) κ *) + (* (δ : S [⇒] S') (H : env' ≡ sub_scope δ env) e : *) + (* interp_val (bind δ e) env κ ≡ interp_val e env' κ *) + (* with interp_ectx_subst {S S'} (env : interp_scope S') (env' : interp_scope S) κ φ φ' *) + (* (δ : S [⇒] S') (H : env' ≡ sub_scope δ env) e : *) + (* interp_ectx (bind δ e) φ env κ ≡ interp_ectx e φ' env' κ. *) (* Proof. *) - (* - revert D s. induction M=> D r D2; simpl; simp subst_expr. *) - (* all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). *) - (* + (* variable *) revert r. *) - (* induction v=>r. *) - (* * simp interp_var interp_rens_scope. done. *) - (* * simp interp_var interp_rens_scope. simpl. *) - (* apply (IHv (tl_sub r)). *) - (* + (* recursive functions *) simpl. *) + (* - destruct e; simpl. *) + (* + by apply interp_val_subst. *) + (* + f_equiv. *) + (* * intros ?; simpl; by apply interp_expr_subst. *) + (* * intros ?; simpl; by apply interp_expr_subst. *) + (* + f_equiv. *) + (* * intros ?; simpl; by apply interp_expr_subst. *) + (* * intros ?; simpl; by apply interp_expr_subst. *) + (* + f_equiv. *) + (* * intros ?; simpl; by apply interp_expr_subst. *) + (* * intros ?; simpl. *) + (* f_equiv. *) + (* -- f_equiv; by apply interp_expr_subst. *) + (* -- by apply interp_expr_subst. *) + (* + f_equiv. *) + (* + f_equiv. *) + (* intros ?; simpl; by apply interp_expr_subst. *) + (* + repeat f_equiv. *) + (* intros ?; simpl. *) + (* repeat f_equiv. *) + (* intros ?; simpl; apply interp_expr_subst. *) + (* intros [| x']; simpl. *) + (* * reflexivity. *) + (* * rewrite interp_val_ren. *) + (* -- rewrite (H _). *) + (* simpl. *) + (* reflexivity. *) + (* -- intros ?; by term_simpl. *) + (* + repeat f_equiv. *) + (* * intros ?; simpl; by apply interp_expr_subst. *) + (* * intros ?; simpl; by apply interp_expr_subst. *) + (* - destruct e; simpl. *) + (* + term_simpl. *) + (* rewrite (H _). *) + (* simpl. *) + (* admit. *) + (* + reflexivity. *) + (* + clear -interp_expr_subst H. *) (* apply bi.siProp.internal_eq_soundness. *) + (* iAssert (∀ (S S' : Set) (env : interp_scope S') (env' : interp_scope S) (κ : IT -n> IT) (δ : S [⇒] S'), *) + (* (env' ≡ sub_scope δ env) -∗ ∀ e : expr S, interp_expr (bind δ e) env κ ≡ interp_expr e env' κ)%I as "H". *) + (* { *) + (* iIntros (? ? ? ? ? ?) "G". *) + (* iIntros (?). *) + (* iRewrite "G". *) + (* iPureIntro. *) + (* apply interp_expr_subst. *) + (* reflexivity. *) + (* } *) (* iLöb as "IH". *) (* rewrite {2}interp_rec_unfold. *) - (* rewrite {2}(interp_rec_unfold (interp_expr M)). *) - (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) + (* rewrite {2}(interp_rec_unfold (interp_expr e)). *) + (* do 2 iApply f_equivI. iNext. *) + (* iApply internal_eq_pointwise. *) (* rewrite /ir_unf. iIntros (x). simpl. *) - (* rewrite interp_expr_subst. *) - (* iApply f_equivI. *) - (* simp interp_subs_scope interp_var. simpl. *) - (* rewrite !interp_subs_scope_tl_sub. *) - (* iRewrite "IH". *) - (* done. *) - (* - revert D s. induction v=> D r D2; simpl; simp subst_val; eauto. *) - (* (* recursive functions *) *) - (* simp subst_expr. simpl. *) - (* apply bi.siProp.internal_eq_soundness. *) - (* iLöb as "IH". *) - (* rewrite {2}interp_rec_unfold. *) - (* rewrite {2}(interp_rec_unfold (interp_expr e)). *) - (* iApply f_equivI. iNext. iApply internal_eq_pointwise. *) - (* rewrite /ir_unf. iIntros (x). simpl. *) - (* rewrite interp_expr_subst. *) - (* iApply f_equivI. *) - (* simp interp_subs_scope interp_var. simpl. *) - (* rewrite !interp_subs_scope_tl_sub. *) - (* iRewrite "IH". *) - (* done. *) - (* Qed. *) + (* unshelve iApply ("H" $! (inc (inc S)) (inc (inc S')) _ _ κ _ with "[H]"). *) + (* iApply internal_eq_pointwise. *) + (* iIntros (y'). *) + (* destruct y' as [| [| y]]; simpl; first done. *) + (* * by iRewrite - "IH". *) + (* * rewrite (H _). *) + (* simpl. *) + (* rewrite interp_val_ren. *) + (* 2: reflexivity. *) + (* { *) + (* rewrite interp_val_ren. *) + (* - iPureIntro. reflexivity. *) + (* - intros z; simpl. *) + (* reflexivity. *) + (* } *) + (* + repeat f_equiv. *) + (* intros ?; simpl. *) + (* by apply interp_ectx_subst. *) + (* - admit. *) + (* Admitted. *) - (* (** ** Interpretation is a homomorphism *) *) - (* #[global] Instance interp_ectx_item_hom {S} (Ki : ectx_item S) env : *) - (* IT_hom (interp_ctx_item Ki env). *) - (* Proof. destruct Ki; simpl; apply _. Qed. *) - (* #[global] Instance interp_ectx_hom {S} (K : ectx S) env : *) - (* IT_hom (interp_ectx K env). *) - (* Proof. induction K; simpl; apply _. Qed. *) - - (* (** ** Finally, preservation of reductions *) *) - (* Lemma interp_expr_head_step {S} env (e : expr S) e' σ σ' n : *) - (* head_step e σ e' σ' (n,0) → *) - (* interp_expr e env ≡ Tick_n n $ interp_expr e' env. *) - (* Proof. *) - (* inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. *) - (* - (*fun->val*) *) - (* reflexivity. *) - (* - (* app lemma *) *) - (* rewrite APP_APP'_ITV. *) - (* trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). *) - (* { repeat f_equiv. apply interp_rec_unfold. } *) - (* rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. *) - (* simplify_eq. *) - (* rewrite interp_expr_subst. f_equiv. *) - (* simp interp_subs_scope. unfold hd_sub, tl_sub. simp conssub. *) - (* simpl. repeat f_equiv. *) - (* generalize (Val (RecV e1)). *) - (* generalize (Val v2). *) - (* clear. *) - (* intros e1 e2. *) - (* trans (interp_subs_scope env idsub); last first. *) - (* { f_equiv. intro v. simp conssub. done. } *) - (* symmetry. *) - (* apply interp_subs_scope_idsub. *) - (* - (* the natop stuff *) *) - (* simplify_eq. *) - (* destruct v1,v2; try naive_solver. simpl in *. *) - (* rewrite NATOP_Ret. *) - (* destruct op; simplify_eq/=; done. *) - (* - by rewrite IF_True. *) - (* - rewrite IF_False; eauto. lia. *) - (* Qed. *) + (** ** Finally, preservation of reductions *) + Lemma interp_expr_head_step {S} env (e : expr S) e' σ σ' K n κ : + head_step e σ e' σ' K (n, 0) → + interp_expr e env κ ≡ Tick_n n $ interp_expr e' env κ. + Proof. + inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. + - (* app lemma *) + subst. + admit. + (* rewrite !interp_expr_subst; [| reflexivity | reflexivity]. *) + (* trans (APP (Fun (Next (ir_unf (interp_expr e1) env κ))) (Next $ interp_val v2 env κ)). *) + (* + rewrite interp_rec_unfold. *) + (* simpl. *) + (* admit. *) + (* + rewrite APP_Fun. simpl. rewrite Tick_eq. do 4 f_equiv. *) + (* intros [| [| x]]; term_simpl. *) + (* * rewrite interp_val_ren. *) + (* -- admit. *) + (* -- reflexivity. *) + (* * admit. *) + (* * reflexivity. *) + - (* the natop stuff *) + simplify_eq. + destruct v1,v2; try naive_solver. simpl in *. + rewrite NATOP_Ret. + destruct op; simplify_eq/=; done. + - subst. + rewrite IF_True; last lia. + reflexivity. + - subst. + rewrite IF_False; last lia. + reflexivity. + - subst. + admit. + Admitted. - (* Lemma interp_expr_fill_no_reify {S} K env (e e' : expr S) σ σ' n : *) - (* head_step e σ e' σ' (n,0) → *) + (* Lemma interp_expr_fill_no_reify {S} K env (e e' : expr S) σ σ' K n : *) + (* head_step e σ e' σ' K (n, 0) → *) (* interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. *) (* Proof. *) (* intros He. *) @@ -659,49 +1015,57 @@ Section interp. (* simpl. done. *) (* Qed. *) - (* Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m env : *) - (* prim_step e1 σ1 e2 σ2 (n,m) → *) - (* ssteps (gReifiers_sReifier rs) *) - (* (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) *) - (* (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. *) - (* Proof. *) - (* Opaque gState_decomp gState_recomp. *) - (* inversion 1; simplify_eq/=. *) - (* destruct (head_step_io_01 _ _ _ _ _ _ H2); subst. *) - (* - assert (σ1 = σ2) as ->. *) - (* { eapply head_step_no_io; eauto. } *) - (* eapply (interp_expr_fill_no_reify K) in H2. *) - (* rewrite H2. eapply ssteps_tick_n. *) - (* - inversion H2;subst. *) - (* + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) - (* rewrite interp_ectx_fill. *) - (* rewrite hom_INPUT. *) - (* change 1 with (1+0). econstructor; last first. *) - (* { apply ssteps_zero; reflexivity. } *) - (* eapply sstep_reify. *) - (* { Transparent INPUT. unfold INPUT. simpl. *) - (* f_equiv. reflexivity. } *) - (* simpl in H2. *) - (* rewrite -H2. *) - (* repeat f_equiv; eauto. *) - (* rewrite interp_ectx_fill hom_INPUT. *) - (* eauto. *) - (* + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) - (* rewrite interp_ectx_fill. simpl. *) - (* rewrite get_ret_ret. *) - (* rewrite hom_OUTPUT_. *) - (* change 1 with (1+0). econstructor; last first. *) - (* { apply ssteps_zero; reflexivity. } *) - (* eapply sstep_reify. *) - (* { Transparent OUTPUT_. unfold OUTPUT_. simpl. *) - (* f_equiv. reflexivity. } *) - (* simpl in H2. *) - (* rewrite -H2. *) - (* repeat f_equiv; eauto. *) - (* Opaque OUTPUT_. *) - (* rewrite interp_ectx_fill /= get_ret_ret hom_OUTPUT_. *) - (* eauto. *) - (* Qed. *) + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m env κ : + prim_step e1 σ1 e2 σ2 (n,m) → + ssteps (gReifiers_sReifier rs) + (interp_expr e1 env κ) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env κ) (gState_recomp σr (sR_state σ2)) n. + Proof. + Opaque gState_decomp gState_recomp. + inversion 1; simplify_eq/=. + { + destruct (head_step_io_01 _ _ _ _ _ _ _ H2); subst. + - assert (σ1 = σ2) as ->. + { eapply head_step_no_io; eauto. } + admit. + (* eapply (interp_expr_fill_no_reify K) in H2. *) + (* rewrite H2. eapply ssteps_tick_n. *) + - inversion H2;subst. + + (* eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) + (* rewrite interp_ectx_fill. *) + (* rewrite hom_INPUT. *) + (* change 1 with (1+0). econstructor; last first. *) + (* { apply ssteps_zero; reflexivity. } *) + (* eapply sstep_reify. *) + (* { Transparent INPUT. unfold INPUT. simpl. *) + (* f_equiv. reflexivity. } *) + (* simpl in H2. *) + (* rewrite -H2. *) + (* repeat f_equiv; eauto. *) + (* rewrite interp_ectx_fill hom_INPUT. *) + (* eauto. *) + admit. + + (* eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) + (* rewrite interp_ectx_fill. simpl. *) + (* rewrite get_ret_ret. *) + (* rewrite hom_OUTPUT_. *) + (* change 1 with (1+0). econstructor; last first. *) + (* { apply ssteps_zero; reflexivity. } *) + (* eapply sstep_reify. *) + (* { Transparent OUTPUT_. unfold OUTPUT_. simpl. *) + (* f_equiv. reflexivity. } *) + (* simpl in H2. *) + (* rewrite -H2. *) + (* repeat f_equiv; eauto. *) + (* Opaque OUTPUT_. *) + (* rewrite interp_ectx_fill /= get_ret_ret hom_OUTPUT_. *) + (* eauto. *) + admit. + } + { + + } + Qed. End interp. #[global] Opaque INPUT OUTPUT_. diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index 5dc84c8..1740760 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -376,7 +376,7 @@ Inductive head_step {S} : expr S → state → expr S → state → ectx S → n head_step (If (Val (LitV n)) e1 e2) σ e2 σ K (0, 0) | CallccS e σ K : - head_step (Callcc e) σ (subst (Inc := inc) e (ContV K)) σ K (0, 0) + head_step (Callcc e) σ (subst (Inc := inc) e (ContV K)) σ K (1, 0) . Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : diff --git a/theories/lang_generic_sem.v b/theories/lang_generic_sem.v index 22caf4b..609e75e 100644 --- a/theories/lang_generic_sem.v +++ b/theories/lang_generic_sem.v @@ -3,7 +3,7 @@ From gitrees Require Import gitree. Require Import List. Import ListNotations. -Require Import Binding.Lib. +Require Import Binding.Lib Binding.Set. From Equations Require Import Equations. Section interp. @@ -43,6 +43,9 @@ Section interp. intros [| a]; simpl; solve_proper. Qed. + Program Definition ren_scope {S S'} (δ : S [→] S') (env : interp_scope S') + : interp_scope S := λne x, env (δ x). + (* (** scope substituions *) *) (* Inductive ssubst : Set → Type := *) (* | emp_ssubst : ssubst ∅ *) From 3c9ea91dc9daefc32d84a442c85495395a33462b Mon Sep 17 00:00:00 2001 From: Kaptch Date: Fri, 17 Nov 2023 16:04:13 +0100 Subject: [PATCH 017/114] non-cps --- theories/input_lang_callcc/interp.v | 1120 +++++++++------------------ theories/input_lang_callcc/lang.v | 2 +- 2 files changed, 379 insertions(+), 743 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index c3a71d6..3368fc5 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -24,7 +24,7 @@ Program Definition callccE : opInterp := {| Program Definition throwE : opInterp := {| Ins := (▶ ∙ * (▶ (∙ -n> ∙))); - Outs := unitO; + Outs := Empty_setO; |}. Definition ioE := @[inputE;outputE;callccE;throwE]. @@ -51,7 +51,7 @@ Proof. + apply Hs'. - simple refine (λne (us : prodO (prodO ((laterO X -n> laterO X) -n> laterO X) stateO) (laterO X -n> laterO X)), Some $ ((fstO (fstO us)) (sndO us), sndO (fstO us))). solve_proper. - - simple refine (λne (us : prodO (prodO (prodO (laterO X) (laterO (X -n> X))) stateO) (unitO -n> laterO X)), Some (laterO_ap us.1.1.2 us.1.1.1, sndO (fstO us))). + - simple refine (λne (us : prodO (prodO (prodO (laterO X) (laterO (X -n> X))) stateO) (Empty_setO -n> laterO X)), Some (laterO_ap us.1.1.2 us.1.1.1, sndO (fstO us))). intros ????. repeat f_equiv; assumption. Defined. @@ -63,34 +63,11 @@ Section constructors. Notation IT := (IT E A). Notation ITV := (ITV E A). - Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> (laterO IT -n> laterO IT) -n> IT := - λne e k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) - (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) e) - (λne o, (k ((subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o))). - Next Obligation. - intros. - intros ???. - by do 2 f_equiv. - Qed. - Next Obligation. - intros. - intros ???. - f_equiv. - intros ?; simpl. - by do 1 f_equiv. - Qed. - Next Obligation. - intros ?????; simpl. - by do 2 f_equiv. - Qed. - - Lemma hom_CALLCC e k f `{!IT_hom f} : f (CALLCC e k) ≡ CALLCC e (laterO_map (OfeMor f) ◎ k). - Proof. - unfold CALLCC. - rewrite hom_vis/=. repeat f_equiv. - intro x. cbn-[laterO_map]. - f_equiv. - Qed. + Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := + λne k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) + (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) k) + (λne o, (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o). + Solve All Obligations with solve_proper. Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) (subEff_ins (F:=ioE) (op:=(inl ())) ()) @@ -184,59 +161,7 @@ Section weakestpre. { simpl. done. } iModIntro. iIntros "H1 H2". iApply wp_val. by iApply ("Ha" with "H1 H2"). - Unshelve. - simpl; constructor. - Qed. - - (* wp_subreify *) - (* Lemma wp_callcc (σ : stateO) (e : (laterO IT -n> laterO IT) -n> laterO IT) (k : laterO IT -n> laterO IT) Φ s : *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} (later_car (k (e k))) @ s {{ Φ }}) -∗ *) - (* WP@{rs} (CALLCC e k) @ s {{ Φ }}. *) - (* Proof. *) - (* iIntros "Hs Ha". *) - (* unfold CALLCC. simpl. *) - (* iApply (wp_subreify with "Hs"). *) - (* { *) - (* simpl. *) - (* do 2 f_equiv; last reflexivity. *) - (* Unshelve. *) - (* 3: apply (k (e k)). *) - (* 2: simpl; apply (e k). *) - (* simpl. *) - (* rewrite ofe_iso_21. *) - (* admit. *) - (* } *) - (* { *) - (* simpl. *) - (* rewrite ofe_iso_21. *) - (* f_equiv. *) - (* } *) - (* iModIntro. *) - (* iApply "Ha". *) - (* Admitted. *) - - Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ - WP@{rs} (THROW x f) @ s {{ Φ }}. - Proof. - iIntros "Hs Ha". - unfold THROW. simpl. - iApply (wp_subreify with "Hs"). - { - simpl. - do 2 f_equiv; reflexivity. - } - { - simpl. - reflexivity. - } - iModIntro. - iApply "Ha". - Unshelve. - simpl. - constructor. + Unshelve. simpl; constructor. Qed. End weakestpre. @@ -245,455 +170,158 @@ Section interp. Context {sz : nat}. Variable (rs : gReifiers sz). Context {subR : subReifier reify_io rs}. - Context {R} `{!Cofe R}. + Context {R} `{CR : !Cofe R}. Context `{!SubOfe natO R}. Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). Context {subEff0 : subEff ioE F}. - (** Interpreting individual operators *) - Program Definition interp_input {A} : A -n> (IT -n> IT) -n> IT := - λne env κ, κ (INPUT Ret). - Solve All Obligations with solve_proper. + Program Definition interp_input {A} : A -n> IT := + λne env, INPUT Ret. + Program Definition interp_output {A} (t : A -n> IT) : A -n> IT := + get_ret OUTPUT ◎ t. + Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). + Proof. solve_proper. Qed. - Program Definition interp_output {A} (t : A -n> (IT -n> IT) -n> IT) : A -n> (IT -n> IT) -n> IT := - λne env κ, t env (λne x, κ ((get_ret OUTPUT x))). - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - by repeat f_equiv. - Qed. - - Program Definition interp_callcc {S} (e : @interp_scope F R _ (inc S) -n> (IT -n> IT) -n> IT) - : interp_scope S -n> (IT -n> IT) -n> IT := λne env κ, CALLCC (λne (f : laterO IT -n> laterO IT), f (Next (e (@extend_scope F R _ _ env (Fun (Next κ))) κ))) (laterO_ap (Next κ)). + Program Definition interp_callcc {S} (e : @interp_scope F R _ (inc S) -n> IT) + : interp_scope S -n> IT := λne env, CALLCC (λne (f : laterO IT -n> laterO IT), (Next (e (@extend_scope F R _ _ env (Fun (Next (λne x, Tau (f (Next x))))))))). Next Obligation. solve_proper. Qed. - Next Obligation. - intros; intros ???. - repeat f_equiv. - - intros a; simpl. - repeat f_equiv; [| assumption]. - intros [| ?]; simpl; solve_proper. - - assumption. - Qed. - Next Obligation. - intros; intros ????; simpl. - repeat f_equiv; intros ?; simpl. - repeat f_equiv. - intros [| ?]; simpl; solve_proper. - Qed. - - Program Definition interp_throw {A} (n : A -n> (IT -n> IT) -n> IT) (m : A -n> (IT -n> IT) -n> IT) - : A -n> (IT -n> IT) -n> IT := λne env κ, n env (λne n', m env (λne m', get_fun (λne (f : laterO (IT -n> IT)), THROW n' f) m')). - Next Obligation. - intros ???????????. - f_equiv; assumption. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv; last done. - Qed. Next Obligation. solve_proper_prepare. repeat f_equiv. - intros ?; simpl. + intros [| a]; simpl; last solve_proper. repeat f_equiv. intros ?; simpl. - repeat f_equiv; first done. - intros ?; simpl. by repeat f_equiv. Qed. Next Obligation. solve_proper_prepare. repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. - Qed. - - Global Instance interp_throw_ne A : NonExpansive2 (@interp_throw A). - Proof. - solve_proper_prepare. - repeat f_equiv; first done. intros ?; simpl. - repeat f_equiv; first done. - Qed. - Typeclasses Opaque interp_throw. - - Program Definition interp_natop {A} (op : nat_op) (t1 t2 : A -n> (IT -n> IT) -n> IT) : A -n> (IT -n> IT) -n> IT := - λne env κ, (t1 env (λne n, t2 env (λne m, κ (NATOP (do_natop op) n m)))). - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - f_equiv. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. repeat f_equiv. - intros ?; simpl. + intros [| a]; simpl; last solve_proper. repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. Qed. + + Program Definition interp_throw {A} (n : A -n> IT) (m : A -n> IT) + : A -n> IT := λne env, get_fun (λne (f : laterO (IT -n> IT)), THROW (n env) f) (m env). Next Obligation. - solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. + intros ????. + intros n' x y H. + f_equiv; assumption. Qed. + 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). + Solve All Obligations with solve_proper_please. + Global Instance interp_natop_ne A op : NonExpansive2 (@interp_natop A op). - Proof. - solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. - Qed. + Proof. solve_proper. Qed. Typeclasses Opaque interp_natop. Opaque laterO_map. - - Program Definition interp_app {A} (t1 t2 : A -n> (IT -n> IT) -n> IT) : A -n> (IT -n> IT) -n> IT := - λne env κ, t1 env (λne m, t2 env (λne n, κ (APP' m n))). - Next Obligation. - solve_proper. - Qed. - Next Obligation. - solve_proper_please. - Qed. - Next Obligation. - intros; intros ???. - f_equiv; intros ?; simpl. - f_equiv; intros ?; simpl. - by f_equiv. - Qed. - Next Obligation. - solve_proper_please. - Qed. - - Typeclasses Opaque interp_app. - - Program Definition interp_if {A} (t0 t1 t2 : A -n> (IT -n> IT) -n> IT) : A -n> (IT -n> IT) -n> IT := - λne env κ, (t0 env (λne b, (IF b (t1 env κ) (t2 env κ)))). - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - f_equiv. - intros ?; simpl; solve_proper. - Qed. + Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) + : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := + λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), + body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. Next Obligation. + intros. solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. - Qed. - - Global Instance interp_if_ne A n : - Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). - Proof. - solve_proper_prepare. - repeat f_equiv; first solve_proper. - intros ?; simpl. - repeat f_equiv; solve_proper. + f_equiv; intros [| [| y']]; simpl; solve_proper. Qed. - - Program Definition interp_nat (n : nat) {A} : A -n> (IT -n> IT) -n> IT := - λne env κ, κ (Ret n). - Solve All Obligations with solve_proper. - - Program Definition interp_var' {S : Set} (v : S) : interp_scope S -n> (IT -n> IT) -n> IT := - λne (f : interp_scope S) κ, κ (interp_var v f). - Solve All Obligations with solve_proper. - - Program Definition interp_emptyk {A} : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) := λne φ env κ, φ env κ. - Solve All Obligations with try solve_proper. - - Program Definition interp_outputk {A} (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) := λne φ env κ, interp_output (K φ) env κ. - Solve All Obligations with try solve_proper. Next Obligation. + intros. solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. + f_equiv; intros [| [| y']]; simpl; solve_proper. Qed. Next Obligation. + intros. solve_proper_prepare. - by repeat f_equiv. + do 3 f_equiv; intros ??; simpl; f_equiv; + intros [| [| y']]; simpl; solve_proper. Qed. Next Obligation. + intros. solve_proper_prepare. - by repeat f_equiv. + by do 2 f_equiv. Qed. - Program Definition interp_ifk {A} (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) - (q : A -n> (IT -n> IT) -n> IT) - (p : A -n> (IT -n> IT) -n> IT) - : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) - := λne φ env κ, interp_if (K φ) q p env κ. - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - by repeat f_equiv. - Qed. + Program Definition interp_rec {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) : @interp_scope F R _ S -n> IT := mmuu (interp_rec_pre body). - Program Definition interp_applk {A} (q : A -n> (IT -n> IT) -n> IT) - (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) - : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) - := λne φ env κ, interp_app q (K φ) env κ. - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. - Qed. + Program Definition ir_unf {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (@extend_scope F R _ _ (@extend_scope F R _ _ env (interp_rec body env)) a). Next Obligation. + intros. solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. + f_equiv. intros [| [| y']]; simpl; solve_proper. Qed. - Program Definition interp_apprk {A} (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) - (q : A -n> (IT -n> IT) -n> IT) - : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) - := λne φ env κ, interp_app (K φ) q env κ. - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - by repeat f_equiv. + Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : + interp_rec body env ≡ Fun $ Next $ ir_unf body env. + Proof. + trans (interp_rec_pre body (Next (interp_rec body)) env). + { f_equiv. rewrite /interp_rec. apply mmuu_unfold. } + simpl. rewrite laterO_map_Next. repeat f_equiv. + simpl. unfold ir_unf. intro. simpl. reflexivity. Qed. - Program Definition interp_natoplk {A} (op : nat_op) - (q : A -n> (IT -n> IT) -n> IT) - (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) - : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) - := λne φ env κ, interp_natop op q (K φ) env κ. - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. - 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 ]. + Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_app. - Program Definition interp_natoprk {A} (op : nat_op) - (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) - (q : A -n> (IT -n> IT) -n> IT) - : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) - := λne φ env κ, interp_natop op (K φ) q env κ. - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - by repeat f_equiv. - Qed. + Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := + λne env, IF (t0 env) (t1 env) (t2 env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_if_ne A n : + Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). + Proof. solve_proper. Qed. - Program Definition interp_throwlk {A} - (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) - (q : A -n> (IT -n> IT) -n> IT) - : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) - := λne φ env κ, interp_throw (K φ) q env κ. - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - by repeat f_equiv. - Qed. + Program Definition interp_nat (n : nat) {A} : A -n> IT := + λne env, Ret n. - Program Definition interp_throwrk {A} - (q : A -n> (IT -n> IT) -n> IT) - (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) - : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT) - := λne φ env κ, interp_throw q (K φ) env κ. - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - repeat f_equiv; first done. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. - Qed. + Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := λne env, Fun (Next (K env)). + Solve All Obligations with solve_proper. - (* Wrong *) - Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> (IT -n> IT) -n> IT) - : laterO (@interp_scope F R _ S -n> (IT -n> IT) -n> IT) -n> @interp_scope F R _ S -n> (IT -n> IT) -n> IT := - λne self env κ, - κ (Fun $ laterO_map (λne - (self : @interp_scope F R _ S -n> (IT -n> IT) -n> IT) - (a : IT), - body - (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env κ)) a) - κ - ) self). - Next Obligation. - intros. - solve_proper_prepare. - do 2 f_equiv; intros [| [| y']]; simpl; solve_proper. - Qed. - Next Obligation. - intros. - solve_proper_prepare. - do 2 f_equiv; intros [| [| y']]; simpl; solve_proper. - Qed. - Next Obligation. - intros. - solve_proper_prepare. - f_equiv; [assumption |]. - do 3 f_equiv; intros ??; simpl; f_equiv. - - f_equiv; intros [| [| y']]; simpl; solve_proper. - - assumption. - Qed. - Next Obligation. - intros. - solve_proper_prepare. - do 4 f_equiv; intros ??; simpl. - do 2 f_equiv; intros [| [| y']]; simpl; solve_proper. - Qed. - Next Obligation. - intros. - solve_proper_prepare. - by do 3 f_equiv. - Qed. + Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_app q (λne env, K env t) env. + Solve All Obligations with solve_proper. - Program Definition interp_rec {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> (IT -n> IT) -n> IT) : @interp_scope F R _ S -n> (IT -n> IT) -n> IT := mmuu (interp_rec_pre body). + Program Definition interp_apprk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_app (λne env, K env t) q env. + Solve All Obligations with solve_proper. - Program Definition ir_unf {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> (IT -n> IT) -n> IT) env κ : IT -n> IT := - λne a, body (@extend_scope F R _ _ (@extend_scope F R _ _ env (interp_rec body env κ)) a) κ. - Next Obligation. - intros. - solve_proper_prepare. - repeat f_equiv; intros [| [| y']]; simpl; solve_proper. - Qed. + Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_natop op q (λne env, K env t) env. + Solve All Obligations with solve_proper. - Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> (IT -n> IT) -n> IT) env κ : - interp_rec body env κ ≡ κ $ Fun $ Next $ ir_unf body env κ. - Proof. - trans (interp_rec_pre body (Next (interp_rec body)) env κ). - { do 2 f_equiv. rewrite /interp_rec. apply mmuu_unfold. } - simpl. rewrite laterO_map_Next. repeat f_equiv. - simpl. unfold ir_unf. simpl. - intro. simpl. reflexivity. - Qed. + Program Definition interp_natoprk {A} (op : nat_op) (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_natop op (λne env, K env t) q env. + Solve All Obligations with solve_proper. - (* Wrong *) - Program Definition interp_cont {A} - (K : (A -n> (IT -n> IT) -n> IT) -n> (A -n> (IT -n> IT) -n> IT)) - : A -n> (IT -n> IT) -n> IT - := λne env κ, Fun (Next (λne e, K (λne _ _, e) env κ)). - Solve All Obligations with try solve_proper. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - by intros ??; simpl. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. - Qed. + Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) (p : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_if (λne env, K env t) q p env. + Solve All Obligations with solve_proper. + + Program Definition interp_outputk {A} (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_output (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_throw (λne env, K env t) q env. + Solve All Obligations with solve_proper_please. + + Program Definition interp_throwrk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_throw q (λne env, K env t) env. + Solve All Obligations with solve_proper_please. (** Interpretation for all the syntactic categories: values, expressions, contexts *) - Fixpoint interp_val {S} (v : val S) : interp_scope S -n> (IT -n> IT) -n> IT := + Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := match v with | LitV n => interp_nat n - | VarV x => interp_var' x + | VarV x => interp_var x | RecV e => interp_rec (interp_expr e) | ContV K => interp_cont (interp_ectx K) end - with interp_expr {S} (e : expr S) : interp_scope S -n> (IT -n> IT) -n> IT := + with interp_expr {S} (e : expr S) : interp_scope S -n> IT := match e with | Val v => interp_val v | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) @@ -704,9 +332,9 @@ Section interp. | Callcc e => interp_callcc (interp_expr e) | Throw e1 e2 => interp_throw (interp_expr e1) (interp_expr e2) end - with interp_ectx {S} (K : ectx S) : (interp_scope S -n> (IT -n> IT) -n> IT) -n> (interp_scope S -n> (IT -n> IT) -n> IT) := + with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := match K with - | EmptyK => interp_emptyk + | EmptyK => λne env, λne t, t | AppLK e1 K => interp_applk (interp_expr e1) (interp_ectx K) | AppRK K v2 => interp_apprk (interp_ectx K) (interp_val v2) | NatOpLK op e1 K => interp_natoplk op (interp_expr e1) (interp_ectx K) @@ -718,9 +346,8 @@ Section interp. end. Solve All Obligations with first [ solve_proper | solve_proper_please ]. - #[global] Instance interp_val_asval {S} (v : val S) (D : interp_scope S) - (H : ∀ (x : S), AsVal (D x)) - : AsVal (interp_val v D idfun). + Global Instance interp_val_asval {S} {D : interp_scope S} {H : ∀ (x : S), AsVal (D x)} (v : val S) + : AsVal (interp_val v D). Proof. destruct v; simpl. - apply H. @@ -729,297 +356,308 @@ Section interp. - apply _. Qed. - Lemma interp_expr_ren {S S'} env env' κ - (δ : S [→] S') (H : env' ≡ (ren_scope δ env)) e : - interp_expr (fmap δ e) env κ ≡ interp_expr e env' κ - with interp_val_ren {S S'} env env' κ - (δ : S [→] S') (H : env' ≡ (ren_scope δ env)) e : - interp_val (fmap δ e) env κ ≡ interp_val e env' κ - with interp_ectx_ren {S S'} env env' κ φ φ' - (δ : S [→] S') (H : env' ≡ (ren_scope δ env)) e : - interp_ectx (fmap δ e) φ env κ ≡ interp_ectx e φ' env' κ. + Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := fun f g => ∀ x, f x = g x. + + Global Instance ArrDist {A B : Set} `{Dist B} : Dist (A [→] B) := fun n => fun f g => ∀ x, f x ≡{n}≡ g x. + + Global Instance ren_scope_proper S S2 : + Proper ((≡) ==> (≡) ==> (≡)) (@ren_scope F _ CR S S2). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - apply Hs. + - apply HE. + Qed. + + Lemma interp_expr_ren {S S'} env + (δ : S [→] S') (e : expr S) : + interp_expr (fmap δ e) env ≡ interp_expr e (ren_scope δ env) + with interp_val_ren {S S'} env + (δ : S [→] S') (e : val S) : + interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env) + with interp_ectx_ren {S S'} env + (δ : S [→] S') (e : ectx S) : + interp_ectx (fmap δ e) env ≡ interp_ectx e (ren_scope δ env). Proof. - destruct e; simpl. + by apply interp_val_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + f_equiv. - * intros ?; by apply interp_expr_ren. - * intros ?; simpl; by apply interp_expr_ren. - + repeat f_equiv. - * intros ?; simpl; by apply interp_expr_ren. - * intros ?; simpl; by apply interp_expr_ren. - + repeat f_equiv. - * intros ?; by apply interp_expr_ren. - * intros ?; simpl. - repeat f_equiv. - -- intros ?; simpl; by apply interp_expr_ren. - -- intros ?; simpl; by apply interp_expr_ren. - + f_equiv. - + repeat f_equiv. - intros ?; simpl; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + repeat f_equiv. intros ?; simpl. repeat f_equiv. - intros ?; simpl; apply interp_expr_ren. + simpl; rewrite interp_expr_ren. + f_equiv. intros [| y]; simpl. * reflexivity. - * specialize (H y). - apply H. + * reflexivity. + repeat f_equiv. * intros ?; simpl. - repeat f_equiv. - intros ?; simpl; by apply interp_expr_ren. - * intros ?; simpl; by apply interp_expr_ren. + repeat f_equiv; first by apply interp_expr_ren. + intros ?; simpl. + repeat f_equiv; by apply interp_expr_ren. + * by apply interp_expr_ren. - destruct e; simpl. - + f_equiv. - rewrite (H _). - reflexivity. + reflexivity. - + clear -interp_expr_ren H. + + reflexivity. + + clear -interp_expr_ren. apply bi.siProp.internal_eq_soundness. - iAssert (∀ (S S' : Set) (env : interp_scope S') (env' : interp_scope S) (κ : IT -n> IT) (δ : S [→] S'), - env' ≡ ren_scope δ env -∗ ∀ e : expr S, interp_expr (fmap δ e) env κ ≡ interp_expr e env' κ)%I as "H". - { - iIntros (? ? ? ? ? ?) "G". - iIntros (?). - iRewrite "G". - iPureIntro. - apply interp_expr_ren. - reflexivity. - } iLöb as "IH". rewrite {2}interp_rec_unfold. rewrite {2}(interp_rec_unfold (interp_expr e)). - do 2 iApply f_equivI. iNext. + do 1 iApply f_equivI. iNext. iApply internal_eq_pointwise. rewrite /ir_unf. iIntros (x). simpl. - unshelve iApply ("H" $! (inc (inc S)) (inc (inc S')) _ _ κ _ with "[H]"). + rewrite interp_expr_ren. + iApply f_equivI. iApply internal_eq_pointwise. iIntros (y'). destruct y' as [| [| y]]; simpl; first done. * by iRewrite - "IH". - * by rewrite (H _). + * done. + repeat f_equiv. intros ?; simpl; by apply interp_ectx_ren. - - admit. - Admitted. - - Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S) κ : - interp_expr (fill K e) env κ ≡ (interp_ectx K) (interp_expr e) env κ. + - destruct e; simpl; intros ?; simpl. + + reflexivity. + + repeat f_equiv; by apply interp_ectx_ren. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_expr_ren | by apply interp_expr_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + + repeat f_equiv; last by apply interp_expr_ren. + intros ?; simpl; repeat f_equiv; first by apply interp_ectx_ren. + intros ?; simpl; repeat f_equiv; by apply interp_ectx_ren. + + repeat f_equiv; last by apply interp_ectx_ren. + intros ?; simpl; repeat f_equiv; first by apply interp_val_ren. + intros ?; simpl; repeat f_equiv; by apply interp_val_ren. + Qed. + + Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): + interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). Proof. revert env. - revert κ. - induction K; simpl; intros κ env; first reflexivity; try (by rewrite IHK). - - f_equiv. - intros ?; simpl. + induction K; simpl; intros env; first reflexivity; try (by rewrite IHK). + - repeat f_equiv. by rewrite IHK. - - f_equiv. - intros ?; simpl. + - repeat f_equiv. by rewrite IHK. - - f_equiv. - intros ?; simpl. + - repeat f_equiv. by rewrite IHK. + - repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + + by rewrite IHK. + + intros ?; simpl. + repeat f_equiv. + by rewrite IHK. Qed. - (* Lemma interp_val_push {S} v (env : interp_scope S) κ: *) - (* interp_val v env κ ≡ κ (interp_val v env idfun) *) - (* (* with interp_ectx_push {S} k (env : interp_scope S) κ: *) *) - (* (* (λit e : IT, interp_ectx k env κ e) ≡ (κ (λit e : IT, interp_ectx k env idfun e)) *). *) - (* Proof. *) - (* { *) - (* destruct v. *) - (* - reflexivity. *) - (* - reflexivity. *) - (* - simpl. *) - (* rewrite !interp_rec_unfold. *) - (* f_equiv. *) - (* simpl. *) - (* repeat f_equiv. *) - (* admit. *) - (* - simpl. *) - (* apply interp_ectx_push. *) + Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') + : interp_scope S := λne x, interp_val (δ x) env. - (* Wrong *) - (* Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') *) - (* : interp_scope S := λne x, interp_val (δ x) env idfun. *) + Global Instance SubEquiv {A B : Set} : Equiv (A [⇒] B) := fun f g => ∀ x, f x = g x. - (* Lemma interp_expr_subst {S S'} (env : interp_scope S') (env' : interp_scope S) κ *) - (* (δ : S [⇒] S') (H : env' ≡ sub_scope δ env) e : *) - (* interp_expr (bind δ e) env κ ≡ interp_expr e env' κ *) - (* with interp_val_subst {S S'} (env : interp_scope S') (env' : interp_scope S) κ *) - (* (δ : S [⇒] S') (H : env' ≡ sub_scope δ env) e : *) - (* interp_val (bind δ e) env κ ≡ interp_val e env' κ *) - (* with interp_ectx_subst {S S'} (env : interp_scope S') (env' : interp_scope S) κ φ φ' *) - (* (δ : S [⇒] S') (H : env' ≡ sub_scope δ env) e : *) - (* interp_ectx (bind δ e) φ env κ ≡ interp_ectx e φ' env' κ. *) - (* Proof. *) - (* - destruct e; simpl. *) - (* + by apply interp_val_subst. *) - (* + f_equiv. *) - (* * intros ?; simpl; by apply interp_expr_subst. *) - (* * intros ?; simpl; by apply interp_expr_subst. *) - (* + f_equiv. *) - (* * intros ?; simpl; by apply interp_expr_subst. *) - (* * intros ?; simpl; by apply interp_expr_subst. *) - (* + f_equiv. *) - (* * intros ?; simpl; by apply interp_expr_subst. *) - (* * intros ?; simpl. *) - (* f_equiv. *) - (* -- f_equiv; by apply interp_expr_subst. *) - (* -- by apply interp_expr_subst. *) - (* + f_equiv. *) - (* + f_equiv. *) - (* intros ?; simpl; by apply interp_expr_subst. *) - (* + repeat f_equiv. *) - (* intros ?; simpl. *) - (* repeat f_equiv. *) - (* intros ?; simpl; apply interp_expr_subst. *) - (* intros [| x']; simpl. *) - (* * reflexivity. *) - (* * rewrite interp_val_ren. *) - (* -- rewrite (H _). *) - (* simpl. *) - (* reflexivity. *) - (* -- intros ?; by term_simpl. *) - (* + repeat f_equiv. *) - (* * intros ?; simpl; by apply interp_expr_subst. *) - (* * intros ?; simpl; by apply interp_expr_subst. *) - (* - destruct e; simpl. *) - (* + term_simpl. *) - (* rewrite (H _). *) - (* simpl. *) - (* admit. *) - (* + reflexivity. *) - (* + clear -interp_expr_subst H. *) - (* apply bi.siProp.internal_eq_soundness. *) - (* iAssert (∀ (S S' : Set) (env : interp_scope S') (env' : interp_scope S) (κ : IT -n> IT) (δ : S [⇒] S'), *) - (* (env' ≡ sub_scope δ env) -∗ ∀ e : expr S, interp_expr (bind δ e) env κ ≡ interp_expr e env' κ)%I as "H". *) - (* { *) - (* iIntros (? ? ? ? ? ?) "G". *) - (* iIntros (?). *) - (* iRewrite "G". *) - (* iPureIntro. *) - (* apply interp_expr_subst. *) - (* reflexivity. *) - (* } *) - (* iLöb as "IH". *) - (* rewrite {2}interp_rec_unfold. *) - (* rewrite {2}(interp_rec_unfold (interp_expr e)). *) - (* do 2 iApply f_equivI. iNext. *) - (* iApply internal_eq_pointwise. *) - (* rewrite /ir_unf. iIntros (x). simpl. *) - (* unshelve iApply ("H" $! (inc (inc S)) (inc (inc S')) _ _ κ _ with "[H]"). *) - (* iApply internal_eq_pointwise. *) - (* iIntros (y'). *) - (* destruct y' as [| [| y]]; simpl; first done. *) - (* * by iRewrite - "IH". *) - (* * rewrite (H _). *) - (* simpl. *) - (* rewrite interp_val_ren. *) - (* 2: reflexivity. *) - (* { *) - (* rewrite interp_val_ren. *) - (* - iPureIntro. reflexivity. *) - (* - intros z; simpl. *) - (* reflexivity. *) - (* } *) - (* + repeat f_equiv. *) - (* intros ?; simpl. *) - (* by apply interp_ectx_subst. *) - (* - admit. *) - (* Admitted. *) + Global Instance sub_scope_proper S S2 : + Proper ((≡) ==> (≡) ==> (≡)) (@sub_scope S S2). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - f_equiv. + apply HE. + - apply Hs. + Qed. + + Lemma interp_expr_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_expr (bind δ e) env ≡ interp_expr e (sub_scope δ env) + with interp_val_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env) + with interp_ectx_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_ectx (bind δ e) env ≡ interp_ectx e (sub_scope δ env). + Proof. + - destruct e; simpl. + + by apply interp_val_subst. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv; by apply interp_expr_subst. + + f_equiv. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + rewrite interp_expr_subst. + f_equiv. + intros [| x']; simpl. + * reflexivity. + * rewrite interp_val_ren. + f_equiv. + intros ?; reflexivity. + + repeat f_equiv. + * intros ?; simpl. + repeat f_equiv; first by apply interp_expr_subst. + intros ?; simpl. + repeat f_equiv; by apply interp_expr_subst. + * by apply interp_expr_subst. + - destruct e; simpl. + + term_simpl. + reflexivity. + + reflexivity. + + clear -interp_expr_subst. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_subst. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * do 2 rewrite interp_val_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (z). + done. + + repeat f_equiv; by apply interp_ectx_subst. + - destruct e; simpl; intros ?; simpl. + + reflexivity. + + repeat f_equiv; by apply interp_ectx_subst. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + + repeat f_equiv; last by apply interp_expr_subst. + intros ?; simpl; repeat f_equiv; first by apply interp_ectx_subst. + intros ?; simpl; repeat f_equiv; by apply interp_ectx_subst. + + repeat f_equiv; last by apply interp_ectx_subst. + intros ?; simpl; repeat f_equiv; first by apply interp_val_subst. + intros ?; simpl; repeat f_equiv; by apply interp_val_subst. + Qed. + + (* (** ** Interpretation is a homomorphism *) *) + #[global] Instance interp_ectx_item_hom {S} (Ki : ectx S) env : + IT_hom (interp_ectx Ki env). + Proof. + destruct Ki; simpl. + Admitted. (** ** Finally, preservation of reductions *) - Lemma interp_expr_head_step {S} env (e : expr S) e' σ σ' K n κ : + Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (H : ∀ (x : S), AsVal (env x)) (e : expr S) e' σ σ' K n : head_step e σ e' σ' K (n, 0) → - interp_expr e env κ ≡ Tick_n n $ interp_expr e' env κ. + interp_expr e env ≡ Tick_n n $ interp_expr e' env. Proof. inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. - (* app lemma *) subst. - admit. - (* rewrite !interp_expr_subst; [| reflexivity | reflexivity]. *) - (* trans (APP (Fun (Next (ir_unf (interp_expr e1) env κ))) (Next $ interp_val v2 env κ)). *) - (* + rewrite interp_rec_unfold. *) - (* simpl. *) - (* admit. *) - (* + rewrite APP_Fun. simpl. rewrite Tick_eq. do 4 f_equiv. *) - (* intros [| [| x]]; term_simpl. *) - (* * rewrite interp_val_ren. *) - (* -- admit. *) - (* -- reflexivity. *) - (* * admit. *) - (* * reflexivity. *) + erewrite APP_APP'_ITV; last apply _. + trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). + { repeat f_equiv. apply interp_rec_unfold. } + rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. + simplify_eq. + rewrite !interp_expr_subst. + f_equiv. + intros [| [| x]]; simpl; [| reflexivity | reflexivity]. + rewrite interp_val_ren. + f_equiv. + intros ?; simpl; reflexivity. - (* the natop stuff *) simplify_eq. destruct v1,v2; try naive_solver. simpl in *. rewrite NATOP_Ret. destruct op; simplify_eq/=; done. - - subst. - rewrite IF_True; last lia. + - rewrite IF_True; last lia. reflexivity. - - subst. - rewrite IF_False; last lia. + - rewrite IF_False; last lia. reflexivity. - - subst. - admit. - Admitted. + Qed. - (* Lemma interp_expr_fill_no_reify {S} K env (e e' : expr S) σ σ' K n : *) - (* head_step e σ e' σ' K (n, 0) → *) - (* interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. *) - (* Proof. *) - (* intros He. *) - (* trans (interp_ectx K env (interp_expr e env)). *) - (* { apply interp_ectx_fill. } *) - (* trans (interp_ectx K env (Tick_n n (interp_expr e' env))). *) - (* { f_equiv. apply (interp_expr_head_step env) in He. apply He. } *) - (* trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. *) - (* { f_equiv. symmetry. apply interp_ectx_fill. } *) - (* apply hom_tick_n. apply _. *) - (* Qed. *) + Lemma interp_expr_fill_no_reify {S} K (env : interp_scope S) (H : ∀ (x : S), AsVal (env x)) (e e' : expr S) σ σ' n : + head_step e σ e' σ' K (n, 0) → + interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. + Proof. + intros He. + trans (interp_ectx K env (interp_expr e env)). + { apply interp_comp. } + trans (interp_ectx K env (Tick_n n (interp_expr e' env))). + { + f_equiv. apply (interp_expr_head_step env) in He. + - apply He. + - apply H. + } + trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. + { f_equiv. symmetry. apply interp_comp. } + apply hom_tick_n. apply _. + Qed. - (* Opaque INPUT OUTPUT_. *) - (* Opaque Ret. *) + Opaque INPUT OUTPUT_. + Opaque Ret. - (* Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) *) - (* (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : *) - (* head_step e σ e' σ' (n,1) → *) - (* reify (gReifiers_sReifier rs) *) - (* (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) *) - (* ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). *) - (* Proof. *) - (* intros Hst. *) - (* trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) *) - (* (gState_recomp σr (sR_state σ))). *) - (* { f_equiv. by rewrite interp_ectx_fill. } *) - (* inversion Hst; simplify_eq; cbn-[gState_recomp]. *) - (* - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). *) - (* { repeat f_equiv; eauto. *) - (* rewrite hom_INPUT. f_equiv. by intro. } *) - (* rewrite reify_vis_eq //; last first. *) - (* { rewrite subReifier_reify/=//. *) - (* rewrite H4. done. } *) - (* repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. *) - (* rewrite interp_ectx_fill. *) - (* by rewrite ofe_iso_21. *) - (* - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). *) - (* { do 3 f_equiv; eauto. *) - (* rewrite get_ret_ret//. } *) - (* trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). *) - (* { do 2 f_equiv; eauto. *) - (* rewrite hom_OUTPUT_//. } *) - (* rewrite reify_vis_eq //; last first. *) - (* { rewrite subReifier_reify/=//. } *) - (* repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. *) - (* rewrite interp_ectx_fill. *) - (* simpl. done. *) - (* Qed. *) + Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) + (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : + head_step e σ e' σ' K (n, 1) → + reify (gReifiers_sReifier rs) + (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). + Proof. + intros Hst. + trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) + (gState_recomp σr (sR_state σ))). + { f_equiv. by rewrite interp_comp. } + inversion Hst; simplify_eq; cbn-[gState_recomp]. + - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). + { + repeat f_equiv; eauto. + rewrite hom_INPUT. f_equiv. by intro. + } + rewrite reify_vis_eq //; last first. + { + (* rewrite subReifier_reify/=//. *) + (* rewrite H4. done. *) + admit. + } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_comp. + reflexivity. + - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). + { + do 3 f_equiv; eauto. + rewrite get_ret_ret//. + } + trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). + { + do 2 f_equiv; eauto. + rewrite hom_OUTPUT_//. + } + rewrite reify_vis_eq //; last first. + { + (* rewrite subReifier_reify/=//. *) + admit. + } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_comp. + reflexivity. + - simpl. + rewrite interp_comp. + admit. + Admitted. - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m env κ : + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) (G : ∀ (x : S), AsVal (env x)) : prim_step e1 σ1 e2 σ2 (n,m) → ssteps (gReifiers_sReifier rs) - (interp_expr e1 env κ) (gState_recomp σr (sR_state σ1)) - (interp_expr e2 env κ) (gState_recomp σr (sR_state σ2)) n. + (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. Proof. Opaque gState_decomp gState_recomp. inversion 1; simplify_eq/=. @@ -1027,45 +665,43 @@ Section interp. destruct (head_step_io_01 _ _ _ _ _ _ _ H2); subst. - assert (σ1 = σ2) as ->. { eapply head_step_no_io; eauto. } - admit. - (* eapply (interp_expr_fill_no_reify K) in H2. *) - (* rewrite H2. eapply ssteps_tick_n. *) + eapply (interp_expr_fill_no_reify K) in H2; last done. + rewrite H2. eapply ssteps_tick_n. - inversion H2;subst. - + (* eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) - (* rewrite interp_ectx_fill. *) - (* rewrite hom_INPUT. *) - (* change 1 with (1+0). econstructor; last first. *) - (* { apply ssteps_zero; reflexivity. } *) - (* eapply sstep_reify. *) - (* { Transparent INPUT. unfold INPUT. simpl. *) - (* f_equiv. reflexivity. } *) - (* simpl in H2. *) - (* rewrite -H2. *) - (* repeat f_equiv; eauto. *) - (* rewrite interp_ectx_fill hom_INPUT. *) - (* eauto. *) - admit. - + (* eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. *) - (* rewrite interp_ectx_fill. simpl. *) - (* rewrite get_ret_ret. *) - (* rewrite hom_OUTPUT_. *) - (* change 1 with (1+0). econstructor; last first. *) - (* { apply ssteps_zero; reflexivity. } *) - (* eapply sstep_reify. *) - (* { Transparent OUTPUT_. unfold OUTPUT_. simpl. *) - (* f_equiv. reflexivity. } *) - (* simpl in H2. *) - (* rewrite -H2. *) - (* repeat f_equiv; eauto. *) - (* Opaque OUTPUT_. *) - (* rewrite interp_ectx_fill /= get_ret_ret hom_OUTPUT_. *) - (* eauto. *) - admit. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite interp_comp. + rewrite hom_INPUT. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify. + { Transparent INPUT. unfold INPUT. simpl. + f_equiv. reflexivity. } + simpl in H2. + rewrite -H2. + repeat f_equiv; eauto. + rewrite interp_comp hom_INPUT. + eauto. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite interp_comp. simpl. + rewrite get_ret_ret. + rewrite hom_OUTPUT_. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify. + { Transparent OUTPUT_. unfold OUTPUT_. simpl. + f_equiv. reflexivity. } + simpl in H2. + rewrite -H2. + repeat f_equiv; eauto. + Opaque OUTPUT_. + rewrite interp_comp /= get_ret_ret hom_OUTPUT_. + eauto. + + admit. } { - + admit. } - Qed. + Admitted. End interp. #[global] Opaque INPUT OUTPUT_. diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index 1740760..f6945b7 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -376,7 +376,7 @@ Inductive head_step {S} : expr S → state → expr S → state → ectx S → n head_step (If (Val (LitV n)) e1 e2) σ e2 σ K (0, 0) | CallccS e σ K : - head_step (Callcc e) σ (subst (Inc := inc) e (ContV K)) σ K (1, 0) + head_step (Callcc e) σ (subst (Inc := inc) e (ContV K)) σ K (1, 1) . Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : From 647c340cf51bdf4750e5b82fdefd71813217138f Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Mon, 20 Nov 2023 13:04:30 +0100 Subject: [PATCH 018/114] Some refactoring and pretification --- theories/input_lang_callcc/interp.v | 149 +++++++++++++++++++--------- 1 file changed, 100 insertions(+), 49 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 3368fc5..193104a 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -8,27 +8,83 @@ Require Import Binding.Set. Notation stateO := (leibnizO state). -Program Definition inputE : opInterp := {| - Ins := unitO; - Outs := natO; - |}. -Program Definition outputE : opInterp := {| - Ins := natO; - Outs := unitO; - |}. - -Program Definition callccE : opInterp := {| - Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); - Outs := (▶ ∙); - |}. - -Program Definition throwE : opInterp := {| - Ins := (▶ ∙ * (▶ (∙ -n> ∙))); - Outs := Empty_setO; - |}. +Program Definition inputE : opInterp := + {| + Ins := unitO; + Outs := natO; + |}. +Program Definition outputE : opInterp := + {| + Ins := natO; + Outs := unitO; + |}. + +Program Definition callccE : opInterp := + {| + Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); + Outs := (▶ ∙); + |}. + +Program Definition throwE : opInterp := + {| + Ins := (▶ ∙ * (▶ (∙ -n> ∙))); + Outs := Empty_setO; + |}. Definition ioE := @[inputE;outputE;callccE;throwE]. +Definition reify_input X `{Cofe X} : unitO * stateO * (natO -n> laterO X) → + option (laterO X * stateO) := + λ '(_, σ, k), let '(n, σ') := (update_input σ : prodO natO stateO) in + Some (k n, σ'). +#[export] Instance reify_input_ne X `{Cofe X} : + NonExpansive (reify_input X : prodO (prodO unitO stateO) + (natO -n> laterO X) → + optionO (prodO (laterO X) stateO)). +Proof. + intros n [[? σ1] k1] [[? σ2] k2]. simpl. + intros [[_ ->] Hk]. simpl in *. + repeat f_equiv. assumption. +Qed. + +Definition reify_output X `{Cofe X} : (natO * stateO * (unitO -n> laterO X)) → + optionO (prodO (laterO X) stateO) := + λ '(n, σ, k), Some (k (), ((update_output n σ) : stateO)). +#[export] Instance reify_output_ne X `{Cofe X} : + NonExpansive (reify_output X : prodO (prodO natO stateO) + (unitO -n> laterO X) → + optionO (prodO (laterO X) stateO)). +Proof. + intros ? [[]] [[]] []; simpl in *. + repeat f_equiv; first assumption; apply H0. +Qed. + +Definition reify_callcc X `{Cofe X} : ((laterO X -n> laterO X) -n> laterO X) * + stateO * (laterO X -n> laterO X) → + option (laterO X * stateO) := + λ '(f, σ, k), Some ((k (f k): laterO X), σ : stateO). +#[export] Instance reify_callcc_ne X `{Cofe X} : + NonExpansive (reify_callcc X : + prodO (prodO ((laterO X -n> laterO X) -n> laterO X) stateO) + (laterO X -n> laterO X) → + optionO (prodO (laterO X) stateO)). +Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; auto. Qed. + +Definition reify_throw X `{Cofe X} : + ((laterO X * (laterO (X -n> X))) * stateO * (Empty_setO -n> laterO X)) → + option (laterO X * stateO) := + λ '((e, k'), σ, _), + Some (((laterO_ap k' : laterO X -n> laterO X) e : laterO X), σ : stateO). +#[export] Instance reify_throw_ne X `{Cofe X} : + NonExpansive (reify_throw X : + prodO (prodO (prodO (laterO X) (laterO (X -n> X))) stateO) + (Empty_setO -n> laterO X) → + optionO (prodO (laterO X) (stateO))). +Proof. + intros ?[[[]]][[[]]]?. rewrite /reify_throw. + repeat f_equiv; apply H0. +Qed. + Canonical Structure reify_io : sReifier. Proof. simple refine {| sReifier_ops := ioE; @@ -36,24 +92,10 @@ Proof. |}. intros X HX op. destruct op as [ | [ | [ | [| []]]]]; simpl. - - simple refine (λne (us : prodO (prodO unitO stateO) (natO -n> laterO X)), - let a : (prodO natO stateO) := (update_input (sndO (fstO us))) in - Some $ ((sndO us) (fstO a), sndO a) : optionO (prodO (laterO X) stateO)). - intros n [[] s1] [[] s2] [[Hs1 Hs2] Hs]; simpl in *. - repeat f_equiv; assumption. - - simple refine (λne (us : prodO (prodO natO stateO) (unitO -n> laterO X)), - let a : stateO := update_output (fstO (fstO us)) (sndO (fstO us)) in - Some $ ((sndO us) (), a) : optionO (prodO (laterO X) stateO)). - intros n [[t1 t2] s1] [[y1 y2] s2] [Hs' Hs]. simpl in *. - repeat f_equiv. - + apply Hs. - + apply Hs'. - + apply Hs'. - - simple refine (λne (us : prodO (prodO ((laterO X -n> laterO X) -n> laterO X) stateO) (laterO X -n> laterO X)), Some $ ((fstO (fstO us)) (sndO us), sndO (fstO us))). - solve_proper. - - simple refine (λne (us : prodO (prodO (prodO (laterO X) (laterO (X -n> X))) stateO) (Empty_setO -n> laterO X)), Some (laterO_ap us.1.1.2 us.1.1.1, sndO (fstO us))). - intros ????. - repeat f_equiv; assumption. + - simple refine (OfeMor (reify_input X)). + - simple refine (OfeMor (reify_output X)). + - simple refine (OfeMor (reify_callcc X)). + - simple refine (OfeMor (reify_throw X)). Defined. Section constructors. @@ -63,16 +105,13 @@ Section constructors. Notation IT := (IT E A). Notation ITV := (ITV E A). - Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := - λne k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) - (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) k) - (λne o, (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o). - Solve All Obligations with solve_proper. - Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) - (subEff_ins (F:=ioE) (op:=(inl ())) ()) - (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). + Program Definition INPUT : (nat -n> IT) -n> IT := + λne k, Vis (E:=E) (subEff_opid (inl ())) + (subEff_ins (F:=ioE) (op:=(inl ())) ()) + (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). Solve Obligations with solve_proper. + Program Definition OUTPUT_ : nat -n> IT -n> IT := λne m α, Vis (E:=E) (subEff_opid (inr (inl ()))) (subEff_ins (F:=ioE) (op:=(inr (inl ()))) m) @@ -95,10 +134,17 @@ Section constructors. done. Qed. + Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := + λne k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) + (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) k) + (λne o, (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o). + Solve All Obligations with solve_proper. + Program Definition THROW : IT -n> (laterO (IT -n> IT)) -n> IT := λne m α, Vis (E:=E) (subEff_opid (inr (inr (inr (inl ()))))) - (subEff_ins (F:=ioE) (op:=(inr (inr (inr (inl ()))))) (NextO m, α)) - (λne _, laterO_ap α (NextO m)). + (subEff_ins (F:=ioE) (op:=(inr (inr (inr (inl ()))))) + (NextO m, α)) + (λne _, laterO_ap α (NextO m)). Next Obligation. solve_proper. Qed. @@ -185,8 +231,11 @@ Section interp. Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). Proof. solve_proper. Qed. - Program Definition interp_callcc {S} (e : @interp_scope F R _ (inc S) -n> IT) - : interp_scope S -n> IT := λne env, CALLCC (λne (f : laterO IT -n> laterO IT), (Next (e (@extend_scope F R _ _ env (Fun (Next (λne x, Tau (f (Next x))))))))). + Program Definition interp_callcc {S} + (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := + λne env, CALLCC (λne (f : laterO IT -n> laterO IT), + (Next (e (@extend_scope F R _ _ env + (Fun (Next (λne x, Tau (f (Next x))))))))). Next Obligation. solve_proper. Qed. @@ -208,7 +257,9 @@ Section interp. Qed. Program Definition interp_throw {A} (n : A -n> IT) (m : A -n> IT) - : A -n> IT := λne env, get_fun (λne (f : laterO (IT -n> IT)), THROW (n env) f) (m env). + : A -n> IT := + λne env, get_fun (λne (f : laterO (IT -n> IT)), + THROW (n env) f) (m env). Next Obligation. intros ????. intros n' x y H. From 41bd6b86d3d8c189d77f921a7b2245d63fbd76ed Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Mon, 20 Nov 2023 17:33:32 +0100 Subject: [PATCH 019/114] WIP on ectx hom --- theories/input_lang_callcc/interp.v | 55 +++++++++++++++++++++++++---- 1 file changed, 49 insertions(+), 6 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 193104a..b2bd79a 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -385,7 +385,7 @@ Section interp. end with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := match K with - | EmptyK => λne env, λne t, t + | EmptyK => λne env, idfun | AppLK e1 K => interp_applk (interp_expr e1) (interp_ectx K) | AppRK K v2 => interp_apprk (interp_ectx K) (interp_val v2) | NatOpLK op e1 K => interp_natoplk op (interp_expr e1) (interp_ectx K) @@ -397,6 +397,14 @@ Section interp. end. Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Open Scope syn_scope. + + Example callcc_ex : expr Empty_set := + NatOp + (# 1) (Callcc (NatOp + (# 1) (Throw (# 2) (VarV VZ)))). + Eval cbn in callcc_ex. + Eval cbn in interp_expr callcc_ex + (λne (x : leibnizO Empty_set), match x with end). + Global Instance interp_val_asval {S} {D : interp_scope S} {H : ∀ (x : S), AsVal (D x)} (v : val S) : AsVal (interp_val v D). Proof. @@ -597,12 +605,47 @@ Section interp. intros ?; simpl; repeat f_equiv; by apply interp_val_subst. Qed. - (* (** ** Interpretation is a homomorphism *) *) - #[global] Instance interp_ectx_item_hom {S} (Ki : ectx S) env : - IT_hom (interp_ectx Ki env). + (** ** Interpretation is a homomorphism (for some constructors) *) + (* #[global] Instance interp_ectx_item_hom {S} (Ki : ectx S) env : *) + (* IT_hom (interp_ectx Ki env). *) + (* Proof. *) + (* destruct Ki; simpl. *) + (* Admitted. *) + #[global] Instance interp_ectx_item_hom_emp {S} env : + IT_hom (interp_ectx (EmptyK : ectx S) env). Proof. - destruct Ki; simpl. - Admitted. + simple refine (IT_HOM _ _ _ _ _); intros; auto. + simpl. fold (@idfun IT). f_equiv. intro. simpl. + by rewrite laterO_map_id. + Qed. + + #[global] Instance interp_ectx_item_hom_output {S} (K : ectx S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (OutputK K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros. + - simpl. by rewrite !hom_tick. + - simpl. rewrite !hom_vis. + f_equiv. intro. simpl. rewrite laterO_map_compose. + f_equiv; auto. f_equiv. intro y. simpl. auto. + - simpl. by rewrite !hom_err. + Qed. + + (* #[global] Instance interp_ectx_item_hom_if {S} *) + (* (K : ectx S) (e1 e2 : expr S) env : *) + (* IT_hom (interp_ectx K env) -> *) + (* IT_hom (interp_ectx (IfK K e1 e2) env). *) + (* Proof. *) + (* intros. simple refine (IT_HOM _ _ _ _ _); intros. *) + (* - simpl. rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. *) + (* - simpl. assert ((interp_ectx K env (Vis op i ko)) ≡ *) + (* (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). *) + (* { by rewrite hom_vis. } *) + (* trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) *) + (* (interp_expr e1 env) (interp_expr e2 env)). *) + (* { do 3 f_equiv. by rewrite hom_vis. } *) + (* rewrite IF_Vis. f_equiv. simpl. *) + (* intro. simpl. rewrite -laterO_map_compose. *) (** ** Finally, preservation of reductions *) Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (H : ∀ (x : S), AsVal (env x)) (e : expr S) e' σ σ' K n : From aeb4b10473db9986ccdef99869b22023ef0484e1 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 21 Nov 2023 09:48:52 +0100 Subject: [PATCH 020/114] If homomorphism --- theories/input_lang_callcc/interp.v | 35 ++++++++++++++++------------- 1 file changed, 20 insertions(+), 15 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index b2bd79a..854d626 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -631,21 +631,26 @@ Section interp. - simpl. by rewrite !hom_err. Qed. - (* #[global] Instance interp_ectx_item_hom_if {S} *) - (* (K : ectx S) (e1 e2 : expr S) env : *) - (* IT_hom (interp_ectx K env) -> *) - (* IT_hom (interp_ectx (IfK K e1 e2) env). *) - (* Proof. *) - (* intros. simple refine (IT_HOM _ _ _ _ _); intros. *) - (* - simpl. rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. *) - (* - simpl. assert ((interp_ectx K env (Vis op i ko)) ≡ *) - (* (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). *) - (* { by rewrite hom_vis. } *) - (* trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) *) - (* (interp_expr e1 env) (interp_expr e2 env)). *) - (* { do 3 f_equiv. by rewrite hom_vis. } *) - (* rewrite IF_Vis. f_equiv. simpl. *) - (* intro. simpl. rewrite -laterO_map_compose. *) + #[global] Instance interp_ectx_item_hom_if {S} + (K : ectx S) (e1 e2 : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (IfK K e1 e2) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros. + - simpl. rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. + - simpl. assert ((interp_ectx K env (Vis op i ko)) ≡ + (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). + { by rewrite hom_vis. } + trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) + (interp_expr e1 env) (interp_expr e2 env)). + { do 3 f_equiv. by rewrite hom_vis. } + rewrite IF_Vis. f_equiv. simpl. + intro. simpl. by rewrite -laterO_map_compose. + - simpl. trans (IF (Err e) (interp_expr e1 env) (interp_expr e2 env)). + { repeat f_equiv. apply hom_err. } + apply IF_Err. + Qed. + (** ** Finally, preservation of reductions *) Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (H : ∀ (x : S), AsVal (env x)) (e : expr S) e' σ σ' K n : From 89dec736ef12e6c25c6b480e440cb4deabc5d83c Mon Sep 17 00:00:00 2001 From: Kaptch Date: Tue, 21 Nov 2023 11:48:57 +0100 Subject: [PATCH 021/114] make syntax not cbv-targeted --- theories/input_lang_callcc/interp.v | 37 +++++++++++++---------------- theories/input_lang_callcc/lang.v | 20 ++++++++-------- 2 files changed, 26 insertions(+), 31 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 854d626..7d4918d 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -368,13 +368,13 @@ Section interp. Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := match v with | LitV n => interp_nat n - | VarV x => interp_var x | RecV e => interp_rec (interp_expr e) | ContV K => interp_cont (interp_ectx K) end with interp_expr {S} (e : expr S) : interp_scope S -n> IT := match e with | Val v => interp_val v + | Var x => interp_var x | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) @@ -400,16 +400,15 @@ Section interp. Open Scope syn_scope. Example callcc_ex : expr Empty_set := - NatOp + (# 1) (Callcc (NatOp + (# 1) (Throw (# 2) (VarV VZ)))). + NatOp + (# 1) (Callcc (NatOp + (# 1) (Throw (# 2) (Var VZ)))). Eval cbn in callcc_ex. Eval cbn in interp_expr callcc_ex (λne (x : leibnizO Empty_set), match x with end). - Global Instance interp_val_asval {S} {D : interp_scope S} {H : ∀ (x : S), AsVal (D x)} (v : val S) + Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) : AsVal (interp_val v D). Proof. destruct v; simpl. - - apply H. - apply _. - rewrite interp_rec_unfold. apply _. - apply _. @@ -419,8 +418,8 @@ Section interp. Global Instance ArrDist {A B : Set} `{Dist B} : Dist (A [→] B) := fun n => fun f g => ∀ x, f x ≡{n}≡ g x. - Global Instance ren_scope_proper S S2 : - Proper ((≡) ==> (≡) ==> (≡)) (@ren_scope F _ CR S S2). + Global Instance ren_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@ren_scope F _ CR S S'). Proof. intros D D' HE s1 s2 Hs. intros x; simpl. @@ -441,10 +440,11 @@ Section interp. Proof. - destruct e; simpl. + by apply interp_val_ren. + + reflexivity. + + repeat f_equiv; by apply interp_expr_ren. + repeat f_equiv; by apply interp_expr_ren. + repeat f_equiv; by apply interp_expr_ren. + repeat f_equiv; by apply interp_expr_ren. - + f_equiv. + repeat f_equiv; by apply interp_expr_ren. + repeat f_equiv. intros ?; simpl. @@ -461,7 +461,6 @@ Section interp. repeat f_equiv; by apply interp_expr_ren. * by apply interp_expr_ren. - destruct e; simpl. - + reflexivity. + reflexivity. + clear -interp_expr_ren. apply bi.siProp.internal_eq_soundness. @@ -517,12 +516,12 @@ Section interp. Qed. Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') - : interp_scope S := λne x, interp_val (δ x) env. + : interp_scope S := λne x, interp_expr (δ x) env. Global Instance SubEquiv {A B : Set} : Equiv (A [⇒] B) := fun f g => ∀ x, f x = g x. - Global Instance sub_scope_proper S S2 : - Proper ((≡) ==> (≡) ==> (≡)) (@sub_scope S S2). + Global Instance sub_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@sub_scope S S'). Proof. intros D D' HE s1 s2 Hs. intros x; simpl. @@ -544,6 +543,8 @@ Section interp. Proof. - destruct e; simpl. + by apply interp_val_subst. + + term_simpl. + reflexivity. + repeat f_equiv; by apply interp_expr_subst. + repeat f_equiv; by apply interp_expr_subst. + repeat f_equiv; by apply interp_expr_subst. @@ -556,7 +557,7 @@ Section interp. f_equiv. intros [| x']; simpl. * reflexivity. - * rewrite interp_val_ren. + * rewrite interp_expr_ren. f_equiv. intros ?; reflexivity. + repeat f_equiv. @@ -566,8 +567,6 @@ Section interp. repeat f_equiv; by apply interp_expr_subst. * by apply interp_expr_subst. - destruct e; simpl. - + term_simpl. - reflexivity. + reflexivity. + clear -interp_expr_subst. apply bi.siProp.internal_eq_soundness. @@ -583,7 +582,7 @@ Section interp. iIntros (y'). destruct y' as [| [| y]]; simpl; first done. * by iRewrite - "IH". - * do 2 rewrite interp_val_ren. + * do 2 rewrite interp_expr_ren. iApply f_equivI. iApply internal_eq_pointwise. iIntros (z). @@ -606,11 +605,7 @@ Section interp. Qed. (** ** Interpretation is a homomorphism (for some constructors) *) - (* #[global] Instance interp_ectx_item_hom {S} (Ki : ectx S) env : *) - (* IT_hom (interp_ectx Ki env). *) - (* Proof. *) - (* destruct Ki; simpl. *) - (* Admitted. *) + #[global] Instance interp_ectx_item_hom_emp {S} env : IT_hom (interp_ectx (EmptyK : ectx S) env). Proof. @@ -630,7 +625,7 @@ Section interp. f_equiv; auto. f_equiv. intro y. simpl. auto. - simpl. by rewrite !hom_err. Qed. - + #[global] Instance interp_ectx_item_hom_if {S} (K : ectx S) (e1 e2 : expr S) env : IT_hom (interp_ectx K env) -> diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index f6945b7..100902b 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -11,6 +11,7 @@ Inductive nat_op := Add | Sub | Mult. Inductive expr {X : Set} := (* Values *) | Val (v : val) : expr +| Var (x : X) : expr (* Base lambda calculus *) | App (e₁ : expr) (e₂ : expr) : expr (* Base types and their operations *) @@ -22,7 +23,6 @@ Inductive expr {X : Set} := | Callcc (e : @expr (inc X)) : expr | Throw (e₁ : expr) (e₂ : expr) : expr with val {X : Set} := -| VarV (x : X) : val | LitV (n : nat) : val | RecV (e : @expr (inc (inc X))) : val | ContV (K : ectx) : val @@ -112,6 +112,7 @@ Local Open Scope bind_scope. Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := match e with | Val v => Val (vmap f v) + | Var x => Var (f x) | App e₁ e₂ => App (emap f e₁) (emap f e₂) | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) @@ -122,7 +123,6 @@ Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := end with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := match v with - | VarV x => VarV (f x) | LitV n => LitV n | RecV e => RecV (emap ((f ↑) ↑) e) | ContV K => ContV (kmap f K) @@ -158,11 +158,12 @@ Proof. intros f; term_simpl; first done; rewrite IH; reflexivity. Qed. -#[export] Instance SPC_val : SetPureCore val := @VarV. +#[export] Instance SPC_expr : SetPureCore expr := @Var. Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := match e with | Val v => Val (vbind f v) + | Var x => f x | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) @@ -173,7 +174,6 @@ Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := end with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := match v with - | VarV x => f x | LitV n => LitV n | RecV e => RecV (ebind ((f ↑) ↑) e) | ContV K => ContV (kbind f K) @@ -195,7 +195,7 @@ with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := #[export] Instance BindCore_val : BindCore val := @vbind. #[export] Instance BindCore_ectx : BindCore ectx := @kbind. -#[export] Instance IP_typ : SetPure val. +#[export] Instance IP_typ : SetPure expr. Proof. split; intros; reflexivity. Qed. @@ -356,7 +356,7 @@ Definition update_output (n:nat) (s : state) : state := Inductive head_step {S} : expr S → state → expr S → state → ectx S → nat * nat → Prop := | BetaS e1 v2 σ K : - head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (Inc := inc) e1) (shift v2)) (RecV e1)) σ K (1,0) + head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) (Val (shift (Inc := inc) v2))) (Val (RecV e1))) σ K (1,0) | InputS σ n σ' K : update_input σ = (n, σ') → head_step Input σ (Val (LitV n)) σ' K (1, 1) @@ -376,7 +376,7 @@ Inductive head_step {S} : expr S → state → expr S → state → ectx S → n head_step (If (Val (LitV n)) e1 e2) σ e2 σ K (0, 0) | CallccS e σ K : - head_step (Callcc e) σ (subst (Inc := inc) e (ContV K)) σ K (1, 1) + head_step (Callcc e) σ (subst (Inc := inc) e (Val (ContV K))) σ K (1, 1) . Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : @@ -526,6 +526,9 @@ Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := | 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 → @@ -552,9 +555,6 @@ Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := typed (Γ ▹ Tcont τ) e τ -> typed Γ (Callcc e) τ with typed_val {S : Set} (Γ : S -> ty) : val S → ty → Prop := -| typed_Var (τ : ty) (v : S) : - Γ v = τ → - typed_val Γ (VarV v) τ | typed_Lit n : typed_val Γ (LitV n) Tnat | typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : From ef5a3b8342215cbce82937d94f00820045b031aa Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 21 Nov 2023 14:03:39 +0100 Subject: [PATCH 022/114] Hom instances for the rest of ctx (but mayb unreasonable assptions) --- theories/input_lang_callcc/interp.v | 62 +++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 854d626..a146e79 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -651,6 +651,68 @@ Section interp. apply IF_Err. Qed. + #[global] Instance interp_ectx_item_hom_appl {S} (K : ectx S) + (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppLK e 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. + Qed. + + #[global] Instance interp_ectx_item_hom_appr {S} (K : ectx S) + (v : val S) (env : interp_scope S) : + (forall (x : S), AsVal (env x)) -> (* FIXME: probably not reasonable *) + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppRK K v) env). + Proof. + intros Hval H. simple refine (IT_HOM _ _ _ _ _); intros. + - simpl. rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. + - Disable Notation "⊙". simpl. + trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) + (interp_val v env)). + + do 2f_equiv. rewrite hom_vis. do 3 f_equiv. by intro. + + rewrite APP'_Vis_l. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - simpl. trans (APP' (Err e) (interp_val v env)). + { do 2f_equiv. apply hom_err. } + apply APP'_Err_l, interp_val_asval. + Qed. + + #[global] Instance interp_ectx_item_homm_natopl {S} (K : ectx S) + (e : expr S) op env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpLK op e K) env). + Proof. + intros H. 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. + Qed. + + #[global] Instance interp_ectx_item_homm_natopr {S} (K : ectx S) + (v : val S) op (env : interp_scope S) : + (forall (x : S), AsVal (env x)) -> (* FIXME: probably not reasonable *) + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpRK op K v) env). + Proof. + intros Hval H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -NATOP_ITV_Tick_l. do 2 f_equiv. apply hom_tick. + - trans (NATOP (do_natop op) + (Vis op0 i (laterO_map (interp_ectx K env) ◎ ko)) + (interp_val v env)). + { do 2 f_equiv. rewrite hom_vis. f_equiv. by intro. } + rewrite NATOP_ITV_Vis_l. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - trans (NATOP (do_natop op) (Err e) (interp_val v env)). + + do 2 f_equiv. apply hom_err. + + apply NATOP_Err_l, interp_val_asval. + Qed. + (** ** Finally, preservation of reductions *) Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (H : ∀ (x : S), AsVal (env x)) (e : expr S) e' σ σ' K n : From b5256c5f92548929cc1fbc61526900c4d3d44263 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Tue, 21 Nov 2023 14:10:05 +0100 Subject: [PATCH 023/114] ectx --- theories/input_lang_callcc/interp.v | 118 +++++++++++++++++++++++++--- 1 file changed, 109 insertions(+), 9 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 7d4918d..b588d74 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -606,7 +606,7 @@ Section interp. (** ** Interpretation is a homomorphism (for some constructors) *) - #[global] Instance interp_ectx_item_hom_emp {S} env : + #[global] Instance interp_ectx_hom_emp {S} env : IT_hom (interp_ectx (EmptyK : ectx S) env). Proof. simple refine (IT_HOM _ _ _ _ _); intros; auto. @@ -614,7 +614,7 @@ Section interp. by rewrite laterO_map_id. Qed. - #[global] Instance interp_ectx_item_hom_output {S} (K : ectx S) env : + #[global] Instance interp_ectx_hom_output {S} (K : ectx S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (OutputK K) env). Proof. @@ -626,7 +626,7 @@ Section interp. - simpl. by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_item_hom_if {S} + #[global] Instance interp_ectx_hom_if {S} (K : ectx S) (e1 e2 : expr S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (IfK K e1 e2) env). @@ -646,9 +646,109 @@ Section interp. apply IF_Err. Qed. + #[global] Instance interp_ectx_hom_appl {S} + (K : ectx S) (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppLK e K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros. + - simpl; rewrite hom_tick. + apply APP'_Tick_r. + - simpl; rewrite !hom_vis. + f_equiv. + intro; simpl. + rewrite laterO_map_compose. + f_equiv; last done. + f_equiv. + intro; done. + - simpl; by rewrite !hom_err. + Qed. + + #[global] Instance interp_ectx_hom_appr {S} + (K : ectx S) (v : val S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppRK K v) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros. + - simpl. + rewrite -APP'_Tick_l. + do 2 f_equiv. + apply hom_tick. + - simpl. + trans (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko) ⊙ (interp_val v env)). + { do 2 f_equiv. apply hom_vis. } + rewrite APP'_Vis_l. + simpl. + f_equiv. + intro; simpl. + rewrite -laterO_map_compose. + do 2 f_equiv. + by intro; simpl. + - simpl. + trans ((Err e) ⊙ (interp_val v env)). + { do 2 f_equiv; apply hom_err. } + by rewrite APP'_Err_l. + Qed. + + #[global] Instance interp_ectx_hom_natl {S} + op (K : ectx S) (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpLK op e K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros. + - simpl; by rewrite !hom_tick. + - simpl; rewrite !hom_vis. + f_equiv. + intro; simpl. + rewrite laterO_map_compose. + reflexivity. + - simpl; by rewrite !hom_err. + Qed. + + #[global] Instance interp_ectx_hom_natr {S} + op (K : ectx S) (v : val S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpRK op K v) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros. + - simpl. + trans (NATOP (do_natop op) (Tick (interp_ectx K env α)) (interp_val v env)). + { do 2 f_equiv; apply hom_tick. } + by rewrite NATOP_ITV_Tick_l. + - simpl. + trans (NATOP (do_natop op) (Vis _ i (laterO_map (λne y, interp_ectx K env y) ◎ ko)) (interp_val v env)). + { do 2 f_equiv; apply hom_vis. } + rewrite NATOP_ITV_Vis_l. + f_equiv. + intro; simpl. + rewrite -laterO_map_compose. + do 2 f_equiv. + by intro; simpl. + - simpl. + trans (NATOP (do_natop op) (Err e) (interp_val v env)). + { do 2 f_equiv; apply hom_err. } + by rewrite NATOP_Err_l. + Qed. + + #[global] Instance interp_ectx_hom_throwr {S} + (K : ectx S) (v : val S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (ThrowRK v K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros. + - simpl; rewrite -get_fun_tick. + f_equiv. + apply hom_tick. + - simpl; rewrite !hom_vis. + f_equiv. + intro; simpl. + rewrite laterO_map_compose. + reflexivity. + - simpl; by rewrite !hom_err. + Qed. (** ** Finally, preservation of reductions *) - Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (H : ∀ (x : S), AsVal (env x)) (e : expr S) e' σ σ' K n : + Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' σ σ' K n : head_step e σ e' σ' K (n, 0) → interp_expr e env ≡ Tick_n n $ interp_expr e' env. Proof. @@ -677,7 +777,7 @@ Section interp. reflexivity. Qed. - Lemma interp_expr_fill_no_reify {S} K (env : interp_scope S) (H : ∀ (x : S), AsVal (env x)) (e e' : expr S) σ σ' n : + Lemma interp_expr_fill_no_reify {S} K (env : interp_scope S) (e e' : expr S) σ σ' n : head_step e σ e' σ' K (n, 0) → interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. Proof. @@ -687,13 +787,12 @@ Section interp. trans (interp_ectx K env (Tick_n n (interp_expr e' env))). { f_equiv. apply (interp_expr_head_step env) in He. - - apply He. - - apply H. + apply He. } trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. { f_equiv. symmetry. apply interp_comp. } - apply hom_tick_n. apply _. - Qed. + apply hom_tick_n. + Admitted. Opaque INPUT OUTPUT_. Opaque Ret. @@ -713,6 +812,7 @@ Section interp. - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). { repeat f_equiv; eauto. + unshelve erewrite hom_INPUT. rewrite hom_INPUT. f_equiv. by intro. } rewrite reify_vis_eq //; last first. From 4abe96dd53b4d365feddd63b74b24f2708af5412 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 21 Nov 2023 14:30:14 +0100 Subject: [PATCH 024/114] Less unreasonable assumptions + style --- theories/input_lang_callcc/interp.v | 45 +++++++++++++---------------- 1 file changed, 20 insertions(+), 25 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index a146e79..cd528b3 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -606,11 +606,7 @@ Section interp. Qed. (** ** Interpretation is a homomorphism (for some constructors) *) - (* #[global] Instance interp_ectx_item_hom {S} (Ki : ectx S) env : *) - (* IT_hom (interp_ectx Ki env). *) - (* Proof. *) - (* destruct Ki; simpl. *) - (* Admitted. *) + #[global] Instance interp_ectx_item_hom_emp {S} env : IT_hom (interp_ectx (EmptyK : ectx S) env). Proof. @@ -623,22 +619,22 @@ Section interp. IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (OutputK K) env). Proof. - intros. simple refine (IT_HOM _ _ _ _ _); intros. - - simpl. by rewrite !hom_tick. - - simpl. rewrite !hom_vis. - f_equiv. intro. simpl. rewrite laterO_map_compose. - f_equiv; auto. f_equiv. intro y. simpl. auto. - - simpl. by rewrite !hom_err. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. + f_equiv. intro. simpl. rewrite -laterO_map_compose. + do 2 f_equiv. by intro. + - by rewrite !hom_err. Qed. - + #[global] Instance interp_ectx_item_hom_if {S} (K : ectx S) (e1 e2 : expr S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (IfK K e1 e2) env). Proof. - intros. simple refine (IT_HOM _ _ _ _ _); intros. - - simpl. rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. - - simpl. assert ((interp_ectx K env (Vis op i ko)) ≡ + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. + - assert ((interp_ectx K env (Vis op i ko)) ≡ (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). { by rewrite hom_vis. } trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) @@ -646,7 +642,7 @@ Section interp. { do 3 f_equiv. by rewrite hom_vis. } rewrite IF_Vis. f_equiv. simpl. intro. simpl. by rewrite -laterO_map_compose. - - simpl. trans (IF (Err e) (interp_expr e1 env) (interp_expr e2 env)). + - trans (IF (Err e) (interp_expr e1 env) (interp_expr e2 env)). { repeat f_equiv. apply hom_err. } apply IF_Err. Qed. @@ -665,21 +661,20 @@ Section interp. #[global] Instance interp_ectx_item_hom_appr {S} (K : ectx S) (v : val S) (env : interp_scope S) : - (forall (x : S), AsVal (env x)) -> (* FIXME: probably not reasonable *) + (AsVal (interp_val v env)) -> (* FIXME: probably not reasonable *) IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (AppRK K v) env). Proof. - intros Hval H. simple refine (IT_HOM _ _ _ _ _); intros. - - simpl. rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. - - Disable Notation "⊙". simpl. - trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) + intros Hval H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. + - trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) (interp_val v env)). + do 2f_equiv. rewrite hom_vis. do 3 f_equiv. by intro. + rewrite APP'_Vis_l. f_equiv. intro x. simpl. by rewrite -laterO_map_compose. - - simpl. trans (APP' (Err e) (interp_val v env)). + - trans (APP' (Err e) (interp_val v env)). { do 2f_equiv. apply hom_err. } - apply APP'_Err_l, interp_val_asval. + by apply APP'_Err_l. Qed. #[global] Instance interp_ectx_item_homm_natopl {S} (K : ectx S) @@ -696,7 +691,7 @@ Section interp. #[global] Instance interp_ectx_item_homm_natopr {S} (K : ectx S) (v : val S) op (env : interp_scope S) : - (forall (x : S), AsVal (env x)) -> (* FIXME: probably not reasonable *) + (AsVal (interp_val v env)) -> (* FIXME: probably not reasonable *) IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (NatOpRK op K v) env). Proof. @@ -710,7 +705,7 @@ Section interp. by rewrite -laterO_map_compose. - trans (NATOP (do_natop op) (Err e) (interp_val v env)). + do 2 f_equiv. apply hom_err. - + apply NATOP_Err_l, interp_val_asval. + + by apply NATOP_Err_l. Qed. From 8af4b3ffd0a79e81e1b5615fd41b1ca670122002 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 21 Nov 2023 14:40:28 +0100 Subject: [PATCH 025/114] fix --- theories/input_lang_callcc/interp.v | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 209a686..5d0ca36 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -660,11 +660,10 @@ Section interp. #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) (v : val S) (env : interp_scope S) : - (AsVal (interp_val v env)) -> (* FIXME: probably not reasonable *) IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (AppRK K v) env). Proof. - intros Hval H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. - trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) (interp_val v env)). @@ -673,7 +672,7 @@ Section interp. by rewrite -laterO_map_compose. - trans (APP' (Err e) (interp_val v env)). { do 2f_equiv. apply hom_err. } - by apply APP'_Err_l. + apply APP'_Err_l, interp_val_asval. Qed. #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) @@ -690,7 +689,6 @@ Section interp. #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) (v : val S) op (env : interp_scope S) : - (AsVal (interp_val v env)) -> (* FIXME: probably not reasonable *) IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (NatOpRK op K v) env). Proof. @@ -704,7 +702,7 @@ Section interp. by rewrite -laterO_map_compose. - trans (NATOP (do_natop op) (Err e) (interp_val v env)). + do 2 f_equiv. apply hom_err. - + by apply NATOP_Err_l. + + by apply NATOP_Err_l, interp_val_asval. Qed. From d02c6bd5aa740fba545dee4124a32c79a4e58ca5 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 22 Nov 2023 13:45:50 +0100 Subject: [PATCH 026/114] lines --- theories/input_lang_callcc/interp.v | 55 +++++++++++++++++++++-------- 1 file changed, 40 insertions(+), 15 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 5d0ca36..e9a5718 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -301,10 +301,16 @@ Section interp. by do 2 f_equiv. Qed. - Program Definition interp_rec {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) : @interp_scope F R _ S -n> IT := mmuu (interp_rec_pre body). - - Program Definition ir_unf {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := - λne a, body (@extend_scope F R _ _ (@extend_scope F R _ _ env (interp_rec body env)) a). + Program Definition interp_rec {S : Set} + (body : @interp_scope F R _ (inc (inc S)) -n> IT) : + @interp_scope F R _ S -n> IT := + mmuu (interp_rec_pre body). + + Program Definition ir_unf {S : Set} + (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (@extend_scope F R _ _ + (@extend_scope F R _ _ env (interp_rec body env)) + a). Next Obligation. intros. solve_proper_prepare. @@ -337,31 +343,48 @@ Section interp. Program Definition interp_nat (n : nat) {A} : A -n> IT := λne env, Ret n. - Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := λne env, Fun (Next (K env)). + Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := + λne env, Fun (Next (K env)). Solve All Obligations with solve_proper. - Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_app q (λne env, K env t) env. + Program Definition interp_applk {A} (q : A -n> IT) + (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := + λne env t, interp_app q (λne env, K env t) env. Solve All Obligations with solve_proper. - Program Definition interp_apprk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_app (λne env, K env t) q env. + Program Definition interp_apprk {A} (K : A -n> (IT -n> IT)) + (q : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_app (λne env, K env t) q env. Solve All Obligations with solve_proper. - Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_natop op q (λne env, K env t) env. + Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) + (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := + λne env t, interp_natop op q (λne env, K env t) env. Solve All Obligations with solve_proper. - Program Definition interp_natoprk {A} (op : nat_op) (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_natop op (λne env, K env t) q env. + Program Definition interp_natoprk {A} (op : nat_op) (K : A -n> (IT -n> IT)) + (q : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_natop op (λne env, K env t) q env. Solve All Obligations with solve_proper. - Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) (p : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_if (λne env, K env t) q p env. + Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) + (p : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_if (λne env, K env t) q p env. Solve All Obligations with solve_proper. - Program Definition interp_outputk {A} (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_output (λne env, K env t) env. + Program Definition interp_outputk {A} (K : A -n> (IT -n> IT)) : + A -n> (IT -n> IT) := + λne env t, interp_output (λne env, K env t) env. Solve All Obligations with solve_proper. - Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_throw (λne env, K env t) q env. + Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : + A -n> (IT -n> IT) := + λne env t, interp_throw (λne env, K env t) q env. Solve All Obligations with solve_proper_please. - Program Definition interp_throwrk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_throw q (λne env, K env t) env. + Program Definition interp_throwrk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : + A -n> (IT -n> IT) := + λne env t, interp_throw q (λne env, K env t) env. Solve All Obligations with solve_proper_please. (** Interpretation for all the syntactic categories: values, expressions, contexts *) @@ -414,9 +437,11 @@ Section interp. - apply _. Qed. - Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := fun f g => ∀ x, f x = g x. + Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := + fun f g => ∀ x, f x = g x. - Global Instance ArrDist {A B : Set} `{Dist B} : Dist (A [→] B) := fun n => fun f g => ∀ x, f x ≡{n}≡ g x. + Global Instance ArrDist {A B : Set} `{Dist B} : Dist (A [→] B) := + fun n => fun f g => ∀ x, f x ≡{n}≡ g x. Global Instance ren_scope_proper {S S'} : Proper ((≡) ==> (≡) ==> (≡)) (@ren_scope F _ CR S S'). From ce6f0fbd7f2dad3faeebd328edac08cd222c0124 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 22 Nov 2023 13:55:42 +0100 Subject: [PATCH 027/114] More sensible and consistent variable naming --- theories/input_lang_callcc/interp.v | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index e9a5718..9a3b450 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -135,16 +135,16 @@ Section constructors. Qed. Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := - λne k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) - (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) k) + λne f, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) + (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) f) (λne o, (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o). Solve All Obligations with solve_proper. Program Definition THROW : IT -n> (laterO (IT -n> IT)) -n> IT := - λne m α, Vis (E:=E) (subEff_opid (inr (inr (inr (inl ()))))) + λne e k, Vis (E:=E) (subEff_opid (inr (inr (inr (inl ()))))) (subEff_ins (F:=ioE) (op:=(inr (inr (inr (inl ()))))) - (NextO m, α)) - (λne _, laterO_ap α (NextO m)). + (NextO e, k)) + (λne _, laterO_ap k (NextO e)). Next Obligation. solve_proper. Qed. @@ -256,10 +256,10 @@ Section interp. repeat f_equiv. Qed. - Program Definition interp_throw {A} (n : A -n> IT) (m : A -n> IT) + Program Definition interp_throw {A} (e : A -n> IT) (k : A -n> IT) : A -n> IT := λne env, get_fun (λne (f : laterO (IT -n> IT)), - THROW (n env) f) (m env). + THROW (e env) f) (k env). Next Obligation. intros ????. intros n' x y H. @@ -377,14 +377,14 @@ Section interp. λne env t, interp_output (λne env, K env t) env. Solve All Obligations with solve_proper. - Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : + Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (k : A -n> IT) : A -n> (IT -n> IT) := - λne env t, interp_throw (λne env, K env t) q env. + λne env t, interp_throw (λne env, K env t) k env. Solve All Obligations with solve_proper_please. - Program Definition interp_throwrk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : + Program Definition interp_throwrk {A} (e : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := - λne env t, interp_throw q (λne env, K env t) env. + λne env t, interp_throw e (λne env, K env t) env. Solve All Obligations with solve_proper_please. (** Interpretation for all the syntactic categories: values, expressions, contexts *) From 28ab6f7083a02b1ba9b6c4b5163a95d0685a2b5c Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 23 Nov 2023 17:51:35 +0100 Subject: [PATCH 028/114] throw interp + soundness wip + weak versions of subreifier lemmas --- theories/gitree/greifiers.v | 37 ++- theories/gitree/weakestpre.v | 22 +- theories/input_lang_callcc/interp.v | 284 +++++++++++++++++------ theories/input_lang_callcc/lang.v | 2 +- theories/input_lang_callcc/logpred.v | 323 +++++++++++++-------------- theories/lang_generic_sem.v | 2 +- 6 files changed, 402 insertions(+), 268 deletions(-) diff --git a/theories/gitree/greifiers.v b/theories/gitree/greifiers.v index c1533c4..af67051 100644 --- a/theories/gitree/greifiers.v +++ b/theories/gitree/greifiers.v @@ -163,13 +163,13 @@ Section greifiers. sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X; sR_re (m : nat) {X} `{!Cofe X} (op : opid (sReifier_ops r)) (x : Ins (sReifier_ops r op) ♯ X) - (y : Outs (sReifier_ops r op) ♯ X) + (y : laterO X) (s1 s2 : sReifier_state r ♯ X) (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) : - sReifier_re r op (x, s1, k) ≡{m}≡ Some ((prodO_map k idfun (y, s2))) → + sReifier_re r op (x, s1, k) ≡{m}≡ Some (y, s2) → sReifier_re (rs !!! sR_idx) (subEff_opid op) (subEff_ins x, sR_state s1, ccompose k (subEff_outs ^-1)) ≡{m}≡ - Some (k y, sR_state s2) + Some (y, sR_state s2) }. Lemma ccompose_id_l {A B : ofe} (f : A -n> B) : @@ -227,13 +227,14 @@ Section greifiers. Lemma subReifier_reify_idx {n} (r : sReifier) (rs : gReifiers n) `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) (x : Ins (sReifier_ops _ op) ♯ X) - (y : Outs (sReifier_ops _ op) ♯ X) + (* (y : Outs (sReifier_ops _ op) ♯ X) *) + (y : laterO X) (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) (s1 s2 : sReifier_state r ♯ X) : - sReifier_re r op (x, s1, k) ≡ Some ((prodO_map k idfun (y, s2))) → + sReifier_re r op (x, s1, k) ≡ Some (y, s2) → sReifier_re (rs !!! sR_idx) (subEff_opid op) (subEff_ins x, sR_state s1, ccompose k (subEff_outs ^-1)) ≡ - Some (k y, sR_state s2). + Some (y, sR_state s2). Proof. intros Hx. apply equiv_dist=>m. apply sR_re. by apply equiv_dist. @@ -242,21 +243,19 @@ Section greifiers. Lemma subReifier_reify {n} (r : sReifier) (rs : gReifiers n) `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) + (x : Ins (sReifier_ops _ op) ♯ X) (y : laterO X) (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : - sReifier_re r op (x, σ, k) ≡ Some (prodO_map k idfun (y, σ')) → + sReifier_re r op (x, σ, k) ≡ Some (y, σ') → gReifiers_re rs (subEff_opid op) (subEff_ins x, gState_recomp rest (sR_state σ), ccompose k (subEff_outs ^-1)) - ≡ Some ((ccompose k (subEff_outs ^-1)) (subEff_outs y), gState_recomp rest (sR_state σ')). + ≡ Some (y, gState_recomp rest (sR_state σ')). Proof. intros Hre. eapply subReifier_reify_idx in Hre. rewrite gReifiers_re_idx//. rewrite Hre. simpl. do 3 f_equiv. - unfold ofe_iso_1'; simpl. - by rewrite ofe_iso_21. Qed. (** Lemma for reasoning internally in iProp *) @@ -276,40 +275,38 @@ Section greifiers. Lemma subReifier_reify_idxI (r : sReifier) `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) (x : Ins (sReifier_ops _ op) ♯ X) - (y : Outs (sReifier_ops _ op) ♯ X) + (y : laterO X) (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) (s1 s2 : sReifier_state r ♯ X) : - sReifier_re r op (x, s1, k) ≡ Some (prodO_map k idfun (y, s2)) ⊢@{iProp} + sReifier_re r op (x, s1, k) ≡ Some (y, s2) ⊢@{iProp} sReifier_re (rs !!! sR_idx) (subEff_opid op) (subEff_ins x, sR_state s1, ccompose k (subEff_outs ^-1)) ≡ - Some ((ccompose k (subEff_outs ^-1)) (subEff_outs y), sR_state s2). + Some (y, sR_state s2). Proof. apply uPred.internal_eq_entails=>m. intros H. rewrite sR_re; last first. - rewrite H. reflexivity. - - simpl; rewrite ofe_iso_21. - reflexivity. + - reflexivity. Qed. Lemma subReifier_reifyI (r : sReifier) `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) + (x : Ins (sReifier_ops _ op) ♯ X) (y : laterO X) (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : - sReifier_re r op (x,σ, k) ≡ Some (prodO_map k idfun (y, σ')) ⊢@{iProp} + sReifier_re r op (x,σ, k) ≡ Some (y, σ') ⊢@{iProp} gReifiers_re rs (subEff_opid op) (subEff_ins x, gState_recomp rest (sR_state σ), ccompose k (subEff_outs ^-1)) - ≡ Some ((ccompose k (subEff_outs ^-1)) (subEff_outs y), gState_recomp rest (sR_state σ')). + ≡ Some (y, gState_recomp rest (sR_state σ')). Proof. apply uPred.internal_eq_entails=>m. intros He. eapply sR_re in He. rewrite gReifiers_re_idx//. rewrite He. simpl. - rewrite ofe_iso_21. reflexivity. Qed. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index da0a3e5..04c4096 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -502,8 +502,8 @@ Section weakestpre. forall (x : Ins (F op) ♯ IT) (k : Outs (F op) ♯ IT -n> laterO IT), (|={E1,E2}=> ∃ σ y σ' β, has_state_idx i σ ∗ - sReifier_re (rs !!! i) lop (x, σ, k) ≡ Some (k y, σ') ∗ - k y ≡ Next β ∗ + sReifier_re (rs !!! i) lop (x, σ, k) ≡ Some (y, σ') ∗ + y ≡ Next β ∗ ▷ (£ 1 -∗ has_state_idx i σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. Proof. @@ -514,10 +514,10 @@ Section weakestpre. iModIntro. iExists σ, σ', β. iFrame "Hlst". iIntros (rest). iFrame "H". - iAssert (gReifiers_re rs op (x, gState_recomp rest σ, _) ≡ Some (k y, gState_recomp rest σ'))%I + iAssert (gReifiers_re rs op (x, gState_recomp rest σ, _) ≡ Some (y, gState_recomp rest σ'))%I with "[Hreify]" as "Hgreify". { rewrite gReifiers_re_idx. - iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) (sReifier_re (rs !!! i) lop (x, σ, k)) ≡ optionO_map (prodO_map idfun (gState_recomp rest)) (Some (k y, σ')))%I with "[Hreify]" as "H". + iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) (sReifier_re (rs !!! i) lop (x, σ, k)) ≡ optionO_map (prodO_map idfun (gState_recomp rest)) (Some (y, σ')))%I with "[Hreify]" as "H". - iApply (f_equivI with "Hreify"). - simpl. iExact "H". } @@ -549,8 +549,8 @@ Section weakestpre. (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ IT) (k : Outs (sReifier_ops sR op) ♯ IT -n> laterO IT) : (|={E1,E2}=> ∃ σ y σ' β, has_substate σ ∗ - sReifier_re sR op (x, σ, k) ≡ Some (k y, σ') ∗ - k y ≡ Next β ∗ + sReifier_re sR op (x, σ, k) ≡ Some (y, σ') ∗ + y ≡ Next β ∗ ▷ (£ 1 -∗ has_substate σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) -∗ WP (Vis (subEff_opid op) (subEff_ins x) (k ◎ (subEff_outs)^-1)) @ s;E1 {{ Φ }}. Proof. @@ -558,23 +558,22 @@ Section weakestpre. iApply wp_reify_idx'. iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". iModIntro. - iExists (sR_state σ), (subEff_outs y), (sR_state σ'), β. + iExists (sR_state σ), y, (sR_state σ'), β. simpl. iFrame "Hlst H". rewrite subReifier_reify_idxI. iRewrite "Hreify". simpl. - rewrite ofe_iso_21. by iFrame "Hk". Qed. Lemma wp_subreify E1 s Φ sR `{!subReifier sR rs} (op : opid (sReifier_ops sR)) - (x : Ins (sReifier_ops sR op) ♯ IT) (y : Outs (sReifier_ops sR op) ♯ IT) + (x : Ins (sReifier_ops sR op) ♯ IT) (y : laterO IT) (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) (σ σ' : sReifier_state sR ♯ IT) β : - sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (k ((subEff_outs) y), σ') → - k (subEff_outs y) ≡ Next β → + sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') → + y ≡ Next β → has_substate σ -∗ ▷ (£ 1 -∗ has_substate σ' -∗ WP β @ s;E1 {{ Φ }}) -∗ @@ -588,7 +587,6 @@ Section weakestpre. rewrite reify_vis_eq //. pose proof (@subReifier_reify n sR rs _ IT _ op x y (k ◎ subEff_outs) σ σ' rest) as H. simpl in H. - rewrite (ofe_iso_12 (subEff_outs)) in H. rewrite <-H. - simpl. repeat f_equiv. diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index b5825b9..4ac99ad 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -144,25 +144,17 @@ Section constructors. λne m α, Vis (E:=E) (subEff_opid (inr (inr (inr (inl ()))))) (subEff_ins (F:=ioE) (op:=(inr (inr (inr (inl ()))))) (NextO m, α)) - (λne _, laterO_ap α (NextO m)). + (λne x, Empty_setO_rec _ ((subEff_outs (F:=ioE) (op:=(inr (inr (inr (inl ()))))))^-1 x)). Next Obligation. - solve_proper. + solve_proper_prepare. + destruct ((subEff_outs ^-1) x). Qed. Next Obligation. intros; intros ???; simpl. - repeat f_equiv; [assumption |]. - intros ?; simpl. - apply Next_contractive. - destruct n as [| n]. - - apply dist_later_0. - - apply dist_later_S. - apply dist_later_S in H. - apply H. + repeat f_equiv. assumption. Qed. Next Obligation. intros ?????; simpl. - repeat f_equiv; [assumption |]. - intros ?; simpl. repeat f_equiv; assumption. Qed. @@ -207,7 +199,26 @@ Section weakestpre. { simpl. done. } iModIntro. iIntros "H1 H2". iApply wp_val. by iApply ("Ha" with "H1 H2"). - Unshelve. simpl; constructor. + Qed. + + Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ + WP@{rs} (THROW x f) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + unfold THROW. simpl. + iApply (wp_subreify with "Hs"). + { + simpl. + do 2 f_equiv; reflexivity. + } + { + simpl. + reflexivity. + } + iModIntro. + iApply "Ha". Qed. End weakestpre. @@ -258,12 +269,22 @@ Section interp. Program Definition interp_throw {A} (n : A -n> IT) (m : A -n> IT) : A -n> IT := - λne env, get_fun (λne (f : laterO (IT -n> IT)), - THROW (n env) f) (m env). + λne env, get_val (λne x, get_fun (λne (f : laterO (IT -n> IT)), + THROW x f) (m env)) (n env). Next Obligation. - intros ????. - intros n' x y H. - f_equiv; assumption. + solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intro; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; last done. + intro; simpl. + by repeat f_equiv. Qed. Program Definition interp_natop {A} (op : nat_op) (t1 t2 : A -n> IT) : A -n> IT := @@ -457,8 +478,6 @@ Section interp. + repeat f_equiv. * intros ?; simpl. repeat f_equiv; first by apply interp_expr_ren. - intros ?; simpl. - repeat f_equiv; by apply interp_expr_ren. * by apply interp_expr_ren. - destruct e; simpl. + reflexivity. @@ -487,12 +506,10 @@ Section interp. + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. - + repeat f_equiv; last by apply interp_expr_ren. - intros ?; simpl; repeat f_equiv; first by apply interp_ectx_ren. - intros ?; simpl; repeat f_equiv; by apply interp_ectx_ren. + repeat f_equiv; last by apply interp_ectx_ren. - intros ?; simpl; repeat f_equiv; first by apply interp_val_ren. - intros ?; simpl; repeat f_equiv; by apply interp_val_ren. + intros ?; simpl; repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; last by apply interp_val_ren. + intros ?; simpl; repeat f_equiv; first by apply interp_ectx_ren. Qed. Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): @@ -509,10 +526,7 @@ Section interp. - repeat f_equiv. intros ?; simpl. repeat f_equiv. - + by rewrite IHK. - + intros ?; simpl. - repeat f_equiv. - by rewrite IHK. + by rewrite IHK. Qed. Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') @@ -563,8 +577,6 @@ Section interp. + repeat f_equiv. * intros ?; simpl. repeat f_equiv; first by apply interp_expr_subst. - intros ?; simpl. - repeat f_equiv; by apply interp_expr_subst. * by apply interp_expr_subst. - destruct e; simpl. + reflexivity. @@ -596,12 +608,10 @@ Section interp. + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. - + repeat f_equiv; last by apply interp_expr_subst. - intros ?; simpl; repeat f_equiv; first by apply interp_ectx_subst. - intros ?; simpl; repeat f_equiv; by apply interp_ectx_subst. + repeat f_equiv; last by apply interp_ectx_subst. - intros ?; simpl; repeat f_equiv; first by apply interp_val_subst. - intros ?; simpl; repeat f_equiv; by apply interp_val_subst. + intros ?; simpl; repeat f_equiv; first by apply interp_expr_subst. + + repeat f_equiv; last by apply interp_val_subst. + intros ?; simpl; repeat f_equiv; first by apply interp_ectx_subst. Qed. (** ** Interpretation is a homomorphism (for some constructors) *) @@ -706,22 +716,71 @@ Section interp. + apply NATOP_Err_l, interp_val_asval. Qed. + Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). + Proof. + intros. + by rewrite IT_rec1_ret. + Qed. #[global] Instance interp_ectx_hom_throwr {S} (K : ectx S) (v : val S) env : IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (ThrowRK v K) env). + IT_hom (interp_ectx (ThrowRK v K)%ectx env). Proof. - intros. simple refine (IT_HOM _ _ _ _ _); intros. - - simpl; rewrite -get_fun_tick. - f_equiv. - apply hom_tick. - - simpl; rewrite !hom_vis. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - pose proof (interp_val_asval v (D := env)). + rewrite ->2 get_val_ITV. + simpl. + rewrite hom_tick. + destruct (IT_dont_confuse ((interp_ectx K env α))) as [(e' & HEQ) |[(n & HEQ) |[(f & HEQ) |[(β & HEQ) | (op & i & k & HEQ)]]]]. + + rewrite HEQ !get_fun_tick !get_fun_err. + reflexivity. + + rewrite HEQ !get_fun_tick !get_fun_ret'. + reflexivity. + + rewrite HEQ !get_fun_tick !get_fun_fun//=. + + rewrite HEQ !get_fun_tick. + reflexivity. + + rewrite HEQ !get_fun_tick !get_fun_vis. + reflexivity. + - pose proof (interp_val_asval v (D := env)). + rewrite get_val_ITV. + simpl. + rewrite hom_vis. + rewrite get_fun_vis. f_equiv. intro; simpl. - rewrite laterO_map_compose. + rewrite -laterO_map_compose. + repeat f_equiv. + intro; simpl. + rewrite get_val_ITV. + simpl. reflexivity. - - simpl; by rewrite !hom_err. + - pose proof (interp_val_asval v (D := env)). + rewrite get_val_ITV. + simpl. + rewrite hom_err. + rewrite get_fun_err. + reflexivity. + Qed. + + #[global] Instance interp_ectx_hom_throwl {S} + (K : ectx S) (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (ThrowLK K e)%ectx env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; [by rewrite !hom_tick| | by rewrite !hom_err]. + rewrite !hom_vis. + f_equiv. + intro; simpl. + rewrite -laterO_map_compose. + reflexivity. + Qed. + + #[global] Instance interp_ectx_hom {S} + (K : ectx S) env : + IT_hom (interp_ectx K env). + Proof. + induction K; apply _. Qed. (** ** Finally, preservation of reductions *) @@ -756,29 +815,28 @@ Section interp. Lemma interp_expr_fill_no_reify {S} K (env : interp_scope S) (e e' : expr S) σ σ' n : head_step e σ e' σ' K (n, 0) → - interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. + interp_expr (fill K e) env + ≡ + Tick_n n $ interp_expr (fill K e') env. Proof. intros He. - trans (interp_ectx K env (interp_expr e env)). - { apply interp_comp. } - trans (interp_ectx K env (Tick_n n (interp_expr e' env))). - { - f_equiv. apply (interp_expr_head_step env) in He. - apply He. - } - trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. - { f_equiv. symmetry. apply interp_comp. } - apply hom_tick_n. - Admitted. + rewrite !interp_comp. + erewrite <-hom_tick_n. + - apply (interp_expr_head_step env) in He. + rewrite He. + reflexivity. + - apply _. + Qed. - Opaque INPUT OUTPUT_. + Opaque INPUT OUTPUT_ CALLCC THROW. + Opaque extend_scope. Opaque Ret. Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : head_step e σ e' σ' K (n, 1) → reify (gReifiers_sReifier rs) - (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) + (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). Proof. intros Hst. @@ -789,14 +847,26 @@ Section interp. - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). { repeat f_equiv; eauto. - unshelve erewrite hom_INPUT. - rewrite hom_INPUT. f_equiv. by intro. + rewrite hom_vis. + Transparent INPUT. + unfold INPUT. + simpl. + f_equiv. + intro; simpl. + rewrite laterO_map_Next. + simpl. + reflexivity. } rewrite reify_vis_eq //; last first. { - (* rewrite subReifier_reify/=//. *) - (* rewrite H4. done. *) - admit. + epose proof (@subReifier_reify sz reify_io rs _ IT _ (inl ()) () (Next (interp_ectx K env (Ret n0))) (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr) as H. + simpl in H. + simpl. + erewrite <-H; last first. + - rewrite H5. + reflexivity. + - (* holds *) + admit. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. @@ -809,22 +879,52 @@ Section interp. trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). { do 2 f_equiv; eauto. - rewrite hom_OUTPUT_//. + rewrite hom_vis. + Transparent OUTPUT. + unfold OUTPUT. + Transparent OUTPUT_. + unfold OUTPUT_. + simpl. + f_equiv. + intro; simpl. + rewrite laterO_map_Next. + simpl. + reflexivity. } rewrite reify_vis_eq //; last first. { - (* rewrite subReifier_reify/=//. *) - admit. + epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inl ())) n0 (Next (interp_ectx K env ((Ret 0)))) (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. + simpl in H. + simpl. + erewrite <-H; last first. + - reflexivity. + - (* holds *) + admit. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. reflexivity. - - simpl. + - match goal with + | |- context G [ofe_mor_car _ _ (CALLCC) ?g] => set (f := g) + end. + Transparent CALLCC. + unfold CALLCC. + simpl. rewrite interp_comp. + rewrite interp_expr_subst. + etrans. + { + apply ofe_mor_car_proper; last reflexivity. + apply ofe_mor_car_proper; first reflexivity. + rewrite hom_vis. + reflexivity. + } + subst f. + (* doesnt hold due to a missing tau in reify + extra tick in interp *) admit. Admitted. - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) (G : ∀ (x : S), AsVal (env x)) : + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : prim_step e1 σ1 e2 σ2 (n,m) → ssteps (gReifiers_sReifier rs) (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) @@ -835,9 +935,11 @@ Section interp. { destruct (head_step_io_01 _ _ _ _ _ _ _ H2); subst. - assert (σ1 = σ2) as ->. - { eapply head_step_no_io; eauto. } - eapply (interp_expr_fill_no_reify K) in H2; last done. - rewrite H2. eapply ssteps_tick_n. + { eapply head_step_no_io; eauto. } + unshelve eapply (interp_expr_fill_no_reify K) in H2; first apply env. + rewrite H2. + rewrite interp_comp. + eapply ssteps_tick_n. - inversion H2;subst. + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. rewrite interp_comp. @@ -867,9 +969,47 @@ Section interp. Opaque OUTPUT_. rewrite interp_comp /= get_ret_ret hom_OUTPUT_. eauto. - + admit. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite !interp_comp interp_expr_subst. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + rewrite -interp_comp. + eapply sstep_reify. + { Transparent CALLCC. unfold CALLCC. rewrite interp_comp hom_vis. + f_equiv. reflexivity. + } + rewrite H2. + simpl. + repeat f_equiv. + rewrite -interp_expr_subst. + rewrite interp_comp. + reflexivity. } { + rewrite !interp_comp. + simpl. + pose proof (interp_val_asval v (D := env)). + rewrite get_val_ITV. + simpl. + rewrite get_fun_fun. + simpl. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify; first (rewrite hom_vis; reflexivity). + trans (reify (gReifiers_sReifier rs) (THROW (interp_val v env) (Next (interp_ectx K' env))) (gState_recomp σr (sR_state σ2))). + { + f_equiv; last done. + f_equiv. + rewrite hom_vis. + Transparent THROW. + unfold THROW. + simpl. + f_equiv. + intros x; simpl. + destruct ((subEff_outs ^-1) x). + } + rewrite reify_vis_eq; first (rewrite Tick_eq; reflexivity). + (* holds *) admit. } Admitted. diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index 100902b..10888ca 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -473,7 +473,7 @@ Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) | Throw_step e1 σ e2 (K : ectx S) v K' : e1 = (fill K (Throw (of_val v) (ContV K'))) -> e2 = (fill K' v) -> - prim_step e1 σ e2 σ (0, 0). + prim_step e1 σ e2 σ (1, 0). Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. diff --git a/theories/input_lang_callcc/logpred.v b/theories/input_lang_callcc/logpred.v index eb1da93..96093d4 100644 --- a/theories/input_lang_callcc/logpred.v +++ b/theories/input_lang_callcc/logpred.v @@ -1,7 +1,9 @@ (** Unary (Kripke) logical relation for the IO lang *) From Equations Require Import Equations. From gitrees Require Import gitree program_logic. -From gitrees.input_lang Require Import lang interp. +From gitrees.input_lang_callcc Require Import lang interp. +Require Import gitrees.lang_generic_sem. +Require Import Binding.Lib Binding.Set Binding.Env. Section io_lang. Context {sz : nat}. @@ -9,7 +11,7 @@ Section io_lang. Context `{!subReifier reify_io rs}. Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. - Context `{!SubOfe natO R}. + Context `{SO : !SubOfe natO R}. Notation IT := (IT F R). Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ, !na_invG Σ}. @@ -20,7 +22,6 @@ Section io_lang. Variable (P : A → iProp). Context `{!NonExpansive P}. - Local Notation tyctx := (tyctx ty). Local Notation expr_pred := (expr_pred s rs P). Program Definition interp_tnat : ITV -n> iProp := λne αv, @@ -36,47 +37,53 @@ Section io_lang. match τ with | Tnat => interp_tnat | Tarr τ1 τ2 => interp_tarr (interp_ty τ1) (interp_ty τ2) + | Tcont τ => interp_tarr (interp_ty τ) (constO ((False)%I)) end. - Definition ssubst_valid {S} (Γ : tyctx S) ss := ssubst_valid rs interp_ty Γ ss. + Program Definition ı_scope + : @interp_scope F R _ ∅ := λne x, match x with end. + + Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S : Set} (Γ : S -> ty) (ss : S [⇒] ∅) : iProp := + (∀ x, □ expr_pred (interp_expr _ (ss x) ı_scope) (interp_ty (Γ x)))%I. #[global] Instance io_lang_interp_ty_pers τ βv : Persistent (io_lang.interp_ty τ βv). Proof. induction τ; apply _. Qed. - #[global] Instance ssubst_valid_pers {S} (Γ : tyctx S) ss : Persistent (ssubst_valid Γ ss). - Proof. apply _. Qed. + #[global] Instance ssubst_valid_pers {S : Set} (Γ : S -> ty) ss : Persistent (ssubst_valid interp_ty Γ ss). + Proof. + apply _. + Qed. - Program Definition valid1 {S} (Γ : tyctx S) (α : interp_scope S -n> IT) (τ : ty) : iProp := - (∀ σ ss, has_substate σ -∗ ssubst_valid Γ ss -∗ - expr_pred (α (interp_ssubst ss)) (λne v, ∃ σ', interp_ty τ v ∗ has_substate σ'))%I. + Program Definition valid1 {S : Set} (Γ : S -> ty) (α : @interp_scope F R _ S -n> IT) (τ : ty) : iProp := + (∀ σ ss, has_substate σ -∗ ssubst_valid interp_ty Γ ss -∗ + expr_pred (α ((@sub_scope sz rs R _ SO _ S ∅ ss ı_scope))) (λne v, ∃ σ', interp_ty τ v ∗ has_substate σ'))%I. Solve Obligations with solve_proper. - Lemma compat_nat {S} n (Ω : tyctx S) : + Lemma compat_nat {S : Set} n (Ω : S -> ty) : ⊢ valid1 Ω (interp_nat rs n) Tnat. Proof. iIntros (σ αs) "Hs Has". simpl. iApply expr_pred_ret. simpl. eauto with iFrame. Qed. - Lemma compat_var {S} Ω τ (v : var S) : - typed_var Ω v τ → + Lemma compat_var {S : Set} Ω τ (v : S) : + Ω v = τ → ⊢ valid1 Ω (interp_var v) τ. Proof. intros Hv. iIntros (σ ss) "Hs Has". simpl. - unfold ssubst_valid. - iInduction Hv as [|? ? ? Ω v] "IH" forall (ss); simpl. - - dependent elimination ss as [cons_ssubst αv ss]. - rewrite ssubst_valid_cons. - simp interp_var. simpl. - iDestruct "Has" as "[H _]". - iApply expr_pred_ret; simpl; eauto with iFrame. - - dependent elimination ss as [cons_ssubst αv ss]. - rewrite ssubst_valid_cons. - simp interp_var. simpl. - iDestruct "Has" as "[_ H]". - by iApply ("IH" with "Hs H"). + iIntros (x) "G". + iDestruct ("Has" $! v x with "G") as "Has". + iApply (wp_wand with "[$Has] [Hs]"). + iIntros (v') "(%y & H1 & H2)". + iModIntro. + iExists y. + iFrame "H2". + iExists σ. + subst. + iFrame. Qed. - Lemma compat_if {S} (Γ : tyctx S) τ α β1 β2 : + + Lemma compat_if {S : Set} (Γ : S -> ty) τ α β1 β2 : ⊢ valid1 Γ α Tnat -∗ valid1 Γ β1 τ -∗ valid1 Γ β2 τ -∗ @@ -85,19 +92,19 @@ Section io_lang. iIntros "H0 H1 H2". iIntros (σ ss) "Hs #Has". iSpecialize ("H0" with "Hs Has"). - simpl. iApply (expr_pred_bind (IFSCtx _ _) with "H0"). - iIntros (αv) "Ha/=". - iDestruct "Ha" as (σ') "[Ha Hs]". - iDestruct "Ha" as (n) "Hn". - unfold IFSCtx. iIntros (x) "Hx". - iRewrite "Hn". - destruct n as [|n]. - - rewrite IF_False; last lia. - iApply ("H2" with "Hs Has Hx"). - - rewrite IF_True; last lia. - iApply ("H1" with "Hs Has Hx"). - Qed. - Lemma compat_input {S} (Γ : tyctx S) : + simpl. (* iApply (expr_pred_bind (IFSCtx _ _) with "H0"). *) + (* iIntros (αv) "Ha/=". *) + (* iDestruct "Ha" as (σ') "[Ha Hs]". *) + (* iDestruct "Ha" as (n) "Hn". *) + (* unfold IFSCtx. iIntros (x) "Hx". *) + (* iRewrite "Hn". *) + (* destruct n as [|n]. *) + (* - rewrite IF_False; last lia. *) + (* iApply ("H2" with "Hs Has Hx"). *) + (* - rewrite IF_True; last lia. *) + (* iApply ("H1" with "Hs Has Hx"). *) + Admitted. + Lemma compat_input {S : Set} (Γ : S -> ty) : ⊢ valid1 Γ (interp_input rs) Tnat. Proof. iIntros (σ ss) "Hs #Has". @@ -108,26 +115,27 @@ Section io_lang. iNext. iIntros "_ Hs". iApply wp_val. simpl. eauto with iFrame. Qed. - Lemma compat_output {S} (Γ : tyctx S) α : + + Lemma compat_output {S : Set} (Γ : S -> ty) α : ⊢ valid1 Γ α Tnat → valid1 Γ (interp_output rs α) Tnat. Proof. iIntros "H". iIntros (σ ss) "Hs #Has". iSpecialize ("H" with "Hs Has"). simpl. - iApply (expr_pred_bind (get_ret _) with "H"). - iIntros (αv) "Ha". - iDestruct "Ha" as (σ') "[Ha Hs]". - iDestruct "Ha" as (n) "Hn". - iApply expr_pred_frame. - iRewrite "Hn". - rewrite get_ret_ret. - iApply (wp_output with "Hs"). - { reflexivity. } - iNext. iIntros "_ Hs /=". - eauto with iFrame. - Qed. - Lemma compat_app {S} (Γ : tyctx S) α β τ1 τ2 : + (* iApply (expr_pred_bind (get_ret _) with "H"). *) + (* iIntros (αv) "Ha". *) + (* iDestruct "Ha" as (σ') "[Ha Hs]". *) + (* iDestruct "Ha" as (n) "Hn". *) + (* iApply expr_pred_frame. *) + (* iRewrite "Hn". *) + (* rewrite get_ret_ret. *) + (* iApply (wp_output with "Hs"). *) + (* { reflexivity. } *) + (* iNext. iIntros "_ Hs /=". *) + (* eauto with iFrame. *) + Admitted. + Lemma compat_app {S : Set} (Γ : S -> ty) α β τ1 τ2 : ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ valid1 Γ β τ1 -∗ valid1 Γ (interp_app rs α β) τ2. @@ -135,24 +143,24 @@ Section io_lang. iIntros "H1 H2". iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). - iApply (expr_pred_bind (AppRSCtx _) with "H2"). - iIntros (βv) "Hb/=". - iDestruct "Hb" as (σ') "[Hb Hs]". - unfold AppRSCtx. - iSpecialize ("H1" with "Hs Has"). - iApply (expr_pred_bind (AppLSCtx (IT_of_V βv)) with "H1"). - iIntros (αv) "Ha". - iDestruct "Ha" as (σ'') "[Ha Hs]". - unfold AppLSCtx. - iApply ("Ha" with "Hs Hb"). - Qed. + (* iApply (expr_pred_bind (AppRSCtx _) with "H2"). *) + (* iIntros (βv) "Hb/=". *) + (* iDestruct "Hb" as (σ') "[Hb Hs]". *) + (* unfold AppRSCtx. *) + (* iSpecialize ("H1" with "Hs Has"). *) + (* iApply (expr_pred_bind (AppLSCtx (IT_of_V βv)) with "H1"). *) + (* iIntros (αv) "Ha". *) + (* iDestruct "Ha" as (σ'') "[Ha Hs]". *) + (* unfold AppLSCtx. *) + (* iApply ("Ha" with "Hs Hb"). *) + Admitted. - Lemma compat_rec {S} (Γ : tyctx S) τ1 τ2 α : - ⊢ □ valid1 (consC (Tarr τ1 τ2) (consC τ1 Γ)) α τ2 -∗ + Lemma compat_rec {S : Set} (Γ : S -> ty) τ1 τ2 α : + ⊢ □ valid1 ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) α τ2 -∗ valid1 Γ (interp_rec rs α) (Tarr τ1 τ2). Proof. iIntros "#H". iIntros (σ ss) "Hs #Hss". - pose (env := (interp_ssubst ss)). fold env. + pose (env := (sub_scope rs ss ı_scope)). fold env. simp subst_expr. pose (f := (ir_unf rs α env)). iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". @@ -165,20 +173,10 @@ Section io_lang. iIntros (x) "Hx". iApply wp_lam. iNext. - pose (ss' := cons_ssubst (FunV (Next f)) (cons_ssubst βv ss)). - iSpecialize ("H" $! _ ss' with "Hs []"). - { unfold ssubst_valid. - unfold ss'. - rewrite !ssubst_valid_cons. - by iFrame "IH Hw Hss". } unfold f. simpl. - unfold ss'. simp interp_ssubst. - iAssert (IT_of_V (FunV (Next f)) ≡ interp_rec rs α env)%I as "Heq". - { rewrite interp_rec_unfold. done. } - iRewrite -"Heq". by iApply "H". - Qed. + Admitted. - Lemma compat_natop {S} (Γ : tyctx S) op α β : + Lemma compat_natop {S : Set} (Γ : S -> ty) op α β : ⊢ valid1 Γ α Tnat -∗ valid1 Γ β Tnat -∗ valid1 Γ (interp_natop _ op α β) Tnat. @@ -186,44 +184,45 @@ Section io_lang. iIntros "H1 H2". iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). - iApply (expr_pred_bind (NatOpRSCtx _ _) with "H2"). - iIntros (βv) "Hb/=". - iDestruct "Hb" as (σ') "[Hb Hs]". - unfold NatOpRSCtx. - iSpecialize ("H1" with "Hs Has"). - iApply (expr_pred_bind (NatOpLSCtx _ (IT_of_V βv)) with "H1"). - iIntros (αv) "Ha". - iDestruct "Ha" as (σ'') "[Ha Hs]". - unfold NatOpLSCtx. - iDestruct "Hb" as (n1) "Hb". - iDestruct "Ha" as (n2) "Ha". - iRewrite "Hb". iRewrite "Ha". - simpl. iApply expr_pred_frame. - rewrite NATOP_Ret. iApply wp_val. simpl. - eauto with iFrame. - Qed. + (* iApply (expr_pred_bind (NatOpRSCtx _ _) with "H2"). *) + (* iIntros (βv) "Hb/=". *) + (* iDestruct "Hb" as (σ') "[Hb Hs]". *) + (* unfold NatOpRSCtx. *) + (* iSpecialize ("H1" with "Hs Has"). *) + (* iApply (expr_pred_bind (NatOpLSCtx _ (IT_of_V βv)) with "H1"). *) + (* iIntros (αv) "Ha". *) + (* iDestruct "Ha" as (σ'') "[Ha Hs]". *) + (* unfold NatOpLSCtx. *) + (* iDestruct "Hb" as (n1) "Hb". *) + (* iDestruct "Ha" as (n2) "Ha". *) + (* iRewrite "Hb". iRewrite "Ha". *) + (* simpl. iApply expr_pred_frame. *) + (* rewrite NATOP_Ret. iApply wp_val. simpl. *) + (* eauto with iFrame. *) + Admitted. - Lemma fundamental {S} (Γ : tyctx S) e τ : + Lemma fundamental {S : Set} (Γ : S -> ty) e τ : typed Γ e τ → ⊢ valid1 Γ (interp_expr rs e) τ - with fundamental_val {S} (Γ : tyctx S) v τ : + with fundamental_val {S : Set} (Γ : S -> ty) v τ : typed_val Γ v τ → ⊢ valid1 Γ (interp_val rs v) τ. Proof. - destruct 1. + by iApply fundamental_val. + by iApply compat_var. - + iApply compat_rec; iApply fundamental; eauto. + iApply compat_app; iApply fundamental; eauto. + iApply compat_natop; iApply fundamental; eauto. + iApply compat_if; iApply fundamental; eauto. + iApply compat_input. + iApply compat_output; iApply fundamental; eauto. + + admit. + + admit. - destruct 1. + iApply compat_nat. + iApply compat_rec; iApply fundamental; eauto. - Qed. - Lemma fundmanetal_closed (e : expr []) (τ : ty) : - typed empC e τ → - ⊢ valid1 empC (interp_expr rs e) τ. + Admitted. + Lemma fundmanetal_closed (e : expr ∅) (τ : ty) : + typed □ e τ → + ⊢ valid1 □ (interp_expr rs e) τ. Proof. apply fundamental. Qed. End io_lang. @@ -235,65 +234,65 @@ Local Definition rs : gReifiers _ := gReifiers_cons reify_io 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 Σ} τ (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : - (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ}, - (£ cr ⊢ valid1 rs notStuck (λ _:unitO, True)%I empC α τ)%I) → - ssteps (gReifiers_sReifier rs) (α ()) 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 (interp_ty (s:=notStuck) (P:=(λ _:unitO, True)) τ)%I. split. - { 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" $! σ with "Hs []"). - { iApply ssubst_valid_nil. } - iSpecialize ("Hlog" $! tt with "[//]"). - iApply (wp_wand with"Hlog"). - iIntros ( βv). simpl. iDestruct 1 as (_) "[H _]". - iDestruct "H" as (σ1') "[$ Hsts]". - done. -Qed. +(* 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 ⊢ valid1 rs notStuck (λ _:unitO, True)%I □ α τ)%I) → *) +(* ssteps (gReifiers_sReifier rs) (α (@ı_scope _ rs R _)) 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 (interp_ty (s:=notStuck) (P:=(λ _:unitO, True)) τ)%I. split. *) +(* { 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" $! σ with "Hs []"). *) +(* { iApply ssubst_valid_nil. } *) +(* iSpecialize ("Hlog" $! tt with "[//]"). *) +(* iApply (wp_wand with"Hlog"). *) +(* iIntros ( βv). simpl. iDestruct 1 as (_) "[H _]". *) +(* iDestruct "H" as (σ1') "[$ Hsts]". *) +(* done. *) +(* Qed. *) -Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : - typed empC e τ → - ssteps (gReifiers_sReifier rs) (interp_expr _ e ()) (σ,()) β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) - ∨ (∃ βv, IT_of_V βv ≡ β). -Proof. - intros Htyped Hsteps. - pose (Σ:=#[invΣ;stateΣ rs natO]). - assert (invGpreS Σ). - { apply _. } - assert (statePreG rs natO Σ). - { apply _. } - eapply (logpred_adequacy 0 Σ); eauto. - intros ? ?. iIntros "_". - by iApply fundamental. -Qed. +(* Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : *) +(* typed empC e τ → *) +(* ssteps (gReifiers_sReifier rs) (interp_expr _ e ()) (σ,()) β st' k → *) +(* (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) *) +(* ∨ (∃ βv, IT_of_V βv ≡ β). *) +(* Proof. *) +(* intros Htyped Hsteps. *) +(* pose (Σ:=#[invΣ;stateΣ rs natO]). *) +(* assert (invGpreS Σ). *) +(* { apply _. } *) +(* assert (statePreG rs natO Σ). *) +(* { apply _. } *) +(* eapply (logpred_adequacy 0 Σ); eauto. *) +(* intros ? ?. iIntros "_". *) +(* by iApply fundamental. *) +(* Qed. *) diff --git a/theories/lang_generic_sem.v b/theories/lang_generic_sem.v index 609e75e..905839d 100644 --- a/theories/lang_generic_sem.v +++ b/theories/lang_generic_sem.v @@ -108,7 +108,7 @@ Section kripke_logrel. #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . Proof. solve_proper. Qed. - (* Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : tyctx ty S) (ss : ssubst S) : iProp := *) + (* Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : S -> ty) (ss : ssubst S) : iProp := *) (* ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), *) (* interp_ty (τx.1) (τx.2))%I. *) From 07a7d599e94d844ada41d7ff5b65d34b5503f941 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Fri, 24 Nov 2023 17:30:54 +0100 Subject: [PATCH 029/114] wp_safety + some progress on denotsem --- theories/gitree/reductions.v | 36 ++-- theories/gitree/reify.v | 208 ++++++++++------------ theories/gitree/weakestpre.v | 7 +- theories/input_lang_callcc/interp.v | 101 +++++++++-- theories/input_lang_callcc/logpred.v | 255 +++++++++++++++------------ theories/lang_generic_sem.v | 70 ++------ theories/program_logic.v | 12 +- 7 files changed, 374 insertions(+), 315 deletions(-) diff --git a/theories/gitree/reductions.v b/theories/gitree/reductions.v index 3a34e9b..f9fef88 100644 --- a/theories/gitree/reductions.v +++ b/theories/gitree/reductions.v @@ -201,7 +201,7 @@ Section istep. Qed. (* ctx-free steps *) - Local Lemma effect_safe_externalize (α : IT) σ {G : ∀ o, CtxIndep r IT o} : + Local Lemma effect_safe_externalize (α : IT) σ : (⊢ ∃ β σ', (∃ op i k, α ≡ Vis op i k ∧ reify r α σ ≡ (σ', Tick β)) : iProp) → ∃ β σ', sstep r α σ β σ'. Proof. @@ -228,8 +228,7 @@ Section istep. + destruct (reify r (Vis op i k) σ) as [σ1 α1] eqn:Hr. assert ((∃ α' : IT, α1 ≡ Tick α') ∨ (α1 ≡ Err RuntimeErr)) as [[α' Ha']| Ha']. { eapply (reify_is_always_a_tick r op i k σ). - - apply G. - - by rewrite Hr. + by rewrite Hr. } * exists α',σ1. eapply sstep_reify; eauto. rewrite -Ha' -Hr; repeat f_equiv; eauto. @@ -258,7 +257,7 @@ Section istep. (* this is true only for iProp/uPred? *) Definition disjunction_property (P Q : iProp) := (⊢ P ∨ Q) → (⊢ P) ∨ (⊢ Q). - Lemma istep_safe_sstep α σ {G : ∀ o, CtxIndep r IT o} : + Lemma istep_safe_sstep α σ : (∀ P Q, disjunction_property P Q) → (⊢ ∃ β σ', istep α σ β σ') → ∃ β σ', sstep r α σ β σ'. Proof. @@ -338,7 +337,7 @@ Section istep. iRewrite -"Ha". iRewrite "Hs". done. Qed. - Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' {G : ∀ o, CtxIndep r IT o} : + Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' : istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. Proof. iDestruct 1 as "[[Ha Hs]|H]". @@ -350,10 +349,11 @@ Section istep. { iPureIntro. apply hom_vis. } iRewrite "Ha". iRewrite "Ha" in "Hr". iRewrite "Hf". iSplit; first done. - iApply (reify_vis_cont with "Hr"). - Qed. - Lemma istep_hom_inv α σ β σ' `{!IT_hom f} {G : ∀ o, CtxIndep r IT o} : + (* iApply (reify_vis_cont with "Hr"). *) + Admitted. + + Lemma istep_hom_inv α σ β σ' `{!IT_hom f} : istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). Proof. @@ -387,15 +387,15 @@ Section istep. + iDestruct "H" as (op' i' k') "[#Ha Hr]". iPoseProof (Vis_inj_op' with "Ha") as "<-". iPoseProof (Vis_inj' with "Ha") as "[Hi Hk]". - iPoseProof (reify_input_cont_inv r op i k fi with "Hr") as (α') "[Hr Ha']". - iAssert (reify r α σ ≡ (σ', Tick α'))%I with "[Hr]" as "Hr". - { iRewrite -"Hr". iPureIntro. repeat f_equiv. - apply Ha. } - iSplit. { iPureIntro. by rewrite Ha IT_to_V_Vis. } - iExists α'. iFrame "Ha'". - rewrite /istep. iRight. - iExists op,i,k. iFrame "Hr". - iPureIntro. apply Ha. - Qed. + (* iPoseProof (reify_input_cont_inv r op i k fi with "Hr") as (α') "[Hr Ha']". *) + (* iAssert (reify r α σ ≡ (σ', Tick α'))%I with "[Hr]" as "Hr". *) + (* { iRewrite -"Hr". iPureIntro. repeat f_equiv. *) + (* apply Ha. } *) + (* iSplit. { iPureIntro. by rewrite Ha IT_to_V_Vis. } *) + (* iExists α'. iFrame "Ha'". *) + (* rewrite /istep. iRight. *) + (* iExists op,i,k. iFrame "Hr". *) + (* iPureIntro. apply Ha. *) + Admitted. End istep. diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 3e6862a..541b1f8 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -25,12 +25,12 @@ Section reifiers. Implicit Type op : opid F. Implicit Type α β : IT. - Class CtxIndep (X : ofe) `{!Cofe X} (op : opid F) := { - cont_irrelev : - (∃ f : (prodO (Ins (sReifier_ops r _) ♯ X) ((sReifier_state r) ♯ X)) -n> - optionO (prodO (Outs (sReifier_ops r _) ♯ X) (sReifier_state r ♯ X)), - ∀ i σ κ, @sReifier_re _ X _ op (i, σ, κ) ≡ fmap (prodO_map κ idfun) (f (i, σ))); - }. + (* Class CtxIndep (X : ofe) `{!Cofe X} (op : opid F) := { *) + (* cont_irrelev : *) + (* (∃ f : (prodO (Ins (sReifier_ops r _) ♯ X) ((sReifier_state r) ♯ X)) -n> *) + (* optionO (prodO (Outs (sReifier_ops r _) ♯ X) (sReifier_state r ♯ X)), *) + (* ∀ i σ κ, @sReifier_re _ X _ op (i, σ, κ) ≡ fmap (prodO_map κ idfun) (f (i, σ))); *) + (* }. *) Notation stateM := ((stateF ♯ IT -n> (stateF ♯ IT) * IT)). #[local] Instance stateT_inhab : Inhabited stateM. @@ -229,9 +229,8 @@ Section reifiers. - reflexivity. Qed. - (* true only for ctx-independent effects *) - Lemma reify_vis_cont op i k1 k2 σ1 σ2 β - {PROP : bi} `{!BiInternalEq PROP} `{H : !(@CtxIndep IT _ op)} : + Lemma reify_vis_cont op i k1 (k2 : IT -n> IT) σ1 σ2 β + {PROP : bi} `{!BiInternalEq PROP} (* (H : IT_hom k2) *) : (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. Proof. @@ -240,125 +239,104 @@ Section reifiers. iIntros "Hr". iExFalso. iPoseProof (prod_equivI with "Hr") as "[_ Hk]". simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. - - destruct H as [[f H]]. - pose proof (H i σ1 k1) as H1. - pose proof (H i σ1 (laterO_map k2 ◎ k1)) as H2. - assert (∃ o σ', f (i, σ1) = Some (o, σ')) as [o' [σ' H3]]. - { - destruct (f (i, σ1)) as [[? ?] | ?]; first (do 2 eexists; reflexivity). - simpl in H1. rewrite Hre in H1; inversion H1. - } - rewrite H3 in H1. - simpl in H1. - rewrite H3 in H2. - simpl in H2. - clear f H H3 Hre. - rewrite reify_vis_eq; last first. - { by rewrite H1. } + - (* destruct H as [[f H]]. *) + (* pose proof (H i σ1 k1) as H1. *) + (* pose proof (H i σ1 (laterO_map k2 ◎ k1)) as H2. *) + (* assert (∃ o σ', f (i, σ1) = Some (o, σ')) as [o' [σ' H3]]. *) + (* { *) + (* destruct (f (i, σ1)) as [[? ?] | ?]; first (do 2 eexists; reflexivity). *) + (* simpl in H1. rewrite Hre in H1; inversion H1. *) + (* } *) + (* rewrite H3 in H1. *) + (* simpl in H1. *) + (* rewrite H3 in H2. *) + (* simpl in H2. *) + (* clear f H H3 Hre. *) rewrite reify_vis_eq; last first. - { by rewrite H2. } + { by rewrite Hre. } iIntros "Hr". iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". - iApply prod_equivI. simpl. iSplit; eauto. iPoseProof (Tau_inj' with "Hk") as "Hk". - iApply Tau_inj'. iRewrite "Hk". - rewrite laterO_map_Next. done. - Qed. - - Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β - {PROP : bi} `{!BiInternalEq PROP} `{H : !(@CtxIndep IT _ op)} : - (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) - ⊢ ∃ α, reify (Vis op i k1) σ1 ≡ (σ2, Tick α) ∧ ▷ (β ≡ k2 α) - : PROP)%I. - Proof. - destruct (sReifier_re r op (i, σ1, (laterO_map k2 ◎ k1))) as [[o σ2']|] eqn:Hre; last first. - - rewrite reify_vis_None; last by rewrite Hre//. - iIntros "Hr". iExFalso. - iPoseProof (prod_equivI with "Hr") as "[_ Hk]". - simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. - - rewrite reify_vis_eq; last first. - { by rewrite Hre. } - iIntros "Hr". simpl. - iPoseProof (prod_equivI with "Hr") as "[#Hs #Hk]". simpl. - iPoseProof (Tau_inj' with "Hk") as "Hk'". - destruct H as [[f H]]. - pose proof (H i σ1 k1) as H1. - pose proof (H i σ1 (laterO_map k2 ◎ k1)) as H2. - assert (∃ o, f (i, σ1) ≡ Some (o, σ2')) as [o' H3]. - { - destruct (f (i, σ1)) as [[? ?] | ?]. - - simpl in H2. - rewrite Hre in H2. - inversion H2 as [? ? H2' |]; subst; inversion H2'; simpl in *; subst. - eexists _; do 2 f_equiv; first reflexivity; symmetry; assumption. - - simpl in H2. - rewrite Hre in H2. - inversion H2. - } - rewrite H3 in H1. - simpl in H1. - rewrite H3 in H2. - simpl in H2. - destruct (Next_uninj (k1 o')) as [a Hk1]. - iExists (a). - rewrite reify_vis_eq; last first. - { by rewrite H1. } - iSplit. - + iApply prod_equivI. simpl. iSplit; eauto. - iApply Tau_inj'. done. - + iAssert (laterO_map k2 (Next a) ≡ Next β)%I as "Ha". - { - iSimpl in "Hk'". iRewrite -"Hk'". - iPureIntro. rewrite -Hk1. - rewrite Hre in H2. - inversion H2 as [? ? H2' |]; subst; inversion H2'; simpl in *; subst. - symmetry; assumption. - } - iAssert (Next (k2 a) ≡ Next β)%I as "Hb". - { iRewrite -"Ha". iPureIntro. - rewrite laterO_map_Next. done. } - iNext. by iApply internal_eq_sym. - Qed. + (* pose proof hom_vis. *) + (* rewrite H. *) + (* iRewrite - "Hs". *) + (* rewrite reify_vis_eq; last first. *) + (* { by rewrite Hre. } *) + (* iRewrite "Hk". *) + (* rewrite -Tick_eq. *) + (* done. *) + (* reflexivity. *) + (* rewrite term *) + (* iApply prod_equivI. simpl. *) + (* iSplit; eauto. *) + (* iApply Tau_inj'. iRewrite "Hk". *) + (* rewrite laterO_map_Next. done. *) + Admitted. + + (* Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β *) + (* {PROP : bi} `{!BiInternalEq PROP} *) + (* (g : (IT -n> IT) -n> (prodO (stateF ♯ IT) IT) -n> (prodO (stateF ♯ IT) IT)) *) + (* (H : reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (g k2) (reify (Vis op i k1) σ1)) *) + (* : *) + (* (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) *) + (* ⊢ ∃ α, reify (Vis op i k1) σ1 ≡ (σ2, Tick α) ∧ ▷ (β ≡ k2 α) *) + (* : PROP)%I. *) + (* Proof. *) + (* destruct (sReifier_re r op (i, σ1, (laterO_map k2 ◎ k1))) as [[o σ2']|] eqn:Hre; last first. *) + (* - rewrite reify_vis_None; last by rewrite Hre//. *) + (* iIntros "Hr". iExFalso. *) + (* iPoseProof (prod_equivI with "Hr") as "[_ Hk]". *) + (* simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. *) + (* - rewrite reify_vis_eq; last first. *) + (* { by rewrite Hre. } *) + (* iIntros "Hr". simpl. *) + (* iPoseProof (prod_equivI with "Hr") as "[#Hs #Hk]". *) + (* simpl. *) + (* iPoseProof (Tau_inj' with "Hk") as "Hk'". *) + (* destruct (Next_uninj o) as [a Hk1]. *) + (* iExists (a). *) + (* assert (Hre' : sReifier_re r op (i, σ1, laterO_map k2 ◎ k1) ≡ Some (o, σ2')). *) + (* { by rewrite Hre. } *) + (* apply reify_vis_eq in Hre'. *) + (* rewrite Hre' in H. *) + (* rewrite H. *) + (* iRewrite - "Hr". *) + (* epose proof (reify_vis_eq _ _ _ _ _ _ Hre). *) + (* rewrite reify_vis_eq; last first. *) + (* { by rewrite H1. } *) + (* iSplit. *) + (* + iApply prod_equivI. simpl. iSplit; eauto. *) + (* iApply Tau_inj'. done. *) + (* + iAssert (laterO_map k2 (Next a) ≡ Next β)%I as "Ha". *) + (* { *) + (* iSimpl in "Hk'". iRewrite -"Hk'". *) + (* iPureIntro. rewrite -Hk1. *) + (* rewrite Hre in H2. *) + (* inversion H2 as [? ? H2' |]; subst; inversion H2'; simpl in *; subst. *) + (* symmetry; assumption. *) + (* } *) + (* iAssert (Next (k2 a) ≡ Next β)%I as "Hb". *) + (* { iRewrite -"Ha". iPureIntro. *) + (* rewrite laterO_map_Next. done. } *) + (* iNext. by iApply internal_eq_sym. *) + (* Qed. *) - Lemma reify_is_always_a_tick op x k σ β σ' `{H : !(@CtxIndep IT _ op)} : + Lemma reify_is_always_a_tick op x k σ β σ' : reify (Vis op x k) σ ≡ (σ', β) → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). Proof. destruct (sReifier_re r op (x, σ, k)) as [[o σ'']|] eqn:Hre; last first. - rewrite reify_vis_None; last by rewrite Hre//. intros [_ ?]. by right. - - destruct H as [[f H]]. - specialize (H x σ k). - rewrite reify_vis_eq; last by rewrite Hre. + - rewrite reify_vis_eq;last by rewrite Hre. intros [? Ho]. + left. simpl in *. - assert (∃ o, f (x, σ) ≡ Some (o, σ'')) as [o' H']. - { - destruct (f (x, σ)) as [[? ?] | ?]. - - simpl in H. - rewrite Hre in H. - inversion H as [? ? H' |]; subst; inversion H'; simpl in *; subst. - eexists _; do 2 f_equiv; first reflexivity; symmetry; assumption. - - simpl in H. - rewrite Hre in H. - inversion H. - } - assert (H'' : sReifier_re r op (x, σ, k) ≡ (prodO_map k idfun) <$> (Some (o', σ''))). - { - rewrite H. - f_equiv. - - intros ???; simpl. - solve_proper. - - assumption. - } - simpl in H''. - rewrite Hre in H''. - inversion H'' as [? ? H''' |]; subst; inversion H''' as [H1 ?]; simpl in *; subst. - rewrite <-!Ho, H1. - destruct (Next_uninj (k o')) as [lβ Hlb]. - left. exists (lβ). - rewrite Tick_eq. - rewrite -Hlb. symmetry. rewrite -H1. apply Ho. + destruct (Next_uninj o) as [t Ht]. + exists (t). + rewrite <-Ho. + rewrite Ht. + reflexivity. Qed. End reifiers. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index 04c4096..e549a24 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -371,7 +371,7 @@ Section weakestpre. iIntros "H". iApply (wp_wand with "H"); auto. Qed. - Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 {G : ∀ o : opid F, CtxIndep rG IT o} : + Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 (* {G : ∀ o : opid F, CtxIndep rG IT o} *) : WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. Proof. assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). @@ -411,6 +411,7 @@ Section weakestpre. iDestruct "Hsafe" as "[Hsafe|Herr]". - iDestruct "Hsafe" as (α' σ') "Hsafe". iLeft. iExists (f α'), σ'. iApply (istep_hom with "Hsafe"). + - iDestruct "Herr" as (e) "[Herr %]". iRight. iExists e. iSplit; last done. iRewrite "Herr". rewrite hom_err//. } @@ -835,8 +836,7 @@ Proof. Qed. Lemma wp_safety cr Σ `{!invGpreS Σ} n (rs : gReifiers n) - {A} `{!Cofe A} `{!statePreG rs A Σ} s k {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) (IT (sReifier_ops (gReifiers_sReifier rs)) A) o} + {A} `{!Cofe A} `{!statePreG rs A Σ} s k (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : (∀ Σ P Q, @disjunction_property Σ P Q) → ssteps (gReifiers_sReifier rs) α σ β σ' k → @@ -853,7 +853,6 @@ Proof. { intros [Hprf | Hprf]%Hdisj. - left. apply (istep_safe_sstep _ (Σ:=Σ)). - { apply G. } { apply Hdisj. } done. - right. diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 09a7dc2..2fd50fd 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -24,7 +24,6 @@ Program Definition callccE : opInterp := Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); Outs := (▶ ∙); |}. - Program Definition throwE : opInterp := {| Ins := (▶ ∙ * (▶ (∙ -n> ∙))); @@ -365,8 +364,15 @@ Section interp. λne env, Ret n. Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := - λne env, Fun (Next (K env)). + λne env, (Fun (Next (λne x, Tau (laterO_map (K env) (Next x))))). Solve All Obligations with solve_proper. + Next Obligation. + intros. + solve_proper_prepare. + repeat f_equiv. + intro; simpl. + by repeat f_equiv. + Qed. Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := @@ -522,7 +528,8 @@ Section interp. * by iRewrite - "IH". * done. + repeat f_equiv. - intros ?; simpl; by apply interp_ectx_ren. + intros ?; simpl. + repeat f_equiv; by apply interp_ectx_ren. - destruct e; simpl; intros ?; simpl. + reflexivity. + repeat f_equiv; by apply interp_ectx_ren. @@ -624,7 +631,8 @@ Section interp. iApply internal_eq_pointwise. iIntros (z). done. - + repeat f_equiv; by apply interp_ectx_subst. + + repeat f_equiv; intro; simpl; repeat f_equiv. + by apply interp_ectx_subst. - destruct e; simpl; intros ?; simpl. + reflexivity. + repeat f_equiv; by apply interp_ectx_subst. @@ -803,8 +811,8 @@ Section interp. #[global] Instance interp_ectx_hom {S} (K : ectx S) env : IT_hom (interp_ectx K env). - Proof. - induction K; apply _. + Proof. + induction K; apply _. Qed. (** ** Finally, preservation of reductions *) @@ -844,7 +852,7 @@ Section interp. Tick_n n $ interp_expr (fill K e') env. Proof. intros He. - rewrite !interp_comp. + rewrite !interp_comp. erewrite <-hom_tick_n. - apply (interp_expr_head_step env) in He. rewrite He. @@ -933,7 +941,7 @@ Section interp. end. Transparent CALLCC. unfold CALLCC. - simpl. + simpl. rewrite interp_comp. rewrite interp_expr_subst. etrans. @@ -943,7 +951,80 @@ Section interp. rewrite hom_vis. reflexivity. } - subst f. + (* subst f. *) + unfold sub_scope. + + unshelve eassert ((extend_scope env (λit x : IT, Tau (laterO_map (interp_ectx K env) (Next x)))) + ≡ + (sub_scope (mk_subst (Val (cont K))) env)). + { + apply interp_cont_obligation_1. + } + { + Transparent extend_scope. + intros [| x]; term_simpl. + - reflexivity. + - reflexivity. + } + (* Check reify. *) + (* Locate "≡". *) + (* clear. *) + (* Set Printing All. *) + (* setoid_rewrite reify_vis_eq; last first. *) + (* { *) + (* (* pose proof (@subEff_outs ioE F subEff0 (inr (inr (inl ()))) IT _). *) *) + (* (* simpl in X. *) *) + (* (* pose (KKK := ((laterO_map (interp_ectx K env) ◎ (X ^-1)))). *) *) + (* unshelve epose (T := @sReifier_re reify_io IT _ (inr (inr (inl ()))) ((f, σ'), (laterO_map (interp_ectx K env)))). *) + (* assert (T ≡ *) + (* SomeO (Next (interp_ectx K env (interp_expr e0 (λne x : leibnizO (inc S), interp_expr (mk_subst (Val (cont K)) x) env))), σ')). *) + (* { *) + (* subst T. *) + (* simpl. *) + (* do 2 f_equiv. *) + (* etrans; first apply laterO_map_Next. *) + (* do 2 f_equiv. *) + (* f_equiv. *) + (* Transparent extend_scope. *) + (* intros [| x]; term_simpl. *) + (* - admit. *) + (* - reflexivity. *) + (* } *) + (* simpl. *) + (* pose proof (@subEff_outs ioE F subEff0 (inr (inr (inl ()))) IT _). *) + (* simpl in X. *) + (* pose (KKK := ((laterO_map (interp_ectx K env) ◎ (X ^-1)))). *) + (* pose proof (@subEff_ins ioE F subEff0 (inr (inr (inl ()))) IT _). *) + (* simpl in X0. *) + (* pose (fff := X0 f). *) + (* simpl in KKK. *) + (* (* epose proof (@subReifier_reify sz reify_io rs subR IT _ (inr (inr (inl ()))) f _) as H'. *) *) + (* epose proof (@subReifier_reify sz (rs !!! projT1 (subEff_opid (inr (inr (inl ()))))) rs _ IT _ (projT2 (subEff_opid (inr (inr (inl ()))))) fff _ KKK (gState_decomp (projT1 (subEff_opid (inr (inr (inl ()))))) ((gState_decomp' sR_idx rs ^-1) (sR_state σ', σr))).1 (gState_decomp (projT1 (subEff_opid (inr (inr (inl ()))))) ((gState_decomp' sR_idx rs ^-1) (sR_state σ', σr))).1 _) as H''. *) + + (* erewrite H''. *) + (* - simpl. *) + (* reflexivity. *) + (* simpl in H'. *) + + (* _ (laterO_map (interp_ectx K env) ◎ (subEff_outs ^-1)) idfun σ σ σr *) + (* } *) + (* eassert ( *) + (* (reify (gReifiers_sReifier rs) *) + (* (Vis (subEff_opid (inr (inr (inl ())))) *) + (* (subEff_ins f) *) + (* (laterO_map (interp_ectx K env) ◎ (subEff_outs ^-1)))) *) + (* ≡ *) + (* (Nat 0, σ')). *) + (* rewrite reify_vis_eq //; last first. *) + (* { *) + (* epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inr (inl ()))) (λne f : laterO IT -n> laterO IT, Next (interp_expr e0 (extend_scope env (λit x : IT, Tau (f (Next x)))))) (Next (interp_ectx K env ((Ret 0)))) (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. *) + (* simpl in H. *) + (* simpl. *) + (* erewrite <-H; last first. *) + (* - reflexivity. *) + (* - (* holds *) *) + (* admit. *) + (* } *) (* doesnt hold due to a missing tau in reify + extra tick in interp *) admit. Admitted. @@ -959,7 +1040,7 @@ Section interp. { destruct (head_step_io_01 _ _ _ _ _ _ _ H2); subst. - assert (σ1 = σ2) as ->. - { eapply head_step_no_io; eauto. } + { eapply head_step_no_io; eauto. } unshelve eapply (interp_expr_fill_no_reify K) in H2; first apply env. rewrite H2. rewrite interp_comp. diff --git a/theories/input_lang_callcc/logpred.v b/theories/input_lang_callcc/logpred.v index 96093d4..45f9058 100644 --- a/theories/input_lang_callcc/logpred.v +++ b/theories/input_lang_callcc/logpred.v @@ -43,8 +43,8 @@ Section io_lang. Program Definition ı_scope : @interp_scope F R _ ∅ := λne x, match x with end. - Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S : Set} (Γ : S -> ty) (ss : S [⇒] ∅) : iProp := - (∀ x, □ expr_pred (interp_expr _ (ss x) ı_scope) (interp_ty (Γ x)))%I. + Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S : Set} (Γ : S -> ty) (ss : interp_scope S) : iProp := + (∀ x, □ expr_pred (ss x) (interp_ty (Γ x)))%I. #[global] Instance io_lang_interp_ty_pers τ βv : Persistent (io_lang.interp_ty τ βv). Proof. induction τ; apply _. Qed. @@ -55,9 +55,9 @@ Section io_lang. Program Definition valid1 {S : Set} (Γ : S -> ty) (α : @interp_scope F R _ S -n> IT) (τ : ty) : iProp := (∀ σ ss, has_substate σ -∗ ssubst_valid interp_ty Γ ss -∗ - expr_pred (α ((@sub_scope sz rs R _ SO _ S ∅ ss ı_scope))) (λne v, ∃ σ', interp_ty τ v ∗ has_substate σ'))%I. + expr_pred (α ss) (λne v, ∃ σ', interp_ty τ v ∗ has_substate σ'))%I. Solve Obligations with solve_proper. - + Lemma compat_nat {S : Set} n (Ω : S -> ty) : ⊢ valid1 Ω (interp_nat rs n) Tnat. Proof. @@ -92,18 +92,20 @@ Section io_lang. iIntros "H0 H1 H2". iIntros (σ ss) "Hs #Has". iSpecialize ("H0" with "Hs Has"). - simpl. (* iApply (expr_pred_bind (IFSCtx _ _) with "H0"). *) - (* iIntros (αv) "Ha/=". *) - (* iDestruct "Ha" as (σ') "[Ha Hs]". *) - (* iDestruct "Ha" as (n) "Hn". *) - (* unfold IFSCtx. iIntros (x) "Hx". *) - (* iRewrite "Hn". *) - (* destruct n as [|n]. *) - (* - rewrite IF_False; last lia. *) - (* iApply ("H2" with "Hs Has Hx"). *) - (* - rewrite IF_True; last lia. *) - (* iApply ("H1" with "Hs Has Hx"). *) - Admitted. + simpl. + iApply (expr_pred_bind (IFSCtx _ _) with "H0"). + iIntros (αv) "Ha/=". + iDestruct "Ha" as (σ') "[Ha Hs]". + iDestruct "Ha" as (n) "Hn". + unfold IFSCtx. iIntros (x) "Hx". + iRewrite "Hn". + destruct n as [|n]. + - rewrite IF_False; last lia. + iApply ("H2" with "Hs Has Hx"). + - rewrite IF_True; last lia. + iApply ("H1" with "Hs Has Hx"). + Qed. + Lemma compat_input {S : Set} (Γ : S -> ty) : ⊢ valid1 Γ (interp_input rs) Tnat. Proof. @@ -123,18 +125,19 @@ Section io_lang. iIntros (σ ss) "Hs #Has". iSpecialize ("H" with "Hs Has"). simpl. - (* iApply (expr_pred_bind (get_ret _) with "H"). *) - (* iIntros (αv) "Ha". *) - (* iDestruct "Ha" as (σ') "[Ha Hs]". *) - (* iDestruct "Ha" as (n) "Hn". *) - (* iApply expr_pred_frame. *) - (* iRewrite "Hn". *) - (* rewrite get_ret_ret. *) - (* iApply (wp_output with "Hs"). *) - (* { reflexivity. } *) - (* iNext. iIntros "_ Hs /=". *) - (* eauto with iFrame. *) - Admitted. + iApply (expr_pred_bind (get_ret _) with "H"). + iIntros (αv) "Ha". + iDestruct "Ha" as (σ') "[Ha Hs]". + iDestruct "Ha" as (n) "Hn". + iApply expr_pred_frame. + iRewrite "Hn". + rewrite get_ret_ret. + iApply (wp_output with "Hs"). + { reflexivity. } + iNext. iIntros "_ Hs /=". + eauto with iFrame. + Qed. + Lemma compat_app {S : Set} (Γ : S -> ty) α β τ1 τ2 : ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ valid1 Γ β τ1 -∗ @@ -143,25 +146,24 @@ Section io_lang. iIntros "H1 H2". iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). - (* iApply (expr_pred_bind (AppRSCtx _) with "H2"). *) - (* iIntros (βv) "Hb/=". *) - (* iDestruct "Hb" as (σ') "[Hb Hs]". *) - (* unfold AppRSCtx. *) - (* iSpecialize ("H1" with "Hs Has"). *) - (* iApply (expr_pred_bind (AppLSCtx (IT_of_V βv)) with "H1"). *) - (* iIntros (αv) "Ha". *) - (* iDestruct "Ha" as (σ'') "[Ha Hs]". *) - (* unfold AppLSCtx. *) - (* iApply ("Ha" with "Hs Hb"). *) - Admitted. + iApply (expr_pred_bind (AppRSCtx _) with "H2"). + iIntros (βv) "Hb/=". + iDestruct "Hb" as (σ') "[Hb Hs]". + unfold AppRSCtx. + iSpecialize ("H1" with "Hs Has"). + iApply (expr_pred_bind (AppLSCtx (IT_of_V βv)) with "H1"). + iIntros (αv) "Ha". + iDestruct "Ha" as (σ'') "[Ha Hs]". + unfold AppLSCtx. + iApply ("Ha" with "Hs Hb"). + Qed. Lemma compat_rec {S : Set} (Γ : S -> ty) τ1 τ2 α : ⊢ □ valid1 ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) α τ2 -∗ valid1 Γ (interp_rec rs α) (Tarr τ1 τ2). Proof. iIntros "#H". iIntros (σ ss) "Hs #Hss". - pose (env := (sub_scope rs ss ı_scope)). fold env. - simp subst_expr. + pose (env := ss). fold env. pose (f := (ir_unf rs α env)). iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". { iPureIntro. apply interp_rec_unfold. } @@ -173,8 +175,26 @@ Section io_lang. iIntros (x) "Hx". iApply wp_lam. iNext. - unfold f. simpl. - Admitted. + unfold valid1. + iAssert (IT_of_V (FunV (Next f)) ≡ interp_rec rs α env)%I as "Heq". + { rewrite interp_rec_unfold. done. } + iRewrite -"Heq". + unfold f. + Opaque extend_scope. + simpl. + pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V βv))). + iApply ("H" with "[$Hs] [] [$Hx]"). + Transparent extend_scope. + iIntros (x'); destruct x' as [| [| x']]; simpl. + - iModIntro. + by iApply expr_pred_ret. + - iModIntro. + iRewrite - "Heq". + iApply expr_pred_ret. + iModIntro. + iApply "IH". + - iApply "Hss". + Qed. Lemma compat_natop {S : Set} (Γ : S -> ty) op α β : ⊢ valid1 Γ α Tnat -∗ @@ -184,23 +204,36 @@ Section io_lang. iIntros "H1 H2". iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). - (* iApply (expr_pred_bind (NatOpRSCtx _ _) with "H2"). *) - (* iIntros (βv) "Hb/=". *) - (* iDestruct "Hb" as (σ') "[Hb Hs]". *) - (* unfold NatOpRSCtx. *) - (* iSpecialize ("H1" with "Hs Has"). *) - (* iApply (expr_pred_bind (NatOpLSCtx _ (IT_of_V βv)) with "H1"). *) - (* iIntros (αv) "Ha". *) - (* iDestruct "Ha" as (σ'') "[Ha Hs]". *) - (* unfold NatOpLSCtx. *) - (* iDestruct "Hb" as (n1) "Hb". *) - (* iDestruct "Ha" as (n2) "Ha". *) - (* iRewrite "Hb". iRewrite "Ha". *) - (* simpl. iApply expr_pred_frame. *) - (* rewrite NATOP_Ret. iApply wp_val. simpl. *) - (* eauto with iFrame. *) - Admitted. + iApply (expr_pred_bind (NatOpRSCtx _ _) with "H2"). + iIntros (βv) "Hb/=". + iDestruct "Hb" as (σ') "[Hb Hs]". + unfold NatOpRSCtx. + iSpecialize ("H1" with "Hs Has"). + iApply (expr_pred_bind (NatOpLSCtx _ (IT_of_V βv)) with "H1"). + iIntros (αv) "Ha". + iDestruct "Ha" as (σ'') "[Ha Hs]". + unfold NatOpLSCtx. + iDestruct "Hb" as (n1) "Hb". + iDestruct "Ha" as (n2) "Ha". + iRewrite "Hb". iRewrite "Ha". + simpl. iApply expr_pred_frame. + rewrite NATOP_Ret. iApply wp_val. simpl. + eauto with iFrame. + Qed. + Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β : + ⊢ valid1 Γ α τ -∗ + valid1 Γ β (Tcont τ) -∗ + valid1 Γ (interp_throw _ α β) τ'. + Proof. + Admitted. + + Lemma compat_callcc {S : Set} (Γ : S -> ty) τ α : + ⊢ valid1 (Γ ▹ Tcont τ) α τ -∗ + valid1 Γ (interp_callcc _ α) τ. + Proof. + Admitted. + Lemma fundamental {S : Set} (Γ : S -> ty) e τ : typed Γ e τ → ⊢ valid1 Γ (interp_expr rs e) τ with fundamental_val {S : Set} (Γ : S -> ty) v τ : @@ -214,17 +247,18 @@ Section io_lang. + iApply compat_if; iApply fundamental; eauto. + iApply compat_input. + iApply compat_output; iApply fundamental; eauto. - + admit. - + admit. + + iApply compat_throw; iApply fundamental; eauto. + + iApply compat_callcc; iApply fundamental; eauto. - destruct 1. + iApply compat_nat. + iApply compat_rec; iApply fundamental; eauto. - Admitted. + Qed. + Lemma fundmanetal_closed (e : expr ∅) (τ : ty) : typed □ e τ → ⊢ valid1 □ (interp_expr rs e) τ. Proof. apply fundamental. Qed. - + End io_lang. Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _} τ. @@ -234,51 +268,56 @@ Local Definition rs : gReifiers _ := gReifiers_cons reify_io 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 ⊢ valid1 rs notStuck (λ _:unitO, True)%I □ α τ)%I) → *) -(* ssteps (gReifiers_sReifier rs) (α (@ı_scope _ rs R _)) 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 (interp_ty (s:=notStuck) (P:=(λ _:unitO, True)) τ)%I. split. *) -(* { 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" $! σ with "Hs []"). *) -(* { iApply ssubst_valid_nil. } *) -(* iSpecialize ("Hlog" $! tt with "[//]"). *) -(* iApply (wp_wand with"Hlog"). *) -(* iIntros ( βv). simpl. iDestruct 1 as (_) "[H _]". *) -(* iDestruct "H" as (σ1') "[$ Hsts]". *) -(* done. *) -(* Qed. *) +(* Check IT_of_to_V. *) +(* Search SetoidClass.Setoid. *) + +(* 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 ⊢ valid1 rs notStuck (λ _:unitO, True)%I □ α τ)%I) → *) *) +(* (* ssteps (gReifiers_sReifier rs) (α (@ı_scope _ rs R _)) 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 (interp_ty (s:=notStuck) (P:=(λ _:unitO, True)) τ)%I. split. *) *) +(* (* { 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" $! σ with "Hs []"). *) *) +(* (* { iApply ssubst_valid_nil. } *) *) +(* (* iSpecialize ("Hlog" $! tt with "[//]"). *) *) +(* (* iApply (wp_wand with"Hlog"). *) *) +(* (* iIntros ( βv). simpl. iDestruct 1 as (_) "[H _]". *) *) +(* (* iDestruct "H" as (σ1') "[$ Hsts]". *) *) +(* (* done. *) *) +(* (* Qed. *) *) (* Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : *) (* typed empC e τ → *) diff --git a/theories/lang_generic_sem.v b/theories/lang_generic_sem.v index 905839d..7351d8b 100644 --- a/theories/lang_generic_sem.v +++ b/theories/lang_generic_sem.v @@ -108,44 +108,6 @@ Section kripke_logrel. #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . Proof. solve_proper. Qed. - (* Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : S -> ty) (ss : ssubst S) : iProp := *) - (* ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), *) - (* interp_ty (τx.1) (τx.2))%I. *) - - (* Lemma ssubst_valid_nil {ty} (interp_ty : ty → ITV -n> iProp) : *) - (* ⊢ ssubst_valid interp_ty empC emp_ssubst. *) - (* Proof. *) - (* unfold ssubst_valid. *) - (* by simp list_of_tyctx list_of_ssubst. *) - (* Qed. *) - - (* Lemma ssubst_valid_cons {ty} (interp_ty : ty → ITV -n> iProp) {S} *) - (* (Γ : tyctx ty S) (ss : ssubst S) τ αv : *) - (* ssubst_valid interp_ty (consC τ Γ) (cons_ssubst αv ss) *) - (* ⊣⊢ interp_ty τ αv ∗ ssubst_valid interp_ty Γ ss. *) - (* Proof. *) - (* unfold ssubst_valid. *) - (* by simp list_of_tyctx list_of_ssubst. *) - (* Qed. *) - - (* Lemma ssubst_valid_app {ty} (interp_ty : ty → ITV -n> iProp) *) - (* {S1 S2} (Ω1 : tyctx ty S1) (Ω2 : tyctx ty S2) αs : *) - (* ssubst_valid interp_ty (tyctx_app Ω1 Ω2) αs ⊢ *) - (* ssubst_valid interp_ty Ω1 (ssubst_split αs).1 *) - (* ∗ ssubst_valid interp_ty Ω2 (ssubst_split αs).2. *) - (* Proof. *) - (* iInduction Ω1 as [|τ Ω1] "IH" forall (Ω2); simp tyctx_app ssubst_split. *) - (* - simpl. iIntros "$". iApply ssubst_valid_nil. *) - (* - iIntros "H". *) - (* rewrite {4 5}/ssubst_valid. *) - (* simpl in αs. *) - (* dependent elimination αs as [cons_ssubst αv αs]. *) - (* simp ssubst_split. simpl. *) - (* simp list_of_ssubst list_of_tyctx. *) - (* simpl. iDestruct "H" as "[$ H]". *) - (* by iApply "IH". *) - (* Qed. *) - Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : Φ αv ⊢ expr_pred α Φ. Proof. @@ -154,21 +116,21 @@ Section kripke_logrel. eauto with iFrame. Qed. - (* Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : *) - (* expr_pred α Ψ ⊢ *) - (* (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ *) - (* expr_pred (f α) Φ. *) - (* Proof. *) - (* iIntros "H1 H2". *) - (* iIntros (x) "Hx". *) - (* iApply wp_bind. *) - (* { solve_proper. } *) - (* iSpecialize ("H1" with "Hx"). *) - (* iApply (wp_wand with "H1"). *) - (* iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". *) - (* iModIntro. *) - (* iApply ("H2" with "Hb Hy"). *) - (* Qed. *) + Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : + expr_pred α Ψ ⊢ + (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ + expr_pred (f α) Φ. + Proof. + iIntros "H1 H2". + iIntros (x) "Hx". + iApply wp_bind. + { solve_proper. } + iSpecialize ("H1" with "Hx"). + iApply (wp_wand with "H1"). + iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". + iModIntro. + iApply ("H2" with "Hb Hy"). + Qed. Lemma expr_pred_frame α Φ : WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. @@ -181,4 +143,4 @@ Section kripke_logrel. End kripke_logrel. -(* Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. *) +Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. diff --git a/theories/program_logic.v b/theories/program_logic.v index a492cf2..c805923 100644 --- a/theories/program_logic.v +++ b/theories/program_logic.v @@ -13,9 +13,9 @@ Section program_logic. Notation iProp := (iProp Σ). Lemma wp_seq α β s Φ `{!NonExpansive Φ} - {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} + (* {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), *) + (* CtxIndep (gReifiers_sReifier rs) *) + (* (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} *) : WP@{rs} α @ s {{ _, WP@{rs} β @ s {{ Φ }} }} ⊢ WP@{rs} SEQ α β @ s {{ Φ }}. Proof. @@ -27,9 +27,9 @@ Section program_logic. Qed. Lemma wp_let α (f : IT -n> IT) s Φ `{!NonExpansive Φ} - {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} + (* {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), *) + (* CtxIndep (gReifiers_sReifier rs) *) + (* (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} *) : WP@{rs} α @ s {{ αv, WP@{rs} f (IT_of_V αv) @ s {{ Φ }} }} ⊢ WP@{rs} (LET α f) @ s {{ Φ }}. Proof. From edaf886e982dc4b09477bf03a59ea2251ee0be0d Mon Sep 17 00:00:00 2001 From: Kaptch Date: Fri, 24 Nov 2023 20:05:37 +0100 Subject: [PATCH 030/114] almost solved annoying issue with extra ticks (wip) --- theories/input_lang_callcc/interp.v | 123 ++++++++++------------------ 1 file changed, 44 insertions(+), 79 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 2fd50fd..d54b12f 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -944,89 +944,49 @@ Section interp. simpl. rewrite interp_comp. rewrite interp_expr_subst. - etrans. + match goal with + | |- context G [Vis _ _ ?q] => set (k := q) + end. + match goal with + | |- context G [(ofe_mor_car _ _ (@ofe_iso_2 _ _ ?s)) ?s'] => set (fσ := s); set (σ'' := s') + end. + pose (@subEff_ins ioE F subEff0 (inr (inr (inl ()))) IT _) as k'. + simpl in k'. + pose (fff := k' f). + trans (reify (gReifiers_sReifier rs) + (Vis (subEff_opid (inr (inr (inl ())))) + fff + (laterO_map (interp_ectx K env) ◎ k)) + ((fσ ^-1) σ'')). { - apply ofe_mor_car_proper; last reflexivity. - apply ofe_mor_car_proper; first reflexivity. + do 2 f_equiv. rewrite hom_vis. + unfold fff, k. + do 3 f_equiv. + intro; simpl. reflexivity. } - (* subst f. *) - unfold sub_scope. - - unshelve eassert ((extend_scope env (λit x : IT, Tau (laterO_map (interp_ectx K env) (Next x)))) - ≡ - (sub_scope (mk_subst (Val (cont K))) env)). - { - apply interp_cont_obligation_1. - } + rewrite reify_vis_eq //; last first. { - Transparent extend_scope. - intros [| x]; term_simpl. - - reflexivity. + epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inr (inl ()))) f _ (laterO_map (interp_ectx K env)) σ' σ' σr) as H. + simpl in H. + simpl. + erewrite <-H; last first. - reflexivity. + - simpl. + subst k k' fff σ'' fσ f. + admit. } - (* Check reify. *) - (* Locate "≡". *) - (* clear. *) - (* Set Printing All. *) - (* setoid_rewrite reify_vis_eq; last first. *) - (* { *) - (* (* pose proof (@subEff_outs ioE F subEff0 (inr (inr (inl ()))) IT _). *) *) - (* (* simpl in X. *) *) - (* (* pose (KKK := ((laterO_map (interp_ectx K env) ◎ (X ^-1)))). *) *) - (* unshelve epose (T := @sReifier_re reify_io IT _ (inr (inr (inl ()))) ((f, σ'), (laterO_map (interp_ectx K env)))). *) - (* assert (T ≡ *) - (* SomeO (Next (interp_ectx K env (interp_expr e0 (λne x : leibnizO (inc S), interp_expr (mk_subst (Val (cont K)) x) env))), σ')). *) - (* { *) - (* subst T. *) - (* simpl. *) - (* do 2 f_equiv. *) - (* etrans; first apply laterO_map_Next. *) - (* do 2 f_equiv. *) - (* f_equiv. *) - (* Transparent extend_scope. *) - (* intros [| x]; term_simpl. *) - (* - admit. *) - (* - reflexivity. *) - (* } *) - (* simpl. *) - (* pose proof (@subEff_outs ioE F subEff0 (inr (inr (inl ()))) IT _). *) - (* simpl in X. *) - (* pose (KKK := ((laterO_map (interp_ectx K env) ◎ (X ^-1)))). *) - (* pose proof (@subEff_ins ioE F subEff0 (inr (inr (inl ()))) IT _). *) - (* simpl in X0. *) - (* pose (fff := X0 f). *) - (* simpl in KKK. *) - (* (* epose proof (@subReifier_reify sz reify_io rs subR IT _ (inr (inr (inl ()))) f _) as H'. *) *) - (* epose proof (@subReifier_reify sz (rs !!! projT1 (subEff_opid (inr (inr (inl ()))))) rs _ IT _ (projT2 (subEff_opid (inr (inr (inl ()))))) fff _ KKK (gState_decomp (projT1 (subEff_opid (inr (inr (inl ()))))) ((gState_decomp' sR_idx rs ^-1) (sR_state σ', σr))).1 (gState_decomp (projT1 (subEff_opid (inr (inr (inl ()))))) ((gState_decomp' sR_idx rs ^-1) (sR_state σ', σr))).1 _) as H''. *) - - (* erewrite H''. *) - (* - simpl. *) - (* reflexivity. *) - (* simpl in H'. *) - - (* _ (laterO_map (interp_ectx K env) ◎ (subEff_outs ^-1)) idfun σ σ σr *) - (* } *) - (* eassert ( *) - (* (reify (gReifiers_sReifier rs) *) - (* (Vis (subEff_opid (inr (inr (inl ())))) *) - (* (subEff_ins f) *) - (* (laterO_map (interp_ectx K env) ◎ (subEff_outs ^-1)))) *) - (* ≡ *) - (* (Nat 0, σ')). *) - (* rewrite reify_vis_eq //; last first. *) - (* { *) - (* epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inr (inl ()))) (λne f : laterO IT -n> laterO IT, Next (interp_expr e0 (extend_scope env (λit x : IT, Tau (f (Next x)))))) (Next (interp_ectx K env ((Ret 0)))) (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. *) - (* simpl in H. *) - (* simpl. *) - (* erewrite <-H; last first. *) - (* - reflexivity. *) - (* - (* holds *) *) - (* admit. *) - (* } *) - (* doesnt hold due to a missing tau in reify + extra tick in interp *) - admit. + f_equiv. + rewrite Tick_eq. + f_equiv. + rewrite laterO_map_Next. + do 3 f_equiv. + Transparent extend_scope. + intros [| x]; term_simpl. + + (* holds *) + admit. + + reflexivity. Admitted. Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : @@ -1101,7 +1061,10 @@ Section interp. change 1 with (Nat.add 1 0). econstructor; last first. { apply ssteps_zero; reflexivity. } eapply sstep_reify; first (rewrite hom_vis; reflexivity). - trans (reify (gReifiers_sReifier rs) (THROW (interp_val v env) (Next (interp_ectx K' env))) (gState_recomp σr (sR_state σ2))). + match goal with + | |- context G [ofe_mor_car _ _ _ (Next ?f)] => set (f' := f) + end. + trans (reify (gReifiers_sReifier rs) (THROW (interp_val v env) (Next f')) (gState_recomp σr (sR_state σ2))). { f_equiv; last done. f_equiv. @@ -1109,12 +1072,14 @@ Section interp. Transparent THROW. unfold THROW. simpl. - f_equiv. + repeat f_equiv. intros x; simpl. destruct ((subEff_outs ^-1) x). } rewrite reify_vis_eq; first (rewrite Tick_eq; reflexivity). - (* holds *) + subst f'. + pose proof @sstep_tick. + (* holds (but with extra tick step) *) admit. } Admitted. From bf502625947577c8811d4b6f1d8a088360f475ef Mon Sep 17 00:00:00 2001 From: Kaptch Date: Tue, 28 Nov 2023 18:24:07 +0100 Subject: [PATCH 031/114] bin rel --- _CoqProject | 3 +- theories/gitree/reify.v | 125 ++--- theories/gitree/weakestpre.v | 553 +++++++++++++----- theories/input_lang_callcc/interp.v | 71 ++- theories/input_lang_callcc/lang.v | 2 +- theories/input_lang_callcc/logpred.v | 274 +++++---- theories/input_lang_callcc/logrel.v | 808 ++++++++++++++++----------- theories/lang_generic.v | 35 +- theories/lang_generic_sem.v | 103 ++-- theories/program_logic.v | 56 +- 10 files changed, 1246 insertions(+), 784 deletions(-) diff --git a/_CoqProject b/_CoqProject index 7c096e8..ae3ac71 100644 --- a/_CoqProject +++ b/_CoqProject @@ -30,8 +30,7 @@ theories/program_logic.v theories/input_lang_callcc/lang.v theories/input_lang_callcc/interp.v -# theories/input_lang_callcc/logpred.v -# theories/input_lang_callcc/logrel.v +theories/input_lang_callcc/logrel.v theories/input_lang/lang.v theories/input_lang/interp.v diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 541b1f8..2b2c494 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -25,13 +25,6 @@ Section reifiers. Implicit Type op : opid F. Implicit Type α β : IT. - (* Class CtxIndep (X : ofe) `{!Cofe X} (op : opid F) := { *) - (* cont_irrelev : *) - (* (∃ f : (prodO (Ins (sReifier_ops r _) ♯ X) ((sReifier_state r) ♯ X)) -n> *) - (* optionO (prodO (Outs (sReifier_ops r _) ♯ X) (sReifier_state r ♯ X)), *) - (* ∀ i σ κ, @sReifier_re _ X _ op (i, σ, κ) ≡ fmap (prodO_map κ idfun) (f (i, σ))); *) - (* }. *) - Notation stateM := ((stateF ♯ IT -n> (stateF ♯ IT) * IT)). #[local] Instance stateT_inhab : Inhabited stateM. Proof. @@ -229,50 +222,65 @@ Section reifiers. - reflexivity. Qed. - Lemma reify_vis_cont op i k1 (k2 : IT -n> IT) σ1 σ2 β - {PROP : bi} `{!BiInternalEq PROP} (* (H : IT_hom k2) *) : - (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ - reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. + Lemma reify_is_always_a_tick op x k σ β σ' : + reify (Vis op x k) σ ≡ (σ', β) → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). Proof. - destruct (sReifier_re r op (i, σ1, k1)) as [[o σ2']|] eqn:Hre; last first. - - rewrite (reify_vis_None _ _ k1); last by rewrite Hre//. - iIntros "Hr". iExFalso. - iPoseProof (prod_equivI with "Hr") as "[_ Hk]". - simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. - - (* destruct H as [[f H]]. *) - (* pose proof (H i σ1 k1) as H1. *) - (* pose proof (H i σ1 (laterO_map k2 ◎ k1)) as H2. *) - (* assert (∃ o σ', f (i, σ1) = Some (o, σ')) as [o' [σ' H3]]. *) - (* { *) - (* destruct (f (i, σ1)) as [[? ?] | ?]; first (do 2 eexists; reflexivity). *) - (* simpl in H1. rewrite Hre in H1; inversion H1. *) - (* } *) - (* rewrite H3 in H1. *) - (* simpl in H1. *) - (* rewrite H3 in H2. *) - (* simpl in H2. *) - (* clear f H H3 Hre. *) - rewrite reify_vis_eq; last first. - { by rewrite Hre. } - iIntros "Hr". - iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". - iPoseProof (Tau_inj' with "Hk") as "Hk". - simpl. - (* pose proof hom_vis. *) - (* rewrite H. *) - (* iRewrite - "Hs". *) - (* rewrite reify_vis_eq; last first. *) - (* { by rewrite Hre. } *) - (* iRewrite "Hk". *) - (* rewrite -Tick_eq. *) - (* done. *) - (* reflexivity. *) - (* rewrite term *) - (* iApply prod_equivI. simpl. *) - (* iSplit; eauto. *) - (* iApply Tau_inj'. iRewrite "Hk". *) - (* rewrite laterO_map_Next. done. *) - Admitted. + destruct (sReifier_re r op (x, σ, k)) as [[o σ'']|] eqn:Hre; last first. + - rewrite reify_vis_None; last by rewrite Hre//. + intros [_ ?]. by right. + - rewrite reify_vis_eq;last by rewrite Hre. + intros [? Ho]. + left. + simpl in *. + destruct (Next_uninj o) as [t Ht]. + exists (t). + rewrite <-Ho. + rewrite Ht. + reflexivity. + Qed. + + (* Lemma reify_vis_cont op i k1 (k2 : IT -n> IT) σ1 σ2 β *) + (* {PROP : bi} `{!BiInternalEq PROP} (H : IT_hom k2) : *) + (* (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ *) + (* reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. *) + (* Proof. *) + (* destruct (sReifier_re r op (i, σ1, k1)) as [[o σ2']|] eqn:Hre; last first. *) + (* - rewrite (reify_vis_None _ _ k1); last by rewrite Hre//. *) + (* iIntros "Hr". iExFalso. *) + (* iPoseProof (prod_equivI with "Hr") as "[_ Hk]". *) + (* simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. *) + (* - rewrite reify_vis_eq; last first. *) + (* { by rewrite Hre. } *) + (* iIntros "Hr". *) + (* iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". *) + (* iPoseProof (Tau_inj' with "Hk") as "Hk". *) + (* iAssert (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (reify (k2 (Vis op i k1)) σ1))%I as "HEQ". *) + (* { *) + (* iPureIntro. *) + (* do 2 f_equiv. *) + (* rewrite hom_vis. *) + (* f_equiv. *) + (* intro; simpl; reflexivity. *) + (* } *) + (* iRewrite "HEQ". *) + (* iEval (iPureIntro; etrans). *) + (* trans (reify (k2 (Vis op i k1)) σ1). *) + (* simpl. *) + (* (* pose proof hom_vis. *) *) + (* (* rewrite H. *) *) + (* (* iRewrite - "Hs". *) *) + (* (* rewrite reify_vis_eq; last first. *) *) + (* (* { by rewrite Hre. } *) *) + (* (* iRewrite "Hk". *) *) + (* (* rewrite -Tick_eq. *) *) + (* (* done. *) *) + (* (* reflexivity. *) *) + (* (* rewrite term *) *) + (* (* iApply prod_equivI. simpl. *) *) + (* (* iSplit; eauto. *) *) + (* (* iApply Tau_inj'. iRewrite "Hk". *) *) + (* (* rewrite laterO_map_Next. done. *) *) + (* Admitted. *) (* Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β *) (* {PROP : bi} `{!BiInternalEq PROP} *) @@ -322,21 +330,4 @@ Section reifiers. (* iNext. by iApply internal_eq_sym. *) (* Qed. *) - Lemma reify_is_always_a_tick op x k σ β σ' : - reify (Vis op x k) σ ≡ (σ', β) → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). - Proof. - destruct (sReifier_re r op (x, σ, k)) as [[o σ'']|] eqn:Hre; last first. - - rewrite reify_vis_None; last by rewrite Hre//. - intros [_ ?]. by right. - - rewrite reify_vis_eq;last by rewrite Hre. - intros [? Ho]. - left. - simpl in *. - destruct (Next_uninj o) as [t Ht]. - exists (t). - rewrite <-Ho. - rewrite Ht. - reflexivity. - Qed. - End reifiers. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index e549a24..e4e2b61 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -371,63 +371,6 @@ Section weakestpre. iIntros "H". iApply (wp_wand with "H"); auto. Qed. - Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 (* {G : ∀ o : opid F, CtxIndep rG IT o} *) : - WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. - Proof. - assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). - { solve_proper. } - iIntros "H". iLöb as "IH" forall (α). - rewrite (wp_unfold (f _)). - destruct (IT_to_V (f α)) as [βv|] eqn:Hfa. - - iLeft. iExists βv. iSplit; first done. - assert (is_Some (IT_to_V α)) as [αv Ha]. - { apply (IT_hom_val_inv _ f). rewrite Hfa. - done. } - assert (IntoVal α αv). - { apply IT_of_to_V'. by rewrite Ha. } - rewrite wp_val_inv. - iApply wp_val_inv. - rewrite IT_of_to_V'; last by rewrite -Ha. - rewrite IT_of_to_V'; last by rewrite -Hfa. - by iApply fupd_wp. - - iRight. iSplit; eauto. - iIntros (σ) "Hs". - rewrite wp_unfold. - iDestruct "H" as "[H | H]". - + iDestruct "H" as (αv) "[Hav H]". - iPoseProof (IT_of_to_V with "Hav") as "Hav". - iMod "H" as "H". rewrite wp_unfold. - iDestruct "H" as "[H|H]". - { iExFalso. iDestruct "H" as (βv) "[H _]". - iRewrite "Hav" in "H". rewrite Hfa. - iApply (option_equivI with "H"). } - iDestruct "H" as "[_ H]". - iMod ("H" with "Hs") as "H". iModIntro. - iRewrite "Hav" in "H". done. - + iDestruct "H" as "[Hav H]". - iMod ("H" with "Hs") as "[Hsafe H]". iModIntro. - iSplit. - { (* safety *) - iDestruct "Hsafe" as "[Hsafe|Herr]". - - iDestruct "Hsafe" as (α' σ') "Hsafe". iLeft. - iExists (f α'), σ'. iApply (istep_hom with "Hsafe"). - - - iDestruct "Herr" as (e) "[Herr %]". - iRight. iExists e. iSplit; last done. - iRewrite "Herr". rewrite hom_err//. } - iIntros (σ' β) "Hst". - rewrite {1}istep_hom_inv. iDestruct "Hst" as "[%Ha | [_ Hst]]". - { destruct Ha as [αv Ha]. rewrite Ha. - iExFalso. - iApply (option_equivI with "Hav"). } - iDestruct "Hst" as (α') "[Hst Hb]". - iIntros "Hlc". - iMod ("H" with "Hst Hlc") as "H". iModIntro. - iNext. iMod "H" as "H". iModIntro. - iMod "H" as "[$ H]". - iModIntro. iRewrite "Hb". by iApply "IH". - Qed. - (* XXX: strengthen it with later credits *) Lemma wp_tick α s E1 Φ : ▷ WP α @ s;E1 {{ Φ }} ⊢ WP (Tick α) @ s;E1 {{ Φ }}. @@ -446,7 +389,6 @@ Section weakestpre. iModIntro. iRewrite "Hb". by iFrame. Qed. - Opaque gState_recomp. (* We can generalize this based on the stuckness bit *) @@ -774,9 +716,309 @@ Section weakestpre. iExFalso. iApply (option_equivI with "Hb"). Qed. + Definition clwp_def (e : IT) (s : stuckness) E (Φ : ITV -n> iProp) : iProp := + (∀ (K : IT -n> IT) {HK : IT_hom K} (Ψ : ITV -n> iProp), (∀ v, Φ v -∗ wp (K (IT_of_V v)) s E Ψ) + -∗ wp (K e) s E Ψ). + Definition clwp_aux : seal (@clwp_def). by eexists. Qed. + Definition clwp := unseal clwp_aux. + Definition clwp_eq : @clwp = @clwp_def := seal_eq clwp_aux. + + Notation "'CLWP' e @ s ; E {{ Φ } }" := + (clwp e s E Φ) + (at level 20, e, s, Φ at level 200, + format "'CLWP' e @ s ; E {{ Φ } }") : bi_scope. + + Notation "'CLWP' α @ s ; E {{ v , Q } }" := + (clwp α s E (λne v, Q)) + (at level 20, α, s, Q at level 200, + format "'[hv' 'CLWP' α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. + + Notation "'CLWP' α @ s {{ β , Φ } }" := + (clwp α s ⊤ (λne β, Φ)) + (at level 20, α, Φ at level 200, + format "'CLWP' α @ s {{ β , Φ } }") : bi_scope. + + Notation "'CLWP' α @ s {{ Φ } }" := + (clwp α s ⊤ Φ) + (at level 20, α, Φ at level 200, + format "'CLWP' α @ s {{ Φ } }") : bi_scope. + + Lemma clwp_cl {s E e} {Φ : ITV -n> iProp} (K : IT -n> IT) {HK : IT_hom K} : + CLWP e @ s ; E {{ Φ }} -∗ + (∀ (Ψ : ITV -n> iProp), (∀ v, Φ v -∗ WP (K (IT_of_V v)) @ s ; E {{ Ψ }}) + -∗ WP (K e) @ s ; E {{ Ψ }})%I. + Proof. + rewrite clwp_eq /clwp_def. iIntros "H". iIntros (?). + iApply "H". + Qed. + + Lemma unfold_clwp (s : stuckness) (E : coPset) (e : IT) (Φ : ITV -n> iProp) : + CLWP e @ s ; E {{Φ}} ⊣⊢ + (∀ (K : IT -n> IT) {HK : IT_hom K} (Ψ : ITV -n> iProp), (∀ v, Φ v -∗ WP (K (IT_of_V v)) @ s ; E {{ Ψ }}) + -∗ WP (K e) @ s ; E {{ Ψ }})%I. + Proof. + by rewrite clwp_eq /clwp_def. + Qed. + + Lemma clwp_wp s (E : coPset) (e : IT) (Φ : ITV -n> iProp) : + CLWP e @ s ; E {{ Φ }} ⊢ WP e @ s ; E {{ Φ }}. + Proof. + iIntros "H". rewrite unfold_clwp. + unshelve iSpecialize ("H" $! idfun _ Φ with "[]"). + - apply _. + - iIntros (w) "Hw". simpl. + iApply wp_val; rewrite /IntoVal /=. + done. + - by simpl. + Qed. + + Global Instance clwp_ne s E e m : + Proper ((dist m) ==> dist m) (clwp e s E). + Proof. + repeat intros?; rewrite !unfold_clwp. + solve_proper. + Qed. + + Global Instance clwp_proper s E e : + Proper ((≡) ==> (≡)) (clwp e s E). + Proof. + by intros Φ Φ' ?; apply equiv_dist=>m; apply clwp_ne=>v; apply equiv_dist. + Qed. + + Lemma clwp_value' s E (Φ : ITV -n> iProp) v : + Φ v ⊢ CLWP (IT_of_V v) @ s ; E {{ Φ }}. + Proof. + iIntros "HΦ"; rewrite unfold_clwp. + iIntros (K HK Ψ) "HK". iApply ("HK" with "HΦ"). + Qed. + + Lemma clwp_value_inv s E (Φ : ITV -n> iProp) v : + CLWP (IT_of_V v) @ s ; E {{ Φ }} ={E}=∗ Φ v. + Proof. + iIntros "H"; iApply wp_val_inv'; last by iApply clwp_wp. + iPureIntro. by apply IT_to_of_V. + Qed. + + Lemma fupd_clwp s E e (Φ : ITV -n> iProp) : + (|={E}=> CLWP e @ s ; E {{ Φ }}) ⊢ CLWP e @ s ; E {{ Φ }}. + Proof. + iIntros "H"; rewrite !unfold_clwp. + iIntros (K HK Ψ) "HK". + iMod "H"; by iApply "H". + Qed. + + Global Instance clwp_ne' s E (Φ : ITV -n> iProp) m : + Proper ((dist m) ==> dist m) (fun x => clwp x s E Φ). + Proof. + repeat intros?; rewrite !unfold_clwp. + solve_proper. + Qed. + + Global Instance clwp_proper' s E (Φ : ITV -n> iProp) : + Proper ((≡) ==> (≡)) (fun x => clwp x s E Φ). + Proof. + intros e e' ?. + rewrite !unfold_clwp. + solve_proper. + Qed. + + Global Instance clwp_ne'' s E (Φ : ITV -n> iProp) m : + Proper ((dist m) ==> dist m) (fun (x : ITVO) => clwp (IT_of_V x) s E Φ). + Proof. + repeat intros?; rewrite !unfold_clwp. + solve_proper. + Qed. + + Global Instance clwp_proper'' s E (Φ : ITV -n> iProp) : + Proper ((≡) ==> (≡)) (fun (x : ITVO) => clwp (IT_of_V x) s E Φ). + Proof. + intros e e' ?. + rewrite !unfold_clwp. + solve_proper. + Qed. + + Global Instance clwp_ne''' s E (Φ : ITV -n> iProp) (K : IT -n> IT) {HK : IT_hom K} : + NonExpansive (λ v : ITVO, (CLWP (K (IT_of_V v)) @ s ; E{{ Φ }})%I). + Proof. + repeat intros?; rewrite !unfold_clwp. + solve_proper. + Qed. + + Global Instance upd_ne {X : ofe} E (Φ : X -n> iProp) : + NonExpansive (λ (a : X), (|={E}=> Φ a)%I). + Proof. + solve_proper. + Qed. + + Lemma clwp_fupd s E e (Φ : ITV -n> iProp) : + CLWP e @ s ; E {{ v , |={E}=> Φ v }} ⊢ CLWP e @ s ; E {{ Φ }}. + Proof. + iIntros "H"; rewrite !unfold_clwp. + iIntros (K HK Ψ) "HK". + iApply "H". iIntros (w) ">Hw"; by iApply "HK". + Qed. + + Lemma clwp_bind (K : IT -n> IT) {HK : IT_hom K} s E e (Φ : ITV -n> iProp) : + CLWP e @ s ; E {{ v , CLWP (K (IT_of_V v)) @ s ; E {{ Φ }} }} + ⊢ CLWP (K e) @ s ; E {{ Φ }}. + Proof. + iIntros "H"; rewrite !unfold_clwp. iIntros (K' HK' Ψ) "HK'". + assert (K' (K e) = (K' ◎ K) e) as ->; first done. + iApply "H". + - iPureIntro. + apply _. + - iIntros (v) "Hv". + simpl. + rewrite !unfold_clwp. + iApply "Hv". + iIntros (w) "Hw". + by iApply "HK'". + Qed. + + Lemma clwp_mono E e (Φ Ψ : ITV -n> iProp) : (∀ v, Φ v ⊢ Ψ v) → + CLWP e @ E {{ Φ }} ⊢ CLWP e @ E {{ Ψ }}. + Proof. + iIntros (HΦ) "H"; rewrite !unfold_clwp. iIntros (K HK χ) "HK". + iApply "H". iIntros (w) "Hw". iApply "HK"; by iApply HΦ. + Qed. + + Lemma clwp_value s E (Φ : ITV -n> iProp) e v `{!IntoVal e v} : + Φ v ⊢ CLWP e @ s ; E {{ Φ }}. + Proof. + iIntros "H". + assert (e = IT_of_V v) as ->. + { admit. } + by iApply clwp_value'. + Admitted. + + Lemma clwp_value_fupd' s E (Φ : ITV -n> iProp) v : + (|={E}=> Φ v) ⊢ CLWP (IT_of_V v) @ s ; E {{ Φ }}. + Proof. intros. by rewrite -clwp_fupd -clwp_value'. Qed. + + Lemma clwp_value_fupd s E (Φ : ITV -n> iProp) e v `{!IntoVal e v} : + (|={E}=> Φ v) ⊢ CLWP e @ s ; E {{ Φ }}. + Proof. intros. rewrite -clwp_fupd -clwp_value //. Qed. + + Global Instance upd_ast_l {X : ofe} R (Φ : X -n> iProp) : + NonExpansive (λ (a : X), (R ∗ Φ a)%I). + Proof. + solve_proper. + Qed. + + Lemma clwp_frame_l s E e (Φ : ITV -n> iProp) R : + R ∗ CLWP e @ s ; E {{ Φ }} ⊢ CLWP e @ s ; E {{ v, R ∗ Φ v }}. + Proof. + iIntros "[HR H]"; rewrite !unfold_clwp. iIntros (K HK Ψ) "HK". + iApply "H". iIntros (v) "Hv". iApply "HK"; iFrame. + Qed. + + Global Instance upd_ast_r {X : ofe} R (Φ : X -n> iProp) : + NonExpansive (λ (a : X), (Φ a ∗ R)%I). + Proof. + solve_proper. + Qed. + + Lemma clwp_frame_r s E e (Φ : ITV -n> iProp) R : + CLWP e @ s ; E {{ Φ }} ∗ R ⊢ CLWP e @ s ; E {{ v, Φ v ∗ R }}. + Proof. + iIntros "[H HR]"; rewrite !unfold_clwp. iIntros (K HK Ψ) "HK". + iApply "H". iIntros (v) "Hv". iApply "HK"; iFrame. + Qed. + + Lemma clwp_wand s E e (Φ Ψ : ITV -n> iProp) : + CLWP e @ s ; E {{ Φ }} -∗ (∀ v, Φ v -∗ Ψ v) -∗ CLWP e @ s ; E {{ Ψ }}. + Proof. + iIntros "Hwp H". rewrite !unfold_clwp. + iIntros (K HK χ) "HK". + iApply "Hwp". iIntros (?) "?"; iApply "HK"; by iApply "H". + Qed. + + Lemma clwp_wand_l s E e (Φ Ψ : ITV -n> iProp) : + (∀ v, Φ v -∗ Ψ v) ∗ CLWP e @ s ; E {{ Φ }} ⊢ CLWP e @ s ; E {{ Ψ }}. + Proof. iIntros "[H Hwp]". iApply (clwp_wand with "Hwp H"). Qed. + + Lemma clwp_wand_r s E e (Φ Ψ : ITV -n> iProp) : + CLWP e @ s ; E {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ CLWP e @ s ; E {{ Ψ }}. + Proof. iIntros "[Hwp H]". iApply (clwp_wand with "Hwp H"). Qed. + + Lemma clwp_tick α s E1 Φ : + ▷ CLWP α @ s;E1 {{ Φ }} ⊢ CLWP (Tick α) @ s;E1 {{ Φ }}. + Proof. + iIntros "H". + rewrite clwp_eq /clwp_def. + iIntros (K HK Ψ) "G". + rewrite hom_tick. + iApply wp_tick. + iNext. + by iApply "H". + Qed. + + Lemma clwp_reify E1 s Φ i (lop : opid (sReifier_ops (rs !!! i))) + x k σ σ' β : + let op : opid F := (existT i lop) in + (∀ (k' : IT -n> IT) (HK : IT_hom k') rest, reify (Vis op x (laterO_map k' ◎ k)) (gState_recomp rest σ) ≡ (gState_recomp rest σ', Tick (k' β))) → + has_state_idx i σ -∗ + ▷ (£ 1 -∗ has_state_idx i σ' -∗ CLWP β @ s;E1 {{ Φ }}) + -∗ CLWP (Vis op x k) @ s;E1 {{ Φ }}. + Proof. + intros op Hr. + iIntros "Hlst H". + rewrite clwp_eq /clwp_def. + iIntros (K HK Ψ) "G". + rewrite hom_vis. + unshelve iApply (@wp_reify _ _ _ _ _ _ _ σ σ' (K β) with "[$Hlst] [-]"). + - intros. + rewrite -Hr. + do 3 f_equiv. + by intro; simpl. + - iNext. + iIntros "HC HS". + iSpecialize ("H" with "HC HS"). + unshelve iSpecialize ("H" $! K _); first apply _. + simpl. + by iApply "H". + Qed. + + Lemma clwp_subreify E1 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops sR)) + (x : Ins (sReifier_ops sR op) ♯ IT) (y : laterO IT) + (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) + (σ σ' : sReifier_state sR ♯ IT) β : + (∀ (k' : IT -n> IT) {Hk : IT_hom k'}, sReifier_re sR op (x, σ, (laterO_map k' ◎ k ◎ subEff_outs)) ≡ Some (Next (k' β), σ')) → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ CLWP β @ s;E1 {{ Φ }}) + -∗ + CLWP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. + Proof. + intros HSR. + iIntros "Hlst H". + iApply (clwp_reify with "Hlst H"). + intros k' ? rest. + rewrite reify_vis_eq //. + { + f_equiv. + symmetry. + apply Tick_eq. + } + pose proof (@subReifier_reify n sR rs _ IT _ op x (Next (k' β)) ((laterO_map k' ◎ k) ◎ subEff_outs) σ σ' rest) as H. + simpl in H. + simpl. + rewrite <-H. + { + repeat f_equiv. + - solve_proper. + - intro; simpl. + rewrite ofe_iso_12. + reflexivity. + } + clear H. + by apply HSR. + Qed. + End weakestpre. Arguments wp {_} rs {_ _ _ _ _} α s E Φ. +Arguments clwp {_} rs {_ _ _ _ _} e s E Φ. Arguments has_full_state {n _ _ _ _ _} σ. Arguments has_state_idx {n _ _ _ _ _} i σ. Arguments has_substate {n _ _ _ _ _ _ _} σ. @@ -807,90 +1049,113 @@ Definition notStuck : stuckness := λ e, False. Notation "'WP@{' re } α {{ Φ } }" := (wp re α notStuck ⊤ Φ) (at level 20, α, Φ at level 200, - format "'WP@{' re } α {{ Φ } }") : bi_scope. - -Lemma wp_adequacy cr Σ `{!invGpreS Σ} n (rs : gReifiers n) - {A} `{!Cofe A} `{!statePreG rs A Σ} - (α : IT _ A) σ βv σ' s k (ψ : (ITV (gReifiers_ops rs) A) → Prop) : - ssteps (gReifiers_sReifier rs) α σ (IT_of_V βv) σ' k → - (∀ `{H1 : !invGS Σ} `{H2: !stateG rs A Σ}, - ∃ Φ, NonExpansive Φ ∧ (∀ βv, Φ βv ⊢ ⌜ψ βv⌝) - ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → - ψ βv. -Proof. - intros Hst Hprf. - cut (⊢ ⌜ψ βv⌝ : iProp Σ)%I. - { intros HH. eapply uPred.pure_soundness; eauto. } - eapply (step_fupdN_soundness_lc _ 0 (cr + 3*k)). - intros Hinv. iIntros "[Hcr Hlc]". - iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". - destruct (Hprf Hinv sg) as (Φ & HΦ & HΦψ & Hprf'). - iPoseProof (Hprf' with "[$Hcr $Hs2]") as "Hic". - iPoseProof (wp_ssteps with "[$Hs $Hic]") as "Hphi". - { eassumption. } - iMod ("Hphi" with "Hlc") as "[Hst H]". - rewrite wp_val_inv; eauto. - iMod "H" as "H". - rewrite HΦψ. iFrame "H". - by iApply fupd_mask_intro_discard. -Qed. + format "'WP@{' re } α {{ Φ } }") : bi_scope. -Lemma wp_safety cr Σ `{!invGpreS Σ} n (rs : gReifiers n) - {A} `{!Cofe A} `{!statePreG rs A Σ} s k - (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : - (∀ Σ P Q, @disjunction_property Σ P Q) → - ssteps (gReifiers_sReifier rs) α σ β σ' k → - IT_to_V β ≡ None → - (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, - ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → - ((∃ β1 σ1, sstep (gReifiers_sReifier rs) β σ' β1 σ1) - ∨ (∃ e, β ≡ Err e ∧ s e)). -Proof. - Opaque istep. - intros Hdisj Hstep Hbv Hwp. - cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier rs) β σ' β1 σ1) - ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. - { intros [Hprf | Hprf]%Hdisj. - - left. - apply (istep_safe_sstep _ (Σ:=Σ)). - { apply Hdisj. } - done. - - right. - destruct (IT_dont_confuse β) - as [[e Ha] | [[m Ha] | [ [g Ha] | [[α' Ha]|[op [i [ko Ha]]]] ]]]. - + exists e. split; eauto. - eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[He %Hs]". rewrite Ha. - iPoseProof (Err_inj' with "He") as "%He". - iPureIntro. rewrite He//. - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_ret_err_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_fun_err_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_tick_err_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_vis_err_ne with "Ha"). } - eapply (step_fupdN_soundness_lc _ 0 (cr + (3*k+2))). - intros Hinv. iIntros "[Hcr Hlc]". - iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". - destruct (Hwp Hinv sg) as (Φ & HΦ & Hprf'). - iPoseProof (Hprf' with "[$Hs2 $Hcr]") as "Hic". - iPoseProof (wp_ssteps_isafe with "[$Hs $Hic]") as "H". - { eassumption. } - iMod ("H" with "Hlc") as "[H | H]". - { iDestruct "H" as (βv) "%Hbeta". - exfalso. rewrite Hbeta in Hbv. - inversion Hbv. } - iFrame "H". - by iApply fupd_mask_intro_discard. -Qed. + Notation "'CLWP@{' re } α @ s ; E {{ Φ } }" := (clwp re α s E Φ) + (at level 20, α, s, Φ at level 200, only parsing) : bi_scope. + + Notation "'CLWP@{' re } α @ s ; E {{ v , Q } }" := (clwp re α s E (λ v, Q)) + (at level 20, α, s, Q at level 200, + format "'[hv' 'CLWP@{' re } α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. + + Notation "'CLWP@{' re } α @ s {{ β , Φ } }" := (clwp re α s ⊤ (λ β, Φ)) + (at level 20, α, Φ at level 200, + format "'CLWP@{' re } α @ s {{ β , Φ } }") : bi_scope. + + Notation "'CLWP@{' re } α @ s {{ Φ } }" := (clwp re α s ⊤ Φ) + (at level 20, α, Φ at level 200, + format "'CLWP@{' re } α @ s {{ Φ } }") : bi_scope. + + Notation "'CLWP@{' re } α {{ β , Φ } }" := (clwp re α notStuck ⊤ (λ β, Φ)) + (at level 20, α, Φ at level 200, + format "'CLWP@{' re } α {{ β , Φ } }") : bi_scope. + + Notation "'CLWP@{' re } α {{ Φ } }" := (clwp re α notStuck ⊤ Φ) + (at level 20, α, Φ at level 200, + format "'CLWP@{' re } α {{ Φ } }") : bi_scope. + + Lemma wp_adequacy cr Σ `{!invGpreS Σ} n (rs : gReifiers n) + {A} `{!Cofe A} `{!statePreG rs A Σ} + (α : IT _ A) σ βv σ' s k (ψ : (ITV (gReifiers_ops rs) A) → Prop) : + ssteps (gReifiers_sReifier rs) α σ (IT_of_V βv) σ' k → + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs A Σ}, + ∃ Φ, NonExpansive Φ ∧ (∀ βv, Φ βv ⊢ ⌜ψ βv⌝) + ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → + ψ βv. + Proof. + intros Hst Hprf. + cut (⊢ ⌜ψ βv⌝ : iProp Σ)%I. + { intros HH. eapply uPred.pure_soundness; eauto. } + eapply (step_fupdN_soundness_lc _ 0 (cr + 3*k)). + intros Hinv. iIntros "[Hcr Hlc]". + iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". + destruct (Hprf Hinv sg) as (Φ & HΦ & HΦψ & Hprf'). + iPoseProof (Hprf' with "[$Hcr $Hs2]") as "Hic". + iPoseProof (wp_ssteps with "[$Hs $Hic]") as "Hphi". + { eassumption. } + iMod ("Hphi" with "Hlc") as "[Hst H]". + rewrite wp_val_inv; eauto. + iMod "H" as "H". + rewrite HΦψ. iFrame "H". + by iApply fupd_mask_intro_discard. + Qed. + + Lemma wp_safety cr Σ `{!invGpreS Σ} n (rs : gReifiers n) + {A} `{!Cofe A} `{!statePreG rs A Σ} s k + (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : + (∀ Σ P Q, @disjunction_property Σ P Q) → + ssteps (gReifiers_sReifier rs) α σ β σ' k → + IT_to_V β ≡ None → + (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, + ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → + ((∃ β1 σ1, sstep (gReifiers_sReifier rs) β σ' β1 σ1) + ∨ (∃ e, β ≡ Err e ∧ s e)). + Proof. + Opaque istep. + intros Hdisj Hstep Hbv Hwp. + cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier rs) β σ' β1 σ1) + ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. + { intros [Hprf | Hprf]%Hdisj. + - left. + apply (istep_safe_sstep _ (Σ:=Σ)). + { apply Hdisj. } + done. + - right. + destruct (IT_dont_confuse β) + as [[e Ha] | [[m Ha] | [ [g Ha] | [[α' Ha]|[op [i [ko Ha]]]] ]]]. + + exists e. split; eauto. + eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[He %Hs]". rewrite Ha. + iPoseProof (Err_inj' with "He") as "%He". + iPureIntro. rewrite He//. + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_ret_err_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_fun_err_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_tick_err_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_vis_err_ne with "Ha"). } + eapply (step_fupdN_soundness_lc _ 0 (cr + (3*k+2))). + intros Hinv. iIntros "[Hcr Hlc]". + iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". + destruct (Hwp Hinv sg) as (Φ & HΦ & Hprf'). + iPoseProof (Hprf' with "[$Hs2 $Hcr]") as "Hic". + iPoseProof (wp_ssteps_isafe with "[$Hs $Hic]") as "H". + { eassumption. } + iMod ("H" with "Hlc") as "[H | H]". + { iDestruct "H" as (βv) "%Hbeta". + exfalso. rewrite Hbeta in Hbv. + inversion Hbv. } + iFrame "H". + by iApply fupd_mask_intro_discard. + Qed. diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index d54b12f..1b49435 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -185,6 +185,20 @@ Section weakestpre. iModIntro. done. Qed. + Lemma clwp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : + update_input σ = (n, σ') → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ CLWP@{rs} (k n) @ s {{ Φ }}) -∗ + CLWP@{rs} (INPUT k) @ s {{ Φ }}. + Proof. + intros Hs. iIntros "Hs Ha". + rewrite clwp_eq. + iIntros (K HK Ψ) "Hf". + rewrite hom_vis. + unfold ccompose, compose. + simpl. + Admitted. + Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : update_output n σ = σ' → has_substate σ -∗ @@ -220,6 +234,30 @@ Section weakestpre. iApply "Ha". Qed. + Lemma wp_callcc (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k (Tau (f (laterO_map k))) @ s {{ Φ }}) -∗ + WP@{rs} (k (CALLCC f)) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + unfold CALLCC. simpl. + rewrite hom_vis. + iApply (wp_subreify with "Hs"). + { + simpl. + do 2 f_equiv; reflexivity. + } + { + simpl. + reflexivity. + } + iModIntro. + iIntros "HC HS". + simpl. + unfold ccompose, compose. + simpl. + Admitted. + End weakestpre. Section interp. @@ -889,15 +927,12 @@ Section interp. simpl. reflexivity. } - rewrite reify_vis_eq //; last first. + rewrite reify_vis_eq //; first last. { - epose proof (@subReifier_reify sz reify_io rs _ IT _ (inl ()) () (Next (interp_ectx K env (Ret n0))) (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr) as H. - simpl in H. - simpl. - erewrite <-H; last first. - - rewrite H5. - reflexivity. - - (* holds *) + pose proof (@subReifier_reify sz reify_io rs subR IT _ (inl ()) () (Next (interp_ectx K env (Ret n0))) (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr) as H. + rewrite <-H; first last. + - by rewrite //=H5. + - clear. admit. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. @@ -974,7 +1009,7 @@ Section interp. erewrite <-H; last first. - reflexivity. - simpl. - subst k k' fff σ'' fσ f. + subst k k' fff σ'' fσ f. admit. } f_equiv. @@ -1057,9 +1092,10 @@ Section interp. rewrite get_val_ITV. simpl. rewrite get_fun_fun. - simpl. - change 1 with (Nat.add 1 0). econstructor; last first. - { apply ssteps_zero; reflexivity. } + simpl. + change 2 with (Nat.add (Nat.add 1 1) 0). + econstructor; last first. + { apply ssteps_tick_n. } eapply sstep_reify; first (rewrite hom_vis; reflexivity). match goal with | |- context G [ofe_mor_car _ _ _ (Next ?f)] => set (f' := f) @@ -1077,8 +1113,15 @@ Section interp. destruct ((subEff_outs ^-1) x). } rewrite reify_vis_eq; first (rewrite Tick_eq; reflexivity). - subst f'. - pose proof @sstep_tick. + assert (laterO_ap (Next f') (Next (interp_val v env)) + ≡ + (Next (Tau (Next ((interp_ectx K' env) (interp_val v env)))))). + { + simpl. + rewrite laterO_map_Next. + reflexivity. + } + (* holds (but with extra tick step) *) admit. } diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index 10888ca..07ee8a8 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -473,7 +473,7 @@ Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) | Throw_step e1 σ e2 (K : ectx S) v K' : e1 = (fill K (Throw (of_val v) (ContV K'))) -> e2 = (fill K' v) -> - prim_step e1 σ e2 σ (1, 0). + prim_step e1 σ e2 σ (2, 0). Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. diff --git a/theories/input_lang_callcc/logpred.v b/theories/input_lang_callcc/logpred.v index 45f9058..3ca68b4 100644 --- a/theories/input_lang_callcc/logpred.v +++ b/theories/input_lang_callcc/logpred.v @@ -19,11 +19,25 @@ Section io_lang. Variable s : stuckness. Context {A:ofe}. - Variable (P : A → iProp). - Context `{!NonExpansive P}. + Variable (P : A -n> iProp). Local Notation expr_pred := (expr_pred s rs P). + (* Program Definition interp_ectx (interp : listC D -n> D) (K : ectx S) *) + (* : listC D -n> iProp Σ := *) + (* λne Δ, (□ ∀ v, interp Δ v -∗ WP (fill K (of_val v)) {{_, True}})%I. *) + (* Solve Obligations with repeat intros ?; simpl; solve_proper. *) + + (* Program Definition interp_cont (interp : listC D -n> D) *) + (* : listC D -n> D := *) + (* λne Δ w, (∃ K, ⌜w = ContV K⌝ ∧ interp_ectx interp K Δ)%I. *) + (* Solve Obligations with repeat intros ?; simpl; solve_proper. *) + + (* Program Definition interp_expr (interp : listC D -n> D) : *) + (* listC D -n> (exprC -n> iProp Σ) := *) + (* λne Δ e, (∀ K, interp_ectx interp K Δ -∗ WP (fill K e) {{_, True}})%I. *) + (* Solve Obligations with repeat intros ?; simpl; solve_proper. *) + Program Definition interp_tnat : ITV -n> iProp := λne αv, (∃ n : nat, αv ≡ RetV n)%I. Solve All Obligations with solve_proper. @@ -31,7 +45,16 @@ Section io_lang. (□ ∀ σ βv, has_substate σ -∗ Φ1 βv -∗ expr_pred (IT_of_V αv ⊙ (IT_of_V βv)) (λne v, ∃ σ', Φ2 v ∗ has_substate σ'))%I. - Solve All Obligations with solve_proper. + Solve All Obligations with try solve_proper. + Next Obligation. + intros. + solve_proper_prepare. + do 8 f_equiv. + unfold expr_pred. + do 3 f_equiv. + apply clwp_ne'. + solve_proper. + Qed. Fixpoint interp_ty (τ : ty) : ITV -n> iProp := match τ with @@ -73,9 +96,9 @@ Section io_lang. iIntros (σ ss) "Hs Has". simpl. iIntros (x) "G". iDestruct ("Has" $! v x with "G") as "Has". - iApply (wp_wand with "[$Has] [Hs]"). + iApply (clwp_wand with "[$Has] [Hs]"). iIntros (v') "(%y & H1 & H2)". - iModIntro. + simpl. iExists y. iFrame "H2". iExists σ. @@ -93,139 +116,144 @@ Section io_lang. iIntros (σ ss) "Hs #Has". iSpecialize ("H0" with "Hs Has"). simpl. - iApply (expr_pred_bind (IFSCtx _ _) with "H0"). + unshelve epose (K := _ : IT -n> IT). + { apply (λne x, IFSCtx (β1 ss) (β2 ss) x). } + iApply (expr_pred_bind K with "H0"). iIntros (αv) "Ha/=". iDestruct "Ha" as (σ') "[Ha Hs]". iDestruct "Ha" as (n) "Hn". unfold IFSCtx. iIntros (x) "Hx". - iRewrite "Hn". - destruct n as [|n]. - - rewrite IF_False; last lia. - iApply ("H2" with "Hs Has Hx"). - - rewrite IF_True; last lia. - iApply ("H1" with "Hs Has Hx"). - Qed. + (* iRewrite "Hn". *) + (* destruct n as [|n]. *) + (* - rewrite IF_False; last lia. *) + (* iApply ("H2" with "Hs Has Hx"). *) + (* - rewrite IF_True; last lia. *) + (* iApply ("H1" with "Hs Has Hx"). *) + Admitted. - Lemma compat_input {S : Set} (Γ : S -> ty) : - ⊢ valid1 Γ (interp_input rs) Tnat. - Proof. - iIntros (σ ss) "Hs #Has". - iApply expr_pred_frame. - destruct (update_input σ) as [n σ'] eqn:Hinp. - iApply (wp_input with "Hs") . - { eauto. } - iNext. iIntros "_ Hs". - iApply wp_val. simpl. eauto with iFrame. - Qed. + (* Lemma compat_input {S : Set} (Γ : S -> ty) : *) + (* ⊢ valid1 Γ (interp_input rs) Tnat. *) + (* Proof. *) + (* iIntros (σ ss) "Hs #Has". *) + (* iApply expr_pred_frame. *) + (* destruct (update_input σ) as [n σ'] eqn:Hinp. *) + (* iApply (wp_input with "Hs") . *) + (* { eauto. } *) + (* iNext. iIntros "_ Hs". *) + (* iApply wp_val. simpl. eauto with iFrame. *) + (* Qed. *) - Lemma compat_output {S : Set} (Γ : S -> ty) α : - ⊢ valid1 Γ α Tnat → valid1 Γ (interp_output rs α) Tnat. - Proof. - iIntros "H". - iIntros (σ ss) "Hs #Has". - iSpecialize ("H" with "Hs Has"). - simpl. - iApply (expr_pred_bind (get_ret _) with "H"). - iIntros (αv) "Ha". - iDestruct "Ha" as (σ') "[Ha Hs]". - iDestruct "Ha" as (n) "Hn". - iApply expr_pred_frame. - iRewrite "Hn". - rewrite get_ret_ret. - iApply (wp_output with "Hs"). - { reflexivity. } - iNext. iIntros "_ Hs /=". - eauto with iFrame. - Qed. + (* Lemma compat_output {S : Set} (Γ : S -> ty) α : *) + (* ⊢ valid1 Γ α Tnat → valid1 Γ (interp_output rs α) Tnat. *) + (* Proof. *) + (* iIntros "H". *) + (* iIntros (σ ss) "Hs #Has". *) + (* iSpecialize ("H" with "Hs Has"). *) + (* simpl. *) + (* iApply (expr_pred_bind (get_ret _) with "H"). *) + (* iIntros (αv) "Ha". *) + (* iDestruct "Ha" as (σ') "[Ha Hs]". *) + (* iDestruct "Ha" as (n) "Hn". *) + (* iApply expr_pred_frame. *) + (* iRewrite "Hn". *) + (* rewrite get_ret_ret. *) + (* iApply (wp_output with "Hs"). *) + (* { reflexivity. } *) + (* iNext. iIntros "_ Hs /=". *) + (* eauto with iFrame. *) + (* Qed. *) - Lemma compat_app {S : Set} (Γ : S -> ty) α β τ1 τ2 : - ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ - valid1 Γ β τ1 -∗ - valid1 Γ (interp_app rs α β) τ2. - Proof. - iIntros "H1 H2". - iIntros (σ ss) "Hs #Has". simpl. - iSpecialize ("H2" with "Hs Has"). - iApply (expr_pred_bind (AppRSCtx _) with "H2"). - iIntros (βv) "Hb/=". - iDestruct "Hb" as (σ') "[Hb Hs]". - unfold AppRSCtx. - iSpecialize ("H1" with "Hs Has"). - iApply (expr_pred_bind (AppLSCtx (IT_of_V βv)) with "H1"). - iIntros (αv) "Ha". - iDestruct "Ha" as (σ'') "[Ha Hs]". - unfold AppLSCtx. - iApply ("Ha" with "Hs Hb"). - Qed. + (* Lemma compat_app {S : Set} (Γ : S -> ty) α β τ1 τ2 : *) + (* ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ *) + (* valid1 Γ β τ1 -∗ *) + (* valid1 Γ (interp_app rs α β) τ2. *) + (* Proof. *) + (* iIntros "H1 H2". *) + (* iIntros (σ ss) "Hs #Has". simpl. *) + (* iSpecialize ("H2" with "Hs Has"). *) + (* iApply (expr_pred_bind (AppRSCtx _) with "H2"). *) + (* iIntros (βv) "Hb/=". *) + (* iDestruct "Hb" as (σ') "[Hb Hs]". *) + (* unfold AppRSCtx. *) + (* iSpecialize ("H1" with "Hs Has"). *) + (* iApply (expr_pred_bind (AppLSCtx (IT_of_V βv)) with "H1"). *) + (* iIntros (αv) "Ha". *) + (* iDestruct "Ha" as (σ'') "[Ha Hs]". *) + (* unfold AppLSCtx. *) + (* iApply ("Ha" with "Hs Hb"). *) + (* Qed. *) - Lemma compat_rec {S : Set} (Γ : S -> ty) τ1 τ2 α : - ⊢ □ valid1 ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) α τ2 -∗ - valid1 Γ (interp_rec rs α) (Tarr τ1 τ2). - Proof. - iIntros "#H". iIntros (σ ss) "Hs #Hss". - pose (env := ss). fold env. - pose (f := (ir_unf rs α env)). - iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". - { iPureIntro. apply interp_rec_unfold. } - iRewrite "Hf". iApply expr_pred_ret. simpl. - iExists _. iFrame. iModIntro. - iLöb as "IH". iSimpl. - clear σ. - iIntros (σ βv) "Hs #Hw". - iIntros (x) "Hx". - iApply wp_lam. - iNext. - unfold valid1. - iAssert (IT_of_V (FunV (Next f)) ≡ interp_rec rs α env)%I as "Heq". - { rewrite interp_rec_unfold. done. } - iRewrite -"Heq". - unfold f. - Opaque extend_scope. - simpl. - pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V βv))). - iApply ("H" with "[$Hs] [] [$Hx]"). - Transparent extend_scope. - iIntros (x'); destruct x' as [| [| x']]; simpl. - - iModIntro. - by iApply expr_pred_ret. - - iModIntro. - iRewrite - "Heq". - iApply expr_pred_ret. - iModIntro. - iApply "IH". - - iApply "Hss". - Qed. + (* Lemma compat_rec {S : Set} (Γ : S -> ty) τ1 τ2 α : *) + (* ⊢ □ valid1 ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) α τ2 -∗ *) + (* valid1 Γ (interp_rec rs α) (Tarr τ1 τ2). *) + (* Proof. *) + (* iIntros "#H". iIntros (σ ss) "Hs #Hss". *) + (* pose (env := ss). fold env. *) + (* pose (f := (ir_unf rs α env)). *) + (* iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". *) + (* { iPureIntro. apply interp_rec_unfold. } *) + (* iRewrite "Hf". iApply expr_pred_ret. simpl. *) + (* iExists _. iFrame. iModIntro. *) + (* iLöb as "IH". iSimpl. *) + (* clear σ. *) + (* iIntros (σ βv) "Hs #Hw". *) + (* iIntros (x) "Hx". *) + (* iApply wp_lam. *) + (* iNext. *) + (* unfold valid1. *) + (* iAssert (IT_of_V (FunV (Next f)) ≡ interp_rec rs α env)%I as "Heq". *) + (* { rewrite interp_rec_unfold. done. } *) + (* iRewrite -"Heq". *) + (* unfold f. *) + (* Opaque extend_scope. *) + (* simpl. *) + (* pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V βv))). *) + (* iApply ("H" with "[$Hs] [] [$Hx]"). *) + (* Transparent extend_scope. *) + (* iIntros (x'); destruct x' as [| [| x']]; simpl. *) + (* - iModIntro. *) + (* by iApply expr_pred_ret. *) + (* - iModIntro. *) + (* iRewrite - "Heq". *) + (* iApply expr_pred_ret. *) + (* iModIntro. *) + (* iApply "IH". *) + (* - iApply "Hss". *) + (* Qed. *) - Lemma compat_natop {S : Set} (Γ : S -> ty) op α β : - ⊢ valid1 Γ α Tnat -∗ - valid1 Γ β Tnat -∗ - valid1 Γ (interp_natop _ op α β) Tnat. - Proof. - iIntros "H1 H2". - iIntros (σ ss) "Hs #Has". simpl. - iSpecialize ("H2" with "Hs Has"). - iApply (expr_pred_bind (NatOpRSCtx _ _) with "H2"). - iIntros (βv) "Hb/=". - iDestruct "Hb" as (σ') "[Hb Hs]". - unfold NatOpRSCtx. - iSpecialize ("H1" with "Hs Has"). - iApply (expr_pred_bind (NatOpLSCtx _ (IT_of_V βv)) with "H1"). - iIntros (αv) "Ha". - iDestruct "Ha" as (σ'') "[Ha Hs]". - unfold NatOpLSCtx. - iDestruct "Hb" as (n1) "Hb". - iDestruct "Ha" as (n2) "Ha". - iRewrite "Hb". iRewrite "Ha". - simpl. iApply expr_pred_frame. - rewrite NATOP_Ret. iApply wp_val. simpl. - eauto with iFrame. - Qed. + (* Lemma compat_natop {S : Set} (Γ : S -> ty) op α β : *) + (* ⊢ valid1 Γ α Tnat -∗ *) + (* valid1 Γ β Tnat -∗ *) + (* valid1 Γ (interp_natop _ op α β) Tnat. *) + (* Proof. *) + (* iIntros "H1 H2". *) + (* iIntros (σ ss) "Hs #Has". simpl. *) + (* iSpecialize ("H2" with "Hs Has"). *) + (* iApply (expr_pred_bind (NatOpRSCtx _ _) with "H2"). *) + (* iIntros (βv) "Hb/=". *) + (* iDestruct "Hb" as (σ') "[Hb Hs]". *) + (* unfold NatOpRSCtx. *) + (* iSpecialize ("H1" with "Hs Has"). *) + (* iApply (expr_pred_bind (NatOpLSCtx _ (IT_of_V βv)) with "H1"). *) + (* iIntros (αv) "Ha". *) + (* iDestruct "Ha" as (σ'') "[Ha Hs]". *) + (* unfold NatOpLSCtx. *) + (* iDestruct "Hb" as (n1) "Hb". *) + (* iDestruct "Ha" as (n2) "Ha". *) + (* iRewrite "Hb". iRewrite "Ha". *) + (* simpl. iApply expr_pred_frame. *) + (* rewrite NATOP_Ret. iApply wp_val. simpl. *) + (* eauto with iFrame. *) + (* Qed. *) Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β : ⊢ valid1 Γ α τ -∗ valid1 Γ β (Tcont τ) -∗ valid1 Γ (interp_throw _ α β) τ'. Proof. + iIntros "H1 H2". + iIntros (σ ss) "Hs #Has"; simpl. + Admitted. Lemma compat_callcc {S : Set} (Γ : S -> ty) τ α : diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 534a185..0a62bd8 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -1,7 +1,9 @@ (** Logical relation for adequacy for the IO lang *) From Equations Require Import Equations. From gitrees Require Import gitree. -From gitrees.input_lang Require Import lang interp. +From gitrees.input_lang_callcc Require Import lang interp. +Require Import gitrees.lang_generic_sem. +Require Import Binding.Lib Binding.Set Binding.Env. Section logrel. Context {sz : nat}. @@ -16,7 +18,7 @@ Section logrel. Canonical Structure exprO S := leibnizO (expr S). Canonical Structure valO S := leibnizO (val S). - Local Notation tyctx := (tyctx ty). + Canonical Structure ectxO S := leibnizO (ectx S). Notation "'WP' α {{ β , Φ } }" := (wp rs α notStuck ⊤ (λ β, Φ)) (at level 20, α, Φ at level 200, @@ -26,394 +28,531 @@ Section logrel. (at level 20, α, Φ at level 200, format "'WP' α {{ Φ } }") : bi_scope. - Definition logrel_expr {S} V (α : IT) (e : expr S) : iProp := + Definition logrel_nat {S} (βv : ITV) (v : val S) : iProp := + (∃ n, βv ≡ RetV n ∧ ⌜v = LitV n⌝)%I. + + Definition obs_ref {S} (α : IT) (e : expr S) : iProp := (∀ (σ : stateO), has_substate σ -∗ WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ - ∗ V βv v ∗ has_substate σ' }})%I. - Definition logrel_nat {S} (βv : ITV) (v : val S) : iProp := - (∃ n, βv ≡ RetV n ∧ ⌜v = Lit n⌝)%I. + ∗ logrel_nat βv v ∗ has_substate σ' }})%I. + + Definition HOM : ofe := @sigO (IT -n> IT) IT_hom. + + Global Instance HOM_hom (κ : HOM) : IT_hom (`κ). + Proof. + apply (proj2_sig κ). + Qed. + + Definition logrel_ectx {S} V (κ : HOM) (K : ectx S) : iProp := + (□ ∀ (βv : ITV) (v : val S), V βv v -∗ obs_ref (`κ (IT_of_V βv)) (fill K (Val v)))%I. + + Definition logrel_expr {S} V (α : IT) (e : expr S) : iProp := + (∀ (κ : HOM) (K : ectx S), + logrel_ectx V κ K -∗ obs_ref (`κ α) (fill K e))%I. + Definition logrel_arr {S} V1 V2 (βv : ITV) (vf : val S) : iProp := - (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. + (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ + logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. + + Global Instance denot_cont_ne (κ : IT -n> IT) : + NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). + Proof. + solve_proper. + Qed. - Fixpoint logrel_val (τ : ty) {S} : ITV → (val S) → iProp + Definition logrel_cont {S} V (βv : ITV) (v : val S) : iProp := + (∃ (κ : HOM) K, (IT_of_V βv) ≡ (Fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))) + ∧ ⌜v = ContV K⌝ + ∧ □ logrel_ectx V κ K)%I. + + Fixpoint logrel_val {S} (τ : ty) : ITV → (val S) → iProp := match τ with | Tnat => logrel_nat | Tarr τ1 τ2 => logrel_arr (logrel_val τ1) (logrel_val τ2) + | Tcont τ => logrel_cont (logrel_val τ) end. - Definition logrel (τ : ty) {S} : IT → (expr S) → iProp + Definition logrel {S} (τ : ty) : IT → (expr S) → iProp := logrel_expr (logrel_val τ). + #[export] Instance obs_ref_ne {S} : + NonExpansive2 (@obs_ref S). + Proof. + solve_proper. + Qed. + #[export] Instance logrel_expr_ne {S} (V : ITV → val S → iProp) : NonExpansive2 V → NonExpansive2 (logrel_expr V). - Proof. solve_proper. Qed. + Proof. + solve_proper. + Qed. + #[export] Instance logrel_nat_ne {S} : NonExpansive2 (@logrel_nat S). - Proof. solve_proper. Qed. - #[export] Instance logrel_val_ne (τ : ty) {S} : NonExpansive2 (@logrel_val τ S). - Proof. induction τ; simpl; solve_proper. Qed. - #[export] Instance logrel_expr_proper {S} (V : ITV → val S → iProp) : - Proper ((≡) ==> (≡) ==> (≡)) V → - Proper ((≡) ==> (≡) ==> (≡)) (logrel_expr V). - Proof. solve_proper. Qed. - #[export] Instance logrel_val_proper (τ : ty) {S} : - Proper ((≡) ==> (≡) ==> (≡)) (@logrel_val τ S). - Proof. induction τ; simpl; solve_proper. Qed. - #[export] Instance logrel_persistent (τ : ty) {S} α v : - Persistent (@logrel_val τ S α v). Proof. - revert α v. induction τ=> α v; simpl. - - unfold logrel_nat. apply _. - - unfold logrel_arr. apply _. + solve_proper. Qed. - Lemma logrel_bind {S} (f : IT → IT) (K : ectx S) `{!IT_hom f} - e α τ1 V2 `{!NonExpansive2 V2} : - ⊢ logrel_expr (logrel_val τ1) α e -∗ - (∀ v βv, logrel_val τ1 βv v -∗ - logrel_expr V2 (f (IT_of_V βv)) (fill K (Val v))) -∗ - logrel_expr V2 (f α) (fill K e). + #[export] Instance logrel_val_ne {S} (τ : ty) : NonExpansive2 (@logrel_val S τ). Proof. - iIntros "H1 H2". - iLöb as "IH" forall (α e). - iIntros (σ) "Hs". - iApply wp_bind. - { solve_proper. } - iSpecialize ("H1" with "Hs"). - iApply (wp_wand with "H1"). - iIntros (αv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H1 Hs]". - apply (prim_steps_ctx K) in Hsteps. - iSpecialize ("H2" with "H1 Hs"). - iApply (wp_wand with "H2"). iModIntro. - iIntros (βv). iDestruct 1 as ([m2 m2'] v2 σ2' Hsteps2) "[H2 Hs]". - iExists (m + m2, m' + m2'),v2,σ2'. iFrame "H2 Hs". - iPureIntro. eapply (prim_steps_app (m,m') (m2,m2')); eauto. + induction τ; simpl; solve_proper. Qed. - Lemma logrel_of_val {S} αv (v : val S) V : - V αv v -∗ logrel_expr V (IT_of_V αv) (Val v). + #[export] Instance logrel_ectx_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V → NonExpansive2 (logrel_ectx V). Proof. - iIntros "H1". iIntros (σ) "Hs". - iApply wp_val. - iExists (0,0),v,σ. iFrame. iPureIntro. - by econstructor. + solve_proper. Qed. - Lemma logrel_step_pure {S} (e' e : expr S) α V : - (∀ σ, prim_step e σ e' σ (0,0)) → - logrel_expr V α e' ⊢ logrel_expr V α e. + #[export] Instance logrel_arr_ne {S} (V1 V2 : ITV → val S → iProp) : + NonExpansive2 V1 -> NonExpansive2 V2 → NonExpansive2 (logrel_arr V1 V2). Proof. - intros Hpure. - iIntros "H". - iIntros (σ) "Hs". - iSpecialize ("H" with "Hs"). - iApply (wp_wand with "H"). - iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". - iExists (m,m'),v,σ'. iFrame "H2 Hs". - iPureIntro. - eapply (prim_steps_app (0,0) (m,m')); eauto. - { eapply prim_step_steps, Hpure. } + solve_proper. Qed. - (* a matching list of closing substitutions *) - Inductive subs2 : scope → Type := - | emp_subs2 : subs2 [] - | cons_subs2 {S} : val [] → ITV → subs2 S → subs2 (()::S) - . + #[export] Instance logrel_cont_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V -> NonExpansive2 (logrel_cont V). + Proof. + solve_proper. + Qed. - Equations subs_of_subs2 {S} (ss : subs2 S) : subs S [] := - subs_of_subs2 emp_subs2 v => idsub v; - subs_of_subs2 (cons_subs2 t α ss) Vz := Val t; - subs_of_subs2 (cons_subs2 t α ss) (Vs v) := subs_of_subs2 ss v. + #[export] Instance obs_ref_proper {S} : + Proper ((≡) ==> (≡) ==> (≡)) (@obs_ref S). + Proof. + solve_proper. + Qed. - Equations its_of_subs2 {S} (ss : subs2 S) : interp_scope (E:=F) (R:=natO) S := - its_of_subs2 emp_subs2 := (); - its_of_subs2 (cons_subs2 t α ss) := (IT_of_V α, its_of_subs2 ss). + #[export] Instance logrel_expr_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V → Proper ((≡) ==> (≡) ==> (≡)) (logrel_expr V). + Proof. + solve_proper. + Qed. - Equations list_of_subs2 {S} (ss : subs2 S) : list (val []*ITV) := - list_of_subs2 emp_subs2 := []; - list_of_subs2 (cons_subs2 v α ss) := (v,α)::(list_of_subs2 ss). + #[export] Instance logrel_nat_proper {S} : Proper ((≡) ==> (≡) ==> (≡)) (@logrel_nat S). + Proof. + solve_proper. + Qed. - Lemma subs_of_emp_subs2 : subs_of_subs2 emp_subs2 ≡ idsub. - Proof. intros v. dependent elimination v. Qed. + #[export] Instance logrel_val_proper {S} (τ : ty) : Proper ((≡) ==> (≡) ==> (≡)) (@logrel_val S τ). + Proof. + induction τ; simpl; solve_proper. + Qed. - Definition subs2_valid {S} (Γ : tyctx S) (ss : subs2 S) : iProp := - ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_subs2 ss), - logrel_val (τx.1) (τx.2.2) (τx.2.1))%I. + #[export] Instance logrel_ectx_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V → Proper ((≡) ==> (≡) ==> (≡)) (logrel_ectx V). + Proof. + solve_proper. + Qed. - Definition logrel_valid {S} (Γ : tyctx S) (e : expr S) (α : interp_scope S -n> IT) (τ : ty) : iProp := - (∀ ss, subs2_valid Γ ss → logrel τ - (α (its_of_subs2 ss)) - (subst_expr e (subs_of_subs2 ss)))%I. + #[export] Instance logrel_arr_proper {S} (V1 V2 : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V1 -> Proper ((≡) ==> (≡) ==> (≡)) V2 → Proper ((≡) ==> (≡) ==> (≡)) (logrel_arr V1 V2). + Proof. + solve_proper. + Qed. - Lemma compat_var {S} (Γ : tyctx S) (x : var S) τ : - typed_var Γ x τ → ⊢ logrel_valid Γ (Var x) (interp_var x) τ. + #[export] Instance logrel_cont_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V -> Proper ((≡) ==> (≡) ==> (≡)) (logrel_cont V). Proof. - intros Hx. iIntros (ss) "Hss". - simp subst_expr. - iInduction Hx as [|Hx] "IH". - - dependent elimination ss. simp subs_of_subs2. - simp interp_var. rewrite /subs2_valid. - simp list_of_tyctx list_of_subs2 its_of_subs2. simpl. - iDestruct "Hss" as "[Hv Hss]". - iApply (logrel_of_val with "Hv"). - - dependent elimination ss. simp subs_of_subs2. - simp interp_var. rewrite /subs2_valid. - simp list_of_tyctx list_of_subs2 its_of_subs2. simpl. - iDestruct "Hss" as "[Hv Hss]". by iApply "IH". + solve_proper. Qed. - Lemma compat_if {S} (Γ : tyctx S) (e0 e1 e2 : expr S) α0 α1 α2 τ : - ⊢ logrel_valid Γ e0 α0 Tnat -∗ - logrel_valid Γ e1 α1 τ -∗ - logrel_valid Γ e2 α2 τ -∗ - logrel_valid Γ (If e0 e1 e2) (interp_if rs α0 α1 α2) τ. + #[export] Instance logrel_val_persistent {S} (τ : ty) α v : + Persistent (@logrel_val S τ α v). Proof. - iIntros "H0 H1 H2". iIntros (ss) "#Hss". - simpl. simp subst_expr. - pose (s := (subs_of_subs2 ss)). fold s. - iSpecialize ("H0" with "Hss"). - iApply (logrel_bind (IFSCtx (α1 (its_of_subs2 ss)) (α2 (its_of_subs2 ss))) - [IfCtx (subst_expr e1 s) (subst_expr e2 s)] - with "H0"). - iIntros (v βv). iDestruct 1 as (n) "[Hb ->]". - iRewrite "Hb". simpl. - unfold IFSCtx. - destruct (decide (0 < n)). - - rewrite IF_True//. - iSpecialize ("H1" with "Hss"). - iApply (logrel_step_pure with "H1"). - intros ?. apply (Ectx_step' []). - econstructor; eauto. - - rewrite IF_False; last lia. - iSpecialize ("H2" with "Hss"). - iApply (logrel_step_pure with "H2"). - intros ?. apply (Ectx_step' []). - econstructor; eauto. lia. + revert α v. induction τ=> α v; simpl. + - unfold logrel_nat. apply _. + - unfold logrel_arr. apply _. + - unfold logrel_cont. apply _. Qed. - Lemma compat_recV {S} Γ (e : expr (()::()::S)) τ1 τ2 α : - ⊢ □ logrel_valid (consC (Tarr τ1 τ2) (consC τ1 Γ)) e α τ2 -∗ - logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). + #[export] Instance logrel_ectx_persistent {S} V κ K : + Persistent (@logrel_ectx S V κ K). Proof. - iIntros "#H". iIntros (ss) "#Hss". - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := (its_of_subs2 ss)). fold env. - simp subst_expr. - pose (f := (ir_unf rs α env)). - iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". - { iPureIntro. apply interp_rec_unfold. } - iRewrite "Hf". - iApply logrel_of_val. iLöb as "IH". iSimpl. - iExists (Next f). iSplit; eauto. - iModIntro. - iIntros (βv w) "#Hw". - iAssert ((APP' (Fun $ Next f) (IT_of_V βv)) ≡ (Tick (ir_unf rs α env (IT_of_V βv))))%I - as "Htick". - { iPureIntro. rewrite APP_APP'_ITV. - rewrite APP_Fun. simpl. done. } - iRewrite "Htick". iClear "Htick". - iIntros (σ) "Hs". - iApply wp_tick. iNext. simpl. - pose (ss' := cons_subs2 (RecV (subst_expr e (subs_lift (subs_lift s)))) (FunV (Next (ir_unf rs α env))) (cons_subs2 w βv ss)). - iSpecialize ("H" $! ss' with "[Hss]"). - { rewrite {2}/subs2_valid /ss'. simp list_of_tyctx list_of_subs2. - cbn-[logrel_val]. iFrame "Hss Hw". fold f. iRewrite -"Hf". - by iApply "IH". } - iSpecialize ("H" with "Hs"). - iClear "IH Hss Hw". - unfold ss'. simpl. simp its_of_subs2. fold f env. - iRewrite "Hf". simpl. - iApply (wp_wand with "H"). - iIntros (v). - iDestruct 1 as ([m m'] v0 σ0 Hsteps) "[Hv Hs]". - iExists (1+m,0+m'),v0,σ0. iFrame "Hv Hs". - iPureIntro. econstructor; eauto. - apply (Ectx_step' []). - apply BetaS. - clear. - unfold subst2. - rewrite subst_expr_appsub. - apply subst_expr_proper. - intro v. - dependent elimination v. - { simp subs_of_subs2. unfold appsub. - simp subs_lift. simp subst_expr. - simp conssub. reflexivity. } - dependent elimination v. - { simp subs_of_subs2. unfold appsub. - simp subs_lift. unfold expr_lift. - simp ren_expr. simp subst_expr. - simp conssub. reflexivity. } - { simp subs_of_subs2. unfold appsub. - simp subs_lift. unfold expr_lift. - fold s. remember (s v) as e1. - rewrite ren_ren_expr. - rewrite subst_ren_expr. - trans (subst_expr e1 idsub). - - symmetry. apply subst_expr_idsub. - - apply subst_expr_proper. - intro v'. simpl. simp conssub. - reflexivity. } + apply _. Qed. - Lemma compat_rec {S} Γ (e : expr (()::()::S)) τ1 τ2 α : - ⊢ □ logrel_valid (consC (Tarr τ1 τ2) (consC τ1 Γ)) e α τ2 -∗ - logrel_valid Γ (Rec e) (interp_rec rs α) (Tarr τ1 τ2). + Lemma logrel_of_val {S} τ αv (v : val S) : + logrel_val τ αv v -∗ logrel τ (IT_of_V αv) (Val v). Proof. - iIntros "#H". iIntros (ss) "#Hss". - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := (its_of_subs2 ss)). fold env. - simp subst_expr. - iApply (logrel_step_pure (Val (RecV (subst_expr e (subs_lift (subs_lift s)))))). - { intros ?. eapply (Ectx_step' []). econstructor. } - iPoseProof (compat_recV with "H") as "H2". - iSpecialize ("H2" with "Hss"). - simp subst_expr. iApply "H2". + iIntros "H1". iIntros (κ K) "HK". + iIntros (σ) "Hs". + by iApply ("HK" $! αv v with "[$H1] [$Hs]"). Qed. - Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : - ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ - logrel_valid Γ e2 α2 τ1 -∗ - logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. + Lemma HOM_ccompose (f g : HOM) + : ∀ α, `f (`g α) = (`f ◎ `g) α. Proof. - iIntros "H1 H2". iIntros (ss) "#Hss". - iSpecialize ("H1" with "Hss"). - iSpecialize ("H2" with "Hss"). - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := its_of_subs2 ss). fold env. - simp subst_expr. simpl. - iApply (logrel_bind (AppRSCtx (α1 env)) [AppRCtx (subst_expr e1 s)] with "H2"). - iIntros (v2 β2) "H2". iSimpl. - iApply (logrel_bind (AppLSCtx (IT_of_V β2)) [AppLCtx v2] with "H1"). - iIntros (v1 β1) "H1". simpl. - iDestruct "H1" as (f) "[Hα H1]". - simpl. - unfold AppLSCtx. iRewrite "Hα". (** XXX why doesn't simpl work here? *) - iApply ("H1" with "H2"). + intro; reflexivity. Qed. - Lemma compat_input {S} Γ : - ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. + Lemma logrel_bind {S} (f : HOM) (K : ectx S) + e α τ1 : + ⊢ logrel τ1 α e -∗ + logrel_ectx (logrel_val τ1) f K -∗ + obs_ref (`f α) (fill K e). Proof. - iIntros (ss) "Hss". + iIntros "H1 #H2". + iLöb as "IH" forall (α e). iIntros (σ) "Hs". - destruct (update_input σ) as [n σ'] eqn:Hinp. - iApply (wp_input with "Hs []"); first eauto. - iNext. iIntros "Hlc Hs". - iApply wp_val. - iExists (1,1),(Lit n),σ'. - iFrame "Hs". iModIntro. iSplit. - { iPureIntro. - simp subst_expr. - apply prim_step_steps. - apply (Ectx_step' []). - by constructor. } - iExists n. eauto. + iApply (wp_wand with "[H1 H2 Hs] []"); first iApply ("H1" with "[H2] [$Hs]"). + - iIntros (βv v). iModIntro. + iIntros "#Hv". + by iApply "H2". + - iIntros (βv). + iIntros "?". + iModIntro. + iFrame. + Qed. + + Definition ssubst2_valid {S : Set} + (Γ : S -> ty) + (ss : @interp_scope F natO _ S) + (γ : S [⇒] ∅) + : iProp := + (∀ x, □ logrel (Γ x) (ss x) (γ x))%I. + + Definition logrel_valid {S : Set} + (Γ : S -> ty) + (e : expr S) + (α : @interp_scope F natO _ S -n> IT) + (τ : ty) : iProp := + (□ ∀ (ss : @interp_scope F natO _ S) + (γ : S [⇒] ∅), + ssubst2_valid Γ ss γ → logrel τ (α ss) (bind γ e))%I. + + Lemma compat_var {S : Set} (Γ : S -> ty) (x : S) : + ⊢ logrel_valid Γ (Var x) (interp_var x) (Γ x). + Proof. + iModIntro. + iIntros (ss γ) "Hss". + iApply "Hss". Qed. - Lemma compat_output {S} Γ (e: expr S) α : - ⊢ logrel_valid Γ e α Tnat -∗ - logrel_valid Γ (Output e) (interp_output rs α) Tnat. + + Lemma logrel_head_step_pure_ectx {S} n K (κ : HOM) (e' e : expr S) α V : + (∀ σ K, head_step e σ e' σ K (n, 0)) → + ⊢ logrel_expr V (`κ α) (fill K e') -∗ logrel_expr V (`κ α) (fill K e). Proof. - iIntros "H1". - iIntros (ss) "Hss". - iSpecialize ("H1" with "Hss"). - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := its_of_subs2 ss). fold env. - simp subst_expr. simpl. - iApply (logrel_bind (get_ret _) [OutputCtx] with "H1"). - iIntros (v βv). - iDestruct 1 as (m) "[Hb ->]". - iRewrite "Hb". simpl. + intros Hpure. + iIntros "H". + iIntros (κ' K') "#HK'". iIntros (σ) "Hs". - rewrite get_ret_ret. - iApply (wp_output with "Hs []"); first done. - iNext. iIntros "Hlc Hs". - iExists (1,1),(Lit 0),_. - iFrame "Hs". iSplit. - { iPureIntro. - apply prim_step_steps. - apply (Ectx_step' []). - by constructor. } - iExists 0. eauto. + iSpecialize ("H" with "HK'"). + iSpecialize ("H" with "Hs"). + iApply (wp_wand with "H"). + iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". + iExists ((Nat.add n m),m'),v,σ'. iFrame "H2 Hs". + iPureIntro. + eapply (prim_steps_app (n, 0) (m, m')); eauto. + eapply prim_step_steps. + rewrite !fill_comp. + eapply Ectx_step; last apply Hpure; done. Qed. - Lemma compat_natop {S} (Γ : tyctx S) e1 e2 α1 α2 op : - ⊢ logrel_valid Γ e1 α1 Tnat -∗ - logrel_valid Γ e2 α2 Tnat -∗ - logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. + Lemma compat_recV {S : Set} (Γ : S -> ty) (e : expr (inc (inc S))) τ1 τ2 α : + ⊢ □ logrel_valid ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) e α τ2 -∗ + logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). Proof. - iIntros "H1 H2". iIntros (ss) "#Hss". - iSpecialize ("H1" with "Hss"). - iSpecialize ("H2" with "Hss"). - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := its_of_subs2 ss). fold env. - simp subst_expr. simpl. - iApply (logrel_bind (NatOpRSCtx (do_natop op) (α1 env)) [NatOpRCtx op (subst_expr e1 s)] with "H2"). - iIntros (v2 β2) "H2". iSimpl. - iApply (logrel_bind (NatOpLSCtx (do_natop op) (IT_of_V β2)) [NatOpLCtx op v2] with "H1"). - iIntros (v1 β1) "H1". simpl. - iDestruct "H1" as (n1) "[Hn1 ->]". - iDestruct "H2" as (n2) "[Hn2 ->]". - unfold NatOpLSCtx. - iAssert ((NATOP (do_natop op) (IT_of_V β1) (IT_of_V β2)) ≡ Ret (do_natop op n1 n2))%I with "[Hn1 Hn2]" as "Hr". - { iRewrite "Hn1". simpl. - iRewrite "Hn2". simpl. + iIntros "#H". + iModIntro. + iIntros (ss γ) "#Hss". + pose (env := ss). fold env. + pose (f := (ir_unf rs α env)). + iAssert (interp_rec rs α env ≡ 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 _. simpl. + iSplit. + { Transparent IT_of_V. done. } + iModIntro. + iLöb as "IH". iSimpl. + iIntros (αv v) "#Hw". + rewrite APP_APP'_ITV. + rewrite APP_Fun. + rewrite laterO_map_Next. + rewrite -Tick_eq. + iIntros (κ K) "#HK". + iIntros (σ) "Hs". + rewrite hom_tick. + iApply wp_tick. + iNext. + unfold f. + Opaque extend_scope. + Opaque IT_of_V. + simpl. + pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V αv))). + pose (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)%bind))%bind : inc (inc S) [⇒] ∅). + iSpecialize ("H" $! ss' γ' with "[]"); last first. + - iSpecialize ("H" $! κ K with "HK"). + unfold ss'. + iSpecialize ("H" $! σ with "Hs"). + iApply (wp_wand with "[$H] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 1 m), m'), v'', σ''. iFrame "H". iPureIntro. - by rewrite NATOP_Ret. } - iApply (logrel_step_pure (Val (Lit (do_natop op n1 n2)))). - { intro. apply (Ectx_step' []). constructor. - destruct op; simpl; eauto. } - iRewrite "Hr". - iApply (logrel_of_val (RetV $ do_natop op n1 n2)). - iExists _. iSplit; eauto. + eapply (prim_steps_app (1, 0) (m, m')); eauto. + term_simpl. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + subst γ'. + rewrite -!bind_bind_comp'. + econstructor. + - Transparent extend_scope. + iIntros (x'); destruct x' as [| [| x']]. + + term_simpl. + iModIntro. + by iApply logrel_of_val. + + term_simpl. + iModIntro. + iRewrite "Hf". + iIntros (κ' K') "#HK'". + iApply "HK'". + simpl. + unfold logrel_arr. + _iExists (Next (ir_unf rs α env)). + iSplit; first done. + iModIntro. + iApply "IH". + + iModIntro. + subst γ'. + term_simpl. + iApply "Hss". + Qed. + + Program Definition IFSCtx_HOM α β : HOM := exist _ (λne x, IFSCtx α β x) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition HOM_compose (f g : HOM) : HOM := exist _ (`f ◎ `g) _. + Next Obligation. + intros f g; simpl. + apply _. + Qed. + + Lemma compat_if {S : Set} (Γ : S -> ty) (e0 e1 e2 : expr S) α0 α1 α2 τ : + ⊢ logrel_valid Γ e0 α0 Tnat -∗ + logrel_valid Γ e1 α1 τ -∗ + logrel_valid Γ e2 α2 τ -∗ + logrel_valid Γ (If e0 e1 e2) (interp_if rs α0 α1 α2) τ. + Proof. + iIntros "#H0 #H1 #H2". + iModIntro. + iIntros (ss γ) "#Hss". + simpl. + pose (κ' := (IFSCtx_HOM (α1 ss) (α2 ss))). + assert ((IF (α0 ss) (α1 ss) (α2 ss)) = ((`κ') (α0 ss))) as ->. + { reflexivity. } + term_simpl. + iIntros (κ K) "#HK". + assert ((`κ) ((IFSCtx (α1 ss) (α2 ss)) (α0 ss)) = ((`κ) ◎ (`κ')) (α0 ss)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + assert (fill K (if bind γ e0 then bind γ e1 else bind γ e2)%syn = fill (ectx_compose K (IfK EmptyK (bind γ e1) (bind γ e2))) (bind γ e0)) as ->. + { rewrite -fill_comp. + reflexivity. + } + iApply (logrel_bind with "[H0] [H1 H2]"). + - by iApply "H0". + - iIntros (βv v). iModIntro. iIntros "#HV". + term_simpl. + unfold logrel_nat. + iDestruct "HV" as "(%n & #Hn & ->)". + iRewrite "Hn". + destruct (decide (0 < n)). + + rewrite -fill_comp. + simpl. + unfold IFSCtx. + rewrite IF_True//. + iSpecialize ("H1" with "Hss"). + term_simpl. + iSpecialize ("H1" $! κ K with "HK"). + iIntros (σ) "Hσ". + iSpecialize ("H1" $! σ with "Hσ"). + iApply (wp_wand with "[$H1] []"). + iIntros (v) "(%m & %w & %σ' & %Hstep & H & G)". + iModIntro. + destruct m as [m m']. + iExists (m, m'), w, σ'. iFrame "H G". + iPureIntro. + eapply (prim_steps_app (0, 0) (m, m')); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + apply IfTrueS; done. + + rewrite -fill_comp. + simpl. + unfold IFSCtx. + rewrite IF_False//; last lia. + iSpecialize ("H2" with "Hss"). + term_simpl. + iSpecialize ("H2" $! κ K with "HK"). + iIntros (σ) "Hσ". + iSpecialize ("H2" $! σ with "Hσ"). + iApply (wp_wand with "[$H2] []"). + iIntros (v) "(%m & %w & %σ' & %Hstep & H & G)". + iModIntro. + destruct m as [m m']. + iExists (m, m'), w, σ'. iFrame "H G". + iPureIntro. + eapply (prim_steps_app (0, 0) (m, m')); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + apply IfFalseS. + lia. Qed. - Lemma fundamental {S} (Γ : tyctx S) τ e : + (* Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : *) + (* ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ *) + (* logrel_valid Γ e2 α2 τ1 -∗ *) + (* logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. *) + (* Proof. *) + (* iIntros "H1 H2". iIntros (ss) "#Hss". *) + (* iSpecialize ("H1" with "Hss"). *) + (* iSpecialize ("H2" with "Hss"). *) + (* pose (s := (subs_of_subs2 ss)). fold s. *) + (* pose (env := its_of_subs2 ss). fold env. *) + (* simp subst_expr. simpl. *) + (* iApply (logrel_bind (AppRSCtx (α1 env)) [AppRCtx (subst_expr e1 s)] with "H2"). *) + (* iIntros (v2 β2) "H2". iSimpl. *) + (* iApply (logrel_bind (AppLSCtx (IT_of_V β2)) [AppLCtx v2] with "H1"). *) + (* iIntros (v1 β1) "H1". simpl. *) + (* iDestruct "H1" as (f) "[Hα H1]". *) + (* simpl. *) + (* unfold AppLSCtx. iRewrite "Hα". (** XXX why doesn't simpl work here? *) *) + (* iApply ("H1" with "H2"). *) + (* Qed. *) + + (* Lemma compat_input {S} Γ : *) + (* ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. *) + (* Proof. *) + (* iIntros (ss) "Hss". *) + (* iIntros (σ) "Hs". *) + (* destruct (update_input σ) as [n σ'] eqn:Hinp. *) + (* iApply (wp_input with "Hs []"); first eauto. *) + (* iNext. iIntros "Hlc Hs". *) + (* iApply wp_val. *) + (* iExists (1,1),(Lit n),σ'. *) + (* iFrame "Hs". iModIntro. iSplit. *) + (* { iPureIntro. *) + (* simp subst_expr. *) + (* apply prim_step_steps. *) + (* apply (Ectx_step' []). *) + (* by constructor. } *) + (* iExists n. eauto. *) + (* Qed. *) + (* Lemma compat_output {S} Γ (e: expr S) α : *) + (* ⊢ logrel_valid Γ e α Tnat -∗ *) + (* logrel_valid Γ (Output e) (interp_output rs α) Tnat. *) + (* Proof. *) + (* iIntros "H1". *) + (* iIntros (ss) "Hss". *) + (* iSpecialize ("H1" with "Hss"). *) + (* pose (s := (subs_of_subs2 ss)). fold s. *) + (* pose (env := its_of_subs2 ss). fold env. *) + (* simp subst_expr. simpl. *) + (* iApply (logrel_bind (get_ret _) [OutputCtx] with "H1"). *) + (* iIntros (v βv). *) + (* iDestruct 1 as (m) "[Hb ->]". *) + (* iRewrite "Hb". simpl. *) + (* iIntros (σ) "Hs". *) + (* rewrite get_ret_ret. *) + (* iApply (wp_output with "Hs []"); first done. *) + (* iNext. iIntros "Hlc Hs". *) + (* iExists (1,1),(Lit 0),_. *) + (* iFrame "Hs". iSplit. *) + (* { iPureIntro. *) + (* apply prim_step_steps. *) + (* apply (Ectx_step' []). *) + (* by constructor. } *) + (* iExists 0. eauto. *) + (* Qed. *) + + (* Lemma compat_natop {S} (Γ : tyctx S) e1 e2 α1 α2 op : *) + (* ⊢ logrel_valid Γ e1 α1 Tnat -∗ *) + (* logrel_valid Γ e2 α2 Tnat -∗ *) + (* logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. *) + (* Proof. *) + (* iIntros "H1 H2". iIntros (ss) "#Hss". *) + (* iSpecialize ("H1" with "Hss"). *) + (* iSpecialize ("H2" with "Hss"). *) + (* pose (s := (subs_of_subs2 ss)). fold s. *) + (* pose (env := its_of_subs2 ss). fold env. *) + (* simp subst_expr. simpl. *) + (* iApply (logrel_bind (NatOpRSCtx (do_natop op) (α1 env)) [NatOpRCtx op (subst_expr e1 s)] with "H2"). *) + (* iIntros (v2 β2) "H2". iSimpl. *) + (* iApply (logrel_bind (NatOpLSCtx (do_natop op) (IT_of_V β2)) [NatOpLCtx op v2] with "H1"). *) + (* iIntros (v1 β1) "H1". simpl. *) + (* iDestruct "H1" as (n1) "[Hn1 ->]". *) + (* iDestruct "H2" as (n2) "[Hn2 ->]". *) + (* unfold NatOpLSCtx. *) + (* iAssert ((NATOP (do_natop op) (IT_of_V β1) (IT_of_V β2)) ≡ Ret (do_natop op n1 n2))%I with "[Hn1 Hn2]" as "Hr". *) + (* { iRewrite "Hn1". simpl. *) + (* iRewrite "Hn2". simpl. *) + (* iPureIntro. *) + (* by rewrite NATOP_Ret. } *) + (* iApply (logrel_step_pure (Val (Lit (do_natop op n1 n2)))). *) + (* { intro. apply (Ectx_step' []). constructor. *) + (* destruct op; simpl; eauto. } *) + (* iRewrite "Hr". *) + (* iApply (logrel_of_val (RetV $ do_natop op n1 n2)). *) + (* iExists _. iSplit; eauto. *) + (* Qed. *) + + (* TODO: boring cases + callcc + throw *) + Lemma fundamental {S : Set} (Γ : S -> ty) τ e : typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ - with fundamental_val {S} (Γ : tyctx S) τ v : + with fundamental_val {S : Set} (Γ : S -> ty) τ v : typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. Proof. - - induction 1; simpl. - + by apply fundamental_val. - + by apply compat_var. - + iApply compat_rec. iApply IHtyped. - + iApply compat_app. - ++ iApply IHtyped1. - ++ iApply IHtyped2. - + iApply compat_natop. - ++ iApply IHtyped1. - ++ iApply IHtyped2. - + iApply compat_if. - ++ iApply IHtyped1. - ++ iApply IHtyped2. - ++ iApply IHtyped3. - + iApply compat_input. - + iApply compat_output. - iApply IHtyped. - - induction 1; simpl. - + iIntros (ss) "Hss". simp subst_expr. simpl. - iApply (logrel_of_val (RetV n)). iExists n. eauto. - + iApply compat_recV. by iApply fundamental. - Qed. + Admitted. + (* - induction 1; simpl. *) + (* + by apply fundamental_val. *) + (* + by apply compat_var. *) + (* + iApply compat_rec. iApply IHtyped. *) + (* + iApply compat_app. *) + (* ++ iApply IHtyped1. *) + (* ++ iApply IHtyped2. *) + (* + iApply compat_natop. *) + (* ++ iApply IHtyped1. *) + (* ++ iApply IHtyped2. *) + (* + iApply compat_if. *) + (* ++ iApply IHtyped1. *) + (* ++ iApply IHtyped2. *) + (* ++ iApply IHtyped3. *) + (* + iApply compat_input. *) + (* + iApply compat_output. *) + (* iApply IHtyped. *) + (* - induction 1; simpl. *) + (* + iIntros (ss) "Hss". simp subst_expr. simpl. *) + (* iApply (logrel_of_val (RetV n)). iExists n. eauto. *) + (* + iApply compat_recV. by iApply fundamental. *) + (* Qed. *) End logrel. Definition κ {S} {E} : ITV E natO → val S := λ x, match x with - | core.RetV n => Lit n - | _ => Lit 0 + | core.RetV n => LitV n + | _ => LitV 0 end. -Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (Lit n : val S). +Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (LitV n : val S). Proof. Transparent RetV. unfold RetV. simpl. done. Opaque RetV. Qed. Definition rs : gReifiers 1 := gReifiers_cons reify_io gReifiers_nil. +Require Import gitrees.gitree.greifiers. + Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (True ⊢ logrel rs Tnat α e)%I) → - ssteps (gReifiers_sReifier rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ Lit n) σ' m. + ssteps (gReifiers_sReifier rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), @@ -423,8 +562,8 @@ Proof. exists m', σ2. revert Hm. by rewrite κ_Ret. } eapply (wp_adequacy 0); eauto. intros Hinv1 Hst1. - pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (Lit n) - ∗ ⌜∃ m σ', prim_steps e σ (Val $ Lit n) σ' m⌝)%I). + pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) + ∗ ⌜∃ m σ', prim_steps e σ (Val $ LitV n) σ' m⌝)%I). assert (NonExpansive Φ). { unfold Φ. intros l a1 a2 Ha. repeat f_equiv. done. } @@ -445,9 +584,9 @@ Proof. iPoseProof (Hlog with "[//]") as "Hlog". iAssert (has_substate σ) with "[Hs]" as "Hs". { unfold has_substate, has_full_state. - assert (of_state rs (IT (gReifiers_ops rs) natO) (σ, ()) ≡ - of_idx rs (IT (gReifiers_ops rs) natO) sR_idx (sR_state σ)) as -> ; last done. - intro j. unfold sR_idx. simpl. + assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ())) ≡ + (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ))) as -> ; last done. + intros j. unfold sR_idx. simpl. unfold of_state, of_idx. destruct decide as [Heq|]; last first. { inv_fin j; first done. @@ -456,6 +595,18 @@ Proof. intros Heq. rewrite (eq_pi _ _ Heq eq_refl)//. } + unshelve epose (idHOM := _ : (HOM rs)). + { exists idfun. apply IT_hom_idfun. } + iSpecialize ("Hlog" $! idHOM EmptyK with "[]"). + { iIntros (βv v); iModIntro. iIntros "Hv". iIntros (σ'') "HS". + iApply wp_val. + iModIntro. + iExists (0, 0), v, σ''. + iSplit; first iPureIntro. + - apply prim_steps_zero. + - by iFrame. + } + simpl. iSpecialize ("Hlog" $! σ with "Hs"). iApply (wp_wand with"Hlog"). iIntros ( βv). iIntros "H". @@ -465,24 +616,25 @@ Proof. iExists l. iSplit; eauto. Qed. +Program Definition ı_scope : @interp_scope (gReifiers_ops rs) natO _ Empty_set := λne (x : ∅), match x with end. -Theorem adequacy (e : expr []) (k : nat) σ σ' n : - typed empC e Tnat → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) (σ,()) (Ret k : IT _ natO) σ' n → - ∃ mm σ', prim_steps e σ (Val $ Lit k) σ' mm. +Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : + typed □ e Tnat → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ,()) (Ret k : IT _ natO) σ' n → + ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. Proof. intros Hty Hst. pose (Σ:=#[invΣ;stateΣ rs natO]). - eapply (logrel_nat_adequacy Σ (interp_expr rs e ())); last eassumption. + eapply (logrel_nat_adequacy Σ (interp_expr rs e ı_scope)); last eassumption. intros ? ?. iPoseProof (fundamental rs) as "H". { apply Hty. } unfold logrel_valid. iIntros "_". - iSpecialize ("H" $! (emp_subs2 rs)). - simp its_of_subs2. - rewrite subs_of_emp_subs2. - rewrite subst_expr_idsub. + unshelve iSpecialize ("H" $! ı_scope _ with "[]"). + { apply ı%bind. } + { iIntros (x); destruct x. } + rewrite ebind_id; first last. + { intros ?; reflexivity. } iApply "H". - unfold subs2_valid. done. Qed. diff --git a/theories/lang_generic.v b/theories/lang_generic.v index be8b2fd..535a89f 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -194,24 +194,21 @@ Section kripke_logrel. eauto with iFrame. Qed. - Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} - {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} : - expr_pred α Ψ ⊢ - (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ - expr_pred (f α) Φ. - Proof. - iIntros "H1 H2". - iIntros (x) "Hx". - iApply wp_bind. - { solve_proper. } - iSpecialize ("H1" with "Hx"). - iApply (wp_wand with "H1"). - iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". - iModIntro. - iApply ("H2" with "Hb Hy"). - Qed. + (* Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : *) + (* expr_pred α Ψ ⊢ *) + (* (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ *) + (* expr_pred (f α) Φ. *) + (* Proof. *) + (* iIntros "H1 H2". *) + (* iIntros (x) "Hx". *) + (* iApply wp_bind. *) + (* { solve_proper. } *) + (* iSpecialize ("H1" with "Hx"). *) + (* iApply (wp_wand with "H1"). *) + (* iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". *) + (* iModIntro. *) + (* iApply ("H2" with "Hb Hy"). *) + (* Qed. *) Lemma expr_pred_frame α Φ : WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. @@ -223,4 +220,4 @@ Section kripke_logrel. Qed. End kripke_logrel. -Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. +(* Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. *) diff --git a/theories/lang_generic_sem.v b/theories/lang_generic_sem.v index 7351d8b..29ab22a 100644 --- a/theories/lang_generic_sem.v +++ b/theories/lang_generic_sem.v @@ -27,9 +27,12 @@ Section interp. Global Instance interp_var_proper {S : Set} (v : S) : Proper ((≡) ==> (≡)) (interp_var v). Proof. apply ne_proper. apply _. Qed. - (* TODO: rewrite in normal-human-being style *) Program Definition extend_scope {S : Set} : interp_scope S -n> IT -n> interp_scope (inc S) - := λne γ μ x, let x' : inc S := x in match x' with | VZ => μ | VS x'' => γ x'' end. + := λne γ μ x, let x' : inc S := x in + match x' with + | VZ => μ + | VS x'' => γ x'' + end. Next Obligation. match goal with | H : context G [(inc S)] |- _ => revert H @@ -46,37 +49,6 @@ Section interp. Program Definition ren_scope {S S'} (δ : S [→] S') (env : interp_scope S') : interp_scope S := λne x, env (δ x). - (* (** scope substituions *) *) - (* Inductive ssubst : Set → Type := *) - (* | emp_ssubst : ssubst ∅ *) - (* | cons_ssubst {S} : ITV → ssubst S → ssubst (inc S) *) - (* . *) - - (* Equations interp_ssubst {S} (ss : ssubst S) : interp_scope S := *) - (* interp_ssubst emp_ssubst := tt; *) - (* interp_ssubst (cons_ssubst αv ss) := (IT_of_V αv, interp_ssubst ss). *) - - (* Equations list_of_ssubst {S} (ss : ssubst S) : list ITV := *) - (* list_of_ssubst emp_ssubst := []; *) - (* list_of_ssubst (cons_ssubst αv ss) := αv::(list_of_ssubst ss). *) - - (* Equations ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : ssubst S1 * ssubst S2 := *) - (* ssubst_split (S1:=[]) αs := (emp_ssubst,αs); *) - (* ssubst_split (S1:=u::_) (cons_ssubst αv αs) := *) - (* (cons_ssubst αv (ssubst_split αs).1, (ssubst_split αs).2). *) - (* Lemma interp_scope_ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : *) - (* interp_scope_split (interp_ssubst αs) ≡ *) - (* (interp_ssubst (ssubst_split αs).1, interp_ssubst (ssubst_split αs).2). *) - (* Proof. *) - (* induction S1 as [|u S1]; simpl. *) - (* - simp ssubst_split. simpl. *) - (* simp interp_ssubst. done. *) - (* - dependent elimination αs as [cons_ssubst αv αs]. *) - (* simp ssubst_split. simpl. *) - (* simp interp_ssubst. repeat f_equiv; eauto; simpl. *) - (* + rewrite IHS1//. *) - (* + rewrite IHS1//. *) - (* Qed. *) End interp. (* Common definitions and lemmas for Kripke logical relations *) @@ -94,43 +66,55 @@ Section kripke_logrel. Notation iProp := (iProp Σ). Context {A:ofe}. (* The type & predicate for the explicit Kripke worlds *) - Variable (P : A → iProp). - Context `{!NonExpansive P}. + Variable (P : A -n> iProp). Implicit Types α β : IT. Implicit Types αv βv : ITV. Implicit Types Φ Ψ : ITV -n> iProp. Program Definition expr_pred (α : IT) (Φ : ITV -n> iProp) : iProp := - (∀ x : A, P x -∗ WP@{rs} α @ s {{ v, ∃ y : A, Φ v ∗ P y }}). - #[export] Instance expr_pred_ne : NonExpansive2 expr_pred. - Proof. solve_proper. Qed. - #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . - Proof. solve_proper. Qed. + (∀ x : A, P x -∗ wp rs α s ⊤ (λne v, ∃ y : A, Φ v ∗ P y)). + Next Obligation. + solve_proper. + Qed. + + (* #[export] Instance expr_pred_ne : NonExpansive2 expr_pred. *) + (* Proof. *) + (* solve_proper_prepare. *) + (* f_equiv. *) + (* intro; simpl. *) + (* f_equiv. *) + (* rewrite clwp_eq. *) + + (* apply clwp_ne'''. *) + (* Qed. *) + (* #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . *) + (* Proof. solve_proper. Qed. *) Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : Φ αv ⊢ expr_pred α Φ. Proof. iIntros "H". iIntros (x) "Hx". iApply wp_val. - eauto with iFrame. + simpl. + iExists x. + by iFrame. Qed. - Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : - expr_pred α Ψ ⊢ - (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ - expr_pred (f α) Φ. - Proof. - iIntros "H1 H2". - iIntros (x) "Hx". - iApply wp_bind. - { solve_proper. } - iSpecialize ("H1" with "Hx"). - iApply (wp_wand with "H1"). - iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". - iModIntro. - iApply ("H2" with "Hb Hy"). - Qed. + (* Lemma expr_pred_bind (f : IT -n> IT) {Hf : IT_hom f} α (Φ Ψ : ITV -n> iProp) : *) + (* expr_pred α Ψ ⊢ *) + (* (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ *) + (* expr_pred (f α) Φ. *) + (* Proof. *) + (* iIntros "H1 H2". *) + (* iIntros (x) "Hx". *) + (* unshelve iApply clwp_bind; first done. *) + (* iSpecialize ("H1" with "Hx"). *) + (* iApply (clwp_wand with "H1"). *) + (* iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". *) + (* simpl. *) + (* iApply ("H2" with "Hb Hy"). *) + (* Qed. *) Lemma expr_pred_frame α Φ : WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. @@ -138,9 +122,12 @@ Section kripke_logrel. iIntros "H". iIntros (x) "Hx". iApply (wp_wand with "H"). - eauto with iFrame. + simpl. + iIntros (v) "Hv". + iExists x. + by iFrame. Qed. End kripke_logrel. -Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. +(* Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. *) diff --git a/theories/program_logic.v b/theories/program_logic.v index c805923..571e703 100644 --- a/theories/program_logic.v +++ b/theories/program_logic.v @@ -12,40 +12,40 @@ Section program_logic. Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - Lemma wp_seq α β s Φ `{!NonExpansive Φ} - (* {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), *) - (* CtxIndep (gReifiers_sReifier rs) *) - (* (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} *) - : - WP@{rs} α @ s {{ _, WP@{rs} β @ s {{ Φ }} }} ⊢ WP@{rs} SEQ α β @ s {{ Φ }}. + Lemma wp_lam (f : IT -n> IT) β s Φ `{!AsVal β} : + ▷ WP@{rs} f β @ s {{ Φ }} ⊢ WP@{rs} Fun (Next f) ⊙ β @ s{{ Φ }}. Proof. iIntros "H". - iApply (wp_bind _ (SEQCtx β)). - iApply (wp_wand with "H"). - iIntros (?) "Hb". unfold SEQCtx. - by rewrite SEQ_Val. + rewrite APP'_Fun_l. + simpl. + rewrite -Tick_eq. + by iApply wp_tick. Qed. - - Lemma wp_let α (f : IT -n> IT) s Φ `{!NonExpansive Φ} - (* {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), *) - (* CtxIndep (gReifiers_sReifier rs) *) - (* (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} *) - : - WP@{rs} α @ s {{ αv, WP@{rs} f (IT_of_V αv) @ s {{ Φ }} }} ⊢ WP@{rs} (LET α f) @ s {{ Φ }}. + + Lemma clwp_seq α β s (Φ : ITV -n> iProp) : + CLWP@{rs} α @ s {{ (constO (CLWP@{rs} β @ s {{ Φ }})) }} ⊢ CLWP@{rs} SEQ α β @ s {{ Φ }}. Proof. iIntros "H". - iApply (wp_bind _ (LETCTX f)). - iApply (wp_wand with "H"). - iIntros (?) "Hb". simpl. - by rewrite LET_Val. - Qed. + iApply (clwp_bind _ (SEQCtx β)). + iApply (clwp_wand with "H"). + iIntros (?) "Hb". unfold SEQCtx. + simpl. + match goal with + | |- context G [ofe_mor_car _ _ (get_val ?a) ?b] => + idtac + end. + simpl. + (* rewrite SEQ_Val. *) + Admitted. - Lemma wp_lam (f : IT -n> IT) β s Φ `{!AsVal β} : - ▷ WP@{rs} f β @ s {{ Φ }} ⊢ WP@{rs} Fun (Next f) ⊙ β @ s{{ Φ }}. + Lemma clwp_let α (f : IT -n> IT) {Hf : IT_hom f} s (Φ : ITV -n> iProp) : + CLWP@{rs} α @ s {{ (λne αv, CLWP@{rs} f (IT_of_V αv) @ s {{ Φ }}) }} ⊢ CLWP@{rs} (LET α f) @ s {{ Φ }}. Proof. - rewrite APP'_Fun_l. - rewrite -Tick_eq/=. iApply wp_tick. - Qed. - + iIntros "H". + iApply (clwp_bind _ (LETCTX f)). + iApply (clwp_wand with "H"). + iIntros (?) "Hb". simpl. + (* by rewrite LET_Val. *) + Admitted. End program_logic. From b9d2fffb32ccbccff4480fbe96c051cdc8da035a Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 29 Nov 2023 01:43:45 +0100 Subject: [PATCH 032/114] a few admits away from adequacy --- theories/input_lang_callcc/interp.v | 45 +-- theories/input_lang_callcc/logrel.v | 520 ++++++++++++++++++++++------ 2 files changed, 438 insertions(+), 127 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 1b49435..d67f184 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -185,20 +185,6 @@ Section weakestpre. iModIntro. done. Qed. - Lemma clwp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : - update_input σ = (n, σ') → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ CLWP@{rs} (k n) @ s {{ Φ }}) -∗ - CLWP@{rs} (INPUT k) @ s {{ Φ }}. - Proof. - intros Hs. iIntros "Hs Ha". - rewrite clwp_eq. - iIntros (K HK Ψ) "Hf". - rewrite hom_vis. - unfold ccompose, compose. - simpl. - Admitted. - Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : update_output n σ = σ' → has_substate σ -∗ @@ -236,27 +222,30 @@ Section weakestpre. Lemma wp_callcc (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} Φ s : has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k (Tau (f (laterO_map k))) @ s {{ Φ }}) -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ WP@{rs} (k (CALLCC f)) @ s {{ Φ }}. Proof. iIntros "Hs Ha". unfold CALLCC. simpl. rewrite hom_vis. - iApply (wp_subreify with "Hs"). + iApply (wp_subreify _ _ _ _ _ _ _ ((later_map k ((f (laterO_map k))))) with "Hs"). { simpl. - do 2 f_equiv; reflexivity. + repeat f_equiv. + - rewrite ofe_iso_21. + f_equiv. + intro; simpl. + f_equiv. + apply ofe_iso_21. + - reflexivity. } { - simpl. + rewrite later_map_Next. reflexivity. - } + } iModIntro. - iIntros "HC HS". - simpl. - unfold ccompose, compose. - simpl. - Admitted. + iApply "Ha". + Qed. End weakestpre. @@ -932,7 +921,7 @@ Section interp. pose proof (@subReifier_reify sz reify_io rs subR IT _ (inl ()) () (Next (interp_ectx K env (Ret n0))) (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr) as H. rewrite <-H; first last. - by rewrite //=H5. - - clear. + - clear. admit. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. @@ -1009,7 +998,7 @@ Section interp. erewrite <-H; last first. - reflexivity. - simpl. - subst k k' fff σ'' fσ f. + subst k k' fff σ'' fσ f. admit. } f_equiv. @@ -1092,7 +1081,7 @@ Section interp. rewrite get_val_ITV. simpl. rewrite get_fun_fun. - simpl. + simpl. change 2 with (Nat.add (Nat.add 1 1) 0). econstructor; last first. { apply ssteps_tick_n. } @@ -1121,7 +1110,7 @@ Section interp. rewrite laterO_map_Next. reflexivity. } - + (* holds (but with extra tick step) *) admit. } diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 0a62bd8..822e38a 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -179,12 +179,38 @@ Section logrel. by iApply ("HK" $! αv v with "[$H1] [$Hs]"). Qed. + Lemma logrel_head_step_pure_ectx {S} n K (κ : HOM) (e' e : expr S) α V : + (∀ σ K, head_step e σ e' σ K (n, 0)) → + ⊢ logrel_expr V (`κ α) (fill K e') -∗ logrel_expr V (`κ α) (fill K e). + Proof. + intros Hpure. + iIntros "H". + iIntros (κ' K') "#HK'". + iIntros (σ) "Hs". + iSpecialize ("H" with "HK'"). + iSpecialize ("H" with "Hs"). + iApply (wp_wand with "H"). + iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". + iExists ((Nat.add n m),m'),v,σ'. iFrame "H2 Hs". + iPureIntro. + eapply (prim_steps_app (n, 0) (m, m')); eauto. + eapply prim_step_steps. + rewrite !fill_comp. + eapply Ectx_step; last apply Hpure; done. + 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 logrel_bind {S} (f : HOM) (K : ectx S) e α τ1 : ⊢ logrel τ1 α e -∗ @@ -192,7 +218,6 @@ Section logrel. obs_ref (`f α) (fill K e). Proof. iIntros "H1 #H2". - iLöb as "IH" forall (α e). iIntros (σ) "Hs". iApply (wp_wand with "[H1 H2 Hs] []"); first iApply ("H1" with "[H2] [$Hs]"). - iIntros (βv v). iModIntro. @@ -228,26 +253,6 @@ Section logrel. iApply "Hss". Qed. - Lemma logrel_head_step_pure_ectx {S} n K (κ : HOM) (e' e : expr S) α V : - (∀ σ K, head_step e σ e' σ K (n, 0)) → - ⊢ logrel_expr V (`κ α) (fill K e') -∗ logrel_expr V (`κ α) (fill K e). - Proof. - intros Hpure. - iIntros "H". - iIntros (κ' K') "#HK'". - iIntros (σ) "Hs". - iSpecialize ("H" with "HK'"). - iSpecialize ("H" with "Hs"). - iApply (wp_wand with "H"). - iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". - iExists ((Nat.add n m),m'),v,σ'. iFrame "H2 Hs". - iPureIntro. - eapply (prim_steps_app (n, 0) (m, m')); eauto. - eapply prim_step_steps. - rewrite !fill_comp. - eapply Ectx_step; last apply Hpure; done. - Qed. - Lemma compat_recV {S : Set} (Γ : S -> ty) (e : expr (inc (inc S))) τ1 τ2 α : ⊢ □ logrel_valid ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) e α τ2 -∗ logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). @@ -328,12 +333,6 @@ Section logrel. apply _. Qed. - Program Definition HOM_compose (f g : HOM) : HOM := exist _ (`f ◎ `g) _. - Next Obligation. - intros f g; simpl. - apply _. - Qed. - Lemma compat_if {S : Set} (Γ : S -> ty) (e0 e1 e2 : expr S) α0 α1 α2 τ : ⊢ logrel_valid Γ e0 α0 Tnat -∗ logrel_valid Γ e1 α1 τ -∗ @@ -407,14 +406,55 @@ Section logrel. lia. Qed. + (* Program Definition AppLSCtx_HOM α : HOM := exist _ (λne x, AppLSCtx x α) _. *) + (* Next Obligation. *) + (* intros; simpl. *) + (* apply _. *) + (* Qed. *) + + (* Program Definition AppRSCtx_HOM α : HOM := exist _ (λne x, AppRSCtx α x) _. *) + (* Next Obligation. *) + (* intros; simpl. *) + (* apply _. *) + (* Qed. *) + (* Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : *) (* ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ *) (* logrel_valid Γ e2 α2 τ1 -∗ *) (* logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. *) (* Proof. *) - (* iIntros "H1 H2". iIntros (ss) "#Hss". *) + (* iIntros "#H1 #H2". *) + (* iIntros (ss). *) + (* iModIntro. *) + (* iIntros (γ). *) + (* iIntros "#Hss". *) (* iSpecialize ("H1" with "Hss"). *) (* iSpecialize ("H2" with "Hss"). *) + (* unfold interp_app. *) + (* simpl. *) + (* assert ((bind γ (App e1 e2))%syn = (fill (AppLK (bind γ e1) EmptyK) (bind γ e2))) as ->. *) + (* { reflexivity. } *) + + (* pose (κ' := (AppLSCtx_HOM (α2 ss))). *) + (* assert ((α1 ss ⊙ (α2 ss)) = ((`κ') (α1 ss))) as ->. *) + (* { simpl; unfold AppLSCtx. reflexivity. } *) + (* iIntros (κ K) "#HK". *) + (* assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α1 ss)) as ->. *) + (* { reflexivity. } *) + (* pose (sss := (HOM_compose κ κ')). *) + (* assert ((`κ ◎ `κ') = (`sss)) as ->. *) + (* { reflexivity. } *) + (* rewrite fill_comp. *) + (* iApply logrel_bind. *) + (* - by iApply "H2". *) + (* - subst sss κ'. *) + (* iIntros (βv v). iModIntro. iIntros "HV". *) + (* unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. *) + (* pose (κ'' := (AppRSCtx_HOM (IT_of_V βv))). *) + (* assert (((`κ) (AppLSCtx (IT_of_V βv) (α2 ss))) = ((`κ'') (α1 ss))) as ->. *) + (* { simpl. *) + (* unfold AppRSCtx, AppLSCtx. *) + (* } *) (* pose (s := (subs_of_subs2 ss)). fold s. *) (* pose (env := its_of_subs2 ss). fold env. *) (* simp subst_expr. simpl. *) @@ -428,24 +468,41 @@ Section logrel. (* iApply ("H1" with "H2"). *) (* Qed. *) - (* Lemma compat_input {S} Γ : *) - (* ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. *) - (* Proof. *) - (* iIntros (ss) "Hss". *) - (* iIntros (σ) "Hs". *) - (* destruct (update_input σ) as [n σ'] eqn:Hinp. *) - (* iApply (wp_input with "Hs []"); first eauto. *) - (* iNext. iIntros "Hlc Hs". *) - (* iApply wp_val. *) - (* iExists (1,1),(Lit n),σ'. *) - (* iFrame "Hs". iModIntro. iSplit. *) - (* { iPureIntro. *) - (* simp subst_expr. *) - (* apply prim_step_steps. *) - (* apply (Ectx_step' []). *) - (* by constructor. } *) - (* iExists n. eauto. *) - (* Qed. *) + Lemma compat_input {S} Γ : + ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. + Proof. + iModIntro. + iIntros (ss γ) "#Hss". + iIntros (κ K) "#HK". + unfold interp_input. + term_simpl. + iIntros (σ) "Hs". + destruct (update_input σ) as [n σ'] eqn:Hinp. + rewrite hom_vis. + iApply (wp_subreify with "Hs"). + - simpl; rewrite Hinp. + rewrite later_map_Next. + rewrite ofe_iso_21. + reflexivity. + - reflexivity. + - iNext. + iIntros "Hlc Hs". + iSpecialize ("HK" $! (RetV n) (LitV n) with "[]"); first by iExists n. + iSpecialize ("HK" $! σ' with "Hs"). + iApply (wp_wand with "[$HK] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + term_simpl. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + constructor. + assumption. + Qed. + (* Lemma compat_output {S} Γ (e: expr S) α : *) (* ⊢ logrel_valid Γ e α Tnat -∗ *) (* logrel_valid Γ (Output e) (interp_output rs α) Tnat. *) @@ -473,66 +530,331 @@ Section logrel. (* iExists 0. eauto. *) (* Qed. *) - (* Lemma compat_natop {S} (Γ : tyctx S) e1 e2 α1 α2 op : *) - (* ⊢ logrel_valid Γ e1 α1 Tnat -∗ *) - (* logrel_valid Γ e2 α2 Tnat -∗ *) - (* logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. *) - (* Proof. *) - (* iIntros "H1 H2". iIntros (ss) "#Hss". *) - (* iSpecialize ("H1" with "Hss"). *) - (* iSpecialize ("H2" with "Hss"). *) - (* pose (s := (subs_of_subs2 ss)). fold s. *) - (* pose (env := its_of_subs2 ss). fold env. *) - (* simp subst_expr. simpl. *) - (* iApply (logrel_bind (NatOpRSCtx (do_natop op) (α1 env)) [NatOpRCtx op (subst_expr e1 s)] with "H2"). *) - (* iIntros (v2 β2) "H2". iSimpl. *) - (* iApply (logrel_bind (NatOpLSCtx (do_natop op) (IT_of_V β2)) [NatOpLCtx op v2] with "H1"). *) - (* iIntros (v1 β1) "H1". simpl. *) - (* iDestruct "H1" as (n1) "[Hn1 ->]". *) - (* iDestruct "H2" as (n2) "[Hn2 ->]". *) - (* unfold NatOpLSCtx. *) - (* iAssert ((NATOP (do_natop op) (IT_of_V β1) (IT_of_V β2)) ≡ Ret (do_natop op n1 n2))%I with "[Hn1 Hn2]" as "Hr". *) - (* { iRewrite "Hn1". simpl. *) - (* iRewrite "Hn2". simpl. *) - (* iPureIntro. *) - (* by rewrite NATOP_Ret. } *) - (* iApply (logrel_step_pure (Val (Lit (do_natop op n1 n2)))). *) - (* { intro. apply (Ectx_step' []). constructor. *) - (* destruct op; simpl; eauto. } *) - (* iRewrite "Hr". *) - (* iApply (logrel_of_val (RetV $ do_natop op n1 n2)). *) - (* iExists _. iSplit; eauto. *) - (* Qed. *) + Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) + (α : @interp_scope F natO _ S -n> IT) (env : @interp_scope F natO _ S) + : HOM := exist _ (interp_natoplk rs op α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) + (α : IT) (env : @interp_scope F natO _ S) + (Hv : AsVal α) + : HOM := exist _ (interp_natoprk rs op (λne env, idfun) (constO α) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. - (* TODO: boring cases + callcc + throw *) + Lemma compat_natop {S : Set} (Γ : S -> ty) e1 e2 α1 α2 op : + ⊢ logrel_valid Γ e1 α1 Tnat -∗ + logrel_valid Γ e2 α2 Tnat -∗ + logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. + Proof. + iIntros "#H1 #H2". iIntros (ss γ). iModIntro. iIntros "#Hss". + iSpecialize ("H1" with "Hss"). + iSpecialize ("H2" with "Hss"). + term_simpl. + pose (κ' := (NatOpLSCtx_HOM op α1 ss)). + assert ((NATOP (do_natop op) (α1 ss) (α2 ss)) = ((`κ') (α2 ss))) as ->. + { reflexivity. } + iIntros (κ K) "#HK". + assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α2 ss)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + assert (fill K (NatOp op (bind γ e1) (bind γ e2))%syn = fill (ectx_compose K (NatOpLK op (bind γ e1) EmptyK)) (bind γ e2)) as ->. + { rewrite -fill_comp. + reflexivity. + } + iApply (logrel_bind with "[H1] [H2]"). + - by iApply "H2". + - iIntros (βv v). iModIntro. iIntros "(%n1 & #HV & ->)". + term_simpl. + subst κ' sss. + unfold NatOpRSCtx. + rewrite -fill_comp. + simpl. + pose (κ' := (NatOpRSCtx_HOM op (IT_of_V βv) ss _)). + assert ((NATOP (do_natop op) (α1 ss) (IT_of_V βv)) = ((`κ') (α1 ss))) as ->. + { reflexivity. } + assert ((`κ) ((`κ') (α1 ss)) = ((`κ) ◎ (`κ')) (α1 ss)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + assert (fill K (NatOp op (bind γ e1) (LitV n1))%syn = fill (ectx_compose K (NatOpRK op EmptyK (LitV n1))) (bind γ e1)) as ->. + { rewrite -fill_comp. + reflexivity. + } + iApply (logrel_bind with "[H1] [H2]"). + + by iApply "H1". + + subst sss κ'. + term_simpl. + iIntros (t r). iModIntro. iIntros "(%n2 & #H & ->)". + simpl. + iAssert ((NATOP (do_natop op) (IT_of_V t) (IT_of_V βv)) ≡ Ret (do_natop op n2 n1))%I with "[HV H]" as "Hr". + { iRewrite "HV". simpl. + iRewrite "H". simpl. + iPureIntro. + by rewrite NATOP_Ret. + } + iRewrite "Hr". + rewrite -fill_comp. + simpl. + rewrite -IT_of_V_Ret. + iSpecialize ("HK" $! (RetV (do_natop op n2 n1)) (LitV (do_natop op n2 n1)) with "[]"). + { + unfold logrel_nat. + by iExists (do_natop op n2 n1). + } + iIntros (σ) "Hs". + iSpecialize ("HK" $! σ with "Hs"). + iApply (wp_wand with "[$HK] []"). + simpl. + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H' & G)". + destruct m as [m m']. + iModIntro. + iExists (m, m'), v'', σ''. iFrame "H' G". + iPureIntro. + eapply (prim_steps_app (0, 0) (m, m')); eauto. + term_simpl. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + constructor. + simpl. + reflexivity. + Qed. + + Program Definition ThrowLSCtx_HOM {S : Set} + (α : @interp_scope F natO _ S -n> IT) + (env : @interp_scope F natO _ S) + : HOM := exist _ ((interp_throwlk rs (λne env, idfun) α env)) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition ThrowRSCtx_HOM + (βv : ITV) + : HOM := exist _ (λne x, (get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) x)) _. + Next Obligation. + solve_proper. + Qed. + Next Obligation. + solve_proper. + Qed. + Next Obligation. + intros; simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite get_fun_tick. + f_equiv. + - rewrite get_fun_vis. + repeat f_equiv. + intro; simpl. + repeat f_equiv. + - rewrite get_fun_err. + reflexivity. + Qed. + + Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β e e' : + ⊢ logrel_valid Γ e α τ -∗ + logrel_valid Γ e' β (Tcont τ) -∗ + logrel_valid Γ (Throw e e') (interp_throw _ α β) τ'. + Proof. + iIntros "#H1 #H2". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + Opaque interp_throw. + term_simpl. + pose (κ' := ThrowLSCtx_HOM β ss). + assert ((interp_throw rs α β ss) = ((`κ') (α ss))) as ->. + { reflexivity. } + assert ((`κ) ((`κ') (α ss)) = ((`κ) ◎ (`κ')) (α ss)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + assert (fill K (Throw (bind γ e) (bind γ e'))%syn = fill (ectx_compose K (ThrowLK EmptyK (bind γ e'))) (bind γ e)) as ->. + { rewrite -fill_comp. + reflexivity. + } + iApply logrel_bind; first by iApply "H1". + iIntros (βv v). iModIntro. iIntros "#Hv". + Transparent interp_throw. + simpl. + rewrite get_val_ITV'. + simpl. + rewrite -!fill_comp. + simpl. + pose (κ'' := ThrowRSCtx_HOM βv). + assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) = ((`κ'') (β ss))) as ->. + { simpl. + cbn. + reflexivity. + admit. + } + assert ((`κ) ((`κ'') (β ss)) = ((`κ) ◎ (`κ'')) (β ss)) as ->. + { reflexivity. } + pose (sss' := (HOM_compose κ κ'')). + assert ((`κ ◎ `κ'') = (`sss')) as ->. + { reflexivity. } + assert (fill K (Throw v (bind γ e'))%syn = fill (ectx_compose K (ThrowRK v EmptyK)) (bind γ e')) as ->. + { rewrite -fill_comp. + reflexivity. + } + iApply logrel_bind; first by iApply "H2". + iIntros (βv' v'). iModIntro. iIntros "#Hv'". + Transparent interp_throw. + simpl. + unfold logrel_cont. + simpl. + iDestruct "Hv'" as "(%f & %F & HEQ & %H & #H)". + iRewrite "HEQ". + rewrite get_fun_fun. + simpl. + rewrite hom_vis. + iIntros (σ) "Hs". + iApply (wp_subreify with "Hs"). + - simpl. + rewrite later_map_Next. + reflexivity. + - reflexivity. + - iNext. + iIntros "Hlc Hs". + rewrite -!fill_comp H. + simpl. + rewrite -Tick_eq. + iApply wp_tick. + iNext. + iSpecialize ("H" $! βv v with "[]"); first done. + iSpecialize ("H" $! σ with "Hs"). + iApply (wp_wand with "[$H] []"). + iIntros (w) "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 2 m), m'), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (2, 0) (m, m')); eauto. + term_simpl. + eapply prim_step_steps. + eapply Throw_step; reflexivity. + Admitted. + + Lemma compat_callcc {S : Set} (Γ : S -> ty) τ α e : + ⊢ logrel_valid (Γ ▹ Tcont τ) e α τ -∗ + logrel_valid Γ (Callcc e) (interp_callcc _ α) τ. + Proof. + iIntros "#H". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + unfold interp_callcc. + Opaque extend_scope. + term_simpl. + iIntros (σ) "Hs". + rewrite hom_vis. + iApply (wp_subreify _ _ _ _ _ _ _ (Next ((`κ) (α (extend_scope ss (λit x : IT, Tick ((`κ) x)))))) with "Hs"). + - simpl. + rewrite ofe_iso_21. + rewrite later_map_Next. + do 2 f_equiv; last reflexivity. + do 5 f_equiv. + apply bi.siProp.internal_eq_soundness. + iApply later_equivI_2. + iNext. + simpl. + iApply internal_eq_pointwise. + iIntros (x). + simpl. + rewrite Tick_eq. + iApply f_equivI. + rewrite ofe_iso_21. + done. + - reflexivity. + - iNext. + iIntros "Hlc Hs". + pose (ss' := (extend_scope ss (λit x : IT, Tick ((`κ) x)))). + pose (γ' := ((mk_subst (Val (ContV K)%syn)) ∘ (γ ↑)%bind)%bind : inc S [⇒] ∅). + iSpecialize ("H" $! ss' γ' with "[HK]"). + { + iIntros (x). + iModIntro. + destruct x as [| x]; term_simpl. + - Transparent extend_scope. + subst ss'; simpl. + pose proof (asval_fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))). + destruct H as [f H]. + rewrite -H. + iIntros (t r) "#H". + simpl. + iApply "H". + unfold logrel_cont. + iExists _, K. + iSplit. + + rewrite H. + done. + + iSplit; first done. + iModIntro. + iApply "HK". + - simpl. + iApply "Hss". + } + iSpecialize ("H" $! κ K with "HK"). + Opaque extend_scope. + term_simpl. + iSpecialize ("H" $! σ with "Hs"). + subst ss' γ'. + iApply (wp_wand with "[$H] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + rewrite -bind_bind_comp' in Hstep. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + term_simpl. + constructor. + Qed. + + (* TODO: boring cases + finish throw + refactor *) Lemma fundamental {S : Set} (Γ : S -> ty) τ e : typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ with fundamental_val {S : Set} (Γ : S -> ty) τ v : typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. Proof. + - induction 1; simpl. + + by apply fundamental_val. + + rewrite -H. + by apply compat_var. + + admit. + + admit. + + iApply compat_if. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + ++ iApply IHtyped3. + + iApply compat_input. + + admit. + + iApply compat_throw. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_callcc. + iApply IHtyped. + - induction 1; simpl. + + iIntros (ss γ). iModIntro. iIntros "#Hss". + term_simpl. + iIntros (κ K) "#HK". + iSpecialize ("HK" $! (RetV n) (LitV n)). + rewrite IT_of_V_Ret. + iApply "HK". + simpl. + unfold logrel_nat. + iExists n; eauto. + + iApply compat_recV. by iApply fundamental. Admitted. - (* - induction 1; simpl. *) - (* + by apply fundamental_val. *) - (* + by apply compat_var. *) - (* + iApply compat_rec. iApply IHtyped. *) - (* + iApply compat_app. *) - (* ++ iApply IHtyped1. *) - (* ++ iApply IHtyped2. *) - (* + iApply compat_natop. *) - (* ++ iApply IHtyped1. *) - (* ++ iApply IHtyped2. *) - (* + iApply compat_if. *) - (* ++ iApply IHtyped1. *) - (* ++ iApply IHtyped2. *) - (* ++ iApply IHtyped3. *) - (* + iApply compat_input. *) - (* + iApply compat_output. *) - (* iApply IHtyped. *) - (* - induction 1; simpl. *) - (* + iIntros (ss) "Hss". simp subst_expr. simpl. *) - (* iApply (logrel_of_val (RetV n)). iExists n. eauto. *) - (* + iApply compat_recV. by iApply fundamental. *) - (* Qed. *) End logrel. From cff35e3772f0580372e6fadad5e4384c3f875e22 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 29 Nov 2023 12:55:25 +0100 Subject: [PATCH 033/114] reifiy tick ok --- theories/input_lang_callcc/interp.v | 135 +++++++++++++--------------- 1 file changed, 62 insertions(+), 73 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index d54b12f..0a1eda0 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -133,12 +133,34 @@ Section constructors. done. Qed. - Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := - λne f, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) + + Program Definition CALLCC_ : ((laterO IT -n> laterO IT) -n> laterO IT) -n> + (laterO IT -n> laterO IT) -n> + IT := + λne f k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) f) - (λne o, (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o). + (k ◎ (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1). Solve All Obligations with solve_proper. + (* Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := *) + (* λne f, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) *) + (* (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) f) *) + (* (λne o, (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o). *) + (* Solve All Obligations with solve_proper. *) + Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := + λne f, CALLCC_ f (idfun). + Solve Obligations with solve_proper. + + + Lemma hom_CALLCC_ k e f `{!IT_hom f} : + f (CALLCC_ e k) ≡ CALLCC_ e (laterO_map (OfeMor f) ◎ k). + Proof. + unfold CALLCC_. + rewrite hom_vis/=. + f_equiv. by intro. + Qed. + + Program Definition THROW : IT -n> (laterO (IT -n> IT)) -n> IT := λne e k, Vis (E:=E) (subEff_opid (inr (inr (inr (inl ()))))) (subEff_ins (F:=ioE) (op:=(inr (inr (inr (inl ()))))) @@ -232,7 +254,7 @@ Section interp. Notation IT := (IT F R). Notation ITV := (ITV F R). - Context {subEff0 : subEff ioE F}. + (* Context {subEff0 : subEff ioE F}. *) (** Interpreting individual operators *) Program Definition interp_input {A} : A -n> IT := λne env, INPUT Ret. @@ -447,13 +469,13 @@ Section interp. end. Solve All Obligations with first [ solve_proper | solve_proper_please ]. - Open Scope syn_scope. + (* Open Scope syn_scope. *) - Example callcc_ex : expr Empty_set := - NatOp + (# 1) (Callcc (NatOp + (# 1) (Throw (# 2) (Var VZ)))). - Eval cbn in callcc_ex. - Eval cbn in interp_expr callcc_ex - (λne (x : leibnizO Empty_set), match x with end). + (* Example callcc_ex : expr Empty_set := *) + (* NatOp + (# 1) (Callcc (NatOp + (# 1) (Throw (# 2) (Var VZ)))). *) + (* Eval cbn in callcc_ex. *) + (* Eval cbn in interp_expr callcc_ex *) + (* (λne (x : leibnizO Empty_set), match x with end). *) Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) : AsVal (interp_val v D). @@ -860,7 +882,7 @@ Section interp. - apply _. Qed. - Opaque INPUT OUTPUT_ CALLCC THROW. + Opaque INPUT OUTPUT_ CALLCC CALLCC_ THROW. Opaque extend_scope. Opaque Ret. @@ -879,15 +901,8 @@ Section interp. - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). { repeat f_equiv; eauto. - rewrite hom_vis. - Transparent INPUT. - unfold INPUT. - simpl. - f_equiv. - intro; simpl. - rewrite laterO_map_Next. - simpl. - reflexivity. + rewrite hom_INPUT. + do 2 f_equiv. by intro. } rewrite reify_vis_eq //; last first. { @@ -895,10 +910,9 @@ Section interp. simpl in H. simpl. erewrite <-H; last first. - - rewrite H5. - reflexivity. - - (* holds *) - admit. + - rewrite H5. reflexivity. + - f_equiv; last done. + intros ???. by rewrite /prod_map H0. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. @@ -911,27 +925,17 @@ Section interp. trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). { do 2 f_equiv; eauto. - rewrite hom_vis. - Transparent OUTPUT. - unfold OUTPUT. - Transparent OUTPUT_. - unfold OUTPUT_. - simpl. - f_equiv. - intro; simpl. - rewrite laterO_map_Next. - simpl. - reflexivity. + by rewrite hom_OUTPUT_. } rewrite reify_vis_eq //; last first. { epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inl ())) n0 (Next (interp_ectx K env ((Ret 0)))) (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. simpl in H. simpl. - erewrite <-H; last first. - - reflexivity. - - (* holds *) - admit. + erewrite <-H; last reflexivity. + f_equiv. + + intros ???. by rewrite /prod_map H0. + + do 2 f_equiv. by intro. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. @@ -939,55 +943,40 @@ Section interp. - match goal with | |- context G [ofe_mor_car _ _ (CALLCC) ?g] => set (f := g) end. + match goal with + | |- context G [(?s, _)] => set (gσ := s) end. Transparent CALLCC. unfold CALLCC. simpl. - rewrite interp_comp. - rewrite interp_expr_subst. - match goal with - | |- context G [Vis _ _ ?q] => set (k := q) - end. - match goal with - | |- context G [(ofe_mor_car _ _ (@ofe_iso_2 _ _ ?s)) ?s'] => set (fσ := s); set (σ'' := s') - end. - pose (@subEff_ins ioE F subEff0 (inr (inr (inl ()))) IT _) as k'. - simpl in k'. - pose (fff := k' f). - trans (reify (gReifiers_sReifier rs) - (Vis (subEff_opid (inr (inr (inl ())))) - fff - (laterO_map (interp_ectx K env) ◎ k)) - ((fσ ^-1) σ'')). + set (subEff1 := @subReifier_subEff sz reify_io rs subR). + trans (reify (gReifiers_sReifier rs) (CALLCC_ f (laterO_map (interp_ectx K env))) gσ). { do 2 f_equiv. - rewrite hom_vis. - unfold fff, k. - do 3 f_equiv. - intro; simpl. - reflexivity. + rewrite hom_CALLCC_. + f_equiv. by intro. } - rewrite reify_vis_eq //; last first. + rewrite reify_vis_eq//; last first. { - epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inr (inl ()))) f _ (laterO_map (interp_ectx K env)) σ' σ' σr) as H. - simpl in H. simpl. - erewrite <-H; last first. - - reflexivity. - - simpl. - subst k k' fff σ'' fσ f. - admit. + epose proof (@subReifier_reify sz reify_io rs subR IT _ + (inr (inr (inl ()))) f _ + (laterO_map (interp_ectx K env)) σ' σ' σr) as H. + simpl in H. + erewrite <-H; last reflexivity. + f_equiv; last done. + intros ???. by rewrite /prod_map H0. } + rewrite interp_comp. + rewrite interp_expr_subst. f_equiv. rewrite Tick_eq. f_equiv. rewrite laterO_map_Next. do 3 f_equiv. Transparent extend_scope. - intros [| x]; term_simpl. - + (* holds *) - admit. - + reflexivity. - Admitted. + intros [| x]; term_simpl; last reflexivity. + do 2 f_equiv. by intro. + Qed. Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : prim_step e1 σ1 e2 σ2 (n,m) → From 52643d6a9dd7d5700db16e790117d8f16c03a53e Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 29 Nov 2023 13:51:50 +0100 Subject: [PATCH 034/114] soundness last clause --- theories/input_lang_callcc/interp.v | 34 ++++++++++++++++------------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 40f0f2f..8288bc9 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -281,7 +281,6 @@ Section interp. Notation IT := (IT F R). Notation ITV := (ITV F R). - (* Context {subEff0 : subEff ioE F}. *) (** Interpreting individual operators *) Program Definition interp_input {A} : A -n> IT := λne env, INPUT Ret. @@ -938,8 +937,8 @@ Section interp. simpl. erewrite <-H; last first. - rewrite H5. reflexivity. - - f_equiv; last done. - intros ???. by rewrite /prod_map H0. + - f_equiv. + solve_proper. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. @@ -1094,19 +1093,24 @@ Section interp. destruct ((subEff_outs ^-1) x). } rewrite reify_vis_eq; first (rewrite Tick_eq; reflexivity). - assert (laterO_ap (Next f') (Next (interp_val v env)) - ≡ - (Next (Tau (Next ((interp_ectx K' env) (interp_val v env)))))). - { - simpl. - rewrite laterO_map_Next. - reflexivity. - } - - (* holds (but with extra tick step) *) - admit. + simpl. + match goal with + | |- context G [(_, _, ?a)] => set (κ := a) + end. + epose proof (@subReifier_reify sz reify_io rs subR IT _ + (inr (inr (inr (inl ())))) (Next (interp_val v env), Next f') + (Next (Tau (Next ((interp_ectx K' env) (interp_val v env))))) + (Empty_setO_rec _) σ2 σ2 σr) as H'. + subst κ. + simpl in H'. + erewrite <-H'; last reflexivity. + rewrite /prod_map. + f_equiv; first solve_proper. + do 2 f_equiv; first reflexivity. + intro; simpl. + f_equiv. } - Admitted. + Qed. End interp. #[global] Opaque INPUT OUTPUT_ CALLCC THROW. From 302c6c2f62a449e07fd8c49ee3e92e18e3dfbe64 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 29 Nov 2023 14:35:00 +0100 Subject: [PATCH 035/114] typo --- theories/input_lang_callcc/interp.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 8288bc9..415c0c8 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -937,7 +937,7 @@ Section interp. simpl. erewrite <-H; last first. - rewrite H5. reflexivity. - - f_equiv. + - f_equiv; solve_proper. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. From d8c00323adbbb5b1b72d6f99c3f12206ec758ef9 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 29 Nov 2023 14:40:47 +0100 Subject: [PATCH 036/114] adequacy, output clause --- theories/input_lang_callcc/logrel.v | 272 ++++++++++++++++------------ 1 file changed, 161 insertions(+), 111 deletions(-) diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 822e38a..f751e4e 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -406,68 +406,6 @@ Section logrel. lia. Qed. - (* Program Definition AppLSCtx_HOM α : HOM := exist _ (λne x, AppLSCtx x α) _. *) - (* Next Obligation. *) - (* intros; simpl. *) - (* apply _. *) - (* Qed. *) - - (* Program Definition AppRSCtx_HOM α : HOM := exist _ (λne x, AppRSCtx α x) _. *) - (* Next Obligation. *) - (* intros; simpl. *) - (* apply _. *) - (* Qed. *) - - (* Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : *) - (* ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ *) - (* logrel_valid Γ e2 α2 τ1 -∗ *) - (* logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. *) - (* Proof. *) - (* iIntros "#H1 #H2". *) - (* iIntros (ss). *) - (* iModIntro. *) - (* iIntros (γ). *) - (* iIntros "#Hss". *) - (* iSpecialize ("H1" with "Hss"). *) - (* iSpecialize ("H2" with "Hss"). *) - (* unfold interp_app. *) - (* simpl. *) - (* assert ((bind γ (App e1 e2))%syn = (fill (AppLK (bind γ e1) EmptyK) (bind γ e2))) as ->. *) - (* { reflexivity. } *) - - (* pose (κ' := (AppLSCtx_HOM (α2 ss))). *) - (* assert ((α1 ss ⊙ (α2 ss)) = ((`κ') (α1 ss))) as ->. *) - (* { simpl; unfold AppLSCtx. reflexivity. } *) - (* iIntros (κ K) "#HK". *) - (* assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α1 ss)) as ->. *) - (* { reflexivity. } *) - (* pose (sss := (HOM_compose κ κ')). *) - (* assert ((`κ ◎ `κ') = (`sss)) as ->. *) - (* { reflexivity. } *) - (* rewrite fill_comp. *) - (* iApply logrel_bind. *) - (* - by iApply "H2". *) - (* - subst sss κ'. *) - (* iIntros (βv v). iModIntro. iIntros "HV". *) - (* unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. *) - (* pose (κ'' := (AppRSCtx_HOM (IT_of_V βv))). *) - (* assert (((`κ) (AppLSCtx (IT_of_V βv) (α2 ss))) = ((`κ'') (α1 ss))) as ->. *) - (* { simpl. *) - (* unfold AppRSCtx, AppLSCtx. *) - (* } *) - (* pose (s := (subs_of_subs2 ss)). fold s. *) - (* pose (env := its_of_subs2 ss). fold env. *) - (* simp subst_expr. simpl. *) - (* iApply (logrel_bind (AppRSCtx (α1 env)) [AppRCtx (subst_expr e1 s)] with "H2"). *) - (* iIntros (v2 β2) "H2". iSimpl. *) - (* iApply (logrel_bind (AppLSCtx (IT_of_V β2)) [AppLCtx v2] with "H1"). *) - (* iIntros (v1 β1) "H1". simpl. *) - (* iDestruct "H1" as (f) "[Hα H1]". *) - (* simpl. *) - (* unfold AppLSCtx. iRewrite "Hα". (** XXX why doesn't simpl work here? *) *) - (* iApply ("H1" with "H2"). *) - (* Qed. *) - Lemma compat_input {S} Γ : ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. Proof. @@ -503,33 +441,6 @@ Section logrel. assumption. Qed. - (* Lemma compat_output {S} Γ (e: expr S) α : *) - (* ⊢ logrel_valid Γ e α Tnat -∗ *) - (* logrel_valid Γ (Output e) (interp_output rs α) Tnat. *) - (* Proof. *) - (* iIntros "H1". *) - (* iIntros (ss) "Hss". *) - (* iSpecialize ("H1" with "Hss"). *) - (* pose (s := (subs_of_subs2 ss)). fold s. *) - (* pose (env := its_of_subs2 ss). fold env. *) - (* simp subst_expr. simpl. *) - (* iApply (logrel_bind (get_ret _) [OutputCtx] with "H1"). *) - (* iIntros (v βv). *) - (* iDestruct 1 as (m) "[Hb ->]". *) - (* iRewrite "Hb". simpl. *) - (* iIntros (σ) "Hs". *) - (* rewrite get_ret_ret. *) - (* iApply (wp_output with "Hs []"); first done. *) - (* iNext. iIntros "Hlc Hs". *) - (* iExists (1,1),(Lit 0),_. *) - (* iFrame "Hs". iSplit. *) - (* { iPureIntro. *) - (* apply prim_step_steps. *) - (* apply (Ectx_step' []). *) - (* by constructor. } *) - (* iExists 0. eauto. *) - (* Qed. *) - Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) (α : @interp_scope F natO _ S -n> IT) (env : @interp_scope F natO _ S) : HOM := exist _ (interp_natoplk rs op α (λne env, idfun) env) _. @@ -637,28 +548,41 @@ Section logrel. apply _. Qed. - Program Definition ThrowRSCtx_HOM - (βv : ITV) - : HOM := exist _ (λne x, (get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) x)) _. - Next Obligation. - solve_proper. - Qed. - Next Obligation. - solve_proper. - Qed. + Program Definition ThrowRSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F natO _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_throwrk rs (constO β) (λne env, idfun) env) _. Next Obligation. - intros; simpl. + intros; simpl. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - rewrite get_fun_tick. + - solve_proper_prepare. + destruct Hv as [? <-]. + rewrite ->2 get_val_ITV. + simpl. + by f_equiv. + - destruct Hv as [? <-]. + rewrite ->2 get_val_ITV. + simpl. + rewrite get_fun_tick. f_equiv. - - rewrite get_fun_vis. + - destruct Hv as [x Hv]. + rewrite <- Hv. + rewrite -> get_val_ITV. + simpl. + rewrite get_fun_vis. repeat f_equiv. intro; simpl. - repeat f_equiv. - - rewrite get_fun_err. + rewrite <- Hv. + rewrite -> get_val_ITV. + simpl. + f_equiv. + - destruct Hv as [? <-]. + rewrite get_val_ITV. + simpl. + rewrite get_fun_err. reflexivity. Qed. - + Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β e e' : ⊢ logrel_valid Γ e α τ -∗ logrel_valid Γ e' β (Tcont τ) -∗ @@ -689,11 +613,10 @@ Section logrel. simpl. rewrite -!fill_comp. simpl. - pose (κ'' := ThrowRSCtx_HOM βv). + pose (κ'' := @ThrowRSCtx_HOM S (IT_of_V βv) ss _). + (* TODO: some typeclasses bs *) assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) = ((`κ'') (β ss))) as ->. - { simpl. - cbn. - reflexivity. + { admit. } assert ((`κ) ((`κ'') (β ss)) = ((`κ) ◎ (`κ'')) (β ss)) as ->. @@ -712,6 +635,8 @@ Section logrel. unfold logrel_cont. simpl. iDestruct "Hv'" as "(%f & %F & HEQ & %H & #H)". + rewrite get_val_ITV. + simpl. iRewrite "HEQ". rewrite get_fun_fun. simpl. @@ -820,6 +745,128 @@ Section logrel. constructor. Qed. + Program Definition OutputSCtx_HOM {S : Set} + (env : @interp_scope F natO _ S) + : HOM := exist _ ((interp_outputk rs (λne env, idfun) env)) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Lemma compat_output {S} Γ (e: expr S) α : + ⊢ logrel_valid Γ e α Tnat -∗ + logrel_valid Γ (Output e) (interp_output rs α) Tnat. + Proof. + iIntros "#H". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + term_simpl. + pose (κ' := OutputSCtx_HOM ss). + assert ((get_ret OUTPUT (α ss)) = ((`κ') (α ss))) as ->. + { reflexivity. } + assert ((`κ) ((`κ') (α ss)) = ((`κ) ◎ (`κ')) (α ss)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + assert (fill K (Output (bind γ e))%syn = fill (ectx_compose K (OutputK EmptyK)) (bind γ e)) as ->. + { rewrite -fill_comp. + reflexivity. + } + iApply logrel_bind; first by iApply "H". + iIntros (βv v). iModIntro. iIntros "#Hv". + iDestruct "Hv" as (n) "[Hb ->]". + iRewrite "Hb". simpl. + iIntros (σ) "Hs". + rewrite get_ret_ret. + rewrite hom_vis. + iApply (wp_subreify with "Hs"). + - simpl. + rewrite later_map_Next. + reflexivity. + - reflexivity. + - iNext. + iIntros "Hlc Hs". + iSpecialize ("HK" $! (RetV 0) (LitV 0) with "[]"); first by iExists 0. + iSpecialize ("HK" $! (update_output n σ) with "Hs"). + iApply (wp_wand with "[$HK] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H')". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H'". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + term_simpl. + eapply prim_step_steps. + rewrite -fill_comp. + simpl. + eapply Ectx_step; [reflexivity | reflexivity |]. + constructor. + reflexivity. + Qed. + + (* Program Definition AppLSCtx_HOM α : HOM := exist _ (λne x, AppLSCtx x α) _. *) + (* Next Obligation. *) + (* intros; simpl. *) + (* apply _. *) + (* Qed. *) + + (* Program Definition AppRSCtx_HOM α : HOM := exist _ (λne x, AppRSCtx α x) _. *) + (* Next Obligation. *) + (* intros; simpl. *) + (* apply _. *) + (* Qed. *) + + (* Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : *) + (* ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ *) + (* logrel_valid Γ e2 α2 τ1 -∗ *) + (* logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. *) + (* Proof. *) + (* iIntros "#H1 #H2". *) + (* iIntros (ss). *) + (* iModIntro. *) + (* iIntros (γ). *) + (* iIntros "#Hss". *) + (* iSpecialize ("H1" with "Hss"). *) + (* iSpecialize ("H2" with "Hss"). *) + (* unfold interp_app. *) + (* simpl. *) + (* assert ((bind γ (App e1 e2))%syn = (fill (AppLK (bind γ e1) EmptyK) (bind γ e2))) as ->. *) + (* { reflexivity. } *) + + (* pose (κ' := (AppLSCtx_HOM (α2 ss))). *) + (* assert ((α1 ss ⊙ (α2 ss)) = ((`κ') (α1 ss))) as ->. *) + (* { simpl; unfold AppLSCtx. reflexivity. } *) + (* iIntros (κ K) "#HK". *) + (* assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α1 ss)) as ->. *) + (* { reflexivity. } *) + (* pose (sss := (HOM_compose κ κ')). *) + (* assert ((`κ ◎ `κ') = (`sss)) as ->. *) + (* { reflexivity. } *) + (* rewrite fill_comp. *) + (* iApply logrel_bind. *) + (* - by iApply "H2". *) + (* - subst sss κ'. *) + (* iIntros (βv v). iModIntro. iIntros "HV". *) + (* unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. *) + (* pose (κ'' := (AppRSCtx_HOM (IT_of_V βv))). *) + (* assert (((`κ) (AppLSCtx (IT_of_V βv) (α2 ss))) = ((`κ'') (α1 ss))) as ->. *) + (* { simpl. *) + (* unfold AppRSCtx, AppLSCtx. *) + (* } *) + (* pose (s := (subs_of_subs2 ss)). fold s. *) + (* pose (env := its_of_subs2 ss). fold env. *) + (* simp subst_expr. simpl. *) + (* iApply (logrel_bind (AppRSCtx (α1 env)) [AppRCtx (subst_expr e1 s)] with "H2"). *) + (* iIntros (v2 β2) "H2". iSimpl. *) + (* iApply (logrel_bind (AppLSCtx (IT_of_V β2)) [AppLCtx v2] with "H1"). *) + (* iIntros (v1 β1) "H1". simpl. *) + (* iDestruct "H1" as (f) "[Hα H1]". *) + (* simpl. *) + (* unfold AppLSCtx. iRewrite "Hα". (** XXX why doesn't simpl work here? *) *) + (* iApply ("H1" with "H2"). *) + (* Qed. *) + (* TODO: boring cases + finish throw + refactor *) Lemma fundamental {S : Set} (Γ : S -> ty) τ e : typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ @@ -831,13 +878,16 @@ Section logrel. + rewrite -H. by apply compat_var. + admit. - + admit. + + iApply compat_natop. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + iApply compat_if. ++ iApply IHtyped1. ++ iApply IHtyped2. ++ iApply IHtyped3. + iApply compat_input. - + admit. + + iApply compat_output. + iApply IHtyped. + iApply compat_throw. ++ iApply IHtyped1. ++ iApply IHtyped2. @@ -942,7 +992,7 @@ Program Definition ı_scope : @interp_scope (gReifiers_ops rs) natO _ Empty_set Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : typed □ e Tnat → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ,()) (Ret k : IT _ natO) σ' n → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. Proof. intros Hty Hst. From d5f30f547393e2d862dbd5a8f6c0eeb127993151 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 29 Nov 2023 14:59:32 +0100 Subject: [PATCH 037/114] lang fix ectx --- theories/input_lang_callcc/lang.v | 32 +++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index 07ee8a8..1315f94 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -30,8 +30,8 @@ with ectx {X : Set} := | EmptyK : ectx | OutputK (K : ectx) : ectx | IfK (K : ectx) (e₁ : expr) (e₂ : expr) : ectx -| AppLK (e : expr) (K : ectx) : ectx -| AppRK (K : ectx) (v : val) : ectx +| AppLK (K : ectx) (v : val) : ectx +| AppRK (e : expr) (K : ectx) : ectx | NatOpLK (op : nat_op) (e : expr) (K : ectx) : ectx | NatOpRK (op : nat_op) (K : ectx) (v : val) : ectx | ThrowLK (K : ectx) (e : expr) : ectx @@ -50,8 +50,8 @@ Delimit Scope ectx_scope with ectx. Coercion Val : val >-> expr. Coercion App : expr >-> Funclass. -Coercion AppLK : expr >-> Funclass. -Coercion AppRK : ectx >-> Funclass. +Coercion AppLK : ectx >-> Funclass. +Coercion AppRK : expr >-> Funclass. Notation "+" := (Add) : syn_scope. Notation "-" := (Sub) : syn_scope. @@ -97,8 +97,8 @@ Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := | EmptyK => e | OutputK K => Output (fill K e) | IfK K e₁ e₂ => If (fill K e) e₁ e₂ - | AppLK e' K => App e' (fill K e) - | AppRK K v => App (fill K e) (Val v) + | AppLK K v => App (fill K e) (Val v) + | AppRK e' K => App e' (fill K e) | NatOpLK op e' K => NatOp op e' (fill K e) | NatOpRK op K v => NatOp op (fill K e) (Val v) | ThrowLK K e' => Throw (fill K e) e' @@ -132,8 +132,8 @@ with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := | EmptyK => EmptyK | OutputK K => OutputK (kmap f K) | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) - | AppLK e K => AppLK (emap f e) (kmap f K) - | AppRK K v => AppRK (kmap f K) (vmap f v) + | AppLK K v => AppLK (kmap f K) (vmap f v) + | AppRK e K => AppRK (emap f e) (kmap f K) | NatOpLK op e K => NatOpLK op (emap f e) (kmap f K) | NatOpRK op K v => NatOpRK op (kmap f K) (vmap f v) | ThrowLK K e => ThrowLK (kmap f K) (emap f e) @@ -149,8 +149,8 @@ Proof. revert f. induction K as [| ?? IH | ?? IH - | ??? IH | ?? IH + | ??? IH | ???? IH | ??? IH | ?? IH @@ -183,8 +183,8 @@ with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := | EmptyK => EmptyK | OutputK K => OutputK (kbind f K) | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) - | AppLK e K => AppLK (ebind f e) (kbind f K) - | AppRK K v => AppRK (kbind f K) (vbind f v) + | AppLK K v => AppLK (kbind f K) (vbind f v) + | AppRK e K => AppRK (ebind f e) (kbind f K) | NatOpLK op e K => NatOpLK op (ebind f e) (kbind f K) | NatOpRK op K v => NatOpRK op (kbind f K) (vbind f v) | ThrowLK K e => ThrowLK (kbind f K) (ebind f e) @@ -405,8 +405,8 @@ Fixpoint ectx_compose {S} (K1 K2 : ectx S) : ectx S | EmptyK => K2 | OutputK K => OutputK (ectx_compose K K2) | IfK K e₁ e₂ => IfK (ectx_compose K K2) e₁ e₂ - | AppLK e K => AppLK e (ectx_compose K K2) - | AppRK K v => AppRK (ectx_compose K K2) v + | AppLK K v => AppLK (ectx_compose K K2) v + | AppRK e K => AppRK e (ectx_compose K K2) | NatOpLK op e K => NatOpLK op e (ectx_compose K K2) | NatOpRK op K v => NatOpRK op (ectx_compose K K2) v | ThrowLK K e => ThrowLK (ectx_compose K K2) e @@ -419,8 +419,8 @@ Proof. revert e. induction K1 as [| ?? IH | ?? IH - | ??? IH | ?? IH + | ??? IH | ???? IH | ??? IH | ?? IH @@ -433,8 +433,8 @@ Proof. intros S K. induction K as [| ?? IH | ?? IH - | ??? IH | ?? IH + | ??? IH | ???? IH | ??? IH | ?? IH @@ -456,8 +456,8 @@ Global Instance fill_inj {S} (K : ectx S) : Inj (=) (=) (fill K). Proof. induction K as [| ?? IH | ?? IH - | ??? IH | ?? IH + | ??? IH | ???? IH | ??? IH | ?? IH From 704f8224e6f4434461d9bb001d51ec51f711275a Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 29 Nov 2023 15:05:35 +0100 Subject: [PATCH 038/114] same for natops --- theories/input_lang_callcc/lang.v | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index 1315f94..bb0fe4f 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -32,8 +32,8 @@ with ectx {X : Set} := | IfK (K : ectx) (e₁ : expr) (e₂ : expr) : ectx | AppLK (K : ectx) (v : val) : ectx | AppRK (e : expr) (K : ectx) : ectx -| NatOpLK (op : nat_op) (e : expr) (K : ectx) : ectx -| NatOpRK (op : nat_op) (K : ectx) (v : val) : ectx +| NatOpRK (op : nat_op) (e : expr) (K : ectx) : ectx +| NatOpLK (op : nat_op) (K : ectx) (v : val) : ectx | ThrowLK (K : ectx) (e : expr) : ectx | ThrowRK (v : val) (K : ectx) : ectx. @@ -66,8 +66,8 @@ Notation "'throw' e₁ e₂" := (Throw e₁ e₂) (at level 60) : syn_scope. Notation "'cont' K" := (ContV K) (at level 60) : syn_scope. Notation "□" := (EmptyK) : ectx_scope. -Notation "'⟨' e₁ op K '⟩ᵣ'" := (NatOpLK op e₁ K) (at level 45, right associativity) : ectx_scope. -Notation "'⟨' K op v₂ '⟩ₗ'" := (NatOpRK op K v₂) (at level 45, right associativity) : ectx_scope. +Notation "'⟨' e₁ op K '⟩ᵣ'" := (NatOpRK op e₁ K) (at level 45, right associativity) : ectx_scope. +Notation "'⟨' K op v₂ '⟩ₗ'" := (NatOpLK op K v₂) (at level 45, right associativity) : ectx_scope. Notation "'if' K 'then' e₂ 'else' e₃" := (IfK K e₂ e₃) : ectx_scope. Notation "'output' K" := (OutputK K) (at level 60) : ectx_scope. Notation "'throwₗ' K e₂" := (ThrowLK K e₂) (at level 60) : ectx_scope. @@ -99,8 +99,8 @@ Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := | IfK K e₁ e₂ => If (fill K e) e₁ e₂ | AppLK K v => App (fill K e) (Val v) | AppRK e' K => App e' (fill K e) - | NatOpLK op e' K => NatOp op e' (fill K e) - | NatOpRK op K v => NatOp op (fill K e) (Val v) + | NatOpRK op e' K => NatOp op e' (fill K e) + | NatOpLK op K v => NatOp op (fill K e) (Val v) | ThrowLK K e' => Throw (fill K e) e' | ThrowRK v K => Throw (Val v) (fill K e) end. @@ -134,8 +134,8 @@ with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) | AppLK K v => AppLK (kmap f K) (vmap f v) | AppRK e K => AppRK (emap f e) (kmap f K) - | NatOpLK op e K => NatOpLK op (emap f e) (kmap f K) - | NatOpRK op K v => NatOpRK op (kmap f K) (vmap f v) + | NatOpRK op e K => NatOpRK op (emap f e) (kmap f K) + | NatOpLK op K v => NatOpLK op (kmap f K) (vmap f v) | ThrowLK K e => ThrowLK (kmap f K) (emap f e) | ThrowRK v K => ThrowRK (vmap f v) (kmap f K) end. @@ -185,8 +185,8 @@ with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) | AppLK K v => AppLK (kbind f K) (vbind f v) | AppRK e K => AppRK (ebind f e) (kbind f K) - | NatOpLK op e K => NatOpLK op (ebind f e) (kbind f K) - | NatOpRK op K v => NatOpRK op (kbind f K) (vbind f v) + | NatOpRK op e K => NatOpRK op (ebind f e) (kbind f K) + | NatOpLK op K v => NatOpLK op (kbind f K) (vbind f v) | ThrowLK K e => ThrowLK (kbind f K) (ebind f e) | ThrowRK v K => ThrowRK (vbind f v) (kbind f K) end. @@ -407,8 +407,8 @@ Fixpoint ectx_compose {S} (K1 K2 : ectx S) : ectx S | IfK K e₁ e₂ => IfK (ectx_compose K K2) e₁ e₂ | AppLK K v => AppLK (ectx_compose K K2) v | AppRK e K => AppRK e (ectx_compose K K2) - | NatOpLK op e K => NatOpLK op e (ectx_compose K K2) - | NatOpRK op K v => NatOpRK op (ectx_compose K K2) v + | NatOpRK op e K => NatOpRK op e (ectx_compose K K2) + | NatOpLK op K v => NatOpLK op (ectx_compose K K2) v | ThrowLK K e => ThrowLK (ectx_compose K K2) e | ThrowRK v K => ThrowRK v (ectx_compose K K2) end. From 99ad4ab6fcd92ef04530b8bd671d04e517955f5f Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 29 Nov 2023 15:09:04 +0100 Subject: [PATCH 039/114] upd soundness --- theories/input_lang_callcc/interp.v | 52 ++++++++++++++++------------- 1 file changed, 29 insertions(+), 23 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 8288bc9..eea3a3f 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -422,22 +422,28 @@ Section interp. by repeat f_equiv. Qed. - Program Definition interp_applk {A} (q : A -n> IT) - (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := - λne env t, interp_app q (λne env, K env t) env. + Program Definition interp_applk {A} + (K : A -n> (IT -n> IT)) + (q : A -n> IT) + : A -n> (IT -n> IT) := + λne env t, interp_app (λne env, K env t) q env. Solve All Obligations with solve_proper. - Program Definition interp_apprk {A} (K : A -n> (IT -n> IT)) - (q : A -n> IT) : A -n> (IT -n> IT) := - λne env t, interp_app (λne env, K env t) q env. + Program Definition interp_apprk {A} + (q : A -n> IT) + (K : A -n> (IT -n> IT)) + : A -n> (IT -n> IT) := + λne env t, interp_app q (λne env, K env t) env. Solve All Obligations with solve_proper. - Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) + Program Definition interp_natoprk {A} (op : nat_op) + (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_natop op q (λne env, K env t) env. Solve All Obligations with solve_proper. - Program Definition interp_natoprk {A} (op : nat_op) (K : A -n> (IT -n> IT)) + Program Definition interp_natoplk {A} (op : nat_op) + (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_natop op (λne env, K env t) q env. Solve All Obligations with solve_proper. @@ -484,10 +490,10 @@ Section interp. with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := match K with | EmptyK => λne env, idfun - | AppLK e1 K => interp_applk (interp_expr e1) (interp_ectx K) - | AppRK K v2 => interp_apprk (interp_ectx K) (interp_val v2) - | NatOpLK op e1 K => interp_natoplk op (interp_expr e1) (interp_ectx K) - | NatOpRK op K v2 => interp_natoprk op (interp_ectx K) (interp_val v2) + | AppRK e1 K => interp_apprk (interp_expr e1) (interp_ectx K) + | AppLK K v2 => interp_applk (interp_ectx K) (interp_val v2) + | NatOpRK op e1 K => interp_natoprk op (interp_expr e1) (interp_ectx K) + | NatOpLK op K v2 => interp_natoplk op (interp_ectx K) (interp_val v2) | IfK K e1 e2 => interp_ifk (interp_ectx K) (interp_expr e1) (interp_expr e2) | OutputK K => interp_outputk (interp_ectx K) | ThrowLK K e => interp_throwlk (interp_ectx K) (interp_expr e) @@ -582,9 +588,9 @@ Section interp. + reflexivity. + repeat f_equiv; by apply interp_ectx_ren. + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_expr_ren | by apply interp_expr_ren]. - + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + repeat f_equiv; last by apply interp_ectx_ren. intros ?; simpl; repeat f_equiv; by apply interp_expr_ren. @@ -684,10 +690,10 @@ Section interp. - destruct e; simpl; intros ?; simpl. + reflexivity. + repeat f_equiv; by apply interp_ectx_subst. - + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. - + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + repeat f_equiv; last by apply interp_ectx_subst. intros ?; simpl; repeat f_equiv; first by apply interp_expr_subst. @@ -737,10 +743,10 @@ Section interp. apply IF_Err. Qed. - #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) + #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) (e : expr S) env : IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (AppLK e K) env). + IT_hom (interp_ectx (AppRK e K) env). Proof. intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - by rewrite !hom_tick. @@ -749,10 +755,10 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) + #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) (v : val S) (env : interp_scope S) : IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (AppRK K v) env). + IT_hom (interp_ectx (AppLK K v) env). Proof. intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. @@ -766,10 +772,10 @@ Section interp. apply APP'_Err_l, interp_val_asval. Qed. - #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) + #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) (e : expr S) op env : IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (NatOpLK op e K) env). + IT_hom (interp_ectx (NatOpRK op e K) env). Proof. intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - by rewrite !hom_tick. @@ -778,10 +784,10 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) + #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) (v : val S) op (env : interp_scope S) : IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (NatOpRK op K v) env). + IT_hom (interp_ectx (NatOpLK op K v) env). Proof. intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - rewrite -NATOP_ITV_Tick_l. do 2 f_equiv. apply hom_tick. From 40ab8476a798d30cd80f2d9c4d727acf48880c5d Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 29 Nov 2023 15:31:25 +0100 Subject: [PATCH 040/114] fl app --- theories/input_lang_callcc/logrel.v | 157 +++++++++++++++------------- 1 file changed, 84 insertions(+), 73 deletions(-) diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index f751e4e..4aaa797 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -441,18 +441,18 @@ Section logrel. assumption. Qed. - Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) + Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) (α : @interp_scope F natO _ S -n> IT) (env : @interp_scope F natO _ S) - : HOM := exist _ (interp_natoplk rs op α (λne env, idfun) env) _. + : HOM := exist _ (interp_natoprk rs op α (λne env, idfun) env) _. Next Obligation. intros; simpl. apply _. Qed. - Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) + Program Definition NatOpLSCtx_HOM {S : Set} (op : nat_op) (α : IT) (env : @interp_scope F natO _ S) (Hv : AsVal α) - : HOM := exist _ (interp_natoprk rs op (λne env, idfun) (constO α) env) _. + : HOM := exist _ (interp_natoplk rs op (λne env, idfun) (constO α) env) _. Next Obligation. intros; simpl. apply _. @@ -467,7 +467,7 @@ Section logrel. iSpecialize ("H1" with "Hss"). iSpecialize ("H2" with "Hss"). term_simpl. - pose (κ' := (NatOpLSCtx_HOM op α1 ss)). + pose (κ' := (NatOpRSCtx_HOM op α1 ss)). assert ((NATOP (do_natop op) (α1 ss) (α2 ss)) = ((`κ') (α2 ss))) as ->. { reflexivity. } iIntros (κ K) "#HK". @@ -476,7 +476,7 @@ Section logrel. pose (sss := (HOM_compose κ κ')). assert ((`κ ◎ `κ') = (`sss)) as ->. { reflexivity. } - assert (fill K (NatOp op (bind γ e1) (bind γ e2))%syn = fill (ectx_compose K (NatOpLK op (bind γ e1) EmptyK)) (bind γ e2)) as ->. + assert (fill K (NatOp op (bind γ e1) (bind γ e2))%syn = fill (ectx_compose K (NatOpRK op (bind γ e1) EmptyK)) (bind γ e2)) as ->. { rewrite -fill_comp. reflexivity. } @@ -485,10 +485,10 @@ Section logrel. - iIntros (βv v). iModIntro. iIntros "(%n1 & #HV & ->)". term_simpl. subst κ' sss. - unfold NatOpRSCtx. + unfold NatOpLSCtx. rewrite -fill_comp. simpl. - pose (κ' := (NatOpRSCtx_HOM op (IT_of_V βv) ss _)). + pose (κ' := (NatOpLSCtx_HOM op (IT_of_V βv) ss _)). assert ((NATOP (do_natop op) (α1 ss) (IT_of_V βv)) = ((`κ') (α1 ss))) as ->. { reflexivity. } assert ((`κ) ((`κ') (α1 ss)) = ((`κ) ◎ (`κ')) (α1 ss)) as ->. @@ -496,7 +496,7 @@ Section logrel. pose (sss := (HOM_compose κ κ')). assert ((`κ ◎ `κ') = (`sss)) as ->. { reflexivity. } - assert (fill K (NatOp op (bind γ e1) (LitV n1))%syn = fill (ectx_compose K (NatOpRK op EmptyK (LitV n1))) (bind γ e1)) as ->. + assert (fill K (NatOp op (bind γ e1) (LitV n1))%syn = fill (ectx_compose K (NatOpLK op EmptyK (LitV n1))) (bind γ e1)) as ->. { rewrite -fill_comp. reflexivity. } @@ -805,69 +805,78 @@ Section logrel. reflexivity. Qed. - (* Program Definition AppLSCtx_HOM α : HOM := exist _ (λne x, AppLSCtx x α) _. *) - (* Next Obligation. *) - (* intros; simpl. *) - (* apply _. *) - (* Qed. *) - - (* Program Definition AppRSCtx_HOM α : HOM := exist _ (λne x, AppRSCtx α x) _. *) - (* Next Obligation. *) - (* intros; simpl. *) - (* apply _. *) - (* Qed. *) - - (* Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : *) - (* ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ *) - (* logrel_valid Γ e2 α2 τ1 -∗ *) - (* logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. *) - (* Proof. *) - (* iIntros "#H1 #H2". *) - (* iIntros (ss). *) - (* iModIntro. *) - (* iIntros (γ). *) - (* iIntros "#Hss". *) - (* iSpecialize ("H1" with "Hss"). *) - (* iSpecialize ("H2" with "Hss"). *) - (* unfold interp_app. *) - (* simpl. *) - (* assert ((bind γ (App e1 e2))%syn = (fill (AppLK (bind γ e1) EmptyK) (bind γ e2))) as ->. *) - (* { reflexivity. } *) - - (* pose (κ' := (AppLSCtx_HOM (α2 ss))). *) - (* assert ((α1 ss ⊙ (α2 ss)) = ((`κ') (α1 ss))) as ->. *) - (* { simpl; unfold AppLSCtx. reflexivity. } *) - (* iIntros (κ K) "#HK". *) - (* assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α1 ss)) as ->. *) - (* { reflexivity. } *) - (* pose (sss := (HOM_compose κ κ')). *) - (* assert ((`κ ◎ `κ') = (`sss)) as ->. *) - (* { reflexivity. } *) - (* rewrite fill_comp. *) - (* iApply logrel_bind. *) - (* - by iApply "H2". *) - (* - subst sss κ'. *) - (* iIntros (βv v). iModIntro. iIntros "HV". *) - (* unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. *) - (* pose (κ'' := (AppRSCtx_HOM (IT_of_V βv))). *) - (* assert (((`κ) (AppLSCtx (IT_of_V βv) (α2 ss))) = ((`κ'') (α1 ss))) as ->. *) - (* { simpl. *) - (* unfold AppRSCtx, AppLSCtx. *) - (* } *) - (* pose (s := (subs_of_subs2 ss)). fold s. *) - (* pose (env := its_of_subs2 ss). fold env. *) - (* simp subst_expr. simpl. *) - (* iApply (logrel_bind (AppRSCtx (α1 env)) [AppRCtx (subst_expr e1 s)] with "H2"). *) - (* iIntros (v2 β2) "H2". iSimpl. *) - (* iApply (logrel_bind (AppLSCtx (IT_of_V β2)) [AppLCtx v2] with "H1"). *) - (* iIntros (v1 β1) "H1". simpl. *) - (* iDestruct "H1" as (f) "[Hα H1]". *) - (* simpl. *) - (* unfold AppLSCtx. iRewrite "Hα". (** XXX why doesn't simpl work here? *) *) - (* iApply ("H1" with "H2"). *) - (* Qed. *) + Program Definition AppRSCtx_HOM {S : Set} + (α : @interp_scope F natO _ S -n> IT) + (env : @interp_scope F natO _ 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 natO _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_applk rs (λne env, idfun) (constO β) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : + ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ + logrel_valid Γ e2 α2 τ1 -∗ + logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. + Proof. + iIntros "#H1 #H2". + iIntros (ss). + iModIntro. + iIntros (γ). + iIntros "#Hss". + iSpecialize ("H1" with "Hss"). + iSpecialize ("H2" with "Hss"). + unfold interp_app. + simpl. + assert ((bind γ (App e1 e2))%syn = (fill (AppRK (bind γ e1) EmptyK) (bind γ e2))) as ->. + { reflexivity. } + pose (κ' := (AppRSCtx_HOM α1 ss)). + assert ((α1 ss ⊙ (α2 ss)) = ((`κ') (α2 ss))) as ->. + { simpl; unfold AppRSCtx. reflexivity. } + iIntros (κ K) "#HK". + assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α2 ss)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + rewrite fill_comp. + iApply logrel_bind; first by iApply "H2". + subst sss κ'. + iIntros (βv v). iModIntro. iIntros "#HV". + unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. + rewrite -fill_comp. + simpl. + assert ((App (bind γ e1) v) = (fill (AppLK EmptyK v) (bind γ e1))) as ->. + { reflexivity. } + pose (κ'' := (AppLSCtx_HOM (IT_of_V βv) ss _)). + assert (((`κ) (α1 ss ⊙ (IT_of_V βv))) = (((`κ) ◎ (`κ'')) (α1 ss))) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ'')). + assert ((`κ ◎ `κ'') = (`sss)) as ->. + { reflexivity. } + rewrite fill_comp. + iApply logrel_bind; first by iApply "H1". + iIntros (βv' v'). iModIntro. iIntros "#HV'". + subst sss κ''. + rewrite -fill_comp. + simpl. + unfold logrel_arr. + iDestruct "HV'" as "(%f & #Hf & #HV')". + iRewrite "Hf". + iSpecialize ("HV'" $! βv v with "HV"). + iApply "HV'"; iApply "HK". + Qed. - (* TODO: boring cases + finish throw + refactor *) + (* TODO: finish throw + refactor *) Lemma fundamental {S : Set} (Γ : S -> ty) τ e : typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ with fundamental_val {S : Set} (Γ : S -> ty) τ v : @@ -877,7 +886,9 @@ Section logrel. + by apply fundamental_val. + rewrite -H. by apply compat_var. - + admit. + + iApply compat_app. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + iApply compat_natop. ++ iApply IHtyped1. ++ iApply IHtyped2. @@ -904,7 +915,7 @@ Section logrel. unfold logrel_nat. iExists n; eauto. + iApply compat_recV. by iApply fundamental. - Admitted. + Qed. End logrel. From 0619e89de98d85825805f2048559f09b4608c1cb Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 29 Nov 2023 15:42:52 +0100 Subject: [PATCH 041/114] small cleanup --- _CoqProject | 8 +-- theories/gitree/reductions.v | 116 +++++++++++++++++------------------ theories/gitree/weakestpre.v | 22 +++---- theories/program_logic.v | 48 +++++++-------- 4 files changed, 97 insertions(+), 97 deletions(-) diff --git a/_CoqProject b/_CoqProject index ae3ac71..3a191be 100644 --- a/_CoqProject +++ b/_CoqProject @@ -32,10 +32,10 @@ theories/input_lang_callcc/lang.v theories/input_lang_callcc/interp.v theories/input_lang_callcc/logrel.v -theories/input_lang/lang.v -theories/input_lang/interp.v -theories/input_lang/logpred.v -theories/input_lang/logrel.v +# theories/input_lang/lang.v +# theories/input_lang/interp.v +# theories/input_lang/logpred.v +# theories/input_lang/logrel.v # theories/affine_lang/lang.v # theories/affine_lang/logrel1.v diff --git a/theories/gitree/reductions.v b/theories/gitree/reductions.v index f9fef88..49be3ad 100644 --- a/theories/gitree/reductions.v +++ b/theories/gitree/reductions.v @@ -337,65 +337,65 @@ Section istep. iRewrite -"Ha". iRewrite "Hs". done. Qed. - Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' : - istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. - Proof. - iDestruct 1 as "[[Ha Hs]|H]". - - iRewrite "Ha". iLeft. iSplit; eauto. iPureIntro. apply hom_tick. - - iDestruct "H" as (op i k) "[#Ha Hr]". - pose (f' := OfeMor f). - iRight. iExists op,i,(laterO_map f' ◎ k). - iAssert (f (Vis op i k) ≡ Vis op i (laterO_map f' ◎ k))%I as "Hf". - { iPureIntro. apply hom_vis. } - iRewrite "Ha". iRewrite "Ha" in "Hr". iRewrite "Hf". - iSplit; first done. + (* Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' : *) + (* istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. *) + (* Proof. *) + (* iDestruct 1 as "[[Ha Hs]|H]". *) + (* - iRewrite "Ha". iLeft. iSplit; eauto. iPureIntro. apply hom_tick. *) + (* - iDestruct "H" as (op i k) "[#Ha Hr]". *) + (* pose (f' := OfeMor f). *) + (* iRight. iExists op,i,(laterO_map f' ◎ k). *) + (* iAssert (f (Vis op i k) ≡ Vis op i (laterO_map f' ◎ k))%I as "Hf". *) + (* { iPureIntro. apply hom_vis. } *) + (* iRewrite "Ha". iRewrite "Ha" in "Hr". iRewrite "Hf". *) + (* iSplit; first done. *) - (* iApply (reify_vis_cont with "Hr"). *) - Admitted. + (* (* iApply (reify_vis_cont with "Hr"). *) *) + (* Admitted. *) - Lemma istep_hom_inv α σ β σ' `{!IT_hom f} : - istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ - ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). - Proof. - iIntros "H". - destruct (IT_dont_confuse α) - as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. - - iExFalso. iApply (istep_err σ e β σ'). - iAssert (f α ≡ Err e)%I as "Hf". - { iPureIntro. by rewrite Ha hom_err. } - iRewrite "Hf" in "H". done. - - iLeft. iPureIntro. rewrite Ha IT_to_V_Ret. done. - - iLeft. iPureIntro. rewrite Ha IT_to_V_Fun. done. - - iAssert (α ≡ Tick la)%I as "Ha"; first by eauto. - iAssert (f (Tick la) ≡ Tick (f la))%I as "Hf". - { iPureIntro. rewrite hom_tick. done. } - iRight. iRewrite "Ha". iRewrite "Ha" in "H". - iRewrite "Hf" in "H". rewrite istep_tick. - iDestruct "H" as "[Hb Hs]". iSplit. - { by rewrite IT_to_V_Tau. } - iExists la. iSplit; last eauto. - unfold istep. iLeft. iSplit; eauto. - - iRight. - pose (fi:=OfeMor f). - iAssert (f α ≡ Vis op i (laterO_map fi ◎ k))%I as "Hf". - { iPureIntro. by rewrite Ha hom_vis. } - iRewrite "Hf" in "H". - rewrite {1}/istep. iSimpl in "H". - iDestruct "H" as "[[H _]|H]". - + iExFalso. iApply (IT_tick_vis_ne). - iApply internal_eq_sym. done. - + iDestruct "H" as (op' i' k') "[#Ha Hr]". - iPoseProof (Vis_inj_op' with "Ha") as "<-". - iPoseProof (Vis_inj' with "Ha") as "[Hi Hk]". - (* iPoseProof (reify_input_cont_inv r op i k fi with "Hr") as (α') "[Hr Ha']". *) - (* iAssert (reify r α σ ≡ (σ', Tick α'))%I with "[Hr]" as "Hr". *) - (* { iRewrite -"Hr". iPureIntro. repeat f_equiv. *) - (* apply Ha. } *) - (* iSplit. { iPureIntro. by rewrite Ha IT_to_V_Vis. } *) - (* iExists α'. iFrame "Ha'". *) - (* rewrite /istep. iRight. *) - (* iExists op,i,k. iFrame "Hr". *) - (* iPureIntro. apply Ha. *) - Admitted. + (* Lemma istep_hom_inv α σ β σ' `{!IT_hom f} : *) + (* istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ *) + (* ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). *) + (* Proof. *) + (* iIntros "H". *) + (* destruct (IT_dont_confuse α) *) + (* as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. *) + (* - iExFalso. iApply (istep_err σ e β σ'). *) + (* iAssert (f α ≡ Err e)%I as "Hf". *) + (* { iPureIntro. by rewrite Ha hom_err. } *) + (* iRewrite "Hf" in "H". done. *) + (* - iLeft. iPureIntro. rewrite Ha IT_to_V_Ret. done. *) + (* - iLeft. iPureIntro. rewrite Ha IT_to_V_Fun. done. *) + (* - iAssert (α ≡ Tick la)%I as "Ha"; first by eauto. *) + (* iAssert (f (Tick la) ≡ Tick (f la))%I as "Hf". *) + (* { iPureIntro. rewrite hom_tick. done. } *) + (* iRight. iRewrite "Ha". iRewrite "Ha" in "H". *) + (* iRewrite "Hf" in "H". rewrite istep_tick. *) + (* iDestruct "H" as "[Hb Hs]". iSplit. *) + (* { by rewrite IT_to_V_Tau. } *) + (* iExists la. iSplit; last eauto. *) + (* unfold istep. iLeft. iSplit; eauto. *) + (* - iRight. *) + (* pose (fi:=OfeMor f). *) + (* iAssert (f α ≡ Vis op i (laterO_map fi ◎ k))%I as "Hf". *) + (* { iPureIntro. by rewrite Ha hom_vis. } *) + (* iRewrite "Hf" in "H". *) + (* rewrite {1}/istep. iSimpl in "H". *) + (* iDestruct "H" as "[[H _]|H]". *) + (* + iExFalso. iApply (IT_tick_vis_ne). *) + (* iApply internal_eq_sym. done. *) + (* + iDestruct "H" as (op' i' k') "[#Ha Hr]". *) + (* iPoseProof (Vis_inj_op' with "Ha") as "<-". *) + (* iPoseProof (Vis_inj' with "Ha") as "[Hi Hk]". *) + (* (* iPoseProof (reify_input_cont_inv r op i k fi with "Hr") as (α') "[Hr Ha']". *) *) + (* (* iAssert (reify r α σ ≡ (σ', Tick α'))%I with "[Hr]" as "Hr". *) *) + (* (* { iRewrite -"Hr". iPureIntro. repeat f_equiv. *) *) + (* (* apply Ha. } *) *) + (* (* iSplit. { iPureIntro. by rewrite Ha IT_to_V_Vis. } *) *) + (* (* iExists α'. iFrame "Ha'". *) *) + (* (* rewrite /istep. iRight. *) *) + (* (* iExists op,i,k. iFrame "Hr". *) *) + (* (* iPureIntro. apply Ha. *) *) + (* Admitted. *) End istep. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index e4e2b61..d8d2148 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -882,22 +882,22 @@ Section weakestpre. iApply "H". iIntros (w) "Hw". iApply "HK"; by iApply HΦ. Qed. - Lemma clwp_value s E (Φ : ITV -n> iProp) e v `{!IntoVal e v} : - Φ v ⊢ CLWP e @ s ; E {{ Φ }}. - Proof. - iIntros "H". - assert (e = IT_of_V v) as ->. - { admit. } - by iApply clwp_value'. - Admitted. + (* Lemma clwp_value s E (Φ : ITV -n> iProp) e v `{!IntoVal e v} : *) + (* Φ v ⊢ CLWP e @ s ; E {{ Φ }}. *) + (* Proof. *) + (* iIntros "H". *) + (* assert (e = IT_of_V v) as ->. *) + (* { admit. } *) + (* by iApply clwp_value'. *) + (* Admitted. *) Lemma clwp_value_fupd' s E (Φ : ITV -n> iProp) v : (|={E}=> Φ v) ⊢ CLWP (IT_of_V v) @ s ; E {{ Φ }}. Proof. intros. by rewrite -clwp_fupd -clwp_value'. Qed. - Lemma clwp_value_fupd s E (Φ : ITV -n> iProp) e v `{!IntoVal e v} : - (|={E}=> Φ v) ⊢ CLWP e @ s ; E {{ Φ }}. - Proof. intros. rewrite -clwp_fupd -clwp_value //. Qed. + (* Lemma clwp_value_fupd s E (Φ : ITV -n> iProp) e v `{!IntoVal e v} : *) + (* (|={E}=> Φ v) ⊢ CLWP e @ s ; E {{ Φ }}. *) + (* Proof. intros. rewrite -clwp_fupd -clwp_value //. Qed. *) Global Instance upd_ast_l {X : ofe} R (Φ : X -n> iProp) : NonExpansive (λ (a : X), (R ∗ Φ a)%I). diff --git a/theories/program_logic.v b/theories/program_logic.v index 571e703..83cf06c 100644 --- a/theories/program_logic.v +++ b/theories/program_logic.v @@ -22,30 +22,30 @@ Section program_logic. by iApply wp_tick. Qed. - Lemma clwp_seq α β s (Φ : ITV -n> iProp) : - CLWP@{rs} α @ s {{ (constO (CLWP@{rs} β @ s {{ Φ }})) }} ⊢ CLWP@{rs} SEQ α β @ s {{ Φ }}. - Proof. - iIntros "H". - iApply (clwp_bind _ (SEQCtx β)). - iApply (clwp_wand with "H"). - iIntros (?) "Hb". unfold SEQCtx. - simpl. - match goal with - | |- context G [ofe_mor_car _ _ (get_val ?a) ?b] => - idtac - end. - simpl. - (* rewrite SEQ_Val. *) - Admitted. + (* Lemma clwp_seq α β s (Φ : ITV -n> iProp) : *) + (* CLWP@{rs} α @ s {{ (constO (CLWP@{rs} β @ s {{ Φ }})) }} ⊢ CLWP@{rs} SEQ α β @ s {{ Φ }}. *) + (* Proof. *) + (* iIntros "H". *) + (* iApply (clwp_bind _ (SEQCtx β)). *) + (* iApply (clwp_wand with "H"). *) + (* iIntros (?) "Hb". unfold SEQCtx. *) + (* simpl. *) + (* match goal with *) + (* | |- context G [ofe_mor_car _ _ (get_val ?a) ?b] => *) + (* idtac *) + (* end. *) + (* simpl. *) + (* (* rewrite SEQ_Val. *) *) + (* Admitted. *) - Lemma clwp_let α (f : IT -n> IT) {Hf : IT_hom f} s (Φ : ITV -n> iProp) : - CLWP@{rs} α @ s {{ (λne αv, CLWP@{rs} f (IT_of_V αv) @ s {{ Φ }}) }} ⊢ CLWP@{rs} (LET α f) @ s {{ Φ }}. - Proof. - iIntros "H". - iApply (clwp_bind _ (LETCTX f)). - iApply (clwp_wand with "H"). - iIntros (?) "Hb". simpl. - (* by rewrite LET_Val. *) - Admitted. + (* Lemma clwp_let α (f : IT -n> IT) {Hf : IT_hom f} s (Φ : ITV -n> iProp) : *) + (* CLWP@{rs} α @ s {{ (λne αv, CLWP@{rs} f (IT_of_V αv) @ s {{ Φ }}) }} ⊢ CLWP@{rs} (LET α f) @ s {{ Φ }}. *) + (* Proof. *) + (* iIntros "H". *) + (* iApply (clwp_bind _ (LETCTX f)). *) + (* iApply (clwp_wand with "H"). *) + (* iIntros (?) "Hb". simpl. *) + (* (* by rewrite LET_Val. *) *) + (* Admitted. *) End program_logic. From cc6b382ab509d2216cb7627e92ed6bf09a93e6ef Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 29 Nov 2023 15:44:12 +0100 Subject: [PATCH 042/114] todos upd --- TODO.md | 7 +++---- check_admits.sh | 3 +++ 2 files changed, 6 insertions(+), 4 deletions(-) create mode 100755 check_admits.sh diff --git a/TODO.md b/TODO.md index 80b188d..2f28c51 100644 --- a/TODO.md +++ b/TODO.md @@ -1,4 +1,3 @@ -- Backward compatibility (affine lang, examples) -- Reification for callcc -- Denotation for input lang + callcc -- Rules for context-dependent effects +- last adequacy subgoal for throw +- clwp +- backward compatibility (input lang, affine lang, examples) diff --git a/check_admits.sh b/check_admits.sh new file mode 100755 index 0000000..e694cc9 --- /dev/null +++ b/check_admits.sh @@ -0,0 +1,3 @@ +#! /bin/sh + +grep -n -e 'admit' -e 'Admitted' $(find . -name '*.v' -type f) From 5bba9992c0051f8b1871a29512dcf95f51862646 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 29 Nov 2023 16:13:24 +0100 Subject: [PATCH 043/114] last admit ok --- theories/input_lang_callcc/logrel.v | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 4aaa797..d89974f 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -5,6 +5,8 @@ From gitrees.input_lang_callcc Require Import lang interp. Require Import gitrees.lang_generic_sem. Require Import Binding.Lib Binding.Set Binding.Env. +Open Scope stdpp_scope. + Section logrel. Context {sz : nat}. Variable (rs : gReifiers sz). @@ -232,7 +234,7 @@ Section logrel. Definition ssubst2_valid {S : Set} (Γ : S -> ty) (ss : @interp_scope F natO _ S) - (γ : S [⇒] ∅) + (γ : S [⇒] Empty_set) : iProp := (∀ x, □ logrel (Γ x) (ss x) (γ x))%I. @@ -242,7 +244,7 @@ Section logrel. (α : @interp_scope F natO _ S -n> IT) (τ : ty) : iProp := (□ ∀ (ss : @interp_scope F natO _ S) - (γ : S [⇒] ∅), + (γ : S [⇒] Empty_set), ssubst2_valid Γ ss γ → logrel τ (α ss) (bind γ e))%I. Lemma compat_var {S : Set} (Γ : S -> ty) (x : S) : @@ -287,7 +289,7 @@ Section logrel. Opaque IT_of_V. simpl. pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V αv))). - pose (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)%bind))%bind : inc (inc S) [⇒] ∅). + pose (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)%bind))%bind : inc (inc S) [⇒] Empty_set). iSpecialize ("H" $! ss' γ' with "[]"); last first. - iSpecialize ("H" $! κ K with "HK"). unfold ss'. @@ -582,7 +584,8 @@ Section logrel. rewrite get_fun_err. reflexivity. Qed. - + + Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β e e' : ⊢ logrel_valid Γ e α τ -∗ logrel_valid Γ e' β (Tcont τ) -∗ @@ -615,9 +618,10 @@ Section logrel. simpl. pose (κ'' := @ThrowRSCtx_HOM S (IT_of_V βv) ss _). (* TODO: some typeclasses bs *) - assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) = ((`κ'') (β ss))) as ->. - { - admit. + assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) ≡ + ((`κ'') (β ss))) as ->. + { + subst κ''. simpl. by rewrite get_val_ITV. } assert ((`κ) ((`κ'') (β ss)) = ((`κ) ◎ (`κ'')) (β ss)) as ->. { reflexivity. } @@ -666,7 +670,8 @@ Section logrel. term_simpl. eapply prim_step_steps. eapply Throw_step; reflexivity. - Admitted. + Qed. + Lemma compat_callcc {S : Set} (Γ : S -> ty) τ α e : ⊢ logrel_valid (Γ ▹ Tcont τ) e α τ -∗ From aa936ac41315e05f231ffe0d93c3d37c9ea0418b Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 30 Nov 2023 11:24:17 +0100 Subject: [PATCH 044/114] cleanup stray spaces --- theories/gitree/weakestpre.v | 4 ++-- theories/input_lang_callcc/logrel.v | 14 +++++++------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index d8d2148..64f9db2 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -766,7 +766,7 @@ Section weakestpre. iIntros "H". rewrite unfold_clwp. unshelve iSpecialize ("H" $! idfun _ Φ with "[]"). - apply _. - - iIntros (w) "Hw". simpl. + - iIntros (w) "Hw". simpl. iApply wp_val; rewrite /IntoVal /=. done. - by simpl. @@ -791,7 +791,7 @@ Section weakestpre. iIntros "HΦ"; rewrite unfold_clwp. iIntros (K HK Ψ) "HK". iApply ("HK" with "HΦ"). Qed. - + Lemma clwp_value_inv s E (Φ : ITV -n> iProp) v : CLWP (IT_of_V v) @ s ; E {{ Φ }} ={E}=∗ Φ v. Proof. diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index d89974f..11d0d22 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -757,7 +757,7 @@ Section logrel. intros; simpl. apply _. Qed. - + Lemma compat_output {S} Γ (e: expr S) α : ⊢ logrel_valid Γ e α Tnat -∗ logrel_valid Γ (Output e) (interp_output rs α) Tnat. @@ -809,13 +809,13 @@ Section logrel. constructor. reflexivity. Qed. - + Program Definition AppRSCtx_HOM {S : Set} (α : @interp_scope F natO _ S -n> IT) (env : @interp_scope F natO _ S) : HOM := exist _ (interp_apprk rs α (λne env, idfun) env) _. Next Obligation. - intros; simpl. + intros; simpl. apply _. Qed. @@ -856,7 +856,7 @@ Section logrel. rewrite fill_comp. iApply logrel_bind; first by iApply "H2". subst sss κ'. - iIntros (βv v). iModIntro. iIntros "#HV". + iIntros (βv v). iModIntro. iIntros "#HV". unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. rewrite -fill_comp. simpl. @@ -864,12 +864,12 @@ Section logrel. { reflexivity. } pose (κ'' := (AppLSCtx_HOM (IT_of_V βv) ss _)). assert (((`κ) (α1 ss ⊙ (IT_of_V βv))) = (((`κ) ◎ (`κ'')) (α1 ss))) as ->. - { reflexivity. } + { reflexivity. } pose (sss := (HOM_compose κ κ'')). assert ((`κ ◎ `κ'') = (`sss)) as ->. { reflexivity. } rewrite fill_comp. - iApply logrel_bind; first by iApply "H1". + iApply logrel_bind; first by iApply "H1". iIntros (βv' v'). iModIntro. iIntros "#HV'". subst sss κ''. rewrite -fill_comp. @@ -880,7 +880,7 @@ Section logrel. iSpecialize ("HV'" $! βv v with "HV"). iApply "HV'"; iApply "HK". Qed. - + (* TODO: finish throw + refactor *) Lemma fundamental {S : Set} (Γ : S -> ty) τ e : typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ From 17894476c01b41e694774173c899875decd58295 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Mon, 4 Dec 2023 11:38:12 +0100 Subject: [PATCH 045/114] todo upd --- TODO.md | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/TODO.md b/TODO.md index 2f28c51..6eb8e79 100644 --- a/TODO.md +++ b/TODO.md @@ -1,3 +1,17 @@ -- last adequacy subgoal for throw -- clwp +# Now +- cleanup code + + especially implicit arguments, inserted by typeclasses + + resolve variable names + + lemmas for logrel - backward compatibility (input lang, affine lang, examples) +- write summary + + reifiers changes + + non-cps vs cps + + extra ticks for throw +# Later +- (ctrees)[https://perso.ens-lyon.fr/yannick.zakowski/papers/ctrees.pdf] +- Nondet : (n : nat) (f : fin n -n> \later IT) -n> IT +- (Nondet : (f : nat -n> \later IT) -n> IT) (might require transfinite iris) +# Later later +- bisimularity for gitrees (might require transfinite iris) +- concurrency From 2e9aac2b7d36fe2ca0b6a7e4ecc72033bdeeb888 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Mon, 4 Dec 2023 11:42:25 +0100 Subject: [PATCH 046/114] todo upd --- TODO.md | 1 + 1 file changed, 1 insertion(+) diff --git a/TODO.md b/TODO.md index 6eb8e79..b628e04 100644 --- a/TODO.md +++ b/TODO.md @@ -12,6 +12,7 @@ - (ctrees)[https://perso.ens-lyon.fr/yannick.zakowski/papers/ctrees.pdf] - Nondet : (n : nat) (f : fin n -n> \later IT) -n> IT - (Nondet : (f : nat -n> \later IT) -n> IT) (might require transfinite iris) +- Cooperative concurrency # Later later - bisimularity for gitrees (might require transfinite iris) - concurrency From e951175e715f04e0b651e33e30b81368ff707090 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 6 Dec 2023 09:52:09 +0100 Subject: [PATCH 047/114] Some proof cleanup --- theories/input_lang_callcc/logrel.v | 145 ++++++++++++---------------- 1 file changed, 61 insertions(+), 84 deletions(-) diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 11d0d22..eb7adcd 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -125,35 +125,42 @@ Section logrel. Qed. #[export] Instance logrel_expr_proper {S} (V : ITV → val S → iProp) : - Proper ((≡) ==> (≡) ==> (≡)) V → Proper ((≡) ==> (≡) ==> (≡)) (logrel_expr V). + Proper ((≡) ==> (≡) ==> (≡)) V → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_expr V). Proof. solve_proper. Qed. - #[export] Instance logrel_nat_proper {S} : Proper ((≡) ==> (≡) ==> (≡)) (@logrel_nat S). + #[export] Instance logrel_nat_proper {S} : + Proper ((≡) ==> (≡) ==> (≡)) (@logrel_nat S). Proof. solve_proper. Qed. - #[export] Instance logrel_val_proper {S} (τ : ty) : Proper ((≡) ==> (≡) ==> (≡)) (@logrel_val S τ). + #[export] Instance logrel_val_proper {S} (τ : ty) : + Proper ((≡) ==> (≡) ==> (≡)) (@logrel_val S τ). Proof. induction τ; simpl; solve_proper. Qed. #[export] Instance logrel_ectx_proper {S} (V : ITV → val S → iProp) : - Proper ((≡) ==> (≡) ==> (≡)) V → Proper ((≡) ==> (≡) ==> (≡)) (logrel_ectx V). + Proper ((≡) ==> (≡) ==> (≡)) V → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_ectx V). Proof. solve_proper. Qed. #[export] Instance logrel_arr_proper {S} (V1 V2 : ITV → val S → iProp) : - Proper ((≡) ==> (≡) ==> (≡)) V1 -> Proper ((≡) ==> (≡) ==> (≡)) V2 → Proper ((≡) ==> (≡) ==> (≡)) (logrel_arr V1 V2). + Proper ((≡) ==> (≡) ==> (≡)) V1 -> + Proper ((≡) ==> (≡) ==> (≡)) V2 → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_arr V1 V2). Proof. solve_proper. Qed. #[export] Instance logrel_cont_proper {S} (V : ITV → val S → iProp) : - Proper ((≡) ==> (≡) ==> (≡)) V -> Proper ((≡) ==> (≡) ==> (≡)) (logrel_cont V). + Proper ((≡) ==> (≡) ==> (≡)) V -> + Proper ((≡) ==> (≡) ==> (≡)) (logrel_cont V). Proof. solve_proper. Qed. @@ -181,9 +188,9 @@ Section logrel. by iApply ("HK" $! αv v with "[$H1] [$Hs]"). Qed. - Lemma logrel_head_step_pure_ectx {S} n K (κ : HOM) (e' e : expr S) α V : + Lemma logrel_head_step_pure_ectx {S} n K (e' e : expr S) α V : (∀ σ K, head_step e σ e' σ K (n, 0)) → - ⊢ logrel_expr V (`κ α) (fill K e') -∗ logrel_expr V (`κ α) (fill K e). + ⊢ logrel_expr V α (fill K e') -∗ logrel_expr V α (fill K e). Proof. intros Hpure. iIntros "H". @@ -250,35 +257,26 @@ Section logrel. Lemma compat_var {S : Set} (Γ : S -> ty) (x : S) : ⊢ logrel_valid Γ (Var x) (interp_var x) (Γ x). Proof. - iModIntro. - iIntros (ss γ) "Hss". - iApply "Hss". + iModIntro. iIntros (ss γ) "Hss". iApply "Hss". Qed. Lemma compat_recV {S : Set} (Γ : S -> ty) (e : expr (inc (inc S))) τ1 τ2 α : ⊢ □ logrel_valid ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) e α τ2 -∗ logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). Proof. - iIntros "#H". - iModIntro. - iIntros (ss γ) "#Hss". - pose (env := ss). fold env. - pose (f := (ir_unf rs α env)). + iIntros "#H !> %env %γ #Henv". + set (f := (ir_unf rs α env)). iAssert (interp_rec rs α env ≡ 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 _. simpl. - iSplit. + iExists _. iSplit. { Transparent IT_of_V. done. } iModIntro. - iLöb as "IH". iSimpl. + iLöb as "IH". iIntros (αv v) "#Hw". - rewrite APP_APP'_ITV. - rewrite APP_Fun. - rewrite laterO_map_Next. - rewrite -Tick_eq. + rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. iIntros (κ K) "#HK". iIntros (σ) "Hs". rewrite hom_tick. @@ -289,7 +287,9 @@ Section logrel. Opaque IT_of_V. simpl. pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V αv))). - pose (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)%bind))%bind : inc (inc S) [⇒] Empty_set). + pose (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) + ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)))%bind : + inc (inc S) [⇒] Empty_set). iSpecialize ("H" $! ss' γ' with "[]"); last first. - iSpecialize ("H" $! κ K with "HK"). unfold ss'. @@ -326,7 +326,7 @@ Section logrel. + iModIntro. subst γ'. term_simpl. - iApply "Hss". + iApply "Henv". Qed. Program Definition IFSCtx_HOM α β : HOM := exist _ (λne x, IFSCtx α β x) _. @@ -346,66 +346,43 @@ Section logrel. iIntros (ss γ) "#Hss". simpl. pose (κ' := (IFSCtx_HOM (α1 ss) (α2 ss))). - assert ((IF (α0 ss) (α1 ss) (α2 ss)) = ((`κ') (α0 ss))) as ->. - { reflexivity. } + assert ((IF (α0 ss) (α1 ss) (α2 ss)) = ((`κ') (α0 ss))) as -> by reflexivity. term_simpl. iIntros (κ K) "#HK". - assert ((`κ) ((IFSCtx (α1 ss) (α2 ss)) (α0 ss)) = ((`κ) ◎ (`κ')) (α0 ss)) as ->. - { reflexivity. } + assert ((`κ) ((IFSCtx (α1 ss) (α2 ss)) (α0 ss)) = ((`κ) ◎ (`κ')) (α0 ss)) + as -> by reflexivity. pose (sss := (HOM_compose κ κ')). - assert ((`κ ◎ `κ') = (`sss)) as ->. - { reflexivity. } - assert (fill K (if bind γ e0 then bind γ e1 else bind γ e2)%syn = fill (ectx_compose K (IfK EmptyK (bind γ e1) (bind γ e2))) (bind γ e0)) as ->. - { rewrite -fill_comp. - reflexivity. - } - iApply (logrel_bind with "[H0] [H1 H2]"). - - by iApply "H0". - - iIntros (βv v). iModIntro. iIntros "#HV". - term_simpl. - unfold logrel_nat. - iDestruct "HV" as "(%n & #Hn & ->)". - iRewrite "Hn". - destruct (decide (0 < n)). - + rewrite -fill_comp. - simpl. - unfold IFSCtx. - rewrite IF_True//. - iSpecialize ("H1" with "Hss"). - term_simpl. - iSpecialize ("H1" $! κ K with "HK"). - iIntros (σ) "Hσ". - iSpecialize ("H1" $! σ with "Hσ"). - iApply (wp_wand with "[$H1] []"). - iIntros (v) "(%m & %w & %σ' & %Hstep & H & G)". - iModIntro. - destruct m as [m m']. - iExists (m, m'), w, σ'. iFrame "H G". - iPureIntro. - eapply (prim_steps_app (0, 0) (m, m')); eauto. - eapply prim_step_steps. - eapply Ectx_step; [reflexivity | reflexivity |]. - apply IfTrueS; done. - + rewrite -fill_comp. - simpl. - unfold IFSCtx. - rewrite IF_False//; last lia. - iSpecialize ("H2" with "Hss"). - term_simpl. - iSpecialize ("H2" $! κ K with "HK"). - iIntros (σ) "Hσ". - iSpecialize ("H2" $! σ with "Hσ"). - iApply (wp_wand with "[$H2] []"). - iIntros (v) "(%m & %w & %σ' & %Hstep & H & G)". - iModIntro. - destruct m as [m m']. - iExists (m, m'), w, σ'. iFrame "H G". - iPureIntro. - eapply (prim_steps_app (0, 0) (m, m')); eauto. - eapply prim_step_steps. - eapply Ectx_step; [reflexivity | reflexivity |]. - apply IfFalseS. - lia. + assert ((`κ ◎ `κ') = (`sss)) as -> by reflexivity. + assert (fill K (if bind γ e0 then bind γ e1 else bind γ e2)%syn = + fill (ectx_compose K (IfK EmptyK (bind γ e1) (bind γ e2))) (bind γ e0)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (logrel_bind with "[H0] [H1 H2]"); first by iApply "H0". + iIntros (βv v). iModIntro. iIntros "#HV". + term_simpl. + unfold logrel_nat. + iDestruct "HV" as "(%n & #Hn & ->)". + iRewrite "Hn". + unfold IFSCtx. + destruct (decide (0 < n)) as [H|H]. + - rewrite -fill_comp. + simpl. + rewrite IF_True//. + iSpecialize ("H1" with "Hss"). + term_simpl. rewrite /logrel. + iPoseProof (logrel_head_step_pure_ectx _ EmptyK + (bind γ e1)%syn _ (α1 ss) (logrel_val τ) with "H1") + as "Hrel"; last iApply ("Hrel" $! κ K with "HK"). + intros σ K0. by apply IfTrueS. + - rewrite -fill_comp. + simpl. + unfold IFSCtx. + rewrite IF_False//; last lia. + iSpecialize ("H2" with "Hss"). + term_simpl. rewrite /logrel. + iPoseProof (logrel_head_step_pure_ectx _ EmptyK + (bind γ e2)%syn _ (α2 ss) (logrel_val τ) with "H2") + as "Hrel"; last iApply ("Hrel" $! κ K with "HK"). + intros σ K0. apply IfFalseS. lia. Qed. Lemma compat_input {S} Γ : @@ -555,7 +532,7 @@ Section logrel. (Hv : AsVal β) : HOM := exist _ (interp_throwrk rs (constO β) (λne env, idfun) env) _. Next Obligation. - intros; simpl. + intros; simpl. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - solve_proper_prepare. destruct Hv as [? <-]. @@ -621,7 +598,7 @@ Section logrel. assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) ≡ ((`κ'') (β ss))) as ->. { - subst κ''. simpl. by rewrite get_val_ITV. + subst κ''. simpl. by rewrite get_val_ITV. } assert ((`κ) ((`κ'') (β ss)) = ((`κ) ◎ (`κ'')) (β ss)) as ->. { reflexivity. } From c27183ca2cd9cbdaa8a9bad853ccacfd1e09db3f Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 6 Dec 2023 17:11:51 +0100 Subject: [PATCH 048/114] Some refactoring --- theories/input_lang_callcc/interp.v | 71 ++++++++-- theories/input_lang_callcc/logrel.v | 208 +++++++++++++--------------- 2 files changed, 158 insertions(+), 121 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index f33650a..3c12a6f 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -193,19 +193,59 @@ Section weakestpre. Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). + Lemma wp_input' (σ σ' : stateO) (n : nat) (k : natO -n> IT) (κ : IT -n> IT) + `{!IT_hom κ} Φ s : + update_input σ = (n, σ') -> + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ ◎ k $ n) @ s {{ Φ }}) -∗ + WP@{rs} κ (INPUT k) @ s {{ Φ }}. + Proof. + iIntros (Hσ) "Hs Ha". + rewrite hom_INPUT. simpl. + iApply (wp_subreify with "Hs"). + + simpl. by rewrite Hσ. + + by rewrite ofe_iso_21. + + done. + Qed. + Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : update_input σ = (n, σ') → has_substate σ -∗ ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ WP@{rs} (INPUT k) @ s {{ Φ }}. Proof. - intros Hs. iIntros "Hs Ha". - unfold INPUT. simpl. + eapply (wp_input' σ σ' n k idfun). + Qed. + + (* Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : *) + (* update_input σ = (n, σ') → *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ *) + (* WP@{rs} (INPUT k) @ s {{ Φ }}. *) + (* Proof. *) + (* intros Hs. iIntros "Hs Ha". *) + (* unfold INPUT. simpl. *) + (* iApply (wp_subreify with "Hs"). *) + (* { simpl. by rewrite Hs. } *) + (* { simpl. by rewrite ofe_iso_21. } *) + (* iModIntro. done. *) + (* Qed. *) + + Lemma wp_output' (σ σ' : stateO) (n : nat) (κ : IT -n> IT) + `{!IT_hom κ} Φ s : + update_output n σ = σ' → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ (Ret 0)) @ s {{ Φ }}) -∗ + WP@{rs} κ (OUTPUT n) @ s {{ Φ }}. + Proof. + iIntros (Hσ) "Hs Ha". + rewrite /OUTPUT hom_OUTPUT_. iApply (wp_subreify with "Hs"). - { simpl. by rewrite Hs. } - { simpl. by rewrite ofe_iso_21. } - iModIntro. done. + + simpl. by rewrite Hσ. + + done. + + done. Qed. + Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : update_output n σ = σ' → @@ -213,15 +253,22 @@ Section weakestpre. ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ WP@{rs} (OUTPUT n) @ s {{ Φ }}. Proof. - intros Hs. iIntros "Hs Ha". - unfold OUTPUT. simpl. - iApply (wp_subreify with "Hs"). - { simpl. by rewrite Hs. } - { simpl. done. } - iModIntro. iIntros "H1 H2". - iApply wp_val. by iApply ("Ha" with "H1 H2"). + iIntros (Hσ) "Hs Ha". + iApply (wp_output' _ _ _ idfun with "Hs [Ha]"); first done. + simpl. iNext. iIntros "Hcl Hs". + iApply wp_val. iApply ("Ha" with "Hcl Hs"). Qed. + (* Proof. *) + (* intros Hs. iIntros "Hs Ha". *) + (* unfold OUTPUT. simpl. *) + (* iApply (wp_subreify with "Hs"). *) + (* { simpl. by rewrite Hs. } *) + (* { simpl. done. } *) + (* iModIntro. iIntros "H1 H2". *) + (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) + (* Qed. *) + Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : has_substate σ -∗ ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index eb7adcd..230942c 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -208,8 +208,8 @@ Section logrel. eapply Ectx_step; last apply Hpure; done. Qed. - Lemma HOM_ccompose (f g : HOM) - : ∀ α, `f (`g α) = (`f ◎ `g) α. + Lemma HOM_ccompose (f g : HOM) : + ∀ α, `f (`g α) = (`f ◎ `g) α. Proof. intro; reflexivity. Qed. @@ -220,8 +220,7 @@ Section logrel. apply _. Qed. - Lemma logrel_bind {S} (f : HOM) (K : ectx S) - e α τ1 : + Lemma logrel_bind {S} (f : HOM) (K : ectx S) e α τ1 : ⊢ logrel τ1 α e -∗ logrel_ectx (logrel_val τ1) f K -∗ obs_ref (`f α) (fill K e). @@ -241,8 +240,7 @@ Section logrel. Definition ssubst2_valid {S : Set} (Γ : S -> ty) (ss : @interp_scope F natO _ S) - (γ : S [⇒] Empty_set) - : iProp := + (γ : S [⇒] Empty_set) : iProp := (∀ x, □ logrel (Γ x) (ss x) (γ x))%I. Definition logrel_valid {S : Set} @@ -395,29 +393,21 @@ Section logrel. term_simpl. iIntros (σ) "Hs". destruct (update_input σ) as [n σ'] eqn:Hinp. - rewrite hom_vis. - iApply (wp_subreify with "Hs"). - - simpl; rewrite Hinp. - rewrite later_map_Next. - rewrite ofe_iso_21. - reflexivity. - - reflexivity. - - iNext. - iIntros "Hlc Hs". - iSpecialize ("HK" $! (RetV n) (LitV n) with "[]"); first by iExists n. - iSpecialize ("HK" $! σ' with "Hs"). - iApply (wp_wand with "[$HK] []"). - iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". - destruct m as [m m']. - iModIntro. - iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H". - iPureIntro. - eapply (prim_steps_app (1, 1) (m, m')); eauto. - term_simpl. - eapply prim_step_steps. - eapply Ectx_step; [reflexivity | reflexivity |]. - constructor. - assumption. + iApply (wp_input' with "Hs []"); first done. + iNext. iIntros "Hlc Hs". term_simpl. + iSpecialize ("HK" $! (RetV n) (LitV n) with "[]"); first by iExists n. + iSpecialize ("HK" $! σ' with "Hs"). + rewrite IT_of_V_Ret. + iApply (wp_wand with "[$HK] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + iModIntro. + destruct m as [m1 m2]. + iExists ((Nat.add 1 m1), (Nat.add 1 m2)), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (1, 1) (m1, m2)); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + by constructor. Qed. Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) @@ -744,49 +734,37 @@ Section logrel. iIntros (κ K) "#HK". term_simpl. pose (κ' := OutputSCtx_HOM ss). - assert ((get_ret OUTPUT (α ss)) = ((`κ') (α ss))) as ->. - { reflexivity. } - assert ((`κ) ((`κ') (α ss)) = ((`κ) ◎ (`κ')) (α ss)) as ->. - { reflexivity. } + replace (get_ret OUTPUT (α ss)) with ((`κ') (α ss)) by reflexivity. + replace ((`κ) ((`κ') (α ss))) with (((`κ) ◎ (`κ')) (α ss)) by reflexivity. pose (sss := (HOM_compose κ κ')). - assert ((`κ ◎ `κ') = (`sss)) as ->. - { reflexivity. } - assert (fill K (Output (bind γ e))%syn = fill (ectx_compose K (OutputK EmptyK)) (bind γ e)) as ->. - { rewrite -fill_comp. - reflexivity. - } + replace (`κ ◎ `κ') with (`sss) by reflexivity. + assert (fill K (Output (bind γ e))%syn = + fill (ectx_compose K (OutputK EmptyK)) (bind γ e)) as ->. + { rewrite -fill_comp. reflexivity. } iApply logrel_bind; first by iApply "H". iIntros (βv v). iModIntro. iIntros "#Hv". iDestruct "Hv" as (n) "[Hb ->]". iRewrite "Hb". simpl. iIntros (σ) "Hs". rewrite get_ret_ret. - rewrite hom_vis. - iApply (wp_subreify with "Hs"). - - simpl. - rewrite later_map_Next. - reflexivity. - - reflexivity. - - iNext. - iIntros "Hlc Hs". - iSpecialize ("HK" $! (RetV 0) (LitV 0) with "[]"); first by iExists 0. - iSpecialize ("HK" $! (update_output n σ) with "Hs"). - iApply (wp_wand with "[$HK] []"). - iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H')". - destruct m as [m m']. - iModIntro. - iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H'". - iPureIntro. - eapply (prim_steps_app (1, 1) (m, m')); eauto. - term_simpl. - eapply prim_step_steps. - rewrite -fill_comp. - simpl. - eapply Ectx_step; [reflexivity | reflexivity |]. - constructor. - reflexivity. + iApply (wp_output' with "Hs []"); first done. + iNext. iIntros "Hlc Hs". + iSpecialize ("HK" $! (RetV 0) (LitV 0) with "[]"); first by iExists 0. + iSpecialize ("HK" $! (update_output n σ) with "Hs"). + iApply (wp_wand with "[$HK] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H')". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H'". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + eapply prim_step_steps. + rewrite -fill_comp. + eapply Ectx_step; [reflexivity | reflexivity |]. + by constructor. Qed. + Program Definition AppRSCtx_HOM {S : Set} (α : @interp_scope F natO _ S -n> IT) (env : @interp_scope F natO _ S) @@ -914,26 +892,33 @@ Definition rs : gReifiers 1 := gReifiers_cons reify_io gReifiers_nil. Require Import gitrees.gitree.greifiers. -Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : - (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, - (True ⊢ logrel rs Tnat α e)%I) → - ssteps (gReifiers_sReifier rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. +Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} + (α : IT (gReifiers_ops rs) natO) + (e : expr S) n σ σ' k : + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (True ⊢ logrel rs Tnat α e)%I) → + ssteps (gReifiers_sReifier rs) α (σ, ()) (Ret n) σ' k → + ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), ∃ m σ', prim_steps e σ (Val $ κ βv) σ' m). cut (ϕ (RetV n)). - { destruct 1 as ( m' & σ2 & Hm). - exists m', σ2. revert Hm. by rewrite κ_Ret. } + { + destruct 1 as ( m' & σ2 & Hm). + exists m', σ2. revert Hm. by rewrite κ_Ret. + } eapply (wp_adequacy 0); eauto. intros Hinv1 Hst1. - pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) - ∗ ⌜∃ m σ', prim_steps e σ (Val $ LitV n) σ' m⌝)%I). + pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), + ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) + ∗ ⌜∃ m σ', prim_steps e σ (Val $ LitV n) σ' m⌝)%I). assert (NonExpansive Φ). - { unfold Φ. - intros l a1 a2 Ha. repeat f_equiv. done. } + { + unfold Φ. + 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 %]". 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. } @@ -944,41 +929,46 @@ Proof. - iExFalso. iApply (IT_ret_fun_ne). iApply internal_eq_sym. iExact "Hb". } iPureIntro. rewrite Hfoo. unfold ϕ. - eauto. } - iIntros "[_ Hs]". - iPoseProof (Hlog with "[//]") as "Hlog". - iAssert (has_substate σ) with "[Hs]" as "Hs". - { unfold has_substate, has_full_state. - assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ())) ≡ - (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ))) as -> ; last done. - intros 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)//. - } - unshelve epose (idHOM := _ : (HOM rs)). - { exists idfun. apply IT_hom_idfun. } - iSpecialize ("Hlog" $! idHOM EmptyK with "[]"). - { iIntros (βv v); iModIntro. iIntros "Hv". iIntros (σ'') "HS". - iApply wp_val. - iModIntro. - iExists (0, 0), v, σ''. - iSplit; first iPureIntro. - - apply prim_steps_zero. - - by iFrame. - } - simpl. - iSpecialize ("Hlog" $! σ with "Hs"). - iApply (wp_wand with"Hlog"). - iIntros ( βv). iIntros "H". - iDestruct "H" as (m' v σ1' Hsts) "[Hi Hsts]". - unfold Φ. iDestruct "Hi" as (l) "[Hβ %]". simplify_eq/=. - iExists l. iModIntro. iSplit; eauto. - iExists l. iSplit; eauto. + eauto. + - iIntros "[_ Hs]". + iPoseProof (Hlog with "[//]") as "Hlog". + iAssert (has_substate σ) with "[Hs]" as "Hs". + { + unfold has_substate, has_full_state. + assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ())) ≡ + (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ))) + as -> ; last done. + intros 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)//. + } + unshelve epose (idHOM := _ : (HOM rs)). + { exists idfun. apply IT_hom_idfun. } + iSpecialize ("Hlog" $! idHOM EmptyK with "[]"). + { + iIntros (βv v); iModIntro. iIntros "Hv". iIntros (σ'') "HS". + iApply wp_val. + iModIntro. + iExists (0, 0), v, σ''. + iSplit; first iPureIntro. + - apply prim_steps_zero. + - by iFrame. + } + simpl. + iSpecialize ("Hlog" $! σ with "Hs"). + iApply (wp_wand with"Hlog"). + iIntros ( βv). iIntros "H". + iDestruct "H" as (m' v σ1' Hsts) "[Hi Hsts]". + unfold Φ. iDestruct "Hi" as (l) "[Hβ %]". simplify_eq/=. + iExists l. iModIntro. iSplit; eauto. + iExists l. iSplit; eauto. Qed. Program Definition ı_scope : @interp_scope (gReifiers_ops rs) natO _ Empty_set := λne (x : ∅), match x with end. From 51466043b3bac87d74c674e4a6b52ac54cdc037f Mon Sep 17 00:00:00 2001 From: Kaptch Date: Wed, 6 Dec 2023 17:43:15 +0100 Subject: [PATCH 049/114] notation for variables --- theories/input_lang_callcc/lang.v | 55 ++++++++++++++++++++++++++++++- 1 file changed, 54 insertions(+), 1 deletion(-) diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index bb0fe4f..b6b5754 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -6,6 +6,52 @@ Import ListNotations. Require Import Binding.Lib Binding.Set Binding.Auto Binding.Env. +Module IncDec. + Global Instance empty_EqDec : EqDec ∅. + Proof. + intros []. + Qed. + + Global Instance inc_EqDec (X : Set) `(EqDec X) : EqDec (inc X). + Proof. + intros [| x] [| y]; [by left | by right | by right |]. + destruct (H x y) as [-> | H2]; [left; reflexivity | right]. + inversion 1; by subst. + Qed. + + Global Instance nth_inc_dec (X : Set) `(EqDec X) (n : nat) : EqDec (Init.Nat.iter n inc X). + Proof. + induction n; apply _. + Qed. +End IncDec. + +Section ResolutionDeBruijn. + Number Notation fin Nat.of_num_uint Nat.to_num_uint (via nat + mapping [[Fin.F1] => O, [Fin.FS] => S]) : fin_scope. + + Class Resolver (D : Set) (n : nat) := { resolve : fin n -> D }. + + Global Instance ResolverEmpty : Resolver ∅ 0. + Proof. + constructor. + apply fin_0_inv. + Defined. + + Global Instance ResolverInc {D : Set} (n : nat) `{Resolver D n} : Resolver (inc D) (S n). + Proof. + constructor. + apply fin_S_inv. + - apply VZ. + - intros x; apply VS, resolve, x. + Defined. + + Global Instance ResolverIncNEmpty {n : nat} : Resolver (Init.Nat.iter n inc ∅) n. + Proof. + induction n; apply _. + Defined. + +End ResolutionDeBruijn. + Inductive nat_op := Add | Sub | Mult. Inductive expr {X : Set} := @@ -62,6 +108,7 @@ Notation "'#' n" := (LitV n) (at level 60) : syn_scope. Notation "'input'" := (Input) : syn_scope. Notation "'output' e" := (Output e) (at level 60) : syn_scope. Notation "'rec' e" := (RecV e) (at level 60) : syn_scope. +Notation "'callcc' e" := (Callcc e) (at level 60) : syn_scope. Notation "'throw' e₁ e₂" := (Throw e₁ e₂) (at level 60) : syn_scope. Notation "'cont' K" := (ContV K) (at level 60) : syn_scope. @@ -72,6 +119,12 @@ Notation "'if' K 'then' e₂ 'else' e₃" := (IfK K e₂ e₃) : ectx_scope. Notation "'output' K" := (OutputK K) (at level 60) : ectx_scope. Notation "'throwₗ' K e₂" := (ThrowLK K e₂) (at level 60) : ectx_scope. Notation "'throwᵣ' e₁ K" := (ThrowRK e₁ K) (at level 60) : ectx_scope. +Definition var_smart {D} {n} `{Resolver D n} (fn : fin n) : expr D := (@Var D (resolve fn)). +Notation "'$' fn" := (@var_smart _ _ _ fn) (at level 60) : syn_scope. + +Example test1 : expr (inc ∅) := ($ 0)%syn. +Example test2 : val ∅ := (rec (($ 1) : expr (inc (inc ∅))))%syn. +Example test3 : expr ∅ := (callcc (($ 0) : expr (inc ∅)))%syn. Definition to_val {S} (e : expr S) : option (val S) := match e with @@ -133,7 +186,7 @@ with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := | OutputK K => OutputK (kmap f K) | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) | AppLK K v => AppLK (kmap f K) (vmap f v) - | AppRK e K => AppRK (emap f e) (kmap f K) + | AppRK e K => AppRK (emap f e) (kmap f K) | NatOpRK op e K => NatOpRK op (emap f e) (kmap f K) | NatOpLK op K v => NatOpLK op (kmap f K) (vmap f v) | ThrowLK K e => ThrowLK (kmap f K) (emap f e) From 44dd464aaa3311b14490aa131305d44864743db9 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 7 Dec 2023 12:28:45 +0100 Subject: [PATCH 050/114] some cleanup --- _CoqProject | 1 + theories/input_lang_callcc/lang.v | 222 ++++++++++++------------------ vendor/Binding/Inc.v | 13 ++ vendor/Binding/Resolver.v | 37 +++++ 4 files changed, 138 insertions(+), 135 deletions(-) create mode 100644 vendor/Binding/Resolver.v diff --git a/_CoqProject b/_CoqProject index 3a191be..cfe0f98 100644 --- a/_CoqProject +++ b/_CoqProject @@ -12,6 +12,7 @@ vendor/Binding/Intrinsic.v vendor/Binding/TermSimpl.v vendor/Binding/Product.v vendor/Binding/Env.v +vendor/Binding/Resolver.v theories/prelude.v theories/lang_generic.v diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index b6b5754..6f488fa 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -4,53 +4,7 @@ From Equations Require Import Equations. Require Import List. Import ListNotations. -Require Import Binding.Lib Binding.Set Binding.Auto Binding.Env. - -Module IncDec. - Global Instance empty_EqDec : EqDec ∅. - Proof. - intros []. - Qed. - - Global Instance inc_EqDec (X : Set) `(EqDec X) : EqDec (inc X). - Proof. - intros [| x] [| y]; [by left | by right | by right |]. - destruct (H x y) as [-> | H2]; [left; reflexivity | right]. - inversion 1; by subst. - Qed. - - Global Instance nth_inc_dec (X : Set) `(EqDec X) (n : nat) : EqDec (Init.Nat.iter n inc X). - Proof. - induction n; apply _. - Qed. -End IncDec. - -Section ResolutionDeBruijn. - Number Notation fin Nat.of_num_uint Nat.to_num_uint (via nat - mapping [[Fin.F1] => O, [Fin.FS] => S]) : fin_scope. - - Class Resolver (D : Set) (n : nat) := { resolve : fin n -> D }. - - Global Instance ResolverEmpty : Resolver ∅ 0. - Proof. - constructor. - apply fin_0_inv. - Defined. - - Global Instance ResolverInc {D : Set} (n : nat) `{Resolver D n} : Resolver (inc D) (S n). - Proof. - constructor. - apply fin_S_inv. - - apply VZ. - - intros x; apply VS, resolve, x. - Defined. - - Global Instance ResolverIncNEmpty {n : nat} : Resolver (Init.Nat.iter n inc ∅) n. - Proof. - induction n; apply _. - Defined. - -End ResolutionDeBruijn. +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. Inductive nat_op := Add | Sub | Mult. @@ -83,83 +37,10 @@ with ectx {X : Set} := | ThrowLK (K : ectx) (e : expr) : ectx | ThrowRK (v : val) (K : ectx) : ectx. -Notation of_val := Val (only parsing). - Arguments val X%bind : clear implicits. Arguments expr X%bind : clear implicits. Arguments ectx X%bind : clear implicits. -Declare Scope syn_scope. -Declare Scope ectx_scope. -Delimit Scope syn_scope with syn. -Delimit Scope ectx_scope with ectx. - -Coercion Val : val >-> expr. -Coercion App : expr >-> Funclass. -Coercion AppLK : ectx >-> Funclass. -Coercion AppRK : expr >-> Funclass. - -Notation "+" := (Add) : syn_scope. -Notation "-" := (Sub) : syn_scope. -Notation "×" := (Mult) : syn_scope. -Notation "'⟨' e₁ op e₂ '⟩'" := (NatOp op e₁ e₂) (at level 45, right associativity) : syn_scope. -Notation "'if' e₁ 'then' e₂ 'else' e₃" := (If e₁ e₂ e₃) : syn_scope. -Notation "'#' n" := (LitV n) (at level 60) : syn_scope. -Notation "'input'" := (Input) : syn_scope. -Notation "'output' e" := (Output e) (at level 60) : syn_scope. -Notation "'rec' e" := (RecV e) (at level 60) : syn_scope. -Notation "'callcc' e" := (Callcc e) (at level 60) : syn_scope. -Notation "'throw' e₁ e₂" := (Throw e₁ e₂) (at level 60) : syn_scope. -Notation "'cont' K" := (ContV K) (at level 60) : syn_scope. - -Notation "□" := (EmptyK) : ectx_scope. -Notation "'⟨' e₁ op K '⟩ᵣ'" := (NatOpRK op e₁ K) (at level 45, right associativity) : ectx_scope. -Notation "'⟨' K op v₂ '⟩ₗ'" := (NatOpLK op K v₂) (at level 45, right associativity) : ectx_scope. -Notation "'if' K 'then' e₂ 'else' e₃" := (IfK K e₂ e₃) : ectx_scope. -Notation "'output' K" := (OutputK K) (at level 60) : ectx_scope. -Notation "'throwₗ' K e₂" := (ThrowLK K e₂) (at level 60) : ectx_scope. -Notation "'throwᵣ' e₁ K" := (ThrowRK e₁ K) (at level 60) : ectx_scope. -Definition var_smart {D} {n} `{Resolver D n} (fn : fin n) : expr D := (@Var D (resolve fn)). -Notation "'$' fn" := (@var_smart _ _ _ fn) (at level 60) : syn_scope. - -Example test1 : expr (inc ∅) := ($ 0)%syn. -Example test2 : val ∅ := (rec (($ 1) : expr (inc (inc ∅))))%syn. -Example test3 : expr ∅ := (callcc (($ 0) : expr (inc ∅)))%syn. - -Definition to_val {S} (e : expr S) : option (val S) := - match e with - | Val v => Some v - | _ => None - end. - -Definition do_natop (op : nat_op) (x y : nat) : nat := - match op with - | Add => plus x y - | Sub => minus x y - | Mult => mult x y - end. - -Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := - match x, y with - | LitV x, LitV y => Some $ LitV $ do_natop n x y - | _,_ => None - end. - -Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := - match K with - | EmptyK => e - | OutputK K => Output (fill K e) - | IfK K e₁ e₂ => If (fill K e) e₁ e₂ - | AppLK K v => App (fill K e) (Val v) - | AppRK e' K => App e' (fill K e) - | NatOpRK op e' K => NatOp op e' (fill K e) - | NatOpLK op K v => NatOp op (fill K e) (Val v) - | ThrowLK K e' => Throw (fill K e) e' - | ThrowRK v K => Throw (Val v) (fill K e) - end. - -Notation "K '[' e ']'" := (fill K e) (at level 60) : syn_scope. - Local Open Scope bind_scope. Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := @@ -196,21 +77,6 @@ with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := #[export] Instance FMap_val : FunctorCore val := @vmap. #[export] Instance FMap_ectx : FunctorCore ectx := @kmap. -Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) - : fmap f (fill K e) = fill (fmap f K) (fmap f e). -Proof. - revert f. - induction K as [| ?? IH - | ?? IH - | ?? IH - | ??? IH - | ???? IH - | ??? IH - | ?? IH - | ??? IH]; - intros f; term_simpl; first done; rewrite IH; reflexivity. -Qed. - #[export] Instance SPC_expr : SetPureCore expr := @Var. Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := @@ -389,6 +255,92 @@ Proof. split; intros; [now apply kbind_id | now apply kbind_comp]. Qed. +Definition to_val {S} (e : expr S) : option (val S) := + match e with + | Val v => Some v + | _ => None + end. + +Definition do_natop (op : nat_op) (x y : nat) : nat := + match op with + | Add => plus x y + | Sub => minus x y + | Mult => mult x y + end. + +Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := + match x, y with + | LitV x, LitV y => Some $ LitV $ do_natop n x y + | _,_ => None + end. + +Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := + match K with + | EmptyK => e + | OutputK K => Output (fill K e) + | IfK K e₁ e₂ => If (fill K e) e₁ e₂ + | AppLK K v => App (fill K e) (Val v) + | AppRK e' K => App e' (fill K e) + | NatOpRK op e' K => NatOp op e' (fill K e) + | NatOpLK op K v => NatOp op (fill K e) (Val v) + | ThrowLK K e' => Throw (fill K e) e' + | ThrowRK v K => Throw (Val v) (fill K e) + end. + +Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) + : fmap f (fill K e) = fill (fmap f K) (fmap f e). +Proof. + revert f. + induction K as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH + | ?? IH + | ??? IH]; + intros f; term_simpl; first done; rewrite IH; reflexivity. +Qed. + +Declare Scope syn_scope. +Declare Scope ectx_scope. +Delimit Scope syn_scope with syn. +Delimit Scope ectx_scope with ectx. + +Coercion Val : val >-> expr. +Coercion App : expr >-> Funclass. +Coercion AppLK : ectx >-> Funclass. +Coercion AppRK : expr >-> Funclass. + +Notation of_val := Val (only parsing). + +Notation "+" := (Add) : syn_scope. +Notation "-" := (Sub) : syn_scope. +Notation "×" := (Mult) : syn_scope. +Notation "'⟨' e₁ op e₂ '⟩'" := (NatOp op e₁ e₂) (at level 45, right associativity) : syn_scope. +Notation "'if' e₁ 'then' e₂ 'else' e₃" := (If e₁ e₂ e₃) : syn_scope. +Notation "'#' n" := (LitV n) (at level 60) : syn_scope. +Notation "'input'" := (Input) : syn_scope. +Notation "'output' e" := (Output e) (at level 60) : syn_scope. +Notation "'rec' e" := (RecV e) (at level 60) : syn_scope. +Notation "'callcc' e" := (Callcc e) (at level 60) : syn_scope. +Notation "'throw' e₁ e₂" := (Throw e₁ e₂) (at level 60) : syn_scope. +Notation "'cont' K" := (ContV K) (at level 60) : syn_scope. + +Notation "□" := (EmptyK) : ectx_scope. +Notation "'⟨' e₁ op K '⟩ᵣ'" := (NatOpRK op e₁ K) (at level 45, right associativity) : ectx_scope. +Notation "'⟨' K op v₂ '⟩ₗ'" := (NatOpLK op K v₂) (at level 45, right associativity) : ectx_scope. +Notation "'if' K 'then' e₂ 'else' e₃" := (IfK K e₂ e₃) : ectx_scope. +Notation "'output' K" := (OutputK K) (at level 60) : ectx_scope. +Notation "'throwₗ' K e₂" := (ThrowLK K e₂) (at level 60) : ectx_scope. +Notation "'throwᵣ' e₁ K" := (ThrowRK e₁ K) (at level 60) : ectx_scope. +Notation "'$' fn" := (set_pure_resolver fn) (at level 60) : syn_scope. +Notation "K '[' e ']'" := (fill K e) (at level 60) : syn_scope. + +Example test1 : expr (inc ∅) := ($ 0)%syn. +Example test2 : val ∅ := (rec ($ 1))%syn. +Example test3 : expr ∅ := (callcc ($ 0))%syn. + (*** Operational semantics *) Record state := State { diff --git a/vendor/Binding/Inc.v b/vendor/Binding/Inc.v index 515ae5e..508f545 100644 --- a/vendor/Binding/Inc.v +++ b/vendor/Binding/Inc.v @@ -1,4 +1,6 @@ Require Import Utf8. +Require Import Eqdep. +Require Import Eqdep_dec. Notation "∅" := Empty_set. @@ -23,3 +25,14 @@ Fixpoint nth_inc n {A : Set} : Nat.iter n inc (inc A) := end. Notation "& n" := (nth_inc n) (at level 5). + +Module IncEqDec (T : DecidableSet) <: DecidableSet. + Definition U := inc T.U. + + Lemma eq_dec : ∀ x y:U, {x = y} + {x <> y}. + Proof. + intros [| x] [| y]; [left; reflexivity | right; inversion 1 | right; inversion 1 |]. + destruct (T.eq_dec x y) as [-> | H2]; [left; reflexivity | right]. + inversion 1; subst; contradiction. + Qed. +End IncEqDec. diff --git a/vendor/Binding/Resolver.v b/vendor/Binding/Resolver.v new file mode 100644 index 0000000..8811e1c --- /dev/null +++ b/vendor/Binding/Resolver.v @@ -0,0 +1,37 @@ +Require Import Binding.Set Binding.Inc. +Require Import Init.Nat. + +(* only fin_S_inv is really needed *) +Require Import stdpp.fin. + +Section ResolutionDeBruijn. + Class Resolver (D : Set) (n : nat) := { resolve : fin n -> D }. + + Global Instance ResolverEmpty : Resolver Empty_set 0. + Proof. + constructor. + apply fin_0_inv. + Defined. + + Global Instance ResolverInc {D : Set} (n : nat) `{Resolver D n} : Resolver (inc D) (S n). + Proof. + constructor. + apply fin_S_inv. + - apply VZ. + - intros x; apply VS, resolve, x. + Defined. + + Global Instance ResolverIncNEmpty {n : nat} : Resolver (iter n inc Empty_set) n. + Proof. + induction n; apply _. + Defined. + +End ResolutionDeBruijn. + +Section SetPureResolver. + Context {F : Set → Type} + {SPC : SetPureCore F}. + + Definition set_pure_resolver {D} {n} `{Resolver D n} (fn : fin n) : F D := (@set_pure _ _ D (resolve fn)). + +End SetPureResolver. From 06717bc1d5458a4ba4d0b01cba4fb1773ea34b0f Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 8 Dec 2023 14:03:38 +0100 Subject: [PATCH 051/114] Refactor compat_recv --- theories/input_lang_callcc/logrel.v | 64 ++++++++++------------------- 1 file changed, 22 insertions(+), 42 deletions(-) diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 230942c..c7e776a 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -270,49 +270,29 @@ Section logrel. Opaque IT_of_V. iApply logrel_of_val; term_simpl. iExists _. iSplit. - { Transparent IT_of_V. done. } + { iPureIntro. apply into_val. } iModIntro. iLöb as "IH". iIntros (αv v) "#Hw". rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. - iIntros (κ K) "#HK". - iIntros (σ) "Hs". - rewrite hom_tick. - iApply wp_tick. - iNext. - unfold f. - Opaque extend_scope. - Opaque IT_of_V. - simpl. pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V αv))). - pose (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) - ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)))%bind : - inc (inc S) [⇒] Empty_set). - iSpecialize ("H" $! ss' γ' with "[]"); last first. - - iSpecialize ("H" $! κ K with "HK"). - unfold ss'. - iSpecialize ("H" $! σ with "Hs"). - iApply (wp_wand with "[$H] []"). - iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". - destruct m as [m m']. - iModIntro. - iExists ((Nat.add 1 m), m'), v'', σ''. iFrame "H". - iPureIntro. - eapply (prim_steps_app (1, 0) (m, m')); eauto. - term_simpl. - eapply prim_step_steps. - eapply Ectx_step; [reflexivity | reflexivity |]. - subst γ'. - rewrite -!bind_bind_comp'. - econstructor. - - Transparent extend_scope. - iIntros (x'); destruct x' as [| [| x']]. - + term_simpl. - iModIntro. - by iApply logrel_of_val. - + term_simpl. - iModIntro. - iRewrite "Hf". + set (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) + ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)))%bind). + rewrite /logrel. + iSpecialize ("H" $! ss' γ'). + set (γ1 := ((γ ↑) ↑)%bind). + iApply (logrel_head_step_pure_ectx _ EmptyK _ + ((rec bind γ1 e)%syn v) + (Tick (later_car (Next f) (IT_of_V αv))) + (logrel_val τ2) with "[]"); last first. + + rewrite {2}/ss'. rewrite /f. + iIntros (κ K) "#HK". iIntros (σ) "Hs". + rewrite hom_tick. iApply wp_tick. iNext. + iApply "H"; eauto. + rewrite /ss' /γ'. + iIntros (x'); destruct x' as [| [| x']]; term_simpl; iModIntro. + * by iApply logrel_of_val. + * iRewrite "Hf". iIntros (κ' K') "#HK'". iApply "HK'". simpl. @@ -321,10 +301,10 @@ Section logrel. iSplit; first done. iModIntro. iApply "IH". - + iModIntro. - subst γ'. - term_simpl. - iApply "Henv". + * iApply "Henv". + + term_simpl. intros. subst γ1 γ'. + rewrite -!bind_bind_comp'. + apply BetaS. Qed. Program Definition IFSCtx_HOM α β : HOM := exist _ (λne x, IFSCtx α β x) _. From 43a90f47b290791cc5a6328d2f993f739a65df5f Mon Sep 17 00:00:00 2001 From: Kaptch Date: Fri, 8 Dec 2023 22:51:03 +0100 Subject: [PATCH 052/114] notations --- theories/input_lang_callcc/interp.v | 33 +-- theories/input_lang_callcc/lang.v | 278 +++++++++++++++++++---- theories/input_lang_callcc/logrel.v | 339 ++++++++++++++++------------ 3 files changed, 436 insertions(+), 214 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index f33650a..d242711 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -104,7 +104,6 @@ Section constructors. Notation IT := (IT E A). Notation ITV := (ITV E A). - Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) (subEff_ins (F:=ioE) (op:=(inl ())) ()) @@ -142,16 +141,10 @@ Section constructors. (k ◎ (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1). Solve All Obligations with solve_proper. - (* Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := *) - (* λne f, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) *) - (* (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) f) *) - (* (λne o, (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1 o). *) - (* Solve All Obligations with solve_proper. *) Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := λne f, CALLCC_ f (idfun). Solve Obligations with solve_proper. - Lemma hom_CALLCC_ k e f `{!IT_hom f} : f (CALLCC_ e k) ≡ CALLCC_ e (laterO_map (OfeMor f) ◎ k). Proof. @@ -160,7 +153,6 @@ Section constructors. f_equiv. by intro. Qed. - Program Definition THROW : IT -n> (laterO (IT -n> IT)) -n> IT := λne e k, Vis (E:=E) (subEff_opid (inr (inr (inr (inl ()))))) (subEff_ins (F:=ioE) (op:=(inr (inr (inr (inl ()))))) @@ -413,25 +405,18 @@ Section interp. Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := λne env, (Fun (Next (λne x, Tau (laterO_map (K env) (Next x))))). - Solve All Obligations with solve_proper. - Next Obligation. - intros. - solve_proper_prepare. - repeat f_equiv. - intro; simpl. - by repeat f_equiv. - Qed. + Solve All Obligations with solve_proper_please. Program Definition interp_applk {A} (K : A -n> (IT -n> IT)) - (q : A -n> IT) + (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_app (λne env, K env t) q env. Solve All Obligations with solve_proper. Program Definition interp_apprk {A} (q : A -n> IT) - (K : A -n> (IT -n> IT)) + (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_app q (λne env, K env t) env. Solve All Obligations with solve_proper. @@ -503,11 +488,11 @@ Section interp. (* Open Scope syn_scope. *) - (* Example callcc_ex : expr Empty_set := *) - (* NatOp + (# 1) (Callcc (NatOp + (# 1) (Throw (# 2) (Var VZ)))). *) + (* Example callcc_ex : expr ∅ := *) + (* NatOp + (# 1) (Callcc (NatOp + (# 1) (Throw (# 2) ($ 0)))). *) (* Eval cbn in callcc_ex. *) (* Eval cbn in interp_expr callcc_ex *) - (* (λne (x : leibnizO Empty_set), match x with end). *) + (* (λne (x : leibnizO ∅), match x with end). *) Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) : AsVal (interp_val v D). @@ -690,7 +675,7 @@ Section interp. - destruct e; simpl; intros ?; simpl. + reflexivity. + repeat f_equiv; by apply interp_ectx_subst. - + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. @@ -811,7 +796,7 @@ Section interp. #[global] Instance interp_ectx_hom_throwr {S} (K : ectx S) (v : val S) env : IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (ThrowRK v K)%ectx env). + IT_hom (interp_ectx (ThrowRK v K) env). Proof. intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - pose proof (interp_val_asval v (D := env)). @@ -852,7 +837,7 @@ Section interp. #[global] Instance interp_ectx_hom_throwl {S} (K : ectx S) (e : expr S) env : IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (ThrowLK K e)%ectx env). + IT_hom (interp_ectx (ThrowLK K e) env). Proof. intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; [by rewrite !hom_tick| | by rewrite !hom_err]. rewrite !hom_vis. diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index 6f488fa..e9aa176 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -302,45 +302,6 @@ Proof. intros f; term_simpl; first done; rewrite IH; reflexivity. Qed. -Declare Scope syn_scope. -Declare Scope ectx_scope. -Delimit Scope syn_scope with syn. -Delimit Scope ectx_scope with ectx. - -Coercion Val : val >-> expr. -Coercion App : expr >-> Funclass. -Coercion AppLK : ectx >-> Funclass. -Coercion AppRK : expr >-> Funclass. - -Notation of_val := Val (only parsing). - -Notation "+" := (Add) : syn_scope. -Notation "-" := (Sub) : syn_scope. -Notation "×" := (Mult) : syn_scope. -Notation "'⟨' e₁ op e₂ '⟩'" := (NatOp op e₁ e₂) (at level 45, right associativity) : syn_scope. -Notation "'if' e₁ 'then' e₂ 'else' e₃" := (If e₁ e₂ e₃) : syn_scope. -Notation "'#' n" := (LitV n) (at level 60) : syn_scope. -Notation "'input'" := (Input) : syn_scope. -Notation "'output' e" := (Output e) (at level 60) : syn_scope. -Notation "'rec' e" := (RecV e) (at level 60) : syn_scope. -Notation "'callcc' e" := (Callcc e) (at level 60) : syn_scope. -Notation "'throw' e₁ e₂" := (Throw e₁ e₂) (at level 60) : syn_scope. -Notation "'cont' K" := (ContV K) (at level 60) : syn_scope. - -Notation "□" := (EmptyK) : ectx_scope. -Notation "'⟨' e₁ op K '⟩ᵣ'" := (NatOpRK op e₁ K) (at level 45, right associativity) : ectx_scope. -Notation "'⟨' K op v₂ '⟩ₗ'" := (NatOpLK op K v₂) (at level 45, right associativity) : ectx_scope. -Notation "'if' K 'then' e₂ 'else' e₃" := (IfK K e₂ e₃) : ectx_scope. -Notation "'output' K" := (OutputK K) (at level 60) : ectx_scope. -Notation "'throwₗ' K e₂" := (ThrowLK K e₂) (at level 60) : ectx_scope. -Notation "'throwᵣ' e₁ K" := (ThrowRK e₁ K) (at level 60) : ectx_scope. -Notation "'$' fn" := (set_pure_resolver fn) (at level 60) : syn_scope. -Notation "K '[' e ']'" := (fill K e) (at level 60) : syn_scope. - -Example test1 : expr (inc ∅) := ($ 0)%syn. -Example test2 : val ∅ := (rec ($ 1))%syn. -Example test3 : expr ∅ := (callcc ($ 0))%syn. - (*** Operational semantics *) Record state := State { @@ -476,8 +437,8 @@ Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) e1 = fill K e1' → e2 = fill K e2' → head_step e1' σ1 e2' σ2 K n → prim_step e1 σ1 e2 σ2 n | Throw_step e1 σ e2 (K : ectx S) v K' : - e1 = (fill K (Throw (of_val v) (ContV K'))) -> - e2 = (fill K' v) -> + e1 = (fill K (Throw (Val v) (Val (ContV K')))) -> + e2 = (fill K' (Val v)) -> prim_step e1 σ e2 σ (2, 0). Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : @@ -522,6 +483,15 @@ Proof. by constructor. Qed. +Lemma prim_step_steps_steps {S} (e1 e2 e3 : expr S) σ1 σ2 σ3 nm1 nm2 nm3 : + nm3 = (plus nm1.1 nm2.1, plus nm1.2 nm2.2) -> + prim_step e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 -> prim_steps e1 σ1 e3 σ3 nm3. +Proof. + intros -> H G. + eapply prim_steps_app; last apply G. + apply prim_step_steps, H. +Qed. + (*** Type system *) Inductive ty := @@ -566,3 +536,229 @@ with typed_val {S : Set} (Γ : S -> ty) : val S → ty → Prop := typed (Γ ▹ (Tarr τ1 τ2) ▹ τ1) e τ2 → typed_val Γ (RecV e) (Tarr τ1 τ2) . + +Declare Scope syn_scope. +Delimit Scope syn_scope with syn. + +Coercion Val : val >-> expr. + +Coercion App : expr >-> Funclass. +Coercion AppLK : ectx >-> Funclass. +Coercion AppRK : expr >-> Funclass. + +Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. + +Arguments __asSynExpr {_} {_} {_}. + +Global Instance AsSynExprValue : AsSynExpr val := { + __asSynExpr _ v := Val v + }. +Global Instance AsSynExprExpr : AsSynExpr expr := { + __asSynExpr _ e := e + }. + +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) := { + __op e₁ op e₂ := NatOp op (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance OpNotationLK {S : Set} : OpNotation (ectx S) (nat_op) (val S) (ectx S) := { + __op K op v := NatOpLK op K v + }. + +Global Instance OpNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : OpNotation (F S) (nat_op) (ectx S) (ectx S) := { + __op e op K := NatOpRK op (__asSynExpr e) K + }. + +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) := { + __if e₁ e₂ e₃ := If (__asSynExpr e₁) (__asSynExpr e₂) (__asSynExpr e₃) + }. + +Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : IfNotation (ectx S) (F S) (G S) (ectx S) := { + __if K e₂ e₃ := IfK K (__asSynExpr e₂) (__asSynExpr e₃) + }. + +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 (ectx S) (ectx S) := { + __output K := OutputK K + }. + +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 (ectx S) (F S) (ectx S) := { + __throw K e₂ := ThrowLK K (__asSynExpr e₂) + }. + +Global Instance ThrowNotationRK {S : Set} : ThrowNotation (val S) (ectx S) (ectx 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) := { + __app e₁ e₂ := App (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance AppNotationLK {S : Set} : AppNotation (ectx S) (val S) (ectx S) := { + __app K v := AppLK K v + }. + +Global Instance AppNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (ectx S) (ectx S) := { + __app e K := AppRK (__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. +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 "'callcc' e" := (Callcc 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. + +Definition LamV {S : Set} (e : expr (inc S)) : val S := + RecV (shift e). + +Notation "'λ' . 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 test3 : expr ∅ := (callcc ($ 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) : ℕ). +End SynExamples. + +Definition compute_head_step {S} (e : expr S) (σ : state) (K : ectx S) : option (expr S * state * (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))), σ, (1,0)) + | Input => + let '(n, σ') := update_input σ in + Some ((Val (LitV n)), σ', (1, 1)) + | Output (Val (LitV n)) => + let σ' := update_output n σ in + Some ((Val (LitV 0)), σ', (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), σ, (0, 0))) None res + | (If (Val (LitV n)) e1 e2) => + if (decide (0 < n)) + then Some (e1, σ, (0, 0)) + else + if (decide (n = 0)) + then Some (e2, σ, (0, 0)) + else None + | (Callcc e) => Some ((subst (Inc := inc) e (Val (ContV K))), σ, (1, 1)) + | _ => None + end. + +Lemma head_step_reflect {S : Set} (e : expr S) (σ : state) (K : ectx S) + : option_reflect (fun '(e', σ', nm) => head_step e σ e' σ' K 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. + do 2 constructor. +Qed. diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index d89974f..980eccd 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -6,6 +6,7 @@ Require Import gitrees.lang_generic_sem. Require Import Binding.Lib Binding.Set Binding.Env. Open Scope stdpp_scope. +Open Scope syn_scope. Section logrel. Context {sz : nat}. @@ -22,6 +23,15 @@ Section logrel. Canonical Structure valO S := leibnizO (val S). Canonical Structure ectxO S := leibnizO (ectx S). + Class LogRelNotation (A : Set -> Type) (B : Type) (C : Set -> Type) := { __logrel : ∀ (S : Set), (A S) -> B -> (C S) -> iProp }. + + Notation "T '@' a '≺' b" := (__logrel _ T a b) (at level 98) : bi_scope. + + Notation "⟦ e ⟧ₑ ρ" := (interp_expr rs e ρ) (at level 200). + Notation "⟦ v ⟧ᵥ ρ" := (interp_val rs v ρ) (at level 200). + Notation "⟦ K ⟧ₖ ρ" := (interp_ectx rs K ρ) (at level 200). + Notation "⟦ S ⟧ᵨ" := (@interp_scope F natO _ S) (at level 200). + Notation "'WP' α {{ β , Φ } }" := (wp rs α notStuck ⊤ (λ β, Φ)) (at level 20, α, Φ at level 200, format "'WP' α {{ β , Φ } }") : bi_scope. @@ -39,6 +49,8 @@ Section logrel. WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ ∗ logrel_nat βv v ∗ has_substate σ' }})%I. + Notation "α ↓ e" := (obs_ref α e) (at level 100) : bi_scope. + Definition HOM : ofe := @sigO (IT -n> IT) IT_hom. Global Instance HOM_hom (κ : HOM) : IT_hom (`κ). @@ -47,15 +59,144 @@ Section logrel. Qed. Definition logrel_ectx {S} V (κ : HOM) (K : ectx S) : iProp := - (□ ∀ (βv : ITV) (v : val S), V βv v -∗ obs_ref (`κ (IT_of_V βv)) (fill K (Val v)))%I. + (□ ∀ (βv : ITV) (v : val S), V βv v -∗ (`κ (IT_of_V βv)) ↓ (K ⟪ Val v ⟫))%I. + + Instance LogRelNotationECtx : LogRelNotation (fun S => ITV → val S → iPropI Σ) HOM ectx := { + __logrel S V κ K := logrel_ectx V κ K + }. + + 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. + + Program Definition id_HOM : HOM := exist _ idfun _. + Next Obligation. + apply _. + Qed. + + Program Definition AppRSCtx_HOM {S : Set} + (α : ⟦ S ⟧ᵨ -n> IT) + (env : ⟦ S ⟧ᵨ) + : HOM := exist _ (interp_apprk rs α (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition AppLSCtx_HOM {S : Set} + (β : IT) (env : ⟦ S ⟧ᵨ) + (Hv : AsVal β) + : HOM := exist _ (interp_applk rs (λne env, idfun) (constO β) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition OutputSCtx_HOM {S : Set} + (env : ⟦ S ⟧ᵨ) + : HOM := exist _ (interp_outputk rs (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition ThrowLSCtx_HOM {S : Set} + (α : ⟦ S ⟧ᵨ -n> IT) + (env : ⟦ S ⟧ᵨ) + : HOM := exist _ (interp_throwlk rs (λne env, idfun) α env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition ThrowRSCtx_HOM {S : Set} + (β : IT) (env : ⟦ S ⟧ᵨ) + (Hv : AsVal β) + : HOM := exist _ (interp_throwrk rs (constO β) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - solve_proper_prepare. + destruct Hv as [? <-]. + rewrite ->2 get_val_ITV. + simpl. + by f_equiv. + - destruct Hv as [? <-]. + rewrite ->2 get_val_ITV. + simpl. + rewrite get_fun_tick. + f_equiv. + - destruct Hv as [x Hv]. + rewrite <- Hv. + rewrite -> get_val_ITV. + simpl. + rewrite get_fun_vis. + repeat f_equiv. + intro; simpl. + rewrite <- Hv. + rewrite -> get_val_ITV. + simpl. + f_equiv. + - destruct Hv as [? <-]. + rewrite get_val_ITV. + simpl. + rewrite get_fun_err. + reflexivity. + Qed. + + Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) + (α : ⟦ S ⟧ᵨ -n> IT) (env : ⟦ 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 : ⟦ S ⟧ᵨ) + (Hv : AsVal α) + : HOM := exist _ (interp_natoplk rs op (λne env, idfun) (constO α) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition IFSCtx_HOM α β : HOM := exist _ (λne x, IFSCtx α β x) _. + Next Obligation. + intros; simpl. + apply _. + Qed. Definition logrel_expr {S} V (α : IT) (e : expr S) : iProp := (∀ (κ : HOM) (K : ectx S), - logrel_ectx V κ K -∗ obs_ref (`κ α) (fill K e))%I. + V @ κ ≺ K -∗ (`κ α) ↓ (K ⟪ e ⟫))%I. + + Class AsSemExpr (F : Type) := { __asSemExpr : F -> IT }. + + Arguments __asSemExpr {_} {_}. + + Global Instance AsSemExprIT : AsSemExpr IT := { + __asSemExpr e := e + }. + Global Instance AsSemExprITV : AsSemExpr ITV := { + __asSemExpr v := IT_of_V v + }. + + Instance LogRelNotationExpr {F : Set -> Type} {G : Type} `{AsSynExpr F} `{AsSemExpr G} : LogRelNotation (fun S => ITV → val S → iPropI Σ) G F := { + __logrel S V α e := logrel_expr V (__asSemExpr α) (__asSynExpr e) + }. Definition logrel_arr {S} V1 V2 (βv : ITV) (vf : val S) : iProp := (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ - logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. + V2 @ APP' (Fun f) (IT_of_V αv) ≺ App (Val vf) (Val v))%I. Global Instance denot_cont_ne (κ : IT -n> IT) : NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). @@ -66,7 +207,7 @@ Section logrel. Definition logrel_cont {S} V (βv : ITV) (v : val S) : iProp := (∃ (κ : HOM) K, (IT_of_V βv) ≡ (Fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))) ∧ ⌜v = ContV K⌝ - ∧ □ logrel_ectx V κ K)%I. + ∧ □ (V @ κ ≺ K))%I. Fixpoint logrel_val {S} (τ : ty) : ITV → (val S) → iProp := match τ with @@ -75,6 +216,8 @@ Section logrel. | Tcont τ => logrel_cont (logrel_val τ) end. + Notation "⟦ τ ⟧ₜ" := (logrel_val τ) (at level 200). + Definition logrel {S} (τ : ty) : IT → (expr S) → iProp := logrel_expr (logrel_val τ). @@ -174,16 +317,17 @@ Section logrel. Qed. Lemma logrel_of_val {S} τ αv (v : val S) : - logrel_val τ αv v -∗ logrel τ (IT_of_V αv) (Val v). + (⟦ τ ⟧ₜ) αv v -∗ logrel τ (IT_of_V αv) (Val v). Proof. - iIntros "H1". iIntros (κ K) "HK". + iIntros "H1". + iIntros (κ K) "HK". iIntros (σ) "Hs". by iApply ("HK" $! αv v with "[$H1] [$Hs]"). Qed. Lemma logrel_head_step_pure_ectx {S} n K (κ : HOM) (e' e : expr S) α V : (∀ σ K, head_step e σ e' σ K (n, 0)) → - ⊢ logrel_expr V (`κ α) (fill K e') -∗ logrel_expr V (`κ α) (fill K e). + ⊢ V @ (`κ α) ≺ (K ⟪ e' ⟫) -∗ V @ (`κ α) ≺ (K ⟪ e ⟫). Proof. intros Hpure. iIntros "H". @@ -201,20 +345,8 @@ Section logrel. eapply Ectx_step; last apply Hpure; done. 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 logrel_bind {S} (f : HOM) (K : ectx S) - e α τ1 : + Lemma obs_ref_bind {S} (f : HOM) (K : ectx S) + (e : expr S) α τ1 : ⊢ logrel τ1 α e -∗ logrel_ectx (logrel_val τ1) f K -∗ obs_ref (`f α) (fill K e). @@ -233,7 +365,7 @@ Section logrel. Definition ssubst2_valid {S : Set} (Γ : S -> ty) - (ss : @interp_scope F natO _ S) + (ss : ⟦ S ⟧ᵨ) (γ : S [⇒] Empty_set) : iProp := (∀ x, □ logrel (Γ x) (ss x) (γ x))%I. @@ -241,9 +373,9 @@ Section logrel. Definition logrel_valid {S : Set} (Γ : S -> ty) (e : expr S) - (α : @interp_scope F natO _ S -n> IT) + (α : ⟦ S ⟧ᵨ -n> IT) (τ : ty) : iProp := - (□ ∀ (ss : @interp_scope F natO _ S) + (□ ∀ (ss : ⟦ S ⟧ᵨ) (γ : S [⇒] Empty_set), ssubst2_valid Γ ss γ → logrel τ (α ss) (bind γ e))%I. @@ -329,12 +461,6 @@ Section logrel. iApply "Hss". Qed. - Program Definition IFSCtx_HOM α β : HOM := exist _ (λne x, IFSCtx α β x) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - Lemma compat_if {S : Set} (Γ : S -> ty) (e0 e1 e2 : expr S) α0 α1 α2 τ : ⊢ logrel_valid Γ e0 α0 Tnat -∗ logrel_valid Γ e1 α1 τ -∗ @@ -344,22 +470,22 @@ Section logrel. iIntros "#H0 #H1 #H2". iModIntro. iIntros (ss γ) "#Hss". - simpl. + iEval (term_simpl). pose (κ' := (IFSCtx_HOM (α1 ss) (α2 ss))). assert ((IF (α0 ss) (α1 ss) (α2 ss)) = ((`κ') (α0 ss))) as ->. { reflexivity. } - term_simpl. iIntros (κ K) "#HK". - assert ((`κ) ((IFSCtx (α1 ss) (α2 ss)) (α0 ss)) = ((`κ) ◎ (`κ')) (α0 ss)) as ->. + assert ((`κ) ((`κ') (α0 ss)) = ((`κ) ◎ (`κ')) (α0 ss)) as ->. { reflexivity. } pose (sss := (HOM_compose κ κ')). assert ((`κ ◎ `κ') = (`sss)) as ->. { reflexivity. } - assert (fill K (if bind γ e0 then bind γ e1 else bind γ e2)%syn = fill (ectx_compose K (IfK EmptyK (bind γ e1) (bind γ e2))) (bind γ e0)) as ->. - { rewrite -fill_comp. + assert (fill K (If (bind γ e0) (bind γ e1) (bind γ e2))%syn = fill (ectx_compose K (IfK EmptyK (bind γ e1) (bind γ e2))) (bind γ e0)) as ->. + { + rewrite -fill_comp. reflexivity. } - iApply (logrel_bind with "[H0] [H1 H2]"). + iApply (obs_ref_bind with "[H0] [H1 H2]"). - by iApply "H0". - iIntros (βv v). iModIntro. iIntros "#HV". term_simpl. @@ -443,23 +569,6 @@ Section logrel. assumption. Qed. - Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) - (α : @interp_scope F natO _ S -n> IT) (env : @interp_scope F natO _ 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 natO _ S) - (Hv : AsVal α) - : HOM := exist _ (interp_natoplk rs op (λne env, idfun) (constO α) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - Lemma compat_natop {S : Set} (Γ : S -> ty) e1 e2 α1 α2 op : ⊢ logrel_valid Γ e1 α1 Tnat -∗ logrel_valid Γ e2 α2 Tnat -∗ @@ -482,7 +591,7 @@ Section logrel. { rewrite -fill_comp. reflexivity. } - iApply (logrel_bind with "[H1] [H2]"). + iApply (obs_ref_bind with "[H1] [H2]"). - by iApply "H2". - iIntros (βv v). iModIntro. iIntros "(%n1 & #HV & ->)". term_simpl. @@ -502,7 +611,7 @@ Section logrel. { rewrite -fill_comp. reflexivity. } - iApply (logrel_bind with "[H1] [H2]"). + iApply (obs_ref_bind with "[H1] [H2]"). + by iApply "H1". + subst sss κ'. term_simpl. @@ -541,51 +650,6 @@ Section logrel. reflexivity. Qed. - Program Definition ThrowLSCtx_HOM {S : Set} - (α : @interp_scope F natO _ S -n> IT) - (env : @interp_scope F natO _ S) - : HOM := exist _ ((interp_throwlk rs (λne env, idfun) α env)) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - - Program Definition ThrowRSCtx_HOM {S : Set} - (β : IT) (env : @interp_scope F natO _ S) - (Hv : AsVal β) - : HOM := exist _ (interp_throwrk rs (constO β) (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - solve_proper_prepare. - destruct Hv as [? <-]. - rewrite ->2 get_val_ITV. - simpl. - by f_equiv. - - destruct Hv as [? <-]. - rewrite ->2 get_val_ITV. - simpl. - rewrite get_fun_tick. - f_equiv. - - destruct Hv as [x Hv]. - rewrite <- Hv. - rewrite -> get_val_ITV. - simpl. - rewrite get_fun_vis. - repeat f_equiv. - intro; simpl. - rewrite <- Hv. - rewrite -> get_val_ITV. - simpl. - f_equiv. - - destruct Hv as [? <-]. - rewrite get_val_ITV. - simpl. - rewrite get_fun_err. - reflexivity. - Qed. - - Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β e e' : ⊢ logrel_valid Γ e α τ -∗ logrel_valid Γ e' β (Tcont τ) -∗ @@ -608,7 +672,7 @@ Section logrel. { rewrite -fill_comp. reflexivity. } - iApply logrel_bind; first by iApply "H1". + iApply obs_ref_bind; first by iApply "H1". iIntros (βv v). iModIntro. iIntros "#Hv". Transparent interp_throw. simpl. @@ -621,7 +685,7 @@ Section logrel. assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) ≡ ((`κ'') (β ss))) as ->. { - subst κ''. simpl. by rewrite get_val_ITV. + subst κ''. simpl. by rewrite get_val_ITV. } assert ((`κ) ((`κ'') (β ss)) = ((`κ) ◎ (`κ'')) (β ss)) as ->. { reflexivity. } @@ -632,7 +696,7 @@ Section logrel. { rewrite -fill_comp. reflexivity. } - iApply logrel_bind; first by iApply "H2". + iApply obs_ref_bind; first by iApply "H2". iIntros (βv' v'). iModIntro. iIntros "#Hv'". Transparent interp_throw. simpl. @@ -750,14 +814,6 @@ Section logrel. constructor. Qed. - Program Definition OutputSCtx_HOM {S : Set} - (env : @interp_scope F natO _ S) - : HOM := exist _ ((interp_outputk rs (λne env, idfun) env)) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - Lemma compat_output {S} Γ (e: expr S) α : ⊢ logrel_valid Γ e α Tnat -∗ logrel_valid Γ (Output e) (interp_output rs α) Tnat. @@ -778,7 +834,7 @@ Section logrel. { rewrite -fill_comp. reflexivity. } - iApply logrel_bind; first by iApply "H". + iApply obs_ref_bind; first by iApply "H". iIntros (βv v). iModIntro. iIntros "#Hv". iDestruct "Hv" as (n) "[Hb ->]". iRewrite "Hb". simpl. @@ -809,24 +865,6 @@ Section logrel. constructor. reflexivity. Qed. - - Program Definition AppRSCtx_HOM {S : Set} - (α : @interp_scope F natO _ S -n> IT) - (env : @interp_scope F natO _ 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 natO _ S) - (Hv : AsVal β) - : HOM := exist _ (interp_applk rs (λne env, idfun) (constO β) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ @@ -854,9 +892,9 @@ Section logrel. assert ((`κ ◎ `κ') = (`sss)) as ->. { reflexivity. } rewrite fill_comp. - iApply logrel_bind; first by iApply "H2". + iApply obs_ref_bind; first by iApply "H2". subst sss κ'. - iIntros (βv v). iModIntro. iIntros "#HV". + iIntros (βv v). iModIntro. iIntros "#HV". unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. rewrite -fill_comp. simpl. @@ -864,12 +902,12 @@ Section logrel. { reflexivity. } pose (κ'' := (AppLSCtx_HOM (IT_of_V βv) ss _)). assert (((`κ) (α1 ss ⊙ (IT_of_V βv))) = (((`κ) ◎ (`κ'')) (α1 ss))) as ->. - { reflexivity. } + { reflexivity. } pose (sss := (HOM_compose κ κ'')). assert ((`κ ◎ `κ'') = (`sss)) as ->. { reflexivity. } rewrite fill_comp. - iApply logrel_bind; first by iApply "H1". + iApply obs_ref_bind; first by iApply "H1". iIntros (βv' v'). iModIntro. iIntros "#HV'". subst sss κ''. rewrite -fill_comp. @@ -880,8 +918,20 @@ Section logrel. iSpecialize ("HV'" $! βv v with "HV"). iApply "HV'"; iApply "HK". Qed. - - (* TODO: finish throw + refactor *) + + Lemma compat_nat {S : Set} (Γ : S -> ty) n : ⊢ logrel_valid Γ (# n) (interp_val rs (# n)) ℕ%typ. + Proof. + iIntros (ss γ). iModIntro. iIntros "#Hss". + term_simpl. + iIntros (κ K) "#HK". + iSpecialize ("HK" $! (RetV n) (LitV n)). + rewrite IT_of_V_Ret. + iApply "HK". + simpl. + unfold logrel_nat. + iExists n; eauto. + Qed. + Lemma fundamental {S : Set} (Γ : S -> ty) τ e : typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ with fundamental_val {S : Set} (Γ : S -> ty) τ v : @@ -910,15 +960,7 @@ Section logrel. + iApply compat_callcc. iApply IHtyped. - induction 1; simpl. - + iIntros (ss γ). iModIntro. iIntros "#Hss". - term_simpl. - iIntros (κ K) "#HK". - iSpecialize ("HK" $! (RetV n) (LitV n)). - rewrite IT_of_V_Ret. - iApply "HK". - simpl. - unfold logrel_nat. - iExists n; eauto. + + iApply compat_nat. + iApply compat_recV. by iApply fundamental. Qed. @@ -939,7 +981,7 @@ Require Import gitrees.gitree.greifiers. Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, - (True ⊢ logrel rs Tnat α e)%I) → + (⊢ logrel rs Tnat α e)%I) → ssteps (gReifiers_sReifier rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. @@ -969,7 +1011,7 @@ Proof. iPureIntro. rewrite Hfoo. unfold ϕ. eauto. } iIntros "[_ Hs]". - iPoseProof (Hlog with "[//]") as "Hlog". + iPoseProof (Hlog) as "Hlog". iAssert (has_substate σ) with "[Hs]" as "Hs". { unfold has_substate, has_full_state. assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ())) ≡ @@ -1007,7 +1049,7 @@ Qed. Program Definition ı_scope : @interp_scope (gReifiers_ops rs) natO _ Empty_set := λne (x : ∅), match x with end. Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : - typed □ e Tnat → + (empty_env ⊢ e : Tnat)%typing → ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. Proof. @@ -1018,7 +1060,6 @@ Proof. iPoseProof (fundamental rs) as "H". { apply Hty. } unfold logrel_valid. - iIntros "_". unshelve iSpecialize ("H" $! ı_scope _ with "[]"). { apply ı%bind. } { iIntros (x); destruct x. } From c0837ca2363c60529a1ac54615831734f9f40d7e Mon Sep 17 00:00:00 2001 From: Kaptch Date: Sun, 10 Dec 2023 01:29:42 +0100 Subject: [PATCH 053/114] ci + bw-comp --- .github/workflows/build.yml | 9 + TODO.md | 6 +- _CoqProject | 26 +- flake.nix | 33 ++- theories/affine_lang/logrel1.v | 147 ++++++++++- theories/affine_lang/logrel2.v | 143 ++++++++++- theories/examples/factorial.v | 11 +- theories/examples/store.v | 85 ++++--- theories/gitree/reductions.v | 117 +++++---- theories/gitree/reify.v | 185 +++++++------- theories/gitree/weakestpre.v | 98 +++++-- theories/input_lang/interp.v | 10 +- theories/input_lang/logpred.v | 69 ++++- theories/input_lang/logrel.v | 50 +++- theories/input_lang_callcc/logpred.v | 365 --------------------------- theories/lang_generic.v | 35 +-- theories/program_logic.v | 62 +++-- 17 files changed, 770 insertions(+), 681 deletions(-) delete mode 100644 theories/input_lang_callcc/logpred.v diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 44b8e6e..4931b29 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -4,6 +4,15 @@ name: Docker CI on: [push, pull_request] jobs: + build_nix: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - uses: cachix/install-nix-action@v24 + with: + github_access_token: ${{ secrets.GITHUB_TOKEN }} + - run: nix build .#coq-artifact + build: runs-on: ubuntu-latest strategy: diff --git a/TODO.md b/TODO.md index b628e04..d76f203 100644 --- a/TODO.md +++ b/TODO.md @@ -1,9 +1,11 @@ # Now - cleanup code + especially implicit arguments, inserted by typeclasses - + resolve variable names + lemmas for logrel -- backward compatibility (input lang, affine lang, examples) + + update opam ci +- backward compatibility + + instances of CtxIndep from individual effects, from sreifiers to greifiers + + last admits - write summary + reifiers changes + non-cps vs cps diff --git a/_CoqProject b/_CoqProject index cfe0f98..2a72fbd 100644 --- a/_CoqProject +++ b/_CoqProject @@ -33,16 +33,16 @@ theories/input_lang_callcc/lang.v theories/input_lang_callcc/interp.v theories/input_lang_callcc/logrel.v -# theories/input_lang/lang.v -# theories/input_lang/interp.v -# theories/input_lang/logpred.v -# theories/input_lang/logrel.v - -# theories/affine_lang/lang.v -# theories/affine_lang/logrel1.v -# theories/affine_lang/logrel2.v - -# theories/examples/store.v -# theories/examples/pairs.v -# theories/examples/while.v -# theories/examples/factorial.v +theories/input_lang/lang.v +theories/input_lang/interp.v +theories/input_lang/logpred.v +theories/input_lang/logrel.v + +theories/affine_lang/lang.v +theories/affine_lang/logrel1.v +theories/affine_lang/logrel2.v + +theories/examples/store.v +theories/examples/pairs.v +theories/examples/while.v +theories/examples/factorial.v diff --git a/flake.nix b/flake.nix index b8c5c45..d2f37bc 100644 --- a/flake.nix +++ b/flake.nix @@ -33,14 +33,27 @@ fi ''; }; - in { - devShell = pkgs.mkShell { - buildInputs = with pkgs; [ - coq - stdpp-dev - iris-dev - coqPkgs.equations - ]; - }; - }); + in { + packages = { + coq-artifact = coqPkgs.mkCoqDerivation { + pname = "coq-artifact"; + version = "main"; + src = ./.; + buildPhase = "make"; + propagatedBuildInputs = [ + stdpp-dev + iris-dev + coqPkgs.equations + ]; + }; + }; + devShell = pkgs.mkShell { + buildInputs = with pkgs; [ + coq + stdpp-dev + iris-dev + coqPkgs.equations + ]; + }; + }); } diff --git a/theories/affine_lang/logrel1.v b/theories/affine_lang/logrel1.v index e2ae89c..a5a1f0b 100644 --- a/theories/affine_lang/logrel1.v +++ b/theories/affine_lang/logrel1.v @@ -69,6 +69,9 @@ Section logrel. Variable (P : A → iProp). Context `{!NonExpansive P}. Local Notation expr_pred := (expr_pred s rs P). + Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. (* interpreting tys *) Program Definition protected (Φ : ITV -n> iProp) : ITV -n> iProp := λne αv, @@ -115,7 +118,7 @@ Section logrel. ⊢ valid1 Ω1 α τ1 -∗ valid1 Ω2 β τ2 -∗ valid1 (tyctx_app Ω1 Ω2) (interp_pair α β ◎ interp_scope_split) (tPair τ1 τ2). - Proof. + Proof using HCI. Opaque pairITV. iIntros "H1 H2". iIntros (αs) "#Hctx Has". @@ -140,7 +143,7 @@ Section logrel. ⊢ valid1 Ω1 α (tPair τ1 τ2) -∗ valid1 (consC τ1 $ consC τ2 Ω2) β τ -∗ valid1 (tyctx_app Ω1 Ω2) (interp_destruct α β ◎ interp_scope_split) τ. - Proof. + Proof using HCI. Opaque pairITV thunked thunkedV projIT1 projIT2. iIntros "H1 H2". iIntros (αs) "#Hctx Has". @@ -207,7 +210,7 @@ Section logrel. Lemma compat_alloc {S} (Ω : tyctx S) α τ: ⊢ valid1 Ω α τ -∗ valid1 Ω (interp_alloc α) (tRef τ). - Proof. + Proof using HCI. iIntros "H". iIntros (αs) "#Hctx Has". iSpecialize ("H" with "Hctx Has"). @@ -225,7 +228,7 @@ Section logrel. ⊢ valid1 Ω1 α (tRef τ) -∗ valid1 Ω2 β τ' -∗ valid1 (tyctx_app Ω1 Ω2) (interp_replace α β ◎ interp_scope_split) (tPair τ (tRef τ')). - Proof. + Proof using HCI. Opaque pairITV. iIntros "H1 H2". iIntros (αs) "#Hctx Has". @@ -266,7 +269,7 @@ Section logrel. Lemma compat_dealloc {S} (Ω : tyctx S) α τ: ⊢ valid1 Ω α (tRef τ) -∗ valid1 Ω (interp_dealloc α) tUnit. - Proof. + Proof using HCI. iIntros "H". iIntros (αs) "#Hctx Has". iSpecialize ("H" with "Hctx Has"). @@ -324,7 +327,7 @@ Section logrel. ⊢ valid1 Ω1 α (tArr τ1 τ2) -∗ valid1 Ω2 β τ1 -∗ valid1 (tyctx_app Ω1 Ω2) (interp_app α β ◎ interp_scope_split) τ2. - Proof. + Proof using HCI. iIntros "H1 H2". iIntros (αs) "#Hctx Has". iEval(cbn-[interp_app]). @@ -348,7 +351,7 @@ Section logrel. Lemma compat_lam {S} (Ω : tyctx S) τ1 τ2 α : ⊢ valid1 (consC τ1 Ω) α τ2 -∗ valid1 Ω (interp_lam α) (tArr τ1 τ2). - Proof. + Proof using HCI. iIntros "H". iIntros (αs) "#Hctx Has". iIntros (x) "Hx". @@ -393,7 +396,7 @@ Section logrel. Lemma fundamental_affine {S} (Ω : tyctx S) (e : expr S) τ : typed Ω e τ → ⊢ valid1 Ω (interp_expr _ e) τ. - Proof. + Proof using HCI. induction 1; simpl. - by iApply compat_var. - by iApply compat_lam. @@ -418,6 +421,133 @@ Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} τ. Local Definition rs : gReifiers 2 := gReifiers_cons reify_store (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). +Require Import iris.algebra.gmap. + +Local Instance CtxIndepInputLang R `{!Cofe R} (o : opid (sReifier_ops (gReifiers_sReifier rs))) : + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o. +Proof. + destruct o as [x o]. + inv_fin x. + - simpl. intros [[]| [[]| [[] | [| []]]]]. + + constructor. + unshelve eexists (λne '(l,(σ, σ')), x ← σ !! l; + Some (x, (σ, σ'))). + * apply _. + * apply _. + * solve_proper_prepare. + destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. + apply (option_mbind_ne _ (λ n, Some (n, _)) (λ n, Some (n, _))). + -- intros ? ? ?; repeat f_equiv; [done | |]; apply H. + -- rewrite lookup_ne; last apply H. + simpl. + f_equiv. + apply H. + * intros. + simpl. + destruct σ as [? [? ?]]. + simpl. + admit. + + constructor. + unshelve eexists (λne '((l,n),(s, s'')), let s' := <[l:=n]>s + in Some ((), (s', s''))). + * apply _. + * solve_proper_prepare. + destruct x as [[? ?] [? ?]]; destruct y as [[? ?] [? ?]]; simpl in *. + do 3 f_equiv; last apply H. + rewrite insert_ne; [| apply H | apply H]. + simpl. + f_equiv. + apply H. + * intros. + simpl. + destruct i as [? ?]. + destruct σ as [? [? ?]]. + simpl. + reflexivity. + + constructor. + unshelve eexists (λne '(n,(s, s'')), let l := Loc.fresh (dom s) in + let s' := <[l:=n]>s in + Some (l, (s', s''))). + * apply _. + * apply _. + * solve_proper_prepare. + destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. + do 2 f_equiv. + -- f_equiv. + destruct H as [_ [H _]]; simpl in H. + apply gmap_dom_ne in H. + apply H. + -- f_equiv; last apply H. + rewrite insert_ne; [| apply H | apply H]. + simpl. + f_equiv. + destruct H as [_ [H _]]; simpl in H. + apply gmap_dom_ne in H. + by rewrite H. + * intros. + simpl. + destruct i as [? ?]. + destruct σ as [? [? ?]]. + simpl. + reflexivity. + + constructor. + simpl. + unshelve eexists (λne '(l,(σ, σ')), Some ((), (delete l σ, σ'))). + * apply _. + * solve_proper_prepare. + destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. + do 2 f_equiv. + f_equiv; last apply H. + rewrite delete_ne; last apply H. + simpl. + f_equiv. + apply H. + * intros. + simpl. + destruct σ as [? [? ?]]. + simpl. + reflexivity. + - intros x; inv_fin x. + + simpl. intros [[]| [[]| []]]. + * constructor. + unshelve eexists (λne '(_, (a, (b, c))), SomeO (_, (_, (_, c)))). + -- simpl in *. + apply ((input_lang.lang.update_input b).1). + -- apply a. + -- apply ((input_lang.lang.update_input b).2). + -- solve_proper_prepare. + destruct x as [? [? [? ?]]]; destruct y as [? [? [? ?]]]. + simpl in *. + do 2 f_equiv. + ++ do 2 f_equiv. + apply H. + ++ f_equiv; first apply H. + f_equiv; last apply H. + do 2 f_equiv; apply H. + -- intros. + simpl. + destruct σ as [? [? ?]]. + simpl. + reflexivity. + * constructor. + unshelve eexists (λne '(x, (y, z)), SomeO ((), _)). + -- simpl in *. + apply (y, ((input_lang.lang.update_output x (fstO z)), ())). + -- solve_proper_prepare. + destruct x as [? [? [? ?]]]; destruct y as [? [? [? ?]]]. + simpl in *. + do 2 f_equiv. + apply pair_ne. + ++ apply H. + ++ do 2 f_equiv; apply H. + -- intros. + simpl. + destruct σ as [σ1 [? []]]; simpl in *. + reflexivity. + + intros i; by apply fin_0_inv. +Admitted. + Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. Lemma logrel1_adequacy cr Σ R `{!Cofe R, !SubOfe natO R, !SubOfe unitO R, !SubOfe locO R} `{!invGpreS Σ} @@ -489,4 +619,3 @@ Proof. iIntros (? ? ?) "_". by iApply fundamental_affine. Qed. - diff --git a/theories/affine_lang/logrel2.v b/theories/affine_lang/logrel2.v index 9370caa..b22771e 100644 --- a/theories/affine_lang/logrel2.v +++ b/theories/affine_lang/logrel2.v @@ -69,6 +69,10 @@ Section glue. Context `{!invGS Σ, !stateG rs R Σ, !heapG rs R Σ, !na_invG Σ}. Notation iProp := (iProp Σ). + Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. + Definition s : stuckness := λ e, e = OtherError. Variable p : na_inv_pool_name. @@ -82,7 +86,7 @@ Section glue. Lemma compat_glue_to_affine_bool {S} (Ω : tyctx S) α : io_valid empC α Tnat ⊢ valid2 Ω (constO (glue2_bool _ (α ()))) tBool. - Proof. + Proof using HCI. iIntros "H". iIntros (ss) "#Hctx Has". simpl. iIntros (σ) "[Hs Hp]". @@ -178,7 +182,7 @@ Section glue. io_valid empC (constO (glue_from_affine_fun _ glue_from_affine glue_to_affine α)) (Tarr (Tarr Tnat τ1') τ2'). - Proof. + Proof using HCI. intros G1 G2. iIntros "H #Hctx". iIntros (σ ss) "Hs _ _ Hp". simpl. clear ss. @@ -285,7 +289,7 @@ Section glue. ⊢ valid2 Ω (constO (glue_to_affine_fun _ glue_from_affine glue_to_affine (α ()))) (tArr τ1 τ2). - Proof. + Proof using HCI. intros G1 G2. iIntros "H". iIntros (αs) "#Hctx Has". @@ -414,7 +418,7 @@ Section glue. with glue_from_affine_compatibility (τ1 : ty) (τ1' : io_lang.ty) (Hconv : ty_conv τ1 τ1') (α : IT) : valid2 empC (constO α) τ1 ⊢ heap_ctx -∗ io_valid empC (constO (glue_from_affine _ Hconv α)) τ1'. - Proof. + Proof using HCI. - destruct Hconv. + by iApply compat_glue_to_affine_bool. + by iApply compat_glue_to_affine_nat. @@ -435,7 +439,7 @@ Section glue. Lemma fundamental_affine_glued {S} (Ω : tyctx S) (e : expr S) τ : typed_glued Ω e τ → ⊢ valid2 Ω (interp_expr _ e) τ. - Proof. + Proof using HCI. intros typed. induction typed; simpl. - iApply glue_to_affine_compatibility. by iApply fundamental. @@ -456,6 +460,133 @@ End glue. Local Definition rs : gReifiers 2 := gReifiers_cons reify_store (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). +Require Import iris.algebra.gmap. + +Local Instance CtxIndepInputLang R `{!Cofe R} (o : opid (sReifier_ops (gReifiers_sReifier rs))) : + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o. +Proof. + destruct o as [x o]. + inv_fin x. + - simpl. intros [[]| [[]| [[] | [| []]]]]. + + constructor. + unshelve eexists (λne '(l,(σ, σ')), x ← σ !! l; + Some (x, (σ, σ'))). + * apply _. + * apply _. + * solve_proper_prepare. + destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. + apply (option_mbind_ne _ (λ n, Some (n, _)) (λ n, Some (n, _))). + -- intros ? ? ?; repeat f_equiv; [done | |]; apply H. + -- rewrite lookup_ne; last apply H. + simpl. + f_equiv. + apply H. + * intros. + simpl. + destruct σ as [? [? ?]]. + simpl. + admit. + + constructor. + unshelve eexists (λne '((l,n),(s, s'')), let s' := <[l:=n]>s + in Some ((), (s', s''))). + * apply _. + * solve_proper_prepare. + destruct x as [[? ?] [? ?]]; destruct y as [[? ?] [? ?]]; simpl in *. + do 3 f_equiv; last apply H. + rewrite insert_ne; [| apply H | apply H]. + simpl. + f_equiv. + apply H. + * intros. + simpl. + destruct i as [? ?]. + destruct σ as [? [? ?]]. + simpl. + reflexivity. + + constructor. + unshelve eexists (λne '(n,(s, s'')), let l := Loc.fresh (dom s) in + let s' := <[l:=n]>s in + Some (l, (s', s''))). + * apply _. + * apply _. + * solve_proper_prepare. + destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. + do 2 f_equiv. + -- f_equiv. + destruct H as [_ [H _]]; simpl in H. + apply gmap_dom_ne in H. + apply H. + -- f_equiv; last apply H. + rewrite insert_ne; [| apply H | apply H]. + simpl. + f_equiv. + destruct H as [_ [H _]]; simpl in H. + apply gmap_dom_ne in H. + by rewrite H. + * intros. + simpl. + destruct i as [? ?]. + destruct σ as [? [? ?]]. + simpl. + reflexivity. + + constructor. + simpl. + unshelve eexists (λne '(l,(σ, σ')), Some ((), (delete l σ, σ'))). + * apply _. + * solve_proper_prepare. + destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. + do 2 f_equiv. + f_equiv; last apply H. + rewrite delete_ne; last apply H. + simpl. + f_equiv. + apply H. + * intros. + simpl. + destruct σ as [? [? ?]]. + simpl. + reflexivity. + - intros x; inv_fin x. + + simpl. intros [[]| [[]| []]]. + * constructor. + unshelve eexists (λne '(_, (a, (b, c))), SomeO (_, (_, (_, c)))). + -- simpl in *. + apply ((input_lang.lang.update_input b).1). + -- apply a. + -- apply ((input_lang.lang.update_input b).2). + -- solve_proper_prepare. + destruct x as [? [? [? ?]]]; destruct y as [? [? [? ?]]]. + simpl in *. + do 2 f_equiv. + ++ do 2 f_equiv. + apply H. + ++ f_equiv; first apply H. + f_equiv; last apply H. + do 2 f_equiv; apply H. + -- intros. + simpl. + destruct σ as [? [? ?]]. + simpl. + reflexivity. + * constructor. + unshelve eexists (λne '(x, (y, z)), SomeO ((), _)). + -- simpl in *. + apply (y, ((input_lang.lang.update_output x (fstO z)), ())). + -- solve_proper_prepare. + destruct x as [? [? [? ?]]]; destruct y as [? [? [? ?]]]. + simpl in *. + do 2 f_equiv. + apply pair_ne. + ++ apply H. + ++ do 2 f_equiv; apply H. + -- intros. + simpl. + destruct σ as [σ1 [? []]]; simpl in *. + reflexivity. + + intros i; by apply fin_0_inv. +Admitted. + Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. Lemma logrel2_adequacy cr R `{!Cofe R, !SubOfe locO R, !SubOfe natO R, !SubOfe unitO R} Σ `{!invGpreS Σ}`{!statePreG rs R Σ} `{!heapPreG rs R Σ} `{!na_invG Σ} @@ -530,5 +661,3 @@ Proof. iIntros (? ? ? ?) "_". by iApply fundamental_affine_glued. Qed. - - diff --git a/theories/examples/factorial.v b/theories/examples/factorial.v index 710062e..3ee54dd 100644 --- a/theories/examples/factorial.v +++ b/theories/examples/factorial.v @@ -12,6 +12,10 @@ Section fact. Notation IT := (IT F R). Notation ITV := (ITV F R). + Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. + Context `{!invGS Σ, !stateG rs R Σ, !heapG rs R Σ}. Notation iProp := (iProp Σ). @@ -36,7 +40,7 @@ Section fact. heap_ctx -∗ pointsto acc (Ret m) -∗ pointsto ℓ (Ret n) -∗ WP@{rs} fact_imp_body acc ℓ {{ _, pointsto acc (Ret (m * fact n)) }}. - Proof. + Proof using HCI. iIntros "#Hctx Hacc Hl". iLöb as "IH" forall (n m). unfold fact_imp_body. @@ -96,7 +100,7 @@ Section fact. Lemma wp_fact_imp (n : nat) : heap_ctx ⊢ WP@{rs} fact_imp ⊙ (Ret n) {{ βv, βv ≡ RetV (fact n) }}. - Proof. + Proof using HCI. iIntros "#Hctx". iApply wp_lam. iNext. simpl. rewrite get_ret_ret. @@ -124,7 +128,7 @@ Section fact. Lemma wp_fact_io (n : nat) : heap_ctx ∗ has_substate (State [n] []) ⊢ WP@{rs} get_ret OUTPUT fact_io {{ _, has_substate (State [] [fact n]) }}. - Proof. + Proof using HCI. iIntros "[#Hctx Htape]". unfold fact_io. iApply (wp_bind _ (get_ret _)). @@ -141,4 +145,3 @@ Section fact. Qed. End fact. - diff --git a/theories/examples/store.v b/theories/examples/store.v index b855f73..425446f 100644 --- a/theories/examples/store.v +++ b/theories/examples/store.v @@ -17,47 +17,47 @@ Proof. apply _. Qed. #[local] Instance state_cofe X `{!Cofe X} : Cofe (stateF ♯ X). Proof. apply _. Qed. -Definition state_read X `{!Cofe X} : loc * (stateF ♯ X) → option (laterO X * (stateF ♯ X)) - := λ '(l,σ), x ← σ !! l; - Some (x, σ). +Definition state_read X `{!Cofe X} : loc * (stateF ♯ X) * (laterO X -n> laterO X) → option (laterO X * (stateF ♯ X)) + := λ '(l,σ,κ), x ← σ !! l; + Some (κ x, σ). #[export] Instance state_read_ne X `{!Cofe X} : - NonExpansive (state_read X : prodO locO (stateF ♯ X) → optionO (prodO (laterO X) (stateF ♯ X))). + NonExpansive (state_read X : prodO (prodO locO (stateF ♯ X)) (laterO X -n> laterO X) → optionO (prodO (laterO X) (stateF ♯ X))). Proof. - intros n [l1 s1] [l2 s2]. simpl. intros [-> Hs]. - apply (option_mbind_ne _ (λ n, Some (n, s1)) (λ n, Some (n, s2))); + intros n [[l1 s1] κ1] [[l2 s2] κ2]. simpl. intros [[-> Hs'] Hs]. + apply (option_mbind_ne _ (λ n, Some (κ1 n, s1)) (λ n, Some (κ2 n, s2))); solve_proper. Qed. -Definition state_dealloc X `{!Cofe X} : loc * (stateF ♯ X) → option (unitO * (stateF ♯ X)) - := λ '(l,σ), Some ((), delete l σ). +Definition state_dealloc X `{!Cofe X} : loc * (stateF ♯ X) * (unitO -n> laterO X) → option (laterO X * (stateF ♯ X)) + := λ '(l,σ,κ), Some (κ (), delete l σ). #[export] Instance state_dealloc_ne X `{!Cofe X} : - NonExpansive (state_dealloc X : prodO locO (stateF ♯ X) → optionO (prodO unitO (stateF ♯ X))). + NonExpansive (state_dealloc X : prodO (prodO locO (stateF ♯ X)) (unitO -n> laterO X) → optionO (prodO (laterO X) (stateF ♯ X))). Proof. - intros n [l1 s1] [l2 s2]. simpl. intros [-> Hs]. + intros n [[l1 s1] κ1] [[l2 s2] κ2]. simpl. intros [[-> Hs'] Hs]. solve_proper. Qed. Definition state_write X `{!Cofe X} : - (loc * (laterO X)) * (stateF ♯ X) → option (unit * (stateF ♯ X)) - := λ '((l,n),s), let s' := <[l:=n]>s - in Some ((), s'). + (loc * (laterO X)) * (stateF ♯ X) * (unitO -n> laterO X) → option (laterO X * (stateF ♯ X)) + := λ '((l,n),s,κ), let s' := <[l:=n]>s + in Some (κ (), s'). #[export] Instance state_write_ne X `{!Cofe X} : - NonExpansive (state_write X : prodO (prodO locO _) (stateF ♯ _) → optionO (prodO unitO (stateF ♯ X))). + NonExpansive (state_write X : prodO (prodO (prodO locO _) (stateF ♯ _)) (unitO -n> laterO X) → optionO (prodO (laterO X) (stateF ♯ X))). Proof. - intros n [[l1 m1] s1] [[l2 m2] s2]. simpl. - intros [[Hl%leibnizO_leibniz Hm] Hs]. simpl in Hl. + intros n [[[l1 m1] s1] κ1] [[[l2 m2] s2] κ2]. simpl. + intros [[[Hl%leibnizO_leibniz Hm] Hs] Hκ]. simpl in Hl. rewrite Hl. solve_proper. Qed. -Definition state_alloc X `{!Cofe X} : (laterO X) * (stateF ♯ X) → option (loc * (stateF ♯ X)) - := λ '(n,s), let l := Loc.fresh (dom s) in +Definition state_alloc X `{!Cofe X} : (laterO X) * (stateF ♯ X) * (loc -n> laterO X) → option ((laterO X) * (stateF ♯ X)) + := λ '(n,s,κ), let l := Loc.fresh (dom s) in let s' := <[l:=n]>s in - Some (l, s'). + Some (κ l, s'). #[export] Instance state_alloc_ne X `{!Cofe X} : - NonExpansive (state_alloc X : prodO _ (stateF ♯ X) → optionO (prodO locO (stateF ♯ X))). + NonExpansive (state_alloc X : prodO (prodO _ (stateF ♯ X)) (locO -n> laterO X) → optionO (prodO (laterO X) (stateF ♯ X))). Proof. - intros n [m1 s1] [m2 s2]. simpl. - intros [Hm Hs]. simpl in *. + intros n [[m1 s1] κ1] [[m2 s2] κ2]. simpl. + intros [[Hm Hs] Hκ]. simpl in *. set (l1 := Loc.fresh (dom s1)). set (l2 := Loc.fresh (dom s2)). assert (l1 = l2) as ->. @@ -226,6 +226,9 @@ Section wp. Proof. iIntros (Hee) "#Hcxt H". unfold READ. simpl. + match goal with + | |- context G [Vis ?a ?b ?c] => assert (c ≡ idfun ◎ (subEff_outs ^-1)) as -> + end; first solve_proper. iApply wp_subreify'. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (fupd_mask_weaken E1). @@ -247,14 +250,21 @@ Section wp. iExists σ,(Next β'),σ,β'. iFrame "Hs". repeat iSplit. - - iAssert ((option_bind _ _ (λ x, Some (x, σ)) (σ !! l)) ≡ - (option_bind _ _ (λ x, Some (x, σ)) (Some (Next β'))))%I as "H". - + iApply (f_equivI with "[]"). - { intros k x1 y1 Hxy. - apply option_mbind_ne; solve_proper. } - iPureIntro. rewrite Hx Hb'//. - + unfold mbind. iSimpl in "H". iRewrite "H". done. - - iPureIntro. apply ofe_iso_21. + - assert ((option_bind _ _ (λ x, Some (x, σ)) (σ !! l)) ≡ + (option_bind _ _ (λ x, Some (x, σ)) (Some (Next β')))) as H. + + f_equiv. + * solve_proper. + * by rewrite Hx Hb'. + + simpl in H. + rewrite <-H. + unfold mbind. + simpl. + iPureIntro. + f_equiv; last done. + intros ???. + do 2 f_equiv. + by rewrite ofe_iso_21. + - done. - iNext. iIntros "Hlc Hs". iMod ("Hback" with "Hp") as "Hback". iMod "Hwk" . @@ -299,7 +309,7 @@ Section wp. destruct (Next_uninj x) as [α' Ha']. iApply (lc_fupd_elim_later with "Hlc"). iNext. - iExists σ,(),(<[l:=Next β]>σ),(Ret ()). + iExists σ,(Next (Ret ())),(<[l:=Next β]>σ),(Ret ()). iFrame "Hs". iSimpl. repeat iSplit; [ done | done | ]. iNext. iIntros "Hlc". @@ -337,12 +347,17 @@ Section wp. iApply (lc_fupd_elim_later with "Hlc"). iModIntro. set (l:=Loc.fresh (dom σ)). - iExists σ,l,_,(k l). + iExists σ,(Next (k l)),_,(k l). iFrame "Hs". simpl. change (Loc.fresh (dom σ)) with l. - iSplit; first done. iSplit. - { simpl. rewrite ofe_iso_21. done. } + { + iPureIntro. + do 2 f_equiv; last reflexivity. + f_equiv. + by rewrite ofe_iso_21. + } + iSplit; first done. iNext. iIntros "Hlc Hs". iMod (istate_alloc α l with "Hh") as "[Hh Hl]". { apply (not_elem_of_dom_1 (M:=gmap loc)). @@ -373,7 +388,7 @@ Section wp. { iApply (istate_loc_dom with "Hh Hp"). } destruct Hdom as [x Hx]. destruct (Next_uninj x) as [β' Hb']. - iExists σ,(),(delete l σ),(Ret ()). + iExists σ,(Next (Ret ())),(delete l σ),(Ret ()). iFrame "Hs". repeat iSplit; simpl; eauto. iNext. iIntros "Hlc Hs". diff --git a/theories/gitree/reductions.v b/theories/gitree/reductions.v index 49be3ad..8036625 100644 --- a/theories/gitree/reductions.v +++ b/theories/gitree/reductions.v @@ -337,65 +337,64 @@ Section istep. iRewrite -"Ha". iRewrite "Hs". done. Qed. - (* Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' : *) - (* istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. *) - (* Proof. *) - (* iDestruct 1 as "[[Ha Hs]|H]". *) - (* - iRewrite "Ha". iLeft. iSplit; eauto. iPureIntro. apply hom_tick. *) - (* - iDestruct "H" as (op i k) "[#Ha Hr]". *) - (* pose (f' := OfeMor f). *) - (* iRight. iExists op,i,(laterO_map f' ◎ k). *) - (* iAssert (f (Vis op i k) ≡ Vis op i (laterO_map f' ◎ k))%I as "Hf". *) - (* { iPureIntro. apply hom_vis. } *) - (* iRewrite "Ha". iRewrite "Ha" in "Hr". iRewrite "Hf". *) - (* iSplit; first done. *) - - (* (* iApply (reify_vis_cont with "Hr"). *) *) - (* Admitted. *) + Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' {G : ∀ o, CtxIndep r IT o} : + istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. + Proof. + iDestruct 1 as "[[Ha Hs]|H]". + - iRewrite "Ha". iLeft. iSplit; eauto. iPureIntro. apply hom_tick. + - iDestruct "H" as (op i k) "[#Ha Hr]". + pose (f' := OfeMor f). + iRight. iExists op,i,(laterO_map f' ◎ k). + iAssert (f (Vis op i k) ≡ Vis op i (laterO_map f' ◎ k))%I as "Hf". + { iPureIntro. apply hom_vis. } + iRewrite "Ha". iRewrite "Ha" in "Hr". iRewrite "Hf". + iSplit; first done. + iApply (reify_vis_cont with "Hr"). + Qed. - (* Lemma istep_hom_inv α σ β σ' `{!IT_hom f} : *) - (* istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ *) - (* ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). *) - (* Proof. *) - (* iIntros "H". *) - (* destruct (IT_dont_confuse α) *) - (* as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. *) - (* - iExFalso. iApply (istep_err σ e β σ'). *) - (* iAssert (f α ≡ Err e)%I as "Hf". *) - (* { iPureIntro. by rewrite Ha hom_err. } *) - (* iRewrite "Hf" in "H". done. *) - (* - iLeft. iPureIntro. rewrite Ha IT_to_V_Ret. done. *) - (* - iLeft. iPureIntro. rewrite Ha IT_to_V_Fun. done. *) - (* - iAssert (α ≡ Tick la)%I as "Ha"; first by eauto. *) - (* iAssert (f (Tick la) ≡ Tick (f la))%I as "Hf". *) - (* { iPureIntro. rewrite hom_tick. done. } *) - (* iRight. iRewrite "Ha". iRewrite "Ha" in "H". *) - (* iRewrite "Hf" in "H". rewrite istep_tick. *) - (* iDestruct "H" as "[Hb Hs]". iSplit. *) - (* { by rewrite IT_to_V_Tau. } *) - (* iExists la. iSplit; last eauto. *) - (* unfold istep. iLeft. iSplit; eauto. *) - (* - iRight. *) - (* pose (fi:=OfeMor f). *) - (* iAssert (f α ≡ Vis op i (laterO_map fi ◎ k))%I as "Hf". *) - (* { iPureIntro. by rewrite Ha hom_vis. } *) - (* iRewrite "Hf" in "H". *) - (* rewrite {1}/istep. iSimpl in "H". *) - (* iDestruct "H" as "[[H _]|H]". *) - (* + iExFalso. iApply (IT_tick_vis_ne). *) - (* iApply internal_eq_sym. done. *) - (* + iDestruct "H" as (op' i' k') "[#Ha Hr]". *) - (* iPoseProof (Vis_inj_op' with "Ha") as "<-". *) - (* iPoseProof (Vis_inj' with "Ha") as "[Hi Hk]". *) - (* (* iPoseProof (reify_input_cont_inv r op i k fi with "Hr") as (α') "[Hr Ha']". *) *) - (* (* iAssert (reify r α σ ≡ (σ', Tick α'))%I with "[Hr]" as "Hr". *) *) - (* (* { iRewrite -"Hr". iPureIntro. repeat f_equiv. *) *) - (* (* apply Ha. } *) *) - (* (* iSplit. { iPureIntro. by rewrite Ha IT_to_V_Vis. } *) *) - (* (* iExists α'. iFrame "Ha'". *) *) - (* (* rewrite /istep. iRight. *) *) - (* (* iExists op,i,k. iFrame "Hr". *) *) - (* (* iPureIntro. apply Ha. *) *) - (* Admitted. *) + Lemma istep_hom_inv α σ β σ' `{!IT_hom f} {G : ∀ o, CtxIndep r IT o} : + istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ + ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). + Proof. + iIntros "H". + destruct (IT_dont_confuse α) + as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. + - iExFalso. iApply (istep_err σ e β σ'). + iAssert (f α ≡ Err e)%I as "Hf". + { iPureIntro. by rewrite Ha hom_err. } + iRewrite "Hf" in "H". done. + - iLeft. iPureIntro. rewrite Ha IT_to_V_Ret. done. + - iLeft. iPureIntro. rewrite Ha IT_to_V_Fun. done. + - iAssert (α ≡ Tick la)%I as "Ha"; first by eauto. + iAssert (f (Tick la) ≡ Tick (f la))%I as "Hf". + { iPureIntro. rewrite hom_tick. done. } + iRight. iRewrite "Ha". iRewrite "Ha" in "H". + iRewrite "Hf" in "H". rewrite istep_tick. + iDestruct "H" as "[Hb Hs]". iSplit. + { by rewrite IT_to_V_Tau. } + iExists la. iSplit; last eauto. + unfold istep. iLeft. iSplit; eauto. + - iRight. + pose (fi:=OfeMor f). + iAssert (f α ≡ Vis op i (laterO_map fi ◎ k))%I as "Hf". + { iPureIntro. by rewrite Ha hom_vis. } + iRewrite "Hf" in "H". + rewrite {1}/istep. iSimpl in "H". + iDestruct "H" as "[[H _]|H]". + + iExFalso. iApply (IT_tick_vis_ne). + iApply internal_eq_sym. done. + + iDestruct "H" as (op' i' k') "[#Ha Hr]". + iPoseProof (Vis_inj_op' with "Ha") as "<-". + iPoseProof (Vis_inj' with "Ha") as "[Hi Hk]". + iPoseProof (reify_input_cont_inv r op i k fi with "Hr") as (α') "[Hr Ha']". + iAssert (reify r α σ ≡ (σ', Tick α'))%I with "[Hr]" as "Hr". + { iRewrite -"Hr". iPureIntro. repeat f_equiv. + apply Ha. } + iSplit. { iPureIntro. by rewrite Ha IT_to_V_Vis. } + iExists α'. iFrame "Ha'". + rewrite /istep. iRight. + iExists op,i,k. iFrame "Hr". + iPureIntro. apply Ha. + Qed. End istep. diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 2b2c494..4050501 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -25,6 +25,13 @@ Section reifiers. Implicit Type op : opid F. Implicit Type α β : IT. + Class CtxIndep (X : ofe) `{!Cofe X} (op : opid F) := { + cont_irrelev : + (∃ f : (prodO (Ins (sReifier_ops r _) ♯ X) ((sReifier_state r) ♯ X)) -n> + optionO (prodO (Outs (sReifier_ops r _) ♯ X) (sReifier_state r ♯ X)), + ∀ i σ κ, @sReifier_re _ X _ op (i, σ, κ) ≡ fmap (prodO_map κ idfun) (f (i, σ))); + }. + Notation stateM := ((stateF ♯ IT -n> (stateF ♯ IT) * IT)). #[local] Instance stateT_inhab : Inhabited stateM. Proof. @@ -239,95 +246,95 @@ Section reifiers. reflexivity. Qed. - (* Lemma reify_vis_cont op i k1 (k2 : IT -n> IT) σ1 σ2 β *) - (* {PROP : bi} `{!BiInternalEq PROP} (H : IT_hom k2) : *) - (* (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ *) - (* reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. *) - (* Proof. *) - (* destruct (sReifier_re r op (i, σ1, k1)) as [[o σ2']|] eqn:Hre; last first. *) - (* - rewrite (reify_vis_None _ _ k1); last by rewrite Hre//. *) - (* iIntros "Hr". iExFalso. *) - (* iPoseProof (prod_equivI with "Hr") as "[_ Hk]". *) - (* simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. *) - (* - rewrite reify_vis_eq; last first. *) - (* { by rewrite Hre. } *) - (* iIntros "Hr". *) - (* iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". *) - (* iPoseProof (Tau_inj' with "Hk") as "Hk". *) - (* iAssert (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (reify (k2 (Vis op i k1)) σ1))%I as "HEQ". *) - (* { *) - (* iPureIntro. *) - (* do 2 f_equiv. *) - (* rewrite hom_vis. *) - (* f_equiv. *) - (* intro; simpl; reflexivity. *) - (* } *) - (* iRewrite "HEQ". *) - (* iEval (iPureIntro; etrans). *) - (* trans (reify (k2 (Vis op i k1)) σ1). *) - (* simpl. *) - (* (* pose proof hom_vis. *) *) - (* (* rewrite H. *) *) - (* (* iRewrite - "Hs". *) *) - (* (* rewrite reify_vis_eq; last first. *) *) - (* (* { by rewrite Hre. } *) *) - (* (* iRewrite "Hk". *) *) - (* (* rewrite -Tick_eq. *) *) - (* (* done. *) *) - (* (* reflexivity. *) *) - (* (* rewrite term *) *) - (* (* iApply prod_equivI. simpl. *) *) - (* (* iSplit; eauto. *) *) - (* (* iApply Tau_inj'. iRewrite "Hk". *) *) - (* (* rewrite laterO_map_Next. done. *) *) - (* Admitted. *) + Lemma reify_vis_cont op i k1 k2 σ1 σ2 β + {PROP : bi} `{!BiInternalEq PROP} `{H : !(@CtxIndep IT _ op)} : + (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ + reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. + Proof. + destruct (sReifier_re r op (i, σ1, k1)) as [[o σ2']|] eqn:Hre; last first. + - rewrite (reify_vis_None _ _ k1); last by rewrite Hre//. + iIntros "Hr". iExFalso. + iPoseProof (prod_equivI with "Hr") as "[_ Hk]". + simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. + - destruct H as [[f H]]. + pose proof (H i σ1 k1) as H1. + pose proof (H i σ1 (laterO_map k2 ◎ k1)) as H2. + assert (∃ o σ', f (i, σ1) = Some (o, σ')) as [o' [σ' H3]]. + { + destruct (f (i, σ1)) as [[? ?] | ?]; first (do 2 eexists; reflexivity). + simpl in H1. rewrite Hre in H1; inversion H1. + } + rewrite H3 in H1. + simpl in H1. + rewrite H3 in H2. + simpl in H2. + clear f H H3 Hre. + rewrite reify_vis_eq; last first. + { by rewrite H1. } + rewrite reify_vis_eq; last first. + { by rewrite H2. } + iIntros "Hr". + iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". + iApply prod_equivI. simpl. iSplit; eauto. + iPoseProof (Tau_inj' with "Hk") as "Hk". + iApply Tau_inj'. iRewrite "Hk". + rewrite laterO_map_Next. done. + Qed. - (* Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β *) - (* {PROP : bi} `{!BiInternalEq PROP} *) - (* (g : (IT -n> IT) -n> (prodO (stateF ♯ IT) IT) -n> (prodO (stateF ♯ IT) IT)) *) - (* (H : reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (g k2) (reify (Vis op i k1) σ1)) *) - (* : *) - (* (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) *) - (* ⊢ ∃ α, reify (Vis op i k1) σ1 ≡ (σ2, Tick α) ∧ ▷ (β ≡ k2 α) *) - (* : PROP)%I. *) - (* Proof. *) - (* destruct (sReifier_re r op (i, σ1, (laterO_map k2 ◎ k1))) as [[o σ2']|] eqn:Hre; last first. *) - (* - rewrite reify_vis_None; last by rewrite Hre//. *) - (* iIntros "Hr". iExFalso. *) - (* iPoseProof (prod_equivI with "Hr") as "[_ Hk]". *) - (* simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. *) - (* - rewrite reify_vis_eq; last first. *) - (* { by rewrite Hre. } *) - (* iIntros "Hr". simpl. *) - (* iPoseProof (prod_equivI with "Hr") as "[#Hs #Hk]". *) - (* simpl. *) - (* iPoseProof (Tau_inj' with "Hk") as "Hk'". *) - (* destruct (Next_uninj o) as [a Hk1]. *) - (* iExists (a). *) - (* assert (Hre' : sReifier_re r op (i, σ1, laterO_map k2 ◎ k1) ≡ Some (o, σ2')). *) - (* { by rewrite Hre. } *) - (* apply reify_vis_eq in Hre'. *) - (* rewrite Hre' in H. *) - (* rewrite H. *) - (* iRewrite - "Hr". *) - (* epose proof (reify_vis_eq _ _ _ _ _ _ Hre). *) - (* rewrite reify_vis_eq; last first. *) - (* { by rewrite H1. } *) - (* iSplit. *) - (* + iApply prod_equivI. simpl. iSplit; eauto. *) - (* iApply Tau_inj'. done. *) - (* + iAssert (laterO_map k2 (Next a) ≡ Next β)%I as "Ha". *) - (* { *) - (* iSimpl in "Hk'". iRewrite -"Hk'". *) - (* iPureIntro. rewrite -Hk1. *) - (* rewrite Hre in H2. *) - (* inversion H2 as [? ? H2' |]; subst; inversion H2'; simpl in *; subst. *) - (* symmetry; assumption. *) - (* } *) - (* iAssert (Next (k2 a) ≡ Next β)%I as "Hb". *) - (* { iRewrite -"Ha". iPureIntro. *) - (* rewrite laterO_map_Next. done. } *) - (* iNext. by iApply internal_eq_sym. *) - (* Qed. *) + Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β + {PROP : bi} `{!BiInternalEq PROP} `{H : !(@CtxIndep IT _ op)} : + (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) + ⊢ ∃ α, reify (Vis op i k1) σ1 ≡ (σ2, Tick α) ∧ ▷ (β ≡ k2 α) + : PROP)%I. + Proof. + destruct (sReifier_re r op (i, σ1, (laterO_map k2 ◎ k1))) as [[o σ2']|] eqn:Hre; last first. + - rewrite reify_vis_None; last by rewrite Hre//. + iIntros "Hr". iExFalso. + iPoseProof (prod_equivI with "Hr") as "[_ Hk]". + simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. + - rewrite reify_vis_eq; last first. + { by rewrite Hre. } + iIntros "Hr". simpl. + iPoseProof (prod_equivI with "Hr") as "[#Hs #Hk]". + simpl. + iPoseProof (Tau_inj' with "Hk") as "Hk'". + destruct H as [[f H]]. + pose proof (H i σ1 k1) as H1. + pose proof (H i σ1 (laterO_map k2 ◎ k1)) as H2. + assert (∃ o, f (i, σ1) ≡ Some (o, σ2')) as [o' H3]. + { + destruct (f (i, σ1)) as [[? ?] | ?]. + - simpl in H2. + rewrite Hre in H2. + inversion H2 as [? ? H2' |]; subst; inversion H2'; simpl in *; subst. + eexists _; do 2 f_equiv; first reflexivity; symmetry; assumption. + - simpl in H2. + rewrite Hre in H2. + inversion H2. + } + rewrite H3 in H1. + simpl in H1. + rewrite H3 in H2. + simpl in H2. + destruct (Next_uninj (k1 o')) as [a Hk1]. + iExists (a). + rewrite reify_vis_eq; last first. + { by rewrite H1. } + iSplit. + + iApply prod_equivI. simpl. iSplit; eauto. + iApply Tau_inj'. done. + + iAssert (laterO_map k2 (Next a) ≡ Next β)%I as "Ha". + { + iSimpl in "Hk'". iRewrite -"Hk'". + iPureIntro. rewrite -Hk1. + rewrite Hre in H2. + inversion H2 as [? ? H2' |]; subst; inversion H2'; simpl in *; subst. + symmetry; assumption. + } + iAssert (Next (k2 a) ≡ Next β)%I as "Hb". + { iRewrite -"Ha". iPureIntro. + rewrite laterO_map_Next. done. } + iNext. by iApply internal_eq_sym. + Qed. End reifiers. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index 64f9db2..6358ffd 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -490,12 +490,11 @@ Section weakestpre. Lemma wp_subreify' E1 E2 s Φ sR `{!subReifier sR rs} (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ IT) - (k : Outs (sReifier_ops sR op) ♯ IT -n> laterO IT) : + (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) : (|={E1,E2}=> ∃ σ y σ' β, has_substate σ ∗ - sReifier_re sR op (x, σ, k) ≡ Some (y, σ') ∗ - y ≡ Next β ∗ + sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') ∗ y ≡ Next β ∗ ▷ (£ 1 -∗ has_substate σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) - -∗ WP (Vis (subEff_opid op) (subEff_ins x) (k ◎ (subEff_outs)^-1)) @ s;E1 {{ Φ }}. + -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. Proof. iIntros "H". iApply wp_reify_idx'. @@ -505,9 +504,12 @@ Section weakestpre. simpl. iFrame "Hlst H". rewrite subReifier_reify_idxI. - iRewrite "Hreify". - simpl. - by iFrame "Hk". + iFrame "Hk". + iRewrite - "Hreify". + iPureIntro. + do 2 f_equiv. + intros ?; simpl. + by rewrite ofe_iso_12. Qed. Lemma wp_subreify E1 s Φ sR `{!subReifier sR rs} @@ -731,7 +733,7 @@ Section weakestpre. Notation "'CLWP' α @ s ; E {{ v , Q } }" := (clwp α s E (λne v, Q)) (at level 20, α, s, Q at level 200, - format "'[hv' 'CLWP' α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. + format "'[hv' 'CLWP' α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. Notation "'CLWP' α @ s {{ β , Φ } }" := (clwp α s ⊤ (λne β, Φ)) @@ -751,7 +753,7 @@ Section weakestpre. rewrite clwp_eq /clwp_def. iIntros "H". iIntros (?). iApply "H". Qed. - + Lemma unfold_clwp (s : stuckness) (E : coPset) (e : IT) (Φ : ITV -n> iProp) : CLWP e @ s ; E {{Φ}} ⊣⊢ (∀ (K : IT -n> IT) {HK : IT_hom K} (Ψ : ITV -n> iProp), (∀ v, Φ v -∗ WP (K (IT_of_V v)) @ s ; E {{ Ψ }}) @@ -849,7 +851,7 @@ Section weakestpre. Proof. solve_proper. Qed. - + Lemma clwp_fupd s E e (Φ : ITV -n> iProp) : CLWP e @ s ; E {{ v , |={E}=> Φ v }} ⊢ CLWP e @ s ; E {{ Φ }}. Proof. @@ -857,13 +859,13 @@ Section weakestpre. iIntros (K HK Ψ) "HK". iApply "H". iIntros (w) ">Hw"; by iApply "HK". Qed. - + Lemma clwp_bind (K : IT -n> IT) {HK : IT_hom K} s E e (Φ : ITV -n> iProp) : CLWP e @ s ; E {{ v , CLWP (K (IT_of_V v)) @ s ; E {{ Φ }} }} ⊢ CLWP (K e) @ s ; E {{ Φ }}. Proof. iIntros "H"; rewrite !unfold_clwp. iIntros (K' HK' Ψ) "HK'". - assert (K' (K e) = (K' ◎ K) e) as ->; first done. + assert (K' (K e) = (K' ◎ K) e) as ->; first done. iApply "H". - iPureIntro. apply _. @@ -874,7 +876,7 @@ Section weakestpre. iIntros (w) "Hw". by iApply "HK'". Qed. - + Lemma clwp_mono E e (Φ Ψ : ITV -n> iProp) : (∀ v, Φ v ⊢ Ψ v) → CLWP e @ E {{ Φ }} ⊢ CLWP e @ E {{ Ψ }}. Proof. @@ -904,7 +906,7 @@ Section weakestpre. Proof. solve_proper. Qed. - + Lemma clwp_frame_l s E e (Φ : ITV -n> iProp) R : R ∗ CLWP e @ s ; E {{ Φ }} ⊢ CLWP e @ s ; E {{ v, R ∗ Φ v }}. Proof. @@ -917,7 +919,7 @@ Section weakestpre. Proof. solve_proper. Qed. - + Lemma clwp_frame_r s E e (Φ : ITV -n> iProp) R : CLWP e @ s ; E {{ Φ }} ∗ R ⊢ CLWP e @ s ; E {{ v, Φ v ∗ R }}. Proof. @@ -932,15 +934,15 @@ Section weakestpre. iIntros (K HK χ) "HK". iApply "Hwp". iIntros (?) "?"; iApply "HK"; by iApply "H". Qed. - + Lemma clwp_wand_l s E e (Φ Ψ : ITV -n> iProp) : (∀ v, Φ v -∗ Ψ v) ∗ CLWP e @ s ; E {{ Φ }} ⊢ CLWP e @ s ; E {{ Ψ }}. Proof. iIntros "[H Hwp]". iApply (clwp_wand with "Hwp H"). Qed. - + Lemma clwp_wand_r s E e (Φ Ψ : ITV -n> iProp) : CLWP e @ s ; E {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ CLWP e @ s ; E {{ Ψ }}. Proof. iIntros "[Hwp H]". iApply (clwp_wand with "Hwp H"). Qed. - + Lemma clwp_tick α s E1 Φ : ▷ CLWP α @ s;E1 {{ Φ }} ⊢ CLWP (Tick α) @ s;E1 {{ Φ }}. Proof. @@ -964,7 +966,7 @@ Section weakestpre. intros op Hr. iIntros "Hlst H". rewrite clwp_eq /clwp_def. - iIntros (K HK Ψ) "G". + iIntros (K HK Ψ) "G". rewrite hom_vis. unshelve iApply (@wp_reify _ _ _ _ _ _ _ σ σ' (K β) with "[$Hlst] [-]"). - intros. @@ -978,7 +980,7 @@ Section weakestpre. simpl. by iApply "H". Qed. - + Lemma clwp_subreify E1 s Φ sR `{!subReifier sR rs} (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ IT) (y : laterO IT) @@ -1015,6 +1017,62 @@ Section weakestpre. by apply HSR. Qed. + Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 {G : ∀ o : opid F, CtxIndep rG IT o} : + WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. + Proof. + assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). + { solve_proper. } + iIntros "H". iLöb as "IH" forall (α). + rewrite (wp_unfold (f _)). + destruct (IT_to_V (f α)) as [βv|] eqn:Hfa. + - iLeft. iExists βv. iSplit; first done. + assert (is_Some (IT_to_V α)) as [αv Ha]. + { apply (IT_hom_val_inv _ f). rewrite Hfa. + done. } + assert (IntoVal α αv). + { apply IT_of_to_V'. by rewrite Ha. } + rewrite wp_val_inv. + iApply wp_val_inv. + rewrite IT_of_to_V'; last by rewrite -Ha. + rewrite IT_of_to_V'; last by rewrite -Hfa. + by iApply fupd_wp. + - iRight. iSplit; eauto. + iIntros (σ) "Hs". + rewrite wp_unfold. + iDestruct "H" as "[H | H]". + + iDestruct "H" as (αv) "[Hav H]". + iPoseProof (IT_of_to_V with "Hav") as "Hav". + iMod "H" as "H". rewrite wp_unfold. + iDestruct "H" as "[H|H]". + { iExFalso. iDestruct "H" as (βv) "[H _]". + iRewrite "Hav" in "H". rewrite Hfa. + iApply (option_equivI with "H"). } + iDestruct "H" as "[_ H]". + iMod ("H" with "Hs") as "H". iModIntro. + iRewrite "Hav" in "H". done. + + iDestruct "H" as "[Hav H]". + iMod ("H" with "Hs") as "[Hsafe H]". iModIntro. + iSplit. + { (* safety *) + iDestruct "Hsafe" as "[Hsafe|Herr]". + - iDestruct "Hsafe" as (α' σ') "Hsafe". iLeft. + iExists (f α'), σ'. iApply (istep_hom with "Hsafe"). + - iDestruct "Herr" as (e) "[Herr %]". + iRight. iExists e. iSplit; last done. + iRewrite "Herr". rewrite hom_err//. } + iIntros (σ' β) "Hst". + rewrite {1}istep_hom_inv. iDestruct "Hst" as "[%Ha | [_ Hst]]". + { destruct Ha as [αv Ha]. rewrite Ha. + iExFalso. + iApply (option_equivI with "Hav"). } + iDestruct "Hst" as (α') "[Hst Hb]". + iIntros "Hlc". + iMod ("H" with "Hst Hlc") as "H". iModIntro. + iNext. iMod "H" as "H". iModIntro. + iMod "H" as "[$ H]". + iModIntro. iRewrite "Hb". by iApply "IH". + Qed. + End weakestpre. Arguments wp {_} rs {_ _ _ _ _} α s E Φ. diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index e9ec2d0..4ced640 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -129,8 +129,6 @@ Section weakestpre. { simpl. done. } iModIntro. iIntros "H1 H2". iApply wp_val. by iApply ("Ha" with "H1 H2"). - Unshelve. - constructor. Qed. End weakestpre. @@ -226,8 +224,6 @@ Section interp. solve_proper. Qed. - (* Axiom falso : False. *) - (** Interpretation for all the syntactic categories: values, expressions, contexts *) Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := match v with @@ -564,7 +560,6 @@ Section interp. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_ectx_fill. simpl. - rewrite ofe_iso_21. rewrite H4; simpl. done. - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). @@ -576,9 +571,10 @@ Section interp. rewrite reify_vis_eq //; last first. { simpl. - pose proof (@subReifier_reify sz reify_io rs subR IT _ ((inr (inl ()))) n0 ()) as H. + pose proof (@subReifier_reify sz reify_io rs subR IT _ ((inr (inl ()))) n0) as H. + simpl in H. + specialize (H (Next (interp_ectx K env (Ret 0))) (λne _, Next (interp_ectx K env (Ret 0))) σ (update_output n0 σ) σr). simpl in H. - specialize (H (λne _, Next (interp_ectx K env (Ret 0))) σ (update_output n0 σ) σr). rewrite <-H; last done. f_equiv. - intros [? ?] [? ?] [? ?]; simpl in *. diff --git a/theories/input_lang/logpred.v b/theories/input_lang/logpred.v index 154aa7d..34888c2 100644 --- a/theories/input_lang/logpred.v +++ b/theories/input_lang/logpred.v @@ -14,9 +14,9 @@ Section io_lang. Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ, !na_invG Σ}. Notation iProp := (iProp Σ). - Context {CtxI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. + Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. Variable s : stuckness. Context {A:ofe}. @@ -79,12 +79,13 @@ Section io_lang. iDestruct "Has" as "[_ H]". by iApply ("IH" with "Hs H"). Qed. + Lemma compat_if {S} (Γ : tyctx S) τ α β1 β2 : ⊢ valid1 Γ α Tnat -∗ valid1 Γ β1 τ -∗ valid1 Γ β2 τ -∗ valid1 Γ (interp_if rs α β1 β2) τ. - Proof using CtxI. + Proof using HCI. iIntros "H0 H1 H2". iIntros (σ ss) "Hs #Has". iSpecialize ("H0" with "Hs Has"). @@ -115,7 +116,7 @@ Section io_lang. Lemma compat_output {S} (Γ : tyctx S) α : ⊢ valid1 Γ α Tnat → valid1 Γ (interp_output rs α) Tnat. - Proof using CtxI. + Proof using HCI. iIntros "H". iIntros (σ ss) "Hs #Has". iSpecialize ("H" with "Hs Has"). @@ -137,7 +138,7 @@ Section io_lang. ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ valid1 Γ β τ1 -∗ valid1 Γ (interp_app rs α β) τ2. - Proof using CtxI. + Proof using HCI. iIntros "H1 H2". iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). @@ -188,7 +189,7 @@ Section io_lang. ⊢ valid1 Γ α Tnat -∗ valid1 Γ β Tnat -∗ valid1 Γ (interp_natop _ op α β) Tnat. - Proof using CtxI. + Proof using HCI. iIntros "H1 H2". iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). @@ -213,7 +214,7 @@ Section io_lang. typed Γ e τ → ⊢ valid1 Γ (interp_expr rs e) τ with fundamental_val {S} (Γ : tyctx S) v τ : typed_val Γ v τ → ⊢ valid1 Γ (interp_val rs v) τ. - Proof using CtxI. + Proof using HCI. - destruct 1. + by iApply fundamental_val. + by iApply compat_var. @@ -230,7 +231,7 @@ Section io_lang. Lemma fundmanetal_closed (e : expr []) (τ : ty) : typed empC e τ → ⊢ valid1 empC (interp_expr rs e) τ. - Proof using CtxI. apply fundamental. Qed. + Proof using HCI. apply fundamental. Qed. End io_lang. @@ -239,11 +240,53 @@ Arguments interp_tarr {_ _ _ _ _ _ _ _ _ _ _} Φ1 Φ2. Local Definition rs : gReifiers _ := gReifiers_cons reify_io gReifiers_nil. +Local Instance CtxIndepInputLang R `{!Cofe R} (o : opid (sReifier_ops (gReifiers_sReifier rs))) : + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o. +Proof. + destruct o as [x o]. + inv_fin x. + - simpl. intros [[]| [[]| []]]. + + constructor. + unshelve eexists (λne '(_, (a, b)), SomeO (_, (_, b))). + * simpl in *. + apply ((update_input a).1). + * simpl in *. + apply ((update_input a).2). + * solve_proper_prepare. + destruct x as [? [? ?]]; destruct y as [? [? ?]]. + simpl in *. + do 2 f_equiv. + -- do 2 f_equiv. + apply H. + -- f_equiv; last apply H. + do 2 f_equiv. + apply H. + * intros. + simpl. + destruct σ. + simpl. + reflexivity. + + constructor. + unshelve eexists (λne '(x, y), SomeO ((), _)). + * simpl in *. + apply ((update_output x (fstO y)), ()). + * solve_proper_prepare. + destruct x as [? [? ?]]; destruct y as [? [? ?]]. + simpl in *. + do 4 f_equiv. + -- apply H. + -- apply H. + * intros. + simpl. + destruct σ as [σ1 []]; simpl in *. + reflexivity. + - intros i; by apply fin_0_inv. +Qed. + Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. Lemma logpred_adequacy cr Σ R `{!Cofe R, SubOfe natO R}`{!invGpreS Σ}`{!statePreG rs R Σ} τ (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k - (HCi : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) (IT (sReifier_ops (gReifiers_sReifier rs)) R) o) : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ}, (£ cr ⊢ valid1 rs notStuck (λ _:unitO, True)%I empC α τ)%I) → @@ -290,9 +333,7 @@ Proof. done. Qed. -Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k - (HCi : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) (IT (sReifier_ops (gReifiers_sReifier rs)) natO) o) : +Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : typed empC e τ → ssteps (gReifiers_sReifier rs) (interp_expr _ e ()) (σ,()) β st' k → (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) diff --git a/theories/input_lang/logrel.v b/theories/input_lang/logrel.v index 5ff4c60..169a7df 100644 --- a/theories/input_lang/logrel.v +++ b/theories/input_lang/logrel.v @@ -413,6 +413,50 @@ Proof. Qed. Definition rs : gReifiers 1 := gReifiers_cons reify_io gReifiers_nil. +Local Instance CtxIndepInputLang R `{!Cofe R} (o : opid (sReifier_ops (gReifiers_sReifier rs))) : + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o. +Proof. + destruct o as [x o]. + inv_fin x. + - simpl. intros [[]| [[]| []]]. + + constructor. + unshelve eexists (λne '(_, (a, b)), SomeO (_, (_, b))). + * simpl in *. + apply ((update_input a).1). + * simpl in *. + apply ((update_input a).2). + * solve_proper_prepare. + destruct x as [? [? ?]]; destruct y as [? [? ?]]. + simpl in *. + do 2 f_equiv. + -- do 2 f_equiv. + apply H. + -- f_equiv; last apply H. + do 2 f_equiv. + apply H. + * intros. + simpl. + destruct σ. + simpl. + reflexivity. + + constructor. + unshelve eexists (λne '(x, y), SomeO ((), _)). + * simpl in *. + apply ((update_output x (fstO y)), ()). + * solve_proper_prepare. + destruct x as [? [? ?]]; destruct y as [? [? ?]]. + simpl in *. + do 4 f_equiv. + -- apply H. + -- apply H. + * intros. + simpl. + destruct σ as [σ1 []]; simpl in *. + reflexivity. + - intros i; by apply fin_0_inv. +Qed. + Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (True ⊢ logrel rs Tnat α e)%I) → @@ -468,11 +512,7 @@ Proof. iExists l. iSplit; eauto. Qed. - -Theorem adequacy (e : expr []) (k : nat) σ σ' n - (HCi : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) (IT (sReifier_ops (gReifiers_sReifier rs)) natO) o) - : +Theorem adequacy (e : expr []) (k : nat) σ σ' n : typed empC e Tnat → ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) (σ,()) (Ret k : IT _ natO) σ' n → ∃ mm σ', prim_steps e σ (Val $ Lit k) σ' mm. diff --git a/theories/input_lang_callcc/logpred.v b/theories/input_lang_callcc/logpred.v deleted file mode 100644 index 3ca68b4..0000000 --- a/theories/input_lang_callcc/logpred.v +++ /dev/null @@ -1,365 +0,0 @@ -(** Unary (Kripke) logical relation for the IO lang *) -From Equations Require Import Equations. -From gitrees Require Import gitree program_logic. -From gitrees.input_lang_callcc Require Import lang interp. -Require Import gitrees.lang_generic_sem. -Require Import Binding.Lib Binding.Set Binding.Env. - -Section io_lang. - Context {sz : nat}. - Variable rs : gReifiers sz. - Context `{!subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). - Context {R} `{!Cofe R}. - Context `{SO : !SubOfe natO R}. - Notation IT := (IT F R). - Notation ITV := (ITV F R). - Context `{!invGS Σ, !stateG rs R Σ, !na_invG Σ}. - Notation iProp := (iProp Σ). - - Variable s : stuckness. - Context {A:ofe}. - Variable (P : A -n> iProp). - - Local Notation expr_pred := (expr_pred s rs P). - - (* Program Definition interp_ectx (interp : listC D -n> D) (K : ectx S) *) - (* : listC D -n> iProp Σ := *) - (* λne Δ, (□ ∀ v, interp Δ v -∗ WP (fill K (of_val v)) {{_, True}})%I. *) - (* Solve Obligations with repeat intros ?; simpl; solve_proper. *) - - (* Program Definition interp_cont (interp : listC D -n> D) *) - (* : listC D -n> D := *) - (* λne Δ w, (∃ K, ⌜w = ContV K⌝ ∧ interp_ectx interp K Δ)%I. *) - (* Solve Obligations with repeat intros ?; simpl; solve_proper. *) - - (* Program Definition interp_expr (interp : listC D -n> D) : *) - (* listC D -n> (exprC -n> iProp Σ) := *) - (* λne Δ e, (∀ K, interp_ectx interp K Δ -∗ WP (fill K e) {{_, True}})%I. *) - (* Solve Obligations with repeat intros ?; simpl; solve_proper. *) - - Program Definition interp_tnat : ITV -n> iProp := λne αv, - (∃ n : nat, αv ≡ RetV n)%I. - Solve All Obligations with solve_proper. - Program Definition interp_tarr (Φ1 Φ2 : ITV -n> iProp) := λne αv, - (□ ∀ σ βv, has_substate σ -∗ - Φ1 βv -∗ - expr_pred (IT_of_V αv ⊙ (IT_of_V βv)) (λne v, ∃ σ', Φ2 v ∗ has_substate σ'))%I. - Solve All Obligations with try solve_proper. - Next Obligation. - intros. - solve_proper_prepare. - do 8 f_equiv. - unfold expr_pred. - do 3 f_equiv. - apply clwp_ne'. - solve_proper. - Qed. - - Fixpoint interp_ty (τ : ty) : ITV -n> iProp := - match τ with - | Tnat => interp_tnat - | Tarr τ1 τ2 => interp_tarr (interp_ty τ1) (interp_ty τ2) - | Tcont τ => interp_tarr (interp_ty τ) (constO ((False)%I)) - end. - - Program Definition ı_scope - : @interp_scope F R _ ∅ := λne x, match x with end. - - Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S : Set} (Γ : S -> ty) (ss : interp_scope S) : iProp := - (∀ x, □ expr_pred (ss x) (interp_ty (Γ x)))%I. - - #[global] Instance io_lang_interp_ty_pers τ βv : Persistent (io_lang.interp_ty τ βv). - Proof. induction τ; apply _. Qed. - #[global] Instance ssubst_valid_pers {S : Set} (Γ : S -> ty) ss : Persistent (ssubst_valid interp_ty Γ ss). - Proof. - apply _. - Qed. - - Program Definition valid1 {S : Set} (Γ : S -> ty) (α : @interp_scope F R _ S -n> IT) (τ : ty) : iProp := - (∀ σ ss, has_substate σ -∗ ssubst_valid interp_ty Γ ss -∗ - expr_pred (α ss) (λne v, ∃ σ', interp_ty τ v ∗ has_substate σ'))%I. - Solve Obligations with solve_proper. - - Lemma compat_nat {S : Set} n (Ω : S -> ty) : - ⊢ valid1 Ω (interp_nat rs n) Tnat. - Proof. - iIntros (σ αs) "Hs Has". - simpl. iApply expr_pred_ret. simpl. - eauto with iFrame. - Qed. - Lemma compat_var {S : Set} Ω τ (v : S) : - Ω v = τ → - ⊢ valid1 Ω (interp_var v) τ. - Proof. - intros Hv. - iIntros (σ ss) "Hs Has". simpl. - iIntros (x) "G". - iDestruct ("Has" $! v x with "G") as "Has". - iApply (clwp_wand with "[$Has] [Hs]"). - iIntros (v') "(%y & H1 & H2)". - simpl. - iExists y. - iFrame "H2". - iExists σ. - subst. - iFrame. - Qed. - - Lemma compat_if {S : Set} (Γ : S -> ty) τ α β1 β2 : - ⊢ valid1 Γ α Tnat -∗ - valid1 Γ β1 τ -∗ - valid1 Γ β2 τ -∗ - valid1 Γ (interp_if rs α β1 β2) τ. - Proof. - iIntros "H0 H1 H2". - iIntros (σ ss) "Hs #Has". - iSpecialize ("H0" with "Hs Has"). - simpl. - unshelve epose (K := _ : IT -n> IT). - { apply (λne x, IFSCtx (β1 ss) (β2 ss) x). } - iApply (expr_pred_bind K with "H0"). - iIntros (αv) "Ha/=". - iDestruct "Ha" as (σ') "[Ha Hs]". - iDestruct "Ha" as (n) "Hn". - unfold IFSCtx. iIntros (x) "Hx". - (* iRewrite "Hn". *) - (* destruct n as [|n]. *) - (* - rewrite IF_False; last lia. *) - (* iApply ("H2" with "Hs Has Hx"). *) - (* - rewrite IF_True; last lia. *) - (* iApply ("H1" with "Hs Has Hx"). *) - Admitted. - - (* Lemma compat_input {S : Set} (Γ : S -> ty) : *) - (* ⊢ valid1 Γ (interp_input rs) Tnat. *) - (* Proof. *) - (* iIntros (σ ss) "Hs #Has". *) - (* iApply expr_pred_frame. *) - (* destruct (update_input σ) as [n σ'] eqn:Hinp. *) - (* iApply (wp_input with "Hs") . *) - (* { eauto. } *) - (* iNext. iIntros "_ Hs". *) - (* iApply wp_val. simpl. eauto with iFrame. *) - (* Qed. *) - - (* Lemma compat_output {S : Set} (Γ : S -> ty) α : *) - (* ⊢ valid1 Γ α Tnat → valid1 Γ (interp_output rs α) Tnat. *) - (* Proof. *) - (* iIntros "H". *) - (* iIntros (σ ss) "Hs #Has". *) - (* iSpecialize ("H" with "Hs Has"). *) - (* simpl. *) - (* iApply (expr_pred_bind (get_ret _) with "H"). *) - (* iIntros (αv) "Ha". *) - (* iDestruct "Ha" as (σ') "[Ha Hs]". *) - (* iDestruct "Ha" as (n) "Hn". *) - (* iApply expr_pred_frame. *) - (* iRewrite "Hn". *) - (* rewrite get_ret_ret. *) - (* iApply (wp_output with "Hs"). *) - (* { reflexivity. } *) - (* iNext. iIntros "_ Hs /=". *) - (* eauto with iFrame. *) - (* Qed. *) - - (* Lemma compat_app {S : Set} (Γ : S -> ty) α β τ1 τ2 : *) - (* ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ *) - (* valid1 Γ β τ1 -∗ *) - (* valid1 Γ (interp_app rs α β) τ2. *) - (* Proof. *) - (* iIntros "H1 H2". *) - (* iIntros (σ ss) "Hs #Has". simpl. *) - (* iSpecialize ("H2" with "Hs Has"). *) - (* iApply (expr_pred_bind (AppRSCtx _) with "H2"). *) - (* iIntros (βv) "Hb/=". *) - (* iDestruct "Hb" as (σ') "[Hb Hs]". *) - (* unfold AppRSCtx. *) - (* iSpecialize ("H1" with "Hs Has"). *) - (* iApply (expr_pred_bind (AppLSCtx (IT_of_V βv)) with "H1"). *) - (* iIntros (αv) "Ha". *) - (* iDestruct "Ha" as (σ'') "[Ha Hs]". *) - (* unfold AppLSCtx. *) - (* iApply ("Ha" with "Hs Hb"). *) - (* Qed. *) - - (* Lemma compat_rec {S : Set} (Γ : S -> ty) τ1 τ2 α : *) - (* ⊢ □ valid1 ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) α τ2 -∗ *) - (* valid1 Γ (interp_rec rs α) (Tarr τ1 τ2). *) - (* Proof. *) - (* iIntros "#H". iIntros (σ ss) "Hs #Hss". *) - (* pose (env := ss). fold env. *) - (* pose (f := (ir_unf rs α env)). *) - (* iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". *) - (* { iPureIntro. apply interp_rec_unfold. } *) - (* iRewrite "Hf". iApply expr_pred_ret. simpl. *) - (* iExists _. iFrame. iModIntro. *) - (* iLöb as "IH". iSimpl. *) - (* clear σ. *) - (* iIntros (σ βv) "Hs #Hw". *) - (* iIntros (x) "Hx". *) - (* iApply wp_lam. *) - (* iNext. *) - (* unfold valid1. *) - (* iAssert (IT_of_V (FunV (Next f)) ≡ interp_rec rs α env)%I as "Heq". *) - (* { rewrite interp_rec_unfold. done. } *) - (* iRewrite -"Heq". *) - (* unfold f. *) - (* Opaque extend_scope. *) - (* simpl. *) - (* pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V βv))). *) - (* iApply ("H" with "[$Hs] [] [$Hx]"). *) - (* Transparent extend_scope. *) - (* iIntros (x'); destruct x' as [| [| x']]; simpl. *) - (* - iModIntro. *) - (* by iApply expr_pred_ret. *) - (* - iModIntro. *) - (* iRewrite - "Heq". *) - (* iApply expr_pred_ret. *) - (* iModIntro. *) - (* iApply "IH". *) - (* - iApply "Hss". *) - (* Qed. *) - - (* Lemma compat_natop {S : Set} (Γ : S -> ty) op α β : *) - (* ⊢ valid1 Γ α Tnat -∗ *) - (* valid1 Γ β Tnat -∗ *) - (* valid1 Γ (interp_natop _ op α β) Tnat. *) - (* Proof. *) - (* iIntros "H1 H2". *) - (* iIntros (σ ss) "Hs #Has". simpl. *) - (* iSpecialize ("H2" with "Hs Has"). *) - (* iApply (expr_pred_bind (NatOpRSCtx _ _) with "H2"). *) - (* iIntros (βv) "Hb/=". *) - (* iDestruct "Hb" as (σ') "[Hb Hs]". *) - (* unfold NatOpRSCtx. *) - (* iSpecialize ("H1" with "Hs Has"). *) - (* iApply (expr_pred_bind (NatOpLSCtx _ (IT_of_V βv)) with "H1"). *) - (* iIntros (αv) "Ha". *) - (* iDestruct "Ha" as (σ'') "[Ha Hs]". *) - (* unfold NatOpLSCtx. *) - (* iDestruct "Hb" as (n1) "Hb". *) - (* iDestruct "Ha" as (n2) "Ha". *) - (* iRewrite "Hb". iRewrite "Ha". *) - (* simpl. iApply expr_pred_frame. *) - (* rewrite NATOP_Ret. iApply wp_val. simpl. *) - (* eauto with iFrame. *) - (* Qed. *) - - Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β : - ⊢ valid1 Γ α τ -∗ - valid1 Γ β (Tcont τ) -∗ - valid1 Γ (interp_throw _ α β) τ'. - Proof. - iIntros "H1 H2". - iIntros (σ ss) "Hs #Has"; simpl. - - Admitted. - - Lemma compat_callcc {S : Set} (Γ : S -> ty) τ α : - ⊢ valid1 (Γ ▹ Tcont τ) α τ -∗ - valid1 Γ (interp_callcc _ α) τ. - Proof. - Admitted. - - Lemma fundamental {S : Set} (Γ : S -> ty) e τ : - typed Γ e τ → ⊢ valid1 Γ (interp_expr rs e) τ - with fundamental_val {S : Set} (Γ : S -> ty) v τ : - typed_val Γ v τ → ⊢ valid1 Γ (interp_val rs v) τ. - Proof. - - destruct 1. - + by iApply fundamental_val. - + by iApply compat_var. - + iApply compat_app; iApply fundamental; eauto. - + iApply compat_natop; iApply fundamental; eauto. - + iApply compat_if; iApply fundamental; eauto. - + iApply compat_input. - + iApply compat_output; iApply fundamental; eauto. - + iApply compat_throw; iApply fundamental; eauto. - + iApply compat_callcc; iApply fundamental; eauto. - - destruct 1. - + iApply compat_nat. - + iApply compat_rec; iApply fundamental; eauto. - Qed. - - Lemma fundmanetal_closed (e : expr ∅) (τ : ty) : - typed □ e τ → - ⊢ valid1 □ (interp_expr rs e) τ. - Proof. apply fundamental. Qed. - -End io_lang. - -Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _} τ. -Arguments interp_tarr {_ _ _ _ _ _ _ _ _ _ _} Φ1 Φ2. - -Local Definition rs : gReifiers _ := gReifiers_cons reify_io gReifiers_nil. - -Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. - -(* Check IT_of_to_V. *) -(* Search SetoidClass.Setoid. *) - -(* 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 ⊢ valid1 rs notStuck (λ _:unitO, True)%I □ α τ)%I) → *) *) -(* (* ssteps (gReifiers_sReifier rs) (α (@ı_scope _ rs R _)) 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 (interp_ty (s:=notStuck) (P:=(λ _:unitO, True)) τ)%I. split. *) *) -(* (* { 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" $! σ with "Hs []"). *) *) -(* (* { iApply ssubst_valid_nil. } *) *) -(* (* iSpecialize ("Hlog" $! tt with "[//]"). *) *) -(* (* iApply (wp_wand with"Hlog"). *) *) -(* (* iIntros ( βv). simpl. iDestruct 1 as (_) "[H _]". *) *) -(* (* iDestruct "H" as (σ1') "[$ Hsts]". *) *) -(* (* done. *) *) -(* (* Qed. *) *) - -(* Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : *) -(* typed empC e τ → *) -(* ssteps (gReifiers_sReifier rs) (interp_expr _ e ()) (σ,()) β st' k → *) -(* (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) *) -(* ∨ (∃ βv, IT_of_V βv ≡ β). *) -(* Proof. *) -(* intros Htyped Hsteps. *) -(* pose (Σ:=#[invΣ;stateΣ rs natO]). *) -(* assert (invGpreS Σ). *) -(* { apply _. } *) -(* assert (statePreG rs natO Σ). *) -(* { apply _. } *) -(* eapply (logpred_adequacy 0 Σ); eauto. *) -(* intros ? ?. iIntros "_". *) -(* by iApply fundamental. *) -(* Qed. *) diff --git a/theories/lang_generic.v b/theories/lang_generic.v index 535a89f..25d604f 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -194,21 +194,24 @@ Section kripke_logrel. eauto with iFrame. Qed. - (* Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} : *) - (* expr_pred α Ψ ⊢ *) - (* (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ *) - (* expr_pred (f α) Φ. *) - (* Proof. *) - (* iIntros "H1 H2". *) - (* iIntros (x) "Hx". *) - (* iApply wp_bind. *) - (* { solve_proper. } *) - (* iSpecialize ("H1" with "Hx"). *) - (* iApply (wp_wand with "H1"). *) - (* iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". *) - (* iModIntro. *) - (* iApply ("H2" with "Hb Hy"). *) - (* Qed. *) + Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} + {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} : + expr_pred α Ψ ⊢ + (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ + expr_pred (f α) Φ. + Proof. + iIntros "H1 H2". + iIntros (x) "Hx". + iApply wp_bind. + { solve_proper. } + iSpecialize ("H1" with "Hx"). + iApply (wp_wand with "H1"). + iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". + iModIntro. + iApply ("H2" with "Hb Hy"). + Qed. Lemma expr_pred_frame α Φ : WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. @@ -220,4 +223,4 @@ Section kripke_logrel. Qed. End kripke_logrel. -(* Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. *) +Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_ _}. diff --git a/theories/program_logic.v b/theories/program_logic.v index 83cf06c..eb86191 100644 --- a/theories/program_logic.v +++ b/theories/program_logic.v @@ -21,31 +21,41 @@ Section program_logic. rewrite -Tick_eq. by iApply wp_tick. Qed. - - (* Lemma clwp_seq α β s (Φ : ITV -n> iProp) : *) - (* CLWP@{rs} α @ s {{ (constO (CLWP@{rs} β @ s {{ Φ }})) }} ⊢ CLWP@{rs} SEQ α β @ s {{ Φ }}. *) - (* Proof. *) - (* iIntros "H". *) - (* iApply (clwp_bind _ (SEQCtx β)). *) - (* iApply (clwp_wand with "H"). *) - (* iIntros (?) "Hb". unfold SEQCtx. *) - (* simpl. *) - (* match goal with *) - (* | |- context G [ofe_mor_car _ _ (get_val ?a) ?b] => *) - (* idtac *) - (* end. *) - (* simpl. *) - (* (* rewrite SEQ_Val. *) *) - (* Admitted. *) - - (* Lemma clwp_let α (f : IT -n> IT) {Hf : IT_hom f} s (Φ : ITV -n> iProp) : *) - (* CLWP@{rs} α @ s {{ (λne αv, CLWP@{rs} f (IT_of_V αv) @ s {{ Φ }}) }} ⊢ CLWP@{rs} (LET α f) @ s {{ Φ }}. *) - (* Proof. *) - (* iIntros "H". *) - (* iApply (clwp_bind _ (LETCTX f)). *) - (* iApply (clwp_wand with "H"). *) - (* iIntros (?) "Hb". simpl. *) - (* (* by rewrite LET_Val. *) *) - (* Admitted. *) End program_logic. + +Section program_logic_ctx_indep. + Context {sz : nat}. + Variable rs : gReifiers sz. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) + (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. + + Lemma wp_seq α β s Φ `{!NonExpansive Φ} : + WP@{rs} α @ s {{ _, WP@{rs} β @ s {{ Φ }} }} ⊢ WP@{rs} SEQ α β @ s {{ Φ }}. + Proof using HCI. + iIntros "H". + iApply (wp_bind _ (SEQCtx β)). + iApply (wp_wand with "H"). + iIntros (?) "Hb". unfold SEQCtx. + by rewrite SEQ_Val. + Qed. + + Lemma wp_let α (f : IT -n> IT) s Φ `{!NonExpansive Φ} : + WP@{rs} α @ s {{ αv, WP@{rs} f (IT_of_V αv) @ s {{ Φ }} }} ⊢ WP@{rs} (LET α f) @ s {{ Φ }}. + Proof using HCI. + iIntros "H". + iApply (wp_bind _ (LETCTX f)). + iApply (wp_wand with "H"). + iIntros (?) "Hb". simpl. + by rewrite LET_Val. + Qed. + +End program_logic_ctx_indep. From 410b665603368867257c26633ba52b171a95badb Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Mon, 11 Dec 2023 15:49:35 +0100 Subject: [PATCH 054/114] Natop refactored + a useful rewriting lemma --- theories/input_lang_callcc/logrel.v | 127 ++++++++++------------------ 1 file changed, 44 insertions(+), 83 deletions(-) diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index c7e776a..88e23f3 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -220,6 +220,11 @@ Section logrel. apply _. Qed. + Lemma HOM_compose_ccompose (f g h : HOM) : + h = HOM_compose f g -> + `f ◎ `g = `h. + Proof. intros ->. done. Qed. + Lemma logrel_bind {S} (f : HOM) (K : ectx S) e α τ1 : ⊢ logrel τ1 α e -∗ logrel_ectx (logrel_val τ1) f K -∗ @@ -329,8 +334,7 @@ Section logrel. iIntros (κ K) "#HK". assert ((`κ) ((IFSCtx (α1 ss) (α2 ss)) (α0 ss)) = ((`κ) ◎ (`κ')) (α0 ss)) as -> by reflexivity. - pose (sss := (HOM_compose κ κ')). - assert ((`κ ◎ `κ') = (`sss)) as -> by reflexivity. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. assert (fill K (if bind γ e0 then bind γ e1 else bind γ e2)%syn = fill (ectx_compose K (IfK EmptyK (bind γ e1) (bind γ e2))) (bind γ e0)) as ->. { rewrite -fill_comp. reflexivity. } @@ -416,76 +420,42 @@ Section logrel. iSpecialize ("H1" with "Hss"). iSpecialize ("H2" with "Hss"). term_simpl. - pose (κ' := (NatOpRSCtx_HOM op α1 ss)). - assert ((NATOP (do_natop op) (α1 ss) (α2 ss)) = ((`κ') (α2 ss))) as ->. - { reflexivity. } iIntros (κ K) "#HK". - assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α2 ss)) as ->. - { reflexivity. } - pose (sss := (HOM_compose κ κ')). - assert ((`κ ◎ `κ') = (`sss)) as ->. - { reflexivity. } - assert (fill K (NatOp op (bind γ e1) (bind γ e2))%syn = fill (ectx_compose K (NatOpRK op (bind γ e1) EmptyK)) (bind γ e2)) as ->. - { rewrite -fill_comp. - reflexivity. + set (κ' := (NatOpRSCtx_HOM op α1 ss)). + assert ((NATOP (do_natop op) (α1 ss) (α2 ss)) = ((`κ') (α2 ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (NatOp op (bind γ e1) (bind γ e2))%syn = + fill (ectx_compose K (NatOpRK op (bind γ e1) EmptyK)) (bind γ e2)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (logrel_bind with "H2"). + iIntros (βv v). iModIntro. iIntros "(%n2 & #HV & ->)". + term_simpl. clear κ' sss. + rewrite -fill_comp. simpl. + pose (κ' := (NatOpLSCtx_HOM op (IT_of_V βv) ss _)). + assert ((NATOP (do_natop op) (α1 ss) (IT_of_V βv)) = ((`κ') (α1 ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (NatOp op (bind γ e1) (LitV n2))%syn = + fill (ectx_compose K (NatOpLK op EmptyK (LitV n2))) (bind γ e1)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (logrel_bind with "H1"). + subst sss κ'. + term_simpl. + iIntros (t r). iModIntro. iIntros "(%n1 & #H & ->)". + simpl. + iAssert ((NATOP (do_natop op) (IT_of_V t) (IT_of_V βv)) ≡ Ret (do_natop op n1 n2))%I with "[HV H]" as "Hr". + { iRewrite "HV". simpl. + iRewrite "H". simpl. + iPureIntro. + by rewrite NATOP_Ret. } - iApply (logrel_bind with "[H1] [H2]"). - - by iApply "H2". - - iIntros (βv v). iModIntro. iIntros "(%n1 & #HV & ->)". - term_simpl. - subst κ' sss. - unfold NatOpLSCtx. - rewrite -fill_comp. - simpl. - pose (κ' := (NatOpLSCtx_HOM op (IT_of_V βv) ss _)). - assert ((NATOP (do_natop op) (α1 ss) (IT_of_V βv)) = ((`κ') (α1 ss))) as ->. - { reflexivity. } - assert ((`κ) ((`κ') (α1 ss)) = ((`κ) ◎ (`κ')) (α1 ss)) as ->. - { reflexivity. } - pose (sss := (HOM_compose κ κ')). - assert ((`κ ◎ `κ') = (`sss)) as ->. - { reflexivity. } - assert (fill K (NatOp op (bind γ e1) (LitV n1))%syn = fill (ectx_compose K (NatOpLK op EmptyK (LitV n1))) (bind γ e1)) as ->. - { rewrite -fill_comp. - reflexivity. - } - iApply (logrel_bind with "[H1] [H2]"). - + by iApply "H1". - + subst sss κ'. - term_simpl. - iIntros (t r). iModIntro. iIntros "(%n2 & #H & ->)". - simpl. - iAssert ((NATOP (do_natop op) (IT_of_V t) (IT_of_V βv)) ≡ Ret (do_natop op n2 n1))%I with "[HV H]" as "Hr". - { iRewrite "HV". simpl. - iRewrite "H". simpl. - iPureIntro. - by rewrite NATOP_Ret. - } - iRewrite "Hr". - rewrite -fill_comp. - simpl. - rewrite -IT_of_V_Ret. - iSpecialize ("HK" $! (RetV (do_natop op n2 n1)) (LitV (do_natop op n2 n1)) with "[]"). - { - unfold logrel_nat. - by iExists (do_natop op n2 n1). - } - iIntros (σ) "Hs". - iSpecialize ("HK" $! σ with "Hs"). - iApply (wp_wand with "[$HK] []"). - simpl. - iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H' & G)". - destruct m as [m m']. - iModIntro. - iExists (m, m'), v'', σ''. iFrame "H' G". - iPureIntro. - eapply (prim_steps_app (0, 0) (m, m')); eauto. - term_simpl. - eapply prim_step_steps. - eapply Ectx_step; [reflexivity | reflexivity |]. - constructor. - simpl. - reflexivity. + rewrite -fill_comp. simpl. + iApply (logrel_head_step_pure_ectx _ EmptyK (Val (LitV (do_natop op n1 n2))) with "[]"); + last done; last first. + + simpl. iRewrite "Hr". iApply (logrel_of_val Tnat (RetV (do_natop op n1 n2))). term_simpl. + iExists _. iSplit; eauto. + + intros. by constructor. Qed. Program Definition ThrowLSCtx_HOM {S : Set} @@ -504,16 +474,10 @@ Section logrel. Next Obligation. intros; simpl. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - solve_proper_prepare. - destruct Hv as [? <-]. - rewrite ->2 get_val_ITV. - simpl. - by f_equiv. + - solve_proper_please. - destruct Hv as [? <-]. rewrite ->2 get_val_ITV. - simpl. - rewrite get_fun_tick. - f_equiv. + simpl. by rewrite get_fun_tick. - destruct Hv as [x Hv]. rewrite <- Hv. rewrite -> get_val_ITV. @@ -522,14 +486,11 @@ Section logrel. repeat f_equiv. intro; simpl. rewrite <- Hv. - rewrite -> get_val_ITV. - simpl. - f_equiv. + by rewrite -> get_val_ITV. - destruct Hv as [? <-]. rewrite get_val_ITV. simpl. - rewrite get_fun_err. - reflexivity. + by rewrite get_fun_err. Qed. From f2ce3da14dc5054163bf6baae1b6a633f3db5add Mon Sep 17 00:00:00 2001 From: Kaptch Date: Mon, 11 Dec 2023 16:02:39 +0100 Subject: [PATCH 055/114] upstream version of iris and stdpp --- flake.lock | 8 ++++---- flake.nix | 32 ++++---------------------------- 2 files changed, 8 insertions(+), 32 deletions(-) diff --git a/flake.lock b/flake.lock index 99cdf3e..0890c9c 100644 --- a/flake.lock +++ b/flake.lock @@ -20,16 +20,16 @@ }, "nixpkgs": { "locked": { - "lastModified": 1696983906, - "narHash": "sha256-L7GyeErguS7Pg4h8nK0wGlcUTbfUMDu+HMf1UcyP72k=", + "lastModified": 1701952659, + "narHash": "sha256-TJv2srXt6fYPUjxgLAL0cy4nuf1OZD4KuA1TrCiQqg0=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "bd1cde45c77891214131cbbea5b1203e485a9d51", + "rev": "b4372c4924d9182034066c823df76d6eaf1f4ec4", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixos-23.05", + "ref": "nixos-23.11", "repo": "nixpkgs", "type": "github" } diff --git a/flake.nix b/flake.nix index d2f37bc..e05e6a3 100644 --- a/flake.nix +++ b/flake.nix @@ -1,7 +1,7 @@ { description = "gitrees"; inputs = { - nixpkgs.url = github:NixOS/nixpkgs/nixos-23.05; + nixpkgs.url = github:NixOS/nixpkgs/nixos-23.11; flake-utils.url = github:numtide/flake-utils; }; outputs = { self, nixpkgs, flake-utils }: @@ -11,28 +11,6 @@ lib = pkgs.lib; coq = pkgs.coq_8_17; coqPkgs = pkgs.coqPackages_8_17; - ocamlPkgs = coq.ocamlPackages; - stdpp-dev = coqPkgs.lib.overrideCoqDerivation - { - defaultVersion = "1.9.0"; - release."1.9.0".sha256 = "sha256-OXeB+XhdyzWMp5Karsz8obp0rTeMKrtG7fu/tmc9aeI="; - } coqPkgs.stdpp; - iris-dev = coqPkgs.mkCoqDerivation rec { - pname = "iris"; - domain = "gitlab.mpi-sws.org"; - owner = "iris"; - defaultVersion = "4.1.0"; - release."4.1.0".sha256 = "sha256-nTZUeZOXiH7HsfGbMKDE7vGrNVCkbMaWxdMWUcTUNlo="; - releaseRev = v: "iris-${v}"; - - propagatedBuildInputs = [ stdpp-dev ]; - - preBuild = '' - if [[ -f coq-lint.sh ]] - then patchShebangs coq-lint.sh - fi - ''; - }; in { packages = { coq-artifact = coqPkgs.mkCoqDerivation { @@ -41,8 +19,8 @@ src = ./.; buildPhase = "make"; propagatedBuildInputs = [ - stdpp-dev - iris-dev + coqPkgs.stdpp + coqPkgs.iris coqPkgs.equations ]; }; @@ -50,10 +28,8 @@ devShell = pkgs.mkShell { buildInputs = with pkgs; [ coq - stdpp-dev - iris-dev - coqPkgs.equations ]; + inputsFrom = [ self.packages.${system}.coq-artifact ]; }; }); } From 899ec45376d8a8d2bc4de5e2660f060917ebfacb Mon Sep 17 00:00:00 2001 From: Kaptch Date: Mon, 11 Dec 2023 16:55:21 +0100 Subject: [PATCH 056/114] opam upd --- coq-gitrees.opam | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/coq-gitrees.opam b/coq-gitrees.opam index d34f9db..8a0f678 100644 --- a/coq-gitrees.opam +++ b/coq-gitrees.opam @@ -10,8 +10,8 @@ install: [make "install"] remove: ["rm" "-rf" "%{lib}%/coq/user-contrib/gitrees"] depends: [ "coq-equations" { (= "1.3+8.17") } - "coq-iris" { (= "dev.2023-09-29.0.4f3a385f") } - "coq-iris-heap-lang" { (= "dev.2023-09-29.0.4f3a385f") } - "coq-stdpp" { (= "dev.2023-09-21.2.7f6df4fa") } + "coq-iris" { (= "4.1.0") } + "coq-iris-heap-lang" { (= "4.1.0") } + "coq-stdpp" { (= "1.9.0") } "coq" { (>= "8.17") | (= "dev") } ] From 247d0db4703dbb0b72cb4e207834767dc9655788 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Mon, 11 Dec 2023 17:29:05 +0100 Subject: [PATCH 057/114] last admits, delete redundant lemmas, upd todo --- TODO.md | 2 - theories/affine_lang/logrel1.v | 13 +- theories/affine_lang/logrel2.v | 13 +- theories/gitree/weakestpre.v | 305 --------------------------------- 4 files changed, 22 insertions(+), 311 deletions(-) diff --git a/TODO.md b/TODO.md index d76f203..1038abe 100644 --- a/TODO.md +++ b/TODO.md @@ -2,10 +2,8 @@ - cleanup code + especially implicit arguments, inserted by typeclasses + lemmas for logrel - + update opam ci - backward compatibility + instances of CtxIndep from individual effects, from sreifiers to greifiers - + last admits - write summary + reifiers changes + non-cps vs cps diff --git a/theories/affine_lang/logrel1.v b/theories/affine_lang/logrel1.v index a5a1f0b..85a6c87 100644 --- a/theories/affine_lang/logrel1.v +++ b/theories/affine_lang/logrel1.v @@ -447,7 +447,16 @@ Proof. simpl. destruct σ as [? [? ?]]. simpl. - admit. + match goal with + | |- context G [@mbind option option_bind _ _ ?a ?b] => set (x := b) + end. + symmetry. + match goal with + | |- context G [@mbind option option_bind _ _ ?a ?b] => set (y := b) + end. + assert (y = x) as ->. + { reflexivity. } + destruct x as [x |]; reflexivity. + constructor. unshelve eexists (λne '((l,n),(s, s'')), let s' := <[l:=n]>s in Some ((), (s', s''))). @@ -546,7 +555,7 @@ Proof. destruct σ as [σ1 [? []]]; simpl in *. reflexivity. + intros i; by apply fin_0_inv. -Admitted. +Qed. Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. diff --git a/theories/affine_lang/logrel2.v b/theories/affine_lang/logrel2.v index b22771e..1255b25 100644 --- a/theories/affine_lang/logrel2.v +++ b/theories/affine_lang/logrel2.v @@ -486,7 +486,16 @@ Proof. simpl. destruct σ as [? [? ?]]. simpl. - admit. + match goal with + | |- context G [@mbind option option_bind _ _ ?a ?b] => set (x := b) + end. + symmetry. + match goal with + | |- context G [@mbind option option_bind _ _ ?a ?b] => set (y := b) + end. + assert (y = x) as ->. + { reflexivity. } + destruct x as [x |]; reflexivity. + constructor. unshelve eexists (λne '((l,n),(s, s'')), let s' := <[l:=n]>s in Some ((), (s', s''))). @@ -585,7 +594,7 @@ Proof. destruct σ as [σ1 [? []]]; simpl in *. reflexivity. + intros i; by apply fin_0_inv. -Admitted. +Qed. Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index 6358ffd..3697856 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -718,305 +718,24 @@ Section weakestpre. iExFalso. iApply (option_equivI with "Hb"). Qed. - Definition clwp_def (e : IT) (s : stuckness) E (Φ : ITV -n> iProp) : iProp := - (∀ (K : IT -n> IT) {HK : IT_hom K} (Ψ : ITV -n> iProp), (∀ v, Φ v -∗ wp (K (IT_of_V v)) s E Ψ) - -∗ wp (K e) s E Ψ). - Definition clwp_aux : seal (@clwp_def). by eexists. Qed. - Definition clwp := unseal clwp_aux. - Definition clwp_eq : @clwp = @clwp_def := seal_eq clwp_aux. - - Notation "'CLWP' e @ s ; E {{ Φ } }" := - (clwp e s E Φ) - (at level 20, e, s, Φ at level 200, - format "'CLWP' e @ s ; E {{ Φ } }") : bi_scope. - - Notation "'CLWP' α @ s ; E {{ v , Q } }" := - (clwp α s E (λne v, Q)) - (at level 20, α, s, Q at level 200, - format "'[hv' 'CLWP' α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. - - Notation "'CLWP' α @ s {{ β , Φ } }" := - (clwp α s ⊤ (λne β, Φ)) - (at level 20, α, Φ at level 200, - format "'CLWP' α @ s {{ β , Φ } }") : bi_scope. - - Notation "'CLWP' α @ s {{ Φ } }" := - (clwp α s ⊤ Φ) - (at level 20, α, Φ at level 200, - format "'CLWP' α @ s {{ Φ } }") : bi_scope. - - Lemma clwp_cl {s E e} {Φ : ITV -n> iProp} (K : IT -n> IT) {HK : IT_hom K} : - CLWP e @ s ; E {{ Φ }} -∗ - (∀ (Ψ : ITV -n> iProp), (∀ v, Φ v -∗ WP (K (IT_of_V v)) @ s ; E {{ Ψ }}) - -∗ WP (K e) @ s ; E {{ Ψ }})%I. - Proof. - rewrite clwp_eq /clwp_def. iIntros "H". iIntros (?). - iApply "H". - Qed. - - Lemma unfold_clwp (s : stuckness) (E : coPset) (e : IT) (Φ : ITV -n> iProp) : - CLWP e @ s ; E {{Φ}} ⊣⊢ - (∀ (K : IT -n> IT) {HK : IT_hom K} (Ψ : ITV -n> iProp), (∀ v, Φ v -∗ WP (K (IT_of_V v)) @ s ; E {{ Ψ }}) - -∗ WP (K e) @ s ; E {{ Ψ }})%I. - Proof. - by rewrite clwp_eq /clwp_def. - Qed. - - Lemma clwp_wp s (E : coPset) (e : IT) (Φ : ITV -n> iProp) : - CLWP e @ s ; E {{ Φ }} ⊢ WP e @ s ; E {{ Φ }}. - Proof. - iIntros "H". rewrite unfold_clwp. - unshelve iSpecialize ("H" $! idfun _ Φ with "[]"). - - apply _. - - iIntros (w) "Hw". simpl. - iApply wp_val; rewrite /IntoVal /=. - done. - - by simpl. - Qed. - - Global Instance clwp_ne s E e m : - Proper ((dist m) ==> dist m) (clwp e s E). - Proof. - repeat intros?; rewrite !unfold_clwp. - solve_proper. - Qed. - - Global Instance clwp_proper s E e : - Proper ((≡) ==> (≡)) (clwp e s E). - Proof. - by intros Φ Φ' ?; apply equiv_dist=>m; apply clwp_ne=>v; apply equiv_dist. - Qed. - - Lemma clwp_value' s E (Φ : ITV -n> iProp) v : - Φ v ⊢ CLWP (IT_of_V v) @ s ; E {{ Φ }}. - Proof. - iIntros "HΦ"; rewrite unfold_clwp. - iIntros (K HK Ψ) "HK". iApply ("HK" with "HΦ"). - Qed. - - Lemma clwp_value_inv s E (Φ : ITV -n> iProp) v : - CLWP (IT_of_V v) @ s ; E {{ Φ }} ={E}=∗ Φ v. - Proof. - iIntros "H"; iApply wp_val_inv'; last by iApply clwp_wp. - iPureIntro. by apply IT_to_of_V. - Qed. - - Lemma fupd_clwp s E e (Φ : ITV -n> iProp) : - (|={E}=> CLWP e @ s ; E {{ Φ }}) ⊢ CLWP e @ s ; E {{ Φ }}. - Proof. - iIntros "H"; rewrite !unfold_clwp. - iIntros (K HK Ψ) "HK". - iMod "H"; by iApply "H". - Qed. - - Global Instance clwp_ne' s E (Φ : ITV -n> iProp) m : - Proper ((dist m) ==> dist m) (fun x => clwp x s E Φ). - Proof. - repeat intros?; rewrite !unfold_clwp. - solve_proper. - Qed. - - Global Instance clwp_proper' s E (Φ : ITV -n> iProp) : - Proper ((≡) ==> (≡)) (fun x => clwp x s E Φ). - Proof. - intros e e' ?. - rewrite !unfold_clwp. - solve_proper. - Qed. - - Global Instance clwp_ne'' s E (Φ : ITV -n> iProp) m : - Proper ((dist m) ==> dist m) (fun (x : ITVO) => clwp (IT_of_V x) s E Φ). - Proof. - repeat intros?; rewrite !unfold_clwp. - solve_proper. - Qed. - - Global Instance clwp_proper'' s E (Φ : ITV -n> iProp) : - Proper ((≡) ==> (≡)) (fun (x : ITVO) => clwp (IT_of_V x) s E Φ). - Proof. - intros e e' ?. - rewrite !unfold_clwp. - solve_proper. - Qed. - - Global Instance clwp_ne''' s E (Φ : ITV -n> iProp) (K : IT -n> IT) {HK : IT_hom K} : - NonExpansive (λ v : ITVO, (CLWP (K (IT_of_V v)) @ s ; E{{ Φ }})%I). - Proof. - repeat intros?; rewrite !unfold_clwp. - solve_proper. - Qed. - Global Instance upd_ne {X : ofe} E (Φ : X -n> iProp) : NonExpansive (λ (a : X), (|={E}=> Φ a)%I). Proof. solve_proper. Qed. - Lemma clwp_fupd s E e (Φ : ITV -n> iProp) : - CLWP e @ s ; E {{ v , |={E}=> Φ v }} ⊢ CLWP e @ s ; E {{ Φ }}. - Proof. - iIntros "H"; rewrite !unfold_clwp. - iIntros (K HK Ψ) "HK". - iApply "H". iIntros (w) ">Hw"; by iApply "HK". - Qed. - - Lemma clwp_bind (K : IT -n> IT) {HK : IT_hom K} s E e (Φ : ITV -n> iProp) : - CLWP e @ s ; E {{ v , CLWP (K (IT_of_V v)) @ s ; E {{ Φ }} }} - ⊢ CLWP (K e) @ s ; E {{ Φ }}. - Proof. - iIntros "H"; rewrite !unfold_clwp. iIntros (K' HK' Ψ) "HK'". - assert (K' (K e) = (K' ◎ K) e) as ->; first done. - iApply "H". - - iPureIntro. - apply _. - - iIntros (v) "Hv". - simpl. - rewrite !unfold_clwp. - iApply "Hv". - iIntros (w) "Hw". - by iApply "HK'". - Qed. - - Lemma clwp_mono E e (Φ Ψ : ITV -n> iProp) : (∀ v, Φ v ⊢ Ψ v) → - CLWP e @ E {{ Φ }} ⊢ CLWP e @ E {{ Ψ }}. - Proof. - iIntros (HΦ) "H"; rewrite !unfold_clwp. iIntros (K HK χ) "HK". - iApply "H". iIntros (w) "Hw". iApply "HK"; by iApply HΦ. - Qed. - - (* Lemma clwp_value s E (Φ : ITV -n> iProp) e v `{!IntoVal e v} : *) - (* Φ v ⊢ CLWP e @ s ; E {{ Φ }}. *) - (* Proof. *) - (* iIntros "H". *) - (* assert (e = IT_of_V v) as ->. *) - (* { admit. } *) - (* by iApply clwp_value'. *) - (* Admitted. *) - - Lemma clwp_value_fupd' s E (Φ : ITV -n> iProp) v : - (|={E}=> Φ v) ⊢ CLWP (IT_of_V v) @ s ; E {{ Φ }}. - Proof. intros. by rewrite -clwp_fupd -clwp_value'. Qed. - - (* Lemma clwp_value_fupd s E (Φ : ITV -n> iProp) e v `{!IntoVal e v} : *) - (* (|={E}=> Φ v) ⊢ CLWP e @ s ; E {{ Φ }}. *) - (* Proof. intros. rewrite -clwp_fupd -clwp_value //. Qed. *) - Global Instance upd_ast_l {X : ofe} R (Φ : X -n> iProp) : NonExpansive (λ (a : X), (R ∗ Φ a)%I). Proof. solve_proper. Qed. - Lemma clwp_frame_l s E e (Φ : ITV -n> iProp) R : - R ∗ CLWP e @ s ; E {{ Φ }} ⊢ CLWP e @ s ; E {{ v, R ∗ Φ v }}. - Proof. - iIntros "[HR H]"; rewrite !unfold_clwp. iIntros (K HK Ψ) "HK". - iApply "H". iIntros (v) "Hv". iApply "HK"; iFrame. - Qed. - Global Instance upd_ast_r {X : ofe} R (Φ : X -n> iProp) : NonExpansive (λ (a : X), (Φ a ∗ R)%I). Proof. solve_proper. Qed. - Lemma clwp_frame_r s E e (Φ : ITV -n> iProp) R : - CLWP e @ s ; E {{ Φ }} ∗ R ⊢ CLWP e @ s ; E {{ v, Φ v ∗ R }}. - Proof. - iIntros "[H HR]"; rewrite !unfold_clwp. iIntros (K HK Ψ) "HK". - iApply "H". iIntros (v) "Hv". iApply "HK"; iFrame. - Qed. - - Lemma clwp_wand s E e (Φ Ψ : ITV -n> iProp) : - CLWP e @ s ; E {{ Φ }} -∗ (∀ v, Φ v -∗ Ψ v) -∗ CLWP e @ s ; E {{ Ψ }}. - Proof. - iIntros "Hwp H". rewrite !unfold_clwp. - iIntros (K HK χ) "HK". - iApply "Hwp". iIntros (?) "?"; iApply "HK"; by iApply "H". - Qed. - - Lemma clwp_wand_l s E e (Φ Ψ : ITV -n> iProp) : - (∀ v, Φ v -∗ Ψ v) ∗ CLWP e @ s ; E {{ Φ }} ⊢ CLWP e @ s ; E {{ Ψ }}. - Proof. iIntros "[H Hwp]". iApply (clwp_wand with "Hwp H"). Qed. - - Lemma clwp_wand_r s E e (Φ Ψ : ITV -n> iProp) : - CLWP e @ s ; E {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ CLWP e @ s ; E {{ Ψ }}. - Proof. iIntros "[Hwp H]". iApply (clwp_wand with "Hwp H"). Qed. - - Lemma clwp_tick α s E1 Φ : - ▷ CLWP α @ s;E1 {{ Φ }} ⊢ CLWP (Tick α) @ s;E1 {{ Φ }}. - Proof. - iIntros "H". - rewrite clwp_eq /clwp_def. - iIntros (K HK Ψ) "G". - rewrite hom_tick. - iApply wp_tick. - iNext. - by iApply "H". - Qed. - - Lemma clwp_reify E1 s Φ i (lop : opid (sReifier_ops (rs !!! i))) - x k σ σ' β : - let op : opid F := (existT i lop) in - (∀ (k' : IT -n> IT) (HK : IT_hom k') rest, reify (Vis op x (laterO_map k' ◎ k)) (gState_recomp rest σ) ≡ (gState_recomp rest σ', Tick (k' β))) → - has_state_idx i σ -∗ - ▷ (£ 1 -∗ has_state_idx i σ' -∗ CLWP β @ s;E1 {{ Φ }}) - -∗ CLWP (Vis op x k) @ s;E1 {{ Φ }}. - Proof. - intros op Hr. - iIntros "Hlst H". - rewrite clwp_eq /clwp_def. - iIntros (K HK Ψ) "G". - rewrite hom_vis. - unshelve iApply (@wp_reify _ _ _ _ _ _ _ σ σ' (K β) with "[$Hlst] [-]"). - - intros. - rewrite -Hr. - do 3 f_equiv. - by intro; simpl. - - iNext. - iIntros "HC HS". - iSpecialize ("H" with "HC HS"). - unshelve iSpecialize ("H" $! K _); first apply _. - simpl. - by iApply "H". - Qed. - - Lemma clwp_subreify E1 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops sR)) - (x : Ins (sReifier_ops sR op) ♯ IT) (y : laterO IT) - (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) - (σ σ' : sReifier_state sR ♯ IT) β : - (∀ (k' : IT -n> IT) {Hk : IT_hom k'}, sReifier_re sR op (x, σ, (laterO_map k' ◎ k ◎ subEff_outs)) ≡ Some (Next (k' β), σ')) → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ CLWP β @ s;E1 {{ Φ }}) - -∗ - CLWP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. - Proof. - intros HSR. - iIntros "Hlst H". - iApply (clwp_reify with "Hlst H"). - intros k' ? rest. - rewrite reify_vis_eq //. - { - f_equiv. - symmetry. - apply Tick_eq. - } - pose proof (@subReifier_reify n sR rs _ IT _ op x (Next (k' β)) ((laterO_map k' ◎ k) ◎ subEff_outs) σ σ' rest) as H. - simpl in H. - simpl. - rewrite <-H. - { - repeat f_equiv. - - solve_proper. - - intro; simpl. - rewrite ofe_iso_12. - reflexivity. - } - clear H. - by apply HSR. - Qed. - Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 {G : ∀ o : opid F, CtxIndep rG IT o} : WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. Proof. @@ -1076,7 +795,6 @@ Section weakestpre. End weakestpre. Arguments wp {_} rs {_ _ _ _ _} α s E Φ. -Arguments clwp {_} rs {_ _ _ _ _} e s E Φ. Arguments has_full_state {n _ _ _ _ _} σ. Arguments has_state_idx {n _ _ _ _ _} i σ. Arguments has_substate {n _ _ _ _ _ _ _} σ. @@ -1109,29 +827,6 @@ Definition notStuck : stuckness := λ e, False. (at level 20, α, Φ at level 200, format "'WP@{' re } α {{ Φ } }") : bi_scope. - Notation "'CLWP@{' re } α @ s ; E {{ Φ } }" := (clwp re α s E Φ) - (at level 20, α, s, Φ at level 200, only parsing) : bi_scope. - - Notation "'CLWP@{' re } α @ s ; E {{ v , Q } }" := (clwp re α s E (λ v, Q)) - (at level 20, α, s, Q at level 200, - format "'[hv' 'CLWP@{' re } α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. - - Notation "'CLWP@{' re } α @ s {{ β , Φ } }" := (clwp re α s ⊤ (λ β, Φ)) - (at level 20, α, Φ at level 200, - format "'CLWP@{' re } α @ s {{ β , Φ } }") : bi_scope. - - Notation "'CLWP@{' re } α @ s {{ Φ } }" := (clwp re α s ⊤ Φ) - (at level 20, α, Φ at level 200, - format "'CLWP@{' re } α @ s {{ Φ } }") : bi_scope. - - Notation "'CLWP@{' re } α {{ β , Φ } }" := (clwp re α notStuck ⊤ (λ β, Φ)) - (at level 20, α, Φ at level 200, - format "'CLWP@{' re } α {{ β , Φ } }") : bi_scope. - - Notation "'CLWP@{' re } α {{ Φ } }" := (clwp re α notStuck ⊤ Φ) - (at level 20, α, Φ at level 200, - format "'CLWP@{' re } α {{ Φ } }") : bi_scope. - Lemma wp_adequacy cr Σ `{!invGpreS Σ} n (rs : gReifiers n) {A} `{!Cofe A} `{!statePreG rs A Σ} (α : IT _ A) σ βv σ' s k (ψ : (ITV (gReifiers_ops rs) A) → Prop) : From 83f01e135ac64403f19fe9748fcb16e1d7d2ee5e Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 12 Dec 2023 11:31:18 +0100 Subject: [PATCH 058/114] throw --- theories/input_lang_callcc/interp.v | 26 +++++----- theories/input_lang_callcc/logrel.v | 77 +++++++++++------------------ 2 files changed, 41 insertions(+), 62 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 475b385..a16b84c 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -261,24 +261,24 @@ Section weakestpre. (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) (* Qed. *) + Lemma wp_throw' (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) + (κ : IT -n> IT) `{!IT_hom κ} Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} (later_car f) x @ s {{ Φ }}) -∗ + WP@{rs} κ (THROW x f) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". rewrite /THROW. simpl. + rewrite hom_vis. + iApply (wp_subreify with "Hs"); simpl; done. + Qed. + + Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : has_substate σ -∗ ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ WP@{rs} (THROW x f) @ s {{ Φ }}. Proof. - iIntros "Hs Ha". - unfold THROW. simpl. - iApply (wp_subreify with "Hs"). - { - simpl. - do 2 f_equiv; reflexivity. - } - { - simpl. - reflexivity. - } - iModIntro. - iApply "Ha". + iApply (wp_throw' _ _ _ idfun). Qed. Lemma wp_callcc (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} Φ s : diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 3f7b398..9d305e2 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -505,24 +505,17 @@ Section logrel. Opaque interp_throw. term_simpl. pose (κ' := ThrowLSCtx_HOM β ss). - assert ((interp_throw rs α β ss) = ((`κ') (α ss))) as ->. - { reflexivity. } - assert ((`κ) ((`κ') (α ss)) = ((`κ) ◎ (`κ')) (α ss)) as ->. - { reflexivity. } - pose (sss := (HOM_compose κ κ')). - assert ((`κ ◎ `κ') = (`sss)) as ->. - { reflexivity. } - assert (fill K (Throw (bind γ e) (bind γ e'))%syn = fill (ectx_compose K (ThrowLK EmptyK (bind γ e'))) (bind γ e)) as ->. - { rewrite -fill_comp. - reflexivity. - } + assert ((interp_throw rs α β ss) = ((`κ') (α ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (Throw (bind γ e) (bind γ e'))%syn = + fill (ectx_compose K (ThrowLK EmptyK (bind γ e'))) (bind γ e)) + as -> by by rewrite -fill_comp. iApply obs_ref_bind; first by iApply "H1". iIntros (βv v). iModIntro. iIntros "#Hv". Transparent interp_throw. simpl. - rewrite get_val_ITV'. - simpl. - rewrite -!fill_comp. + rewrite get_val_ITV' -!fill_comp. simpl. pose (κ'' := @ThrowRSCtx_HOM S (IT_of_V βv) ss _). (* TODO: some typeclasses bs *) @@ -531,53 +524,39 @@ Section logrel. { subst κ''. simpl. by rewrite get_val_ITV. } - assert ((`κ) ((`κ'') (β ss)) = ((`κ) ◎ (`κ'')) (β ss)) as ->. - { reflexivity. } - pose (sss' := (HOM_compose κ κ'')). - assert ((`κ ◎ `κ'') = (`sss')) as ->. - { reflexivity. } - assert (fill K (Throw v (bind γ e'))%syn = fill (ectx_compose K (ThrowRK v EmptyK)) (bind γ e')) as ->. - { rewrite -fill_comp. - reflexivity. - } + rewrite HOM_ccompose. + pose (sss' := (HOM_compose κ κ'')). rewrite (HOM_compose_ccompose κ κ'' sss')//. + assert (fill K (Throw v (bind γ e'))%syn = + fill (ectx_compose K (ThrowRK v EmptyK)) (bind γ e')) + as -> by by rewrite -fill_comp. iApply obs_ref_bind; first by iApply "H2". iIntros (βv' v'). iModIntro. iIntros "#Hv'". Transparent interp_throw. simpl. unfold logrel_cont. - simpl. iDestruct "Hv'" as "(%f & %F & HEQ & %H & #H)". rewrite get_val_ITV. simpl. iRewrite "HEQ". rewrite get_fun_fun. simpl. - rewrite hom_vis. iIntros (σ) "Hs". - iApply (wp_subreify with "Hs"). - - simpl. - rewrite later_map_Next. - reflexivity. - - reflexivity. - - iNext. - iIntros "Hlc Hs". - rewrite -!fill_comp H. - simpl. - rewrite -Tick_eq. - iApply wp_tick. - iNext. - iSpecialize ("H" $! βv v with "[]"); first done. - iSpecialize ("H" $! σ with "Hs"). - iApply (wp_wand with "[$H] []"). - iIntros (w) "(%m & %v'' & %σ'' & %Hstep & H)". - destruct m as [m m']. - iModIntro. - iExists ((Nat.add 2 m), m'), v'', σ''. iFrame "H". - iPureIntro. - eapply (prim_steps_app (2, 0) (m, m')); eauto. - term_simpl. - eapply prim_step_steps. - eapply Throw_step; reflexivity. + iApply (wp_throw' with "Hs []"). + iNext. iIntros "Hcl Hs". term_simpl. + rewrite later_map_Next. iApply wp_tick. iNext. + iSpecialize ("H" $! βv v with "[]"); first done. + iSpecialize ("H" $! σ with "Hs"). + iApply (wp_wand with "[$H] []"). + iIntros (w) "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 2 m), m'), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (2, 0) (m, m')); eauto. + term_simpl. + eapply prim_step_steps. + eapply Throw_step; last done. + rewrite H. by rewrite -!fill_comp. Qed. From 9b442f7bc8217d4189779c9789538065d7690134 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 14 Dec 2023 10:22:41 +0100 Subject: [PATCH 059/114] callcc --- theories/input_lang_callcc/logrel.v | 118 ++++++++++++++-------------- 1 file changed, 57 insertions(+), 61 deletions(-) diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 9d305e2..6e50343 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -571,70 +571,66 @@ Section logrel. Opaque extend_scope. term_simpl. iIntros (σ) "Hs". - rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ (Next ((`κ) (α (extend_scope ss (λit x : IT, Tick ((`κ) x)))))) with "Hs"). - - simpl. - rewrite ofe_iso_21. - rewrite later_map_Next. - do 2 f_equiv; last reflexivity. - do 5 f_equiv. + + iApply (wp_callcc with "Hs []"). + iNext. iIntros "Hcl Hs". term_simpl. + + pose (ff := (λit x : IT, Tick ((`κ) x))). + match goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ extend_scope ss )?f] => set (fff := f) + end. + assert (ff ≡ fff) as Hf. + { subst ff fff. f_equiv. apply bi.siProp.internal_eq_soundness. - iApply later_equivI_2. - iNext. - simpl. - iApply internal_eq_pointwise. + iApply (later_equivI). + iNext. iApply (internal_eq_pointwise). iIntros. + simpl. by rewrite later_map_Next. + } + rewrite -Hf. + pose (ss' := (extend_scope ss ff)). + pose (γ' := ((mk_subst (Val (ContV K)%syn)) ∘ (γ ↑)%bind)%bind : inc S [⇒] ∅). + iSpecialize ("H" $! ss' γ' with "[HK]"). + { iIntros (x). - simpl. - rewrite Tick_eq. - iApply f_equivI. - rewrite ofe_iso_21. - done. - - reflexivity. - - iNext. - iIntros "Hlc Hs". - pose (ss' := (extend_scope ss (λit x : IT, Tick ((`κ) x)))). - pose (γ' := ((mk_subst (Val (ContV K)%syn)) ∘ (γ ↑)%bind)%bind : inc S [⇒] ∅). - iSpecialize ("H" $! ss' γ' with "[HK]"). - { - iIntros (x). - iModIntro. - destruct x as [| x]; term_simpl. - - Transparent extend_scope. - subst ss'; simpl. - pose proof (asval_fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))). - destruct H as [f H]. - rewrite -H. - iIntros (t r) "#H". - simpl. - iApply "H". - unfold logrel_cont. - iExists _, K. - iSplit. - + rewrite H. - done. - + iSplit; first done. - iModIntro. - iApply "HK". - - simpl. - iApply "Hss". - } - iSpecialize ("H" $! κ K with "HK"). - Opaque extend_scope. - term_simpl. - iSpecialize ("H" $! σ with "Hs"). - subst ss' γ'. - iApply (wp_wand with "[$H] []"). - iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". - destruct m as [m m']. - rewrite -bind_bind_comp' in Hstep. iModIntro. - iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H". - iPureIntro. - eapply (prim_steps_app (1, 1) (m, m')); eauto. - eapply prim_step_steps. - eapply Ectx_step; [reflexivity | reflexivity |]. - term_simpl. - constructor. + destruct x as [| x]; term_simpl. + - Transparent extend_scope. + subst ss'; simpl. + pose proof (asval_fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))). + destruct H as [f H]. + subst ff. + rewrite -H. + iIntros (t r) "#H". + simpl. + iApply "H". + unfold logrel_cont. + iExists _, K. + iSplit. + + rewrite H. + done. + + iSplit; first done. + iModIntro. + iApply "HK". + - simpl. + iApply "Hss". + } + iSpecialize ("H" $! κ K with "HK"). + Opaque extend_scope. + term_simpl. + iSpecialize ("H" $! σ with "Hs"). + subst ss' γ'. + iApply (wp_wand with "[$H] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + rewrite -bind_bind_comp' in Hstep. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + term_simpl. + constructor. Qed. Program Definition OutputSCtx_HOM {S : Set} From 5632aaaa532a11f0c11b5aaac993e75a3313cec2 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 14 Dec 2023 13:55:26 +0100 Subject: [PATCH 060/114] move HOM out --- theories/input_lang_callcc/hom.v | 130 ++++++++++++++++++++++++++++ theories/input_lang_callcc/logrel.v | 120 +------------------------ 2 files changed, 134 insertions(+), 116 deletions(-) create mode 100644 theories/input_lang_callcc/hom.v diff --git a/theories/input_lang_callcc/hom.v b/theories/input_lang_callcc/hom.v new file mode 100644 index 0000000..7250497 --- /dev/null +++ b/theories/input_lang_callcc/hom.v @@ -0,0 +1,130 @@ +From Equations Require Import Equations. +From gitrees Require Import gitree. +From gitrees.input_lang_callcc Require Import lang interp. +Require Import gitrees.lang_generic_sem. +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope stdpp_scope. + +Section hom. + Context {sz : nat}. + Context {rs : gReifiers sz}. + Context {subR : subReifier 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. + + 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) + : 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 natO _ S) + (Hv : AsVal α) + : HOM := exist _ (interp_natoplk rs op (λne env, idfun) (constO α) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition ThrowLSCtx_HOM {S : Set} + (α : @interp_scope F natO _ S -n> IT) + (env : @interp_scope F natO _ S) + : HOM := exist _ ((interp_throwlk rs (λne env, idfun) α env)) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition ThrowRSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F natO _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_throwrk rs (constO β) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - solve_proper_please. + - destruct Hv as [? <-]. + rewrite ->2 get_val_ITV. + simpl. by rewrite get_fun_tick. + - destruct Hv as [x Hv]. + rewrite <- Hv. + rewrite -> get_val_ITV. + simpl. + rewrite get_fun_vis. + repeat f_equiv. + intro; simpl. + rewrite <- Hv. + by rewrite -> get_val_ITV. + - destruct Hv as [? <-]. + rewrite get_val_ITV. + simpl. + by rewrite get_fun_err. + Qed. + + Program Definition OutputSCtx_HOM {S : Set} + (env : @interp_scope F natO _ S) + : HOM := 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) + : 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 natO _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_applk rs (λne env, idfun) (constO β) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + +End hom. diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 6e50343..a8be3c8 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -1,7 +1,7 @@ (** Logical relation for adequacy for the IO lang *) From Equations Require Import Equations. From gitrees Require Import gitree. -From gitrees.input_lang_callcc Require Import lang interp. +From gitrees.input_lang_callcc Require Import lang interp hom. Require Import gitrees.lang_generic_sem. Require Import Binding.Lib Binding.Set Binding.Env. @@ -39,13 +39,6 @@ Section logrel. WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ ∗ logrel_nat βv v ∗ has_substate σ' }})%I. - Definition HOM : ofe := @sigO (IT -n> IT) IT_hom. - - Global Instance HOM_hom (κ : HOM) : IT_hom (`κ). - Proof. - apply (proj2_sig κ). - Qed. - Definition logrel_ectx {S} V (κ : HOM) (K : ectx S) : iProp := (□ ∀ (βv : ITV) (v : val S), V βv v -∗ obs_ref (`κ (IT_of_V βv)) (fill K (Val v)))%I. @@ -208,23 +201,6 @@ Section logrel. eapply Ectx_step; last apply Hpure; done. 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. - Lemma obs_ref_bind {S} (f : HOM) (K : ectx S) e α τ1 : ⊢ logrel τ1 α e -∗ logrel_ectx (logrel_val τ1) f K -∗ @@ -312,12 +288,6 @@ Section logrel. apply BetaS. Qed. - Program Definition IFSCtx_HOM α β : HOM := exist _ (λne x, IFSCtx α β x) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - Lemma compat_if {S : Set} (Γ : S -> ty) (e0 e1 e2 : expr S) α0 α1 α2 τ : ⊢ logrel_valid Γ e0 α0 Tnat -∗ logrel_valid Γ e1 α1 τ -∗ @@ -394,23 +364,6 @@ Section logrel. by constructor. Qed. - Program Definition NatOpRSCtx_HOM {S : Set} (op : nat_op) - (α : @interp_scope F natO _ S -n> IT) (env : @interp_scope F natO _ 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 natO _ S) - (Hv : AsVal α) - : HOM := exist _ (interp_natoplk rs op (λne env, idfun) (constO α) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - Lemma compat_natop {S : Set} (Γ : S -> ty) e1 e2 α1 α2 op : ⊢ logrel_valid Γ e1 α1 Tnat -∗ logrel_valid Γ e2 α2 Tnat -∗ @@ -458,42 +411,6 @@ Section logrel. + intros. by constructor. Qed. - Program Definition ThrowLSCtx_HOM {S : Set} - (α : @interp_scope F natO _ S -n> IT) - (env : @interp_scope F natO _ S) - : HOM := exist _ ((interp_throwlk rs (λne env, idfun) α env)) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - - Program Definition ThrowRSCtx_HOM {S : Set} - (β : IT) (env : @interp_scope F natO _ S) - (Hv : AsVal β) - : HOM := exist _ (interp_throwrk rs (constO β) (λne env, idfun) env) _. - Next Obligation. - intros; simpl. - simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - solve_proper_please. - - destruct Hv as [? <-]. - rewrite ->2 get_val_ITV. - simpl. by rewrite get_fun_tick. - - destruct Hv as [x Hv]. - rewrite <- Hv. - rewrite -> get_val_ITV. - simpl. - rewrite get_fun_vis. - repeat f_equiv. - intro; simpl. - rewrite <- Hv. - by rewrite -> get_val_ITV. - - destruct Hv as [? <-]. - rewrite get_val_ITV. - simpl. - by rewrite get_fun_err. - Qed. - - Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β e e' : ⊢ logrel_valid Γ e α τ -∗ logrel_valid Γ e' β (Tcont τ) -∗ @@ -517,7 +434,7 @@ Section logrel. simpl. rewrite get_val_ITV' -!fill_comp. simpl. - pose (κ'' := @ThrowRSCtx_HOM S (IT_of_V βv) ss _). + pose (κ'' := ThrowRSCtx_HOM (IT_of_V βv) ss _). (* TODO: some typeclasses bs *) assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) ≡ ((`κ'') (β ss))) as ->. @@ -556,7 +473,7 @@ Section logrel. term_simpl. eapply prim_step_steps. eapply Throw_step; last done. - rewrite H. by rewrite -!fill_comp. + rewrite H. by rewrite -!fill_comp. Qed. @@ -633,14 +550,6 @@ Section logrel. constructor. Qed. - Program Definition OutputSCtx_HOM {S : Set} - (env : @interp_scope F natO _ S) - : HOM := exist _ ((interp_outputk rs (λne env, idfun) env)) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - Lemma compat_output {S} Γ (e: expr S) α : ⊢ logrel_valid Γ e α Tnat -∗ logrel_valid Γ (Output e) (interp_output rs α) Tnat. @@ -680,25 +589,6 @@ Section logrel. by constructor. Qed. - - Program Definition AppRSCtx_HOM {S : Set} - (α : @interp_scope F natO _ S -n> IT) - (env : @interp_scope F natO _ 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 natO _ S) - (Hv : AsVal β) - : HOM := exist _ (interp_applk rs (λne env, idfun) (constO β) env) _. - Next Obligation. - intros; simpl. - apply _. - Qed. - Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ logrel_valid Γ e2 α2 τ1 -∗ @@ -865,9 +755,7 @@ Proof. intros Heq. rewrite (eq_pi _ _ Heq eq_refl)//. } - unshelve epose (idHOM := _ : (HOM rs)). - { exists idfun. apply IT_hom_idfun. } - iSpecialize ("Hlog" $! idHOM EmptyK with "[]"). + iSpecialize ("Hlog" $! HOM_id EmptyK with "[]"). { iIntros (βv v); iModIntro. iIntros "Hv". iIntros (σ'') "HS". iApply wp_val. From 1c5a26eb00bed9402b16c7c04dd494ce86dba0ea Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 14 Dec 2023 13:59:25 +0100 Subject: [PATCH 061/114] compat nat --- theories/input_lang_callcc/logrel.v | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index a8be3c8..7eb1a44 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -642,7 +642,20 @@ Section logrel. iApply "HV'"; iApply "HK". Qed. - (* TODO: finish throw + refactor *) + Lemma compat_nat {S : Set} (Γ : S -> ty) n : + ⊢ logrel_valid Γ (# n)%syn (interp_val rs (# n)%syn) ℕ%typ. + Proof. + iIntros (ss γ). iModIntro. iIntros "#Hss". + term_simpl. + iIntros (κ K) "#HK". + iSpecialize ("HK" $! (RetV n) (LitV n)). + rewrite IT_of_V_Ret. + iApply "HK". + simpl. + unfold logrel_nat. + iExists n; eauto. + Qed. + Lemma fundamental {S : Set} (Γ : S -> ty) τ e : typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ with fundamental_val {S : Set} (Γ : S -> ty) τ v : @@ -671,15 +684,7 @@ Section logrel. + iApply compat_callcc. iApply IHtyped. - induction 1; simpl. - + iIntros (ss γ). iModIntro. iIntros "#Hss". - term_simpl. - iIntros (κ K) "#HK". - iSpecialize ("HK" $! (RetV n) (LitV n)). - rewrite IT_of_V_Ret. - iApply "HK". - simpl. - unfold logrel_nat. - iExists n; eauto. + + iApply compat_nat. + iApply compat_recV. by iApply fundamental. Qed. From bb319470df56bb97037bf1f6bf37d5cc958d4bdc Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 14 Dec 2023 14:10:43 +0100 Subject: [PATCH 062/114] cleanup --- README.md | 14 ++++++---- theories/lang_generic_sem.v | 51 ++++++++----------------------------- 2 files changed, 20 insertions(+), 45 deletions(-) diff --git a/README.md b/README.md index 865ab57..819d1b8 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,6 @@ The dependencies can be easily installed using [Opam](https://opam.ocaml.org/) w ``` opam repo add coq-released https://coq.inria.fr/opam/released -opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git opam update opam install . --deps-only ``` @@ -26,9 +25,11 @@ to the code structure. - `gitree/` -- contains the core definitions related to guarded interaction trees - `input_lang/` -- formalization of the language with io, the soundness and adequacy +- `input_lang_callcc/` -- formalization of the language with io, throw and call/cc, the soundness and adequacy - `affine_lang/` -- formalization of the affine language, type safety of the language interoperability -- `examples/` -- some other smaller examples +- `examples/` -- some other smaller examples - `lang_generic.v` -- generic facts about languages with binders and their interpretations, shared by `input_lang` and `affine_lang` +- `lang_generic_sem.v` -- generic facts about languages with a different representation of binders and their interpretations, used for `input_lang_callcc` - `prelude.v` -- some stuff that is missing from Iris ### References from the paper to the code @@ -42,7 +43,7 @@ to the code structure. + The factorial example is in `examples/factorial.v`, and the pairs example is in `examples/pairs.v` - **Section 4** - + The definition of reifiers and the reify function are in `gitree/reify.v` + + The definition of context-dependent versions of reifiers and the reify function are in `gitree/reify.v` + The reduction relation is in `gitree/reductions.v` + The specific reifiers for IO and state are in `examples/store.v` and `input_lang/interp.v` @@ -70,11 +71,14 @@ to the code structure. ## Notes -### Representations of binders +### Representations of binders 1 For the representation of languages with binders, we follow the approach of (Benton, Hur, Kennedy, McBride, JAR 2012) with well-scoped -terms and substitutions/renamings. +terms and substitutions/renamings. (`input_lang`, `affine_lang`) +### Representations of binders 2 +For `input_lang_callcc` we use a binder library, implemented by Filip +Sieczkowski and Piotr Polesiuk. ### Disjunction property Some results in the formalization make use of the disjunction property diff --git a/theories/lang_generic_sem.v b/theories/lang_generic_sem.v index 29ab22a..21816f1 100644 --- a/theories/lang_generic_sem.v +++ b/theories/lang_generic_sem.v @@ -4,7 +4,6 @@ Require Import List. Import ListNotations. Require Import Binding.Lib Binding.Set. -From Equations Require Import Equations. Section interp. Local Open Scope type. @@ -23,6 +22,9 @@ Section interp. Program Definition interp_var {S : Set} (v : S) : interp_scope S -n> IT := λne (f : interp_scope S), f v. + Next Obligation. + solve_proper. + Qed. Global Instance interp_var_proper {S : Set} (v : S) : Proper ((≡) ==> (≡)) (interp_var v). Proof. apply ne_proper. apply _. Qed. @@ -34,16 +36,15 @@ Section interp. | VS x'' => γ x'' end. Next Obligation. - match goal with - | H : context G [(inc S)] |- _ => revert H - end. - intros [| a]; simpl; solve_proper. + intros ???? [| x] [| y]; term_simpl; [solve_proper | inversion 1 | inversion 1 | inversion 1; by subst]. + Qed. + Next Obligation. + intros ??????. + intros [| a]; term_simpl; solve_proper. Qed. Next Obligation. - match goal with - | H : context G [(inc S)] |- _ => revert H - end. - intros [| a]; simpl; solve_proper. + intros ??????. + intros [| a]; term_simpl; solve_proper. Qed. Program Definition ren_scope {S S'} (δ : S [→] S') (env : interp_scope S') @@ -78,19 +79,6 @@ Section kripke_logrel. solve_proper. Qed. - (* #[export] Instance expr_pred_ne : NonExpansive2 expr_pred. *) - (* Proof. *) - (* solve_proper_prepare. *) - (* f_equiv. *) - (* intro; simpl. *) - (* f_equiv. *) - (* rewrite clwp_eq. *) - - (* apply clwp_ne'''. *) - (* Qed. *) - (* #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . *) - (* Proof. solve_proper. Qed. *) - Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : Φ αv ⊢ expr_pred α Φ. Proof. @@ -98,24 +86,9 @@ Section kripke_logrel. iIntros (x) "Hx". iApply wp_val. simpl. iExists x. - by iFrame. + by iFrame. Qed. - (* Lemma expr_pred_bind (f : IT -n> IT) {Hf : IT_hom f} α (Φ Ψ : ITV -n> iProp) : *) - (* expr_pred α Ψ ⊢ *) - (* (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ *) - (* expr_pred (f α) Φ. *) - (* Proof. *) - (* iIntros "H1 H2". *) - (* iIntros (x) "Hx". *) - (* unshelve iApply clwp_bind; first done. *) - (* iSpecialize ("H1" with "Hx"). *) - (* iApply (clwp_wand with "H1"). *) - (* iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". *) - (* simpl. *) - (* iApply ("H2" with "Hb Hy"). *) - (* Qed. *) - Lemma expr_pred_frame α Φ : WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. Proof. @@ -129,5 +102,3 @@ Section kripke_logrel. Qed. End kripke_logrel. - -(* Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_}. *) From a576f2b58a0f65a3f1ebd13cdb3829e0979f98a0 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 14 Dec 2023 14:13:10 +0100 Subject: [PATCH 063/114] more cleanup --- .github/workflows/build.yml | 1 - _CoqProject | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 4931b29..6f094f0 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -30,7 +30,6 @@ jobs: install: | startGroup "Install dependencies" sudo apt-get update -y -q - opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git opam pin add -n -y -k path $PACKAGE $WORKDIR opam update -y opam install --confirm-level=unsafe-yes -j 2 $PACKAGE --deps-only diff --git a/_CoqProject b/_CoqProject index d9e9582..018b6cf 100644 --- a/_CoqProject +++ b/_CoqProject @@ -31,6 +31,7 @@ theories/program_logic.v theories/input_lang_callcc/lang.v theories/input_lang_callcc/interp.v +theories/input_lang_callcc/hom.v theories/input_lang_callcc/logrel.v theories/input_lang/lang.v From 93e6dc9d9eecc9624e6f20866b5c52fa6a997e29 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 14 Dec 2023 14:34:48 +0100 Subject: [PATCH 064/114] more rework on callcc --- theories/input_lang_callcc/interp.v | 6 ++++ theories/input_lang_callcc/logrel.v | 53 +++++++++++------------------ 2 files changed, 26 insertions(+), 33 deletions(-) diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index a16b84c..c5450bc 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -320,6 +320,12 @@ Section interp. Notation IT := (IT F R). Notation ITV := (ITV F R). + Global Instance denot_cont_ne (κ : IT -n> IT) : + NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). + Proof. + solve_proper. + Qed. + (** Interpreting individual operators *) Program Definition interp_input {A} : A -n> IT := λne env, INPUT Ret. diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 6e50343..98bb695 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -57,11 +57,6 @@ Section logrel. (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. - Global Instance denot_cont_ne (κ : IT -n> IT) : - NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). - Proof. - solve_proper. - Qed. Definition logrel_cont {S} V (βv : ITV) (v : val S) : iProp := (∃ (κ : HOM) K, (IT_of_V βv) ≡ (Fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))) @@ -579,40 +574,32 @@ Section logrel. match goal with | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ extend_scope ss )?f] => set (fff := f) end. - assert (ff ≡ fff) as Hf. - { subst ff fff. f_equiv. - apply bi.siProp.internal_eq_soundness. - iApply (later_equivI). - iNext. iApply (internal_eq_pointwise). iIntros. - simpl. by rewrite later_map_Next. + assert (ff ≡ fff) as <-. + { + subst ff fff. do 1 f_equiv. + epose proof (contractive_proper Next). + rewrite H; first reflexivity. + rewrite ofe_mor_ext. intro. simpl. + by rewrite later_map_Next. } - rewrite -Hf. pose (ss' := (extend_scope ss ff)). pose (γ' := ((mk_subst (Val (ContV K)%syn)) ∘ (γ ↑)%bind)%bind : inc S [⇒] ∅). iSpecialize ("H" $! ss' γ' with "[HK]"). { - iIntros (x). + iIntros (x). iModIntro. + destruct x as [| x]; term_simpl; last iApply "Hss". + Transparent extend_scope. + subst ss'; simpl. + pose proof (asval_fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))). + subst ff. destruct H as [f H]. + iIntros (t r) "#H". + simpl. rewrite -H. iApply "H". + unfold logrel_cont. + iExists κ, K. + iSplit; first done. + iSplit; first done. iModIntro. - destruct x as [| x]; term_simpl. - - Transparent extend_scope. - subst ss'; simpl. - pose proof (asval_fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))). - destruct H as [f H]. - subst ff. - rewrite -H. - iIntros (t r) "#H". - simpl. - iApply "H". - unfold logrel_cont. - iExists _, K. - iSplit. - + rewrite H. - done. - + iSplit; first done. - iModIntro. - iApply "HK". - - simpl. - iApply "Hss". + iApply "HK". } iSpecialize ("H" $! κ K with "HK"). Opaque extend_scope. From e5ebc9a1259299d3d4bf1ecd7c011f287683b60b Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 15 Dec 2023 14:26:21 +0100 Subject: [PATCH 065/114] Better context indep reifiers --- theories/input_lang/interp.v | 106 +++++++++++++++++++--------- theories/input_lang_callcc/logrel.v | 1 - 2 files changed, 72 insertions(+), 35 deletions(-) diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index 4ced640..456fe39 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -4,16 +4,75 @@ From gitrees.input_lang Require Import lang. Notation stateO := (leibnizO state). -Program Definition inputE : opInterp := {| - Ins := unitO; - Outs := natO; - |}. -Program Definition outputE : opInterp := {| - Ins := natO; - Outs := unitO; -|}. +Program Definition inputE : opInterp := + {| + Ins := unitO; + Outs := natO; + |}. + +Program Definition outputE : opInterp := + {| + Ins := natO; + Outs := unitO; + |}. Definition ioE := @[inputE;outputE]. + +Definition wrap_reifier X `{Cofe X} (A B : ofe) : + (A * stateO -n> option (B * stateO))%type -> + (A * stateO * (B -n> laterO X) → option (laterO X * stateO))%type := + λ f, + λ x, let '(i, σ, k) := x in + fmap (prodO_map k idfun) (f (i, σ)). +#[export] Instance wrap_reifier_ne X `{Cofe X} (A B : ofe) f : + NonExpansive (wrap_reifier X A B f). +Proof. + intros n [[a1 σ1] k1] [[a2 σ2] k2] [[Ha Hσ] Hk]. simpl. + solve_proper. +Qed. + +(* INPUT *) +Definition reify_input' X `{Cofe X} : unitO * stateO → + option (natO * stateO) := + λ '(o, σ), Some (update_input σ : prodO natO stateO). +#[export] Instance reify_input'_ne X `{Cofe X} : + NonExpansive (reify_input' X). +Proof. intros ????. solve_proper. Qed. + +Definition reify_input X `{Cofe X} : unitO * stateO * (natO -n> laterO X) → + option (laterO X * stateO) := + λ '(o, σ, k), fmap (prodO_map k idfun) (reify_input' X (o, σ)). +#[export] Instance reify_input_ne X `{Cofe X} : + NonExpansive (reify_input X : prodO (prodO unitO stateO) + (natO -n> laterO X) → + optionO (prodO (laterO X) stateO)). +Proof. + intros n [[? σ1] k1] [[? σ2] k2]. simpl. + intros [[_ ->] Hk]. simpl in *. + repeat f_equiv. assumption. +Qed. + +(* OUTPUT *) +Definition reify_output' X `{Cofe X} : (natO * stateO) → + option (unitO * stateO) := + λ '(n, σ), Some((), update_output n σ : stateO). +#[export] Instance reify_output'_ne X `{Cofe X} : + NonExpansive (reify_output' X). +Proof. intros ????. solve_proper. Qed. + +Definition reify_output X `{Cofe X} : (natO * stateO * (unitO -n> laterO X)) → + optionO (prodO (laterO X) stateO) := + λ '(n, σ, k), fmap (prodO_map k idfun) + (reify_output' X (n, σ)). +#[export] Instance reify_output_ne X `{Cofe X} : + NonExpansive (reify_output X : prodO (prodO natO stateO) + (unitO -n> laterO X) → + optionO (prodO (laterO X) stateO)). +Proof. + intros ? [[]] [[]] []; simpl in *. + repeat f_equiv; first assumption; apply H0. +Qed. + Canonical Structure reify_io : sReifier. Proof. simple refine {| sReifier_ops := ioE; @@ -21,19 +80,8 @@ Proof. |}. intros X HX op. destruct op as [[] | [ | []]]; simpl. - - simple refine (λne (us : (unitO * stateO * (natO -n> laterO X))%type), - let out : (natO * stateO)%type := (update_input (sndO (fstO us))) in - Some $ (us.2 out.1, out.2) : - optionO (laterO X * stateO)%type). - intros n [[? σ1] k1] [[? σ2] k2] [[_ HR1] HR2]. cbn in HR1, HR2 |- *. - rewrite HR1. by repeat f_equiv. - - simple refine (λne (us : (natO * stateO * (unitO -n> laterO X))%type ), - Some $ (us.2 (() : unitO), update_output us.1.1 us.1.2) : - optionO (prodO (laterO X) stateO)). - intros n [[n1 σ1] k1] [[n2 σ2] k2] [[HRn HRσ] HR]. - cbn in HRn, HRσ, HR |-*. - rewrite HRn HRσ. apply (@Some_ne (prodO (laterO X) stateO)). - apply pair_dist_inj; solve_proper. + - simple refine (OfeMor (reify_input X)). + - simple refine (OfeMor (reify_output X)). Defined. Section constructors. @@ -47,19 +95,9 @@ Section constructors. ∀ (o : opid ioE), CtxIndep reify_io IT o. Proof. intros op. - destruct op as [[] | [ | []]]; simpl. - - constructor. - unshelve eexists (λne (x : prodO (Ins (sReifier_ops reify_io (inl ())) ♯ IT) (sReifier_state reify_io ♯ IT)), Some ((update_input (sndO x)).1, (update_input (sndO x)).2) : optionO (prodO (Outs (sReifier_ops reify_io (inl ())) ♯ IT) (sReifier_state reify_io ♯ IT))). - + intros ? [? ?] [? ?] [? ?]; simpl in *; solve_proper. - + intros i σ κ. - simpl in *. - reflexivity. - - constructor. - unshelve eexists (λne (x : prodO (Ins (sReifier_ops reify_io (inr (inl o))) ♯ IT) (sReifier_state reify_io ♯ IT)), Some ((), update_output (fstO x) (sndO x)) : optionO (prodO (Outs (sReifier_ops reify_io (inr (inl o))) ♯ IT) (sReifier_state reify_io ♯ IT))). - + intros ? [? ?] [? ?] [? ?]; simpl in *; solve_proper. - + intros i σ κ. - simpl. - reflexivity. + destruct op as [[] | [ | []]]. + - constructor. by exists (OfeMor (reify_input' IT)). + - constructor. by exists (OfeMor (reify_output' IT)). Qed. Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index db33e0b..1adfe97 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -430,7 +430,6 @@ Section logrel. rewrite get_val_ITV' -!fill_comp. simpl. pose (κ'' := ThrowRSCtx_HOM (IT_of_V βv) ss _). - (* TODO: some typeclasses bs *) assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) ≡ ((`κ'') (β ss))) as ->. { From 6159a220ab6d017b223f4dbb56132077cfe47cbc Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 15 Dec 2023 14:53:24 +0100 Subject: [PATCH 066/114] Fixing some proofs re new reifiers --- theories/input_lang/interp.v | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index 456fe39..590ece6 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -149,7 +149,7 @@ Section weakestpre. intros Hs. iIntros "Hs Ha". unfold INPUT. simpl. iApply (wp_subreify with "Hs"). - { simpl. by rewrite Hs. } + { simpl. rewrite Hs//=. } { simpl. by rewrite ofe_iso_21. } iModIntro. done. Qed. @@ -591,14 +591,11 @@ Section interp. { repeat f_equiv; eauto. rewrite hom_INPUT. f_equiv. by intro. } rewrite reify_vis_eq //; last first. - { rewrite subReifier_reify/=//. - } - repeat f_equiv. - { simpl. f_equiv. by rewrite H4. } + { rewrite subReifier_reify//= H4//=. } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_ectx_fill. simpl. - rewrite H4; simpl. done. - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). { do 3 f_equiv; eauto. From 5ea4b4798fe6cbd72837458b548e0d6bce7ae6ce Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 15 Dec 2023 17:13:51 +0100 Subject: [PATCH 067/114] coq 8.18 --- coq-gitrees.opam | 8 ++++---- flake.nix | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/coq-gitrees.opam b/coq-gitrees.opam index 8a0f678..7fe4b64 100644 --- a/coq-gitrees.opam +++ b/coq-gitrees.opam @@ -9,9 +9,9 @@ build: [make "-j%{jobs}%"] install: [make "install"] remove: ["rm" "-rf" "%{lib}%/coq/user-contrib/gitrees"] depends: [ - "coq-equations" { (= "1.3+8.17") } - "coq-iris" { (= "4.1.0") } - "coq-iris-heap-lang" { (= "4.1.0") } - "coq-stdpp" { (= "1.9.0") } + "coq-equations" { (>= "1.3+8.17") } + "coq-iris" { (>= "4.1.0") } + "coq-iris-heap-lang" { (>= "4.1.0") } + "coq-stdpp" { (>= "1.9.0") } "coq" { (>= "8.17") | (= "dev") } ] diff --git a/flake.nix b/flake.nix index e05e6a3..ff9f177 100644 --- a/flake.nix +++ b/flake.nix @@ -9,8 +9,8 @@ let pkgs = nixpkgs.legacyPackages.${system}; lib = pkgs.lib; - coq = pkgs.coq_8_17; - coqPkgs = pkgs.coqPackages_8_17; + coq = pkgs.coq_8_18; + coqPkgs = pkgs.coqPackages_8_18; in { packages = { coq-artifact = coqPkgs.mkCoqDerivation { From 8d31bf81cb1f0fce9bdb3ba2be0423ef902f0271 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 15 Dec 2023 17:33:18 +0100 Subject: [PATCH 068/114] Revert "coq 8.18" This reverts commit 5ea4b4798fe6cbd72837458b548e0d6bce7ae6ce. --- coq-gitrees.opam | 8 ++++---- flake.nix | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/coq-gitrees.opam b/coq-gitrees.opam index 7fe4b64..8a0f678 100644 --- a/coq-gitrees.opam +++ b/coq-gitrees.opam @@ -9,9 +9,9 @@ build: [make "-j%{jobs}%"] install: [make "install"] remove: ["rm" "-rf" "%{lib}%/coq/user-contrib/gitrees"] depends: [ - "coq-equations" { (>= "1.3+8.17") } - "coq-iris" { (>= "4.1.0") } - "coq-iris-heap-lang" { (>= "4.1.0") } - "coq-stdpp" { (>= "1.9.0") } + "coq-equations" { (= "1.3+8.17") } + "coq-iris" { (= "4.1.0") } + "coq-iris-heap-lang" { (= "4.1.0") } + "coq-stdpp" { (= "1.9.0") } "coq" { (>= "8.17") | (= "dev") } ] diff --git a/flake.nix b/flake.nix index ff9f177..e05e6a3 100644 --- a/flake.nix +++ b/flake.nix @@ -9,8 +9,8 @@ let pkgs = nixpkgs.legacyPackages.${system}; lib = pkgs.lib; - coq = pkgs.coq_8_18; - coqPkgs = pkgs.coqPackages_8_18; + coq = pkgs.coq_8_17; + coqPkgs = pkgs.coqPackages_8_17; in { packages = { coq-artifact = coqPkgs.mkCoqDerivation { From a3b9b8250191f283e4f0ae4ba50689b137a04947 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 15 Dec 2023 17:39:07 +0100 Subject: [PATCH 069/114] remove problematic solve_proper --- theories/input_lang/interp.v | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index 590ece6..3c20da7 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -37,7 +37,10 @@ Definition reify_input' X `{Cofe X} : unitO * stateO → λ '(o, σ), Some (update_input σ : prodO natO stateO). #[export] Instance reify_input'_ne X `{Cofe X} : NonExpansive (reify_input' X). -Proof. intros ????. solve_proper. Qed. +Proof. + intros ?[[]][[]][_?]. simpl in *. f_equiv. + repeat f_equiv. done. +Qed. Definition reify_input X `{Cofe X} : unitO * stateO * (natO -n> laterO X) → option (laterO X * stateO) := @@ -58,7 +61,11 @@ Definition reify_output' X `{Cofe X} : (natO * stateO) → λ '(n, σ), Some((), update_output n σ : stateO). #[export] Instance reify_output'_ne X `{Cofe X} : NonExpansive (reify_output' X). -Proof. intros ????. solve_proper. Qed. +Proof. + intros ?[][][]. simpl in *. + repeat f_equiv; done. +Qed. + Definition reify_output X `{Cofe X} : (natO * stateO * (unitO -n> laterO X)) → optionO (prodO (laterO X) stateO) := From 167a7b071803a4a029f34525bb7c4aa2912b2551 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Fri, 15 Dec 2023 19:14:34 +0100 Subject: [PATCH 070/114] comments --- theories/affine_lang/logrel1.v | 13 ++++++------- theories/affine_lang/logrel2.v | 11 +++++------ theories/gitree/greifiers.v | 22 +++++----------------- theories/input_lang/interp.v | 2 +- theories/input_lang_callcc/interp.v | 13 +------------ theories/lang_generic.v | 3 +-- theories/prelude.v | 12 ++++++++++++ 7 files changed, 31 insertions(+), 45 deletions(-) diff --git a/theories/affine_lang/logrel1.v b/theories/affine_lang/logrel1.v index 85a6c87..9710d44 100644 --- a/theories/affine_lang/logrel1.v +++ b/theories/affine_lang/logrel1.v @@ -3,6 +3,7 @@ From Equations Require Import Equations. From gitrees Require Export lang_generic gitree program_logic. From gitrees.affine_lang Require Import lang. From gitrees.examples Require Import store pairs. +Require Import iris.algebra.gmap. Local Notation tyctx := (tyctx ty). @@ -69,9 +70,9 @@ Section logrel. Variable (P : A → iProp). Context `{!NonExpansive P}. Local Notation expr_pred := (expr_pred s rs P). - Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. + Context {HCI : + ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) IT o}. (* interpreting tys *) Program Definition protected (Φ : ITV -n> iProp) : ITV -n> iProp := λne αv, @@ -421,11 +422,8 @@ Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} τ. Local Definition rs : gReifiers 2 := gReifiers_cons reify_store (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). -Require Import iris.algebra.gmap. - Local Instance CtxIndepInputLang R `{!Cofe R} (o : opid (sReifier_ops (gReifiers_sReifier rs))) : - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o. + CtxIndep (gReifiers_sReifier rs) (IT (gReifiers_ops rs) R) o. Proof. destruct o as [x o]. inv_fin x. @@ -616,6 +614,7 @@ Proof. Qed. Definition R := sumO locO (sumO unitO natO). + Lemma logrel1_safety e τ (β : IT (gReifiers_ops rs) R) st st' k : typed empC e τ → ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) st β st' k → diff --git a/theories/affine_lang/logrel2.v b/theories/affine_lang/logrel2.v index 1255b25..6c5b827 100644 --- a/theories/affine_lang/logrel2.v +++ b/theories/affine_lang/logrel2.v @@ -4,6 +4,7 @@ From gitrees Require Export lang_generic gitree program_logic. From gitrees.input_lang Require Import lang interp logpred. From gitrees.affine_lang Require Import lang logrel1. From gitrees.examples Require Import store pairs. +Require Import iris.algebra.gmap. Local Notation tyctx := (tyctx ty). @@ -69,9 +70,9 @@ Section glue. Context `{!invGS Σ, !stateG rs R Σ, !heapG rs R Σ, !na_invG Σ}. Notation iProp := (iProp Σ). - Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. + Context {HCI : + ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), + CtxIndep (gReifiers_sReifier rs) IT o}. Definition s : stuckness := λ e, e = OtherError. Variable p : na_inv_pool_name. @@ -460,11 +461,9 @@ End glue. Local Definition rs : gReifiers 2 := gReifiers_cons reify_store (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). -Require Import iris.algebra.gmap. - Local Instance CtxIndepInputLang R `{!Cofe R} (o : opid (sReifier_ops (gReifiers_sReifier rs))) : CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o. + (IT (sReifier_ops (gReifiers_sReifier rs)) R) o. Proof. destruct o as [x o]. inv_fin x. diff --git a/theories/gitree/greifiers.v b/theories/gitree/greifiers.v index af67051..05ded03 100644 --- a/theories/gitree/greifiers.v +++ b/theories/gitree/greifiers.v @@ -168,22 +168,10 @@ Section greifiers. (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) : sReifier_re r op (x, s1, k) ≡{m}≡ Some (y, s2) → sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1, ccompose k (subEff_outs ^-1)) ≡{m}≡ + (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡{m}≡ Some (y, sR_state s2) }. - Lemma ccompose_id_l {A B : ofe} (f : A -n> B) : - cid ◎ f ≡ f. - Proof. - intros x; reflexivity. - Qed. - - Lemma ccompose_id_r {A B : ofe} (f : A -n> B) : - f ◎ cid ≡ f. - Proof. - intros x; reflexivity. - Qed. - #[global] Instance subReifier_here {n} (r : sReifier) (rs : gReifiers n) : subReifier r (gReifiers_cons r rs). Proof. @@ -233,7 +221,7 @@ Section greifiers. (s1 s2 : sReifier_state r ♯ X) : sReifier_re r op (x, s1, k) ≡ Some (y, s2) → sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1, ccompose k (subEff_outs ^-1)) ≡ + (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ Some (y, sR_state s2). Proof. intros Hx. apply equiv_dist=>m. @@ -248,7 +236,7 @@ Section greifiers. (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : sReifier_re r op (x, σ, k) ≡ Some (y, σ') → gReifiers_re rs (subEff_opid op) - (subEff_ins x, gState_recomp rest (sR_state σ), ccompose k (subEff_outs ^-1)) + (subEff_ins x, gState_recomp rest (sR_state σ), k ◎ (subEff_outs ^-1)) ≡ Some (y, gState_recomp rest (sR_state σ')). Proof. intros Hre. @@ -280,7 +268,7 @@ Section greifiers. (s1 s2 : sReifier_state r ♯ X) : sReifier_re r op (x, s1, k) ≡ Some (y, s2) ⊢@{iProp} sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1, ccompose k (subEff_outs ^-1)) ≡ + (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ Some (y, sR_state s2). Proof. apply uPred.internal_eq_entails=>m. @@ -299,7 +287,7 @@ Section greifiers. (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : sReifier_re r op (x,σ, k) ≡ Some (y, σ') ⊢@{iProp} gReifiers_re rs (subEff_opid op) - (subEff_ins x, gState_recomp rest (sR_state σ), ccompose k (subEff_outs ^-1)) + (subEff_ins x, gState_recomp rest (sR_state σ), k ◎ (subEff_outs ^-1)) ≡ Some (y, gState_recomp rest (sR_state σ')). Proof. apply uPred.internal_eq_entails=>m. diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index 3c20da7..dd001c1 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -169,7 +169,7 @@ Section weakestpre. Proof. intros Hs. iIntros "Hs Ha". unfold OUTPUT. simpl. - iApply (wp_subreify rs _ _ _ _ _ _ _ with "Hs"). + iApply (wp_subreify rs with "Hs"). { simpl. by rewrite Hs. } { simpl. done. } iModIntro. iIntros "H1 H2". diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index c5450bc..73ad941 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -237,7 +237,7 @@ Section weakestpre. + done. + done. Qed. - + Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : update_output n σ = σ' → @@ -251,16 +251,6 @@ Section weakestpre. iApply wp_val. iApply ("Ha" with "Hcl Hs"). Qed. - (* Proof. *) - (* intros Hs. iIntros "Hs Ha". *) - (* unfold OUTPUT. simpl. *) - (* iApply (wp_subreify with "Hs"). *) - (* { simpl. by rewrite Hs. } *) - (* { simpl. done. } *) - (* iModIntro. iIntros "H1 H2". *) - (* iApply wp_val. by iApply ("Ha" with "H1 H2"). *) - (* Qed. *) - Lemma wp_throw' (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) (κ : IT -n> IT) `{!IT_hom κ} Φ s : has_substate σ -∗ @@ -272,7 +262,6 @@ Section weakestpre. iApply (wp_subreify with "Hs"); simpl; done. Qed. - Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : has_substate σ -∗ ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ diff --git a/theories/lang_generic.v b/theories/lang_generic.v index 25d604f..7c27639 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -196,8 +196,7 @@ Section kripke_logrel. Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o} : + CtxIndep (gReifiers_sReifier rs) IT o} : expr_pred α Ψ ⊢ (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ expr_pred (f α) Φ. diff --git a/theories/prelude.v b/theories/prelude.v index 4ef5b7b..84cd443 100644 --- a/theories/prelude.v +++ b/theories/prelude.v @@ -12,6 +12,18 @@ Program Definition idfun {A : ofe} : A -n> A := λne x, x. (** OFEs stuff *) Notation "F ♯ E" := (oFunctor_apply F E) (at level 20, right associativity). +Lemma ccompose_id_l {A B : ofe} (f : A -n> B) : + cid ◎ f ≡ f. +Proof. + intros x; reflexivity. +Qed. + +Lemma ccompose_id_r {A B : ofe} (f : A -n> B) : + f ◎ cid ≡ f. +Proof. + intros x; reflexivity. +Qed. + Infix "≃" := (ofe_iso) (at level 50). Definition ofe_iso_1' {A B : ofe} (p : A ≃ B) : A → B := ofe_iso_1 p. From 6d384efa104266b2fdc133be8d28670ce2b041ba Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 5 Jan 2024 14:47:49 +0100 Subject: [PATCH 071/114] Files + First ideas on ope semantics --- _CoqProject | 6 + theories/input_lang_delim/hom.v | 130 ++++ theories/input_lang_delim/interp.v | 1142 ++++++++++++++++++++++++++++ theories/input_lang_delim/lang.v | 774 +++++++++++++++++++ theories/input_lang_delim/logrel.v | 789 +++++++++++++++++++ 5 files changed, 2841 insertions(+) create mode 100644 theories/input_lang_delim/hom.v create mode 100644 theories/input_lang_delim/interp.v create mode 100644 theories/input_lang_delim/lang.v create mode 100644 theories/input_lang_delim/logrel.v diff --git a/_CoqProject b/_CoqProject index 018b6cf..f02ab0c 100644 --- a/_CoqProject +++ b/_CoqProject @@ -29,6 +29,12 @@ theories/gitree.v theories/program_logic.v + +theories/input_lang_delim/lang.v +theories/input_lang_delim/interp.v +theories/input_lang_delim/hom.v +theories/input_lang_delim/logrel.v + theories/input_lang_callcc/lang.v theories/input_lang_callcc/interp.v theories/input_lang_callcc/hom.v diff --git a/theories/input_lang_delim/hom.v b/theories/input_lang_delim/hom.v new file mode 100644 index 0000000..7250497 --- /dev/null +++ b/theories/input_lang_delim/hom.v @@ -0,0 +1,130 @@ +From Equations Require Import Equations. +From gitrees Require Import gitree. +From gitrees.input_lang_callcc Require Import lang interp. +Require Import gitrees.lang_generic_sem. +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope stdpp_scope. + +Section hom. + Context {sz : nat}. + Context {rs : gReifiers sz}. + Context {subR : subReifier 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. + + 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) + : 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 natO _ S) + (Hv : AsVal α) + : HOM := exist _ (interp_natoplk rs op (λne env, idfun) (constO α) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition ThrowLSCtx_HOM {S : Set} + (α : @interp_scope F natO _ S -n> IT) + (env : @interp_scope F natO _ S) + : HOM := exist _ ((interp_throwlk rs (λne env, idfun) α env)) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + + Program Definition ThrowRSCtx_HOM {S : Set} + (β : IT) (env : @interp_scope F natO _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_throwrk rs (constO β) (λne env, idfun) env) _. + Next Obligation. + intros; simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - solve_proper_please. + - destruct Hv as [? <-]. + rewrite ->2 get_val_ITV. + simpl. by rewrite get_fun_tick. + - destruct Hv as [x Hv]. + rewrite <- Hv. + rewrite -> get_val_ITV. + simpl. + rewrite get_fun_vis. + repeat f_equiv. + intro; simpl. + rewrite <- Hv. + by rewrite -> get_val_ITV. + - destruct Hv as [? <-]. + rewrite get_val_ITV. + simpl. + by rewrite get_fun_err. + Qed. + + Program Definition OutputSCtx_HOM {S : Set} + (env : @interp_scope F natO _ S) + : HOM := 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) + : 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 natO _ S) + (Hv : AsVal β) + : HOM := exist _ (interp_applk rs (λne env, idfun) (constO β) env) _. + Next Obligation. + intros; simpl. + apply _. + Qed. + +End hom. diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v new file mode 100644 index 0000000..b1ec2d8 --- /dev/null +++ b/theories/input_lang_delim/interp.v @@ -0,0 +1,1142 @@ +(* From Equations Require Import Equations. *) +From gitrees Require Import gitree. +From gitrees.input_lang_callcc Require Import lang. +Require Import gitrees.lang_generic_sem. + +Require Import Binding.Lib. +Require Import Binding.Set. + +Notation stateO := (leibnizO state). + +Program Definition inputE : opInterp := + {| + Ins := unitO; + Outs := natO; + |}. +Program Definition outputE : opInterp := + {| + Ins := natO; + Outs := unitO; + |}. + +Program Definition shiftE : opInterp := + {| + Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); + Outs := (▶ ∙); + |}. + +Program Definition resetE : opInterp := + {| + Ins := (▶ ∙); + Outs := (▶ ∙); + |}. + +Definition ioE := @[inputE; outputE; shiftE; resetE]. + +Definition reify_input X `{Cofe X} : unitO * stateO * (natO -n> laterO X) → + option (laterO X * stateO) := + λ '(_, σ, k), let '(n, σ') := (update_input σ : prodO natO stateO) in + Some (k n, σ'). +#[export] Instance reify_input_ne X `{Cofe X} : + NonExpansive (reify_input X : prodO (prodO unitO stateO) + (natO -n> laterO X) → + optionO (prodO (laterO X) stateO)). +Proof. + intros n [[? σ1] k1] [[? σ2] k2]. simpl. + intros [[_ ->] Hk]. simpl in *. + repeat f_equiv. assumption. +Qed. + +Definition reify_output X `{Cofe X} : (natO * stateO * (unitO -n> laterO X)) → + optionO (prodO (laterO X) stateO) := + λ '(n, σ, k), Some (k (), ((update_output n σ) : stateO)). +#[export] Instance reify_output_ne X `{Cofe X} : + NonExpansive (reify_output X : prodO (prodO natO stateO) + (unitO -n> laterO X) → + optionO (prodO (laterO X) stateO)). +Proof. + intros ? [[]] [[]] []; simpl in *. + repeat f_equiv; first assumption; apply H0. +Qed. + +Definition reify_shift X `{Cofe X} : ((laterO X -n> laterO X) -n> laterO X) * + stateO * (laterO X -n> laterO X) → + option (laterO X * stateO) := + λ '(f, σ, k), Some ((k (f k): laterO X), σ : stateO). +#[export] Instance reify_callcc_ne X `{Cofe X} : + NonExpansive (reify_shift X : + prodO (prodO ((laterO X -n> laterO X) -n> laterO X) stateO) + (laterO X -n> laterO X) → + optionO (prodO (laterO X) stateO)). +Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; auto. Qed. + + +(* Definition reify_reset X `{Cofe X} : *) +(* (laterO X * stateO * (laterO X -n> laterO X)) → *) +(* option (laterO X * stateO) := *) +(* λ '(e, σ, k), Some (σ, k (laterO_map (get_val idfun) ( e))). *) +(* CHECK: get_val def on IT... (also maybe not what we want idk) *) + +Context {E : opsInterp} {A} `{!Cofe A}. +Context {subEff0 : subEff ioE E}. +Context {subOfe0 : SubOfe natO A}. +Notation IT := (IT E A). +Notation ITV := (ITV E A). + +Definition reify_reset : (laterO IT * stateO * (laterO IT -n> laterO IT)) → + option (laterO IT * stateO) := + λ '(e, σ, k), Some (k $ laterO_map (get_val idfun) e, σ). +#[export] Instance reify_reset_ne : + NonExpansive (reify_reset : + prodO (prodO (laterO IT) stateO) (laterO IT -n> laterO IT) → + optionO (prodO (laterO IT) stateO)). +Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; done. Qed. + + +Canonical Structure reify_io : sReifier. +Proof. + simple refine {| sReifier_ops := ioE; + sReifier_state := stateO + |}. + intros X HX op. + destruct op as [ | [ | [ | [| []]]]]; simpl. + - simple refine (OfeMor (reify_input X)). + - simple refine (OfeMor (reify_output X)). + - simple refine (OfeMor (reify_callcc X)). + - simple refine (OfeMor (reify_throw X)). +Defined. + +Section constructors. + Context {E : opsInterp} {A} `{!Cofe A}. + Context {subEff0 : subEff ioE E}. + Context {subOfe0 : SubOfe natO A}. + Notation IT := (IT E A). + Notation ITV := (ITV E A). + + Program Definition INPUT : (nat -n> IT) -n> IT := + λne k, Vis (E:=E) (subEff_opid (inl ())) + (subEff_ins (F:=ioE) (op:=(inl ())) ()) + (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). + Solve Obligations with solve_proper. + + Program Definition OUTPUT_ : nat -n> IT -n> IT := + λne m α, Vis (E:=E) (subEff_opid (inr (inl ()))) + (subEff_ins (F:=ioE) (op:=(inr (inl ()))) m) + (λne _, NextO α). + Solve All Obligations with solve_proper_please. + Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). + + + 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 (inr (inr (inl ())))) + (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) f) + (k ◎ (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-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_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). + Proof. + unfold INPUT. + rewrite hom_vis/=. repeat f_equiv. + intro x. cbn-[laterO_map]. rewrite laterO_map_Next. + done. + Qed. + Lemma hom_OUTPUT_ m α f `{!IT_hom f} : f (OUTPUT_ m α) ≡ OUTPUT_ m (f α). + Proof. + unfold OUTPUT. + rewrite hom_vis/=. repeat f_equiv. + intro x. cbn-[laterO_map]. rewrite laterO_map_Next. + done. + Qed. + + Lemma hom_CALLCC_ k e f `{!IT_hom f} : + f (CALLCC_ e k) ≡ CALLCC_ e (laterO_map (OfeMor f) ◎ k). + Proof. + unfold CALLCC_. + rewrite hom_vis/=. + f_equiv. by intro. + Qed. + + +End constructors. + +Section weakestpre. + Context {sz : nat}. + Variable (rs : gReifiers sz). + Context {subR : subReifier reify_io rs}. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Lemma wp_input' (σ σ' : stateO) (n : nat) (k : natO -n> IT) (κ : IT -n> IT) + `{!IT_hom κ} Φ s : + update_input σ = (n, σ') -> + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ ◎ k $ n) @ s {{ Φ }}) -∗ + WP@{rs} κ (INPUT k) @ s {{ Φ }}. + Proof. + iIntros (Hσ) "Hs Ha". + rewrite hom_INPUT. simpl. + iApply (wp_subreify with "Hs"). + + simpl. by rewrite Hσ. + + by rewrite ofe_iso_21. + + done. + Qed. + + Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : + update_input σ = (n, σ') → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ + WP@{rs} (INPUT k) @ s {{ Φ }}. + Proof. + eapply (wp_input' σ σ' n k idfun). + Qed. + + (* Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : *) + (* update_input σ = (n, σ') → *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ *) + (* WP@{rs} (INPUT k) @ s {{ Φ }}. *) + (* Proof. *) + (* intros Hs. iIntros "Hs Ha". *) + (* unfold INPUT. simpl. *) + (* iApply (wp_subreify with "Hs"). *) + (* { simpl. by rewrite Hs. } *) + (* { simpl. by rewrite ofe_iso_21. } *) + (* iModIntro. done. *) + (* Qed. *) + + Lemma wp_output' (σ σ' : stateO) (n : nat) (κ : IT -n> IT) + `{!IT_hom κ} Φ s : + update_output n σ = σ' → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ (Ret 0)) @ s {{ Φ }}) -∗ + WP@{rs} κ (OUTPUT n) @ s {{ Φ }}. + Proof. + iIntros (Hσ) "Hs Ha". + rewrite /OUTPUT hom_OUTPUT_. + iApply (wp_subreify with "Hs"). + + simpl. by rewrite Hσ. + + done. + + done. + Qed. + + + Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : + update_output n σ = σ' → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ + WP@{rs} (OUTPUT n) @ s {{ Φ }}. + Proof. + iIntros (Hσ) "Hs Ha". + iApply (wp_output' _ _ _ idfun with "Hs [Ha]"); first done. + simpl. iNext. iIntros "Hcl Hs". + iApply wp_val. iApply ("Ha" with "Hcl Hs"). + Qed. + + Lemma wp_throw' (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) + (κ : IT -n> IT) `{!IT_hom κ} Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} (later_car f) x @ s {{ Φ }}) -∗ + WP@{rs} κ (THROW x f) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". rewrite /THROW. simpl. + rewrite hom_vis. + iApply (wp_subreify with "Hs"); simpl; done. + Qed. + + Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ + WP@{rs} (THROW x f) @ s {{ Φ }}. + Proof. + iApply (wp_throw' _ _ _ idfun). + Qed. + + Lemma wp_callcc (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ + WP@{rs} (k (CALLCC f)) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + unfold CALLCC. simpl. + rewrite hom_vis. + iApply (wp_subreify _ _ _ _ _ _ _ ((later_map k ((f (laterO_map k))))) with "Hs"). + { + simpl. + repeat f_equiv. + - rewrite ofe_iso_21. + f_equiv. + intro; simpl. + f_equiv. + apply ofe_iso_21. + - reflexivity. + } + { + rewrite later_map_Next. + reflexivity. + } + iModIntro. + iApply "Ha". + Qed. + +End weakestpre. + +Section interp. + Context {sz : nat}. + Variable (rs : gReifiers sz). + Context {subR : subReifier reify_io rs}. + Context {R} `{CR : !Cofe R}. + Context `{!SubOfe natO R}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + + Global Instance denot_cont_ne (κ : IT -n> IT) : + NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). + Proof. + solve_proper. + Qed. + + (** Interpreting individual operators *) + Program Definition interp_input {A} : A -n> IT := + λne env, INPUT Ret. + Program Definition interp_output {A} (t : A -n> IT) : A -n> IT := + get_ret OUTPUT ◎ t. + Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). + Proof. solve_proper. Qed. + + Program Definition interp_callcc {S} + (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := + λne env, CALLCC (λne (f : laterO IT -n> laterO IT), + (Next (e (@extend_scope F R _ _ env + (Fun (Next (λne x, Tau (f (Next x))))))))). + Next Obligation. + solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros [| a]; simpl; last solve_proper. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros [| a]; simpl; last solve_proper. + repeat f_equiv. + Qed. + + Program Definition interp_throw {A} (e : A -n> IT) (k : A -n> IT) + : A -n> IT := + λne env, get_val (λne x, get_fun (λne (f : laterO (IT -n> IT)), + THROW x f) (k env)) (e env). + Next Obligation. + solve_proper. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intro; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv; last done. + intro; simpl. + by repeat f_equiv. + Qed. + + 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). + Solve All Obligations with solve_proper_please. + + Global Instance interp_natop_ne A op : NonExpansive2 (@interp_natop A op). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_natop. + + Opaque laterO_map. + Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) + : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := + λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), + body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + do 3 f_equiv; intros ??; simpl; f_equiv; + intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + by do 2 f_equiv. + Qed. + + Program Definition interp_rec {S : Set} + (body : @interp_scope F R _ (inc (inc S)) -n> IT) : + @interp_scope F R _ S -n> IT := + mmuu (interp_rec_pre body). + + Program Definition ir_unf {S : Set} + (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (@extend_scope F R _ _ + (@extend_scope F R _ _ env (interp_rec body env)) + a). + Next Obligation. + intros. + solve_proper_prepare. + f_equiv. intros [| [| y']]; simpl; solve_proper. + Qed. + + Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : + interp_rec body env ≡ Fun $ Next $ ir_unf body env. + Proof. + trans (interp_rec_pre body (Next (interp_rec body)) env). + { f_equiv. rewrite /interp_rec. apply mmuu_unfold. } + simpl. rewrite laterO_map_Next. repeat f_equiv. + simpl. unfold ir_unf. intro. simpl. reflexivity. + 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 ]. + Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_app. + + Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := + λne env, IF (t0 env) (t1 env) (t2 env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_if_ne A n : + Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). + Proof. solve_proper. Qed. + + Program Definition interp_nat (n : nat) {A} : A -n> IT := + λne env, Ret n. + + Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := + λne env, (Fun (Next (λne x, Tau (laterO_map (K env) (Next x))))). + Solve All Obligations with solve_proper_please. + + Program Definition interp_applk {A} + (K : A -n> (IT -n> IT)) + (q : A -n> IT) + : A -n> (IT -n> IT) := + λne env t, interp_app (λne env, K env t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_apprk {A} + (q : A -n> IT) + (K : A -n> (IT -n> IT)) + : A -n> (IT -n> IT) := + λne env t, interp_app q (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoprk {A} (op : nat_op) + (q : A -n> IT) + (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := + λne env t, interp_natop op q (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoplk {A} (op : nat_op) + (K : A -n> (IT -n> IT)) + (q : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_natop op (λne env, K env t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) + (p : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_if (λne env, K env t) q p env. + Solve All Obligations with solve_proper. + + Program Definition interp_outputk {A} (K : A -n> (IT -n> IT)) : + A -n> (IT -n> IT) := + λne env t, interp_output (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (k : A -n> IT) : + A -n> (IT -n> IT) := + λne env t, interp_throw (λne env, K env t) k env. + Solve All Obligations with solve_proper_please. + + Program Definition interp_throwrk {A} (e : A -n> IT) (K : A -n> (IT -n> IT)) : + A -n> (IT -n> IT) := + λne env t, interp_throw e (λne env, K env t) env. + Solve All Obligations with solve_proper_please. + + (** Interpretation for all the syntactic categories: values, expressions, contexts *) + Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := + match v with + | LitV n => interp_nat n + | RecV e => interp_rec (interp_expr e) + | ContV K => interp_cont (interp_ectx K) + end + with interp_expr {S} (e : expr S) : interp_scope S -n> IT := + match e with + | Val v => interp_val v + | Var x => interp_var x + | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) + | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) + | Input => interp_input + | Output e => interp_output (interp_expr e) + | Callcc e => interp_callcc (interp_expr e) + | Throw e1 e2 => interp_throw (interp_expr e1) (interp_expr e2) + end + with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := + match K with + | EmptyK => λne env, idfun + | AppRK e1 K => interp_apprk (interp_expr e1) (interp_ectx K) + | AppLK K v2 => interp_applk (interp_ectx K) (interp_val v2) + | NatOpRK op e1 K => interp_natoprk op (interp_expr e1) (interp_ectx K) + | NatOpLK op K v2 => interp_natoplk op (interp_ectx K) (interp_val v2) + | IfK K e1 e2 => interp_ifk (interp_ectx K) (interp_expr e1) (interp_expr e2) + | OutputK K => interp_outputk (interp_ectx K) + | ThrowLK K e => interp_throwlk (interp_ectx K) (interp_expr e) + | ThrowRK v K => interp_throwrk (interp_val v) (interp_ectx K) + end. + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + + (* Open Scope syn_scope. *) + + (* Example callcc_ex : expr ∅ := *) + (* NatOp + (# 1) (Callcc (NatOp + (# 1) (Throw (# 2) ($ 0)))). *) + (* Eval cbn in callcc_ex. *) + (* Eval cbn in interp_expr callcc_ex *) + (* (λne (x : leibnizO ∅), match x with end). *) + + Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) + : AsVal (interp_val v D). + Proof. + destruct v; simpl. + - apply _. + - rewrite interp_rec_unfold. apply _. + - apply _. + Qed. + + Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := + fun f g => ∀ x, f x = g x. + + Global Instance ArrDist {A B : Set} `{Dist B} : Dist (A [→] B) := + fun n => fun f g => ∀ x, f x ≡{n}≡ g x. + + Global Instance ren_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@ren_scope F _ CR S S'). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - apply Hs. + - apply HE. + Qed. + + Lemma interp_expr_ren {S S'} env + (δ : S [→] S') (e : expr S) : + interp_expr (fmap δ e) env ≡ interp_expr e (ren_scope δ env) + with interp_val_ren {S S'} env + (δ : S [→] S') (e : val S) : + interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env) + with interp_ectx_ren {S S'} env + (δ : S [→] S') (e : ectx S) : + interp_ectx (fmap δ e) env ≡ interp_ectx e (ren_scope δ env). + Proof. + - destruct e; simpl. + + by apply interp_val_ren. + + reflexivity. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + simpl; rewrite interp_expr_ren. + f_equiv. + intros [| y]; simpl. + * reflexivity. + * reflexivity. + + repeat f_equiv. + * intros ?; simpl. + repeat f_equiv; first by apply interp_expr_ren. + * by apply interp_expr_ren. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_ren. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * done. + + repeat f_equiv. + intros ?; simpl. + repeat f_equiv; by apply interp_ectx_ren. + - destruct e; simpl; intros ?; simpl. + + reflexivity. + + repeat f_equiv; by apply interp_ectx_ren. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_expr_ren | by apply interp_expr_ren]. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + + repeat f_equiv; last by apply interp_ectx_ren. + intros ?; simpl; repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; last by apply interp_val_ren. + intros ?; simpl; repeat f_equiv; first by apply interp_ectx_ren. + Qed. + + Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): + interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). + Proof. + revert env. + induction K; simpl; intros env; first reflexivity; try (by rewrite IHK). + - repeat f_equiv. + by rewrite IHK. + - repeat f_equiv. + by rewrite IHK. + - repeat f_equiv. + by rewrite IHK. + - repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + by rewrite IHK. + Qed. + + Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') + : interp_scope S := λne x, interp_expr (δ x) env. + + Global Instance SubEquiv {A B : Set} : Equiv (A [⇒] B) := fun f g => ∀ x, f x = g x. + + Global Instance sub_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@sub_scope S S'). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - f_equiv. + apply HE. + - apply Hs. + Qed. + + Lemma interp_expr_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_expr (bind δ e) env ≡ interp_expr e (sub_scope δ env) + with interp_val_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env) + with interp_ectx_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_ectx (bind δ e) env ≡ interp_ectx e (sub_scope δ env). + Proof. + - destruct e; simpl. + + by apply interp_val_subst. + + term_simpl. + reflexivity. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv; by apply interp_expr_subst. + + f_equiv. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + rewrite interp_expr_subst. + f_equiv. + intros [| x']; simpl. + * reflexivity. + * rewrite interp_expr_ren. + f_equiv. + intros ?; reflexivity. + + repeat f_equiv. + * intros ?; simpl. + repeat f_equiv; first by apply interp_expr_subst. + * by apply interp_expr_subst. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_subst. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_subst. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * do 2 rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (z). + done. + + repeat f_equiv; intro; simpl; repeat f_equiv. + by apply interp_ectx_subst. + - destruct e; simpl; intros ?; simpl. + + reflexivity. + + repeat f_equiv; by apply interp_ectx_subst. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + + repeat f_equiv; last by apply interp_ectx_subst. + intros ?; simpl; repeat f_equiv; first by apply interp_expr_subst. + + repeat f_equiv; last by apply interp_val_subst. + intros ?; simpl; repeat f_equiv; first by apply interp_ectx_subst. + Qed. + + (** ** Interpretation is a homomorphism (for some constructors) *) + + #[global] Instance interp_ectx_hom_emp {S} env : + IT_hom (interp_ectx (EmptyK : ectx S) env). + Proof. + simple refine (IT_HOM _ _ _ _ _); intros; auto. + simpl. fold (@idfun IT). f_equiv. intro. simpl. + by rewrite laterO_map_id. + Qed. + + #[global] Instance interp_ectx_hom_output {S} (K : ectx S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (OutputK K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. + f_equiv. intro. simpl. rewrite -laterO_map_compose. + do 2 f_equiv. by intro. + - by rewrite !hom_err. + Qed. + + #[global] Instance interp_ectx_hom_if {S} + (K : ectx S) (e1 e2 : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (IfK K e1 e2) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. + - assert ((interp_ectx K env (Vis op i ko)) ≡ + (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). + { by rewrite hom_vis. } + trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) + (interp_expr e1 env) (interp_expr e2 env)). + { do 3 f_equiv. by rewrite hom_vis. } + rewrite IF_Vis. f_equiv. simpl. + intro. simpl. by rewrite -laterO_map_compose. + - trans (IF (Err e) (interp_expr e1 env) (interp_expr e2 env)). + { repeat f_equiv. apply hom_err. } + apply IF_Err. + Qed. + + #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) + (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppRK e 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. + Qed. + + #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) + (v : val S) (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppLK K v) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. + - trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) + (interp_val v env)). + + do 2f_equiv. rewrite hom_vis. do 3 f_equiv. by intro. + + rewrite APP'_Vis_l. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - trans (APP' (Err e) (interp_val v env)). + { do 2f_equiv. apply hom_err. } + apply APP'_Err_l, interp_val_asval. + Qed. + + #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) + (e : expr S) op env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpRK op e K) env). + Proof. + intros H. 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. + Qed. + + #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) + (v : val S) op (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpLK op K v) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -NATOP_ITV_Tick_l. do 2 f_equiv. apply hom_tick. + - trans (NATOP (do_natop op) + (Vis op0 i (laterO_map (interp_ectx K env) ◎ ko)) + (interp_val v env)). + { do 2 f_equiv. rewrite hom_vis. f_equiv. by intro. } + rewrite NATOP_ITV_Vis_l. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - trans (NATOP (do_natop op) (Err e) (interp_val v env)). + + do 2 f_equiv. apply hom_err. + + by apply NATOP_Err_l, interp_val_asval. + Qed. + + Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). + Proof. + intros. + by rewrite IT_rec1_ret. + Qed. + + #[global] Instance interp_ectx_hom_throwr {S} + (K : ectx S) (v : val S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (ThrowRK v K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - pose proof (interp_val_asval v (D := env)). + rewrite ->2 get_val_ITV. + simpl. + rewrite hom_tick. + destruct (IT_dont_confuse ((interp_ectx K env α))) as [(e' & HEQ) |[(n & HEQ) |[(f & HEQ) |[(β & HEQ) | (op & i & k & HEQ)]]]]. + + rewrite HEQ !get_fun_tick !get_fun_err. + reflexivity. + + rewrite HEQ !get_fun_tick !get_fun_ret'. + reflexivity. + + rewrite HEQ !get_fun_tick !get_fun_fun//=. + + rewrite HEQ !get_fun_tick. + reflexivity. + + rewrite HEQ !get_fun_tick !get_fun_vis. + reflexivity. + - pose proof (interp_val_asval v (D := env)). + rewrite get_val_ITV. + simpl. + rewrite hom_vis. + rewrite get_fun_vis. + f_equiv. + intro; simpl. + rewrite -laterO_map_compose. + repeat f_equiv. + intro; simpl. + rewrite get_val_ITV. + simpl. + reflexivity. + - pose proof (interp_val_asval v (D := env)). + rewrite get_val_ITV. + simpl. + rewrite hom_err. + rewrite get_fun_err. + reflexivity. + Qed. + + #[global] Instance interp_ectx_hom_throwl {S} + (K : ectx S) (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (ThrowLK K e) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; [by rewrite !hom_tick| | by rewrite !hom_err]. + rewrite !hom_vis. + f_equiv. + intro; simpl. + rewrite -laterO_map_compose. + reflexivity. + Qed. + + #[global] Instance interp_ectx_hom {S} + (K : ectx S) env : + IT_hom (interp_ectx K env). + Proof. + induction K; apply _. + Qed. + + (** ** Finally, preservation of reductions *) + Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' σ σ' K n : + head_step e σ e' σ' K (n, 0) → + interp_expr e env ≡ Tick_n n $ interp_expr e' env. + Proof. + inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. + - (* app lemma *) + subst. + erewrite APP_APP'_ITV; last apply _. + trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). + { repeat f_equiv. apply interp_rec_unfold. } + rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. + simplify_eq. + rewrite !interp_expr_subst. + f_equiv. + intros [| [| x]]; simpl; [| reflexivity | reflexivity]. + rewrite interp_val_ren. + f_equiv. + intros ?; simpl; reflexivity. + - (* the natop stuff *) + simplify_eq. + destruct v1,v2; try naive_solver. simpl in *. + rewrite NATOP_Ret. + destruct op; simplify_eq/=; done. + - rewrite IF_True; last lia. + reflexivity. + - rewrite IF_False; last lia. + reflexivity. + Qed. + + Lemma interp_expr_fill_no_reify {S} K (env : interp_scope S) (e e' : expr S) σ σ' n : + head_step e σ e' σ' K (n, 0) → + interp_expr (fill K e) env + ≡ + Tick_n n $ interp_expr (fill K e') env. + Proof. + intros He. + rewrite !interp_comp. + erewrite <-hom_tick_n. + - apply (interp_expr_head_step env) in He. + rewrite He. + reflexivity. + - apply _. + Qed. + + Opaque INPUT OUTPUT_ CALLCC CALLCC_ THROW. + Opaque extend_scope. + Opaque Ret. + + Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) + (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : + head_step e σ e' σ' K (n, 1) → + reify (gReifiers_sReifier rs) + (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). + Proof. + intros Hst. + trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) + (gState_recomp σr (sR_state σ))). + { f_equiv. by rewrite interp_comp. } + inversion Hst; simplify_eq; cbn-[gState_recomp]. + - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). + { + repeat f_equiv; eauto. + rewrite hom_INPUT. + do 2 f_equiv. by intro. + } + rewrite reify_vis_eq //; first last. + { + epose proof (@subReifier_reify sz reify_io rs _ IT _ (inl ()) () (Next (interp_ectx K env (Ret n0))) (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr) as H. + simpl in H. + simpl. + erewrite <-H; last first. + - rewrite H5. reflexivity. + - f_equiv; + solve_proper. + } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_comp. + reflexivity. + - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). + { + do 3 f_equiv; eauto. + rewrite get_ret_ret//. + } + trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). + { + do 2 f_equiv; eauto. + by rewrite hom_OUTPUT_. + } + rewrite reify_vis_eq //; last first. + { + epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inl ())) n0 (Next (interp_ectx K env ((Ret 0)))) (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. + simpl in H. + simpl. + erewrite <-H; last reflexivity. + f_equiv. + + intros ???. by rewrite /prod_map H0. + + do 2 f_equiv. by intro. + } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_comp. + reflexivity. + - match goal with + | |- context G [ofe_mor_car _ _ (CALLCC) ?g] => set (f := g) + end. + match goal with + | |- context G [(?s, _)] => set (gσ := s) end. + Transparent CALLCC. + unfold CALLCC. + simpl. + set (subEff1 := @subReifier_subEff sz reify_io rs subR). + trans (reify (gReifiers_sReifier rs) (CALLCC_ f (laterO_map (interp_ectx K env))) gσ). + { + do 2 f_equiv. + rewrite hom_CALLCC_. + f_equiv. by intro. + } + rewrite reify_vis_eq//; last first. + { + simpl. + epose proof (@subReifier_reify sz reify_io rs subR IT _ + (inr (inr (inl ()))) f _ + (laterO_map (interp_ectx K env)) σ' σ' σr) as H. + simpl in H. + erewrite <-H; last reflexivity. + f_equiv; last done. + intros ???. by rewrite /prod_map H0. + } + rewrite interp_comp. + rewrite interp_expr_subst. + f_equiv. + rewrite Tick_eq. + f_equiv. + rewrite laterO_map_Next. + do 3 f_equiv. + Transparent extend_scope. + intros [| x]; term_simpl; last reflexivity. + do 2 f_equiv. by intro. + Qed. + + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : + prim_step e1 σ1 e2 σ2 (n,m) → + ssteps (gReifiers_sReifier rs) + (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. + Proof. + Opaque gState_decomp gState_recomp. + inversion 1; simplify_eq/=. + { + destruct (head_step_io_01 _ _ _ _ _ _ _ H2); subst. + - assert (σ1 = σ2) as ->. + { eapply head_step_no_io; eauto. } + unshelve eapply (interp_expr_fill_no_reify K) in H2; first apply env. + rewrite H2. + rewrite interp_comp. + eapply ssteps_tick_n. + - inversion H2;subst. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite interp_comp. + rewrite hom_INPUT. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify. + { Transparent INPUT. unfold INPUT. simpl. + f_equiv. reflexivity. } + simpl in H2. + rewrite -H2. + repeat f_equiv; eauto. + rewrite interp_comp hom_INPUT. + eauto. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite interp_comp. simpl. + rewrite get_ret_ret. + rewrite hom_OUTPUT_. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + eapply sstep_reify. + { Transparent OUTPUT_. unfold OUTPUT_. simpl. + f_equiv. reflexivity. } + simpl in H2. + rewrite -H2. + repeat f_equiv; eauto. + Opaque OUTPUT_. + rewrite interp_comp /= get_ret_ret hom_OUTPUT_. + eauto. + + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + rewrite !interp_comp interp_expr_subst. + change 1 with (Nat.add 1 0). econstructor; last first. + { apply ssteps_zero; reflexivity. } + rewrite -interp_comp. + eapply sstep_reify. + { Transparent CALLCC. unfold CALLCC. rewrite interp_comp hom_vis. + f_equiv. reflexivity. + } + rewrite H2. + simpl. + repeat f_equiv. + rewrite -interp_expr_subst. + rewrite interp_comp. + reflexivity. + } + { + rewrite !interp_comp. + simpl. + pose proof (interp_val_asval v (D := env)). + rewrite get_val_ITV. + simpl. + rewrite get_fun_fun. + simpl. + change 2 with (Nat.add (Nat.add 1 1) 0). + econstructor; last first. + { apply ssteps_tick_n. } + eapply sstep_reify; first (rewrite hom_vis; reflexivity). + match goal with + | |- context G [ofe_mor_car _ _ _ (Next ?f)] => set (f' := f) + end. + trans (reify (gReifiers_sReifier rs) (THROW (interp_val v env) (Next f')) (gState_recomp σr (sR_state σ2))). + { + f_equiv; last done. + f_equiv. + rewrite hom_vis. + Transparent THROW. + unfold THROW. + simpl. + repeat f_equiv. + intros x; simpl. + destruct ((subEff_outs ^-1) x). + } + rewrite reify_vis_eq; first (rewrite Tick_eq; reflexivity). + simpl. + match goal with + | |- context G [(_, _, ?a)] => set (κ := a) + end. + epose proof (@subReifier_reify sz reify_io rs subR IT _ + (inr (inr (inr (inl ())))) (Next (interp_val v env), Next f') + (Next (Tau (Next ((interp_ectx K' env) (interp_val v env))))) + (Empty_setO_rec _) σ2 σ2 σr) as H'. + subst κ. + simpl in H'. + erewrite <-H'; last reflexivity. + rewrite /prod_map. + f_equiv; first solve_proper. + do 2 f_equiv; first reflexivity. + intro; simpl. + f_equiv. + } + Qed. + +End interp. +#[global] Opaque INPUT OUTPUT_ CALLCC THROW. diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v new file mode 100644 index 0000000..33216a4 --- /dev/null +++ b/theories/input_lang_delim/lang.v @@ -0,0 +1,774 @@ +From stdpp Require Export strings. +From gitrees Require Export prelude. +(* From Equations Require Import Equations. *) +Require Import List. +Import ListNotations. + +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. + +Inductive nat_op := Add | Sub | Mult. + +Inductive expr {X : Set} := +(* Values *) +| Val (v : val) : expr +| Var (x : X) : expr +(* Base lambda calculus *) +| App (e₁ : expr) (e₂ : expr) : expr +(* Base types and their operations *) +| NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr +| If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr +(* The effects *) +| Input : expr +| Output (e : expr) : expr +| Shift (e : @expr (inc X)) : expr +| Reset (e : expr) : expr +with val {X : Set} := +| LitV (n : nat) : val +| RecV (e : @expr (inc (inc X))) : val +| ContV (K : ectx) : val +with ectx {X : Set} := +| EmptyK : ectx +| OutputK (K : ectx) : ectx +| IfK (K : ectx) (e₁ : expr) (e₂ : expr) : ectx +| AppLK (K : ectx) (v : val) : ectx +| AppRK (e : expr) (K : ectx) : ectx +| NatOpRK (op : nat_op) (e : expr) (K : ectx) : ectx +| NatOpLK (op : nat_op) (K : ectx) (v : val) : ectx +| ResetK (K : ectx) : ectx. + +Arguments val X%bind : clear implicits. +Arguments expr X%bind : clear implicits. +Arguments ectx X%bind : clear implicits. + +Local Open Scope bind_scope. + +Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := + match e with + | Val v => Val (vmap f v) + | Var x => Var (f x) + | App e₁ e₂ => App (emap f e₁) (emap f e₂) + | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) + | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) + | Input => Input + | Output e => Output (emap f e) + | Shift e => Shift (emap (f ↑) e) + | Reset e => Reset (emap f e) + end +with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (emap ((f ↑) ↑) e) + | ContV K => ContV (kmap f K) + end +with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kmap f K) + | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) + | AppLK K v => AppLK (kmap f K) (vmap f v) + | AppRK e K => AppRK (emap f e) (kmap f K) + | NatOpRK op e K => NatOpRK op (emap f e) (kmap f K) + | NatOpLK op K v => NatOpLK op (kmap f K) (vmap f v) + | ResetK K => ResetK (kmap f K) + end. +#[export] Instance FMap_expr : FunctorCore expr := @emap. +#[export] Instance FMap_val : FunctorCore val := @vmap. +#[export] Instance FMap_ectx : FunctorCore ectx := @kmap. + +#[export] Instance SPC_expr : SetPureCore expr := @Var. + +Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := + match e with + | Val v => Val (vbind f v) + | Var x => f x + | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) + | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) + | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) + | Input => Input + | Output e => Output (ebind f e) + | Shift e => Shift (ebind (f ↑) e) + | Reset e => Reset (ebind f e) + end +with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (ebind ((f ↑) ↑) e) + | ContV K => ContV (kbind f K) + end +with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kbind f K) + | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) + | AppLK K v => AppLK (kbind f K) (vbind f v) + | AppRK e K => AppRK (ebind f e) (kbind f K) + | NatOpRK op e K => NatOpRK op (ebind f e) (kbind f K) + | NatOpLK op K v => NatOpLK op (kbind f K) (vbind f v) + | ResetK K => ResetK (kbind f K) + end. + +#[export] Instance BindCore_expr : BindCore expr := @ebind. +#[export] Instance BindCore_val : BindCore val := @vbind. +#[export] Instance BindCore_ectx : BindCore ectx := @kbind. + +#[export] Instance IP_typ : SetPure expr. +Proof. + split; intros; reflexivity. +Qed. + +Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v +with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e +with kmap_id X (δ : X [→] X) (e : ectx X) : δ ≡ ı → fmap δ e = e. +Proof. + - auto_map_id. + - auto_map_id. + - auto_map_id. +Qed. + +Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : + f ∘ g ≡ h → fmap f (fmap g v) = fmap h v +with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e +with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : ectx A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. +Proof. + - auto_map_comp. + - auto_map_comp. + - auto_map_comp. +Qed. + +#[export] Instance Functor_val : Functor val. +Proof. + split; [exact vmap_id | exact vmap_comp]. +Qed. +#[export] Instance Functor_expr : Functor expr. +Proof. + split; [exact emap_id | exact emap_comp]. +Qed. +#[export] Instance Functor_ectx : Functor ectx. +Proof. + split; [exact kmap_id | exact kmap_comp]. +Qed. + +Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : + f ̂ ≡ g → fmap f v = bind g v +with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : + f ̂ ≡ g → fmap f e = bind g e +with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx A) : + f ̂ ≡ g → fmap f e = bind g e. +Proof. + - auto_map_bind_pure. + erewrite emap_ebind_pure; [reflexivity |]. + intros [| [| x]]; term_simpl; [reflexivity | reflexivity |]. + rewrite <-(EQ x). + reflexivity. + - auto_map_bind_pure. + - auto_map_bind_pure. +Qed. + +#[export] Instance BindMapPure_val : BindMapPure val. +Proof. + split; intros; now apply vmap_vbind_pure. +Qed. +#[export] Instance BindMapPure_expr : BindMapPure expr. +Proof. + split; intros; now apply emap_ebind_pure. +Qed. +#[export] Instance BindMapPure_ectx : BindMapPure ectx. +Proof. + split; intros; now apply kmap_kbind_pure. +Qed. + +Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (v : val A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) +with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) +with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : ectx A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). +Proof. + - auto_map_bind_comm. + erewrite emap_ebind_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity | assumption]. + - auto_map_bind_comm. + - auto_map_bind_comm. +Qed. + +#[export] Instance BindMapComm_val : BindMapComm val. +Proof. + split; intros; now apply vmap_vbind_comm. +Qed. +#[export] Instance BindMapComm_expr : BindMapComm expr. +Proof. + split; intros; now apply emap_ebind_comm. +Qed. +#[export] Instance BindMapComm_ectx : BindMapComm ectx. +Proof. + split; intros; now apply kmap_kbind_comm. +Qed. + +Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : + f ≡ ı → bind f v = v +with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : + f ≡ ı → bind f e = e +with kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : + f ≡ ı → bind f e = e. +Proof. + - auto_bind_id. + rewrite ebind_id; [reflexivity |]. + apply lift_id, lift_id; assumption. + - auto_bind_id. + - auto_bind_id. +Qed. + +Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : + f ∘ g ≡ h → bind f (bind g v) = bind h v +with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e +with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e. +Proof. + - auto_bind_comp. + erewrite ebind_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity | assumption]. + - auto_bind_comp. + - auto_bind_comp. +Qed. + +#[export] Instance Bind_val : Bind val. +Proof. + split; intros; [now apply vbind_id | now apply vbind_comp]. +Qed. +#[export] Instance Bind_expr : Bind expr. +Proof. + split; intros; [now apply ebind_id | now apply ebind_comp]. +Qed. +#[export] Instance Bind_ectx : Bind ectx. +Proof. + split; intros; [now apply kbind_id | now apply kbind_comp]. +Qed. + +Definition to_val {S} (e : expr S) : option (val S) := + match e with + | Val v => Some v + | _ => None + end. + +Definition do_natop (op : nat_op) (x y : nat) : nat := + match op with + | Add => plus x y + | Sub => minus x y + | Mult => mult x y + end. + +Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := + match x, y with + | LitV x, LitV y => Some $ LitV $ do_natop n x y + | _,_ => None + end. + +Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := + match K with + | EmptyK => e + | OutputK K => Output (fill K e) + | IfK K e₁ e₂ => If (fill K e) e₁ e₂ + | AppLK K v => App (fill K e) (Val v) + | AppRK e' K => App e' (fill K e) + | NatOpRK op e' K => NatOp op e' (fill K e) + | NatOpLK op K v => NatOp op (fill K e) (Val v) + | ResetK K => Reset (fill K e) + end. + +Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) + : fmap f (fill K e) = fill (fmap f K) (fmap f e). +Proof. + revert f. + induction K as + [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH + | ??? IH | ?? IH ]; + intros f; term_simpl; first done; rewrite IH; reflexivity. +Qed. + +(*** Operational semantics *) + +Record state := State { + inputs : list nat; + outputs : list nat; + }. +#[export] Instance state_inhabited : Inhabited state := populate (State [] []). + +Definition update_input (s : state) : nat * state := + match s.(inputs) with + | [] => (0, s) + | n::ns => + (n, {| inputs := ns; outputs := s.(outputs) |}) + end. +Definition update_output (n:nat) (s : state) : state := + {| inputs := s.(inputs); outputs := n::s.(outputs) |}. + + +(** [head_step e σ e' σ' K (n, m)] : step from [(e, σ)] to [(e', σ')] under context K + in [n] ticks with [m] i/o accesses *) +Inductive head_step {S} : expr S → state → expr S → state → ectx S → nat * nat → Prop := +| BetaS e1 v2 σ K : + head_step (App (Val $ RecV e1) (Val v2)) σ + (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) + (Val (shift (Inc := inc) v2))) + (Val (RecV e1))) σ K (1,0) +| InputS σ n σ' K : + update_input σ = (n, σ') → + head_step Input σ (Val (LitV n)) σ' K (1, 1) +| OutputS σ n σ' K : + update_output n σ = σ' → + head_step (Output (Val (LitV n))) σ (Val (LitV 0)) σ' K (1, 1) +| NatOpS op v1 v2 v3 σ K : + nat_op_interp op v1 v2 = Some v3 → + head_step (NatOp op (Val v1) (Val v2)) σ + (Val v3) σ K (0, 0) +| IfTrueS n e1 e2 σ K : + n > 0 → + head_step (If (Val (LitV n)) e1 e2) σ + e1 σ K (0, 0) +| IfFalseS n e1 e2 σ K : + n = 0 → + head_step (If (Val (LitV n)) e1 e2) σ + e2 σ K (0, 0) +(* | ShiftS e σ K : *) +(* head_step (Shift e) σ (subst (Inc := inc) e (Val (ContV K))) σ K (1, 1) *) +| ResetValS v σ K: + head_step (Reset (Val v)) σ (Val v) σ K (1,0) +| ResetShiftS e σ K E: + head_step + (Reset (fill E (Shift e))) σ + (Reset (subst (Inc := inc) e (Val $ ContV $ ResetK E))) σ K (1,0). + +Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : + head_step e1 σ1 e2 σ2 K (n,m) → m = 0 ∨ m = 1. +Proof. inversion 1; eauto. Qed. +Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : + head_step e1 σ1 e2 σ2 K (n,m) → n = 0 ∨ n = 1. +Proof. inversion 1; eauto. Qed. +Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K n : + head_step e1 σ1 e2 σ2 K (n,0) → σ1 = σ2. +Proof. inversion 1; eauto. Qed. + +(** Carbonara from heap lang *) +Global Instance fill_item_inj {S} (Ki : ectx S) : Inj (=) (=) (fill Ki). +Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. + +Lemma fill_item_val {S} Ki (e : expr S) : + is_Some (to_val (fill Ki e)) → is_Some (to_val e). +Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed. + +Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K m : head_step e1 σ1 e2 σ2 K m → to_val e1 = None. +Proof. destruct 1; naive_solver. Qed. + +Fixpoint ectx_compose {S} (K1 K2 : ectx S) : ectx S + := match K1 with + | EmptyK => K2 + | OutputK K => OutputK (ectx_compose K K2) + | IfK K e₁ e₂ => IfK (ectx_compose K K2) e₁ e₂ + | AppLK K v => AppLK (ectx_compose K K2) v + | AppRK e K => AppRK e (ectx_compose K K2) + | NatOpRK op e K => NatOpRK op e (ectx_compose K K2) + | NatOpLK op K v => NatOpLK op (ectx_compose K K2) v + | ResetK K => ResetK (ectx_compose K K2) + end. + +Lemma fill_app {S} (K1 K2 : ectx S) e : fill (ectx_compose K1 K2) e = fill K1 (fill K2 e). +Proof. + revert K2. + revert e. + induction K1 as + [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH | ??? IH | ?? IH ]; + simpl; first done; intros e' K2; rewrite IH; reflexivity. +Qed. + +Lemma fill_val : ∀ {S} K (e : expr S), is_Some (to_val (fill K e)) → is_Some (to_val e). +Proof. + intros S K. + induction K as [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH | ??? IH | ?? IH ] + => e' //=; + inversion 1 as [? HH]; inversion HH. +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. + +Lemma fill_empty {S} (e : expr S) : fill EmptyK e = e. +Proof. reflexivity. Qed. +Lemma fill_comp {S} K1 K2 (e : expr S) : fill K2 (fill K1 e) = fill (ectx_compose K2 K1) e. +Proof. by rewrite fill_app. Qed. +Global Instance fill_inj {S} (K : ectx S) : Inj (=) (=) (fill K). +Proof. + induction K as [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH | ??? IH | ?? IH ]; + rewrite /Inj; naive_solver. +Qed. + +(* FIXME maybe *) +Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) + (e2 : expr S) (σ2 : state) (n : nat * nat), Prop := +| Ectx_step e1 σ1 e2 σ2 n (K : ectx S) e1' e2' : + e1 = fill K e1' → e2 = fill K e2' → + head_step e1' σ1 e2' σ2 K n → prim_step e1 σ1 e2 σ2 n +| App_cont_step e1 σ e2 (K : ectx S) v K' : + e1 = (fill K (App (Val $ ContV K') (Val v))) -> + e2 = (fill K' (Val v)) -> + prim_step e1 σ e2 σ (2, 0). +(* CHECK *) + +Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : + prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. +Proof. + inversion 1; simplify_eq/=. + - by inversion H2. + - by inversion H. +Qed. + +Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat → Prop := +| prim_steps_zero e σ : + prim_steps e σ e σ (0, 0) +| prim_steps_abit e1 σ1 e2 σ2 e3 σ3 n1 m1 n2 m2 : + prim_step e1 σ1 e2 σ2 (n1, m1) → + prim_steps e2 σ2 e3 σ3 (n2, m2) → + prim_steps e1 σ1 e3 σ3 (plus n1 n2, plus m1 m2) +. + +Lemma Ectx_step' {S} (K : ectx S) e1 σ1 e2 σ2 efs : + head_step e1 σ1 e2 σ2 K efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. +Proof. econstructor; eauto. Qed. + +Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : + prim_steps e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 → + prim_steps e1 σ1 e3 σ3 (plus nm1.1 nm2.1, plus nm1.2 nm2.2). +Proof. + intros Hst. revert nm2. + induction Hst; intros [n' m']; simplify_eq/=; first done. + rewrite -!Nat.add_assoc. intros Hsts. + econstructor; eauto. + by apply (IHHst (n',m')). +Qed. + +Lemma prim_step_steps {S} nm (e1 e2 : expr S) σ1 σ2 : + prim_step e1 σ1 e2 σ2 nm → prim_steps e1 σ1 e2 σ2 nm. +Proof. + destruct nm as [n m]. intro Hs. + rewrite -(Nat.add_0_r n). + rewrite -(Nat.add_0_r m). + econstructor; eauto. + by constructor. +Qed. + +Lemma prim_step_steps_steps {S} (e1 e2 e3 : expr S) σ1 σ2 σ3 nm1 nm2 nm3 : + nm3 = (plus nm1.1 nm2.1, plus nm1.2 nm2.2) -> + prim_step e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 -> prim_steps e1 σ1 e3 σ3 nm3. +Proof. + intros -> H G. + eapply prim_steps_app; last apply G. + apply prim_step_steps, H. +Qed. + +Lemma head_step_prim_step {S} (e1 e2 : expr S) σ1 σ2 nm : + head_step e1 σ1 e2 σ2 EmptyK nm -> prim_step e1 σ1 e2 σ2 nm. +Proof. + assert (e1 = fill EmptyK e1) as Heq1; first done. + rewrite ->Heq1 at 2. + assert (e2 = fill EmptyK e2) as Heq2; first done. + rewrite ->Heq2 at 2. + apply Ectx_step'. +Qed. + +(*** Type system *) + +Inductive ty := + | Tnat : ty | Tarr : ty → ty → ty | Tcont : ty → ty. + +Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := +| 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_Input : + typed Γ Input Tnat +| typed_Output e : + typed Γ e Tnat → + typed Γ (Output e) Tnat +(* | typed_Throw e1 e2 τ τ' : *) +(* typed Γ e1 τ -> *) +(* typed Γ e2 (Tcont τ) -> *) +(* typed Γ (Throw e1 e2) τ' *) +| typed_Callcc e τ : + typed (Γ ▹ Tcont τ) e τ -> + typed Γ (Shift e) τ +| type_Reset e τ : + typed Γ e τ -> + typed Γ (Reset e) τ +(* CHECK *) +with typed_val {S : Set} (Γ : S -> ty) : val S → ty → Prop := +| typed_Lit n : + typed_val Γ (LitV n) Tnat +| typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : + typed (Γ ▹ (Tarr τ1 τ2) ▹ τ1) e τ2 → + typed_val Γ (RecV e) (Tarr τ1 τ2) +. + +Declare Scope syn_scope. +Delimit Scope syn_scope with syn. + +Coercion Val : val >-> expr. + +Coercion App : expr >-> Funclass. +Coercion AppLK : ectx >-> Funclass. +Coercion AppRK : expr >-> Funclass. + +Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. + +Arguments __asSynExpr {_} {_} {_}. + +Global Instance AsSynExprValue : AsSynExpr val := { + __asSynExpr _ v := Val v + }. +Global Instance AsSynExprExpr : AsSynExpr expr := { + __asSynExpr _ e := e + }. + +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) := { + __op e₁ op e₂ := NatOp op (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance OpNotationLK {S : Set} : OpNotation (ectx S) (nat_op) (val S) (ectx S) := { + __op K op v := NatOpLK op K v + }. + +Global Instance OpNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : OpNotation (F S) (nat_op) (ectx S) (ectx S) := { + __op e op K := NatOpRK op (__asSynExpr e) K + }. + +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) := { + __if e₁ e₂ e₃ := If (__asSynExpr e₁) (__asSynExpr e₂) (__asSynExpr e₃) + }. + +Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : IfNotation (ectx S) (F S) (G S) (ectx S) := { + __if K e₂ e₃ := IfK K (__asSynExpr e₂) (__asSynExpr e₃) + }. + +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 (ectx S) (ectx S) := { + __output K := OutputK K + }. + +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 (ectx S) (ectx S) := + { __reset K := ResetK K }. + +(* 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 (ectx S) (F S) (ectx S) := { *) +(* __throw K e₂ := ThrowLK K (__asSynExpr e₂) *) +(* }. *) + +(* Global Instance ThrowNotationRK {S : Set} : ThrowNotation (val S) (ectx S) (ectx 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) := { + __app e₁ e₂ := App (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance AppNotationLK {S : Set} : AppNotation (ectx S) (val S) (ectx S) := { + __app K v := AppLK K v + }. + +Global Instance AppNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (ectx S) (ectx S) := { + __app e K := AppRK (__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. +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. + +Definition LamV {S : Set} (e : expr (inc S)) : val S := + RecV (shift e). + +Notation "'λ' . 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 test3 : expr ∅ := (shift/cc ($ 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) : ℕ). +End SynExamples. + +Definition compute_head_step {S} (e : expr S) (σ : state) (K : ectx S) : option (expr S * state * (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))), σ, (1,0)) + | Input => + let '(n, σ') := update_input σ in + Some ((Val (LitV n)), σ', (1, 1)) + | Output (Val (LitV n)) => + let σ' := update_output n σ in + Some ((Val (LitV 0)), σ', (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), σ, (0, 0))) None res + | (If (Val (LitV n)) e1 e2) => + if (decide (0 < n)) + then Some (e1, σ, (0, 0)) + else + if (decide (n = 0)) + then Some (e2, σ, (0, 0)) + else None + (* | (Shift e) => Some ((subst (Inc := inc) e (Val (ContV K))), σ, (1, 1)) *) + | (Reset (Val v)) => Some (Val v, σ, (1, 0)) + (* | (Reset (fill E (Shift e))) => None *) + | _ => None + end. +(* CHECK *) + +Lemma head_step_reflect {S : Set} (e : expr S) (σ : state) (K : ectx S) + : option_reflect (fun '(e', σ', nm) => head_step e σ e' σ' K 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 e; try (by constructor). + do 2 constructor. +Qed. diff --git a/theories/input_lang_delim/logrel.v b/theories/input_lang_delim/logrel.v new file mode 100644 index 0000000..1adfe97 --- /dev/null +++ b/theories/input_lang_delim/logrel.v @@ -0,0 +1,789 @@ +(** Logical relation for adequacy for the IO lang *) +From Equations Require Import Equations. +From gitrees Require Import gitree. +From gitrees.input_lang_callcc Require Import lang interp hom. +Require Import gitrees.lang_generic_sem. +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope stdpp_scope. + +Section logrel. + Context {sz : nat}. + Variable (rs : gReifiers sz). + Context {subR : subReifier reify_io rs}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F natO). + Notation ITV := (ITV F natO). + Context `{!invGS Σ, !stateG rs natO Σ}. + Notation iProp := (iProp Σ). + Notation restO := (gState_rest sR_idx rs ♯ IT). + + Canonical Structure exprO S := leibnizO (expr S). + Canonical Structure valO S := leibnizO (val S). + Canonical Structure ectxO S := leibnizO (ectx 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} (βv : ITV) (v : val S) : iProp := + (∃ n, βv ≡ RetV n ∧ ⌜v = LitV n⌝)%I. + + Definition obs_ref {S} (α : IT) (e : expr S) : iProp := + (∀ (σ : stateO), + has_substate σ -∗ + WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ + ∗ logrel_nat βv v ∗ has_substate σ' }})%I. + + Definition logrel_ectx {S} V (κ : HOM) (K : ectx S) : iProp := + (□ ∀ (βv : ITV) (v : val S), V βv v -∗ obs_ref (`κ (IT_of_V βv)) (fill K (Val v)))%I. + + Definition logrel_expr {S} V (α : IT) (e : expr S) : iProp := + (∀ (κ : HOM) (K : ectx S), + logrel_ectx V κ K -∗ obs_ref (`κ α) (fill K e))%I. + + Definition logrel_arr {S} V1 V2 (βv : ITV) (vf : val S) : iProp := + (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ + logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. + + + Definition logrel_cont {S} V (βv : ITV) (v : val S) : iProp := + (∃ (κ : HOM) K, (IT_of_V βv) ≡ (Fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))) + ∧ ⌜v = ContV K⌝ + ∧ □ logrel_ectx V κ K)%I. + + Fixpoint logrel_val {S} (τ : ty) : ITV → (val S) → iProp + := match τ with + | Tnat => logrel_nat + | Tarr τ1 τ2 => logrel_arr (logrel_val τ1) (logrel_val τ2) + | Tcont τ => logrel_cont (logrel_val τ) + end. + + Definition logrel {S} (τ : ty) : IT → (expr S) → iProp + := logrel_expr (logrel_val τ). + + #[export] Instance obs_ref_ne {S} : + NonExpansive2 (@obs_ref S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_expr_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V → NonExpansive2 (logrel_expr V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_nat_ne {S} : NonExpansive2 (@logrel_nat S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_val_ne {S} (τ : ty) : NonExpansive2 (@logrel_val S τ). + Proof. + induction τ; simpl; solve_proper. + Qed. + + #[export] Instance logrel_ectx_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V → NonExpansive2 (logrel_ectx V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_arr_ne {S} (V1 V2 : ITV → val S → iProp) : + NonExpansive2 V1 -> NonExpansive2 V2 → NonExpansive2 (logrel_arr V1 V2). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_cont_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V -> NonExpansive2 (logrel_cont V). + Proof. + solve_proper. + Qed. + + #[export] Instance obs_ref_proper {S} : + Proper ((≡) ==> (≡) ==> (≡)) (@obs_ref S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_expr_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_expr V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_nat_proper {S} : + Proper ((≡) ==> (≡) ==> (≡)) (@logrel_nat S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_val_proper {S} (τ : ty) : + Proper ((≡) ==> (≡) ==> (≡)) (@logrel_val S τ). + Proof. + induction τ; simpl; solve_proper. + Qed. + + #[export] Instance logrel_ectx_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_ectx V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_arr_proper {S} (V1 V2 : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V1 -> + Proper ((≡) ==> (≡) ==> (≡)) V2 → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_arr V1 V2). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_cont_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V -> + Proper ((≡) ==> (≡) ==> (≡)) (logrel_cont V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_val_persistent {S} (τ : ty) α v : + Persistent (@logrel_val S τ α v). + Proof. + revert α v. induction τ=> α v; simpl. + - unfold logrel_nat. apply _. + - unfold logrel_arr. apply _. + - unfold logrel_cont. apply _. + Qed. + + #[export] Instance logrel_ectx_persistent {S} V κ K : + Persistent (@logrel_ectx S V κ K). + Proof. + apply _. + Qed. + + Lemma logrel_of_val {S} τ αv (v : val S) : + logrel_val τ αv v -∗ logrel τ (IT_of_V αv) (Val v). + Proof. + iIntros "H1". iIntros (κ K) "HK". + iIntros (σ) "Hs". + by iApply ("HK" $! αv v with "[$H1] [$Hs]"). + Qed. + + Lemma logrel_head_step_pure_ectx {S} n K (e' e : expr S) α V : + (∀ σ K, head_step e σ e' σ K (n, 0)) → + ⊢ logrel_expr V α (fill K e') -∗ logrel_expr V α (fill K e). + Proof. + intros Hpure. + iIntros "H". + iIntros (κ' K') "#HK'". + iIntros (σ) "Hs". + iSpecialize ("H" with "HK'"). + iSpecialize ("H" with "Hs"). + iApply (wp_wand with "H"). + iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". + iExists ((Nat.add n m),m'),v,σ'. iFrame "H2 Hs". + iPureIntro. + eapply (prim_steps_app (n, 0) (m, m')); eauto. + eapply prim_step_steps. + rewrite !fill_comp. + eapply Ectx_step; last apply Hpure; done. + Qed. + + Lemma obs_ref_bind {S} (f : HOM) (K : ectx S) e α τ1 : + ⊢ logrel τ1 α e -∗ + logrel_ectx (logrel_val τ1) f K -∗ + obs_ref (`f α) (fill K e). + Proof. + iIntros "H1 #H2". + iIntros (σ) "Hs". + iApply (wp_wand with "[H1 H2 Hs] []"); first iApply ("H1" with "[H2] [$Hs]"). + - iIntros (βv v). iModIntro. + iIntros "#Hv". + by iApply "H2". + - iIntros (βv). + iIntros "?". + iModIntro. + iFrame. + Qed. + + Definition ssubst2_valid {S : Set} + (Γ : S -> ty) + (ss : @interp_scope F natO _ S) + (γ : S [⇒] Empty_set) : iProp := + (∀ x, □ logrel (Γ x) (ss x) (γ x))%I. + + Definition logrel_valid {S : Set} + (Γ : S -> ty) + (e : expr S) + (α : @interp_scope F natO _ S -n> IT) + (τ : ty) : iProp := + (□ ∀ (ss : @interp_scope F natO _ S) + (γ : S [⇒] Empty_set), + ssubst2_valid Γ ss γ → logrel τ (α ss) (bind γ e))%I. + + Lemma compat_var {S : Set} (Γ : S -> ty) (x : S) : + ⊢ logrel_valid Γ (Var x) (interp_var x) (Γ x). + Proof. + iModIntro. iIntros (ss γ) "Hss". iApply "Hss". + Qed. + + Lemma compat_recV {S : Set} (Γ : S -> ty) (e : expr (inc (inc S))) τ1 τ2 α : + ⊢ □ logrel_valid ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) e α τ2 -∗ + logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). + Proof. + iIntros "#H !> %env %γ #Henv". + set (f := (ir_unf rs α env)). + iAssert (interp_rec rs α env ≡ 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 v) "#Hw". + rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. + pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V αv))). + set (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) + ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)))%bind). + rewrite /logrel. + iSpecialize ("H" $! ss' γ'). + set (γ1 := ((γ ↑) ↑)%bind). + iApply (logrel_head_step_pure_ectx _ EmptyK _ + ((rec bind γ1 e)%syn v) + (Tick (later_car (Next f) (IT_of_V αv))) + (logrel_val τ2) with "[]"); last first. + + rewrite {2}/ss'. rewrite /f. + iIntros (κ K) "#HK". iIntros (σ) "Hs". + rewrite hom_tick. iApply wp_tick. iNext. + iApply "H"; eauto. + rewrite /ss' /γ'. + iIntros (x'); destruct x' as [| [| x']]; term_simpl; iModIntro. + * by iApply logrel_of_val. + * iRewrite "Hf". + iIntros (κ' K') "#HK'". + iApply "HK'". + simpl. + unfold logrel_arr. + _iExists (Next (ir_unf rs α env)). + iSplit; first done. + iModIntro. + iApply "IH". + * iApply "Henv". + + term_simpl. intros. subst γ1 γ'. + rewrite -!bind_bind_comp'. + apply BetaS. + Qed. + + Lemma compat_if {S : Set} (Γ : S -> ty) (e0 e1 e2 : expr S) α0 α1 α2 τ : + ⊢ logrel_valid Γ e0 α0 Tnat -∗ + logrel_valid Γ e1 α1 τ -∗ + logrel_valid Γ e2 α2 τ -∗ + logrel_valid Γ (If e0 e1 e2) (interp_if rs α0 α1 α2) τ. + Proof. + iIntros "#H0 #H1 #H2". + iModIntro. + iIntros (ss γ) "#Hss". + simpl. + pose (κ' := (IFSCtx_HOM (α1 ss) (α2 ss))). + assert ((IF (α0 ss) (α1 ss) (α2 ss)) = ((`κ') (α0 ss))) as -> by reflexivity. + term_simpl. + iIntros (κ K) "#HK". + assert ((`κ) ((IFSCtx (α1 ss) (α2 ss)) (α0 ss)) = ((`κ) ◎ (`κ')) (α0 ss)) + as -> by reflexivity. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (If (bind γ e0) (bind γ e1) (bind γ e2))%syn = + fill (ectx_compose K (IfK EmptyK (bind γ e1) (bind γ e2))) (bind γ e0)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (obs_ref_bind with "[H0] [H1 H2]"); first by iApply "H0". + iIntros (βv v). iModIntro. iIntros "#HV". + term_simpl. + unfold logrel_nat. + iDestruct "HV" as "(%n & #Hn & ->)". + iRewrite "Hn". + unfold IFSCtx. + destruct (decide (0 < n)) as [H|H]. + - rewrite -fill_comp. + simpl. + rewrite IF_True//. + iSpecialize ("H1" with "Hss"). + term_simpl. rewrite /logrel. + iPoseProof (logrel_head_step_pure_ectx _ EmptyK + (bind γ e1)%syn _ (α1 ss) (logrel_val τ) with "H1") + as "Hrel"; last iApply ("Hrel" $! κ K with "HK"). + intros σ K0. by apply IfTrueS. + - rewrite -fill_comp. + simpl. + unfold IFSCtx. + rewrite IF_False//; last lia. + iSpecialize ("H2" with "Hss"). + term_simpl. rewrite /logrel. + iPoseProof (logrel_head_step_pure_ectx _ EmptyK + (bind γ e2)%syn _ (α2 ss) (logrel_val τ) with "H2") + as "Hrel"; last iApply ("Hrel" $! κ K with "HK"). + intros σ K0. apply IfFalseS. lia. + Qed. + + Lemma compat_input {S} Γ : + ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. + Proof. + iModIntro. + iIntros (ss γ) "#Hss". + iIntros (κ K) "#HK". + unfold interp_input. + term_simpl. + iIntros (σ) "Hs". + destruct (update_input σ) as [n σ'] eqn:Hinp. + iApply (wp_input' with "Hs []"); first done. + iNext. iIntros "Hlc Hs". term_simpl. + iSpecialize ("HK" $! (RetV n) (LitV n) with "[]"); first by iExists n. + iSpecialize ("HK" $! σ' with "Hs"). + rewrite IT_of_V_Ret. + iApply (wp_wand with "[$HK] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + iModIntro. + destruct m as [m1 m2]. + iExists ((Nat.add 1 m1), (Nat.add 1 m2)), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (1, 1) (m1, m2)); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + by constructor. + Qed. + + Lemma compat_natop {S : Set} (Γ : S -> ty) e1 e2 α1 α2 op : + ⊢ logrel_valid Γ e1 α1 Tnat -∗ + logrel_valid Γ e2 α2 Tnat -∗ + logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. + Proof. + iIntros "#H1 #H2". iIntros (ss γ). iModIntro. iIntros "#Hss". + iSpecialize ("H1" with "Hss"). + iSpecialize ("H2" with "Hss"). + term_simpl. + iIntros (κ K) "#HK". + set (κ' := (NatOpRSCtx_HOM op α1 ss)). + assert ((NATOP (do_natop op) (α1 ss) (α2 ss)) = ((`κ') (α2 ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (NatOp op (bind γ e1) (bind γ e2))%syn = + fill (ectx_compose K (NatOpRK op (bind γ e1) EmptyK)) (bind γ e2)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (obs_ref_bind with "H2"). + iIntros (βv v). iModIntro. iIntros "(%n2 & #HV & ->)". + term_simpl. clear κ' sss. + rewrite -fill_comp. simpl. + pose (κ' := (NatOpLSCtx_HOM op (IT_of_V βv) ss _)). + assert ((NATOP (do_natop op) (α1 ss) (IT_of_V βv)) = ((`κ') (α1 ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (NatOp op (bind γ e1) (LitV n2))%syn = + fill (ectx_compose K (NatOpLK op EmptyK (LitV n2))) (bind γ e1)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (obs_ref_bind with "H1"). + subst sss κ'. + term_simpl. + iIntros (t r). iModIntro. iIntros "(%n1 & #H & ->)". + simpl. + iAssert ((NATOP (do_natop op) (IT_of_V t) (IT_of_V βv)) ≡ Ret (do_natop op n1 n2))%I with "[HV H]" as "Hr". + { iRewrite "HV". simpl. + iRewrite "H". simpl. + iPureIntro. + by rewrite NATOP_Ret. + } + rewrite -fill_comp. simpl. + iApply (logrel_head_step_pure_ectx _ EmptyK (Val (LitV (do_natop op n1 n2))) with "[]"); + last done; last first. + + simpl. iRewrite "Hr". iApply (logrel_of_val Tnat (RetV (do_natop op n1 n2))). term_simpl. + iExists _. iSplit; eauto. + + intros. by constructor. + Qed. + + Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β e e' : + ⊢ logrel_valid Γ e α τ -∗ + logrel_valid Γ e' β (Tcont τ) -∗ + logrel_valid Γ (Throw e e') (interp_throw _ α β) τ'. + Proof. + iIntros "#H1 #H2". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + Opaque interp_throw. + term_simpl. + pose (κ' := ThrowLSCtx_HOM β ss). + assert ((interp_throw rs α β ss) = ((`κ') (α ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (Throw (bind γ e) (bind γ e'))%syn = + fill (ectx_compose K (ThrowLK EmptyK (bind γ e'))) (bind γ e)) + as -> by by rewrite -fill_comp. + iApply obs_ref_bind; first by iApply "H1". + iIntros (βv v). iModIntro. iIntros "#Hv". + Transparent interp_throw. + simpl. + rewrite get_val_ITV' -!fill_comp. + simpl. + pose (κ'' := ThrowRSCtx_HOM (IT_of_V βv) ss _). + assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) ≡ + ((`κ'') (β ss))) as ->. + { + subst κ''. simpl. by rewrite get_val_ITV. + } + rewrite HOM_ccompose. + pose (sss' := (HOM_compose κ κ'')). rewrite (HOM_compose_ccompose κ κ'' sss')//. + assert (fill K (Throw v (bind γ e'))%syn = + fill (ectx_compose K (ThrowRK v EmptyK)) (bind γ e')) + as -> by by rewrite -fill_comp. + iApply obs_ref_bind; first by iApply "H2". + iIntros (βv' v'). iModIntro. iIntros "#Hv'". + Transparent interp_throw. + simpl. + unfold logrel_cont. + iDestruct "Hv'" as "(%f & %F & HEQ & %H & #H)". + rewrite get_val_ITV. + simpl. + iRewrite "HEQ". + rewrite get_fun_fun. + simpl. + iIntros (σ) "Hs". + iApply (wp_throw' with "Hs []"). + iNext. iIntros "Hcl Hs". term_simpl. + rewrite later_map_Next. iApply wp_tick. iNext. + iSpecialize ("H" $! βv v with "[]"); first done. + iSpecialize ("H" $! σ with "Hs"). + iApply (wp_wand with "[$H] []"). + iIntros (w) "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 2 m), m'), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (2, 0) (m, m')); eauto. + term_simpl. + eapply prim_step_steps. + eapply Throw_step; last done. + rewrite H. by rewrite -!fill_comp. + Qed. + + + Lemma compat_callcc {S : Set} (Γ : S -> ty) τ α e : + ⊢ logrel_valid (Γ ▹ Tcont τ) e α τ -∗ + logrel_valid Γ (Callcc e) (interp_callcc _ α) τ. + Proof. + iIntros "#H". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + unfold interp_callcc. + Opaque extend_scope. + term_simpl. + iIntros (σ) "Hs". + + iApply (wp_callcc with "Hs []"). + iNext. iIntros "Hcl Hs". term_simpl. + + pose (ff := (λit x : IT, Tick ((`κ) x))). + match goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ extend_scope ss )?f] => set (fff := f) + end. + assert (ff ≡ fff) as <-. + { + subst ff fff. do 1 f_equiv. + epose proof (contractive_proper Next). + rewrite H; first reflexivity. + rewrite ofe_mor_ext. intro. simpl. + by rewrite later_map_Next. + } + pose (ss' := (extend_scope ss ff)). + pose (γ' := ((mk_subst (Val (ContV K)%syn)) ∘ (γ ↑)%bind)%bind : inc S [⇒] ∅). + iSpecialize ("H" $! ss' γ' with "[HK]"). + { + iIntros (x). iModIntro. + destruct x as [| x]; term_simpl; last iApply "Hss". + Transparent extend_scope. + subst ss'; simpl. + pose proof (asval_fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))). + subst ff. destruct H as [f H]. + iIntros (t r) "#H". + simpl. rewrite -H. iApply "H". + unfold logrel_cont. + iExists κ, K. + iSplit; first done. + iSplit; first done. + iModIntro. + iApply "HK". + } + iSpecialize ("H" $! κ K with "HK"). + Opaque extend_scope. + term_simpl. + iSpecialize ("H" $! σ with "Hs"). + subst ss' γ'. + iApply (wp_wand with "[$H] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + rewrite -bind_bind_comp' in Hstep. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + term_simpl. + constructor. + Qed. + + Lemma compat_output {S} Γ (e: expr S) α : + ⊢ logrel_valid Γ e α Tnat -∗ + logrel_valid Γ (Output e) (interp_output rs α) Tnat. + Proof. + iIntros "#H". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + term_simpl. + pose (κ' := OutputSCtx_HOM ss). + replace (get_ret OUTPUT (α ss)) with ((`κ') (α ss)) by reflexivity. + replace ((`κ) ((`κ') (α ss))) with (((`κ) ◎ (`κ')) (α ss)) by reflexivity. + pose (sss := (HOM_compose κ κ')). + replace (`κ ◎ `κ') with (`sss) by reflexivity. + assert (fill K (Output (bind γ e))%syn = + fill (ectx_compose K (OutputK EmptyK)) (bind γ e)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply obs_ref_bind; first by iApply "H". + iIntros (βv v). iModIntro. iIntros "#Hv". + iDestruct "Hv" as (n) "[Hb ->]". + iRewrite "Hb". simpl. + iIntros (σ) "Hs". + rewrite get_ret_ret. + iApply (wp_output' with "Hs []"); first done. + iNext. iIntros "Hlc Hs". + iSpecialize ("HK" $! (RetV 0) (LitV 0) with "[]"); first by iExists 0. + iSpecialize ("HK" $! (update_output n σ) with "Hs"). + iApply (wp_wand with "[$HK] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H')". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H'". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + eapply prim_step_steps. + rewrite -fill_comp. + eapply Ectx_step; [reflexivity | reflexivity |]. + by constructor. + Qed. + + Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : + ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ + logrel_valid Γ e2 α2 τ1 -∗ + logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. + Proof. + iIntros "#H1 #H2". + iIntros (ss). + iModIntro. + iIntros (γ). + iIntros "#Hss". + iSpecialize ("H1" with "Hss"). + iSpecialize ("H2" with "Hss"). + unfold interp_app. + simpl. + assert ((bind γ (App e1 e2))%syn = (fill (AppRK (bind γ e1) EmptyK) (bind γ e2))) as ->. + { reflexivity. } + pose (κ' := (AppRSCtx_HOM α1 ss)). + assert ((α1 ss ⊙ (α2 ss)) = ((`κ') (α2 ss))) as ->. + { simpl; unfold AppRSCtx. reflexivity. } + iIntros (κ K) "#HK". + assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α2 ss)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + rewrite fill_comp. + iApply obs_ref_bind; first by iApply "H2". + subst sss κ'. + iIntros (βv v). iModIntro. iIntros "#HV". + unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. + rewrite -fill_comp. + simpl. + assert ((App (bind γ e1) v) = (fill (AppLK EmptyK v) (bind γ e1))) as ->. + { reflexivity. } + pose (κ'' := (AppLSCtx_HOM (IT_of_V βv) ss _)). + assert (((`κ) (α1 ss ⊙ (IT_of_V βv))) = (((`κ) ◎ (`κ'')) (α1 ss))) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ'')). + assert ((`κ ◎ `κ'') = (`sss)) as ->. + { reflexivity. } + rewrite fill_comp. + iApply obs_ref_bind; first by iApply "H1". + iIntros (βv' v'). iModIntro. iIntros "#HV'". + subst sss κ''. + rewrite -fill_comp. + simpl. + unfold logrel_arr. + iDestruct "HV'" as "(%f & #Hf & #HV')". + iRewrite "Hf". + iSpecialize ("HV'" $! βv v with "HV"). + iApply "HV'"; iApply "HK". + Qed. + + Lemma compat_nat {S : Set} (Γ : S -> ty) n : + ⊢ logrel_valid Γ (# n)%syn (interp_val rs (# n)%syn) ℕ%typ. + Proof. + iIntros (ss γ). iModIntro. iIntros "#Hss". + term_simpl. + iIntros (κ K) "#HK". + iSpecialize ("HK" $! (RetV n) (LitV n)). + rewrite IT_of_V_Ret. + iApply "HK". + simpl. + unfold logrel_nat. + iExists n; eauto. + Qed. + + Lemma fundamental {S : Set} (Γ : S -> ty) τ e : + typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ + with fundamental_val {S : Set} (Γ : S -> ty) τ v : + typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. + Proof. + - induction 1; simpl. + + by apply fundamental_val. + + rewrite -H. + by apply compat_var. + + iApply compat_app. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_natop. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_if. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + ++ iApply IHtyped3. + + iApply compat_input. + + iApply compat_output. + iApply IHtyped. + + iApply compat_throw. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_callcc. + iApply IHtyped. + - induction 1; simpl. + + iApply compat_nat. + + iApply compat_recV. by iApply fundamental. + Qed. + +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. +Definition rs : gReifiers 1 := gReifiers_cons reify_io gReifiers_nil. + +Require Import gitrees.gitree.greifiers. + +Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} + (α : IT (gReifiers_ops rs) natO) + (e : expr S) n σ σ' k : + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (⊢ logrel rs Tnat α e)%I) → + ssteps (gReifiers_sReifier rs) α (σ, ()) (Ret n) σ' k → + ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. +Proof. + intros Hlog Hst. + pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), + ∃ m σ', prim_steps e σ (Val $ κ βv) σ' m). + cut (ϕ (RetV n)). + { + destruct 1 as ( m' & σ2 & Hm). + exists m', σ2. revert Hm. by rewrite κ_Ret. + } + eapply (wp_adequacy 0); eauto. + intros Hinv1 Hst1. + pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), + ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) + ∗ ⌜∃ m σ', prim_steps e σ (Val $ 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 σ) with "[Hs]" as "Hs". + { + unfold has_substate, has_full_state. + assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ())) ≡ + (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ))) + as -> ; last done. + intros 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" $! HOM_id EmptyK with "[]"). + { + iIntros (βv v); iModIntro. iIntros "Hv". iIntros (σ'') "HS". + iApply wp_val. + iModIntro. + iExists (0, 0), v, σ''. + iSplit; first iPureIntro. + - apply prim_steps_zero. + - by iFrame. + } + simpl. + iSpecialize ("Hlog" $! σ with "Hs"). + iApply (wp_wand with"Hlog"). + iIntros ( βv). iIntros "H". + iDestruct "H" as (m' v σ1' Hsts) "[Hi Hsts]". + unfold Φ. iDestruct "Hi" as (l) "[Hβ %]". simplify_eq/=. + iExists l. iModIntro. iSplit; eauto. + iExists l. iSplit; eauto. +Qed. + +Program Definition ı_scope : @interp_scope (gReifiers_ops rs) natO _ Empty_set := λne (x : ∅), match x with end. + +Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : + typed □ e Tnat → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → + ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. +Proof. + intros Hty Hst. + pose (Σ:=#[invΣ;stateΣ rs natO]). + eapply (logrel_nat_adequacy Σ (interp_expr rs e ı_scope)); last eassumption. + intros ? ?. + iPoseProof (fundamental rs) as "H". + { apply Hty. } + unfold logrel_valid. + unshelve iSpecialize ("H" $! ı_scope _ with "[]"). + { apply ı%bind. } + { iIntros (x); destruct x. } + rewrite ebind_id; first last. + { intros ?; reflexivity. } + iApply "H". +Qed. From d2148b4125b3376105521edc3bdaf2cfafaf45b7 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 5 Jan 2024 17:48:45 +0100 Subject: [PATCH 072/114] work re: contexts as stacks --- theories/input_lang_delim/lang.v | 238 ++++++++++++++++++++----------- 1 file changed, 155 insertions(+), 83 deletions(-) diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 33216a4..58bd638 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -6,7 +6,10 @@ Import ListNotations. Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. -Inductive nat_op := Add | Sub | Mult. +Require Import FunctionalExtensionality. + + +Variant nat_op := Add | Sub | Mult. Inductive expr {X : Set} := (* Values *) @@ -24,20 +27,25 @@ Inductive expr {X : Set} := | Reset (e : expr) : expr with val {X : Set} := | LitV (n : nat) : val -| RecV (e : @expr (inc (inc X))) : val -| ContV (K : ectx) : val -with ectx {X : Set} := -| EmptyK : ectx -| OutputK (K : ectx) : ectx -| IfK (K : ectx) (e₁ : expr) (e₂ : expr) : ectx -| AppLK (K : ectx) (v : val) : ectx -| AppRK (e : expr) (K : ectx) : ectx -| NatOpRK (op : nat_op) (e : expr) (K : ectx) : ectx -| NatOpLK (op : nat_op) (K : ectx) (v : val) : ectx -| ResetK (K : ectx) : ectx. +| RecV (e : @expr (inc (inc X))) : val. + +Variant ectx_el {X : Set} := + | OutputK : ectx_el + | IfCondK (e1 : @expr X) (e2 : @expr X) : ectx_el + | IfTrueK (b : @expr X) (e2 : @expr X) : ectx_el + | IfFalseK (b : @expr X) (e1 : @expr X) : ectx_el + | AppLK (er : @expr X) : ectx_el (* ◻ er *) + | AppRK (el : @expr X) : ectx_el (* el ◻ *) + | NatOpLK (op : nat_op) (er : @expr X) : ectx_el (* ◻ + er *) + | NatOpRK (op : nat_op) (el : @expr X) : ectx_el (* el + square *) + | ResetK : ectx_el. + + +Definition ectx {X : Set} := list (@ectx_el X). Arguments val X%bind : clear implicits. Arguments expr X%bind : clear implicits. +Arguments ectx_el X%bind : clear implicits. Arguments ectx X%bind : clear implicits. Local Open Scope bind_scope. @@ -54,25 +62,30 @@ Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := | Shift e => Shift (emap (f ↑) e) | Reset e => Reset (emap f e) end -with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := - match v with - | LitV n => LitV n - | RecV e => RecV (emap ((f ↑) ↑) e) - | ContV K => ContV (kmap f K) - end -with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := - match K with - | EmptyK => EmptyK - | OutputK K => OutputK (kmap f K) - | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) - | AppLK K v => AppLK (kmap f K) (vmap f v) - | AppRK e K => AppRK (emap f e) (kmap f K) - | NatOpRK op e K => NatOpRK op (emap f e) (kmap f K) - | NatOpLK op K v => NatOpLK op (kmap f K) (vmap f v) - | ResetK K => ResetK (kmap f K) - end. +with +vmap {A B : Set} (f : A [→] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (emap ((f ↑) ↑) e) +(* | ContV K => ContV (kmap f K) *) + end. + #[export] Instance FMap_expr : FunctorCore expr := @emap. #[export] Instance FMap_val : FunctorCore val := @vmap. + +Definition kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := + map (fun x => match x with + | OutputK => OutputK + | IfCondK e1 e2 => IfCondK (fmap f e1) (fmap f e2) + | IfTrueK b e2 => IfTrueK (fmap f b) (fmap f e2) + | IfFalseK b e1 => IfFalseK (fmap f b) (fmap f e1) + | AppLK er => AppLK (fmap f er) + | AppRK el => AppRK (fmap f el) + | NatOpLK op er => NatOpLK op (fmap f er) + | NatOpRK op el => NatOpRK op (fmap f el) + | ResetK => ResetK + end) K. + #[export] Instance FMap_ectx : FunctorCore ectx := @kmap. #[export] Instance SPC_expr : SetPureCore expr := @Var. @@ -89,26 +102,42 @@ Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := | Shift e => Shift (ebind (f ↑) e) | Reset e => Reset (ebind f e) end -with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := - match v with - | LitV n => LitV n - | RecV e => RecV (ebind ((f ↑) ↑) e) - | ContV K => ContV (kbind f K) - end -with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := - match K with - | EmptyK => EmptyK - | OutputK K => OutputK (kbind f K) - | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) - | AppLK K v => AppLK (kbind f K) (vbind f v) - | AppRK e K => AppRK (ebind f e) (kbind f K) - | NatOpRK op e K => NatOpRK op (ebind f e) (kbind f K) - | NatOpLK op K v => NatOpLK op (kbind f K) (vbind f v) - | ResetK K => ResetK (kbind f K) - end. +with +vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (ebind ((f ↑) ↑) e) + (* | ContV K => ContV (kbind f K) *) + end. #[export] Instance BindCore_expr : BindCore expr := @ebind. #[export] Instance BindCore_val : BindCore val := @vbind. + +Definition kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := + map (fun x => match x with + | OutputK => OutputK + | IfCondK e1 e2 => IfCondK (bind f e1) (bind f e2) + | IfTrueK b e2 => IfTrueK (bind f b) (bind f e2) + | IfFalseK b e1 => IfFalseK (bind f b) (bind f e1) + | AppLK er => AppLK (bind f er) + | AppRK el => AppRK (bind f el) + | NatOpLK op er => NatOpLK op (bind f er) + | NatOpRK op el => NatOpRK op (bind f el) + | ResetK => ResetK + end) K. + +(* with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := *) +(* match K with *) +(* | EmptyK => EmptyK *) +(* | OutputK K => OutputK (kbind f K) *) +(* | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) *) +(* | AppLK K v => AppLK (kbind f K) (vbind f v) *) +(* | AppRK e K => AppRK (ebind f e) (kbind f K) *) +(* | NatOpRK op e K => NatOpRK op (ebind f e) (kbind f K) *) +(* | NatOpLK op K v => NatOpLK op (kbind f K) (vbind f v) *) +(* | ResetK K => ResetK (kbind f K) *) +(* end. *) + #[export] Instance BindCore_ectx : BindCore ectx := @kbind. #[export] Instance IP_typ : SetPure expr. @@ -117,26 +146,42 @@ Proof. Qed. Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v -with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e -with kmap_id X (δ : X [→] X) (e : ectx X) : δ ≡ ı → fmap δ e = e. +with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e. +(* with kmap_id X (δ : X [→] X) (e : ectx X) : δ ≡ ı → fmap δ e = e. *) Proof. - auto_map_id. - auto_map_id. - - auto_map_id. Qed. +Definition kmap_id X (δ : X [→] X) (k : ectx X) : δ ≡ ı -> fmap δ k = k. +Proof. + rewrite /fmap /FMap_ectx /kmap => H. + rewrite <-List.map_id. do 2 f_equal. + extensionality x. case: x => // >; rewrite !emap_id//. +Qed. + + Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : f ∘ g ≡ h → fmap f (fmap g v) = fmap h v with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : - f ∘ g ≡ h → fmap f (fmap g e) = fmap h e -with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : ectx A) : f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. Proof. - auto_map_comp. - auto_map_comp. - - auto_map_comp. Qed. + +Definition kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : ectx A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. +Proof. + rewrite /fmap /FMap_ectx => H. + rewrite /kmap map_map. do 2 f_equal. + extensionality x. + case : x => // >; rewrite !(emap_comp _ _ _ f g h)//. +Qed. + + + #[export] Instance Functor_val : Functor val. Proof. split; [exact vmap_id | exact vmap_comp]. @@ -153,8 +198,6 @@ Qed. Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : f ̂ ≡ g → fmap f v = bind g v with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : - f ̂ ≡ g → fmap f e = bind g e -with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx A) : f ̂ ≡ g → fmap f e = bind g e. Proof. - auto_map_bind_pure. @@ -163,7 +206,6 @@ Proof. rewrite <-(EQ x). reflexivity. - auto_map_bind_pure. - - auto_map_bind_pure. Qed. #[export] Instance BindMapPure_val : BindMapPure val. @@ -174,6 +216,16 @@ Qed. Proof. split; intros; now apply emap_ebind_pure. Qed. + +Definition kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx A) : + f ̂ ≡ g → fmap f e = bind g e. +Proof. + rewrite /fmap /FMap_ectx /bind /BindCore_ectx /kmap /kbind => H. + do 2 f_equal. extensionality x. + case: x => [] > //; rewrite !(emap_ebind_pure _ _ _ g)//. +Qed. + + #[export] Instance BindMapPure_ectx : BindMapPure ectx. Proof. split; intros; now apply kmap_kbind_pure. @@ -184,9 +236,6 @@ Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [ g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : - g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) -with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) - (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : ectx A) : g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). Proof. - auto_map_bind_comm. @@ -194,9 +243,18 @@ Proof. erewrite lift_comm; [reflexivity |]. erewrite lift_comm; [reflexivity | assumption]. - auto_map_bind_comm. - - auto_map_bind_comm. Qed. +Definition kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : ectx A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). +Proof. + rewrite /fmap /FMap_ectx /bind /BindCore_ectx /kmap /kbind => H. + rewrite !map_map. do 2 f_equal. extensionality x. + case : x => // >; rewrite !(emap_ebind_comm _ B₁ _ _ f₁ _ g₁)//. +Qed. + + #[export] Instance BindMapComm_val : BindMapComm val. Proof. split; intros; now apply vmap_vbind_comm. @@ -213,22 +271,27 @@ Qed. Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : f ≡ ı → bind f v = v with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : - f ≡ ı → bind f e = e -with kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : f ≡ ı → bind f e = e. Proof. - auto_bind_id. rewrite ebind_id; [reflexivity |]. apply lift_id, lift_id; assumption. - auto_bind_id. - - auto_bind_id. Qed. +Definition kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : + f ≡ ı → bind f e = e. +Proof. + rewrite /bind /BindCore_ectx /kbind => H. + rewrite <-List.map_id. do 2 f_equal. + extensionality x. case : x => // >; rewrite !ebind_id//. +Qed. + + + Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : f ∘ g ≡ h → bind f (bind g v) = bind h v with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : - f ∘ g ≡ h → bind f (bind g e) = bind h e -with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx A) : f ∘ g ≡ h → bind f (bind g e) = bind h e. Proof. - auto_bind_comp. @@ -236,9 +299,17 @@ Proof. erewrite lift_comp; [reflexivity |]. erewrite lift_comp; [reflexivity | assumption]. - auto_bind_comp. - - auto_bind_comp. Qed. +Definition kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e. +Proof. + rewrite /bind/BindCore_ectx/kbind => H. + rewrite map_map. do 2 f_equal. extensionality x. + case : x => // >; rewrite !(ebind_comp _ _ _ _ _ h)//. +Qed. + + #[export] Instance Bind_val : Bind val. Proof. split; intros; [now apply vbind_id | now apply vbind_comp]. @@ -271,27 +342,28 @@ Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := | _,_ => None end. -Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := +Definition fill {X : Set} (K : ectx_el X) (e : expr X) : expr X := match K with - | EmptyK => e - | OutputK K => Output (fill K e) - | IfK K e₁ e₂ => If (fill K e) e₁ e₂ - | AppLK K v => App (fill K e) (Val v) - | AppRK e' K => App e' (fill K e) - | NatOpRK op e' K => NatOp op e' (fill K e) - | NatOpLK op K v => NatOp op (fill K e) (Val v) - | ResetK K => Reset (fill K e) + | OutputK => Output e + | IfCondK e1 e2 => If e e1 e2 + | IfTrueK b e2 => If b e e2 + | IfFalseK b e1 => If b e1 e + | AppLK er => App e er + | AppRK el => App el e + | NatOpLK op er => NatOp op e er + | NatOpRK op el => NatOp op el e + | ResetK => Reset e end. -Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) - : fmap f (fill K e) = fill (fmap f K) (fmap f e). -Proof. - revert f. - induction K as - [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH - | ??? IH | ?? IH ]; - intros f; term_simpl; first done; rewrite IH; reflexivity. -Qed. +(* Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) *) +(* : fmap f (fill K e) = fill (fmap f K) (fmap f e). *) +(* Proof. *) +(* revert f. *) +(* induction K as *) +(* [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH *) +(* | ??? IH | ?? IH ]; *) +(* intros f; term_simpl; first done; rewrite IH; reflexivity. *) +(* Qed. *) (*** Operational semantics *) From d386f86dec0860f7f3982a594d96993930207fcc Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Mon, 8 Jan 2024 17:55:18 +0100 Subject: [PATCH 073/114] some rules for head_step --- theories/input_lang_delim/lang.v | 147 +++++++++++++++++++++---------- 1 file changed, 101 insertions(+), 46 deletions(-) diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 58bd638..044ee20 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -29,6 +29,8 @@ with val {X : Set} := | LitV (n : nat) : val | RecV (e : @expr (inc (inc X))) : val. + + Variant ectx_el {X : Set} := | OutputK : ectx_el | IfCondK (e1 : @expr X) (e2 : @expr X) : ectx_el @@ -48,8 +50,12 @@ Arguments expr X%bind : clear implicits. Arguments ectx_el X%bind : clear implicits. Arguments ectx X%bind : clear implicits. + + + Local Open Scope bind_scope. + Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := match e with | Val v => Val (vmap f v) @@ -342,9 +348,10 @@ Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := | _,_ => None end. -Definition fill {X : Set} (K : ectx_el X) (e : expr X) : expr X := + +Definition ctx_el_to_expr {X : Set} (K : ectx_el X) (e : expr X) : expr X := match K with - | OutputK => Output e + | OutputK => Output $ e | IfCondK e1 e2 => If e e1 e2 | IfTrueK b e2 => If b e e2 | IfFalseK b e1 => If b e1 e @@ -352,9 +359,41 @@ Definition fill {X : Set} (K : ectx_el X) (e : expr X) : expr X := | AppRK el => App el e | NatOpLK op er => NatOp op e er | NatOpRK op el => NatOp op el e - | ResetK => Reset e + | ResetK => e + end. + +Definition fill {X : Set} (K : ectx X) (e : expr X) : expr X := + fold_left (fun e c => ctx_el_to_expr c e) K e. + + +Fixpoint trim_to_first_reset {X : Set} (K : ectx X) (acc : ectx X) : (ectx X * ectx X) := + match K with + | OutputK :: K => trim_to_first_reset K (OutputK :: acc) + | (IfCondK e1 e2) :: K => trim_to_first_reset K ((IfCondK e1 e2) :: acc) + | (IfTrueK b e2) :: K => trim_to_first_reset K ((IfTrueK b e2) :: acc) + | (IfFalseK b e1) :: K => trim_to_first_reset K ((IfFalseK b e1) :: acc) + | (AppLK er) :: K => trim_to_first_reset K ((AppLK er) :: acc) + | (AppRK el) :: K => trim_to_first_reset K ((AppRK el) :: acc) + | (NatOpLK op er) :: K => trim_to_first_reset K ((NatOpLK op er) :: acc) + | (NatOpRK op el) :: K => trim_to_first_reset K ((NatOpRK op el) :: acc) + | (ResetK) :: K => (acc, ResetK :: K) + | [] => (acc, []) end. +(* Separate continuation [K] on innermost [reset] *) +Definition shift_context {X : Set} (K : ectx X) : (ectx X * ectx X) := + let (Ki, Ko) := trim_to_first_reset K [] in + (List.rev Ki, Ko). + + +Definition LamV {S : Set} (e : expr (inc S)) : val S := + RecV (shift e). + +(* Only if no reset in K *) +Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := + LamV (fill (shift K) (Var VZ)). + + (* Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) *) (* : fmap f (fill K e) = fill (fmap f K) (fmap f e). *) (* Proof. *) @@ -383,58 +422,74 @@ Definition update_output (n:nat) (s : state) : state := {| inputs := s.(inputs); outputs := n::s.(outputs) |}. -(** [head_step e σ e' σ' K (n, m)] : step from [(e, σ)] to [(e', σ')] under context K +(** [head_step e σ K e' σ' K' (n, m)] : step from [(e, σ, K)] to [(e', σ', K')] in [n] ticks with [m] i/o accesses *) -Inductive head_step {S} : expr S → state → expr S → state → ectx S → nat * nat → Prop := -| BetaS e1 v2 σ K : - head_step (App (Val $ RecV e1) (Val v2)) σ - (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) - (Val (shift (Inc := inc) v2))) - (Val (RecV e1))) σ K (1,0) -| InputS σ n σ' K : - update_input σ = (n, σ') → - head_step Input σ (Val (LitV n)) σ' K (1, 1) -| OutputS σ n σ' K : - update_output n σ = σ' → - head_step (Output (Val (LitV n))) σ (Val (LitV 0)) σ' K (1, 1) -| NatOpS op v1 v2 v3 σ K : - nat_op_interp op v1 v2 = Some v3 → - head_step (NatOp op (Val v1) (Val v2)) σ - (Val v3) σ K (0, 0) -| IfTrueS n e1 e2 σ K : - n > 0 → - head_step (If (Val (LitV n)) e1 e2) σ - e1 σ K (0, 0) -| IfFalseS n e1 e2 σ K : - n = 0 → - head_step (If (Val (LitV n)) e1 e2) σ - e2 σ K (0, 0) -(* | ShiftS e σ K : *) -(* head_step (Shift e) σ (subst (Inc := inc) e (Val (ContV K))) σ K (1, 1) *) -| ResetValS v σ K: - head_step (Reset (Val v)) σ (Val v) σ K (1,0) -| ResetShiftS e σ K E: - head_step - (Reset (fill E (Shift e))) σ - (Reset (subst (Inc := inc) e (Val $ ContV $ ResetK E))) σ K (1,0). - -Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : - head_step e1 σ1 e2 σ2 K (n,m) → m = 0 ∨ m = 1. +Variant head_step {S} : expr S → state -> ectx S → + expr S → state → ectx S → + nat * nat → Prop := + | BetaS e1 v2 σ K : + head_step (App (Val $ RecV e1) (Val v2)) σ K + (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) + (Val (shift (Inc := inc) v2))) + (Val (RecV e1))) σ K (1,0) + | InputS σ n σ' K : + update_input σ = (n, σ') → + head_step Input σ K (Val (LitV n)) σ' K (1, 1) + | OutputS σ n σ' K : + update_output n σ = σ' → + head_step (Output (Val (LitV n))) σ K (Val (LitV 0)) σ' K (1, 1) + | NatOpS op v1 v2 v3 σ K : + nat_op_interp op v1 v2 = Some v3 → + head_step (NatOp op (Val v1) (Val v2)) σ K + (Val v3) σ K (0, 0) + | IfTrueS n e1 e2 σ K : + n > 0 → + head_step (If (Val (LitV n)) e1 e2) σ K + e1 σ K (0, 0) + | IfFalseS n e1 e2 σ K : + n = 0 → + head_step (If (Val (LitV n)) e1 e2) σ K + e2 σ K (0, 0) + | ValueS v σ K C: + head_step (Val v) σ (C::K) (ctx_el_to_expr C (Val v)) σ K (0, 0) + + | ShiftS e σ K Ki Ko f: + ((Ki, Ko) = shift_context K) -> + f = cont_to_rec Ki -> + head_step (Shift e) σ K (subst (Inc := inc) e (Val f)) σ Ko (1, 0). + + (* | ResetShiftS e σ K E: *) + (* head_step *) + (* (Reset (fill E (Shift e))) σ *) + (* (Reset (subst (Inc := inc) e (Val $ ContV $ ResetK E))) σ K (1,0). *) + +Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : + head_step e1 σ1 K e2 σ2 K' (n,m) → m = 0 ∨ m = 1. Proof. inversion 1; eauto. Qed. -Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K n m : - head_step e1 σ1 e2 σ2 K (n,m) → n = 0 ∨ n = 1. +Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : + head_step e1 σ1 K e2 σ2 K' (n,m) → n = 0 ∨ n = 1. Proof. inversion 1; eauto. Qed. -Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K n : - head_step e1 σ1 e2 σ2 K (n,0) → σ1 = σ2. +Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K K' n : + head_step e1 σ1 K e2 σ2 K' (n,0) → σ1 = σ2. Proof. inversion 1; eauto. Qed. (** Carbonara from heap lang *) -Global Instance fill_item_inj {S} (Ki : ectx S) : Inj (=) (=) (fill Ki). + +Global Instance ctx_el_to_expr_inj {S} (C : ectx_el S) : Inj (=) (=) (ctx_el_to_expr C). +Proof. case: C => [] >; simpl in*; congruence. Qed. + +Global Instance fill_inj {S} (Ki : ectx S) : Inj (=) (=) (fill Ki). Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. -Lemma fill_item_val {S} Ki (e : expr S) : +Lemma ctx_el_to_expr_val {S} C (e : expr S) : + is_Some (to_val (ctx_el_to_expr C e)) → is_Some (to_val e). +Proof. case : C => [] > H; simpl in H; try by apply is_Some_None in H. done. Qed. + +Lemma fill_val {S} Ki (e : expr S) : is_Some (to_val (fill Ki e)) → is_Some (to_val e). -Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed. +Proof. elim: Ki e; simpl in *; first done. intros. + apply (ctx_el_to_expr_val a e). apply H. apply H0. +Qed. Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K m : head_step e1 σ1 e2 σ2 K m → to_val e1 = None. Proof. destruct 1; naive_solver. Qed. From 4bae225629e7b5fdb016e69dd0a43ca1172b84ff Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 9 Jan 2024 13:32:38 +0100 Subject: [PATCH 074/114] head_step maybe complete? incomplete computable head_step --- theories/input_lang_delim/lang.v | 162 +++++++++++++++---------------- 1 file changed, 81 insertions(+), 81 deletions(-) diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 044ee20..ff0b3e6 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -329,6 +329,12 @@ Proof. split; intros; [now apply kbind_id | now apply kbind_comp]. Qed. + + +Definition LamV {S : Set} (e : expr (inc S)) : val S := + RecV (shift e). + + Definition to_val {S} (e : expr S) : option (val S) := match e with | Val v => Some v @@ -386,9 +392,6 @@ Definition shift_context {X : Set} (K : ectx X) : (ectx X * ectx X) := (List.rev Ki, Ko). -Definition LamV {S : Set} (e : expr (inc S)) : val S := - RecV (shift e). - (* Only if no reset in K *) Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := LamV (fill (shift K) (Var VZ)). @@ -491,37 +494,22 @@ Proof. elim: Ki e; simpl in *; first done. intros. apply (ctx_el_to_expr_val a e). apply H. apply H0. Qed. -Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K m : head_step e1 σ1 e2 σ2 K m → to_val e1 = None. -Proof. destruct 1; naive_solver. Qed. +(* CHECK *) +(* Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K m : *) +(* head_step e1 σ1 e2 σ2 K m → to_val e1 = None. *) +(* Proof. destruct 1; naive_solver. Qed. *) + -Fixpoint ectx_compose {S} (K1 K2 : ectx S) : ectx S - := match K1 with - | EmptyK => K2 - | OutputK K => OutputK (ectx_compose K K2) - | IfK K e₁ e₂ => IfK (ectx_compose K K2) e₁ e₂ - | AppLK K v => AppLK (ectx_compose K K2) v - | AppRK e K => AppRK e (ectx_compose K K2) - | NatOpRK op e K => NatOpRK op e (ectx_compose K K2) - | NatOpLK op K v => NatOpLK op (ectx_compose K K2) v - | ResetK K => ResetK (ectx_compose K K2) - end. +(* K1 ∘ K2 *) +Definition ectx_compose {S} (K1 K2 : ectx S) : ectx S := + K2 ++ K1. Lemma fill_app {S} (K1 K2 : ectx S) e : fill (ectx_compose K1 K2) e = fill K1 (fill K2 e). Proof. - revert K2. - revert e. - induction K1 as - [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH | ??? IH | ?? IH ]; - simpl; first done; intros e' K2; rewrite IH; reflexivity. + elim: K2 K1 e =>>; eauto. + intros H K1 e. simpl. by rewrite H. Qed. -Lemma fill_val : ∀ {S} K (e : expr S), is_Some (to_val (fill K e)) → is_Some (to_val e). -Proof. - intros S K. - induction K as [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH | ??? IH | ?? IH ] - => e' //=; - inversion 1 as [? HH]; inversion HH. -Qed. Lemma fill_not_val : ∀ {S} K (e : expr S), to_val e = None → to_val (fill K e) = None. Proof. @@ -529,34 +517,28 @@ Proof. eauto using fill_val. Qed. -Lemma fill_empty {S} (e : expr S) : fill EmptyK e = e. -Proof. reflexivity. Qed. + Lemma fill_comp {S} K1 K2 (e : expr S) : fill K2 (fill K1 e) = fill (ectx_compose K2 K1) e. Proof. by rewrite fill_app. Qed. -Global Instance fill_inj {S} (K : ectx S) : Inj (=) (=) (fill K). -Proof. - induction K as [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH | ??? IH | ?? IH ]; - rewrite /Inj; naive_solver. -Qed. + (* FIXME maybe *) Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) (e2 : expr S) (σ2 : state) (n : nat * nat), Prop := -| Ectx_step e1 σ1 e2 σ2 n (K : ectx S) e1' e2' : - e1 = fill K e1' → e2 = fill K e2' → - head_step e1' σ1 e2' σ2 K n → prim_step e1 σ1 e2 σ2 n -| App_cont_step e1 σ e2 (K : ectx S) v K' : - e1 = (fill K (App (Val $ ContV K') (Val v))) -> - e2 = (fill K' (Val v)) -> - prim_step e1 σ e2 σ (2, 0). +| Ectx_step e1 σ1 e2 σ2 n (K1 K2 : ectx S) e1' e2' : + e1 = fill K1 e1' → e2 = fill K2 e2' → + head_step e1' σ1 K1 e2' σ2 K2 n → prim_step e1 σ1 e2 σ2 n. +(* | App_cont_step e1 σ e2 (K : ectx S) v K' : *) +(* e1 = (fill K (App (Val $ ContV K') (Val v))) -> *) +(* e2 = (fill K' (Val v)) -> *) +(* prim_step e1 σ e2 σ (2, 0). *) (* CHECK *) Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. Proof. inversion 1; simplify_eq/=. - - by inversion H2. - - by inversion H. + by inversion H2. Qed. Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat → Prop := @@ -568,8 +550,8 @@ Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat prim_steps e1 σ1 e3 σ3 (plus n1 n2, plus m1 m2) . -Lemma Ectx_step' {S} (K : ectx S) e1 σ1 e2 σ2 efs : - head_step e1 σ1 e2 σ2 K efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs. +Lemma Ectx_step' {S} (K1 K2 : ectx S) e1 σ1 e2 σ2 efs : + head_step e1 σ1 K1 e2 σ2 K2 efs → prim_step (fill K1 e1) σ1 (fill K2 e2) σ2 efs. Proof. econstructor; eauto. Qed. Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : @@ -603,12 +585,8 @@ Proof. Qed. Lemma head_step_prim_step {S} (e1 e2 : expr S) σ1 σ2 nm : - head_step e1 σ1 e2 σ2 EmptyK nm -> prim_step e1 σ1 e2 σ2 nm. + head_step e1 σ1 [] e2 σ2 [] nm -> prim_step e1 σ1 e2 σ2 nm. Proof. - assert (e1 = fill EmptyK e1) as Heq1; first done. - rewrite ->Heq1 at 2. - assert (e2 = fill EmptyK e2) as Heq2; first done. - rewrite ->Heq2 at 2. apply Ectx_step'. Qed. @@ -646,9 +624,13 @@ Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := (* typed Γ e1 τ -> *) (* typed Γ e2 (Tcont τ) -> *) (* typed Γ (Throw e1 e2) τ' *) -| typed_Callcc e τ : +| typed_Shift e τ : 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) τ @@ -667,8 +649,8 @@ Delimit Scope syn_scope with syn. Coercion Val : val >-> expr. Coercion App : expr >-> Funclass. -Coercion AppLK : ectx >-> Funclass. -Coercion AppRK : expr >-> Funclass. +(* Coercion AppLK : expr >-> Funclass. *) +(* Coercion AppRK : expr >-> Funclass. *) Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. @@ -688,11 +670,11 @@ Global Instance OpNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSy }. Global Instance OpNotationLK {S : Set} : OpNotation (ectx S) (nat_op) (val S) (ectx S) := { - __op K op v := NatOpLK op K v + __op K op v := K ++ [NatOpLK op v] }. Global Instance OpNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : OpNotation (F S) (nat_op) (ectx S) (ectx S) := { - __op e op K := NatOpRK op (__asSynExpr e) K + __op e op K := K ++ [NatOpRK op (__asSynExpr e)] }. Class IfNotation (A B C D : Type) := { __if : A -> B -> C -> D }. @@ -701,8 +683,19 @@ Global Instance IfNotationExpr {S : Set} {F G H : Set -> Type} `{AsSynExpr F, As __if e₁ e₂ e₃ := If (__asSynExpr e₁) (__asSynExpr e₂) (__asSynExpr e₃) }. -Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : IfNotation (ectx S) (F S) (G S) (ectx S) := { - __if K e₂ e₃ := IfK K (__asSynExpr e₂) (__asSynExpr e₃) +Global Instance IfNotationCondK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : + IfNotation (ectx S) (F S) (G S) (ectx S) := { + __if K e₂ e₃ := K ++ [IfCondK (__asSynExpr e₂) (__asSynExpr e₃)] + }. + +Global Instance IfNotationTrueK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : + IfNotation (F S) (ectx S) (G S) (ectx S) := { + __if b K e₃ := K ++ [IfCondK (__asSynExpr b) (__asSynExpr e₃)] + }. + +Global Instance IfNotationFalseK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : + IfNotation (F S) (G S) (ectx S) (ectx S) := { + __if b e2 K := K ++ [IfCondK (__asSynExpr b) (__asSynExpr e2)] }. Class OutputNotation (A B : Type) := { __output : A -> B }. @@ -712,7 +705,7 @@ Global Instance OutputNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : }. Global Instance OutputNotationK {S : Set} : OutputNotation (ectx S) (ectx S) := { - __output K := OutputK K + __output K := K ++ [OutputK] }. Class ResetNotation (A B : Type) := { __reset : A -> B }. @@ -721,7 +714,7 @@ 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 (ectx S) (ectx S) := - { __reset K := ResetK K }. + { __reset K := K ++ [ResetK] }. (* Class ThrowNotation (A B C : Type) := { __throw : A -> B -> C }. *) @@ -743,12 +736,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 (ectx S) (val S) (ectx S) := { - __app K v := AppLK K v +Global Instance AppNotationLK {S : Set} : AppNotation (ectx S) (expr S) (ectx S) := { + __app K e := K ++ [AppLK e] }. Global Instance AppNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (ectx S) (ectx S) := { - __app e K := AppRK (__asSynExpr e) K + __app e K := K ++ [AppRK (__asSynExpr e)] }. Notation of_val := Val (only parsing). @@ -765,15 +758,13 @@ 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 "'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 "□" := (EmptyK) : syn_scope. *) Notation "K '⟪' e '⟫'" := (fill K%syn e%syn) (at level 60) : syn_scope. -Definition LamV {S : Set} (e : expr (inc S)) : val S := - RecV (shift e). -Notation "'λ' . e" := (LamV 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). @@ -815,6 +806,7 @@ Module SynExamples. 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 ($ 0)). Example test4 : expr ∅ := ((# 1) + (# 0)). Example test5 : val ∅ := (rec (if ($ 1) then # 1 else (($ 0) ⋆ (($ 1) - (# 1))))). @@ -826,34 +818,42 @@ Module SynExamples. Example test8 : Prop := (empty_env ⊢ (# 0) : ℕ). End SynExamples. -Definition compute_head_step {S} (e : expr S) (σ : state) (K : ectx S) : option (expr S * state * (nat * nat)) := +Definition compute_head_step {S} + (e : expr S) (σ : state) (K : ectx S) : + option (expr S * state * ectx 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))), σ, (1,0)) + | (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)), σ', (1, 1)) + Some ((Val (LitV n)), σ', K, (1, 1)) | Output (Val (LitV n)) => let σ' := update_output n σ in - Some ((Val (LitV 0)), σ', (1, 1)) + 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), σ, (0, 0))) None res + 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, σ, (0, 0)) + then Some (e1, σ, K, (0, 0)) else if (decide (n = 0)) - then Some (e2, σ, (0, 0)) + then Some (e2, σ, K, (0, 0)) else None - (* | (Shift e) => Some ((subst (Inc := inc) e (Val (ContV K))), σ, (1, 1)) *) - | (Reset (Val v)) => Some (Val v, σ, (1, 0)) + | (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, 0)) + (* | (Reset (Val v)) => Some (Val v, σ, (1, 0)) *) (* | (Reset (fill E (Shift e))) => None *) | _ => None end. (* CHECK *) Lemma head_step_reflect {S : Set} (e : expr S) (σ : state) (K : ectx S) - : option_reflect (fun '(e', σ', nm) => head_step e σ e' σ' K nm) + : option_reflect (fun '(e', σ', K', nm) => head_step e σ K e' σ' K' nm) True (compute_head_step e σ K). Proof. @@ -895,7 +895,7 @@ Proof. destruct v; try (by constructor). destruct (update_output n σ) eqn:Heqn. by do 2 constructor. - - simpl. - destruct e; try (by constructor). - do 2 constructor. + - simpl. + destruct (shift_context K) as [Ki Ko] eqn:HK. + constructor. apply ShiftS with Ki =>//=. Qed. From 9b05924d093c3cbadfa89427da3dd30685e08b6d Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 9 Jan 2024 17:01:36 +0100 Subject: [PATCH 075/114] Some work on interpretation --- theories/input_lang_delim/interp.v | 401 ++++++++++++++++------------- 1 file changed, 224 insertions(+), 177 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index b1ec2d8..0f74cdb 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -1,6 +1,6 @@ (* From Equations Require Import Equations. *) From gitrees Require Import gitree. -From gitrees.input_lang_callcc Require Import lang. +From gitrees.input_lang_delim Require Import lang. Require Import gitrees.lang_generic_sem. Require Import Binding.Lib. @@ -71,26 +71,35 @@ Definition reify_shift X `{Cofe X} : ((laterO X -n> laterO X) -n> laterO X) * Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; auto. Qed. -(* Definition reify_reset X `{Cofe X} : *) -(* (laterO X * stateO * (laterO X -n> laterO X)) → *) -(* option (laterO X * stateO) := *) -(* λ '(e, σ, k), Some (σ, k (laterO_map (get_val idfun) ( e))). *) -(* CHECK: get_val def on IT... (also maybe not what we want idk) *) +(* CHECK *) +Definition reify_reset X `{Cofe X} : + (laterO X * stateO * (laterO X -n> laterO X)) → + option (laterO X * stateO) := + λ '(e, σ, k), Some (k e, σ). +(* and add the [get_val] in interp. BUT: doesn't it defeat the whole purpose of + having reset as an effect? *) +#[export] Instance reify_reset_ne X `{Cofe X} : + NonExpansive (reify_reset X : + prodO (prodO (laterO X) stateO) (laterO X -n> laterO X) → + optionO (prodO (laterO X) stateO)). +Proof. intros ?[[]][[]][[]]. simpl in *. by repeat f_equiv. Qed. -Context {E : opsInterp} {A} `{!Cofe A}. -Context {subEff0 : subEff ioE E}. -Context {subOfe0 : SubOfe natO A}. -Notation IT := (IT E A). -Notation ITV := (ITV E A). -Definition reify_reset : (laterO IT * stateO * (laterO IT -n> laterO IT)) → - option (laterO IT * stateO) := - λ '(e, σ, k), Some (k $ laterO_map (get_val idfun) e, σ). -#[export] Instance reify_reset_ne : - NonExpansive (reify_reset : - prodO (prodO (laterO IT) stateO) (laterO IT -n> laterO IT) → - optionO (prodO (laterO IT) stateO)). -Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; done. Qed. +(* Context {E : opsInterp} {A} `{!Cofe A}. *) +(* Context {subEff0 : subEff ioE E}. *) +(* Context {subOfe0 : SubOfe natO A}. *) +(* Notation IT := (IT E A). *) +(* Notation ITV := (ITV E A). *) + +(* Definition reify_reset : (laterO IT * stateO * (laterO IT -n> laterO IT)) → *) +(* option (laterO IT * stateO) := *) +(* λ '(e, σ, k), Some (k $ laterO_map (get_val idfun) e, σ). *) +(* #[export] Instance reify_reset_ne : *) +(* NonExpansive (reify_reset : *) +(* prodO (prodO (laterO IT) stateO) (laterO IT -n> laterO IT) → *) +(* optionO (prodO (laterO IT) stateO)). *) +(* Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; done. Qed. *) + Canonical Structure reify_io : sReifier. @@ -102,10 +111,16 @@ Proof. destruct op as [ | [ | [ | [| []]]]]; simpl. - simple refine (OfeMor (reify_input X)). - simple refine (OfeMor (reify_output X)). - - simple refine (OfeMor (reify_callcc X)). - - simple refine (OfeMor (reify_throw X)). + - simple refine (OfeMor (reify_shift X)). + - simple refine (OfeMor (reify_reset X)). Defined. + +Notation op_input := (inl ()). +Notation op_output := (inr (inl ())). +Notation op_shift := (inr (inr (inl ()))). +Notation op_reset := (inr (inr (inr (inl ())))). + Section constructors. Context {E : opsInterp} {A} `{!Cofe A}. Context {subEff0 : subEff ioE E}. @@ -114,14 +129,14 @@ Section constructors. Notation ITV := (ITV E A). Program Definition INPUT : (nat -n> IT) -n> IT := - λne k, Vis (E:=E) (subEff_opid (inl ())) - (subEff_ins (F:=ioE) (op:=(inl ())) ()) - (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). + λne k, Vis (E:=E) (subEff_opid op_input) + (subEff_ins (F:=ioE) (op:=op_input) ()) + (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=op_input))^-1). Solve Obligations with solve_proper. Program Definition OUTPUT_ : nat -n> IT -n> IT := - λne m α, Vis (E:=E) (subEff_opid (inr (inl ()))) - (subEff_ins (F:=ioE) (op:=(inr (inl ()))) m) + λne m α, Vis (E:=E) (subEff_opid op_output) + (subEff_ins (F:=ioE) (op:=op_output) m) (λne _, NextO α). Solve All Obligations with solve_proper_please. Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). @@ -130,15 +145,21 @@ Section constructors. 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 (inr (inr (inl ())))) - (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) f) - (k ◎ (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1). + λne f k, Vis (E:=E) (subEff_opid op_shift) + (subEff_ins (F:=ioE) (op:=op_shift) f) + (k ◎ (subEff_outs (F:=ioE) (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. + Program Definition RESET : laterO IT -n> IT := + λne e, Vis (E:=E) (subEff_opid op_reset) + (subEff_ins (F := ioE) (op := op_reset) e) + (subEff_outs (F := ioE) (op := op_reset)^-1). + Solve All Obligations with solve_proper. + Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). Proof. @@ -155,10 +176,10 @@ Section constructors. done. Qed. - Lemma hom_CALLCC_ k e f `{!IT_hom f} : - f (CALLCC_ e k) ≡ CALLCC_ e (laterO_map (OfeMor f) ◎ k). + Lemma hom_SHIFT_ k e f `{!IT_hom f} : + f (SHIFT_ e k) ≡ SHIFT_ e (laterO_map (OfeMor f) ◎ k). Proof. - unfold CALLCC_. + unfold SHIFT_. rewrite hom_vis/=. f_equiv. by intro. Qed. @@ -244,32 +265,33 @@ Section weakestpre. iApply wp_val. iApply ("Ha" with "Hcl Hs"). Qed. - Lemma wp_throw' (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) - (κ : IT -n> IT) `{!IT_hom κ} Φ s : - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} (later_car f) x @ s {{ Φ }}) -∗ - WP@{rs} κ (THROW x f) @ s {{ Φ }}. - Proof. - iIntros "Hs Ha". rewrite /THROW. simpl. - rewrite hom_vis. - iApply (wp_subreify with "Hs"); simpl; done. - Qed. + (* Lemma wp_throw' (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) *) + (* (κ : IT -n> IT) `{!IT_hom κ} Φ s : *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} (later_car f) x @ s {{ Φ }}) -∗ *) + (* WP@{rs} κ (THROW x f) @ s {{ Φ }}. *) + (* Proof. *) + (* iIntros "Hs Ha". rewrite /THROW. simpl. *) + (* rewrite hom_vis. *) + (* iApply (wp_subreify with "Hs"); simpl; done. *) + (* Qed. *) - Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ - WP@{rs} (THROW x f) @ s {{ Φ }}. - Proof. - iApply (wp_throw' _ _ _ idfun). - Qed. + (* Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : *) + (* has_substate σ -∗ *) + (* ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ *) + (* WP@{rs} (THROW x f) @ s {{ Φ }}. *) + (* Proof. *) + (* iApply (wp_throw' _ _ _ idfun). *) + (* Qed. *) - Lemma wp_callcc (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} Φ s : + Lemma wp_shift (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) + (k : IT -n> IT) {Hk : IT_hom k} Φ s : has_substate σ -∗ ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ - WP@{rs} (k (CALLCC f)) @ s {{ Φ }}. + WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. Proof. iIntros "Hs Ha". - unfold CALLCC. simpl. + unfold SHIFT. simpl. rewrite hom_vis. iApply (wp_subreify _ _ _ _ _ _ _ ((later_map k ((f (laterO_map k))))) with "Hs"). { @@ -316,9 +338,9 @@ Section interp. Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). Proof. solve_proper. Qed. - Program Definition interp_callcc {S} + Program Definition interp_shift {S} (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := - λne env, CALLCC (λne (f : laterO IT -n> laterO IT), + λne env, SHIFT (λne (f : laterO IT -n> laterO IT), (Next (e (@extend_scope F R _ _ env (Fun (Next (λne x, Tau (f (Next x))))))))). Next Obligation. @@ -341,25 +363,30 @@ Section interp. repeat f_equiv. Qed. - Program Definition interp_throw {A} (e : A -n> IT) (k : A -n> IT) - : A -n> IT := - λne env, get_val (λne x, get_fun (λne (f : laterO (IT -n> IT)), - THROW x f) (k env)) (e env). - Next Obligation. - solve_proper. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intro; simpl. - by repeat f_equiv. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv; last done. - intro; simpl. - by repeat f_equiv. - Qed. + Program Definition interp_reset {S} (e : S -n> IT) : S -n> IT := + λne env, get_val idfun (RESET (Next (e env))). + Solve All Obligations with solve_proper_please. + + (* Program Definition interp_throw {A} (e : A -n> IT) (k : A -n> IT) *) + (* : A -n> IT := *) + (* λne env, get_val (λne x, get_fun (λne (f : laterO (IT -n> IT)), *) + (* THROW x f) (k env)) (e env). *) + (* Next Obligation. *) + (* solve_proper. *) + (* Qed. *) + (* Next Obligation. *) + (* solve_proper_prepare. *) + (* repeat f_equiv. *) + (* intro; simpl. *) + (* by repeat f_equiv. *) + (* Qed. *) + (* Next Obligation. *) + (* solve_proper_prepare. *) + (* repeat f_equiv; last done. *) + (* intro; simpl. *) + (* by repeat f_equiv. *) + (* Qed. *) + 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). @@ -438,89 +465,125 @@ Section interp. Program Definition interp_nat (n : nat) {A} : A -n> IT := λne env, Ret n. - Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := - λne env, (Fun (Next (λne x, Tau (laterO_map (K env) (Next x))))). - Solve All Obligations with solve_proper_please. + (* Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := *) + (* λne env, (Fun (Next (λne x, Tau (laterO_map (K env) (Next x))))). *) + (* Solve All Obligations with solve_proper_please. *) - Program Definition interp_applk {A} - (K : A -n> (IT -n> IT)) - (q : A -n> IT) - : A -n> (IT -n> IT) := - λne env t, interp_app (λne env, K env t) q env. - Solve All Obligations with solve_proper. - Program Definition interp_apprk {A} - (q : A -n> IT) - (K : A -n> (IT -n> IT)) - : A -n> (IT -n> IT) := - λne env t, interp_app q (λne env, K env t) env. - Solve All Obligations with solve_proper. - Program Definition interp_natoprk {A} (op : nat_op) - (q : A -n> IT) - (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := - λne env t, interp_natop op q (λne env, K env t) env. - Solve All Obligations with solve_proper. - Program Definition interp_natoplk {A} (op : nat_op) - (K : A -n> (IT -n> IT)) - (q : A -n> IT) : A -n> (IT -n> IT) := - λne env t, interp_natop op (λne env, K env t) q env. - Solve All Obligations with solve_proper. + (* Program Definition interp_natoprk {A} (op : nat_op) *) + (* (q : A -n> IT) *) + (* (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := *) + (* λne env t, interp_natop op q (λne env, K env t) env. *) + (* Solve All Obligations with solve_proper. *) + + (* Program Definition interp_natoplk {A} (op : nat_op) *) + (* (K : A -n> (IT -n> IT)) *) + (* (q : A -n> IT) : A -n> (IT -n> IT) := *) + (* λne env t, interp_natop op (λne env, K env t) q env. *) + (* Solve All Obligations with solve_proper. *) Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) (p : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_if (λne env, K env t) q p env. Solve All Obligations with solve_proper. - Program Definition interp_outputk {A} (K : A -n> (IT -n> IT)) : - A -n> (IT -n> IT) := - λne env t, interp_output (λne env, K env t) env. - Solve All Obligations with solve_proper. - Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (k : A -n> IT) : - A -n> (IT -n> IT) := - λne env t, interp_throw (λne env, K env t) k env. - Solve All Obligations with solve_proper_please. + (* Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (k : A -n> IT) : *) + (* A -n> (IT -n> IT) := *) + (* λne env t, interp_throw (λne env, K env t) k env. *) + (* Solve All Obligations with solve_proper_please. *) - Program Definition interp_throwrk {A} (e : A -n> IT) (K : A -n> (IT -n> IT)) : - A -n> (IT -n> IT) := - λne env t, interp_throw e (λne env, K env t) env. - Solve All Obligations with solve_proper_please. + (* Program Definition interp_throwrk {A} (e : A -n> IT) (K : A -n> (IT -n> IT)) : *) + (* A -n> (IT -n> IT) := *) + (* λne env t, interp_throw e (λne env, K env t) env. *) + (* Solve All Obligations with solve_proper_please. *) (** Interpretation for all the syntactic categories: values, expressions, contexts *) Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := match v with | LitV n => interp_nat n | RecV e => interp_rec (interp_expr e) - | ContV K => interp_cont (interp_ectx K) + (* | ContV K => interp_cont (interp_ectx K) *) end - with interp_expr {S} (e : expr S) : interp_scope S -n> IT := - match e with - | Val v => interp_val v - | Var x => interp_var x - | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) - | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) - | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) - | Input => interp_input - | Output e => interp_output (interp_expr e) - | Callcc e => interp_callcc (interp_expr e) - | Throw e1 e2 => interp_throw (interp_expr e1) (interp_expr e2) - end - with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := - match K with - | EmptyK => λne env, idfun - | AppRK e1 K => interp_apprk (interp_expr e1) (interp_ectx K) - | AppLK K v2 => interp_applk (interp_ectx K) (interp_val v2) - | NatOpRK op e1 K => interp_natoprk op (interp_expr e1) (interp_ectx K) - | NatOpLK op K v2 => interp_natoplk op (interp_ectx K) (interp_val v2) - | IfK K e1 e2 => interp_ifk (interp_ectx K) (interp_expr e1) (interp_expr e2) - | OutputK K => interp_outputk (interp_ectx K) - | ThrowLK K e => interp_throwlk (interp_ectx K) (interp_expr e) - | ThrowRK v K => interp_throwrk (interp_val v) (interp_ectx K) - end. + with + interp_expr {S} (e : expr S) : interp_scope S -n> IT := + match e with + | Val v => interp_val v + | Var x => interp_var x + | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) + | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) + | Input => interp_input + | Output e => interp_output (interp_expr e) + | Shift e => interp_shift (interp_expr e) + | Reset e => interp_reset (interp_expr e) + end. Solve All Obligations with first [ solve_proper | solve_proper_please ]. + + Program Definition interp_outputk {S} : S -n> (S -n> IT) -n> IT := + λne env t, interp_output t env. + Solve All Obligations with solve_proper. + + Program Definition interp_apprk {A} (q : A -n> IT) : A -n> (A -n> IT) -n> IT := + λne env t, interp_app q t env. + Solve All Obligations with solve_proper. + + Program Definition interp_applk {A} (q : A -n> IT) : A -n> (A -n> IT) -n> IT := + λne env t, interp_app t q env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoprk {A} (op : nat_op) (q : A -n> IT) : + A -n> (A -n> IT) -n> IT := + λne env t, interp_natop op q t env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) : + A -n> (A -n> IT) -n> IT := + λne env t, interp_natop op t q env. + Solve All Obligations with solve_proper. + + Program Definition interp_ifcondk {A} (e1 e2 : A -n> IT) : + A -n> (A -n> IT) -n> IT := + λne env b, interp_if b e1 e2 env. + Solve All Obligations with solve_proper. + + Program Definition interp_iftruek {A} (b e2 : A -n> IT) : + A -n> (A -n> IT) -n> IT := + λne env e1, interp_if b e1 e2 env. + Solve All Obligations with solve_proper. + + Program Definition interp_iffalsek {A} (e1 b : A -n> IT) : + A -n> (A -n> IT) -n> IT := + λne env e2, interp_if b e1 e2 env. + Solve All Obligations with solve_proper. + + Program Definition interp_resetk {S} : S -n> (S -n> IT) -n> IT := + λne env t, interp_reset t env. + Solve All Obligations with solve_proper. + + Definition interp_ectx_el {S} (C : ectx_el S) : + interp_scope S -n> ((interp_scope S -n> IT) -n> IT) := + match C with + | OutputK => interp_outputk + | AppRK e1 => interp_apprk (interp_expr e1) + | AppLK e2 => interp_applk (interp_expr e2) + | NatOpRK op e1 => interp_natoprk op (interp_expr e1) + | NatOpLK op e2 => interp_natoplk op (interp_expr e2) + | IfCondK e1 e2 => interp_ifcondk (interp_expr e1) (interp_expr e2) + | IfTrueK b e2 => interp_iftruek (interp_expr b) (interp_expr e2) + | IfFalseK b e1 => interp_iffalsek (interp_expr b) (interp_expr e1) + | ResetK => interp_resetk + end. + + Definition interp_ectx {S} (K : ectx S) : + interp_scope S -n> (interp_scope S -n> IT) -n> IT := + λne env e, + (fold_left (λ k c, λne (e : interp_scope S -n> IT), + (interp_ectx_el c env) (λne env, k e)) K (λne env e, e env)) e. + (* Open Scope syn_scope. *) (* Example callcc_ex : expr ∅ := *) @@ -535,7 +598,6 @@ Section interp. destruct v; simpl. - apply _. - rewrite interp_rec_unfold. apply _. - - apply _. Qed. Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := @@ -559,31 +621,20 @@ Section interp. interp_expr (fmap δ e) env ≡ interp_expr e (ren_scope δ env) with interp_val_ren {S S'} env (δ : S [→] S') (e : val S) : - interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env) - with interp_ectx_ren {S S'} env - (δ : S [→] S') (e : ectx S) : - interp_ectx (fmap δ e) env ≡ interp_ectx e (ren_scope δ env). + interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env). + (* with interp_ectx_ren {S S'} env *) + (* (δ : S [→] S') (e : ectx S) : *) + (* interp_ectx (fmap δ e) env ≡ interp_ectx e (ren_scope δ env). *) Proof. - - destruct e; simpl. - + by apply interp_val_ren. + - destruct e; simpl; try by repeat f_equiv. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + simpl; rewrite interp_expr_ren. + f_equiv. + intros [| y]; simpl. + + reflexivity. + reflexivity. - + repeat f_equiv; by apply interp_expr_ren. - + repeat f_equiv; by apply interp_expr_ren. - + repeat f_equiv; by apply interp_expr_ren. - + repeat f_equiv; by apply interp_expr_ren. - + repeat f_equiv; by apply interp_expr_ren. - + repeat f_equiv. - intros ?; simpl. - repeat f_equiv. - simpl; rewrite interp_expr_ren. - f_equiv. - intros [| y]; simpl. - * reflexivity. - * reflexivity. - + repeat f_equiv. - * intros ?; simpl. - repeat f_equiv; first by apply interp_expr_ren. - * by apply interp_expr_ren. - destruct e; simpl. + reflexivity. + clear -interp_expr_ren. @@ -598,24 +649,20 @@ Section interp. iApply f_equivI. iApply internal_eq_pointwise. iIntros (y'). - destruct y' as [| [| y]]; simpl; first done. - * by iRewrite - "IH". - * done. - + repeat f_equiv. - intros ?; simpl. - repeat f_equiv; by apply interp_ectx_ren. - - destruct e; simpl; intros ?; simpl. - + reflexivity. - + repeat f_equiv; by apply interp_ectx_ren. - + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_expr_ren | by apply interp_expr_ren]. - + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. - + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. - + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. - + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. - + repeat f_equiv; last by apply interp_ectx_ren. - intros ?; simpl; repeat f_equiv; by apply interp_expr_ren. - + repeat f_equiv; last by apply interp_val_ren. - intros ?; simpl; repeat f_equiv; first by apply interp_ectx_ren. + destruct y' as [| [| y]]; simpl; first done; last done. + by iRewrite - "IH". + (* - destruct e; simpl; intros ?; simpl. *) + (* + reflexivity. *) + (* + repeat f_equiv; by apply interp_ectx_ren. *) + (* + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_expr_ren | by apply interp_expr_ren]. *) + (* + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. *) + (* + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. *) + (* + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. *) + (* + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. *) + (* + repeat f_equiv; last by apply interp_ectx_ren. *) + (* intros ?; simpl; repeat f_equiv; by apply interp_expr_ren. *) + (* + repeat f_equiv; last by apply interp_val_ren. *) + (* intros ?; simpl; repeat f_equiv; first by apply interp_ectx_ren. *) Qed. Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): From 350352c5b18017db99002930420e5e98b67eefbf Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 10 Jan 2024 17:43:07 +0100 Subject: [PATCH 076/114] some interp of ctxs, some rework of the op sem --- theories/input_lang_delim/interp.v | 496 +++++++++++++++-------------- theories/input_lang_delim/lang.v | 24 +- 2 files changed, 265 insertions(+), 255 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 0f74cdb..0b144a9 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -523,49 +523,49 @@ Section interp. Solve All Obligations with first [ solve_proper | solve_proper_please ]. - Program Definition interp_outputk {S} : S -n> (S -n> IT) -n> IT := - λne env t, interp_output t env. + Program Definition interp_outputk {A} : (A -n> IT) -n> A -n> IT := + λne t env, interp_output t env. Solve All Obligations with solve_proper. - Program Definition interp_apprk {A} (q : A -n> IT) : A -n> (A -n> IT) -n> IT := - λne env t, interp_app q t env. + Program Definition interp_apprk {A} (q : A -n> IT) : (A -n> IT) -n> A -n> IT := + λne t env, interp_app q t env. Solve All Obligations with solve_proper. - Program Definition interp_applk {A} (q : A -n> IT) : A -n> (A -n> IT) -n> IT := - λne env t, interp_app t q env. + Program Definition interp_applk {A} (q : A -n> IT) : (A -n> IT) -n> A -n> IT := + λne t env, interp_app t q env. Solve All Obligations with solve_proper. Program Definition interp_natoprk {A} (op : nat_op) (q : A -n> IT) : - A -n> (A -n> IT) -n> IT := - λne env t, interp_natop op q t env. + (A -n> IT) -n> A -n> IT := + λne t env, interp_natop op q t env. Solve All Obligations with solve_proper. Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) : - A -n> (A -n> IT) -n> IT := - λne env t, interp_natop op t q env. + (A -n> IT) -n> A -n> IT := + λne t env, interp_natop op t q env. Solve All Obligations with solve_proper. Program Definition interp_ifcondk {A} (e1 e2 : A -n> IT) : - A -n> (A -n> IT) -n> IT := - λne env b, interp_if b e1 e2 env. + (A -n> IT) -n> A -n> IT := + λne b env, interp_if b e1 e2 env. Solve All Obligations with solve_proper. Program Definition interp_iftruek {A} (b e2 : A -n> IT) : - A -n> (A -n> IT) -n> IT := - λne env e1, interp_if b e1 e2 env. + (A -n> IT) -n> A -n> IT := + λne e1 env, interp_if b e1 e2 env. Solve All Obligations with solve_proper. Program Definition interp_iffalsek {A} (e1 b : A -n> IT) : - A -n> (A -n> IT) -n> IT := - λne env e2, interp_if b e1 e2 env. + (A -n> IT) -n> A -n> IT := + λne e2 env, interp_if b e1 e2 env. Solve All Obligations with solve_proper. - Program Definition interp_resetk {S} : S -n> (S -n> IT) -n> IT := - λne env t, interp_reset t env. + Program Definition interp_resetk {A} : (A -n> IT) -n> A -n> IT := + λne t env, interp_reset t env. Solve All Obligations with solve_proper. Definition interp_ectx_el {S} (C : ectx_el S) : - interp_scope S -n> ((interp_scope S -n> IT) -n> IT) := + (interp_scope S -n> IT) -n> (interp_scope S) -n> IT := match C with | OutputK => interp_outputk | AppRK e1 => interp_apprk (interp_expr e1) @@ -578,11 +578,24 @@ Section interp. | ResetK => interp_resetk end. - Definition interp_ectx {S} (K : ectx S) : - interp_scope S -n> (interp_scope S -n> IT) -n> IT := - λne env e, - (fold_left (λ k c, λne (e : interp_scope S -n> IT), - (interp_ectx_el c env) (λne env, k e)) K (λne env e, e env)) e. + + Fixpoint interp_ectx {S} (K : ectx S) : + interp_scope S → IT → IT := + match K with + | [] => λ env, idfun + | C :: K => λ (env : interp_scope S) (t : IT), + (interp_ectx K env) (interp_ectx_el C (λne env, t) env) + end. + #[export] Instance interp_ectx_1_ne {S} (K : ectx S) (env : interp_scope S) : + NonExpansive (interp_ectx K env : IT → IT). + Proof. solve_proper_prepare. + induction K; eauto. + + + (* Definition interp_ectx {S} (K : ectx S) : interp_scope S -n> IT -n> IT := *) + (* λne env e, *) + (* (fold_left (λ k c, λne (e : interp_scope S -n> IT), *) + (* (interp_ectx_el c env) (λne env, k e)) K (λne t : , t)) e. *) (* Open Scope syn_scope. *) @@ -665,22 +678,22 @@ Section interp. (* intros ?; simpl; repeat f_equiv; first by apply interp_ectx_ren. *) Qed. - Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): - interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). - Proof. - revert env. - induction K; simpl; intros env; first reflexivity; try (by rewrite IHK). - - repeat f_equiv. - by rewrite IHK. - - repeat f_equiv. - by rewrite IHK. - - repeat f_equiv. - by rewrite IHK. - - repeat f_equiv. - intros ?; simpl. - repeat f_equiv. - by rewrite IHK. - Qed. + (* Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): *) + (* interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). *) + (* Proof. *) + (* revert env. *) + (* induction K; simpl; intros env; first reflexivity; try (by rewrite IHK). *) + (* - repeat f_equiv. *) + (* by rewrite IHK. *) + (* - repeat f_equiv. *) + (* by rewrite IHK. *) + (* - repeat f_equiv. *) + (* by rewrite IHK. *) + (* - repeat f_equiv. *) + (* intros ?; simpl. *) + (* repeat f_equiv. *) + (* by rewrite IHK. *) + (* Qed. *) Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') : interp_scope S := λne x, interp_expr (δ x) env. @@ -703,34 +716,22 @@ Section interp. interp_expr (bind δ e) env ≡ interp_expr e (sub_scope δ env) with interp_val_subst {S S'} (env : interp_scope S') (δ : S [⇒] S') e : - interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env) - with interp_ectx_subst {S S'} (env : interp_scope S') - (δ : S [⇒] S') e : - interp_ectx (bind δ e) env ≡ interp_ectx e (sub_scope δ env). + interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env). + (* with interp_ectx_subst {S S'} (env : interp_scope S') *) + (* (δ : S [⇒] S') e : *) + (* interp_ectx (bind δ e) env ≡ interp_ectx e (sub_scope δ env). *) Proof. - - destruct e; simpl. - + by apply interp_val_subst. - + term_simpl. - reflexivity. - + repeat f_equiv; by apply interp_expr_subst. - + repeat f_equiv; by apply interp_expr_subst. - + repeat f_equiv; by apply interp_expr_subst. - + f_equiv. - + repeat f_equiv; by apply interp_expr_subst. - + repeat f_equiv. - intros ?; simpl. - repeat f_equiv. - rewrite interp_expr_subst. + - destruct e; simpl; try by repeat f_equiv. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + rewrite interp_expr_subst. + f_equiv. + intros [| x']; simpl. + + reflexivity. + + rewrite interp_expr_ren. f_equiv. - intros [| x']; simpl. - * reflexivity. - * rewrite interp_expr_ren. - f_equiv. - intros ?; reflexivity. - + repeat f_equiv. - * intros ?; simpl. - repeat f_equiv; first by apply interp_expr_subst. - * by apply interp_expr_subst. + intros ?; reflexivity. - destruct e; simpl. + reflexivity. + clear -interp_expr_subst. @@ -752,193 +753,193 @@ Section interp. iApply internal_eq_pointwise. iIntros (z). done. - + repeat f_equiv; intro; simpl; repeat f_equiv. - by apply interp_ectx_subst. - - destruct e; simpl; intros ?; simpl. - + reflexivity. - + repeat f_equiv; by apply interp_ectx_subst. - + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. - + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. - + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. - + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. - + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. - + repeat f_equiv; last by apply interp_ectx_subst. - intros ?; simpl; repeat f_equiv; first by apply interp_expr_subst. - + repeat f_equiv; last by apply interp_val_subst. - intros ?; simpl; repeat f_equiv; first by apply interp_ectx_subst. + (* + repeat f_equiv; intro; simpl; repeat f_equiv. *) + (* by apply interp_ectx_subst. *) + (* - destruct e; simpl; intros ?; simpl. *) + (* + reflexivity. *) + (* + repeat f_equiv; by apply interp_ectx_subst. *) + (* + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. *) + (* + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. *) + (* + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. *) + (* + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. *) + (* + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. *) + (* + repeat f_equiv; last by apply interp_ectx_subst. *) + (* intros ?; simpl; repeat f_equiv; first by apply interp_expr_subst. *) + (* + repeat f_equiv; last by apply interp_val_subst. *) + (* intros ?; simpl; repeat f_equiv; first by apply interp_ectx_subst. *) Qed. (** ** Interpretation is a homomorphism (for some constructors) *) - #[global] Instance interp_ectx_hom_emp {S} env : - IT_hom (interp_ectx (EmptyK : ectx S) env). - Proof. - simple refine (IT_HOM _ _ _ _ _); intros; auto. - simpl. fold (@idfun IT). f_equiv. intro. simpl. - by rewrite laterO_map_id. - Qed. + (* #[global] Instance interp_ectx_hom_emp {S} env : *) + (* IT_hom (interp_ectx (EmptyK : ectx S) env). *) + (* Proof. *) + (* simple refine (IT_HOM _ _ _ _ _); intros; auto. *) + (* simpl. fold (@idfun IT). f_equiv. intro. simpl. *) + (* by rewrite laterO_map_id. *) + (* Qed. *) - #[global] Instance interp_ectx_hom_output {S} (K : ectx S) env : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (OutputK K) env). - Proof. - intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - by rewrite !hom_tick. - - rewrite !hom_vis. - f_equiv. intro. simpl. rewrite -laterO_map_compose. - do 2 f_equiv. by intro. - - by rewrite !hom_err. - Qed. + (* #[global] Instance interp_ectx_hom_output {S} (K : ectx S) env : *) + (* IT_hom (interp_ectx K env) -> *) + (* IT_hom (interp_ectx (OutputK K) env). *) + (* Proof. *) + (* intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. *) + (* - by rewrite !hom_tick. *) + (* - rewrite !hom_vis. *) + (* f_equiv. intro. simpl. rewrite -laterO_map_compose. *) + (* do 2 f_equiv. by intro. *) + (* - by rewrite !hom_err. *) + (* Qed. *) - #[global] Instance interp_ectx_hom_if {S} - (K : ectx S) (e1 e2 : expr S) env : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (IfK K e1 e2) env). - Proof. - intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. - - assert ((interp_ectx K env (Vis op i ko)) ≡ - (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). - { by rewrite hom_vis. } - trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) - (interp_expr e1 env) (interp_expr e2 env)). - { do 3 f_equiv. by rewrite hom_vis. } - rewrite IF_Vis. f_equiv. simpl. - intro. simpl. by rewrite -laterO_map_compose. - - trans (IF (Err e) (interp_expr e1 env) (interp_expr e2 env)). - { repeat f_equiv. apply hom_err. } - apply IF_Err. - Qed. + (* #[global] Instance interp_ectx_hom_if {S} *) + (* (K : ectx S) (e1 e2 : expr S) env : *) + (* IT_hom (interp_ectx K env) -> *) + (* IT_hom (interp_ectx (IfK K e1 e2) env). *) + (* Proof. *) + (* intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. *) + (* - rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. *) + (* - assert ((interp_ectx K env (Vis op i ko)) ≡ *) + (* (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). *) + (* { by rewrite hom_vis. } *) + (* trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) *) + (* (interp_expr e1 env) (interp_expr e2 env)). *) + (* { do 3 f_equiv. by rewrite hom_vis. } *) + (* rewrite IF_Vis. f_equiv. simpl. *) + (* intro. simpl. by rewrite -laterO_map_compose. *) + (* - trans (IF (Err e) (interp_expr e1 env) (interp_expr e2 env)). *) + (* { repeat f_equiv. apply hom_err. } *) + (* apply IF_Err. *) + (* Qed. *) - #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) - (e : expr S) env : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (AppRK e 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. - Qed. + (* #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) *) + (* (e : expr S) env : *) + (* IT_hom (interp_ectx K env) -> *) + (* IT_hom (interp_ectx (AppRK e 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. *) + (* Qed. *) - #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) - (v : val S) (env : interp_scope S) : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (AppLK K v) env). - Proof. - intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. - - trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) - (interp_val v env)). - + do 2f_equiv. rewrite hom_vis. do 3 f_equiv. by intro. - + rewrite APP'_Vis_l. f_equiv. intro x. simpl. - by rewrite -laterO_map_compose. - - trans (APP' (Err e) (interp_val v env)). - { do 2f_equiv. apply hom_err. } - apply APP'_Err_l, interp_val_asval. - Qed. + (* #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) *) + (* (v : val S) (env : interp_scope S) : *) + (* IT_hom (interp_ectx K env) -> *) + (* IT_hom (interp_ectx (AppLK K v) env). *) + (* Proof. *) + (* intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. *) + (* - rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. *) + (* - trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) *) + (* (interp_val v env)). *) + (* + do 2f_equiv. rewrite hom_vis. do 3 f_equiv. by intro. *) + (* + rewrite APP'_Vis_l. f_equiv. intro x. simpl. *) + (* by rewrite -laterO_map_compose. *) + (* - trans (APP' (Err e) (interp_val v env)). *) + (* { do 2f_equiv. apply hom_err. } *) + (* apply APP'_Err_l, interp_val_asval. *) + (* Qed. *) - #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) - (e : expr S) op env : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (NatOpRK op e K) env). - Proof. - intros H. 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. - Qed. + (* #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) *) + (* (e : expr S) op env : *) + (* IT_hom (interp_ectx K env) -> *) + (* IT_hom (interp_ectx (NatOpRK op e K) env). *) + (* Proof. *) + (* intros H. 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. *) + (* Qed. *) - #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) - (v : val S) op (env : interp_scope S) : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (NatOpLK op K v) env). - Proof. - intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - rewrite -NATOP_ITV_Tick_l. do 2 f_equiv. apply hom_tick. - - trans (NATOP (do_natop op) - (Vis op0 i (laterO_map (interp_ectx K env) ◎ ko)) - (interp_val v env)). - { do 2 f_equiv. rewrite hom_vis. f_equiv. by intro. } - rewrite NATOP_ITV_Vis_l. f_equiv. intro x. simpl. - by rewrite -laterO_map_compose. - - trans (NATOP (do_natop op) (Err e) (interp_val v env)). - + do 2 f_equiv. apply hom_err. - + by apply NATOP_Err_l, interp_val_asval. - Qed. + (* #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) *) + (* (v : val S) op (env : interp_scope S) : *) + (* IT_hom (interp_ectx K env) -> *) + (* IT_hom (interp_ectx (NatOpLK op K v) env). *) + (* Proof. *) + (* intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. *) + (* - rewrite -NATOP_ITV_Tick_l. do 2 f_equiv. apply hom_tick. *) + (* - trans (NATOP (do_natop op) *) + (* (Vis op0 i (laterO_map (interp_ectx K env) ◎ ko)) *) + (* (interp_val v env)). *) + (* { do 2 f_equiv. rewrite hom_vis. f_equiv. by intro. } *) + (* rewrite NATOP_ITV_Vis_l. f_equiv. intro x. simpl. *) + (* by rewrite -laterO_map_compose. *) + (* - trans (NATOP (do_natop op) (Err e) (interp_val v env)). *) + (* + do 2 f_equiv. apply hom_err. *) + (* + by apply NATOP_Err_l, interp_val_asval. *) + (* Qed. *) - Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). - Proof. - intros. - by rewrite IT_rec1_ret. - Qed. + (* Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). *) + (* Proof. *) + (* intros. *) + (* by rewrite IT_rec1_ret. *) + (* Qed. *) - #[global] Instance interp_ectx_hom_throwr {S} - (K : ectx S) (v : val S) env : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (ThrowRK v K) env). - Proof. - intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - pose proof (interp_val_asval v (D := env)). - rewrite ->2 get_val_ITV. - simpl. - rewrite hom_tick. - destruct (IT_dont_confuse ((interp_ectx K env α))) as [(e' & HEQ) |[(n & HEQ) |[(f & HEQ) |[(β & HEQ) | (op & i & k & HEQ)]]]]. - + rewrite HEQ !get_fun_tick !get_fun_err. - reflexivity. - + rewrite HEQ !get_fun_tick !get_fun_ret'. - reflexivity. - + rewrite HEQ !get_fun_tick !get_fun_fun//=. - + rewrite HEQ !get_fun_tick. - reflexivity. - + rewrite HEQ !get_fun_tick !get_fun_vis. - reflexivity. - - pose proof (interp_val_asval v (D := env)). - rewrite get_val_ITV. - simpl. - rewrite hom_vis. - rewrite get_fun_vis. - f_equiv. - intro; simpl. - rewrite -laterO_map_compose. - repeat f_equiv. - intro; simpl. - rewrite get_val_ITV. - simpl. - reflexivity. - - pose proof (interp_val_asval v (D := env)). - rewrite get_val_ITV. - simpl. - rewrite hom_err. - rewrite get_fun_err. - reflexivity. - Qed. + (* #[global] Instance interp_ectx_hom_throwr {S} *) + (* (K : ectx S) (v : val S) env : *) + (* IT_hom (interp_ectx K env) -> *) + (* IT_hom (interp_ectx (ThrowRK v K) env). *) + (* Proof. *) + (* intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. *) + (* - pose proof (interp_val_asval v (D := env)). *) + (* rewrite ->2 get_val_ITV. *) + (* simpl. *) + (* rewrite hom_tick. *) + (* destruct (IT_dont_confuse ((interp_ectx K env α))) as [(e' & HEQ) |[(n & HEQ) |[(f & HEQ) |[(β & HEQ) | (op & i & k & HEQ)]]]]. *) + (* + rewrite HEQ !get_fun_tick !get_fun_err. *) + (* reflexivity. *) + (* + rewrite HEQ !get_fun_tick !get_fun_ret'. *) + (* reflexivity. *) + (* + rewrite HEQ !get_fun_tick !get_fun_fun//=. *) + (* + rewrite HEQ !get_fun_tick. *) + (* reflexivity. *) + (* + rewrite HEQ !get_fun_tick !get_fun_vis. *) + (* reflexivity. *) + (* - pose proof (interp_val_asval v (D := env)). *) + (* rewrite get_val_ITV. *) + (* simpl. *) + (* rewrite hom_vis. *) + (* rewrite get_fun_vis. *) + (* f_equiv. *) + (* intro; simpl. *) + (* rewrite -laterO_map_compose. *) + (* repeat f_equiv. *) + (* intro; simpl. *) + (* rewrite get_val_ITV. *) + (* simpl. *) + (* reflexivity. *) + (* - pose proof (interp_val_asval v (D := env)). *) + (* rewrite get_val_ITV. *) + (* simpl. *) + (* rewrite hom_err. *) + (* rewrite get_fun_err. *) + (* reflexivity. *) + (* Qed. *) - #[global] Instance interp_ectx_hom_throwl {S} - (K : ectx S) (e : expr S) env : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (ThrowLK K e) env). - Proof. - intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; [by rewrite !hom_tick| | by rewrite !hom_err]. - rewrite !hom_vis. - f_equiv. - intro; simpl. - rewrite -laterO_map_compose. - reflexivity. - Qed. + (* #[global] Instance interp_ectx_hom_throwl {S} *) + (* (K : ectx S) (e : expr S) env : *) + (* IT_hom (interp_ectx K env) -> *) + (* IT_hom (interp_ectx (ThrowLK K e) env). *) + (* Proof. *) + (* intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; [by rewrite !hom_tick| | by rewrite !hom_err]. *) + (* rewrite !hom_vis. *) + (* f_equiv. *) + (* intro; simpl. *) + (* rewrite -laterO_map_compose. *) + (* reflexivity. *) + (* Qed. *) - #[global] Instance interp_ectx_hom {S} - (K : ectx S) env : - IT_hom (interp_ectx K env). - Proof. - induction K; apply _. - Qed. + (* #[global] Instance interp_ectx_hom {S} *) + (* (K : ectx S) env : *) + (* IT_hom (interp_ectx K env). *) + (* Proof. *) + (* induction K; apply _. *) + (* Qed. *) (** ** Finally, preservation of reductions *) Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' σ σ' K n : - head_step e σ e' σ' K (n, 0) → + head_step e σ K e' σ' K (n, 0) → interp_expr e env ≡ Tick_n n $ interp_expr e' env. Proof. inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. @@ -966,19 +967,20 @@ Section interp. reflexivity. Qed. - Lemma interp_expr_fill_no_reify {S} K (env : interp_scope S) (e e' : expr S) σ σ' n : - head_step e σ e' σ' K (n, 0) → - interp_expr (fill K e) env - ≡ - Tick_n n $ interp_expr (fill K e') env. + Lemma interp_expr_fill_no_reify {S} K K' (env : interp_scope S) (e e' : expr S) σ σ' n : + head_step e σ K e' σ' K' (n, 0) → + interp_expr (fill K e) env ≡ + Tick_n n $ interp_expr (fill K' e') env. Proof. + inversion 1; subst. + - eapply sH. intros He. - rewrite !interp_comp. - erewrite <-hom_tick_n. - - apply (interp_expr_head_step env) in He. - rewrite He. - reflexivity. - - apply _. + (* rewrite !interp_comp. *) + (* erewrite <-hom_tick_n. *) + (* - apply (interp_expr_head_step env) in He. *) + (* rewrite He. *) + (* reflexivity. *) + (* - apply _. *) Qed. Opaque INPUT OUTPUT_ CALLCC CALLCC_ THROW. diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index ff0b3e6..0644406 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -365,7 +365,7 @@ Definition ctx_el_to_expr {X : Set} (K : ectx_el X) (e : expr X) : expr X := | AppRK el => App el e | NatOpLK op er => NatOp op e er | NatOpRK op el => NatOp op el e - | ResetK => e + | ResetK => Reset e end. Definition fill {X : Set} (K : ectx X) (e : expr X) : expr X := @@ -426,7 +426,7 @@ Definition update_output (n:nat) (s : state) : state := (** [head_step e σ K e' σ' K' (n, m)] : step from [(e, σ, K)] to [(e', σ', K')] - in [n] ticks with [m] i/o accesses *) + in [n] ticks with [m] effects encountered *) Variant head_step {S} : expr S → state -> ectx S → expr S → state → ectx S → nat * nat → Prop := @@ -453,13 +453,18 @@ Variant head_step {S} : expr S → state -> ectx S → n = 0 → head_step (If (Val (LitV n)) e1 e2) σ K e2 σ K (0, 0) - | ValueS v σ K C: - head_step (Val v) σ (C::K) (ctx_el_to_expr C (Val v)) σ K (0, 0) | ShiftS e σ K Ki Ko f: ((Ki, Ko) = shift_context K) -> f = cont_to_rec Ki -> - head_step (Shift e) σ K (subst (Inc := inc) e (Val f)) σ Ko (1, 0). + head_step (Shift e) σ K (subst (Inc := inc) e (Val f)) σ Ko (1, 1) + + | ResetS v σ K : + head_step (Reset (Val v)) σ K (Val v) σ K (1, 1). + + + (* | ValueS v σ K C: *) + (* head_step (Val v) σ (C::K) (ctx_el_to_expr C (Val v)) σ K (0, 0) *) (* | ResetShiftS e σ K E: *) (* head_step *) @@ -486,7 +491,7 @@ Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. Lemma ctx_el_to_expr_val {S} C (e : expr S) : is_Some (to_val (ctx_el_to_expr C e)) → is_Some (to_val e). -Proof. case : C => [] > H; simpl in H; try by apply is_Some_None in H. done. Qed. +Proof. case : C => [] > H; simpl in H; try by apply is_Some_None in H. Qed. Lemma fill_val {S} Ki (e : expr S) : is_Some (to_val (fill Ki e)) → is_Some (to_val e). @@ -845,8 +850,8 @@ Definition compute_head_step {S} | (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, 0)) - (* | (Reset (Val v)) => Some (Val v, σ, (1, 0)) *) + 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. @@ -898,4 +903,7 @@ Proof. - 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. From 4729118538deab4debeaf38054044b06831a4186 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 11 Jan 2024 14:02:30 +0100 Subject: [PATCH 077/114] interpretation of ctxs and properties --- theories/input_lang_delim/interp.v | 69 ++++++++++++++---------------- 1 file changed, 33 insertions(+), 36 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 0b144a9..4b0e0b8 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -555,7 +555,7 @@ Section interp. λne e1 env, interp_if b e1 e2 env. Solve All Obligations with solve_proper. - Program Definition interp_iffalsek {A} (e1 b : A -n> IT) : + Program Definition interp_iffalsek {A} (b e1 : A -n> IT) : (A -n> IT) -n> A -n> IT := λne e2 env, interp_if b e1 e2 env. Solve All Obligations with solve_proper. @@ -579,19 +579,21 @@ Section interp. end. - Fixpoint interp_ectx {S} (K : ectx S) : + Fixpoint interp_ectx' {S} (K : ectx S) : interp_scope S → IT → IT := match K with | [] => λ env, idfun | C :: K => λ (env : interp_scope S) (t : IT), - (interp_ectx K env) (interp_ectx_el C (λne env, t) env) + (interp_ectx' K env) (interp_ectx_el C (λne env, t) env) end. #[export] Instance interp_ectx_1_ne {S} (K : ectx S) (env : interp_scope S) : - NonExpansive (interp_ectx K env : IT → IT). - Proof. solve_proper_prepare. - induction K; eauto. + NonExpansive (interp_ectx' K env : IT → IT). + Proof. induction K; solve_proper_please. Qed. + Definition interp_ectx {S} (K : ectx S) : interp_scope S → (IT -n> IT) := + λ env, OfeMor (interp_ectx' K env). + (* Example test_ectx : ectx ∅ := [OutputK ; AppRK (LamV (Var VZ))]. *) (* Definition interp_ectx {S} (K : ectx S) : interp_scope S -n> IT -n> IT := *) (* λne env e, *) (* (fold_left (λ k c, λne (e : interp_scope S -n> IT), *) @@ -678,22 +680,13 @@ Section interp. (* intros ?; simpl; repeat f_equiv; first by apply interp_ectx_ren. *) Qed. - (* Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): *) - (* interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). *) - (* Proof. *) - (* revert env. *) - (* induction K; simpl; intros env; first reflexivity; try (by rewrite IHK). *) - (* - repeat f_equiv. *) - (* by rewrite IHK. *) - (* - repeat f_equiv. *) - (* by rewrite IHK. *) - (* - repeat f_equiv. *) - (* by rewrite IHK. *) - (* - repeat f_equiv. *) - (* intros ?; simpl. *) - (* repeat f_equiv. *) - (* by rewrite IHK. *) - (* Qed. *) + Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): + interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). + Proof. + revert env e. + induction K; eauto. + induction a; simpl; intros env e; by eapply IHK. + Qed. Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') : interp_scope S := λne x, interp_expr (δ x) env. @@ -753,22 +746,26 @@ Section interp. iApply internal_eq_pointwise. iIntros (z). done. - (* + repeat f_equiv; intro; simpl; repeat f_equiv. *) - (* by apply interp_ectx_subst. *) - (* - destruct e; simpl; intros ?; simpl. *) - (* + reflexivity. *) - (* + repeat f_equiv; by apply interp_ectx_subst. *) - (* + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. *) - (* + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. *) - (* + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. *) - (* + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. *) - (* + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. *) - (* + repeat f_equiv; last by apply interp_ectx_subst. *) - (* intros ?; simpl; repeat f_equiv; first by apply interp_expr_subst. *) - (* + repeat f_equiv; last by apply interp_val_subst. *) - (* intros ?; simpl; repeat f_equiv; first by apply interp_ectx_subst. *) Qed. + + Lemma interp_ectx_subst {S S'} (env : interp_scope S') (δ : S [⇒] S') K : + interp_ectx (bind δ K) env ≡ interp_ectx K (sub_scope δ env). + Proof. + induction K; simpl; intros ?; simpl; eauto. + destruct a; simpl; try by eapply IHK. + - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. + - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. + - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. + - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. + - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. + - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. + - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. + Qed. + (* FIXME this is aweful. *) + + + (** ** Interpretation is a homomorphism (for some constructors) *) (* #[global] Instance interp_ectx_hom_emp {S} env : *) From f8ba784b13e57e833aedfe77c4fa75afeaaff884 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 11 Jan 2024 17:03:44 +0100 Subject: [PATCH 078/114] more on ctx. however maybe not homomorphisms? Might be a problem --- theories/input_lang_delim/interp.v | 262 ++++++++++++----------------- 1 file changed, 104 insertions(+), 158 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 4b0e0b8..8d44e9b 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -768,170 +768,114 @@ Section interp. (** ** Interpretation is a homomorphism (for some constructors) *) - (* #[global] Instance interp_ectx_hom_emp {S} env : *) - (* IT_hom (interp_ectx (EmptyK : ectx S) env). *) - (* Proof. *) - (* simple refine (IT_HOM _ _ _ _ _); intros; auto. *) - (* simpl. fold (@idfun IT). f_equiv. intro. simpl. *) - (* by rewrite laterO_map_id. *) - (* Qed. *) + #[global] Instance interp_ectx_hom_emp {S} env : + IT_hom (interp_ectx ([] : ectx S) env). + Proof. + simple refine (IT_HOM _ _ _ _ _); intros; auto. + simpl. f_equiv. intro. simpl. + by rewrite laterO_map_id. + Qed. - (* #[global] Instance interp_ectx_hom_output {S} (K : ectx S) env : *) - (* IT_hom (interp_ectx K env) -> *) - (* IT_hom (interp_ectx (OutputK K) env). *) - (* Proof. *) - (* intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. *) - (* - by rewrite !hom_tick. *) - (* - rewrite !hom_vis. *) - (* f_equiv. intro. simpl. rewrite -laterO_map_compose. *) - (* do 2 f_equiv. by intro. *) - (* - by rewrite !hom_err. *) - (* Qed. *) + #[global] Instance interp_ectx_hom_output {S} (K : ectx S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (OutputK :: K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. + f_equiv. intro. simpl. rewrite -laterO_map_compose. + do 2 f_equiv. by intro. + - by rewrite !hom_err. + Qed. - (* #[global] Instance interp_ectx_hom_if {S} *) - (* (K : ectx S) (e1 e2 : expr S) env : *) - (* IT_hom (interp_ectx K env) -> *) - (* IT_hom (interp_ectx (IfK K e1 e2) env). *) - (* Proof. *) - (* intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. *) - (* - rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. *) - (* - assert ((interp_ectx K env (Vis op i ko)) ≡ *) - (* (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). *) - (* { by rewrite hom_vis. } *) - (* trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) *) - (* (interp_expr e1 env) (interp_expr e2 env)). *) - (* { do 3 f_equiv. by rewrite hom_vis. } *) - (* rewrite IF_Vis. f_equiv. simpl. *) - (* intro. simpl. by rewrite -laterO_map_compose. *) - (* - trans (IF (Err e) (interp_expr e1 env) (interp_expr e2 env)). *) - (* { repeat f_equiv. apply hom_err. } *) - (* apply IF_Err. *) - (* Qed. *) + #[global] Instance interp_ectx_hom_if {S} + (K : ectx S) (e1 e2 : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (IfCondK e1 e2 :: K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite -hom_tick -IF_Tick. + - trans (Vis op i (laterO_map (λne y, + (λne t : IT, interp_ectx' K env (IF t (interp_expr e1 env) (interp_expr e2 env))) + y) ◎ ko)); + last (simpl; do 3 f_equiv; by intro). + by rewrite -hom_vis. + - trans (interp_ectx' K env (Err e)); first (f_equiv; apply IF_Err). + apply hom_err. + Qed. - (* #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) *) - (* (e : expr S) env : *) - (* IT_hom (interp_ectx K env) -> *) - (* IT_hom (interp_ectx (AppRK e 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. *) - (* Qed. *) - (* #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) *) - (* (v : val S) (env : interp_scope S) : *) - (* IT_hom (interp_ectx K env) -> *) - (* IT_hom (interp_ectx (AppLK K v) env). *) - (* Proof. *) - (* intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. *) - (* - rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. *) - (* - trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) *) - (* (interp_val v env)). *) - (* + do 2f_equiv. rewrite hom_vis. do 3 f_equiv. by intro. *) - (* + rewrite APP'_Vis_l. f_equiv. intro x. simpl. *) - (* by rewrite -laterO_map_compose. *) - (* - trans (APP' (Err e) (interp_val v env)). *) - (* { do 2f_equiv. apply hom_err. } *) - (* apply APP'_Err_l, interp_val_asval. *) - (* Qed. *) + #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) + (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppRK e :: 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. + Qed. - (* #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) *) - (* (e : expr S) op env : *) - (* IT_hom (interp_ectx K env) -> *) - (* IT_hom (interp_ectx (NatOpRK op e K) env). *) - (* Proof. *) - (* intros H. 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. *) - (* Qed. *) + #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) + (v : val S) (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppLK v :: 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_ectx' K env (t ⊙ (interp_val v env))) + y) ◎ ko)); + last (simpl; do 3 f_equiv; by intro). + by rewrite -hom_vis. + - trans (interp_ectx' K env (Err e)); + first (f_equiv; apply APP'_Err_l; apply interp_val_asval). + apply hom_err. + Qed. - (* #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) *) - (* (v : val S) op (env : interp_scope S) : *) - (* IT_hom (interp_ectx K env) -> *) - (* IT_hom (interp_ectx (NatOpLK op K v) env). *) - (* Proof. *) - (* intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. *) - (* - rewrite -NATOP_ITV_Tick_l. do 2 f_equiv. apply hom_tick. *) - (* - trans (NATOP (do_natop op) *) - (* (Vis op0 i (laterO_map (interp_ectx K env) ◎ ko)) *) - (* (interp_val v env)). *) - (* { do 2 f_equiv. rewrite hom_vis. f_equiv. by intro. } *) - (* rewrite NATOP_ITV_Vis_l. f_equiv. intro x. simpl. *) - (* by rewrite -laterO_map_compose. *) - (* - trans (NATOP (do_natop op) (Err e) (interp_val v env)). *) - (* + do 2 f_equiv. apply hom_err. *) - (* + by apply NATOP_Err_l, interp_val_asval. *) - (* Qed. *) + #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) + (e : expr S) op env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpRK op e :: K) env). + Proof. + intros H. 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. + Qed. - (* Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). *) - (* Proof. *) - (* intros. *) - (* by rewrite IT_rec1_ret. *) - (* Qed. *) + #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) + (v : val S) op (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpLK op v :: K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -hom_tick. f_equiv. by rewrite -NATOP_ITV_Tick_l. + - trans (Vis op0 i (laterO_map (λne y, + (λne t : IT, interp_ectx' K env (NATOP (do_natop op) t (interp_val v env))) y) ◎ ko)); + last (simpl; do 3 f_equiv; by intro). + rewrite NATOP_ITV_Vis_l hom_vis. f_equiv. intro. simpl. + by rewrite -laterO_map_compose. + - trans (interp_ectx' K env (Err e)). + + f_equiv. by apply NATOP_Err_l, interp_val_asval. + + apply hom_err. + Qed. - (* #[global] Instance interp_ectx_hom_throwr {S} *) - (* (K : ectx S) (v : val S) env : *) - (* IT_hom (interp_ectx K env) -> *) - (* IT_hom (interp_ectx (ThrowRK v K) env). *) - (* Proof. *) - (* intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. *) - (* - pose proof (interp_val_asval v (D := env)). *) - (* rewrite ->2 get_val_ITV. *) - (* simpl. *) - (* rewrite hom_tick. *) - (* destruct (IT_dont_confuse ((interp_ectx K env α))) as [(e' & HEQ) |[(n & HEQ) |[(f & HEQ) |[(β & HEQ) | (op & i & k & HEQ)]]]]. *) - (* + rewrite HEQ !get_fun_tick !get_fun_err. *) - (* reflexivity. *) - (* + rewrite HEQ !get_fun_tick !get_fun_ret'. *) - (* reflexivity. *) - (* + rewrite HEQ !get_fun_tick !get_fun_fun//=. *) - (* + rewrite HEQ !get_fun_tick. *) - (* reflexivity. *) - (* + rewrite HEQ !get_fun_tick !get_fun_vis. *) - (* reflexivity. *) - (* - pose proof (interp_val_asval v (D := env)). *) - (* rewrite get_val_ITV. *) - (* simpl. *) - (* rewrite hom_vis. *) - (* rewrite get_fun_vis. *) - (* f_equiv. *) - (* intro; simpl. *) - (* rewrite -laterO_map_compose. *) - (* repeat f_equiv. *) - (* intro; simpl. *) - (* rewrite get_val_ITV. *) - (* simpl. *) - (* reflexivity. *) - (* - pose proof (interp_val_asval v (D := env)). *) - (* rewrite get_val_ITV. *) - (* simpl. *) - (* rewrite hom_err. *) - (* rewrite get_fun_err. *) - (* reflexivity. *) - (* Qed. *) + Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). + Proof. + intros. + by rewrite IT_rec1_ret. + Qed. - (* #[global] Instance interp_ectx_hom_throwl {S} *) - (* (K : ectx S) (e : expr S) env : *) - (* IT_hom (interp_ectx K env) -> *) - (* IT_hom (interp_ectx (ThrowLK K e) env). *) - (* Proof. *) - (* intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; [by rewrite !hom_tick| | by rewrite !hom_err]. *) - (* rewrite !hom_vis. *) - (* f_equiv. *) - (* intro; simpl. *) - (* rewrite -laterO_map_compose. *) - (* reflexivity. *) - (* Qed. *) (* #[global] Instance interp_ectx_hom {S} *) (* (K : ectx S) env : *) (* IT_hom (interp_ectx K env). *) (* Proof. *) - (* induction K; apply _. *) + (* induction K; simpl; first apply IT_hom_idfun. *) + (* destruct a; try apply _. *) (* Qed. *) (** ** Finally, preservation of reductions *) @@ -970,14 +914,16 @@ Section interp. Tick_n n $ interp_expr (fill K' e') env. Proof. inversion 1; subst. - - eapply sH. - intros He. - (* rewrite !interp_comp. *) - (* erewrite <-hom_tick_n. *) - (* - apply (interp_expr_head_step env) in He. *) - (* rewrite He. *) - (* reflexivity. *) - (* - apply _. *) + - rewrite !interp_comp. + erewrite <-hom_tick_n. + + simpl. apply (interp_expr_head_step env) in H. + rewrite equiv_dist => n; f_equiv; move : n; apply equiv_dist. + apply H. + + + - apply (interp_expr_head_step env) in He. + rewrite He. + reflexivity. + - apply _. Qed. Opaque INPUT OUTPUT_ CALLCC CALLCC_ THROW. From 2237d732514cf9b1f7d2f650c72e94f78024ff79 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 12 Jan 2024 14:46:52 +0100 Subject: [PATCH 079/114] Corrections re contexts: no Resets -> homomorphism --- theories/input_lang_delim/interp.v | 80 ++++++++++++------- theories/input_lang_delim/lang.v | 123 ++++++++++++++++------------- 2 files changed, 117 insertions(+), 86 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 8d44e9b..ed48418 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -323,6 +323,8 @@ Section interp. Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). Global Instance denot_cont_ne (κ : IT -n> IT) : NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). @@ -484,10 +486,10 @@ Section interp. (* λne env t, interp_natop op (λne env, K env t) q env. *) (* Solve All Obligations with solve_proper. *) - Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) - (p : A -n> IT) : A -n> (IT -n> IT) := - λne env t, interp_if (λne env, K env t) q p env. - Solve All Obligations with solve_proper. + (* Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) *) + (* (p : A -n> IT) : A -n> (IT -n> IT) := *) + (* λne env t, interp_if (λne env, K env t) q p env. *) + (* Solve All Obligations with solve_proper. *) (* Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (k : A -n> IT) : *) @@ -545,20 +547,20 @@ Section interp. λne t env, interp_natop op t q env. Solve All Obligations with solve_proper. - Program Definition interp_ifcondk {A} (e1 e2 : A -n> IT) : + Program Definition interp_ifk {A} (e1 e2 : A -n> IT) : (A -n> IT) -n> A -n> IT := λne b env, interp_if b e1 e2 env. Solve All Obligations with solve_proper. - Program Definition interp_iftruek {A} (b e2 : A -n> IT) : - (A -n> IT) -n> A -n> IT := - λne e1 env, interp_if b e1 e2 env. - Solve All Obligations with solve_proper. + (* Program Definition interp_iftruek {A} (b e2 : A -n> IT) : *) + (* (A -n> IT) -n> A -n> IT := *) + (* λne e1 env, interp_if b e1 e2 env. *) + (* Solve All Obligations with solve_proper. *) - Program Definition interp_iffalsek {A} (b e1 : A -n> IT) : - (A -n> IT) -n> A -n> IT := - λne e2 env, interp_if b e1 e2 env. - Solve All Obligations with solve_proper. + (* Program Definition interp_iffalsek {A} (b e1 : A -n> IT) : *) + (* (A -n> IT) -n> A -n> IT := *) + (* λne e2 env, interp_if b e1 e2 env. *) + (* Solve All Obligations with solve_proper. *) Program Definition interp_resetk {A} : (A -n> IT) -n> A -n> IT := λne t env, interp_reset t env. @@ -572,9 +574,9 @@ Section interp. | AppLK e2 => interp_applk (interp_expr e2) | NatOpRK op e1 => interp_natoprk op (interp_expr e1) | NatOpLK op e2 => interp_natoplk op (interp_expr e2) - | IfCondK e1 e2 => interp_ifcondk (interp_expr e1) (interp_expr e2) - | IfTrueK b e2 => interp_iftruek (interp_expr b) (interp_expr e2) - | IfFalseK b e1 => interp_iffalsek (interp_expr b) (interp_expr e1) + | IfK e1 e2 => interp_ifk (interp_expr e1) (interp_expr e2) + (* | IfTrueK b e2 => interp_iftruek (interp_expr b) (interp_expr e2) *) + (* | IfFalseK b e1 => interp_iffalsek (interp_expr b) (interp_expr e1) *) | ResetK => interp_resetk end. @@ -685,7 +687,7 @@ Section interp. Proof. revert env e. induction K; eauto. - induction a; simpl; intros env e; by eapply IHK. + destruct a; simpl; intros env e'; by eapply IHK. Qed. Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') @@ -755,11 +757,9 @@ Section interp. induction K; simpl; intros ?; simpl; eauto. destruct a; simpl; try by eapply IHK. - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. + - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_val_subst. - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. - - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. - - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. - - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. - - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. + - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_val_subst. - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. Qed. (* FIXME this is aweful. *) @@ -791,10 +791,10 @@ Section interp. #[global] Instance interp_ectx_hom_if {S} (K : ectx S) (e1 e2 : expr S) env : IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (IfCondK e1 e2 :: K) env). + IT_hom (interp_ectx (IfK e1 e2 :: K) env). Proof. intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - by rewrite -hom_tick -IF_Tick. + - by rewrite -hom_tick -IF_Tick. - trans (Vis op i (laterO_map (λne y, (λne t : IT, interp_ectx' K env (IF t (interp_expr e1 env) (interp_expr e2 env))) y) ◎ ko)); @@ -863,6 +863,23 @@ Section interp. + apply hom_err. Qed. + (* ResetK is not a homomorphism *) + Lemma interp_ectx_reset_not_hom {S} env : + IT_hom (interp_ectx ([ResetK] : ectx S) env) -> False. + Proof. + intros [ _ Hi _ _ ]. simpl in Hi. + specialize (Hi (Ret 0)). + rewrite -hom_tick in Hi. + rewrite get_val_tick get_val_vis in Hi. + apply bi.siProp.pure_soundness. + iApply IT_tick_vis_ne. + iPureIntro. + symmetry. + eapply Hi. + Unshelve. apply bi.siProp_internal_eq. + Qed. + + Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). Proof. intros. @@ -870,13 +887,16 @@ Section interp. Qed. - (* #[global] Instance interp_ectx_hom {S} *) - (* (K : ectx S) env : *) - (* IT_hom (interp_ectx K env). *) - (* Proof. *) - (* induction K; simpl; first apply IT_hom_idfun. *) - (* destruct a; try apply _. *) - (* Qed. *) + #[global] Instance interp_ectx_hom {S} + (K : ectx S) env : + ResetK ∉ K -> + IT_hom (interp_ectx K env). + Proof. + intro. + induction K; simpl; first apply IT_hom_idfun. + apply not_elem_of_cons in H. destruct H as [H1 ?]. specialize (IHK H). + destruct a; try apply _. contradiction. + Qed. (** ** Finally, preservation of reductions *) Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' σ σ' K n : diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 0644406..c1fe453 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -33,13 +33,11 @@ with val {X : Set} := Variant ectx_el {X : Set} := | OutputK : ectx_el - | IfCondK (e1 : @expr X) (e2 : @expr X) : ectx_el - | IfTrueK (b : @expr X) (e2 : @expr X) : ectx_el - | IfFalseK (b : @expr X) (e1 : @expr X) : ectx_el - | AppLK (er : @expr X) : ectx_el (* ◻ er *) - | AppRK (el : @expr X) : ectx_el (* el ◻ *) - | NatOpLK (op : nat_op) (er : @expr X) : ectx_el (* ◻ + er *) - | NatOpRK (op : nat_op) (el : @expr X) : ectx_el (* el + square *) + | IfK (e1 : @expr X) (e2 : @expr X) : ectx_el + | AppLK (v : @val X) : ectx_el (* ◻ v *) + | AppRK (e : @expr X) : ectx_el (* e ◻ *) + | NatOpLK (op : nat_op) (v : @val X) : ectx_el (* ◻ + v *) + | NatOpRK (op : nat_op) (e : @expr X) : ectx_el (* e + ◻ *) | ResetK : ectx_el. @@ -82,13 +80,11 @@ vmap {A B : Set} (f : A [→] B) (v : val A) : val B := Definition kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := map (fun x => match x with | OutputK => OutputK - | IfCondK e1 e2 => IfCondK (fmap f e1) (fmap f e2) - | IfTrueK b e2 => IfTrueK (fmap f b) (fmap f e2) - | IfFalseK b e1 => IfFalseK (fmap f b) (fmap f e1) - | AppLK er => AppLK (fmap f er) - | AppRK el => AppRK (fmap f el) - | NatOpLK op er => NatOpLK op (fmap f er) - | NatOpRK op el => NatOpRK op (fmap f el) + | IfK e1 e2 => IfK (fmap f e1) (fmap f e2) + | AppLK v => AppLK (fmap f v) + | AppRK e => AppRK (fmap f e) + | NatOpLK op v => NatOpLK op (fmap f v) + | NatOpRK op e => NatOpRK op (fmap f e) | ResetK => ResetK end) K. @@ -122,13 +118,11 @@ vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := Definition kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := map (fun x => match x with | OutputK => OutputK - | IfCondK e1 e2 => IfCondK (bind f e1) (bind f e2) - | IfTrueK b e2 => IfTrueK (bind f b) (bind f e2) - | IfFalseK b e1 => IfFalseK (bind f b) (bind f e1) - | AppLK er => AppLK (bind f er) - | AppRK el => AppRK (bind f el) - | NatOpLK op er => NatOpLK op (bind f er) - | NatOpRK op el => NatOpRK op (bind f el) + | IfK e1 e2 => IfK (bind f e1) (bind f e2) + | AppLK v => AppLK (bind f v) + | AppRK e => AppRK (bind f e) + | NatOpLK op v => NatOpLK op (bind f v) + | NatOpRK op e => NatOpRK op (bind f e) | ResetK => ResetK end) K. @@ -163,7 +157,7 @@ Definition kmap_id X (δ : X [→] X) (k : ectx X) : δ ≡ ı -> fmap δ k = k. Proof. rewrite /fmap /FMap_ectx /kmap => H. rewrite <-List.map_id. do 2 f_equal. - extensionality x. case: x => // >; rewrite !emap_id//. + extensionality x. case: x => // >; rewrite !(emap_id, vmap_id)//. Qed. @@ -183,7 +177,7 @@ Proof. rewrite /fmap /FMap_ectx => H. rewrite /kmap map_map. do 2 f_equal. extensionality x. - case : x => // >; rewrite !(emap_comp _ _ _ f g h)//. + case : x => // >; rewrite !(emap_comp _ _ _ f g h, vmap_comp _ _ _ f g h)//. Qed. @@ -228,7 +222,8 @@ Definition kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx Proof. rewrite /fmap /FMap_ectx /bind /BindCore_ectx /kmap /kbind => H. do 2 f_equal. extensionality x. - case: x => [] > //; rewrite !(emap_ebind_pure _ _ _ g)//. + case: x => [] > //; rewrite !(emap_ebind_pure _ _ _ g, + vmap_vbind_pure _ _ _ g)//. Qed. @@ -257,7 +252,8 @@ Definition kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A Proof. rewrite /fmap /FMap_ectx /bind /BindCore_ectx /kmap /kbind => H. rewrite !map_map. do 2 f_equal. extensionality x. - case : x => // >; rewrite !(emap_ebind_comm _ B₁ _ _ f₁ _ g₁)//. + case : x => // >; rewrite !(emap_ebind_comm _ B₁ _ _ f₁ _ g₁, + vmap_vbind_comm _ B₁ _ _ f₁ _ g₁)//. Qed. @@ -290,7 +286,7 @@ Definition kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : Proof. rewrite /bind /BindCore_ectx /kbind => H. rewrite <-List.map_id. do 2 f_equal. - extensionality x. case : x => // >; rewrite !ebind_id//. + extensionality x. case : x => // >; rewrite !(ebind_id, vbind_id)//. Qed. @@ -312,7 +308,8 @@ Definition kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx Proof. rewrite /bind/BindCore_ectx/kbind => H. rewrite map_map. do 2 f_equal. extensionality x. - case : x => // >; rewrite !(ebind_comp _ _ _ _ _ h)//. + case : x => // >; rewrite !(ebind_comp _ _ _ _ _ h, + vbind_comp _ _ _ _ _ h)//. Qed. @@ -358,12 +355,10 @@ Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := Definition ctx_el_to_expr {X : Set} (K : ectx_el X) (e : expr X) : expr X := match K with | OutputK => Output $ e - | IfCondK e1 e2 => If e e1 e2 - | IfTrueK b e2 => If b e e2 - | IfFalseK b e1 => If b e1 e - | AppLK er => App e er + | IfK e1 e2 => If e e1 e2 + | AppLK v => App e (Val v) | AppRK el => App el e - | NatOpLK op er => NatOp op e er + | NatOpLK op v => NatOp op e (Val v) | NatOpRK op el => NatOp op el e | ResetK => Reset e end. @@ -374,23 +369,48 @@ Definition fill {X : Set} (K : ectx X) (e : expr X) : expr X := Fixpoint trim_to_first_reset {X : Set} (K : ectx X) (acc : ectx X) : (ectx X * ectx X) := match K with - | OutputK :: K => trim_to_first_reset K (OutputK :: acc) - | (IfCondK e1 e2) :: K => trim_to_first_reset K ((IfCondK e1 e2) :: acc) - | (IfTrueK b e2) :: K => trim_to_first_reset K ((IfTrueK b e2) :: acc) - | (IfFalseK b e1) :: K => trim_to_first_reset K ((IfFalseK b e1) :: acc) - | (AppLK er) :: K => trim_to_first_reset K ((AppLK er) :: acc) - | (AppRK el) :: K => trim_to_first_reset K ((AppRK el) :: acc) - | (NatOpLK op er) :: K => trim_to_first_reset K ((NatOpLK op er) :: acc) - | (NatOpRK op el) :: K => trim_to_first_reset K ((NatOpRK op el) :: acc) + (* | OutputK :: K => trim_to_first_reset K (OutputK :: acc) *) + (* | (IfK e1 e2) :: K => trim_to_first_reset K ((IfK e1 e2) :: acc) *) + (* | (AppLK v) :: K => trim_to_first_reset K ((AppLK v) :: acc) *) + (* | (AppRK el) :: K => trim_to_first_reset K ((AppRK el) :: acc) *) + (* | (NatOpLK op v) :: K => trim_to_first_reset K ((NatOpLK op v) :: acc) *) + (* | (NatOpRK op el) :: K => trim_to_first_reset K ((NatOpRK op el) :: acc) *) | (ResetK) :: K => (acc, ResetK :: K) + | C :: K => trim_to_first_reset K (C :: acc) | [] => (acc, []) end. + + (* Separate continuation [K] on innermost [reset] *) Definition shift_context {X : Set} (K : ectx X) : (ectx X * ectx X) := let (Ki, Ko) := trim_to_first_reset K [] in (List.rev Ki, Ko). +Lemma trim_to_first_reset_app {X : Set} (K Ki Ko acc : ectx X) : + (Ki, Ko) = trim_to_first_reset K acc -> + (List.rev Ki) ++ Ko = (List.rev acc) ++ K. +Proof. + revert Ki Ko acc. induction K; simpl; intros. + - by inversion H. + - specialize (IHK Ki Ko (a :: acc)) as HI. + destruct a; try (specialize (HI H); rewrite HI; simpl; + rewrite -app_assoc; symmetry; apply cons_middle). + by inversion H. +Qed. + + + +Lemma shift_context_app {X : Set} (K Ki Ko : ectx X) : + (Ki, Ko) = shift_context K -> K = Ki ++ Ko. +Proof. + unfold shift_context. intro. + destruct (trim_to_first_reset K ([])) as [Ki' Ko'] eqn:He. + inversion H. subst. + trans (rev [] ++ K); first auto. symmetry. + by apply trim_to_first_reset_app. +Qed. + (* Only if no reset in K *) Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := @@ -500,9 +520,9 @@ Proof. elim: Ki e; simpl in *; first done. intros. Qed. (* CHECK *) -(* Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K m : *) -(* head_step e1 σ1 e2 σ2 K m → to_val e1 = None. *) -(* Proof. destruct 1; naive_solver. Qed. *) +Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K K' m : + head_step e1 σ1 K e2 σ2 K' m → to_val e1 = None. +Proof. destruct 1; naive_solver. Qed. (* K1 ∘ K2 *) @@ -688,20 +708,11 @@ Global Instance IfNotationExpr {S : Set} {F G H : Set -> Type} `{AsSynExpr F, As __if e₁ e₂ e₃ := If (__asSynExpr e₁) (__asSynExpr e₂) (__asSynExpr e₃) }. -Global Instance IfNotationCondK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : +Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : IfNotation (ectx S) (F S) (G S) (ectx S) := { - __if K e₂ e₃ := K ++ [IfCondK (__asSynExpr e₂) (__asSynExpr e₃)] + __if K e₂ e₃ := K ++ [IfK (__asSynExpr e₂) (__asSynExpr e₃)] }. -Global Instance IfNotationTrueK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : - IfNotation (F S) (ectx S) (G S) (ectx S) := { - __if b K e₃ := K ++ [IfCondK (__asSynExpr b) (__asSynExpr e₃)] - }. - -Global Instance IfNotationFalseK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : - IfNotation (F S) (G S) (ectx S) (ectx S) := { - __if b e2 K := K ++ [IfCondK (__asSynExpr b) (__asSynExpr e2)] - }. Class OutputNotation (A B : Type) := { __output : A -> B }. @@ -741,8 +752,8 @@ 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 (ectx S) (expr S) (ectx S) := { - __app K e := K ++ [AppLK e] +Global Instance AppNotationLK {S : Set} : AppNotation (ectx S) (val S) (ectx S) := { + __app K v := K ++ [AppLK v] }. Global Instance AppNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (ectx S) (ectx S) := { From d68c45b763cf4c1e88a3ba531b7cf4c718feb03d Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 12 Jan 2024 18:05:24 +0100 Subject: [PATCH 080/114] some proof elements in interpretation --- theories/input_lang_delim/interp.v | 69 ++++++++++++++++-------------- 1 file changed, 36 insertions(+), 33 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index ed48418..8a92c97 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -930,39 +930,40 @@ Section interp. Lemma interp_expr_fill_no_reify {S} K K' (env : interp_scope S) (e e' : expr S) σ σ' n : head_step e σ K e' σ' K' (n, 0) → - interp_expr (fill K e) env ≡ - Tick_n n $ interp_expr (fill K' e') env. + ResetK ∉ K-> + interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K' e') env. Proof. - inversion 1; subst. - - rewrite !interp_comp. - erewrite <-hom_tick_n. - + simpl. apply (interp_expr_head_step env) in H. - rewrite equiv_dist => n; f_equiv; move : n; apply equiv_dist. - apply H. - + - - apply (interp_expr_head_step env) in He. - rewrite He. - reflexivity. - - apply _. + inversion 1; subst; intros H1; rewrite !interp_comp; + apply (interp_ectx_hom K' env) in H1. + - rewrite <-hom_tick_n; last eauto. + simpl. apply (interp_expr_head_step env) in H. + by rewrite equiv_dist => n; f_equiv; move : n; apply equiv_dist. + - rewrite <-hom_tick_n; last eauto. apply (interp_expr_head_step env) in H. + by rewrite H. + - rewrite <-hom_tick_n; last eauto. apply (interp_expr_head_step env) in H. + by rewrite H. + - rewrite <-hom_tick_n; last eauto. apply (interp_expr_head_step env) in H. + by rewrite H. Qed. - Opaque INPUT OUTPUT_ CALLCC CALLCC_ THROW. + Opaque INPUT OUTPUT_ SHIFT RESET. Opaque extend_scope. Opaque Ret. - Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) + Lemma interp_expr_fill_yes_reify {S} K K' env (e e' : expr S) (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : - head_step e σ e' σ' K (n, 1) → + head_step e σ K e' σ' K' (n, 1) → + ResetK ∉ K-> reify (gReifiers_sReifier rs) (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) - ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K' e') env). Proof. - intros Hst. + intros Hst H1. apply (interp_ectx_hom K env) in H1. trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) (gState_recomp σr (sR_state σ))). { f_equiv. by rewrite interp_comp. } inversion Hst; simplify_eq; cbn-[gState_recomp]. - - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). + - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K' env ◎ Ret)) (gState_recomp σr (sR_state σ))). { repeat f_equiv; eauto. rewrite hom_INPUT. @@ -970,30 +971,30 @@ Section interp. } rewrite reify_vis_eq //; first last. { - epose proof (@subReifier_reify sz reify_io rs _ IT _ (inl ()) () (Next (interp_ectx K env (Ret n0))) (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr) as H. + epose proof (@subReifier_reify sz reify_io rs _ IT _ (inl ()) () (Next (interp_ectx K' env (Ret n0))) (NextO ◎ (interp_ectx K' env ◎ Ret)) σ σ' σr) as H. simpl in H. simpl. erewrite <-H; last first. - - rewrite H5. reflexivity. + - rewrite H7. reflexivity. - f_equiv; solve_proper. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. reflexivity. - - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). + - trans (reify (gReifiers_sReifier rs) (interp_ectx K' env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). { do 3 f_equiv; eauto. rewrite get_ret_ret//. } - trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). + trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K' env (Ret 0))) (gState_recomp σr (sR_state σ))). { do 2 f_equiv; eauto. by rewrite hom_OUTPUT_. } rewrite reify_vis_eq //; last first. { - epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inl ())) n0 (Next (interp_ectx K env ((Ret 0)))) (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. + epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inl ())) n0 (Next (interp_ectx K' env ((Ret 0)))) (constO (Next (interp_ectx K' env ((Ret 0))))) σ (update_output n0 σ) σr) as H. simpl in H. simpl. erewrite <-H; last reflexivity. @@ -1005,19 +1006,20 @@ Section interp. rewrite interp_comp. reflexivity. - match goal with - | |- context G [ofe_mor_car _ _ (CALLCC) ?g] => set (f := g) + | |- context G [ofe_mor_car _ _ (SHIFT) ?g] => set (f := g) end. match goal with | |- context G [(?s, _)] => set (gσ := s) end. - Transparent CALLCC. - unfold CALLCC. + Transparent SHIFT. + unfold SHIFT. simpl. set (subEff1 := @subReifier_subEff sz reify_io rs subR). - trans (reify (gReifiers_sReifier rs) (CALLCC_ f (laterO_map (interp_ectx K env))) gσ). + trans (reify (gReifiers_sReifier rs) + (SHIFT_ f (laterO_map (λne y, interp_ectx K env y) ◎ idfun)) gσ). { do 2 f_equiv. - rewrite hom_CALLCC_. - f_equiv. by intro. + rewrite -(@hom_SHIFT_ F R CR subEff1 idfun f _). + by f_equiv. } rewrite reify_vis_eq//; last first. { @@ -1027,8 +1029,9 @@ Section interp. (laterO_map (interp_ectx K env)) σ' σ' σr) as H. simpl in H. erewrite <-H; last reflexivity. - f_equiv; last done. - intros ???. by rewrite /prod_map H0. + f_equiv. + + intros ???. by rewrite /prod_map H2. + + do 3f_equiv; try done. by intro. } rewrite interp_comp. rewrite interp_expr_subst. @@ -1036,7 +1039,7 @@ Section interp. rewrite Tick_eq. f_equiv. rewrite laterO_map_Next. - do 3 f_equiv. + f_equiv. Transparent extend_scope. intros [| x]; term_simpl; last reflexivity. do 2 f_equiv. by intro. From cb5d7e9fdcf55075053a140cde05f872d2e75de0 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Mon, 15 Jan 2024 18:06:21 +0100 Subject: [PATCH 081/114] better head_step and prim_step, work on soundness --- theories/input_lang_delim/interp.v | 96 +++++++++++++++++++----------- theories/input_lang_delim/lang.v | 78 ++++++++++++++---------- 2 files changed, 108 insertions(+), 66 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 8a92c97..30e56b5 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -62,7 +62,7 @@ Qed. Definition reify_shift X `{Cofe X} : ((laterO X -n> laterO X) -n> laterO X) * stateO * (laterO X -n> laterO X) → option (laterO X * stateO) := - λ '(f, σ, k), Some ((k (f k): laterO X), σ : stateO). + λ '(f, σ, k), Some ((f k): laterO X, σ : stateO). #[export] Instance reify_callcc_ne X `{Cofe X} : NonExpansive (reify_shift X : prodO (prodO ((laterO X -n> laterO X) -n> laterO X) stateO) @@ -287,27 +287,22 @@ Section weakestpre. Lemma wp_shift (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} Φ s : has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} idfun (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. Proof. iIntros "Hs Ha". unfold SHIFT. simpl. rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ ((later_map k ((f (laterO_map k))))) with "Hs"). + iApply (wp_subreify _ _ _ _ _ _ _ ((later_map idfun ((f (laterO_map k))))) with "Hs"). { simpl. repeat f_equiv. - - rewrite ofe_iso_21. - f_equiv. - intro; simpl. - f_equiv. - apply ofe_iso_21. + - rewrite ccompose_id_l later_map_id. + f_equiv. intro x. simpl. + by rewrite ofe_iso_21. - reflexivity. } - { - rewrite later_map_Next. - reflexivity. - } + { by rewrite later_map_Next. } iModIntro. iApply "Ha". Qed. @@ -668,20 +663,26 @@ Section interp. iIntros (y'). destruct y' as [| [| y]]; simpl; first done; last done. by iRewrite - "IH". - (* - destruct e; simpl; intros ?; simpl. *) - (* + reflexivity. *) - (* + repeat f_equiv; by apply interp_ectx_ren. *) - (* + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_expr_ren | by apply interp_expr_ren]. *) - (* + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. *) - (* + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. *) - (* + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. *) - (* + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. *) - (* + repeat f_equiv; last by apply interp_ectx_ren. *) - (* intros ?; simpl; repeat f_equiv; by apply interp_expr_ren. *) - (* + repeat f_equiv; last by apply interp_val_ren. *) - (* intros ?; simpl; repeat f_equiv; first by apply interp_ectx_ren. *) Qed. + + Lemma interp_ectx_ren {S S'} env (δ : S [→] S') (K : ectx S) : + interp_ectx (fmap δ K) env ≡ interp_ectx K (ren_scope δ env). + Proof. + (* unfold interp_ectx. intro. simpl. *) + (* generalize env x. *) + induction K; intros ?; simpl; eauto. + destruct a; simpl. + - etrans; first by apply IHK. repeat f_equiv. + - etrans; first by apply IHK. repeat f_equiv; by apply interp_expr_ren. + - etrans; first by apply IHK. repeat f_equiv; by apply interp_val_ren. + - etrans; first by apply IHK. repeat f_equiv; by apply interp_expr_ren. + - etrans; first by apply IHK. repeat f_equiv; by apply interp_val_ren. + - etrans; first by apply IHK. repeat f_equiv; by apply interp_expr_ren. + - etrans; first by apply IHK. repeat f_equiv; by apply interp_expr_ren. + Qed. + + Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). Proof. @@ -1010,8 +1011,8 @@ Section interp. end. match goal with | |- context G [(?s, _)] => set (gσ := s) end. - Transparent SHIFT. - unfold SHIFT. + (* Transparent SHIFT. *) + (* unfold SHIFT. *) simpl. set (subEff1 := @subReifier_subEff sz reify_io rs subR). trans (reify (gReifiers_sReifier rs) @@ -1019,13 +1020,13 @@ Section interp. { do 2 f_equiv. rewrite -(@hom_SHIFT_ F R CR subEff1 idfun f _). - by f_equiv. + by f_equiv. } rewrite reify_vis_eq//; last first. { simpl. epose proof (@subReifier_reify sz reify_io rs subR IT _ - (inr (inr (inl ()))) f _ + op_shift f _ (laterO_map (interp_ectx K env)) σ' σ' σr) as H. simpl in H. erewrite <-H; last reflexivity. @@ -1033,16 +1034,41 @@ Section interp. + intros ???. by rewrite /prod_map H2. + do 3f_equiv; try done. by intro. } - rewrite interp_comp. - rewrite interp_expr_subst. - f_equiv. - rewrite Tick_eq. - f_equiv. - rewrite laterO_map_Next. + (* simpl. *) + (* rewrite interp_comp. *) f_equiv. + rewrite -Tick_eq. + unfold cont_to_rec. + rewrite interp_expr_subst. + Disable Notation "λit". + simpl. f_equiv. + (* rewrite laterO_map_Next. *) Transparent extend_scope. + f_equiv. + intros [| x]; term_simpl; last reflexivity. - do 2 f_equiv. by intro. + rewrite interp_rec_unfold. + do 2 f_equiv. intro. + Opaque extend_scope. + simpl. + rewrite laterO_map_Next -Tick_eq. + rewrite interp_comp. + symmetry. etrans; first by apply interp_ectx_ren. + etrans; first by apply interp_ectx_ren. + rewrite -hom_tick. + match goal with + | |- context G [(interp_ectx K ?e)] => set (env' := e) + end. + trans (interp_ectx K env' (Tick x)). + + f_equiv. Transparent extend_scope. + simpl. admit. + + admit. + - + rewrite -(interp_comp). + f_equiv. + + f_equiv. + + Qed. Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index c1fe453..ab3bd2b 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -328,8 +328,8 @@ Qed. -Definition LamV {S : Set} (e : expr (inc S)) : val S := - RecV (shift e). +(* Definition LamV {S : Set} (e : expr (inc S)) : val S := *) +(* RecV (shift e). *) Definition to_val {S} (e : expr S) : option (val S) := @@ -414,8 +414,9 @@ Qed. (* Only if no reset in K *) Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := - LamV (fill (shift K) (Var VZ)). + RecV (fill (shift (shift K)) (Var VZ)). +Example test1 : val (inc ∅) := (cont_to_rec [OutputK; AppRK (Var VZ)]). (* Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) *) (* : fmap f (fill K e) = fill (fmap f K) (fmap f e). *) @@ -474,10 +475,10 @@ Variant head_step {S} : expr S → state -> ectx S → head_step (If (Val (LitV n)) e1 e2) σ K e2 σ K (0, 0) - | ShiftS e σ K Ki Ko f: - ((Ki, Ko) = shift_context K) -> - f = cont_to_rec Ki -> - head_step (Shift e) σ K (subst (Inc := inc) e (Val f)) σ Ko (1, 1) + | ShiftS e σ K f: + ResetK ∉ K -> + f = cont_to_rec K -> + head_step (Shift e) σ K (subst (Inc := inc) e (Val f)) σ [] (1, 1) | ResetS v σ K : head_step (Reset (Val v)) σ K (Val v) σ K (1, 1). @@ -494,9 +495,9 @@ Variant head_step {S} : expr S → state -> ectx S → Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : head_step e1 σ1 K e2 σ2 K' (n,m) → m = 0 ∨ m = 1. Proof. inversion 1; eauto. Qed. -Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : - head_step e1 σ1 K e2 σ2 K' (n,m) → n = 0 ∨ n = 1. -Proof. inversion 1; eauto. Qed. +(* Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : *) +(* head_step e1 σ1 K e2 σ2 K' (n,m) → n = 0 ∨ n = 1. *) +(* Proof. inversion 1; eauto. Qed. *) Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K K' n : head_step e1 σ1 K e2 σ2 K' (n,0) → σ1 = σ2. Proof. inversion 1; eauto. Qed. @@ -549,10 +550,16 @@ Proof. by rewrite fill_app. Qed. (* FIXME maybe *) Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) - (e2 : expr S) (σ2 : state) (n : nat * nat), Prop := -| Ectx_step e1 σ1 e2 σ2 n (K1 K2 : ectx S) e1' e2' : - e1 = fill K1 e1' → e2 = fill K2 e2' → - head_step e1' σ1 K1 e2' σ2 K2 n → prim_step e1 σ1 e2 σ2 n. + (e2 : expr S) (σ2 : state) (nm : nat * nat), Prop := +| Ectx_step e1 σ1 e2 σ2 nm (K1 K2 : ectx S) e1' e2' : + e1 = fill K1 e1' -> + e2 = fill K2 e2' -> + head_step e1' σ1 K1 e2' σ2 K2 nm -> + prim_step e1 σ1 e2 σ2 nm +| Shift_step e1 σ1 K Ki Ko e2 σ2 Ki' nm : + (Ki, Ko) = shift_context K -> + head_step e1 σ1 Ki e2 σ2 Ki' nm -> + prim_step (fill K e1) σ1 (fill (Ki' ++ Ko) e2) σ2 nm. (* | App_cont_step e1 σ e2 (K : ectx S) v K' : *) (* e1 = (fill K (App (Val $ ContV K') (Val v))) -> *) (* e2 = (fill K' (Val v)) -> *) @@ -563,7 +570,8 @@ Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. Proof. inversion 1; simplify_eq/=. - by inversion H2. + + by inversion H2. + + by inversion H1. Qed. Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat → Prop := @@ -780,17 +788,17 @@ Notation "'$' fn" := (set_pure_resolver fn) (at level 60) : 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. +(* 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). +(* 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. +(* 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'. +(* 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. +(* Notation "e₁ ';;' e₂" := (SeqE e₁%syn e₂%syn) : syn_scope. *) Declare Scope typ_scope. Delimit Scope typ_scope with typ. @@ -822,12 +830,12 @@ Module SynExamples. 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 test21 : val ∅ := (lam (if ($ 0) then # 1 else #0)). *) Example test3 : expr ∅ := (shift/cc ($ 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))). + (* Example test7 : expr ∅ := (let_ ((rec (if ($ 1) then # 1 else (($ 0) ⋆ (($ 1) - (# 1))))) ⋆ (# 5)) in (output ($ 0))). *) Open Scope typing_scope. @@ -858,16 +866,24 @@ Definition compute_head_step {S} 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)) + (* | (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 ∅) * state * ectx (inc ∅) * (nat * nat)) := + (compute_head_step (App (Val test1) (Val $ LitV 5)) (State [] []) []). +Eval compute in testc. + + Lemma head_step_reflect {S : Set} (e : expr S) (σ : state) (K : ectx S) : option_reflect (fun '(e', σ', K', nm) => head_step e σ K e' σ' K' nm) True @@ -911,9 +927,9 @@ Proof. 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 (shift_context K) as [Ki Ko] eqn:HK. *) + (* constructor. apply ShiftS with Ki =>//=. *) - simpl. destruct e; try (by constructor). do 2 constructor. From a317e082fbe50f3529b3a5016cc8399a60afa421 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 16 Jan 2024 13:47:08 +0100 Subject: [PATCH 082/114] reify reset, still some admits on shift --- theories/input_lang_delim/interp.v | 69 ++++++++++++++++++++++++------ 1 file changed, 55 insertions(+), 14 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 30e56b5..a20f27d 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -154,11 +154,22 @@ Section constructors. λne f, SHIFT_ f (idfun). Solve Obligations with solve_proper. + (* Program Definition RESET : laterO IT -n> IT := *) + (* λne e, Vis (E:=E) (subEff_opid op_reset) *) + (* (subEff_ins (F := ioE) (op := op_reset) e) *) + (* (subEff_outs (F := ioE) (op := op_reset)^-1). *) + (* Solve All Obligations with solve_proper. *) + + 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 := ioE) (op := op_reset) e) + (k ◎ subEff_outs (F := ioE) (op := op_reset)^-1). + Solve Obligations with solve_proper. + Program Definition RESET : laterO IT -n> IT := - λne e, Vis (E:=E) (subEff_opid op_reset) - (subEff_ins (F := ioE) (op := op_reset) e) - (subEff_outs (F := ioE) (op := op_reset)^-1). - Solve All Obligations with solve_proper. + RESET_ idfun. Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). @@ -360,6 +371,10 @@ Section interp. repeat f_equiv. Qed. + (* Program Definition interp_reset {S} (e : S -n> IT) : S -n> IT := *) + (* λne env, get_val idfun (RESET (Next (e env))). *) + (* Solve All Obligations with solve_proper_please. *) + Program Definition interp_reset {S} (e : S -n> IT) : S -n> IT := λne env, get_val idfun (RESET (Next (e env))). Solve All Obligations with solve_proper_please. @@ -590,7 +605,9 @@ Section interp. Definition interp_ectx {S} (K : ectx S) : interp_scope S → (IT -n> IT) := λ env, OfeMor (interp_ectx' K env). - (* Example test_ectx : ectx ∅ := [OutputK ; AppRK (LamV (Var VZ))]. *) + Example test_ectx : ectx ∅ := [OutputK ; AppRK (RecV (Var VZ))]. + (* Eval cbv[test_ectx interp_ectx interp_ectx' interp_ectx_el *) + (* interp_apprk interp_outputk interp_output interp_app] in (interp_ectx test_ectx). *) (* Definition interp_ectx {S} (K : ectx S) : interp_scope S -n> IT -n> IT := *) (* λne env e, *) (* (fold_left (λ k c, λne (e : interp_scope S -n> IT), *) @@ -869,9 +886,8 @@ Section interp. IT_hom (interp_ectx ([ResetK] : ectx S) env) -> False. Proof. intros [ _ Hi _ _ ]. simpl in Hi. - specialize (Hi (Ret 0)). - rewrite -hom_tick in Hi. - rewrite get_val_tick get_val_vis in Hi. + specialize (Hi (Ret 0)). + rewrite hom_vis in Hi. apply bi.siProp.pure_soundness. iApply IT_tick_vis_ne. iPureIntro. @@ -995,7 +1011,10 @@ Section interp. } rewrite reify_vis_eq //; last first. { - epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inl ())) n0 (Next (interp_ectx K' env ((Ret 0)))) (constO (Next (interp_ectx K' env ((Ret 0))))) σ (update_output n0 σ) σr) as H. + epose proof (@subReifier_reify sz reify_io rs _ IT _ op_output + n0 (Next (interp_ectx K' env ((Ret 0)))) + (constO (Next (interp_ectx K' env ((Ret 0))))) + σ (update_output n0 σ) σr) as H. simpl in H. simpl. erewrite <-H; last reflexivity. @@ -1063,12 +1082,34 @@ Section interp. + f_equiv. Transparent extend_scope. simpl. admit. + admit. - - - rewrite -(interp_comp). + - Transparent RESET. unfold RESET. + trans (reify (gReifiers_sReifier rs) + (RESET_ (laterO_map (λne y, interp_ectx' K' env y) ◎ + (laterO_map (λne y, get_val idfun y)) ◎ + idfun) + (Next (interp_val v env))) + (gState_recomp σr (sR_state σ'))). + { + do 2 f_equiv; last done. + rewrite !hom_vis. simpl. f_equiv. + by intro x. + } + rewrite reify_vis_eq//; last first. + { + simpl. + epose proof (@subReifier_reify sz reify_io rs subR IT _ + op_reset (Next (interp_val v env)) _ + (laterO_map (interp_ectx K' env) ◎ + laterO_map (get_val idfun)) σ' σ' σr) as H. + simpl in H. erewrite <-H; last reflexivity. + f_equiv. + + intros ???. by rewrite /prod_map H0. + + do 2 f_equiv. by intro x. + } f_equiv. - + f_equiv. - - + rewrite laterO_map_Next -Tick_eq. f_equiv. + rewrite interp_comp. f_equiv. + simpl. by rewrite get_val_ITV. Qed. Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : From ef6848f5ec6a7f7546703bf2be870a48a4053acd Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 17 Jan 2024 16:45:05 +0100 Subject: [PATCH 083/114] Changed op sem for shift but still extra tick --- theories/input_lang_delim/interp.v | 156 +++++++++++++++++------------ theories/input_lang_delim/lang.v | 15 +-- 2 files changed, 100 insertions(+), 71 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index a20f27d..34a781d 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -63,7 +63,7 @@ Definition reify_shift X `{Cofe X} : ((laterO X -n> laterO X) -n> laterO X) * stateO * (laterO X -n> laterO X) → option (laterO X * stateO) := λ '(f, σ, k), Some ((f k): laterO X, σ : stateO). -#[export] Instance reify_callcc_ne X `{Cofe X} : +#[export] Instance reify_shift_ne X `{Cofe X} : NonExpansive (reify_shift X : prodO (prodO ((laterO X -n> laterO X) -n> laterO X) stateO) (laterO X -n> laterO X) → @@ -346,35 +346,49 @@ Section interp. Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). Proof. solve_proper. Qed. - Program Definition interp_shift {S} - (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := - λne env, SHIFT (λne (f : laterO IT -n> laterO IT), - (Next (e (@extend_scope F R _ _ env - (Fun (Next (λne x, Tau (f (Next x))))))))). + (* Program Definition interp_shift {S} *) + (* (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := *) + (* λne env, SHIFT (λne (k : laterO IT -n> laterO IT), *) + (* (Next (e (@extend_scope F R _ _ env *) + (* (Fun (Next (λne x, Tau (k (Next x))))))))). *) + (* Next Obligation. *) + (* solve_proper. *) + (* Qed. *) + (* Next Obligation. *) + (* solve_proper_prepare. *) + (* repeat f_equiv. *) + (* intros [| a]; simpl; last solve_proper. *) + (* repeat f_equiv. *) + (* intros ?; simpl. *) + (* by repeat f_equiv. *) + (* Qed. *) + (* Next Obligation. *) + (* solve_proper_prepare. *) + (* repeat f_equiv. *) + (* intros ?; simpl. *) + (* repeat f_equiv. *) + (* intros [| a]; simpl; last solve_proper. *) + (* repeat f_equiv. *) + (* Qed. *) + + Program Definition interp_shift {S} (e : S -n> IT) : S -n> IT := + λne env, get_fun (λne (f : laterO (IT -n> IT)), + SHIFT (λne (k : laterO IT -n> laterO IT), + laterO_ap f (Next (λit x, Tau (k (Next x)))))) (e env). + Solve Obligations with solve_proper. Next Obligation. - solve_proper. + solve_proper_prepare. repeat f_equiv. intro. simpl. by repeat f_equiv. Qed. Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros [| a]; simpl; last solve_proper. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. + Opaque laterO_ap. + solve_proper_prepare. repeat f_equiv. intro. simpl. + by apply later_ap_ne. + Transparent laterO_ap. Qed. Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intros ?; simpl. - repeat f_equiv. - intros [| a]; simpl; last solve_proper. - repeat f_equiv. + solve_proper_prepare. by repeat f_equiv. Qed. - (* Program Definition interp_reset {S} (e : S -n> IT) : S -n> IT := *) - (* λne env, get_val idfun (RESET (Next (e env))). *) - (* Solve All Obligations with solve_proper_please. *) - Program Definition interp_reset {S} (e : S -n> IT) : S -n> IT := λne env, get_val idfun (RESET (Next (e env))). Solve All Obligations with solve_proper_please. @@ -656,14 +670,14 @@ Section interp. (* interp_ectx (fmap δ e) env ≡ interp_ectx e (ren_scope δ env). *) Proof. - destruct e; simpl; try by repeat f_equiv. - repeat f_equiv. - intros ?; simpl. - repeat f_equiv. - simpl; rewrite interp_expr_ren. - f_equiv. - intros [| y]; simpl. - + reflexivity. - + reflexivity. + (* repeat f_equiv. *) + (* intros ?; simpl. *) + (* repeat f_equiv. *) + (* simpl; rewrite interp_expr_ren. *) + (* f_equiv. *) + (* intros [| y]; simpl. *) + (* + reflexivity. *) + (* + reflexivity. *) - destruct e; simpl. + reflexivity. + clear -interp_expr_ren. @@ -735,16 +749,16 @@ Section interp. (* interp_ectx (bind δ e) env ≡ interp_ectx e (sub_scope δ env). *) Proof. - destruct e; simpl; try by repeat f_equiv. - repeat f_equiv. - intros ?; simpl. - repeat f_equiv. - rewrite interp_expr_subst. - f_equiv. - intros [| x']; simpl. - + reflexivity. - + rewrite interp_expr_ren. - f_equiv. - intros ?; reflexivity. + (* repeat f_equiv. *) + (* intros ?; simpl. *) + (* repeat f_equiv. *) + (* rewrite interp_expr_subst. *) + (* f_equiv. *) + (* intros [| x']; simpl. *) + (* + reflexivity. *) + (* + rewrite interp_expr_ren. *) + (* f_equiv. *) + (* intros ?; reflexivity. *) - destruct e; simpl. + reflexivity. + clear -interp_expr_subst. @@ -1025,15 +1039,29 @@ Section interp. repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. reflexivity. - - match goal with - | |- context G [ofe_mor_car _ _ (SHIFT) ?g] => set (f := g) + - + match goal with + | |- context G + [(ofe_mor_car _ _ (get_fun (?g)) + ?e)] => set (f := g) end. match goal with | |- context G [(?s, _)] => set (gσ := s) end. (* Transparent SHIFT. *) (* unfold SHIFT. *) - simpl. set (subEff1 := @subReifier_subEff sz reify_io rs subR). + trans (reify (gReifiers_sReifier rs) + (interp_ectx' K env + (get_fun f (Fun (Next (ir_unf (interp_expr e0) env))))) gσ). + { repeat f_equiv. apply interp_rec_unfold. } + trans (reify (gReifiers_sReifier rs) + (interp_ectx' K env + (f (Next (ir_unf (interp_expr e0) env)))) gσ). + { repeat f_equiv. apply get_fun_fun. } + subst f. simpl. + match goal with + | |- context G [(ofe_mor_car _ _ SHIFT ?g)] => set (f := g) + end. trans (reify (gReifiers_sReifier rs) (SHIFT_ f (laterO_map (λne y, interp_ectx K env y) ◎ idfun)) gσ). { @@ -1053,35 +1081,35 @@ Section interp. + intros ???. by rewrite /prod_map H2. + do 3f_equiv; try done. by intro. } - (* simpl. *) - (* rewrite interp_comp. *) + clear f. f_equiv. - rewrite -Tick_eq. - unfold cont_to_rec. - rewrite interp_expr_subst. - Disable Notation "λit". - simpl. f_equiv. + trans ((Fun $ Next $ ir_unf (interp_expr e0) env) + ⊙ (Fun $ Next $ ir_unf (interp_expr (shift (shift K) ⟪ Var VZ ⟫)%syn) env) + ); last first. + { repeat f_equiv; by rewrite interp_rec_unfold. } + rewrite APP'_Fun_r APP_Fun -!Tick_eq. simpl. + repeat f_equiv. + intro. simpl. + rewrite interp_comp. (* rewrite laterO_map_Next. *) - Transparent extend_scope. - f_equiv. - - intros [| x]; term_simpl; last reflexivity. - rewrite interp_rec_unfold. - do 2 f_equiv. intro. - Opaque extend_scope. - simpl. - rewrite laterO_map_Next -Tick_eq. - rewrite interp_comp. + (* Transparent extend_scope. *) + (* intros [| x]; term_simpl; last reflexivity. *) + (* rewrite interp_rec_unfold. *) + (* do 2 f_equiv. intro. *) + (* Opaque extend_scope. *) + (* rewrite laterO_map_Next -Tick_eq. *) + (* rewrite interp_comp. *) symmetry. etrans; first by apply interp_ectx_ren. etrans; first by apply interp_ectx_ren. - rewrite -hom_tick. + (* rewrite -hom_tick. *) match goal with | |- context G [(interp_ectx K ?e)] => set (env' := e) end. + rewrite laterO_map_Next -Tick_eq. trans (interp_ectx K env' (Tick x)). + f_equiv. Transparent extend_scope. simpl. admit. - + admit. + + simpl. admit. - Transparent RESET. unfold RESET. trans (reify (gReifiers_sReifier rs) (RESET_ (laterO_map (λne y, interp_ectx' K' env y) ◎ @@ -1109,7 +1137,7 @@ Section interp. f_equiv. rewrite laterO_map_Next -Tick_eq. f_equiv. rewrite interp_comp. f_equiv. - simpl. by rewrite get_val_ITV. + simpl. by rewrite get_val_ITV. Qed. Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index ab3bd2b..ca94fe4 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -23,7 +23,7 @@ Inductive expr {X : Set} := (* The effects *) | Input : expr | Output (e : expr) : expr -| Shift (e : @expr (inc X)) : expr +| Shift (e : expr) : expr | Reset (e : expr) : expr with val {X : Set} := | LitV (n : nat) : val @@ -63,7 +63,7 @@ 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₃) | Input => Input | Output e => Output (emap f e) - | Shift e => Shift (emap (f ↑) e) + | Shift e => Shift (emap f e) | Reset e => Reset (emap f e) end with @@ -101,7 +101,7 @@ 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₃) | Input => Input | Output e => Output (ebind f e) - | Shift e => Shift (ebind (f ↑) e) + | Shift e => Shift (ebind f e) | Reset e => Reset (ebind f e) end with @@ -475,10 +475,11 @@ Variant head_step {S} : expr S → state -> ectx S → head_step (If (Val (LitV n)) e1 e2) σ K e2 σ K (0, 0) - | ShiftS e σ K f: + | ShiftS (e : expr (inc (inc S))) σ K f: ResetK ∉ K -> f = cont_to_rec K -> - head_step (Shift e) σ K (subst (Inc := inc) e (Val f)) σ [] (1, 1) + head_step (Shift (Val $ RecV e)) σ K + (App (Val $ RecV e) (Val f)) σ [] (0, 1) | ResetS v σ K : head_step (Reset (Val v)) σ K (Val v) σ K (1, 1). @@ -658,7 +659,7 @@ Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := (* typed Γ e2 (Tcont τ) -> *) (* typed Γ (Throw e1 e2) τ' *) | typed_Shift e τ : - typed (Γ ▹ Tcont τ) e τ -> + typed Γ e (Tarr (Tcont τ) τ) -> typed Γ (Shift e) τ | typed_App_Cont (τ τ' : ty) e1 e2 : typed Γ e1 (Tcont τ) -> @@ -831,7 +832,7 @@ Module SynExamples. 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 ($ 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). From 1b6ede9a2cd4ac1b26239e13907801e6480e922f Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 18 Jan 2024 13:52:02 +0100 Subject: [PATCH 084/114] yes_reify OK --- theories/input_lang_delim/interp.v | 113 ++++++++++++++++++++--------- theories/input_lang_delim/lang.v | 13 +++- 2 files changed, 89 insertions(+), 37 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 34a781d..b533657 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -491,10 +491,24 @@ Section interp. Program Definition interp_nat (n : nat) {A} : A -n> IT := λne env, Ret n. - (* Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := *) - (* λne env, (Fun (Next (λne x, Tau (laterO_map (K env) (Next x))))). *) - (* Solve All Obligations with solve_proper_please. *) + Program Definition interp_cont {S} (e : @interp_scope F R _ (inc S) -n> IT) : + interp_scope S -n> IT := + λne env, (Fun (Next (λne x, Tick $ e (@extend_scope F R _ _ env x)))). + Next Obligation. + solve_proper_prepare. repeat f_equiv. + intros [|a]; eauto. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intro. simpl. repeat f_equiv. + intros [|z]; eauto. + Qed. + (* (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := *) + (* λne env, SHIFT (λne (k : laterO IT -n> laterO IT), *) + (* (Next (e (@extend_scope F R _ _ env *) + (* (Fun (Next (λne x, Tau (k (Next x))))))))). *) @@ -531,7 +545,7 @@ Section interp. match v with | LitV n => interp_nat n | RecV e => interp_rec (interp_expr e) - (* | ContV K => interp_cont (interp_ectx K) *) + | ContV e => interp_cont (interp_expr e) end with interp_expr {S} (e : expr S) : interp_scope S -n> IT := @@ -606,18 +620,37 @@ Section interp. Fixpoint interp_ectx' {S} (K : ectx S) : - interp_scope S → IT → IT := + interp_scope S -> IT -> IT := match K with | [] => λ env, idfun - | C :: K => λ (env : interp_scope S) (t : IT), + | C :: K => λ (env : interp_scope S), λ (t : IT), (interp_ectx' K env) (interp_ectx_el C (λne env, t) env) end. #[export] Instance interp_ectx_1_ne {S} (K : ectx S) (env : interp_scope S) : NonExpansive (interp_ectx' K env : IT → IT). Proof. induction K; solve_proper_please. Qed. - Definition interp_ectx {S} (K : ectx S) : interp_scope S → (IT -n> IT) := - λ env, OfeMor (interp_ectx' K env). + Definition interp_ectx'' {S} (K : ectx S) (env : interp_scope S) : IT -n> IT := + OfeMor (interp_ectx' K env). + + Lemma interp_ectx''_cons {S} (env : interp_scope S) + (K : ectx S) (C : ectx_el S) (x : IT) (n : nat) : + interp_ectx'' (C :: K) env x ≡{n}≡ interp_ectx'' K env (interp_ectx_el C (λne _, x) env). + Proof. done. Qed. + + #[export] Instance interp_ectx_2_ne {S} (K : ectx S) : + NonExpansive (interp_ectx'' K : interp_scope S → (IT -n> IT)). + Proof. + induction K; intros ????; try by intro. + intro. + rewrite !interp_ectx''_cons. + f_equiv. + - by apply IHK. + - by f_equiv. + Qed. + + Definition interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := + OfeMor (interp_ectx'' K). Example test_ectx : ectx ∅ := [OutputK ; AppRK (RecV (Var VZ))]. (* Eval cbv[test_ectx interp_ectx interp_ectx' interp_ectx_el *) @@ -641,6 +674,7 @@ Section interp. destruct v; simpl. - apply _. - rewrite interp_rec_unfold. apply _. + - apply _. Qed. Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := @@ -694,6 +728,10 @@ Section interp. iIntros (y'). destruct y' as [| [| y]]; simpl; first done; last done. by iRewrite - "IH". + + repeat f_equiv. + intro. simpl. + rewrite interp_expr_ren. repeat f_equiv. + intros [|?]; eauto. Qed. @@ -780,6 +818,11 @@ Section interp. iApply internal_eq_pointwise. iIntros (z). done. + + repeat f_equiv. intro. simpl. + rewrite interp_expr_subst. repeat f_equiv. + intros [|?]; eauto. simpl. + rewrite interp_expr_ren. f_equiv. + by intro. Qed. @@ -948,6 +991,13 @@ Section interp. rewrite interp_val_ren. f_equiv. intros ?; simpl; reflexivity. + - (* continuations *) + subst. + erewrite APP_APP'_ITV; last apply _. + rewrite APP_Fun. simpl. rewrite -Tick_eq. do 2 f_equiv. + rewrite interp_expr_subst. + f_equiv. + intros [|?]; eauto. - (* the natop stuff *) simplify_eq. destruct v1,v2; try naive_solver. simpl in *. @@ -975,6 +1025,8 @@ Section interp. by rewrite H. - rewrite <-hom_tick_n; last eauto. apply (interp_expr_head_step env) in H. by rewrite H. + - rewrite <-hom_tick_n; last eauto. apply (interp_expr_head_step env) in H. + by rewrite H. Qed. Opaque INPUT OUTPUT_ SHIFT RESET. @@ -1083,33 +1135,27 @@ Section interp. } clear f. f_equiv. - trans ((Fun $ Next $ ir_unf (interp_expr e0) env) - ⊙ (Fun $ Next $ ir_unf (interp_expr (shift (shift K) ⟪ Var VZ ⟫)%syn) env) - ); last first. - { repeat f_equiv; by rewrite interp_rec_unfold. } - rewrite APP'_Fun_r APP_Fun -!Tick_eq. simpl. + rewrite APP'_Fun_r. + match goal with + | |- context G [(ofe_mor_car _ _ (ofe_mor_car _ _ APP _) ?f)] => + trans (APP (Fun $ Next $ ir_unf (interp_expr e0) env) f); last first + end. + { repeat f_equiv; try by rewrite interp_rec_unfold. } + rewrite APP_Fun -!Tick_eq. simpl. repeat f_equiv. intro. simpl. - rewrite interp_comp. - (* rewrite laterO_map_Next. *) - (* Transparent extend_scope. *) - (* intros [| x]; term_simpl; last reflexivity. *) - (* rewrite interp_rec_unfold. *) - (* do 2 f_equiv. intro. *) - (* Opaque extend_scope. *) - (* rewrite laterO_map_Next -Tick_eq. *) - (* rewrite interp_comp. *) - symmetry. etrans; first by apply interp_ectx_ren. + rewrite interp_comp laterO_map_Next -Tick_eq. f_equiv. + symmetry. + Transparent extend_scope. + fold (@interp_ectx S K env). + Opaque interp_ectx. + simpl. etrans; first by apply interp_ectx_ren. - (* rewrite -hom_tick. *) - match goal with - | |- context G [(interp_ectx K ?e)] => set (env' := e) - end. - rewrite laterO_map_Next -Tick_eq. - trans (interp_ectx K env' (Tick x)). - + f_equiv. Transparent extend_scope. - simpl. admit. - + simpl. admit. + repeat f_equiv. + unfold ren_scope. simpl. + apply ofe_mor_ext. done. + Transparent interp_ectx. + Opaque extend_scope. - Transparent RESET. unfold RESET. trans (reify (gReifiers_sReifier rs) (RESET_ (laterO_map (λne y, interp_ectx' K' env y) ◎ @@ -1137,7 +1183,8 @@ Section interp. f_equiv. rewrite laterO_map_Next -Tick_eq. f_equiv. rewrite interp_comp. f_equiv. - simpl. by rewrite get_val_ITV. + + done. + + simpl. by rewrite get_val_ITV. Qed. Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index ca94fe4..748adf0 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -27,7 +27,8 @@ Inductive expr {X : Set} := | Reset (e : expr) : expr with val {X : Set} := | LitV (n : nat) : val -| RecV (e : @expr (inc (inc X))) : val. +| RecV (e : @expr (inc (inc X))) : val +| ContV (e : @expr (inc X)) : val. @@ -71,7 +72,7 @@ vmap {A B : Set} (f : A [→] B) (v : val A) : val B := match v with | LitV n => LitV n | RecV e => RecV (emap ((f ↑) ↑) e) -(* | ContV K => ContV (kmap f K) *) + | ContV e => ContV (emap (f ↑) e) end. #[export] Instance FMap_expr : FunctorCore expr := @emap. @@ -109,7 +110,7 @@ vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := match v with | LitV n => LitV n | RecV e => RecV (ebind ((f ↑) ↑) e) - (* | ContV K => ContV (kbind f K) *) + | ContV e => ContV (ebind (f ↑) e) end. #[export] Instance BindCore_expr : BindCore expr := @ebind. @@ -414,7 +415,7 @@ Qed. (* Only if no reset in K *) Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := - RecV (fill (shift (shift K)) (Var VZ)). + ContV (fill (shift K) (Var VZ)). Example test1 : val (inc ∅) := (cont_to_rec [OutputK; AppRK (Var VZ)]). @@ -456,6 +457,10 @@ Variant head_step {S} : expr S → state -> ectx S → (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) (Val (shift (Inc := inc) v2))) (Val (RecV e1))) σ K (1,0) + | BetaContS e1 v2 σ K : + head_step (App (Val $ ContV e1) (Val v2)) σ K + (subst (Inc := inc) e1 (Val v2)) + σ K (2,0) | InputS σ n σ' K : update_input σ = (n, σ') → head_step Input σ K (Val (LitV n)) σ' K (1, 1) From 8a055f8620254ecbaa7f58e84d763473f2575622 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 19 Jan 2024 16:25:55 +0100 Subject: [PATCH 085/114] better proofs, more lemmas. Need to figure sthg out for soundness --- theories/input_lang_delim/interp.v | 175 +++++++++++++++++------------ theories/input_lang_delim/lang.v | 38 ++++++- 2 files changed, 137 insertions(+), 76 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index b533657..da2d787 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -738,17 +738,9 @@ Section interp. Lemma interp_ectx_ren {S S'} env (δ : S [→] S') (K : ectx S) : interp_ectx (fmap δ K) env ≡ interp_ectx K (ren_scope δ env). Proof. - (* unfold interp_ectx. intro. simpl. *) - (* generalize env x. *) induction K; intros ?; simpl; eauto. - destruct a; simpl. - - etrans; first by apply IHK. repeat f_equiv. - - etrans; first by apply IHK. repeat f_equiv; by apply interp_expr_ren. - - etrans; first by apply IHK. repeat f_equiv; by apply interp_val_ren. - - etrans; first by apply IHK. repeat f_equiv; by apply interp_expr_ren. - - etrans; first by apply IHK. repeat f_equiv; by apply interp_val_ren. - - etrans; first by apply IHK. repeat f_equiv; by apply interp_expr_ren. - - etrans; first by apply IHK. repeat f_equiv; by apply interp_expr_ren. + destruct a; simpl; try (etrans; first by apply IHK); repeat f_equiv; + try solve [by apply interp_expr_ren | by apply interp_val_ren]. Qed. @@ -830,14 +822,9 @@ Section interp. interp_ectx (bind δ K) env ≡ interp_ectx K (sub_scope δ env). Proof. induction K; simpl; intros ?; simpl; eauto. - destruct a; simpl; try by eapply IHK. - - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. - - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_val_subst. - - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. - - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_val_subst. - - etrans; first by eapply IHK. repeat f_equiv; by eapply interp_expr_subst. + destruct a; simpl; try (etrans; first by apply IHK); + repeat f_equiv; try solve [by eapply interp_expr_subst | by eapply interp_val_subst]. Qed. - (* FIXME this is aweful. *) @@ -1091,8 +1078,7 @@ Section interp. repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. reflexivity. - - - match goal with + - match goal with | |- context G [(ofe_mor_car _ _ (get_fun (?g)) ?e)] => set (f := g) @@ -1107,10 +1093,12 @@ Section interp. (get_fun f (Fun (Next (ir_unf (interp_expr e0) env))))) gσ). { repeat f_equiv. apply interp_rec_unfold. } trans (reify (gReifiers_sReifier rs) - (interp_ectx' K env + (interp_ectx K env (f (Next (ir_unf (interp_expr e0) env)))) gσ). { repeat f_equiv. apply get_fun_fun. } - subst f. simpl. + subst f. + Opaque interp_ectx. + simpl. match goal with | |- context G [(ofe_mor_car _ _ SHIFT ?g)] => set (f := g) end. @@ -1135,27 +1123,37 @@ Section interp. } clear f. f_equiv. - rewrite APP'_Fun_r. - match goal with - | |- context G [(ofe_mor_car _ _ (ofe_mor_car _ _ APP _) ?f)] => - trans (APP (Fun $ Next $ ir_unf (interp_expr e0) env) f); last first - end. - { repeat f_equiv; try by rewrite interp_rec_unfold. } - rewrite APP_Fun -!Tick_eq. simpl. - repeat f_equiv. - intro. simpl. - rewrite interp_comp laterO_map_Next -Tick_eq. f_equiv. - symmetry. + rewrite -Tick_eq. f_equiv. + rewrite !interp_expr_subst. f_equiv. + intros [|[|x]]; eauto. simpl. Transparent extend_scope. - fold (@interp_ectx S K env). - Opaque interp_ectx. - simpl. + simpl. repeat f_equiv. intro. simpl. + rewrite laterO_map_Next -Tick_eq. f_equiv. + rewrite interp_expr_ren interp_comp. simpl. + symmetry. etrans; first by apply interp_ectx_ren. - repeat f_equiv. - unfold ren_scope. simpl. - apply ofe_mor_ext. done. - Transparent interp_ectx. - Opaque extend_scope. + repeat f_equiv. unfold ren_scope. simpl. by intro. + (* rewrite APP'_Fun_r. *) + (* match goal with *) + (* | |- context G [(ofe_mor_car _ _ (ofe_mor_car _ _ APP _) ?f)] => *) + (* trans (APP (Fun $ Next $ ir_unf (interp_expr e0) env) f); last first *) + (* end. *) + (* { repeat f_equiv; try by rewrite interp_rec_unfold. } *) + (* rewrite APP_Fun -!Tick_eq. simpl. *) + (* repeat f_equiv. *) + (* intro. simpl. *) + (* rewrite interp_comp laterO_map_Next -Tick_eq. f_equiv. *) + (* symmetry. *) + (* Transparent extend_scope. *) + (* fold (@interp_ectx S K env). *) + (* Opaque interp_ectx. *) + (* simpl. *) + (* etrans; first by apply interp_ectx_ren. *) + (* repeat f_equiv. *) + (* unfold ren_scope. simpl. *) + (* apply ofe_mor_ext. done. *) + (* Transparent interp_ectx. *) + (* Opaque extend_scope. *) - Transparent RESET. unfold RESET. trans (reify (gReifiers_sReifier rs) (RESET_ (laterO_map (λne y, interp_ectx' K' env y) ◎ @@ -1183,29 +1181,33 @@ Section interp. f_equiv. rewrite laterO_map_Next -Tick_eq. f_equiv. rewrite interp_comp. f_equiv. - + done. - + simpl. by rewrite get_val_ITV. + simpl. by rewrite get_val_ITV. Qed. - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : - prim_step e1 σ1 e2 σ2 (n,m) → + + Lemma soundness_Ectx {S} (e1 e2 e'1 e'2 : expr S) σ1 σ2 (K1 K2 : ectx S) + (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : + ResetK ∉ K1 -> + e1 = (K1 ⟪ e'1 ⟫)%syn -> + e2 = (K2 ⟪ e'2 ⟫)%syn -> + head_step e'1 σ1 K1 e'2 σ2 K2 (n, m) -> ssteps (gReifiers_sReifier rs) - (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) - (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. + (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. Proof. Opaque gState_decomp gState_recomp. - inversion 1; simplify_eq/=. - { - destruct (head_step_io_01 _ _ _ _ _ _ _ H2); subst. + intros. simplify_eq/=. + destruct (head_step_io_01 _ _ _ _ _ _ _ _ H2); subst. - assert (σ1 = σ2) as ->. { eapply head_step_no_io; eauto. } - unshelve eapply (interp_expr_fill_no_reify K) in H2; first apply env. + unshelve eapply (interp_expr_fill_no_reify K1) in H2; first apply env; last apply H. rewrite H2. rewrite interp_comp. eapply ssteps_tick_n. - - inversion H2;subst. - + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. - rewrite interp_comp. + - specialize (interp_ectx_hom K1 env H) as Hhom. + inversion H2;subst. + + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr) in H2; last apply H. + rewrite interp_comp. simpl. rewrite hom_INPUT. change 1 with (Nat.add 1 0). econstructor; last first. { apply ssteps_zero; reflexivity. } @@ -1217,7 +1219,7 @@ Section interp. repeat f_equiv; eauto. rewrite interp_comp hom_INPUT. eauto. - + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. + + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr _ H2) in H. rewrite interp_comp. simpl. rewrite get_ret_ret. rewrite hom_OUTPUT_. @@ -1226,31 +1228,62 @@ Section interp. eapply sstep_reify. { Transparent OUTPUT_. unfold OUTPUT_. simpl. f_equiv. reflexivity. } - simpl in H2. - rewrite -H2. + simpl in H. + rewrite -H. repeat f_equiv; eauto. Opaque OUTPUT_. rewrite interp_comp /= get_ret_ret hom_OUTPUT_. eauto. - + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. - rewrite !interp_comp interp_expr_subst. - change 1 with (Nat.add 1 0). econstructor; last first. - { apply ssteps_zero; reflexivity. } - rewrite -interp_comp. - eapply sstep_reify. - { Transparent CALLCC. unfold CALLCC. rewrite interp_comp hom_vis. - f_equiv. reflexivity. - } - rewrite H2. + + eapply (interp_expr_fill_yes_reify K1 [] env _ _ _ _ σr _ H2) in H. + rewrite !interp_comp. + Opaque interp_ectx. simpl. + match goal with + | |- context G [ofe_mor_car _ _ (get_fun _) ?g] => set (f := g) + end. + assert (f ≡ Fun $ Next $ ir_unf (interp_expr e) env) as -> by apply interp_rec_unfold. + rewrite get_fun_fun. simpl. - repeat f_equiv. - rewrite -interp_expr_subst. - rewrite interp_comp. - reflexivity. + econstructor; last constructor; last done; last done. + eapply sstep_reify. + { rewrite hom_SHIFT_. simpl. + f_equiv. reflexivity. } + simpl in H. rewrite -H. repeat f_equiv. + rewrite interp_comp. f_equiv. simpl. + match goal with + |- context G [ ofe_mor_car _ _ (get_fun ?g)] => set (gi := g) + end. + trans (get_fun gi + (Fun $ Next $ ir_unf (interp_expr e) env)); last by rewrite interp_rec_unfold. + rewrite get_fun_fun. simpl. reflexivity. + + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr _ H2) in H. + rewrite !interp_comp. + econstructor; last constructor; last done; last done. + eapply sstep_reify. + { simpl. rewrite !hom_vis. reflexivity. } + simpl in H2. + trans (gState_recomp σr (sR_state σ2), + Tick (interp_expr (K2 ⟪ v ⟫)%syn env)); + last by (repeat f_equiv; apply interp_comp). + rewrite -H. repeat f_equiv. by rewrite interp_comp. + Qed. + + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : + prim_step e1 σ1 e2 σ2 (n,m) → + ssteps (gReifiers_sReifier rs) + (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. + Proof. + Opaque gState_decomp gState_recomp. + inversion 1; simplify_eq/=. + { + eapply soundness_Ectx =>//=. } { rewrite !interp_comp. - simpl. + pose proof (shift_context_no_reset K Ki Ko H0). + unshelve epose proof (soundness_Ectx (Ki ⟪ e0 ⟫)%syn (Ki' ⟪ e3 ⟫)%syn e0 e3 σ1 σ2 Ki Ki' σr n m env H2 _ _ H1 ); try done. + pose proof (shift_context_app K Ki Ko H0) as ->. + pose proof (interp_val_asval v (D := env)). rewrite get_val_ITV. simpl. diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 748adf0..544a21e 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -413,6 +413,27 @@ Proof. Qed. +Lemma trim_reset_no_reset {X : Set} (K Ki Ko acc : ectx X) : + (Ki, Ko) = trim_to_first_reset K acc -> + ResetK ∉ acc -> + ResetK ∉ Ki. +Proof. + elim: K Ko acc Ki; simpl; intros. + - congruence. + - destruct a; try solve [eapply H; try eapply H0; try (apply not_elem_of_cons; done)]. + congruence. +Qed. + + +Lemma shift_context_no_reset {X : Set} (K Ki Ko : ectx X) : + (Ki, Ko) = shift_context K -> ResetK ∉ Ki. +Proof. + rewrite /shift_context//. destruct (trim_to_first_reset K []) eqn:Heq. symmetry in Heq. + intros. eapply trim_reset_no_reset in Heq; last apply not_elem_of_nil. + rewrite rev_alt in H. inversion H. subst. by rewrite elem_of_reverse. +Qed. + + (* Only if no reset in K *) Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := ContV (fill (shift K) (Var VZ)). @@ -483,8 +504,12 @@ Variant head_step {S} : expr S → state -> ectx S → | ShiftS (e : expr (inc (inc S))) σ K f: ResetK ∉ K -> f = cont_to_rec K -> - head_step (Shift (Val $ RecV e)) σ K - (App (Val $ RecV e) (Val f)) σ [] (0, 1) + head_step (Shift (Val $ RecV e)) σ K + (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e) + (Val (shift (Inc := inc) f))) + (Val $ RecV e)) σ [] (1, 1) + (* head_step (Shift (Val $ RecV e)) σ K *) + (* (App (Val $ RecV e) (Val f)) σ [] (0, 1) *) | ResetS v σ K : head_step (Reset (Val v)) σ K (Val v) σ K (1, 1). @@ -560,6 +585,7 @@ Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) | Ectx_step e1 σ1 e2 σ2 nm (K1 K2 : ectx S) e1' e2' : e1 = fill K1 e1' -> e2 = fill K2 e2' -> + ResetK ∉ K1 -> head_step e1' σ1 K1 e2' σ2 K2 nm -> prim_step e1 σ1 e2 σ2 nm | Shift_step e1 σ1 K Ki Ko e2 σ2 Ki' nm : @@ -576,7 +602,7 @@ Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. Proof. inversion 1; simplify_eq/=. - + by inversion H2. + + by inversion H3. + by inversion H1. Qed. @@ -590,7 +616,9 @@ Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat . Lemma Ectx_step' {S} (K1 K2 : ectx S) e1 σ1 e2 σ2 efs : - head_step e1 σ1 K1 e2 σ2 K2 efs → prim_step (fill K1 e1) σ1 (fill K2 e2) σ2 efs. + head_step e1 σ1 K1 e2 σ2 K2 efs → + ResetK ∉ K1 -> + prim_step (fill K1 e1) σ1 (fill K2 e2) σ2 efs. Proof. econstructor; eauto. Qed. Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : @@ -626,7 +654,7 @@ Qed. Lemma head_step_prim_step {S} (e1 e2 : expr S) σ1 σ2 nm : head_step e1 σ1 [] e2 σ2 [] nm -> prim_step e1 σ1 e2 σ2 nm. Proof. - apply Ectx_step'. + move => H; apply Ectx_step' in H => //=. apply not_elem_of_nil. Qed. (*** Type system *) From cfcf08a1c509543e7b031992d3ed2dc8d3f32540 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Mon, 22 Jan 2024 17:56:12 +0100 Subject: [PATCH 086/114] better head/prim_step BUT /!\ Reset probably wrong... --- theories/input_lang_delim/interp.v | 227 +++++++++++++++++++---------- theories/input_lang_delim/lang.v | 112 ++++++++------ 2 files changed, 212 insertions(+), 127 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index da2d787..c463926 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -960,8 +960,8 @@ Section interp. Qed. (** ** Finally, preservation of reductions *) - Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' σ σ' K n : - head_step e σ K e' σ' K (n, 0) → + Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' σ σ' K Ko n : + head_step e σ K e' σ' K Ko (n, 0) → interp_expr e env ≡ Tick_n n $ interp_expr e' env. Proof. inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. @@ -996,8 +996,8 @@ Section interp. reflexivity. Qed. - Lemma interp_expr_fill_no_reify {S} K K' (env : interp_scope S) (e e' : expr S) σ σ' n : - head_step e σ K e' σ' K' (n, 0) → + Lemma interp_expr_fill_no_reify {S} K K' Ko (env : interp_scope S) (e e' : expr S) σ σ' n : + head_step e σ K e' σ' K' Ko (n, 0) → ResetK ∉ K-> interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K' e') env. Proof. @@ -1020,9 +1020,9 @@ Section interp. Opaque extend_scope. Opaque Ret. - Lemma interp_expr_fill_yes_reify {S} K K' env (e e' : expr S) + Lemma interp_expr_fill_yes_reify {S} K K' Ko env (e e' : expr S) (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : - head_step e σ K e' σ' K' (n, 1) → + head_step e σ K e' σ' K' Ko (n, 1) → ResetK ∉ K-> reify (gReifiers_sReifier rs) (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) @@ -1045,7 +1045,7 @@ Section interp. simpl in H. simpl. erewrite <-H; last first. - - rewrite H7. reflexivity. + - rewrite H8. reflexivity. - f_equiv; solve_proper. } @@ -1185,23 +1185,103 @@ Section interp. Qed. - Lemma soundness_Ectx {S} (e1 e2 e'1 e'2 : expr S) σ1 σ2 (K1 K2 : ectx S) - (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : - ResetK ∉ K1 -> - e1 = (K1 ⟪ e'1 ⟫)%syn -> - e2 = (K2 ⟪ e'2 ⟫)%syn -> - head_step e'1 σ1 K1 e'2 σ2 K2 (n, m) -> + (* Lemma soundness_Ectx {S} (e1 e2 e'1 e'2 : expr S) σ1 σ2 (K1 K2 : ectx S) *) + (* (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : *) + (* ResetK ∉ K1 -> *) + (* e1 = (K1 ⟪ e'1 ⟫)%syn -> *) + (* e2 = (K2 ⟪ e'2 ⟫)%syn -> *) + (* head_step e'1 σ1 K1 e'2 σ2 K2 (n, m) -> *) + (* ssteps (gReifiers_sReifier rs) *) + (* (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) *) + (* (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. *) + (* Proof. *) + (* Opaque gState_decomp gState_recomp. *) + (* intros. simplify_eq/=. *) + (* destruct (head_step_io_01 _ _ _ _ _ _ _ _ H2); subst. *) + (* - assert (σ1 = σ2) as ->. *) + (* { eapply head_step_no_io; eauto. } *) + (* unshelve eapply (interp_expr_fill_no_reify K1) in H2; first apply env; last apply H. *) + (* rewrite H2. *) + (* rewrite interp_comp. *) + (* eapply ssteps_tick_n. *) + (* - specialize (interp_ectx_hom K1 env H) as Hhom. *) + (* inversion H2;subst. *) + (* + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr) in H2; last apply H. *) + (* rewrite interp_comp. simpl. *) + (* rewrite hom_INPUT. *) + (* change 1 with (Nat.add 1 0). econstructor; last first. *) + (* { apply ssteps_zero; reflexivity. } *) + (* eapply sstep_reify. *) + (* { Transparent INPUT. unfold INPUT. simpl. *) + (* f_equiv. reflexivity. } *) + (* simpl in H2. *) + (* rewrite -H2. *) + (* repeat f_equiv; eauto. *) + (* rewrite interp_comp hom_INPUT. *) + (* eauto. *) + (* + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr _ H2) in H. *) + (* rewrite interp_comp. simpl. *) + (* rewrite get_ret_ret. *) + (* rewrite hom_OUTPUT_. *) + (* change 1 with (Nat.add 1 0). econstructor; last first. *) + (* { apply ssteps_zero; reflexivity. } *) + (* eapply sstep_reify. *) + (* { Transparent OUTPUT_. unfold OUTPUT_. simpl. *) + (* f_equiv. reflexivity. } *) + (* simpl in H. *) + (* rewrite -H. *) + (* repeat f_equiv; eauto. *) + (* Opaque OUTPUT_. *) + (* rewrite interp_comp /= get_ret_ret hom_OUTPUT_. *) + (* eauto. *) + (* + eapply (interp_expr_fill_yes_reify K1 [] env _ _ _ _ σr _ H2) in H. *) + (* rewrite !interp_comp. *) + (* Opaque interp_ectx. simpl. *) + (* match goal with *) + (* | |- context G [ofe_mor_car _ _ (get_fun _) ?g] => set (f := g) *) + (* end. *) + (* assert (f ≡ Fun $ Next $ ir_unf (interp_expr e) env) as -> by apply interp_rec_unfold. *) + (* rewrite get_fun_fun. *) + (* simpl. *) + (* econstructor; last constructor; last done; last done. *) + (* eapply sstep_reify. *) + (* { rewrite hom_SHIFT_. simpl. *) + (* f_equiv. reflexivity. } *) + (* simpl in H. rewrite -H. repeat f_equiv. *) + (* rewrite interp_comp. f_equiv. simpl. *) + (* match goal with *) + (* |- context G [ ofe_mor_car _ _ (get_fun ?g)] => set (gi := g) *) + (* end. *) + (* trans (get_fun gi *) + (* (Fun $ Next $ ir_unf (interp_expr e) env)); last by rewrite interp_rec_unfold. *) + (* rewrite get_fun_fun. simpl. reflexivity. *) + (* + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr _ H2) in H. *) + (* rewrite !interp_comp. *) + (* econstructor; last constructor; last done; last done. *) + (* eapply sstep_reify. *) + (* { simpl. rewrite !hom_vis. reflexivity. } *) + (* simpl in H2. *) + (* trans (gState_recomp σr (sR_state σ2), *) + (* Tick (interp_expr (K2 ⟪ v ⟫)%syn env)); *) + (* last by (repeat f_equiv; apply interp_comp). *) + (* rewrite -H. repeat f_equiv. by rewrite interp_comp. *) + (* Qed. *) + + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : + prim_step e1 σ1 e2 σ2 (n,m) → ssteps (gReifiers_sReifier rs) - (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) - (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. + (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. Proof. Opaque gState_decomp gState_recomp. - intros. simplify_eq/=. - destruct (head_step_io_01 _ _ _ _ _ _ _ _ H2); subst. + inversion 1; simplify_eq/=. + rewrite !interp_comp. + pose proof (shift_context_no_reset K Ki Ko H0). + destruct (head_step_io_01 _ _ _ _ _ _ _ _ _ H1); subst. - assert (σ1 = σ2) as ->. { eapply head_step_no_io; eauto. } - unshelve eapply (interp_expr_fill_no_reify K1) in H2; first apply env; last apply H. - rewrite H2. + unshelve eapply (interp_expr_fill_no_reify Ki) in H1; first apply env; last apply H2. + rewrite H1. rewrite interp_comp. eapply ssteps_tick_n. - specialize (interp_ectx_hom K1 env H) as Hhom. @@ -1256,7 +1336,7 @@ Section interp. (Fun $ Next $ ir_unf (interp_expr e) env)); last by rewrite interp_rec_unfold. rewrite get_fun_fun. simpl. reflexivity. + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr _ H2) in H. - rewrite !interp_comp. + rewrite !interp_comp. econstructor; last constructor; last done; last done. eapply sstep_reify. { simpl. rewrite !hom_vis. reflexivity. } @@ -1265,68 +1345,55 @@ Section interp. Tick (interp_expr (K2 ⟪ v ⟫)%syn env)); last by (repeat f_equiv; apply interp_comp). rewrite -H. repeat f_equiv. by rewrite interp_comp. - Qed. - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : - prim_step e1 σ1 e2 σ2 (n,m) → - ssteps (gReifiers_sReifier rs) - (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) - (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. - Proof. - Opaque gState_decomp gState_recomp. - inversion 1; simplify_eq/=. - { - eapply soundness_Ectx =>//=. - } - { - rewrite !interp_comp. - pose proof (shift_context_no_reset K Ki Ko H0). - unshelve epose proof (soundness_Ectx (Ki ⟪ e0 ⟫)%syn (Ki' ⟪ e3 ⟫)%syn e0 e3 σ1 σ2 Ki Ki' σr n m env H2 _ _ H1 ); try done. - pose proof (shift_context_app K Ki Ko H0) as ->. - pose proof (interp_val_asval v (D := env)). - rewrite get_val_ITV. - simpl. - rewrite get_fun_fun. - simpl. - change 2 with (Nat.add (Nat.add 1 1) 0). - econstructor; last first. - { apply ssteps_tick_n. } - eapply sstep_reify; first (rewrite hom_vis; reflexivity). - match goal with - | |- context G [ofe_mor_car _ _ _ (Next ?f)] => set (f' := f) - end. - trans (reify (gReifiers_sReifier rs) (THROW (interp_val v env) (Next f')) (gState_recomp σr (sR_state σ2))). - { - f_equiv; last done. - f_equiv. - rewrite hom_vis. - Transparent THROW. - unfold THROW. - simpl. - repeat f_equiv. - intros x; simpl. - destruct ((subEff_outs ^-1) x). - } - rewrite reify_vis_eq; first (rewrite Tick_eq; reflexivity). - simpl. - match goal with - | |- context G [(_, _, ?a)] => set (κ := a) - end. - epose proof (@subReifier_reify sz reify_io rs subR IT _ - (inr (inr (inr (inl ())))) (Next (interp_val v env), Next f') - (Next (Tau (Next ((interp_ectx K' env) (interp_val v env))))) - (Empty_setO_rec _) σ2 σ2 σr) as H'. - subst κ. - simpl in H'. - erewrite <-H'; last reflexivity. - rewrite /prod_map. - f_equiv; first solve_proper. - do 2 f_equiv; first reflexivity. - intro; simpl. - f_equiv. - } - Qed. + + + (* unshelve epose proof (soundness_Ectx (Ki ⟪ e0 ⟫)%syn (Ki' ⟪ e3 ⟫)%syn e0 e3 σ1 σ2 Ki Ki' σr n m env H2 _ _ H1 ); try done. *) + (* pose proof (shift_context_app K Ki Ko H0) as ->. *) + (* pose proof (interp_val_asval v (D := env)). *) + (* rewrite get_val_ITV. *) + (* simpl. *) + (* rewrite get_fun_fun. *) + (* simpl. *) + (* change 2 with (Nat.add (Nat.add 1 1) 0). *) + (* econstructor; last first. *) + (* { apply ssteps_tick_n. } *) + (* eapply sstep_reify; first (rewrite hom_vis; reflexivity). *) + (* match goal with *) + (* | |- context G [ofe_mor_car _ _ _ (Next ?f)] => set (f' := f) *) + (* end. *) + (* trans (reify (gReifiers_sReifier rs) (THROW (interp_val v env) (Next f')) (gState_recomp σr (sR_state σ2))). *) + (* { *) + (* f_equiv; last done. *) + (* f_equiv. *) + (* rewrite hom_vis. *) + (* Transparent THROW. *) + (* unfold THROW. *) + (* simpl. *) + (* repeat f_equiv. *) + (* intros x; simpl. *) + (* destruct ((subEff_outs ^-1) x). *) + (* } *) + (* rewrite reify_vis_eq; first (rewrite Tick_eq; reflexivity). *) + (* simpl. *) + (* match goal with *) + (* | |- context G [(_, _, ?a)] => set (κ := a) *) + (* end. *) + (* epose proof (@subReifier_reify sz reify_io rs subR IT _ *) + (* (inr (inr (inr (inl ())))) (Next (interp_val v env), Next f') *) + (* (Next (Tau (Next ((interp_ectx K' env) (interp_val v env))))) *) + (* (Empty_setO_rec _) σ2 σ2 σr) as H'. *) + (* subst κ. *) + (* simpl in H'. *) + (* erewrite <-H'; last reflexivity. *) + (* rewrite /prod_map. *) + (* f_equiv; first solve_proper. *) + (* do 2 f_equiv; first reflexivity. *) + (* intro; simpl. *) + (* f_equiv. *) + (* } *) + (* Qed. *) End interp. #[global] Opaque INPUT OUTPUT_ CALLCC THROW. diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 544a21e..3a36907 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -434,6 +434,26 @@ Proof. Qed. +Lemma no_reset_trim_ident {X : Set} (K acc : ectx X) : + ResetK ∉ K -> ResetK ∉ acc -> + ((List.rev K) ++ acc, []) = trim_to_first_reset K acc. + Proof. + elim: K acc; intros; simpl; eauto. + apply not_elem_of_cons in H0 as [Hh Ht]. + destruct a; try contradiction; + rewrite -app_assoc; simpl; apply H; eauto; by apply not_elem_of_cons. + Qed. + + +Lemma no_reset_shift_context_ident {X : Set} (K : ectx X) : + ResetK ∉ K -> (K, []) = shift_context K. +Proof. + unfold shift_context. intros. rewrite -no_reset_trim_ident; + last apply not_elem_of_nil; last done. + by rewrite app_nil_r rev_involutive. +Qed. + + (* Only if no reset in K *) Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := ContV (fill (shift K) (Var VZ)). @@ -468,51 +488,52 @@ Definition update_output (n:nat) (s : state) : state := {| inputs := s.(inputs); outputs := n::s.(outputs) |}. -(** [head_step e σ K e' σ' K' (n, m)] : step from [(e, σ, K)] to [(e', σ', K')] - in [n] ticks with [m] effects encountered *) -Variant head_step {S} : expr S → state -> ectx S → - expr S → state → ectx S → +(** [head_step e σ K e' σ' K' Ko (n, m)] : step from [(e, σ, K)] to [(e', σ', K')] + under outer context [Ko] in [n] ticks with [m] effects encountered *) +Variant head_step {S} : expr S -> state -> ectx S -> + expr S -> state -> ectx S -> + ectx S -> nat * nat → Prop := - | BetaS e1 v2 σ K : + | BetaS e1 v2 σ K Ko : head_step (App (Val $ RecV e1) (Val v2)) σ K (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) (Val (shift (Inc := inc) v2))) - (Val (RecV e1))) σ K (1,0) - | BetaContS e1 v2 σ K : + (Val (RecV e1))) σ K Ko (1,0) + | BetaContS e1 v2 σ K Ko : head_step (App (Val $ ContV e1) (Val v2)) σ K (subst (Inc := inc) e1 (Val v2)) - σ K (2,0) - | InputS σ n σ' K : + σ K Ko (2,0) + | InputS σ n σ' K Ko : update_input σ = (n, σ') → - head_step Input σ K (Val (LitV n)) σ' K (1, 1) - | OutputS σ n σ' K : + head_step Input σ K (Val (LitV n)) σ' K Ko (1, 1) + | OutputS σ n σ' K Ko : update_output n σ = σ' → - head_step (Output (Val (LitV n))) σ K (Val (LitV 0)) σ' K (1, 1) - | NatOpS op v1 v2 v3 σ K : + head_step (Output (Val (LitV n))) σ K (Val (LitV 0)) σ' K Ko (1, 1) + | NatOpS op v1 v2 v3 σ K Ko : nat_op_interp op v1 v2 = Some v3 → head_step (NatOp op (Val v1) (Val v2)) σ K - (Val v3) σ K (0, 0) - | IfTrueS n e1 e2 σ K : + (Val v3) σ K Ko (0, 0) + | IfTrueS n e1 e2 σ K Ko : n > 0 → head_step (If (Val (LitV n)) e1 e2) σ K - e1 σ K (0, 0) - | IfFalseS n e1 e2 σ K : + e1 σ K Ko (0, 0) + | IfFalseS n e1 e2 σ K Ko : n = 0 → head_step (If (Val (LitV n)) e1 e2) σ K - e2 σ K (0, 0) + e2 σ K Ko (0, 0) - | ShiftS (e : expr (inc (inc S))) σ K f: + | ShiftS (e : expr (inc (inc S))) σ K Ko f : ResetK ∉ K -> f = cont_to_rec K -> head_step (Shift (Val $ RecV e)) σ K (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e) (Val (shift (Inc := inc) f))) - (Val $ RecV e)) σ [] (1, 1) + (Val $ RecV e)) σ [] Ko (1, 1) (* head_step (Shift (Val $ RecV e)) σ K *) (* (App (Val $ RecV e) (Val f)) σ [] (0, 1) *) - | ResetS v σ K : - head_step (Reset (Val v)) σ K (Val v) σ K (1, 1). + | ResetS v σ K Ko : + head_step (Reset (Val v)) σ K (Val v) σ K Ko (1, 1). (* | ValueS v σ K C: *) @@ -523,14 +544,14 @@ Variant head_step {S} : expr S → state -> ectx S → (* (Reset (fill E (Shift e))) σ *) (* (Reset (subst (Inc := inc) e (Val $ ContV $ ResetK E))) σ K (1,0). *) -Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : - head_step e1 σ1 K e2 σ2 K' (n,m) → m = 0 ∨ m = 1. +Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K K' Ko n m : + head_step e1 σ1 K e2 σ2 K' Ko (n,m) → m = 0 ∨ m = 1. Proof. inversion 1; eauto. Qed. (* Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : *) (* head_step e1 σ1 K e2 σ2 K' (n,m) → n = 0 ∨ n = 1. *) (* Proof. inversion 1; eauto. Qed. *) -Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K K' n : - head_step e1 σ1 K e2 σ2 K' (n,0) → σ1 = σ2. +Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K K' Ko n : + head_step e1 σ1 K e2 σ2 K' Ko (n,0) → σ1 = σ2. Proof. inversion 1; eauto. Qed. (** Carbonara from heap lang *) @@ -552,8 +573,8 @@ Proof. elim: Ki e; simpl in *; first done. intros. Qed. (* CHECK *) -Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K K' m : - head_step e1 σ1 K e2 σ2 K' m → to_val e1 = None. +Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K K' Ko m : + head_step e1 σ1 K e2 σ2 K' Ko m → to_val e1 = None. Proof. destruct 1; naive_solver. Qed. @@ -582,28 +603,22 @@ Proof. by rewrite fill_app. Qed. (* FIXME maybe *) Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) (e2 : expr S) (σ2 : state) (nm : nat * nat), Prop := -| Ectx_step e1 σ1 e2 σ2 nm (K1 K2 : ectx S) e1' e2' : - e1 = fill K1 e1' -> - e2 = fill K2 e2' -> - ResetK ∉ K1 -> - head_step e1' σ1 K1 e2' σ2 K2 nm -> - prim_step e1 σ1 e2 σ2 nm +(* | Ectx_step e1 σ1 e2 σ2 nm (K1 K2 : ectx S) e1' e2' : *) +(* e1 = fill K1 e1' -> *) +(* e2 = fill K2 e2' -> *) +(* ResetK ∉ K1 -> *) +(* head_step e1' σ1 K1 e2' σ2 K2 nm -> *) +(* prim_step e1 σ1 e2 σ2 nm *) | Shift_step e1 σ1 K Ki Ko e2 σ2 Ki' nm : (Ki, Ko) = shift_context K -> - head_step e1 σ1 Ki e2 σ2 Ki' nm -> + head_step e1 σ1 Ki e2 σ2 Ki' Ko nm -> prim_step (fill K e1) σ1 (fill (Ki' ++ Ko) e2) σ2 nm. -(* | App_cont_step e1 σ e2 (K : ectx S) v K' : *) -(* e1 = (fill K (App (Val $ ContV K') (Val v))) -> *) -(* e2 = (fill K' (Val v)) -> *) -(* prim_step e1 σ e2 σ (2, 0). *) (* CHECK *) Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. Proof. - inversion 1; simplify_eq/=. - + by inversion H3. - + by inversion H1. + inversion 1; simplify_eq/=. by inversion H1. Qed. Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat → Prop := @@ -616,10 +631,13 @@ Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat . Lemma Ectx_step' {S} (K1 K2 : ectx S) e1 σ1 e2 σ2 efs : - head_step e1 σ1 K1 e2 σ2 K2 efs → + head_step e1 σ1 K1 e2 σ2 K2 [] efs → ResetK ∉ K1 -> prim_step (fill K1 e1) σ1 (fill K2 e2) σ2 efs. -Proof. econstructor; eauto. Qed. +Proof. + intros. rewrite -(app_nil_r K2). + econstructor; eauto. by apply no_reset_shift_context_ident. +Qed. Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : prim_steps e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 → @@ -652,7 +670,7 @@ Proof. Qed. Lemma head_step_prim_step {S} (e1 e2 : expr S) σ1 σ2 nm : - head_step e1 σ1 [] e2 σ2 [] nm -> prim_step e1 σ1 e2 σ2 nm. + head_step e1 σ1 [] e2 σ2 [] [] nm -> prim_step e1 σ1 e2 σ2 nm. Proof. move => H; apply Ectx_step' in H => //=. apply not_elem_of_nil. Qed. @@ -918,8 +936,8 @@ Example testc : option (expr (inc ∅) * state * ectx (inc ∅) * (nat * nat)) : Eval compute in testc. -Lemma head_step_reflect {S : Set} (e : expr S) (σ : state) (K : ectx S) - : option_reflect (fun '(e', σ', K', nm) => head_step e σ K e' σ' K' nm) +Lemma head_step_reflect {S : Set} (e : expr S) (σ : state) (K Ko : ectx S) + : option_reflect (fun '(e', σ', K', nm) => head_step e σ K e' σ' K' Ko nm) True (compute_head_step e σ K). Proof. From 3188e355b41539b38db8ceea9a0a89c27d8deb88 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Mon, 29 Jan 2024 15:27:56 +0100 Subject: [PATCH 087/114] simplify ctxdep --- theories/gitree/greifiers.v | 491 +++++++++++++++++++++++++++-------- theories/gitree/reductions.v | 76 +++--- theories/gitree/reify.v | 453 +++++++++++++++++++++----------- theories/gitree/weakestpre.v | 477 +++++++++++++++++++++++----------- 4 files changed, 1048 insertions(+), 449 deletions(-) diff --git a/theories/gitree/greifiers.v b/theories/gitree/greifiers.v index 05ded03..f9ff81e 100644 --- a/theories/gitree/greifiers.v +++ b/theories/gitree/greifiers.v @@ -3,11 +3,15 @@ From iris.base_logic.lib Require Export invariants. From gitrees Require Import prelude. From gitrees.gitree Require Import core reify. - -Section greifiers. +Section greifiers_generic. #[local] Open Scope type. + Context (a : is_ctx_dep). + Notation sReifier := (sReifier a). + Notation sReifier_ops := (sReifier_ops a). + Notation sReifier_state := (sReifier_state a). + Notation sReifier_re := (sReifier_re a). - (** Global reifiers: a collection of reifiers *) + (** Global reifiers: a collection of reifiers *) Inductive gReifiers : nat → Type := | gReifiers_nil : gReifiers 0 | gReifiers_cons {n} : sReifier → gReifiers n → gReifiers (S n) @@ -18,10 +22,11 @@ Section greifiers. Proof. revert P Hcons. refine match v with gReifiers_nil => tt - | gReifiers_cons sR v => λ P Hcons, Hcons sR v end. + | gReifiers_cons sR v => λ P Hcons, Hcons sR v end. Defined. - #[global] Instance gReifiers_lookup_total : ∀ m, LookupTotal (fin m) sReifier (gReifiers m) := + #[global] Instance gReifiers_lookup_total + : ∀ m, LookupTotal (fin m) sReifier (gReifiers m) := fix go m i {struct i} := let _ : ∀ m, LookupTotal _ _ _ := @go in match i in fin m return gReifiers m → sReifier with | 0%fin => grs_S_inv (λ _, sReifier) (λ x _, x) @@ -30,7 +35,7 @@ Section greifiers. Program Definition gReifiers_ops {n} (rs : gReifiers n) : opsInterp := {| opid := { i : fin n & opid (sReifier_ops (rs !!! i)) }; - opsInterp_lookup := λ iop, sReifier_ops (rs !!! projT1 iop) (projT2 iop) + opsInterp_lookup := λ iop, sReifier_ops (rs !!! projT1 iop) (projT2 iop) |}. Next Obligation. intros n rs. @@ -65,14 +70,14 @@ Section greifiers. Fixpoint gState_rest {m} (i : fin m) : gReifiers m → oFunctor := match i in fin m return gReifiers m → oFunctor with | 0%fin => grs_S_inv (λ _, oFunctor) - (λ sR rs, gReifiers_state rs) + (λ sR rs, gReifiers_state rs) | FS j => grs_S_inv (λ _, oFunctor) - (λ sR rs, sReifier_state sR * gState_rest j rs)%OF + (λ sR rs, sReifier_state sR * gState_rest j rs)%OF end. Lemma gState_decomp' {m} (i : fin m) (rs : gReifiers m) {X} `{!Cofe X} : gReifiers_state rs ♯ X ≃ - ((sReifier_state (rs !!! i) ♯ X) * (gState_rest i rs ♯ X))%type. + ((sReifier_state (rs !!! i) ♯ X) * (gState_rest i rs ♯ X))%type. Proof. revert i. induction rs as [|n r rs]=>i. { inversion i. } @@ -105,47 +110,116 @@ Section greifiers. Proof. rewrite ofe_iso_12. reflexivity. Qed. Lemma gState_recomp_decomp {m} (i : fin m) {rs : gReifiers m} {X} `{!Cofe X} (σ : sReifier_state (rs !!! i) ♯ X) rest fs : - gState_decomp i fs ≡ (σ, rest) → - gState_recomp rest σ ≡ fs. + gState_decomp i fs ≡ (σ, rest) → + gState_recomp rest σ ≡ fs. Proof. unfold gState_recomp. simpl. intros <-. rewrite ofe_iso_21//. Qed. Opaque gState_recomp gState_decomp. - Program Definition gReifiers_re {n} (rs : gReifiers n) {X} `{!Cofe X} - (op : opid (gReifiers_ops rs)) : - (Ins (gReifiers_ops rs op) ♯ X) * (gReifiers_state rs ♯ X) * ((Outs (gReifiers_ops rs op) ♯ X) -n> laterO X) -n> - optionO (laterO X * (gReifiers_state rs ♯ X)) +End greifiers_generic. + +Section greifiers. + #[local] Open Scope type. + + Program Definition gReifiers_re_ctx_indep {n} (rs : gReifiers NotCtxDep n) {X} `{!Cofe X} + (op : opid (gReifiers_ops NotCtxDep rs)) : + (Ins (gReifiers_ops NotCtxDep rs op) ♯ X) * (gReifiers_state NotCtxDep rs ♯ X) -n> + optionO ((Outs (gReifiers_ops NotCtxDep rs op) ♯ X) * (gReifiers_state NotCtxDep rs ♯ X)) + := λne xst, + let i := projT1 op in + let op' := projT2 op in + let x := xst.1 in + let st := xst.2 in + let fs := gState_decomp NotCtxDep i st in + let σ := fs.1 in + let rest := fs.2 in + let rx := sReifier_re NotCtxDep (rs !!! i) op' (x, σ) in + optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) rx. + Next Obligation. solve_proper_please. Qed. + + Program Definition gReifiers_re_ctx_dep {n} (rs : gReifiers CtxDep n) {X} `{!Cofe X} + (op : opid (gReifiers_ops CtxDep rs)) : + (Ins (gReifiers_ops CtxDep rs op) ♯ X) * (gReifiers_state CtxDep rs ♯ X) + * ((Outs (gReifiers_ops CtxDep rs op) ♯ X) -n> laterO X) -n> + optionO (laterO X * (gReifiers_state CtxDep rs ♯ X)) := λne xst, let i := projT1 op in let op' := projT2 op in let a := xst.1.1 in let b := xst.1.2 in let c := xst.2 in - let fs := gState_decomp i b in + let fs := gState_decomp CtxDep i b in let σ := fs.1 in let rest := fs.2 in - let rx := sReifier_re (rs !!! i) op' (a, σ, c) in - optionO_map (prodO_map idfun (gState_recomp rest)) rx. + let rx := sReifier_re CtxDep (rs !!! i) op' (a, σ, c) in + optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) rx. Next Obligation. solve_proper_please. Qed. + Program Definition gReifiers_re_type {n} + (a : is_ctx_dep) (rs : gReifiers a n) {X} `{!Cofe X} + (op : opid (gReifiers_ops a rs)) : ofe := + match a with + | CtxDep => + prodO (prodO (Ins (gReifiers_ops a rs op) ♯ X) (gReifiers_state a rs ♯ X)) + (Outs (gReifiers_ops a rs op) ♯ X -n> laterO X) -n> + optionO (prodO (laterO X) (gReifiers_state a rs ♯ X)) + | NotCtxDep => + prodO (Ins (gReifiers_ops a rs op) ♯ X) (gReifiers_state a rs ♯ X) -n> + optionO (prodO (Outs (gReifiers_ops a rs op) ♯ X) (gReifiers_state a rs ♯ X)) + end. + + Program Definition gReifiers_re {n} (a : is_ctx_dep) (rs : gReifiers a n) + {X} `{!Cofe X} + (op : opid (gReifiers_ops a rs)) : + @gReifiers_re_type n a rs X _ op. + Proof. + destruct a. + - apply gReifiers_re_ctx_dep. + - apply gReifiers_re_ctx_indep. + Defined. + (** We can turn a collection of reifiers into a single reifier *) - Definition gReifiers_sReifier {n} (rs : gReifiers n) : sReifier := - {| sReifier_ops := gReifiers_ops rs; - sReifier_state := gReifiers_state rs; - sReifier_re := @gReifiers_re n rs; + Program Definition gReifiers_sReifier {n} (a : is_ctx_dep) (rs : gReifiers a n) + : sReifier a := + {| sReifier_ops := gReifiers_ops a rs; + sReifier_state := gReifiers_state a rs; + sReifier_re X _ op := _; |}. + Next Obligation. + intros n [|] rs X ? op. + - apply (@gReifiers_re n CtxDep rs X _ op). + - apply (@gReifiers_re n NotCtxDep rs X _ op). + Defined. + + Lemma gReifiers_re_idx_ctx_dep {n} (i : fin n) (rs : gReifiers CtxDep n) + {X} `{!Cofe X} (op : opid (sReifier_ops CtxDep (rs !!! i))) + (x : Ins (sReifier_ops CtxDep _ op) ♯ X) + (σ : sReifier_state CtxDep (rs !!! i) ♯ X) + (rest : gState_rest CtxDep i rs ♯ X) + (κ : (Outs (sReifier_ops CtxDep (rs !!! i) op) ♯ X -n> laterO X)) : + gReifiers_re CtxDep rs (existT i op) (x, gState_recomp CtxDep rest σ, κ) ≡ + optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) + (sReifier_re CtxDep (rs !!! i) op (x, σ, κ)). + Proof. + unfold gReifiers_re. cbn-[prodO_map optionO_map]. + f_equiv; last repeat f_equiv. + - eapply optionO_map_proper. + intros [x1 x2]; simpl. f_equiv. + f_equiv. f_equiv. + rewrite gState_decomp_recomp//. + - rewrite gState_decomp_recomp//. + Qed. - Lemma gReifiers_re_idx {n} (i : fin n) (rs : gReifiers n) - {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) - (x : Ins (sReifier_ops _ op) ♯ X) - (σ : sReifier_state (rs !!! i) ♯ X) - (κ : (Outs (sReifier_ops (rs !!! i) op) ♯ X -n> laterO X)) - (rest : gState_rest i rs ♯ X) : - gReifiers_re rs (existT i op) (x, gState_recomp rest σ, κ) ≡ - optionO_map (prodO_map idfun (gState_recomp rest)) - (sReifier_re (rs !!! i) op (x, σ, κ)). + Lemma gReifiers_re_idx_ctx_indep {n} (i : fin n) (rs : gReifiers NotCtxDep n) + {X} `{!Cofe X} (op : opid (sReifier_ops NotCtxDep (rs !!! i))) + (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) + (σ : sReifier_state NotCtxDep (rs !!! i) ♯ X) + (rest : gState_rest NotCtxDep i rs ♯ X) : + gReifiers_re NotCtxDep rs (existT i op) (x, gState_recomp NotCtxDep rest σ) ≡ + optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) + (sReifier_re NotCtxDep (rs !!! i) op (x, σ)). Proof. unfold gReifiers_re. cbn-[prodO_map optionO_map]. f_equiv; last repeat f_equiv. @@ -156,54 +230,117 @@ Section greifiers. - rewrite gState_decomp_recomp//. Qed. - Class subReifier {n} (r : sReifier) (rs : gReifiers n) := + Program Definition gReifiers_re_idx_type {n} a (i : fin n) (rs : gReifiers a n) + {X} `{!Cofe X} (op : opid (sReifier_ops a (rs !!! i))) + (x : Ins (sReifier_ops a _ op) ♯ X) + (σ : sReifier_state a (rs !!! i) ♯ X) + (rest : gState_rest a i rs ♯ X) : + Type. + Proof. + destruct a. + - apply (∀ (κ : (Outs (sReifier_ops CtxDep (rs !!! i) op) ♯ X -n> laterO X)), + gReifiers_re CtxDep rs (existT i op) (x, gState_recomp CtxDep rest σ, κ) ≡ + optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) + (sReifier_re CtxDep (rs !!! i) op (x, σ, κ))). + - apply (gReifiers_re NotCtxDep rs (existT i op) (x, gState_recomp NotCtxDep rest σ) ≡ + optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) + (sReifier_re NotCtxDep (rs !!! i) op (x, σ))). + Defined. + + Lemma gReifiers_re_idx {n} a (i : fin n) (rs : gReifiers a n) + {X} `{!Cofe X} (op : opid (sReifier_ops a (rs !!! i))) + (x : Ins (sReifier_ops a _ op) ♯ X) + (σ : sReifier_state a (rs !!! i) ♯ X) + (rest : gState_rest a i rs ♯ X) : gReifiers_re_idx_type a i rs op x σ rest. + Proof. + destruct a. + - intros κ. apply gReifiers_re_idx_ctx_dep. + - apply gReifiers_re_idx_ctx_indep. + Qed. + + Program Definition sR_re_type {n} + {X} `{!Cofe X} (a : is_ctx_dep) (r : sReifier a) (rs : gReifiers a n) + (sR_idx : fin n) + (sR_ops : subEff (sReifier_ops a r) (sReifier_ops a (rs !!! sR_idx))) + (sR_state : sReifier_state a r ♯ X ≃ sReifier_state a (rs !!! sR_idx) ♯ X) + (m : nat) (op : opid (sReifier_ops a r)) : Type. + Proof. + destruct a. + - apply (∀ (x : Ins (sReifier_ops CtxDep r op) ♯ X) + (y : laterO X) + (s1 s2 : sReifier_state CtxDep r ♯ X) + (k : (Outs (sReifier_ops CtxDep r op) ♯ X -n> laterO X)), + sReifier_re CtxDep r op (x, s1, k) ≡{m}≡ Some (y, s2) → + sReifier_re CtxDep (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡{m}≡ + Some (y, sR_state s2)). + - apply (∀ (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) + (y : Outs (sReifier_ops NotCtxDep _ op) ♯ X) + (s1 s2 : sReifier_state NotCtxDep r ♯ X), + sReifier_re NotCtxDep r op (x, s1) ≡{m}≡ Some (y, s2) → + sReifier_re NotCtxDep (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1) ≡{m}≡ + Some (subEff_outs y, sR_state s2)). + Defined. + + Class subReifier {n} {a : is_ctx_dep} (r : sReifier a) (rs : gReifiers a n) := { sR_idx : fin n; - sR_ops :: subEff (sReifier_ops r) (sReifier_ops (rs !!! sR_idx)); + sR_ops :: subEff (sReifier_ops a r) (sReifier_ops a (rs !!! sR_idx)); sR_state {X} `{!Cofe X} : - sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X; - sR_re (m : nat) {X} `{!Cofe X} (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops r op) ♯ X) - (y : laterO X) - (s1 s2 : sReifier_state r ♯ X) - (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) : - sReifier_re r op (x, s1, k) ≡{m}≡ Some (y, s2) → - sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡{m}≡ - Some (y, sR_state s2) + sReifier_state a r ♯ X ≃ sReifier_state a (rs !!! sR_idx) ♯ X; + sR_re (m : nat) {X} `{!Cofe X} (op : opid (sReifier_ops a r)) + : sR_re_type a r rs sR_idx sR_ops (@sR_state X _) m op }. - #[global] Instance subReifier_here {n} (r : sReifier) (rs : gReifiers n) : - subReifier r (gReifiers_cons r rs). + #[global] Instance subReifier_here {n} {a : is_ctx_dep} + (r : sReifier a) (rs : gReifiers a n) : + subReifier r (gReifiers_cons a r rs). Proof. simple refine ({| sR_idx := 0%fin |}). - simpl. apply subEff_id. - simpl. intros. apply iso_ofe_refl. - - intros X ? op x y ? s1 s2 k HEQ; simpl. - unfold ofe_iso_1'; simpl. - rewrite ccompose_id_r HEQ. - reflexivity. + - destruct a. + + intros X ? op x y ? s1 s2 k HEQ; simpl. + unfold ofe_iso_1'; simpl. + rewrite ccompose_id_r HEQ. + reflexivity. + + intros X ? op x y s1 s2. + simpl. eauto. Defined. - #[global] Instance subReifier_there {n} (r r' : sReifier) (rs : gReifiers n) : + #[global] Instance subReifier_there {n} {a : is_ctx_dep} + (r r' : sReifier a) (rs : gReifiers a n) : subReifier r rs → - subReifier r (gReifiers_cons r' rs). + subReifier r (gReifiers_cons a r' rs). Proof. intros SR. simple refine ({| sR_idx := FS sR_idx |}). - simpl. intros. apply sR_state. - - intros X ? op x y s1 s2. - simpl. apply sR_re. + - destruct a. + + intros ? X ? op x y s1 s2. + simpl. intros. + pose proof (@sR_re n CtxDep r rs _ m X _ op) as G. + simpl in G. + by apply G. + + intros ? X ? op x y s1 s2. + simpl. intros. + pose proof (@sR_re n NotCtxDep r rs _ m X _ op) as G. + simpl in G. + by apply G. Defined. - #[local] Definition subR_op {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : - opid (sReifier_ops r) → opid (gReifiers_ops rs). + #[local] Definition subR_op {n} {a : is_ctx_dep} + {r : sReifier a} {rs : gReifiers a n} `{!subReifier r rs} : + opid (sReifier_ops a r) → opid (gReifiers_ops a rs). Proof. intros op. simpl. refine (existT sR_idx (subEff_opid op)). Defined. - #[export] Instance subReifier_subEff {n} {r : sReifier} {rs : gReifiers n} `{!subReifier r rs} : - subEff (sReifier_ops r) (gReifiers_ops rs). + + #[export] Instance subReifier_subEff {n} {a : is_ctx_dep} + {r : sReifier a} {rs : gReifiers a n} `{!subReifier r rs} : + subEff (sReifier_ops a r) (gReifiers_ops a rs). Proof. simple refine {| subEff_opid := subR_op |}. - intros op X ?. simpl. @@ -212,90 +349,216 @@ Section greifiers. apply subEff_outs. Defined. - Lemma subReifier_reify_idx {n} (r : sReifier) (rs : gReifiers n) - `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) - (* (y : Outs (sReifier_ops _ op) ♯ X) *) - (y : laterO X) - (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) - (s1 s2 : sReifier_state r ♯ X) : - sReifier_re r op (x, s1, k) ≡ Some (y, s2) → - sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ - Some (y, sR_state s2). + Program Definition subReifier_reify_idx_type {n} + (a : is_ctx_dep) (r : sReifier a) (rs : gReifiers a n) + `{!subReifier r rs} X `{!Cofe X} (op : opid (sReifier_ops a r)) : Type. + Proof. + destruct a. + - apply (∀ (x : Ins (sReifier_ops CtxDep r op) ♯ X) + (y : laterO X) + (s1 s2 : sReifier_state CtxDep r ♯ X) + (k : (Outs (sReifier_ops CtxDep r op) ♯ X -n> laterO X)), + sReifier_re CtxDep r op (x, s1, k) ≡ Some (y, s2) → + sReifier_re CtxDep (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ + Some (y, sR_state s2)). + - apply (∀ (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) + (y : Outs (sReifier_ops NotCtxDep _ op) ♯ X) + (s1 s2 : sReifier_state NotCtxDep r ♯ X), + sReifier_re NotCtxDep r op (x, s1) ≡ Some (y, s2) → + sReifier_re NotCtxDep (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1) ≡ + Some (subEff_outs y, sR_state s2)). + Defined. + + Lemma subReifier_reify_idx {n} {a : is_ctx_dep} + (r : sReifier a) (rs : gReifiers a n) + `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops a r)) + : subReifier_reify_idx_type a r rs X op. Proof. - intros Hx. apply equiv_dist=>m. - apply sR_re. by apply equiv_dist. + destruct a. + - intros Hx. intros. apply equiv_dist=>m. + pose proof (@sR_re n CtxDep r rs _ m X _ op Hx y s1 s2 k) as G. + simpl in G. + rewrite G; first done. + by apply equiv_dist. + - intros Hx. intros. apply equiv_dist=>m. + pose proof (@sR_re n NotCtxDep r rs _ m X _ op Hx y s1 s2) as G. + simpl in G. + rewrite G; first done. + by apply equiv_dist. Qed. - Lemma subReifier_reify {n} (r : sReifier) - (rs : gReifiers n) `{!subReifier r rs} {X} `{!Cofe X} - (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) (y : laterO X) - (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) - (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : - sReifier_re r op (x, σ, k) ≡ Some (y, σ') → - gReifiers_re rs (subEff_opid op) - (subEff_ins x, gState_recomp rest (sR_state σ), k ◎ (subEff_outs ^-1)) - ≡ Some (y, gState_recomp rest (sR_state σ')). + Program Definition subReifier_reify_type {n} (a : is_ctx_dep) (r : sReifier a) + (rs : gReifiers a n) `{!subReifier r rs} X `{!Cofe X} + (op : opid (sReifier_ops a r)) : Type. + Proof. + destruct a. + - apply (∀ (x : Ins (sReifier_ops CtxDep _ op) ♯ X) (y : laterO X) + (k : (Outs (sReifier_ops CtxDep r op) ♯ X -n> laterO X)) + (σ σ' : sReifier_state CtxDep r ♯ X) (rest : gState_rest CtxDep sR_idx rs ♯ X), + sReifier_re CtxDep r op (x, σ, k) ≡ Some (y, σ') → + gReifiers_re CtxDep rs (subEff_opid op) + (subEff_ins x, gState_recomp CtxDep rest (sR_state σ), k ◎ (subEff_outs ^-1)) + ≡ Some (y, gState_recomp CtxDep rest (sR_state σ'))). + - apply (∀ (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) (y : Outs (sReifier_ops NotCtxDep _ op) ♯ X) + (σ σ' : sReifier_state NotCtxDep r ♯ X) (rest : gState_rest NotCtxDep sR_idx rs ♯ X), + sReifier_re NotCtxDep r op (x,σ) ≡ Some (y, σ') → + gReifiers_re NotCtxDep rs (subEff_opid op) + (subEff_ins x, gState_recomp NotCtxDep rest (sR_state σ)) + ≡ Some (subEff_outs y, gState_recomp NotCtxDep rest (sR_state σ'))). + Defined. + + Lemma subReifier_reify {n} {a : is_ctx_dep} (r : sReifier a) + (rs : gReifiers a n) `{!subReifier r rs} {X} `{!Cofe X} + (op : opid (sReifier_ops a r)) : subReifier_reify_type a r rs X op. Proof. - intros Hre. - eapply subReifier_reify_idx in Hre. - rewrite gReifiers_re_idx//. - rewrite Hre. simpl. - do 3 f_equiv. + destruct a. + - simpl. + intros x y k σ σ' H Hre. + pose proof (@subReifier_reify_idx n CtxDep r rs _ X _ op x y σ σ' k Hre) as J; clear Hre. + simpl in J. + pose proof (@gReifiers_re_idx n CtxDep sR_idx rs X _ (subEff_opid op)) as J'. + simpl in J'. + rewrite J'; clear J'. + transitivity (prod_map (λ x0 : laterO X, x0) + (λ st : sReifier_state CtxDep (rs !!! sR_idx) ♯ X, + (gState_decomp' CtxDep sR_idx rs ^-1) (st, H)) <$> + (Some (y, sR_state σ'))). + + unfold prod_map. + rewrite option_fmap_proper; [reflexivity | intros ??? | apply J]. + do 2 f_equiv; first assumption. + do 2 f_equiv; assumption. + + simpl; reflexivity. + - simpl. + intros x y σ σ' rest Hre. + pose proof (@subReifier_reify_idx n NotCtxDep r rs _ X _ op x y σ σ' Hre) + as J; clear Hre. + simpl in J. + pose proof (@gReifiers_re_idx n NotCtxDep sR_idx rs X _ (subEff_opid op)) + as J'. + simpl in J'. + rewrite J'; clear J'. + transitivity (prod_map (λ x0 : Outs (sReifier_ops NotCtxDep (rs !!! sR_idx) + (subEff_opid op)) ♯ X, x0) + (λ st : sReifier_state NotCtxDep (rs !!! sR_idx) ♯ X, + (gState_decomp' NotCtxDep sR_idx rs ^-1) (st, rest)) <$> + (Some (subEff_outs y, sR_state σ'))). + + unfold prod_map. + rewrite option_fmap_proper; [reflexivity | intros ??? | apply J]. + do 2 f_equiv; first assumption. + do 2 f_equiv; assumption. + + simpl; reflexivity. Qed. (** Lemma for reasoning internally in iProp *) Context `{!invGS_gen hlc Σ}. Notation iProp := (iProp Σ). Context {sz : nat}. - Variable (rs : gReifiers sz). - Notation sr := (gReifiers_sReifier rs). + Notation sr a rs := (gReifiers_sReifier a rs). - Lemma reify_vis_eqI {A} `{!Cofe A} op i k o σ σ' : - (gReifiers_re rs op (i, σ, k) ≡ Some (o,σ') ⊢@{iProp} reify sr (Vis op i k : IT _ A) σ ≡ (σ', Tau $ o))%I. + Lemma reify_vis_eqI_ctx_dep (rs : gReifiers CtxDep sz) + {A} `{!Cofe A} op i k o σ σ' : + (gReifiers_re CtxDep rs op (i, σ, k) ≡ Some (o,σ') + ⊢@{iProp} reify (sr CtxDep rs) (Vis op i k : IT _ A) σ ≡ (σ', Tau $ o))%I. Proof. apply uPred.internal_eq_entails=>m. - intros H. apply reify_vis_dist. exact H. + intros H. apply reify_vis_dist_ctx_dep. exact H. Qed. - Lemma subReifier_reify_idxI (r : sReifier) - `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) + Lemma reify_vis_eqI_ctx_indep (rs : gReifiers NotCtxDep sz) + {A} `{!Cofe A} op i k o σ σ' : + (gReifiers_re NotCtxDep rs op (i, σ) ≡ Some (o,σ') + ⊢@{iProp} reify (sr NotCtxDep rs) (Vis op i k : IT _ A) σ ≡ (σ', Tau $ k o))%I. + Proof. + apply uPred.internal_eq_entails=>m. + intros H. apply reify_vis_dist_ctx_indep. exact H. + Qed. + + Lemma subReifier_reify_idxI_ctx_dep (r : sReifier CtxDep) + `{!@subReifier sz CtxDep r rs} {X} `{!Cofe X} (op : opid (sReifier_ops CtxDep r)) + (x : Ins (sReifier_ops CtxDep _ op) ♯ X) (y : laterO X) - (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) - (s1 s2 : sReifier_state r ♯ X) : - sReifier_re r op (x, s1, k) ≡ Some (y, s2) ⊢@{iProp} - sReifier_re (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ - Some (y, sR_state s2). + (k : (Outs (sReifier_ops CtxDep r op) ♯ X -n> laterO X)) + (s1 s2 : sReifier_state CtxDep r ♯ X) : + sReifier_re CtxDep r op (x, s1, k) ≡ Some (y, s2) ⊢@{iProp} + sReifier_re CtxDep (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ + Some (y, sR_state s2). Proof. apply uPred.internal_eq_entails=>m. - intros H. - rewrite sR_re; last first. - - rewrite H. + intros H'. + rewrite (sR_re (a := CtxDep)); last first. + - rewrite H'. reflexivity. - reflexivity. Qed. - Lemma subReifier_reifyI (r : sReifier) - `{!subReifier r rs} {X} `{!Cofe X} - (op : opid (sReifier_ops r)) - (x : Ins (sReifier_ops _ op) ♯ X) (y : laterO X) - (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) - (σ σ' : sReifier_state r ♯ X) (rest : gState_rest sR_idx rs ♯ X) : - sReifier_re r op (x,σ, k) ≡ Some (y, σ') ⊢@{iProp} - gReifiers_re rs (subEff_opid op) - (subEff_ins x, gState_recomp rest (sR_state σ), k ◎ (subEff_outs ^-1)) - ≡ Some (y, gState_recomp rest (sR_state σ')). + Lemma subReifier_reify_idxI_ctx_indep (r : sReifier NotCtxDep) + `{!@subReifier sz NotCtxDep r rs} {X} `{!Cofe X} (op : opid (sReifier_ops NotCtxDep r)) + (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) + (y : Outs (sReifier_ops NotCtxDep _ op) ♯ X) + (s1 s2 : sReifier_state NotCtxDep r ♯ X) : + sReifier_re NotCtxDep r op (x, s1) ≡ Some (y, s2) + ⊢@{iProp} + sReifier_re NotCtxDep (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1) ≡ + Some (subEff_outs y, sR_state s2). + Proof. + apply uPred.internal_eq_entails=>m. + apply (sR_re (a := NotCtxDep)). + Qed. + + Lemma subReifier_reifyI_ctx_dep (r : sReifier CtxDep) + `{!@subReifier sz CtxDep r rs} {X} `{!Cofe X} + (op : opid (sReifier_ops CtxDep r)) + (x : Ins (sReifier_ops CtxDep _ op) ♯ X) (y : laterO X) + (k : (Outs (sReifier_ops CtxDep r op) ♯ X -n> laterO X)) + (σ σ' : sReifier_state CtxDep r ♯ X) (rest : gState_rest CtxDep sR_idx rs ♯ X) : + sReifier_re CtxDep r op (x,σ, k) ≡ Some (y, σ') ⊢@{iProp} + gReifiers_re CtxDep rs (subEff_opid op) + (subEff_ins x, gState_recomp CtxDep rest (sR_state σ), k ◎ (subEff_outs ^-1)) + ≡ Some (y, gState_recomp CtxDep rest (sR_state σ')). Proof. apply uPred.internal_eq_entails=>m. intros He. - eapply sR_re in He. - rewrite gReifiers_re_idx//. + eapply (sR_re (a := CtxDep)) in He. + rewrite (gReifiers_re_idx CtxDep)//. rewrite He. simpl. reflexivity. Qed. + Lemma subReifier_reifyI_ctx_indep (r : sReifier NotCtxDep) + `{!@subReifier sz NotCtxDep r rs} {X} `{!Cofe X} + (op : opid (sReifier_ops NotCtxDep r)) + (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) (y : Outs (sReifier_ops NotCtxDep _ op) ♯ X) + (σ σ' : sReifier_state NotCtxDep r ♯ X) (rest : gState_rest NotCtxDep sR_idx rs ♯ X) : + sReifier_re NotCtxDep r op (x,σ) ≡ Some (y, σ') + ⊢@{iProp} + gReifiers_re NotCtxDep rs (subEff_opid op) + (subEff_ins x, gState_recomp NotCtxDep rest (sR_state σ)) + ≡ Some (subEff_outs y, gState_recomp NotCtxDep rest (sR_state σ')). + Proof. + apply uPred.internal_eq_entails=>m. + intros He. + eapply (sR_re (a := NotCtxDep)) in He. + pose proof (@gReifiers_re_idx sz NotCtxDep sR_idx rs X _ (subEff_opid op) + (subEff_ins x)) as J. + simpl in J. + simpl. + rewrite J//; clear J. + transitivity (prod_map (λ x0 : Outs (sReifier_ops NotCtxDep (rs !!! sR_idx) + (subEff_opid op)) ♯ X, x0) + (λ st : sReifier_state NotCtxDep (rs !!! sR_idx) ♯ X, + (gState_decomp' NotCtxDep sR_idx rs ^-1) (st, rest)) <$> + (Some + (subEff_outs y, sR_state σ'))). + - unfold prod_map. + rewrite option_fmap_ne; [reflexivity | intros ??? | apply He]. + do 2 f_equiv; first assumption. + do 2 f_equiv; assumption. + - simpl. + reflexivity. + Qed. + End greifiers. diff --git a/theories/gitree/reductions.v b/theories/gitree/reductions.v index 8036625..cfd14bd 100644 --- a/theories/gitree/reductions.v +++ b/theories/gitree/reductions.v @@ -4,16 +4,13 @@ From gitrees Require Import prelude. From gitrees.gitree Require Import core reify. Section sstep. - Context {A} `{!Cofe A}. - Context (r : sReifier). - Notation F := (sReifier_ops r). - Notation stateF := (sReifier_state r). + Context {A} `{!Cofe A} {a : is_ctx_dep}. + Context (r : sReifier a). + Notation F := (sReifier_ops a r). + Notation stateF := (sReifier_state a r). Notation IT := (IT F A). Notation ITV := (ITV F A). Notation stateO := (stateF ♯ IT). - Implicit Type op : opid F. - Implicit Type α β : IT. - Implicit Type σ : stateO. (** ** Reductions at the Prop level *) Inductive sstep : IT → stateO → IT → stateO → Prop := @@ -25,7 +22,8 @@ Section sstep. α ≡ Vis op i k → reify r α σ1 ≡ (σ2, Tick β) → sstep α σ1 β σ2. - #[export] Instance sstep_proper : Proper ((≡) ==> (≡) ==> (≡) ==> (≡) ==> (iff)) sstep. + #[export] Instance sstep_proper + : Proper ((≡) ==> (≡) ==> (≡) ==> (≡) ==> (iff)) sstep. Proof. intros α1 α2 Ha σ1 σ2 Hs β1 β2 Hb σ'1 σ'2 Hs'. simplify_eq/=. split. @@ -47,13 +45,14 @@ Section sstep. rewrite -H0. repeat f_equiv; eauto. Qed. - Inductive ssteps : IT → stateO → IT → stateO → nat → Prop := + Inductive ssteps : IT → stateO → IT → stateO → nat → Prop := | ssteps_zero α β σ σ' : α ≡ β → σ ≡ σ' → ssteps α σ β σ' 0 | ssteps_many α1 σ1 α2 σ2 α3 σ3 n2 : sstep α1 σ1 α2 σ2 → ssteps α2 σ2 α3 σ3 n2 → ssteps α1 σ1 α3 σ3 (1+n2). - #[export] Instance ssteps_proper : Proper ((≡) ==> (≡) ==> (≡) ==> (≡) ==> (=) ==> (iff)) ssteps. + #[export] Instance ssteps_proper + : Proper ((≡) ==> (≡) ==> (≡) ==> (≡) ==> (=) ==> (iff)) ssteps. Proof. intros α α' Ha σ σ' Hs β β' Hb σ2 σ2' Hs2 n1 n2 Hnm. fold_leibniz. simplify_eq/=. @@ -87,10 +86,10 @@ Section sstep. End sstep. Section istep. - Context {A} `{!Cofe A}. - Context (r : sReifier). - Notation F := (sReifier_ops r). - Notation stateF := (sReifier_state r). + Context {A} `{!Cofe A} {a : is_ctx_dep}. + Context (r : sReifier a). + Notation F := (sReifier_ops a r). + Notation stateF := (sReifier_state a r). Notation IT := (IT F A). Notation ITV := (ITV F A). Notation stateO := (stateF ♯ IT). @@ -105,11 +104,11 @@ Section istep. Solve All Obligations with solve_proper. Program Definition isteps_pre - (self : IT -n> stateO -n> IT -n> stateO -n> natO -n> iProp): + (self : IT -n> stateO -n> IT -n> stateO -n> natO -n> iProp): IT -n> stateO -n> IT -n> stateO -n> natO -n> iProp := λne α σ β σ' n, ((n ≡ 0 ∧ α ≡ β ∧ σ ≡ σ') - ∨ (∃ n' α0 σ0, n ≡ (1+n') ∧ istep α σ α0 σ0 ∧ - ▷ self α0 σ0 β σ' n'))%I. + ∨ (∃ n' α0 σ0, n ≡ (1+n') ∧ istep α σ α0 σ0 ∧ + ▷ self α0 σ0 β σ' n'))%I. Solve All Obligations with solve_proper. Global Instance isteps_pre_ne : NonExpansive isteps_pre. @@ -122,8 +121,8 @@ Section istep. Lemma isteps_unfold α β σ σ' n : isteps α σ β σ' n ≡ ((n ≡ 0 ∧ α ≡ β ∧ σ ≡ σ') - ∨ (∃ n' α0 σ0, n ≡ (1+n') ∧ istep α σ α0 σ0 ∧ - ▷ isteps α0 σ0 β σ' n'))%I. + ∨ (∃ n' α0 σ0, n ≡ (1+n') ∧ istep α σ α0 σ0 ∧ + ▷ isteps α0 σ0 β σ' n'))%I. Proof. unfold isteps. apply (fixpoint_unfold isteps_pre _ _ _ _ _) . Qed. @@ -179,7 +178,7 @@ Section istep. Proof. intros Hprf. destruct (IT_dont_confuse α) - as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. + as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. + exfalso. eapply uPred.pure_soundness. iPoseProof (Hprf) as "H". iDestruct "H" as (β σ') "[Ha Hs]". rewrite Ha. @@ -207,7 +206,7 @@ Section istep. Proof. intros Hprf. destruct (IT_dont_confuse α) - as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. + as [[e Ha] | [[n Ha] | [ [g Ha] | [[α' Ha]|[op [i [k Ha]]]] ]]]. + exfalso. eapply uPred.pure_soundness. iPoseProof (Hprf) as "H". iDestruct "H" as (β σ' op i k) "[Ha _]". rewrite Ha. @@ -246,7 +245,7 @@ Section istep. Local Lemma istep_safe_disj α σ : (∃ β σ', istep α σ β σ') - ⊢ (∃ β σ', α ≡ Tick β ∧ σ ≡ σ') + ⊢ (∃ β σ', α ≡ Tick β ∧ σ ≡ σ') ∨ (∃ β σ', (∃ op i k, α ≡ Vis op i k ∧ reify r α σ ≡ (σ', Tick β))). Proof. rewrite -bi.or_exist. @@ -321,7 +320,8 @@ Section istep. ++ iApply (IT_fun_vis_ne with "Ht"). Qed. Lemma isteps_tick α βv σ σ' k : - isteps (Tick α) σ (IT_of_V βv) σ' k ⊢ ∃ k' : nat, ⌜k = (1 + k')%nat⌝ ∧ ▷ isteps α σ (IT_of_V βv) σ' k'. + isteps (Tick α) σ (IT_of_V βv) σ' k + ⊢ ∃ k' : nat, ⌜k = (1 + k')%nat⌝ ∧ ▷ isteps α σ (IT_of_V βv) σ' k'. Proof. rewrite isteps_unfold. iDestruct 1 as "[[Hk [Ht Hs]] | H]". @@ -337,8 +337,22 @@ Section istep. iRewrite -"Ha". iRewrite "Hs". done. Qed. - Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' {G : ∀ o, CtxIndep r IT o} : - istep α σ β σ' ⊢ istep (f α) σ (f β) σ' : iProp. +End istep. + +Section istep_ctx_indep. + Context {A} `{!Cofe A}. + Context (r : sReifier NotCtxDep). + Notation F := (sReifier_ops NotCtxDep r). + Notation stateF := (sReifier_state NotCtxDep r). + Notation IT := (IT F A). + Notation ITV := (ITV F A). + Notation stateO := (stateF ♯ IT). + + Context `{!invGS_gen hlc Σ}. + Notation iProp := (iProp Σ). + + Lemma istep_hom (f : IT → IT) `{!IT_hom f} α σ β σ' : + istep r α σ β σ' ⊢ istep r (f α) σ (f β) σ' : iProp. Proof. iDestruct 1 as "[[Ha Hs]|H]". - iRewrite "Ha". iLeft. iSplit; eauto. iPureIntro. apply hom_tick. @@ -352,14 +366,15 @@ Section istep. iApply (reify_vis_cont with "Hr"). Qed. - Lemma istep_hom_inv α σ β σ' `{!IT_hom f} {G : ∀ o, CtxIndep r IT o} : - istep (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ - ∨ (IT_to_V α ≡ None ∧ ∃ α', istep α σ α' σ' ∧ ▷ (β ≡ f α')). + Lemma istep_hom_inv α σ β σ' (f : IT → IT) `{!IT_hom f} : + istep r (f α) σ β σ' ⊢@{iProp} ⌜is_Some (IT_to_V α)⌝ + ∨ (IT_to_V α ≡ None ∧ ∃ α', istep r α σ α' σ' + ∧ ▷ (β ≡ f α')). Proof. iIntros "H". destruct (IT_dont_confuse α) as [[e Ha] | [[n Ha] | [ [g Ha] | [[la Ha]|[op [i [k Ha]]]] ]]]. - - iExFalso. iApply (istep_err σ e β σ'). + - iExFalso. iApply (istep_err r σ e β σ'). iAssert (f α ≡ Err e)%I as "Hf". { iPureIntro. by rewrite Ha hom_err. } iRewrite "Hf" in "H". done. @@ -396,5 +411,4 @@ Section istep. iExists op,i,k. iFrame "Hr". iPureIntro. apply Ha. Qed. - -End istep. +End istep_ctx_indep. diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 4050501..49e5deb 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -2,8 +2,12 @@ From iris.proofmode Require Import classes tactics. From gitrees Require Import prelude. From gitrees.gitree Require Import core. -Section reifiers. - Context {A} `{!Cofe A}. +Section reifier. + Inductive is_ctx_dep : Type := + | CtxDep + | NotCtxDep. + + Context {A} `{!Cofe A} (icd : is_ctx_dep). #[local] Open Scope type. (** A single reifier *) @@ -11,57 +15,65 @@ Section reifiers. { sReifier_ops : opsInterp; sReifier_state : oFunctor; sReifier_re {X} `{!Cofe X} : forall (op : opid sReifier_ops), - (Ins (sReifier_ops op) ♯ X) * (sReifier_state ♯ X) * ((Outs (sReifier_ops op) ♯ X) -n> laterO X) - -n> optionO (laterO X * (sReifier_state ♯ X)); + match icd with + | CtxDep => + (Ins (sReifier_ops op) ♯ X) + * (sReifier_state ♯ X) + * ((Outs (sReifier_ops op) ♯ X) -n> laterO X) + -n> optionO (laterO X * (sReifier_state ♯ X)) + | NotCtxDep => + (Ins (sReifier_ops op) ♯ X) + * (sReifier_state ♯ X) + -n> optionO ((Outs (sReifier_ops op) ♯ X) * (sReifier_state ♯ X)) + end; sReifier_inhab :: Inhabited (sReifier_state ♯ unitO); sReifier_cofe X (HX : Cofe X) :: Cofe (sReifier_state ♯ X); }. +End reifier. - Context (r : sReifier). - Notation F := (sReifier_ops r). - Notation stateF := (sReifier_state r). - Notation IT := (IT F A). - Notation ITV := (ITV F A). - Implicit Type op : opid F. - Implicit Type α β : IT. - - Class CtxIndep (X : ofe) `{!Cofe X} (op : opid F) := { - cont_irrelev : - (∃ f : (prodO (Ins (sReifier_ops r _) ♯ X) ((sReifier_state r) ♯ X)) -n> - optionO (prodO (Outs (sReifier_ops r _) ♯ X) (sReifier_state r ♯ X)), - ∀ i σ κ, @sReifier_re _ X _ op (i, σ, κ) ≡ fmap (prodO_map κ idfun) (f (i, σ))); - }. +Section reifier_cofe_inst. + Context {A} `{!Cofe A}. + #[local] Open Scope type. + Notation F a r := (sReifier_ops a r). + Notation stateF a r := (sReifier_state a r). + Notation IT a r := (IT (F a r) A). + Notation ITV a r := (ITV (F a r) A). + Notation stateM a r := ((stateF a r) ♯ (IT a r) -n> ((stateF a r) ♯ (IT a r)) * (IT a r)). - Notation stateM := ((stateF ♯ IT -n> (stateF ♯ IT) * IT)). - #[local] Instance stateT_inhab : Inhabited stateM. + #[global] Instance stateT_inhab {a r} : Inhabited (stateM a r). Proof. simple refine (populate (λne s, (s, inhabitant))). { apply _. } solve_proper. Qed. - #[local] Instance stateM_cofe : Cofe stateM. + #[global] Instance stateM_cofe {a r} : Cofe (stateM a r). Proof. unfold stateM. apply _. Qed. - Opaque laterO_map. - - Program Definition reify_fun : laterO (sumO IT stateM -n> prodO IT stateM) -n> stateM := - λne f s, (s, Fun $ laterO_map (λne f, fstO ◎ f ◎ inlO) f). - Solve All Obligations with solve_proper. +End reifier_cofe_inst. - Program Definition reify_tau : laterO (prodO IT stateM) -n> stateM := - λne x s, (s, Tau $ laterO_map fstO x). - Solve All Obligations with solve_proper. +Section reifier_vis. + Context {A} `{!Cofe A}. + #[local] Open Scope type. + Notation F a r := (sReifier_ops a r). + Notation stateF a r := (sReifier_state a r). + Notation IT a r := (IT (F a r) A). + Notation ITV a r := (ITV (F a r) A). + Notation stateM a r := ((stateF a r) ♯ (IT a r) -n> ((stateF a r) ♯ (IT a r)) * (IT a r)). - Program Definition reify_vis ( op : opid F ) : - oFunctor_car (Ins (F op)) (sumO IT stateM) (prodO IT stateM) -n> - (oFunctor_car (Outs (F op)) (prodO IT stateM) (sumO IT stateM) -n> laterO (prodO IT stateM)) -n> stateM. + Program Definition reify_vis_ctx_dep (r : sReifier CtxDep) ( op : opid (F CtxDep r)) : + oFunctor_car (Ins (F CtxDep r op)) + (sumO (IT CtxDep r) (stateM CtxDep r)) (prodO (IT CtxDep r) (stateM CtxDep r)) -n> + (oFunctor_car (Outs (F CtxDep r op)) (prodO (IT CtxDep r) (stateM CtxDep r)) + (sumO (IT CtxDep r) (stateM CtxDep r)) + -n> laterO (prodO (IT CtxDep r) (stateM CtxDep r))) -n> (stateM CtxDep r). Proof. simpl. - simple refine (λne i (k : _ -n> _) (s : stateF ♯ IT), _). + simple refine (λne i (k : _ -n> _) (s : stateF CtxDep r ♯ (IT CtxDep r)), _). - simple refine - (let ns := sReifier_re r op + (let ns := sReifier_re CtxDep r op (oFunctor_map _ (inlO,fstO) i, s, - (λne o, (laterO_map fstO $ k $ oFunctor_map (Outs (F op)) (fstO, inlO) o))) in _). + (λne o, (laterO_map fstO $ k + $ oFunctor_map (Outs (F CtxDep r op)) (fstO, inlO) o))) in _). + intros m s1 s2 Hs. solve_proper. + simple refine (from_option (λ ns, (ns.2, Tau $ ns.1)) @@ -73,6 +85,56 @@ Section reifiers. - intros m i1 i2 Hi k s. simpl. eapply (from_option_ne (dist m)); solve_proper. Defined. + Program Definition reify_vis_ctx_indep (r : sReifier NotCtxDep) ( op : opid (F NotCtxDep r) ) : + oFunctor_car (Ins (F NotCtxDep r op)) (sumO (IT NotCtxDep r) (stateM NotCtxDep r)) + (prodO (IT NotCtxDep r) (stateM NotCtxDep r)) -n> + (oFunctor_car (Outs (F NotCtxDep r op)) (prodO (IT NotCtxDep r) (stateM NotCtxDep r)) + (sumO (IT NotCtxDep r) (stateM NotCtxDep r)) + -n> laterO (prodO (IT NotCtxDep r) (stateM NotCtxDep r))) -n> (stateM NotCtxDep r). + Proof. + simpl. + simple refine (λne i (k : _ -n> _) (s : stateF NotCtxDep r ♯ (IT NotCtxDep r)), _). + - simple refine (let ns := sReifier_re NotCtxDep r op (oFunctor_map _ (inlO,fstO) i, s) in _). + simple refine (from_option (λ ns, + let out2' := k $ oFunctor_map (Outs (F NotCtxDep r op)) (fstO,inlO) ns.1 in + (ns.2, Tau $ laterO_map fstO out2')) + (s, Err RuntimeErr) ns). + - intros m s1 s2 Hs. simpl. eapply (from_option_ne (dist m)); solve_proper. + - intros m k1 k2 Hk s. simpl. eapply (from_option_ne (dist m)); solve_proper. + - intros m i1 i2 Hi k s. simpl. eapply (from_option_ne (dist m)); solve_proper. + Defined. + + Program Definition reify_vis (a : is_ctx_dep) (r : sReifier a) : ∀ ( op : opid (F a r)), + oFunctor_car (Ins (F a r op)) (sumO (IT a r) (stateM a r)) (prodO (IT a r) (stateM a r)) -n> + (oFunctor_car (Outs (F a r op)) (prodO (IT a r) (stateM a r)) + (sumO (IT a r) (stateM a r)) -n> laterO (prodO (IT a r) (stateM a r))) -n> (stateM a r). + Proof. + destruct a. + - apply reify_vis_ctx_dep. + - apply reify_vis_ctx_indep. + Defined. +End reifier_vis. + +Section reify. + Context {A} `{!Cofe A} {a : is_ctx_dep}. + #[local] Open Scope type. + Context {r : sReifier a}. + Notation F := (sReifier_ops a r). + Notation stateF := (sReifier_state a r). + Notation IT := (IT F A). + Notation ITV := (ITV F A). + Notation stateM := (stateF ♯ IT -n> (stateF ♯ IT) * IT). + + Opaque laterO_map. + + Program Definition reify_fun : laterO (sumO IT stateM -n> prodO IT stateM) -n> stateM := + λne f s, (s, Fun $ laterO_map (λne f, fstO ◎ f ◎ inlO) f). + Solve All Obligations with solve_proper. + + Program Definition reify_tau : laterO (prodO IT stateM) -n> stateM := + λne x s, (s, Tau $ laterO_map fstO x). + Solve All Obligations with solve_proper. + Program Definition reify_err : errorO -n> stateM := λne e s, (s, Err e). Solve All Obligations with solve_proper. @@ -80,35 +142,36 @@ Section reifiers. Solve All Obligations with solve_proper. Program Definition unr : stateM -n> - sumO (sumO (sumO (sumO A (laterO (stateM -n> stateM))) errorO) (laterO stateM)) - (sigTO (λ op : opid F, prodO (oFunctor_apply (Ins (F op)) stateM) (oFunctor_apply (Outs (F op)) stateM -n> laterO stateM))). + sumO (sumO (sumO (sumO A (laterO (stateM -n> stateM))) errorO) (laterO stateM)) + (sigTO (λ op : opid F, prodO (oFunctor_apply (Ins (F op)) stateM) + (oFunctor_apply (Outs (F op)) stateM -n> laterO stateM))). Proof. simple refine (λne d, inl (inl (inr (RuntimeErr)))). Qed. Definition reify : IT -n> stateM := IT_rec1 _ - reify_err - reify_ret - reify_fun - reify_tau - reify_vis - unr. + reify_err + reify_ret + reify_fun + reify_tau + (reify_vis a r) + unr. Definition unreify : stateM -n> IT := IT_rec2 _ - reify_err - reify_ret - reify_fun - reify_tau - reify_vis - unr. + reify_err + reify_ret + reify_fun + reify_tau + (reify_vis a r) + unr. Lemma reify_fun_eq f σ : reify (Fun f) σ ≡ (σ, Fun f). Proof. rewrite /reify/=. trans (reify_fun (laterO_map (sandwich (Perr:=reify_err) (Pret:=reify_ret) - (Parr:=reify_fun) (Ptau:=reify_tau) - (Pvis:=reify_vis) (Punfold:=unr) - stateM) f) σ). + (Parr:=reify_fun) (Ptau:=reify_tau) + (Pvis:=reify_vis a r) (Punfold:=unr) + (stateM)) f) σ). { f_equiv. apply IT_rec1_fun. } simpl. repeat f_equiv. rewrite -laterO_map_compose. @@ -117,22 +180,37 @@ Section reifiers. apply laterO_map_id. Qed. - Lemma reify_vis_dist m op i o k σ σ' : - sReifier_re r op (i, σ, k) ≡{m}≡ Some (o, σ') → +End reify. + +Section reify_props. + Context {A} `{!Cofe A}. + #[local] Open Scope type. + Notation F a r := (sReifier_ops a r). + Notation stateF a r := (sReifier_state a r). + Notation IT a r := (IT (F a r) A). + Notation ITV a r := (ITV (F a r) A). + Notation stateM a r := (stateF a r ♯ (IT a r) -n> (stateF a r ♯ (IT a r)) * (IT a r)). + + Opaque laterO_map. + + Lemma reify_vis_dist_ctx_dep (r : sReifier CtxDep) m op i o k σ σ' : + @sReifier_re CtxDep r (IT CtxDep r) _ op (i, σ, k) ≡{m}≡ Some (o, σ') → reify (Vis op i k) σ ≡{m}≡ (σ', Tau o). Proof. intros Hst. - trans (reify_vis op + trans (reify_vis CtxDep r op (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) - (laterO_map (prod_in idfun reify) ◎ k ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) + (laterO_map (prod_in idfun reify) ◎ k + ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) σ). { f_equiv. rewrite IT_rec1_vis//. } Opaque prod_in. simpl. - pose (rs := (sReifier_re r op - (oFunctor_map (Ins (F op)) (inlO, fstO) - (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ, k))). + pose (rs := (sReifier_re _ r op + (oFunctor_map (Ins (F _ _ op)) (inlO, fstO) + (oFunctor_map (Ins (F _ _ op)) + (sumO_rec idfun unreify, prod_in idfun reify) i), σ, k))). fold rs. - assert (rs ≡ sReifier_re r op (i,σ, k)) as Hr'. + assert (rs ≡ sReifier_re _ r op (i,σ, k)) as Hr'. { unfold rs. f_equiv. f_equiv. rewrite -oFunctor_map_compose. f_equiv. @@ -140,7 +218,7 @@ Section reifiers. repeat f_equiv; intro; done. } assert (rs ≡{m}≡ Some (o, σ')) as Hr. { by rewrite Hr' Hst. } - trans (from_option (λ ns : laterO IT * stateF ♯ IT, (ns.2, Tau ns.1)) + trans (from_option (λ ns : laterO (IT _ _) * (stateF _ _) ♯ (IT _ _), (ns.2, Tau ns.1)) (σ, Err RuntimeErr) rs). - subst rs. @@ -160,40 +238,99 @@ Section reifiers. reflexivity. + by rewrite oFunctor_map_id. - subst rs. - trans (from_option (λ ns : laterO IT * stateF ♯ IT, (ns.2, Tau ns.1)) - (σ, Err RuntimeErr) - (Some (o, σ'))). + trans (from_option (λ ns : laterO (IT _ _) * (stateF _ _) ♯ (IT _ _), (ns.2, Tau ns.1)) + (σ, Err RuntimeErr) + (Some (o, σ'))). + eapply (from_option_ne (dist m)); [solve_proper | solve_proper |]. by rewrite Hr. + reflexivity. Qed. - Lemma reify_vis_eq op i o k σ σ' : - sReifier_re r op (i,σ,k) ≡ Some (o,σ') → + Lemma reify_vis_dist_ctx_indep (r : sReifier NotCtxDep) m op i o k σ σ' : + @sReifier_re NotCtxDep r (IT NotCtxDep r) _ op (i,σ) ≡{m}≡ Some (o,σ') → + reify (Vis op i k) σ ≡{m}≡ (σ', Tau $ k o). + Proof. + intros Hst. + trans (reify_vis _ _ op + (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) + (laterO_map (prod_in idfun reify) ◎ k + ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) + σ). + { f_equiv. rewrite IT_rec1_vis//. } + Opaque prod_in. simpl. + pose (rs := (@sReifier_re NotCtxDep r _ _ op + (oFunctor_map (Ins (F NotCtxDep r op)) (inlO, fstO) + (oFunctor_map (Ins (F NotCtxDep r op)) + (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). + fold rs. + assert (rs ≡ sReifier_re NotCtxDep r op (i,σ)) as Hr'. + { unfold rs. f_equiv. f_equiv. + rewrite -oFunctor_map_compose. + etrans; last by apply oFunctor_map_id. + repeat f_equiv; intro; done. } + assert (rs ≡{m}≡ Some (o,σ')) as Hr. + { by rewrite Hr' Hst. } + trans (from_option (λ ns, + (ns.2, + Tau + (laterO_map fstO + (laterO_map (prod_in idfun reify) + (k + (oFunctor_map (Outs (F NotCtxDep r op)) + (prod_in idfun reify, sumO_rec idfun unreify) + (oFunctor_map (Outs (F NotCtxDep r op)) (fstO, inlO) ns.1))))))) + (σ, Err RuntimeErr) (Some (o,σ'))). + { eapply (from_option_ne (dist m)); solve_proper. } + simpl. repeat f_equiv. + rewrite -laterO_map_compose. + rewrite -oFunctor_map_compose. + trans (laterO_map idfun (k o)); last first. + { by rewrite laterO_map_id. } + repeat f_equiv. + { intro; done. } + trans (oFunctor_map _ (idfun, idfun) o); last first. + { by rewrite oFunctor_map_id. } + simpl. + repeat f_equiv; intro; done. + Qed. + + Lemma reify_vis_eq_ctx_dep r op i o k σ σ' : + @sReifier_re CtxDep r (IT CtxDep r) _ op (i,σ,k) ≡ Some (o,σ') → reify (Vis op i k) σ ≡ (σ', Tau $ o). Proof. intros H. apply equiv_dist=>m. - apply reify_vis_dist. + apply reify_vis_dist_ctx_dep. by apply equiv_dist. Qed. - Lemma reify_vis_None op i k σ : - sReifier_re r op (i,σ,k) ≡ None → + Lemma reify_vis_eq_ctx_indep r op i o k σ σ' : + @sReifier_re NotCtxDep r (IT NotCtxDep r) _ op (i,σ) ≡ Some (o,σ') → + reify (Vis op i k) σ ≡ (σ', Tau $ k o). + Proof. + intros H. apply equiv_dist=>m. + apply reify_vis_dist_ctx_indep. + by apply equiv_dist. + Qed. + + Lemma reify_vis_None_ctx_dep r op i k σ : + @sReifier_re CtxDep r (IT CtxDep r) _ op (i,σ,k) ≡ None → reify (Vis op i k) σ ≡ (σ, Err RuntimeErr). Proof. intros Hs. - trans (reify_vis op + trans (reify_vis _ _ op (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) - (laterO_map (prod_in idfun reify) ◎ k ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) + (laterO_map (prod_in idfun reify) ◎ k + ◎ (oFunctor_map _ (prod_in idfun reify,sumO_rec idfun unreify))) σ). { f_equiv. apply IT_rec1_vis. } simpl. - pose (rs := (sReifier_re r op - (oFunctor_map (Ins (F op)) (inlO, fstO) - (oFunctor_map (Ins (F op)) (sumO_rec idfun unreify, prod_in idfun reify) i), σ, k))). + pose (rs := (sReifier_re CtxDep r op + (oFunctor_map (Ins (F CtxDep r op)) (inlO, fstO) + (oFunctor_map (Ins (F CtxDep r op)) + (sumO_rec idfun unreify, prod_in idfun reify) i), σ, k))). fold rs. - assert (rs ≡ sReifier_re r op (i,σ, k)) as Hr'. + assert (rs ≡ sReifier_re CtxDep r op (i,σ, k)) as Hr'. { unfold rs. f_equiv. f_equiv. rewrite -oFunctor_map_compose. f_equiv. @@ -201,7 +338,7 @@ Section reifiers. repeat f_equiv; intro; done. } assert (rs ≡ None) as Hr. { by rewrite Hr' Hs. } - trans (from_option (λ ns : laterO IT * stateF ♯ IT, (ns.2, Tau ns.1)) + trans (from_option (λ ns : laterO (IT _ _) * (stateF _ _) ♯ (IT _ _), (ns.2, Tau ns.1)) (σ, Err RuntimeErr) rs). { @@ -223,56 +360,99 @@ Section reifiers. reflexivity. - by rewrite oFunctor_map_id. } - trans (from_option (λ ns : laterO IT * stateF ♯ IT, (ns.2, Tau ns.1)) (σ, Err RuntimeErr) None). + trans (from_option (λ ns : laterO (IT CtxDep r) * (stateF _ _) ♯ (IT _ _), + (ns.2, Tau ns.1)) (σ, Err RuntimeErr) None). - f_equiv; [| assumption]. intros [? ?] [? ?] [? ?]; simpl in *; f_equiv; [assumption | f_equiv; assumption]. - reflexivity. Qed. - Lemma reify_is_always_a_tick op x k σ β σ' : - reify (Vis op x k) σ ≡ (σ', β) → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). + Lemma reify_vis_None_ctx_indep r op i k σ : + @sReifier_re NotCtxDep r (IT NotCtxDep r) _ op (i,σ) ≡ None → + reify (Vis op i k) σ ≡ (σ, Err RuntimeErr). + Proof. + intros Hs. + trans (reify_vis _ _ op + (oFunctor_map _ (sumO_rec idfun unreify,prod_in idfun reify) i) + (laterO_map (prod_in idfun reify) ◎ k + ◎ (oFunctor_map _ + (prod_in idfun reify,sumO_rec idfun unreify))) + σ). + { f_equiv. + apply IT_rec1_vis. } + simpl. + pose (rs := (sReifier_re NotCtxDep r op + (oFunctor_map (Ins (F _ _ op)) (inlO, fstO) + (oFunctor_map (Ins (F _ _ op)) + (sumO_rec idfun unreify, prod_in idfun reify) i), σ))). + fold rs. + assert (rs ≡ sReifier_re _ r op (i,σ)) as Hr'. + { unfold rs. f_equiv. f_equiv. + rewrite -oFunctor_map_compose. + etrans; last by apply oFunctor_map_id. + repeat f_equiv; intro; done. } + assert (rs ≡ None) as Hr. + { by rewrite Hr' Hs. } + trans (from_option (λ ns, + (ns.2, + Tau + (laterO_map fstO + (laterO_map (prod_in idfun reify) + (k + (oFunctor_map (Outs (F _ _ op)) + (prod_in idfun reify, sumO_rec idfun unreify) + (oFunctor_map (Outs (F _ _ op)) (fstO, inlO) ns.1))))))) + (σ, Err RuntimeErr) None). + { apply from_option_proper; solve_proper. } + reflexivity. + Qed. + + Lemma reify_is_always_a_tick {a : is_ctx_dep} r op x k σ β σ' : + reify (a := a) (A := A) (r := r) (Vis op x k) σ ≡ (σ', β) + → (∃ β', β ≡ Tick β') ∨ (β ≡ Err RuntimeErr). Proof. - destruct (sReifier_re r op (x, σ, k)) as [[o σ'']|] eqn:Hre; last first. - - rewrite reify_vis_None; last by rewrite Hre//. - intros [_ ?]. by right. - - rewrite reify_vis_eq;last by rewrite Hre. - intros [? Ho]. - left. - simpl in *. - destruct (Next_uninj o) as [t Ht]. - exists (t). - rewrite <-Ho. - rewrite Ht. - reflexivity. + destruct a. + { + destruct (sReifier_re _ r op (x, σ, k)) as [[o σ'']|] eqn:Hre; last first. + - rewrite reify_vis_None_ctx_dep; last by rewrite Hre//. + intros [_ ?]. by right. + - rewrite reify_vis_eq_ctx_dep;last by rewrite Hre. + intros [? Ho]. + left. + simpl in *. + destruct (Next_uninj o) as [t Ht]. + exists (t). + rewrite <-Ho. + rewrite Ht. + reflexivity. + } + { + destruct (sReifier_re _ r op (x, σ)) as [[o σ'']|] eqn:Hre; last first. + - rewrite reify_vis_None_ctx_indep; last by rewrite Hre//. + intros [_ ?]. by right. + - rewrite reify_vis_eq_ctx_indep;last by rewrite Hre. + intros [? Ho]. + destruct (Next_uninj (k o)) as [lβ Hlb]. + left. exists (lβ). + rewrite Tick_eq. + rewrite -Hlb. symmetry. apply Ho. + } Qed. - Lemma reify_vis_cont op i k1 k2 σ1 σ2 β - {PROP : bi} `{!BiInternalEq PROP} `{H : !(@CtxIndep IT _ op)} : - (reify (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ + Lemma reify_vis_cont r op i k1 k2 σ1 σ2 β + {PROP : bi} `{!BiInternalEq PROP} : + (reify (a := NotCtxDep) (A := A) (r := r) (Vis op i k1) σ1 ≡ (σ2, Tick β) ⊢ reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick (k2 β)) : PROP)%I. Proof. - destruct (sReifier_re r op (i, σ1, k1)) as [[o σ2']|] eqn:Hre; last first. - - rewrite (reify_vis_None _ _ k1); last by rewrite Hre//. + destruct (sReifier_re _ r op (i,σ1)) as [[o σ2']|] eqn:Hre; last first. + - rewrite reify_vis_None_ctx_indep; last by rewrite Hre//. iIntros "Hr". iExFalso. iPoseProof (prod_equivI with "Hr") as "[_ Hk]". simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. - - destruct H as [[f H]]. - pose proof (H i σ1 k1) as H1. - pose proof (H i σ1 (laterO_map k2 ◎ k1)) as H2. - assert (∃ o σ', f (i, σ1) = Some (o, σ')) as [o' [σ' H3]]. - { - destruct (f (i, σ1)) as [[? ?] | ?]; first (do 2 eexists; reflexivity). - simpl in H1. rewrite Hre in H1; inversion H1. - } - rewrite H3 in H1. - simpl in H1. - rewrite H3 in H2. - simpl in H2. - clear f H H3 Hre. - rewrite reify_vis_eq; last first. - { by rewrite H1. } - rewrite reify_vis_eq; last first. - { by rewrite H2. } + - rewrite reify_vis_eq_ctx_indep; last first. + { by rewrite Hre. } + rewrite reify_vis_eq_ctx_indep; last first. + { by rewrite Hre. } iIntros "Hr". iPoseProof (prod_equivI with "Hr") as "[Hs Hk]". iApply prod_equivI. simpl. iSplit; eauto. @@ -281,60 +461,39 @@ Section reifiers. rewrite laterO_map_Next. done. Qed. - Lemma reify_input_cont_inv op i (k1 : _ -n> laterO IT) (k2 : IT -n> IT) σ1 σ2 β - {PROP : bi} `{!BiInternalEq PROP} `{H : !(@CtxIndep IT _ op)} : + Lemma reify_input_cont_inv r op i (k1 : _ -n> laterO (IT NotCtxDep r)) + (k2 : IT _ r -n> IT _ r) σ1 σ2 β + {PROP : bi} `{!BiInternalEq PROP} : (reify (Vis op i (laterO_map k2 ◎ k1)) σ1 ≡ (σ2, Tick β) ⊢ ∃ α, reify (Vis op i k1) σ1 ≡ (σ2, Tick α) ∧ ▷ (β ≡ k2 α) : PROP)%I. Proof. - destruct (sReifier_re r op (i, σ1, (laterO_map k2 ◎ k1))) as [[o σ2']|] eqn:Hre; last first. - - rewrite reify_vis_None; last by rewrite Hre//. + destruct (sReifier_re _ r op (i,σ1)) as [[o σ2']|] eqn:Hre; last first. + - rewrite reify_vis_None_ctx_indep; last by rewrite Hre//. iIntros "Hr". iExFalso. iPoseProof (prod_equivI with "Hr") as "[_ Hk]". simpl. iApply (IT_tick_err_ne). by iApply internal_eq_sym. - - rewrite reify_vis_eq; last first. + - rewrite reify_vis_eq_ctx_indep; last first. { by rewrite Hre. } iIntros "Hr". simpl. iPoseProof (prod_equivI with "Hr") as "[#Hs #Hk]". simpl. iPoseProof (Tau_inj' with "Hk") as "Hk'". - destruct H as [[f H]]. - pose proof (H i σ1 k1) as H1. - pose proof (H i σ1 (laterO_map k2 ◎ k1)) as H2. - assert (∃ o, f (i, σ1) ≡ Some (o, σ2')) as [o' H3]. - { - destruct (f (i, σ1)) as [[? ?] | ?]. - - simpl in H2. - rewrite Hre in H2. - inversion H2 as [? ? H2' |]; subst; inversion H2'; simpl in *; subst. - eexists _; do 2 f_equiv; first reflexivity; symmetry; assumption. - - simpl in H2. - rewrite Hre in H2. - inversion H2. - } - rewrite H3 in H1. - simpl in H1. - rewrite H3 in H2. - simpl in H2. - destruct (Next_uninj (k1 o')) as [a Hk1]. + destruct (Next_uninj (k1 o)) as [a Hk1]. iExists (a). - rewrite reify_vis_eq; last first. - { by rewrite H1. } + rewrite reify_vis_eq_ctx_indep; last first. + { by rewrite Hre. } iSplit. + iApply prod_equivI. simpl. iSplit; eauto. iApply Tau_inj'. done. + iAssert (laterO_map k2 (Next a) ≡ Next β)%I as "Ha". - { - iSimpl in "Hk'". iRewrite -"Hk'". - iPureIntro. rewrite -Hk1. - rewrite Hre in H2. - inversion H2 as [? ? H2' |]; subst; inversion H2'; simpl in *; subst. - symmetry; assumption. - } + { iSimpl in "Hk'". iRewrite -"Hk'". + iPureIntro. rewrite -Hk1. done. } iAssert (Next (k2 a) ≡ Next β)%I as "Hb". { iRewrite -"Ha". iPureIntro. rewrite laterO_map_Next. done. } iNext. by iApply internal_eq_sym. Qed. +End reify_props. -End reifiers. +Arguments reify {_ _ _} _. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index 3697856..a3cdb39 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -6,25 +6,32 @@ From gitrees.gitree Require Import core reify greifiers reductions. (** * Ghost state from gReifiers *) -Definition gReifiers_ucmra {n} (rs : gReifiers n) (X : ofe) `{!Cofe X} : ucmra := - discrete_funUR (λ (i : fin n), optionUR (exclR (sReifier_state (rs !!! i) ♯ X))). +Definition gReifiers_ucmra {n} (a : is_ctx_dep) (rs : gReifiers a n) + (X : ofe) `{!Cofe X} : ucmra := + discrete_funUR (λ (i : fin n), + optionUR (exclR (sReifier_state a (rs !!! i) ♯ X))). (** The resource corresponding to the whole global state *) -Definition of_state {n} (rs : gReifiers n) (X : ofe) `{!Cofe X} (st : gReifiers_state rs ♯ X) : gReifiers_ucmra rs X := - λ i, Excl' (fstO (gState_decomp i st)). +Definition of_state {n} (a : is_ctx_dep) (rs : gReifiers a n) + (X : ofe) `{!Cofe X} (st : gReifiers_state a rs ♯ X) + : gReifiers_ucmra a rs X := + λ i, Excl' (fstO (gState_decomp a i st)). (** The resource corresponding to a speicific projection out of the global state *) -Definition of_idx {n} (rs : gReifiers n) (X : ofe) `{!Cofe X} (i : fin n) - (st : sReifier_state (rs !!! i) ♯ X) : gReifiers_ucmra rs X. +Definition of_idx {n} (a : is_ctx_dep) (rs : gReifiers a n) + (X : ofe) `{!Cofe X} (i : fin n) + (st : sReifier_state a (rs !!! i) ♯ X) : gReifiers_ucmra a rs X. Proof. simple refine (λ j, if (decide (j = i)) then _ else None). simpl. induction e. exact (Excl' st). Defined. -Lemma of_state_recomp_lookup_ne {n} (rs : gReifiers n) (X : ofe) `{!Cofe X} - i j (σ1 σ2 : sReifier_state (rs !!! i) ♯ X) rest : +Lemma of_state_recomp_lookup_ne {n} (a : is_ctx_dep) (rs : gReifiers a n) + (X : ofe) `{!Cofe X} + i j (σ1 σ2 : sReifier_state a (rs !!! i) ♯ X) rest : i ≠ j → - of_state rs X (gState_recomp rest σ1) j ≡ of_state rs X (gState_recomp rest σ2) j. + of_state a rs X (gState_recomp a rest σ1) j + ≡ of_state a rs X (gState_recomp a rest σ2) j. Proof. intros Hij. revert σ1 σ2 rest. unfold of_state. @@ -42,31 +49,30 @@ Proof. intro. simplify_eq/=. Qed. - Section ucmra. - Context {n : nat} (rs : gReifiers n). + Context {n : nat} (a : is_ctx_dep) (rs : gReifiers a n). Context (X : ofe) `{!Cofe X}. - Notation gReifiers_ucmra := (gReifiers_ucmra rs X). - Notation of_state := (of_state rs X). - Notation of_idx := (of_idx rs X). + Notation gReifiers_ucmra := (gReifiers_ucmra a rs X). + Notation of_state := (of_state a rs X). + Notation of_idx := (of_idx a rs X). #[export] Instance of_state_ne : NonExpansive of_state. Proof. solve_proper. Qed. #[export] Instance of_state_proper : Proper ((≡) ==> (≡)) of_state. Proof. apply ne_proper, _. Qed. - Lemma of_state_valid (σ : gReifiers_state rs ♯ X) : ✓ (of_state σ). + Lemma of_state_valid (σ : gReifiers_state a rs ♯ X) : ✓ (of_state σ). Proof. intro; done. Qed. - Lemma of_state_recomp_lookup i (σ : sReifier_state (rs !!! i) ♯ X) rest : - of_state (gState_recomp rest σ) i ≡ Excl' σ. + Lemma of_state_recomp_lookup i (σ : sReifier_state a (rs !!! i) ♯ X) rest : + of_state (gState_recomp a rest σ) i ≡ Excl' σ. Proof. unfold of_state. rewrite gState_decomp_recomp. done. Qed. - Lemma of_state_decomp_local_update i (σ σ1 σ2 : sReifier_state (rs !!! i) ♯ X) rest : - (of_state (gState_recomp rest σ1), of_idx i σ2) - ~l~> (of_state (gState_recomp rest σ), of_idx i σ). + Lemma of_state_decomp_local_update i (σ σ1 σ2 : sReifier_state a (rs !!! i) ♯ X) rest : + (of_state (gState_recomp a rest σ1), of_idx i σ2) + ~l~> (of_state (gState_recomp a rest σ), of_idx i σ). Proof. apply discrete_fun_local_update. intros j. @@ -82,7 +88,7 @@ Section ucmra. Qed. Lemma of_state_of_idx_agree i σ1 σ2 rest f Σ : - of_state (gState_recomp rest σ1) ≡ of_idx i σ2 ⋅ f ⊢@{iProp Σ} σ1 ≡ σ2. + of_state (gState_recomp a rest σ1) ≡ of_idx i σ2 ⋅ f ⊢@{iProp Σ} σ1 ≡ σ2. Proof. iIntros "Hs". rewrite discrete_fun_equivI. @@ -100,16 +106,16 @@ Section ucmra. End ucmra. Section weakestpre. - Context {n : nat} (rs : gReifiers n) {A} `{!Cofe A}. - Notation rG := (gReifiers_sReifier rs). - Notation F := (sReifier_ops rG). + Context {n : nat} (a : is_ctx_dep) (rs : gReifiers a n) {A} `{!Cofe A}. + Notation rG := (gReifiers_sReifier a rs). + Notation F := (sReifier_ops a rG). Notation IT := (IT F A). Notation ITV := (ITV F A). - Notation stateF := (gReifiers_state rs). + Notation stateF := (gReifiers_state a rs). Notation stateO := (stateF ♯ IT). - Notation stateR := (gReifiers_ucmra rs IT). - Let of_state := (of_state rs IT). - Let of_idx := (of_idx rs IT). + Notation stateR := (gReifiers_ucmra a rs IT). + Let of_state := (of_state a rs IT). + Let of_idx := (of_idx a rs IT). Notation reify := (reify rG). Notation istep := (istep rG). Notation isteps := (isteps rG). @@ -135,15 +141,16 @@ Section weakestpre. Definition has_full_state `{!stateG Σ} (σ : stateO) : iProp Σ := (own stateG_name (◯ (of_state σ)))%I. Definition has_state_idx `{!stateG Σ} - (i : fin n) (σ : sReifier_state (rs !!! i) ♯ IT) : iProp Σ := + (i : fin n) (σ : sReifier_state a (rs !!! i) ♯ IT) : iProp Σ := (own stateG_name (◯ (of_idx i σ)))%I. - Definition has_substate {sR : sReifier} `{!stateG Σ} `{!subReifier sR rs} - (σ : sReifier_state sR ♯ IT) : iProp Σ := + Definition has_substate {sR : sReifier a} `{!stateG Σ} `{!subReifier sR rs} + (σ : sReifier_state a sR ♯ IT) : iProp Σ := (own stateG_name (◯ (of_idx sR_idx (sR_state σ))))%I. #[export] Instance state_interp_ne `{!stateG Σ} : NonExpansive state_interp. Proof. solve_proper. Qed. - #[export] Instance state_interp_proper `{!stateG Σ} : Proper ((≡) ==> (≡)) state_interp. + #[export] Instance state_interp_proper `{!stateG Σ} + : Proper ((≡) ==> (≡)) state_interp. Proof. solve_proper. Qed. Lemma new_state_interp σ `{!invGS_gen hlc Σ, !statePreG Σ} : @@ -156,9 +163,9 @@ Section weakestpre. Qed. Lemma state_interp_has_state_idx_agree (i : fin n) - (σ1 σ2 : sReifier_state (rs !!! i) ♯ IT) - (rest : gState_rest i rs ♯ IT) `{!stateG Σ} : - state_interp (gState_recomp rest σ1) -∗ has_state_idx i σ2 -∗ σ1 ≡ σ2. + (σ1 σ2 : sReifier_state a (rs !!! i) ♯ IT) + (rest : gState_rest a i rs ♯ IT) `{!stateG Σ} : + state_interp (gState_recomp a rest σ1) -∗ has_state_idx i σ2 -∗ σ1 ≡ σ2. Proof. iIntros "H1 H2". iDestruct (own_valid_2 with "H1 H2") as "Hs". @@ -169,15 +176,15 @@ Section weakestpre. Qed. Lemma state_interp_has_state_idx_update (i : fin n) - (σ σ1 σ2 : sReifier_state (rs !!! i) ♯ IT) - (rest : gState_rest i rs ♯ IT) `{!stateG Σ} : - state_interp (gState_recomp rest σ1) -∗ has_state_idx i σ2 ==∗ - state_interp (gState_recomp rest σ) ∗ has_state_idx i σ. + (σ σ1 σ2 : sReifier_state a (rs !!! i) ♯ IT) + (rest : gState_rest a i rs ♯ IT) `{!stateG Σ} : + state_interp (gState_recomp a rest σ1) -∗ has_state_idx i σ2 ==∗ + state_interp (gState_recomp a rest σ) ∗ has_state_idx i σ. Proof. iIntros "H1 H2". iMod (own_update_2 with "H1 H2") as "H". { apply auth_update. - apply (of_state_decomp_local_update _ _ _ σ). } + apply (of_state_decomp_local_update a _ _ _ σ). } iDestruct "H" as "[$ $]". done. Qed. @@ -209,7 +216,7 @@ Section weakestpre. #[local] Instance wp_pre_contractive s Φ : Contractive (wp_pre s Φ). Proof. unfold wp_pre. - intros m s1 s2 Hs E1 a. simpl. + intros m s1 s2 Hs E1 a'. simpl. (* repeat first [f_contractive | f_equiv; solve_proper *) (* | f_equiv ]. *) f_equiv. f_equiv. f_equiv. @@ -245,7 +252,9 @@ Section weakestpre. format "'WP' α @ s {{ Φ } }") : bi_scope. #[export] Instance wp_ne m : - Proper ((dist m) ==> (pointwise_relation _ (iff)) ==> (dist m) ==> (pointwise_relation _ (dist m)) ==> (dist m)) wp. + Proper ((dist m) ==> + (pointwise_relation _ (iff)) ==> + (dist m) ==> (pointwise_relation _ (dist m)) ==> (dist m)) wp. Proof. intros α1 α2 Ha s s' Hs E1 E2 HE Φ1 Φ2 Hp. assert (E1 = E2) as ->. @@ -267,7 +276,8 @@ Section weakestpre. eapply dist_le; [apply Hp|lia]. Qed. #[export] Instance wp_proper : - Proper ((≡) ==> (pointwise_relation _ (iff)) ==> (≡) ==> (pointwise_relation _ (≡)) ==> (≡)) wp. + Proper ((≡) ==> (pointwise_relation _ (iff)) ==> (≡) ==> + (pointwise_relation _ (≡)) ==> (≡)) wp. Proof. intros α1 α2 Ha s s' Hs E1 E2 HE Φ1 Φ2 Hp. apply equiv_dist=>m. @@ -392,13 +402,13 @@ Section weakestpre. Opaque gState_recomp. (* We can generalize this based on the stuckness bit *) - Lemma wp_reify_idx E1 E2 s Φ i (lop : opid (sReifier_ops (rs !!! i))) : + Lemma wp_reify_idx E1 E2 s Φ i (lop : opid (sReifier_ops a (rs !!! i))) : let op : opid F := (existT i lop) in forall (x : Ins (F op) ♯ IT) (k : Outs (F op) ♯ IT -n> laterO IT), (|={E1,E2}=> ∃ σ σ' β, has_state_idx i σ ∗ - ∀ rest, reify (Vis op x k) (gState_recomp rest σ) - ≡ (gState_recomp rest σ', Tick β) ∗ + ∀ rest, reify (Vis op x k) (gState_recomp a rest σ) + ≡ (gState_recomp a rest σ', Tick β) ∗ ▷ (£ 1 -∗ has_state_idx i σ' -∗ |={E2,E1}=> WP β @ s;E1 {{ Φ }})) -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. Proof. @@ -408,8 +418,8 @@ Section weakestpre. iRight. iSplit. { iPureIntro. apply IT_to_V_Vis. } iIntros (fs) "Hgst". - destruct (gState_decomp i fs) as [σ0 rest] eqn:Hdecomp. - assert (fs ≡ gState_recomp rest σ0) as Hfs. + destruct (gState_decomp a i fs) as [σ0 rest] eqn:Hdecomp. + assert (fs ≡ gState_recomp a rest σ0) as Hfs. { symmetry. apply gState_recomp_decomp. by rewrite Hdecomp. } iMod "H" as (σ σ' β) "[Hlst H]". @@ -424,10 +434,10 @@ Section weakestpre. iSplit. { (* it is safe *) iLeft. - iExists β,(gState_recomp rest σ'). iRight. + iExists β,(gState_recomp a rest σ'). iRight. iExists op,x,k; eauto. } iIntros (fs' α0) "Hst Hlc". rewrite istep_vis. - iAssert (gState_recomp rest σ' ≡ fs' ∧ Tick β ≡ Tick α0)%I + iAssert (gState_recomp a rest σ' ≡ fs' ∧ Tick β ≡ Tick α0)%I with "[Hreify Hst]" as "[Hst Hb]". { iRewrite "Hreify" in "Hst". by rewrite prod_equivI. } @@ -440,39 +450,10 @@ Section weakestpre. iRewrite -"Hb". by iFrame. Qed. - Lemma wp_reify_idx' E1 E2 s Φ i (lop : opid (sReifier_ops (rs !!! i))) : - let op : opid F := (existT i lop) in - forall (x : Ins (F op) ♯ IT) - (k : Outs (F op) ♯ IT -n> laterO IT), - (|={E1,E2}=> ∃ σ y σ' β, has_state_idx i σ ∗ - sReifier_re (rs !!! i) lop (x, σ, k) ≡ Some (y, σ') ∗ - y ≡ Next β ∗ - ▷ (£ 1 -∗ has_state_idx i σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) - -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. - Proof. - intros op x k. - iIntros "H". - iApply wp_reify_idx. - iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". - iModIntro. iExists σ, σ', β. - iFrame "Hlst". - iIntros (rest). iFrame "H". - iAssert (gReifiers_re rs op (x, gState_recomp rest σ, _) ≡ Some (y, gState_recomp rest σ'))%I - with "[Hreify]" as "Hgreify". - { rewrite gReifiers_re_idx. - iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) (sReifier_re (rs !!! i) lop (x, σ, k)) ≡ optionO_map (prodO_map idfun (gState_recomp rest)) (Some (y, σ')))%I with "[Hreify]" as "H". - - iApply (f_equivI with "Hreify"). - - simpl. iExact "H". - } - iPoseProof (reify_vis_eqI _ _ _ k with "Hgreify") as "Hreify". - iRewrite "Hk" in "Hreify". - by rewrite -Tick_eq. - Qed. - - Lemma wp_reify E1 s Φ i (lop : opid (sReifier_ops (rs !!! i))) + Lemma wp_reify E1 s Φ i (lop : opid (sReifier_ops a (rs !!! i))) x k σ σ' β : let op : opid F := (existT i lop) in - (∀ rest, reify (Vis op x k) (gState_recomp rest σ) ≡ (gState_recomp rest σ', Tick β)) → + (∀ rest, reify (Vis op x k) (gState_recomp a rest σ) ≡ (gState_recomp a rest σ', Tick β)) → has_state_idx i σ -∗ ▷ (£ 1 -∗ has_state_idx i σ' -∗ WP β @ s;E1 {{ Φ }}) -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. @@ -488,62 +469,6 @@ Section weakestpre. iModIntro. by iApply ("H" with "Hlc Hs"). Qed. - Lemma wp_subreify' E1 E2 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ IT) - (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) : - (|={E1,E2}=> ∃ σ y σ' β, has_substate σ ∗ - sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') ∗ y ≡ Next β ∗ - ▷ (£ 1 -∗ has_substate σ' ={E2,E1}=∗ WP β @ s;E1 {{ Φ }})) - -∗ WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. - Proof. - iIntros "H". - iApply wp_reify_idx'. - iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". - iModIntro. - iExists (sR_state σ), y, (sR_state σ'), β. - simpl. - iFrame "Hlst H". - rewrite subReifier_reify_idxI. - iFrame "Hk". - iRewrite - "Hreify". - iPureIntro. - do 2 f_equiv. - intros ?; simpl. - by rewrite ofe_iso_12. - Qed. - - Lemma wp_subreify E1 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops sR)) - (x : Ins (sReifier_ops sR op) ♯ IT) (y : laterO IT) - (k : Outs (F (subEff_opid op)) ♯ IT -n> laterO IT) - (σ σ' : sReifier_state sR ♯ IT) β : - sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') → - y ≡ Next β → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP β @ s;E1 {{ Φ }}) - -∗ - WP (Vis (subEff_opid op) (subEff_ins x) k) @ s;E1 {{ Φ }}. - Proof. - intros HSR Hk. - iIntros "Hlst H". - iApply (wp_reify with "Hlst H"). - intros rest. - rewrite Tick_eq. rewrite -Hk. - rewrite reify_vis_eq //. - pose proof (@subReifier_reify n sR rs _ IT _ op x y (k ◎ subEff_outs) σ σ' rest) as H. - simpl in H. - rewrite <-H. - - simpl. - repeat f_equiv. - + intros ???. - solve_proper. - + intros ?; simpl. - rewrite ofe_iso_12. - reflexivity. - - rewrite HSR. - reflexivity. - Qed. - Lemma wp_err E1 e (s : error → Prop) Φ : s e → ⊢ WP (Err e) @ s;E1 {{ Φ }}. @@ -559,6 +484,7 @@ Section weakestpre. iIntros (σ' β) "Hst". iExFalso. iApply istep_err. done. Qed. + Lemma wp_stuckness_mono α E1 (s1 s2 : error → Prop) Φ : (∀ e, s1 e → s2 e) → WP α @ s1;E1 {{ Φ }} ⊢ WP α @ s2;E1 {{ Φ }}. @@ -736,13 +662,250 @@ Section weakestpre. solve_proper. Qed. - Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 {G : ∀ o : opid F, CtxIndep rG IT o} : +End weakestpre. + +Section weakestpre_specific. + Context {n : nat} {A} `{!Cofe A}. + + Notation rG a rs := (gReifiers_sReifier (n := n) a rs). + Notation F a rs := (sReifier_ops a (rG a rs)). + Notation IT a rs := (IT (F a rs) A). + Notation ITV a rs := (ITV (F a rs) A). + Notation stateF a rs := (gReifiers_state a rs). + Notation stateO a rs := (stateF a rs ♯ IT a rs). + Notation stateR a rs := (gReifiers_ucmra a rs (IT a rs)). + Let of_state a rs := (of_state a rs (IT a rs)). + Let of_idx a rs := (of_idx a rs (IT a rs)). + Notation reify a rs := (reify (rG a rs)). + Notation istep a rs := (istep (rG a rs)). + Notation isteps a rs := (isteps (rG a rs)). + Notation sstep a rs := (sstep (rG a rs)). + Notation ssteps a rs := (ssteps (rG a rs)). + Notation wp a rs := (wp a rs). + + Context `{!invGS Σ}. + Notation iProp := (iProp Σ). + Notation coPsetO := (leibnizO coPset). + + Lemma wp_reify_idx_ctx_dep (rs : gReifiers CtxDep n) + `{!@stateG _ CtxDep rs A _ Σ} E1 E2 s Φ i + (lop : opid (sReifier_ops CtxDep (rs !!! i))) : + let op : opid (F CtxDep rs) := (existT i lop) in + forall (x : Ins (F CtxDep rs op) ♯ IT CtxDep rs) + (k : Outs (F CtxDep rs op) ♯ IT CtxDep rs -n> laterO (IT CtxDep rs)), + (|={E1,E2}=> + ∃ σ y σ' β, has_state_idx CtxDep rs i σ + ∗ sReifier_re CtxDep (rs !!! i) lop (x, σ, k) ≡ Some (y, σ') + ∗ y ≡ Next β + ∗ ▷ (£ 1 -∗ has_state_idx CtxDep rs i σ' ={E2,E1}=∗ wp CtxDep rs β s E1 Φ)) + -∗ wp CtxDep rs (Vis op x k) s E1 Φ. + Proof. + intros op x k. + iIntros "H". + iApply wp_reify_idx. + iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". + iModIntro. iExists σ, σ', β. + iFrame "Hlst". + iIntros (rest). + iFrame "H". + iAssert (gReifiers_re CtxDep rs op (x, gState_recomp CtxDep rest σ, _) + ≡ Some (y, gState_recomp CtxDep rest σ'))%I + with "[Hreify]" as "Hgreify". + { rewrite (gReifiers_re_idx CtxDep). + iAssert (optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) + (sReifier_re CtxDep (rs !!! i) lop (x, σ, k)) + ≡ optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) + (Some (y, σ')))%I with "[Hreify]" as "H". + - iApply (f_equivI with "Hreify"). + - simpl. iExact "H". + } + iPoseProof (reify_vis_eqI_ctx_dep _ _ _ k with "Hgreify") as "Hreify". + iRewrite "Hk" in "Hreify". + by rewrite -Tick_eq. + Qed. + + Lemma wp_reify_idx_ctx_indep (rs : gReifiers NotCtxDep n) + `{!@stateG _ NotCtxDep rs A _ Σ} E1 E2 s Φ i + (lop : opid (sReifier_ops NotCtxDep (rs !!! i))) : + let op : opid (F NotCtxDep rs) := (existT i lop) in + forall (x : Ins (F NotCtxDep rs op) ♯ IT NotCtxDep rs) + (k : Outs (F NotCtxDep rs op) ♯ IT NotCtxDep rs -n> laterO (IT NotCtxDep rs)), + (|={E1,E2}=> ∃ σ y σ' β, has_state_idx NotCtxDep rs i σ + ∗ sReifier_re NotCtxDep (rs !!! i) lop (x, σ) ≡ Some (y, σ') + ∗ k y ≡ Next β + ∗ ▷ (£ 1 -∗ has_state_idx NotCtxDep rs i σ' ={E2,E1}=∗ wp NotCtxDep rs β s E1 Φ)) + -∗ wp NotCtxDep rs (Vis op x k) s E1 Φ. + Proof. + intros op x k. + iIntros "H". + iApply wp_reify_idx. + iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". + iModIntro. iExists σ, σ', β. + iFrame "Hlst". + iIntros (rest). + iFrame "H". + iAssert (gReifiers_re NotCtxDep rs op (x, gState_recomp NotCtxDep rest σ) + ≡ Some (y, gState_recomp NotCtxDep rest σ'))%I + with "[Hreify]" as "Hgreify". + { pose proof (@gReifiers_re_idx n NotCtxDep i rs (IT NotCtxDep rs)) as J. + simpl in J. + simpl. + rewrite J; clear J. + iAssert (optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) + (sReifier_re NotCtxDep (rs !!! i) lop (x, σ)) + ≡ optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) + (Some (y, σ')))%I with "[Hreify]" as "H". + - iApply (f_equivI with "Hreify"). + - simpl. iExact "H". + } + iPoseProof (reify_vis_eqI_ctx_indep _ _ _ k with "Hgreify") as "Hreify". + iRewrite "Hk" in "Hreify". + by rewrite -Tick_eq. + Qed. + + Lemma wp_subreify_ctx_dep' (rs : gReifiers CtxDep n) + `{!@stateG _ CtxDep rs A _ Σ} E1 E2 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops CtxDep sR)) (x : Ins (sReifier_ops CtxDep sR op) ♯ (IT CtxDep rs)) + (k : Outs (F CtxDep rs (subEff_opid op)) ♯ IT CtxDep rs -n> laterO (IT CtxDep rs)) : + (|={E1,E2}=> ∃ σ y σ' β, has_substate CtxDep rs σ ∗ + sReifier_re CtxDep sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') + ∗ y ≡ Next β + ∗ ▷ (£ 1 -∗ has_substate CtxDep rs σ' ={E2,E1}=∗ wp CtxDep rs β s E1 Φ)) + -∗ wp CtxDep rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + Proof. + iIntros "H". + iApply wp_reify_idx_ctx_dep. + iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". + iModIntro. + iExists (sR_state σ), y, (sR_state σ'), β. + simpl. + iFrame "Hlst H". + rewrite subReifier_reify_idxI_ctx_dep. + iFrame "Hk". + iRewrite - "Hreify". + iPureIntro. + do 2 f_equiv. + intros ?; simpl. + by rewrite ofe_iso_12. + Qed. + + Lemma wp_subreify_ctx_indep' (rs : gReifiers NotCtxDep n) + `{!@stateG _ NotCtxDep rs A _ Σ} E1 E2 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops NotCtxDep sR)) (x : Ins (sReifier_ops NotCtxDep sR op) ♯ (IT NotCtxDep rs)) + (k : Outs (F NotCtxDep rs (subEff_opid op)) ♯ IT NotCtxDep rs -n> laterO (IT NotCtxDep rs)) : + (|={E1,E2}=> ∃ σ y σ' β, has_substate NotCtxDep rs σ ∗ + sReifier_re NotCtxDep sR op (x, σ) ≡ Some (y, σ') + ∗ k (subEff_outs y) ≡ Next β + ∗ ▷ (£ 1 -∗ has_substate NotCtxDep rs σ' ={E2,E1}=∗ wp NotCtxDep rs β s E1 Φ)) + -∗ wp NotCtxDep rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + Proof. + iIntros "H". + iApply wp_reify_idx_ctx_indep. + iMod "H" as (σ y σ' β) "[Hlst [Hreify [Hk H]]]". + iModIntro. + iExists (sR_state σ),(subEff_outs y), (sR_state σ'), β. + iFrame "Hlst H Hk". + by iApply subReifier_reify_idxI_ctx_indep. + Qed. + + Lemma wp_subreify_ctx_dep (rs : gReifiers CtxDep n) + `{!@stateG _ CtxDep rs A _ Σ} E1 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops CtxDep sR)) + (x : Ins (sReifier_ops CtxDep sR op) ♯ IT CtxDep rs) (y : laterO (IT CtxDep rs)) + (k : Outs (F CtxDep rs (subEff_opid op)) ♯ IT CtxDep rs -n> laterO (IT CtxDep rs)) + (σ σ' : sReifier_state CtxDep sR ♯ IT CtxDep rs) β : + sReifier_re CtxDep sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') → + y ≡ Next β → + has_substate CtxDep rs σ -∗ + ▷ (£ 1 -∗ has_substate CtxDep rs σ' -∗ wp CtxDep rs β s E1 Φ) + -∗ + wp CtxDep rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + Proof. + intros HSR Hk. + iIntros "Hlst H". + iApply (wp_reify with "Hlst H"). + intros rest. + rewrite Tick_eq. rewrite -Hk. + rewrite reify_vis_eq_ctx_dep //. + pose proof (@subReifier_reify n CtxDep sR rs _ + (IT CtxDep rs) _ op x y (k ◎ subEff_outs) σ σ' rest) as H'. + simpl in H'. + rewrite <-H'. + - simpl. + repeat f_equiv. + + intros ???. + solve_proper. + + intros ?; simpl. + rewrite ofe_iso_12. + reflexivity. + - rewrite HSR. + reflexivity. + Qed. + + Lemma wp_subreify_ctx_indep (rs : gReifiers NotCtxDep n) + `{!@stateG _ NotCtxDep rs A _ Σ} E1 s Φ sR `{!subReifier sR rs} + (op : opid (sReifier_ops NotCtxDep sR)) + (x : Ins (sReifier_ops NotCtxDep sR op) ♯ IT NotCtxDep rs) + (y : Outs (sReifier_ops NotCtxDep sR op) ♯ IT NotCtxDep rs) + (k : Outs (F NotCtxDep rs (subEff_opid op)) ♯ IT NotCtxDep rs -n> laterO (IT NotCtxDep rs)) + (σ σ' : sReifier_state NotCtxDep sR ♯ IT NotCtxDep rs) β : + sReifier_re NotCtxDep sR op (x, σ) ≡ Some (y, σ') → + k (subEff_outs y) ≡ Next β → + has_substate NotCtxDep rs σ -∗ + ▷ (£ 1 -∗ has_substate NotCtxDep rs σ' -∗ wp NotCtxDep rs β s E1 Φ) + -∗ + wp NotCtxDep rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + Proof. + intros HSR Hk. + iIntros "Hlst H". + iApply (wp_reify with "Hlst H"). + intros rest. + rewrite Tick_eq. rewrite -Hk. + rewrite reify_vis_eq_ctx_indep //. + by apply (subReifier_reify (a := NotCtxDep)). + Qed. + +End weakestpre_specific. + +Section weakestpre_bind. + Context {n : nat} (rs : gReifiers NotCtxDep n) {A} `{!Cofe A}. + Notation rG := (gReifiers_sReifier NotCtxDep rs). + Notation F := (sReifier_ops NotCtxDep rG). + Notation IT := (IT F A). + Notation ITV := (ITV F A). + Notation stateF := (gReifiers_state NotCtxDep rs). + Notation stateO := (stateF ♯ IT). + Notation stateR := (gReifiers_ucmra NotCtxDep rs IT). + Let of_state := (of_state NotCtxDep rs IT). + Let of_idx := (of_idx NotCtxDep rs IT). + Notation reify := (reify rG). + Notation istep := (istep rG). + Notation isteps := (isteps rG). + Notation sstep := (sstep rG). + Notation ssteps := (ssteps rG). + Notation wp := (wp NotCtxDep rs). + + Implicit Type op : opid F. + Implicit Type α β : IT. + + Context `{!invGS Σ} `{!@stateG _ NotCtxDep rs A _ Σ}. + Notation iProp := (iProp Σ). + Notation coPsetO := (leibnizO coPset). + + Notation "'WP' α @ s ; E {{ Φ } }" := (wp α s E Φ) + (at level 20, α, s, Φ at level 200, only parsing) : bi_scope. + + Notation "'WP' α @ s ; E {{ v , Q } }" := (wp α s E (λ v, Q)) + (at level 20, α, s, Q at level 200, + format "'[hv' 'WP' α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. + + Lemma wp_bind (f : IT → IT) `{!IT_hom f} (α : IT) s Φ `{!NonExpansive Φ} E1 : WP α @ s;E1 {{ βv, WP (f (IT_of_V βv)) @ s;E1 {{ βv, Φ βv }} }} ⊢ WP (f α) @ s;E1 {{ Φ }}. Proof. assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). { solve_proper. } iIntros "H". iLöb as "IH" forall (α). - rewrite (wp_unfold (f _)). + rewrite (wp_unfold _ _ (f _)). destruct (IT_to_V (f α)) as [βv|] eqn:Hfa. - iLeft. iExists βv. iSplit; first done. assert (is_Some (IT_to_V α)) as [αv Ha]. @@ -792,15 +955,15 @@ Section weakestpre. iModIntro. iRewrite "Hb". by iApply "IH". Qed. -End weakestpre. +End weakestpre_bind. -Arguments wp {_} rs {_ _ _ _ _} α s E Φ. -Arguments has_full_state {n _ _ _ _ _} σ. -Arguments has_state_idx {n _ _ _ _ _} i σ. -Arguments has_substate {n _ _ _ _ _ _ _} σ. -Arguments stateG {n} rs A {_} Σ. -Arguments statePreG {n} rs A {_} Σ. -Arguments stateΣ {n} rs A {_}. +Arguments wp {_ _} rs {_ _ _ _ _} α s E Φ. +Arguments has_full_state {n _ _ _ _ _ _} σ. +Arguments has_state_idx {n _ _ _ _ _ _} i σ. +Arguments has_substate {n _ _ _ _ _ _ _ _} σ. +Arguments stateG {n _} rs A {_} Σ. +Arguments statePreG {n _} rs A {_} Σ. +Arguments stateΣ {n _} rs A {_}. Definition notStuck : stuckness := λ e, False. @@ -827,10 +990,10 @@ Definition notStuck : stuckness := λ e, False. (at level 20, α, Φ at level 200, format "'WP@{' re } α {{ Φ } }") : bi_scope. - Lemma wp_adequacy cr Σ `{!invGpreS Σ} n (rs : gReifiers n) + Lemma wp_adequacy cr Σ `{!invGpreS Σ} n a (rs : gReifiers a n) {A} `{!Cofe A} `{!statePreG rs A Σ} - (α : IT _ A) σ βv σ' s k (ψ : (ITV (gReifiers_ops rs) A) → Prop) : - ssteps (gReifiers_sReifier rs) α σ (IT_of_V βv) σ' k → + (α : IT _ A) σ βv σ' s k (ψ : (ITV (gReifiers_ops a rs) A) → Prop) : + ssteps (gReifiers_sReifier a rs) α σ (IT_of_V βv) σ' k → (∀ `{H1 : !invGS Σ} `{H2: !stateG rs A Σ}, ∃ Φ, NonExpansive Φ ∧ (∀ βv, Φ βv ⊢ ⌜ψ βv⌝) ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → @@ -841,7 +1004,7 @@ Definition notStuck : stuckness := λ e, False. { intros HH. eapply uPred.pure_soundness; eauto. } eapply (step_fupdN_soundness_lc _ 0 (cr + 3*k)). intros Hinv. iIntros "[Hcr Hlc]". - iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". + iMod (new_state_interp a rs σ) as (sg) "[Hs Hs2]". destruct (Hprf Hinv sg) as (Φ & HΦ & HΦψ & Hprf'). iPoseProof (Hprf' with "[$Hcr $Hs2]") as "Hic". iPoseProof (wp_ssteps with "[$Hs $Hic]") as "Hphi". @@ -853,20 +1016,20 @@ Definition notStuck : stuckness := λ e, False. by iApply fupd_mask_intro_discard. Qed. - Lemma wp_safety cr Σ `{!invGpreS Σ} n (rs : gReifiers n) + Lemma wp_safety cr Σ `{!invGpreS Σ} n a (rs : gReifiers a n) {A} `{!Cofe A} `{!statePreG rs A Σ} s k - (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : + (α β : IT (gReifiers_ops a rs) A) (σ σ' : gReifiers_state a rs ♯ IT (gReifiers_ops a rs) A) : (∀ Σ P Q, @disjunction_property Σ P Q) → - ssteps (gReifiers_sReifier rs) α σ β σ' k → + ssteps (gReifiers_sReifier a rs) α σ β σ' k → IT_to_V β ≡ None → (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → - ((∃ β1 σ1, sstep (gReifiers_sReifier rs) β σ' β1 σ1) + ((∃ β1 σ1, sstep (gReifiers_sReifier a rs) β σ' β1 σ1) ∨ (∃ e, β ≡ Err e ∧ s e)). Proof. Opaque istep. intros Hdisj Hstep Hbv Hwp. - cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier rs) β σ' β1 σ1) + cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier a rs) β σ' β1 σ1) ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. { intros [Hprf | Hprf]%Hdisj. - left. @@ -900,7 +1063,7 @@ Definition notStuck : stuckness := λ e, False. iApply (IT_vis_err_ne with "Ha"). } eapply (step_fupdN_soundness_lc _ 0 (cr + (3*k+2))). intros Hinv. iIntros "[Hcr Hlc]". - iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". + iMod (new_state_interp a rs σ) as (sg) "[Hs Hs2]". destruct (Hwp Hinv sg) as (Φ & HΦ & Hprf'). iPoseProof (Hprf' with "[$Hs2 $Hcr]") as "Hic". iPoseProof (wp_ssteps_isafe with "[$Hs $Hic]") as "H". From 733ff1dc6fb0c52122a439e96646f4d6f965a301 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Mon, 29 Jan 2024 21:17:52 +0100 Subject: [PATCH 088/114] simplify ctxdep reifiers --- _CoqProject | 2 +- theories/affine_lang/lang.v | 16 +- theories/affine_lang/logrel1.v | 188 +------ theories/affine_lang/logrel2.v | 301 ++++------ theories/examples/factorial.v | 18 +- theories/examples/iter.v | 9 +- theories/examples/store.v | 78 ++- theories/input_lang/interp.v | 822 +++++++++++++++------------- theories/input_lang/lang.v | 723 +++++++++++++----------- theories/input_lang/logpred.v | 231 ++++---- theories/input_lang/logrel.v | 406 ++++++-------- theories/input_lang_callcc/hom.v | 7 +- theories/input_lang_callcc/interp.v | 84 ++- theories/input_lang_callcc/lang.v | 2 - theories/input_lang_callcc/logrel.v | 27 +- theories/lang_affine.v | 245 +++++++++ theories/lang_generic.v | 239 +++----- theories/lang_generic_sem.v | 104 ---- theories/program_logic.v | 17 +- 19 files changed, 1661 insertions(+), 1858 deletions(-) create mode 100644 theories/lang_affine.v delete mode 100644 theories/lang_generic_sem.v diff --git a/_CoqProject b/_CoqProject index 018b6cf..e8cf1c7 100644 --- a/_CoqProject +++ b/_CoqProject @@ -16,7 +16,7 @@ vendor/Binding/Resolver.v theories/prelude.v theories/lang_generic.v -theories/lang_generic_sem.v +theories/lang_affine.v theories/gitree/core.v theories/gitree/subofe.v diff --git a/theories/affine_lang/lang.v b/theories/affine_lang/lang.v index 3096ec2..9616cb1 100644 --- a/theories/affine_lang/lang.v +++ b/theories/affine_lang/lang.v @@ -7,12 +7,14 @@ Module io_lang. Definition state := input_lang.lang.state. Definition ty := input_lang.lang.ty. Definition expr := input_lang.lang.expr. - Definition tyctx := tyctx ty. - Definition typed {S} := input_lang.lang.typed (S:=S). - Definition interp_closed {sz} (rs : gReifiers sz) `{!subReifier reify_io rs} (e : expr []) {R} `{!Cofe R, !SubOfe natO R} : IT (gReifiers_ops rs) R := - input_lang.interp.interp_expr rs e (). + Definition tyctx {S : Set} := S → ty. + Definition typed {S : Set} := input_lang.lang.typed (S:=S). + Program Definition ı_scope {sz} (rs : gReifiers NotCtxDep sz) `{!subReifier reify_io rs} {R} `{!Cofe R} : @interp_scope (gReifiers_ops NotCtxDep rs) R _ Empty_set := λne (x : ∅), match x with end. + Definition interp_closed {sz} (rs : gReifiers NotCtxDep sz) `{!subReifier reify_io rs} (e : expr ∅) {R} `{!Cofe R, !SubOfe natO R} : IT (gReifiers_ops NotCtxDep rs) R := + input_lang.interp.interp_expr rs e (ı_scope rs). End io_lang. +From gitrees Require Export lang_affine. Inductive ty := tBool | tInt | tUnit @@ -42,15 +44,15 @@ Inductive expr : scope → Type := | Alloc {S} : expr S → expr S | Replace {S1 S2} : expr S1 → expr S2 → expr (S1++S2) | Dealloc {S} : expr S → expr S -| EEmbed {τ1 τ1' S} : io_lang.expr [] → ty_conv τ1 τ1' → expr S +| EEmbed {τ1 τ1' S} : io_lang.expr Empty_set → ty_conv τ1 τ1' → expr S . Section affine. Context {sz : nat}. - Variable rs : gReifiers sz. + Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_store rs}. Context `{!subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops NotCtxDep rs). Context {R : ofe}. Context `{!Cofe R, !SubOfe unitO R, !SubOfe natO R, !SubOfe locO R}. Notation IT := (IT F R). diff --git a/theories/affine_lang/logrel1.v b/theories/affine_lang/logrel1.v index 9710d44..b5757b3 100644 --- a/theories/affine_lang/logrel1.v +++ b/theories/affine_lang/logrel1.v @@ -1,6 +1,6 @@ (** Unary (Kripke) logical relation for the affine lang *) From Equations Require Import Equations. -From gitrees Require Export lang_generic gitree program_logic. +From gitrees Require Export lang_affine gitree program_logic. From gitrees.affine_lang Require Import lang. From gitrees.examples Require Import store pairs. Require Import iris.algebra.gmap. @@ -51,10 +51,10 @@ Inductive typed : forall {S}, tyctx S → expr S → ty → Prop := Section logrel. Context {sz : nat}. - Variable rs : gReifiers sz. + Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_store rs}. Context `{!subReifier input_lang.interp.reify_io rs}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops NotCtxDep rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Context `{!SubOfe unitO R}. @@ -67,12 +67,8 @@ Section logrel. (* parameters for the kripke logical relation *) Variable s : stuckness. Context `{A:ofe}. - Variable (P : A → iProp). - Context `{!NonExpansive P}. + Variable (P : A -n> iProp). Local Notation expr_pred := (expr_pred s rs P). - Context {HCI : - ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) IT o}. (* interpreting tys *) Program Definition protected (Φ : ITV -n> iProp) : ITV -n> iProp := λne αv, @@ -110,7 +106,7 @@ Section logrel. end. Definition ssubst_valid {S} (Ω : tyctx S) ss := - lang_generic.ssubst_valid rs (λ τ, protected (interp_ty τ)) Ω ss. + lang_affine.ssubst_valid rs (λ τ, protected (interp_ty τ)) Ω ss. Definition valid1 {S} (Ω : tyctx S) (α : interp_scope S -n> IT) (τ : ty) : iProp := ∀ ss, heap_ctx -∗ ssubst_valid Ω ss -∗ expr_pred (α (interp_ssubst ss)) (interp_ty τ). @@ -119,7 +115,7 @@ Section logrel. ⊢ valid1 Ω1 α τ1 -∗ valid1 Ω2 β τ2 -∗ valid1 (tyctx_app Ω1 Ω2) (interp_pair α β ◎ interp_scope_split) (tPair τ1 τ2). - Proof using HCI. + Proof. Opaque pairITV. iIntros "H1 H2". iIntros (αs) "#Hctx Has". @@ -144,7 +140,7 @@ Section logrel. ⊢ valid1 Ω1 α (tPair τ1 τ2) -∗ valid1 (consC τ1 $ consC τ2 Ω2) β τ -∗ valid1 (tyctx_app Ω1 Ω2) (interp_destruct α β ◎ interp_scope_split) τ. - Proof using HCI. + Proof. Opaque pairITV thunked thunkedV projIT1 projIT2. iIntros "H1 H2". iIntros (αs) "#Hctx Has". @@ -211,7 +207,7 @@ Section logrel. Lemma compat_alloc {S} (Ω : tyctx S) α τ: ⊢ valid1 Ω α τ -∗ valid1 Ω (interp_alloc α) (tRef τ). - Proof using HCI. + Proof. iIntros "H". iIntros (αs) "#Hctx Has". iSpecialize ("H" with "Hctx Has"). @@ -229,7 +225,7 @@ Section logrel. ⊢ valid1 Ω1 α (tRef τ) -∗ valid1 Ω2 β τ' -∗ valid1 (tyctx_app Ω1 Ω2) (interp_replace α β ◎ interp_scope_split) (tPair τ (tRef τ')). - Proof using HCI. + Proof. Opaque pairITV. iIntros "H1 H2". iIntros (αs) "#Hctx Has". @@ -270,7 +266,7 @@ Section logrel. Lemma compat_dealloc {S} (Ω : tyctx S) α τ: ⊢ valid1 Ω α (tRef τ) -∗ valid1 Ω (interp_dealloc α) tUnit. - Proof using HCI. + Proof. iIntros "H". iIntros (αs) "#Hctx Has". iSpecialize ("H" with "Hctx Has"). @@ -328,7 +324,7 @@ Section logrel. ⊢ valid1 Ω1 α (tArr τ1 τ2) -∗ valid1 Ω2 β τ1 -∗ valid1 (tyctx_app Ω1 Ω2) (interp_app α β ◎ interp_scope_split) τ2. - Proof using HCI. + Proof. iIntros "H1 H2". iIntros (αs) "#Hctx Has". iEval(cbn-[interp_app]). @@ -352,7 +348,7 @@ Section logrel. Lemma compat_lam {S} (Ω : tyctx S) τ1 τ2 α : ⊢ valid1 (consC τ1 Ω) α τ2 -∗ valid1 Ω (interp_lam α) (tArr τ1 τ2). - Proof using HCI. + Proof. iIntros "H". iIntros (αs) "#Hctx Has". iIntros (x) "Hx". @@ -397,7 +393,7 @@ Section logrel. Lemma fundamental_affine {S} (Ω : tyctx S) (e : expr S) τ : typed Ω e τ → ⊢ valid1 Ω (interp_expr _ e) τ. - Proof using HCI. + Proof. induction 1; simpl. - by iApply compat_var. - by iApply compat_lam. @@ -420,157 +416,25 @@ Arguments interp_tnat {_ _ _ _ _ _}. Arguments interp_tunit {_ _ _ _ _ _}. Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} τ. -Local Definition rs : gReifiers 2 := gReifiers_cons reify_store (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). - -Local Instance CtxIndepInputLang R `{!Cofe R} (o : opid (sReifier_ops (gReifiers_sReifier rs))) : - CtxIndep (gReifiers_sReifier rs) (IT (gReifiers_ops rs) R) o. -Proof. - destruct o as [x o]. - inv_fin x. - - simpl. intros [[]| [[]| [[] | [| []]]]]. - + constructor. - unshelve eexists (λne '(l,(σ, σ')), x ← σ !! l; - Some (x, (σ, σ'))). - * apply _. - * apply _. - * solve_proper_prepare. - destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. - apply (option_mbind_ne _ (λ n, Some (n, _)) (λ n, Some (n, _))). - -- intros ? ? ?; repeat f_equiv; [done | |]; apply H. - -- rewrite lookup_ne; last apply H. - simpl. - f_equiv. - apply H. - * intros. - simpl. - destruct σ as [? [? ?]]. - simpl. - match goal with - | |- context G [@mbind option option_bind _ _ ?a ?b] => set (x := b) - end. - symmetry. - match goal with - | |- context G [@mbind option option_bind _ _ ?a ?b] => set (y := b) - end. - assert (y = x) as ->. - { reflexivity. } - destruct x as [x |]; reflexivity. - + constructor. - unshelve eexists (λne '((l,n),(s, s'')), let s' := <[l:=n]>s - in Some ((), (s', s''))). - * apply _. - * solve_proper_prepare. - destruct x as [[? ?] [? ?]]; destruct y as [[? ?] [? ?]]; simpl in *. - do 3 f_equiv; last apply H. - rewrite insert_ne; [| apply H | apply H]. - simpl. - f_equiv. - apply H. - * intros. - simpl. - destruct i as [? ?]. - destruct σ as [? [? ?]]. - simpl. - reflexivity. - + constructor. - unshelve eexists (λne '(n,(s, s'')), let l := Loc.fresh (dom s) in - let s' := <[l:=n]>s in - Some (l, (s', s''))). - * apply _. - * apply _. - * solve_proper_prepare. - destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. - do 2 f_equiv. - -- f_equiv. - destruct H as [_ [H _]]; simpl in H. - apply gmap_dom_ne in H. - apply H. - -- f_equiv; last apply H. - rewrite insert_ne; [| apply H | apply H]. - simpl. - f_equiv. - destruct H as [_ [H _]]; simpl in H. - apply gmap_dom_ne in H. - by rewrite H. - * intros. - simpl. - destruct i as [? ?]. - destruct σ as [? [? ?]]. - simpl. - reflexivity. - + constructor. - simpl. - unshelve eexists (λne '(l,(σ, σ')), Some ((), (delete l σ, σ'))). - * apply _. - * solve_proper_prepare. - destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. - do 2 f_equiv. - f_equiv; last apply H. - rewrite delete_ne; last apply H. - simpl. - f_equiv. - apply H. - * intros. - simpl. - destruct σ as [? [? ?]]. - simpl. - reflexivity. - - intros x; inv_fin x. - + simpl. intros [[]| [[]| []]]. - * constructor. - unshelve eexists (λne '(_, (a, (b, c))), SomeO (_, (_, (_, c)))). - -- simpl in *. - apply ((input_lang.lang.update_input b).1). - -- apply a. - -- apply ((input_lang.lang.update_input b).2). - -- solve_proper_prepare. - destruct x as [? [? [? ?]]]; destruct y as [? [? [? ?]]]. - simpl in *. - do 2 f_equiv. - ++ do 2 f_equiv. - apply H. - ++ f_equiv; first apply H. - f_equiv; last apply H. - do 2 f_equiv; apply H. - -- intros. - simpl. - destruct σ as [? [? ?]]. - simpl. - reflexivity. - * constructor. - unshelve eexists (λne '(x, (y, z)), SomeO ((), _)). - -- simpl in *. - apply (y, ((input_lang.lang.update_output x (fstO z)), ())). - -- solve_proper_prepare. - destruct x as [? [? [? ?]]]; destruct y as [? [? [? ?]]]. - simpl in *. - do 2 f_equiv. - apply pair_ne. - ++ apply H. - ++ do 2 f_equiv; apply H. - -- intros. - simpl. - destruct σ as [σ1 [? []]]; simpl in *. - reflexivity. - + intros i; by apply fin_0_inv. -Qed. +Local Definition rs : gReifiers NotCtxDep 2 := + gReifiers_cons NotCtxDep reify_store (gReifiers_cons NotCtxDep input_lang.interp.reify_io (gReifiers_nil NotCtxDep)). Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. Lemma logrel1_adequacy cr Σ R `{!Cofe R, !SubOfe natO R, !SubOfe unitO R, !SubOfe locO R} `{!invGpreS Σ} `{!statePreG rs R Σ} `{!heapPreG rs R Σ} τ - (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : + (α : unitO -n> IT (gReifiers_ops NotCtxDep rs) R) (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ}, - (£ cr ⊢ valid1 rs notStuck (λ _:unitO, True)%I empC α τ)%I) → - ssteps (gReifiers_sReifier rs) (α ()) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) + (£ cr ⊢ valid1 rs notStuck (λne _: unitO, True)%I empC α τ)%I) → + ssteps (gReifiers_sReifier NotCtxDep rs) (α ()) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep 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) + cut ((∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (∃ e, β ≡ Err e ∧ notStuck e)). { intros [?|He]; first done. destruct He as [? [? []]]. } @@ -586,9 +450,9 @@ Proof. iMod (new_heapG rs σ) as (H3) "H". iAssert (has_substate σ ∗ has_substate ios)%I with "[Hst]" as "[Hs Hio]". { unfold has_substate, has_full_state. - assert (of_state rs (IT (gReifiers_ops rs) _) st ≡ - of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ) - ⋅ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios)) as ->; last first. + assert (of_state NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) st ≡ + of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state σ) + ⋅ of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state ios)) as ->; last first. { rewrite -own_op. done. } unfold sR_idx. simpl. intro j. @@ -615,10 +479,10 @@ Qed. Definition R := sumO locO (sumO unitO natO). -Lemma logrel1_safety e τ (β : IT (gReifiers_ops rs) R) st st' k : +Lemma logrel1_safety e τ (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : typed empC e τ → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) + ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ()) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (∃ βv, IT_of_V βv ≡ β). Proof. intros Hty Hst. diff --git a/theories/affine_lang/logrel2.v b/theories/affine_lang/logrel2.v index 6c5b827..a45dac8 100644 --- a/theories/affine_lang/logrel2.v +++ b/theories/affine_lang/logrel2.v @@ -1,18 +1,20 @@ From Equations Require Import Equations. From iris.base_logic.lib Require Import na_invariants. -From gitrees Require Export lang_generic gitree program_logic. +From gitrees Require Export lang_affine gitree program_logic. From gitrees.input_lang Require Import lang interp logpred. From gitrees.affine_lang Require Import lang logrel1. From gitrees.examples Require Import store pairs. Require Import iris.algebra.gmap. +Require Import Binding.Lib Binding.Set Binding.Env. + Local Notation tyctx := (tyctx ty). Inductive typed_glued : forall {S}, tyctx S → expr S → ty → Type := (** FFI *) | typed_Glue {S} (Ω : tyctx S) τ' τ e (tconv : ty_conv τ τ') : - io_lang.typed empC e τ' → + io_lang.typed □ e τ' → typed_glued Ω (EEmbed e tconv) τ (** functions *) | typed_VarG {S} (Ω : tyctx S) (τ : ty) (v : var S) : @@ -57,10 +59,10 @@ Inductive typed_glued : forall {S}, tyctx S → expr S → ty → Type := Section glue. Context {sz : nat}. - Variable rs : gReifiers sz. + Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_store rs}. Context `{!subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops NotCtxDep rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Context `{!SubOfe unitO R}. @@ -70,30 +72,30 @@ Section glue. Context `{!invGS Σ, !stateG rs R Σ, !heapG rs R Σ, !na_invG Σ}. Notation iProp := (iProp Σ). - Context {HCI : - ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) IT o}. - Definition s : stuckness := λ e, e = OtherError. Variable p : na_inv_pool_name. Definition valid2 {S} (Ω : tyctx S) (α : interp_scope (E:=F) S -n> IT) (τ : ty) : iProp := - valid1 rs s (λ σ, has_substate σ ∗ na_own p ⊤)%I Ω α τ. + valid1 rs s (λne σ, has_substate σ ∗ na_own p ⊤)%I Ω α τ. - Definition io_valid {S} (Γ : io_lang.tyctx S) α (τ' : io_lang.ty) : iProp := - input_lang.logpred.valid1 rs s (λ _ : unitO, na_own p ⊤) Γ α τ'. + Definition io_valid {S : Set} (Γ : S → io_lang.ty) α (τ' : io_lang.ty) : iProp := + input_lang.logpred.valid1 rs s (λne _ : unitO, na_own p ⊤) Γ α τ'. Local Opaque thunked thunkedV Thunk. + + Program Definition ı_scope : @lang_generic.interp_scope (gReifiers_ops NotCtxDep rs) R _ Empty_set := λne (x : ∅), match x with end. + Lemma compat_glue_to_affine_bool {S} (Ω : tyctx S) α : - io_valid empC α Tnat ⊢ - valid2 Ω (constO (glue2_bool _ (α ()))) tBool. - Proof using HCI. + io_valid □ α Tnat ⊢ + valid2 Ω (constO (glue2_bool _ (α ı_scope))) tBool. + Proof. iIntros "H". iIntros (ss) "#Hctx Has". simpl. iIntros (σ) "[Hs Hp]". - iSpecialize ("H" $! σ emp_ssubst with "Hs []"). + iSpecialize ("H" $! σ ı_scope with "Hs []"). { unfold logpred.ssubst_valid. - iApply ssubst_valid_nil. } + iIntros ([]). + } iSpecialize ("H" $! tt with "Hp"). simp interp_ssubst. simpl. iApply (wp_bind _ (IFSCtx _ _)). @@ -111,48 +113,58 @@ Section glue. iApply wp_val; eauto with iFrame. Qed. Lemma compat_glue_to_affine_nat {S} (Ω : tyctx S) α : - io_valid empC α Tnat ⊢ - valid2 Ω (constO (α ())) tInt. + io_valid □ α Tnat ⊢ + valid2 Ω (constO (α ı_scope)) tInt. Proof. iIntros "H". iIntros (ss) "#Hctx Has". simpl. iIntros (σ) "[Hs Hp]". - iSpecialize ("H" $! σ emp_ssubst with "Hs []"). + iSpecialize ("H" $! σ ı_scope with "Hs []"). { unfold logpred.ssubst_valid. - iApply ssubst_valid_nil. } + iIntros ([]). + } iSpecialize ("H" $! tt with "Hp"). simp interp_ssubst. simpl. iApply (wp_wand with "H"). iIntros (αv). iDestruct 1 as (_) "[Ha Hp]". iDestruct "Ha" as (σ') "[Ha Hs]". iModIntro. eauto with iFrame. - Qed. + + Lemma IT_move_from_affine (α : @interp_scope (@gReifiers_ops NotCtxDep sz rs) R _ [] -n> IT) + : @lang_generic.interp_scope (@gReifiers_ops NotCtxDep sz rs) R _ ∅ -n> IT. + Proof. + unshelve econstructor. + - intros g. apply α. + constructor. + - repeat intro. + f_equiv. + Defined. + Lemma compat_glue_from_affine_bool α : valid2 empC α tBool ⊢ - heap_ctx -∗ io_valid empC α Tnat. + heap_ctx -∗ io_valid □ (IT_move_from_affine α) Tnat. Proof. iIntros "H #Hctx". iIntros (σ ss) "Hs Hss". - iIntros (_) "Hp". + iIntros (?) "Hp". iSpecialize ("H" $! emp_ssubst with "Hctx [] [$Hs $Hp]"). { iApply ssubst_valid_nil. } - dependent elimination ss as [emp_ssubst]. iApply (wp_wand with "H"). iIntros (αv) "Ha". iDestruct "Ha" as (σ') "[Ha [Hs Hp]]". iModIntro. simpl. iFrame. iExists tt,_; iFrame. iDestruct "Ha" as "[Ha|Ha]"; iExists _; eauto. Qed. + Lemma compat_glue_from_affine_nat α : valid2 empC α tInt ⊢ - heap_ctx -∗ io_valid empC α Tnat. + heap_ctx -∗ io_valid □ (IT_move_from_affine α) Tnat. Proof. iIntros "H #Hctx". iIntros (σ ss) "Hs Hss". - iIntros (_) "Hp". + iIntros (?) "Hp". iSpecialize ("H" $! emp_ssubst with "Hctx [] [$Hs $Hp]"). { iApply ssubst_valid_nil. } - dependent elimination ss as [emp_ssubst]. iApply (wp_wand with "H"). iIntros (αv) "Ha". iDestruct "Ha" as (σ') "[Ha [Hs Hp]]". iModIntro. iExists tt. eauto with iFrame. @@ -160,11 +172,11 @@ Section glue. Lemma compat_glue_from_affine_unit α : valid2 empC α tUnit ⊢ - heap_ctx -∗ io_valid empC (constO (glue_from_affine _ ty_conv_unit (α ()))) Tnat. + heap_ctx -∗ io_valid □ (constO (glue_from_affine _ ty_conv_unit (α ()))) Tnat. Proof. iIntros "H #Hctx". iIntros (σ ss) "Hs Hss". - iIntros (_) "Hp". + iIntros (?) "Hp". simpl. iApply wp_val. iModIntro. iExists tt. iFrame. simpl. eauto with iFrame. @@ -174,19 +186,23 @@ Section glue. Lemma compat_glue_from_affine_fun (τ1 τ2 : ty) (τ1' τ2' : io_lang.ty) α (glue_to_affine glue_from_affine : IT -n> IT) : - (∀ α, io_valid empC α τ1' - ⊢ valid2 empC (constO (glue_to_affine (α ()))) τ1) → + (∀ α, io_valid □ α τ1' + ⊢ valid2 empC (constO (glue_to_affine (α ı_scope))) τ1) → (∀ α, valid2 empC (constO α) τ2 - ⊢ heap_ctx -∗ io_valid empC (constO (glue_from_affine α)) τ2') → + ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine α)) τ2') → valid2 empC (constO α) (tArr τ1 τ2) ⊢ heap_ctx -∗ - io_valid empC + io_valid □ (constO (glue_from_affine_fun _ glue_from_affine glue_to_affine α)) (Tarr (Tarr Tnat τ1') τ2'). - Proof using HCI. + Proof. intros G1 G2. - iIntros "H #Hctx". iIntros (σ ss) "Hs _ _ Hp". - simpl. clear ss. + iIntros "H #Hctx". + unfold io_valid. + unfold logpred.valid1. + iIntros (σ ss) "Hs ?". + simpl. + iIntros (?) "Hp". iSpecialize ("H" $! emp_ssubst with "Hctx [] [$Hs $Hp]"). { iApply ssubst_valid_nil. } simpl. iApply wp_let. @@ -209,7 +225,7 @@ Section glue. iModIntro. simpl. iApply wp_val. iModIntro. iExists tt. iFrame. iExists σ'. iFrame. iModIntro. clear σ σ'. iIntros (σ βv) "Hs #Hb". - iIntros (_) "Hp". + iIntros (?) "Hp". iApply wp_lam. iNext. simpl. iApply wp_let. { solve_proper. } @@ -249,7 +265,7 @@ Section glue. { eauto with iFrame. } iSpecialize ("Hb" $! tt with "Hp"). iApply (wp_wand with "Hb"). - iIntros (γv). iDestruct 1 as (_) "[Hg Hp]". + iIntros (γv). iDestruct 1 as (?) "[Hg Hp]". iDestruct "Hg" as (σ') "[Hg Hst]". iModIntro. simpl. iApply wp_let. @@ -275,28 +291,32 @@ Section glue. iSpecialize ("G1" with "[Hg] Hctx"). { iIntros (ss0) "_ _". by iApply expr_pred_ret. } - iSpecialize ("G1" $! _ emp_ssubst with "Hst []"). - { iApply ssubst_valid_nil. } + iSpecialize ("G1" $! _ ı_scope with "Hst []"). + { + iIntros ([]). + } iApply ("G1" $! tt with "Hp"). Qed. Lemma compat_glue_to_affine_fun {S} (Ω : tyctx S) (τ1 τ2 : ty) (τ1' τ2' : io_lang.ty) α (glue_to_affine glue_from_affine : IT -n> IT) : - (∀ α, io_valid empC α τ2' - ⊢ valid2 Ω (constO (glue_to_affine (α ()))) τ2) → + (∀ α, io_valid □ α τ2' + ⊢ valid2 Ω (constO (glue_to_affine (α ı_scope))) τ2) → (∀ α, valid2 empC (constO α) τ1 - ⊢ heap_ctx -∗ io_valid empC (constO (glue_from_affine α)) τ1') → - io_valid empC α (Tarr (Tarr Tnat τ1') τ2') + ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine α)) τ1') → + io_valid □ α (Tarr (Tarr Tnat τ1') τ2') ⊢ valid2 Ω - (constO (glue_to_affine_fun _ glue_from_affine glue_to_affine (α ()))) + (constO (glue_to_affine_fun _ glue_from_affine glue_to_affine (α ı_scope))) (tArr τ1 τ2). - Proof using HCI. + Proof. intros G1 G2. iIntros "H". iIntros (αs) "#Hctx Has". iIntros (σ) "[Hs Hp]". simpl. - iSpecialize ("H" $! _ emp_ssubst with "Hs []"). - { iApply ssubst_valid_nil. } + iSpecialize ("H" $! _ ı_scope with "Hs []"). + { + iIntros ([]). + } iSpecialize ("H" $! tt with "Hp"). simp interp_ssubst. simpl. iApply wp_let. @@ -345,12 +365,14 @@ Section glue. iIntros (σ0) "Hs". simpl. iApply wp_val. eauto with iFrame. } iSpecialize ("G2" with "Hctx"). - iSpecialize ("G2" $! _ emp_ssubst with "Hs []"). - { iApply ssubst_valid_nil. } + iSpecialize ("G2" $! _ ı_scope with "Hs []"). + { + iIntros ([]). + } iSpecialize ("G2" $! tt with "Hp"). iApply (wp_wand with "G2"). iIntros (β'v). - iDestruct 1 as (_) "[Hb Hp]". iModIntro. + iDestruct 1 as (?) "[Hb Hp]". iModIntro. simpl. clear σ. iDestruct "Hb" as (σ) "[#Hb Hs]". (* calling the original function *) iApply wp_let. @@ -369,7 +391,7 @@ Section glue. iPoseProof ("Ha" $! _ (thunkedV (IT_of_V β'v) l') with "Hs [-Has Hp]") as "H1". { iModIntro. iIntros (σ' βn) "Hs Hbm". iDestruct "Hbm" as (m) "Hbm". - iIntros (_) "Hp". + iIntros (?) "Hp". iApply wp_lam. iNext. iSimpl. iApply (wp_bind _ (IFSCtx _ _)). { solve_proper. } @@ -401,7 +423,7 @@ Section glue. iModIntro. iSpecialize ("H1" $! tt with "Hp"). iApply (wp_wand with "H1"). - iIntros (γv). iDestruct 1 as (_) "[H2 Hp]". + iIntros (γv). iDestruct 1 as (?) "[H2 Hp]". iModIntro. simpl. iDestruct "H2" as (σ') "[#H2 Hs]". iPoseProof (G1 (constO (IT_of_V γv))) as "G1". iSpecialize ("G1" with "[H2]"). @@ -415,11 +437,11 @@ Section glue. Lemma glue_to_affine_compatibility {S} (Ω : tyctx S) (τ1 : ty) (τ1' : io_lang.ty) (Hconv : ty_conv τ1 τ1') α : - io_valid empC α τ1' ⊢ valid2 Ω (constO (glue_to_affine _ Hconv (α ()))) τ1 + io_valid □ α τ1' ⊢ valid2 Ω (constO (glue_to_affine _ Hconv (α ı_scope))) τ1 with glue_from_affine_compatibility (τ1 : ty) (τ1' : io_lang.ty) (Hconv : ty_conv τ1 τ1') (α : IT) : - valid2 empC (constO α) τ1 ⊢ heap_ctx -∗ io_valid empC (constO (glue_from_affine _ Hconv α)) τ1'. - Proof using HCI. + valid2 empC (constO α) τ1 ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine _ Hconv α)) τ1'. + Proof. - destruct Hconv. + by iApply compat_glue_to_affine_bool. + by iApply compat_glue_to_affine_nat. @@ -440,7 +462,7 @@ Section glue. Lemma fundamental_affine_glued {S} (Ω : tyctx S) (e : expr S) τ : typed_glued Ω e τ → ⊢ valid2 Ω (interp_expr _ e) τ. - Proof using HCI. + Proof. intros typed. induction typed; simpl. - iApply glue_to_affine_compatibility. by iApply fundamental. @@ -459,161 +481,32 @@ Section glue. End glue. -Local Definition rs : gReifiers 2 := gReifiers_cons reify_store (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). - -Local Instance CtxIndepInputLang R `{!Cofe R} (o : opid (sReifier_ops (gReifiers_sReifier rs))) : - CtxIndep (gReifiers_sReifier rs) - (IT (sReifier_ops (gReifiers_sReifier rs)) R) o. -Proof. - destruct o as [x o]. - inv_fin x. - - simpl. intros [[]| [[]| [[] | [| []]]]]. - + constructor. - unshelve eexists (λne '(l,(σ, σ')), x ← σ !! l; - Some (x, (σ, σ'))). - * apply _. - * apply _. - * solve_proper_prepare. - destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. - apply (option_mbind_ne _ (λ n, Some (n, _)) (λ n, Some (n, _))). - -- intros ? ? ?; repeat f_equiv; [done | |]; apply H. - -- rewrite lookup_ne; last apply H. - simpl. - f_equiv. - apply H. - * intros. - simpl. - destruct σ as [? [? ?]]. - simpl. - match goal with - | |- context G [@mbind option option_bind _ _ ?a ?b] => set (x := b) - end. - symmetry. - match goal with - | |- context G [@mbind option option_bind _ _ ?a ?b] => set (y := b) - end. - assert (y = x) as ->. - { reflexivity. } - destruct x as [x |]; reflexivity. - + constructor. - unshelve eexists (λne '((l,n),(s, s'')), let s' := <[l:=n]>s - in Some ((), (s', s''))). - * apply _. - * solve_proper_prepare. - destruct x as [[? ?] [? ?]]; destruct y as [[? ?] [? ?]]; simpl in *. - do 3 f_equiv; last apply H. - rewrite insert_ne; [| apply H | apply H]. - simpl. - f_equiv. - apply H. - * intros. - simpl. - destruct i as [? ?]. - destruct σ as [? [? ?]]. - simpl. - reflexivity. - + constructor. - unshelve eexists (λne '(n,(s, s'')), let l := Loc.fresh (dom s) in - let s' := <[l:=n]>s in - Some (l, (s', s''))). - * apply _. - * apply _. - * solve_proper_prepare. - destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. - do 2 f_equiv. - -- f_equiv. - destruct H as [_ [H _]]; simpl in H. - apply gmap_dom_ne in H. - apply H. - -- f_equiv; last apply H. - rewrite insert_ne; [| apply H | apply H]. - simpl. - f_equiv. - destruct H as [_ [H _]]; simpl in H. - apply gmap_dom_ne in H. - by rewrite H. - * intros. - simpl. - destruct i as [? ?]. - destruct σ as [? [? ?]]. - simpl. - reflexivity. - + constructor. - simpl. - unshelve eexists (λne '(l,(σ, σ')), Some ((), (delete l σ, σ'))). - * apply _. - * solve_proper_prepare. - destruct x as [? [? ?]]; destruct y as [? [? ?]]; simpl in *. - do 2 f_equiv. - f_equiv; last apply H. - rewrite delete_ne; last apply H. - simpl. - f_equiv. - apply H. - * intros. - simpl. - destruct σ as [? [? ?]]. - simpl. - reflexivity. - - intros x; inv_fin x. - + simpl. intros [[]| [[]| []]]. - * constructor. - unshelve eexists (λne '(_, (a, (b, c))), SomeO (_, (_, (_, c)))). - -- simpl in *. - apply ((input_lang.lang.update_input b).1). - -- apply a. - -- apply ((input_lang.lang.update_input b).2). - -- solve_proper_prepare. - destruct x as [? [? [? ?]]]; destruct y as [? [? [? ?]]]. - simpl in *. - do 2 f_equiv. - ++ do 2 f_equiv. - apply H. - ++ f_equiv; first apply H. - f_equiv; last apply H. - do 2 f_equiv; apply H. - -- intros. - simpl. - destruct σ as [? [? ?]]. - simpl. - reflexivity. - * constructor. - unshelve eexists (λne '(x, (y, z)), SomeO ((), _)). - -- simpl in *. - apply (y, ((input_lang.lang.update_output x (fstO z)), ())). - -- solve_proper_prepare. - destruct x as [? [? [? ?]]]; destruct y as [? [? [? ?]]]. - simpl in *. - do 2 f_equiv. - apply pair_ne. - ++ apply H. - ++ do 2 f_equiv; apply H. - -- intros. - simpl. - destruct σ as [σ1 [? []]]; simpl in *. - reflexivity. - + intros i; by apply fin_0_inv. -Qed. +Local Definition rs : gReifiers NotCtxDep 2 + := gReifiers_cons NotCtxDep reify_store + (gReifiers_cons NotCtxDep input_lang.interp.reify_io (gReifiers_nil NotCtxDep)). Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. -Lemma logrel2_adequacy cr R `{!Cofe R, !SubOfe locO R, !SubOfe natO R, !SubOfe unitO R} Σ `{!invGpreS Σ}`{!statePreG rs R Σ} `{!heapPreG rs R Σ} `{!na_invG Σ} - τ (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : +Require Import gitrees.gitree.greifiers. + +Lemma logrel2_adequacy (cr : nat) R `{!Cofe R, !SubOfe locO R, !SubOfe natO R, !SubOfe unitO R} + Σ `{!invGpreS Σ}`{!statePreG rs R Σ} `{!heapPreG rs R Σ} `{!na_invG Σ} + (τ : ty) (α : unitO -n> IT (gReifiers_ops NotCtxDep rs) R) (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ} p, (£ cr ⊢ valid2 rs p empC α τ)%I) → - ssteps (gReifiers_sReifier rs) (α ()) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) + ssteps (gReifiers_sReifier NotCtxDep rs) (α ()) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (β ≡ Err OtherError) ∨ (∃ βv, IT_of_V βv ≡ β). Proof. intros Hlog Hst. destruct (IT_to_V β) as [βv|] eqn:Hb. { right. right. exists βv. apply IT_of_to_V'. rewrite Hb; eauto. } - cut ((∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) + cut ((∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (∃ e, β ≡ Err e ∧ s e)). { intros [?|He]; first eauto. right. left. destruct He as [? [? ->]]. done. } - eapply (wp_safety (S cr) _ _ rs s); eauto. + eapply (wp_safety (S cr) _ _ NotCtxDep rs s); eauto. { apply Hdisj. } { by rewrite Hb. } intros H1 H2. @@ -625,9 +518,9 @@ Proof. iMod (new_heapG rs σ) as (H3) "H". iAssert (has_substate σ ∗ has_substate ios)%I with "[Hst]" as "[Hs Hio]". { unfold has_substate, has_full_state. - assert (of_state rs (IT (gReifiers_ops rs) _) st ≡ - of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ) - ⋅ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios)) as ->; last first. + assert (of_state NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) st ≡ + of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state σ) + ⋅ of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state ios)) as ->; last first. { rewrite -own_op. done. } unfold sR_idx. simpl. intro j. @@ -656,10 +549,10 @@ Qed. Definition R := sumO locO (sumO natO unitO). -Lemma logrel2_safety e τ (β : IT (gReifiers_ops rs) R) st st' k : +Lemma logrel2_safety e τ (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : typed_glued empC e τ → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) + ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ()) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (β ≡ Err OtherError) ∨ (∃ βv, IT_of_V βv ≡ β). Proof. diff --git a/theories/examples/factorial.v b/theories/examples/factorial.v index 3ee54dd..3d2cc4e 100644 --- a/theories/examples/factorial.v +++ b/theories/examples/factorial.v @@ -4,18 +4,14 @@ From gitrees.input_lang Require Import lang interp. From gitrees.examples Require Import store while. Section fact. - Definition rs : gReifiers 2 := - gReifiers_cons reify_io (gReifiers_cons reify_store gReifiers_nil). - Notation F := (gReifiers_ops rs). + Definition rs : gReifiers NotCtxDep 2 := + gReifiers_cons NotCtxDep reify_io (gReifiers_cons NotCtxDep reify_store (gReifiers_nil NotCtxDep)). + Notation F := (gReifiers_ops NotCtxDep rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R, !SubOfe unitO R}. Notation IT := (IT F R). Notation ITV := (ITV F R). - Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. - Context `{!invGS Σ, !stateG rs R Σ, !heapG rs R Σ}. Notation iProp := (iProp Σ). @@ -40,7 +36,7 @@ Section fact. heap_ctx -∗ pointsto acc (Ret m) -∗ pointsto ℓ (Ret n) -∗ WP@{rs} fact_imp_body acc ℓ {{ _, pointsto acc (Ret (m * fact n)) }}. - Proof using HCI. + Proof. iIntros "#Hctx Hacc Hl". iLöb as "IH" forall (n m). unfold fact_imp_body. @@ -100,7 +96,7 @@ Section fact. Lemma wp_fact_imp (n : nat) : heap_ctx ⊢ WP@{rs} fact_imp ⊙ (Ret n) {{ βv, βv ≡ RetV (fact n) }}. - Proof using HCI. + Proof. iIntros "#Hctx". iApply wp_lam. iNext. simpl. rewrite get_ret_ret. @@ -114,7 +110,7 @@ Section fact. iIntros (ℓ) "Hl". simpl. iApply wp_seq. { solve_proper. } - iApply (wp_wand _ (λ _, pointsto acc (Ret $ fact n)) with "[-]"); last first. + iApply (wp_wand _ _ (λ _, pointsto acc (Ret $ fact n)) with "[-]"); last first. { simpl. iIntros (_) "Hacc". iModIntro. iApply (wp_read with "Hctx Hacc"). iNext. iNext. iIntros "Hacc". @@ -128,7 +124,7 @@ Section fact. Lemma wp_fact_io (n : nat) : heap_ctx ∗ has_substate (State [n] []) ⊢ WP@{rs} get_ret OUTPUT fact_io {{ _, has_substate (State [] [fact n]) }}. - Proof using HCI. + Proof. iIntros "[#Hctx Htape]". unfold fact_io. iApply (wp_bind _ (get_ret _)). diff --git a/theories/examples/iter.v b/theories/examples/iter.v index 18ef4f9..e19dc18 100644 --- a/theories/examples/iter.v +++ b/theories/examples/iter.v @@ -59,23 +59,20 @@ End iter. Section iter_wp. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers NotCtxDep sz). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops NotCtxDep rs). Notation IT := (IT F R). Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. Lemma wp_iter f (m : nat) β Ψ `{!AsVal f} `{!NonExpansive Ψ} : ⊢ WP@{rs} β {{ Ψ }} -∗ □ (∀ βv, Ψ βv -∗ WP@{rs} (f ⊙ (IT_of_V βv)) {{ Ψ }}) -∗ WP@{rs} (ITER ⊙ f ⊙ (Ret m) ⊙ β) {{ Ψ }}. - Proof using HCI. + Proof. iIntros "Hb #H". iApply (wp_bind _ (AppRSCtx (ITER ⊙ f ⊙ (Ret m)))). iApply (wp_wand with "Hb"). diff --git a/theories/examples/store.v b/theories/examples/store.v index 425446f..490ad68 100644 --- a/theories/examples/store.v +++ b/theories/examples/store.v @@ -17,47 +17,47 @@ Proof. apply _. Qed. #[local] Instance state_cofe X `{!Cofe X} : Cofe (stateF ♯ X). Proof. apply _. Qed. -Definition state_read X `{!Cofe X} : loc * (stateF ♯ X) * (laterO X -n> laterO X) → option (laterO X * (stateF ♯ X)) - := λ '(l,σ,κ), x ← σ !! l; - Some (κ x, σ). +Definition state_read X `{!Cofe X} : loc * (stateF ♯ X) → option (laterO X * (stateF ♯ X)) + := λ '(l,σ), x ← σ !! l; + Some (x, σ). #[export] Instance state_read_ne X `{!Cofe X} : - NonExpansive (state_read X : prodO (prodO locO (stateF ♯ X)) (laterO X -n> laterO X) → optionO (prodO (laterO X) (stateF ♯ X))). + NonExpansive (state_read X : prodO locO (stateF ♯ X) → optionO (prodO (laterO X) (stateF ♯ X))). Proof. - intros n [[l1 s1] κ1] [[l2 s2] κ2]. simpl. intros [[-> Hs'] Hs]. - apply (option_mbind_ne _ (λ n, Some (κ1 n, s1)) (λ n, Some (κ2 n, s2))); + intros n [l1 s1] [l2 s2]. simpl. intros [-> Hs]. + apply (option_mbind_ne _ (λ n, Some (n, s1)) (λ n, Some (n, s2))); solve_proper. Qed. -Definition state_dealloc X `{!Cofe X} : loc * (stateF ♯ X) * (unitO -n> laterO X) → option (laterO X * (stateF ♯ X)) - := λ '(l,σ,κ), Some (κ (), delete l σ). +Definition state_dealloc X `{!Cofe X} : loc * (stateF ♯ X) → option (unitO * (stateF ♯ X)) + := λ '(l,σ), Some ((), delete l σ). #[export] Instance state_dealloc_ne X `{!Cofe X} : - NonExpansive (state_dealloc X : prodO (prodO locO (stateF ♯ X)) (unitO -n> laterO X) → optionO (prodO (laterO X) (stateF ♯ X))). + NonExpansive (state_dealloc X : prodO locO (stateF ♯ X) → optionO (prodO unitO (stateF ♯ X))). Proof. - intros n [[l1 s1] κ1] [[l2 s2] κ2]. simpl. intros [[-> Hs'] Hs]. + intros n [l1 s1] [l2 s2]. simpl. intros [-> Hs]. solve_proper. Qed. Definition state_write X `{!Cofe X} : - (loc * (laterO X)) * (stateF ♯ X) * (unitO -n> laterO X) → option (laterO X * (stateF ♯ X)) - := λ '((l,n),s,κ), let s' := <[l:=n]>s - in Some (κ (), s'). + (loc * (laterO X)) * (stateF ♯ X) → option (unit * (stateF ♯ X)) + := λ '((l,n),s), let s' := <[l:=n]>s + in Some ((), s'). #[export] Instance state_write_ne X `{!Cofe X} : - NonExpansive (state_write X : prodO (prodO (prodO locO _) (stateF ♯ _)) (unitO -n> laterO X) → optionO (prodO (laterO X) (stateF ♯ X))). + NonExpansive (state_write X : prodO (prodO locO _) (stateF ♯ _) → optionO (prodO unitO (stateF ♯ X))). Proof. - intros n [[[l1 m1] s1] κ1] [[[l2 m2] s2] κ2]. simpl. - intros [[[Hl%leibnizO_leibniz Hm] Hs] Hκ]. simpl in Hl. + intros n [[l1 m1] s1] [[l2 m2] s2]. simpl. + intros [[Hl%leibnizO_leibniz Hm] Hs]. simpl in Hl. rewrite Hl. solve_proper. Qed. -Definition state_alloc X `{!Cofe X} : (laterO X) * (stateF ♯ X) * (loc -n> laterO X) → option ((laterO X) * (stateF ♯ X)) - := λ '(n,s,κ), let l := Loc.fresh (dom s) in +Definition state_alloc X `{!Cofe X} : (laterO X) * (stateF ♯ X) → option (loc * (stateF ♯ X)) + := λ '(n,s), let l := Loc.fresh (dom s) in let s' := <[l:=n]>s in - Some (κ l, s'). + Some (l, s'). #[export] Instance state_alloc_ne X `{!Cofe X} : - NonExpansive (state_alloc X : prodO (prodO _ (stateF ♯ X)) (locO -n> laterO X) → optionO (prodO (laterO X) (stateF ♯ X))). + NonExpansive (state_alloc X : prodO _ (stateF ♯ X) → optionO (prodO locO (stateF ♯ X))). Proof. - intros n [[m1 s1] κ1] [[m2 s2] κ2]. simpl. - intros [[Hm Hs] Hκ]. simpl in *. + intros n [m1 s1] [m2 s2]. simpl. + intros [Hm Hs]. simpl in *. set (l1 := Loc.fresh (dom s1)). set (l2 := Loc.fresh (dom s2)). assert (l1 = l2) as ->. @@ -83,7 +83,7 @@ Program Definition DeallocE : opInterp := {| |}. Definition storeE : opsInterp := @[ReadE;WriteE;AllocE;DeallocE]. -Canonical Structure reify_store : sReifier. +Canonical Structure reify_store : sReifier NotCtxDep. Proof. simple refine {| sReifier_ops := storeE |}. intros X HX op. @@ -129,11 +129,11 @@ End constructors. Section wp. Context {n : nat}. - Variable (rs : gReifiers n). + Variable (rs : gReifiers NotCtxDep n). Context {R} `{!Cofe R}. Context `{!SubOfe unitO R}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops NotCtxDep rs). Notation IT := (IT F R). Notation ITV := (ITV F R). Notation stateO := (stateF ♯ IT). @@ -229,7 +229,7 @@ Section wp. match goal with | |- context G [Vis ?a ?b ?c] => assert (c ≡ idfun ◎ (subEff_outs ^-1)) as -> end; first solve_proper. - iApply wp_subreify'. + iApply wp_subreify_ctx_indep'. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (fupd_mask_weaken E1). { set_solver. } @@ -261,10 +261,7 @@ Section wp. simpl. iPureIntro. f_equiv; last done. - intros ???. - do 2 f_equiv. - by rewrite ofe_iso_21. - - done. + - iPureIntro. apply ofe_iso_21. - iNext. iIntros "Hlc Hs". iMod ("Hback" with "Hp") as "Hback". iMod "Hwk" . @@ -296,7 +293,7 @@ Section wp. Proof. iIntros (Hee) "#Hcxt H". unfold READ. simpl. - iApply wp_subreify'. + iApply wp_subreify_ctx_indep'. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (fupd_mask_weaken E1). { set_solver. } @@ -309,7 +306,7 @@ Section wp. destruct (Next_uninj x) as [α' Ha']. iApply (lc_fupd_elim_later with "Hlc"). iNext. - iExists σ,(Next (Ret ())),(<[l:=Next β]>σ),(Ret ()). + iExists σ,(),(<[l:=Next β]>σ),(Ret ()). iFrame "Hs". iSimpl. repeat iSplit; [ done | done | ]. iNext. iIntros "Hlc". @@ -342,22 +339,17 @@ Section wp. WP@{rs} ALLOC α k @ s {{ Φ }}. Proof. iIntros "Hh H". - iApply wp_subreify'. + iApply wp_subreify_ctx_indep'. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (lc_fupd_elim_later with "Hlc"). iModIntro. set (l:=Loc.fresh (dom σ)). - iExists σ,(Next (k l)),_,(k l). + iExists σ,l,_,(k l). iFrame "Hs". simpl. change (Loc.fresh (dom σ)) with l. - iSplit. - { - iPureIntro. - do 2 f_equiv; last reflexivity. - f_equiv. - by rewrite ofe_iso_21. - } iSplit; first done. + iSplit. + { simpl. rewrite ofe_iso_21. done. } iNext. iIntros "Hlc Hs". iMod (istate_alloc α l with "Hh") as "[Hh Hl]". { apply (not_elem_of_dom_1 (M:=gmap loc)). @@ -376,7 +368,7 @@ Section wp. Proof. iIntros (Hee) "#Hcxt H". unfold DEALLOC. simpl. - iApply wp_subreify'. + iApply wp_subreify_ctx_indep'. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (fupd_mask_weaken E1). { set_solver. } @@ -388,7 +380,7 @@ Section wp. { iApply (istate_loc_dom with "Hh Hp"). } destruct Hdom as [x Hx]. destruct (Next_uninj x) as [β' Hb']. - iExists σ,(Next (Ret ())),(delete l σ),(Ret ()). + iExists σ,(),(delete l σ),(Ret ()). iFrame "Hs". repeat iSplit; simpl; eauto. iNext. iIntros "Hlc Hs". diff --git a/theories/input_lang/interp.v b/theories/input_lang/interp.v index dd001c1..41bf8af 100644 --- a/theories/input_lang/interp.v +++ b/theories/input_lang/interp.v @@ -1,7 +1,9 @@ -From Equations Require Import Equations. -From gitrees Require Import gitree. +From gitrees Require Import gitree lang_generic. From gitrees.input_lang Require Import lang. +Require Import Binding.Lib. +Require Import Binding.Set. + Notation stateO := (leibnizO state). Program Definition inputE : opInterp := @@ -18,69 +20,29 @@ Program Definition outputE : opInterp := Definition ioE := @[inputE;outputE]. -Definition wrap_reifier X `{Cofe X} (A B : ofe) : - (A * stateO -n> option (B * stateO))%type -> - (A * stateO * (B -n> laterO X) → option (laterO X * stateO))%type := - λ f, - λ x, let '(i, σ, k) := x in - fmap (prodO_map k idfun) (f (i, σ)). -#[export] Instance wrap_reifier_ne X `{Cofe X} (A B : ofe) f : - NonExpansive (wrap_reifier X A B f). -Proof. - intros n [[a1 σ1] k1] [[a2 σ2] k2] [[Ha Hσ] Hk]. simpl. - solve_proper. -Qed. - (* INPUT *) -Definition reify_input' X `{Cofe X} : unitO * stateO → +Definition reify_input X `{Cofe X} : unitO * stateO → option (natO * stateO) := λ '(o, σ), Some (update_input σ : prodO natO stateO). -#[export] Instance reify_input'_ne X `{Cofe X} : - NonExpansive (reify_input' X). +#[export] Instance reify_input_ne X `{Cofe X} : + NonExpansive (reify_input X). Proof. intros ?[[]][[]][_?]. simpl in *. f_equiv. repeat f_equiv. done. Qed. -Definition reify_input X `{Cofe X} : unitO * stateO * (natO -n> laterO X) → - option (laterO X * stateO) := - λ '(o, σ, k), fmap (prodO_map k idfun) (reify_input' X (o, σ)). -#[export] Instance reify_input_ne X `{Cofe X} : - NonExpansive (reify_input X : prodO (prodO unitO stateO) - (natO -n> laterO X) → - optionO (prodO (laterO X) stateO)). -Proof. - intros n [[? σ1] k1] [[? σ2] k2]. simpl. - intros [[_ ->] Hk]. simpl in *. - repeat f_equiv. assumption. -Qed. - (* OUTPUT *) -Definition reify_output' X `{Cofe X} : (natO * stateO) → +Definition reify_output X `{Cofe X} : (natO * stateO) → option (unitO * stateO) := λ '(n, σ), Some((), update_output n σ : stateO). -#[export] Instance reify_output'_ne X `{Cofe X} : - NonExpansive (reify_output' X). +#[export] Instance reify_output_ne X `{Cofe X} : + NonExpansive (reify_output X). Proof. intros ?[][][]. simpl in *. repeat f_equiv; done. Qed. - -Definition reify_output X `{Cofe X} : (natO * stateO * (unitO -n> laterO X)) → - optionO (prodO (laterO X) stateO) := - λ '(n, σ, k), fmap (prodO_map k idfun) - (reify_output' X (n, σ)). -#[export] Instance reify_output_ne X `{Cofe X} : - NonExpansive (reify_output X : prodO (prodO natO stateO) - (unitO -n> laterO X) → - optionO (prodO (laterO X) stateO)). -Proof. - intros ? [[]] [[]] []; simpl in *. - repeat f_equiv; first assumption; apply H0. -Qed. - -Canonical Structure reify_io : sReifier. +Canonical Structure reify_io : sReifier NotCtxDep. Proof. simple refine {| sReifier_ops := ioE; sReifier_state := stateO @@ -98,15 +60,6 @@ Section constructors. Notation IT := (IT E A). Notation ITV := (ITV E A). - Global Instance ioEctx_indep : - ∀ (o : opid ioE), CtxIndep reify_io IT o. - Proof. - intros op. - destruct op as [[] | [ | []]]. - - constructor. by exists (OfeMor (reify_input' IT)). - - constructor. by exists (OfeMor (reify_output' IT)). - Qed. - Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) (subEff_ins (F:=ioE) (op:=(inl ())) ()) (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). @@ -137,9 +90,9 @@ End constructors. Section weakestpre. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers NotCtxDep sz). Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops NotCtxDep rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Notation IT := (IT F R). @@ -155,7 +108,7 @@ Section weakestpre. Proof. intros Hs. iIntros "Hs Ha". unfold INPUT. simpl. - iApply (wp_subreify with "Hs"). + iApply (wp_subreify_ctx_indep with "Hs"). { simpl. rewrite Hs//=. } { simpl. by rewrite ofe_iso_21. } iModIntro. done. @@ -169,7 +122,7 @@ Section weakestpre. Proof. intros Hs. iIntros "Hs Ha". unfold OUTPUT. simpl. - iApply (wp_subreify rs with "Hs"). + iApply (wp_subreify_ctx_indep rs with "Hs"). { simpl. by rewrite Hs. } { simpl. done. } iModIntro. iIntros "H1 H2". @@ -180,14 +133,20 @@ End weakestpre. Section interp. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers NotCtxDep sz). Context {subR : subReifier reify_io rs}. - Context {R} `{!Cofe R}. + Context {R} `{CR : !Cofe R}. Context `{!SubOfe natO R}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops NotCtxDep rs). Notation IT := (IT F R). Notation ITV := (ITV F R). + Global Instance denot_cont_ne (κ : IT -n> IT) : + NonExpansive (λ x : IT, Tau (laterO_map κ (Next x))). + Proof. + solve_proper. + Qed. + (** Interpreting individual operators *) Program Definition interp_input {A} : A -n> IT := λne env, INPUT Ret. @@ -205,18 +164,49 @@ Section interp. Typeclasses Opaque interp_natop. Opaque laterO_map. - Program Definition interp_rec_pre {A} (body : prodO IT (prodO IT A) -n> IT) - : laterO (A -n> IT) -n> A -n> IT := - λne self env, Fun $ laterO_map (λne (self : A -n> IT) (a : IT), - body (self env,(a,env))) self. - Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) + : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := + λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), + body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + do 3 f_equiv; intros ??; simpl; f_equiv; + intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + by do 2 f_equiv. + Qed. - Definition interp_rec {A} body : A -n> IT := mmuu (interp_rec_pre body). - Program Definition ir_unf {A} (body : prodO IT (prodO IT A) -n> IT) env : IT -n> IT := - λne a, body (interp_rec body env, (a,env)). - Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Program Definition interp_rec {S : Set} + (body : @interp_scope F R _ (inc (inc S)) -n> IT) : + @interp_scope F R _ S -n> IT := + mmuu (interp_rec_pre body). - Lemma interp_rec_unfold {A} (body : prodO IT (prodO IT A) -n> IT) env : + Program Definition ir_unf {S : Set} + (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (@extend_scope F R _ _ + (@extend_scope F R _ _ env (interp_rec body env)) + a). + Next Obligation. + intros. + solve_proper_prepare. + f_equiv. intros [| [| y']]; simpl; solve_proper. + Qed. + + Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : interp_rec body env ≡ Fun $ Next $ ir_unf body env. Proof. trans (interp_rec_pre body (Next (interp_rec body)) env). @@ -242,412 +232,458 @@ Section interp. Program Definition interp_nat (n : nat) {A} : A -n> IT := λne env, Ret n. - Program Definition interp_cont {A} (K : A -n> (IT -n> IT)) : A -n> IT := λne env, Fun (Next (K env)). - Next Obligation. - solve_proper. - Qed. - - Program Definition interp_applk {A} (q : A -n> IT) (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := λne env t, interp_app q (λne env, K env t) env. - Next Obligation. - solve_proper. - Qed. - Next Obligation. - solve_proper. - Qed. - Next Obligation. - solve_proper. - Qed. - - Program Definition interp_apprk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) : A -n> (IT -n> IT) := λne env t, interp_app (λne env, K env t) q env. - Next Obligation. - solve_proper. - Qed. - Next Obligation. - solve_proper. - Qed. - Next Obligation. - solve_proper. - Qed. + Program Definition interp_applk {A} + (K : A -n> (IT -n> IT)) + (q : A -n> IT) + : A -n> (IT -n> IT) := + λne env t, interp_app (λne env, K env t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_apprk {A} + (q : A -n> IT) + (K : A -n> (IT -n> IT)) + : A -n> (IT -n> IT) := + λne env t, interp_app q (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoprk {A} (op : nat_op) + (q : A -n> IT) + (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := + λne env t, interp_natop op q (λne env, K env t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoplk {A} (op : nat_op) + (K : A -n> (IT -n> IT)) + (q : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_natop op (λne env, K env t) q env. + Solve All Obligations with solve_proper. + + Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) + (p : A -n> IT) : A -n> (IT -n> IT) := + λne env t, interp_if (λne env, K env t) q p env. + Solve All Obligations with solve_proper. + + Program Definition interp_outputk {A} (K : A -n> (IT -n> IT)) : + A -n> (IT -n> IT) := + λne env t, interp_output (λne env, K env t) env. + Solve All Obligations with solve_proper. (** Interpretation for all the syntactic categories: values, expressions, contexts *) Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := match v with - | Lit n => interp_nat n + | LitV n => interp_nat n | RecV e => interp_rec (interp_expr e) end with interp_expr {S} (e : expr S) : interp_scope S -n> IT := - match e with - | Val v => interp_val v - | Var x => interp_var x - | Rec e => interp_rec (interp_expr e) - | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) - | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) - | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) - | Input => interp_input - | Output e => interp_output (interp_expr e) - end. - - Program Definition interp_ctx_item {S : scope} (K : ectx_item S) : interp_scope S -n> IT -n> IT := - match K with - | AppLCtx v2 => λne env t, interp_app (constO t) (interp_val v2) env - | AppRCtx e1 => λne env t, interp_app (interp_expr e1) (constO t) env - | NatOpLCtx op v2 => λne env t, interp_natop op (constO t) (interp_val v2) env - | NatOpRCtx op e1 => λne env t, interp_natop op (interp_expr e1) (constO t) env - | IfCtx e1 e2 => λne env t, interp_if (constO t) (interp_expr e1) (interp_expr e2) env - | OutputCtx => λne env t, interp_output (constO t) env - end. + match e with + | Val v => interp_val v + | Var x => interp_var x + | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) + | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) + | Input => interp_input + | Output e => interp_output (interp_expr e) + end + with interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := + match K with + | EmptyK => λne env, idfun + | AppRK e1 K => interp_apprk (interp_expr e1) (interp_ectx K) + | AppLK K v2 => interp_applk (interp_ectx K) (interp_val v2) + | NatOpRK op e1 K => interp_natoprk op (interp_expr e1) (interp_ectx K) + | NatOpLK op K v2 => interp_natoplk op (interp_ectx K) (interp_val v2) + | IfK K e1 e2 => interp_ifk (interp_ectx K) (interp_expr e1) (interp_expr e2) + | OutputK K => interp_outputk (interp_ectx K) + end. Solve All Obligations with first [ solve_proper | solve_proper_please ]. - #[global] Instance interp_val_asval {S} (v : val S) D : AsVal (interp_val v D). - Proof. - destruct v; simpl; first apply _. - rewrite interp_rec_unfold. apply _. - Qed. - Program Fixpoint interp_ectx {S} (K : ectx S) : interp_scope S -n> IT -n> IT - := - match K with - | [] => λne env, idfun - | Ki::K => λne env, interp_ectx K env ◎ interp_ctx_item Ki env - end. - Next Obligation. solve_proper. Defined. (* XXX why can't i qed here? *) - - Lemma interp_ctx_item_fill {S} (Ki : ectx_item S) e env : - interp_expr (fill_item Ki e) env ≡ interp_ctx_item Ki env (interp_expr e env). - Proof. destruct Ki; reflexivity. Qed. - - Lemma interp_ectx_fill {S} (K : ectx S) e env : - interp_expr (fill K e) env ≡ interp_ectx K env (interp_expr e env). + Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) + : AsVal (interp_val v D). Proof. - revert e; induction K as [|Ki K]=>e; first done. - rewrite IHK. simpl. rewrite interp_ctx_item_fill. done. + destruct v; simpl. + - apply _. + - rewrite interp_rec_unfold. apply _. Qed. - (** Applying renamings and subsitutions to the interpretation of scopes *) - Equations interp_rens_scope {S S' : scope} - (E : interp_scope (E:=F) (R:=R) S') (s : rens S S') : interp_scope (E:=F) (R:=R) S := - interp_rens_scope (S:=[]) E s := tt : interp_scope []; - interp_rens_scope (S:=_::_) E s := - (interp_var (hd_ren s) E, interp_rens_scope E (tl_ren s)). + Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := + fun f g => ∀ x, f x = g x. - Equations interp_subs_scope {S S' : scope} - (E : interp_scope (E:=F) (R:=R) S') (s : subs S S') : interp_scope (E:=F) (R:=R) S := - interp_subs_scope (S:=[]) E s := tt : interp_scope []; - interp_subs_scope (S:=_::_) E s := - (interp_expr (hd_sub s) E, interp_subs_scope E (tl_sub s)). + Global Instance ArrDist {A B : Set} `{Dist B} : Dist (A [→] B) := + fun n => fun f g => ∀ x, f x ≡{n}≡ g x. - - Global Instance interp_rens_scope_ne S S2 n : - Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_rens_scope S S2). + Global Instance ren_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@ren_scope F _ CR S S'). Proof. intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_rens_scope; auto. + intros x; simpl. f_equiv. - - unfold hd_ren; rewrite Hs. by f_equiv. - - apply IHS. intros v. unfold tl_ren; by rewrite Hs. + - apply Hs. + - apply HE. + Qed. + + Lemma interp_expr_ren {S S'} env + (δ : S [→] S') (e : expr S) : + interp_expr (fmap δ e) env ≡ interp_expr e (ren_scope δ env) + with interp_val_ren {S S'} env + (δ : S [→] S') (e : val S) : + interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env) + with interp_ectx_ren {S S'} env + (δ : S [→] S') (e : ectx S) : + interp_ectx (fmap δ e) env ≡ interp_ectx e (ren_scope δ env). + Proof. + - destruct e; simpl. + + by apply interp_val_ren. + + reflexivity. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + + repeat f_equiv; by apply interp_expr_ren. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_ren. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * done. + - destruct e; simpl; intros ?; simpl. + + reflexivity. + + repeat f_equiv; by apply interp_ectx_ren. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_expr_ren | by apply interp_expr_ren]. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_expr_ren | by apply interp_ectx_ren]. + + repeat f_equiv; [by apply interp_ectx_ren | by apply interp_val_ren]. Qed. - Global Instance interp_subs_scope_ne S S2 n : - Proper ((dist n) ==> (≡) ==> (dist n)) (@interp_subs_scope S S2). + + Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): + interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). Proof. - intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_subs_scope; auto. - f_equiv. - - unfold hd_sub; by rewrite Hs HE. - - apply IHS. intros v. unfold tl_sub; by rewrite Hs. + revert env. + induction K; simpl; intros env; first reflexivity; try (by rewrite IHK). + - repeat f_equiv. + by rewrite IHK. + - repeat f_equiv. + by rewrite IHK. + - repeat f_equiv. + by rewrite IHK. Qed. - Global Instance interp_rens_scope_proper S S2 : - Proper ((≡) ==> (≡) ==> (≡)) (@interp_rens_scope S S2). + + Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') + : interp_scope S := λne x, interp_expr (δ x) env. + + Global Instance SubEquiv {A B : Set} : Equiv (A [⇒] B) := fun f g => ∀ x, f x = g x. + + Global Instance sub_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@sub_scope S S'). Proof. intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_rens_scope; auto. + intros x; simpl. f_equiv. - - unfold hd_ren; rewrite Hs. - by rewrite HE. - - apply IHS. intros v. unfold tl_ren; by rewrite Hs. + - f_equiv. + apply HE. + - apply Hs. + Qed. + + Lemma interp_expr_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_expr (bind δ e) env ≡ interp_expr e (sub_scope δ env) + with interp_val_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env) + with interp_ectx_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_ectx (bind δ e) env ≡ interp_ectx e (sub_scope δ env). + Proof. + - destruct e; simpl. + + by apply interp_val_subst. + + term_simpl. + reflexivity. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv; by apply interp_expr_subst. + + repeat f_equiv; by apply interp_expr_subst. + + f_equiv. + + repeat f_equiv; by apply interp_expr_subst. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_subst. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_subst. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * do 2 rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (z). + done. + - destruct e; simpl; intros ?; simpl. + + reflexivity. + + repeat f_equiv; by apply interp_ectx_subst. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_expr_subst | by apply interp_expr_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_expr_subst | by apply interp_ectx_subst]. + + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. Qed. - Global Instance interp_subs_scope_proper S S2 : - Proper ((≡) ==> (≡) ==> (≡)) (@interp_subs_scope S S2). + + (** ** Interpretation is a homomorphism (for some constructors) *) + + #[global] Instance interp_ectx_hom_emp {S} env : + IT_hom (interp_ectx (EmptyK : ectx S) env). Proof. - intros D D' HE s1 s2 Hs. - induction S as [|τ' S]; simp interp_subs_scope; auto. - f_equiv. - - unfold hd_sub; by rewrite Hs HE. - - apply IHS. intros v. unfold tl_sub; by rewrite Hs. + simple refine (IT_HOM _ _ _ _ _); intros; auto. + simpl. fold (@idfun IT). f_equiv. intro. simpl. + by rewrite laterO_map_id. Qed. - (** ** The substituion lemma, for renamings and substitutions *) - Lemma interp_rens_scope_tl_ren {S S2} x D (r : rens S S2) : - interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift r)) - ≡ interp_rens_scope D r. + #[global] Instance interp_ectx_hom_output {S} (K : ectx S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (OutputK K) env). Proof. - induction S as [|τ' S]; simp interp_rens_scope; eauto. - f_equiv. - { unfold hd_ren, tl_ren. simp rens_lift interp_var. - done. } - { rewrite -IHS. f_equiv. clear. - intros v. dependent elimination v; - unfold hd_ren, tl_ren; simp rens_lift; auto. } + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. + f_equiv. intro. simpl. rewrite -laterO_map_compose. + do 2 f_equiv. by intro. + - by rewrite !hom_err. Qed. - Lemma interp_rens_scope_idren {S} (D : interp_scope S) : - interp_rens_scope D (@idren S) ≡ D. + #[global] Instance interp_ectx_hom_if {S} + (K : ectx S) (e1 e2 : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (IfK K e1 e2) env). Proof. - induction S as [|[] S]; simp interp_rens_scope. - { by destruct D. } - destruct D as [x D]. simp interp_var. simpl. - f_equiv. - trans (interp_rens_scope ((x, D) : interp_scope (()::S)) (tl_ren (rens_lift idren))). - { f_equiv. intros v. unfold tl_ren. - reflexivity. } - rewrite interp_rens_scope_tl_ren. - apply IHS. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -IF_Tick. do 3 f_equiv. apply hom_tick. + - assert ((interp_ectx K env (Vis op i ko)) ≡ + (Vis op i (laterO_map (λne y, interp_ectx K env y) ◎ ko))). + { by rewrite hom_vis. } + trans (IF (Vis op i (laterO_map (λne y : IT, interp_ectx K env y) ◎ ko)) + (interp_expr e1 env) (interp_expr e2 env)). + { do 3 f_equiv. by rewrite hom_vis. } + rewrite IF_Vis. f_equiv. simpl. + intro. simpl. by rewrite -laterO_map_compose. + - trans (IF (Err e) (interp_expr e1 env) (interp_expr e2 env)). + { repeat f_equiv. apply hom_err. } + apply IF_Err. Qed. - Lemma interp_expr_ren {S D : scope} (M : expr S) (r : rens S D) : - ∀ (E : interp_scope D), - interp_expr (ren_expr M r) E ≡ interp_expr M (interp_rens_scope E r) - with interp_val_ren {S D : scope} (v : val S) (r : rens S D) : - ∀ (E : interp_scope D), - interp_val (ren_val v r) E ≡ interp_val v (interp_rens_scope E r). + #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) + (e : expr S) env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppRK e K) env). Proof. - - revert D r. induction M=> D r D2; simpl; simp ren_expr. - all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). - + (* variable *) revert r. - induction v=>r. - * simp interp_var interp_rens_scope. done. - * simp interp_var interp_rens_scope. simpl. - apply (IHv (tl_ren r)). - + (* recursive functions *) simp ren_expr. simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr M)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_ren. - iApply f_equivI. - simp interp_rens_scope interp_var. simpl. - rewrite !interp_rens_scope_tl_ren. - iRewrite "IH". - done. - - revert D r. induction v=> D r D2; simpl; simp ren_val; eauto. - (* recursive functions *) - simp ren_expr. simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr e)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_ren. - iApply f_equivI. - simp interp_rens_scope interp_var. simpl. - rewrite !interp_rens_scope_tl_ren. - iRewrite "IH". - done. + 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. Qed. - Lemma interp_subs_scope_tl_sub {S S2} x D (s : subs S S2) : - interp_subs_scope ((x, D) : interp_scope (()::S2)) (tl_sub (subs_lift s)) - ≡ interp_subs_scope D s. + #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) + (v : val S) (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (AppLK K v) env). Proof. - induction S as [|[] S]; simp interp_subs_scope; first done. - f_equiv. - { unfold hd_sub, tl_sub. simp subs_lift interp_var. - unfold expr_lift. rewrite interp_expr_ren. f_equiv. - trans (interp_rens_scope ((x, D) : interp_scope (()::S2)) (tl_ren (rens_lift idren))). - { f_equiv. intros v. unfold tl_ren. - simp rens_lift idren. done. } - rewrite interp_rens_scope_tl_ren. - apply interp_rens_scope_idren. } - { rewrite -IHS. f_equiv. clear. - intros v. dependent elimination v; - unfold hd_sub, tl_sub; simp subs_lift; auto. } + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -APP'_Tick_l. do 2 f_equiv. apply hom_tick. + - trans (APP' (Vis op i (laterO_map (interp_ectx K env) ◎ ko)) + (interp_val v env)). + + do 2f_equiv. rewrite hom_vis. do 3 f_equiv. by intro. + + rewrite APP'_Vis_l. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - trans (APP' (Err e) (interp_val v env)). + { do 2f_equiv. apply hom_err. } + apply APP'_Err_l, interp_val_asval. Qed. - Lemma interp_subs_scope_idsub {S} (env : interp_scope S) : - interp_subs_scope env idsub ≡ env. + #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) + (e : expr S) op env : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpRK op e K) env). Proof. - induction S as [|[] S]; simp interp_subs_scope. - { by destruct env. } - destruct env as [x env]. - unfold hd_sub, idsub. simpl. - simp interp_var. simpl. f_equiv. - etrans; last first. - { apply IHS. } - rewrite -(interp_subs_scope_tl_sub x env idsub). - repeat f_equiv. intro v. unfold tl_sub, idsub; simpl. - simp subs_lift. unfold expr_lift. simp ren_expr. done. + intros H. 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. Qed. - Lemma interp_expr_subst {S D : scope} (M : expr S) (s : subs S D) : - ∀ (E : interp_scope D), - interp_expr (subst_expr M s) E ≡ interp_expr M (interp_subs_scope E s) - with interp_val_subst {S D : scope} (v : val S) (s : subs S D) : - ∀ (E : interp_scope D), - interp_val (subst_val v s) E ≡ interp_val v (interp_subs_scope E s). + #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) + (v : val S) op (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (NatOpLK op K v) env). Proof. - - revert D s. induction M=> D r D2; simpl; simp subst_expr. - all: try by (simpl; repeat intro; simpl; repeat f_equiv; eauto). - + (* variable *) revert r. - induction v=>r. - * simp interp_var interp_rens_scope. done. - * simp interp_var interp_rens_scope. simpl. - apply (IHv (tl_sub r)). - + (* recursive functions *) simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr M)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_subst. - iApply f_equivI. - simp interp_subs_scope interp_var. simpl. - rewrite !interp_subs_scope_tl_sub. - iRewrite "IH". - done. - - revert D s. induction v=> D r D2; simpl; simp subst_val; eauto. - (* recursive functions *) - simp subst_expr. simpl. - apply bi.siProp.internal_eq_soundness. - iLöb as "IH". - rewrite {2}interp_rec_unfold. - rewrite {2}(interp_rec_unfold (interp_expr e)). - iApply f_equivI. iNext. iApply internal_eq_pointwise. - rewrite /ir_unf. iIntros (x). simpl. - rewrite interp_expr_subst. - iApply f_equivI. - simp interp_subs_scope interp_var. simpl. - rewrite !interp_subs_scope_tl_sub. - iRewrite "IH". - done. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -NATOP_ITV_Tick_l. do 2 f_equiv. apply hom_tick. + - trans (NATOP (do_natop op) + (Vis op0 i (laterO_map (interp_ectx K env) ◎ ko)) + (interp_val v env)). + { do 2 f_equiv. rewrite hom_vis. f_equiv. by intro. } + rewrite NATOP_ITV_Vis_l. f_equiv. intro x. simpl. + by rewrite -laterO_map_compose. + - trans (NATOP (do_natop op) (Err e) (interp_val v env)). + + do 2 f_equiv. apply hom_err. + + by apply NATOP_Err_l, interp_val_asval. + Qed. + + Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). + Proof. + intros. + by rewrite IT_rec1_ret. Qed. - (** ** Interpretation is a homomorphism *) - #[global] Instance interp_ectx_item_hom {S} (Ki : ectx_item S) env : - IT_hom (interp_ctx_item Ki env). - Proof. destruct Ki; simpl; apply _. Qed. - #[global] Instance interp_ectx_hom {S} (K : ectx S) env : + #[global] Instance interp_ectx_hom {S} + (K : ectx S) env : IT_hom (interp_ectx K env). - Proof. induction K; simpl; apply _. Qed. + Proof. + induction K; apply _. + Qed. (** ** Finally, preservation of reductions *) - Lemma interp_expr_head_step {S} env (e : expr S) e' σ σ' n : - head_step e σ e' σ' (n,0) → + Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' σ σ' n : + head_step e σ e' σ' (n, 0) → interp_expr e env ≡ Tick_n n $ interp_expr e' env. Proof. inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. - - (*fun->val*) - reflexivity. - (* app lemma *) - rewrite APP_APP'_ITV. + subst. + erewrite APP_APP'_ITV; last apply _. trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). { repeat f_equiv. apply interp_rec_unfold. } rewrite APP_Fun. simpl. rewrite Tick_eq. do 2 f_equiv. simplify_eq. - rewrite interp_expr_subst. f_equiv. - simp interp_subs_scope. unfold hd_sub, tl_sub. simp conssub. - simpl. repeat f_equiv. - generalize (Val (RecV e1)). - generalize (Val v2). - clear. - intros e1 e2. - trans (interp_subs_scope env idsub); last first. - { f_equiv. intro v. simp conssub. done. } - symmetry. - apply interp_subs_scope_idsub. + rewrite !interp_expr_subst. + f_equiv. + intros [| [| x]]; simpl; [| reflexivity | reflexivity]. + rewrite interp_val_ren. + f_equiv. + intros ?; simpl; reflexivity. - (* the natop stuff *) simplify_eq. destruct v1,v2; try naive_solver. simpl in *. rewrite NATOP_Ret. destruct op; simplify_eq/=; done. - - by rewrite IF_True. - - rewrite IF_False; eauto. lia. + - rewrite IF_True; last lia. + reflexivity. + - rewrite IF_False; last lia. + reflexivity. Qed. - Lemma interp_expr_fill_no_reify {S} K env (e e' : expr S) σ σ' n : - head_step e σ e' σ' (n,0) → - interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K e') env. + Lemma interp_expr_fill_no_reify {S} K (env : interp_scope S) (e e' : expr S) σ σ' n : + head_step e σ e' σ' (n, 0) → + interp_expr (fill K e) env + ≡ + Tick_n n $ interp_expr (fill K e') env. Proof. intros He. - trans (interp_ectx K env (interp_expr e env)). - { apply interp_ectx_fill. } - trans (interp_ectx K env (Tick_n n (interp_expr e' env))). - { f_equiv. apply (interp_expr_head_step env) in He. apply He. } - trans (Tick_n n $ interp_ectx K env (interp_expr e' env)); last first. - { f_equiv. symmetry. apply interp_ectx_fill. } - apply hom_tick_n. apply _. + rewrite !interp_comp. + erewrite <-hom_tick_n. + - apply (interp_expr_head_step env) in He. + rewrite He. + reflexivity. + - apply _. Qed. Opaque INPUT OUTPUT_. + Opaque extend_scope. Opaque Ret. Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) - (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : - head_step e σ e' σ' (n,1) → - reify (gReifiers_sReifier rs) - (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) - ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). + (σ σ' : stateO) (σr : gState_rest NotCtxDep sR_idx rs ♯ IT) n : + head_step e σ e' σ' (n, 1) → + reify (gReifiers_sReifier NotCtxDep rs) + (interp_expr (fill K e) env) (gState_recomp NotCtxDep σr (sR_state σ)) + ≡ (gState_recomp NotCtxDep σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). Proof. intros Hst. - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) - (gState_recomp σr (sR_state σ))). - { f_equiv. by rewrite interp_ectx_fill. } + trans (reify (gReifiers_sReifier NotCtxDep rs) (interp_ectx K env (interp_expr e env)) + (gState_recomp NotCtxDep σr (sR_state σ))). + { f_equiv. by rewrite interp_comp. } inversion Hst; simplify_eq; cbn-[gState_recomp]. - - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). - { repeat f_equiv; eauto. - rewrite hom_INPUT. f_equiv. by intro. } - rewrite reify_vis_eq //; last first. - { rewrite subReifier_reify//= H4//=. } - repeat f_equiv. - rewrite Tick_eq/=. repeat f_equiv. - rewrite interp_ectx_fill. - simpl. - done. - - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). - { do 3 f_equiv; eauto. - rewrite get_ret_ret//. } - trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). - { do 2 f_equiv; eauto. - rewrite hom_OUTPUT_//. } - rewrite reify_vis_eq //; last first. + - trans (reify (gReifiers_sReifier NotCtxDep rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp NotCtxDep σr (sR_state σ))). { - simpl. - pose proof (@subReifier_reify sz reify_io rs subR IT _ ((inr (inl ()))) n0) as H. + repeat f_equiv; eauto. + rewrite hom_INPUT. + do 2 f_equiv. by intro. + } + rewrite reify_vis_eq_ctx_indep //; first last. + { + epose proof (@subReifier_reify sz NotCtxDep reify_io rs _ IT _ (inl ()) () _ σ σ' σr) as H. simpl in H. - specialize (H (Next (interp_ectx K env (Ret 0))) (λne _, Next (interp_ectx K env (Ret 0))) σ (update_output n0 σ) σr). + simpl. + erewrite <-H; last first. + - rewrite H4. reflexivity. + - f_equiv; + solve_proper. + } + repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. + rewrite interp_comp. + rewrite ofe_iso_21. + simpl. + reflexivity. + - trans (reify (gReifiers_sReifier NotCtxDep rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp NotCtxDep σr (sR_state σ))). + { + do 3 f_equiv; eauto. + rewrite get_ret_ret//. + } + trans (reify (gReifiers_sReifier NotCtxDep rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp NotCtxDep σr (sR_state σ))). + { + do 2 f_equiv; eauto. + by rewrite hom_OUTPUT_. + } + rewrite reify_vis_eq_ctx_indep //; last first. + { + epose proof (@subReifier_reify sz NotCtxDep reify_io rs _ IT _ (inr (inl ())) n0 _ σ (update_output n0 σ) σr) as H. simpl in H. - rewrite <-H; last done. + simpl. + erewrite <-H; last reflexivity. f_equiv. - - intros [? ?] [? ?] [? ?]; simpl in *. - solve_proper. - - do 2 f_equiv. - intros ?; simpl. - reflexivity. + intros ???. by rewrite /prod_map H0. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. - rewrite interp_ectx_fill. - simpl. done. + rewrite interp_comp. + reflexivity. Qed. - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m env : + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest NotCtxDep sR_idx rs ♯ IT) n m (env : interp_scope S) : prim_step e1 σ1 e2 σ2 (n,m) → - ssteps (gReifiers_sReifier rs) - (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) - (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. + ssteps (gReifiers_sReifier NotCtxDep rs) + (interp_expr e1 env) (gState_recomp NotCtxDep σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp NotCtxDep σr (sR_state σ2)) n. Proof. Opaque gState_decomp gState_recomp. inversion 1; simplify_eq/=. destruct (head_step_io_01 _ _ _ _ _ _ H2); subst. - assert (σ1 = σ2) as ->. { eapply head_step_no_io; eauto. } - eapply (interp_expr_fill_no_reify K) in H2. - rewrite H2. eapply ssteps_tick_n. + unshelve eapply (interp_expr_fill_no_reify K) in H2; first apply env. + rewrite H2. + rewrite interp_comp. + eapply ssteps_tick_n. - inversion H2;subst. + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. - rewrite interp_ectx_fill. + rewrite interp_comp. rewrite hom_INPUT. - change 1 with (1+0). econstructor; last first. + change 1 with (Nat.add 1 0). econstructor; last first. { apply ssteps_zero; reflexivity. } eapply sstep_reify. { Transparent INPUT. unfold INPUT. simpl. @@ -655,13 +691,13 @@ Section interp. simpl in H2. rewrite -H2. repeat f_equiv; eauto. - rewrite interp_ectx_fill hom_INPUT. + rewrite interp_comp hom_INPUT. eauto. + eapply (interp_expr_fill_yes_reify K env _ _ _ _ σr) in H2. - rewrite interp_ectx_fill. simpl. + rewrite interp_comp. simpl. rewrite get_ret_ret. rewrite hom_OUTPUT_. - change 1 with (1+0). econstructor; last first. + change 1 with (Nat.add 1 0). econstructor; last first. { apply ssteps_zero; reflexivity. } eapply sstep_reify. { Transparent OUTPUT_. unfold OUTPUT_. simpl. @@ -670,7 +706,7 @@ Section interp. rewrite -H2. repeat f_equiv; eauto. Opaque OUTPUT_. - rewrite interp_ectx_fill /= get_ret_ret hom_OUTPUT_. + rewrite interp_comp /= get_ret_ret hom_OUTPUT_. eauto. Qed. diff --git a/theories/input_lang/lang.v b/theories/input_lang/lang.v index 82fac6c..bd6939f 100644 --- a/theories/input_lang/lang.v +++ b/theories/input_lang/lang.v @@ -1,281 +1,284 @@ -From stdpp Require Export strings. -From gitrees Require Export prelude lang_generic. -From Equations Require Import Equations. +From gitrees Require Export prelude. Require Import List. Import ListNotations. -Delimit Scope expr_scope with E. +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. Inductive nat_op := Add | Sub | Mult. -Inductive expr : scope → Type := +Inductive expr {X : Set} : Type := (* Values *) - | Val : forall {S}, val S → expr S - (* Base lambda calculus *) - | Var : forall {S}, var S → expr S - | Rec : forall {S}, expr (()::()::S) → expr S - | App : forall {S}, expr S → expr S → expr S - (* Base types and their operations *) - | NatOp : forall {S}, - nat_op → expr S → expr S → expr S - | If : forall {S}, - expr S → expr S → expr S → expr S - (* The effects *) - | Input : forall {S}, expr S - | Output : forall {S}, expr S → expr S -with val : scope → Type := - | Lit : forall {S}, nat → val S - | RecV : forall {S}, expr (()::()::S) → val S. - -Bind Scope expr_scope with expr. -Notation of_val := Val (only parsing). - -Definition to_val {S} (e : expr S) : option (val S) := +| Val (v : val) : expr +| Var (x : X) : expr +(* Base lambda calculus *) +| App (e₁ : expr) (e₂ : expr) : expr +(* Base types and their operations *) +| NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr +| If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr +(* The effects *) +| Input : expr +| Output (e : expr) : expr +with val {X : Set} := +| LitV (n : nat) : val +| RecV (e : @expr (inc (inc X))) : val +with ectx {X : Set} := +| EmptyK : ectx +| OutputK (K : ectx) : ectx +| IfK (K : ectx) (e₁ : expr) (e₂ : expr) : ectx +| AppLK (K : ectx) (v : val) : ectx +| AppRK (e : expr) (K : ectx) : ectx +| NatOpRK (op : nat_op) (e : expr) (K : ectx) : ectx +| NatOpLK (op : nat_op) (K : ectx) (v : val) : ectx. + +Arguments val X%bind : clear implicits. +Arguments expr X%bind : clear implicits. +Arguments ectx X%bind : clear implicits. + +Local Open Scope bind_scope. + +Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := match e with - | Val v => Some v - | _ => None - end. - -Definition do_natop (op : nat_op) (x y : nat) : nat := - match op with - | Add => x+y - | Sub => x-y - | Mult => x+y - end. - -Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := - match x, y with - | Lit x, Lit y => Some $ Lit $ do_natop n x y - | _,_ => None - end. - -(** substitution stuff *) -Definition rens S S' := var S → var S'. -Definition subs S S' := var S → expr S'. - -Definition idren {S} : rens S S := fun v => v. -Definition idsub {S} : subs S S := Var. - -Equations conssub {S S' τ} (M : expr S') (s : subs S S') : subs (τ::S) S' := - conssub M s Vz := M; - conssub M s (Vs v) := s v. - -Notation "{/ e ; .. ; f /}" := (conssub e .. (conssub f idsub) ..). - -Definition tl_sub {S S' τ} : subs (τ::S) S' → subs S S' := λ s v, s (Vs v). -Definition hd_sub {S S' τ} : subs (τ::S) S' → expr S' := λ s, s Vz. -Definition tl_ren {S S' τ} : rens (τ::S) S' → rens S S' := λ s v, s (Vs v). -Definition hd_ren {S S' τ} : rens (τ::S) S' → var S' := λ s, s Vz. - -(* Lifting a renaming, renaming terms, and lifting substitutions *) -Equations rens_lift {S S'} (s : rens S S') : rens (()::S) (()::S') := - rens_lift s Vz := Vz; - rens_lift s (Vs v) := Vs $ s v. - -Equations ren_expr {S S'} (M : expr S) (r : rens S S') : expr S' := -ren_expr (Val v) r := Val $ ren_val v r; -ren_expr (Var v) r := Var (r v); -ren_expr (Rec M) r := Rec (ren_expr M (rens_lift (rens_lift r))); -ren_expr (App M N) r := App (ren_expr M r) (ren_expr N r); -ren_expr (NatOp op e1 e2) r := NatOp op (ren_expr e1 r) (ren_expr e2 r); -ren_expr (If e0 e1 e2) r := If (ren_expr e0 r) (ren_expr e1 r) (ren_expr e2 r); -ren_expr Input r := Input; -ren_expr (Output e) r := Output (ren_expr e r); -with ren_val {S S'} (M : val S) (r : rens S S') : val S' := -ren_val (Lit n) _ := Lit n; -ren_val (RecV e) r := RecV (ren_expr e (rens_lift (rens_lift r))). - - -Definition expr_lift {S} (M : expr S) : expr (()::S) := ren_expr M Vs. - -Equations subs_lift {S S'} (s : subs S S') : subs (()::S) (()::S') := - subs_lift s Vz := Var Vz; - subs_lift s (Vs v) := expr_lift $ s v. - -(* We can now define the substitution operation *) -Equations subst_expr {S S'} (M : expr S) (s : subs S S') : expr S' := -subst_expr (Val v) r := Val $ subst_val v r; -subst_expr (Var v) r := r v; -subst_expr (Rec M) r := Rec (subst_expr M (subs_lift (subs_lift r))); -subst_expr (App M N) r := App (subst_expr M r) (subst_expr N r); -subst_expr (NatOp op e1 e2) r := NatOp op (subst_expr e1 r) (subst_expr e2 r); -subst_expr (If e0 e1 e2) r := If (subst_expr e0 r) (subst_expr e1 r) (subst_expr e2 r); -subst_expr (Input) r := Input; -subst_expr (Output e) r := Output (subst_expr e r); -with subst_val {S S'} (M : val S) (r : subs S S') : val S' := -subst_val (Lit n) _ := Lit n; -subst_val (RecV e) r := RecV (subst_expr e (subs_lift (subs_lift r))). - -Definition subst1 {S : scope} {τ} (M : expr (τ::S)) (N : expr S) : expr S - := subst_expr M {/ N /}. -Definition subst2 {S : scope} {i j} (M : expr (i::j::S)) (N1 : expr S) (N2 : expr S) : expr S - := subst_expr M {/ N1; N2 /}. - -Definition appsub {S1 S2 S3} (s : subs S1 S2) (s' : subs S2 S3) : subs S1 S3 := - λ v, subst_expr (s v) s'. - -Global Instance rens_equiv S S' : Equiv (rens S S') := λ s1 s2, ∀ v, s1 v = s2 v. -Global Instance subs_equiv S S' : Equiv (subs S S') := λ s1 s2, ∀ v, s1 v = s2 v. - -Global Instance rens_lift_proper S S' : Proper ((≡) ==> (≡)) (@rens_lift S S'). + | Val v => Val (vmap f v) + | Var x => Var (f x) + | App e₁ e₂ => App (emap f e₁) (emap f e₂) + | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) + | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) + | Input => Input + | Output e => Output (emap f e) + end +with vmap {A B : Set} (f : A [→] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (emap ((f ↑) ↑) e) + end +with kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kmap f K) + | IfK K e₁ e₂ => IfK (kmap f K) (emap f e₁) (emap f e₂) + | AppLK K v => AppLK (kmap f K) (vmap f v) + | AppRK e K => AppRK (emap f e) (kmap f K) + | NatOpRK op e K => NatOpRK op (emap f e) (kmap f K) + | NatOpLK op K v => NatOpLK op (kmap f K) (vmap f v) + end. +#[export] Instance FMap_expr : FunctorCore expr := @emap. +#[export] Instance FMap_val : FunctorCore val := @vmap. +#[export] Instance FMap_ectx : FunctorCore ectx := @kmap. + +#[export] Instance SPC_expr : SetPureCore expr := @Var. + +Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := + match e with + | Val v => Val (vbind f v) + | Var x => f x + | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) + | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) + | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) + | Input => Input + | Output e => Output (ebind f e) + end +with vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (ebind ((f ↑) ↑) e) + end +with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := + match K with + | EmptyK => EmptyK + | OutputK K => OutputK (kbind f K) + | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) + | AppLK K v => AppLK (kbind f K) (vbind f v) + | AppRK e K => AppRK (ebind f e) (kbind f K) + | NatOpRK op e K => NatOpRK op (ebind f e) (kbind f K) + | NatOpLK op K v => NatOpLK op (kbind f K) (vbind f v) + end. + +#[export] Instance BindCore_expr : BindCore expr := @ebind. +#[export] Instance BindCore_val : BindCore val := @vbind. +#[export] Instance BindCore_ectx : BindCore ectx := @kbind. + +#[export] Instance IP_typ : SetPure expr. Proof. - intros s1 s2 Hs v. dependent elimination v; simp rens_lift; eauto. - f_equiv. apply Hs. + split; intros; reflexivity. Qed. -Lemma ren_expr_proper {S S'} (e : expr S) : Proper ((≡) ==> (=)) (@ren_expr S S' e) - with ren_val_proper {S S'} v : Proper ((≡) ==> (=)) (@ren_val S S' v). +Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v +with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e +with kmap_id X (δ : X [→] X) (e : ectx X) : δ ≡ ı → fmap δ e = e. Proof. - - revert S'. - induction e; intros S' s1 s2 Hs; simp ren_expr; - f_equiv; try solve [eauto | apply ren_expr_proper; eauto ]. - + by apply ren_val_proper. - + apply ren_expr_proper. by repeat f_equiv. - - revert S'. - induction v; intros S' s1 s2 Hs; simp ren_expr; - f_equiv; try solve [eauto | apply ren_expr_proper; eauto ]. - apply ren_expr_proper. by repeat f_equiv. + - auto_map_id. + - auto_map_id. + - auto_map_id. Qed. -#[export] Existing Instance ren_expr_proper. -#[export] Existing Instance ren_val_proper. - -#[export] Instance subs_lift_proper S S' : Proper ((≡) ==> (≡)) (@subs_lift S S'). +Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : + f ∘ g ≡ h → fmap f (fmap g v) = fmap h v +with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e +with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : ectx A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. Proof. - intros s1 s2 Hs v. dependent elimination v; simp subs_lift; eauto. - f_equiv. apply Hs. + - auto_map_comp. + - auto_map_comp. + - auto_map_comp. Qed. -Lemma subst_expr_proper {S S'} (e : expr S) : Proper ((≡) ==> (=)) (@subst_expr S S' e) - with subst_val_proper {S S'} v : Proper ((≡) ==> (=)) (@subst_val S S' v). +#[export] Instance Functor_val : Functor val. +Proof. + split; [exact vmap_id | exact vmap_comp]. +Qed. +#[export] Instance Functor_expr : Functor expr. +Proof. + split; [exact emap_id | exact emap_comp]. +Qed. +#[export] Instance Functor_ectx : Functor ectx. Proof. - - revert S'. - induction e; intros S' s1 s2 Hs; simp subst_expr; - f_equiv; try solve [eauto | apply subst_expr_proper; eauto ]. - + by apply subst_val_proper. - + apply subst_expr_proper. by repeat f_equiv. - - revert S'. - induction v; intros S' s1 s2 Hs; simp subst_expr; - f_equiv; try solve [eauto | apply subst_expr_proper; eauto ]. - apply subst_expr_proper. by repeat f_equiv. + split; [exact kmap_id | exact kmap_comp]. Qed. -#[export] Existing Instance subst_expr_proper. -#[export] Existing Instance subst_val_proper. -Lemma subst_ren_expr {S1 S2 S3} e (s : subs S2 S3) (r : rens S1 S2) : - subst_expr (ren_expr e r) s = subst_expr e (compose s r) -with subst_ren_val {S1 S2 S3} v (s : subs S2 S3) (r : rens S1 S2) : - subst_val (ren_val v r) s = subst_val v (compose s r). +Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : + f ̂ ≡ g → fmap f v = bind g v +with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : + f ̂ ≡ g → fmap f e = bind g e +with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx A) : + f ̂ ≡ g → fmap f e = bind g e. Proof. - - revert S2 S3 r s. - induction e=>S2 S3 r s; simp ren_expr; simp subst_expr; try f_equiv; eauto. - rewrite IHe. apply subst_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. - - revert S2 S3 r s. - induction v=>S2 S3 r s; simpl; simp ren_val; simp subst_val; try f_equiv. - rewrite subst_ren_expr. - apply subst_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. + - auto_map_bind_pure. + erewrite emap_ebind_pure; [reflexivity |]. + intros [| [| x]]; term_simpl; [reflexivity | reflexivity |]. + rewrite <-(EQ x). + reflexivity. + - auto_map_bind_pure. + - auto_map_bind_pure. Qed. -Lemma ren_ren_expr {S1 S2 S3} e (s : rens S2 S3) (r : rens S1 S2) : - ren_expr (ren_expr e r) s = ren_expr e (compose s r) -with ren_ren_val {S1 S2 S3} v (s : rens S2 S3) (r : rens S1 S2) : - ren_val (ren_val v r) s = ren_val v (compose s r). +#[export] Instance BindMapPure_val : BindMapPure val. +Proof. + split; intros; now apply vmap_vbind_pure. +Qed. +#[export] Instance BindMapPure_expr : BindMapPure expr. +Proof. + split; intros; now apply emap_ebind_pure. +Qed. +#[export] Instance BindMapPure_ectx : BindMapPure ectx. Proof. - - revert S2 S3 r s. - induction e=>S2 S3 r s; simp ren_expr; try f_equiv; eauto. - rewrite IHe. apply ren_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. - - revert S2 S3 r s. - induction v=>S2 S3 r s; simpl; simp ren_val; simp subst_val; try f_equiv. - rewrite ren_ren_expr. - apply ren_expr_proper. - intro v. simpl. - dependent elimination v; simp rens_lift; simp subs_lift; eauto. - f_equiv. dependent elimination v; simp rens_lift; simp subs_lift; eauto. + split; intros; now apply kmap_kbind_pure. Qed. -Definition rcompose {S1 S2 S3} (r : rens S2 S3) (s : subs S1 S2) : subs S1 S3 := - λ v, ren_expr (s v) r. +Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (v : val A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) +with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) +with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : ectx A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). +Proof. + - auto_map_bind_comm. + erewrite emap_ebind_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity | assumption]. + - auto_map_bind_comm. + - auto_map_bind_comm. +Qed. -Lemma ren_subst_expr {S1 S2 S3} e (s : subs S1 S2) (r : rens S2 S3) : - ren_expr (subst_expr e s) r = subst_expr e (rcompose r s) -with ren_subst_val {S1 S2 S3} v (s : subs S1 S2) (r : rens S2 S3) : - ren_val (subst_val v s) r = subst_val v (rcompose r s). +#[export] Instance BindMapComm_val : BindMapComm val. +Proof. + split; intros; now apply vmap_vbind_comm. +Qed. +#[export] Instance BindMapComm_expr : BindMapComm expr. +Proof. + split; intros; now apply emap_ebind_comm. +Qed. +#[export] Instance BindMapComm_ectx : BindMapComm ectx. Proof. - - revert S2 S3 r s. - induction e=>S2 S3 r s; simp subst_expr; simp ren_expr; try f_equiv; eauto. - rewrite IHe. apply subst_expr_proper. - intro v. simpl. unfold rcompose. - dependent elimination v; eauto. - dependent elimination v; eauto. - simp subs_lift. unfold expr_lift. - rewrite !ren_ren_expr. apply ren_expr_proper. - intro x. dependent elimination v; eauto. - - revert S2 S3 r s. - induction v=>S2 S3 r s; simp subst_expr; simp ren_expr; try f_equiv; eauto. - rewrite ren_subst_expr. apply subst_expr_proper. - intro v. simpl. unfold rcompose. - dependent elimination v; eauto. - dependent elimination v; eauto. - simp subs_lift. unfold expr_lift. - rewrite !ren_ren_expr. apply ren_expr_proper. - intro x. dependent elimination v; eauto. + split; intros; now apply kmap_kbind_comm. Qed. -Lemma appsub_lift {S1 S2 S3} (s : subs S1 S2) (s' : subs S2 S3) : - subs_lift (appsub s s') ≡ appsub (subs_lift s) (subs_lift s'). +Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : + f ≡ ı → bind f v = v +with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : + f ≡ ı → bind f e = e +with kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : + f ≡ ı → bind f e = e. Proof. - unfold appsub. - intro v. dependent elimination v; simp subs_lift; eauto. - unfold expr_lift. rewrite subst_ren_expr. - rewrite ren_subst_expr. apply subst_expr_proper. - intro x. unfold rcompose. simpl. simp subs_lift. done. + - auto_bind_id. + rewrite ebind_id; [reflexivity |]. + apply lift_id, lift_id; assumption. + - auto_bind_id. + - auto_bind_id. Qed. -Lemma subst_expr_appsub {S1 S2 S3} (s1 : subs S1 S2) (s2 : subs S2 S3) e : - subst_expr (subst_expr e s1) s2 = subst_expr e (appsub s1 s2) -with subst_val_appsub {S1 S2 S3} (s1 : subs S1 S2) (s2 : subs S2 S3) v : - subst_val (subst_val v s1) s2 = subst_val v (appsub s1 s2). +Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : + f ∘ g ≡ h → bind f (bind g v) = bind h v +with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e +with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e. Proof. - - revert S2 S3 s1 s2. - induction e=>S2 S3 s1 s2; simp subst_expr; try f_equiv; eauto. - rewrite !appsub_lift. apply IHe. - - revert S3 s2. - induction v=>S3 s2; simpl; f_equiv; eauto. - rewrite !appsub_lift. apply subst_expr_appsub. + - auto_bind_comp. + erewrite ebind_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity | assumption]. + - auto_bind_comp. + - auto_bind_comp. Qed. -Lemma subst_expr_lift {S S'} e e1 (s : subs S S') : - subst_expr (expr_lift e) (conssub e1 s) = subst_expr e s. +#[export] Instance Bind_val : Bind val. Proof. - unfold expr_lift. - rewrite subst_ren_expr. apply subst_expr_proper. - intro v. simpl. simp conssub. done. + split; intros; [now apply vbind_id | now apply vbind_comp]. +Qed. +#[export] Instance Bind_expr : Bind expr. +Proof. + split; intros; [now apply ebind_id | now apply ebind_comp]. +Qed. +#[export] Instance Bind_ectx : Bind ectx. +Proof. + split; intros; [now apply kbind_id | now apply kbind_comp]. Qed. -Lemma subst_expr_idsub {S} (e : expr S) : - subst_expr e idsub = e -with subst_val_idsub {S} (v : val S) : - subst_val v idsub = v. +Definition to_val {S} (e : expr S) : option (val S) := + match e with + | Val v => Some v + | _ => None + end. + +Definition do_natop (op : nat_op) (x y : nat) : nat := + match op with + | Add => plus x y + | Sub => minus x y + | Mult => mult x y + end. + +Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := + match x, y with + | LitV x, LitV y => Some $ LitV $ do_natop n x y + | _,_ => None + end. + +Fixpoint fill {X : Set} (K : ectx X) (e : expr X) : expr X := + match K with + | EmptyK => e + | OutputK K => Output (fill K e) + | IfK K e₁ e₂ => If (fill K e) e₁ e₂ + | AppLK K v => App (fill K e) (Val v) + | AppRK e' K => App e' (fill K e) + | NatOpRK op e' K => NatOp op e' (fill K e) + | NatOpLK op K v => NatOp op (fill K e) (Val v) + end. + +Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) + : fmap f (fill K e) = fill (fmap f K) (fmap f e). Proof. - - induction e; simp subst_expr; simpl; try f_equiv; eauto. - assert ((subs_lift (subs_lift idsub)) ≡ idsub) as ->; last auto. - intro v. - dependent elimination v; simp subs_lift; auto. - dependent elimination v; simp subs_lift; auto. - - induction v; simp subst_val; simpl; try f_equiv; eauto. - assert ((subs_lift (subs_lift idsub)) ≡ idsub) as ->; last auto. - intro v. - dependent elimination v; simp subs_lift; auto. - dependent elimination v; simp subs_lift; auto. + revert f. + induction K as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH]; + intros f; term_simpl; first done; rewrite IH; reflexivity. Qed. (*** Operational semantics *) @@ -286,7 +289,6 @@ Record state := State { }. #[export] Instance state_inhabited : Inhabited state := populate (State [] []). - Definition update_input (s : state) : nat * state := match s.(inputs) with | [] => (0, s) @@ -296,30 +298,26 @@ Definition update_input (s : state) : nat * state := Definition update_output (n:nat) (s : state) : state := {| inputs := s.(inputs); outputs := n::s.(outputs) |}. - Inductive head_step {S} : expr S → state → expr S → state → nat*nat → Prop := -| RecS e σ : - head_step (Rec e) σ (Val $ RecV e) σ (0,0) -| BetaS e1 v2 e' σ : - e' = subst2 e1 (Val $ RecV e1) (Val v2) → - head_step (App (Val $ RecV e1) (Val v2)) σ e' σ (1,0) +| BetaS e1 v2 σ : + head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) (Val (shift (Inc := inc) v2))) (Val (RecV e1))) σ (1,0) | InputS σ n σ' : update_input σ = (n,σ') → - head_step Input σ (Val (Lit n)) σ' (1,1) + head_step Input σ (Val (LitV n)) σ' (1,1) | OutputS σ n σ' : update_output n σ = σ' → - head_step (Output (Val (Lit n))) σ (Val (Lit 0)) σ' (1,1) + head_step (Output (Val (LitV n))) σ (Val (LitV 0)) σ' (1,1) | NatOpS op v1 v2 v3 σ : nat_op_interp op v1 v2 = Some v3 → head_step (NatOp op (Val v1) (Val v2)) σ (Val v3) σ (0,0) | IfTrueS n e1 e2 σ : n > 0 → - head_step (If (Val (Lit n)) e1 e2) σ + head_step (If (Val (LitV n)) e1 e2) σ e1 σ (0,0) | IfFalseS n e1 e2 σ : n = 0 → - head_step (If (Val (Lit n)) e1 e2) σ + head_step (If (Val (LitV n)) e1 e2) σ e2 σ (0,0) . @@ -333,59 +331,52 @@ Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 n : head_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. Proof. inversion 1; eauto. Qed. -Inductive ectx_item {S} := - | AppLCtx (v2 : val S) - | AppRCtx (e1 : expr S) - | NatOpLCtx (op : nat_op) (v2 : val S) - | NatOpRCtx (op : nat_op) (e1 : expr S) - | IfCtx (e1 e2 : expr S) - | OutputCtx -. -Arguments ectx_item S : clear implicits. - -Definition fill_item {S} (Ki : ectx_item S) (e : expr S) : expr S := - match Ki with - | AppLCtx v2 => App e (of_val v2) - | AppRCtx e1 => App e1 e - | NatOpLCtx op v2 => NatOp op e (Val v2) - | NatOpRCtx op e1 => NatOp op e1 e - | IfCtx e1 e2 => If e e1 e2 - | OutputCtx => Output e - end. - (** Carbonara from heap lang *) -Global Instance fill_item_inj {S} (Ki : ectx_item S) : Inj (=) (=) (fill_item Ki). +Global Instance fill_item_inj {S} (Ki : ectx S) : Inj (=) (=) (fill Ki). Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. Lemma fill_item_val {S} Ki (e : expr S) : - is_Some (to_val (fill_item Ki e)) → is_Some (to_val e). + is_Some (to_val (fill Ki e)) → is_Some (to_val e). Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed. Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 m : head_step e1 σ1 e2 σ2 m → to_val e1 = None. Proof. destruct 1; naive_solver. Qed. -Lemma head_ctx_item_step_val {S} Ki (e : expr S) σ1 e2 σ2 m : - head_step (fill_item Ki e) σ1 e2 σ2 m → is_Some (to_val e). -Proof. revert m e2. induction Ki; simpl; inversion 1; simplify_option_eq; eauto. Qed. - -Lemma fill_item_no_val_inj {S} Ki1 Ki2 (e1 e2 : expr S) : - to_val e1 = None → to_val e2 = None → - fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2. +Fixpoint ectx_compose {S} (K1 K2 : ectx S) : ectx S + := match K1 with + | EmptyK => K2 + | OutputK K => OutputK (ectx_compose K K2) + | IfK K e₁ e₂ => IfK (ectx_compose K K2) e₁ e₂ + | AppLK K v => AppLK (ectx_compose K K2) v + | AppRK e K => AppRK e (ectx_compose K K2) + | NatOpRK op e K => NatOpRK op e (ectx_compose K K2) + | NatOpLK op K v => NatOpLK op (ectx_compose K K2) v + end. + +Lemma fill_app {S} (K1 K2 : ectx S) e : fill (ectx_compose K1 K2) e = fill K1 (fill K2 e). Proof. - revert Ki1. induction Ki2; intros Ki1; induction Ki1; naive_solver eauto with f_equal. + revert K2. + revert e. + induction K1 as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH]; + simpl; first done; intros e' K2; rewrite IH; reflexivity. Qed. -(** Lifting the head step **) - -Definition ectx S := (list (ectx_item S)). -Definition fill {S} (K : ectx S) (e : expr S) : expr S := foldl (flip fill_item) e K. - -Lemma fill_app {S} (K1 K2 : ectx S) e : fill (K1 ++ K2) e = fill K2 (fill K1 e). -Proof. apply foldl_app. Qed. - - Lemma fill_val : ∀ {S} K (e : expr S), is_Some (to_val (fill K e)) → is_Some (to_val e). -Proof. intros S K. induction K as [|Ki K IH]=> e //=. by intros ?%IH%fill_item_val. Qed. +Proof. + intros S K. + induction K as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH]=> e' //=; + inversion 1 as [? HH]; inversion HH. +Qed. Lemma fill_not_val : ∀ {S} K (e : expr S), to_val e = None → to_val (fill K e) = None. Proof. @@ -393,13 +384,20 @@ Proof. eauto using fill_val. Qed. -Lemma fill_empty {S} (e : expr S) : fill [] e = e. +Lemma fill_empty {S} (e : expr S) : fill EmptyK e = e. Proof. reflexivity. Qed. -Lemma fill_comp {S} K1 K2 (e : expr S) : fill K1 (fill K2 e) = fill (K2 ++ K1) e. +Lemma fill_comp {S} K1 K2 (e : expr S) : fill K2 (fill K1 e) = fill (ectx_compose K2 K1) e. Proof. by rewrite fill_app. Qed. -Global Instance fill_inj {S} (K:ectx S) : Inj (=) (=) (fill K). -Proof. induction K as [|Ki K IH]; rewrite /Inj; naive_solver. Qed. - +Global Instance fill_inj {S} (K : ectx S) : Inj (=) (=) (fill K). +Proof. + induction K as [| ?? IH + | ?? IH + | ?? IH + | ??? IH + | ???? IH + | ??? IH]; + rewrite /Inj; naive_solver. +Qed. Inductive prim_step {S} (e1 : expr S) (σ1 : state) (e2 : expr S) (σ2 : state) (n : nat*nat) : Prop:= @@ -469,41 +467,140 @@ Qed. Inductive ty := | Tnat : ty | Tarr : ty → ty → ty. -Local Notation tyctx := (tyctx ty). - -Inductive typed : forall {S}, tyctx S → expr S → ty → Prop := -| typed_Val {S} (Γ : tyctx S) (τ : ty) (v : val S) : +Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := +| typed_Val (τ : ty) (v : val S) : typed_val Γ v τ → typed Γ (Val v) τ -| typed_Var {S} (Γ : tyctx S) (τ : ty) (v : var S) : - typed_var Γ v τ → +| typed_Var (τ : ty) (v : S) : + Γ v = τ → typed Γ (Var v) τ -| typed_Rec {S} (Γ : tyctx S) (τ1 τ2 : ty) (e : expr (()::()::S) ) : - typed (consC (Tarr τ1 τ2) (consC τ1 Γ)) e τ2 → - typed Γ (Rec e) (Tarr τ1 τ2) -| typed_App {S} (Γ : tyctx S) (τ1 τ2 : ty) e1 e2 : +| typed_App (τ1 τ2 : ty) e1 e2 : typed Γ e1 (Tarr τ1 τ2) → typed Γ e2 τ1 → typed Γ (App e1 e2) τ2 -| typed_NatOp {S} (Γ : tyctx S) e1 e2 op : +| typed_NatOp e1 e2 op : typed Γ e1 Tnat → typed Γ e2 Tnat → typed Γ (NatOp op e1 e2) Tnat -| typed_If {S} (Γ : tyctx S) e0 e1 e2 τ : +| typed_If e0 e1 e2 τ : typed Γ e0 Tnat → typed Γ e1 τ → typed Γ e2 τ → typed Γ (If e0 e1 e2) τ -| typed_Input {S} (Γ : tyctx S) : +| typed_Input : typed Γ Input Tnat -| typed_Output {S} (Γ : tyctx S) e : +| typed_Output e : typed Γ e Tnat → typed Γ (Output e) Tnat -with typed_val : forall {S}, tyctx S → val S → ty → Prop := -| typed_Lit {S} (Γ : tyctx S) n : - typed_val Γ (Lit n) Tnat -| typed_RecV {S} (Γ : tyctx S) (τ1 τ2 : ty) (e : expr (()::()::S) ) : - typed (consC (Tarr τ1 τ2) (consC τ1 Γ)) e τ2 → +with typed_val {S : Set} (Γ : S -> ty) : val S → ty → Prop := +| typed_Lit n : + typed_val Γ (LitV n) Tnat +| typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : + typed (Γ ▹ (Tarr τ1 τ2) ▹ τ1) e τ2 → typed_val Γ (RecV e) (Tarr τ1 τ2) . +Declare Scope syn_scope. +Delimit Scope syn_scope with syn. + +Coercion Val : val >-> expr. + +Coercion App : expr >-> Funclass. +Coercion AppLK : ectx >-> Funclass. +Coercion AppRK : expr >-> Funclass. + +Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. + +Arguments __asSynExpr {_} {_} {_}. + +Global Instance AsSynExprValue : AsSynExpr val := { + __asSynExpr _ v := Val v + }. +Global Instance AsSynExprExpr : AsSynExpr expr := { + __asSynExpr _ e := e + }. + +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) := { + __op e₁ op e₂ := NatOp op (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance OpNotationLK {S : Set} : OpNotation (ectx S) (nat_op) (val S) (ectx S) := { + __op K op v := NatOpLK op K v + }. + +Global Instance OpNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : OpNotation (F S) (nat_op) (ectx S) (ectx S) := { + __op e op K := NatOpRK op (__asSynExpr e) K + }. + +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) := { + __if e₁ e₂ e₃ := If (__asSynExpr e₁) (__asSynExpr e₂) (__asSynExpr e₃) + }. + +Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : IfNotation (ectx S) (F S) (G S) (ectx S) := { + __if K e₂ e₃ := IfK K (__asSynExpr e₂) (__asSynExpr e₃) + }. + +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 (ectx S) (ectx S) := { + __output K := OutputK 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) := { + __app e₁ e₂ := App (__asSynExpr e₁) (__asSynExpr e₂) + }. + +Global Instance AppNotationLK {S : Set} : AppNotation (ectx S) (val S) (ectx S) := { + __app K v := AppLK K v + }. + +Global Instance AppNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (ectx S) (ectx S) := { + __app e K := AppRK (__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. +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 "'#' 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 "'$' 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. + +Definition LamV {S : Set} (e : expr (inc S)) : val S := + RecV (shift e). + +Notation "'λ' . 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. diff --git a/theories/input_lang/logpred.v b/theories/input_lang/logpred.v index 34888c2..ea1b802 100644 --- a/theories/input_lang/logpred.v +++ b/theories/input_lang/logpred.v @@ -1,38 +1,38 @@ (** Unary (Kripke) logical relation for the IO lang *) -From Equations Require Import Equations. -From gitrees Require Import gitree program_logic. +From gitrees Require Import gitree program_logic lang_generic. From gitrees.input_lang Require Import lang interp. +Require Import Binding.Lib Binding.Set Binding.Env. Section io_lang. Context {sz : nat}. - Variable rs : gReifiers sz. + Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops NotCtxDep rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Notation IT := (IT F R). Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ, !na_invG Σ}. Notation iProp := (iProp Σ). - Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. + + Canonical Structure exprO S := leibnizO (expr S). + Canonical Structure valO S := leibnizO (val S). Variable s : stuckness. - Context {A:ofe}. - Variable (P : A → iProp). - Context `{!NonExpansive P}. + Context {A : ofe}. + Variable (P : A -n> iProp). - Local Notation tyctx := (tyctx ty). Local Notation expr_pred := (expr_pred s rs P). Program Definition interp_tnat : ITV -n> iProp := λne αv, (∃ n : nat, αv ≡ RetV n)%I. Solve All Obligations with solve_proper. + Program Definition interp_tarr (Φ1 Φ2 : ITV -n> iProp) := λne αv, - (□ ∀ σ βv, has_substate σ -∗ - Φ1 βv -∗ - expr_pred (IT_of_V αv ⊙ (IT_of_V βv)) (λne v, ∃ σ', Φ2 v ∗ has_substate σ'))%I. + (□ ∀ σ βv, has_substate σ + -∗ Φ1 βv + -∗ expr_pred (IT_of_V αv ⊙ (IT_of_V βv)) + (λne v, ∃ σ', Φ2 v ∗ has_substate σ'))%I. Solve All Obligations with solve_proper. Fixpoint interp_ty (τ : ty) : ITV -n> iProp := @@ -41,55 +41,58 @@ Section io_lang. | Tarr τ1 τ2 => interp_tarr (interp_ty τ1) (interp_ty τ2) end. - Definition ssubst_valid {S} (Γ : tyctx S) ss := ssubst_valid rs interp_ty Γ ss. + Definition ssubst_valid {S : Set} + (Γ : S -> ty) + (ss : @interp_scope F R _ S) : iProp := + (∀ x, □ expr_pred (ss x) (interp_ty (Γ x)))%I. #[global] Instance io_lang_interp_ty_pers τ βv : Persistent (io_lang.interp_ty τ βv). Proof. induction τ; apply _. Qed. - #[global] Instance ssubst_valid_pers {S} (Γ : tyctx S) ss : Persistent (ssubst_valid Γ ss). + #[global] Instance ssubst_valid_pers {S : Set} (Γ : S → ty) ss : Persistent (ssubst_valid Γ ss). Proof. apply _. Qed. - Program Definition valid1 {S} (Γ : tyctx S) (α : interp_scope S -n> IT) (τ : ty) : iProp := + Program Definition valid1 {S : Set} (Γ : S → ty) (α : interp_scope S -n> IT) (τ : ty) : iProp := (∀ σ ss, has_substate σ -∗ ssubst_valid Γ ss -∗ - expr_pred (α (interp_ssubst ss)) (λne v, ∃ σ', interp_ty τ v ∗ has_substate σ'))%I. + expr_pred (α ss) (λne v, ∃ σ', interp_ty τ v ∗ has_substate σ'))%I. Solve Obligations with solve_proper. - Lemma compat_nat {S} n (Ω : tyctx S) : + Lemma compat_nat {S : Set} n (Ω : S → ty) : ⊢ valid1 Ω (interp_nat rs n) Tnat. Proof. iIntros (σ αs) "Hs Has". simpl. iApply expr_pred_ret. simpl. eauto with iFrame. Qed. - Lemma compat_var {S} Ω τ (v : var S) : - typed_var Ω v τ → - ⊢ valid1 Ω (interp_var v) τ. + + Lemma compat_var {S : Set} (Ω : S → ty) (v : S) : + ⊢ valid1 Ω (interp_var v) (Ω v). Proof. - intros Hv. iIntros (σ ss) "Hs Has". simpl. - unfold ssubst_valid. - iInduction Hv as [|? ? ? Ω v] "IH" forall (ss); simpl. - - dependent elimination ss as [cons_ssubst αv ss]. - rewrite ssubst_valid_cons. - simp interp_var. simpl. - iDestruct "Has" as "[H _]". - iApply expr_pred_ret; simpl; eauto with iFrame. - - dependent elimination ss as [cons_ssubst αv ss]. - rewrite ssubst_valid_cons. - simp interp_var. simpl. - iDestruct "Has" as "[_ H]". - by iApply ("IH" with "Hs H"). + iIntros (x) "HP". + simpl. + iSpecialize ("Has" $! v x with "HP"). + iApply (wp_wand with "Has"). + iIntros (v') "HH". + simpl. + iDestruct "HH" as "(%y & HH & HP')". + iModIntro. + iExists y. + iFrame "HP'". + iExists σ. + iFrame. Qed. - Lemma compat_if {S} (Γ : tyctx S) τ α β1 β2 : + Lemma compat_if {S : Set} (Γ : S → ty) τ α β1 β2 : ⊢ valid1 Γ α Tnat -∗ valid1 Γ β1 τ -∗ valid1 Γ β2 τ -∗ valid1 Γ (interp_if rs α β1 β2) τ. - Proof using HCI. + Proof. iIntros "H0 H1 H2". iIntros (σ ss) "Hs #Has". iSpecialize ("H0" with "Hs Has"). - simpl. iApply (expr_pred_bind (IFSCtx _ _) with "H0"). + simpl. + iApply (expr_pred_bind (IFSCtx _ _) with "H0"). iIntros (αv) "Ha/=". iDestruct "Ha" as (σ') "[Ha Hs]". iDestruct "Ha" as (n) "Hn". @@ -102,7 +105,7 @@ Section io_lang. iApply ("H1" with "Hs Has Hx"). Qed. - Lemma compat_input {S} (Γ : tyctx S) : + Lemma compat_input {S : Set} (Γ : S → ty) : ⊢ valid1 Γ (interp_input rs) Tnat. Proof. iIntros (σ ss) "Hs #Has". @@ -114,9 +117,9 @@ Section io_lang. iApply wp_val. simpl. eauto with iFrame. Qed. - Lemma compat_output {S} (Γ : tyctx S) α : + Lemma compat_output {S : Set} (Γ : S → ty) α : ⊢ valid1 Γ α Tnat → valid1 Γ (interp_output rs α) Tnat. - Proof using HCI. + Proof. iIntros "H". iIntros (σ ss) "Hs #Has". iSpecialize ("H" with "Hs Has"). @@ -134,11 +137,11 @@ Section io_lang. eauto with iFrame. Qed. - Lemma compat_app {S} (Γ : tyctx S) α β τ1 τ2 : + Lemma compat_app {S : Set} (Γ : S → ty) α β τ1 τ2 : ⊢ valid1 Γ α (Tarr τ1 τ2) -∗ valid1 Γ β τ1 -∗ valid1 Γ (interp_app rs α β) τ2. - Proof using HCI. + Proof. iIntros "H1 H2". iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). @@ -154,15 +157,14 @@ Section io_lang. iApply ("Ha" with "Hs Hb"). Qed. - Lemma compat_rec {S} (Γ : tyctx S) τ1 τ2 α : - ⊢ □ valid1 (consC (Tarr τ1 τ2) (consC τ1 Γ)) α τ2 -∗ + Lemma compat_rec {S : Set} (Γ : S → ty) τ1 τ2 α : + ⊢ □ valid1 (Γ ▹ (Tarr τ1 τ2) ▹ τ1) α τ2 -∗ valid1 Γ (interp_rec rs α) (Tarr τ1 τ2). Proof. iIntros "#H". iIntros (σ ss) "Hs #Hss". - pose (env := (interp_ssubst ss)). fold env. - simp subst_expr. - pose (f := (ir_unf rs α env)). - iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". + term_simpl. + pose (f := (ir_unf rs α ss)). + iAssert (interp_rec rs α ss ≡ IT_of_V $ FunV (Next f))%I as "Hf". { iPureIntro. apply interp_rec_unfold. } iRewrite "Hf". iApply expr_pred_ret. simpl. iExists _. iFrame. iModIntro. @@ -172,24 +174,34 @@ Section io_lang. iIntros (x) "Hx". iApply wp_lam. iNext. - pose (ss' := cons_ssubst (FunV (Next f)) (cons_ssubst βv ss)). + pose (ss' := (extend_scope (extend_scope ss (interp_rec rs α ss)) (IT_of_V βv))). iSpecialize ("H" $! _ ss' with "Hs []"). - { unfold ssubst_valid. - unfold ss'. - rewrite !ssubst_valid_cons. - by iFrame "IH Hw Hss". } - unfold f. simpl. - unfold ss'. simp interp_ssubst. - iAssert (IT_of_V (FunV (Next f)) ≡ interp_rec rs α env)%I as "Heq". + { + unfold ssubst_valid. + iIntros ([| [|]]); term_simpl. + - iModIntro; by iApply expr_pred_ret. + - iModIntro. + iRewrite "Hf". + iIntros (x') "Hx". + iApply wp_val. + iModIntro. + iExists x'. + iFrame "Hx". + iModIntro. + iApply "IH". + - iApply "Hss". + } + unfold f. + iAssert (IT_of_V (FunV (Next f)) ≡ interp_rec rs α ss)%I as "Heq". { rewrite interp_rec_unfold. done. } iRewrite -"Heq". by iApply "H". Qed. - Lemma compat_natop {S} (Γ : tyctx S) op α β : + Lemma compat_natop {S : Set} (Γ : S → ty) op α β : ⊢ valid1 Γ α Tnat -∗ valid1 Γ β Tnat -∗ valid1 Γ (interp_natop _ op α β) Tnat. - Proof using HCI. + Proof. iIntros "H1 H2". iIntros (σ ss) "Hs #Has". simpl. iSpecialize ("H2" with "Hs Has"). @@ -210,15 +222,14 @@ Section io_lang. eauto with iFrame. Qed. - Lemma fundamental {S} (Γ : tyctx S) e τ : + Lemma fundamental {S : Set} (Γ : S → ty) e τ : typed Γ e τ → ⊢ valid1 Γ (interp_expr rs e) τ - with fundamental_val {S} (Γ : tyctx S) v τ : + with fundamental_val {S : Set} (Γ : S → ty) v τ : typed_val Γ v τ → ⊢ valid1 Γ (interp_val rs v) τ. - Proof using HCI. + Proof. - destruct 1. + by iApply fundamental_val. - + by iApply compat_var. - + iApply compat_rec; iApply fundamental; eauto. + + subst. by iApply compat_var. + iApply compat_app; iApply fundamental; eauto. + iApply compat_natop; iApply fundamental; eauto. + iApply compat_if; iApply fundamental; eauto. @@ -228,77 +239,40 @@ Section io_lang. + iApply compat_nat. + iApply compat_rec; iApply fundamental; eauto. Qed. - Lemma fundmanetal_closed (e : expr []) (τ : ty) : - typed empC e τ → - ⊢ valid1 empC (interp_expr rs e) τ. - Proof using HCI. apply fundamental. Qed. + + Lemma fundmanetal_closed (e : expr ∅) (τ : ty) : + typed □ e τ → + ⊢ valid1 □ (interp_expr rs e) τ. + Proof. apply fundamental. Qed. End io_lang. Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _} τ. Arguments interp_tarr {_ _ _ _ _ _ _ _ _ _ _} Φ1 Φ2. -Local Definition rs : gReifiers _ := gReifiers_cons reify_io gReifiers_nil. - -Local Instance CtxIndepInputLang R `{!Cofe R} (o : opid (sReifier_ops (gReifiers_sReifier rs))) : - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o. -Proof. - destruct o as [x o]. - inv_fin x. - - simpl. intros [[]| [[]| []]]. - + constructor. - unshelve eexists (λne '(_, (a, b)), SomeO (_, (_, b))). - * simpl in *. - apply ((update_input a).1). - * simpl in *. - apply ((update_input a).2). - * solve_proper_prepare. - destruct x as [? [? ?]]; destruct y as [? [? ?]]. - simpl in *. - do 2 f_equiv. - -- do 2 f_equiv. - apply H. - -- f_equiv; last apply H. - do 2 f_equiv. - apply H. - * intros. - simpl. - destruct σ. - simpl. - reflexivity. - + constructor. - unshelve eexists (λne '(x, y), SomeO ((), _)). - * simpl in *. - apply ((update_output x (fstO y)), ()). - * solve_proper_prepare. - destruct x as [? [? ?]]; destruct y as [? [? ?]]. - simpl in *. - do 4 f_equiv. - -- apply H. - -- apply H. - * intros. - simpl. - destruct σ as [σ1 []]; simpl in *. - reflexivity. - - intros i; by apply fin_0_inv. -Qed. +Local Definition rs : gReifiers NotCtxDep _ := gReifiers_cons NotCtxDep reify_io (gReifiers_nil NotCtxDep). Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. -Lemma logpred_adequacy cr Σ R `{!Cofe R, SubOfe natO R}`{!invGpreS Σ}`{!statePreG rs R Σ} τ (α : unitO -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k - : +Require Import gitrees.gitree.greifiers. + +Program Definition ı_scope R `{!Cofe R} : @interp_scope (gReifiers_ops NotCtxDep rs) R _ Empty_set := λne (x : ∅), match x with end. + +Lemma logpred_adequacy cr Σ R `{!Cofe R, SubOfe natO R} + `{!invGpreS Σ} `{!statePreG rs R Σ} τ + (α : interp_scope ∅ -n> IT (gReifiers_ops NotCtxDep rs) R) + (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ}, - (£ cr ⊢ valid1 rs notStuck (λ _:unitO, True)%I empC α τ)%I) → - ssteps (gReifiers_sReifier rs) (α ()) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) + (£ cr ⊢ valid1 rs notStuck (λne _ : unitO, True)%I □ α τ)%I) → + ssteps (gReifiers_sReifier NotCtxDep rs) (α (ı_scope _)) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep 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) + cut ((∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (∃ e, β ≡ Err e ∧ notStuck e)). { intros [?|He]; first done. destruct He as [? [? []]]. } @@ -306,15 +280,15 @@ Proof. { apply Hdisj. } { by rewrite Hb. } intros H1 H2. - exists (interp_ty (s:=notStuck) (P:=(λ _:unitO, True)) τ)%I. split. + exists (interp_ty (s:=notStuck) (P:=(λne _:unitO, True)) τ)%I. split. { 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. + assert (of_state NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) (σ,()) ≡ + of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep 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. @@ -325,7 +299,10 @@ Proof. rewrite (eq_pi _ _ Heq eq_refl)//. } iSpecialize ("Hlog" $! σ with "Hs []"). - { iApply ssubst_valid_nil. } + { + iIntros (x). + destruct x. + } iSpecialize ("Hlog" $! tt with "[//]"). iApply (wp_wand with"Hlog"). iIntros ( βv). simpl. iDestruct 1 as (_) "[H _]". @@ -333,10 +310,10 @@ Proof. done. Qed. -Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : - typed empC e τ → - ssteps (gReifiers_sReifier rs) (interp_expr _ e ()) (σ,()) β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) +Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops NotCtxDep (gReifiers_sReifier NotCtxDep rs)) natO) k : + typed □ e τ → + ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e (ı_scope _)) (σ, ()) β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (∃ βv, IT_of_V βv ≡ β). Proof. intros Htyped Hsteps. diff --git a/theories/input_lang/logrel.v b/theories/input_lang/logrel.v index 169a7df..a1f0017 100644 --- a/theories/input_lang/logrel.v +++ b/theories/input_lang/logrel.v @@ -1,25 +1,21 @@ (** Logical relation for adequacy for the IO lang *) -From Equations Require Import Equations. -From gitrees Require Import gitree. +From gitrees Require Import gitree lang_generic. From gitrees.input_lang Require Import lang interp. +Require Import Binding.Lib Binding.Set Binding.Env. Section logrel. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers NotCtxDep sz). Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops NotCtxDep rs). Notation IT := (IT F natO). Notation ITV := (ITV F natO). Context `{!invGS Σ, !stateG rs natO Σ}. Notation iProp := (iProp Σ). Notation restO := (gState_rest sR_idx rs ♯ IT). - Variable (HCi : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) natO) o). Canonical Structure exprO S := leibnizO (expr S). Canonical Structure valO S := leibnizO (val S). - Local Notation tyctx := (tyctx ty). Notation "'WP' α {{ β , Φ } }" := (wp rs α notStuck ⊤ (λ β, Φ)) (at level 20, α, Φ at level 200, @@ -35,7 +31,7 @@ Section logrel. WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ ∗ V βv v ∗ has_substate σ' }})%I. Definition logrel_nat {S} (βv : ITV) (v : val S) : iProp := - (∃ n, βv ≡ RetV n ∧ ⌜v = Lit n⌝)%I. + (∃ n, βv ≡ RetV n ∧ ⌜v = LitV n⌝)%I. Definition logrel_arr {S} V1 V2 (βv : ITV) (vf : val S) : iProp := (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. @@ -76,7 +72,7 @@ Section logrel. (∀ v βv, logrel_val τ1 βv v -∗ logrel_expr V2 (f (IT_of_V βv)) (fill K (Val v))) -∗ logrel_expr V2 (f α) (fill K e). - Proof using HCi. + Proof. iIntros "H1 H2". iLöb as "IH" forall (α e). iIntros (σ) "Hs". @@ -102,8 +98,8 @@ Section logrel. by econstructor. Qed. - Lemma logrel_step_pure {S} (e' e : expr S) α V : - (∀ σ, prim_step e σ e' σ (0,0)) → + Lemma logrel_step_pure {S} n (e' e : expr S) α V : + (∀ σ, prim_step e σ e' σ (n,0)) → logrel_expr V α e' ⊢ logrel_expr V α e. Proof. intros Hpure. @@ -112,219 +108,167 @@ Section logrel. iSpecialize ("H" with "Hs"). iApply (wp_wand with "H"). iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". - iExists (m,m'),v,σ'. iFrame "H2 Hs". + iExists ((Nat.add n m),m'),v,σ'. iFrame "H2 Hs". iPureIntro. - eapply (prim_steps_app (0,0) (m,m')); eauto. + eapply (prim_steps_app (n,0) (m,m')); eauto. { eapply prim_step_steps, Hpure. } Qed. - (* a matching list of closing substitutions *) - Inductive subs2 : scope → Type := - | emp_subs2 : subs2 [] - | cons_subs2 {S} : val [] → ITV → subs2 S → subs2 (()::S) - . - - Equations subs_of_subs2 {S} (ss : subs2 S) : subs S [] := - subs_of_subs2 emp_subs2 v => idsub v; - subs_of_subs2 (cons_subs2 t α ss) Vz := Val t; - subs_of_subs2 (cons_subs2 t α ss) (Vs v) := subs_of_subs2 ss v. - - Equations its_of_subs2 {S} (ss : subs2 S) : interp_scope (E:=F) (R:=natO) S := - its_of_subs2 emp_subs2 := (); - its_of_subs2 (cons_subs2 t α ss) := (IT_of_V α, its_of_subs2 ss). - - Equations list_of_subs2 {S} (ss : subs2 S) : list (val []*ITV) := - list_of_subs2 emp_subs2 := []; - list_of_subs2 (cons_subs2 v α ss) := (v,α)::(list_of_subs2 ss). + Definition ssubst2_valid {S : Set} + (Γ : S -> ty) + (ss : @interp_scope F natO _ S) + (γ : S [⇒] Empty_set) : iProp := + (∀ x, □ logrel (Γ x) (ss x) (γ x))%I. - Lemma subs_of_emp_subs2 : subs_of_subs2 emp_subs2 ≡ idsub. - Proof. intros v. dependent elimination v. Qed. + Definition logrel_valid {S : Set} + (Γ : S -> ty) + (e : expr S) + (α : @interp_scope F natO _ S -n> IT) + (τ : ty) : iProp := + (□ ∀ (ss : @interp_scope F natO _ S) + (γ : S [⇒] Empty_set), + ssubst2_valid Γ ss γ → logrel τ (α ss) (bind γ e))%I. - Definition subs2_valid {S} (Γ : tyctx S) (ss : subs2 S) : iProp := - ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_subs2 ss), - logrel_val (τx.1) (τx.2.2) (τx.2.1))%I. - - Definition logrel_valid {S} (Γ : tyctx S) (e : expr S) (α : interp_scope S -n> IT) (τ : ty) : iProp := - (∀ ss, subs2_valid Γ ss → logrel τ - (α (its_of_subs2 ss)) - (subst_expr e (subs_of_subs2 ss)))%I. - - Lemma compat_var {S} (Γ : tyctx S) (x : var S) τ : - typed_var Γ x τ → ⊢ logrel_valid Γ (Var x) (interp_var x) τ. + Lemma compat_var {S : Set} (Γ : S → ty) (x : S): + ⊢ logrel_valid Γ (Var x) (interp_var x) (Γ x). Proof. - intros Hx. iIntros (ss) "Hss". - simp subst_expr. - iInduction Hx as [|Hx] "IH". - - dependent elimination ss. simp subs_of_subs2. - simp interp_var. rewrite /subs2_valid. - simp list_of_tyctx list_of_subs2 its_of_subs2. simpl. - iDestruct "Hss" as "[Hv Hss]". - iApply (logrel_of_val with "Hv"). - - dependent elimination ss. simp subs_of_subs2. - simp interp_var. rewrite /subs2_valid. - simp list_of_tyctx list_of_subs2 its_of_subs2. simpl. - iDestruct "Hss" as "[Hv Hss]". by iApply "IH". + iModIntro. iIntros (ss γ) "Hss". iApply "Hss". Qed. - Lemma compat_if {S} (Γ : tyctx S) (e0 e1 e2 : expr S) α0 α1 α2 τ : + Lemma compat_if {S : Set} (Γ : S → ty) (e0 e1 e2 : expr S) α0 α1 α2 τ : ⊢ logrel_valid Γ e0 α0 Tnat -∗ logrel_valid Γ e1 α1 τ -∗ logrel_valid Γ e2 α2 τ -∗ logrel_valid Γ (If e0 e1 e2) (interp_if rs α0 α1 α2) τ. - Proof using HCi. - iIntros "H0 H1 H2". iIntros (ss) "#Hss". - simpl. simp subst_expr. - pose (s := (subs_of_subs2 ss)). fold s. + Proof. + iIntros "#H0 #H1 #H2". + iModIntro. + iIntros (ss γ) "#Hss". + simpl. iSpecialize ("H0" with "Hss"). - iApply (logrel_bind (IFSCtx (α1 (its_of_subs2 ss)) (α2 (its_of_subs2 ss))) - [IfCtx (subst_expr e1 s) (subst_expr e2 s)] - with "H0"). + term_simpl. + iApply (@logrel_bind Empty_set + (IFSCtx (α1 ss) (α2 ss)) + (IfK EmptyK (bind γ e1) (bind γ e2)) _ (bind γ e0) (α0 ss) Tnat with "H0"). iIntros (v βv). iDestruct 1 as (n) "[Hb ->]". iRewrite "Hb". simpl. unfold IFSCtx. destruct (decide (0 < n)). - - rewrite IF_True//. + - rewrite IF_True; last done. iSpecialize ("H1" with "Hss"). iApply (logrel_step_pure with "H1"). - intros ?. apply (Ectx_step' []). + intros ?. apply (Ectx_step' EmptyK). econstructor; eauto. - rewrite IF_False; last lia. iSpecialize ("H2" with "Hss"). iApply (logrel_step_pure with "H2"). - intros ?. apply (Ectx_step' []). + intros ?. apply (Ectx_step' EmptyK). econstructor; eauto. lia. Qed. - Lemma compat_recV {S} Γ (e : expr (()::()::S)) τ1 τ2 α : - ⊢ □ logrel_valid (consC (Tarr τ1 τ2) (consC τ1 Γ)) e α τ2 -∗ + Lemma compat_recV {S : Set} (Γ : S -> ty) (e : expr (inc (inc S))) τ1 τ2 α : + ⊢ □ logrel_valid ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) e α τ2 -∗ logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). Proof. - iIntros "#H". iIntros (ss) "#Hss". - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := (its_of_subs2 ss)). fold env. - simp subst_expr. - pose (f := (ir_unf rs α env)). + iIntros "#H !> %env %γ #Henv". + set (f := (ir_unf rs α env)). iAssert (interp_rec rs α env ≡ IT_of_V $ FunV (Next f))%I as "Hf". { iPureIntro. apply interp_rec_unfold. } iRewrite "Hf". - iApply logrel_of_val. iLöb as "IH". iSimpl. - iExists (Next f). iSplit; eauto. + Opaque IT_of_V. + iApply logrel_of_val; term_simpl. + iExists _. iSplit. + { iPureIntro. apply into_val. } iModIntro. - iIntros (βv w) "#Hw". - iAssert ((APP' (Fun $ Next f) (IT_of_V βv)) ≡ (Tick (ir_unf rs α env (IT_of_V βv))))%I - as "Htick". - { iPureIntro. rewrite APP_APP'_ITV. - rewrite APP_Fun. simpl. done. } - iRewrite "Htick". iClear "Htick". + iLöb as "IH". + iIntros (αv v) "#Hw". + rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. + pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V αv))). + set (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) + ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)))%bind). + rewrite /logrel. + iSpecialize ("H" $! ss' γ'). + set (γ1 := ((γ ↑) ↑)%bind). + iApply (logrel_step_pure 1 ((bind γ' e)%syn) with "[]"). + { + intros ?. eapply (Ectx_step' EmptyK). term_simpl. subst γ1 γ'. + rewrite -!bind_bind_comp'. + apply BetaS. + } + rewrite {2}/ss'. rewrite /f. iIntros (σ) "Hs". - iApply wp_tick. iNext. simpl. - pose (ss' := cons_subs2 (RecV (subst_expr e (subs_lift (subs_lift s)))) (FunV (Next (ir_unf rs α env))) (cons_subs2 w βv ss)). - iSpecialize ("H" $! ss' with "[Hss]"). - { rewrite {2}/subs2_valid /ss'. simp list_of_tyctx list_of_subs2. - cbn-[logrel_val]. iFrame "Hss Hw". fold f. iRewrite -"Hf". - by iApply "IH". } - iSpecialize ("H" with "Hs"). - iClear "IH Hss Hw". - unfold ss'. simpl. simp its_of_subs2. fold f env. - iRewrite "Hf". simpl. - iApply (wp_wand with "H"). - iIntros (v). - iDestruct 1 as ([m m'] v0 σ0 Hsteps) "[Hv Hs]". - iExists (1+m,0+m'),v0,σ0. iFrame "Hv Hs". - iPureIntro. econstructor; eauto. - apply (Ectx_step' []). - apply BetaS. - clear. - unfold subst2. - rewrite subst_expr_appsub. - apply subst_expr_proper. - intro v. - dependent elimination v. - { simp subs_of_subs2. unfold appsub. - simp subs_lift. simp subst_expr. - simp conssub. reflexivity. } - dependent elimination v. - { simp subs_of_subs2. unfold appsub. - simp subs_lift. unfold expr_lift. - simp ren_expr. simp subst_expr. - simp conssub. reflexivity. } - { simp subs_of_subs2. unfold appsub. - simp subs_lift. unfold expr_lift. - fold s. remember (s v) as e1. - rewrite ren_ren_expr. - rewrite subst_ren_expr. - trans (subst_expr e1 idsub). - - symmetry. apply subst_expr_idsub. - - apply subst_expr_proper. - intro v'. simpl. simp conssub. - reflexivity. } - Qed. - - Lemma compat_rec {S} Γ (e : expr (()::()::S)) τ1 τ2 α : - ⊢ □ logrel_valid (consC (Tarr τ1 τ2) (consC τ1 Γ)) e α τ2 -∗ - logrel_valid Γ (Rec e) (interp_rec rs α) (Tarr τ1 τ2). - Proof. - iIntros "#H". iIntros (ss) "#Hss". - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := (its_of_subs2 ss)). fold env. - simp subst_expr. - iApply (logrel_step_pure (Val (RecV (subst_expr e (subs_lift (subs_lift s)))))). - { intros ?. eapply (Ectx_step' []). econstructor. } - iPoseProof (compat_recV with "H") as "H2". - iSpecialize ("H2" with "Hss"). - simp subst_expr. iApply "H2". + iApply wp_tick. iNext. + iApply "H"; eauto; iClear "H". + rewrite /ss' /γ'. + iIntros (x'); destruct x' as [| [| x']]; term_simpl; iModIntro. + * by iApply logrel_of_val. + * iRewrite "Hf". + iApply logrel_of_val. + simpl. + iExists (Next (ir_unf rs α env)). + iSplit; first done. + iModIntro. + iApply "IH". + * iApply "Henv". Qed. - Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : + Lemma compat_app {S : Set} (Γ : S → ty) (e1 e2 : expr S) τ1 τ2 α1 α2 : ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ logrel_valid Γ e2 α2 τ1 -∗ logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. - Proof using HCi. - iIntros "H1 H2". iIntros (ss) "#Hss". + Proof. + iIntros "#H1 #H2". + iIntros (ss). + iModIntro. + iIntros (γ). + iIntros "#Hss". iSpecialize ("H1" with "Hss"). iSpecialize ("H2" with "Hss"). - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := its_of_subs2 ss). fold env. - simp subst_expr. simpl. - iApply (logrel_bind (AppRSCtx (α1 env)) [AppRCtx (subst_expr e1 s)] with "H2"). - iIntros (v2 β2) "H2". iSimpl. - iApply (logrel_bind (AppLSCtx (IT_of_V β2)) [AppLCtx v2] with "H1"). - iIntros (v1 β1) "H1". simpl. - iDestruct "H1" as (f) "[Hα H1]". + unfold interp_app. simpl. - unfold AppLSCtx. iRewrite "Hα". (** XXX why doesn't simpl work here? *) - iApply ("H1" with "H2"). + assert ((bind γ (App e1 e2))%syn = (fill (AppRK (bind γ e1) EmptyK) (bind γ e2))) as ->. + { reflexivity. } + iApply (logrel_bind (AppRSCtx (α1 ss)) (AppRK (bind γ e1) EmptyK) with "H2"). + iIntros (v2 β2) "#H2'". iSimpl. + iApply (logrel_bind (AppLSCtx (IT_of_V β2)) (AppLK EmptyK v2) with "H1"). + iIntros (v1 β1) "#H1'". iSimpl. + iDestruct "H1'" as (f) "[Hα H1']". + simpl. + unfold AppLSCtx. iRewrite "Hα". + iApply ("H1'" with "H2'"). Qed. - Lemma compat_input {S} Γ : + Lemma compat_input {S : Set} (Γ : S → ty) : ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. Proof. - iIntros (ss) "Hss". + iModIntro. + iIntros (ss γ) "Hss". iIntros (σ) "Hs". destruct (update_input σ) as [n σ'] eqn:Hinp. iApply (wp_input with "Hs []"); first eauto. iNext. iIntros "Hlc Hs". iApply wp_val. - iExists (1,1),(Lit n),σ'. + iExists (1,1),(LitV n),σ'. iFrame "Hs". iModIntro. iSplit. { iPureIntro. - simp subst_expr. + term_simpl. apply prim_step_steps. - apply (Ectx_step' []). - by constructor. } + apply (Ectx_step' EmptyK). + by constructor. + } iExists n. eauto. Qed. - Lemma compat_output {S} Γ (e: expr S) α : + + Lemma compat_output {S : Set} (Γ : S → ty) (e: expr S) α : ⊢ logrel_valid Γ e α Tnat -∗ logrel_valid Γ (Output e) (interp_output rs α) Tnat. - Proof using HCi. - iIntros "H1". - iIntros (ss) "Hss". + Proof. + iIntros "#H1". + iModIntro. + iIntros (ss γ) "#Hss". iSpecialize ("H1" with "Hss"). - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := its_of_subs2 ss). fold env. - simp subst_expr. simpl. - iApply (logrel_bind (get_ret _) [OutputCtx] with "H1"). + term_simpl. + iApply (logrel_bind (get_ret _) (OutputK EmptyK) with "H1"). iIntros (v βv). iDestruct 1 as (m) "[Hb ->]". iRewrite "Hb". simpl. @@ -332,55 +276,53 @@ Section logrel. rewrite get_ret_ret. iApply (wp_output with "Hs []"); first done. iNext. iIntros "Hlc Hs". - iExists (1,1),(Lit 0),_. + iExists (1,1),(LitV 0),_. iFrame "Hs". iSplit. { iPureIntro. apply prim_step_steps. - apply (Ectx_step' []). + apply (Ectx_step' EmptyK). by constructor. } iExists 0. eauto. Qed. - Lemma compat_natop {S} (Γ : tyctx S) e1 e2 α1 α2 op : + Lemma compat_natop {S : Set} (Γ : S → ty) e1 e2 α1 α2 op : ⊢ logrel_valid Γ e1 α1 Tnat -∗ logrel_valid Γ e2 α2 Tnat -∗ logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. - Proof using HCi. - iIntros "H1 H2". iIntros (ss) "#Hss". + Proof. + iIntros "#H1 #H2". iModIntro. iIntros (ss γ) "#Hss". iSpecialize ("H1" with "Hss"). iSpecialize ("H2" with "Hss"). - pose (s := (subs_of_subs2 ss)). fold s. - pose (env := its_of_subs2 ss). fold env. - simp subst_expr. simpl. - iApply (logrel_bind (NatOpRSCtx (do_natop op) (α1 env)) [NatOpRCtx op (subst_expr e1 s)] with "H2"). - iIntros (v2 β2) "H2". iSimpl. - iApply (logrel_bind (NatOpLSCtx (do_natop op) (IT_of_V β2)) [NatOpLCtx op v2] with "H1"). - iIntros (v1 β1) "H1". simpl. - iDestruct "H1" as (n1) "[Hn1 ->]". - iDestruct "H2" as (n2) "[Hn2 ->]". + term_simpl. + iApply (logrel_bind (NatOpRSCtx (do_natop op) (α1 ss)) (NatOpRK op (bind γ e1) EmptyK) with "H2"). + iIntros (v2 β2) "H2'". iSimpl. + iApply (logrel_bind (NatOpLSCtx (do_natop op) (IT_of_V β2)) (NatOpLK op EmptyK v2) with "H1"). + iIntros (v1 β1) "H1'". simpl. + iDestruct "H1'" as (n1) "[Hn1 ->]". + iDestruct "H2'" as (n2) "[Hn2 ->]". unfold NatOpLSCtx. iAssert ((NATOP (do_natop op) (IT_of_V β1) (IT_of_V β2)) ≡ Ret (do_natop op n1 n2))%I with "[Hn1 Hn2]" as "Hr". { iRewrite "Hn1". simpl. iRewrite "Hn2". simpl. iPureIntro. by rewrite NATOP_Ret. } - iApply (logrel_step_pure (Val (Lit (do_natop op n1 n2)))). - { intro. apply (Ectx_step' []). constructor. + iApply (logrel_step_pure _ (Val (LitV (do_natop op n1 n2)))). + { intro. apply (Ectx_step' EmptyK). constructor. destruct op; simpl; eauto. } iRewrite "Hr". iApply (logrel_of_val (RetV $ do_natop op n1 n2)). iExists _. iSplit; eauto. Qed. - Lemma fundamental {S} (Γ : tyctx S) τ e : + Lemma fundamental {S : Set} (Γ : S → ty) τ e : typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ - with fundamental_val {S} (Γ : tyctx S) τ v : + with fundamental_val {S : Set} (Γ : S → ty) τ v : typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. - Proof using HCi. + Proof. - induction 1; simpl. + by apply fundamental_val. - + by apply compat_var. - + iApply compat_rec. iApply IHtyped. + + subst. + by apply compat_var. + iApply compat_app. ++ iApply IHtyped1. ++ iApply IHtyped2. @@ -395,7 +337,7 @@ Section logrel. + iApply compat_output. iApply IHtyped. - induction 1; simpl. - + iIntros (ss) "Hss". simp subst_expr. simpl. + + iModIntro. iIntros (ss γ) "Hss". term_simpl. iApply (logrel_of_val (RetV n)). iExists n. eauto. + iApply compat_recV. by iApply fundamental. Qed. @@ -404,74 +346,32 @@ End logrel. Definition κ {S} {E} : ITV E natO → val S := λ x, match x with - | core.RetV n => Lit n - | _ => Lit 0 + | core.RetV n => LitV n + | _ => LitV 0 end. -Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (Lit n : val S). +Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (LitV n : val S). Proof. Transparent RetV. unfold RetV. simpl. done. Opaque RetV. Qed. -Definition rs : gReifiers 1 := gReifiers_cons reify_io gReifiers_nil. +Definition rs : gReifiers NotCtxDep 1 := gReifiers_cons NotCtxDep reify_io (gReifiers_nil NotCtxDep). -Local Instance CtxIndepInputLang R `{!Cofe R} (o : opid (sReifier_ops (gReifiers_sReifier rs))) : - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o. -Proof. - destruct o as [x o]. - inv_fin x. - - simpl. intros [[]| [[]| []]]. - + constructor. - unshelve eexists (λne '(_, (a, b)), SomeO (_, (_, b))). - * simpl in *. - apply ((update_input a).1). - * simpl in *. - apply ((update_input a).2). - * solve_proper_prepare. - destruct x as [? [? ?]]; destruct y as [? [? ?]]. - simpl in *. - do 2 f_equiv. - -- do 2 f_equiv. - apply H. - -- f_equiv; last apply H. - do 2 f_equiv. - apply H. - * intros. - simpl. - destruct σ. - simpl. - reflexivity. - + constructor. - unshelve eexists (λne '(x, y), SomeO ((), _)). - * simpl in *. - apply ((update_output x (fstO y)), ()). - * solve_proper_prepare. - destruct x as [? [? ?]]; destruct y as [? [? ?]]. - simpl in *. - do 4 f_equiv. - -- apply H. - -- apply H. - * intros. - simpl. - destruct σ as [σ1 []]; simpl in *. - reflexivity. - - intros i; by apply fin_0_inv. -Qed. +Require Import gitrees.gitree.greifiers. -Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : +Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops NotCtxDep rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (True ⊢ logrel rs Tnat α e)%I) → - ssteps (gReifiers_sReifier rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ Lit n) σ' m. + ssteps (gReifiers_sReifier NotCtxDep rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. - pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), + pose (ϕ := λ (βv : ITV (gReifiers_ops NotCtxDep rs) natO), ∃ m σ', prim_steps e σ (Val $ κ βv) σ' m). cut (ϕ (RetV n)). { destruct 1 as ( m' & σ2 & Hm). exists m', σ2. revert Hm. by rewrite κ_Ret. } eapply (wp_adequacy 0); eauto. intros Hinv1 Hst1. - pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (Lit n) - ∗ ⌜∃ m σ', prim_steps e σ (Val $ Lit n) σ' m⌝)%I). + pose (Φ := (λ (βv : ITV (gReifiers_ops NotCtxDep rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) + ∗ ⌜∃ m σ', prim_steps e σ (Val $ LitV n) σ' m⌝)%I). assert (NonExpansive Φ). { unfold Φ. intros l a1 a2 Ha. repeat f_equiv. done. } @@ -492,8 +392,8 @@ Proof. iPoseProof (Hlog with "[//]") as "Hlog". iAssert (has_substate σ) with "[Hs]" as "Hs". { unfold has_substate, has_full_state. - assert (of_state rs (IT (gReifiers_ops rs) natO) (σ, ()) ≡ - of_idx rs (IT (gReifiers_ops rs) natO) sR_idx (sR_state σ)) as -> ; last done. + assert (of_state NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) natO) (σ, ()) ≡ + of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) natO) 0 σ) as ->; last done. intro j. unfold sR_idx. simpl. unfold of_state, of_idx. destruct decide as [Heq|]; last first. @@ -512,23 +412,25 @@ Proof. iExists l. iSplit; eauto. Qed. -Theorem adequacy (e : expr []) (k : nat) σ σ' n : - typed empC e Tnat → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ()) (σ,()) (Ret k : IT _ natO) σ' n → - ∃ mm σ', prim_steps e σ (Val $ Lit k) σ' mm. +Program Definition ı_scope : @interp_scope (gReifiers_ops NotCtxDep rs) natO _ Empty_set := λne (x : ∅), match x with end. + +Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : + typed □ e Tnat → + ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ı_scope) (σ,()) (Ret k : IT _ natO) σ' n → + ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. Proof. intros Hty Hst. pose (Σ:=#[invΣ;stateΣ rs natO]). - eapply (logrel_nat_adequacy Σ (interp_expr rs e ())); last eassumption. + eapply (logrel_nat_adequacy Σ (interp_expr rs e ı_scope)); last eassumption. intros ? ?. iPoseProof (fundamental rs) as "H". { apply Hty. } unfold logrel_valid. iIntros "_". - iSpecialize ("H" $! (emp_subs2 rs)). - simp its_of_subs2. - rewrite subs_of_emp_subs2. - rewrite subst_expr_idsub. + unshelve iSpecialize ("H" $! ı_scope _ with "[]"). + { apply ı%bind. } + { iIntros (x); destruct x. } + rewrite ebind_id; first last. + { intros ?; reflexivity. } iApply "H". - unfold subs2_valid. done. Qed. diff --git a/theories/input_lang_callcc/hom.v b/theories/input_lang_callcc/hom.v index 7250497..16d7ad0 100644 --- a/theories/input_lang_callcc/hom.v +++ b/theories/input_lang_callcc/hom.v @@ -1,16 +1,15 @@ -From Equations Require Import Equations. From gitrees Require Import gitree. From gitrees.input_lang_callcc Require Import lang interp. -Require Import gitrees.lang_generic_sem. +Require Import gitrees.lang_generic. Require Import Binding.Lib Binding.Set Binding.Env. Open Scope stdpp_scope. Section hom. Context {sz : nat}. - Context {rs : gReifiers sz}. + Context {rs : gReifiers CtxDep sz}. Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops CtxDep rs). Notation IT := (IT F natO). Notation ITV := (ITV F natO). diff --git a/theories/input_lang_callcc/interp.v b/theories/input_lang_callcc/interp.v index 73ad941..ae97290 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/input_lang_callcc/interp.v @@ -1,7 +1,6 @@ -From Equations Require Import Equations. From gitrees Require Import gitree. From gitrees.input_lang_callcc Require Import lang. -Require Import gitrees.lang_generic_sem. +Require Import gitrees.lang_generic. Require Import Binding.Lib. Require Import Binding.Set. @@ -84,7 +83,7 @@ Proof. repeat f_equiv; apply H0. Qed. -Canonical Structure reify_io : sReifier. +Canonical Structure reify_io : sReifier CtxDep. Proof. simple refine {| sReifier_ops := ioE; sReifier_state := stateO @@ -175,9 +174,9 @@ End constructors. Section weakestpre. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers CtxDep sz). Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops CtxDep rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Notation IT := (IT F R). @@ -194,7 +193,7 @@ Section weakestpre. Proof. iIntros (Hσ) "Hs Ha". rewrite hom_INPUT. simpl. - iApply (wp_subreify with "Hs"). + iApply (wp_subreify_ctx_dep with "Hs"). + simpl. by rewrite Hσ. + by rewrite ofe_iso_21. + done. @@ -209,20 +208,6 @@ Section weakestpre. eapply (wp_input' σ σ' n k idfun). Qed. - (* Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : *) - (* update_input σ = (n, σ') → *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ *) - (* WP@{rs} (INPUT k) @ s {{ Φ }}. *) - (* Proof. *) - (* intros Hs. iIntros "Hs Ha". *) - (* unfold INPUT. simpl. *) - (* iApply (wp_subreify with "Hs"). *) - (* { simpl. by rewrite Hs. } *) - (* { simpl. by rewrite ofe_iso_21. } *) - (* iModIntro. done. *) - (* Qed. *) - Lemma wp_output' (σ σ' : stateO) (n : nat) (κ : IT -n> IT) `{!IT_hom κ} Φ s : update_output n σ = σ' → @@ -232,13 +217,12 @@ Section weakestpre. Proof. iIntros (Hσ) "Hs Ha". rewrite /OUTPUT hom_OUTPUT_. - iApply (wp_subreify with "Hs"). + iApply (wp_subreify_ctx_dep with "Hs"). + simpl. by rewrite Hσ. + done. + done. Qed. - Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : update_output n σ = σ' → has_substate σ -∗ @@ -259,7 +243,7 @@ Section weakestpre. Proof. iIntros "Hs Ha". rewrite /THROW. simpl. rewrite hom_vis. - iApply (wp_subreify with "Hs"); simpl; done. + iApply (wp_subreify_ctx_dep with "Hs"); simpl; done. Qed. Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : @@ -278,7 +262,7 @@ Section weakestpre. iIntros "Hs Ha". unfold CALLCC. simpl. rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ ((later_map k ((f (laterO_map k))))) with "Hs"). + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ ((later_map k ((f (laterO_map k))))) with "Hs"). { simpl. repeat f_equiv. @@ -301,11 +285,11 @@ End weakestpre. Section interp. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers CtxDep sz). Context {subR : subReifier reify_io rs}. Context {R} `{CR : !Cofe R}. Context `{!SubOfe natO R}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops CtxDep rs). Notation IT := (IT F R). Notation ITV := (ITV F R). @@ -946,26 +930,26 @@ Section interp. Opaque Ret. Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) - (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : + (σ σ' : stateO) (σr : gState_rest CtxDep sR_idx rs ♯ IT) n : head_step e σ e' σ' K (n, 1) → - reify (gReifiers_sReifier rs) - (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) - ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). + reify (gReifiers_sReifier CtxDep rs) + (interp_expr (fill K e) env) (gState_recomp CtxDep σr (sR_state σ)) + ≡ (gState_recomp CtxDep σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). Proof. intros Hst. - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) - (gState_recomp σr (sR_state σ))). + trans (reify (gReifiers_sReifier CtxDep rs) (interp_ectx K env (interp_expr e env)) + (gState_recomp CtxDep σr (sR_state σ))). { f_equiv. by rewrite interp_comp. } inversion Hst; simplify_eq; cbn-[gState_recomp]. - - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). + - trans (reify (gReifiers_sReifier CtxDep rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp CtxDep σr (sR_state σ))). { repeat f_equiv; eauto. rewrite hom_INPUT. do 2 f_equiv. by intro. } - rewrite reify_vis_eq //; first last. + rewrite reify_vis_eq_ctx_dep //; first last. { - epose proof (@subReifier_reify sz reify_io rs _ IT _ (inl ()) () (Next (interp_ectx K env (Ret n0))) (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr) as H. + epose proof (@subReifier_reify sz CtxDep reify_io rs _ IT _ (inl ()) () (Next (interp_ectx K env (Ret n0))) (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr) as H. simpl in H. simpl. erewrite <-H; last first. @@ -976,19 +960,19 @@ Section interp. repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. reflexivity. - - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). + - trans (reify (gReifiers_sReifier CtxDep rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp CtxDep σr (sR_state σ))). { do 3 f_equiv; eauto. rewrite get_ret_ret//. } - trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). + trans (reify (gReifiers_sReifier CtxDep rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp CtxDep σr (sR_state σ))). { do 2 f_equiv; eauto. by rewrite hom_OUTPUT_. } - rewrite reify_vis_eq //; last first. + rewrite reify_vis_eq_ctx_dep //; last first. { - epose proof (@subReifier_reify sz reify_io rs _ IT _ (inr (inl ())) n0 (Next (interp_ectx K env ((Ret 0)))) (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. + epose proof (@subReifier_reify sz CtxDep reify_io rs _ IT _ (inr (inl ())) n0 (Next (interp_ectx K env ((Ret 0)))) (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. simpl in H. simpl. erewrite <-H; last reflexivity. @@ -1007,17 +991,17 @@ Section interp. Transparent CALLCC. unfold CALLCC. simpl. - set (subEff1 := @subReifier_subEff sz reify_io rs subR). - trans (reify (gReifiers_sReifier rs) (CALLCC_ f (laterO_map (interp_ectx K env))) gσ). + set (subEff1 := @subReifier_subEff sz CtxDep reify_io rs subR). + trans (reify (gReifiers_sReifier CtxDep rs) (CALLCC_ f (laterO_map (interp_ectx K env))) gσ). { do 2 f_equiv. rewrite hom_CALLCC_. f_equiv. by intro. } - rewrite reify_vis_eq//; last first. + rewrite reify_vis_eq_ctx_dep//; last first. { simpl. - epose proof (@subReifier_reify sz reify_io rs subR IT _ + epose proof (@subReifier_reify sz CtxDep reify_io rs subR IT _ (inr (inr (inl ()))) f _ (laterO_map (interp_ectx K env)) σ' σ' σr) as H. simpl in H. @@ -1037,11 +1021,11 @@ Section interp. do 2 f_equiv. by intro. Qed. - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest CtxDep sR_idx rs ♯ IT) n m (env : interp_scope S) : prim_step e1 σ1 e2 σ2 (n,m) → - ssteps (gReifiers_sReifier rs) - (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) - (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. + ssteps (gReifiers_sReifier CtxDep rs) + (interp_expr e1 env) (gState_recomp CtxDep σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp CtxDep σr (sR_state σ2)) n. Proof. Opaque gState_decomp gState_recomp. inversion 1; simplify_eq/=. @@ -1113,7 +1097,7 @@ Section interp. match goal with | |- context G [ofe_mor_car _ _ _ (Next ?f)] => set (f' := f) end. - trans (reify (gReifiers_sReifier rs) (THROW (interp_val v env) (Next f')) (gState_recomp σr (sR_state σ2))). + trans (reify (gReifiers_sReifier CtxDep rs) (THROW (interp_val v env) (Next f')) (gState_recomp CtxDep σr (sR_state σ2))). { f_equiv; last done. f_equiv. @@ -1125,12 +1109,12 @@ Section interp. intros x; simpl. destruct ((subEff_outs ^-1) x). } - rewrite reify_vis_eq; first (rewrite Tick_eq; reflexivity). + rewrite reify_vis_eq_ctx_dep; first (rewrite Tick_eq; reflexivity). simpl. match goal with | |- context G [(_, _, ?a)] => set (κ := a) end. - epose proof (@subReifier_reify sz reify_io rs subR IT _ + epose proof (@subReifier_reify sz CtxDep reify_io rs subR IT _ (inr (inr (inr (inl ())))) (Next (interp_val v env), Next f') (Next (Tau (Next ((interp_ectx K' env) (interp_val v env))))) (Empty_setO_rec _) σ2 σ2 σr) as H'. diff --git a/theories/input_lang_callcc/lang.v b/theories/input_lang_callcc/lang.v index d917ecb..e7cb712 100644 --- a/theories/input_lang_callcc/lang.v +++ b/theories/input_lang_callcc/lang.v @@ -1,6 +1,4 @@ -From stdpp Require Export strings. From gitrees Require Export prelude. -From Equations Require Import Equations. Require Import List. Import ListNotations. diff --git a/theories/input_lang_callcc/logrel.v b/theories/input_lang_callcc/logrel.v index 1adfe97..b88fac4 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/input_lang_callcc/logrel.v @@ -1,17 +1,16 @@ (** Logical relation for adequacy for the IO lang *) -From Equations Require Import Equations. From gitrees Require Import gitree. From gitrees.input_lang_callcc Require Import lang interp hom. -Require Import gitrees.lang_generic_sem. +Require Import gitrees.lang_generic. Require Import Binding.Lib Binding.Set Binding.Env. Open Scope stdpp_scope. Section logrel. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers CtxDep sz). Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops CtxDep rs). Notation IT := (IT F natO). Notation ITV := (ITV F natO). Context `{!invGS Σ, !stateG rs natO Σ}. @@ -273,7 +272,7 @@ Section logrel. iApply "HK'". simpl. unfold logrel_arr. - _iExists (Next (ir_unf rs α env)). + iExists (Next (ir_unf rs α env)). iSplit; first done. iModIntro. iApply "IH". @@ -685,19 +684,19 @@ Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (LitV n : val S). Proof. Transparent RetV. unfold RetV. simpl. done. Opaque RetV. Qed. -Definition rs : gReifiers 1 := gReifiers_cons reify_io gReifiers_nil. +Definition rs : gReifiers CtxDep 1 := gReifiers_cons CtxDep reify_io (gReifiers_nil CtxDep). Require Import gitrees.gitree.greifiers. Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} - (α : IT (gReifiers_ops rs) natO) + (α : IT (gReifiers_ops CtxDep rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (⊢ logrel rs Tnat α e)%I) → - ssteps (gReifiers_sReifier rs) α (σ, ()) (Ret n) σ' k → + ssteps (gReifiers_sReifier CtxDep rs) α (σ, ()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. - pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), + pose (ϕ := λ (βv : ITV (gReifiers_ops CtxDep rs) natO), ∃ m σ', prim_steps e σ (Val $ κ βv) σ' m). cut (ϕ (RetV n)). { @@ -706,7 +705,7 @@ Proof. } eapply (wp_adequacy 0); eauto. intros Hinv1 Hst1. - pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), + pose (Φ := (λ (βv : ITV (gReifiers_ops CtxDep rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) ∗ ⌜∃ m σ', prim_steps e σ (Val $ LitV n) σ' m⌝)%I). assert (NonExpansive Φ). @@ -732,8 +731,8 @@ Proof. iAssert (has_substate σ) with "[Hs]" as "Hs". { unfold has_substate, has_full_state. - assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ())) ≡ - (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ))) + assert ((of_state CtxDep rs (IT (sReifier_ops CtxDep (gReifiers_sReifier CtxDep rs)) natO) (σ, ())) ≡ + (of_idx CtxDep rs (IT (sReifier_ops CtxDep (gReifiers_sReifier CtxDep rs)) natO) sR_idx (sR_state σ))) as -> ; last done. intros j. unfold sR_idx. simpl. unfold of_state, of_idx. @@ -766,11 +765,11 @@ Proof. iExists l. iSplit; eauto. Qed. -Program Definition ı_scope : @interp_scope (gReifiers_ops rs) natO _ Empty_set := λne (x : ∅), match x with end. +Program Definition ı_scope : @interp_scope (gReifiers_ops CtxDep rs) natO _ Empty_set := λne (x : ∅), match x with end. Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : typed □ e Tnat → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → + ssteps (gReifiers_sReifier CtxDep rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. Proof. intros Hty Hst. diff --git a/theories/lang_affine.v b/theories/lang_affine.v new file mode 100644 index 0000000..b13c0be --- /dev/null +++ b/theories/lang_affine.v @@ -0,0 +1,245 @@ +From gitrees Require Import prelude. +From gitrees Require Import gitree. +From Equations Require Import Equations. +Require Import List. +Import ListNotations. + +(** XXX: We /NEED/ this line for [Equations Derive] to work, *) +(* this flag is globally unset by std++, but Equations need obligations to be transparent. *) +Set Transparent Obligations. + +Derive NoConfusion NoConfusionHom for list. + +Definition scope := (list unit). + +(** Variables in a context *) +Inductive var : scope → Type := +| Vz : forall {S : scope} {s}, var (s::S) +| Vs : forall {S : scope} {s}, var S -> var (s::S) +. +Derive Signature NoConfusion for var. + +Inductive tyctx (ty : Type) : scope → Type := +| empC : tyctx ty [] +| consC : forall{Γ}, ty → tyctx ty Γ → tyctx ty (()::Γ) +. +Arguments empC {_}. +Arguments consC {_ _} _ _. + +Equations list_of_tyctx {S ty} (Γ : tyctx ty S) : list ty := + list_of_tyctx empC := []; + list_of_tyctx (consC τ Γ') := τ::list_of_tyctx Γ'. + +Equations tyctx_app {S1 S2 ty} (c1 : tyctx ty S1) (c2 : tyctx ty S2) : tyctx ty (S1++S2) := + tyctx_app empC c2 := c2; + tyctx_app (consC τ c1) c2 := consC τ (tyctx_app c1 c2). + +Inductive typed_var {ty : Type}: forall {S}, tyctx ty S → var S → ty → Prop := +| typed_var_Z S (τ : ty) (Γ : tyctx ty S) : + typed_var (consC τ Γ) Vz τ +| typed_var_S S (τ τ' : ty) (Γ : tyctx ty S) v : + typed_var Γ v τ → + typed_var (consC τ' Γ) (Vs v) τ +. + +Section interp. + Local Open Scope type. + Context {E: opsInterp}. + Context {R} `{!Cofe R}. + Notation IT := (IT E R). + Notation ITV := (ITV E R). + + Fixpoint interp_scope (S : scope) : ofe := + match S with + | [] => unitO + | τ::Sc => prodO IT (interp_scope Sc) + end. + + Instance interp_scope_cofe S : Cofe (interp_scope S). + Proof. induction S; simpl; apply _. Qed. + + Instance interp_scope_inhab S : Inhabited (interp_scope S). + Proof. induction S; simpl; apply _. Defined. + + Equations interp_var {S : scope} (v : var S) : interp_scope S -n> IT := + interp_var (S:=(_::_)) Vz := fstO; + interp_var (S:=(_::Sc)) (Vs v) := interp_var v ◎ sndO. + + Instance interp_var_ne S (v : var S) : NonExpansive (@interp_var S v). + Proof. + intros n D1 D2 HD12. induction v; simp interp_var. + - by f_equiv. + - eapply IHv. by f_equiv. + Qed. + + Global Instance interp_var_proper S (v : var S) : Proper ((≡) ==> (≡)) (interp_var v). + Proof. apply ne_proper. apply _. Qed. + + Definition interp_scope_split {S1 S2} : + interp_scope (S1 ++ S2) -n> interp_scope S1 * interp_scope S2. + Proof. + induction S1 as [|? S1]; simpl. + - simple refine (λne x, (tt, x)). + solve_proper. + - simple refine (λne xy, let ss := IHS1 xy.2 in ((xy.1, ss.1), ss.2)). + solve_proper. + Defined. + + (** scope substituions *) + Inductive ssubst : scope → Type := + | emp_ssubst : ssubst [] + | cons_ssubst {S} : ITV → ssubst S → ssubst (tt::S) + . + + Equations interp_ssubst {S} (ss : ssubst S) : interp_scope S := + interp_ssubst emp_ssubst := tt; + interp_ssubst (cons_ssubst αv ss) := (IT_of_V αv, interp_ssubst ss). + + Equations list_of_ssubst {S} (ss : ssubst S) : list ITV := + list_of_ssubst emp_ssubst := []; + list_of_ssubst (cons_ssubst αv ss) := αv::(list_of_ssubst ss). + + Equations ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : ssubst S1 * ssubst S2 := + ssubst_split (S1:=[]) αs := (emp_ssubst,αs); + ssubst_split (S1:=u::_) (cons_ssubst αv αs) := + (cons_ssubst αv (ssubst_split αs).1, (ssubst_split αs).2). + Lemma interp_scope_ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : + interp_scope_split (interp_ssubst αs) ≡ + (interp_ssubst (ssubst_split αs).1, interp_ssubst (ssubst_split αs).2). + Proof. + induction S1 as [|u S1]; simpl. + - simp ssubst_split. simpl. + simp interp_ssubst. done. + - dependent elimination αs as [cons_ssubst αv αs]. + simp ssubst_split. simpl. + simp interp_ssubst. repeat f_equiv; eauto; simpl. + + rewrite IHS1//. + + rewrite IHS1//. + Qed. + +End interp. + +(* Common definitions and lemmas for Kripke logical relations *) +Section kripke_logrel. + Variable s : stuckness. + + Context {sz : nat} {a : is_ctx_dep}. + Variable rs : gReifiers a sz. + Context {R} `{!Cofe R}. + + Notation F := (gReifiers_ops a rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Context {A:ofe}. (* The type & predicate for the explicit Kripke worlds *) + Variable (P : A -n> iProp). + + Implicit Types α β : IT. + Implicit Types αv βv : ITV. + Implicit Types Φ Ψ : ITV -n> iProp. + + Program Definition expr_pred (α : IT) (Φ : ITV -n> iProp) : iProp := + (∀ x : A, P x -∗ WP@{rs} α @ s {{ v, ∃ y : A, Φ v ∗ P y }}). + #[export] Instance expr_pred_ne : NonExpansive2 expr_pred. + Proof. solve_proper. Qed. + #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . + Proof. solve_proper. Qed. + + Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : tyctx ty S) (ss : ssubst S) : iProp := + ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), + interp_ty (τx.1) (τx.2))%I. + + Lemma ssubst_valid_nil {ty} (interp_ty : ty → ITV -n> iProp) : + ⊢ ssubst_valid interp_ty empC emp_ssubst. + Proof. + unfold ssubst_valid. + by simp list_of_tyctx list_of_ssubst. + Qed. + + Lemma ssubst_valid_cons {ty} (interp_ty : ty → ITV -n> iProp) {S} + (Γ : tyctx ty S) (ss : ssubst S) τ αv : + ssubst_valid interp_ty (consC τ Γ) (cons_ssubst αv ss) + ⊣⊢ interp_ty τ αv ∗ ssubst_valid interp_ty Γ ss. + Proof. + unfold ssubst_valid. + by simp list_of_tyctx list_of_ssubst. + Qed. + + Lemma ssubst_valid_app {ty} (interp_ty : ty → ITV -n> iProp) + {S1 S2} (Ω1 : tyctx ty S1) (Ω2 : tyctx ty S2) αs : + ssubst_valid interp_ty (tyctx_app Ω1 Ω2) αs ⊢ + ssubst_valid interp_ty Ω1 (ssubst_split αs).1 + ∗ ssubst_valid interp_ty Ω2 (ssubst_split αs).2. + Proof. + iInduction Ω1 as [|τ Ω1] "IH" forall (Ω2); simp tyctx_app ssubst_split. + - simpl. iIntros "$". iApply ssubst_valid_nil. + - iIntros "H". + rewrite {4 5}/ssubst_valid. + simpl in αs. + dependent elimination αs as [cons_ssubst αv αs]. + simp ssubst_split. simpl. + simp list_of_ssubst list_of_tyctx. + simpl. iDestruct "H" as "[$ H]". + by iApply "IH". + Qed. + + Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : + Φ αv ⊢ expr_pred α Φ. + Proof. + iIntros "H". + iIntros (x) "Hx". iApply wp_val. + eauto with iFrame. + Qed. + + Lemma expr_pred_frame α Φ : + WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. + Proof. + iIntros "H". + iIntros (x) "Hx". + iApply (wp_wand with "H"). + eauto with iFrame. + Qed. +End kripke_logrel. + +Section kripke_logrel_ctx_indep. + Variable s : stuckness. + + Context {sz : nat}. + Variable rs : gReifiers NotCtxDep sz. + Context {R} `{!Cofe R}. + + Notation F := (gReifiers_ops NotCtxDep rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Context {A : ofe}. + Variable (P : A -n> iProp). + + Implicit Types α β : IT. + Implicit Types αv βv : ITV. + Implicit Types Φ Ψ : ITV -n> iProp. + + Local Notation expr_pred := (expr_pred s rs P). + + Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} + : expr_pred α Ψ ⊢ + (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) + -∗ expr_pred (f α) Φ. + Proof. + iIntros "H1 H2". + iIntros (x) "Hx". + iApply wp_bind. + { solve_proper. } + iSpecialize ("H1" with "Hx"). + iApply (wp_wand with "H1"). + iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". + iModIntro. + iApply ("H2" with "Hb Hy"). + Qed. +End kripke_logrel_ctx_indep. + +Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_ _}. diff --git a/theories/lang_generic.v b/theories/lang_generic.v index 7c27639..144c061 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -1,46 +1,9 @@ From gitrees Require Import prelude. From gitrees Require Import gitree. -From Equations Require Import Equations. Require Import List. Import ListNotations. -(** XXX: We /NEED/ this line for [Equations Derive] to work, - this flag is globally unset by std++, but Equations need obligations to be transparent. *) -Set Transparent Obligations. - -Derive NoConfusion NoConfusionHom for list. - -Definition scope := (list unit). - -(** Variables in a context *) -Inductive var : scope → Type := -| Vz : forall {S : scope} {s}, var (s::S) -| Vs : forall {S : scope} {s}, var S -> var (s::S) -. -Derive Signature NoConfusion for var. - -Inductive tyctx (ty : Type) : scope → Type := -| empC : tyctx ty [] -| consC : forall{Γ}, ty → tyctx ty Γ → tyctx ty (()::Γ) -. -Arguments empC {_}. -Arguments consC {_ _} _ _. - -Equations list_of_tyctx {S ty} (Γ : tyctx ty S) : list ty := - list_of_tyctx empC := []; - list_of_tyctx (consC τ Γ') := τ::list_of_tyctx Γ'. - -Equations tyctx_app {S1 S2 ty} (c1 : tyctx ty S1) (c2 : tyctx ty S2) : tyctx ty (S1++S2) := - tyctx_app empC c2 := c2; - tyctx_app (consC τ c1) c2 := consC τ (tyctx_app c1 c2). - -Inductive typed_var {ty : Type}: forall {S}, tyctx ty S → var S → ty → Prop := -| typed_var_Z S (τ : ty) (Γ : tyctx ty S) : - typed_var (consC τ Γ) Vz τ -| typed_var_S S (τ τ' : ty) (Γ : tyctx ty S) v : - typed_var Γ v τ → - typed_var (consC τ' Γ) (Vs v) τ -. +Require Import Binding.Lib Binding.Set. Section interp. Local Open Scope type. @@ -49,141 +12,81 @@ Section interp. Notation IT := (IT E R). Notation ITV := (ITV E R). - Fixpoint interp_scope (S : scope) : ofe := - match S with - | [] => unitO - | τ::Sc => prodO IT (interp_scope Sc) - end. + Definition interp_scope (S : Set) : ofe := (leibnizO S) -n> IT. - Instance interp_scope_cofe S : Cofe (interp_scope S). - Proof. induction S; simpl; apply _. Qed. + Global Instance interp_scope_cofe S : Cofe (interp_scope S). + Proof. apply _. Qed. - Instance interp_scope_inhab S : Inhabited (interp_scope S). - Proof. induction S; simpl; apply _. Defined. + Global Instance interp_scope_inhab S : Inhabited (interp_scope S). + Proof. apply _. Defined. - Equations interp_var {S : scope} (v : var S) : interp_scope S -n> IT := - interp_var (S:=(_::_)) Vz := fstO; - interp_var (S:=(_::Sc)) (Vs v) := interp_var v ◎ sndO. - - Instance interp_var_ne S (v : var S) : NonExpansive (@interp_var S v). - Proof. - intros n D1 D2 HD12. induction v; simp interp_var. - - by f_equiv. - - eapply IHv. by f_equiv. + Program Definition interp_var {S : Set} (v : S) : interp_scope S -n> IT := + λne (f : interp_scope S), f v. + Next Obligation. + solve_proper. Qed. - Global Instance interp_var_proper S (v : var S) : Proper ((≡) ==> (≡)) (interp_var v). + Global Instance interp_var_proper {S : Set} (v : S) : Proper ((≡) ==> (≡)) (interp_var v). Proof. apply ne_proper. apply _. Qed. - Definition interp_scope_split {S1 S2} : - interp_scope (S1 ++ S2) -n> interp_scope S1 * interp_scope S2. - Proof. - induction S1 as [|? S1]; simpl. - - simple refine (λne x, (tt, x)). - solve_proper. - - simple refine (λne xy, let ss := IHS1 xy.2 in ((xy.1, ss.1), ss.2)). - solve_proper. - Defined. - - (** scope substituions *) - Inductive ssubst : scope → Type := - | emp_ssubst : ssubst [] - | cons_ssubst {S} : ITV → ssubst S → ssubst (tt::S) - . - - Equations interp_ssubst {S} (ss : ssubst S) : interp_scope S := - interp_ssubst emp_ssubst := tt; - interp_ssubst (cons_ssubst αv ss) := (IT_of_V αv, interp_ssubst ss). - - Equations list_of_ssubst {S} (ss : ssubst S) : list ITV := - list_of_ssubst emp_ssubst := []; - list_of_ssubst (cons_ssubst αv ss) := αv::(list_of_ssubst ss). - - Equations ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : ssubst S1 * ssubst S2 := - ssubst_split (S1:=[]) αs := (emp_ssubst,αs); - ssubst_split (S1:=u::_) (cons_ssubst αv αs) := - (cons_ssubst αv (ssubst_split αs).1, (ssubst_split αs).2). - Lemma interp_scope_ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : - interp_scope_split (interp_ssubst αs) ≡ - (interp_ssubst (ssubst_split αs).1, interp_ssubst (ssubst_split αs).2). - Proof. - induction S1 as [|u S1]; simpl. - - simp ssubst_split. simpl. - simp interp_ssubst. done. - - dependent elimination αs as [cons_ssubst αv αs]. - simp ssubst_split. simpl. - simp interp_ssubst. repeat f_equiv; eauto; simpl. - + rewrite IHS1//. - + rewrite IHS1//. + Program Definition extend_scope {S : Set} : interp_scope S -n> IT -n> interp_scope (inc S) + := λne γ μ x, let x' : inc S := x in + match x' with + | VZ => μ + | VS x'' => γ x'' + end. + Next Obligation. + intros ???? [| x] [| y]; term_simpl; [solve_proper | inversion 1 | inversion 1 | inversion 1; by subst]. + Qed. + Next Obligation. + intros ??????. + intros [| a]; term_simpl; solve_proper. + Qed. + Next Obligation. + intros ??????. + intros [| a]; term_simpl; solve_proper. Qed. + Program Definition ren_scope {S S'} (δ : S [→] S') (env : interp_scope S') + : interp_scope S := λne x, env (δ x). + End interp. (* Common definitions and lemmas for Kripke logical relations *) Section kripke_logrel. Variable s : stuckness. - Context {sz : nat}. - Variable rs : gReifiers sz. + Context {sz : nat} {a : is_ctx_dep}. + Variable rs : gReifiers a sz. Context {R} `{!Cofe R}. - Notation F := (gReifiers_ops rs). + Notation F := (gReifiers_ops a rs). Notation IT := (IT F R). Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). Context {A:ofe}. (* The type & predicate for the explicit Kripke worlds *) - Variable (P : A → iProp). - Context `{!NonExpansive P}. + Variable (P : A -n> iProp). Implicit Types α β : IT. Implicit Types αv βv : ITV. Implicit Types Φ Ψ : ITV -n> iProp. Program Definition expr_pred (α : IT) (Φ : ITV -n> iProp) : iProp := - (∀ x : A, P x -∗ WP@{rs} α @ s {{ v, ∃ y : A, Φ v ∗ P y }}). - #[export] Instance expr_pred_ne : NonExpansive2 expr_pred. - Proof. solve_proper. Qed. - #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . - Proof. solve_proper. Qed. - - Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : tyctx ty S) (ss : ssubst S) : iProp := - ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), - interp_ty (τx.1) (τx.2))%I. - - Lemma ssubst_valid_nil {ty} (interp_ty : ty → ITV -n> iProp) : - ⊢ ssubst_valid interp_ty empC emp_ssubst. - Proof. - unfold ssubst_valid. - by simp list_of_tyctx list_of_ssubst. + (∀ x : A, P x -∗ wp rs α s ⊤ (λne v, ∃ y : A, Φ v ∗ P y)). + Next Obligation. + solve_proper. Qed. - Lemma ssubst_valid_cons {ty} (interp_ty : ty → ITV -n> iProp) {S} - (Γ : tyctx ty S) (ss : ssubst S) τ αv : - ssubst_valid interp_ty (consC τ Γ) (cons_ssubst αv ss) - ⊣⊢ interp_ty τ αv ∗ ssubst_valid interp_ty Γ ss. + Global Instance expr_pred_ne {n} : Proper (dist n ==> dist n ==> dist n) expr_pred. Proof. - unfold ssubst_valid. - by simp list_of_tyctx list_of_ssubst. + solve_proper. Qed. - Lemma ssubst_valid_app {ty} (interp_ty : ty → ITV -n> iProp) - {S1 S2} (Ω1 : tyctx ty S1) (Ω2 : tyctx ty S2) αs : - ssubst_valid interp_ty (tyctx_app Ω1 Ω2) αs ⊢ - ssubst_valid interp_ty Ω1 (ssubst_split αs).1 - ∗ ssubst_valid interp_ty Ω2 (ssubst_split αs).2. + Global Instance expr_pred_proper : Proper (equiv ==> equiv ==> equiv) expr_pred. Proof. - iInduction Ω1 as [|τ Ω1] "IH" forall (Ω2); simp tyctx_app ssubst_split. - - simpl. iIntros "$". iApply ssubst_valid_nil. - - iIntros "H". - rewrite {4 5}/ssubst_valid. - simpl in αs. - dependent elimination αs as [cons_ssubst αv αs]. - simp ssubst_split. simpl. - simp list_of_ssubst list_of_tyctx. - simpl. iDestruct "H" as "[$ H]". - by iApply "IH". + solve_proper. Qed. Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : @@ -191,35 +94,61 @@ Section kripke_logrel. Proof. iIntros "H". iIntros (x) "Hx". iApply wp_val. - eauto with iFrame. + simpl. + iExists x. + by iFrame. Qed. + Lemma expr_pred_frame α Φ : + WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. + Proof. + iIntros "H". + iIntros (x) "Hx". + iApply (wp_wand with "H"). + simpl. + iIntros (v) "Hv". + iExists x. + by iFrame. + Qed. + +End kripke_logrel. + +Section kripke_logrel_ctx_indep. + Variable s : stuckness. + + Context {sz : nat}. + Variable rs : gReifiers NotCtxDep sz. + Context {R} `{!Cofe R}. + + Notation F := (gReifiers_ops NotCtxDep rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Context {A : ofe}. + Variable (P : A -n> iProp). + + Implicit Types α β : IT. + Implicit Types αv βv : ITV. + Implicit Types Φ Ψ : ITV -n> iProp. + + Local Notation expr_pred := (expr_pred s rs P). + Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} - {G : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) IT o} : - expr_pred α Ψ ⊢ - (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) -∗ - expr_pred (f α) Φ. + : expr_pred α Ψ ⊢ + (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) + -∗ expr_pred (f α) Φ. Proof. iIntros "H1 H2". iIntros (x) "Hx". iApply wp_bind. - { solve_proper. } iSpecialize ("H1" with "Hx"). iApply (wp_wand with "H1"). iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". iModIntro. iApply ("H2" with "Hb Hy"). Qed. - - Lemma expr_pred_frame α Φ : - WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. - Proof. - iIntros "H". - iIntros (x) "Hx". - iApply (wp_wand with "H"). - eauto with iFrame. - Qed. -End kripke_logrel. +End kripke_logrel_ctx_indep. Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_ _}. diff --git a/theories/lang_generic_sem.v b/theories/lang_generic_sem.v deleted file mode 100644 index 21816f1..0000000 --- a/theories/lang_generic_sem.v +++ /dev/null @@ -1,104 +0,0 @@ -From gitrees Require Import prelude. -From gitrees Require Import gitree. -Require Import List. -Import ListNotations. - -Require Import Binding.Lib Binding.Set. - -Section interp. - Local Open Scope type. - Context {E: opsInterp}. - Context {R} `{!Cofe R}. - Notation IT := (IT E R). - Notation ITV := (ITV E R). - - Definition interp_scope (S : Set) : ofe := (leibnizO S) -n> IT. - - Global Instance interp_scope_cofe S : Cofe (interp_scope S). - Proof. apply _. Qed. - - Global Instance interp_scope_inhab S : Inhabited (interp_scope S). - Proof. apply _. Defined. - - Program Definition interp_var {S : Set} (v : S) : interp_scope S -n> IT := - λne (f : interp_scope S), f v. - Next Obligation. - solve_proper. - Qed. - - Global Instance interp_var_proper {S : Set} (v : S) : Proper ((≡) ==> (≡)) (interp_var v). - Proof. apply ne_proper. apply _. Qed. - - Program Definition extend_scope {S : Set} : interp_scope S -n> IT -n> interp_scope (inc S) - := λne γ μ x, let x' : inc S := x in - match x' with - | VZ => μ - | VS x'' => γ x'' - end. - Next Obligation. - intros ???? [| x] [| y]; term_simpl; [solve_proper | inversion 1 | inversion 1 | inversion 1; by subst]. - Qed. - Next Obligation. - intros ??????. - intros [| a]; term_simpl; solve_proper. - Qed. - Next Obligation. - intros ??????. - intros [| a]; term_simpl; solve_proper. - Qed. - - Program Definition ren_scope {S S'} (δ : S [→] S') (env : interp_scope S') - : interp_scope S := λne x, env (δ x). - -End interp. - -(* Common definitions and lemmas for Kripke logical relations *) -Section kripke_logrel. - Variable s : stuckness. - - Context {sz : nat}. - Variable rs : gReifiers sz. - Context {R} `{!Cofe R}. - - Notation F := (gReifiers_ops rs). - Notation IT := (IT F R). - Notation ITV := (ITV F R). - Context `{!invGS Σ, !stateG rs R Σ}. - Notation iProp := (iProp Σ). - - Context {A:ofe}. (* The type & predicate for the explicit Kripke worlds *) - Variable (P : A -n> iProp). - - Implicit Types α β : IT. - Implicit Types αv βv : ITV. - Implicit Types Φ Ψ : ITV -n> iProp. - - Program Definition expr_pred (α : IT) (Φ : ITV -n> iProp) : iProp := - (∀ x : A, P x -∗ wp rs α s ⊤ (λne v, ∃ y : A, Φ v ∗ P y)). - Next Obligation. - solve_proper. - Qed. - - Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : - Φ αv ⊢ expr_pred α Φ. - Proof. - iIntros "H". - iIntros (x) "Hx". iApply wp_val. - simpl. - iExists x. - by iFrame. - Qed. - - Lemma expr_pred_frame α Φ : - WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. - Proof. - iIntros "H". - iIntros (x) "Hx". - iApply (wp_wand with "H"). - simpl. - iIntros (v) "Hv". - iExists x. - by iFrame. - Qed. - -End kripke_logrel. diff --git a/theories/program_logic.v b/theories/program_logic.v index eb86191..d4d514f 100644 --- a/theories/program_logic.v +++ b/theories/program_logic.v @@ -2,9 +2,9 @@ From gitrees Require Import gitree. Section program_logic. - Context {sz : nat}. - Variable rs : gReifiers sz. - Notation F := (gReifiers_ops rs). + Context {sz : nat} {a : is_ctx_dep}. + Variable rs : gReifiers a sz. + Notation F := (gReifiers_ops a rs). Context {R} `{!Cofe R}. Notation IT := (IT F R). Notation ITV := (ITV F R). @@ -26,21 +26,18 @@ End program_logic. Section program_logic_ctx_indep. Context {sz : nat}. - Variable rs : gReifiers sz. - Notation F := (gReifiers_ops rs). + Variable rs : gReifiers NotCtxDep sz. + Notation F := (gReifiers_ops NotCtxDep rs). Context {R} `{!Cofe R}. Notation IT := (IT F R). Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - Context {HCI : ∀ o : opid (sReifier_ops (gReifiers_sReifier rs)), - CtxIndep (gReifiers_sReifier rs) - (ITF_solution.IT (sReifier_ops (gReifiers_sReifier rs)) R) o}. Lemma wp_seq α β s Φ `{!NonExpansive Φ} : WP@{rs} α @ s {{ _, WP@{rs} β @ s {{ Φ }} }} ⊢ WP@{rs} SEQ α β @ s {{ Φ }}. - Proof using HCI. + Proof. iIntros "H". iApply (wp_bind _ (SEQCtx β)). iApply (wp_wand with "H"). @@ -50,7 +47,7 @@ Section program_logic_ctx_indep. Lemma wp_let α (f : IT -n> IT) s Φ `{!NonExpansive Φ} : WP@{rs} α @ s {{ αv, WP@{rs} f (IT_of_V αv) @ s {{ Φ }} }} ⊢ WP@{rs} (LET α f) @ s {{ Φ }}. - Proof using HCI. + Proof. iIntros "H". iApply (wp_bind _ (LETCTX f)). iApply (wp_wand with "H"). From d5cbc7756e021530cc54b6cc7afe3f163cf9ee31 Mon Sep 17 00:00:00 2001 From: Kaptch Date: Tue, 30 Jan 2024 23:11:17 +0100 Subject: [PATCH 089/114] coercion --- theories/gitree/reify.v | 20 ++++++++++++++++++++ theories/lang_generic.v | 13 +++++++++++++ 2 files changed, 33 insertions(+) diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 49e5deb..4ba8243 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -31,6 +31,26 @@ Section reifier. }. End reifier. +Section reifier_coercion. + Context {A} `{!Cofe A}. + #[local] Open Scope type. + Program Definition sReifier_NotCtxDep_CtxDep (r : sReifier NotCtxDep) + : sReifier CtxDep := + {| + sReifier_ops := sReifier_ops _ r; + sReifier_state := sReifier_state _ r; + sReifier_re x xc op := + (λne y, (optionO_map (prodO_map y.2 idfun) + (sReifier_re _ r op (y.1.1, y.1.2)))); + sReifier_inhab := sReifier_inhab _ r; + sReifier_cofe := sReifier_cofe _ r; + |}. + Next Obligation. + intros. + repeat intro; repeat f_equiv; assumption. + Qed. +End reifier_coercion. + Section reifier_cofe_inst. Context {A} `{!Cofe A}. #[local] Open Scope type. diff --git a/theories/lang_generic.v b/theories/lang_generic.v index 144c061..a4a3663 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -26,6 +26,19 @@ Section interp. solve_proper. Qed. + Definition interp_scope_split {S1 S2 : Set} : + interp_scope (sum S1 S2) -n> interp_scope S1 * interp_scope S2. + Proof. + simple refine (λne (f : interp_scope (sum S1 S2)), _). + - split. + + simple refine (λne x, _). + apply (f (inl x)). + + simple refine (λne x, _). + apply (f (inr x)). + - repeat intro; simpl. + repeat f_equiv; intro; simpl; f_equiv; assumption. + Defined. + Global Instance interp_var_proper {S : Set} (v : S) : Proper ((≡) ==> (≡)) (interp_var v). Proof. apply ne_proper. apply _. Qed. From 3c34ea1e8ebcbc195243dc297f3d46e4eefb224b Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 1 Feb 2024 00:28:03 +0100 Subject: [PATCH 090/114] refactoring (affine) --- _CoqProject | 40 +- theories/affine_lang/logrel1.v | 493 ---------- theories/{examples => effects}/store.v | 1 - theories/{ => examples}/affine_lang/lang.v | 113 ++- theories/examples/affine_lang/logrel1.v | 931 ++++++++++++++++++ theories/{ => examples}/affine_lang/logrel2.v | 182 ++-- theories/{ => examples}/input_lang/interp.v | 2 +- theories/{ => examples}/input_lang/lang.v | 0 theories/{ => examples}/input_lang/logpred.v | 2 +- theories/{ => examples}/input_lang/logrel.v | 2 +- .../{ => examples}/input_lang_callcc/hom.v | 2 +- .../{ => examples}/input_lang_callcc/interp.v | 2 +- .../{ => examples}/input_lang_callcc/lang.v | 0 .../{ => examples}/input_lang_callcc/logrel.v | 2 +- theories/lang_affine.v | 245 ----- theories/{examples => lib}/factorial.v | 6 +- theories/{examples => lib}/iter.v | 0 theories/{examples => lib}/pairs.v | 0 theories/{examples => lib}/while.v | 0 19 files changed, 1128 insertions(+), 895 deletions(-) delete mode 100644 theories/affine_lang/logrel1.v rename theories/{examples => effects}/store.v (99%) rename theories/{ => examples}/affine_lang/lang.v (69%) create mode 100644 theories/examples/affine_lang/logrel1.v rename theories/{ => examples}/affine_lang/logrel2.v (77%) rename theories/{ => examples}/input_lang/interp.v (99%) rename theories/{ => examples}/input_lang/lang.v (100%) rename theories/{ => examples}/input_lang/logpred.v (99%) rename theories/{ => examples}/input_lang/logrel.v (99%) rename theories/{ => examples}/input_lang_callcc/hom.v (98%) rename theories/{ => examples}/input_lang_callcc/interp.v (99%) rename theories/{ => examples}/input_lang_callcc/lang.v (100%) rename theories/{ => examples}/input_lang_callcc/logrel.v (99%) delete mode 100644 theories/lang_affine.v rename theories/{examples => lib}/factorial.v (97%) rename theories/{examples => lib}/iter.v (100%) rename theories/{examples => lib}/pairs.v (100%) rename theories/{examples => lib}/while.v (100%) diff --git a/_CoqProject b/_CoqProject index e8cf1c7..4ef1b32 100644 --- a/_CoqProject +++ b/_CoqProject @@ -16,7 +16,6 @@ vendor/Binding/Resolver.v theories/prelude.v theories/lang_generic.v -theories/lang_affine.v theories/gitree/core.v theories/gitree/subofe.v @@ -29,22 +28,23 @@ theories/gitree.v theories/program_logic.v -theories/input_lang_callcc/lang.v -theories/input_lang_callcc/interp.v -theories/input_lang_callcc/hom.v -theories/input_lang_callcc/logrel.v - -theories/input_lang/lang.v -theories/input_lang/interp.v -theories/input_lang/logpred.v -theories/input_lang/logrel.v - -theories/affine_lang/lang.v -theories/affine_lang/logrel1.v -theories/affine_lang/logrel2.v - -theories/examples/store.v -theories/examples/pairs.v -theories/examples/while.v -theories/examples/factorial.v -theories/examples/iter.v +theories/examples/input_lang_callcc/lang.v +theories/examples/input_lang_callcc/interp.v +theories/examples/input_lang_callcc/hom.v +theories/examples/input_lang_callcc/logrel.v + +theories/examples/input_lang/lang.v +theories/examples/input_lang/interp.v +theories/examples/input_lang/logpred.v +theories/examples/input_lang/logrel.v + +theories/examples/affine_lang/lang.v +theories/examples/affine_lang/logrel1.v +theories/examples/affine_lang/logrel2.v + +theories/effects/store.v + +theories/lib/pairs.v +theories/lib/while.v +theories/lib/factorial.v +theories/lib/iter.v diff --git a/theories/affine_lang/logrel1.v b/theories/affine_lang/logrel1.v deleted file mode 100644 index b5757b3..0000000 --- a/theories/affine_lang/logrel1.v +++ /dev/null @@ -1,493 +0,0 @@ -(** Unary (Kripke) logical relation for the affine lang *) -From Equations Require Import Equations. -From gitrees Require Export lang_affine gitree program_logic. -From gitrees.affine_lang Require Import lang. -From gitrees.examples Require Import store pairs. -Require Import iris.algebra.gmap. - -Local Notation tyctx := (tyctx ty). - -Inductive typed : forall {S}, tyctx S → expr S → ty → Prop := -(** functions *) -| typed_Var {S} (Ω : tyctx S) (τ : ty) (v : var S) : - typed_var Ω v τ → - typed Ω (Var v) τ -| typed_Lam {S} (Ω : tyctx S) (τ1 τ2 : ty) (e : expr (()::S) ) : - typed (consC τ1 Ω) e τ2 → - typed Ω (Lam e) (tArr τ1 τ2) -| typed_App {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : - typed Ω1 e1 (tArr τ1 τ2) → - typed Ω2 e2 τ1 → - typed (tyctx_app Ω1 Ω2) (App e1 e2) τ2 -(** pairs *) -| typed_Pair {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : - typed Ω1 e1 τ1 → - typed Ω2 e2 τ2 → - typed (tyctx_app Ω1 Ω2) (EPair e1 e2) (tPair τ1 τ2) -| typed_Destruct {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 τ : ty) - (e1 : expr S1) (e2 : expr (()::()::S2)) : - typed Ω1 e1 (tPair τ1 τ2) → - typed (consC τ1 (consC τ2 Ω2)) e2 τ → - typed (tyctx_app Ω1 Ω2) (EDestruct e1 e2) τ -(** references *) -| typed_Alloc {S} (Ω : tyctx S) τ e : - typed Ω e τ → - typed Ω (Alloc e) (tRef τ) -| typed_Replace {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : - typed Ω1 e1 (tRef τ1) → - typed Ω2 e2 τ2 → - typed (tyctx_app Ω1 Ω2) (Replace e1 e2) (tPair τ1 (tRef τ2)) -| typed_Dealloc {S} (Ω : tyctx S) e τ : - typed Ω e (tRef τ) → - typed Ω (Dealloc e) tUnit -(** literals *) -| typed_Nat {S} (Ω : tyctx S) n : - typed Ω (LitNat n) tInt -| typed_Bool {S} (Ω : tyctx S) b : - typed Ω (LitBool b) tBool -| typed_Unit {S} (Ω : tyctx S) : - typed Ω LitUnit tUnit -. - -Section logrel. - Context {sz : nat}. - Variable rs : gReifiers NotCtxDep sz. - Context `{!subReifier reify_store rs}. - Context `{!subReifier input_lang.interp.reify_io rs}. - Notation F := (gReifiers_ops NotCtxDep rs). - Context {R} `{!Cofe R}. - Context `{!SubOfe natO R}. - Context `{!SubOfe unitO R}. - Context `{!SubOfe locO R}. - Notation IT := (IT F R). - Notation ITV := (ITV F R). - Context `{!invGS Σ, !stateG rs R Σ, !heapG rs R Σ}. - Notation iProp := (iProp Σ). - - (* parameters for the kripke logical relation *) - Variable s : stuckness. - Context `{A:ofe}. - Variable (P : A -n> iProp). - Local Notation expr_pred := (expr_pred s rs P). - - (* interpreting tys *) - Program Definition protected (Φ : ITV -n> iProp) : ITV -n> iProp := λne αv, - (WP@{rs} Force (IT_of_V αv) @ s {{ Φ }})%I. - Solve All Obligations with solve_proper_please. - Program Definition interp_tbool : ITV -n> iProp := λne αv, - (αv ≡ RetV 0 ∨ αv ≡ RetV 1)%I. - Solve All Obligations with solve_proper_please. - Program Definition interp_tnat : ITV -n> iProp := λne αv, - (∃ n : nat, αv ≡ RetV n)%I. - Solve All Obligations with solve_proper_please. - Program Definition interp_tunit : ITV -n> iProp := λne αv, - (αv ≡ RetV ())%I. - Solve All Obligations with solve_proper_please. - Program Definition interp_tpair (Φ1 Φ2 : ITV -n> iProp) : ITV -n> iProp := λne αv, - (∃ β1v β2v, IT_of_V αv ≡ pairITV (IT_of_V β1v) (IT_of_V β2v) ∗ - Φ1 β1v ∗ Φ2 β2v)%I. - Solve All Obligations with solve_proper_please. - Program Definition interp_tarr (Φ1 Φ2 : ITV -n> iProp) : ITV -n> iProp := λne αv, - (∀ βv, Φ1 βv -∗ expr_pred ((IT_of_V αv) ⊙ (Thunk (IT_of_V βv))) Φ2)%I. - Solve All Obligations with solve_proper_please. - - Program Definition interp_ref (Φ : ITV -n> iProp) : ITV -n> iProp := λne αv, - (∃ (l : loc) βv, αv ≡ RetV l ∗ pointsto l (IT_of_V βv) ∗ Φ βv)%I. - Solve All Obligations with solve_proper_please. - - Fixpoint interp_ty (τ : ty) : ITV -n> iProp := - match τ with - | tBool => interp_tbool - | tUnit => interp_tunit - | tInt => interp_tnat - | tPair τ1 τ2 => interp_tpair (interp_ty τ1) (interp_ty τ2) - | tArr τ1 τ2 => interp_tarr (interp_ty τ1) (interp_ty τ2) - | tRef τ => interp_ref (interp_ty τ) - end. - - Definition ssubst_valid {S} (Ω : tyctx S) ss := - lang_affine.ssubst_valid rs (λ τ, protected (interp_ty τ)) Ω ss. - - Definition valid1 {S} (Ω : tyctx S) (α : interp_scope S -n> IT) (τ : ty) : iProp := - ∀ ss, heap_ctx -∗ ssubst_valid Ω ss -∗ expr_pred (α (interp_ssubst ss)) (interp_ty τ). - - Lemma compat_pair {S1 S2} (Ω1: tyctx S1) (Ω2:tyctx S2) α β τ1 τ2 : - ⊢ valid1 Ω1 α τ1 -∗ - valid1 Ω2 β τ2 -∗ - valid1 (tyctx_app Ω1 Ω2) (interp_pair α β ◎ interp_scope_split) (tPair τ1 τ2). - Proof. - Opaque pairITV. - iIntros "H1 H2". - iIntros (αs) "#Hctx Has". - cbn-[interp_pair]. - unfold ssubst_valid. - rewrite ssubst_valid_app. - rewrite interp_scope_ssubst_split. - iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. - iSpecialize ("H1" with "Hctx Ha1"). - iSpecialize ("H2" with "Hctx Ha2"). - iApply (expr_pred_bind with "H2"). - iIntros (βv) "Hb". simpl. - rewrite -> get_val_ITV. simpl. - iApply (expr_pred_bind with "H1"). - iIntros (αv) "Ha". simpl. - rewrite -> get_val_ITV. simpl. - iApply expr_pred_ret. - iExists _,_. iFrame. done. - Qed. - - Lemma compat_destruct {S1 S2} (Ω1: tyctx S1) (Ω2:tyctx S2) α β τ1 τ2 τ : - ⊢ valid1 Ω1 α (tPair τ1 τ2) -∗ - valid1 (consC τ1 $ consC τ2 Ω2) β τ -∗ - valid1 (tyctx_app Ω1 Ω2) (interp_destruct α β ◎ interp_scope_split) τ. - Proof. - Opaque pairITV thunked thunkedV projIT1 projIT2. - iIntros "H1 H2". - iIntros (αs) "#Hctx Has". - cbn-[interp_destruct]. - unfold ssubst_valid. - rewrite ssubst_valid_app. - rewrite interp_scope_ssubst_split. - iDestruct "Has" as "[Ha1 Ha2]". - iSpecialize ("H1" with "Hctx Ha1"). - simpl. iApply (expr_pred_bind (LETCTX _) with "H1"). - iIntros (αv) "Ha". unfold LETCTX. simpl. - rewrite LET_Val/=. - iDestruct "Ha" as (β1 β2) "[#Ha [Hb1 Hb2]]". - iIntros (x) "Hx". - iApply wp_let. - { solve_proper. } - iApply (wp_Thunk with "Hctx"). - { solve_proper_please. } - iNext. iIntros (l1) "Hl1". simpl. - iApply wp_let. - { solve_proper. } - iApply (wp_Thunk with "Hctx"). - { solve_proper_please. } - iNext. iIntros (l2) "Hl2". simpl. - iSpecialize ("H2" $! (cons_ssubst (thunkedV (projIT1 (IT_of_V αv)) l1) - $ cons_ssubst (thunkedV (projIT2 (IT_of_V αv)) l2) (ssubst_split αs).2) - with "Hctx [-Hx] Hx"). - { unfold ssubst_valid. rewrite !ssubst_valid_cons. - iFrame. Transparent thunkedV thunked. - iSplitL "Hb1 Hl1". - - simpl. iApply wp_lam. simpl. iNext. - iApply (wp_bind _ (IFSCtx _ _)). - iApply (wp_read with "Hctx Hl1"). - iNext. iNext. iIntros "Hl1". - iApply wp_val. iModIntro. unfold IFSCtx. - rewrite IF_False; last lia. - iApply wp_seq. - { solve_proper. } - iApply (wp_write with "Hctx Hl1"). - iNext. iNext. iIntros "Hl1". - iRewrite "Ha". - rewrite projIT1_pairV. simpl. - repeat iApply wp_tick. - repeat iNext. iApply wp_val. done. - - simpl. iApply wp_lam. simpl. iNext. - iApply (wp_bind _ (IFSCtx _ _)). - iApply (wp_read with "Hctx Hl2"). - iNext. iNext. iIntros "Hl2". - iApply wp_val. iModIntro. unfold IFSCtx. - rewrite IF_False; last lia. - iApply wp_seq. - { solve_proper. } - iApply (wp_write with "Hctx Hl2"). - iNext. iNext. iIntros "Hl2". - iRewrite "Ha". - rewrite projIT2_pairV. simpl. - repeat iApply wp_tick. - repeat iNext. iApply wp_val. done. - } - simp interp_ssubst. - iApply "H2". - Qed. - - Lemma compat_alloc {S} (Ω : tyctx S) α τ: - ⊢ valid1 Ω α τ -∗ - valid1 Ω (interp_alloc α) (tRef τ). - Proof. - iIntros "H". - iIntros (αs) "#Hctx Has". - iSpecialize ("H" with "Hctx Has"). - simpl. iApply (expr_pred_bind (LETCTX _) with "H"). - iIntros (αv) "Hav". unfold LETCTX. simpl. - rewrite LET_Val/=. - iApply expr_pred_frame. - iApply (wp_alloc with "Hctx"). - iNext. iNext. iIntros (l) "Hl". - iApply wp_val. iModIntro. simpl. - eauto with iFrame. - Qed. - - Lemma compat_replace {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) α β τ τ' : - ⊢ valid1 Ω1 α (tRef τ) -∗ - valid1 Ω2 β τ' -∗ - valid1 (tyctx_app Ω1 Ω2) (interp_replace α β ◎ interp_scope_split) (tPair τ (tRef τ')). - Proof. - Opaque pairITV. - iIntros "H1 H2". - iIntros (αs) "#Hctx Has". - cbn-[interp_replace]. - unfold ssubst_valid. - rewrite ssubst_valid_app. - rewrite interp_scope_ssubst_split. - iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. - iSpecialize ("H1" with "Hctx Ha1"). - iSpecialize ("H2" with "Hctx Ha2"). - iApply (expr_pred_bind (LETCTX _) with "H2"). - iIntros (βv) "Hb". unfold LETCTX. simpl. - rewrite LET_Val/=. - iApply (expr_pred_bind with "H1"). - iIntros (αv) "Ha". simpl. - iDestruct "Ha" as (l γ) "[Ha [Hl Hg]]". - iApply expr_pred_frame. - iRewrite "Ha". simpl. - rewrite IT_of_V_Ret. - rewrite -> get_ret_ret; simpl. - iApply wp_let. - { solve_proper. } - iApply (wp_read with "Hctx Hl"). - iNext. iNext. iIntros "Hl". - iApply wp_val. iModIntro. - simpl. iApply wp_seq. - { solve_proper. } - iApply (wp_write with "Hctx Hl"). - iNext. iNext. iIntros "Hl". - rewrite get_val_ITV. simpl. - rewrite get_val_ITV. simpl. - iApply wp_val. iModIntro. - iExists γ,(RetV l). - iSplit; first done. - iFrame. eauto with iFrame. - Qed. - - Lemma compat_dealloc {S} (Ω : tyctx S) α τ: - ⊢ valid1 Ω α (tRef τ) -∗ - valid1 Ω (interp_dealloc α) tUnit. - Proof. - iIntros "H". - iIntros (αs) "#Hctx Has". - iSpecialize ("H" with "Hctx Has"). - iApply (expr_pred_bind with "H"). - iIntros (αv) "Ha /=". - iDestruct "Ha" as (l βv) "[Ha [Hl Hb]]". - iRewrite "Ha". iApply expr_pred_frame. simpl. - rewrite IT_of_V_Ret. rewrite -> get_ret_ret. simpl. - iApply (wp_dealloc with "Hctx Hl"). - iNext. iNext. eauto with iFrame. - Qed. - - Lemma compat_bool {S} b (Ω : tyctx S) : - ⊢ valid1 Ω (interp_litbool b) tBool. - Proof. - iIntros (αs) "#Hctx Has". - iApply expr_pred_ret. - destruct b; simpl; eauto. - Qed. - Lemma compat_nat {S} n (Ω : tyctx S) : - ⊢ valid1 Ω (interp_litnat n) tInt. - Proof. - iIntros (αs) "#Hctx Has". - iApply expr_pred_ret. eauto with iFrame. - Qed. - Lemma compat_unit {S} (Ω : tyctx S) : - ⊢ valid1 Ω interp_litunit tUnit. - Proof. - iIntros (αs) "#Hctx Has". - iApply expr_pred_ret. eauto with iFrame. - Qed. - Lemma compat_var {S} Ω τ (v : var S) : - typed_var Ω v τ → - ⊢ valid1 Ω (Force ◎ interp_var v) τ. - Proof. - iIntros (Hv ss) "#Hctx Has". - iApply expr_pred_frame. - unfold ssubst_valid. - iInduction Hv as [|? ? ? Ω v] "IH" forall (ss); simpl. - - dependent elimination ss as [cons_ssubst αv ss]. - rewrite ssubst_valid_cons. - simp interp_var. simpl. - iDestruct "Has" as "[H _]". - simp interp_ssubst. simpl. done. - - dependent elimination ss as [cons_ssubst αv ss]. - rewrite ssubst_valid_cons. - simp interp_var. simpl. - iDestruct "Has" as "[_ H]". - simp interp_ssubst. simpl. - by iApply ("IH" with "H"). - Qed. - - Lemma compat_app {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) - α β τ1 τ2 : - ⊢ valid1 Ω1 α (tArr τ1 τ2) -∗ - valid1 Ω2 β τ1 -∗ - valid1 (tyctx_app Ω1 Ω2) (interp_app α β ◎ interp_scope_split) τ2. - Proof. - iIntros "H1 H2". - iIntros (αs) "#Hctx Has". - iEval(cbn-[interp_app]). - unfold ssubst_valid. - rewrite ssubst_valid_app. - rewrite interp_scope_ssubst_split. - iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. - iSpecialize ("H1" with "Hctx Ha1"). - iSpecialize ("H2" with "Hctx Ha2"). - Local Opaque Thunk. - iSimpl. - iApply (expr_pred_bind (LETCTX _) with "H2"). - iIntros (βv) "H2". unfold LETCTX. iSimpl. - rewrite LET_Val/=. - iApply (expr_pred_bind (LETCTX _) with "H1"). - iIntros (αv) "H1". unfold LETCTX. iSimpl. - rewrite LET_Val/=. - by iApply "H1". - Qed. - - Lemma compat_lam {S} (Ω : tyctx S) τ1 τ2 α : - ⊢ valid1 (consC τ1 Ω) α τ2 -∗ - valid1 Ω (interp_lam α) (tArr τ1 τ2). - Proof. - iIntros "H". - iIntros (αs) "#Hctx Has". - iIntros (x) "Hx". - iApply wp_val. - iModIntro. simpl. - iExists _; iFrame. - iIntros (βv) "Hb". clear x. - iIntros (x) "Hx". - iApply (wp_bind _ (AppRSCtx _)). - { solve_proper. } - Local Transparent Thunk. - Local Opaque thunked thunkedV. - iSimpl. iApply (wp_alloc with "Hctx"). - { solve_proper. } - iNext. iNext. iIntros (l) "Hl". - iApply wp_val. iModIntro. - unfold AppRSCtx. - iApply wp_lam. iNext. - iEval(cbn-[thunked]). - iSpecialize ("H" $! (cons_ssubst (thunkedV (IT_of_V βv) l) αs) - with "Hctx [-Hx] Hx"). - { unfold ssubst_valid. - rewrite ssubst_valid_cons. iFrame. - Local Transparent thunked thunkedV. - iApply wp_lam. iNext. simpl. - iApply (wp_bind _ (IFSCtx _ _)). - iApply (wp_read with "Hctx Hl"). - iNext. iNext. iIntros "Hl". - iApply wp_val. iModIntro. - unfold IFSCtx. simpl. - rewrite IF_False; last lia. - iApply wp_seq. - { solve_proper. } - iApply (wp_write with "Hctx Hl"). - iNext. iNext. iIntros "Hl". - iApply wp_val. iModIntro. - iApply "Hb". } - simp interp_ssubst. - iApply "H". - Qed. - - Lemma fundamental_affine {S} (Ω : tyctx S) (e : expr S) τ : - typed Ω e τ → - ⊢ valid1 Ω (interp_expr _ e) τ. - Proof. - induction 1; simpl. - - by iApply compat_var. - - by iApply compat_lam. - - by iApply compat_app. - - by iApply compat_pair. - - by iApply compat_destruct. - - by iApply compat_alloc. - - by iApply compat_replace. - - by iApply compat_dealloc. - - by iApply compat_nat. - - by iApply compat_bool. - - by iApply compat_unit. - Qed. - -End logrel. - -Arguments interp_tarr {_ _ _ _ _ _ _ _ _ _ _ _ _} Φ1 Φ2. -Arguments interp_tbool {_ _ _ _ _ _}. -Arguments interp_tnat {_ _ _ _ _ _}. -Arguments interp_tunit {_ _ _ _ _ _}. -Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} τ. - -Local Definition rs : gReifiers NotCtxDep 2 := - gReifiers_cons NotCtxDep reify_store (gReifiers_cons NotCtxDep input_lang.interp.reify_io (gReifiers_nil NotCtxDep)). - -Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. - -Lemma logrel1_adequacy cr Σ R `{!Cofe R, !SubOfe natO R, !SubOfe unitO R, !SubOfe locO R} `{!invGpreS Σ} - `{!statePreG rs R Σ} `{!heapPreG rs R Σ} τ - (α : unitO -n> IT (gReifiers_ops NotCtxDep rs) R) (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : - (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ}, - (£ cr ⊢ valid1 rs notStuck (λne _: unitO, True)%I empC α τ)%I) → - ssteps (gReifiers_sReifier NotCtxDep rs) (α ()) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep 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 NotCtxDep rs) β st' β1 st1) - ∨ (∃ e, β ≡ Err e ∧ notStuck e)). - { intros [?|He]; first done. - destruct He as [? [? []]]. } - eapply (wp_safety (S cr)); eauto. - { apply Hdisj. } - { by rewrite Hb. } - intros H1 H2. - exists (λ _, True)%I. split. - { apply _. } - iIntros "[[Hone Hcr] Hst]". - pose (σ := st.1). - pose (ios := st.2.1). - iMod (new_heapG rs σ) as (H3) "H". - iAssert (has_substate σ ∗ has_substate ios)%I with "[Hst]" as "[Hs Hio]". - { unfold has_substate, has_full_state. - assert (of_state NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) st ≡ - of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state σ) - ⋅ of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state ios)) as ->; last first. - { rewrite -own_op. done. } - unfold sR_idx. simpl. - intro j. - rewrite discrete_fun_lookup_op. - inv_fin j. - { unfold of_state, of_idx. simpl. - erewrite (eq_pi _ _ _ (@eq_refl _ 0%fin)). done. } - intros j. inv_fin j. - { unfold of_state, of_idx. simpl. - erewrite (eq_pi _ _ _ (@eq_refl _ 1%fin)). done. } - intros i. inversion i. } - iApply fupd_wp. - iMod (inv_alloc (nroot.@"storeE") _ (∃ σ, £ 1 ∗ has_substate σ ∗ own (heapG_name rs) (●V σ))%I with "[-Hcr]") as "#Hinv". - { iNext. iExists _. iFrame. } - simpl. - iPoseProof (@Hlog _ _ _ with "Hcr") as "Hlog". - iSpecialize ("Hlog" $! emp_ssubst with "Hinv []"). - { iApply ssubst_valid_nil. } - iSpecialize ("Hlog" $! tt with "[//]"). - iModIntro. - iApply (wp_wand with "Hlog"). - eauto with iFrame. -Qed. - -Definition R := sumO locO (sumO unitO natO). - -Lemma logrel1_safety e τ (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : - typed empC e τ → - ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ()) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) - ∨ (∃ βv, IT_of_V βv ≡ β). -Proof. - intros Hty Hst. - pose (Σ:=#[invΣ;stateΣ rs R;heapΣ rs R]). - eapply (logrel1_adequacy 0 Σ); eauto; try apply _. - iIntros (? ? ?) "_". - by iApply fundamental_affine. -Qed. diff --git a/theories/examples/store.v b/theories/effects/store.v similarity index 99% rename from theories/examples/store.v rename to theories/effects/store.v index 490ad68..6b72ad6 100644 --- a/theories/examples/store.v +++ b/theories/effects/store.v @@ -1,4 +1,3 @@ -From Equations Require Import Equations. From iris.algebra Require Import gmap excl auth gmap_view. From iris.proofmode Require Import classes tactics. From iris.base_logic Require Import algebra. diff --git a/theories/affine_lang/lang.v b/theories/examples/affine_lang/lang.v similarity index 69% rename from theories/affine_lang/lang.v rename to theories/examples/affine_lang/lang.v index 9616cb1..3e5505f 100644 --- a/theories/affine_lang/lang.v +++ b/theories/examples/affine_lang/lang.v @@ -1,6 +1,7 @@ From gitrees Require Export lang_generic gitree program_logic. -From gitrees.input_lang Require Import lang interp. -From gitrees.examples Require Import store pairs. +From gitrees.examples.input_lang Require Import lang interp. +From gitrees.effects Require Import store. +From gitrees.lib Require Import pairs. (* for namespace sake *) Module io_lang. @@ -14,15 +15,13 @@ Module io_lang. input_lang.interp.interp_expr rs e (ı_scope rs). End io_lang. -From gitrees Require Export lang_affine. +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. Inductive ty := tBool | tInt | tUnit | tArr (τ1 τ2 : ty) | tPair (τ1 τ2 : ty) | tRef (τ : ty). -Local Notation tyctx := (tyctx ty). - Inductive ty_conv : ty → io_lang.ty → Type := | ty_conv_bool : ty_conv tBool Tnat | ty_conv_int : ty_conv tInt Tnat @@ -32,19 +31,19 @@ Inductive ty_conv : ty → io_lang.ty → Type := ty_conv (tArr τ1 τ2) (Tarr (Tarr Tnat t1) t2) . -Inductive expr : scope → Type := -| LitBool (b : bool) {S} : expr S -| LitNat (n : nat) {S} : expr S -| LitUnit {S} : expr S -| Lam {S} : expr (tt::S) → expr S -| Var {S} : var S → expr S -| App {S1 S2} : expr S1 → expr S2 → expr (S1++S2) -| EPair {S1 S2} : expr S1 → expr S2 → expr (S1++S2) -| EDestruct {S1 S2} : expr S1 → expr (()::()::S2) → expr (S1++S2) -| Alloc {S} : expr S → expr S -| Replace {S1 S2} : expr S1 → expr S2 → expr (S1++S2) -| Dealloc {S} : expr S → expr S -| EEmbed {τ1 τ1' S} : io_lang.expr Empty_set → ty_conv τ1 τ1' → expr S +Inductive expr : ∀ (S : Set), Type := +| LitBool {S : Set} (b : bool) : expr S +| LitNat {S : Set} (n : nat) : expr S +| LitUnit {S : Set} : expr S +| Lam {S : Set} : expr (inc S) → expr S +| Var {S : Set} : S → expr S +| App {S1 S2 : Set} : expr S1 → expr S2 → expr (sum S1 S2) +| EPair {S1 S2 : Set} : expr S1 → expr S2 → expr (sum S1 S2) +| EDestruct {S1 S2 : Set} : expr S1 → expr (inc (inc S2)) → expr (sum S1 S2) +| Alloc {S : Set} : expr S → expr S +| Replace {S1 S2 : Set} : expr S1 → expr S2 → expr (sum S1 S2) +| Dealloc {S : Set} : expr S → expr S +| EEmbed {S : Set} {τ1 τ1'} : io_lang.expr Empty_set → ty_conv τ1 τ1' → expr S . Section affine. @@ -64,9 +63,11 @@ Section affine. λit _, IF (READ ℓ) (Err OtherError) (SEQ (WRITE ℓ (Ret 1)) e). Solve All Obligations with first [solve_proper|solve_proper_please]. + Program Definition thunkedV : IT -n> locO -n> ITV := λne e ℓ, FunV $ Next (λne _, IF (READ ℓ) (Err OtherError) (SEQ (WRITE ℓ (Ret 1)) e)). Solve All Obligations with first [solve_proper|solve_proper_please]. + #[export] Instance thunked_into_val e l : IntoVal (thunked e l) (thunkedV e l). Proof. unfold IntoVal. simpl. f_equiv. f_equiv. intro. done. @@ -75,45 +76,52 @@ Section affine. Program Definition Thunk : IT -n> IT := λne e, ALLOC (Ret 0) (thunked e). Solve All Obligations with first [solve_proper|solve_proper_please]. + Program Definition Force : IT -n> IT := λne e, e ⊙ (Ret 0). Local Open Scope type. Definition interp_litbool {A} (b : bool) : A -n> IT := λne _, - Ret (if b then 1 else 0). + Ret (if b then 1 else 0). + Definition interp_litnat {A} (n : nat) : A -n> IT := λne _, - Ret n. + Ret n. + Definition interp_litunit {A} : A -n> IT := λne _, Ret tt. + Program Definition interp_pair {A1 A2} (t1 : A1 -n> IT) (t2 : A2 -n> IT) - : A1*A2 -n> IT := λne env, + : A1 * A2 -n> IT := λne env, pairIT (t1 env.1) (t2 env.2). (* we don't need to evaluate the pair here, i.e. lazy pairs? *) Next Obligation. solve_proper_please. Qed. - Program Definition interp_lam {A : ofe} (b : (IT * A) -n> IT) : A -n> IT := λne env, - λit x, b (x,env). - Solve All Obligations with solve_proper_please. + + Program Definition interp_lam {S : Set} (b : @interp_scope F R _ (inc S) -n> IT) : @interp_scope F R _ S -n> IT := λne env, (λit x, (b (@extend_scope F R _ _ env x))). + Next Obligation. + intros; repeat intro; repeat f_equiv; assumption. + Qed. + Next Obligation. + intros; repeat intro; repeat f_equiv; intro; simpl; + f_equiv; intro z; simpl. + destruct z; done. + Qed. + Program Definition interp_app {A1 A2 : ofe} (t1 : A1 -n> IT) (t2 : A2 -n> IT) : A1*A2 -n> IT := λne env, LET (t2 env.2) $ λne x, LET (t1 env.1) $ λne f, APP' f (Thunk x). Solve All Obligations with solve_proper_please. - Program Definition interp_destruct {A1 A2 : ofe} - (ps : A1 -n> IT) (t : IT*(IT*A2) -n> IT) - : A1*A2 -n> IT := λne env, - LET (ps env.1) $ λne ps, - LET (Thunk (projIT1 ps)) $ λne x, - LET (Thunk (projIT2 ps)) $ λne y, - t (x, (y, env.2)). - Solve All Obligations with solve_proper_please. + Program Definition interp_alloc {A} (α : A -n> IT) : A -n> IT := λne env, LET (α env) $ λne α, ALLOC α Ret. Solve All Obligations with solve_proper_please. + Program Definition interp_replace {A1 A2} (α : A1 -n> IT) (β : A2 -n> IT) : A1*A2 -n> IT := λne env, LET (β env.2) $ λne β, flip get_ret (α env.1) $ λne (l : loc), LET (READ l) $ λne γ, SEQ (WRITE l β) (pairIT γ (Ret l)). Solve All Obligations with solve_proper_please. + Program Definition interp_dealloc {A} (α : A -n> IT) : A -n> IT := λne env, get_ret DEALLOC (α env). Solve All Obligations with solve_proper_please. @@ -154,6 +162,35 @@ Section affine. | ty_conv_fun conv1 conv2 => glue_from_affine_fun (glue_from_affine conv2) (glue_to_affine conv1) end. + Program Definition interp_destruct {S1 S2 : Set} + (ps : @interp_scope F R _ S1 -n> IT) + (t : (@interp_scope F R _ (inc (inc S2)) -n> IT)) + : (@interp_scope F R _ S1 * @interp_scope F R _ S2) -n> IT + := λne env, + LET (ps env.1) $ λne z, + LET (Thunk (projIT1 z)) $ λne x, + LET (Thunk (projIT2 z)) $ λne y, + (t (@extend_scope F R _ _ (@extend_scope F R _ _ env.2 y) x)). + Next Obligation. + intros; repeat intro; repeat f_equiv; assumption. + Qed. + Next Obligation. + intros; repeat intro; repeat f_equiv; intro; simpl; f_equiv; intro A; simpl. + destruct A as [| [|]]; [assumption | reflexivity | reflexivity]. + Qed. + Next Obligation. + intros; repeat intro; repeat f_equiv; first assumption. + intro; simpl; f_equiv; intro; simpl. + repeat f_equiv; intro; simpl; repeat f_equiv; intro; simpl. + repeat f_equiv; assumption. + Qed. + Next Obligation. + intros; repeat intro; repeat f_equiv; first assumption. + intro; simpl; f_equiv; intro; simpl. + repeat f_equiv; intro; simpl; repeat f_equiv; intro A; simpl. + destruct A as [| [|]]; [reflexivity | reflexivity |]. + repeat f_equiv; assumption. + Qed. Fixpoint interp_expr {S} (e : expr S) : interp_scope S -n> IT := match e with @@ -162,12 +199,16 @@ Section affine. | LitUnit => interp_litunit | Var v => Force ◎ interp_var v | Lam e => interp_lam (interp_expr e) - | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) ◎ interp_scope_split - | EPair e1 e2 => interp_pair (interp_expr e1) (interp_expr e2) ◎ interp_scope_split - | EDestruct e1 e2 => interp_destruct (interp_expr e1) (interp_expr e2) ◎ interp_scope_split + | App e1 e2 => + interp_app (interp_expr e1) (interp_expr e2) ◎ interp_scope_split + | EPair e1 e2 => + interp_pair (interp_expr e1) (interp_expr e2) ◎ interp_scope_split + | EDestruct e1 e2 => + interp_destruct (interp_expr e1) (interp_expr e2) ◎ interp_scope_split | Alloc e => interp_alloc (interp_expr e) | Dealloc e => interp_dealloc (interp_expr e) - | Replace e1 e2 => interp_replace (interp_expr e1) (interp_expr e2) ◎ interp_scope_split + | Replace e1 e2 => + interp_replace (interp_expr e1) (interp_expr e2) ◎ interp_scope_split | EEmbed e tconv => constO $ glue_to_affine tconv (io_lang.interp_closed _ e) end. diff --git a/theories/examples/affine_lang/logrel1.v b/theories/examples/affine_lang/logrel1.v new file mode 100644 index 0000000..50b2fcd --- /dev/null +++ b/theories/examples/affine_lang/logrel1.v @@ -0,0 +1,931 @@ +(** Unary (Kripke) logical relation for the affine lang *) +From gitrees Require Export gitree program_logic. +From gitrees.examples.affine_lang Require Import lang. +From gitrees.effects Require Import store. +From gitrees.lib Require Import pairs. +Require Import iris.algebra.gmap. +Require Import stdpp.finite. + +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. + +Lemma fin_to_set_sum {S1 S2 : Set} `{EqDecision S1} `{EqDecision S2} `{EqDecision (S1 + S2)} + `{Finite S1} `{Finite S2} `{Finite (S1 + S2)} + `{Countable S1} `{Countable S2} `{Countable (S1 + S2)} + : let A1 : gset S1 := (fin_to_set S1) in + let A2 : gset (S1 + S2) := set_map (inl : S1 → S1 + S2) A1 in + let B1 : gset S2 := (fin_to_set S2) in + let B2 : gset (S1 + S2) := set_map (inr : S2 → S1 + S2) B1 in + let C : gset (S1 + S2) := fin_to_set (S1 + S2) in + C = A2 ∪ B2. +Proof. + apply set_eq. + intros [x|x]; simpl; split; intros _. + - apply elem_of_union; left. + apply elem_of_map_2. + apply elem_of_fin_to_set. + - apply elem_of_fin_to_set. + - apply elem_of_union; right. + apply elem_of_map_2. + apply elem_of_fin_to_set. + - apply elem_of_fin_to_set. +Qed. + +Lemma fin_to_set_empty : + let A : gset ∅ := fin_to_set ∅ in + let B : gset ∅ := empty in + A = B. +Proof. + apply set_eq; intros []. +Qed. + +Section InstSum. + Global Instance EqDecisionLeft {S1 S2 : Set} {H : EqDecision (S1 + S2)} : EqDecision S1. + Proof. + intros x y. + destruct (decide (inl x = inl y)) as [G | G]; + [left; by inversion G | right; intros C; by subst]. + Qed. + + Global Instance EqDecisionRight {S1 S2 : Set} {H : EqDecision (S1 + S2)} : EqDecision S2. + Proof. + intros x y. + destruct (decide (inr x = inr y)) as [G | G]; + [left; by inversion G | right; intros C; by subst]. + Qed. + + Global Instance FiniteLeft {S1 S2 : Set} `{EqDecision S1} + `{EqDecision (S1 + S2)} `{Finite (S1 + S2)} + : Finite S1. + Proof. + unshelve econstructor. + - apply (foldr (λ x acc, match x with + | inl x => x :: acc + | inr _ => acc + end) [] (enum (S1 + S2))). + - set (l := enum (S1 + S2)). + assert (NoDup l) as K; first apply NoDup_enum. + clearbody l. + induction l as [| a l IH]; first constructor. + destruct a as [a | a]; simpl. + + constructor. + * intros C. + assert (inl a ∈ l) as C'. + { + clear -C. + induction l as [| b l IH]; first inversion C. + destruct b as [b | b]; simpl. + - rewrite foldr_cons in C. + rewrite elem_of_cons in C. + destruct C as [-> | C]. + + apply elem_of_cons. + by left. + + right. + apply IH. + apply C. + - apply elem_of_cons. + right. + rewrite foldr_cons in C. + apply IH. + apply C. + } + by inversion K. + * apply IH. + by inversion K. + + apply IH. + by inversion K. + - intros x. + set (l := enum (S1 + S2)). + assert (inl x ∈ l) as K; first apply elem_of_enum. + clearbody l. + induction l as [| a l IH]; first inversion K. + destruct a as [a | a]; simpl. + + rewrite elem_of_cons in K. + destruct K as [K | K]. + * inversion K; subst. + apply elem_of_cons; by left. + * apply elem_of_cons; right; by apply IH. + + rewrite elem_of_cons in K. + destruct K as [K | K]; first inversion K. + by apply IH. + Qed. + + Global Instance FiniteRight {S1 S2 : Set} `{EqDecision S2} + `{EqDecision (S1 + S2)} `{H : Finite (S1 + S2)} + : Finite S2. + Proof. + unshelve econstructor. + - apply (foldr (λ x acc, match x with + | inl _ => acc + | inr x => x :: acc + end) [] (enum (S1 + S2))). + - set (l := enum (S1 + S2)). + assert (NoDup l) as K; first apply NoDup_enum. + clearbody l. + induction l as [| a l IH]; first constructor. + destruct a as [a | a]; simpl. + + apply IH. + by inversion K. + + constructor. + * intros C. + assert (inr a ∈ l) as C'. + { + clear -C. + induction l as [| b l IH]; first inversion C. + destruct b as [b | b]; simpl. + - apply elem_of_cons. + right. + rewrite foldr_cons in C. + apply IH. + apply C. + - rewrite foldr_cons in C. + rewrite elem_of_cons in C. + destruct C as [-> | C]. + + apply elem_of_cons. + by left. + + right. + apply IH. + apply C. + } + by inversion K. + * apply IH. + by inversion K. + - intros x. + set (l := enum (S1 + S2)). + assert (inr x ∈ l) as K; first apply elem_of_enum. + clearbody l. + induction l as [| a l IH]; first inversion K. + destruct a as [a | a]; simpl. + + rewrite elem_of_cons in K. + destruct K as [K | K]; first inversion K. + by apply IH. + + rewrite elem_of_cons in K. + destruct K as [K | K]. + * inversion K; subst. + apply elem_of_cons; by left. + * apply elem_of_cons; right; by apply IH. + Qed. + +End InstSum. + +Section InstInc. + Context (S : Set). + + Global Instance EqDecisionIncN {HS : EqDecision S} (n : nat) : EqDecision (Init.Nat.iter n inc S). + Proof using S. + induction n; simpl. + - apply _. + - intros [|x] [|y]. + + by left. + + by right. + + by right. + + destruct (decide (x = y)) as [-> |]; first by left. + right; by inversion 1. + Qed. + + Global Instance EqDecisionInc {HS : EqDecision S} : EqDecision (inc S). + Proof using S. + assert (inc S = Init.Nat.iter 1 inc S) as ->; first done. + by apply EqDecisionIncN. + Qed. + + Global Instance FiniteIncN {HS : EqDecision S} (HF : Finite S) (n : nat) {HS' : EqDecision (Init.Nat.iter n inc S)} : Finite (Init.Nat.iter n inc S). + Proof using S. + induction n. + - apply (@surjective_finite S HS HF _ _ id). + apply _. + - simpl. + unshelve eapply (@surjective_finite (option (Init.Nat.iter n inc S))); simpl in *. + + intros [x |]. + * apply (VS x). + * apply VZ. + + apply _. + + intros [| x]; simpl. + * exists None; reflexivity. + * exists (Some x); reflexivity. + Qed. + + Global Instance FiniteInc {HS : EqDecision S} (HF : Finite S) (HE : EqDecision (inc S)) : Finite (inc S). + Proof using S. + assert (J : @Finite (Init.Nat.iter 1 inc S) HE). + { apply FiniteIncN, HF. } + simpl in J. + apply J. + Qed. + +End InstInc. + +Definition sum_map' {A B C : Set} (f : A → C) (g : B → C) : sum A B → C := + λ x, match x with | inl x' => f x' | inr x' => g x' end. + +Inductive typed : forall {S : Set}, (S → ty) → expr S → ty → Prop := +(** functions *) +| typed_Var {S : Set} (Ω : S → ty) (v : S) : + typed Ω (Var v) (Ω v) +| typed_Lam {S : Set} (Ω : S → ty) (τ1 τ2 : ty) (e : expr (inc S) ) : + typed (Ω ▹ τ1) e τ2 → + typed Ω (Lam e) (tArr τ1 τ2) +| typed_App {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : + typed Ω1 e1 (tArr τ1 τ2) → + typed Ω2 e2 τ1 → + typed (sum_map' Ω1 Ω2) (App e1 e2) τ2 +(** pairs *) +| typed_Pair {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : + typed Ω1 e1 τ1 → + typed Ω2 e2 τ2 → + typed (sum_map' Ω1 Ω2) (EPair e1 e2) (tPair τ1 τ2) +| typed_Destruct {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 τ : ty) + (e1 : expr S1) (e2 : expr (inc (inc S2))) : + typed Ω1 e1 (tPair τ1 τ2) → + typed ((Ω2 ▹ τ2) ▹ τ1) e2 τ → + typed (sum_map' Ω1 Ω2) (EDestruct e1 e2) τ +(** references *) +| typed_Alloc {S : Set} (Ω : S → ty) τ e : + typed Ω e τ → + typed Ω (Alloc e) (tRef τ) +| typed_Replace {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : + typed Ω1 e1 (tRef τ1) → + typed Ω2 e2 τ2 → + typed (sum_map' Ω1 Ω2) (Replace e1 e2) (tPair τ1 (tRef τ2)) +| typed_Dealloc {S : Set} (Ω : S → ty) e τ : + typed Ω e (tRef τ) → + typed Ω (Dealloc e) tUnit +(** literals *) +| typed_Nat {S : Set} (Ω : S → ty) n : + typed Ω (LitNat n) tInt +| typed_Bool {S : Set} (Ω : S → ty) b : + typed Ω (LitBool b) tBool +| typed_Unit {S : Set} (Ω : S → ty) : + typed Ω LitUnit tUnit +. + +Section logrel. + Context {sz : nat}. + Variable rs : gReifiers NotCtxDep sz. + Context `{!subReifier reify_store rs}. + Context `{!subReifier input_lang.interp.reify_io rs}. + Notation F := (gReifiers_ops NotCtxDep rs). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Context `{!SubOfe unitO R}. + Context `{!SubOfe locO R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ, !heapG rs R Σ}. + Notation iProp := (iProp Σ). + + (* parameters for the kripke logical relation *) + Variable s : stuckness. + Context `{A:ofe}. + Variable (P : A -n> iProp). + Local Notation expr_pred := (expr_pred s rs P). + + (* interpreting tys *) + Program Definition protected (Φ : ITV -n> iProp) : ITV -n> iProp := λne αv, + (WP@{rs} Force (IT_of_V αv) @ s {{ Φ }})%I. + Solve All Obligations with solve_proper_please. + Program Definition interp_tbool : ITV -n> iProp := λne αv, + (αv ≡ RetV 0 ∨ αv ≡ RetV 1)%I. + Solve All Obligations with solve_proper_please. + Program Definition interp_tnat : ITV -n> iProp := λne αv, + (∃ n : nat, αv ≡ RetV n)%I. + Solve All Obligations with solve_proper_please. + Program Definition interp_tunit : ITV -n> iProp := λne αv, + (αv ≡ RetV ())%I. + Solve All Obligations with solve_proper_please. + Program Definition interp_tpair (Φ1 Φ2 : ITV -n> iProp) : ITV -n> iProp := λne αv, + (∃ β1v β2v, IT_of_V αv ≡ pairITV (IT_of_V β1v) (IT_of_V β2v) ∗ + Φ1 β1v ∗ Φ2 β2v)%I. + Solve All Obligations with solve_proper_please. + Program Definition interp_tarr (Φ1 Φ2 : ITV -n> iProp) : ITV -n> iProp := λne αv, + (∀ βv, Φ1 βv -∗ expr_pred ((IT_of_V αv) ⊙ (Thunk (IT_of_V βv))) Φ2)%I. + Solve All Obligations with solve_proper_please. + + Program Definition interp_ref (Φ : ITV -n> iProp) : ITV -n> iProp := λne αv, + (∃ (l : loc), αv ≡ RetV l ∗ ∃ βv, pointsto l (IT_of_V βv) ∗ Φ βv)%I. + Solve All Obligations with solve_proper_please. + + Fixpoint interp_ty (τ : ty) : ITV -n> iProp := + match τ with + | tBool => interp_tbool + | tUnit => interp_tunit + | tInt => interp_tnat + | tPair τ1 τ2 => interp_tpair (interp_ty τ1) (interp_ty τ2) + | tArr τ1 τ2 => interp_tarr (interp_ty τ1) (interp_ty τ2) + | tRef τ => interp_ref (interp_ty τ) + end. + + Program Definition ssubst_valid {S : Set} `{!EqDecision S} `{!Finite S} + (Ω : S → ty) (ss : interp_scope S) : iProp + := ([∗ set] x ∈ (fin_to_set S), + (expr_pred (ss x) (protected (interp_ty (Ω x))))%I). + + Definition valid1 {S : Set} `{!EqDecision S} `{!Finite S} (Ω : S → ty) + (α : interp_scope S -n> IT) (τ : ty) : iProp := + ∀ ss, heap_ctx + -∗ (ssubst_valid Ω ss) + -∗ expr_pred (α ss) (interp_ty τ). + + Lemma ssubst_valid_empty (αs : interp_scope ∅) : + ⊢ ssubst_valid □ αs. + Proof. + iStartProof. + unfold ssubst_valid. + match goal with + | |- context G [big_opS ?a ?b ?c] => assert (c = empty) as -> + end. + { apply set_eq; intros []. } + by iApply big_sepS_empty. + Qed. + + Lemma ssubst_valid_app + {S1 S2 : Set} `{!EqDecision S1} `{!Finite S1} + `{!EqDecision S2} `{!Finite S2} + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) + (αs : interp_scope (sum S1 S2)) : + (ssubst_valid (sum_map' Ω1 Ω2) αs) ⊢ + (ssubst_valid Ω1 (interp_scope_split αs).1) + ∗ (ssubst_valid Ω2 (interp_scope_split αs).2). + Proof. + iIntros "H". + rewrite /ssubst_valid fin_to_set_sum big_sepS_union; first last. + { + apply elem_of_disjoint. + intros [x | x]. + - rewrite !elem_of_list_to_set. + intros _ H2. + apply elem_of_list_fmap_2 in H2. + destruct H2 as [y [H2 H2']]; inversion H2. + - rewrite !elem_of_list_to_set. + intros H1 _. + apply elem_of_list_fmap_2 in H1. + destruct H1 as [y [H1 H1']]; inversion H1. + } + iDestruct "H" as "(H1 & H2)". + iSplitL "H1". + - rewrite big_opS_list_to_set; first last. + { + apply NoDup_fmap. + - intros ??; by inversion 1. + - apply NoDup_elements. + } + rewrite big_sepL_fmap /=. + rewrite big_sepS_elements. + iFrame "H1". + - rewrite big_opS_list_to_set; first last. + { + apply NoDup_fmap. + - intros ??; by inversion 1. + - apply NoDup_elements. + } + rewrite big_sepL_fmap /=. + rewrite big_sepS_elements. + iFrame "H2". + Qed. + + Lemma ssubst_valid_cons {S : Set} `{!EqDecision S} `{!Finite S} + (Ω : S → ty) (αs : interp_scope S) τ t : + ssubst_valid Ω αs ∗ expr_pred t (protected (interp_ty τ)) ⊢ ssubst_valid (Ω ▹ τ) (extend_scope αs t). + Proof. + iIntros "(H & G)". + rewrite /ssubst_valid. + pose (Y := let A := {[VZ]} : @gset (leibnizO (inc S)) _ finite_countable in + let B := fin_to_set (leibnizO S) : gset (leibnizO S) in + let C := set_map (VS : S → inc S) B + : gset (inc S) in A ∪ C). + assert (fin_to_set (inc S) = Y) as ->. + { + subst Y; simpl. + apply set_eq. + intros [| x]. + - split. + + intros _; apply elem_of_union; left. + by apply elem_of_singleton. + + intros _; apply elem_of_fin_to_set. + - split. + + intros _; apply elem_of_union; right. + apply elem_of_map_2, elem_of_fin_to_set. + + intros H. + apply elem_of_fin_to_set. + } + subst Y; simpl. + rewrite big_sepS_union; first last. + { + apply elem_of_disjoint. + intros [| x]. + - rewrite !elem_of_list_to_set. + intros _ H2. + apply elem_of_list_fmap_2 in H2. + destruct H2 as [y [H2 H2']]; inversion H2. + - rewrite !elem_of_list_to_set. + intros H1 _. + apply elem_of_singleton_1 in H1. + inversion H1. + } + iSplitL "G". + - rewrite big_opS_singleton. + iFrame "G". + - erewrite big_opS_set_map. + + iFrame "H". + + intros ?? H; by inversion H. + Qed. + + Lemma ssubst_valid_lookup {S : Set} `{!EqDecision S} `{!Finite S} + (Ω : S → ty) (αs : interp_scope S) x : + ssubst_valid Ω αs ⊢ expr_pred (αs x) (protected (interp_ty (Ω x))). + Proof. + iIntros "H". + iDestruct (big_sepS_elem_of_acc _ _ x with "H") as "($ & _)"; + first apply elem_of_fin_to_set. + Qed. + + Lemma compat_pair {S1 S2 : Set} + `{!EqDecision S1} `{!Finite S1} + `{!EqDecision S2} `{!Finite S2} + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) α β τ1 τ2 : + ⊢ valid1 Ω1 α τ1 -∗ + valid1 Ω2 β τ2 -∗ + valid1 (sum_map' Ω1 Ω2) (interp_pair α β ◎ interp_scope_split) (tPair τ1 τ2). + Proof. + Opaque pairITV. + iIntros "H1 H2". + iIntros (αs) "#Hctx Has". + cbn-[interp_pair]. + rewrite ssubst_valid_app. + iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. + iSpecialize ("H1" with "Hctx Ha1"). + iSpecialize ("H2" with "Hctx Ha2"). + iApply (expr_pred_bind with "H2"). + iIntros (βv) "Hb". simpl. + rewrite -> get_val_ITV. simpl. + iApply (expr_pred_bind with "H1"). + iIntros (αv) "Ha". simpl. + rewrite -> get_val_ITV. simpl. + iApply expr_pred_ret. + simpl. + iExists _,_. + by iFrame. + Qed. + + Lemma compat_destruct {S1 S2 : Set} + `{!EqDecision S1} `{!Finite S1} + `{!EqDecision S2} `{!Finite S2} + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) + α β τ1 τ2 τ : + ⊢ valid1 Ω1 α (tPair τ1 τ2) + -∗ valid1 (Ω2 ▹ τ2 ▹ τ1) β τ + -∗ valid1 (sum_map' Ω1 Ω2) (interp_destruct α β ◎ interp_scope_split) τ. + Proof. + Opaque pairITV thunked thunkedV projIT1 projIT2. + iIntros "H1 H2". + iIntros (αs) "#Hctx Has". + cbn-[interp_destruct]. + rewrite ssubst_valid_app. + iDestruct "Has" as "[Ha1 Ha2]". + iSpecialize ("H1" with "Hctx Ha1"). + iApply (expr_pred_bind (LETCTX _) with "H1"). + iIntros (αv) "Ha". unfold LETCTX. simpl. + rewrite LET_Val/=. + iDestruct "Ha" as (β1 β2) "[#Ha [Hb1 Hb2]]". + iIntros (x) "Hx". + iApply wp_let. + iApply (wp_Thunk with "Hctx"). + { + repeat intro; simpl. + repeat f_equiv. + intro; simpl. + f_equiv. + intro B; simpl. + destruct B as [| [|]]; [by f_equiv | reflexivity | reflexivity]. + } + iNext. iIntros (l1) "Hl1". simpl. + iApply wp_let. + { solve_proper. } + iApply (wp_Thunk with "Hctx"). + { + repeat intro; simpl. + repeat f_equiv. + intro B; simpl. + destruct B as [| [|]]; [reflexivity | by f_equiv | reflexivity]. + } + iNext. iIntros (l2) "Hl2". simpl. + pose (ss' := (extend_scope + (extend_scope + (interp_scope_split αs).2 + (IT_of_V (thunkedV (projIT2 (IT_of_V αv)) l2))) + (IT_of_V (thunkedV (projIT1 (IT_of_V αv)) l1)))). + iSpecialize ("H2" $! ss' + with "Hctx [-Hx] Hx"). + { + iApply ssubst_valid_cons. + iSplitR "Hl1 Hb1". + - iApply ssubst_valid_cons. + iSplitL "Ha2"; first done. + Transparent thunkedV thunked. + simpl. + iIntros (z) "Hz". + simpl. + iApply wp_val. + iModIntro. + iExists z; iFrame. + iApply wp_lam. + iNext. + simpl. + iApply (wp_bind _ (IFSCtx _ _)). + iApply (wp_read with "Hctx Hl2"). + iNext. iNext. iIntros "Hl2". + iApply wp_val. iModIntro. + unfold IFSCtx. simpl. + rewrite IF_False; last lia. + iApply wp_seq. + { solve_proper. } + iApply (wp_write with "Hctx Hl2"). + iNext. iNext. iIntros "Hl2". + iRewrite "Ha". + simpl. + rewrite projIT2_pairV. + do 3 (iApply wp_tick; iNext). + iApply wp_val. iModIntro. + iApply "Hb2". + - Transparent thunkedV thunked. + simpl. + iIntros (z) "Hz". + simpl. + iApply wp_val. + iModIntro. + iExists z; iFrame. + iApply wp_lam. + iNext. + simpl. + iApply (wp_bind _ (IFSCtx _ _)). + iApply (wp_read with "Hctx Hl1"). + iNext. iNext. iIntros "Hl1". + iApply wp_val. iModIntro. + unfold IFSCtx. simpl. + rewrite IF_False; last lia. + iApply wp_seq. + { solve_proper. } + iApply (wp_write with "Hctx Hl1"). + iNext. iNext. iIntros "Hl1". + iRewrite "Ha". + simpl. + rewrite projIT1_pairV. + do 3 (iApply wp_tick; iNext). + iApply wp_val. iModIntro. + iApply "Hb1". + } + iApply "H2". + Qed. + + Lemma compat_alloc {S : Set} + `{!EqDecision S} `{!Finite S} + (Ω : S → ty) α τ: + ⊢ valid1 Ω α τ -∗ + valid1 Ω (interp_alloc α) (tRef τ). + Proof. + iIntros "H". + iIntros (αs) "#Hctx Has". + iSpecialize ("H" with "Hctx Has"). + simpl. iApply (expr_pred_bind (LETCTX _) with "H"). + iIntros (αv) "Hav". unfold LETCTX. simpl. + rewrite LET_Val/=. + iApply expr_pred_frame. + iApply (wp_alloc with "Hctx"). + iNext. iNext. iIntros (l) "Hl". + iApply wp_val. iModIntro. simpl. + iExists l. + iSplit; first done. + iExists αv. + iFrame "Hl". + iFrame. + Qed. + + Lemma compat_replace {S1 S2 : Set} + `{!EqDecision S1} `{!Finite S1} + `{!EqDecision S2} `{!Finite S2} + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) α β τ τ' : + ⊢ valid1 Ω1 α (tRef τ) -∗ + valid1 Ω2 β τ' -∗ + valid1 (sum_map' Ω1 Ω2) (interp_replace α β ◎ interp_scope_split) (tPair τ (tRef τ')). + Proof. + Opaque pairITV. + iIntros "H1 H2". + iIntros (αs) "#Hctx Has". + cbn-[interp_replace]. + rewrite ssubst_valid_app. + iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. + iSpecialize ("H1" with "Hctx Ha1"). + iSpecialize ("H2" with "Hctx Ha2"). + iApply (expr_pred_bind (LETCTX _) with "H2"). + iIntros (βv) "Hb". unfold LETCTX. simpl. + rewrite LET_Val/=. + iApply (expr_pred_bind with "H1"). + iIntros (αv) "Ha". simpl. + iDestruct "Ha" as (l) "[Ha Ha']". + iDestruct "Ha'" as (γ) "[Hl Hg]". + iApply expr_pred_frame. + iRewrite "Ha". simpl. + rewrite IT_of_V_Ret. + rewrite -> get_ret_ret; simpl. + iApply wp_let. + { solve_proper. } + iApply (wp_read with "Hctx Hl"). + iNext. iNext. iIntros "Hl". + iApply wp_val. iModIntro. + simpl. iApply wp_seq. + { solve_proper. } + iApply (wp_write with "Hctx Hl"). + iNext. iNext. iIntros "Hl". + rewrite get_val_ITV. simpl. + rewrite get_val_ITV. simpl. + iApply wp_val. iModIntro. + iExists γ, (RetV l). + iSplit; first done. + iFrame. eauto with iFrame. + Qed. + + Lemma compat_dealloc {S : Set} + `{!EqDecision S} `{!Finite S} + (Ω : S → ty) α τ: + ⊢ valid1 Ω α (tRef τ) -∗ + valid1 Ω (interp_dealloc α) tUnit. + Proof. + iIntros "H". + iIntros (αs) "#Hctx Has". + iSpecialize ("H" with "Hctx Has"). + iApply (expr_pred_bind with "H"). + iIntros (αv) "Ha /=". + iDestruct "Ha" as (l) "[Ha Ha']". + iDestruct "Ha'" as (βv) "[Hl Hb]". + iRewrite "Ha". iApply expr_pred_frame. simpl. + rewrite IT_of_V_Ret. rewrite -> get_ret_ret. simpl. + iApply (wp_dealloc with "Hctx Hl"). + iNext. iNext. eauto with iFrame. + Qed. + + Lemma compat_bool {S : Set} + `{!EqDecision S} `{!Finite S} + b (Ω : S → ty) : + ⊢ valid1 Ω (interp_litbool b) tBool. + Proof. + iIntros (αs) "#Hctx Has". + iApply expr_pred_ret. + destruct b; simpl; eauto. + Qed. + + Lemma compat_nat {S : Set} + `{!EqDecision S} `{!Finite S} + n (Ω : S → ty) : + ⊢ valid1 Ω (interp_litnat n) tInt. + Proof. + iIntros (αs) "#Hctx Has". + iApply expr_pred_ret. eauto with iFrame. + Qed. + + Lemma compat_unit {S : Set} + `{!EqDecision S} `{!Finite S} + (Ω : S → ty) : + ⊢ valid1 Ω interp_litunit tUnit. + Proof. + iIntros (αs) "#Hctx Has". + iApply expr_pred_ret. eauto with iFrame. + Qed. + + Lemma compat_var {S : Set} + `{!EqDecision S} `{!Finite S} + Ω (v : S) : + ⊢ valid1 Ω (Force ◎ interp_var v) (Ω v). + Proof. + iIntros (ss) "#Hctx Has". + iIntros (x) "Hx". + unfold Force. + simpl. + iApply (wp_bind rs (AppRSCtx (ss v))). + { solve_proper. } + iApply wp_val. + iModIntro. + unfold AppRSCtx. + iApply (wp_bind rs (AppLSCtx (IT_of_V (RetV 0)))). + { solve_proper. } + unfold AppLSCtx. + simpl. + unfold ssubst_valid. + iDestruct (ssubst_valid_lookup _ _ v with "Has Hx") as "Has". + iApply (wp_wand with "Has"). + iIntros (w) "(%y & Hw1 & Hw2)"; simpl. + iModIntro. + rewrite IT_of_V_Ret. + iApply (wp_wand with "Hw1 [Hw2]"). + iIntros (z) "Hz". + iModIntro. + iExists y. + iFrame. + Qed. + + Lemma compat_app {S1 S2 : Set} + `{!EqDecision S1} `{!Finite S1} + `{!EqDecision S2} `{!Finite S2} + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) + α β τ1 τ2 : + ⊢ valid1 Ω1 α (tArr τ1 τ2) -∗ + valid1 Ω2 β τ1 -∗ + valid1 (sum_map' Ω1 Ω2) (interp_app α β ◎ interp_scope_split) τ2. + Proof. + iIntros "H1 H2". + iIntros (αs) "#Hctx Has". + iEval(cbn-[interp_app]). + rewrite ssubst_valid_app. + iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. + iSpecialize ("H1" with "Hctx Ha1"). + iSpecialize ("H2" with "Hctx Ha2"). + Local Opaque Thunk. + iSimpl. + iApply (expr_pred_bind (LETCTX _) with "H2"). + iIntros (βv) "H2". unfold LETCTX. iSimpl. + rewrite LET_Val/=. + iApply (expr_pred_bind (LETCTX _) with "H1"). + iIntros (αv) "H1". unfold LETCTX. iSimpl. + rewrite LET_Val/=. + by iApply "H1". + Qed. + + Lemma compat_lam {S : Set} + `{!EqDecision S} `{!Finite S} + (Ω : S → ty) τ1 τ2 α : + ⊢ valid1 (Ω ▹ τ1) α τ2 -∗ + valid1 Ω (interp_lam α) (tArr τ1 τ2). + Proof. + iIntros "H". + iIntros (αs) "#Hctx Has". + iIntros (x) "Hx". + iApply wp_val. + iModIntro. simpl. + iExists _; iFrame. + iIntros (βv) "Hb". clear x. + iIntros (x) "Hx". + iApply (wp_bind _ (AppRSCtx _)). + Local Transparent Thunk. + Local Opaque thunked thunkedV. + iSimpl. iApply (wp_alloc with "Hctx"). + { solve_proper. } + iNext. iNext. iIntros (l) "Hl". + iApply wp_val. iModIntro. + unfold AppRSCtx. + iApply wp_lam. iNext. + iEval(cbn-[thunked]). + pose (ss' := extend_scope αs (IT_of_V (thunkedV (IT_of_V βv) l))). + iSpecialize ("H" $! ss' + with "Hctx [-Hx] Hx"). + { + iApply ssubst_valid_cons. + iFrame "Has". + Local Transparent thunked thunkedV. + simpl. + iIntros (x') "Hx". + iApply wp_val. + iModIntro. + iExists x'. + iFrame "Hx". + iApply wp_lam. + iNext. + iApply (wp_bind _ (IFSCtx _ _)). + iApply (wp_read with "Hctx Hl"). + iNext. iNext. iIntros "Hl". + iApply wp_val. iModIntro. + unfold IFSCtx. simpl. + rewrite IF_False; last lia. + iApply wp_seq. + { solve_proper. } + iApply (wp_write with "Hctx Hl"). + iNext. iNext. iIntros "Hl". + iApply wp_val. iModIntro. + iApply "Hb". + } + iApply "H". + Qed. + + Lemma fundamental_affine (S : Set) + {HE : EqDecision S} {HF : Finite S} + (Ω : S → ty) + (e : expr S) τ : + typed Ω e τ → + ⊢ valid1 Ω (interp_expr _ e) τ. + Proof. + intros H. + induction H. + - by iApply compat_var. + - iApply compat_lam; + iApply IHtyped. + - iApply (@compat_app S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + + iApply IHtyped1. + + iApply IHtyped2. + - iApply (@compat_pair S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + + iApply IHtyped1. + + iApply IHtyped2. + - iApply (@compat_destruct S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + + iApply IHtyped1. + + iApply IHtyped2. + - iApply compat_alloc; + iApply IHtyped. + - iApply (@compat_replace S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + + iApply IHtyped1. + + iApply IHtyped2. + - iApply compat_dealloc; + iApply IHtyped. + - by iApply compat_nat. + - by iApply compat_bool. + - by iApply compat_unit. + Qed. + +End logrel. + +Arguments interp_tarr {_ _ _ _ _ _ _ _ _ _ _ _ _} Φ1 Φ2. +Arguments interp_tbool {_ _ _ _ _ _}. +Arguments interp_tnat {_ _ _ _ _ _}. +Arguments interp_tunit {_ _ _ _ _ _}. +Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} τ. + +Local Definition rs : gReifiers NotCtxDep 2 := + gReifiers_cons NotCtxDep reify_store (gReifiers_cons NotCtxDep input_lang.interp.reify_io (gReifiers_nil NotCtxDep)). + +Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. + +Require Import gitrees.gitree.greifiers. + +Program Definition ı_scope R `{!Cofe R} : @interp_scope (gReifiers_ops NotCtxDep rs) R _ Empty_set := λne (x : ∅), match x with end. + +Lemma logrel1_adequacy cr Σ R `{!Cofe R, !SubOfe natO R, !SubOfe unitO R, !SubOfe locO R} `{!invGpreS Σ} + `{!statePreG rs R Σ} `{!heapPreG rs R Σ} τ + (α : interp_scope ∅ -n> IT (gReifiers_ops NotCtxDep rs) R) (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ}, + (£ cr ⊢ valid1 rs notStuck (λne _: unitO, True)%I □ α τ)%I) → + ssteps (gReifiers_sReifier NotCtxDep rs) (α (ı_scope _)) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep 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 NotCtxDep rs) β st' β1 st1) + ∨ (∃ e, β ≡ Err e ∧ notStuck e)). + { intros [?|He]; first done. + destruct He as [? [? []]]. } + eapply (wp_safety (S cr)); eauto. + { apply Hdisj. } + { by rewrite Hb. } + intros H1 H2. + exists (λ _, True)%I. split. + { apply _. } + iIntros "[[Hone Hcr] Hst]". + pose (σ := st.1). + pose (ios := st.2.1). + iMod (new_heapG rs σ) as (H3) "H". + iAssert (has_substate σ ∗ has_substate ios)%I with "[Hst]" as "[Hs Hio]". + { unfold has_substate, has_full_state. + assert (of_state NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) st ≡ + of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state σ) + ⋅ of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state ios)) as ->; last first. + { rewrite -own_op. done. } + unfold sR_idx. simpl. + intro j. + rewrite discrete_fun_lookup_op. + inv_fin j. + { unfold of_state, of_idx. simpl. + erewrite (eq_pi _ _ _ (@eq_refl _ 0%fin)). done. } + intros j. inv_fin j. + { unfold of_state, of_idx. simpl. + erewrite (eq_pi _ _ _ (@eq_refl _ 1%fin)). done. } + intros i. inversion i. } + iApply fupd_wp. + iMod (inv_alloc (nroot.@"storeE") _ (∃ σ, £ 1 ∗ has_substate σ ∗ own (heapG_name rs) (●V σ))%I with "[-Hcr]") as "#Hinv". + { iNext. iExists _. iFrame. } + simpl. + iPoseProof (@Hlog _ _ _ with "Hcr") as "Hlog". + iSpecialize ("Hlog" $! (ı_scope _) with "Hinv []"). + { iApply ssubst_valid_empty. } + iSpecialize ("Hlog" $! tt with "[//]"). + iModIntro. + iApply (wp_wand with "Hlog"). + eauto with iFrame. +Qed. + +Definition R := sumO locO (sumO unitO natO). + +Lemma logrel1_safety e τ (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : + typed □ e τ → + ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e (ı_scope _)) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) + ∨ (∃ βv, IT_of_V βv ≡ β). +Proof. + intros Hty Hst. + pose (Σ:=#[invΣ;stateΣ rs R;heapΣ rs R]). + eapply (logrel1_adequacy 0 Σ); eauto; try apply _. + iIntros (? ? ?) "_". + iApply (fundamental_affine rs notStuck (λne _ : unitO, True)%I). + apply Hty. +Qed. diff --git a/theories/affine_lang/logrel2.v b/theories/examples/affine_lang/logrel2.v similarity index 77% rename from theories/affine_lang/logrel2.v rename to theories/examples/affine_lang/logrel2.v index a45dac8..0c1cba4 100644 --- a/theories/affine_lang/logrel2.v +++ b/theories/examples/affine_lang/logrel2.v @@ -1,59 +1,57 @@ -From Equations Require Import Equations. From iris.base_logic.lib Require Import na_invariants. -From gitrees Require Export lang_affine gitree program_logic. -From gitrees.input_lang Require Import lang interp logpred. -From gitrees.affine_lang Require Import lang logrel1. -From gitrees.examples Require Import store pairs. +From gitrees Require Export gitree program_logic. +From gitrees.examples.input_lang Require Import lang interp logpred. +From gitrees.examples.affine_lang Require Import lang logrel1. +From gitrees.effects Require Import store. +From gitrees.lib Require Import pairs. Require Import iris.algebra.gmap. +Require Import stdpp.finite. Require Import Binding.Lib Binding.Set Binding.Env. -Local Notation tyctx := (tyctx ty). - -Inductive typed_glued : forall {S}, tyctx S → expr S → ty → Type := +Inductive typed_glued : forall {S : Set}, (S → ty) → expr S → ty → Type := (** FFI *) -| typed_Glue {S} (Ω : tyctx S) τ' τ e +| typed_Glue {S : Set} (Ω : S → ty) τ' τ e (tconv : ty_conv τ τ') : io_lang.typed □ e τ' → typed_glued Ω (EEmbed e tconv) τ (** functions *) -| typed_VarG {S} (Ω : tyctx S) (τ : ty) (v : var S) : - typed_var Ω v τ → - typed_glued Ω (Var v) τ -| typed_LamG {S} (Ω : tyctx S) (τ1 τ2 : ty) (e : expr (()::S) ) : - typed_glued (consC τ1 Ω) e τ2 → +| typed_VarG {S : Set} (Ω : S → ty) (τ : ty) (v : S) : + typed_glued Ω (Var v) (Ω v) +| typed_LamG {S : Set} (Ω : S → ty) (τ1 τ2 : ty) (e : expr (inc S) ) : + typed_glued (Ω ▹ τ1) e τ2 → typed_glued Ω (Lam e) (tArr τ1 τ2) -| typed_AppG {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : +| typed_AppG {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : typed_glued Ω1 e1 (tArr τ1 τ2) → typed_glued Ω2 e2 τ1 → - typed_glued (tyctx_app Ω1 Ω2) (App e1 e2) τ2 + typed_glued (sum_map' Ω1 Ω2) (App e1 e2) τ2 (** pairs *) -| typed_PairG {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : +| typed_PairG {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : typed_glued Ω1 e1 τ1 → typed_glued Ω2 e2 τ2 → - typed_glued (tyctx_app Ω1 Ω2) (EPair e1 e2) (tPair τ1 τ2) -| typed_DestructG {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 τ : ty) - (e1 : expr S1) (e2 : expr (()::()::S2)) : + typed_glued (sum_map' Ω1 Ω2) (EPair e1 e2) (tPair τ1 τ2) +| typed_DestructG {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 τ : ty) + (e1 : expr S1) (e2 : expr (inc (inc S2))) : typed_glued Ω1 e1 (tPair τ1 τ2) → - typed_glued (consC τ1 (consC τ2 Ω2)) e2 τ → - typed_glued (tyctx_app Ω1 Ω2) (EDestruct e1 e2) τ + typed_glued ((Ω2 ▹ τ2) ▹ τ1) e2 τ → + typed_glued (sum_map' Ω1 Ω2) (EDestruct e1 e2) τ (** references *) -| typed_AllocG {S} (Ω : tyctx S) τ e : +| typed_AllocG {S : Set} (Ω : S → ty) τ e : typed_glued Ω e τ → typed_glued Ω (Alloc e) (tRef τ) -| typed_ReplaceG {S1 S2} (Ω1 : tyctx S1) (Ω2 : tyctx S2) (τ1 τ2 : ty) e1 e2 : +| typed_ReplaceG {S1 S2 : Set} (Ω1 : S1 → ty) (Ω2 : S2 → ty) (τ1 τ2 : ty) e1 e2 : typed_glued Ω1 e1 (tRef τ1) → typed_glued Ω2 e2 τ2 → - typed_glued (tyctx_app Ω1 Ω2) (Replace e1 e2) (tPair τ1 (tRef τ2)) -| typed_DeallocG {S} (Ω : tyctx S) e τ : + typed_glued (sum_map' Ω1 Ω2) (Replace e1 e2) (tPair τ1 (tRef τ2)) +| typed_DeallocG {S : Set} (Ω : S → ty) e τ : typed_glued Ω e (tRef τ) → typed_glued Ω (Dealloc e) tUnit (** literals *) -| typed_NatG {S} (Ω : tyctx S) n : +| typed_NatG {S : Set} (Ω : S → ty) n : typed_glued Ω (LitNat n) tInt -| typed_BoolG {S} (Ω : tyctx S) b : +| typed_BoolG {S : Set} (Ω : S → ty) b : typed_glued Ω (LitBool b) tBool -| typed_UnitG {S} (Ω : tyctx S) : +| typed_UnitG {S : Set} (Ω : S → ty) : typed_glued Ω LitUnit tUnit . @@ -75,17 +73,19 @@ Section glue. Definition s : stuckness := λ e, e = OtherError. Variable p : na_inv_pool_name. - Definition valid2 {S} (Ω : tyctx S) (α : interp_scope (E:=F) S -n> IT) (τ : ty) : iProp := + Definition valid2 {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) (α : interp_scope (E:=F) S -n> IT) + (τ : ty) : iProp := valid1 rs s (λne σ, has_substate σ ∗ na_own p ⊤)%I Ω α τ. - Definition io_valid {S : Set} (Γ : S → io_lang.ty) α (τ' : io_lang.ty) : iProp := + Definition io_valid {S : Set} (Γ : S → io_lang.ty) α (τ' : io_lang.ty) + : iProp := input_lang.logpred.valid1 rs s (λne _ : unitO, na_own p ⊤) Γ α τ'. Local Opaque thunked thunkedV Thunk. Program Definition ı_scope : @lang_generic.interp_scope (gReifiers_ops NotCtxDep rs) R _ Empty_set := λne (x : ∅), match x with end. - Lemma compat_glue_to_affine_bool {S} (Ω : tyctx S) α : + Lemma compat_glue_to_affine_bool {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) α : io_valid □ α Tnat ⊢ valid2 Ω (constO (glue2_bool _ (α ı_scope))) tBool. Proof. @@ -97,7 +97,7 @@ Section glue. iIntros ([]). } iSpecialize ("H" $! tt with "Hp"). - simp interp_ssubst. simpl. + simpl. iApply (wp_bind _ (IFSCtx _ _)). { solve_proper. } iApply (wp_wand with "H"). @@ -112,7 +112,8 @@ Section glue. * rewrite IF_True ; last lia. iApply wp_val; eauto with iFrame. Qed. - Lemma compat_glue_to_affine_nat {S} (Ω : tyctx S) α : + + Lemma compat_glue_to_affine_nat {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) α : io_valid □ α Tnat ⊢ valid2 Ω (constO (α ı_scope)) tInt. Proof. @@ -124,32 +125,23 @@ Section glue. iIntros ([]). } iSpecialize ("H" $! tt with "Hp"). - simp interp_ssubst. simpl. + simpl. iApply (wp_wand with "H"). iIntros (αv). iDestruct 1 as (_) "[Ha Hp]". iDestruct "Ha" as (σ') "[Ha Hs]". iModIntro. eauto with iFrame. Qed. - Lemma IT_move_from_affine (α : @interp_scope (@gReifiers_ops NotCtxDep sz rs) R _ [] -n> IT) - : @lang_generic.interp_scope (@gReifiers_ops NotCtxDep sz rs) R _ ∅ -n> IT. - Proof. - unshelve econstructor. - - intros g. apply α. - constructor. - - repeat intro. - f_equiv. - Defined. - Lemma compat_glue_from_affine_bool α : - valid2 empC α tBool ⊢ - heap_ctx -∗ io_valid □ (IT_move_from_affine α) Tnat. + valid2 □ α tBool ⊢ + heap_ctx -∗ io_valid □ α Tnat. Proof. iIntros "H #Hctx". iIntros (σ ss) "Hs Hss". iIntros (?) "Hp". - iSpecialize ("H" $! emp_ssubst with "Hctx [] [$Hs $Hp]"). - { iApply ssubst_valid_nil. } + iSpecialize ("H" $! ss with "Hctx [] [$Hs $Hp]"). + { iApply ssubst_valid_empty. } + simpl. iApply (wp_wand with "H"). iIntros (αv) "Ha". iDestruct "Ha" as (σ') "[Ha [Hs Hp]]". iModIntro. simpl. iFrame. iExists tt,_; iFrame. @@ -157,22 +149,22 @@ Section glue. Qed. Lemma compat_glue_from_affine_nat α : - valid2 empC α tInt ⊢ - heap_ctx -∗ io_valid □ (IT_move_from_affine α) Tnat. + valid2 □ α tInt ⊢ + heap_ctx -∗ io_valid □ α Tnat. Proof. iIntros "H #Hctx". iIntros (σ ss) "Hs Hss". iIntros (?) "Hp". - iSpecialize ("H" $! emp_ssubst with "Hctx [] [$Hs $Hp]"). - { iApply ssubst_valid_nil. } + iSpecialize ("H" $! ss with "Hctx [] [$Hs $Hp]"). + { iApply ssubst_valid_empty. } iApply (wp_wand with "H"). iIntros (αv) "Ha". iDestruct "Ha" as (σ') "[Ha [Hs Hp]]". iModIntro. iExists tt. eauto with iFrame. Qed. Lemma compat_glue_from_affine_unit α : - valid2 empC α tUnit ⊢ - heap_ctx -∗ io_valid □ (constO (glue_from_affine _ ty_conv_unit (α ()))) Tnat. + valid2 □ α tUnit ⊢ + heap_ctx -∗ io_valid □ (constO (glue_from_affine _ ty_conv_unit (α ı_scope))) Tnat. Proof. iIntros "H #Hctx". iIntros (σ ss) "Hs Hss". @@ -187,10 +179,10 @@ Section glue. Lemma compat_glue_from_affine_fun (τ1 τ2 : ty) (τ1' τ2' : io_lang.ty) α (glue_to_affine glue_from_affine : IT -n> IT) : (∀ α, io_valid □ α τ1' - ⊢ valid2 empC (constO (glue_to_affine (α ı_scope))) τ1) → - (∀ α, valid2 empC (constO α) τ2 + ⊢ valid2 □ (constO (glue_to_affine (α ı_scope))) τ1) → + (∀ α, valid2 □ (constO α) τ2 ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine α)) τ2') → - valid2 empC (constO α) (tArr τ1 τ2) + valid2 □ (constO α) (tArr τ1 τ2) ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine_fun _ glue_from_affine glue_to_affine α)) @@ -203,8 +195,8 @@ Section glue. iIntros (σ ss) "Hs ?". simpl. iIntros (?) "Hp". - iSpecialize ("H" $! emp_ssubst with "Hctx [] [$Hs $Hp]"). - { iApply ssubst_valid_nil. } + iSpecialize ("H" $! ss with "Hctx [] [$Hs $Hp]"). + { iApply ssubst_valid_empty. } simpl. iApply wp_let. { solve_proper. } iApply (wp_wand with "H"). @@ -274,8 +266,8 @@ Section glue. iSpecialize ("G1" with "[Hg]"). { iIntros (σ0 ss0) "Hs Has". simpl. iApply expr_pred_ret. simpl. eauto with iFrame. } - iSpecialize ("G1" $! emp_ssubst with "Hctx [] [$Hst $Hp]"). - { iApply ssubst_valid_nil. } + iSpecialize ("G1" $! ss with "Hctx [] [$Hst $Hp]"). + { iApply ssubst_valid_empty. } iApply (wp_wand with "G1"). clear βv σ'. iIntros (βv). iDestruct 1 as (σ') "[Hb [Hst Hp]]". @@ -298,11 +290,11 @@ Section glue. iApply ("G1" $! tt with "Hp"). Qed. - Lemma compat_glue_to_affine_fun {S} (Ω : tyctx S) (τ1 τ2 : ty) + Lemma compat_glue_to_affine_fun {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) (τ1 τ2 : ty) (τ1' τ2' : io_lang.ty) α (glue_to_affine glue_from_affine : IT -n> IT) : (∀ α, io_valid □ α τ2' ⊢ valid2 Ω (constO (glue_to_affine (α ı_scope))) τ2) → - (∀ α, valid2 empC (constO α) τ1 + (∀ α, valid2 □ (constO α) τ1 ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine α)) τ1') → io_valid □ α (Tarr (Tarr Tnat τ1') τ2') ⊢ valid2 Ω @@ -314,11 +306,9 @@ Section glue. iIntros (αs) "#Hctx Has". iIntros (σ) "[Hs Hp]". simpl. iSpecialize ("H" $! _ ı_scope with "Hs []"). - { - iIntros ([]). - } + { iIntros ([]). } iSpecialize ("H" $! tt with "Hp"). - simp interp_ssubst. simpl. + simpl. iApply wp_let. { solve_proper. } iApply (wp_wand with "H"). @@ -332,7 +322,6 @@ Section glue. iSimpl. clear σ σ'. iIntros (σ) "[Hs Hp]". iApply (wp_bind _ (AppRSCtx _)). - { solve_proper. } iApply (wp_Thunk with "Hctx"). { solve_proper. } iNext. iIntros (l) "Hl". @@ -435,20 +424,20 @@ Section glue. simpl. done. Qed. - Lemma glue_to_affine_compatibility {S} (Ω : tyctx S) (τ1 : ty) (τ1' : io_lang.ty) + Lemma glue_to_affine_compatibility {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) (τ1 : ty) (τ1' : io_lang.ty) (Hconv : ty_conv τ1 τ1') α : io_valid □ α τ1' ⊢ valid2 Ω (constO (glue_to_affine _ Hconv (α ı_scope))) τ1 with glue_from_affine_compatibility (τ1 : ty) (τ1' : io_lang.ty) (Hconv : ty_conv τ1 τ1') (α : IT) : - valid2 empC (constO α) τ1 ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine _ Hconv α)) τ1'. + valid2 □ (constO α) τ1 ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine _ Hconv α)) τ1'. Proof. - destruct Hconv. - + by iApply compat_glue_to_affine_bool. - + by iApply compat_glue_to_affine_nat. + + by iApply (@compat_glue_to_affine_bool). + + by iApply (@compat_glue_to_affine_nat). + iIntros "_". simpl. iApply compat_unit. - + simpl. iApply compat_glue_to_affine_fun. - * apply glue_to_affine_compatibility. + + simpl. iApply (@compat_glue_to_affine_fun). + * by apply glue_to_affine_compatibility. * apply glue_from_affine_compatibility. - destruct Hconv. + iApply compat_glue_from_affine_bool. @@ -459,7 +448,7 @@ Section glue. * apply glue_from_affine_compatibility. Qed. - Lemma fundamental_affine_glued {S} (Ω : tyctx S) (e : expr S) τ : + Lemma fundamental_affine_glued {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) (e : expr S) τ : typed_glued Ω e τ → ⊢ valid2 Ω (interp_expr _ e) τ. Proof. @@ -467,13 +456,24 @@ Section glue. - iApply glue_to_affine_compatibility. by iApply fundamental. - by iApply compat_var. - - by iApply compat_lam. - - by iApply compat_app. - - by iApply compat_pair. - - by iApply compat_destruct. - - by iApply compat_alloc. - - by iApply compat_replace. - - by iApply compat_dealloc. + - iApply compat_lam. + iApply IHtyped. + - iApply (@compat_app _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + + iApply IHtyped1. + + iApply IHtyped2. + - iApply (@compat_pair _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + + iApply IHtyped1. + + iApply IHtyped2. + - iApply (@compat_destruct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + + iApply IHtyped1. + + iApply IHtyped2. + - iApply compat_alloc. + iApply IHtyped. + - iApply (@compat_replace _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + + iApply IHtyped1. + + iApply IHtyped2. + - iApply compat_dealloc. + iApply IHtyped. - by iApply compat_nat. - by iApply compat_bool. - by iApply compat_unit. @@ -491,10 +491,10 @@ Require Import gitrees.gitree.greifiers. Lemma logrel2_adequacy (cr : nat) R `{!Cofe R, !SubOfe locO R, !SubOfe natO R, !SubOfe unitO R} Σ `{!invGpreS Σ}`{!statePreG rs R Σ} `{!heapPreG rs R Σ} `{!na_invG Σ} - (τ : ty) (α : unitO -n> IT (gReifiers_ops NotCtxDep rs) R) (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : + (τ : ty) (α : interp_scope Empty_set -n> IT (gReifiers_ops NotCtxDep rs) R) (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ} p, - (£ cr ⊢ valid2 rs p empC α τ)%I) → - ssteps (gReifiers_sReifier NotCtxDep rs) (α ()) st β st' k → + (£ cr ⊢ valid2 rs p □ α τ)%I) → + ssteps (gReifiers_sReifier NotCtxDep rs) (α (ı_scope rs)) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (β ≡ Err OtherError) ∨ (∃ βv, IT_of_V βv ≡ β). @@ -538,11 +538,11 @@ Proof. simpl. iMod na_alloc as (p) "Hp". iPoseProof (@Hlog _ _ _ p with "Hcr") as "Hlog". - iSpecialize ("Hlog" $! emp_ssubst with "Hinv []"). - { iApply ssubst_valid_nil. } + iSpecialize ("Hlog" $! (ı_scope _) with "Hinv []"). + { iApply ssubst_valid_empty. } unfold expr_pred. simpl. iSpecialize ("Hlog" $! ios with "[$Hio $Hp]"). - iModIntro. simp interp_ssubst. + iModIntro. simpl. iApply (wp_wand with "Hlog"). eauto with iFrame. Qed. @@ -550,8 +550,8 @@ Qed. Definition R := sumO locO (sumO natO unitO). Lemma logrel2_safety e τ (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : - typed_glued empC e τ → - ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ()) st β st' k → + typed_glued □ e τ → + ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e (ı_scope _)) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (β ≡ Err OtherError) ∨ (∃ βv, IT_of_V βv ≡ β). diff --git a/theories/input_lang/interp.v b/theories/examples/input_lang/interp.v similarity index 99% rename from theories/input_lang/interp.v rename to theories/examples/input_lang/interp.v index 41bf8af..c0ae876 100644 --- a/theories/input_lang/interp.v +++ b/theories/examples/input_lang/interp.v @@ -1,5 +1,5 @@ From gitrees Require Import gitree lang_generic. -From gitrees.input_lang Require Import lang. +From gitrees.examples.input_lang Require Import lang. Require Import Binding.Lib. Require Import Binding.Set. diff --git a/theories/input_lang/lang.v b/theories/examples/input_lang/lang.v similarity index 100% rename from theories/input_lang/lang.v rename to theories/examples/input_lang/lang.v diff --git a/theories/input_lang/logpred.v b/theories/examples/input_lang/logpred.v similarity index 99% rename from theories/input_lang/logpred.v rename to theories/examples/input_lang/logpred.v index ea1b802..b548bc9 100644 --- a/theories/input_lang/logpred.v +++ b/theories/examples/input_lang/logpred.v @@ -1,6 +1,6 @@ (** Unary (Kripke) logical relation for the IO lang *) From gitrees Require Import gitree program_logic lang_generic. -From gitrees.input_lang Require Import lang interp. +From gitrees.examples.input_lang Require Import lang interp. Require Import Binding.Lib Binding.Set Binding.Env. Section io_lang. diff --git a/theories/input_lang/logrel.v b/theories/examples/input_lang/logrel.v similarity index 99% rename from theories/input_lang/logrel.v rename to theories/examples/input_lang/logrel.v index a1f0017..53f9756 100644 --- a/theories/input_lang/logrel.v +++ b/theories/examples/input_lang/logrel.v @@ -1,6 +1,6 @@ (** Logical relation for adequacy for the IO lang *) From gitrees Require Import gitree lang_generic. -From gitrees.input_lang Require Import lang interp. +From gitrees.examples.input_lang Require Import lang interp. Require Import Binding.Lib Binding.Set Binding.Env. Section logrel. diff --git a/theories/input_lang_callcc/hom.v b/theories/examples/input_lang_callcc/hom.v similarity index 98% rename from theories/input_lang_callcc/hom.v rename to theories/examples/input_lang_callcc/hom.v index 16d7ad0..3e4f03e 100644 --- a/theories/input_lang_callcc/hom.v +++ b/theories/examples/input_lang_callcc/hom.v @@ -1,5 +1,5 @@ From gitrees Require Import gitree. -From gitrees.input_lang_callcc Require Import lang interp. +From gitrees.examples.input_lang_callcc Require Import lang interp. Require Import gitrees.lang_generic. Require Import Binding.Lib Binding.Set Binding.Env. diff --git a/theories/input_lang_callcc/interp.v b/theories/examples/input_lang_callcc/interp.v similarity index 99% rename from theories/input_lang_callcc/interp.v rename to theories/examples/input_lang_callcc/interp.v index ae97290..8e41b93 100644 --- a/theories/input_lang_callcc/interp.v +++ b/theories/examples/input_lang_callcc/interp.v @@ -1,5 +1,5 @@ From gitrees Require Import gitree. -From gitrees.input_lang_callcc Require Import lang. +From gitrees.examples.input_lang_callcc Require Import lang. Require Import gitrees.lang_generic. Require Import Binding.Lib. diff --git a/theories/input_lang_callcc/lang.v b/theories/examples/input_lang_callcc/lang.v similarity index 100% rename from theories/input_lang_callcc/lang.v rename to theories/examples/input_lang_callcc/lang.v diff --git a/theories/input_lang_callcc/logrel.v b/theories/examples/input_lang_callcc/logrel.v similarity index 99% rename from theories/input_lang_callcc/logrel.v rename to theories/examples/input_lang_callcc/logrel.v index b88fac4..89d9c44 100644 --- a/theories/input_lang_callcc/logrel.v +++ b/theories/examples/input_lang_callcc/logrel.v @@ -1,6 +1,6 @@ (** Logical relation for adequacy for the IO lang *) From gitrees Require Import gitree. -From gitrees.input_lang_callcc Require Import lang interp hom. +From gitrees.examples.input_lang_callcc Require Import lang interp hom. Require Import gitrees.lang_generic. Require Import Binding.Lib Binding.Set Binding.Env. diff --git a/theories/lang_affine.v b/theories/lang_affine.v deleted file mode 100644 index b13c0be..0000000 --- a/theories/lang_affine.v +++ /dev/null @@ -1,245 +0,0 @@ -From gitrees Require Import prelude. -From gitrees Require Import gitree. -From Equations Require Import Equations. -Require Import List. -Import ListNotations. - -(** XXX: We /NEED/ this line for [Equations Derive] to work, *) -(* this flag is globally unset by std++, but Equations need obligations to be transparent. *) -Set Transparent Obligations. - -Derive NoConfusion NoConfusionHom for list. - -Definition scope := (list unit). - -(** Variables in a context *) -Inductive var : scope → Type := -| Vz : forall {S : scope} {s}, var (s::S) -| Vs : forall {S : scope} {s}, var S -> var (s::S) -. -Derive Signature NoConfusion for var. - -Inductive tyctx (ty : Type) : scope → Type := -| empC : tyctx ty [] -| consC : forall{Γ}, ty → tyctx ty Γ → tyctx ty (()::Γ) -. -Arguments empC {_}. -Arguments consC {_ _} _ _. - -Equations list_of_tyctx {S ty} (Γ : tyctx ty S) : list ty := - list_of_tyctx empC := []; - list_of_tyctx (consC τ Γ') := τ::list_of_tyctx Γ'. - -Equations tyctx_app {S1 S2 ty} (c1 : tyctx ty S1) (c2 : tyctx ty S2) : tyctx ty (S1++S2) := - tyctx_app empC c2 := c2; - tyctx_app (consC τ c1) c2 := consC τ (tyctx_app c1 c2). - -Inductive typed_var {ty : Type}: forall {S}, tyctx ty S → var S → ty → Prop := -| typed_var_Z S (τ : ty) (Γ : tyctx ty S) : - typed_var (consC τ Γ) Vz τ -| typed_var_S S (τ τ' : ty) (Γ : tyctx ty S) v : - typed_var Γ v τ → - typed_var (consC τ' Γ) (Vs v) τ -. - -Section interp. - Local Open Scope type. - Context {E: opsInterp}. - Context {R} `{!Cofe R}. - Notation IT := (IT E R). - Notation ITV := (ITV E R). - - Fixpoint interp_scope (S : scope) : ofe := - match S with - | [] => unitO - | τ::Sc => prodO IT (interp_scope Sc) - end. - - Instance interp_scope_cofe S : Cofe (interp_scope S). - Proof. induction S; simpl; apply _. Qed. - - Instance interp_scope_inhab S : Inhabited (interp_scope S). - Proof. induction S; simpl; apply _. Defined. - - Equations interp_var {S : scope} (v : var S) : interp_scope S -n> IT := - interp_var (S:=(_::_)) Vz := fstO; - interp_var (S:=(_::Sc)) (Vs v) := interp_var v ◎ sndO. - - Instance interp_var_ne S (v : var S) : NonExpansive (@interp_var S v). - Proof. - intros n D1 D2 HD12. induction v; simp interp_var. - - by f_equiv. - - eapply IHv. by f_equiv. - Qed. - - Global Instance interp_var_proper S (v : var S) : Proper ((≡) ==> (≡)) (interp_var v). - Proof. apply ne_proper. apply _. Qed. - - Definition interp_scope_split {S1 S2} : - interp_scope (S1 ++ S2) -n> interp_scope S1 * interp_scope S2. - Proof. - induction S1 as [|? S1]; simpl. - - simple refine (λne x, (tt, x)). - solve_proper. - - simple refine (λne xy, let ss := IHS1 xy.2 in ((xy.1, ss.1), ss.2)). - solve_proper. - Defined. - - (** scope substituions *) - Inductive ssubst : scope → Type := - | emp_ssubst : ssubst [] - | cons_ssubst {S} : ITV → ssubst S → ssubst (tt::S) - . - - Equations interp_ssubst {S} (ss : ssubst S) : interp_scope S := - interp_ssubst emp_ssubst := tt; - interp_ssubst (cons_ssubst αv ss) := (IT_of_V αv, interp_ssubst ss). - - Equations list_of_ssubst {S} (ss : ssubst S) : list ITV := - list_of_ssubst emp_ssubst := []; - list_of_ssubst (cons_ssubst αv ss) := αv::(list_of_ssubst ss). - - Equations ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : ssubst S1 * ssubst S2 := - ssubst_split (S1:=[]) αs := (emp_ssubst,αs); - ssubst_split (S1:=u::_) (cons_ssubst αv αs) := - (cons_ssubst αv (ssubst_split αs).1, (ssubst_split αs).2). - Lemma interp_scope_ssubst_split {S1 S2} (αs : ssubst (S1++S2)) : - interp_scope_split (interp_ssubst αs) ≡ - (interp_ssubst (ssubst_split αs).1, interp_ssubst (ssubst_split αs).2). - Proof. - induction S1 as [|u S1]; simpl. - - simp ssubst_split. simpl. - simp interp_ssubst. done. - - dependent elimination αs as [cons_ssubst αv αs]. - simp ssubst_split. simpl. - simp interp_ssubst. repeat f_equiv; eauto; simpl. - + rewrite IHS1//. - + rewrite IHS1//. - Qed. - -End interp. - -(* Common definitions and lemmas for Kripke logical relations *) -Section kripke_logrel. - Variable s : stuckness. - - Context {sz : nat} {a : is_ctx_dep}. - Variable rs : gReifiers a sz. - Context {R} `{!Cofe R}. - - Notation F := (gReifiers_ops a rs). - Notation IT := (IT F R). - Notation ITV := (ITV F R). - Context `{!invGS Σ, !stateG rs R Σ}. - Notation iProp := (iProp Σ). - - Context {A:ofe}. (* The type & predicate for the explicit Kripke worlds *) - Variable (P : A -n> iProp). - - Implicit Types α β : IT. - Implicit Types αv βv : ITV. - Implicit Types Φ Ψ : ITV -n> iProp. - - Program Definition expr_pred (α : IT) (Φ : ITV -n> iProp) : iProp := - (∀ x : A, P x -∗ WP@{rs} α @ s {{ v, ∃ y : A, Φ v ∗ P y }}). - #[export] Instance expr_pred_ne : NonExpansive2 expr_pred. - Proof. solve_proper. Qed. - #[export] Instance expr_pred_proper : Proper ((≡) ==> (≡) ==> (≡)) expr_pred . - Proof. solve_proper. Qed. - - Definition ssubst_valid {ty} (interp_ty : ty → ITV -n> iProp) {S} (Γ : tyctx ty S) (ss : ssubst S) : iProp := - ([∗ list] τx ∈ zip (list_of_tyctx Γ) (list_of_ssubst (E:=F) ss), - interp_ty (τx.1) (τx.2))%I. - - Lemma ssubst_valid_nil {ty} (interp_ty : ty → ITV -n> iProp) : - ⊢ ssubst_valid interp_ty empC emp_ssubst. - Proof. - unfold ssubst_valid. - by simp list_of_tyctx list_of_ssubst. - Qed. - - Lemma ssubst_valid_cons {ty} (interp_ty : ty → ITV -n> iProp) {S} - (Γ : tyctx ty S) (ss : ssubst S) τ αv : - ssubst_valid interp_ty (consC τ Γ) (cons_ssubst αv ss) - ⊣⊢ interp_ty τ αv ∗ ssubst_valid interp_ty Γ ss. - Proof. - unfold ssubst_valid. - by simp list_of_tyctx list_of_ssubst. - Qed. - - Lemma ssubst_valid_app {ty} (interp_ty : ty → ITV -n> iProp) - {S1 S2} (Ω1 : tyctx ty S1) (Ω2 : tyctx ty S2) αs : - ssubst_valid interp_ty (tyctx_app Ω1 Ω2) αs ⊢ - ssubst_valid interp_ty Ω1 (ssubst_split αs).1 - ∗ ssubst_valid interp_ty Ω2 (ssubst_split αs).2. - Proof. - iInduction Ω1 as [|τ Ω1] "IH" forall (Ω2); simp tyctx_app ssubst_split. - - simpl. iIntros "$". iApply ssubst_valid_nil. - - iIntros "H". - rewrite {4 5}/ssubst_valid. - simpl in αs. - dependent elimination αs as [cons_ssubst αv αs]. - simp ssubst_split. simpl. - simp list_of_ssubst list_of_tyctx. - simpl. iDestruct "H" as "[$ H]". - by iApply "IH". - Qed. - - Lemma expr_pred_ret α αv Φ `{!IntoVal α αv} : - Φ αv ⊢ expr_pred α Φ. - Proof. - iIntros "H". - iIntros (x) "Hx". iApply wp_val. - eauto with iFrame. - Qed. - - Lemma expr_pred_frame α Φ : - WP@{rs} α @ s {{ Φ }} ⊢ expr_pred α Φ. - Proof. - iIntros "H". - iIntros (x) "Hx". - iApply (wp_wand with "H"). - eauto with iFrame. - Qed. -End kripke_logrel. - -Section kripke_logrel_ctx_indep. - Variable s : stuckness. - - Context {sz : nat}. - Variable rs : gReifiers NotCtxDep sz. - Context {R} `{!Cofe R}. - - Notation F := (gReifiers_ops NotCtxDep rs). - Notation IT := (IT F R). - Notation ITV := (ITV F R). - Context `{!invGS Σ, !stateG rs R Σ}. - Notation iProp := (iProp Σ). - - Context {A : ofe}. - Variable (P : A -n> iProp). - - Implicit Types α β : IT. - Implicit Types αv βv : ITV. - Implicit Types Φ Ψ : ITV -n> iProp. - - Local Notation expr_pred := (expr_pred s rs P). - - Lemma expr_pred_bind f `{!IT_hom f} α Φ Ψ `{!NonExpansive Φ} - : expr_pred α Ψ ⊢ - (∀ αv, Ψ αv -∗ expr_pred (f (IT_of_V αv)) Φ) - -∗ expr_pred (f α) Φ. - Proof. - iIntros "H1 H2". - iIntros (x) "Hx". - iApply wp_bind. - { solve_proper. } - iSpecialize ("H1" with "Hx"). - iApply (wp_wand with "H1"). - iIntros (βv). iDestruct 1 as (y) "[Hb Hy]". - iModIntro. - iApply ("H2" with "Hb Hy"). - Qed. -End kripke_logrel_ctx_indep. - -Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_ _}. diff --git a/theories/examples/factorial.v b/theories/lib/factorial.v similarity index 97% rename from theories/examples/factorial.v rename to theories/lib/factorial.v index 3d2cc4e..259395e 100644 --- a/theories/examples/factorial.v +++ b/theories/lib/factorial.v @@ -1,7 +1,7 @@ -From Equations Require Import Equations. From gitrees Require Import gitree program_logic. -From gitrees.input_lang Require Import lang interp. -From gitrees.examples Require Import store while. +From gitrees.examples.input_lang Require Import lang interp. +From gitrees.effects Require Import store. +From gitrees.lib Require Import while. Section fact. Definition rs : gReifiers NotCtxDep 2 := diff --git a/theories/examples/iter.v b/theories/lib/iter.v similarity index 100% rename from theories/examples/iter.v rename to theories/lib/iter.v diff --git a/theories/examples/pairs.v b/theories/lib/pairs.v similarity index 100% rename from theories/examples/pairs.v rename to theories/lib/pairs.v diff --git a/theories/examples/while.v b/theories/lib/while.v similarity index 100% rename from theories/examples/while.v rename to theories/lib/while.v From ddddc3f0878bc70942f1fdd1a65f3a08acaa41cb Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 1 Feb 2024 12:56:12 +0100 Subject: [PATCH 091/114] minor proof simplification (fundamental for affine) --- theories/examples/affine_lang/logrel1.v | 28 ++++++++---------------- theories/examples/affine_lang/logrel2.v | 29 +++++++++---------------- 2 files changed, 19 insertions(+), 38 deletions(-) diff --git a/theories/examples/affine_lang/logrel1.v b/theories/examples/affine_lang/logrel1.v index 50b2fcd..edecf4b 100644 --- a/theories/examples/affine_lang/logrel1.v +++ b/theories/examples/affine_lang/logrel1.v @@ -816,26 +816,16 @@ Section logrel. ⊢ valid1 Ω (interp_expr _ e) τ. Proof. intros H. - induction H. + iStartProof. + iInduction H as [| | | | | | | | | |] "IH". - by iApply compat_var. - - iApply compat_lam; - iApply IHtyped. - - iApply (@compat_app S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - + iApply IHtyped1. - + iApply IHtyped2. - - iApply (@compat_pair S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - + iApply IHtyped1. - + iApply IHtyped2. - - iApply (@compat_destruct S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - + iApply IHtyped1. - + iApply IHtyped2. - - iApply compat_alloc; - iApply IHtyped. - - iApply (@compat_replace S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - + iApply IHtyped1. - + iApply IHtyped2. - - iApply compat_dealloc; - iApply IHtyped. + - by iApply compat_lam. + - by iApply (@compat_app S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (@compat_pair S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (@compat_destruct S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply compat_alloc. + - by iApply (@compat_replace S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply compat_dealloc. - by iApply compat_nat. - by iApply compat_bool. - by iApply compat_unit. diff --git a/theories/examples/affine_lang/logrel2.v b/theories/examples/affine_lang/logrel2.v index 0c1cba4..e855def 100644 --- a/theories/examples/affine_lang/logrel2.v +++ b/theories/examples/affine_lang/logrel2.v @@ -452,28 +452,19 @@ Section glue. typed_glued Ω e τ → ⊢ valid2 Ω (interp_expr _ e) τ. Proof. - intros typed. induction typed; simpl. + intros typed. + iStartProof. + iInduction typed as [| | | | | | | | | | |] "IH". - iApply glue_to_affine_compatibility. by iApply fundamental. - by iApply compat_var. - - iApply compat_lam. - iApply IHtyped. - - iApply (@compat_app _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - + iApply IHtyped1. - + iApply IHtyped2. - - iApply (@compat_pair _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - + iApply IHtyped1. - + iApply IHtyped2. - - iApply (@compat_destruct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - + iApply IHtyped1. - + iApply IHtyped2. - - iApply compat_alloc. - iApply IHtyped. - - iApply (@compat_replace _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - + iApply IHtyped1. - + iApply IHtyped2. - - iApply compat_dealloc. - iApply IHtyped. + - by iApply compat_lam. + - by iApply (@compat_app _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (@compat_pair _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (@compat_destruct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply compat_alloc. + - by iApply (@compat_replace _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply compat_dealloc. - by iApply compat_nat. - by iApply compat_bool. - by iApply compat_unit. From 12c70c5c632c04696d2efdc0689b54788eed1edd Mon Sep 17 00:00:00 2001 From: Kaptch Date: Thu, 1 Feb 2024 22:00:15 +0100 Subject: [PATCH 092/114] cleanup --- _CoqProject | 2 + theories/effects/store.v | 3 +- theories/examples/affine_lang/lang.v | 7 +- theories/examples/affine_lang/logrel1.v | 416 ++----------------- theories/examples/affine_lang/logrel2.v | 75 ++-- theories/examples/input_lang/interp.v | 27 +- theories/examples/input_lang/logpred.v | 30 +- theories/examples/input_lang/logrel.v | 19 +- theories/examples/input_lang_callcc/hom.v | 2 +- theories/examples/input_lang_callcc/interp.v | 4 +- theories/examples/input_lang_callcc/logrel.v | 26 +- theories/gitree/greifiers.v | 202 ++++----- theories/gitree/reductions.v | 12 +- theories/gitree/reify.v | 3 + theories/gitree/weakestpre.v | 272 ++++++------ theories/lang_generic.v | 168 +++++++- theories/lib/factorial.v | 7 +- theories/lib/iter.v | 2 +- theories/prelude.v | 3 + theories/program_logic.v | 4 +- theories/utils/finite_sets.v | 221 ++++++++++ 21 files changed, 777 insertions(+), 728 deletions(-) create mode 100644 theories/utils/finite_sets.v diff --git a/_CoqProject b/_CoqProject index 4ef1b32..6ff13f8 100644 --- a/_CoqProject +++ b/_CoqProject @@ -48,3 +48,5 @@ theories/lib/pairs.v theories/lib/while.v theories/lib/factorial.v theories/lib/iter.v + +theories/utils/finite_sets.v \ No newline at end of file diff --git a/theories/effects/store.v b/theories/effects/store.v index 6b72ad6..7027cba 100644 --- a/theories/effects/store.v +++ b/theories/effects/store.v @@ -125,14 +125,13 @@ Section constructors. (λne _, Next (Ret ())). End constructors. - Section wp. Context {n : nat}. Variable (rs : gReifiers NotCtxDep n). Context {R} `{!Cofe R}. Context `{!SubOfe unitO R}. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). Notation stateO := (stateF ♯ IT). diff --git a/theories/examples/affine_lang/lang.v b/theories/examples/affine_lang/lang.v index 3e5505f..628d2e9 100644 --- a/theories/examples/affine_lang/lang.v +++ b/theories/examples/affine_lang/lang.v @@ -10,9 +10,8 @@ Module io_lang. Definition expr := input_lang.lang.expr. Definition tyctx {S : Set} := S → ty. Definition typed {S : Set} := input_lang.lang.typed (S:=S). - Program Definition ı_scope {sz} (rs : gReifiers NotCtxDep sz) `{!subReifier reify_io rs} {R} `{!Cofe R} : @interp_scope (gReifiers_ops NotCtxDep rs) R _ Empty_set := λne (x : ∅), match x with end. - Definition interp_closed {sz} (rs : gReifiers NotCtxDep sz) `{!subReifier reify_io rs} (e : expr ∅) {R} `{!Cofe R, !SubOfe natO R} : IT (gReifiers_ops NotCtxDep rs) R := - input_lang.interp.interp_expr rs e (ı_scope rs). + Definition interp_closed {sz} (rs : gReifiers NotCtxDep sz) `{!subReifier reify_io rs} (e : expr ∅) {R} `{!Cofe R, !SubOfe natO R} : IT (gReifiers_ops rs) R := + input_lang.interp.interp_expr rs e ı_scope. End io_lang. Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. @@ -51,7 +50,7 @@ Section affine. Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_store rs}. Context `{!subReifier reify_io rs}. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Context {R : ofe}. Context `{!Cofe R, !SubOfe unitO R, !SubOfe natO R, !SubOfe locO R}. Notation IT := (IT F R). diff --git a/theories/examples/affine_lang/logrel1.v b/theories/examples/affine_lang/logrel1.v index edecf4b..d26e888 100644 --- a/theories/examples/affine_lang/logrel1.v +++ b/theories/examples/affine_lang/logrel1.v @@ -1,221 +1,10 @@ (** Unary (Kripke) logical relation for the affine lang *) -From gitrees Require Export gitree program_logic. +Require Import iris.algebra.gmap. +From gitrees Require Export gitree program_logic greifiers. From gitrees.examples.affine_lang Require Import lang. From gitrees.effects Require Import store. From gitrees.lib Require Import pairs. -Require Import iris.algebra.gmap. -Require Import stdpp.finite. - -Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. - -Lemma fin_to_set_sum {S1 S2 : Set} `{EqDecision S1} `{EqDecision S2} `{EqDecision (S1 + S2)} - `{Finite S1} `{Finite S2} `{Finite (S1 + S2)} - `{Countable S1} `{Countable S2} `{Countable (S1 + S2)} - : let A1 : gset S1 := (fin_to_set S1) in - let A2 : gset (S1 + S2) := set_map (inl : S1 → S1 + S2) A1 in - let B1 : gset S2 := (fin_to_set S2) in - let B2 : gset (S1 + S2) := set_map (inr : S2 → S1 + S2) B1 in - let C : gset (S1 + S2) := fin_to_set (S1 + S2) in - C = A2 ∪ B2. -Proof. - apply set_eq. - intros [x|x]; simpl; split; intros _. - - apply elem_of_union; left. - apply elem_of_map_2. - apply elem_of_fin_to_set. - - apply elem_of_fin_to_set. - - apply elem_of_union; right. - apply elem_of_map_2. - apply elem_of_fin_to_set. - - apply elem_of_fin_to_set. -Qed. - -Lemma fin_to_set_empty : - let A : gset ∅ := fin_to_set ∅ in - let B : gset ∅ := empty in - A = B. -Proof. - apply set_eq; intros []. -Qed. - -Section InstSum. - Global Instance EqDecisionLeft {S1 S2 : Set} {H : EqDecision (S1 + S2)} : EqDecision S1. - Proof. - intros x y. - destruct (decide (inl x = inl y)) as [G | G]; - [left; by inversion G | right; intros C; by subst]. - Qed. - - Global Instance EqDecisionRight {S1 S2 : Set} {H : EqDecision (S1 + S2)} : EqDecision S2. - Proof. - intros x y. - destruct (decide (inr x = inr y)) as [G | G]; - [left; by inversion G | right; intros C; by subst]. - Qed. - - Global Instance FiniteLeft {S1 S2 : Set} `{EqDecision S1} - `{EqDecision (S1 + S2)} `{Finite (S1 + S2)} - : Finite S1. - Proof. - unshelve econstructor. - - apply (foldr (λ x acc, match x with - | inl x => x :: acc - | inr _ => acc - end) [] (enum (S1 + S2))). - - set (l := enum (S1 + S2)). - assert (NoDup l) as K; first apply NoDup_enum. - clearbody l. - induction l as [| a l IH]; first constructor. - destruct a as [a | a]; simpl. - + constructor. - * intros C. - assert (inl a ∈ l) as C'. - { - clear -C. - induction l as [| b l IH]; first inversion C. - destruct b as [b | b]; simpl. - - rewrite foldr_cons in C. - rewrite elem_of_cons in C. - destruct C as [-> | C]. - + apply elem_of_cons. - by left. - + right. - apply IH. - apply C. - - apply elem_of_cons. - right. - rewrite foldr_cons in C. - apply IH. - apply C. - } - by inversion K. - * apply IH. - by inversion K. - + apply IH. - by inversion K. - - intros x. - set (l := enum (S1 + S2)). - assert (inl x ∈ l) as K; first apply elem_of_enum. - clearbody l. - induction l as [| a l IH]; first inversion K. - destruct a as [a | a]; simpl. - + rewrite elem_of_cons in K. - destruct K as [K | K]. - * inversion K; subst. - apply elem_of_cons; by left. - * apply elem_of_cons; right; by apply IH. - + rewrite elem_of_cons in K. - destruct K as [K | K]; first inversion K. - by apply IH. - Qed. - - Global Instance FiniteRight {S1 S2 : Set} `{EqDecision S2} - `{EqDecision (S1 + S2)} `{H : Finite (S1 + S2)} - : Finite S2. - Proof. - unshelve econstructor. - - apply (foldr (λ x acc, match x with - | inl _ => acc - | inr x => x :: acc - end) [] (enum (S1 + S2))). - - set (l := enum (S1 + S2)). - assert (NoDup l) as K; first apply NoDup_enum. - clearbody l. - induction l as [| a l IH]; first constructor. - destruct a as [a | a]; simpl. - + apply IH. - by inversion K. - + constructor. - * intros C. - assert (inr a ∈ l) as C'. - { - clear -C. - induction l as [| b l IH]; first inversion C. - destruct b as [b | b]; simpl. - - apply elem_of_cons. - right. - rewrite foldr_cons in C. - apply IH. - apply C. - - rewrite foldr_cons in C. - rewrite elem_of_cons in C. - destruct C as [-> | C]. - + apply elem_of_cons. - by left. - + right. - apply IH. - apply C. - } - by inversion K. - * apply IH. - by inversion K. - - intros x. - set (l := enum (S1 + S2)). - assert (inr x ∈ l) as K; first apply elem_of_enum. - clearbody l. - induction l as [| a l IH]; first inversion K. - destruct a as [a | a]; simpl. - + rewrite elem_of_cons in K. - destruct K as [K | K]; first inversion K. - by apply IH. - + rewrite elem_of_cons in K. - destruct K as [K | K]. - * inversion K; subst. - apply elem_of_cons; by left. - * apply elem_of_cons; right; by apply IH. - Qed. - -End InstSum. - -Section InstInc. - Context (S : Set). - - Global Instance EqDecisionIncN {HS : EqDecision S} (n : nat) : EqDecision (Init.Nat.iter n inc S). - Proof using S. - induction n; simpl. - - apply _. - - intros [|x] [|y]. - + by left. - + by right. - + by right. - + destruct (decide (x = y)) as [-> |]; first by left. - right; by inversion 1. - Qed. - - Global Instance EqDecisionInc {HS : EqDecision S} : EqDecision (inc S). - Proof using S. - assert (inc S = Init.Nat.iter 1 inc S) as ->; first done. - by apply EqDecisionIncN. - Qed. - - Global Instance FiniteIncN {HS : EqDecision S} (HF : Finite S) (n : nat) {HS' : EqDecision (Init.Nat.iter n inc S)} : Finite (Init.Nat.iter n inc S). - Proof using S. - induction n. - - apply (@surjective_finite S HS HF _ _ id). - apply _. - - simpl. - unshelve eapply (@surjective_finite (option (Init.Nat.iter n inc S))); simpl in *. - + intros [x |]. - * apply (VS x). - * apply VZ. - + apply _. - + intros [| x]; simpl. - * exists None; reflexivity. - * exists (Some x); reflexivity. - Qed. - - Global Instance FiniteInc {HS : EqDecision S} (HF : Finite S) (HE : EqDecision (inc S)) : Finite (inc S). - Proof using S. - assert (J : @Finite (Init.Nat.iter 1 inc S) HE). - { apply FiniteIncN, HF. } - simpl in J. - apply J. - Qed. - -End InstInc. - -Definition sum_map' {A B C : Set} (f : A → C) (g : B → C) : sum A B → C := - λ x, match x with | inl x' => f x' | inr x' => g x' end. +From gitrees.utils Require Import finite_sets. Inductive typed : forall {S : Set}, (S → ty) → expr S → ty → Prop := (** functions *) @@ -263,7 +52,7 @@ Section logrel. Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_store rs}. Context `{!subReifier input_lang.interp.reify_io rs}. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Context `{!SubOfe unitO R}. @@ -314,10 +103,7 @@ Section logrel. | tRef τ => interp_ref (interp_ty τ) end. - Program Definition ssubst_valid {S : Set} `{!EqDecision S} `{!Finite S} - (Ω : S → ty) (ss : interp_scope S) : iProp - := ([∗ set] x ∈ (fin_to_set S), - (expr_pred (ss x) (protected (interp_ty (Ω x))))%I). + Notation ssubst_valid := (ssubst_valid_fin1 rs ty (λ x, protected (interp_ty x)) expr_pred). Definition valid1 {S : Set} `{!EqDecision S} `{!Finite S} (Ω : S → ty) (α : interp_scope S -n> IT) (τ : ty) : iProp := @@ -325,123 +111,9 @@ Section logrel. -∗ (ssubst_valid Ω ss) -∗ expr_pred (α ss) (interp_ty τ). - Lemma ssubst_valid_empty (αs : interp_scope ∅) : - ⊢ ssubst_valid □ αs. - Proof. - iStartProof. - unfold ssubst_valid. - match goal with - | |- context G [big_opS ?a ?b ?c] => assert (c = empty) as -> - end. - { apply set_eq; intros []. } - by iApply big_sepS_empty. - Qed. - - Lemma ssubst_valid_app - {S1 S2 : Set} `{!EqDecision S1} `{!Finite S1} - `{!EqDecision S2} `{!Finite S2} - `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} - (Ω1 : S1 → ty) (Ω2 : S2 → ty) - (αs : interp_scope (sum S1 S2)) : - (ssubst_valid (sum_map' Ω1 Ω2) αs) ⊢ - (ssubst_valid Ω1 (interp_scope_split αs).1) - ∗ (ssubst_valid Ω2 (interp_scope_split αs).2). - Proof. - iIntros "H". - rewrite /ssubst_valid fin_to_set_sum big_sepS_union; first last. - { - apply elem_of_disjoint. - intros [x | x]. - - rewrite !elem_of_list_to_set. - intros _ H2. - apply elem_of_list_fmap_2 in H2. - destruct H2 as [y [H2 H2']]; inversion H2. - - rewrite !elem_of_list_to_set. - intros H1 _. - apply elem_of_list_fmap_2 in H1. - destruct H1 as [y [H1 H1']]; inversion H1. - } - iDestruct "H" as "(H1 & H2)". - iSplitL "H1". - - rewrite big_opS_list_to_set; first last. - { - apply NoDup_fmap. - - intros ??; by inversion 1. - - apply NoDup_elements. - } - rewrite big_sepL_fmap /=. - rewrite big_sepS_elements. - iFrame "H1". - - rewrite big_opS_list_to_set; first last. - { - apply NoDup_fmap. - - intros ??; by inversion 1. - - apply NoDup_elements. - } - rewrite big_sepL_fmap /=. - rewrite big_sepS_elements. - iFrame "H2". - Qed. - - Lemma ssubst_valid_cons {S : Set} `{!EqDecision S} `{!Finite S} - (Ω : S → ty) (αs : interp_scope S) τ t : - ssubst_valid Ω αs ∗ expr_pred t (protected (interp_ty τ)) ⊢ ssubst_valid (Ω ▹ τ) (extend_scope αs t). - Proof. - iIntros "(H & G)". - rewrite /ssubst_valid. - pose (Y := let A := {[VZ]} : @gset (leibnizO (inc S)) _ finite_countable in - let B := fin_to_set (leibnizO S) : gset (leibnizO S) in - let C := set_map (VS : S → inc S) B - : gset (inc S) in A ∪ C). - assert (fin_to_set (inc S) = Y) as ->. - { - subst Y; simpl. - apply set_eq. - intros [| x]. - - split. - + intros _; apply elem_of_union; left. - by apply elem_of_singleton. - + intros _; apply elem_of_fin_to_set. - - split. - + intros _; apply elem_of_union; right. - apply elem_of_map_2, elem_of_fin_to_set. - + intros H. - apply elem_of_fin_to_set. - } - subst Y; simpl. - rewrite big_sepS_union; first last. - { - apply elem_of_disjoint. - intros [| x]. - - rewrite !elem_of_list_to_set. - intros _ H2. - apply elem_of_list_fmap_2 in H2. - destruct H2 as [y [H2 H2']]; inversion H2. - - rewrite !elem_of_list_to_set. - intros H1 _. - apply elem_of_singleton_1 in H1. - inversion H1. - } - iSplitL "G". - - rewrite big_opS_singleton. - iFrame "G". - - erewrite big_opS_set_map. - + iFrame "H". - + intros ?? H; by inversion H. - Qed. - - Lemma ssubst_valid_lookup {S : Set} `{!EqDecision S} `{!Finite S} - (Ω : S → ty) (αs : interp_scope S) x : - ssubst_valid Ω αs ⊢ expr_pred (αs x) (protected (interp_ty (Ω x))). - Proof. - iIntros "H". - iDestruct (big_sepS_elem_of_acc _ _ x with "H") as "($ & _)"; - first apply elem_of_fin_to_set. - Qed. - Lemma compat_pair {S1 S2 : Set} - `{!EqDecision S1} `{!Finite S1} - `{!EqDecision S2} `{!Finite S2} + `(!EqDecision S1) `(!Finite S1) + `(!EqDecision S2) `(!Finite S2) `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} (Ω1 : S1 → ty) (Ω2 : S2 → ty) α β τ1 τ2 : ⊢ valid1 Ω1 α τ1 -∗ @@ -452,7 +124,7 @@ Section logrel. iIntros "H1 H2". iIntros (αs) "#Hctx Has". cbn-[interp_pair]. - rewrite ssubst_valid_app. + rewrite ssubst_valid_fin_app1. iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. iSpecialize ("H1" with "Hctx Ha1"). iSpecialize ("H2" with "Hctx Ha2"). @@ -469,8 +141,8 @@ Section logrel. Qed. Lemma compat_destruct {S1 S2 : Set} - `{!EqDecision S1} `{!Finite S1} - `{!EqDecision S2} `{!Finite S2} + `(!EqDecision S1) `(!Finite S1) + `(!EqDecision S2) `(!Finite S2) `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} (Ω1 : S1 → ty) (Ω2 : S2 → ty) α β τ1 τ2 τ : @@ -482,7 +154,7 @@ Section logrel. iIntros "H1 H2". iIntros (αs) "#Hctx Has". cbn-[interp_destruct]. - rewrite ssubst_valid_app. + rewrite ssubst_valid_fin_app1. iDestruct "Has" as "[Ha1 Ha2]". iSpecialize ("H1" with "Hctx Ha1"). iApply (expr_pred_bind (LETCTX _) with "H1"). @@ -519,9 +191,9 @@ Section logrel. iSpecialize ("H2" $! ss' with "Hctx [-Hx] Hx"). { - iApply ssubst_valid_cons. + iApply ssubst_valid_fin_cons1. iSplitR "Hl1 Hb1". - - iApply ssubst_valid_cons. + - iApply ssubst_valid_fin_cons1. iSplitL "Ha2"; first done. Transparent thunkedV thunked. simpl. @@ -603,8 +275,8 @@ Section logrel. Qed. Lemma compat_replace {S1 S2 : Set} - `{!EqDecision S1} `{!Finite S1} - `{!EqDecision S2} `{!Finite S2} + `(!EqDecision S1) `(!Finite S1) + `(!EqDecision S2) `(!Finite S2) `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} (Ω1 : S1 → ty) (Ω2 : S2 → ty) α β τ τ' : ⊢ valid1 Ω1 α (tRef τ) -∗ @@ -615,7 +287,7 @@ Section logrel. iIntros "H1 H2". iIntros (αs) "#Hctx Has". cbn-[interp_replace]. - rewrite ssubst_valid_app. + rewrite ssubst_valid_fin_app1. iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. iSpecialize ("H1" with "Hctx Ha1"). iSpecialize ("H2" with "Hctx Ha2"). @@ -712,8 +384,7 @@ Section logrel. { solve_proper. } unfold AppLSCtx. simpl. - unfold ssubst_valid. - iDestruct (ssubst_valid_lookup _ _ v with "Has Hx") as "Has". + iDestruct (ssubst_valid_fin_lookup1 _ _ _ _ _ _ v with "Has Hx") as "Has". iApply (wp_wand with "Has"). iIntros (w) "(%y & Hw1 & Hw2)"; simpl. iModIntro. @@ -726,8 +397,8 @@ Section logrel. Qed. Lemma compat_app {S1 S2 : Set} - `{!EqDecision S1} `{!Finite S1} - `{!EqDecision S2} `{!Finite S2} + `(!EqDecision S1) `(!Finite S1) + `(!EqDecision S2) `(!Finite S2) `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} (Ω1 : S1 → ty) (Ω2 : S2 → ty) α β τ1 τ2 : @@ -738,7 +409,7 @@ Section logrel. iIntros "H1 H2". iIntros (αs) "#Hctx Has". iEval(cbn-[interp_app]). - rewrite ssubst_valid_app. + rewrite ssubst_valid_fin_app1. iDestruct "Has" as "[Ha1 Ha2]". cbn-[interp_app]. iSpecialize ("H1" with "Hctx Ha1"). iSpecialize ("H2" with "Hctx Ha2"). @@ -781,7 +452,7 @@ Section logrel. iSpecialize ("H" $! ss' with "Hctx [-Hx] Hx"). { - iApply ssubst_valid_cons. + iApply ssubst_valid_fin_cons1. iFrame "Has". Local Transparent thunked thunkedV. simpl. @@ -809,7 +480,7 @@ Section logrel. Qed. Lemma fundamental_affine (S : Set) - {HE : EqDecision S} {HF : Finite S} + (HE : EqDecision S) (HF : Finite S) (Ω : S → ty) (e : expr S) τ : typed Ω e τ → @@ -820,11 +491,11 @@ Section logrel. iInduction H as [| | | | | | | | | |] "IH". - by iApply compat_var. - by iApply compat_lam. - - by iApply (@compat_app S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - - by iApply (@compat_pair S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - - by iApply (@compat_destruct S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_app EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_pair EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_destruct EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - by iApply compat_alloc. - - by iApply (@compat_replace S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_replace EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - by iApply compat_dealloc. - by iApply compat_nat. - by iApply compat_bool. @@ -839,30 +510,31 @@ Arguments interp_tnat {_ _ _ _ _ _}. Arguments interp_tunit {_ _ _ _ _ _}. Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} τ. +Arguments compat_app {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. +Arguments compat_pair {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. +Arguments compat_destruct {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. +Arguments compat_replace {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. + Local Definition rs : gReifiers NotCtxDep 2 := - gReifiers_cons NotCtxDep reify_store (gReifiers_cons NotCtxDep input_lang.interp.reify_io (gReifiers_nil NotCtxDep)). + gReifiers_cons reify_store (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. -Require Import gitrees.gitree.greifiers. - -Program Definition ı_scope R `{!Cofe R} : @interp_scope (gReifiers_ops NotCtxDep rs) R _ Empty_set := λne (x : ∅), match x with end. - Lemma logrel1_adequacy cr Σ R `{!Cofe R, !SubOfe natO R, !SubOfe unitO R, !SubOfe locO R} `{!invGpreS Σ} `{!statePreG rs R Σ} `{!heapPreG rs R Σ} τ - (α : interp_scope ∅ -n> IT (gReifiers_ops NotCtxDep rs) R) (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : + (α : interp_scope ∅ -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ}, (£ cr ⊢ valid1 rs notStuck (λne _: unitO, True)%I □ α τ)%I) → - ssteps (gReifiers_sReifier NotCtxDep rs) (α (ı_scope _)) st β st' k → + ssteps (gReifiers_sReifier NotCtxDep rs) (α ı_scope) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) - ∨ (∃ βv, IT_of_V βv ≡ β). + ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). 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 NotCtxDep rs) β st' β1 st1) - ∨ (∃ e, β ≡ Err e ∧ notStuck e)). + ∨ (∃ e, (β ≡ Err e)%stdpp ∧ notStuck e)). { intros [?|He]; first done. destruct He as [? [? []]]. } eapply (wp_safety (S cr)); eauto. @@ -877,9 +549,9 @@ Proof. iMod (new_heapG rs σ) as (H3) "H". iAssert (has_substate σ ∗ has_substate ios)%I with "[Hst]" as "[Hs Hio]". { unfold has_substate, has_full_state. - assert (of_state NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) st ≡ - of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state σ) - ⋅ of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state ios)) as ->; last first. + assert (of_state NotCtxDep rs (IT (gReifiers_ops rs) _) st ≡ + of_idx NotCtxDep rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ) + ⋅ of_idx NotCtxDep rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios))%stdpp as ->; last first. { rewrite -own_op. done. } unfold sR_idx. simpl. intro j. @@ -896,8 +568,8 @@ Proof. { iNext. iExists _. iFrame. } simpl. iPoseProof (@Hlog _ _ _ with "Hcr") as "Hlog". - iSpecialize ("Hlog" $! (ı_scope _) with "Hinv []"). - { iApply ssubst_valid_empty. } + iSpecialize ("Hlog" $! ı_scope with "Hinv []"). + { iApply ssubst_valid_fin_empty1. } iSpecialize ("Hlog" $! tt with "[//]"). iModIntro. iApply (wp_wand with "Hlog"). @@ -906,11 +578,11 @@ Qed. Definition R := sumO locO (sumO unitO natO). -Lemma logrel1_safety e τ (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : +Lemma logrel1_safety e τ (β : IT (gReifiers_ops rs) R) st st' k : typed □ e τ → - ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e (ı_scope _)) st β st' k → + ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ı_scope) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) - ∨ (∃ βv, IT_of_V βv ≡ β). + ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). Proof. intros Hty Hst. pose (Σ:=#[invΣ;stateΣ rs R;heapΣ rs R]). diff --git a/theories/examples/affine_lang/logrel2.v b/theories/examples/affine_lang/logrel2.v index e855def..3db5de0 100644 --- a/theories/examples/affine_lang/logrel2.v +++ b/theories/examples/affine_lang/logrel2.v @@ -1,11 +1,12 @@ +From stdpp Require Import finite. From iris.base_logic.lib Require Import na_invariants. -From gitrees Require Export gitree program_logic. +From iris.algebra Require Import gmap. +From gitrees Require Export gitree program_logic greifiers. From gitrees.examples.input_lang Require Import lang interp logpred. From gitrees.examples.affine_lang Require Import lang logrel1. From gitrees.effects Require Import store. From gitrees.lib Require Import pairs. -Require Import iris.algebra.gmap. -Require Import stdpp.finite. +From gitrees.utils Require Import finite_sets. Require Import Binding.Lib Binding.Set Binding.Env. @@ -60,7 +61,7 @@ Section glue. Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_store rs}. Context `{!subReifier reify_io rs}. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Context `{!SubOfe unitO R}. @@ -83,8 +84,6 @@ Section glue. Local Opaque thunked thunkedV Thunk. - Program Definition ı_scope : @lang_generic.interp_scope (gReifiers_ops NotCtxDep rs) R _ Empty_set := λne (x : ∅), match x with end. - Lemma compat_glue_to_affine_bool {S : Set} `{HE : EqDecision S} `{!Finite S} (Ω : S → ty) α : io_valid □ α Tnat ⊢ valid2 Ω (constO (glue2_bool _ (α ı_scope))) tBool. @@ -93,9 +92,7 @@ Section glue. iIntros (ss) "#Hctx Has". simpl. iIntros (σ) "[Hs Hp]". iSpecialize ("H" $! σ ı_scope with "Hs []"). - { unfold logpred.ssubst_valid. - iIntros ([]). - } + { iIntros ([]). } iSpecialize ("H" $! tt with "Hp"). simpl. iApply (wp_bind _ (IFSCtx _ _)). @@ -121,9 +118,7 @@ Section glue. iIntros (ss) "#Hctx Has". simpl. iIntros (σ) "[Hs Hp]". iSpecialize ("H" $! σ ı_scope with "Hs []"). - { unfold logpred.ssubst_valid. - iIntros ([]). - } + { iIntros ([]). } iSpecialize ("H" $! tt with "Hp"). simpl. iApply (wp_wand with "H"). @@ -140,7 +135,7 @@ Section glue. iIntros (σ ss) "Hs Hss". iIntros (?) "Hp". iSpecialize ("H" $! ss with "Hctx [] [$Hs $Hp]"). - { iApply ssubst_valid_empty. } + { iApply ssubst_valid_fin_empty1. } simpl. iApply (wp_wand with "H"). iIntros (αv) "Ha". iDestruct "Ha" as (σ') "[Ha [Hs Hp]]". @@ -156,7 +151,7 @@ Section glue. iIntros (σ ss) "Hs Hss". iIntros (?) "Hp". iSpecialize ("H" $! ss with "Hctx [] [$Hs $Hp]"). - { iApply ssubst_valid_empty. } + { iApply ssubst_valid_fin_empty1. } iApply (wp_wand with "H"). iIntros (αv) "Ha". iDestruct "Ha" as (σ') "[Ha [Hs Hp]]". iModIntro. iExists tt. eauto with iFrame. @@ -196,7 +191,7 @@ Section glue. simpl. iIntros (?) "Hp". iSpecialize ("H" $! ss with "Hctx [] [$Hs $Hp]"). - { iApply ssubst_valid_empty. } + { iApply ssubst_valid_fin_empty1. } simpl. iApply wp_let. { solve_proper. } iApply (wp_wand with "H"). @@ -267,7 +262,7 @@ Section glue. { iIntros (σ0 ss0) "Hs Has". simpl. iApply expr_pred_ret. simpl. eauto with iFrame. } iSpecialize ("G1" $! ss with "Hctx [] [$Hst $Hp]"). - { iApply ssubst_valid_empty. } + { iApply ssubst_valid_fin_empty1. } iApply (wp_wand with "G1"). clear βv σ'. iIntros (βv). iDestruct 1 as (σ') "[Hb [Hst Hp]]". @@ -432,11 +427,11 @@ Section glue. valid2 □ (constO α) τ1 ⊢ heap_ctx -∗ io_valid □ (constO (glue_from_affine _ Hconv α)) τ1'. Proof. - destruct Hconv. - + by iApply (@compat_glue_to_affine_bool). - + by iApply (@compat_glue_to_affine_nat). + + by iApply compat_glue_to_affine_bool. + + by iApply compat_glue_to_affine_nat. + iIntros "_". simpl. iApply compat_unit. - + simpl. iApply (@compat_glue_to_affine_fun). + + simpl. iApply compat_glue_to_affine_fun. * by apply glue_to_affine_compatibility. * apply glue_from_affine_compatibility. - destruct Hconv. @@ -459,11 +454,11 @@ Section glue. by iApply fundamental. - by iApply compat_var. - by iApply compat_lam. - - by iApply (@compat_app _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - - by iApply (@compat_pair _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - - by iApply (@compat_destruct _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_app EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_pair EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_destruct EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - by iApply compat_alloc. - - by iApply (@compat_replace _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ S1 S2 EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). + - by iApply (compat_replace EqDecisionLeft FiniteLeft EqDecisionRight FiniteRight). - by iApply compat_dealloc. - by iApply compat_nat. - by iApply compat_bool. @@ -473,28 +468,26 @@ Section glue. End glue. Local Definition rs : gReifiers NotCtxDep 2 - := gReifiers_cons NotCtxDep reify_store - (gReifiers_cons NotCtxDep input_lang.interp.reify_io (gReifiers_nil NotCtxDep)). + := gReifiers_cons reify_store + (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. -Require Import gitrees.gitree.greifiers. - Lemma logrel2_adequacy (cr : nat) R `{!Cofe R, !SubOfe locO R, !SubOfe natO R, !SubOfe unitO R} Σ `{!invGpreS Σ}`{!statePreG rs R Σ} `{!heapPreG rs R Σ} `{!na_invG Σ} - (τ : ty) (α : interp_scope Empty_set -n> IT (gReifiers_ops NotCtxDep rs) R) (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : + (τ : ty) (α : interp_scope Empty_set -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ} p, (£ cr ⊢ valid2 rs p □ α τ)%I) → - ssteps (gReifiers_sReifier NotCtxDep rs) (α (ı_scope rs)) st β st' k → + ssteps (gReifiers_sReifier NotCtxDep rs) (α ı_scope) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) - ∨ (β ≡ Err OtherError) - ∨ (∃ βv, IT_of_V βv ≡ β). + ∨ (β ≡ Err OtherError)%stdpp + ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). Proof. intros Hlog Hst. destruct (IT_to_V β) as [βv|] eqn:Hb. { right. right. exists βv. apply IT_of_to_V'. rewrite Hb; eauto. } cut ((∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) - ∨ (∃ e, β ≡ Err e ∧ s e)). + ∨ (∃ e, (β ≡ Err e)%stdpp ∧ s e)). { intros [?|He]; first eauto. right. left. destruct He as [? [? ->]]. done. } eapply (wp_safety (S cr) _ _ NotCtxDep rs s); eauto. @@ -509,9 +502,9 @@ Proof. iMod (new_heapG rs σ) as (H3) "H". iAssert (has_substate σ ∗ has_substate ios)%I with "[Hst]" as "[Hs Hio]". { unfold has_substate, has_full_state. - assert (of_state NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) st ≡ - of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state σ) - ⋅ of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state ios)) as ->; last first. + assert (of_state NotCtxDep rs (IT (gReifiers_ops rs) _) st ≡ + of_idx NotCtxDep rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ) + ⋅ of_idx NotCtxDep rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios))%stdpp as ->; last first. { rewrite -own_op. done. } unfold sR_idx. simpl. intro j. @@ -529,8 +522,8 @@ Proof. simpl. iMod na_alloc as (p) "Hp". iPoseProof (@Hlog _ _ _ p with "Hcr") as "Hlog". - iSpecialize ("Hlog" $! (ı_scope _) with "Hinv []"). - { iApply ssubst_valid_empty. } + iSpecialize ("Hlog" $! ı_scope with "Hinv []"). + { iApply ssubst_valid_fin_empty1. } unfold expr_pred. simpl. iSpecialize ("Hlog" $! ios with "[$Hio $Hp]"). iModIntro. simpl. @@ -540,12 +533,12 @@ Qed. Definition R := sumO locO (sumO natO unitO). -Lemma logrel2_safety e τ (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : +Lemma logrel2_safety e τ (β : IT (gReifiers_ops rs) R) st st' k : typed_glued □ e τ → - ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e (ı_scope _)) st β st' k → + ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ı_scope) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) - ∨ (β ≡ Err OtherError) - ∨ (∃ βv, IT_of_V βv ≡ β). + ∨ (β ≡ Err OtherError)%stdpp + ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). Proof. intros Hty Hst. pose (Σ:=#[invΣ;stateΣ rs R;heapΣ rs R;na_invΣ]). diff --git a/theories/examples/input_lang/interp.v b/theories/examples/input_lang/interp.v index c0ae876..0f8c135 100644 --- a/theories/examples/input_lang/interp.v +++ b/theories/examples/input_lang/interp.v @@ -1,8 +1,7 @@ From gitrees Require Import gitree lang_generic. From gitrees.examples.input_lang Require Import lang. -Require Import Binding.Lib. -Require Import Binding.Set. +Require Import Binding.Lib Binding.Set. Notation stateO := (leibnizO state). @@ -92,7 +91,7 @@ Section weakestpre. Context {sz : nat}. Variable (rs : gReifiers NotCtxDep sz). Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Notation IT := (IT F R). @@ -137,7 +136,7 @@ Section interp. Context {subR : subReifier reify_io rs}. Context {R} `{CR : !Cofe R}. Context `{!SubOfe natO R}. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). @@ -164,10 +163,10 @@ Section interp. Typeclasses Opaque interp_natop. Opaque laterO_map. - Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) - : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := - λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), - body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. + Program Definition interp_rec_pre {S : Set} (body : interp_scope (inc (inc S)) -n> IT) + : laterO (interp_scope S -n> IT) -n> interp_scope S -n> IT := + λne self env, Fun $ laterO_map (λne (self : interp_scope S -n> IT) (a : IT), + body (extend_scope (extend_scope env (self env)) a)) self. Next Obligation. intros. solve_proper_prepare. @@ -191,14 +190,14 @@ Section interp. Qed. Program Definition interp_rec {S : Set} - (body : @interp_scope F R _ (inc (inc S)) -n> IT) : - @interp_scope F R _ S -n> IT := + (body : interp_scope (inc (inc S)) -n> IT) : + interp_scope S -n> IT := mmuu (interp_rec_pre body). Program Definition ir_unf {S : Set} - (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := - λne a, body (@extend_scope F R _ _ - (@extend_scope F R _ _ env (interp_rec body env)) + (body : interp_scope (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (extend_scope + (extend_scope env (interp_rec body env)) a). Next Obligation. intros. @@ -206,7 +205,7 @@ Section interp. f_equiv. intros [| [| y']]; simpl; solve_proper. Qed. - Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : + Lemma interp_rec_unfold {S : Set} (body : interp_scope (inc (inc S)) -n> IT) env : interp_rec body env ≡ Fun $ Next $ ir_unf body env. Proof. trans (interp_rec_pre body (Next (interp_rec body)) env). diff --git a/theories/examples/input_lang/logpred.v b/theories/examples/input_lang/logpred.v index b548bc9..303d9d4 100644 --- a/theories/examples/input_lang/logpred.v +++ b/theories/examples/input_lang/logpred.v @@ -2,12 +2,13 @@ From gitrees Require Import gitree program_logic lang_generic. From gitrees.examples.input_lang Require Import lang interp. Require Import Binding.Lib Binding.Set Binding.Env. +Require Import gitrees.gitree.greifiers. Section io_lang. Context {sz : nat}. Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_io rs}. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Notation IT := (IT F R). @@ -41,15 +42,10 @@ Section io_lang. | Tarr τ1 τ2 => interp_tarr (interp_ty τ1) (interp_ty τ2) end. - Definition ssubst_valid {S : Set} - (Γ : S -> ty) - (ss : @interp_scope F R _ S) : iProp := - (∀ x, □ expr_pred (ss x) (interp_ty (Γ x)))%I. + Notation ssubst_valid := (ssubst_valid1 rs ty interp_ty expr_pred). #[global] Instance io_lang_interp_ty_pers τ βv : Persistent (io_lang.interp_ty τ βv). Proof. induction τ; apply _. Qed. - #[global] Instance ssubst_valid_pers {S : Set} (Γ : S → ty) ss : Persistent (ssubst_valid Γ ss). - Proof. apply _. Qed. Program Definition valid1 {S : Set} (Γ : S → ty) (α : interp_scope S -n> IT) (τ : ty) : iProp := (∀ σ ss, has_substate σ -∗ ssubst_valid Γ ss -∗ @@ -250,21 +246,17 @@ End io_lang. Arguments interp_ty {_ _ _ _ _ _ _ _ _ _ _ _} τ. Arguments interp_tarr {_ _ _ _ _ _ _ _ _ _ _} Φ1 Φ2. -Local Definition rs : gReifiers NotCtxDep _ := gReifiers_cons NotCtxDep reify_io (gReifiers_nil NotCtxDep). +Local Definition rs : gReifiers NotCtxDep _ := gReifiers_cons reify_io gReifiers_nil. Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. -Require Import gitrees.gitree.greifiers. - -Program Definition ı_scope R `{!Cofe R} : @interp_scope (gReifiers_ops NotCtxDep rs) R _ Empty_set := λne (x : ∅), match x with end. - Lemma logpred_adequacy cr Σ R `{!Cofe R, SubOfe natO R} `{!invGpreS Σ} `{!statePreG rs R Σ} τ - (α : interp_scope ∅ -n> IT (gReifiers_ops NotCtxDep rs) R) - (β : IT (gReifiers_ops NotCtxDep rs) R) st st' k : + (α : interp_scope ∅ -n> IT (gReifiers_ops rs) R) + (β : IT (gReifiers_ops rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ}, (£ cr ⊢ valid1 rs notStuck (λne _ : unitO, True)%I □ α τ)%I) → - ssteps (gReifiers_sReifier NotCtxDep rs) (α (ı_scope _)) st β st' k → + ssteps (gReifiers_sReifier NotCtxDep rs) (α ı_scope) st β st' k → (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (∃ βv, IT_of_V βv ≡ β). Proof. @@ -287,8 +279,8 @@ Proof. destruct st as [σ []]. iAssert (has_substate σ) with "[Hst]" as "Hs". { unfold has_substate, has_full_state. - assert (of_state NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) (σ,()) ≡ - of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) _) sR_idx (sR_state σ)) as ->; last done. + assert (of_state NotCtxDep rs (IT (gReifiers_ops rs) _) (σ,()) ≡ + of_idx NotCtxDep 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. @@ -310,9 +302,9 @@ Proof. done. Qed. -Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops NotCtxDep (gReifiers_sReifier NotCtxDep rs)) natO) k : +Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier NotCtxDep rs)) natO) k : typed □ e τ → - ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e (ı_scope _)) (σ, ()) β st' k → + ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ı_scope) (σ, ()) β st' k → (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) ∨ (∃ βv, IT_of_V βv ≡ β). Proof. diff --git a/theories/examples/input_lang/logrel.v b/theories/examples/input_lang/logrel.v index 53f9756..c058fd2 100644 --- a/theories/examples/input_lang/logrel.v +++ b/theories/examples/input_lang/logrel.v @@ -1,13 +1,14 @@ (** Logical relation for adequacy for the IO lang *) From gitrees Require Import gitree lang_generic. From gitrees.examples.input_lang Require Import lang interp. +Require Import gitrees.gitree.greifiers. Require Import Binding.Lib Binding.Set Binding.Env. Section logrel. Context {sz : nat}. Variable (rs : gReifiers NotCtxDep sz). Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Notation IT := (IT F natO). Notation ITV := (ITV F natO). Context `{!invGS Σ, !stateG rs natO Σ}. @@ -353,24 +354,22 @@ Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (LitV n : val S). Proof. Transparent RetV. unfold RetV. simpl. done. Opaque RetV. Qed. -Definition rs : gReifiers NotCtxDep 1 := gReifiers_cons NotCtxDep reify_io (gReifiers_nil NotCtxDep). - -Require Import gitrees.gitree.greifiers. +Definition rs : gReifiers NotCtxDep 1 := gReifiers_cons reify_io gReifiers_nil. -Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops NotCtxDep rs) natO) (e : expr S) n σ σ' k : +Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (True ⊢ logrel rs Tnat α e)%I) → ssteps (gReifiers_sReifier NotCtxDep rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. - pose (ϕ := λ (βv : ITV (gReifiers_ops NotCtxDep rs) natO), + pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), ∃ m σ', prim_steps e σ (Val $ κ βv) σ' m). cut (ϕ (RetV n)). { destruct 1 as ( m' & σ2 & Hm). exists m', σ2. revert Hm. by rewrite κ_Ret. } eapply (wp_adequacy 0); eauto. intros Hinv1 Hst1. - pose (Φ := (λ (βv : ITV (gReifiers_ops NotCtxDep rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) + pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) ∗ ⌜∃ m σ', prim_steps e σ (Val $ LitV n) σ' m⌝)%I). assert (NonExpansive Φ). { unfold Φ. @@ -392,8 +391,8 @@ Proof. iPoseProof (Hlog with "[//]") as "Hlog". iAssert (has_substate σ) with "[Hs]" as "Hs". { unfold has_substate, has_full_state. - assert (of_state NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) natO) (σ, ()) ≡ - of_idx NotCtxDep rs (IT (gReifiers_ops NotCtxDep rs) natO) 0 σ) as ->; last done. + assert (of_state NotCtxDep rs (IT (gReifiers_ops rs) natO) (σ, ()) ≡ + of_idx NotCtxDep rs (IT (gReifiers_ops rs) natO) 0 σ)%stdpp as ->; last done. intro j. unfold sR_idx. simpl. unfold of_state, of_idx. destruct decide as [Heq|]; last first. @@ -412,8 +411,6 @@ Proof. iExists l. iSplit; eauto. Qed. -Program Definition ı_scope : @interp_scope (gReifiers_ops NotCtxDep rs) natO _ Empty_set := λne (x : ∅), match x with end. - Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : typed □ e Tnat → ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ı_scope) (σ,()) (Ret k : IT _ natO) σ' n → diff --git a/theories/examples/input_lang_callcc/hom.v b/theories/examples/input_lang_callcc/hom.v index 3e4f03e..661374b 100644 --- a/theories/examples/input_lang_callcc/hom.v +++ b/theories/examples/input_lang_callcc/hom.v @@ -9,7 +9,7 @@ Section hom. Context {sz : nat}. Context {rs : gReifiers CtxDep sz}. Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops CtxDep rs). + Notation F := (gReifiers_ops rs). Notation IT := (IT F natO). Notation ITV := (ITV F natO). diff --git a/theories/examples/input_lang_callcc/interp.v b/theories/examples/input_lang_callcc/interp.v index 8e41b93..5daeec3 100644 --- a/theories/examples/input_lang_callcc/interp.v +++ b/theories/examples/input_lang_callcc/interp.v @@ -176,7 +176,7 @@ Section weakestpre. Context {sz : nat}. Variable (rs : gReifiers CtxDep sz). Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops CtxDep rs). + Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. Notation IT := (IT F R). @@ -289,7 +289,7 @@ Section interp. Context {subR : subReifier reify_io rs}. Context {R} `{CR : !Cofe R}. Context `{!SubOfe natO R}. - Notation F := (gReifiers_ops CtxDep rs). + Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). diff --git a/theories/examples/input_lang_callcc/logrel.v b/theories/examples/input_lang_callcc/logrel.v index 89d9c44..cbfd44f 100644 --- a/theories/examples/input_lang_callcc/logrel.v +++ b/theories/examples/input_lang_callcc/logrel.v @@ -2,6 +2,7 @@ From gitrees Require Import gitree. From gitrees.examples.input_lang_callcc Require Import lang interp hom. Require Import gitrees.lang_generic. +Require Import gitrees.gitree.greifiers. Require Import Binding.Lib Binding.Set Binding.Env. Open Scope stdpp_scope. @@ -10,7 +11,7 @@ Section logrel. Context {sz : nat}. Variable (rs : gReifiers CtxDep sz). Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops CtxDep rs). + Notation F := (gReifiers_ops rs). Notation IT := (IT F natO). Notation ITV := (ITV F natO). Context `{!invGS Σ, !stateG rs natO Σ}. @@ -646,10 +647,11 @@ Section logrel. with fundamental_val {S : Set} (Γ : S -> ty) τ v : typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. Proof. - - induction 1; simpl. - + by apply fundamental_val. + - intros H. + induction H. + + by iApply fundamental_val. + rewrite -H. - by apply compat_var. + by iApply compat_var. + iApply compat_app. ++ iApply IHtyped1. ++ iApply IHtyped2. @@ -684,19 +686,17 @@ Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (LitV n : val S). Proof. Transparent RetV. unfold RetV. simpl. done. Opaque RetV. Qed. -Definition rs : gReifiers CtxDep 1 := gReifiers_cons CtxDep reify_io (gReifiers_nil CtxDep). - -Require Import gitrees.gitree.greifiers. +Definition rs : gReifiers CtxDep 1 := gReifiers_cons reify_io gReifiers_nil. Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} - (α : IT (gReifiers_ops CtxDep rs) natO) + (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (⊢ logrel rs Tnat α e)%I) → ssteps (gReifiers_sReifier CtxDep rs) α (σ, ()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. - pose (ϕ := λ (βv : ITV (gReifiers_ops CtxDep rs) natO), + pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), ∃ m σ', prim_steps e σ (Val $ κ βv) σ' m). cut (ϕ (RetV n)). { @@ -705,7 +705,7 @@ Proof. } eapply (wp_adequacy 0); eauto. intros Hinv1 Hst1. - pose (Φ := (λ (βv : ITV (gReifiers_ops CtxDep rs) natO), + pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) ∗ ⌜∃ m σ', prim_steps e σ (Val $ LitV n) σ' m⌝)%I). assert (NonExpansive Φ). @@ -731,8 +731,8 @@ Proof. iAssert (has_substate σ) with "[Hs]" as "Hs". { unfold has_substate, has_full_state. - assert ((of_state CtxDep rs (IT (sReifier_ops CtxDep (gReifiers_sReifier CtxDep rs)) natO) (σ, ())) ≡ - (of_idx CtxDep rs (IT (sReifier_ops CtxDep (gReifiers_sReifier CtxDep rs)) natO) sR_idx (sR_state σ))) + assert ((of_state CtxDep rs (IT (sReifier_ops (gReifiers_sReifier CtxDep rs)) natO) (σ, ())) ≡ + (of_idx CtxDep rs (IT (sReifier_ops (gReifiers_sReifier CtxDep rs)) natO) sR_idx (sR_state σ))) as -> ; last done. intros j. unfold sR_idx. simpl. unfold of_state, of_idx. @@ -765,8 +765,6 @@ Proof. iExists l. iSplit; eauto. Qed. -Program Definition ı_scope : @interp_scope (gReifiers_ops CtxDep rs) natO _ Empty_set := λne (x : ∅), match x with end. - Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : typed □ e Tnat → ssteps (gReifiers_sReifier CtxDep rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → diff --git a/theories/gitree/greifiers.v b/theories/gitree/greifiers.v index f9ff81e..1e549a4 100644 --- a/theories/gitree/greifiers.v +++ b/theories/gitree/greifiers.v @@ -7,9 +7,6 @@ Section greifiers_generic. #[local] Open Scope type. Context (a : is_ctx_dep). Notation sReifier := (sReifier a). - Notation sReifier_ops := (sReifier_ops a). - Notation sReifier_state := (sReifier_state a). - Notation sReifier_re := (sReifier_re a). (** Global reifiers: a collection of reifiers *) Inductive gReifiers : nat → Type := @@ -135,7 +132,7 @@ Section greifiers. let fs := gState_decomp NotCtxDep i st in let σ := fs.1 in let rest := fs.2 in - let rx := sReifier_re NotCtxDep (rs !!! i) op' (x, σ) in + let rx := sReifier_re (rs !!! i) op' (x, σ) in optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) rx. Next Obligation. solve_proper_please. Qed. @@ -153,7 +150,7 @@ Section greifiers. let fs := gState_decomp CtxDep i b in let σ := fs.1 in let rest := fs.2 in - let rx := sReifier_re CtxDep (rs !!! i) op' (a, σ, c) in + let rx := sReifier_re (rs !!! i) op' (a, σ, c) in optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) rx. Next Obligation. solve_proper_please. Qed. @@ -194,14 +191,14 @@ Section greifiers. Defined. Lemma gReifiers_re_idx_ctx_dep {n} (i : fin n) (rs : gReifiers CtxDep n) - {X} `{!Cofe X} (op : opid (sReifier_ops CtxDep (rs !!! i))) - (x : Ins (sReifier_ops CtxDep _ op) ♯ X) - (σ : sReifier_state CtxDep (rs !!! i) ♯ X) + {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) + (x : Ins (sReifier_ops _ op) ♯ X) + (σ : sReifier_state (rs !!! i) ♯ X) (rest : gState_rest CtxDep i rs ♯ X) - (κ : (Outs (sReifier_ops CtxDep (rs !!! i) op) ♯ X -n> laterO X)) : + (κ : (Outs (sReifier_ops (rs !!! i) op) ♯ X -n> laterO X)) : gReifiers_re CtxDep rs (existT i op) (x, gState_recomp CtxDep rest σ, κ) ≡ optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) - (sReifier_re CtxDep (rs !!! i) op (x, σ, κ)). + (sReifier_re (rs !!! i) op (x, σ, κ)). Proof. unfold gReifiers_re. cbn-[prodO_map optionO_map]. f_equiv; last repeat f_equiv. @@ -213,13 +210,13 @@ Section greifiers. Qed. Lemma gReifiers_re_idx_ctx_indep {n} (i : fin n) (rs : gReifiers NotCtxDep n) - {X} `{!Cofe X} (op : opid (sReifier_ops NotCtxDep (rs !!! i))) - (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) - (σ : sReifier_state NotCtxDep (rs !!! i) ♯ X) + {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) + (x : Ins (sReifier_ops _ op) ♯ X) + (σ : sReifier_state (rs !!! i) ♯ X) (rest : gState_rest NotCtxDep i rs ♯ X) : gReifiers_re NotCtxDep rs (existT i op) (x, gState_recomp NotCtxDep rest σ) ≡ optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) - (sReifier_re NotCtxDep (rs !!! i) op (x, σ)). + (sReifier_re (rs !!! i) op (x, σ)). Proof. unfold gReifiers_re. cbn-[prodO_map optionO_map]. f_equiv; last repeat f_equiv. @@ -231,26 +228,26 @@ Section greifiers. Qed. Program Definition gReifiers_re_idx_type {n} a (i : fin n) (rs : gReifiers a n) - {X} `{!Cofe X} (op : opid (sReifier_ops a (rs !!! i))) - (x : Ins (sReifier_ops a _ op) ♯ X) - (σ : sReifier_state a (rs !!! i) ♯ X) + {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) + (x : Ins (sReifier_ops _ op) ♯ X) + (σ : sReifier_state (rs !!! i) ♯ X) (rest : gState_rest a i rs ♯ X) : Type. Proof. destruct a. - - apply (∀ (κ : (Outs (sReifier_ops CtxDep (rs !!! i) op) ♯ X -n> laterO X)), + - apply (∀ (κ : (Outs (sReifier_ops (rs !!! i) op) ♯ X -n> laterO X)), gReifiers_re CtxDep rs (existT i op) (x, gState_recomp CtxDep rest σ, κ) ≡ optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) - (sReifier_re CtxDep (rs !!! i) op (x, σ, κ))). + (sReifier_re (rs !!! i) op (x, σ, κ))). - apply (gReifiers_re NotCtxDep rs (existT i op) (x, gState_recomp NotCtxDep rest σ) ≡ optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) - (sReifier_re NotCtxDep (rs !!! i) op (x, σ))). + (sReifier_re (rs !!! i) op (x, σ))). Defined. Lemma gReifiers_re_idx {n} a (i : fin n) (rs : gReifiers a n) - {X} `{!Cofe X} (op : opid (sReifier_ops a (rs !!! i))) - (x : Ins (sReifier_ops a _ op) ♯ X) - (σ : sReifier_state a (rs !!! i) ♯ X) + {X} `{!Cofe X} (op : opid (sReifier_ops (rs !!! i))) + (x : Ins (sReifier_ops _ op) ♯ X) + (σ : sReifier_state (rs !!! i) ♯ X) (rest : gState_rest a i rs ♯ X) : gReifiers_re_idx_type a i rs op x σ rest. Proof. destruct a. @@ -261,34 +258,34 @@ Section greifiers. Program Definition sR_re_type {n} {X} `{!Cofe X} (a : is_ctx_dep) (r : sReifier a) (rs : gReifiers a n) (sR_idx : fin n) - (sR_ops : subEff (sReifier_ops a r) (sReifier_ops a (rs !!! sR_idx))) - (sR_state : sReifier_state a r ♯ X ≃ sReifier_state a (rs !!! sR_idx) ♯ X) - (m : nat) (op : opid (sReifier_ops a r)) : Type. + (sR_ops : subEff (sReifier_ops r) (sReifier_ops (rs !!! sR_idx))) + (sR_state : sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X) + (m : nat) (op : opid (sReifier_ops r)) : Type. Proof. destruct a. - - apply (∀ (x : Ins (sReifier_ops CtxDep r op) ♯ X) + - apply (∀ (x : Ins (sReifier_ops r op) ♯ X) (y : laterO X) - (s1 s2 : sReifier_state CtxDep r ♯ X) - (k : (Outs (sReifier_ops CtxDep r op) ♯ X -n> laterO X)), - sReifier_re CtxDep r op (x, s1, k) ≡{m}≡ Some (y, s2) → - sReifier_re CtxDep (rs !!! sR_idx) (subEff_opid op) + (s1 s2 : sReifier_state r ♯ X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)), + sReifier_re r op (x, s1, k) ≡{m}≡ Some (y, s2) → + @sReifier_re CtxDep (rs !!! sR_idx) _ _ (subEff_opid op) (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡{m}≡ Some (y, sR_state s2)). - - apply (∀ (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) - (y : Outs (sReifier_ops NotCtxDep _ op) ♯ X) - (s1 s2 : sReifier_state NotCtxDep r ♯ X), - sReifier_re NotCtxDep r op (x, s1) ≡{m}≡ Some (y, s2) → - sReifier_re NotCtxDep (rs !!! sR_idx) (subEff_opid op) + - apply (∀ (x : Ins (sReifier_ops _ op) ♯ X) + (y : Outs (sReifier_ops _ op) ♯ X) + (s1 s2 : sReifier_state r ♯ X), + sReifier_re r op (x, s1) ≡{m}≡ Some (y, s2) → + @sReifier_re NotCtxDep (rs !!! sR_idx) _ _ (subEff_opid op) (subEff_ins x, sR_state s1) ≡{m}≡ Some (subEff_outs y, sR_state s2)). Defined. Class subReifier {n} {a : is_ctx_dep} (r : sReifier a) (rs : gReifiers a n) := { sR_idx : fin n; - sR_ops :: subEff (sReifier_ops a r) (sReifier_ops a (rs !!! sR_idx)); + sR_ops :: subEff (sReifier_ops r) (sReifier_ops (rs !!! sR_idx)); sR_state {X} `{!Cofe X} : - sReifier_state a r ♯ X ≃ sReifier_state a (rs !!! sR_idx) ♯ X; - sR_re (m : nat) {X} `{!Cofe X} (op : opid (sReifier_ops a r)) + sReifier_state r ♯ X ≃ sReifier_state (rs !!! sR_idx) ♯ X; + sR_re (m : nat) {X} `{!Cofe X} (op : opid (sReifier_ops r)) : sR_re_type a r rs sR_idx sR_ops (@sR_state X _) m op }. @@ -331,7 +328,7 @@ Section greifiers. #[local] Definition subR_op {n} {a : is_ctx_dep} {r : sReifier a} {rs : gReifiers a n} `{!subReifier r rs} : - opid (sReifier_ops a r) → opid (gReifiers_ops a rs). + opid (sReifier_ops r) → opid (gReifiers_ops a rs). Proof. intros op. simpl. @@ -340,7 +337,7 @@ Section greifiers. #[export] Instance subReifier_subEff {n} {a : is_ctx_dep} {r : sReifier a} {rs : gReifiers a n} `{!subReifier r rs} : - subEff (sReifier_ops a r) (gReifiers_ops a rs). + subEff (sReifier_ops r) (gReifiers_ops a rs). Proof. simple refine {| subEff_opid := subR_op |}. - intros op X ?. simpl. @@ -351,29 +348,29 @@ Section greifiers. Program Definition subReifier_reify_idx_type {n} (a : is_ctx_dep) (r : sReifier a) (rs : gReifiers a n) - `{!subReifier r rs} X `{!Cofe X} (op : opid (sReifier_ops a r)) : Type. + `{!subReifier r rs} X `{!Cofe X} (op : opid (sReifier_ops r)) : Type. Proof. destruct a. - - apply (∀ (x : Ins (sReifier_ops CtxDep r op) ♯ X) + - apply (∀ (x : Ins (sReifier_ops r op) ♯ X) (y : laterO X) - (s1 s2 : sReifier_state CtxDep r ♯ X) - (k : (Outs (sReifier_ops CtxDep r op) ♯ X -n> laterO X)), - sReifier_re CtxDep r op (x, s1, k) ≡ Some (y, s2) → - sReifier_re CtxDep (rs !!! sR_idx) (subEff_opid op) + (s1 s2 : sReifier_state r ♯ X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)), + sReifier_re r op (x, s1, k) ≡ Some (y, s2) → + @sReifier_re CtxDep (rs !!! sR_idx) _ _ (subEff_opid op) (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ Some (y, sR_state s2)). - - apply (∀ (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) - (y : Outs (sReifier_ops NotCtxDep _ op) ♯ X) - (s1 s2 : sReifier_state NotCtxDep r ♯ X), - sReifier_re NotCtxDep r op (x, s1) ≡ Some (y, s2) → - sReifier_re NotCtxDep (rs !!! sR_idx) (subEff_opid op) + - apply (∀ (x : Ins (sReifier_ops _ op) ♯ X) + (y : Outs (sReifier_ops _ op) ♯ X) + (s1 s2 : sReifier_state r ♯ X), + sReifier_re r op (x, s1) ≡ Some (y, s2) → + @sReifier_re NotCtxDep (rs !!! sR_idx) _ _ (subEff_opid op) (subEff_ins x, sR_state s1) ≡ Some (subEff_outs y, sR_state s2)). Defined. Lemma subReifier_reify_idx {n} {a : is_ctx_dep} (r : sReifier a) (rs : gReifiers a n) - `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops a r)) + `{!subReifier r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) : subReifier_reify_idx_type a r rs X op. Proof. destruct a. @@ -391,19 +388,19 @@ Section greifiers. Program Definition subReifier_reify_type {n} (a : is_ctx_dep) (r : sReifier a) (rs : gReifiers a n) `{!subReifier r rs} X `{!Cofe X} - (op : opid (sReifier_ops a r)) : Type. + (op : opid (sReifier_ops r)) : Type. Proof. destruct a. - - apply (∀ (x : Ins (sReifier_ops CtxDep _ op) ♯ X) (y : laterO X) - (k : (Outs (sReifier_ops CtxDep r op) ♯ X -n> laterO X)) - (σ σ' : sReifier_state CtxDep r ♯ X) (rest : gState_rest CtxDep sR_idx rs ♯ X), - sReifier_re CtxDep r op (x, σ, k) ≡ Some (y, σ') → + - apply (∀ (x : Ins (sReifier_ops _ op) ♯ X) (y : laterO X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) + (σ σ' : sReifier_state r ♯ X) (rest : gState_rest CtxDep sR_idx rs ♯ X), + sReifier_re r op (x, σ, k) ≡ Some (y, σ') → gReifiers_re CtxDep rs (subEff_opid op) (subEff_ins x, gState_recomp CtxDep rest (sR_state σ), k ◎ (subEff_outs ^-1)) ≡ Some (y, gState_recomp CtxDep rest (sR_state σ'))). - - apply (∀ (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) (y : Outs (sReifier_ops NotCtxDep _ op) ♯ X) - (σ σ' : sReifier_state NotCtxDep r ♯ X) (rest : gState_rest NotCtxDep sR_idx rs ♯ X), - sReifier_re NotCtxDep r op (x,σ) ≡ Some (y, σ') → + - apply (∀ (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) + (σ σ' : sReifier_state r ♯ X) (rest : gState_rest NotCtxDep sR_idx rs ♯ X), + sReifier_re r op (x,σ) ≡ Some (y, σ') → gReifiers_re NotCtxDep rs (subEff_opid op) (subEff_ins x, gState_recomp NotCtxDep rest (sR_state σ)) ≡ Some (subEff_outs y, gState_recomp NotCtxDep rest (sR_state σ'))). @@ -411,7 +408,7 @@ Section greifiers. Lemma subReifier_reify {n} {a : is_ctx_dep} (r : sReifier a) (rs : gReifiers a n) `{!subReifier r rs} {X} `{!Cofe X} - (op : opid (sReifier_ops a r)) : subReifier_reify_type a r rs X op. + (op : opid (sReifier_ops r)) : subReifier_reify_type a r rs X op. Proof. destruct a. - simpl. @@ -422,7 +419,7 @@ Section greifiers. simpl in J'. rewrite J'; clear J'. transitivity (prod_map (λ x0 : laterO X, x0) - (λ st : sReifier_state CtxDep (rs !!! sR_idx) ♯ X, + (λ st : sReifier_state (rs !!! sR_idx) ♯ X, (gState_decomp' CtxDep sR_idx rs ^-1) (st, H)) <$> (Some (y, sR_state σ'))). + unfold prod_map. @@ -439,9 +436,9 @@ Section greifiers. as J'. simpl in J'. rewrite J'; clear J'. - transitivity (prod_map (λ x0 : Outs (sReifier_ops NotCtxDep (rs !!! sR_idx) + transitivity (prod_map (λ x0 : Outs (sReifier_ops (rs !!! sR_idx) (subEff_opid op)) ♯ X, x0) - (λ st : sReifier_state NotCtxDep (rs !!! sR_idx) ♯ X, + (λ st : sReifier_state (rs !!! sR_idx) ♯ X, (gState_decomp' NotCtxDep sR_idx rs ^-1) (st, rest)) <$> (Some (subEff_outs y, sR_state σ'))). + unfold prod_map. @@ -476,53 +473,55 @@ Section greifiers. Qed. Lemma subReifier_reify_idxI_ctx_dep (r : sReifier CtxDep) - `{!@subReifier sz CtxDep r rs} {X} `{!Cofe X} (op : opid (sReifier_ops CtxDep r)) - (x : Ins (sReifier_ops CtxDep _ op) ♯ X) + `{!@subReifier sz CtxDep r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops _ op) ♯ X) (y : laterO X) - (k : (Outs (sReifier_ops CtxDep r op) ♯ X -n> laterO X)) - (s1 s2 : sReifier_state CtxDep r ♯ X) : - sReifier_re CtxDep r op (x, s1, k) ≡ Some (y, s2) ⊢@{iProp} - sReifier_re CtxDep (rs !!! sR_idx) (subEff_opid op) - (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ - Some (y, sR_state s2). + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) + (s1 s2 : sReifier_state r ♯ X) : + sReifier_re r op (x, s1, k) ≡ Some (y, s2) + ⊢@{iProp} + sReifier_re (rs !!! sR_idx) (subEff_opid op) + (subEff_ins x, sR_state s1, k ◎ (subEff_outs ^-1)) ≡ + Some (y, sR_state s2). Proof. apply uPred.internal_eq_entails=>m. intros H'. - rewrite (sR_re (a := CtxDep)); last first. + rewrite (@sR_re _ CtxDep); last first. - rewrite H'. reflexivity. - reflexivity. Qed. Lemma subReifier_reify_idxI_ctx_indep (r : sReifier NotCtxDep) - `{!@subReifier sz NotCtxDep r rs} {X} `{!Cofe X} (op : opid (sReifier_ops NotCtxDep r)) - (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) - (y : Outs (sReifier_ops NotCtxDep _ op) ♯ X) - (s1 s2 : sReifier_state NotCtxDep r ♯ X) : - sReifier_re NotCtxDep r op (x, s1) ≡ Some (y, s2) + `{!@subReifier sz NotCtxDep r rs} {X} `{!Cofe X} (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops _ op) ♯ X) + (y : Outs (sReifier_ops _ op) ♯ X) + (s1 s2 : sReifier_state r ♯ X) : + sReifier_re r op (x, s1) ≡ Some (y, s2) ⊢@{iProp} - sReifier_re NotCtxDep (rs !!! sR_idx) (subEff_opid op) + sReifier_re (rs !!! sR_idx) (subEff_opid op) (subEff_ins x, sR_state s1) ≡ Some (subEff_outs y, sR_state s2). Proof. apply uPred.internal_eq_entails=>m. - apply (sR_re (a := NotCtxDep)). + apply (@sR_re _ NotCtxDep). Qed. Lemma subReifier_reifyI_ctx_dep (r : sReifier CtxDep) `{!@subReifier sz CtxDep r rs} {X} `{!Cofe X} - (op : opid (sReifier_ops CtxDep r)) - (x : Ins (sReifier_ops CtxDep _ op) ♯ X) (y : laterO X) - (k : (Outs (sReifier_ops CtxDep r op) ♯ X -n> laterO X)) - (σ σ' : sReifier_state CtxDep r ♯ X) (rest : gState_rest CtxDep sR_idx rs ♯ X) : - sReifier_re CtxDep r op (x,σ, k) ≡ Some (y, σ') ⊢@{iProp} - gReifiers_re CtxDep rs (subEff_opid op) - (subEff_ins x, gState_recomp CtxDep rest (sR_state σ), k ◎ (subEff_outs ^-1)) - ≡ Some (y, gState_recomp CtxDep rest (sR_state σ')). + (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops _ op) ♯ X) (y : laterO X) + (k : (Outs (sReifier_ops r op) ♯ X -n> laterO X)) + (σ σ' : sReifier_state r ♯ X) (rest : gState_rest CtxDep sR_idx rs ♯ X) : + sReifier_re r op (x,σ, k) ≡ Some (y, σ') + ⊢@{iProp} + gReifiers_re CtxDep rs (subEff_opid op) + (subEff_ins x, gState_recomp CtxDep rest (sR_state σ), k ◎ (subEff_outs ^-1)) + ≡ Some (y, gState_recomp CtxDep rest (sR_state σ')). Proof. apply uPred.internal_eq_entails=>m. intros He. - eapply (sR_re (a := CtxDep)) in He. + eapply (@sR_re _ CtxDep) in He. rewrite (gReifiers_re_idx CtxDep)//. rewrite He. simpl. reflexivity. @@ -530,10 +529,10 @@ Section greifiers. Lemma subReifier_reifyI_ctx_indep (r : sReifier NotCtxDep) `{!@subReifier sz NotCtxDep r rs} {X} `{!Cofe X} - (op : opid (sReifier_ops NotCtxDep r)) - (x : Ins (sReifier_ops NotCtxDep _ op) ♯ X) (y : Outs (sReifier_ops NotCtxDep _ op) ♯ X) - (σ σ' : sReifier_state NotCtxDep r ♯ X) (rest : gState_rest NotCtxDep sR_idx rs ♯ X) : - sReifier_re NotCtxDep r op (x,σ) ≡ Some (y, σ') + (op : opid (sReifier_ops r)) + (x : Ins (sReifier_ops _ op) ♯ X) (y : Outs (sReifier_ops _ op) ♯ X) + (σ σ' : sReifier_state r ♯ X) (rest : gState_rest NotCtxDep sR_idx rs ♯ X) : + sReifier_re r op (x,σ) ≡ Some (y, σ') ⊢@{iProp} gReifiers_re NotCtxDep rs (subEff_opid op) (subEff_ins x, gState_recomp NotCtxDep rest (sR_state σ)) @@ -541,15 +540,15 @@ Section greifiers. Proof. apply uPred.internal_eq_entails=>m. intros He. - eapply (sR_re (a := NotCtxDep)) in He. + eapply (@sR_re _ NotCtxDep) in He. pose proof (@gReifiers_re_idx sz NotCtxDep sR_idx rs X _ (subEff_opid op) (subEff_ins x)) as J. simpl in J. simpl. rewrite J//; clear J. - transitivity (prod_map (λ x0 : Outs (sReifier_ops NotCtxDep (rs !!! sR_idx) + transitivity (prod_map (λ x0 : Outs (sReifier_ops (rs !!! sR_idx) (subEff_opid op)) ♯ X, x0) - (λ st : sReifier_state NotCtxDep (rs !!! sR_idx) ♯ X, + (λ st : sReifier_state (rs !!! sR_idx) ♯ X, (gState_decomp' NotCtxDep sR_idx rs ^-1) (st, rest)) <$> (Some (subEff_outs y, sR_state σ'))). @@ -562,3 +561,12 @@ Section greifiers. Qed. End greifiers. + +Arguments gReifiers_cons {_ _}. +Arguments gReifiers_nil {_}. +Arguments gReifiers_ops {_ _}. +Arguments gReifiers_re {_ _}. +Arguments gReifiers_state {_ _}. +Arguments gReifiers_re_idx {_ _}. +Arguments gReifiers_re_idx_type {_ _}. +Arguments gReifiers_re_type {_ _}. diff --git a/theories/gitree/reductions.v b/theories/gitree/reductions.v index cfd14bd..e5833d9 100644 --- a/theories/gitree/reductions.v +++ b/theories/gitree/reductions.v @@ -6,8 +6,8 @@ From gitrees.gitree Require Import core reify. Section sstep. Context {A} `{!Cofe A} {a : is_ctx_dep}. Context (r : sReifier a). - Notation F := (sReifier_ops a r). - Notation stateF := (sReifier_state a r). + Notation F := (sReifier_ops r). + Notation stateF := (sReifier_state r). Notation IT := (IT F A). Notation ITV := (ITV F A). Notation stateO := (stateF ♯ IT). @@ -88,8 +88,8 @@ End sstep. Section istep. Context {A} `{!Cofe A} {a : is_ctx_dep}. Context (r : sReifier a). - Notation F := (sReifier_ops a r). - Notation stateF := (sReifier_state a r). + Notation F := (sReifier_ops r). + Notation stateF := (sReifier_state r). Notation IT := (IT F A). Notation ITV := (ITV F A). Notation stateO := (stateF ♯ IT). @@ -342,8 +342,8 @@ End istep. Section istep_ctx_indep. Context {A} `{!Cofe A}. Context (r : sReifier NotCtxDep). - Notation F := (sReifier_ops NotCtxDep r). - Notation stateF := (sReifier_state NotCtxDep r). + Notation F := (sReifier_ops r). + Notation stateF := (sReifier_state r). Notation IT := (IT F A). Notation ITV := (ITV F A). Notation stateO := (stateF ♯ IT). diff --git a/theories/gitree/reify.v b/theories/gitree/reify.v index 4ba8243..84cc1d8 100644 --- a/theories/gitree/reify.v +++ b/theories/gitree/reify.v @@ -517,3 +517,6 @@ Section reify_props. End reify_props. Arguments reify {_ _ _} _. +Arguments sReifier_ops {_}. +Arguments sReifier_re {_} _ {_ _}. +Arguments sReifier_state {_}. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index a3cdb39..45d4d16 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -9,18 +9,18 @@ From gitrees.gitree Require Import core reify greifiers reductions. Definition gReifiers_ucmra {n} (a : is_ctx_dep) (rs : gReifiers a n) (X : ofe) `{!Cofe X} : ucmra := discrete_funUR (λ (i : fin n), - optionUR (exclR (sReifier_state a (rs !!! i) ♯ X))). + optionUR (exclR (sReifier_state (rs !!! i) ♯ X))). (** The resource corresponding to the whole global state *) Definition of_state {n} (a : is_ctx_dep) (rs : gReifiers a n) - (X : ofe) `{!Cofe X} (st : gReifiers_state a rs ♯ X) + (X : ofe) `{!Cofe X} (st : gReifiers_state rs ♯ X) : gReifiers_ucmra a rs X := λ i, Excl' (fstO (gState_decomp a i st)). (** The resource corresponding to a speicific projection out of the global state *) Definition of_idx {n} (a : is_ctx_dep) (rs : gReifiers a n) (X : ofe) `{!Cofe X} (i : fin n) - (st : sReifier_state a (rs !!! i) ♯ X) : gReifiers_ucmra a rs X. + (st : sReifier_state (rs !!! i) ♯ X) : gReifiers_ucmra a rs X. Proof. simple refine (λ j, if (decide (j = i)) then _ else None). simpl. induction e. exact (Excl' st). @@ -28,7 +28,7 @@ Defined. Lemma of_state_recomp_lookup_ne {n} (a : is_ctx_dep) (rs : gReifiers a n) (X : ofe) `{!Cofe X} - i j (σ1 σ2 : sReifier_state a (rs !!! i) ♯ X) rest : + i j (σ1 σ2 : sReifier_state (rs !!! i) ♯ X) rest : i ≠ j → of_state a rs X (gState_recomp a rest σ1) j ≡ of_state a rs X (gState_recomp a rest σ2) j. @@ -61,16 +61,16 @@ Section ucmra. #[export] Instance of_state_proper : Proper ((≡) ==> (≡)) of_state. Proof. apply ne_proper, _. Qed. - Lemma of_state_valid (σ : gReifiers_state a rs ♯ X) : ✓ (of_state σ). + Lemma of_state_valid (σ : gReifiers_state rs ♯ X) : ✓ (of_state σ). Proof. intro; done. Qed. - Lemma of_state_recomp_lookup i (σ : sReifier_state a (rs !!! i) ♯ X) rest : + Lemma of_state_recomp_lookup i (σ : sReifier_state (rs !!! i) ♯ X) rest : of_state (gState_recomp a rest σ) i ≡ Excl' σ. Proof. unfold of_state. rewrite gState_decomp_recomp. done. Qed. - Lemma of_state_decomp_local_update i (σ σ1 σ2 : sReifier_state a (rs !!! i) ♯ X) rest : + Lemma of_state_decomp_local_update i (σ σ1 σ2 : sReifier_state (rs !!! i) ♯ X) rest : (of_state (gState_recomp a rest σ1), of_idx i σ2) ~l~> (of_state (gState_recomp a rest σ), of_idx i σ). Proof. @@ -108,10 +108,10 @@ End ucmra. Section weakestpre. Context {n : nat} (a : is_ctx_dep) (rs : gReifiers a n) {A} `{!Cofe A}. Notation rG := (gReifiers_sReifier a rs). - Notation F := (sReifier_ops a rG). + Notation F := (sReifier_ops rG). Notation IT := (IT F A). Notation ITV := (ITV F A). - Notation stateF := (gReifiers_state a rs). + Notation stateF := (gReifiers_state rs). Notation stateO := (stateF ♯ IT). Notation stateR := (gReifiers_ucmra a rs IT). Let of_state := (of_state a rs IT). @@ -141,10 +141,10 @@ Section weakestpre. Definition has_full_state `{!stateG Σ} (σ : stateO) : iProp Σ := (own stateG_name (◯ (of_state σ)))%I. Definition has_state_idx `{!stateG Σ} - (i : fin n) (σ : sReifier_state a (rs !!! i) ♯ IT) : iProp Σ := + (i : fin n) (σ : sReifier_state (rs !!! i) ♯ IT) : iProp Σ := (own stateG_name (◯ (of_idx i σ)))%I. Definition has_substate {sR : sReifier a} `{!stateG Σ} `{!subReifier sR rs} - (σ : sReifier_state a sR ♯ IT) : iProp Σ := + (σ : sReifier_state sR ♯ IT) : iProp Σ := (own stateG_name (◯ (of_idx sR_idx (sR_state σ))))%I. #[export] Instance state_interp_ne `{!stateG Σ} : NonExpansive state_interp. @@ -163,7 +163,7 @@ Section weakestpre. Qed. Lemma state_interp_has_state_idx_agree (i : fin n) - (σ1 σ2 : sReifier_state a (rs !!! i) ♯ IT) + (σ1 σ2 : sReifier_state (rs !!! i) ♯ IT) (rest : gState_rest a i rs ♯ IT) `{!stateG Σ} : state_interp (gState_recomp a rest σ1) -∗ has_state_idx i σ2 -∗ σ1 ≡ σ2. Proof. @@ -176,7 +176,7 @@ Section weakestpre. Qed. Lemma state_interp_has_state_idx_update (i : fin n) - (σ σ1 σ2 : sReifier_state a (rs !!! i) ♯ IT) + (σ σ1 σ2 : sReifier_state (rs !!! i) ♯ IT) (rest : gState_rest a i rs ♯ IT) `{!stateG Σ} : state_interp (gState_recomp a rest σ1) -∗ has_state_idx i σ2 ==∗ state_interp (gState_recomp a rest σ) ∗ has_state_idx i σ. @@ -402,7 +402,7 @@ Section weakestpre. Opaque gState_recomp. (* We can generalize this based on the stuckness bit *) - Lemma wp_reify_idx E1 E2 s Φ i (lop : opid (sReifier_ops a (rs !!! i))) : + Lemma wp_reify_idx E1 E2 s Φ i (lop : opid (sReifier_ops (rs !!! i))) : let op : opid F := (existT i lop) in forall (x : Ins (F op) ♯ IT) (k : Outs (F op) ♯ IT -n> laterO IT), @@ -450,7 +450,7 @@ Section weakestpre. iRewrite -"Hb". by iFrame. Qed. - Lemma wp_reify E1 s Φ i (lop : opid (sReifier_ops a (rs !!! i))) + Lemma wp_reify E1 s Φ i (lop : opid (sReifier_ops (rs !!! i))) x k σ σ' β : let op : opid F := (existT i lop) in (∀ rest, reify (Vis op x k) (gState_recomp a rest σ) ≡ (gState_recomp a rest σ', Tick β)) → @@ -668,7 +668,7 @@ Section weakestpre_specific. Context {n : nat} {A} `{!Cofe A}. Notation rG a rs := (gReifiers_sReifier (n := n) a rs). - Notation F a rs := (sReifier_ops a (rG a rs)). + Notation F a rs := (sReifier_ops (rG a rs)). Notation IT a rs := (IT (F a rs) A). Notation ITV a rs := (ITV (F a rs) A). Notation stateF a rs := (gReifiers_state a rs). @@ -689,13 +689,13 @@ Section weakestpre_specific. Lemma wp_reify_idx_ctx_dep (rs : gReifiers CtxDep n) `{!@stateG _ CtxDep rs A _ Σ} E1 E2 s Φ i - (lop : opid (sReifier_ops CtxDep (rs !!! i))) : + (lop : opid (sReifier_ops (rs !!! i))) : let op : opid (F CtxDep rs) := (existT i lop) in forall (x : Ins (F CtxDep rs op) ♯ IT CtxDep rs) (k : Outs (F CtxDep rs op) ♯ IT CtxDep rs -n> laterO (IT CtxDep rs)), (|={E1,E2}=> ∃ σ y σ' β, has_state_idx CtxDep rs i σ - ∗ sReifier_re CtxDep (rs !!! i) lop (x, σ, k) ≡ Some (y, σ') + ∗ sReifier_re (rs !!! i) lop (x, σ, k) ≡ Some (y, σ') ∗ y ≡ Next β ∗ ▷ (£ 1 -∗ has_state_idx CtxDep rs i σ' ={E2,E1}=∗ wp CtxDep rs β s E1 Φ)) -∗ wp CtxDep rs (Vis op x k) s E1 Φ. @@ -708,12 +708,12 @@ Section weakestpre_specific. iFrame "Hlst". iIntros (rest). iFrame "H". - iAssert (gReifiers_re CtxDep rs op (x, gState_recomp CtxDep rest σ, _) + iAssert (gReifiers_re rs _ _ op (x, gState_recomp CtxDep rest σ, _) ≡ Some (y, gState_recomp CtxDep rest σ'))%I with "[Hreify]" as "Hgreify". - { rewrite (gReifiers_re_idx CtxDep). + { rewrite (@gReifiers_re_idx _ CtxDep). iAssert (optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) - (sReifier_re CtxDep (rs !!! i) lop (x, σ, k)) + (sReifier_re (rs !!! i) lop (x, σ, k)) ≡ optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) (Some (y, σ')))%I with "[Hreify]" as "H". - iApply (f_equivI with "Hreify"). @@ -726,12 +726,12 @@ Section weakestpre_specific. Lemma wp_reify_idx_ctx_indep (rs : gReifiers NotCtxDep n) `{!@stateG _ NotCtxDep rs A _ Σ} E1 E2 s Φ i - (lop : opid (sReifier_ops NotCtxDep (rs !!! i))) : + (lop : opid (sReifier_ops (rs !!! i))) : let op : opid (F NotCtxDep rs) := (existT i lop) in forall (x : Ins (F NotCtxDep rs op) ♯ IT NotCtxDep rs) (k : Outs (F NotCtxDep rs op) ♯ IT NotCtxDep rs -n> laterO (IT NotCtxDep rs)), (|={E1,E2}=> ∃ σ y σ' β, has_state_idx NotCtxDep rs i σ - ∗ sReifier_re NotCtxDep (rs !!! i) lop (x, σ) ≡ Some (y, σ') + ∗ sReifier_re (rs !!! i) lop (x, σ) ≡ Some (y, σ') ∗ k y ≡ Next β ∗ ▷ (£ 1 -∗ has_state_idx NotCtxDep rs i σ' ={E2,E1}=∗ wp NotCtxDep rs β s E1 Φ)) -∗ wp NotCtxDep rs (Vis op x k) s E1 Φ. @@ -744,7 +744,7 @@ Section weakestpre_specific. iFrame "Hlst". iIntros (rest). iFrame "H". - iAssert (gReifiers_re NotCtxDep rs op (x, gState_recomp NotCtxDep rest σ) + iAssert (@gReifiers_re _ NotCtxDep rs _ _ op (x, gState_recomp NotCtxDep rest σ) ≡ Some (y, gState_recomp NotCtxDep rest σ'))%I with "[Hreify]" as "Hgreify". { pose proof (@gReifiers_re_idx n NotCtxDep i rs (IT NotCtxDep rs)) as J. @@ -752,7 +752,7 @@ Section weakestpre_specific. simpl. rewrite J; clear J. iAssert (optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) - (sReifier_re NotCtxDep (rs !!! i) lop (x, σ)) + (sReifier_re (rs !!! i) lop (x, σ)) ≡ optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) (Some (y, σ')))%I with "[Hreify]" as "H". - iApply (f_equivI with "Hreify"). @@ -765,10 +765,10 @@ Section weakestpre_specific. Lemma wp_subreify_ctx_dep' (rs : gReifiers CtxDep n) `{!@stateG _ CtxDep rs A _ Σ} E1 E2 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops CtxDep sR)) (x : Ins (sReifier_ops CtxDep sR op) ♯ (IT CtxDep rs)) + (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ (IT CtxDep rs)) (k : Outs (F CtxDep rs (subEff_opid op)) ♯ IT CtxDep rs -n> laterO (IT CtxDep rs)) : (|={E1,E2}=> ∃ σ y σ' β, has_substate CtxDep rs σ ∗ - sReifier_re CtxDep sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') + sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') ∗ y ≡ Next β ∗ ▷ (£ 1 -∗ has_substate CtxDep rs σ' ={E2,E1}=∗ wp CtxDep rs β s E1 Φ)) -∗ wp CtxDep rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. @@ -791,10 +791,10 @@ Section weakestpre_specific. Lemma wp_subreify_ctx_indep' (rs : gReifiers NotCtxDep n) `{!@stateG _ NotCtxDep rs A _ Σ} E1 E2 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops NotCtxDep sR)) (x : Ins (sReifier_ops NotCtxDep sR op) ♯ (IT NotCtxDep rs)) + (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ (IT NotCtxDep rs)) (k : Outs (F NotCtxDep rs (subEff_opid op)) ♯ IT NotCtxDep rs -n> laterO (IT NotCtxDep rs)) : (|={E1,E2}=> ∃ σ y σ' β, has_substate NotCtxDep rs σ ∗ - sReifier_re NotCtxDep sR op (x, σ) ≡ Some (y, σ') + sReifier_re sR op (x, σ) ≡ Some (y, σ') ∗ k (subEff_outs y) ≡ Next β ∗ ▷ (£ 1 -∗ has_substate NotCtxDep rs σ' ={E2,E1}=∗ wp NotCtxDep rs β s E1 Φ)) -∗ wp NotCtxDep rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. @@ -810,11 +810,11 @@ Section weakestpre_specific. Lemma wp_subreify_ctx_dep (rs : gReifiers CtxDep n) `{!@stateG _ CtxDep rs A _ Σ} E1 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops CtxDep sR)) - (x : Ins (sReifier_ops CtxDep sR op) ♯ IT CtxDep rs) (y : laterO (IT CtxDep rs)) + (op : opid (sReifier_ops sR)) + (x : Ins (sReifier_ops sR op) ♯ IT CtxDep rs) (y : laterO (IT CtxDep rs)) (k : Outs (F CtxDep rs (subEff_opid op)) ♯ IT CtxDep rs -n> laterO (IT CtxDep rs)) - (σ σ' : sReifier_state CtxDep sR ♯ IT CtxDep rs) β : - sReifier_re CtxDep sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') → + (σ σ' : sReifier_state sR ♯ IT CtxDep rs) β : + sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') → y ≡ Next β → has_substate CtxDep rs σ -∗ ▷ (£ 1 -∗ has_substate CtxDep rs σ' -∗ wp CtxDep rs β s E1 Φ) @@ -844,12 +844,12 @@ Section weakestpre_specific. Lemma wp_subreify_ctx_indep (rs : gReifiers NotCtxDep n) `{!@stateG _ NotCtxDep rs A _ Σ} E1 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops NotCtxDep sR)) - (x : Ins (sReifier_ops NotCtxDep sR op) ♯ IT NotCtxDep rs) - (y : Outs (sReifier_ops NotCtxDep sR op) ♯ IT NotCtxDep rs) + (op : opid (sReifier_ops sR)) + (x : Ins (sReifier_ops sR op) ♯ IT NotCtxDep rs) + (y : Outs (sReifier_ops sR op) ♯ IT NotCtxDep rs) (k : Outs (F NotCtxDep rs (subEff_opid op)) ♯ IT NotCtxDep rs -n> laterO (IT NotCtxDep rs)) - (σ σ' : sReifier_state NotCtxDep sR ♯ IT NotCtxDep rs) β : - sReifier_re NotCtxDep sR op (x, σ) ≡ Some (y, σ') → + (σ σ' : sReifier_state sR ♯ IT NotCtxDep rs) β : + sReifier_re sR op (x, σ) ≡ Some (y, σ') → k (subEff_outs y) ≡ Next β → has_substate NotCtxDep rs σ -∗ ▷ (£ 1 -∗ has_substate NotCtxDep rs σ' -∗ wp NotCtxDep rs β s E1 Φ) @@ -870,7 +870,7 @@ End weakestpre_specific. Section weakestpre_bind. Context {n : nat} (rs : gReifiers NotCtxDep n) {A} `{!Cofe A}. Notation rG := (gReifiers_sReifier NotCtxDep rs). - Notation F := (sReifier_ops NotCtxDep rG). + Notation F := (sReifier_ops rG). Notation IT := (IT F A). Notation ITV := (ITV F A). Notation stateF := (gReifiers_state NotCtxDep rs). @@ -967,111 +967,117 @@ Arguments stateΣ {n _} rs A {_}. Definition notStuck : stuckness := λ e, False. - Notation "'WP@{' re } α @ s ; E {{ Φ } }" := (wp re α s E Φ) +Notation "'WP@{' re } α @ s ; E {{ Φ } }" := + (wp re α s E Φ) (at level 20, α, s, Φ at level 200, only parsing) : bi_scope. - Notation "'WP@{' re } α @ s ; E {{ v , Q } }" := (wp re α s E (λ v, Q)) +Notation "'WP@{' re } α @ s ; E {{ v , Q } }" := + (wp re α s E (λ v, Q)) (at level 20, α, s, Q at level 200, - format "'[hv' 'WP@{' re } α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. + format "'[hv' 'WP@{' re } α '/' @ s ; E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. - Notation "'WP@{' re } α @ s {{ β , Φ } }" := (wp re α s ⊤ (λ β, Φ)) +Notation "'WP@{' re } α @ s {{ β , Φ } }" := + (wp re α s ⊤ (λ β, Φ)) (at level 20, α, Φ at level 200, - format "'WP@{' re } α @ s {{ β , Φ } }") : bi_scope. + format "'WP@{' re } α @ s {{ β , Φ } }") : bi_scope. - Notation "'WP@{' re } α @ s {{ Φ } }" := (wp re α s ⊤ Φ) +Notation "'WP@{' re } α @ s {{ Φ } }" := + (wp re α s ⊤ Φ) (at level 20, α, Φ at level 200, - format "'WP@{' re } α @ s {{ Φ } }") : bi_scope. + format "'WP@{' re } α @ s {{ Φ } }") : bi_scope. - Notation "'WP@{' re } α {{ β , Φ } }" := (wp re α notStuck ⊤ (λ β, Φ)) +Notation "'WP@{' re } α {{ β , Φ } }" := + (wp re α notStuck ⊤ (λ β, Φ)) (at level 20, α, Φ at level 200, - format "'WP@{' re } α {{ β , Φ } }") : bi_scope. + format "'WP@{' re } α {{ β , Φ } }") : bi_scope. - Notation "'WP@{' re } α {{ Φ } }" := (wp re α notStuck ⊤ Φ) +Notation "'WP@{' re } α {{ Φ } }" := + (wp re α notStuck ⊤ Φ) (at level 20, α, Φ at level 200, format "'WP@{' re } α {{ Φ } }") : bi_scope. - Lemma wp_adequacy cr Σ `{!invGpreS Σ} n a (rs : gReifiers a n) - {A} `{!Cofe A} `{!statePreG rs A Σ} - (α : IT _ A) σ βv σ' s k (ψ : (ITV (gReifiers_ops a rs) A) → Prop) : - ssteps (gReifiers_sReifier a rs) α σ (IT_of_V βv) σ' k → - (∀ `{H1 : !invGS Σ} `{H2: !stateG rs A Σ}, - ∃ Φ, NonExpansive Φ ∧ (∀ βv, Φ βv ⊢ ⌜ψ βv⌝) - ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → - ψ βv. - Proof. - intros Hst Hprf. - cut (⊢ ⌜ψ βv⌝ : iProp Σ)%I. - { intros HH. eapply uPred.pure_soundness; eauto. } - eapply (step_fupdN_soundness_lc _ 0 (cr + 3*k)). - intros Hinv. iIntros "[Hcr Hlc]". - iMod (new_state_interp a rs σ) as (sg) "[Hs Hs2]". - destruct (Hprf Hinv sg) as (Φ & HΦ & HΦψ & Hprf'). - iPoseProof (Hprf' with "[$Hcr $Hs2]") as "Hic". - iPoseProof (wp_ssteps with "[$Hs $Hic]") as "Hphi". - { eassumption. } - iMod ("Hphi" with "Hlc") as "[Hst H]". - rewrite wp_val_inv; eauto. - iMod "H" as "H". - rewrite HΦψ. iFrame "H". - by iApply fupd_mask_intro_discard. - Qed. +Lemma wp_adequacy cr Σ `{!invGpreS Σ} n a (rs : gReifiers a n) + {A} `{!Cofe A} `{!statePreG rs A Σ} + (α : IT _ A) σ βv σ' s k (ψ : (ITV (gReifiers_ops rs) A) → Prop) : + ssteps (gReifiers_sReifier a rs) α σ (IT_of_V βv) σ' k → + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs A Σ}, + ∃ Φ, NonExpansive Φ ∧ (∀ βv, Φ βv ⊢ ⌜ψ βv⌝) + ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → + ψ βv. +Proof. + intros Hst Hprf. + cut (⊢ ⌜ψ βv⌝ : iProp Σ)%I. + { intros HH. eapply uPred.pure_soundness; eauto. } + eapply (step_fupdN_soundness_lc _ 0 (cr + 3*k)). + intros Hinv. iIntros "[Hcr Hlc]". + iMod (new_state_interp a rs σ) as (sg) "[Hs Hs2]". + destruct (Hprf Hinv sg) as (Φ & HΦ & HΦψ & Hprf'). + iPoseProof (Hprf' with "[$Hcr $Hs2]") as "Hic". + iPoseProof (wp_ssteps with "[$Hs $Hic]") as "Hphi". + { eassumption. } + iMod ("Hphi" with "Hlc") as "[Hst H]". + rewrite wp_val_inv; eauto. + iMod "H" as "H". + rewrite HΦψ. iFrame "H". + by iApply fupd_mask_intro_discard. +Qed. - Lemma wp_safety cr Σ `{!invGpreS Σ} n a (rs : gReifiers a n) - {A} `{!Cofe A} `{!statePreG rs A Σ} s k - (α β : IT (gReifiers_ops a rs) A) (σ σ' : gReifiers_state a rs ♯ IT (gReifiers_ops a rs) A) : - (∀ Σ P Q, @disjunction_property Σ P Q) → - ssteps (gReifiers_sReifier a rs) α σ β σ' k → - IT_to_V β ≡ None → - (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, - ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → - ((∃ β1 σ1, sstep (gReifiers_sReifier a rs) β σ' β1 σ1) - ∨ (∃ e, β ≡ Err e ∧ s e)). - Proof. - Opaque istep. - intros Hdisj Hstep Hbv Hwp. - cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier a rs) β σ' β1 σ1) - ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. - { intros [Hprf | Hprf]%Hdisj. - - left. - apply (istep_safe_sstep _ (Σ:=Σ)). - { apply Hdisj. } - done. - - right. - destruct (IT_dont_confuse β) - as [[e Ha] | [[m Ha] | [ [g Ha] | [[α' Ha]|[op [i [ko Ha]]]] ]]]. - + exists e. split; eauto. - eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[He %Hs]". rewrite Ha. - iPoseProof (Err_inj' with "He") as "%He". - iPureIntro. rewrite He//. - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_ret_err_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_fun_err_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_tick_err_ne with "Ha"). - + exfalso. eapply uPred.pure_soundness. - iPoseProof (Hprf) as "H". - iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. - iApply (IT_vis_err_ne with "Ha"). } - eapply (step_fupdN_soundness_lc _ 0 (cr + (3*k+2))). - intros Hinv. iIntros "[Hcr Hlc]". - iMod (new_state_interp a rs σ) as (sg) "[Hs Hs2]". - destruct (Hwp Hinv sg) as (Φ & HΦ & Hprf'). - iPoseProof (Hprf' with "[$Hs2 $Hcr]") as "Hic". - iPoseProof (wp_ssteps_isafe with "[$Hs $Hic]") as "H". - { eassumption. } - iMod ("H" with "Hlc") as "[H | H]". - { iDestruct "H" as (βv) "%Hbeta". - exfalso. rewrite Hbeta in Hbv. - inversion Hbv. } - iFrame "H". - by iApply fupd_mask_intro_discard. - Qed. +Lemma wp_safety cr Σ `{!invGpreS Σ} n a (rs : gReifiers a n) + {A} `{!Cofe A} `{!statePreG rs A Σ} s k + (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : + (∀ Σ P Q, @disjunction_property Σ P Q) → + ssteps (gReifiers_sReifier a rs) α σ β σ' k → + IT_to_V β ≡ None → + (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, + ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → + ((∃ β1 σ1, sstep (gReifiers_sReifier a rs) β σ' β1 σ1) + ∨ (∃ e, β ≡ Err e ∧ s e)). +Proof. + Opaque istep. + intros Hdisj Hstep Hbv Hwp. + cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier a rs) β σ' β1 σ1) + ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. + { intros [Hprf | Hprf]%Hdisj. + - left. + apply (istep_safe_sstep _ (Σ:=Σ)). + { apply Hdisj. } + done. + - right. + destruct (IT_dont_confuse β) + as [[e Ha] | [[m Ha] | [ [g Ha] | [[α' Ha]|[op [i [ko Ha]]]] ]]]. + + exists e. split; eauto. + eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[He %Hs]". rewrite Ha. + iPoseProof (Err_inj' with "He") as "%He". + iPureIntro. rewrite He//. + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_ret_err_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_fun_err_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_tick_err_ne with "Ha"). + + exfalso. eapply uPred.pure_soundness. + iPoseProof (Hprf) as "H". + iDestruct "H" as (e') "[Ha Hs]". rewrite Ha. + iApply (IT_vis_err_ne with "Ha"). } + eapply (step_fupdN_soundness_lc _ 0 (cr + (3*k+2))). + intros Hinv. iIntros "[Hcr Hlc]". + iMod (new_state_interp a rs σ) as (sg) "[Hs Hs2]". + destruct (Hwp Hinv sg) as (Φ & HΦ & Hprf'). + iPoseProof (Hprf' with "[$Hs2 $Hcr]") as "Hic". + iPoseProof (wp_ssteps_isafe with "[$Hs $Hic]") as "H". + { eassumption. } + iMod ("H" with "Hlc") as "[H | H]". + { iDestruct "H" as (βv) "%Hbeta". + exfalso. rewrite Hbeta in Hbv. + inversion Hbv. } + iFrame "H". + by iApply fupd_mask_intro_discard. +Qed. diff --git a/theories/lang_generic.v b/theories/lang_generic.v index a4a3663..79b5a69 100644 --- a/theories/lang_generic.v +++ b/theories/lang_generic.v @@ -1,11 +1,10 @@ -From gitrees Require Import prelude. -From gitrees Require Import gitree. +From gitrees Require Import prelude gitree utils.finite_sets. Require Import List. Import ListNotations. Require Import Binding.Lib Binding.Set. -Section interp. +Section ctx_interp. Local Open Scope type. Context {E: opsInterp}. Context {R} `{!Cofe R}. @@ -26,6 +25,9 @@ Section interp. solve_proper. Qed. + Program Definition ı_scope : interp_scope Empty_set + := λne (x : ∅), match x with end. + Definition interp_scope_split {S1 S2 : Set} : interp_scope (sum S1 S2) -n> interp_scope S1 * interp_scope S2. Proof. @@ -63,7 +65,7 @@ Section interp. Program Definition ren_scope {S S'} (δ : S [→] S') (env : interp_scope S') : interp_scope S := λne x, env (δ x). -End interp. +End ctx_interp. (* Common definitions and lemmas for Kripke logical relations *) Section kripke_logrel. @@ -73,7 +75,7 @@ Section kripke_logrel. Variable rs : gReifiers a sz. Context {R} `{!Cofe R}. - Notation F := (gReifiers_ops a rs). + Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ}. @@ -133,7 +135,7 @@ Section kripke_logrel_ctx_indep. Variable rs : gReifiers NotCtxDep sz. Context {R} `{!Cofe R}. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ}. @@ -165,3 +167,157 @@ Section kripke_logrel_ctx_indep. End kripke_logrel_ctx_indep. Arguments expr_pred_bind {_ _ _ _ _ _ _ _ _ _} f {_ _}. + +Section tm_interp. + Context {sz : nat} {a : is_ctx_dep}. + Variable rs : gReifiers a sz. + Context {R} `{!Cofe R}. + + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Context {A : ofe}. + Variable (P : A -n> iProp). + + Variable (ty : Set). + Variable (interp_ty : ty → (ITV -n> iProp)). + Variable (kripke : IT → (ITV -n> iProp) → iProp). + + Definition ssubst_valid1 {S : Set} + (Γ : S -> ty) + (ss : interp_scope S) : iProp := + (∀ x, □ kripke (ss x) (interp_ty (Γ x)))%I. + + Global Instance ssubst_valid_pers `{∀ τ β, Persistent (interp_ty τ β)} + {S : Set} (Γ : S → ty) ss : Persistent (ssubst_valid1 Γ ss). + Proof. apply _. Qed. + +End tm_interp. + +Section tm_interp_fin. + Context {sz : nat} {a : is_ctx_dep}. + Variable rs : gReifiers a sz. + Context {R} `{!Cofe R}. + + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Context {A : ofe}. + Variable (P : A -n> iProp). + + Variable (ty : Set). + Variable (interp_ty : ty → (ITV -n> iProp)). + Variable (kripke : IT → (ITV -n> iProp) → iProp). + + Program Definition ssubst_valid_fin1 {S : Set} `{!EqDecision S} `{!Finite S} + (Ω : S → ty) (ss : interp_scope S) : iProp + := ([∗ set] x ∈ (fin_to_set S), + (kripke (ss x) (interp_ty (Ω x)))%I). + + Context (Q : iProp). + + Definition valid_fin1 {S : Set} `{!EqDecision S} `{!Finite S} (Ω : S → ty) + (α : interp_scope S -n> IT) (τ : ty) : iProp := + ∀ ss, Q + -∗ (ssubst_valid_fin1 Ω ss) + -∗ kripke (α ss) (interp_ty τ). + + Lemma ssubst_valid_fin_empty1 (αs : interp_scope ∅) : + ⊢ ssubst_valid_fin1 □ αs. + Proof. + iStartProof. + unfold ssubst_valid_fin1. + rewrite fin_to_set_empty. + by iApply big_sepS_empty. + Qed. + + Lemma ssubst_valid_fin_app1 + {S1 S2 : Set} `{!EqDecision S1} `{!Finite S1} + `{!EqDecision S2} `{!Finite S2} + `{!EqDecision (S1 + S2)} `{!Finite (S1 + S2)} + (Ω1 : S1 → ty) (Ω2 : S2 → ty) + (αs : interp_scope (sum S1 S2)) : + (ssubst_valid_fin1 (sum_map' Ω1 Ω2) αs) ⊢ + (ssubst_valid_fin1 Ω1 (interp_scope_split αs).1) + ∗ (ssubst_valid_fin1 Ω2 (interp_scope_split αs).2). + Proof. + iIntros "H". + rewrite /ssubst_valid_fin1 fin_to_set_sum big_sepS_union; first last. + { + apply elem_of_disjoint. + intros [x | x]. + - rewrite !elem_of_list_to_set. + intros _ H2. + apply elem_of_list_fmap_2 in H2. + destruct H2 as [y [H2 H2']]; inversion H2. + - rewrite !elem_of_list_to_set. + intros H1 _. + apply elem_of_list_fmap_2 in H1. + destruct H1 as [y [H1 H1']]; inversion H1. + } + iDestruct "H" as "(H1 & H2)". + iSplitL "H1". + - rewrite big_opS_list_to_set; first last. + { + apply NoDup_fmap. + - intros ??; by inversion 1. + - apply NoDup_elements. + } + rewrite big_sepL_fmap /=. + rewrite big_sepS_elements. + iFrame "H1". + - rewrite big_opS_list_to_set; first last. + { + apply NoDup_fmap. + - intros ??; by inversion 1. + - apply NoDup_elements. + } + rewrite big_sepL_fmap /=. + rewrite big_sepS_elements. + iFrame "H2". + Qed. + + Lemma ssubst_valid_fin_cons1 {S : Set} `{!EqDecision S} `{!Finite S} + (Ω : S → ty) (αs : interp_scope S) τ t : + ssubst_valid_fin1 Ω αs ∗ kripke t (interp_ty τ) ⊢ ssubst_valid_fin1 (Ω ▹ τ) (extend_scope αs t). + Proof. + iIntros "(H & G)". + rewrite /ssubst_valid_fin1. + rewrite fin_to_set_inc /=. + rewrite big_sepS_union; first last. + { + apply elem_of_disjoint. + intros [| x]. + - rewrite !elem_of_list_to_set. + intros _ H2. + apply elem_of_list_fmap_2 in H2. + destruct H2 as [y [H2 H2']]; inversion H2. + - rewrite !elem_of_list_to_set. + intros H1 _. + apply elem_of_singleton_1 in H1. + inversion H1. + } + iSplitL "G". + - rewrite big_opS_singleton. + iFrame "G". + - erewrite big_opS_set_map. + + iFrame "H". + + intros ?? H; by inversion H. + Qed. + + Lemma ssubst_valid_fin_lookup1 {S : Set} `{!EqDecision S} `{!Finite S} + (Ω : S → ty) (αs : interp_scope S) x : + ssubst_valid_fin1 Ω αs ⊢ kripke (αs x) (interp_ty (Ω x)). + Proof. + iIntros "H". + iDestruct (big_sepS_elem_of_acc _ _ x with "H") as "($ & _)"; + first apply elem_of_fin_to_set. + Qed. + +End tm_interp_fin. diff --git a/theories/lib/factorial.v b/theories/lib/factorial.v index 259395e..e30fc24 100644 --- a/theories/lib/factorial.v +++ b/theories/lib/factorial.v @@ -4,9 +4,10 @@ From gitrees.effects Require Import store. From gitrees.lib Require Import while. Section fact. - Definition rs : gReifiers NotCtxDep 2 := - gReifiers_cons NotCtxDep reify_io (gReifiers_cons NotCtxDep reify_store (gReifiers_nil NotCtxDep)). - Notation F := (gReifiers_ops NotCtxDep rs). + Context (n' : nat) (r : gReifiers NotCtxDep n'). + Definition rs : gReifiers NotCtxDep (S (S n')) := + (gReifiers_cons reify_io (gReifiers_cons reify_store r)). + Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R, !SubOfe unitO R}. Notation IT := (IT F R). diff --git a/theories/lib/iter.v b/theories/lib/iter.v index e19dc18..c43e367 100644 --- a/theories/lib/iter.v +++ b/theories/lib/iter.v @@ -62,7 +62,7 @@ Section iter_wp. Variable (rs : gReifiers NotCtxDep sz). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ}. diff --git a/theories/prelude.v b/theories/prelude.v index 84cd443..9592851 100644 --- a/theories/prelude.v +++ b/theories/prelude.v @@ -7,6 +7,9 @@ From iris.si_logic Require Import bi siprop. From iris.proofmode Require Import classes tactics modality_instances coq_tactics reduction. +Definition sum_map' {A B C : Set} (f : A → C) (g : B → C) : sum A B → C := + λ x, match x with | inl x' => f x' | inr x' => g x' end. + Program Definition idfun {A : ofe} : A -n> A := λne x, x. (** OFEs stuff *) diff --git a/theories/program_logic.v b/theories/program_logic.v index d4d514f..304248d 100644 --- a/theories/program_logic.v +++ b/theories/program_logic.v @@ -4,7 +4,7 @@ From gitrees Require Import gitree. Section program_logic. Context {sz : nat} {a : is_ctx_dep}. Variable rs : gReifiers a sz. - Notation F := (gReifiers_ops a rs). + Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Notation IT := (IT F R). Notation ITV := (ITV F R). @@ -27,7 +27,7 @@ End program_logic. Section program_logic_ctx_indep. Context {sz : nat}. Variable rs : gReifiers NotCtxDep sz. - Notation F := (gReifiers_ops NotCtxDep rs). + Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Notation IT := (IT F R). Notation ITV := (ITV F R). diff --git a/theories/utils/finite_sets.v b/theories/utils/finite_sets.v new file mode 100644 index 0000000..463e388 --- /dev/null +++ b/theories/utils/finite_sets.v @@ -0,0 +1,221 @@ +From stdpp Require Export finite gmap. +Require Export Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. + +Lemma fin_to_set_sum {S1 S2 : Set} `{!EqDecision S1} `{!EqDecision S2} + `{!Finite S1} `{!Finite S2} `{HE : EqDecision (S1 + S2)} `{HF : @Finite (S1 + S2) HE} + : fin_to_set (S1 + S2) + = (set_map inl (fin_to_set S1 : gset S1)) + ∪ (set_map inr (fin_to_set S2 : gset S2)) + :> @gset (S1 + S2) HE (@finite_countable _ HE HF). +Proof. + apply set_eq. + intros [x|x]; simpl; split; intros _. + - apply elem_of_union; left. + apply elem_of_map_2. + apply elem_of_fin_to_set. + - apply elem_of_fin_to_set. + - apply elem_of_union; right. + apply elem_of_map_2. + apply elem_of_fin_to_set. + - apply elem_of_fin_to_set. +Qed. + +Lemma fin_to_set_empty `{HE : EqDecision ∅} `{HF : @Finite ∅ HE} : + fin_to_set ∅ = empty :> @gset ∅ HE (@finite_countable _ HE HF). +Proof. + apply set_eq; intros []. +Qed. + +Lemma fin_to_set_inc {S : Set} `{!EqDecision S} `{!Finite S} + `{HE : EqDecision (inc S)} `{HF : @Finite (inc S) HE} + : fin_to_set (inc S) = ({[VZ]} : gset (inc S)) ∪ (set_map VS (fin_to_set S : gset S)) + :> @gset (inc S) HE (@finite_countable _ HE HF). +Proof. + apply set_eq. + intros [| x]. + - split. + + intros _; apply elem_of_union; left. + by apply elem_of_singleton. + + intros _; apply elem_of_fin_to_set. + - split. + + intros _; apply elem_of_union; right. + apply elem_of_map_2, elem_of_fin_to_set. + + intros H. + apply elem_of_fin_to_set. +Qed. + +Section Sum. + (* Kenny Loggins starts playing in a background *) + + Lemma EqDecisionLeft {S1 S2 : Set} {H : EqDecision (S1 + S2)} : EqDecision S1. + Proof. + intros x y. + destruct (decide (inl x = inl y)) as [G | G]; + [left; by inversion G | right; intros C; by subst]. + Qed. + + Lemma EqDecisionRight {S1 S2 : Set} {H : EqDecision (S1 + S2)} : EqDecision S2. + Proof. + intros x y. + destruct (decide (inr x = inr y)) as [G | G]; + [left; by inversion G | right; intros C; by subst]. + Qed. + + Lemma FiniteLeft {S1 S2 : Set} `{EqDecision S1} + `{EqDecision (S1 + S2)} `{Finite (S1 + S2)} + : Finite S1. + Proof. + unshelve econstructor. + - apply (foldr (λ x acc, match x with + | inl x => x :: acc + | inr _ => acc + end) [] (enum (S1 + S2))). + - set (l := enum (S1 + S2)). + assert (NoDup l) as K; [apply (NoDup_enum (S1 + S2)) |]. + clearbody l. + induction l as [| a l IH]; [constructor |]. + destruct a as [a | a]; simpl. + + constructor. + * intros C. + assert (inl a ∈ l) as C'. + { + clear -C. + induction l as [| b l IH]; [inversion C |]. + destruct b as [b | b]; simpl. + - rewrite foldr_cons in C. + rewrite elem_of_cons in C. + destruct C as [-> | C]. + + apply elem_of_cons. + by left. + + right. + apply IH. + apply C. + - apply elem_of_cons. + right. + rewrite foldr_cons in C. + apply IH. + apply C. + } + by inversion K. + * apply IH. + by inversion K. + + apply IH. + by inversion K. + - intros x. + set (l := enum (S1 + S2)). + assert (inl x ∈ l) as K; [apply elem_of_enum |]. + clearbody l. + induction l as [| a l IH]; [inversion K |]. + destruct a as [a | a]; simpl. + + rewrite elem_of_cons in K. + destruct K as [K | K]. + * inversion K; subst. + apply elem_of_cons; by left. + * apply elem_of_cons; right; by apply IH. + + rewrite elem_of_cons in K. + destruct K as [K | K]; [inversion K |]. + by apply IH. + Qed. + + Lemma FiniteRight {S1 S2 : Set} `{EqDecision S2} + `{EqDecision (S1 + S2)} `{H : Finite (S1 + S2)} + : Finite S2. + Proof. + unshelve econstructor. + - apply (foldr (λ x acc, match x with + | inl _ => acc + | inr x => x :: acc + end) [] (enum (S1 + S2))). + - set (l := enum (S1 + S2)). + assert (NoDup l) as K; [apply NoDup_enum |]. + clearbody l. + induction l as [| a l IH]; [constructor |]. + destruct a as [a | a]; simpl. + + apply IH. + by inversion K. + + constructor. + * intros C. + assert (inr a ∈ l) as C'. + { + clear -C. + induction l as [| b l IH]; [inversion C |]. + destruct b as [b | b]; simpl. + - apply elem_of_cons. + right. + rewrite foldr_cons in C. + apply IH, C. + - rewrite foldr_cons in C. + rewrite elem_of_cons in C. + destruct C as [-> | C]. + + apply elem_of_cons. + by left. + + right. + apply IH, C. + } + by inversion K. + * apply IH. + by inversion K. + - intros x. + set (l := enum (S1 + S2)). + assert (inr x ∈ l) as K; [apply elem_of_enum |]. + clearbody l. + induction l as [| a l IH]; [inversion K |]. + destruct a as [a | a]; simpl. + + rewrite elem_of_cons in K. + destruct K as [K | K]; [inversion K |]. + by apply IH. + + rewrite elem_of_cons in K. + destruct K as [K | K]. + * inversion K; subst. + apply elem_of_cons; by left. + * apply elem_of_cons; right; by apply IH. + Qed. + +End Sum. + +Section Inc. + Context (S : Set). + + Global Instance EqDecisionIncN {HS : EqDecision S} (n : nat) : EqDecision (Init.Nat.iter n inc S). + Proof using S. + induction n; simpl. + - apply _. + - intros [|x] [|y]. + + by left. + + by right. + + by right. + + destruct (decide (x = y)) as [-> |]; [by left |]. + right; by inversion 1. + Qed. + + Global Instance EqDecisionInc {HS : EqDecision S} : EqDecision (inc S). + Proof using S. + assert (inc S = Init.Nat.iter 1 inc S) as ->; [done |]. + by apply EqDecisionIncN. + Qed. + + Global Instance FiniteIncN {HS : EqDecision S} (HF : Finite S) (n : nat) {HS' : EqDecision (Init.Nat.iter n inc S)} : Finite (Init.Nat.iter n inc S). + Proof using S. + induction n. + - apply (@surjective_finite S HS HF _ _ id). + apply _. + - simpl. + unshelve eapply (@surjective_finite (option (Init.Nat.iter n inc S))); simpl in *. + + intros [x |]. + * apply (VS x). + * apply VZ. + + apply _. + + intros [| x]; simpl. + * exists None; reflexivity. + * exists (Some x); reflexivity. + Qed. + + Global Instance FiniteInc {HS : EqDecision S} (HF : Finite S) (HE : EqDecision (inc S)) : Finite (inc S). + Proof using S. + assert (J : @Finite (Init.Nat.iter 1 inc S) HE). + { apply FiniteIncN, HF. } + simpl in J. + apply J. + Qed. + +End Inc. From 0487b73567509d981763ffe66b23b989bcf5250d Mon Sep 17 00:00:00 2001 From: Kaptch Date: Fri, 2 Feb 2024 12:47:13 +0100 Subject: [PATCH 093/114] minor simplification --- theories/lib/factorial.v | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/theories/lib/factorial.v b/theories/lib/factorial.v index e30fc24..3d8b324 100644 --- a/theories/lib/factorial.v +++ b/theories/lib/factorial.v @@ -4,9 +4,9 @@ From gitrees.effects Require Import store. From gitrees.lib Require Import while. Section fact. - Context (n' : nat) (r : gReifiers NotCtxDep n'). - Definition rs : gReifiers NotCtxDep (S (S n')) := - (gReifiers_cons reify_io (gReifiers_cons reify_store r)). + Context (n' : nat) (rs : gReifiers NotCtxDep n'). + Context `{!subReifier reify_store rs}. + Context `{!subReifier reify_io rs}. Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R, !SubOfe unitO R}. @@ -103,11 +103,11 @@ Section fact. simpl. rewrite get_ret_ret. iApply (wp_alloc with "Hctx"). { solve_proper. } - fold rs. iNext. iNext. + iNext. iNext. iIntros (acc) "Hacc". simpl. iApply (wp_alloc with "Hctx"). { solve_proper. } - fold rs. iNext. iNext. + iNext. iNext. iIntros (ℓ) "Hl". simpl. iApply wp_seq. { solve_proper. } From 3c93d64925333d4cf7dd76202fe449ccd43a66b5 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 8 Feb 2024 13:48:01 +0100 Subject: [PATCH 094/114] mostly trying stuff out because none of the previous stuff works --- theories/input_lang_delim/interp.v | 937 ++++++++++++++++------------- theories/input_lang_delim/lang.v | 379 +++++++----- 2 files changed, 765 insertions(+), 551 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index c463926..9551c92 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -2,313 +2,460 @@ From gitrees Require Import gitree. From gitrees.input_lang_delim Require Import lang. Require Import gitrees.lang_generic_sem. +From iris.algebra Require Import gmap excl auth gmap_view. +From iris.proofmode Require Import classes tactics. +From iris.base_logic Require Import algebra. +From iris.heap_lang Require Export locations. Require Import Binding.Lib. Require Import Binding.Set. -Notation stateO := (leibnizO state). -Program Definition inputE : opInterp := - {| - Ins := unitO; - Outs := natO; - |}. -Program Definition outputE : opInterp := - {| - Ins := natO; - Outs := unitO; - |}. +(** * State *) + +Definition stateF : oFunctor := (gmapOF unitO (▶ ∙))%OF. + +#[local] Instance state_inhabited : Inhabited (stateF ♯ unitO). +Proof. apply _. Qed. +#[local] Instance state_cofe X `{!Cofe X} : Cofe (stateF ♯ X). +Proof. apply _. Qed. + + + +(** * Signatures *) + +Program Definition readE : opInterp := {| + Ins := unitO; + Outs := (▶ ∙); +|}. + +Program Definition writeE : opInterp := {| + Ins := (▶ ∙); + Outs := unitO; +|}. -Program Definition shiftE : opInterp := +Program Definition callccE : opInterp := {| Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); Outs := (▶ ∙); |}. - -Program Definition resetE : opInterp := +Program Definition throwE : opInterp := {| - Ins := (▶ ∙); - Outs := (▶ ∙); + Ins := (▶ ∙ * (▶ ∙ -n> ▶ ∙)); + Outs := Empty_setO; |}. -Definition ioE := @[inputE; outputE; shiftE; resetE]. -Definition reify_input X `{Cofe X} : unitO * stateO * (natO -n> laterO X) → - option (laterO X * stateO) := - λ '(_, σ, k), let '(n, σ') := (update_input σ : prodO natO stateO) in - Some (k n, σ'). -#[export] Instance reify_input_ne X `{Cofe X} : - NonExpansive (reify_input X : prodO (prodO unitO stateO) - (natO -n> laterO X) → - optionO (prodO (laterO X) stateO)). -Proof. - intros n [[? σ1] k1] [[? σ2] k2]. simpl. - intros [[_ ->] Hk]. simpl in *. - repeat f_equiv. assumption. -Qed. - -Definition reify_output X `{Cofe X} : (natO * stateO * (unitO -n> laterO X)) → - optionO (prodO (laterO X) stateO) := - λ '(n, σ, k), Some (k (), ((update_output n σ) : stateO)). -#[export] Instance reify_output_ne X `{Cofe X} : - NonExpansive (reify_output X : prodO (prodO natO stateO) - (unitO -n> laterO X) → - optionO (prodO (laterO X) stateO)). -Proof. - intros ? [[]] [[]] []; simpl in *. - repeat f_equiv; first assumption; apply H0. -Qed. - -Definition reify_shift X `{Cofe X} : ((laterO X -n> laterO X) -n> laterO X) * - stateO * (laterO X -n> laterO X) → - option (laterO X * stateO) := - λ '(f, σ, k), Some ((f k): laterO X, σ : stateO). -#[export] Instance reify_shift_ne X `{Cofe X} : - NonExpansive (reify_shift X : - prodO (prodO ((laterO X -n> laterO X) -n> laterO X) stateO) - (laterO X -n> laterO X) → - optionO (prodO (laterO X) stateO)). -Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; auto. Qed. - - -(* CHECK *) -Definition reify_reset X `{Cofe X} : - (laterO X * stateO * (laterO X -n> laterO X)) → - option (laterO X * stateO) := - λ '(e, σ, k), Some (k e, σ). -(* and add the [get_val] in interp. BUT: doesn't it defeat the whole purpose of - having reset as an effect? *) -#[export] Instance reify_reset_ne X `{Cofe X} : - NonExpansive (reify_reset X : - prodO (prodO (laterO X) stateO) (laterO X -n> laterO X) → - optionO (prodO (laterO X) stateO)). -Proof. intros ?[[]][[]][[]]. simpl in *. by repeat f_equiv. Qed. - - -(* Context {E : opsInterp} {A} `{!Cofe A}. *) -(* Context {subEff0 : subEff ioE E}. *) -(* Context {subOfe0 : SubOfe natO A}. *) -(* Notation IT := (IT E A). *) -(* Notation ITV := (ITV E A). *) - -(* Definition reify_reset : (laterO IT * stateO * (laterO IT -n> laterO IT)) → *) -(* option (laterO IT * stateO) := *) -(* λ '(e, σ, k), Some (k $ laterO_map (get_val idfun) e, σ). *) -(* #[export] Instance reify_reset_ne : *) -(* NonExpansive (reify_reset : *) -(* prodO (prodO (laterO IT) stateO) (laterO IT -n> laterO IT) → *) -(* optionO (prodO (laterO IT) stateO)). *) -(* Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; done. Qed. *) - - - -Canonical Structure reify_io : sReifier. +Definition delimE := @[readE; writeE; callccE; throwE]. + + +Notation op_read := (inl ()). +Notation op_write := (inr (inl ())). +Notation op_callcc := (inr (inr (inl ()))). +Notation op_throw := (inr (inr (inr (inl ())))). + + +Section reifiers. + + Context {X} `{!Cofe X}. + Notation state := (stateF ♯ X). + + + Definition reify_read : unit * state * (laterO X -n> laterO X) → + option (laterO X * state) + := λ '(u,σ,κ), x ← σ !! u; + Some (κ x, σ). + #[export] Instance reify_read_ne : + NonExpansive (reify_read : prodO (prodO unitO state) + (laterO X -n> laterO X) → + optionO (prodO (laterO X) state)). + Proof. + intros n[[]][[]][[]]. simpl in *. + apply option_mbind_ne; first solve_proper. + by rewrite H0. + Qed. + + Definition reify_write : (laterO X) * state * (unitO -n> laterO X) → + option (laterO X * state) + := λ '(n,s,κ), let s' := <[():=n]>s + in Some (κ (), s'). + #[export] Instance reify_write_ne : + NonExpansive (reify_write : prodO (prodO _ state) + (unitO -n> laterO X) → + optionO (prodO (laterO X) state)). + Proof. + intros n [[]] [[]] [[]]; simpl in *. solve_proper. + Qed. + + + Definition reify_callcc : ((laterO X -n> laterO X) -n> laterO X) * + state * (laterO X -n> laterO X) → + option (laterO X * state) := + λ '(f, σ, k), Some ((k (f k): laterO X), σ : state). + #[export] Instance reify_callcc_ne : + NonExpansive (reify_callcc : + 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_throw : + ((laterO X * (laterO X -n> laterO X)) * state * (Empty_setO -n> laterO X)) → + option (laterO X * state) := + λ '((e, k'), σ, _), + Some ((k' e : laterO X), σ : state). + #[export] Instance reify_throw_ne : + NonExpansive (reify_throw : + prodO (prodO (prodO (laterO X) (laterO X -n> laterO X)) state) + (Empty_setO -n> laterO X) → + optionO (prodO (laterO X) (state))). + Proof. + intros ?[[[]]][[[]]]?. rewrite /reify_throw. + repeat f_equiv; apply H. + Qed. + +End reifiers. + +Canonical Structure reify_delim : sReifier. Proof. - simple refine {| sReifier_ops := ioE; - sReifier_state := stateO - |}. + simple refine {| + sReifier_ops := delimE; + sReifier_state := stateF + |}. intros X HX op. destruct op as [ | [ | [ | [| []]]]]; simpl. - - simple refine (OfeMor (reify_input X)). - - simple refine (OfeMor (reify_output X)). - - simple refine (OfeMor (reify_shift X)). - - simple refine (OfeMor (reify_reset X)). + - simple refine (OfeMor (reify_read)). + - simple refine (OfeMor (reify_write)). + - simple refine (OfeMor (reify_callcc)). + - simple refine (OfeMor (reify_throw)). Defined. -Notation op_input := (inl ()). -Notation op_output := (inr (inl ())). -Notation op_shift := (inr (inr (inl ()))). -Notation op_reset := (inr (inr (inr (inl ())))). Section constructors. Context {E : opsInterp} {A} `{!Cofe A}. - Context {subEff0 : subEff ioE E}. + 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). - Program Definition INPUT : (nat -n> IT) -n> IT := - λne k, Vis (E:=E) (subEff_opid op_input) - (subEff_ins (F:=ioE) (op:=op_input) ()) - (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=op_input))^-1). - Solve Obligations with solve_proper. - - Program Definition OUTPUT_ : nat -n> IT -n> IT := - λne m α, Vis (E:=E) (subEff_opid op_output) - (subEff_ins (F:=ioE) (op:=op_output) m) - (λne _, NextO α). - Solve All Obligations with solve_proper_please. - Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). + Program Definition READ : IT := + Vis (E:=E) (subEff_opid $ op_read) + (subEff_ins (F:=delimE) (op:=op_read) ()) + ((subEff_outs (F:=delimE) (op:=op_read))^-1). - 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:=ioE) (op:=op_shift) f) - (k ◎ (subEff_outs (F:=ioE) (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). + Program Definition WRITE : IT -n> IT := + λne a, Vis (E:=E) (subEff_opid $ op_write) + (subEff_ins (F:=delimE) (op:=op_write) (Next a)) + (λne _, Next (Ret ())). Solve Obligations with solve_proper. - (* Program Definition RESET : laterO IT -n> IT := *) - (* λne e, Vis (E:=E) (subEff_opid op_reset) *) - (* (subEff_ins (F := ioE) (op := op_reset) e) *) - (* (subEff_outs (F := ioE) (op := op_reset)^-1). *) - (* Solve All Obligations with solve_proper. *) - Program Definition RESET_ : (laterO IT -n> laterO IT) -n> - laterO IT -n> + Program Definition CALLCC_ : ((laterO IT -n> laterO IT) -n> laterO IT) -n> + (laterO IT -n> laterO IT) -n> IT := - λne k e, Vis (E:=E) (subEff_opid op_reset) - (subEff_ins (F := ioE) (op := op_reset) e) - (k ◎ subEff_outs (F := ioE) (op := op_reset)^-1). - Solve Obligations with solve_proper. - - Program Definition RESET : laterO IT -n> IT := - RESET_ idfun. - + λne f k, Vis (E:=E) (subEff_opid op_callcc) + (subEff_ins (F:=delimE) (op:=op_callcc) f) + (k ◎ (subEff_outs (F:=delimE) (op:=op_callcc))^-1). + Solve All Obligations with solve_proper. - Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). - Proof. - unfold INPUT. - rewrite hom_vis/=. repeat f_equiv. - intro x. cbn-[laterO_map]. rewrite laterO_map_Next. - done. - Qed. - Lemma hom_OUTPUT_ m α f `{!IT_hom f} : f (OUTPUT_ m α) ≡ OUTPUT_ m (f α). - Proof. - unfold OUTPUT. - rewrite hom_vis/=. repeat f_equiv. - intro x. cbn-[laterO_map]. rewrite laterO_map_Next. - done. - Qed. + Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := + λne f, CALLCC_ 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). + Lemma hom_CALLCC_ k e f `{!IT_hom f} : + f (CALLCC_ e k) ≡ CALLCC_ e (laterO_map (OfeMor f) ◎ k). Proof. - unfold SHIFT_. + unfold CALLCC_. rewrite hom_vis/=. f_equiv. by intro. Qed. + Program Definition THROW : IT -n> (laterO IT -n> laterO IT) -n> IT := + λne e k, Vis (E:=E) (subEff_opid op_throw) + (subEff_ins (F:=delimE) (op:=op_throw) + (NextO e, k)) + (λne x, Empty_setO_rec _ ((subEff_outs (F:=delimE) (op:=op_throw))^-1 x)). + Next Obligation. + solve_proper_prepare. + destruct ((subEff_outs ^-1) x). + Qed. + Next Obligation. + intros; intros ???; simpl. + repeat f_equiv. assumption. + Qed. + Next Obligation. + intros ?????; simpl. + repeat f_equiv; assumption. + Qed. + End constructors. Section weakestpre. Context {sz : nat}. Variable (rs : gReifiers sz). - Context {subR : subReifier reify_io rs}. + 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). - Context `{!invGS Σ, !stateG rs R Σ}. + Notation state := (stateF ♯ IT). + + + (* a separate ghost state for keeping track of locations *) + Definition istate := gmap_viewUR unit (laterO IT). + Class heapPreG Σ := HeapPreG { heapPreG_inG :: inG Σ istate }. + Class heapG Σ := HeapG { + heapG_inG :: inG Σ istate; + heapG_name : gname; + }. + Definition heapΣ : gFunctors := GFunctor istate. + #[export] Instance subG_heapΣ {Σ} : subG heapΣ Σ → heapPreG Σ. + Proof. solve_inG. Qed. + + Lemma new_heapG σ `{!heapPreG Σ} : + (⊢ |==> ∃ `{!heapG Σ}, own heapG_name (●V σ): iProp Σ)%I. + Proof. + iMod (own_alloc (●V σ)) as (γ) "H". + { apply gmap_view_auth_valid. } + pose (sg := {| heapG_inG := _; heapG_name := γ |}). + iModIntro. iExists sg. by iFrame. + Qed. + + Context `{!invGS_gen HasLc Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - Lemma wp_input' (σ σ' : stateO) (n : nat) (k : natO -n> IT) (κ : IT -n> IT) - `{!IT_hom κ} Φ s : - update_input σ = (n, σ') -> - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ ◎ k $ n) @ s {{ Φ }}) -∗ - WP@{rs} κ (INPUT k) @ s {{ Φ }}. + (** * The ghost state theory for the heap *) + + Context `{!heapG Σ}. + + Definition heap_ctx := inv (nroot.@"storeE") + (∃ σ, £ 1 ∗ has_substate σ ∗ own heapG_name (●V σ))%I. + + Definition pointsto (u : unit) (α : IT) : iProp := + own heapG_name $ gmap_view_frag u (DfracOwn 1) (Next α). + + + + Lemma istate_alloc α u σ : + σ !! u = None → + own heapG_name (●V σ) ==∗ own heapG_name (●V (<[u:=(Next α)]>σ)) + ∗ pointsto u α. + Proof. + iIntros (Hl) "H". + iMod (own_update with "H") as "[$ $]". + { apply (gmap_view_alloc _ u (DfracOwn 1) (Next α)); eauto. + done. } + done. + Qed. + Lemma istate_read u α σ : + own heapG_name (●V σ) -∗ pointsto u α -∗ σ !! u ≡ Some (Next α). + Proof. + iIntros "Ha Hf". + iPoseProof (own_valid_2 with "Ha Hf") as "H". + rewrite gmap_view_both_validI. + iDestruct "H" as "[_ Hval]". done. + Qed. + Lemma istate_loc_dom u α σ : + own heapG_name (●V σ) -∗ pointsto u α -∗ ⌜is_Some (σ !! u)⌝. Proof. - iIntros (Hσ) "Hs Ha". - rewrite hom_INPUT. simpl. - iApply (wp_subreify with "Hs"). - + simpl. by rewrite Hσ. - + by rewrite ofe_iso_21. - + done. + iIntros "Hinv Hloc". + iPoseProof (istate_read with "Hinv Hloc") as "Hl". + destruct (σ !! u) ; eauto. + by rewrite option_equivI. + Qed. + Lemma istate_write u α β σ : + own heapG_name (●V σ) -∗ pointsto u α ==∗ own heapG_name (●V <[u:=(Next β)]>σ) + ∗ pointsto u β. + Proof. + iIntros "H Hu". + iMod (own_update_2 with "H Hu") as "[$ $]". + { apply (gmap_view_update). } + done. + Qed. + Lemma istate_delete u α σ : + own heapG_name (●V σ) -∗ pointsto u α ==∗ own heapG_name (●V delete u σ). + Proof. + iIntros "H Hu". + iMod (own_update_2 with "H Hu") as "$". + { apply (gmap_view_delete). } + done. Qed. - Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : - update_input σ = (n, σ') → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ - WP@{rs} (INPUT k) @ s {{ Φ }}. + + (** * The symbolic execution rules *) + + (** ** READ *) + + Lemma wp_read_atomic (l : unit) E1 E2 s Φ + (k : IT -n> IT) `{!IT_hom k} : + nclose (nroot.@"storeE") ## E1 → + heap_ctx -∗ + (|={E1,E2}=> ∃ α, ▷ pointsto l α ∗ + ▷ ▷ (pointsto l α ={E2,E1}=∗ WP@{rs} k α @ s {{ Φ }})) -∗ + WP@{rs} k READ @ s {{ Φ }}. Proof. - eapply (wp_input' σ σ' n k idfun). + iIntros (Hee) "#Hcxt H". rewrite hom_vis. simpl. + match goal with + | |- context G [Vis ?a ?b ?c] => assert (c ≡ laterO_map k ◎ subEff_outs (op:=op_read) ^-1) as -> + end; first solve_proper. + iApply wp_subreify'. + iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". + iApply (fupd_mask_weaken E1). + { set_solver. } + iIntros "Hwk". + iMod "H" as (α) "[Hp Hback]". + iApply (lc_fupd_elim_later with "Hlc"). + iNext. + iAssert (⌜is_Some (σ !! l)⌝)%I as "%Hdom". + { iApply (istate_loc_dom with "Hh Hp"). } + destruct Hdom as [x Hx]. + destruct (Next_uninj x) as [β' Hb']. + iAssert ((σ !! l ≡ Some (Next α)))%I as "#Hlookup". + { iApply (istate_read with "Hh Hp"). } + iAssert (▷ (β' ≡ α))%I as "#Hba". + { rewrite Hx. rewrite option_equivI. + rewrite Hb'. by iNext. } + iClear "Hlookup". + iExists σ,(Next $ k β'),σ,(k β'). + iFrame "Hs". + repeat iSplit. + - assert ((option_bind _ _ (λ x, Some (laterO_map k x, σ)) (σ !! l)) ≡ + (option_bind _ _ (λ x, Some (x, σ)) (Some (Next $ k β')))) as H. + { rewrite Hx. simpl. rewrite Hb'. by rewrite later_map_Next. } + simpl in H. + rewrite <-H. + unfold mbind. + simpl. + iPureIntro. + f_equiv; last done. + intros ???. + do 2 f_equiv. rewrite H0. + by rewrite ofe_iso_21. + - done. + - iNext. iIntros "Hlc Hs". + iMod ("Hback" with "Hp") as "Hback". + iMod "Hwk" . + iMod ("Hcl" with "[Hlc Hh Hs]") as "_". + { iExists _. by iFrame. } + iRewrite "Hba". done. Qed. - (* Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : *) - (* update_input σ = (n, σ') → *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ *) - (* WP@{rs} (INPUT k) @ s {{ Φ }}. *) - (* Proof. *) - (* intros Hs. iIntros "Hs Ha". *) - (* unfold INPUT. simpl. *) - (* iApply (wp_subreify with "Hs"). *) - (* { simpl. by rewrite Hs. } *) - (* { simpl. by rewrite ofe_iso_21. } *) - (* iModIntro. done. *) - (* Qed. *) + Lemma wp_read (l : unit) (α : IT) s Φ + (k : IT -n> IT) `{!IT_hom k} : + heap_ctx -∗ + ▷ pointsto l α -∗ + ▷ ▷ (pointsto l α -∗ WP@{rs} k α @ s {{ Φ }}) -∗ + WP@{rs} k READ @ s {{ Φ }}. + Proof. + iIntros "#Hcxt Hp Ha". + iApply (wp_read_atomic _ (⊤∖ nclose (nroot.@"storeE")) with "[$]"). + { set_solver. } + iModIntro. iExists _; iFrame. + iNext. iNext. iIntros "Hl". + iModIntro. by iApply "Ha". + Qed. - Lemma wp_output' (σ σ' : stateO) (n : nat) (κ : IT -n> IT) - `{!IT_hom κ} Φ s : - update_output n σ = σ' → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ (Ret 0)) @ s {{ Φ }}) -∗ - WP@{rs} κ (OUTPUT n) @ s {{ Φ }}. + (** ** WRITE *) + + Lemma wp_write_atomic E1 E2 β s Φ + (k : IT -n> IT) `{!IT_hom k} : + nclose (nroot.@"storeE") ## E1 → + heap_ctx -∗ + (|={E1,E2}=> ∃ α, ▷ pointsto () α ∗ + ▷ ▷ (pointsto () β ={E2,E1}=∗ WP@{rs} k (Ret ()) @ s {{ Φ }})) -∗ + WP@{rs} k (WRITE β) @ s {{ Φ }}. + Proof. + iIntros (Hee) "#Hcxt H". rewrite hom_vis. simpl. + iApply wp_subreify'. + iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". + iApply (fupd_mask_weaken E1). + { set_solver. } + iIntros "Hwk". + iMod "H" as (α) "[Hp Hback]". + iAssert (▷ ⌜is_Some (σ !! tt)⌝)%I as "#Hdom". + { iNext. iApply (istate_loc_dom with "Hh Hp"). } + iDestruct "Hdom" as ">%Hdom". + destruct Hdom as [x Hx]. + destruct (Next_uninj x) as [α' Ha']. + iApply (lc_fupd_elim_later with "Hlc"). + iNext. + iExists σ, (Next $ k (Ret ())), (<[():=Next β]>σ), (k $ Ret ()). + iFrame "Hs". + iSimpl. repeat iSplit; [ by rewrite later_map_Next | done | ]. + iNext. iIntros "Hlc". + iMod (istate_write _ _ β with "Hh Hp") as "[Hh Hp]". + iIntros "Hs". + iMod ("Hback" with "Hp") as "Hback". + iMod "Hwk" . + iMod ("Hcl" with "[Hlc Hh Hs]") as "_". + { iExists _. iFrame. } + done. + Qed. + + Lemma wp_write (α β : IT) s Φ (k : IT -n> IT) `{!IT_hom k} : + heap_ctx -∗ + ▷ pointsto () α -∗ + ▷▷ (pointsto () β -∗ WP@{rs} k (Ret ()) @ s {{ Φ }}) -∗ + WP@{rs} k $ WRITE β @ s {{ Φ }}. Proof. - iIntros (Hσ) "Hs Ha". - rewrite /OUTPUT hom_OUTPUT_. - iApply (wp_subreify with "Hs"). - + simpl. by rewrite Hσ. - + done. - + done. + iIntros "#Hctx Hp Ha". + iApply (wp_write_atomic (⊤∖ nclose (nroot.@"storeE")) with "[$]"). + { set_solver. } + iModIntro. iExists _; iFrame. + iNext. iNext. iIntros "Hl". + iModIntro. by iApply "Ha". Qed. - Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : - update_output n σ = σ' → + (** ** THROW *) + + Lemma wp_throw' (σ : state) (f : laterO IT -n> laterO IT) (x : IT) + (κ : IT -n> IT) `{!IT_hom κ} Φ s : has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ - WP@{rs} (OUTPUT n) @ s {{ Φ }}. + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car $ f (Next x) @ s {{ Φ }}) -∗ + WP@{rs} κ (THROW x f) @ s {{ Φ }}. Proof. - iIntros (Hσ) "Hs Ha". - iApply (wp_output' _ _ _ idfun with "Hs [Ha]"); first done. - simpl. iNext. iIntros "Hcl Hs". - iApply wp_val. iApply ("Ha" with "Hcl Hs"). + iIntros "Hs Ha". rewrite /THROW. simpl. + rewrite hom_vis. + destruct (Next_uninj (f (Next x))) as [α Hα]. + iApply (wp_subreify with "Hs"); simpl. + + reflexivity. + + apply Hα. + + by assert (α ≡ later_car (f (Next x))) as -> by done. Qed. - (* Lemma wp_throw' (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) *) - (* (κ : IT -n> IT) `{!IT_hom κ} Φ s : *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} (later_car f) x @ s {{ Φ }}) -∗ *) - (* WP@{rs} κ (THROW x f) @ s {{ Φ }}. *) - (* Proof. *) - (* iIntros "Hs Ha". rewrite /THROW. simpl. *) - (* rewrite hom_vis. *) - (* iApply (wp_subreify with "Hs"); simpl; done. *) - (* Qed. *) + Lemma wp_throw (σ : state) (f : laterO IT -n> laterO IT) (x : IT) Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car $ f $ Next x @ s {{ Φ }}) -∗ + WP@{rs} (THROW x f) @ s {{ Φ }}. + Proof. + iApply (wp_throw' _ _ _ idfun). + Qed. - (* Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : *) - (* has_substate σ -∗ *) - (* ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ *) - (* WP@{rs} (THROW x f) @ s {{ Φ }}. *) - (* Proof. *) - (* iApply (wp_throw' _ _ _ idfun). *) - (* Qed. *) + (** ** CALL/CC *) - Lemma wp_shift (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) + Lemma wp_callcc (σ : state) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} Φ s : has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} idfun (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ - WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ + WP@{rs} (k (CALLCC f)) @ s {{ Φ }}. Proof. iIntros "Hs Ha". - unfold SHIFT. simpl. + unfold CALLCC. simpl. rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ ((later_map idfun ((f (laterO_map k))))) with "Hs"). + iApply (wp_subreify _ _ _ _ _ _ _ ((later_map k ((f (laterO_map k))))) with "Hs"). { simpl. repeat f_equiv. - - rewrite ccompose_id_l later_map_id. + - rewrite ofe_iso_21. f_equiv. intro x. simpl. by rewrite ofe_iso_21. - reflexivity. @@ -323,12 +470,14 @@ End weakestpre. Section interp. Context {sz : nat}. Variable (rs : gReifiers sz). - Context {subR : subReifier reify_io rs}. + Context {subR : subReifier reify_delim rs}. Context {R} `{CR : !Cofe R}. Context `{!SubOfe natO R}. + Context `{!SubOfe unitO R}. Notation F := (gReifiers_ops rs). Notation IT := (IT F R). Notation ITV := (ITV F R). + Notation state := (stateF ♯ IT). Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). @@ -338,82 +487,55 @@ Section interp. solve_proper. Qed. - (** Interpreting individual operators *) - Program Definition interp_input {A} : A -n> IT := - λne env, INPUT Ret. - Program Definition interp_output {A} (t : A -n> IT) : A -n> IT := - get_ret OUTPUT ◎ t. - Local Instance interp_ouput_ne {A} : NonExpansive2 (@interp_output A). - Proof. solve_proper. Qed. - - (* Program Definition interp_shift {S} *) - (* (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := *) - (* λne env, SHIFT (λne (k : laterO IT -n> laterO IT), *) - (* (Next (e (@extend_scope F R _ _ env *) - (* (Fun (Next (λne x, Tau (k (Next x))))))))). *) - (* Next Obligation. *) - (* solve_proper. *) - (* Qed. *) - (* Next Obligation. *) - (* solve_proper_prepare. *) - (* repeat f_equiv. *) - (* intros [| a]; simpl; last solve_proper. *) - (* repeat f_equiv. *) - (* intros ?; simpl. *) - (* by repeat f_equiv. *) - (* Qed. *) - (* Next Obligation. *) - (* solve_proper_prepare. *) - (* repeat f_equiv. *) - (* intros ?; simpl. *) - (* repeat f_equiv. *) - (* intros [| a]; simpl; last solve_proper. *) - (* repeat f_equiv. *) - (* Qed. *) + (** * Interpreting individual operators *) - Program Definition interp_shift {S} (e : S -n> IT) : S -n> IT := - λne env, get_fun (λne (f : laterO (IT -n> IT)), - SHIFT (λne (k : laterO IT -n> laterO IT), - laterO_ap f (Next (λit x, Tau (k (Next x)))))) (e env). + (** ** RESET *) + Program Definition interp_reset (e : IT) : IT := + get_val (λne v, + CALLCC (λne (k : laterO IT -n> laterO IT), + Next $ + LET READ (λne m, SEQ + (WRITE (λit r, SEQ (WRITE m) (THROW r k))) + (APP' READ v)))) e. Solve Obligations with solve_proper. Next Obligation. - solve_proper_prepare. repeat f_equiv. intro. simpl. by repeat f_equiv. + intros e v k n ???. repeat f_equiv. intro. simpl. solve_proper. Qed. Next Obligation. - Opaque laterO_ap. - solve_proper_prepare. repeat f_equiv. intro. simpl. - by apply later_ap_ne. - Transparent laterO_ap. + intros e v n ???. repeat f_equiv. by do 2 (intro; simpl; repeat f_equiv). Qed. Next Obligation. - solve_proper_prepare. by repeat f_equiv. + intros e n ???. f_equiv. intro. simpl. solve_proper_please. Qed. - Program Definition interp_reset {S} (e : S -n> IT) : S -n> IT := - λne env, get_val idfun (RESET (Next (e env))). - Solve All Obligations with solve_proper_please. + #[export] Instance interp_reset_ne : + NonExpansive (interp_reset). + Proof. + solve_proper. + (* intros n ???. rewrite /interp_reset. simpl. repeat f_equiv. done. *) + (* by do 2 (intro; simpl; repeat f_equiv). *) + Qed. - (* Program Definition interp_throw {A} (e : A -n> IT) (k : A -n> IT) *) - (* : A -n> IT := *) - (* λne env, get_val (λne x, get_fun (λne (f : laterO (IT -n> IT)), *) - (* THROW x f) (k env)) (e env). *) - (* Next Obligation. *) - (* solve_proper. *) - (* Qed. *) - (* Next Obligation. *) - (* solve_proper_prepare. *) - (* repeat f_equiv. *) - (* intro; simpl. *) - (* by repeat f_equiv. *) - (* Qed. *) - (* Next Obligation. *) - (* solve_proper_prepare. *) - (* repeat f_equiv; last done. *) - (* intro; simpl. *) - (* by repeat f_equiv. *) - (* Qed. *) + (** ** SHIFT *) + Program Definition interp_shift {S} (e : S -n> IT) : S -n> IT := + λne env, CALLCC (λne (k : laterO IT -n> laterO IT), + Next (APP' + READ + (APP' + (e env) + (λit x, interp_reset (THROW x k))))). + Next Obligation. + intros S e env k n ???. by repeat f_equiv. + Qed. + Next Obligation. + intros S e env n ???. repeat f_equiv. intro. simpl. by repeat f_equiv. + Qed. + Next Obligation. + intros S e n ???. f_equiv. by intro; simpl; 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). Solve All Obligations with solve_proper_please. @@ -422,6 +544,8 @@ Section interp. Proof. solve_proper. Qed. Typeclasses Opaque interp_natop. + + (** ** REC *) Opaque laterO_map. Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := @@ -474,6 +598,8 @@ 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, APP' (t1 env) (t2 env). Solve All Obligations with first [ solve_proper | solve_proper_please ]. @@ -481,6 +607,7 @@ Section interp. Proof. solve_proper. Qed. Typeclasses Opaque interp_app. + (** ** IF *) Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := λne env, IF (t0 env) (t1 env) (t2 env). Solve All Obligations with first [ solve_proper | solve_proper_please ]. @@ -488,9 +615,11 @@ Section interp. Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). Proof. solve_proper. Qed. + (** ** NAT *) Program Definition interp_nat (n : nat) {A} : A -n> IT := λne env, Ret n. + (** ** CONT *) Program Definition interp_cont {S} (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := λne env, (Fun (Next (λne x, Tick $ e (@extend_scope F R _ _ env x)))). @@ -505,40 +634,9 @@ Section interp. intros [|z]; eauto. Qed. - (* (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := *) - (* λne env, SHIFT (λne (k : laterO IT -n> laterO IT), *) - (* (Next (e (@extend_scope F R _ _ env *) - (* (Fun (Next (λne x, Tau (k (Next x))))))))). *) - - - - (* Program Definition interp_natoprk {A} (op : nat_op) *) - (* (q : A -n> IT) *) - (* (K : A -n> (IT -n> IT)) : A -n> (IT -n> IT) := *) - (* λne env t, interp_natop op q (λne env, K env t) env. *) - (* Solve All Obligations with solve_proper. *) - - (* Program Definition interp_natoplk {A} (op : nat_op) *) - (* (K : A -n> (IT -n> IT)) *) - (* (q : A -n> IT) : A -n> (IT -n> IT) := *) - (* λne env t, interp_natop op (λne env, K env t) q env. *) - (* Solve All Obligations with solve_proper. *) - - (* Program Definition interp_ifk {A} (K : A -n> (IT -n> IT)) (q : A -n> IT) *) - (* (p : A -n> IT) : A -n> (IT -n> IT) := *) - (* λne env t, interp_if (λne env, K env t) q p env. *) - (* Solve All Obligations with solve_proper. *) - - - (* Program Definition interp_throwlk {A} (K : A -n> (IT -n> IT)) (k : A -n> IT) : *) - (* A -n> (IT -n> IT) := *) - (* λne env t, interp_throw (λne env, K env t) k env. *) - (* Solve All Obligations with solve_proper_please. *) - - (* Program Definition interp_throwrk {A} (e : A -n> IT) (K : A -n> (IT -n> IT)) : *) - (* A -n> (IT -n> IT) := *) - (* λne env t, interp_throw e (λne env, K env t) env. *) - (* Solve All Obligations with solve_proper_please. *) + #[local] Instance interp_reset_full_ne {S} (f : @interp_scope F R _ S -n> IT): + NonExpansive (λ env, interp_reset (f env)). + Proof. solve_proper. Qed. (** Interpretation for all the syntactic categories: values, expressions, contexts *) Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := @@ -555,17 +653,10 @@ Section interp. | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) - | Input => interp_input - | Output e => interp_output (interp_expr e) | Shift e => interp_shift (interp_expr e) - | Reset e => interp_reset (interp_expr e) + | Reset e => λne env, (OfeMor interp_reset) (interp_expr e env) end. - Solve All Obligations with first [ solve_proper | solve_proper_please ]. - - Program Definition interp_outputk {A} : (A -n> IT) -n> A -n> IT := - λne t env, interp_output t env. - Solve All Obligations with solve_proper. Program Definition interp_apprk {A} (q : A -n> IT) : (A -n> IT) -n> A -n> IT := λne t env, interp_app q t env. @@ -590,31 +681,19 @@ Section interp. λne b env, interp_if b e1 e2 env. Solve All Obligations with solve_proper. - (* Program Definition interp_iftruek {A} (b e2 : A -n> IT) : *) - (* (A -n> IT) -n> A -n> IT := *) - (* λne e1 env, interp_if b e1 e2 env. *) - (* Solve All Obligations with solve_proper. *) - - (* Program Definition interp_iffalsek {A} (b e1 : A -n> IT) : *) - (* (A -n> IT) -n> A -n> IT := *) - (* λne e2 env, interp_if b e1 e2 env. *) - (* Solve All Obligations with solve_proper. *) Program Definition interp_resetk {A} : (A -n> IT) -n> A -n> IT := - λne t env, interp_reset t env. + λne t env, interp_reset (t env). Solve All Obligations with solve_proper. Definition interp_ectx_el {S} (C : ectx_el S) : (interp_scope S -n> IT) -n> (interp_scope S) -n> IT := match C with - | OutputK => interp_outputk | AppRK e1 => interp_apprk (interp_expr e1) | AppLK e2 => interp_applk (interp_expr e2) | NatOpRK op e1 => interp_natoprk op (interp_expr e1) | NatOpLK op e2 => interp_natoplk op (interp_expr e2) | IfK e1 e2 => interp_ifk (interp_expr e1) (interp_expr e2) - (* | IfTrueK b e2 => interp_iftruek (interp_expr b) (interp_expr e2) *) - (* | IfFalseK b e1 => interp_iffalsek (interp_expr b) (interp_expr e1) *) | ResetK => interp_resetk end. @@ -652,7 +731,6 @@ Section interp. Definition interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := OfeMor (interp_ectx'' K). - Example test_ectx : ectx ∅ := [OutputK ; AppRK (RecV (Var VZ))]. (* Eval cbv[test_ectx interp_ectx interp_ectx' interp_ectx_el *) (* interp_apprk interp_outputk interp_output interp_app] in (interp_ectx test_ectx). *) (* Definition interp_ectx {S} (K : ectx S) : interp_scope S -n> IT -n> IT := *) @@ -704,14 +782,9 @@ Section interp. (* interp_ectx (fmap δ e) env ≡ interp_ectx e (ren_scope δ env). *) Proof. - destruct e; simpl; try by repeat f_equiv. - (* repeat f_equiv. *) - (* intros ?; simpl. *) - (* repeat f_equiv. *) - (* simpl; rewrite interp_expr_ren. *) - (* f_equiv. *) - (* intros [| y]; simpl. *) - (* + reflexivity. *) - (* + reflexivity. *) + + repeat f_equiv. by repeat (intro; simpl; repeat f_equiv). + + unfold interp_reset. repeat f_equiv. + by repeat (intro; simpl; repeat f_equiv). - destruct e; simpl. + reflexivity. + clear -interp_expr_ren. @@ -779,16 +852,8 @@ Section interp. (* interp_ectx (bind δ e) env ≡ interp_ectx e (sub_scope δ env). *) Proof. - destruct e; simpl; try by repeat f_equiv. - (* repeat f_equiv. *) - (* intros ?; simpl. *) - (* repeat f_equiv. *) - (* rewrite interp_expr_subst. *) - (* f_equiv. *) - (* intros [| x']; simpl. *) - (* + reflexivity. *) - (* + rewrite interp_expr_ren. *) - (* f_equiv. *) - (* intros ?; reflexivity. *) + + repeat f_equiv. by repeat (intro; simpl; repeat f_equiv). + + unfold interp_reset; repeat f_equiv. by repeat (intro; simpl; repeat f_equiv). - destruct e; simpl. + reflexivity. + clear -interp_expr_subst. @@ -838,17 +903,6 @@ Section interp. by rewrite laterO_map_id. Qed. - #[global] Instance interp_ectx_hom_output {S} (K : ectx S) env : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (OutputK :: K) env). - Proof. - intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - by rewrite !hom_tick. - - rewrite !hom_vis. - f_equiv. intro. simpl. rewrite -laterO_map_compose. - do 2 f_equiv. by intro. - - by rewrite !hom_err. - Qed. #[global] Instance interp_ectx_hom_if {S} (K : ectx S) (e1 e2 : expr S) env : @@ -926,18 +980,32 @@ Section interp. Qed. (* ResetK is not a homomorphism *) - Lemma interp_ectx_reset_not_hom {S} env : - IT_hom (interp_ectx ([ResetK] : ectx S) env) -> False. + (* Lemma interp_ectx_reset_not_hom {S} env : *) + (* IT_hom (interp_ectx ([ResetK] : ectx S) env) -> False. *) + (* Proof. *) + (* intros [ _ Hi _ _ ]. simpl in Hi. *) + (* specialize (Hi (Ret 0)). *) + (* unfold interp_reset, CALLCC, CALLCC_ in Hi. *) + (* simpl in Hi. *) + (* apply bi.siProp.pure_soundness. *) + (* iApply IT_tick_vis_ne. *) + (* iPureIntro. *) + (* symmetry. *) + (* eapply Hi. *) + (* Unshelve. apply bi.siProp_internal_eq. *) + (* Qed. *) + + #[global] Instance interp_ectx_hom_reset {S} (K : ectx S) + (env : interp_scope S) : + IT_hom (interp_ectx K env) -> + IT_hom (interp_ectx (ResetK :: K) env). Proof. - intros [ _ Hi _ _ ]. simpl in Hi. - specialize (Hi (Ret 0)). - rewrite hom_vis in Hi. - apply bi.siProp.pure_soundness. - iApply IT_tick_vis_ne. - iPureIntro. - symmetry. - eapply Hi. - Unshelve. apply bi.siProp_internal_eq. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; unfold interp_reset. + + - rewrite -hom_tick. f_equiv. by rewrite get_val_tick. + - rewrite get_val_vis. rewrite hom_vis. f_equiv. + intro. simpl. rewrite -laterO_map_compose. done. + - by rewrite get_val_err hom_err. Qed. @@ -950,21 +1018,18 @@ Section interp. #[global] Instance interp_ectx_hom {S} (K : ectx S) env : - ResetK ∉ K -> IT_hom (interp_ectx K env). Proof. - intro. induction K; simpl; first apply IT_hom_idfun. - apply not_elem_of_cons in H. destruct H as [H1 ?]. specialize (IHK H). - destruct a; try apply _. contradiction. + destruct a; apply _. Qed. (** ** Finally, preservation of reductions *) - Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' σ σ' K Ko n : - head_step e σ K e' σ' K Ko (n, 0) → + Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' K K' Ko n : + head_step e K e' K' Ko (n, 0) → interp_expr e env ≡ Tick_n n $ interp_expr e' env. Proof. - inversion 1; cbn-[IF APP' INPUT Tick get_ret2]. + inversion 1; cbn-[IF APP' Tick get_ret2]. - (* app lemma *) subst. erewrite APP_APP'_ITV; last apply _. @@ -996,34 +1061,72 @@ Section interp. reflexivity. Qed. - Lemma interp_expr_fill_no_reify {S} K K' Ko (env : interp_scope S) (e e' : expr S) σ σ' n : - head_step e σ K e' σ' K' Ko (n, 0) → - ResetK ∉ K-> - interp_expr (fill K e) env ≡ Tick_n n $ interp_expr (fill K' e') env. + Lemma interp_expr_fill_no_reify {S} (env : interp_scope S) (e e' : expr S) n : + prim_step e e' (n, 0) → + interp_expr e env ≡ Tick_n n $ interp_expr e' env. Proof. - inversion 1; subst; intros H1; rewrite !interp_comp; - apply (interp_ectx_hom K' env) in H1. - - rewrite <-hom_tick_n; last eauto. - simpl. apply (interp_expr_head_step env) in H. - by rewrite equiv_dist => n; f_equiv; move : n; apply equiv_dist. - - rewrite <-hom_tick_n; last eauto. apply (interp_expr_head_step env) in H. - by rewrite H. - - rewrite <-hom_tick_n; last eauto. apply (interp_expr_head_step env) in H. - by rewrite H. - - rewrite <-hom_tick_n; last eauto. apply (interp_expr_head_step env) in H. - by rewrite H. - - rewrite <-hom_tick_n; last eauto. apply (interp_expr_head_step env) in H. - by rewrite H. + inversion 1; subst. + inversion H1; subst; rewrite !interp_comp; simpl. + - rewrite -hom_tick. rewrite -(shift_context_app K Ki' Ko); eauto. + f_equiv. eapply (interp_expr_head_step env _ _ _ _ _) in H1. + simpl in H1. done. + - rewrite -!hom_tick. rewrite -(shift_context_app K Ki' Ko); eauto. + f_equiv. eapply (interp_expr_head_step env _ _ _ _ _) in H1. + simpl in H1. done. + - rewrite -(shift_context_app K Ki' Ko); eauto. + f_equiv. eapply (interp_expr_head_step env _ _ _ _ _) in H1. + simpl in H1. done. + - rewrite -(shift_context_app K Ki' Ko); eauto. + f_equiv. eapply (interp_expr_head_step env _ _ _ _ _) in H1. + simpl in H1. done. + - rewrite -(shift_context_app K Ki' Ko); eauto. + f_equiv. eapply (interp_expr_head_step env _ _ _ _ _) in H1. + simpl in H1. done. Qed. - Opaque INPUT OUTPUT_ SHIFT RESET. Opaque extend_scope. Opaque Ret. + + + Parameter env : @interp_scope F R CR ∅. + Parameter σ : state. + Parameter (σr : gState_rest sR_idx rs ♯ IT). + Example term : expr ∅ := ((#2) + reset ((#3) + shift/cc (rec (($0) ⋆ (# 5)))))%syn. + (* Goal forall e, (interp_expr term env) ≡ e -> *) + (* exists e' σ', reify (gReifiers_sReifier rs) *) + (* e (gState_recomp σr (sR_state σ)) ≡ (gState_recomp σr (sR_state σ'), e'). *) + (* Proof. *) + (* intros. *) + (* eexists. eexists. Opaque CALLCC_. simpl in H. *) + (* rewrite /interp_reset in H. *) + (* rewrite !hom_CALLCC_ in H. *) + (* match goal with *) + (* | H : (equiv ?f e) |- _ => set (g := f) *) + (* end. *) + (* trans (reify (gReifiers_sReifier rs) g (gState_recomp σr (sR_state σ))). *) + (* { f_equiv. f_equiv. symmetry. apply H. } *) + (* subst g. *) + (* rewrite reify_vis_eq //; first last. *) + (* match goal with *) + (* | |- context G [ofe_mor_car _ _ (sReifier_re _ _) (?f, _, ?h)] => set (i := f); set (o := h) *) + (* end. *) + (* epose proof (@subReifier_reify sz reify_delim rs _ IT _ op_callcc (subEff_ins^-1 i) _ (o ◎ subEff_outs) σ _ σr) as He. *) + (* simpl in He |-*. *) + (* erewrite <-He; last reflexivity. *) + (* f_equiv. *) + (* - intros [][][]. simpl. solve_proper. *) + (* - f_equiv. f_equiv. *) + (* + f_equiv. by rewrite ofe_iso_21. *) + (* + intro. simpl. rewrite ofe_iso_12. done. *) + + Lemma interp_expr_fill_yes_reify {S} K K' Ko env (e e' : expr S) - (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : - head_step e σ K e' σ' K' Ko (n, 1) → - ResetK ∉ K-> + (σ σ' : state) + (σr : gState_rest sR_idx rs ♯ IT) n : + head_step e K e' K' Ko (n, 1) → + some_relation K Ko σ -> + some_relation K' Ko σ -> reify (gReifiers_sReifier rs) (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K' e') env). diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 3a36907..e5b2ba1 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -21,8 +21,8 @@ Inductive expr {X : Set} := | NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr | If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr (* The effects *) -| Input : expr -| Output (e : expr) : expr +(* | Input : expr *) +(* | Output (e : expr) : expr *) | Shift (e : expr) : expr | Reset (e : expr) : expr with val {X : Set} := @@ -33,7 +33,7 @@ with val {X : Set} := Variant ectx_el {X : Set} := - | OutputK : ectx_el + (* | OutputK : ectx_el *) | IfK (e1 : @expr X) (e2 : @expr X) : ectx_el | AppLK (v : @val X) : ectx_el (* ◻ v *) | AppRK (e : @expr X) : ectx_el (* e ◻ *) @@ -62,8 +62,8 @@ Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := | App e₁ e₂ => App (emap f e₁) (emap f e₂) | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) - | Input => Input - | Output e => Output (emap f e) + (* | Input => Input *) + (* | Output e => Output (emap f e) *) | Shift e => Shift (emap f e) | Reset e => Reset (emap f e) end @@ -80,7 +80,7 @@ vmap {A B : Set} (f : A [→] B) (v : val A) : val B := Definition kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := map (fun x => match x with - | OutputK => OutputK + (* | OutputK => OutputK *) | IfK e1 e2 => IfK (fmap f e1) (fmap f e2) | AppLK v => AppLK (fmap f v) | AppRK e => AppRK (fmap f e) @@ -100,8 +100,8 @@ Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) - | Input => Input - | Output e => Output (ebind f e) + (* | Input => Input *) + (* | Output e => Output (ebind f e) *) | Shift e => Shift (ebind f e) | Reset e => Reset (ebind f e) end @@ -118,7 +118,7 @@ vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := Definition kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := map (fun x => match x with - | OutputK => OutputK + (* | OutputK => OutputK *) | IfK e1 e2 => IfK (bind f e1) (bind f e2) | AppLK v => AppLK (bind f v) | AppRK e => AppRK (bind f e) @@ -355,7 +355,7 @@ Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := Definition ctx_el_to_expr {X : Set} (K : ectx_el X) (e : expr X) : expr X := match K with - | OutputK => Output $ e + (* | OutputK => Output $ e *) | IfK e1 e2 => If e e1 e2 | AppLK v => App e (Val v) | AppRK el => App el e @@ -388,6 +388,8 @@ Definition shift_context {X : Set} (K : ectx X) : (ectx X * ectx X) := let (Ki, Ko) := trim_to_first_reset K [] in (List.rev Ki, Ko). + + Lemma trim_to_first_reset_app {X : Set} (K Ki Ko acc : ectx X) : (Ki, Ko) = trim_to_first_reset K acc -> (List.rev Ki) ++ Ko = (List.rev acc) ++ K. @@ -401,7 +403,6 @@ Proof. Qed. - Lemma shift_context_app {X : Set} (K Ki Ko : ectx X) : (Ki, Ko) = shift_context K -> K = Ki ++ Ko. Proof. @@ -458,7 +459,7 @@ Qed. Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := ContV (fill (shift K) (Var VZ)). -Example test1 : val (inc ∅) := (cont_to_rec [OutputK; AppRK (Var VZ)]). +Example test1 : val (inc ∅) := (cont_to_rec [(NatOpLK Add (LitV 3)); AppRK (Var VZ)]). (* Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) *) (* : fmap f (fill K e) = fill (fmap f K) (fmap f e). *) @@ -472,68 +473,66 @@ Example test1 : val (inc ∅) := (cont_to_rec [OutputK; AppRK (Var VZ)]). (*** Operational semantics *) -Record state := State { - inputs : list nat; - outputs : list nat; - }. -#[export] Instance state_inhabited : Inhabited state := populate (State [] []). - -Definition update_input (s : state) : nat * state := - match s.(inputs) with - | [] => (0, s) - | n::ns => - (n, {| inputs := ns; outputs := s.(outputs) |}) - end. -Definition update_output (n:nat) (s : state) : state := - {| inputs := s.(inputs); outputs := n::s.(outputs) |}. +(* Record state := State { *) +(* inputs : list nat; *) +(* outputs : list nat; *) +(* }. *) +(* #[export] Instance state_inhabited : Inhabited state := populate (State [] []). *) + +(* Definition update_input (s : state) : nat * state := *) +(* match s.(inputs) with *) +(* | [] => (0, s) *) +(* | n::ns => *) +(* (n, {| inputs := ns; outputs := s.(outputs) |}) *) +(* end. *) +(* Definition update_output (n:nat) (s : state) : state := *) +(* {| inputs := s.(inputs); outputs := n::s.(outputs) |}. *) (** [head_step e σ K e' σ' K' Ko (n, m)] : step from [(e, σ, K)] to [(e', σ', K')] under outer context [Ko] in [n] ticks with [m] effects encountered *) -Variant head_step {S} : expr S -> state -> ectx S -> - expr S -> state -> ectx S -> +Variant head_step {S} : expr S -> ectx S -> + expr S -> ectx S -> ectx S -> nat * nat → Prop := - | BetaS e1 v2 σ K Ko : - head_step (App (Val $ RecV e1) (Val v2)) σ K + | BetaS e1 v2 K Ko : + head_step (App (Val $ RecV e1) (Val v2)) K (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) (Val (shift (Inc := inc) v2))) - (Val (RecV e1))) σ K Ko (1,0) - | BetaContS e1 v2 σ K Ko : - head_step (App (Val $ ContV e1) (Val v2)) σ K + (Val (RecV e1))) K Ko (1,0) + | BetaContS e1 v2 K Ko : + head_step (App (Val $ ContV e1) (Val v2)) K (subst (Inc := inc) e1 (Val v2)) - σ K Ko (2,0) - | InputS σ n σ' K Ko : - update_input σ = (n, σ') → - head_step Input σ K (Val (LitV n)) σ' K Ko (1, 1) - | OutputS σ n σ' K Ko : - update_output n σ = σ' → - head_step (Output (Val (LitV n))) σ K (Val (LitV 0)) σ' K Ko (1, 1) - | NatOpS op v1 v2 v3 σ K Ko : + K Ko (2,0) + (* | InputS n σ' K Ko : *) + (* update_input = (n, σ') → *) + (* head_step Input K (Val (LitV n)) σ' K Ko (1, 1) *) + (* | OutputS n σ' K Ko : *) + (* update_output n = σ' → *) + (* head_step (Output (Val (LitV n))) K (Val (LitV 0)) σ' K Ko (1, 1) *) + | NatOpS op v1 v2 v3 K Ko : nat_op_interp op v1 v2 = Some v3 → - head_step (NatOp op (Val v1) (Val v2)) σ K - (Val v3) σ K Ko (0, 0) - | IfTrueS n e1 e2 σ K Ko : + head_step (NatOp op (Val v1) (Val v2)) K + (Val v3) K Ko (0, 0) + | IfTrueS n e1 e2 K Ko : n > 0 → - head_step (If (Val (LitV n)) e1 e2) σ K - e1 σ K Ko (0, 0) - | IfFalseS n e1 e2 σ K Ko : + head_step (If (Val (LitV n)) e1 e2) K + e1 K Ko (0, 0) + | IfFalseS n e1 e2 K Ko : n = 0 → - head_step (If (Val (LitV n)) e1 e2) σ K - e2 σ K Ko (0, 0) + head_step (If (Val (LitV n)) e1 e2) K + e2 K Ko (0, 0) - | ShiftS (e : expr (inc (inc S))) σ K Ko f : + | ShiftS (e : expr (inc (inc S))) K Ko f : ResetK ∉ K -> - f = cont_to_rec K -> - head_step (Shift (Val $ RecV e)) σ K + f = cont_to_rec (ResetK::K) -> + head_step (Shift (Val $ RecV e)) K (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e) (Val (shift (Inc := inc) f))) - (Val $ RecV e)) σ [] Ko (1, 1) - (* head_step (Shift (Val $ RecV e)) σ K *) - (* (App (Val $ RecV e) (Val f)) σ [] (0, 1) *) + (Val $ RecV e)) [] Ko (1, 1) - | ResetS v σ K Ko : - head_step (Reset (Val v)) σ K (Val v) σ K Ko (1, 1). + | ResetS v K Ko : + head_step (Reset (Val v)) K (Val v) K Ko (1, 1). (* | ValueS v σ K C: *) @@ -544,15 +543,15 @@ Variant head_step {S} : expr S -> state -> ectx S -> (* (Reset (fill E (Shift e))) σ *) (* (Reset (subst (Inc := inc) e (Val $ ContV $ ResetK E))) σ K (1,0). *) -Lemma head_step_io_01 {S} (e1 e2 : expr S) σ1 σ2 K K' Ko n m : - head_step e1 σ1 K e2 σ2 K' Ko (n,m) → m = 0 ∨ m = 1. +Lemma head_step_io_01 {S} (e1 e2 : expr S) K K' Ko n m : + head_step e1 K e2 K' Ko (n,m) → m = 0 ∨ m = 1. Proof. inversion 1; eauto. Qed. (* Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : *) (* head_step e1 σ1 K e2 σ2 K' (n,m) → n = 0 ∨ n = 1. *) (* Proof. inversion 1; eauto. Qed. *) -Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K K' Ko n : - head_step e1 σ1 K e2 σ2 K' Ko (n,0) → σ1 = σ2. -Proof. inversion 1; eauto. Qed. +(* Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K K' Ko n : *) +(* head_step e1 σ1 K e2 σ2 K' Ko (n,0) → σ1 = σ2. *) +(* Proof. inversion 1; eauto. Qed. *) (** Carbonara from heap lang *) @@ -573,8 +572,8 @@ Proof. elim: Ki e; simpl in *; first done. intros. Qed. (* CHECK *) -Lemma val_head_stuck {S} (e1 : expr S) σ1 e2 σ2 K K' Ko m : - head_step e1 σ1 K e2 σ2 K' Ko m → to_val e1 = None. +Lemma val_head_stuck {S} (e1 : expr S) e2 K K' Ko m : + head_step e1 K e2 K' Ko m → to_val e1 = None. Proof. destruct 1; naive_solver. Qed. @@ -601,47 +600,47 @@ Proof. by rewrite fill_app. Qed. (* FIXME maybe *) -Inductive prim_step {S} : ∀ (e1 : expr S) (σ1 : state) - (e2 : expr S) (σ2 : state) (nm : nat * nat), Prop := +Inductive prim_step {S} : ∀ (e1 : expr S) + (e2 : expr S) (nm : nat * nat), Prop := (* | Ectx_step e1 σ1 e2 σ2 nm (K1 K2 : ectx S) e1' e2' : *) (* e1 = fill K1 e1' -> *) (* e2 = fill K2 e2' -> *) (* ResetK ∉ K1 -> *) (* head_step e1' σ1 K1 e2' σ2 K2 nm -> *) (* prim_step e1 σ1 e2 σ2 nm *) -| Shift_step e1 σ1 K Ki Ko e2 σ2 Ki' nm : +| Shift_step e1 K Ki Ko e2 Ki' nm : (Ki, Ko) = shift_context K -> - head_step e1 σ1 Ki e2 σ2 Ki' Ko nm -> - prim_step (fill K e1) σ1 (fill (Ki' ++ Ko) e2) σ2 nm. + head_step e1 Ki e2 Ki' Ko nm -> + prim_step (fill K e1) (fill (Ki' ++ Ko) e2) nm. (* CHECK *) -Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : - prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. -Proof. - inversion 1; simplify_eq/=. by inversion H1. -Qed. +(* Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : *) +(* prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. *) +(* Proof. *) +(* inversion 1; simplify_eq/=. by inversion H1. *) +(* Qed. *) -Inductive prim_steps {S} : expr S → state → expr S → state → nat * nat → Prop := -| prim_steps_zero e σ : - prim_steps e σ e σ (0, 0) -| prim_steps_abit e1 σ1 e2 σ2 e3 σ3 n1 m1 n2 m2 : - prim_step e1 σ1 e2 σ2 (n1, m1) → - prim_steps e2 σ2 e3 σ3 (n2, m2) → - prim_steps e1 σ1 e3 σ3 (plus n1 n2, plus m1 m2) +Inductive prim_steps {S} : expr S → expr S → nat * nat → Prop := +| prim_steps_zero e : + prim_steps e e (0, 0) +| prim_steps_abit e1 e2 e3 n1 m1 n2 m2 : + prim_step e1 e2 (n1, m1) → + prim_steps e2 e3 (n2, m2) → + prim_steps e1 e3 (plus n1 n2, plus m1 m2) . -Lemma Ectx_step' {S} (K1 K2 : ectx S) e1 σ1 e2 σ2 efs : - head_step e1 σ1 K1 e2 σ2 K2 [] efs → +Lemma Ectx_step' {S} (K1 K2 : ectx S) e1 e2 efs : + head_step e1 K1 e2 K2 [] efs → ResetK ∉ K1 -> - prim_step (fill K1 e1) σ1 (fill K2 e2) σ2 efs. + prim_step (fill K1 e1) (fill K2 e2) efs. Proof. intros. rewrite -(app_nil_r K2). econstructor; eauto. by apply no_reset_shift_context_ident. Qed. -Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) σ1 σ2 σ3 : - prim_steps e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 → - prim_steps e1 σ1 e3 σ3 (plus nm1.1 nm2.1, plus nm1.2 nm2.2). +Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) : + prim_steps e1 e2 nm1 → prim_steps e2 e3 nm2 → + prim_steps e1 e3 (plus nm1.1 nm2.1, plus nm1.2 nm2.2). Proof. intros Hst. revert nm2. induction Hst; intros [n' m']; simplify_eq/=; first done. @@ -650,8 +649,8 @@ Proof. by apply (IHHst (n',m')). Qed. -Lemma prim_step_steps {S} nm (e1 e2 : expr S) σ1 σ2 : - prim_step e1 σ1 e2 σ2 nm → prim_steps e1 σ1 e2 σ2 nm. +Lemma prim_step_steps {S} nm (e1 e2 : expr S) : + prim_step e1 e2 nm → prim_steps e1 e2 nm. Proof. destruct nm as [n m]. intro Hs. rewrite -(Nat.add_0_r n). @@ -660,21 +659,133 @@ Proof. by constructor. Qed. -Lemma prim_step_steps_steps {S} (e1 e2 e3 : expr S) σ1 σ2 σ3 nm1 nm2 nm3 : +Lemma prim_step_steps_steps {S} (e1 e2 e3 : expr S) nm1 nm2 nm3 : nm3 = (plus nm1.1 nm2.1, plus nm1.2 nm2.2) -> - prim_step e1 σ1 e2 σ2 nm1 → prim_steps e2 σ2 e3 σ3 nm2 -> prim_steps e1 σ1 e3 σ3 nm3. + prim_step e1 e2 nm1 → prim_steps e2 e3 nm2 -> prim_steps e1 e3 nm3. Proof. intros -> H G. eapply prim_steps_app; last apply G. apply prim_step_steps, H. Qed. -Lemma head_step_prim_step {S} (e1 e2 : expr S) σ1 σ2 nm : - head_step e1 σ1 [] e2 σ2 [] [] nm -> prim_step e1 σ1 e2 σ2 nm. +Lemma head_step_prim_step {S} (e1 e2 : expr S) nm : + head_step e1 [] e2 [] [] nm -> prim_step e1 e2 nm. Proof. move => H; apply Ectx_step' in H => //=. apply not_elem_of_nil. Qed. + +(*** Abstract Machine semantics *) + +Definition Mectx {S} := list $ ectx S. + +Variant config {S} : Type := + | Ceval : expr S -> ectx S -> @Mectx S -> config + | Ccont : ectx S -> val S -> @Mectx S -> config + | Cmcont : @Mectx S -> val S -> config + | Cexpr : expr S -> config + | Cret : val S -> config. + +Reserved Notation "c '===>' c' / nm" + (at level 40, c', nm at level 30). + +Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := + + (* init *) + | Ceval_init : forall (e : expr S), + Cexpr e ===> Ceval e [] [] / (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) + + | 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_reset : forall e k mk, + Ceval (Reset e) k mk ===> Ceval e [] (k :: mk) / (1, 1) + + | Ceval_shift : forall (e : expr $ inc $ inc S) k f mk, + f = cont_to_rec (k) -> (* CHECK: should we add a reset to ctx ? don't think so *) + Ceval (Shift $ Val $ RecV e) k mk ===> + Ceval (subst (Inc := inc) + (subst (F := expr) (Inc := inc) + e (Val (shift (Inc:=inc) f))) + (Val (RecV e))) [] mk / (1, 1) + + (* cont *) + | Ccont_hole : forall v mk, + Ccont [] 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 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_cont : forall e v k mk, + Ccont (AppLK v :: k) (ContV e) mk ===> + Ceval (subst (Inc := inc) e (Val v)) [] (k :: mk) / (2, 0) + + | Ccont_ift : forall et ef n k mk, + n > 0 -> + Ccont (IfK et ef :: k) (LitV n) mk ===> + Ceval et k mk / (0, 0) + + | Ccont_iff : forall et ef n k mk, + n = 0 -> + Ccont (IfK et ef :: k) (LitV n) mk ===> + Ceval ef 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, + nat_op_interp op v0 v1 = Some v2 -> + 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 / (0,0) + + | Cmcont_ret : forall v, + Cmcont [] v ===> Cret v / (0, 0) + +where "c ===> c' / nm" := (Cred c c' nm). + +Arguments Mectx S%bind : clear implicits. +Arguments config S%bind : clear implicits. + +(** ** On configs & meta-contexts *) + +Definition meta_fill {S} (mk : Mectx S) e := + fold_left (λ e k, fill k e) mk e. + + +Definition config_to_expr {S} (c : config S) := + match c with + | Ceval e k mk => meta_fill mk (fill k e) + | Ccont k v mk => meta_fill mk (fill k (Val v)) + | Cmcont mk v => meta_fill mk (Val v) + | Cexpr e => e + | Cret v => Val v + end. +(* i mean not really bcause missing [reset]s *) + + (*** Type system *) Inductive ty := @@ -700,11 +811,11 @@ Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := typed Γ e1 τ → typed Γ e2 τ → typed Γ (If e0 e1 e2) τ -| typed_Input : - typed Γ Input Tnat -| typed_Output e : - typed Γ e Tnat → - typed Γ (Output e) Tnat +(* | typed_Input : *) +(* typed Γ Input Tnat *) +(* | typed_Output e : *) +(* typed Γ e Tnat → *) +(* typed Γ (Output e) Tnat *) (* | typed_Throw e1 e2 τ τ' : *) (* typed Γ e1 τ -> *) (* typed Γ e2 (Tcont τ) -> *) @@ -774,15 +885,15 @@ Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynEx }. -Class OutputNotation (A B : Type) := { __output : A -> B }. +(* 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 OutputNotationExpr {S : Set} {F : Set -> Type} `{AsSynExpr F} : OutputNotation (F S) (expr S) := { *) +(* __output e := Output (__asSynExpr e) *) +(* }. *) -Global Instance OutputNotationK {S : Set} : OutputNotation (ectx S) (ectx S) := { - __output K := K ++ [OutputK] - }. +(* Global Instance OutputNotationK {S : Set} : OutputNotation (ectx S) (ectx S) := { *) +(* __output K := K ++ [OutputK] *) +(* }. *) Class ResetNotation (A B : Type) := { __reset : A -> B }. @@ -827,10 +938,10 @@ 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 "'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 "'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. @@ -895,34 +1006,34 @@ Module SynExamples. End SynExamples. Definition compute_head_step {S} - (e : expr S) (σ : state) (K : ectx S) : - option (expr S * state * ectx S * (nat * nat)) := + (e : expr S) (K : ectx S) : + option (expr S * ectx 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)) + (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 + 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)) + then Some (e1, K, (0, 0)) else if (decide (n = 0)) - then Some (e2, σ, K, (0, 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)) + (* 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. @@ -931,15 +1042,15 @@ Definition compute_head_step {S} Example test21 : val ∅ := (rec (if ($ 0) then # 1 else #0))%syn. -Example testc : option (expr (inc ∅) * state * ectx (inc ∅) * (nat * nat)) := - (compute_head_step (App (Val test1) (Val $ LitV 5)) (State [] []) []). +Example testc : option (expr (inc ∅) * ectx (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) (σ : state) (K Ko : ectx S) - : option_reflect (fun '(e', σ', K', nm) => head_step e σ K e' σ' K' Ko nm) +Lemma head_step_reflect {S : Set} (e : expr S) (K Ko : ectx S) + : option_reflect (fun '(e', K', nm) => head_step e K e' K' Ko nm) True - (compute_head_step e σ K). + (compute_head_step e K). Proof. destruct e; try (by constructor). - destruct e1; try (by constructor). @@ -971,14 +1082,14 @@ Proof. 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 (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 =>//=. *) From 8dd1fe5c4335bb60cf5042299a0aa2304f1abc60 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 8 Feb 2024 16:53:26 +0100 Subject: [PATCH 095/114] Abstract machine sem for delim_lang (cf biernack(a/i) danvy 2005) --- theories/input_lang_delim/lang.v | 723 ++++++++++++++----------------- 1 file changed, 322 insertions(+), 401 deletions(-) diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index e5b2ba1..ef1188f 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -23,31 +23,27 @@ Inductive expr {X : Set} := (* The effects *) (* | Input : expr *) (* | Output (e : expr) : expr *) -| Shift (e : expr) : expr +| Shift (e : @expr (inc X)) : expr | Reset (e : expr) : expr with val {X : Set} := | LitV (n : nat) : val | RecV (e : @expr (inc (inc X))) : val -| ContV (e : @expr (inc X)) : val. +| ContV (k : cont) : val +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 ◻ *) +| NatOpLK (op : nat_op) (v : val) : cont -> cont (* ◻ + v *) +| NatOpRK (op : nat_op) (e : expr) : cont -> cont. (* e + ◻ *) +(* conts are inside-out contexts: eg + IfK e1 e2 (AppLK v ◻) ==> App (if ◻ then e1 else e2) v*) -Variant ectx_el {X : Set} := - (* | OutputK : ectx_el *) - | IfK (e1 : @expr X) (e2 : @expr X) : ectx_el - | AppLK (v : @val X) : ectx_el (* ◻ v *) - | AppRK (e : @expr X) : ectx_el (* e ◻ *) - | NatOpLK (op : nat_op) (v : @val X) : ectx_el (* ◻ + v *) - | NatOpRK (op : nat_op) (e : @expr X) : ectx_el (* e + ◻ *) - | ResetK : ectx_el. - - -Definition ectx {X : Set} := list (@ectx_el X). - Arguments val X%bind : clear implicits. Arguments expr X%bind : clear implicits. -Arguments ectx_el X%bind : clear implicits. -Arguments ectx X%bind : clear implicits. +Arguments cont X%bind : clear implicits. @@ -64,7 +60,7 @@ 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₃) (* | Input => Input *) (* | Output e => Output (emap f e) *) - | Shift e => Shift (emap f e) + | Shift e => Shift (emap (f ↑) e) | Reset e => Reset (emap f e) end with @@ -72,24 +68,22 @@ vmap {A B : Set} (f : A [→] B) (v : val A) : val B := match v with | LitV n => LitV n | RecV e => RecV (emap ((f ↑) ↑) e) - | ContV e => ContV (emap (f ↑) e) - end. + | ContV k => ContV (kmap f k) + end +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) + | NatOpLK op v k => NatOpLK op (vmap f v) (kmap f k) + | NatOpRK op e k => NatOpRK op (emap f e) (kmap f k) + end. + #[export] Instance FMap_expr : FunctorCore expr := @emap. #[export] Instance FMap_val : FunctorCore val := @vmap. - -Definition kmap {A B : Set} (f : A [→] B) (K : ectx A) : ectx B := - map (fun x => match x with - (* | OutputK => OutputK *) - | IfK e1 e2 => IfK (fmap f e1) (fmap f e2) - | AppLK v => AppLK (fmap f v) - | AppRK e => AppRK (fmap f e) - | NatOpLK op v => NatOpLK op (fmap f v) - | NatOpRK op e => NatOpRK op (fmap f e) - | ResetK => ResetK - end) K. - -#[export] Instance FMap_ectx : FunctorCore ectx := @kmap. +#[export] Instance FMap_cont : FunctorCore cont := @kmap. #[export] Instance SPC_expr : SetPureCore expr := @Var. @@ -102,7 +96,7 @@ 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₃) (* | Input => Input *) (* | Output e => Output (ebind f e) *) - | Shift e => Shift (ebind f e) + | Shift e => Shift (ebind (f ↑) e) | Reset e => Reset (ebind f e) end with @@ -110,36 +104,21 @@ vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := match v with | LitV n => LitV n | RecV e => RecV (ebind ((f ↑) ↑) e) - | ContV e => ContV (ebind (f ↑) e) - end. + | ContV k => ContV (kbind f k) + end +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) + | NatOpLK op v k => NatOpLK op (vbind f v) (kbind f k) + | NatOpRK op e k => NatOpRK op (ebind f e) (kbind f k) + end. #[export] Instance BindCore_expr : BindCore expr := @ebind. #[export] Instance BindCore_val : BindCore val := @vbind. - -Definition kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := - map (fun x => match x with - (* | OutputK => OutputK *) - | IfK e1 e2 => IfK (bind f e1) (bind f e2) - | AppLK v => AppLK (bind f v) - | AppRK e => AppRK (bind f e) - | NatOpLK op v => NatOpLK op (bind f v) - | NatOpRK op e => NatOpRK op (bind f e) - | ResetK => ResetK - end) K. - -(* with kbind {A B : Set} (f : A [⇒] B) (K : ectx A) : ectx B := *) -(* match K with *) -(* | EmptyK => EmptyK *) -(* | OutputK K => OutputK (kbind f K) *) -(* | IfK K e₁ e₂ => IfK (kbind f K) (ebind f e₁) (ebind f e₂) *) -(* | AppLK K v => AppLK (kbind f K) (vbind f v) *) -(* | AppRK e K => AppRK (ebind f e) (kbind f K) *) -(* | NatOpRK op e K => NatOpRK op (ebind f e) (kbind f K) *) -(* | NatOpLK op K v => NatOpLK op (kbind f K) (vbind f v) *) -(* | ResetK K => ResetK (kbind f K) *) -(* end. *) - -#[export] Instance BindCore_ectx : BindCore ectx := @kbind. +#[export] Instance BindCore_cont : BindCore cont := @kbind. #[export] Instance IP_typ : SetPure expr. Proof. @@ -147,42 +126,26 @@ Proof. Qed. Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v -with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e. -(* with kmap_id X (δ : X [→] X) (e : ectx X) : δ ≡ ı → fmap δ e = e. *) +with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e +with kmap_id X (δ : X [→] X) (k : cont X) : δ ≡ ı → fmap δ k = k. Proof. - auto_map_id. - auto_map_id. + - auto_map_id. Qed. -Definition kmap_id X (δ : X [→] X) (k : ectx X) : δ ≡ ı -> fmap δ k = k. -Proof. - rewrite /fmap /FMap_ectx /kmap => H. - rewrite <-List.map_id. do 2 f_equal. - extensionality x. case: x => // >; rewrite !(emap_id, vmap_id)//. -Qed. - - Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : f ∘ g ≡ h → fmap f (fmap g v) = fmap h v with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e +with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : cont A) : f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. Proof. - auto_map_comp. - auto_map_comp. + - auto_map_comp. Qed. - -Definition kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : ectx A) : - f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. -Proof. - rewrite /fmap /FMap_ectx => H. - rewrite /kmap map_map. do 2 f_equal. - extensionality x. - case : x => // >; rewrite !(emap_comp _ _ _ f g h, vmap_comp _ _ _ f g h)//. -Qed. - - - #[export] Instance Functor_val : Functor val. Proof. split; [exact vmap_id | exact vmap_comp]. @@ -191,7 +154,7 @@ Qed. Proof. split; [exact emap_id | exact emap_comp]. Qed. -#[export] Instance Functor_ectx : Functor ectx. +#[export] Instance Functor_cont : Functor cont. Proof. split; [exact kmap_id | exact kmap_comp]. Qed. @@ -199,6 +162,8 @@ Qed. Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : f ̂ ≡ g → fmap f v = bind g v with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : + f ̂ ≡ g → fmap f e = bind g e +with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : cont A) : f ̂ ≡ g → fmap f e = bind g e. Proof. - auto_map_bind_pure. @@ -207,6 +172,7 @@ Proof. rewrite <-(EQ x). reflexivity. - auto_map_bind_pure. + - auto_map_bind_pure. Qed. #[export] Instance BindMapPure_val : BindMapPure val. @@ -217,18 +183,7 @@ Qed. Proof. split; intros; now apply emap_ebind_pure. Qed. - -Definition kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : ectx A) : - f ̂ ≡ g → fmap f e = bind g e. -Proof. - rewrite /fmap /FMap_ectx /bind /BindCore_ectx /kmap /kbind => H. - do 2 f_equal. extensionality x. - case: x => [] > //; rewrite !(emap_ebind_pure _ _ _ g, - vmap_vbind_pure _ _ _ g)//. -Qed. - - -#[export] Instance BindMapPure_ectx : BindMapPure ectx. +#[export] Instance BindMapPure_cont : BindMapPure cont. Proof. split; intros; now apply kmap_kbind_pure. Qed. @@ -238,6 +193,9 @@ Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [ g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) +with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : cont A) : g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). Proof. - auto_map_bind_comm. @@ -245,19 +203,9 @@ Proof. erewrite lift_comm; [reflexivity |]. erewrite lift_comm; [reflexivity | assumption]. - auto_map_bind_comm. + - auto_map_bind_comm. Qed. -Definition kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) - (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : ectx A) : - g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). -Proof. - rewrite /fmap /FMap_ectx /bind /BindCore_ectx /kmap /kbind => H. - rewrite !map_map. do 2 f_equal. extensionality x. - case : x => // >; rewrite !(emap_ebind_comm _ B₁ _ _ f₁ _ g₁, - vmap_vbind_comm _ B₁ _ _ f₁ _ g₁)//. -Qed. - - #[export] Instance BindMapComm_val : BindMapComm val. Proof. split; intros; now apply vmap_vbind_comm. @@ -266,7 +214,7 @@ Qed. Proof. split; intros; now apply emap_ebind_comm. Qed. -#[export] Instance BindMapComm_ectx : BindMapComm ectx. +#[export] Instance BindMapComm_cont : BindMapComm cont. Proof. split; intros; now apply kmap_kbind_comm. Qed. @@ -274,27 +222,23 @@ Qed. Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : f ≡ ı → bind f v = v with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : + f ≡ ı → bind f e = e +with kbind_id (A : Set) (f : A [⇒] A) (e : cont A) : f ≡ ı → bind f e = e. Proof. - auto_bind_id. rewrite ebind_id; [reflexivity |]. apply lift_id, lift_id; assumption. - auto_bind_id. -Qed. - -Definition kbind_id (A : Set) (f : A [⇒] A) (e : ectx A) : - f ≡ ı → bind f e = e. -Proof. - rewrite /bind /BindCore_ectx /kbind => H. - rewrite <-List.map_id. do 2 f_equal. - extensionality x. case : x => // >; rewrite !(ebind_id, vbind_id)//. + - auto_bind_id. Qed. - Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : f ∘ g ≡ h → bind f (bind g v) = bind h v with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e +with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : cont A) : f ∘ g ≡ h → bind f (bind g e) = bind h e. Proof. - auto_bind_comp. @@ -302,15 +246,7 @@ Proof. erewrite lift_comp; [reflexivity |]. erewrite lift_comp; [reflexivity | assumption]. - auto_bind_comp. -Qed. - -Definition kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : ectx A) : - f ∘ g ≡ h → bind f (bind g e) = bind h e. -Proof. - rewrite /bind/BindCore_ectx/kbind => H. - rewrite map_map. do 2 f_equal. extensionality x. - case : x => // >; rewrite !(ebind_comp _ _ _ _ _ h, - vbind_comp _ _ _ _ _ h)//. + - auto_bind_comp. Qed. @@ -322,17 +258,12 @@ Qed. Proof. split; intros; [now apply ebind_id | now apply ebind_comp]. Qed. -#[export] Instance Bind_ectx : Bind ectx. +#[export] Instance Bind_cont : Bind cont. Proof. split; intros; [now apply kbind_id | now apply kbind_comp]. Qed. - -(* Definition LamV {S : Set} (e : expr (inc S)) : val S := *) -(* RecV (shift e). *) - - Definition to_val {S} (e : expr S) : option (val S) := match e with | Val v => Some v @@ -352,114 +283,109 @@ Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := | _,_ => None end. - -Definition ctx_el_to_expr {X : Set} (K : ectx_el X) (e : expr X) : expr X := +Fixpoint fill {X : Set} (K : cont X) (e : expr X) : expr X := match K with - (* | OutputK => Output $ e *) - | IfK e1 e2 => If e e1 e2 - | AppLK v => App e (Val v) - | AppRK el => App el e - | NatOpLK op v => NatOp op e (Val v) - | NatOpRK op el => NatOp op el e - | ResetK => Reset e + | 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) + | NatOpLK op v K => fill K (NatOp op e (Val v)) + | NatOpRK op el K => fill K (NatOp op el e) end. -Definition fill {X : Set} (K : ectx X) (e : expr X) : expr X := - fold_left (fun e c => ctx_el_to_expr c e) K e. - -Fixpoint trim_to_first_reset {X : Set} (K : ectx X) (acc : ectx X) : (ectx X * ectx X) := - match K with - (* | OutputK :: K => trim_to_first_reset K (OutputK :: acc) *) - (* | (IfK e1 e2) :: K => trim_to_first_reset K ((IfK e1 e2) :: acc) *) - (* | (AppLK v) :: K => trim_to_first_reset K ((AppLK v) :: acc) *) - (* | (AppRK el) :: K => trim_to_first_reset K ((AppRK el) :: acc) *) - (* | (NatOpLK op v) :: K => trim_to_first_reset K ((NatOpLK op v) :: acc) *) - (* | (NatOpRK op el) :: K => trim_to_first_reset K ((NatOpRK op el) :: acc) *) - | (ResetK) :: K => (acc, ResetK :: K) - | C :: K => trim_to_first_reset K (C :: acc) - | [] => (acc, []) - end. +(* Fixpoint trim_to_first_reset {X : Set} (K : ectx X) (acc : ectx X) : (ectx X * ectx X) := *) +(* match K with *) +(* (* | OutputK :: K => trim_to_first_reset K (OutputK :: acc) *) *) +(* (* | (IfK e1 e2) :: K => trim_to_first_reset K ((IfK e1 e2) :: acc) *) *) +(* (* | (AppLK v) :: K => trim_to_first_reset K ((AppLK v) :: acc) *) *) +(* (* | (AppRK el) :: K => trim_to_first_reset K ((AppRK el) :: acc) *) *) +(* (* | (NatOpLK op v) :: K => trim_to_first_reset K ((NatOpLK op v) :: acc) *) *) +(* (* | (NatOpRK op el) :: K => trim_to_first_reset K ((NatOpRK op el) :: acc) *) *) +(* | (ResetK) :: K => (acc, ResetK :: K) *) +(* | C :: K => trim_to_first_reset K (C :: acc) *) +(* | [] => (acc, []) *) +(* end. *) -(* Separate continuation [K] on innermost [reset] *) -Definition shift_context {X : Set} (K : ectx X) : (ectx X * ectx X) := - let (Ki, Ko) := trim_to_first_reset K [] in - (List.rev Ki, Ko). +(* (* Separate continuation [K] on innermost [reset] *) *) +(* Definition shift_context {X : Set} (K : ectx X) : (ectx X * ectx X) := *) +(* let (Ki, Ko) := trim_to_first_reset K [] in *) +(* (List.rev Ki, Ko). *) -Lemma trim_to_first_reset_app {X : Set} (K Ki Ko acc : ectx X) : - (Ki, Ko) = trim_to_first_reset K acc -> - (List.rev Ki) ++ Ko = (List.rev acc) ++ K. -Proof. - revert Ki Ko acc. induction K; simpl; intros. - - by inversion H. - - specialize (IHK Ki Ko (a :: acc)) as HI. - destruct a; try (specialize (HI H); rewrite HI; simpl; - rewrite -app_assoc; symmetry; apply cons_middle). - by inversion H. -Qed. +(* Lemma trim_to_first_reset_app {X : Set} (K Ki Ko acc : ectx X) : *) +(* (Ki, Ko) = trim_to_first_reset K acc -> *) +(* (List.rev Ki) ++ Ko = (List.rev acc) ++ K. *) +(* Proof. *) +(* revert Ki Ko acc. induction K; simpl; intros. *) +(* - by inversion H. *) +(* - specialize (IHK Ki Ko (a :: acc)) as HI. *) +(* destruct a; try (specialize (HI H); rewrite HI; simpl; *) +(* rewrite -app_assoc; symmetry; apply cons_middle). *) +(* by inversion H. *) +(* Qed. *) -Lemma shift_context_app {X : Set} (K Ki Ko : ectx X) : - (Ki, Ko) = shift_context K -> K = Ki ++ Ko. -Proof. - unfold shift_context. intro. - destruct (trim_to_first_reset K ([])) as [Ki' Ko'] eqn:He. - inversion H. subst. - trans (rev [] ++ K); first auto. symmetry. - by apply trim_to_first_reset_app. -Qed. +(* Lemma shift_context_app {X : Set} (K Ki Ko : ectx X) : *) +(* (Ki, Ko) = shift_context K -> K = Ki ++ Ko. *) +(* Proof. *) +(* unfold shift_context. intro. *) +(* destruct (trim_to_first_reset K ([])) as [Ki' Ko'] eqn:He. *) +(* inversion H. subst. *) +(* trans (rev [] ++ K); first auto. symmetry. *) +(* by apply trim_to_first_reset_app. *) +(* Qed. *) -Lemma trim_reset_no_reset {X : Set} (K Ki Ko acc : ectx X) : - (Ki, Ko) = trim_to_first_reset K acc -> - ResetK ∉ acc -> - ResetK ∉ Ki. -Proof. - elim: K Ko acc Ki; simpl; intros. - - congruence. - - destruct a; try solve [eapply H; try eapply H0; try (apply not_elem_of_cons; done)]. - congruence. -Qed. +(* Lemma trim_reset_no_reset {X : Set} (K Ki Ko acc : ectx X) : *) +(* (Ki, Ko) = trim_to_first_reset K acc -> *) +(* ResetK ∉ acc -> *) +(* ResetK ∉ Ki. *) +(* Proof. *) +(* elim: K Ko acc Ki; simpl; intros. *) +(* - congruence. *) +(* - destruct a; try solve [eapply H; try eapply H0; try (apply not_elem_of_cons; done)]. *) +(* congruence. *) +(* Qed. *) -Lemma shift_context_no_reset {X : Set} (K Ki Ko : ectx X) : - (Ki, Ko) = shift_context K -> ResetK ∉ Ki. -Proof. - rewrite /shift_context//. destruct (trim_to_first_reset K []) eqn:Heq. symmetry in Heq. - intros. eapply trim_reset_no_reset in Heq; last apply not_elem_of_nil. - rewrite rev_alt in H. inversion H. subst. by rewrite elem_of_reverse. -Qed. +(* Lemma shift_context_no_reset {X : Set} (K Ki Ko : ectx X) : *) +(* (Ki, Ko) = shift_context K -> ResetK ∉ Ki. *) +(* Proof. *) +(* rewrite /shift_context//. destruct (trim_to_first_reset K []) eqn:Heq. symmetry in Heq. *) +(* intros. eapply trim_reset_no_reset in Heq; last apply not_elem_of_nil. *) +(* rewrite rev_alt in H. inversion H. subst. by rewrite elem_of_reverse. *) +(* Qed. *) -Lemma no_reset_trim_ident {X : Set} (K acc : ectx X) : - ResetK ∉ K -> ResetK ∉ acc -> - ((List.rev K) ++ acc, []) = trim_to_first_reset K acc. - Proof. - elim: K acc; intros; simpl; eauto. - apply not_elem_of_cons in H0 as [Hh Ht]. - destruct a; try contradiction; - rewrite -app_assoc; simpl; apply H; eauto; by apply not_elem_of_cons. - Qed. +(* Lemma no_reset_trim_ident {X : Set} (K acc : ectx X) : *) +(* ResetK ∉ K -> ResetK ∉ acc -> *) +(* ((List.rev K) ++ acc, []) = trim_to_first_reset K acc. *) +(* Proof. *) +(* elim: K acc; intros; simpl; eauto. *) +(* apply not_elem_of_cons in H0 as [Hh Ht]. *) +(* destruct a; try contradiction; *) +(* rewrite -app_assoc; simpl; apply H; eauto; by apply not_elem_of_cons. *) +(* Qed. *) -Lemma no_reset_shift_context_ident {X : Set} (K : ectx X) : - ResetK ∉ K -> (K, []) = shift_context K. -Proof. - unfold shift_context. intros. rewrite -no_reset_trim_ident; - last apply not_elem_of_nil; last done. - by rewrite app_nil_r rev_involutive. -Qed. +(* Lemma no_reset_shift_context_ident {X : Set} (K : ectx X) : *) +(* ResetK ∉ K -> (K, []) = shift_context K. *) +(* Proof. *) +(* unfold shift_context. intros. rewrite -no_reset_trim_ident; *) +(* last apply not_elem_of_nil; last done. *) +(* by rewrite app_nil_r rev_involutive. *) +(* Qed. *) (* Only if no reset in K *) -Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := - ContV (fill (shift K) (Var VZ)). +(* Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := *) +(* ContV (fill (shift K) (Var VZ)). *) -Example test1 : val (inc ∅) := (cont_to_rec [(NatOpLK Add (LitV 3)); AppRK (Var VZ)]). +(* Example test1 : val (inc ∅) := (cont_to_rec [(NatOpLK Add (LitV 3)); AppRK (Var VZ)]). *) (* Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) *) (* : fmap f (fill K e) = fill (fmap f K) (fmap f e). *) @@ -491,100 +417,109 @@ Example test1 : val (inc ∅) := (cont_to_rec [(NatOpLK Add (LitV 3)); AppRK (Va (** [head_step e σ K e' σ' K' Ko (n, m)] : step from [(e, σ, K)] to [(e', σ', K')] under outer context [Ko] in [n] ticks with [m] effects encountered *) -Variant head_step {S} : expr S -> ectx S -> - expr S -> ectx S -> - ectx S -> - nat * nat → Prop := - | BetaS e1 v2 K Ko : - head_step (App (Val $ RecV e1) (Val v2)) K - (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) - (Val (shift (Inc := inc) v2))) - (Val (RecV e1))) K Ko (1,0) - | BetaContS e1 v2 K Ko : - head_step (App (Val $ ContV e1) (Val v2)) K - (subst (Inc := inc) e1 (Val v2)) - K Ko (2,0) - (* | InputS n σ' K Ko : *) - (* update_input = (n, σ') → *) - (* head_step Input K (Val (LitV n)) σ' K Ko (1, 1) *) - (* | OutputS n σ' K Ko : *) - (* update_output n = σ' → *) - (* head_step (Output (Val (LitV n))) K (Val (LitV 0)) σ' K Ko (1, 1) *) - | NatOpS op v1 v2 v3 K Ko : - nat_op_interp op v1 v2 = Some v3 → - head_step (NatOp op (Val v1) (Val v2)) K - (Val v3) K Ko (0, 0) - | IfTrueS n e1 e2 K Ko : - n > 0 → - head_step (If (Val (LitV n)) e1 e2) K - e1 K Ko (0, 0) - | IfFalseS n e1 e2 K Ko : - n = 0 → - head_step (If (Val (LitV n)) e1 e2) K - e2 K Ko (0, 0) - - | ShiftS (e : expr (inc (inc S))) K Ko f : - ResetK ∉ K -> - f = cont_to_rec (ResetK::K) -> - head_step (Shift (Val $ RecV e)) K - (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e) - (Val (shift (Inc := inc) f))) - (Val $ RecV e)) [] Ko (1, 1) - - | ResetS v K Ko : - head_step (Reset (Val v)) K (Val v) K Ko (1, 1). - - - (* | ValueS v σ K C: *) - (* head_step (Val v) σ (C::K) (ctx_el_to_expr C (Val v)) σ K (0, 0) *) - - (* | ResetShiftS e σ K E: *) - (* head_step *) - (* (Reset (fill E (Shift e))) σ *) - (* (Reset (subst (Inc := inc) e (Val $ ContV $ ResetK E))) σ K (1,0). *) - -Lemma head_step_io_01 {S} (e1 e2 : expr S) K K' Ko n m : - head_step e1 K e2 K' Ko (n,m) → m = 0 ∨ m = 1. -Proof. inversion 1; eauto. Qed. -(* Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : *) -(* head_step e1 σ1 K e2 σ2 K' (n,m) → n = 0 ∨ n = 1. *) -(* Proof. inversion 1; eauto. Qed. *) -(* Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K K' Ko n : *) -(* head_step e1 σ1 K e2 σ2 K' Ko (n,0) → σ1 = σ2. *) +(* Variant head_step {S} : expr S -> ectx S -> *) +(* expr S -> ectx S -> *) +(* ectx S -> *) +(* nat * nat → Prop := *) +(* | BetaS e1 v2 K Ko : *) +(* head_step (App (Val $ RecV e1) (Val v2)) K *) +(* (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) *) +(* (Val (shift (Inc := inc) v2))) *) +(* (Val (RecV e1))) K Ko (1,0) *) +(* | BetaContS e1 v2 K Ko : *) +(* head_step (App (Val $ ContV e1) (Val v2)) K *) +(* (subst (Inc := inc) e1 (Val v2)) *) +(* K Ko (2,0) *) +(* (* | InputS n σ' K Ko : *) *) +(* (* update_input = (n, σ') → *) *) +(* (* head_step Input K (Val (LitV n)) σ' K Ko (1, 1) *) *) +(* (* | OutputS n σ' K Ko : *) *) +(* (* update_output n = σ' → *) *) +(* (* head_step (Output (Val (LitV n))) K (Val (LitV 0)) σ' K Ko (1, 1) *) *) +(* | NatOpS op v1 v2 v3 K Ko : *) +(* nat_op_interp op v1 v2 = Some v3 → *) +(* head_step (NatOp op (Val v1) (Val v2)) K *) +(* (Val v3) K Ko (0, 0) *) +(* | IfTrueS n e1 e2 K Ko : *) +(* n > 0 → *) +(* head_step (If (Val (LitV n)) e1 e2) K *) +(* e1 K Ko (0, 0) *) +(* | IfFalseS n e1 e2 K Ko : *) +(* n = 0 → *) +(* head_step (If (Val (LitV n)) e1 e2) K *) +(* e2 K Ko (0, 0) *) + +(* | ShiftS (e : expr (inc (inc S))) K Ko f : *) +(* ResetK ∉ K -> *) +(* f = cont_to_rec (ResetK::K) -> *) +(* head_step (Shift (Val $ RecV e)) K *) +(* (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e) *) +(* (Val (shift (Inc := inc) f))) *) +(* (Val $ RecV e)) [] Ko (1, 1) *) + +(* | ResetS v K Ko : *) +(* head_step (Reset (Val v)) K (Val v) K Ko (1, 1). *) + + +(* (* | ValueS v σ K C: *) *) +(* (* head_step (Val v) σ (C::K) (ctx_el_to_expr C (Val v)) σ K (0, 0) *) *) + +(* (* | ResetShiftS e σ K E: *) *) +(* (* head_step *) *) +(* (* (Reset (fill E (Shift e))) σ *) *) +(* (* (Reset (subst (Inc := inc) e (Val $ ContV $ ResetK E))) σ K (1,0). *) *) + +(* Lemma head_step_io_01 {S} (e1 e2 : expr S) K K' Ko n m : *) +(* head_step e1 K e2 K' Ko (n,m) → m = 0 ∨ m = 1. *) (* Proof. inversion 1; eauto. Qed. *) +(* (* Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : *) *) +(* (* head_step e1 σ1 K e2 σ2 K' (n,m) → n = 0 ∨ n = 1. *) *) +(* (* Proof. inversion 1; eauto. Qed. *) *) +(* (* Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K K' Ko n : *) *) +(* (* head_step e1 σ1 K e2 σ2 K' Ko (n,0) → σ1 = σ2. *) *) +(* (* Proof. inversion 1; eauto. Qed. *) *) -(** Carbonara from heap lang *) +(* (** Carbonara from heap lang *) *) -Global Instance ctx_el_to_expr_inj {S} (C : ectx_el S) : Inj (=) (=) (ctx_el_to_expr C). -Proof. case: C => [] >; simpl in*; congruence. Qed. +(* Global Instance ctx_el_to_expr_inj {S} (C : ectx_el S) : Inj (=) (=) (ctx_el_to_expr C). *) +(* Proof. case: C => [] >; simpl in*; congruence. Qed. *) -Global Instance fill_inj {S} (Ki : ectx S) : Inj (=) (=) (fill Ki). +Global Instance fill_inj {S} (Ki : cont S) : Inj (=) (=) (fill Ki). Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. -Lemma ctx_el_to_expr_val {S} C (e : expr S) : - is_Some (to_val (ctx_el_to_expr C e)) → is_Some (to_val e). -Proof. case : C => [] > H; simpl in H; try by apply is_Some_None in H. Qed. +(* Lemma ctx_el_to_expr_val {S} C (e : expr S) : *) +(* is_Some (to_val (ctx_el_to_expr C e)) → is_Some (to_val e). *) +(* Proof. case : C => [] > H; simpl in H; try by apply is_Some_None in H. Qed. *) Lemma fill_val {S} Ki (e : expr S) : is_Some (to_val (fill Ki e)) → is_Some (to_val e). -Proof. elim: Ki e; simpl in *; first done. intros. - apply (ctx_el_to_expr_val a e). apply H. apply H0. +Proof. + elim: Ki e; simpl in *; intros; first done; + apply H in H0; simpl in H0; contradiction (is_Some_None H0). Qed. -(* CHECK *) -Lemma val_head_stuck {S} (e1 : expr S) e2 K K' Ko m : - head_step e1 K e2 K' Ko m → to_val e1 = None. -Proof. destruct 1; naive_solver. Qed. +(* (* CHECK *) *) +(* Lemma val_head_stuck {S} (e1 : expr S) e2 K K' Ko m : *) +(* head_step e1 K e2 K' Ko m → to_val e1 = None. *) +(* Proof. destruct 1; naive_solver. Qed. *) (* K1 ∘ K2 *) -Definition ectx_compose {S} (K1 K2 : ectx S) : ectx S := - K2 ++ K1. +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) + | NatOpLK op v K => NatOpLK op v (cont_compose K1 K) + | NatOpRK op e K => NatOpRK op e (cont_compose K1 K) + end. + -Lemma fill_app {S} (K1 K2 : ectx S) e : fill (ectx_compose K1 K2) e = fill K1 (fill K2 e). +Lemma fill_comp {S} (K1 K2 : cont S) e : fill (cont_compose K1 K2) e = fill K1 (fill K2 e). Proof. - elim: K2 K1 e =>>; eauto. - intros H K1 e. simpl. by rewrite H. + elim: K2 K1 e =>>; eauto; + intros H K1 e; simpl; by rewrite H. Qed. @@ -595,94 +530,90 @@ Proof. Qed. -Lemma fill_comp {S} K1 K2 (e : expr S) : fill K2 (fill K1 e) = fill (ectx_compose K2 K1) e. -Proof. by rewrite fill_app. Qed. - - (* FIXME maybe *) -Inductive prim_step {S} : ∀ (e1 : expr S) - (e2 : expr S) (nm : nat * nat), Prop := -(* | Ectx_step e1 σ1 e2 σ2 nm (K1 K2 : ectx S) e1' e2' : *) -(* e1 = fill K1 e1' -> *) -(* e2 = fill K2 e2' -> *) +(* Inductive prim_step {S} : ∀ (e1 : expr S) *) +(* (e2 : expr S) (nm : nat * nat), Prop := *) +(* (* | Ectx_step e1 σ1 e2 σ2 nm (K1 K2 : ectx S) e1' e2' : *) *) +(* (* e1 = fill K1 e1' -> *) *) +(* (* e2 = fill K2 e2' -> *) *) +(* (* ResetK ∉ K1 -> *) *) +(* (* head_step e1' σ1 K1 e2' σ2 K2 nm -> *) *) +(* (* prim_step e1 σ1 e2 σ2 nm *) *) +(* | Shift_step e1 K Ki Ko e2 Ki' nm : *) +(* (Ki, Ko) = shift_context K -> *) +(* head_step e1 Ki e2 Ki' Ko nm -> *) +(* prim_step (fill K e1) (fill (Ki' ++ Ko) e2) nm. *) +(* (* CHECK *) *) + +(* (* Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : *) *) +(* (* prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. *) *) +(* (* Proof. *) *) +(* (* inversion 1; simplify_eq/=. by inversion H1. *) *) +(* (* Qed. *) *) + +(* Inductive prim_steps {S} : expr S → expr S → nat * nat → Prop := *) +(* | prim_steps_zero e : *) +(* prim_steps e e (0, 0) *) +(* | prim_steps_abit e1 e2 e3 n1 m1 n2 m2 : *) +(* prim_step e1 e2 (n1, m1) → *) +(* prim_steps e2 e3 (n2, m2) → *) +(* prim_steps e1 e3 (plus n1 n2, plus m1 m2) *) +(* . *) + +(* Lemma Ectx_step' {S} (K1 K2 : ectx S) e1 e2 efs : *) +(* head_step e1 K1 e2 K2 [] efs → *) (* ResetK ∉ K1 -> *) -(* head_step e1' σ1 K1 e2' σ2 K2 nm -> *) -(* prim_step e1 σ1 e2 σ2 nm *) -| Shift_step e1 K Ki Ko e2 Ki' nm : - (Ki, Ko) = shift_context K -> - head_step e1 Ki e2 Ki' Ko nm -> - prim_step (fill K e1) (fill (Ki' ++ Ko) e2) nm. -(* CHECK *) - -(* Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : *) -(* prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. *) +(* prim_step (fill K1 e1) (fill K2 e2) efs. *) (* Proof. *) -(* inversion 1; simplify_eq/=. by inversion H1. *) +(* intros. rewrite -(app_nil_r K2). *) +(* econstructor; eauto. by apply no_reset_shift_context_ident. *) (* Qed. *) -Inductive prim_steps {S} : expr S → expr S → nat * nat → Prop := -| prim_steps_zero e : - prim_steps e e (0, 0) -| prim_steps_abit e1 e2 e3 n1 m1 n2 m2 : - prim_step e1 e2 (n1, m1) → - prim_steps e2 e3 (n2, m2) → - prim_steps e1 e3 (plus n1 n2, plus m1 m2) -. - -Lemma Ectx_step' {S} (K1 K2 : ectx S) e1 e2 efs : - head_step e1 K1 e2 K2 [] efs → - ResetK ∉ K1 -> - prim_step (fill K1 e1) (fill K2 e2) efs. -Proof. - intros. rewrite -(app_nil_r K2). - econstructor; eauto. by apply no_reset_shift_context_ident. -Qed. - -Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) : - prim_steps e1 e2 nm1 → prim_steps e2 e3 nm2 → - prim_steps e1 e3 (plus nm1.1 nm2.1, plus nm1.2 nm2.2). -Proof. - intros Hst. revert nm2. - induction Hst; intros [n' m']; simplify_eq/=; first done. - rewrite -!Nat.add_assoc. intros Hsts. - econstructor; eauto. - by apply (IHHst (n',m')). -Qed. +(* Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) : *) +(* prim_steps e1 e2 nm1 → prim_steps e2 e3 nm2 → *) +(* prim_steps e1 e3 (plus nm1.1 nm2.1, plus nm1.2 nm2.2). *) +(* Proof. *) +(* intros Hst. revert nm2. *) +(* induction Hst; intros [n' m']; simplify_eq/=; first done. *) +(* rewrite -!Nat.add_assoc. intros Hsts. *) +(* econstructor; eauto. *) +(* by apply (IHHst (n',m')). *) +(* Qed. *) -Lemma prim_step_steps {S} nm (e1 e2 : expr S) : - prim_step e1 e2 nm → prim_steps e1 e2 nm. -Proof. - destruct nm as [n m]. intro Hs. - rewrite -(Nat.add_0_r n). - rewrite -(Nat.add_0_r m). - econstructor; eauto. - by constructor. -Qed. +(* Lemma prim_step_steps {S} nm (e1 e2 : expr S) : *) +(* prim_step e1 e2 nm → prim_steps e1 e2 nm. *) +(* Proof. *) +(* destruct nm as [n m]. intro Hs. *) +(* rewrite -(Nat.add_0_r n). *) +(* rewrite -(Nat.add_0_r m). *) +(* econstructor; eauto. *) +(* by constructor. *) +(* Qed. *) -Lemma prim_step_steps_steps {S} (e1 e2 e3 : expr S) nm1 nm2 nm3 : - nm3 = (plus nm1.1 nm2.1, plus nm1.2 nm2.2) -> - prim_step e1 e2 nm1 → prim_steps e2 e3 nm2 -> prim_steps e1 e3 nm3. -Proof. - intros -> H G. - eapply prim_steps_app; last apply G. - apply prim_step_steps, H. -Qed. +(* Lemma prim_step_steps_steps {S} (e1 e2 e3 : expr S) nm1 nm2 nm3 : *) +(* nm3 = (plus nm1.1 nm2.1, plus nm1.2 nm2.2) -> *) +(* prim_step e1 e2 nm1 → prim_steps e2 e3 nm2 -> prim_steps e1 e3 nm3. *) +(* Proof. *) +(* intros -> H G. *) +(* eapply prim_steps_app; last apply G. *) +(* apply prim_step_steps, H. *) +(* Qed. *) -Lemma head_step_prim_step {S} (e1 e2 : expr S) nm : - head_step e1 [] e2 [] [] nm -> prim_step e1 e2 nm. -Proof. - move => H; apply Ectx_step' in H => //=. apply not_elem_of_nil. -Qed. +(* Lemma head_step_prim_step {S} (e1 e2 : expr S) nm : *) +(* head_step e1 [] e2 [] [] nm -> prim_step e1 e2 nm. *) +(* Proof. *) +(* move => H; apply Ectx_step' in H => //=. apply not_elem_of_nil. *) +(* Qed. *) (*** Abstract Machine semantics *) -Definition Mectx {S} := list $ ectx S. +Definition Mcont {S} := list $ cont S. Variant config {S} : Type := - | Ceval : expr S -> ectx S -> @Mectx S -> config - | Ccont : ectx S -> val S -> @Mectx S -> config - | Cmcont : @Mectx S -> val 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 | Cret : val S -> config. @@ -693,70 +624,60 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := (* init *) | Ceval_init : forall (e : expr S), - Cexpr e ===> Ceval e [] [] / (0,0) + 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) + 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 (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 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 [] (k :: mk) / (1, 1) + Ceval (Reset e) k mk ===> Ceval e END (k :: mk) / (1, 1) - | Ceval_shift : forall (e : expr $ inc $ inc S) k f mk, - f = cont_to_rec (k) -> (* CHECK: should we add a reset to ctx ? don't think so *) - Ceval (Shift $ Val $ RecV e) k mk ===> - Ceval (subst (Inc := inc) - (subst (F := expr) (Inc := inc) - e (Val (shift (Inc:=inc) f))) - (Val (RecV e))) [] 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_hole : forall v mk, - Ccont [] v mk ===> Cmcont mk v / (0,0) + | 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 (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 ===> + 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_cont : forall e v k mk, - Ccont (AppLK v :: k) (ContV e) mk ===> - Ceval (subst (Inc := inc) e (Val v)) [] (k :: mk) / (2, 0) - - | Ccont_ift : forall et ef n k mk, - n > 0 -> - Ccont (IfK et ef :: k) (LitV n) mk ===> - Ceval et k mk / (0, 0) + | Ccont_cont : forall v k k' mk, + Ccont (AppLK v k) (ContV k') mk ===> + Ccont k' v (k :: mk) / (2, 0) - | Ccont_iff : forall et ef n k mk, - n = 0 -> - Ccont (IfK et ef :: k) (LitV n) mk ===> - Ceval ef 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 (NatOpRK op e k) v mk ===> + Ceval e (NatOpLK op v 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 ===> + 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 / (0,0) @@ -766,12 +687,12 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := where "c ===> c' / nm" := (Cred c c' nm). -Arguments Mectx S%bind : clear implicits. +Arguments Mcont S%bind : clear implicits. Arguments config S%bind : clear implicits. (** ** On configs & meta-contexts *) -Definition meta_fill {S} (mk : Mectx S) e := +Definition meta_fill {S} (mk : Mcont S) e := fold_left (λ e k, fill k e) mk e. From 881b6b22c84b955e5a1ffb9668d7a59c8f1e898b Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 9 Feb 2024 17:01:34 +0100 Subject: [PATCH 096/114] more stuff on this sem, now onto interpretation of configurations --- theories/input_lang_delim/interp.v | 353 ++++++++++++++--------------- theories/input_lang_delim/lang.v | 225 +++++++++--------- 2 files changed, 286 insertions(+), 292 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 9551c92..6d358f4 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -491,39 +491,34 @@ Section interp. (** ** RESET *) Program Definition interp_reset (e : IT) : IT := - get_val (λne v, CALLCC (λne (k : laterO IT -n> laterO IT), Next $ LET READ (λne m, SEQ (WRITE (λit r, SEQ (WRITE m) (THROW r k))) - (APP' READ v)))) e. + (APP' READ e))). Solve Obligations with solve_proper. Next Obligation. - intros e v k n ???. repeat f_equiv. intro. simpl. solve_proper. + intros e k n ???. repeat f_equiv. intro. simpl. solve_proper. Qed. Next Obligation. - intros e v n ???. repeat f_equiv. by do 2 (intro; simpl; repeat f_equiv). - Qed. - Next Obligation. - intros e n ???. f_equiv. intro. simpl. solve_proper_please. + intros e n ???. repeat f_equiv. by do 2 (intro; simpl; repeat f_equiv). Qed. #[export] Instance interp_reset_ne : NonExpansive (interp_reset). Proof. - solve_proper. - (* intros n ???. rewrite /interp_reset. simpl. repeat f_equiv. done. *) - (* by do 2 (intro; simpl; repeat f_equiv). *) + intros n ???. rewrite /interp_reset. simpl. repeat f_equiv. + by do 2 (intro; simpl; repeat f_equiv). Qed. (** ** SHIFT *) - Program Definition interp_shift {S} (e : S -n> IT) : S -n> IT := + Program Definition interp_shift {S} + (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := λne env, CALLCC (λne (k : laterO IT -n> laterO IT), Next (APP' READ - (APP' - (e env) - (λit x, interp_reset (THROW x k))))). + (e (@extend_scope F R _ _ env + (λit x, interp_reset (THROW x k)))))). Next Obligation. intros S e env k n ???. by repeat f_equiv. Qed. @@ -531,7 +526,9 @@ Section interp. intros S e env n ???. repeat f_equiv. intro. simpl. by repeat f_equiv. Qed. Next Obligation. - intros S e n ???. f_equiv. by intro; simpl; repeat f_equiv. + intros S e n ???. f_equiv. intro; simpl; repeat f_equiv. + intros [|a]; simpl; last solve_proper. + repeat f_equiv. Qed. @@ -620,30 +617,59 @@ Section interp. λne env, Ret n. (** ** CONT *) - Program Definition interp_cont {S} (e : @interp_scope F R _ (inc S) -n> IT) : - interp_scope S -n> IT := - λne env, (Fun (Next (λne x, Tick $ e (@extend_scope F R _ _ env x)))). - Next Obligation. - solve_proper_prepare. repeat f_equiv. - intros [|a]; eauto. - Qed. - Next Obligation. - solve_proper_prepare. - repeat f_equiv. - intro. simpl. repeat f_equiv. - intros [|z]; eauto. - Qed. + Program Definition interp_cont_val {S} (K : S -n> (IT -n> IT)) : S -n> IT := + λne env, (λit x, Tau (laterO_map (K env) (Next x))). + Solve All Obligations with solve_proper_please. + + (* Program Definition interp_cont {S} (e : @interp_scope F R _ (inc S) -n> IT) : *) + (* interp_scope S -n> IT := *) + (* λne env, (Fun (Next (λne x, Tick $ e (@extend_scope F R _ _ env x)))). *) + (* Next Obligation. *) + (* solve_proper_prepare. repeat f_equiv. *) + (* intros [|a]; eauto. *) + (* Qed. *) + (* Next Obligation. *) + (* solve_proper_prepare. *) + (* repeat f_equiv. *) + (* intro. simpl. repeat f_equiv. *) + (* intros [|z]; eauto. *) + (* Qed. *) #[local] Instance interp_reset_full_ne {S} (f : @interp_scope F R _ S -n> IT): NonExpansive (λ env, interp_reset (f env)). Proof. solve_proper. Qed. + Program Definition interp_ifk {A} (e1 e2 : A -n> IT) (K : A -n> IT -n> IT) : + A -n> (IT -n> IT) := + λne env b, (K env) $ interp_if (λne env, b) e1 e2 env. + Solve All Obligations with solve_proper. + + 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. + + 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. + + Program Definition interp_natoprk {A} (op : nat_op) (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_natop op q (λne env, t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_natop op (λne env, t) q env. + Solve All Obligations with solve_proper. + (** Interpretation for all the syntactic categories: values, expressions, contexts *) Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := match v with | LitV n => interp_nat n | RecV e => interp_rec (interp_expr e) - | ContV e => interp_cont (interp_expr e) + | ContV K => interp_cont_val (interp_cont K) end with interp_expr {S} (e : expr S) : interp_scope S -n> IT := @@ -655,81 +681,62 @@ Section interp. | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) | Shift e => interp_shift (interp_expr e) | Reset e => λne env, (OfeMor interp_reset) (interp_expr e env) + end + with + interp_cont {S} (K : cont S) : interp_scope S -n> (IT -n> IT) := + 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) + | NatOpLK op v K => interp_natoplk op (interp_val v) (interp_cont K) + | NatOpRK op e K => interp_natoprk op (interp_expr e) (interp_cont K) end. - - Program Definition interp_apprk {A} (q : A -n> IT) : (A -n> IT) -n> A -n> IT := - λne t env, interp_app q t env. - Solve All Obligations with solve_proper. - - Program Definition interp_applk {A} (q : A -n> IT) : (A -n> IT) -n> A -n> IT := - λne t env, interp_app t q env. - Solve All Obligations with solve_proper. - - Program Definition interp_natoprk {A} (op : nat_op) (q : A -n> IT) : - (A -n> IT) -n> A -n> IT := - λne t env, interp_natop op q t env. - Solve All Obligations with solve_proper. - - Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) : - (A -n> IT) -n> A -n> IT := - λne t env, interp_natop op t q env. - Solve All Obligations with solve_proper. - - Program Definition interp_ifk {A} (e1 e2 : A -n> IT) : - (A -n> IT) -n> A -n> IT := - λne b env, interp_if b e1 e2 env. - Solve All Obligations with solve_proper. - - - Program Definition interp_resetk {A} : (A -n> IT) -n> A -n> IT := - λne t env, interp_reset (t env). - Solve All Obligations with solve_proper. - - Definition interp_ectx_el {S} (C : ectx_el S) : - (interp_scope S -n> IT) -n> (interp_scope S) -n> IT := - match C with - | AppRK e1 => interp_apprk (interp_expr e1) - | AppLK e2 => interp_applk (interp_expr e2) - | NatOpRK op e1 => interp_natoprk op (interp_expr e1) - | NatOpLK op e2 => interp_natoplk op (interp_expr e2) - | IfK e1 e2 => interp_ifk (interp_expr e1) (interp_expr e2) - | ResetK => interp_resetk - end. + (* Definition interp_ectx_el {S} (C : ectx_el S) : *) + (* (interp_scope S -n> IT) -n> (interp_scope S) -n> IT := *) + (* match C with *) + (* | AppRK e1 => interp_apprk (interp_expr e1) *) + (* | AppLK e2 => interp_applk (interp_expr e2) *) + (* | NatOpRK op e1 => interp_natoprk op (interp_expr e1) *) + (* | NatOpLK op e2 => interp_natoplk op (interp_expr e2) *) + (* | IfK e1 e2 => interp_ifk (interp_expr e1) (interp_expr e2) *) + (* | ResetK => interp_resetk *) + (* end. *) - Fixpoint interp_ectx' {S} (K : ectx S) : - interp_scope S -> IT -> IT := - match K with - | [] => λ env, idfun - | C :: K => λ (env : interp_scope S), λ (t : IT), - (interp_ectx' K env) (interp_ectx_el C (λne env, t) env) - end. - #[export] Instance interp_ectx_1_ne {S} (K : ectx S) (env : interp_scope S) : - NonExpansive (interp_ectx' K env : IT → IT). - Proof. induction K; solve_proper_please. Qed. + (* Fixpoint interp_ectx' {S} (K : ectx S) : *) + (* interp_scope S -> IT -> IT := *) + (* match K with *) + (* | [] => λ env, idfun *) + (* | C :: K => λ (env : interp_scope S), λ (t : IT), *) + (* (interp_ectx' K env) (interp_ectx_el C (λne env, t) env) *) + (* end. *) + (* #[export] Instance interp_ectx_1_ne {S} (K : ectx S) (env : interp_scope S) : *) + (* NonExpansive (interp_ectx' K env : IT → IT). *) + (* Proof. induction K; solve_proper_please. Qed. *) - Definition interp_ectx'' {S} (K : ectx S) (env : interp_scope S) : IT -n> IT := - OfeMor (interp_ectx' K env). + (* Definition interp_ectx'' {S} (K : ectx S) (env : interp_scope S) : IT -n> IT := *) + (* OfeMor (interp_ectx' K env). *) - Lemma interp_ectx''_cons {S} (env : interp_scope S) - (K : ectx S) (C : ectx_el S) (x : IT) (n : nat) : - interp_ectx'' (C :: K) env x ≡{n}≡ interp_ectx'' K env (interp_ectx_el C (λne _, x) env). - Proof. done. Qed. + (* Lemma interp_ectx''_cons {S} (env : interp_scope S) *) + (* (K : ectx S) (C : ectx_el S) (x : IT) (n : nat) : *) + (* interp_ectx'' (C :: K) env x ≡{n}≡ interp_ectx'' K env (interp_ectx_el C (λne _, x) env). *) + (* Proof. done. Qed. *) - #[export] Instance interp_ectx_2_ne {S} (K : ectx S) : - NonExpansive (interp_ectx'' K : interp_scope S → (IT -n> IT)). - Proof. - induction K; intros ????; try by intro. - intro. - rewrite !interp_ectx''_cons. - f_equiv. - - by apply IHK. - - by f_equiv. - Qed. + (* #[export] Instance interp_ectx_2_ne {S} (K : ectx S) : *) + (* NonExpansive (interp_ectx'' K : interp_scope S → (IT -n> IT)). *) + (* Proof. *) + (* induction K; intros ????; try by intro. *) + (* intro. *) + (* rewrite !interp_ectx''_cons. *) + (* f_equiv. *) + (* - by apply IHK. *) + (* - by f_equiv. *) + (* Qed. *) - Definition interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := - OfeMor (interp_ectx'' K). + (* Definition interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := *) + (* OfeMor (interp_ectx'' K). *) (* Eval cbv[test_ectx interp_ectx interp_ectx' interp_ectx_el *) (* interp_apprk interp_outputk interp_output interp_app] in (interp_ectx test_ectx). *) @@ -776,13 +783,16 @@ Section interp. interp_expr (fmap δ e) env ≡ interp_expr e (ren_scope δ env) with interp_val_ren {S S'} env (δ : S [→] S') (e : val S) : - interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env). - (* with interp_ectx_ren {S S'} env *) - (* (δ : S [→] S') (e : ectx S) : *) - (* interp_ectx (fmap δ e) env ≡ interp_ectx e (ren_scope δ env). *) + interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env) + with interp_cont_ren {S S'} env + (δ : S [→] S') (K : cont S) : + interp_cont (fmap δ K) env ≡ interp_cont K (ren_scope δ env). Proof. - destruct e; simpl; try by repeat f_equiv. - + repeat f_equiv. by repeat (intro; simpl; repeat 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. + unfold interp_reset. repeat f_equiv. by repeat (intro; simpl; repeat f_equiv). - destruct e; simpl. @@ -802,28 +812,25 @@ Section interp. destruct y' as [| [| y]]; simpl; first done; last done. by iRewrite - "IH". + repeat f_equiv. - intro. simpl. - rewrite interp_expr_ren. repeat f_equiv. - intros [|?]; eauto. + intro. simpl. repeat f_equiv. + apply interp_cont_ren. + - destruct K; simpl; repeat f_equiv; intro; simpl; repeat f_equiv; + (apply interp_expr_ren || apply interp_val_ren || apply interp_cont_ren). Qed. - Lemma interp_ectx_ren {S S'} env (δ : S [→] S') (K : ectx S) : - interp_ectx (fmap δ K) env ≡ interp_ectx K (ren_scope δ env). - Proof. - induction K; intros ?; simpl; eauto. - destruct a; simpl; try (etrans; first by apply IHK); repeat f_equiv; - try solve [by apply interp_expr_ren | by apply interp_val_ren]. - Qed. + (* Lemma interp_ectx_ren {S S'} env (δ : S [→] S') (K : ectx S) : *) + (* interp_ectx (fmap δ K) env ≡ interp_ectx K (ren_scope δ env). *) + (* Proof. *) + (* induction K; intros ?; simpl; eauto. *) + (* destruct a; simpl; try (etrans; first by apply IHK); repeat f_equiv; *) + (* try solve [by apply interp_expr_ren | by apply interp_val_ren]. *) + (* Qed. *) - Lemma interp_comp {S} (e : expr S) (env : interp_scope S) (K : ectx S): - interp_expr (fill K e) env ≡ (interp_ectx K) env ((interp_expr e) env). - Proof. - revert env e. - induction K; eauto. - destruct a; simpl; intros env e'; by eapply IHK. - 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. Qed. Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') : interp_scope S := λne x, interp_expr (δ x) env. @@ -846,13 +853,16 @@ Section interp. interp_expr (bind δ e) env ≡ interp_expr e (sub_scope δ env) with interp_val_subst {S S'} (env : interp_scope S') (δ : S [⇒] S') e : - interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env). - (* with interp_ectx_subst {S S'} (env : interp_scope S') *) - (* (δ : S [⇒] S') e : *) - (* interp_ectx (bind δ e) env ≡ interp_ectx e (sub_scope δ env). *) + interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env) + with interp_cont_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') K : + interp_cont (bind δ K) env ≡ interp_cont K (sub_scope δ env). Proof. - destruct e; simpl; try by repeat f_equiv. - + repeat f_equiv. by repeat (intro; simpl; 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. + unfold interp_reset; repeat f_equiv. by repeat (intro; simpl; repeat f_equiv). - destruct e; simpl. + reflexivity. @@ -875,28 +885,18 @@ Section interp. iApply internal_eq_pointwise. iIntros (z). done. - + repeat f_equiv. intro. simpl. - rewrite interp_expr_subst. repeat f_equiv. - intros [|?]; eauto. simpl. - rewrite interp_expr_ren. f_equiv. - by intro. - Qed. - - - Lemma interp_ectx_subst {S S'} (env : interp_scope S') (δ : S [⇒] S') K : - interp_ectx (bind δ K) env ≡ interp_ectx K (sub_scope δ env). - Proof. - induction K; simpl; intros ?; simpl; eauto. - destruct a; simpl; try (etrans; first by apply IHK); - repeat f_equiv; try solve [by eapply interp_expr_subst | by eapply interp_val_subst]. + + repeat f_equiv. intro. simpl. repeat f_equiv. + by rewrite interp_cont_subst. + - destruct K; simpl; repeat f_equiv; intro; simpl; repeat f_equiv; + (apply interp_expr_subst || apply interp_val_subst || apply interp_cont_subst). Qed. (** ** Interpretation is a homomorphism (for some constructors) *) - #[global] Instance interp_ectx_hom_emp {S} env : - IT_hom (interp_ectx ([] : ectx S) env). + #[global] Instance interp_cont_hom_emp {S} env : + IT_hom (interp_cont (END : cont S) env). Proof. simple refine (IT_HOM _ _ _ _ _); intros; auto. simpl. f_equiv. intro. simpl. @@ -904,27 +904,27 @@ Section interp. Qed. - #[global] Instance interp_ectx_hom_if {S} - (K : ectx S) (e1 e2 : expr S) env : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (IfK e1 e2 :: K) env). + #[global] Instance interp_cont_hom_if {S} + (K : cont S) (e1 e2 : expr S) env : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (IfK e1 e2 K) env). Proof. intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - by rewrite -hom_tick -IF_Tick. - trans (Vis op i (laterO_map (λne y, - (λne t : IT, interp_ectx' K env (IF t (interp_expr e1 env) (interp_expr e2 env))) + (λne t : IT, interp_cont K env (IF t (interp_expr e1 env) (interp_expr e2 env))) y) ◎ ko)); last (simpl; do 3 f_equiv; by intro). by rewrite -hom_vis. - - trans (interp_ectx' K env (Err e)); first (f_equiv; apply IF_Err). + - trans (interp_cont K env (Err e)); first (f_equiv; apply IF_Err). apply hom_err. Qed. - #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) + #[global] Instance interp_cont_hom_appr {S} (K : cont S) (e : expr S) env : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (AppRK e :: K) env). + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppRK e K) env). Proof. intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - by rewrite !hom_tick. @@ -933,27 +933,27 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) + #[global] Instance interp_cont_hom_appl {S} (K : cont S) (v : val S) (env : interp_scope S) : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (AppLK v :: K) env). + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppLK v 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_ectx' K env (t ⊙ (interp_val v env))) + (λ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_ectx' K env (Err e)); + - trans (interp_cont K env (Err e)); first (f_equiv; apply APP'_Err_l; apply interp_val_asval). apply hom_err. Qed. - #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) + #[global] Instance interp_cont_hom_natopr {S} (K : cont S) (e : expr S) op env : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (NatOpRK op e :: K) env). + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (NatOpRK op e K) env). Proof. intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - by rewrite !hom_tick. @@ -962,19 +962,19 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) + #[global] Instance interp_cont_hom_natopl {S} (K : cont S) (v : val S) op (env : interp_scope S) : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (NatOpLK op v :: K) env). + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (NatOpLK op v K) env). Proof. intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - rewrite -hom_tick. f_equiv. by rewrite -NATOP_ITV_Tick_l. - trans (Vis op0 i (laterO_map (λne y, - (λne t : IT, interp_ectx' K env (NATOP (do_natop op) t (interp_val v env))) y) ◎ ko)); + (λne t : IT, interp_cont K env (NATOP (do_natop op) t (interp_val v env))) y) ◎ ko)); last (simpl; do 3 f_equiv; by intro). rewrite NATOP_ITV_Vis_l hom_vis. f_equiv. intro. simpl. by rewrite -laterO_map_compose. - - trans (interp_ectx' K env (Err e)). + - trans (interp_cont K env (Err e)). + f_equiv. by apply NATOP_Err_l, interp_val_asval. + apply hom_err. Qed. @@ -995,18 +995,18 @@ Section interp. (* Unshelve. apply bi.siProp_internal_eq. *) (* Qed. *) - #[global] Instance interp_ectx_hom_reset {S} (K : ectx S) - (env : interp_scope S) : - IT_hom (interp_ectx K env) -> - IT_hom (interp_ectx (ResetK :: K) env). - Proof. - intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; unfold interp_reset. + (* #[global] Instance interp_ectx_hom_reset {S} (K : ectx S) *) + (* (env : interp_scope S) : *) + (* IT_hom (interp_ectx K env) -> *) + (* IT_hom (interp_ectx (ResetK :: K) env). *) + (* Proof. *) + (* intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; unfold interp_reset. *) - - rewrite -hom_tick. f_equiv. by rewrite get_val_tick. - - rewrite get_val_vis. rewrite hom_vis. f_equiv. - intro. simpl. rewrite -laterO_map_compose. done. - - by rewrite get_val_err hom_err. - Qed. + (* - rewrite -hom_tick. f_equiv. by rewrite get_val_tick. *) + (* - rewrite get_val_vis. rewrite hom_vis. f_equiv. *) + (* intro. simpl. rewrite -laterO_map_compose. done. *) + (* - by rewrite get_val_err hom_err. *) + (* Qed. *) Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). @@ -1016,12 +1016,11 @@ Section interp. Qed. - #[global] Instance interp_ectx_hom {S} - (K : ectx S) env : - IT_hom (interp_ectx K env). + #[global] Instance interp_cont_hom {S} + (K : cont S) env : + IT_hom (interp_cont K env). Proof. - induction K; simpl; first apply IT_hom_idfun. - destruct a; apply _. + induction K; simpl; apply _. Qed. (** ** Finally, preservation of reductions *) diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index ef1188f..062ccc7 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -705,7 +705,11 @@ Definition config_to_expr {S} (c : config S) := | Cret v => Val v end. (* i mean not really bcause missing [reset]s *) +(* is the solution just adding a reset between each metacontext? + maybe? but idk if we would want that *) +(* Definition meta_fill_reset {S} (mk : Mcont S) e := *) +(* fold_left (λ e k, Reset (fill k e)) mk e. *) (*** Type system *) @@ -732,17 +736,8 @@ Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := typed Γ e1 τ → typed Γ e2 τ → typed Γ (If e0 e1 e2) τ -(* | typed_Input : *) -(* typed Γ Input Tnat *) -(* | typed_Output e : *) -(* typed Γ e Tnat → *) -(* typed Γ (Output e) Tnat *) -(* | typed_Throw e1 e2 τ τ' : *) -(* typed Γ e1 τ -> *) -(* typed Γ e2 (Tcont τ) -> *) -(* typed Γ (Throw e1 e2) τ' *) -| typed_Shift e τ : - typed Γ e (Tarr (Tcont τ) τ) -> +| typed_Shift (e : expr (inc S)) τ : + typed (Γ ▹ Tcont τ) e τ -> typed Γ (Shift e) τ | typed_App_Cont (τ τ' : ty) e1 e2 : typed Γ e1 (Tcont τ) -> @@ -786,12 +781,12 @@ Global Instance OpNotationExpr {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSy __op e₁ op e₂ := NatOp op (__asSynExpr e₁) (__asSynExpr e₂) }. -Global Instance OpNotationLK {S : Set} : OpNotation (ectx S) (nat_op) (val S) (ectx S) := { - __op K op v := K ++ [NatOpLK op v] +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) (ectx S) (ectx S) := { - __op e op K := K ++ [NatOpRK op (__asSynExpr e)] +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 }. @@ -801,8 +796,8 @@ Global Instance IfNotationExpr {S : Set} {F G H : Set -> Type} `{AsSynExpr F, As }. Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynExpr G} : - IfNotation (ectx S) (F S) (G S) (ectx S) := { - __if K e₂ e₃ := K ++ [IfK (__asSynExpr e₂) (__asSynExpr e₃)] + IfNotation (cont S) (F S) (G S) (cont S) := { + __if K e₂ e₃ := cont_compose K (IfK (__asSynExpr e₂) (__asSynExpr e₃) END) }. @@ -812,8 +807,8 @@ Global Instance IfNotationK {S : Set} {F G : Set -> Type} `{AsSynExpr F, AsSynEx (* __output e := Output (__asSynExpr e) *) (* }. *) -(* Global Instance OutputNotationK {S : Set} : OutputNotation (ectx S) (ectx S) := { *) -(* __output K := K ++ [OutputK] *) +(* 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 }. @@ -821,8 +816,8 @@ 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 (ectx S) (ectx S) := - { __reset K := K ++ [ResetK] }. +(* 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 }. *) @@ -830,11 +825,11 @@ Global Instance ResetNotationK {S : Set} : ResetNotation (ectx S) (ectx S) := (* __throw e₁ e₂ := Throw (__asSynExpr e₁) (__asSynExpr e₂) *) (* }. *) -(* Global Instance ThrowNotationLK {S : Set} {F : Set -> Type} `{AsSynExpr F} : ThrowNotation (ectx S) (F S) (ectx S) := { *) +(* 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) (ectx S) (ectx S) := { *) +(* Global Instance ThrowNotationRK {S : Set} : ThrowNotation (val S) (cont S) (cont S) := { *) (* __throw v K := ThrowRK v K *) (* }. *) @@ -844,12 +839,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 (ectx S) (val S) (ectx S) := { - __app K v := K ++ [AppLK v] +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} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (ectx S) (ectx S) := { - __app e K := K ++ [AppRK (__asSynExpr e)] +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) }. Notation of_val := Val (only parsing). @@ -890,7 +885,7 @@ 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) +Notation "A 'Cont'" := (Tcont A%typ) (at level 60) : typ_scope. Declare Scope typing_scope. @@ -926,95 +921,95 @@ Module SynExamples. Example test8 : Prop := (empty_env ⊢ (# 0) : ℕ). End SynExamples. -Definition compute_head_step {S} - (e : expr S) (K : ectx S) : - option (expr S * ectx 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 *) +(* 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 test21 : val ∅ := (rec (if ($ 0) then # 1 else #0))%syn. *) -Example testc : option (expr (inc ∅) * ectx (inc ∅) * (nat * nat)) := - (compute_head_step (App (Val test1) (Val $ LitV 5)) []). -Eval compute in testc. +(* 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 : ectx 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. +(* 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. *) From a00e547f92cd34e4478f40a33739efd72889ee2a Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 14 Feb 2024 12:48:32 +0100 Subject: [PATCH 097/114] whitespace --- theories/input_lang_delim/interp.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 6d358f4..a218431 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -507,7 +507,7 @@ Section interp. #[export] Instance interp_reset_ne : NonExpansive (interp_reset). Proof. - intros n ???. rewrite /interp_reset. simpl. repeat f_equiv. + intros n ???. rewrite /interp_reset. simpl. repeat f_equiv. by do 2 (intro; simpl; repeat f_equiv). Qed. From c5465e1c5ebb9baa1dc60a4008fdbbef6323e3e2 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Wed, 14 Feb 2024 18:10:35 +0100 Subject: [PATCH 098/114] Reintroduce shift/reset as effects, some hope --- theories/input_lang_delim/interp.v | 653 +++++++++-------------------- theories/input_lang_delim/lang.v | 2 +- 2 files changed, 207 insertions(+), 448 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index a218431..f03427a 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -13,107 +13,96 @@ Require Import Binding.Set. (** * State *) -Definition stateF : oFunctor := (gmapOF unitO (▶ ∙))%OF. +(* Definition stateF : oFunctor := (gmapOF unitO (▶ ∙))%OF. *) + +(* #[local] Instance state_inhabited : Inhabited (stateF ♯ unitO). *) +(* Proof. apply _. Qed. *) +(* #[local] Instance state_cofe X `{!Cofe X} : Cofe (stateF ♯ X). *) +(* Proof. apply _. Qed. *) + +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 readE : opInterp := {| - Ins := unitO; - Outs := (▶ ∙); -|}. - -Program Definition writeE : opInterp := {| - Ins := (▶ ∙); - Outs := unitO; -|}. - -Program Definition callccE : opInterp := +Program Definition shiftE : opInterp := {| Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); Outs := (▶ ∙); |}. -Program Definition throwE : opInterp := + +Program Definition resetE : opInterp := {| - Ins := (▶ ∙ * (▶ ∙ -n> ▶ ∙)); - Outs := Empty_setO; + Ins := (▶ ∙); + Outs := (▶ ∙); |}. +(* to apply the head of the meta continuation *) +Program Definition metaE : opInterp := + {| + Ins := (▶ ∙); + Outs := (▶ ∙); + |}. -Definition delimE := @[readE; writeE; callccE; throwE]. +Definition delimE := @[shiftE; resetE; metaE]. -Notation op_read := (inl ()). -Notation op_write := (inr (inl ())). -Notation op_callcc := (inr (inr (inl ()))). -Notation op_throw := (inr (inr (inr (inl ())))). -Section reifiers. +Notation op_shift := (inl ()). +Notation op_reset := (inr (inl ())). +Notation op_meta := (inr (inr (inl ()))). - Context {X} `{!Cofe X}. - Notation state := (stateF ♯ X). - Definition reify_read : unit * state * (laterO X -n> laterO X) → - option (laterO X * state) - := λ '(u,σ,κ), x ← σ !! u; - Some (κ x, σ). - #[export] Instance reify_read_ne : - NonExpansive (reify_read : prodO (prodO unitO state) - (laterO X -n> laterO X) → - optionO (prodO (laterO X) state)). - Proof. - intros n[[]][[]][[]]. simpl in *. - apply option_mbind_ne; first solve_proper. - by rewrite H0. - Qed. +Section reifiers. - Definition reify_write : (laterO X) * state * (unitO -n> laterO X) → - option (laterO X * state) - := λ '(n,s,κ), let s' := <[():=n]>s - in Some (κ (), s'). - #[export] Instance reify_write_ne : - NonExpansive (reify_write : prodO (prodO _ state) - (unitO -n> laterO X) → - optionO (prodO (laterO X) state)). - Proof. - intros n [[]] [[]] [[]]; simpl in *. solve_proper. - Qed. + Context {X} `{!Cofe X}. + Notation state := (stateF ♯ X). - Definition reify_callcc : ((laterO X -n> laterO X) -n> laterO 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 ((k (f k): laterO X), σ : state). - #[export] Instance reify_callcc_ne : - NonExpansive (reify_callcc : + λ '(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_meta : (laterO X) * state * (laterO X -n> laterO X) → + option (laterO X * state) := + λ '(e, σ, k), + match σ with + | [] => Some (e, σ) + | k' :: σ' => Some (k' e, σ') + end. + #[export] Instance reify_meta_ne : + NonExpansive (reify_meta : + 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_throw : - ((laterO X * (laterO X -n> laterO X)) * state * (Empty_setO -n> laterO X)) → - option (laterO X * state) := - λ '((e, k'), σ, _), - Some ((k' e : laterO X), σ : state). - #[export] Instance reify_throw_ne : - NonExpansive (reify_throw : - prodO (prodO (prodO (laterO X) (laterO X -n> laterO X)) state) - (Empty_setO -n> laterO X) → - optionO (prodO (laterO X) (state))). - Proof. - intros ?[[[]]][[[]]]?. rewrite /reify_throw. - repeat f_equiv; apply H. - Qed. End reifiers. @@ -124,11 +113,10 @@ Proof. sReifier_state := stateF |}. intros X HX op. - destruct op as [ | [ | [ | [| []]]]]; simpl. - - simple refine (OfeMor (reify_read)). - - simple refine (OfeMor (reify_write)). - - simple refine (OfeMor (reify_callcc)). - - simple refine (OfeMor (reify_throw)). + destruct op as [ | [ | [ | []]]]; simpl. + - simple refine (OfeMor (reify_shift)). + - simple refine (OfeMor (reify_reset)). + - simple refine (OfeMor (reify_meta)). Defined. @@ -142,56 +130,46 @@ Section constructors. Notation ITV := (ITV E A). - Program Definition READ : IT := - Vis (E:=E) (subEff_opid $ op_read) - (subEff_ins (F:=delimE) (op:=op_read) ()) - ((subEff_outs (F:=delimE) (op:=op_read))^-1). - Program Definition WRITE : IT -n> IT := - λne a, Vis (E:=E) (subEff_opid $ op_write) - (subEff_ins (F:=delimE) (op:=op_write) (Next a)) - (λne _, Next (Ret ())). - Solve Obligations with solve_proper. - - - Program Definition CALLCC_ : ((laterO IT -n> laterO IT) -n> laterO IT) -n> + 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_callcc) - (subEff_ins (F:=delimE) (op:=op_callcc) f) - (k ◎ (subEff_outs (F:=delimE) (op:=op_callcc))^-1). + λne f k, Vis (E:=E) (subEff_opid op_shift) + (subEff_ins (F:=delimE) (op:=op_shift) f) + (k ◎ (subEff_outs (F:=delimE) (op:=op_shift))^-1). Solve All Obligations with solve_proper. - Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := - λne f, CALLCC_ f (idfun). + 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_CALLCC_ k e f `{!IT_hom f} : - f (CALLCC_ e k) ≡ CALLCC_ e (laterO_map (OfeMor f) ◎ k). + Lemma hom_SHIFT_ k e f `{!IT_hom f} : + f (SHIFT_ e k) ≡ SHIFT_ e (laterO_map (OfeMor f) ◎ k). Proof. - unfold CALLCC_. + unfold SHIFT_. rewrite hom_vis/=. f_equiv. by intro. Qed. - Program Definition THROW : IT -n> (laterO IT -n> laterO IT) -n> IT := - λne e k, Vis (E:=E) (subEff_opid op_throw) - (subEff_ins (F:=delimE) (op:=op_throw) - (NextO e, k)) - (λne x, Empty_setO_rec _ ((subEff_outs (F:=delimE) (op:=op_throw))^-1 x)). - Next Obligation. - solve_proper_prepare. - destruct ((subEff_outs ^-1) x). - Qed. - Next Obligation. - intros; intros ???; simpl. - repeat f_equiv. assumption. - Qed. - Next Obligation. - intros ?????; simpl. - repeat f_equiv; assumption. - Qed. + + Program Definition META : IT -n> IT := + λne e, Vis (E:=E) (subEff_opid op_meta) + (subEff_ins (F:=delimE) (op:=op_meta) (Next e)) + ((subEff_outs (F:=delimE) (op:=op_meta))^-1). + Solve All Obligations with solve_proper. + + 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 (get_val META) e)) + (k ◎ subEff_outs (F := delimE) (op := op_reset)^-1). + Solve Obligations with solve_proper. + + Program Definition RESET : laterO IT -n> IT := + RESET_ idfun. + End constructors. @@ -207,262 +185,82 @@ Section weakestpre. Notation IT := (IT F R). Notation ITV := (ITV F R). Notation state := (stateF ♯ IT). - - - (* a separate ghost state for keeping track of locations *) - Definition istate := gmap_viewUR unit (laterO IT). - Class heapPreG Σ := HeapPreG { heapPreG_inG :: inG Σ istate }. - Class heapG Σ := HeapG { - heapG_inG :: inG Σ istate; - heapG_name : gname; - }. - Definition heapΣ : gFunctors := GFunctor istate. - #[export] Instance subG_heapΣ {Σ} : subG heapΣ Σ → heapPreG Σ. - Proof. solve_inG. Qed. - - Lemma new_heapG σ `{!heapPreG Σ} : - (⊢ |==> ∃ `{!heapG Σ}, own heapG_name (●V σ): iProp Σ)%I. - Proof. - iMod (own_alloc (●V σ)) as (γ) "H". - { apply gmap_view_auth_valid. } - pose (sg := {| heapG_inG := _; heapG_name := γ |}). - iModIntro. iExists sg. by iFrame. - Qed. - - Context `{!invGS_gen HasLc Σ, !stateG rs R Σ}. + Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - (** * The ghost state theory for the heap *) - - Context `{!heapG Σ}. - - Definition heap_ctx := inv (nroot.@"storeE") - (∃ σ, £ 1 ∗ has_substate σ ∗ own heapG_name (●V σ))%I. - - Definition pointsto (u : unit) (α : IT) : iProp := - own heapG_name $ gmap_view_frag u (DfracOwn 1) (Next α). - - - - Lemma istate_alloc α u σ : - σ !! u = None → - own heapG_name (●V σ) ==∗ own heapG_name (●V (<[u:=(Next α)]>σ)) - ∗ pointsto u α. - Proof. - iIntros (Hl) "H". - iMod (own_update with "H") as "[$ $]". - { apply (gmap_view_alloc _ u (DfracOwn 1) (Next α)); eauto. - done. } - done. - Qed. - Lemma istate_read u α σ : - own heapG_name (●V σ) -∗ pointsto u α -∗ σ !! u ≡ Some (Next α). - Proof. - iIntros "Ha Hf". - iPoseProof (own_valid_2 with "Ha Hf") as "H". - rewrite gmap_view_both_validI. - iDestruct "H" as "[_ Hval]". done. - Qed. - Lemma istate_loc_dom u α σ : - own heapG_name (●V σ) -∗ pointsto u α -∗ ⌜is_Some (σ !! u)⌝. - Proof. - iIntros "Hinv Hloc". - iPoseProof (istate_read with "Hinv Hloc") as "Hl". - destruct (σ !! u) ; eauto. - by rewrite option_equivI. - Qed. - Lemma istate_write u α β σ : - own heapG_name (●V σ) -∗ pointsto u α ==∗ own heapG_name (●V <[u:=(Next β)]>σ) - ∗ pointsto u β. - Proof. - iIntros "H Hu". - iMod (own_update_2 with "H Hu") as "[$ $]". - { apply (gmap_view_update). } - done. - Qed. - Lemma istate_delete u α σ : - own heapG_name (●V σ) -∗ pointsto u α ==∗ own heapG_name (●V delete u σ). - Proof. - iIntros "H Hu". - iMod (own_update_2 with "H Hu") as "$". - { apply (gmap_view_delete). } - done. - Qed. - - (** * The symbolic execution rules *) - (** ** READ *) - - Lemma wp_read_atomic (l : unit) E1 E2 s Φ - (k : IT -n> IT) `{!IT_hom k} : - nclose (nroot.@"storeE") ## E1 → - heap_ctx -∗ - (|={E1,E2}=> ∃ α, ▷ pointsto l α ∗ - ▷ ▷ (pointsto l α ={E2,E1}=∗ WP@{rs} k α @ s {{ Φ }})) -∗ - WP@{rs} k READ @ s {{ Φ }}. - Proof. - iIntros (Hee) "#Hcxt H". rewrite hom_vis. simpl. - match goal with - | |- context G [Vis ?a ?b ?c] => assert (c ≡ laterO_map k ◎ subEff_outs (op:=op_read) ^-1) as -> - end; first solve_proper. - iApply wp_subreify'. - iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". - iApply (fupd_mask_weaken E1). - { set_solver. } - iIntros "Hwk". - iMod "H" as (α) "[Hp Hback]". - iApply (lc_fupd_elim_later with "Hlc"). - iNext. - iAssert (⌜is_Some (σ !! l)⌝)%I as "%Hdom". - { iApply (istate_loc_dom with "Hh Hp"). } - destruct Hdom as [x Hx]. - destruct (Next_uninj x) as [β' Hb']. - iAssert ((σ !! l ≡ Some (Next α)))%I as "#Hlookup". - { iApply (istate_read with "Hh Hp"). } - iAssert (▷ (β' ≡ α))%I as "#Hba". - { rewrite Hx. rewrite option_equivI. - rewrite Hb'. by iNext. } - iClear "Hlookup". - iExists σ,(Next $ k β'),σ,(k β'). - iFrame "Hs". - repeat iSplit. - - assert ((option_bind _ _ (λ x, Some (laterO_map k x, σ)) (σ !! l)) ≡ - (option_bind _ _ (λ x, Some (x, σ)) (Some (Next $ k β')))) as H. - { rewrite Hx. simpl. rewrite Hb'. by rewrite later_map_Next. } - simpl in H. - rewrite <-H. - unfold mbind. - simpl. - iPureIntro. - f_equiv; last done. - intros ???. - do 2 f_equiv. rewrite H0. - by rewrite ofe_iso_21. - - done. - - iNext. iIntros "Hlc Hs". - iMod ("Hback" with "Hp") as "Hback". - iMod "Hwk" . - iMod ("Hcl" with "[Hlc Hh Hs]") as "_". - { iExists _. by iFrame. } - iRewrite "Hba". done. - Qed. - - Lemma wp_read (l : unit) (α : IT) s Φ - (k : IT -n> IT) `{!IT_hom k} : - heap_ctx -∗ - ▷ pointsto l α -∗ - ▷ ▷ (pointsto l α -∗ WP@{rs} k α @ s {{ Φ }}) -∗ - WP@{rs} k READ @ s {{ Φ }}. - Proof. - iIntros "#Hcxt Hp Ha". - iApply (wp_read_atomic _ (⊤∖ nclose (nroot.@"storeE")) with "[$]"). - { set_solver. } - iModIntro. iExists _; iFrame. - iNext. iNext. iIntros "Hl". - iModIntro. by iApply "Ha". - Qed. - (** ** WRITE *) - - Lemma wp_write_atomic E1 E2 β s Φ - (k : IT -n> IT) `{!IT_hom k} : - nclose (nroot.@"storeE") ## E1 → - heap_ctx -∗ - (|={E1,E2}=> ∃ α, ▷ pointsto () α ∗ - ▷ ▷ (pointsto () β ={E2,E1}=∗ WP@{rs} k (Ret ()) @ s {{ Φ }})) -∗ - WP@{rs} k (WRITE β) @ s {{ Φ }}. - Proof. - iIntros (Hee) "#Hcxt H". rewrite hom_vis. simpl. - iApply wp_subreify'. - iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". - iApply (fupd_mask_weaken E1). - { set_solver. } - iIntros "Hwk". - iMod "H" as (α) "[Hp Hback]". - iAssert (▷ ⌜is_Some (σ !! tt)⌝)%I as "#Hdom". - { iNext. iApply (istate_loc_dom with "Hh Hp"). } - iDestruct "Hdom" as ">%Hdom". - destruct Hdom as [x Hx]. - destruct (Next_uninj x) as [α' Ha']. - iApply (lc_fupd_elim_later with "Hlc"). - iNext. - iExists σ, (Next $ k (Ret ())), (<[():=Next β]>σ), (k $ Ret ()). - iFrame "Hs". - iSimpl. repeat iSplit; [ by rewrite later_map_Next | done | ]. - iNext. iIntros "Hlc". - iMod (istate_write _ _ β with "Hh Hp") as "[Hh Hp]". - iIntros "Hs". - iMod ("Hback" with "Hp") as "Hback". - iMod "Hwk" . - iMod ("Hcl" with "[Hlc Hh Hs]") as "_". - { iExists _. iFrame. } - done. - Qed. + (** ** SHIFT *) - Lemma wp_write (α β : IT) s Φ (k : IT -n> IT) `{!IT_hom k} : - heap_ctx -∗ - ▷ pointsto () α -∗ - ▷▷ (pointsto () β -∗ WP@{rs} k (Ret ()) @ s {{ Φ }}) -∗ - WP@{rs} k $ WRITE β @ s {{ Φ }}. + Lemma wp_shift (σ : state) (f : (laterO IT -n> laterO IT) -n> laterO IT) + (k : IT -n> IT) {Hk : IT_hom k} Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} idfun (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ + WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. Proof. - iIntros "#Hctx Hp Ha". - iApply (wp_write_atomic (⊤∖ nclose (nroot.@"storeE")) with "[$]"). - { set_solver. } - iModIntro. iExists _; iFrame. - iNext. iNext. iIntros "Hl". - iModIntro. by iApply "Ha". + iIntros "Hs Ha". + unfold SHIFT. simpl. + rewrite hom_vis. + iApply (wp_subreify _ _ _ _ _ _ _ (later_map idfun $ f (laterO_map k)) with "Hs"). + { + simpl. + repeat f_equiv. + - rewrite ccompose_id_l later_map_id. + f_equiv. intro. simpl. by rewrite ofe_iso_21. + - reflexivity. + } + { by rewrite later_map_Next. } + iModIntro. + iApply "Ha". Qed. - (** ** THROW *) - Lemma wp_throw' (σ : state) (f : laterO IT -n> laterO IT) (x : IT) - (κ : IT -n> IT) `{!IT_hom κ} Φ s : + Lemma wp_reset (σ : state) (e : laterO IT) (k : IT -n> IT) {Hk : IT_hom k} + Φ s : has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car $ f (Next x) @ s {{ Φ }}) -∗ - WP@{rs} κ (THROW x f) @ s {{ Φ }}. + ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ + WP@{rs} get_val META (later_car e) @ s {{ Φ }}) -∗ + WP@{rs} k $ (RESET e) @ s {{ Φ }}. Proof. - iIntros "Hs Ha". rewrite /THROW. simpl. - rewrite hom_vis. - destruct (Next_uninj (f (Next x))) as [α Hα]. - iApply (wp_subreify with "Hs"); simpl. - + reflexivity. - + apply Hα. - + by assert (α ≡ later_car (f (Next x))) as -> by done. + iIntros "Hs Ha". + unfold RESET. simpl. rewrite hom_vis. + iApply (wp_subreify _ _ _ _ _ _ _ (laterO_map (get_val META) 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_throw (σ : state) (f : laterO IT -n> laterO IT) (x : IT) Φ s : - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car $ f $ Next x @ s {{ Φ }}) -∗ - WP@{rs} (THROW x f) @ s {{ Φ }}. + + Lemma wp_meta_end (v : ITV) (k : IT -n> IT) {Hk : IT_hom k} + Φ s : + has_substate [] -∗ + ▷ (£ 1 -∗ has_substate [] -∗ WP@{rs} IT_of_V v @ s {{ Φ }}) -∗ + WP@{rs} k $ get_val META (IT_of_V v) @ s {{ Φ }}. Proof. - iApply (wp_throw' _ _ _ idfun). + iIntros "Hs Ha". + rewrite get_val_ITV. simpl. rewrite hom_vis. + iApply (wp_subreify _ _ _ _ _ _ _ ((Next $ IT_of_V v)) with "Hs"). + - simpl. reflexivity. + - reflexivity. + - done. Qed. - (** ** CALL/CC *) - - Lemma wp_callcc (σ : state) (f : (laterO IT -n> laterO IT) -n> laterO IT) - (k : IT -n> IT) {Hk : IT_hom k} Φ s : - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ - WP@{rs} (k (CALLCC f)) @ s {{ Φ }}. + Lemma wp_meta_cons (σ : state) (v : ITV) (k : IT -n> IT) {Hk : IT_hom k} + Φ s : + has_substate ((laterO_map k) :: σ) -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k $ IT_of_V v @ s {{ Φ }}) -∗ + WP@{rs} k $ get_val META (IT_of_V v) @ s {{ Φ }}. Proof. iIntros "Hs Ha". - unfold CALLCC. simpl. - rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ ((later_map k ((f (laterO_map k))))) with "Hs"). - { - simpl. - repeat f_equiv. - - rewrite ofe_iso_21. - f_equiv. intro x. simpl. - by rewrite ofe_iso_21. - - reflexivity. - } - { by rewrite later_map_Next. } - iModIntro. - iApply "Ha". + rewrite get_val_ITV. simpl. rewrite hom_vis. + iApply (wp_subreify _ _ _ _ _ _ _ ((laterO_map k (Next $ IT_of_V v))) with "Hs"). + - simpl. reflexivity. + - reflexivity. + - done. Qed. End weakestpre. @@ -490,44 +288,32 @@ Section interp. (** * Interpreting individual operators *) (** ** RESET *) - Program Definition interp_reset (e : IT) : IT := - CALLCC (λne (k : laterO IT -n> laterO IT), - Next $ - LET READ (λne m, SEQ - (WRITE (λit r, SEQ (WRITE m) (THROW r k))) - (APP' READ e))). - Solve Obligations with solve_proper. - Next Obligation. - intros e k n ???. repeat f_equiv. intro. simpl. solve_proper. - Qed. - Next Obligation. - intros e n ???. repeat f_equiv. by do 2 (intro; simpl; repeat f_equiv). - Qed. - #[export] Instance interp_reset_ne : - NonExpansive (interp_reset). - Proof. - intros n ???. rewrite /interp_reset. simpl. repeat f_equiv. - by do 2 (intro; simpl; repeat f_equiv). - Qed. + Program Definition interp_reset {S} (e : S -n> IT) : S -n> IT := + λne env, RESET (Next $ e env). + Solve All Obligations with solve_proper. (** ** SHIFT *) - Program Definition interp_shift {S} - (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := - λne env, CALLCC (λne (k : laterO IT -n> laterO IT), - Next (APP' - READ - (e (@extend_scope F R _ _ env - (λit x, interp_reset (THROW x k)))))). - Next Obligation. - intros S e env k n ???. by repeat f_equiv. - Qed. + + Program Definition interp_shift {S} (e : @interp_scope F R _ (inc S) -n> IT) : + interp_scope S -n> IT := + λne env, SHIFT (λne (k : laterO IT -n> laterO IT), + Next (e (@extend_scope F R _ _ env (λit x, Tau (k (Next x)))))). + Next Obligation. solve_proper. Qed. Next Obligation. - intros S e env n ???. repeat f_equiv. intro. simpl. by repeat f_equiv. + solve_proper_prepare. + repeat f_equiv. + intros [| a]; simpl; last solve_proper. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. Qed. Next Obligation. - intros S e n ???. f_equiv. intro; simpl; repeat f_equiv. - intros [|a]; simpl; last solve_proper. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros [| a]; simpl; last solve_proper. repeat f_equiv. Qed. @@ -635,9 +421,9 @@ Section interp. (* intros [|z]; eauto. *) (* Qed. *) - #[local] Instance interp_reset_full_ne {S} (f : @interp_scope F R _ S -n> IT): - NonExpansive (λ env, interp_reset (f env)). - Proof. solve_proper. Qed. + (* #[local] Instance interp_reset_full_ne {S} (f : @interp_scope F R _ S -n> IT): *) + (* NonExpansive (λ env, interp_reset (f env)). *) + (* Proof. solve_proper. Qed. *) Program Definition interp_ifk {A} (e1 e2 : A -n> IT) (K : A -n> IT -n> IT) : A -n> (IT -n> IT) := @@ -680,7 +466,7 @@ Section interp. | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) | Shift e => interp_shift (interp_expr e) - | Reset e => λne env, (OfeMor interp_reset) (interp_expr e env) + | Reset e => interp_reset (interp_expr e) end with interp_cont {S} (K : cont S) : interp_scope S -n> (IT -n> IT) := @@ -693,65 +479,39 @@ Section interp. | NatOpRK op e K => interp_natoprk op (interp_expr e) (interp_cont K) end. - (* Definition interp_ectx_el {S} (C : ectx_el S) : *) - (* (interp_scope S -n> IT) -n> (interp_scope S) -n> IT := *) - (* match C with *) - (* | AppRK e1 => interp_apprk (interp_expr e1) *) - (* | AppLK e2 => interp_applk (interp_expr e2) *) - (* | NatOpRK op e1 => interp_natoprk op (interp_expr e1) *) - (* | NatOpLK op e2 => interp_natoplk op (interp_expr e2) *) - (* | IfK e1 e2 => interp_ifk (interp_expr e1) (interp_expr e2) *) - (* | ResetK => interp_resetk *) - (* end. *) - - - (* Fixpoint interp_ectx' {S} (K : ectx S) : *) - (* interp_scope S -> IT -> IT := *) - (* match K with *) - (* | [] => λ env, idfun *) - (* | C :: K => λ (env : interp_scope S), λ (t : IT), *) - (* (interp_ectx' K env) (interp_ectx_el C (λne env, t) env) *) - (* end. *) - (* #[export] Instance interp_ectx_1_ne {S} (K : ectx S) (env : interp_scope S) : *) - (* NonExpansive (interp_ectx' K env : IT → IT). *) - (* Proof. induction K; solve_proper_please. Qed. *) - - (* Definition interp_ectx'' {S} (K : ectx S) (env : interp_scope S) : IT -n> IT := *) - (* OfeMor (interp_ectx' K env). *) - - (* Lemma interp_ectx''_cons {S} (env : interp_scope S) *) - (* (K : ectx S) (C : ectx_el S) (x : IT) (n : nat) : *) - (* interp_ectx'' (C :: K) env x ≡{n}≡ interp_ectx'' K env (interp_ectx_el C (λne _, x) env). *) - (* Proof. done. Qed. *) - - (* #[export] Instance interp_ectx_2_ne {S} (K : ectx S) : *) - (* NonExpansive (interp_ectx'' K : interp_scope S → (IT -n> IT)). *) - (* Proof. *) - (* induction K; intros ????; try by intro. *) - (* intro. *) - (* rewrite !interp_ectx''_cons. *) - (* f_equiv. *) - (* - by apply IHK. *) - (* - by f_equiv. *) - (* Qed. *) + (** ** Interpretation of configurations *) + + Program Definition interp_config {S} (C : config S) : @interp_scope F R _ S -n> (prodO IT state) := + match C with + | Cexpr e => λne env, (get_val META (interp_expr e env), []) : prodO IT state + | Ceval e K mk => λne env, (get_val META (interp_cont K env (interp_expr e env)), + list_fmap _ _ (λ k, laterO_map (interp_cont k env)) mk) + | Ccont K v mk => λne env, (get_val META (interp_cont K env (interp_val v env)), + list_fmap _ _ (λ k, laterO_map (interp_cont k env)) mk) + | Cmcont mk v => λne env, (get_val META (interp_val v env), + list_fmap _ _ (λ k, laterO_map (interp_cont k env)) mk) + | Cret v => λne env, (get_val META (interp_val v env), []) + end. + Solve Obligations with try solve_proper. + Next Obligation. + intros S C e K mk <- n???. f_equiv. + - by repeat f_equiv. + - apply list_fmap_ext_ne. intro. by repeat f_equiv. + Qed. + Next Obligation. + intros S C v K mk <- n???. f_equiv. + - by repeat f_equiv. + - apply list_fmap_ext_ne. intro. by repeat f_equiv. + Qed. + Next Obligation. + intros S C v mk <- n???. f_equiv. + - by repeat f_equiv. + - apply list_fmap_ext_ne. intro. by repeat f_equiv. + Qed. - (* Definition interp_ectx {S} (K : ectx S) : interp_scope S -n> (IT -n> IT) := *) - (* OfeMor (interp_ectx'' K). *) - (* Eval cbv[test_ectx interp_ectx interp_ectx' interp_ectx_el *) - (* interp_apprk interp_outputk interp_output interp_app] in (interp_ectx test_ectx). *) - (* Definition interp_ectx {S} (K : ectx S) : interp_scope S -n> IT -n> IT := *) - (* λne env e, *) - (* (fold_left (λ k c, λne (e : interp_scope S -n> IT), *) - (* (interp_ectx_el c env) (λne env, k e)) K (λne t : , t)) e. *) - (* Open Scope syn_scope. *) - (* Example callcc_ex : expr ∅ := *) - (* NatOp + (# 1) (Callcc (NatOp + (# 1) (Throw (# 2) ($ 0)))). *) - (* Eval cbn in callcc_ex. *) - (* Eval cbn in interp_expr callcc_ex *) - (* (λne (x : leibnizO ∅), match x with end). *) Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) : AsVal (interp_val v D). @@ -793,8 +553,6 @@ Section interp. rewrite interp_expr_ren. f_equiv. intros [|a]; simpl; last done. by repeat f_equiv. - + unfold interp_reset. repeat f_equiv. - by repeat (intro; simpl; repeat f_equiv). - destruct e; simpl. + reflexivity. + clear -interp_expr_ren. @@ -863,7 +621,6 @@ Section interp. rewrite interp_expr_subst. f_equiv. intros [|a]; simpl; repeat f_equiv. rewrite interp_expr_ren. f_equiv. intro. done. - + unfold interp_reset; repeat f_equiv. by repeat (intro; simpl; repeat f_equiv). - destruct e; simpl. + reflexivity. + clear -interp_expr_subst. @@ -1023,18 +780,21 @@ Section interp. induction K; simpl; apply _. Qed. + (** ** Finally, preservation of reductions *) - Lemma interp_expr_head_step {S : Set} (env : interp_scope S) (e : expr S) e' K K' Ko n : - head_step e K e' K' Ko (n, 0) → - interp_expr e env ≡ Tick_n n $ interp_expr e' env. + Lemma interp_cred {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) n : + C ===> C' / (n, 0) -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> + t ≡ Tick_n n $ t'. Proof. - inversion 1; cbn-[IF APP' Tick get_ret2]. - - (* app lemma *) - subst. + inversion 1; cbn-[IF APP' Tick get_ret2]; intros Ht Ht'; inversion Ht; inversion Ht'; try done. + - rewrite -hom_tick. f_equiv. erewrite APP_APP'_ITV; last apply _. - trans (APP (Fun (Next (ir_unf (interp_expr e1) env))) (Next $ interp_val v2 env)). + 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 Tick_eq. do 2 f_equiv. + rewrite APP_Fun. simpl. rewrite hom_tick. do 2 f_equiv. simplify_eq. rewrite !interp_expr_subst. f_equiv. @@ -1042,8 +802,7 @@ Section interp. rewrite interp_val_ren. f_equiv. intros ?; simpl; reflexivity. - - (* continuations *) - subst. + - rewrite -!hom_tick. erewrite APP_APP'_ITV; last apply _. rewrite APP_Fun. simpl. rewrite -Tick_eq. do 2 f_equiv. rewrite interp_expr_subst. diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 062ccc7..425fdab 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -680,7 +680,7 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := (* meta-cont *) | Cmcont_cont : forall k mk v, - Cmcont (k :: mk) v ===> Ccont k v mk / (0,0) + Cmcont (k :: mk) v ===> Ccont k v mk / (0,1) | Cmcont_ret : forall v, Cmcont [] v ===> Cret v / (0, 0) From 59f6a2ac2b38d9577d51d21140763bec7349eed6 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 15 Feb 2024 14:01:20 +0100 Subject: [PATCH 099/114] some notations, refactoring, and soundness for no reifying and reset --- theories/input_lang_delim/interp.v | 167 ++++++++++------------------- theories/input_lang_delim/lang.v | 49 ++++++++- 2 files changed, 106 insertions(+), 110 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index f03427a..5d1e085 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -481,38 +481,37 @@ Section interp. (** ** Interpretation of configurations *) + Program Definition map_meta_cont {S} (mk : Mcont S) : @interp_scope F R _ S -n> state := + λne env, list_fmap _ _ (λ k, laterO_map (get_val (META) ◎ (interp_cont k env))) mk. + Next Obligation. intros S mk n ???. apply list_fmap_ext_ne. intro. by repeat f_equiv. Qed. + + Lemma map_meta_cont_cons {S} (k : cont S) (mk : Mcont S) env : + map_meta_cont (k::mk) env = (laterO_map ((get_val META) ◎ interp_cont k env)) :: (map_meta_cont mk env). + Proof. done. Qed. + Program Definition interp_config {S} (C : config S) : @interp_scope F R _ S -n> (prodO IT state) := match C with | Cexpr e => λne env, (get_val META (interp_expr e env), []) : prodO IT state | Ceval e K mk => λne env, (get_val META (interp_cont K env (interp_expr e env)), - list_fmap _ _ (λ k, laterO_map (interp_cont k env)) mk) + map_meta_cont mk env) | Ccont K v mk => λne env, (get_val META (interp_cont K env (interp_val v env)), - list_fmap _ _ (λ k, laterO_map (interp_cont k env)) mk) + map_meta_cont mk env) | Cmcont mk v => λne env, (get_val META (interp_val v env), - list_fmap _ _ (λ k, laterO_map (interp_cont k env)) mk) + map_meta_cont mk env) | Cret v => λne env, (get_val META (interp_val v env), []) end. Solve Obligations with try solve_proper. Next Obligation. - intros S C e K mk <- n???. f_equiv. - - by repeat f_equiv. - - apply list_fmap_ext_ne. intro. by repeat f_equiv. + intros S C e K mk <- n???. by repeat f_equiv. Qed. Next Obligation. - intros S C v K mk <- n???. f_equiv. - - by repeat f_equiv. - - apply list_fmap_ext_ne. intro. by repeat f_equiv. + intros S C v K mk <- n???. by repeat f_equiv. Qed. Next Obligation. - intros S C v mk <- n???. f_equiv. - - by repeat f_equiv. - - apply list_fmap_ext_ne. intro. by repeat f_equiv. + intros S C v mk <- n???. by repeat f_equiv. Qed. - - - Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) : AsVal (interp_val v D). Proof. @@ -736,35 +735,6 @@ Section interp. + apply hom_err. Qed. - (* ResetK is not a homomorphism *) - (* Lemma interp_ectx_reset_not_hom {S} env : *) - (* IT_hom (interp_ectx ([ResetK] : ectx S) env) -> False. *) - (* Proof. *) - (* intros [ _ Hi _ _ ]. simpl in Hi. *) - (* specialize (Hi (Ret 0)). *) - (* unfold interp_reset, CALLCC, CALLCC_ in Hi. *) - (* simpl in Hi. *) - (* apply bi.siProp.pure_soundness. *) - (* iApply IT_tick_vis_ne. *) - (* iPureIntro. *) - (* symmetry. *) - (* eapply Hi. *) - (* Unshelve. apply bi.siProp_internal_eq. *) - (* Qed. *) - - (* #[global] Instance interp_ectx_hom_reset {S} (K : ectx S) *) - (* (env : interp_scope S) : *) - (* IT_hom (interp_ectx K env) -> *) - (* IT_hom (interp_ectx (ResetK :: K) env). *) - (* Proof. *) - (* intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl; unfold interp_reset. *) - - (* - rewrite -hom_tick. f_equiv. by rewrite get_val_tick. *) - (* - rewrite get_val_vis. rewrite hom_vis. f_equiv. *) - (* intro. simpl. rewrite -laterO_map_compose. done. *) - (* - by rewrite get_val_err hom_err. *) - (* Qed. *) - Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). Proof. @@ -782,7 +752,7 @@ Section interp. (** ** Finally, preservation of reductions *) - Lemma interp_cred {S : Set} (env : interp_scope S) (C C' : config S) + Lemma interp_cred_no_reify {S : Set} (env : interp_scope S) (C C' : config S) (t t' : IT) (σ σ' : state) n : C ===> C' / (n, 0) -> (interp_config C env) = (t, σ) -> @@ -804,80 +774,59 @@ Section interp. intros ?; simpl; reflexivity. - rewrite -!hom_tick. erewrite APP_APP'_ITV; last apply _. - rewrite APP_Fun. simpl. rewrite -Tick_eq. do 2 f_equiv. - rewrite interp_expr_subst. - f_equiv. - intros [|?]; eauto. - - (* the natop stuff *) - simplify_eq. - destruct v1,v2; try naive_solver. simpl in *. + rewrite APP_Fun. simpl. + f_equiv. rewrite -Tick_eq !hom_tick. + do 2 f_equiv. simpl. + replace (interp_val v env) with (interp_expr (Val v) env) by done. + by rewrite -!interp_comp fill_comp. + - subst. + destruct n0; simpl. + + by rewrite IF_False; last lia. + + by rewrite IF_True; last lia. + - do 2 f_equiv. simplify_eq. + destruct v1,v0; try naive_solver. simpl in *. rewrite NATOP_Ret. destruct op; simplify_eq/=; done. - - rewrite IF_True; last lia. - reflexivity. - - rewrite IF_False; last lia. - reflexivity. Qed. - Lemma interp_expr_fill_no_reify {S} (env : interp_scope S) (e e' : expr S) n : - prim_step e e' (n, 0) → - interp_expr e env ≡ Tick_n n $ interp_expr e' env. - Proof. - inversion 1; subst. - inversion H1; subst; rewrite !interp_comp; simpl. - - rewrite -hom_tick. rewrite -(shift_context_app K Ki' Ko); eauto. - f_equiv. eapply (interp_expr_head_step env _ _ _ _ _) in H1. - simpl in H1. done. - - rewrite -!hom_tick. rewrite -(shift_context_app K Ki' Ko); eauto. - f_equiv. eapply (interp_expr_head_step env _ _ _ _ _) in H1. - simpl in H1. done. - - rewrite -(shift_context_app K Ki' Ko); eauto. - f_equiv. eapply (interp_expr_head_step env _ _ _ _ _) in H1. - simpl in H1. done. - - rewrite -(shift_context_app K Ki' Ko); eauto. - f_equiv. eapply (interp_expr_head_step env _ _ _ _ _) in H1. - simpl in H1. done. - - rewrite -(shift_context_app K Ki' Ko); eauto. - f_equiv. eapply (interp_expr_head_step env _ _ _ _ _) in H1. - simpl in H1. done. - Qed. + Opaque map_meta_cont. Opaque extend_scope. Opaque Ret. + Lemma interp_cred_yes_reify {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) (σr : gState_rest sR_idx rs ♯ IT) n : + C ===> C' / (n, 1) -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> + reify (gReifiers_sReifier rs) t (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ t'). + Proof. + inversion 1; cbn-[IF APP' Tick get_ret2 gState_recomp]; intros Ht Ht'; inversion Ht; inversion Ht'; subst; + try rewrite !map_meta_cont_cons in Ht, Ht'|-*. + - trans (reify (gReifiers_sReifier rs) + (RESET_ (laterO_map (get_val META ◎ (interp_cont k env))) + (Next (interp_expr e env))) + (gState_recomp σr (sR_state (map_meta_cont mk env))) + ). + { + repeat f_equiv. rewrite !hom_vis. simpl. f_equiv. + rewrite ccompose_id_l. by intro. + } + rewrite reify_vis_eq//; last first. + { + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_reset) + (laterO_map (get_val META) (Next (interp_expr e env))) + _ (laterO_map (get_val META ◎ interp_cont k env)) (map_meta_cont mk env) + (laterO_map (get_val META ◎ interp_cont k env) :: map_meta_cont mk env) σr) as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last done. solve_proper. + } + f_equiv. by rewrite laterO_map_Next. + - - Parameter env : @interp_scope F R CR ∅. - Parameter σ : state. - Parameter (σr : gState_rest sR_idx rs ♯ IT). - Example term : expr ∅ := ((#2) + reset ((#3) + shift/cc (rec (($0) ⋆ (# 5)))))%syn. - (* Goal forall e, (interp_expr term env) ≡ e -> *) - (* exists e' σ', reify (gReifiers_sReifier rs) *) - (* e (gState_recomp σr (sR_state σ)) ≡ (gState_recomp σr (sR_state σ'), e'). *) - (* Proof. *) - (* intros. *) - (* eexists. eexists. Opaque CALLCC_. simpl in H. *) - (* rewrite /interp_reset in H. *) - (* rewrite !hom_CALLCC_ in H. *) - (* match goal with *) - (* | H : (equiv ?f e) |- _ => set (g := f) *) - (* end. *) - (* trans (reify (gReifiers_sReifier rs) g (gState_recomp σr (sR_state σ))). *) - (* { f_equiv. f_equiv. symmetry. apply H. } *) - (* subst g. *) - (* rewrite reify_vis_eq //; first last. *) - (* match goal with *) - (* | |- context G [ofe_mor_car _ _ (sReifier_re _ _) (?f, _, ?h)] => set (i := f); set (o := h) *) - (* end. *) - (* epose proof (@subReifier_reify sz reify_delim rs _ IT _ op_callcc (subEff_ins^-1 i) _ (o ◎ subEff_outs) σ _ σr) as He. *) - (* simpl in He |-*. *) - (* erewrite <-He; last reflexivity. *) - (* f_equiv. *) - (* - intros [][][]. simpl. solve_proper. *) - (* - f_equiv. f_equiv. *) - (* + f_equiv. by rewrite ofe_iso_21. *) - (* + intro. simpl. rewrite ofe_iso_12. done. *) - Lemma interp_expr_fill_yes_reify {S} K K' Ko env (e e' : expr S) (σ σ' : state) diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 425fdab..9948b0d 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -661,9 +661,13 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := (Val (shift (Inc := inc) v))) (Val (RecV e))) k mk / (1, 0) + (* | Ccont_cont : forall v k k' mk, *) + (* Ccont (AppLK v k) (ContV k') mk ===> *) + (* Ccont k' v (k :: mk) / (2, 0) *) + | Ccont_cont : forall v k k' mk, Ccont (AppLK v k) (ContV k') mk ===> - Ccont k' v (k :: mk) / (2, 0) + Ccont (cont_compose k k') v mk / (2, 0) | Ccont_if : forall et ef n k mk, Ccont (IfK et ef k) (LitV n) mk ===> @@ -696,6 +700,49 @@ Definition meta_fill {S} (mk : Mcont S) e := fold_left (λ e k, fill k e) mk e. + +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', + c1 ===> c2 / (n,m) -> + steps c2 c3 (n',m') -> + steps c1 c3 (n+n',m+m'). + + +(* Lemma ceval_expr_to_val {S} : *) +(* forall (e : expr S) k mk, exists v nm, steps (Ceval e k mk) (Ceval v k mk) nm. *) +(* Proof. *) +(* intros. *) +(* induction 1; intros. *) +(* - exists (Val v), (0,0). constructor. *) +(* - *) + + +(* (* One of the rule has been changed slightly *) *) +(* Lemma old_new_confluence {S} : forall (K K' : cont S) mk v v' n m, *) +(* steps (Ccont K' v (K::mk)) (Ccont K v' mk) (n, m+1) -> *) +(* steps (Ccont (cont_compose K K') v mk) (Ccont K v' mk) (n, m). *) +(* Proof. *) +(* intros until K'. revert K. induction K'; intros. *) +(* - simpl in *. inversion H as []; subst. *) +(* { contradict H3. clear H. induction mk; congruence. } *) +(* inversion H0; subst. *) +(* inversion H1; subst. *) +(* inversion H7; subst. *) +(* simpl in H5. *) +(* replace (0 + (0 + n'0)) with (n'0) by lia. *) +(* assert (m'0 = m) as -> by lia. *) +(* eapply H8. *) +(* - simpl in *. inversion H as []; subst; first lia. *) +(* inversion H0; subst. simpl in *. *) +(* (* inversion H1; subst. *) *) +(* replace m with (0+m) by lia. *) +(* replace n' with (0+n') by lia. *) +(* constructor 2 with (Ceval (if n =? 0 then e2 else e1) (cont_compose K K') mk); first constructor. *) +(* subst. *) + + Definition config_to_expr {S} (c : config S) := match c with | Ceval e k mk => meta_fill mk (fill k e) From 18b7c60442e8b21a342c95d845f0e784c603cb67 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Thu, 15 Feb 2024 18:24:45 +0100 Subject: [PATCH 100/114] half solution to a problem with shift and meta --- theories/input_lang_delim/interp.v | 31 ++++++++++++++++++++++++++---- theories/input_lang_delim/lang.v | 2 +- 2 files changed, 28 insertions(+), 5 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 5d1e085..0e19527 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -404,7 +404,7 @@ Section interp. (** ** CONT *) Program Definition interp_cont_val {S} (K : S -n> (IT -n> IT)) : S -n> IT := - λne env, (λit x, Tau (laterO_map (K env) (Next x))). + λne env, (λit x, Tau (laterO_map (get_val META ◎ K env) (Next x))). Solve All Obligations with solve_proper_please. (* Program Definition interp_cont {S} (e : @interp_scope F R _ (inc S) -n> IT) : *) @@ -751,6 +751,7 @@ Section interp. Qed. + (** ** Finally, preservation of reductions *) Lemma interp_cred_no_reify {S : Set} (env : interp_scope S) (C C' : config S) (t t' : IT) (σ σ' : state) n : @@ -778,6 +779,7 @@ Section interp. f_equiv. rewrite -Tick_eq !hom_tick. do 2 f_equiv. simpl. replace (interp_val v env) with (interp_expr (Val v) env) by done. + by rewrite -!interp_comp fill_comp. - subst. destruct n0; simpl. @@ -807,8 +809,7 @@ Section interp. - trans (reify (gReifiers_sReifier rs) (RESET_ (laterO_map (get_val META ◎ (interp_cont k env))) (Next (interp_expr e env))) - (gState_recomp σr (sR_state (map_meta_cont mk env))) - ). + (gState_recomp σr (sR_state (map_meta_cont mk env)))). { repeat f_equiv. rewrite !hom_vis. simpl. f_equiv. rewrite ccompose_id_l. by intro. @@ -824,7 +825,29 @@ Section interp. repeat f_equiv; last done. solve_proper. } f_equiv. by rewrite laterO_map_Next. - - + - remember (map_meta_cont mk env) as σ. + match goal with + | |- context G [Vis _ (_ ?f)] => set (fin := f) + end. + trans (reify (gReifiers_sReifier rs) + (SHIFT_ (fin) + ((laterO_map (get_val META ◎ interp_cont k env)))) + (gState_recomp σr (sR_state σ))). + { + repeat f_equiv. rewrite !hom_vis. + subst fin. simpl. f_equiv. by intro. + } + rewrite reify_vis_eq//; last first. + { + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_shift) + (fin) _ (laterO_map (get_val META ◎ interp_cont k env)) + σ σ σr) as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last done. solve_proper. + } + rewrite -Tick_eq. do 2 f_equiv. + rewrite interp_expr_subst. diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 9948b0d..8c002ee 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -687,7 +687,7 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := Cmcont (k :: mk) v ===> Ccont k v mk / (0,1) | Cmcont_ret : forall v, - Cmcont [] v ===> Cret v / (0, 0) + Cmcont [] v ===> Cret v / (0, 0) (* FIXME snd0=1 and fix interp *) where "c ===> c' / nm" := (Cred c c' nm). From 328bfe043c0753344835f4e162cca81d1452e1a9 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 16 Feb 2024 12:47:55 +0100 Subject: [PATCH 101/114] Soundness for shift and meta --- theories/input_lang_delim/interp.v | 123 ++++++++++++++++++++--------- theories/input_lang_delim/lang.v | 4 +- 2 files changed, 89 insertions(+), 38 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 0e19527..80c2ddb 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -132,25 +132,6 @@ Section constructors. - 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) 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. Program Definition META : IT -n> IT := @@ -170,6 +151,25 @@ Section constructors. Program Definition RESET : laterO IT -n> IT := RESET_ idfun. + 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 $ get_val META) ◎ 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. End constructors. @@ -196,18 +196,17 @@ Section weakestpre. Lemma wp_shift (σ : state) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} Φ s : has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} idfun (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} get_val META (later_car ( f (laterO_map k))) @ s {{ Φ }}) -∗ WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. Proof. iIntros "Hs Ha". unfold SHIFT. simpl. rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ (later_map idfun $ f (laterO_map k)) with "Hs"). + iApply (wp_subreify _ _ _ _ _ _ _ (later_map (get_val META) $ f (laterO_map k)) with "Hs"). { simpl. repeat f_equiv. - - rewrite ccompose_id_l later_map_id. - f_equiv. intro. simpl. by rewrite ofe_iso_21. + - rewrite ccompose_id_l. intro. simpl. by rewrite ofe_iso_21. - reflexivity. } { by rewrite later_map_Next. } @@ -485,6 +484,10 @@ Section interp. λne env, list_fmap _ _ (λ k, laterO_map (get_val (META) ◎ (interp_cont k env))) mk. Next Obligation. intros S mk n ???. apply list_fmap_ext_ne. intro. by repeat f_equiv. Qed. + Lemma map_meta_cont_nil {S} env : + map_meta_cont ([] : Mcont S) env = []. + Proof. done. Qed. + Lemma map_meta_cont_cons {S} (k : cont S) (mk : Mcont S) env : map_meta_cont (k::mk) env = (laterO_map ((get_val META) ◎ interp_cont k env)) :: (map_meta_cont mk env). Proof. done. Qed. @@ -498,7 +501,7 @@ Section interp. map_meta_cont mk env) | Cmcont mk v => λne env, (get_val META (interp_val v env), map_meta_cont mk env) - | Cret v => λne env, (get_val META (interp_val v env), []) + | Cret v => λne env, (interp_val v env, []) end. Solve Obligations with try solve_proper. Next Obligation. @@ -779,8 +782,8 @@ Section interp. f_equiv. rewrite -Tick_eq !hom_tick. do 2 f_equiv. simpl. replace (interp_val v env) with (interp_expr (Val v) env) by done. - - by rewrite -!interp_comp fill_comp. + admit. + (* by rewrite -!interp_comp fill_comp. *) - subst. destruct n0; simpl. + by rewrite IF_False; last lia. @@ -789,7 +792,9 @@ Section interp. destruct v1,v0; try naive_solver. simpl in *. rewrite NATOP_Ret. destruct op; simplify_eq/=; done. - Qed. + (* Qed. *) + Admitted. + Opaque map_meta_cont. @@ -827,27 +832,73 @@ Section interp. f_equiv. by rewrite laterO_map_Next. - remember (map_meta_cont mk env) as σ. match goal with - | |- context G [Vis _ (_ ?f)] => set (fin := f) + | |- context G [Vis ?o ?f ?κ] => set (fin := f); set (op := o); set (kout := κ) end. trans (reify (gReifiers_sReifier rs) - (SHIFT_ (fin) - ((laterO_map (get_val META ◎ interp_cont k env)))) + (Vis op fin ((laterO_map (get_val META ◎ interp_cont k env)) ◎ kout)) (gState_recomp σr (sR_state σ))). { - repeat f_equiv. rewrite !hom_vis. - subst fin. simpl. f_equiv. by intro. + repeat f_equiv. rewrite !hom_vis. f_equiv. by intro. } rewrite reify_vis_eq//; last first. { epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_shift) - (fin) _ (laterO_map (get_val META ◎ interp_cont k env)) + _ _ (laterO_map (get_val META ◎ interp_cont k env)) σ σ σr) as Hr. simpl in Hr|-*. erewrite <-Hr; last reflexivity. - repeat f_equiv; last done. solve_proper. + repeat f_equiv; last first. + - subst kout. by rewrite ccompose_id_l. + - subst fin. reflexivity. + - solve_proper. + } + rewrite -Tick_eq. do 3 f_equiv. + rewrite interp_expr_subst. + simpl. f_equiv. + intros [|s]; simpl; eauto. + Transparent extend_scope. + simpl. f_equiv. f_equiv. by intro. + Opaque extend_scope. + - remember (map_meta_cont mk env) as σ. + trans (reify (gReifiers_sReifier rs) (META (interp_val v env)) + (gState_recomp σr (sR_state (laterO_map (get_val META ◎ interp_cont k env) :: σ)))). + { + do 2 f_equiv; last repeat f_equiv. + apply get_val_ITV. + } + rewrite reify_vis_eq//; last first. + { + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_meta) + (Next (interp_val v env)) _ _ + (laterO_map (get_val META ◎ interp_cont k env) :: σ) σ σr) + as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last by erewrite ccompose_id_l. + solve_proper. + } + f_equiv. rewrite laterO_map_Next -Tick_eq. + by f_equiv. + - trans (reify (gReifiers_sReifier rs) (META (interp_val v env)) + (gState_recomp σr (sR_state []))). + { + do 2 f_equiv; last first. + { f_equiv. by rewrite map_meta_cont_nil. } + apply get_val_ITV. + } + rewrite reify_vis_eq//; last first. + { + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_meta) + (Next (interp_val v env)) _ _ + [] [] σr) + as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last by erewrite ccompose_id_l. + solve_proper. } - rewrite -Tick_eq. do 2 f_equiv. - rewrite interp_expr_subst. + f_equiv. by rewrite -Tick_eq. + Qed. diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 8c002ee..2b517e0 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -684,10 +684,10 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := (* meta-cont *) | Cmcont_cont : forall k mk v, - Cmcont (k :: mk) v ===> Ccont k v mk / (0,1) + Cmcont (k :: mk) v ===> Ccont k v mk / (1,1) | Cmcont_ret : forall v, - Cmcont [] v ===> Cret v / (0, 0) (* FIXME snd0=1 and fix interp *) + Cmcont [] v ===> Cret v / (1, 1) (* FIXME snd0=1 and fix interp *) where "c ===> c' / nm" := (Cred c c' nm). From 01004f4d0e6722f3f16f99004b914ae4b7c3f2d4 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 16 Feb 2024 14:46:52 +0100 Subject: [PATCH 102/114] Separate appcont constructor + soundness for all rules --- theories/input_lang_delim/interp.v | 184 +++++++++++++++++++++++++---- theories/input_lang_delim/lang.v | 27 ++++- 2 files changed, 185 insertions(+), 26 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 80c2ddb..39ef6b4 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -52,14 +52,21 @@ Program Definition metaE : opInterp := Outs := (▶ ∙); |}. +(* apply continuation, pushes outer context in meta *) +Program Definition appContE : opInterp := + {| + Ins := (▶ ∙ * (▶ (∙ -n> ∙))); + Outs := ▶ ∙; + |} . -Definition delimE := @[shiftE; resetE; metaE]. +Definition delimE := @[shiftE; resetE; metaE;appContE]. Notation op_shift := (inl ()). Notation op_reset := (inr (inl ())). Notation op_meta := (inr (inr (inl ()))). +Notation op_app_cont := (inr (inr (inr (inl ())))). @@ -104,6 +111,20 @@ Section reifiers. 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. @@ -113,10 +134,11 @@ Proof. sReifier_state := stateF |}. intros X HX op. - destruct op as [ | [ | [ | []]]]; simpl. + destruct op as [ | [ | [ | [| []]]]]; simpl. - simple refine (OfeMor (reify_shift)). - simple refine (OfeMor (reify_reset)). - simple refine (OfeMor (reify_meta)). + - simple refine (OfeMor (reify_app_cont)). Defined. @@ -131,8 +153,7 @@ Section constructors. - - + (** ** META *) Program Definition META : IT -n> IT := λne e, Vis (E:=E) (subEff_opid op_meta) @@ -140,6 +161,8 @@ Section constructors. ((subEff_outs (F:=delimE) (op:=op_meta))^-1). Solve All Obligations with solve_proper. + (** ** RESET *) + Program Definition RESET_ : (laterO IT -n> laterO IT) -n> laterO IT -n> IT := @@ -151,6 +174,8 @@ Section constructors. 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 := @@ -172,6 +197,21 @@ Section constructors. 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. Section weakestpre. @@ -389,6 +429,22 @@ Section interp. Proof. solve_proper. Qed. Typeclasses Opaque interp_app. + (** ** APP_CONT *) + + 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)), + APP_CONT (Next x) f) + (k env)) + (e env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_app_cont_ne A : NonExpansive2 (@interp_app_cont A). + Proof. + intros n??????. rewrite /interp_app_cont. intro. simpl. + repeat f_equiv; last done. intro. simpl. by repeat f_equiv. + Qed. + (* Typeclasses Opaque interp_app_cont. *) + (** ** IF *) Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := λne env, IF (t0 env) (t1 env) (t2 env). @@ -439,6 +495,33 @@ Section interp. λne env t, (K env) $ interp_app (λne env, t) q env. Solve All Obligations with solve_proper. + Program Definition interp_app_contrk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_app_cont q (λne env, t) env. + Next Obligation. intros A q K t n ????. done. Qed. + Next Obligation. + intros A q K env n ???. simpl. by repeat f_equiv. + Qed. + Next Obligation. + intros A q K n ???. intro. simpl. f_equiv. + - by f_equiv. + - f_equiv. f_equiv. intro. simpl. by repeat f_equiv. + Qed. + + Program Definition interp_app_contlk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_app_cont (λne env, t) q env. + Next Obligation. intros A q K t n ????. done. Qed. + Next Obligation. + intros A q K env n ???. simpl. repeat f_equiv. + intro. simpl. by repeat f_equiv. + Qed. + Next Obligation. + intros A q K n ???. intro. simpl. f_equiv. + - by f_equiv. + - f_equiv; last by f_equiv. f_equiv. intro. simpl. repeat f_equiv. + Qed. + Program Definition interp_natoprk {A} (op : nat_op) (q : A -n> IT) (K : A -n> IT -n> IT) : A -n> IT -n> IT := λne env t, (K env) $ interp_natop op q (λne env, t) env. @@ -462,6 +545,7 @@ Section interp. | Val v => interp_val v | Var x => interp_var x | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | AppCont e1 e2 => interp_app_cont (interp_expr e1) (interp_expr e2) | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) | Shift e => interp_shift (interp_expr e) @@ -474,6 +558,8 @@ Section interp. | 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) + | 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) | NatOpRK op e K => interp_natoprk op (interp_expr e) (interp_cont K) end. @@ -551,6 +637,8 @@ Section interp. interp_cont (fmap δ K) env ≡ interp_cont K (ren_scope δ env). Proof. - destruct e; simpl; try by repeat 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. @@ -574,8 +662,12 @@ Section interp. + repeat f_equiv. intro. simpl. repeat f_equiv. apply interp_cont_ren. - - destruct K; simpl; repeat f_equiv; intro; simpl; repeat f_equiv; - (apply interp_expr_ren || apply interp_val_ren || 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. Qed. @@ -590,7 +682,10 @@ Section interp. 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. Qed. + Proof. elim : K e env; eauto. + 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') : interp_scope S := λne x, interp_expr (δ x) env. @@ -619,6 +714,7 @@ Section interp. interp_cont (bind δ K) env ≡ interp_cont K (sub_scope δ env). Proof. - destruct e; simpl; try 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. @@ -646,8 +742,10 @@ Section interp. done. + repeat f_equiv. intro. simpl. repeat f_equiv. by rewrite interp_cont_subst. - - destruct K; simpl; repeat f_equiv; intro; simpl; repeat f_equiv; - (apply interp_expr_subst || apply interp_val_subst || apply 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)]. + + 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. @@ -709,6 +807,36 @@ Section interp. apply hom_err. Qed. + + #[global] Instance interp_cont_hom_app_contr {S} (K : cont S) + (e : expr S) env : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppContRK e 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. + Qed. + + #[global] Instance interp_cont_hom_app_contl {S} (K : cont S) + (v : val S) (env : interp_scope S) : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppContLK v K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -hom_tick. f_equiv. + rewrite get_val_ITV. simpl. rewrite hom_tick. + f_equiv. by rewrite get_val_ITV. + - rewrite get_val_ITV. simpl. rewrite get_fun_vis. rewrite hom_vis. + f_equiv. intro. simpl. rewrite -laterO_map_compose. + f_equiv. f_equiv. intro. simpl. + f_equiv. by rewrite get_val_ITV. + - rewrite get_val_ITV. simpl. rewrite get_fun_err. apply hom_err. + Qed. + + #[global] Instance interp_cont_hom_natopr {S} (K : cont S) (e : expr S) op env : IT_hom (interp_cont K env) -> @@ -776,14 +904,6 @@ Section interp. rewrite interp_val_ren. f_equiv. intros ?; simpl; reflexivity. - - rewrite -!hom_tick. - erewrite APP_APP'_ITV; last apply _. - rewrite APP_Fun. simpl. - f_equiv. rewrite -Tick_eq !hom_tick. - do 2 f_equiv. simpl. - replace (interp_val v env) with (interp_expr (Val v) env) by done. - admit. - (* by rewrite -!interp_comp fill_comp. *) - subst. destruct n0; simpl. + by rewrite IF_False; last lia. @@ -792,10 +912,7 @@ Section interp. destruct v1,v0; try naive_solver. simpl in *. rewrite NATOP_Ret. destruct op; simplify_eq/=; done. - (* Qed. *) - Admitted. - - + Qed. Opaque map_meta_cont. Opaque extend_scope. @@ -859,6 +976,31 @@ Section interp. Transparent extend_scope. simpl. f_equiv. f_equiv. by intro. Opaque extend_scope. + - remember (map_meta_cont mk env) as σ. + remember (laterO_map (get_val META ◎ interp_cont k env)) as kk. + match goal with + | |- context G [ofe_mor_car _ _ (get_fun _) + (ofe_mor_car _ _ Fun ?f)] => set (fin := f) + end. + trans (reify (gReifiers_sReifier rs) + (APP_CONT_ (Next (interp_val v env)) + fin kk) + (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. + rewrite laterO_map_compose. done. + } + rewrite reify_vis_eq//; last first. + { + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_app_cont) + (Next (interp_val v env), fin) _ kk σ (kk :: σ) σr) + as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; eauto. solve_proper. + } + f_equiv. by rewrite -!Tick_eq. - remember (map_meta_cont mk env) as σ. trans (reify (gReifiers_sReifier rs) (META (interp_val v env)) (gState_recomp σr (sR_state (laterO_map (get_val META ◎ interp_cont k env) :: σ)))). diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 2b517e0..6f0ece3 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -17,6 +17,8 @@ Inductive expr {X : Set} := | Var (x : X) : expr (* Base lambda calculus *) | App (e₁ : expr) (e₂ : expr) : expr +(* special application for continuations *) +| AppCont (e₁ : expr) (e₂ : expr) : expr (* Base types and their operations *) | NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr | If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr @@ -34,6 +36,8 @@ with cont {X : Set} := | IfK (e1 : expr) (e2 : expr) : cont -> cont | AppLK (v : val) : cont -> cont (* ◻ v *) | AppRK (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 *) | NatOpRK (op : nat_op) (e : expr) : cont -> cont. (* e + ◻ *) @@ -56,6 +60,7 @@ Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := | Val v => Val (vmap f v) | Var x => Var (f x) | App e₁ e₂ => App (emap f e₁) (emap f e₂) + | AppCont e₁ e₂ => AppCont (emap f e₁) (emap f e₂) | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) (* | Input => Input *) @@ -76,6 +81,8 @@ with kmap {A B : Set} (f : A [→] B) (K : cont A) : cont B := | 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) + | 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) | NatOpRK op e k => NatOpRK op (emap f e) (kmap f k) end. @@ -92,6 +99,7 @@ Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := | Val v => Val (vbind f v) | Var x => f x | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) + | AppCont e₁ e₂ => AppCont (ebind f e₁) (ebind f e₂) | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) (* | Input => Input *) @@ -112,6 +120,8 @@ with kbind {A B : Set} (f : A [⇒] B) (K : cont A) : cont B := | 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) + | 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) | NatOpRK op e k => NatOpRK op (ebind f e) (kbind f k) end. @@ -289,6 +299,8 @@ Fixpoint fill {X : Set} (K : cont X) (e : expr X) : expr X := | END => e | AppLK v K => fill K (App e (Val v)) | AppRK el K => fill K (App el e) + | 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)) | NatOpRK op el K => fill K (NatOp op el e) end. @@ -511,6 +523,8 @@ Fixpoint cont_compose {S} (K1 K2 : cont S) : cont S := | 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) + | 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) | NatOpRK op e K => NatOpRK op e (cont_compose K1 K) end. @@ -633,6 +647,9 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := | Ceval_app : forall e0 e1 k mk, Ceval (App e0 e1) k mk ===> Ceval e1 (AppRK 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) @@ -661,13 +678,13 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := (Val (shift (Inc := inc) v))) (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 (AppLK v k) (ContV k') mk ===> *) - (* Ccont k' v (k :: mk) / (2, 0) *) - - | Ccont_cont : forall v k k' mk, - Ccont (AppLK v k) (ContV k') mk ===> - Ccont (cont_compose k k') v mk / (2, 0) + (* Ccont (cont_compose k k') v mk / (2, 0) *) | Ccont_if : forall et ef n k mk, Ccont (IfK et ef k) (LitV n) mk ===> From 7309ccaa0bd8cffa2888b969009a30973df2e241 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 16 Feb 2024 16:46:50 +0100 Subject: [PATCH 103/114] Soundness --- theories/input_lang_delim/interp.v | 443 +++++------------------------ theories/input_lang_delim/lang.v | 5 +- 2 files changed, 70 insertions(+), 378 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 39ef6b4..446ffc0 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -892,6 +892,7 @@ Section interp. t ≡ Tick_n n $ t'. Proof. inversion 1; cbn-[IF APP' Tick get_ret2]; intros Ht Ht'; inversion Ht; inversion Ht'; try done. + - 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))). @@ -914,6 +915,16 @@ Section interp. destruct op; simplify_eq/=; done. Qed. + Lemma interp_cred_no_reify_state {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) n : + C ===> C' / (n, 0) -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> + σ = σ'. + Proof. + inversion 1; cbn; intros Ht Ht'; inversion Ht; inversion Ht'; subst; reflexivity. + Qed. + Opaque map_meta_cont. Opaque extend_scope. Opaque Ret. @@ -1000,7 +1011,7 @@ Section interp. erewrite <-Hr; last reflexivity. repeat f_equiv; eauto. solve_proper. } - f_equiv. by rewrite -!Tick_eq. + f_equiv. by rewrite -!Tick_eq. - remember (map_meta_cont mk env) as σ. trans (reify (gReifiers_sReifier rs) (META (interp_val v env)) (gState_recomp σr (sR_state (laterO_map (get_val META ◎ interp_cont k env) :: σ)))). @@ -1043,383 +1054,61 @@ Section interp. Qed. - - Lemma interp_expr_fill_yes_reify {S} K K' Ko env (e e' : expr S) - (σ σ' : state) - (σr : gState_rest sR_idx rs ♯ IT) n : - head_step e K e' K' Ko (n, 1) → - some_relation K Ko σ -> - some_relation K' Ko σ -> - reify (gReifiers_sReifier rs) - (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) - ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K' e') env). - Proof. - intros Hst H1. apply (interp_ectx_hom K env) in H1. - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) - (gState_recomp σr (sR_state σ))). - { f_equiv. by rewrite interp_comp. } - inversion Hst; simplify_eq; cbn-[gState_recomp]. - - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K' env ◎ Ret)) (gState_recomp σr (sR_state σ))). - { - repeat f_equiv; eauto. - rewrite hom_INPUT. - do 2 f_equiv. by intro. - } - rewrite reify_vis_eq //; first last. - { - epose proof (@subReifier_reify sz reify_io rs _ IT _ (inl ()) () (Next (interp_ectx K' env (Ret n0))) (NextO ◎ (interp_ectx K' env ◎ Ret)) σ σ' σr) as H. - simpl in H. - simpl. - erewrite <-H; last first. - - rewrite H8. reflexivity. - - f_equiv; - solve_proper. - } - repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. - rewrite interp_comp. - reflexivity. - - trans (reify (gReifiers_sReifier rs) (interp_ectx K' env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). - { - do 3 f_equiv; eauto. - rewrite get_ret_ret//. - } - trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K' env (Ret 0))) (gState_recomp σr (sR_state σ))). - { - do 2 f_equiv; eauto. - by rewrite hom_OUTPUT_. - } - rewrite reify_vis_eq //; last first. - { - epose proof (@subReifier_reify sz reify_io rs _ IT _ op_output - n0 (Next (interp_ectx K' env ((Ret 0)))) - (constO (Next (interp_ectx K' env ((Ret 0))))) - σ (update_output n0 σ) σr) as H. - simpl in H. - simpl. - erewrite <-H; last reflexivity. - f_equiv. - + intros ???. by rewrite /prod_map H0. - + do 2 f_equiv. by intro. - } - repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. - rewrite interp_comp. - reflexivity. - - match goal with - | |- context G - [(ofe_mor_car _ _ (get_fun (?g)) - ?e)] => set (f := g) - end. - match goal with - | |- context G [(?s, _)] => set (gσ := s) end. - (* Transparent SHIFT. *) - (* unfold SHIFT. *) - set (subEff1 := @subReifier_subEff sz reify_io rs subR). - trans (reify (gReifiers_sReifier rs) - (interp_ectx' K env - (get_fun f (Fun (Next (ir_unf (interp_expr e0) env))))) gσ). - { repeat f_equiv. apply interp_rec_unfold. } - trans (reify (gReifiers_sReifier rs) - (interp_ectx K env - (f (Next (ir_unf (interp_expr e0) env)))) gσ). - { repeat f_equiv. apply get_fun_fun. } - subst f. - Opaque interp_ectx. - simpl. - match goal with - | |- context G [(ofe_mor_car _ _ SHIFT ?g)] => set (f := g) - end. - trans (reify (gReifiers_sReifier rs) - (SHIFT_ f (laterO_map (λne y, interp_ectx K env y) ◎ idfun)) gσ). - { - do 2 f_equiv. - rewrite -(@hom_SHIFT_ F R CR subEff1 idfun f _). - by f_equiv. - } - rewrite reify_vis_eq//; last first. - { - simpl. - epose proof (@subReifier_reify sz reify_io rs subR IT _ - op_shift f _ - (laterO_map (interp_ectx K env)) σ' σ' σr) as H. - simpl in H. - erewrite <-H; last reflexivity. - f_equiv. - + intros ???. by rewrite /prod_map H2. - + do 3f_equiv; try done. by intro. - } - clear f. - f_equiv. - rewrite -Tick_eq. f_equiv. - rewrite !interp_expr_subst. f_equiv. - intros [|[|x]]; eauto. simpl. - Transparent extend_scope. - simpl. repeat f_equiv. intro. simpl. - rewrite laterO_map_Next -Tick_eq. f_equiv. - rewrite interp_expr_ren interp_comp. simpl. - symmetry. - etrans; first by apply interp_ectx_ren. - repeat f_equiv. unfold ren_scope. simpl. by intro. - (* rewrite APP'_Fun_r. *) - (* match goal with *) - (* | |- context G [(ofe_mor_car _ _ (ofe_mor_car _ _ APP _) ?f)] => *) - (* trans (APP (Fun $ Next $ ir_unf (interp_expr e0) env) f); last first *) - (* end. *) - (* { repeat f_equiv; try by rewrite interp_rec_unfold. } *) - (* rewrite APP_Fun -!Tick_eq. simpl. *) - (* repeat f_equiv. *) - (* intro. simpl. *) - (* rewrite interp_comp laterO_map_Next -Tick_eq. f_equiv. *) - (* symmetry. *) - (* Transparent extend_scope. *) - (* fold (@interp_ectx S K env). *) - (* Opaque interp_ectx. *) - (* simpl. *) - (* etrans; first by apply interp_ectx_ren. *) - (* repeat f_equiv. *) - (* unfold ren_scope. simpl. *) - (* apply ofe_mor_ext. done. *) - (* Transparent interp_ectx. *) - (* Opaque extend_scope. *) - - Transparent RESET. unfold RESET. - trans (reify (gReifiers_sReifier rs) - (RESET_ (laterO_map (λne y, interp_ectx' K' env y) ◎ - (laterO_map (λne y, get_val idfun y)) ◎ - idfun) - (Next (interp_val v env))) - (gState_recomp σr (sR_state σ'))). - { - do 2 f_equiv; last done. - rewrite !hom_vis. simpl. f_equiv. - by intro x. - } - rewrite reify_vis_eq//; last first. - { - simpl. - epose proof (@subReifier_reify sz reify_io rs subR IT _ - op_reset (Next (interp_val v env)) _ - (laterO_map (interp_ectx K' env) ◎ - laterO_map (get_val idfun)) σ' σ' σr) as H. - simpl in H. erewrite <-H; last reflexivity. - f_equiv. - + intros ???. by rewrite /prod_map H0. - + do 2 f_equiv. by intro x. - } - f_equiv. - rewrite laterO_map_Next -Tick_eq. f_equiv. - rewrite interp_comp. f_equiv. - simpl. by rewrite get_val_ITV. - Qed. - - - (* Lemma soundness_Ectx {S} (e1 e2 e'1 e'2 : expr S) σ1 σ2 (K1 K2 : ectx S) *) - (* (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : *) - (* ResetK ∉ K1 -> *) - (* e1 = (K1 ⟪ e'1 ⟫)%syn -> *) - (* e2 = (K2 ⟪ e'2 ⟫)%syn -> *) - (* head_step e'1 σ1 K1 e'2 σ2 K2 (n, m) -> *) - (* ssteps (gReifiers_sReifier rs) *) - (* (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) *) - (* (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. *) - (* Proof. *) - (* Opaque gState_decomp gState_recomp. *) - (* intros. simplify_eq/=. *) - (* destruct (head_step_io_01 _ _ _ _ _ _ _ _ H2); subst. *) - (* - assert (σ1 = σ2) as ->. *) - (* { eapply head_step_no_io; eauto. } *) - (* unshelve eapply (interp_expr_fill_no_reify K1) in H2; first apply env; last apply H. *) - (* rewrite H2. *) - (* rewrite interp_comp. *) - (* eapply ssteps_tick_n. *) - (* - specialize (interp_ectx_hom K1 env H) as Hhom. *) - (* inversion H2;subst. *) - (* + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr) in H2; last apply H. *) - (* rewrite interp_comp. simpl. *) - (* rewrite hom_INPUT. *) - (* change 1 with (Nat.add 1 0). econstructor; last first. *) - (* { apply ssteps_zero; reflexivity. } *) - (* eapply sstep_reify. *) - (* { Transparent INPUT. unfold INPUT. simpl. *) - (* f_equiv. reflexivity. } *) - (* simpl in H2. *) - (* rewrite -H2. *) - (* repeat f_equiv; eauto. *) - (* rewrite interp_comp hom_INPUT. *) - (* eauto. *) - (* + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr _ H2) in H. *) - (* rewrite interp_comp. simpl. *) - (* rewrite get_ret_ret. *) - (* rewrite hom_OUTPUT_. *) - (* change 1 with (Nat.add 1 0). econstructor; last first. *) - (* { apply ssteps_zero; reflexivity. } *) - (* eapply sstep_reify. *) - (* { Transparent OUTPUT_. unfold OUTPUT_. simpl. *) - (* f_equiv. reflexivity. } *) - (* simpl in H. *) - (* rewrite -H. *) - (* repeat f_equiv; eauto. *) - (* Opaque OUTPUT_. *) - (* rewrite interp_comp /= get_ret_ret hom_OUTPUT_. *) - (* eauto. *) - (* + eapply (interp_expr_fill_yes_reify K1 [] env _ _ _ _ σr _ H2) in H. *) - (* rewrite !interp_comp. *) - (* Opaque interp_ectx. simpl. *) - (* match goal with *) - (* | |- context G [ofe_mor_car _ _ (get_fun _) ?g] => set (f := g) *) - (* end. *) - (* assert (f ≡ Fun $ Next $ ir_unf (interp_expr e) env) as -> by apply interp_rec_unfold. *) - (* rewrite get_fun_fun. *) - (* simpl. *) - (* econstructor; last constructor; last done; last done. *) - (* eapply sstep_reify. *) - (* { rewrite hom_SHIFT_. simpl. *) - (* f_equiv. reflexivity. } *) - (* simpl in H. rewrite -H. repeat f_equiv. *) - (* rewrite interp_comp. f_equiv. simpl. *) - (* match goal with *) - (* |- context G [ ofe_mor_car _ _ (get_fun ?g)] => set (gi := g) *) - (* end. *) - (* trans (get_fun gi *) - (* (Fun $ Next $ ir_unf (interp_expr e) env)); last by rewrite interp_rec_unfold. *) - (* rewrite get_fun_fun. simpl. reflexivity. *) - (* + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr _ H2) in H. *) - (* rewrite !interp_comp. *) - (* econstructor; last constructor; last done; last done. *) - (* eapply sstep_reify. *) - (* { simpl. rewrite !hom_vis. reflexivity. } *) - (* simpl in H2. *) - (* trans (gState_recomp σr (sR_state σ2), *) - (* Tick (interp_expr (K2 ⟪ v ⟫)%syn env)); *) - (* last by (repeat f_equiv; apply interp_comp). *) - (* rewrite -H. repeat f_equiv. by rewrite interp_comp. *) - (* Qed. *) - - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : - prim_step e1 σ1 e2 σ2 (n,m) → + (** * SOUNDNESS *) + Lemma soundness {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) (σr : gState_rest sR_idx rs ♯ IT) n nm : + steps C C' nm -> + fst nm = n -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> ssteps (gReifiers_sReifier rs) - (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) - (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. + t (gState_recomp σr (sR_state σ)) + t' (gState_recomp σr (sR_state σ')) n. Proof. - Opaque gState_decomp gState_recomp. - inversion 1; simplify_eq/=. - rewrite !interp_comp. - pose proof (shift_context_no_reset K Ki Ko H0). - destruct (head_step_io_01 _ _ _ _ _ _ _ _ _ H1); subst. - - assert (σ1 = σ2) as ->. - { eapply head_step_no_io; eauto. } - unshelve eapply (interp_expr_fill_no_reify Ki) in H1; first apply env; last apply H2. - rewrite H1. - rewrite interp_comp. - eapply ssteps_tick_n. - - specialize (interp_ectx_hom K1 env H) as Hhom. - inversion H2;subst. - + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr) in H2; last apply H. - rewrite interp_comp. simpl. - rewrite hom_INPUT. - change 1 with (Nat.add 1 0). econstructor; last first. - { apply ssteps_zero; reflexivity. } - eapply sstep_reify. - { Transparent INPUT. unfold INPUT. simpl. - f_equiv. reflexivity. } - simpl in H2. - rewrite -H2. - repeat f_equiv; eauto. - rewrite interp_comp hom_INPUT. - eauto. - + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr _ H2) in H. - rewrite interp_comp. simpl. - rewrite get_ret_ret. - rewrite hom_OUTPUT_. - change 1 with (Nat.add 1 0). econstructor; last first. - { apply ssteps_zero; reflexivity. } - eapply sstep_reify. - { Transparent OUTPUT_. unfold OUTPUT_. simpl. - f_equiv. reflexivity. } - simpl in H. - rewrite -H. - repeat f_equiv; eauto. - Opaque OUTPUT_. - rewrite interp_comp /= get_ret_ret hom_OUTPUT_. - eauto. - + eapply (interp_expr_fill_yes_reify K1 [] env _ _ _ _ σr _ H2) in H. - rewrite !interp_comp. - Opaque interp_ectx. simpl. - match goal with - | |- context G [ofe_mor_car _ _ (get_fun _) ?g] => set (f := g) - end. - assert (f ≡ Fun $ Next $ ir_unf (interp_expr e) env) as -> by apply interp_rec_unfold. - rewrite get_fun_fun. - simpl. - econstructor; last constructor; last done; last done. - eapply sstep_reify. - { rewrite hom_SHIFT_. simpl. - f_equiv. reflexivity. } - simpl in H. rewrite -H. repeat f_equiv. - rewrite interp_comp. f_equiv. simpl. - match goal with - |- context G [ ofe_mor_car _ _ (get_fun ?g)] => set (gi := g) - end. - trans (get_fun gi - (Fun $ Next $ ir_unf (interp_expr e) env)); last by rewrite interp_rec_unfold. - rewrite get_fun_fun. simpl. reflexivity. - + eapply (interp_expr_fill_yes_reify K2 K2 env _ _ _ _ σr _ H2) in H. - rewrite !interp_comp. - econstructor; last constructor; last done; last done. - eapply sstep_reify. - { simpl. rewrite !hom_vis. reflexivity. } - simpl in H2. - trans (gState_recomp σr (sR_state σ2), - Tick (interp_expr (K2 ⟪ v ⟫)%syn env)); - last by (repeat f_equiv; apply interp_comp). - rewrite -H. repeat f_equiv. by rewrite interp_comp. - - - - - (* unshelve epose proof (soundness_Ectx (Ki ⟪ e0 ⟫)%syn (Ki' ⟪ e3 ⟫)%syn e0 e3 σ1 σ2 Ki Ki' σr n m env H2 _ _ H1 ); try done. *) - (* pose proof (shift_context_app K Ki Ko H0) as ->. *) - (* pose proof (interp_val_asval v (D := env)). *) - (* rewrite get_val_ITV. *) - (* simpl. *) - (* rewrite get_fun_fun. *) - (* simpl. *) - (* change 2 with (Nat.add (Nat.add 1 1) 0). *) - (* econstructor; last first. *) - (* { apply ssteps_tick_n. } *) - (* eapply sstep_reify; first (rewrite hom_vis; reflexivity). *) - (* match goal with *) - (* | |- context G [ofe_mor_car _ _ _ (Next ?f)] => set (f' := f) *) - (* end. *) - (* trans (reify (gReifiers_sReifier rs) (THROW (interp_val v env) (Next f')) (gState_recomp σr (sR_state σ2))). *) - (* { *) - (* f_equiv; last done. *) - (* f_equiv. *) - (* rewrite hom_vis. *) - (* Transparent THROW. *) - (* unfold THROW. *) - (* simpl. *) - (* repeat f_equiv. *) - (* intros x; simpl. *) - (* destruct ((subEff_outs ^-1) x). *) - (* } *) - (* rewrite reify_vis_eq; first (rewrite Tick_eq; reflexivity). *) - (* simpl. *) - (* match goal with *) - (* | |- context G [(_, _, ?a)] => set (κ := a) *) - (* end. *) - (* epose proof (@subReifier_reify sz reify_io rs subR IT _ *) - (* (inr (inr (inr (inl ())))) (Next (interp_val v env), Next f') *) - (* (Next (Tau (Next ((interp_ectx K' env) (interp_val v env))))) *) - (* (Empty_setO_rec _) σ2 σ2 σr) as H'. *) - (* subst κ. *) - (* simpl in H'. *) - (* erewrite <-H'; last reflexivity. *) - (* rewrite /prod_map. *) - (* f_equiv; first solve_proper. *) - (* do 2 f_equiv; first reflexivity. *) - (* intro; simpl. *) - (* f_equiv. *) - (* } *) - (* Qed. *) + intros H. + revert n t t' σ σ'. + induction (H); intros n0 t t' σ σ' Hnm Ht Ht'; subst; simpl. + - rewrite Ht' in Ht. constructor; inversion Ht; done. + - destruct (interp_config c2 env) as [t2 σ2] eqn:Heqc2. + 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 <-; + 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; + 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 <-. + simpl in Heq|-*; rewrite Heq. constructor; eauto. + + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq. + simpl in Heq|-*. + change (2+n') with (1+(1+n')). + eapply ssteps_many; last first. + * eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. + eapply sstep_tick; reflexivity. + * eapply sstep_reify; last apply Heq. + cbn in Ht. inversion Ht. + 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. + 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. + 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. + * f_equiv. reflexivity. + Qed. End interp. -#[global] Opaque INPUT OUTPUT_ CALLCC THROW. +#[global] Opaque SHIFT_ RESET_ META APP_CONT_. diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 6f0ece3..9598db5 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -671,6 +671,9 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := | Ccont_appr : forall e v k mk, Ccont (AppRK e k) v mk ===> Ceval e (AppLK 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 ===> Ceval (subst (Inc := inc) @@ -704,7 +707,7 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := Cmcont (k :: mk) v ===> Ccont k v mk / (1,1) | Cmcont_ret : forall v, - Cmcont [] v ===> Cret v / (1, 1) (* FIXME snd0=1 and fix interp *) + Cmcont [] v ===> Cret v / (1, 1) where "c ===> c' / nm" := (Cred c c' nm). From 4a128e7f48e00b71134e2b95b35aaa643f4df1d1 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Fri, 23 Feb 2024 14:49:40 +0100 Subject: [PATCH 104/114] Rename META into POP, change output arity to 0 --- theories/input_lang_delim/interp.v | 101 +++---- theories/input_lang_delim/lang.v | 433 ++++++----------------------- 2 files changed, 139 insertions(+), 395 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index 446ffc0..ef7fc8d 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -46,10 +46,10 @@ Program Definition resetE : opInterp := |}. (* to apply the head of the meta continuation *) -Program Definition metaE : opInterp := +Program Definition popE : opInterp := {| Ins := (▶ ∙); - Outs := (▶ ∙); + Outs := Empty_setO; |}. (* apply continuation, pushes outer context in meta *) @@ -59,13 +59,13 @@ Program Definition appContE : opInterp := Outs := ▶ ∙; |} . -Definition delimE := @[shiftE; resetE; metaE;appContE]. +Definition delimE := @[shiftE; resetE; popE;appContE]. Notation op_shift := (inl ()). Notation op_reset := (inr (inl ())). -Notation op_meta := (inr (inr (inl ()))). +Notation op_pop := (inr (inr (inl ()))). Notation op_app_cont := (inr (inr (inr (inl ())))). @@ -97,16 +97,16 @@ Section reifiers. Proof. intros ?[[]][[]][[]]. simpl in *. by repeat f_equiv. Qed. - Definition reify_meta : (laterO X) * state * (laterO X -n> laterO X) → + Definition reify_pop : (laterO X) * state * (Empty_setO -n> laterO X) → option (laterO X * state) := - λ '(e, σ, k), + λ '(e, σ, _), match σ with | [] => Some (e, σ) | k' :: σ' => Some (k' e, σ') end. - #[export] Instance reify_meta_ne : - NonExpansive (reify_meta : - prodO (prodO (laterO X) state) (laterO X -n> laterO X) → + #[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. @@ -137,7 +137,7 @@ Proof. destruct op as [ | [ | [ | [| []]]]]; simpl. - simple refine (OfeMor (reify_shift)). - simple refine (OfeMor (reify_reset)). - - simple refine (OfeMor (reify_meta)). + - simple refine (OfeMor (reify_pop)). - simple refine (OfeMor (reify_app_cont)). Defined. @@ -153,21 +153,23 @@ Section constructors. - (** ** META *) + (** ** POP *) - Program Definition META : IT -n> IT := - λne e, Vis (E:=E) (subEff_opid op_meta) - (subEff_ins (F:=delimE) (op:=op_meta) (Next e)) - ((subEff_outs (F:=delimE) (op:=op_meta))^-1). + 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 (get_val META) e)) + (subEff_ins (F := delimE) (op := op_reset) (laterO_map 𝒫 e)) (k ◎ subEff_outs (F := delimE) (op := op_reset)^-1). Solve Obligations with solve_proper. @@ -180,7 +182,7 @@ Section constructors. (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 $ get_val META) ◎ f)) + (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. @@ -214,6 +216,8 @@ Section constructors. End constructors. +Notation 𝒫 := (get_val POP). + Section weakestpre. Context {sz : nat}. Variable (rs : gReifiers sz). @@ -230,19 +234,18 @@ Section weakestpre. (** * 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 : has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} get_val META (later_car ( f (laterO_map k))) @ s {{ Φ }}) -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} 𝒫 (later_car ( f (laterO_map k))) @ s {{ Φ }}) -∗ WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. Proof. iIntros "Hs Ha". unfold SHIFT. simpl. rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ (later_map (get_val META) $ f (laterO_map k)) with "Hs"). + iApply (wp_subreify _ _ _ _ _ _ _ (later_map 𝒫 $ f (laterO_map k)) with "Hs"). { simpl. repeat f_equiv. @@ -260,12 +263,12 @@ Section weakestpre. Φ s : has_substate σ -∗ ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ - WP@{rs} get_val META (later_car e) @ s {{ Φ }}) -∗ + WP@{rs} 𝒫 (later_car e) @ s {{ Φ }}) -∗ WP@{rs} k $ (RESET e) @ s {{ Φ }}. Proof. iIntros "Hs Ha". unfold RESET. simpl. rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ (laterO_map (get_val META) e) with "Hs"). + iApply (wp_subreify _ _ _ _ _ _ _ (laterO_map 𝒫 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. @@ -274,11 +277,11 @@ Section weakestpre. Qed. - Lemma wp_meta_end (v : ITV) (k : IT -n> IT) {Hk : IT_hom k} + Lemma wp_pop_end (v : ITV) (k : IT -n> IT) {Hk : IT_hom k} Φ s : has_substate [] -∗ ▷ (£ 1 -∗ has_substate [] -∗ WP@{rs} IT_of_V v @ s {{ Φ }}) -∗ - WP@{rs} k $ get_val META (IT_of_V v) @ s {{ Φ }}. + WP@{rs} k $ 𝒫 (IT_of_V v) @ s {{ Φ }}. Proof. iIntros "Hs Ha". rewrite get_val_ITV. simpl. rewrite hom_vis. @@ -288,11 +291,11 @@ Section weakestpre. - done. Qed. - Lemma wp_meta_cons (σ : state) (v : ITV) (k : IT -n> IT) {Hk : IT_hom k} + Lemma wp_pop_cons (σ : state) (v : ITV) (k : IT -n> IT) {Hk : IT_hom k} Φ s : has_substate ((laterO_map k) :: σ) -∗ ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k $ IT_of_V v @ s {{ Φ }}) -∗ - WP@{rs} k $ get_val META (IT_of_V v) @ s {{ Φ }}. + WP@{rs} k $ 𝒫 (IT_of_V v) @ s {{ Φ }}. Proof. iIntros "Hs Ha". rewrite get_val_ITV. simpl. rewrite hom_vis. @@ -459,7 +462,7 @@ Section interp. (** ** CONT *) Program Definition interp_cont_val {S} (K : S -n> (IT -n> IT)) : S -n> IT := - λne env, (λit x, Tau (laterO_map (get_val META ◎ K env) (Next x))). + λne env, (λit x, Tau (laterO_map (𝒫 ◎ K env) (Next x))). Solve All Obligations with solve_proper_please. (* Program Definition interp_cont {S} (e : @interp_scope F R _ (inc S) -n> IT) : *) @@ -567,7 +570,7 @@ Section interp. (** ** Interpretation of configurations *) Program Definition map_meta_cont {S} (mk : Mcont S) : @interp_scope F R _ S -n> state := - λne env, list_fmap _ _ (λ k, laterO_map (get_val (META) ◎ (interp_cont k env))) mk. + λne env, list_fmap _ _ (λ k, laterO_map (𝒫 ◎ (interp_cont k env))) mk. Next Obligation. intros S mk n ???. apply list_fmap_ext_ne. intro. by repeat f_equiv. Qed. Lemma map_meta_cont_nil {S} env : @@ -575,17 +578,17 @@ Section interp. Proof. done. Qed. Lemma map_meta_cont_cons {S} (k : cont S) (mk : Mcont S) env : - map_meta_cont (k::mk) env = (laterO_map ((get_val META) ◎ interp_cont k env)) :: (map_meta_cont mk env). + map_meta_cont (k::mk) env = (laterO_map (𝒫 ◎ interp_cont k env)) :: (map_meta_cont mk env). Proof. done. Qed. Program Definition interp_config {S} (C : config S) : @interp_scope F R _ S -n> (prodO IT state) := match C with - | Cexpr e => λne env, (get_val META (interp_expr e env), []) : prodO IT state - | Ceval e K mk => λne env, (get_val META (interp_cont K env (interp_expr e env)), + | Cexpr e => λne env, (𝒫 (interp_expr e env), []) : prodO IT state + | Ceval e K mk => λne env, (𝒫 (interp_cont K env (interp_expr e env)), map_meta_cont mk env) - | Ccont K v mk => λne env, (get_val META (interp_cont K env (interp_val v env)), + | Ccont K v mk => λne env, (𝒫 (interp_cont K env (interp_val v env)), map_meta_cont mk env) - | Cmcont mk v => λne env, (get_val META (interp_val v env), + | Cmcont mk v => λne env, (𝒫 (interp_val v env), map_meta_cont mk env) | Cret v => λne env, (interp_val v env, []) end. @@ -940,7 +943,7 @@ Section interp. inversion 1; cbn-[IF APP' Tick get_ret2 gState_recomp]; intros Ht Ht'; inversion Ht; inversion Ht'; subst; try rewrite !map_meta_cont_cons in Ht, Ht'|-*. - trans (reify (gReifiers_sReifier rs) - (RESET_ (laterO_map (get_val META ◎ (interp_cont k env))) + (RESET_ (laterO_map (𝒫 ◎ (interp_cont k env))) (Next (interp_expr e env))) (gState_recomp σr (sR_state (map_meta_cont mk env)))). { @@ -950,9 +953,9 @@ Section interp. rewrite reify_vis_eq//; last first. { epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_reset) - (laterO_map (get_val META) (Next (interp_expr e env))) - _ (laterO_map (get_val META ◎ interp_cont k env)) (map_meta_cont mk env) - (laterO_map (get_val META ◎ interp_cont k env) :: map_meta_cont mk env) σr) as Hr. + (laterO_map 𝒫 (Next (interp_expr e env))) + _ (laterO_map (𝒫 ◎ interp_cont k env)) (map_meta_cont mk env) + (laterO_map (𝒫 ◎ interp_cont k env) :: map_meta_cont mk env) σr) as Hr. simpl in Hr|-*. erewrite <-Hr; last reflexivity. repeat f_equiv; last done. solve_proper. @@ -963,7 +966,7 @@ Section interp. | |- context G [Vis ?o ?f ?κ] => set (fin := f); set (op := o); set (kout := κ) end. trans (reify (gReifiers_sReifier rs) - (Vis op fin ((laterO_map (get_val META ◎ interp_cont k env)) ◎ kout)) + (Vis op fin ((laterO_map (𝒫 ◎ interp_cont k env)) ◎ kout)) (gState_recomp σr (sR_state σ))). { repeat f_equiv. rewrite !hom_vis. f_equiv. by intro. @@ -971,7 +974,7 @@ Section interp. rewrite reify_vis_eq//; last first. { epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_shift) - _ _ (laterO_map (get_val META ◎ interp_cont k env)) + _ _ (laterO_map (𝒫 ◎ interp_cont k env)) σ σ σr) as Hr. simpl in Hr|-*. erewrite <-Hr; last reflexivity. @@ -988,7 +991,7 @@ Section interp. simpl. f_equiv. f_equiv. by intro. Opaque extend_scope. - remember (map_meta_cont mk env) as σ. - remember (laterO_map (get_val META ◎ interp_cont k env)) as kk. + remember (laterO_map (𝒫 ◎ interp_cont k env)) as kk. match goal with | |- context G [ofe_mor_car _ _ (get_fun _) (ofe_mor_car _ _ Fun ?f)] => set (fin := f) @@ -1013,26 +1016,26 @@ Section interp. } f_equiv. by rewrite -!Tick_eq. - remember (map_meta_cont mk env) as σ. - trans (reify (gReifiers_sReifier rs) (META (interp_val v env)) - (gState_recomp σr (sR_state (laterO_map (get_val META ◎ interp_cont k env) :: σ)))). + trans (reify (gReifiers_sReifier rs) (POP (interp_val v env)) + (gState_recomp σr (sR_state (laterO_map (𝒫 ◎ interp_cont k env) :: σ)))). { do 2 f_equiv; last repeat f_equiv. apply get_val_ITV. } rewrite reify_vis_eq//; last first. { - epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_meta) + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_pop) (Next (interp_val v env)) _ _ - (laterO_map (get_val META ◎ interp_cont k env) :: σ) σ σr) + (laterO_map (𝒫 ◎ interp_cont k env) :: σ) σ σr) as Hr. simpl in Hr|-*. erewrite <-Hr; last reflexivity. - repeat f_equiv; last by erewrite ccompose_id_l. + repeat f_equiv; last reflexivity. solve_proper. } f_equiv. rewrite laterO_map_Next -Tick_eq. by f_equiv. - - trans (reify (gReifiers_sReifier rs) (META (interp_val v env)) + - trans (reify (gReifiers_sReifier rs) (POP (interp_val v env)) (gState_recomp σr (sR_state []))). { do 2 f_equiv; last first. @@ -1041,13 +1044,13 @@ Section interp. } rewrite reify_vis_eq//; last first. { - epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_meta) + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_pop) (Next (interp_val v env)) _ _ [] [] σr) as Hr. simpl in Hr|-*. erewrite <-Hr; last reflexivity. - repeat f_equiv; last by erewrite ccompose_id_l. + repeat f_equiv; last reflexivity. solve_proper. } f_equiv. by rewrite -Tick_eq. @@ -1111,4 +1114,4 @@ Section interp. Qed. End interp. -#[global] Opaque SHIFT_ RESET_ META APP_CONT_. +#[global] Opaque SHIFT_ RESET_ POP APP_CONT_. diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index 9598db5..aaa60b5 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -306,98 +306,6 @@ Fixpoint fill {X : Set} (K : cont X) (e : expr X) : expr X := end. -(* Fixpoint trim_to_first_reset {X : Set} (K : ectx X) (acc : ectx X) : (ectx X * ectx X) := *) -(* match K with *) -(* (* | OutputK :: K => trim_to_first_reset K (OutputK :: acc) *) *) -(* (* | (IfK e1 e2) :: K => trim_to_first_reset K ((IfK e1 e2) :: acc) *) *) -(* (* | (AppLK v) :: K => trim_to_first_reset K ((AppLK v) :: acc) *) *) -(* (* | (AppRK el) :: K => trim_to_first_reset K ((AppRK el) :: acc) *) *) -(* (* | (NatOpLK op v) :: K => trim_to_first_reset K ((NatOpLK op v) :: acc) *) *) -(* (* | (NatOpRK op el) :: K => trim_to_first_reset K ((NatOpRK op el) :: acc) *) *) -(* | (ResetK) :: K => (acc, ResetK :: K) *) -(* | C :: K => trim_to_first_reset K (C :: acc) *) -(* | [] => (acc, []) *) -(* end. *) - - - -(* (* Separate continuation [K] on innermost [reset] *) *) -(* Definition shift_context {X : Set} (K : ectx X) : (ectx X * ectx X) := *) -(* let (Ki, Ko) := trim_to_first_reset K [] in *) -(* (List.rev Ki, Ko). *) - - - -(* Lemma trim_to_first_reset_app {X : Set} (K Ki Ko acc : ectx X) : *) -(* (Ki, Ko) = trim_to_first_reset K acc -> *) -(* (List.rev Ki) ++ Ko = (List.rev acc) ++ K. *) -(* Proof. *) -(* revert Ki Ko acc. induction K; simpl; intros. *) -(* - by inversion H. *) -(* - specialize (IHK Ki Ko (a :: acc)) as HI. *) -(* destruct a; try (specialize (HI H); rewrite HI; simpl; *) -(* rewrite -app_assoc; symmetry; apply cons_middle). *) -(* by inversion H. *) -(* Qed. *) - - -(* Lemma shift_context_app {X : Set} (K Ki Ko : ectx X) : *) -(* (Ki, Ko) = shift_context K -> K = Ki ++ Ko. *) -(* Proof. *) -(* unfold shift_context. intro. *) -(* destruct (trim_to_first_reset K ([])) as [Ki' Ko'] eqn:He. *) -(* inversion H. subst. *) -(* trans (rev [] ++ K); first auto. symmetry. *) -(* by apply trim_to_first_reset_app. *) -(* Qed. *) - - -(* Lemma trim_reset_no_reset {X : Set} (K Ki Ko acc : ectx X) : *) -(* (Ki, Ko) = trim_to_first_reset K acc -> *) -(* ResetK ∉ acc -> *) -(* ResetK ∉ Ki. *) -(* Proof. *) -(* elim: K Ko acc Ki; simpl; intros. *) -(* - congruence. *) -(* - destruct a; try solve [eapply H; try eapply H0; try (apply not_elem_of_cons; done)]. *) -(* congruence. *) -(* Qed. *) - - -(* Lemma shift_context_no_reset {X : Set} (K Ki Ko : ectx X) : *) -(* (Ki, Ko) = shift_context K -> ResetK ∉ Ki. *) -(* Proof. *) -(* rewrite /shift_context//. destruct (trim_to_first_reset K []) eqn:Heq. symmetry in Heq. *) -(* intros. eapply trim_reset_no_reset in Heq; last apply not_elem_of_nil. *) -(* rewrite rev_alt in H. inversion H. subst. by rewrite elem_of_reverse. *) -(* Qed. *) - - -(* Lemma no_reset_trim_ident {X : Set} (K acc : ectx X) : *) -(* ResetK ∉ K -> ResetK ∉ acc -> *) -(* ((List.rev K) ++ acc, []) = trim_to_first_reset K acc. *) -(* Proof. *) -(* elim: K acc; intros; simpl; eauto. *) -(* apply not_elem_of_cons in H0 as [Hh Ht]. *) -(* destruct a; try contradiction; *) -(* rewrite -app_assoc; simpl; apply H; eauto; by apply not_elem_of_cons. *) -(* Qed. *) - - -(* Lemma no_reset_shift_context_ident {X : Set} (K : ectx X) : *) -(* ResetK ∉ K -> (K, []) = shift_context K. *) -(* Proof. *) -(* unfold shift_context. intros. rewrite -no_reset_trim_ident; *) -(* last apply not_elem_of_nil; last done. *) -(* by rewrite app_nil_r rev_involutive. *) -(* Qed. *) - - -(* Only if no reset in K *) -(* Definition cont_to_rec {X : Set} (K : ectx X) : (val X) := *) -(* ContV (fill (shift K) (Var VZ)). *) - -(* Example test1 : val (inc ∅) := (cont_to_rec [(NatOpLK Add (LitV 3)); AppRK (Var VZ)]). *) (* Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) *) (* : fmap f (fill K e) = fill (fmap f K) (fmap f e). *) @@ -411,90 +319,6 @@ Fixpoint fill {X : Set} (K : cont X) (e : expr X) : expr X := (*** Operational semantics *) -(* Record state := State { *) -(* inputs : list nat; *) -(* outputs : list nat; *) -(* }. *) -(* #[export] Instance state_inhabited : Inhabited state := populate (State [] []). *) - -(* Definition update_input (s : state) : nat * state := *) -(* match s.(inputs) with *) -(* | [] => (0, s) *) -(* | n::ns => *) -(* (n, {| inputs := ns; outputs := s.(outputs) |}) *) -(* end. *) -(* Definition update_output (n:nat) (s : state) : state := *) -(* {| inputs := s.(inputs); outputs := n::s.(outputs) |}. *) - - -(** [head_step e σ K e' σ' K' Ko (n, m)] : step from [(e, σ, K)] to [(e', σ', K')] - under outer context [Ko] in [n] ticks with [m] effects encountered *) -(* Variant head_step {S} : expr S -> ectx S -> *) -(* expr S -> ectx S -> *) -(* ectx S -> *) -(* nat * nat → Prop := *) -(* | BetaS e1 v2 K Ko : *) -(* head_step (App (Val $ RecV e1) (Val v2)) K *) -(* (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) *) -(* (Val (shift (Inc := inc) v2))) *) -(* (Val (RecV e1))) K Ko (1,0) *) -(* | BetaContS e1 v2 K Ko : *) -(* head_step (App (Val $ ContV e1) (Val v2)) K *) -(* (subst (Inc := inc) e1 (Val v2)) *) -(* K Ko (2,0) *) -(* (* | InputS n σ' K Ko : *) *) -(* (* update_input = (n, σ') → *) *) -(* (* head_step Input K (Val (LitV n)) σ' K Ko (1, 1) *) *) -(* (* | OutputS n σ' K Ko : *) *) -(* (* update_output n = σ' → *) *) -(* (* head_step (Output (Val (LitV n))) K (Val (LitV 0)) σ' K Ko (1, 1) *) *) -(* | NatOpS op v1 v2 v3 K Ko : *) -(* nat_op_interp op v1 v2 = Some v3 → *) -(* head_step (NatOp op (Val v1) (Val v2)) K *) -(* (Val v3) K Ko (0, 0) *) -(* | IfTrueS n e1 e2 K Ko : *) -(* n > 0 → *) -(* head_step (If (Val (LitV n)) e1 e2) K *) -(* e1 K Ko (0, 0) *) -(* | IfFalseS n e1 e2 K Ko : *) -(* n = 0 → *) -(* head_step (If (Val (LitV n)) e1 e2) K *) -(* e2 K Ko (0, 0) *) - -(* | ShiftS (e : expr (inc (inc S))) K Ko f : *) -(* ResetK ∉ K -> *) -(* f = cont_to_rec (ResetK::K) -> *) -(* head_step (Shift (Val $ RecV e)) K *) -(* (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e) *) -(* (Val (shift (Inc := inc) f))) *) -(* (Val $ RecV e)) [] Ko (1, 1) *) - -(* | ResetS v K Ko : *) -(* head_step (Reset (Val v)) K (Val v) K Ko (1, 1). *) - - -(* (* | ValueS v σ K C: *) *) -(* (* head_step (Val v) σ (C::K) (ctx_el_to_expr C (Val v)) σ K (0, 0) *) *) - -(* (* | ResetShiftS e σ K E: *) *) -(* (* head_step *) *) -(* (* (Reset (fill E (Shift e))) σ *) *) -(* (* (Reset (subst (Inc := inc) e (Val $ ContV $ ResetK E))) σ K (1,0). *) *) - -(* Lemma head_step_io_01 {S} (e1 e2 : expr S) K K' Ko n m : *) -(* head_step e1 K e2 K' Ko (n,m) → m = 0 ∨ m = 1. *) -(* Proof. inversion 1; eauto. Qed. *) -(* (* Lemma head_step_unfold_01 {S} (e1 e2 : expr S) σ1 σ2 K K' n m : *) *) -(* (* head_step e1 σ1 K e2 σ2 K' (n,m) → n = 0 ∨ n = 1. *) *) -(* (* Proof. inversion 1; eauto. Qed. *) *) -(* (* Lemma head_step_no_io {S} (e1 e2 : expr S) σ1 σ2 K K' Ko n : *) *) -(* (* head_step e1 σ1 K e2 σ2 K' Ko (n,0) → σ1 = σ2. *) *) -(* (* Proof. inversion 1; eauto. Qed. *) *) - -(* (** Carbonara from heap lang *) *) - -(* Global Instance ctx_el_to_expr_inj {S} (C : ectx_el S) : Inj (=) (=) (ctx_el_to_expr C). *) -(* Proof. case: C => [] >; simpl in*; congruence. Qed. *) Global Instance fill_inj {S} (Ki : cont S) : Inj (=) (=) (fill Ki). Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. @@ -544,82 +368,6 @@ Proof. Qed. -(* FIXME maybe *) -(* Inductive prim_step {S} : ∀ (e1 : expr S) *) -(* (e2 : expr S) (nm : nat * nat), Prop := *) -(* (* | Ectx_step e1 σ1 e2 σ2 nm (K1 K2 : ectx S) e1' e2' : *) *) -(* (* e1 = fill K1 e1' -> *) *) -(* (* e2 = fill K2 e2' -> *) *) -(* (* ResetK ∉ K1 -> *) *) -(* (* head_step e1' σ1 K1 e2' σ2 K2 nm -> *) *) -(* (* prim_step e1 σ1 e2 σ2 nm *) *) -(* | Shift_step e1 K Ki Ko e2 Ki' nm : *) -(* (Ki, Ko) = shift_context K -> *) -(* head_step e1 Ki e2 Ki' Ko nm -> *) -(* prim_step (fill K e1) (fill (Ki' ++ Ko) e2) nm. *) -(* (* CHECK *) *) - -(* (* Lemma prim_step_pure {S} (e1 e2 : expr S) σ1 σ2 n : *) *) -(* (* prim_step e1 σ1 e2 σ2 (n,0) → σ1 = σ2. *) *) -(* (* Proof. *) *) -(* (* inversion 1; simplify_eq/=. by inversion H1. *) *) -(* (* Qed. *) *) - -(* Inductive prim_steps {S} : expr S → expr S → nat * nat → Prop := *) -(* | prim_steps_zero e : *) -(* prim_steps e e (0, 0) *) -(* | prim_steps_abit e1 e2 e3 n1 m1 n2 m2 : *) -(* prim_step e1 e2 (n1, m1) → *) -(* prim_steps e2 e3 (n2, m2) → *) -(* prim_steps e1 e3 (plus n1 n2, plus m1 m2) *) -(* . *) - -(* Lemma Ectx_step' {S} (K1 K2 : ectx S) e1 e2 efs : *) -(* head_step e1 K1 e2 K2 [] efs → *) -(* ResetK ∉ K1 -> *) -(* prim_step (fill K1 e1) (fill K2 e2) efs. *) -(* Proof. *) -(* intros. rewrite -(app_nil_r K2). *) -(* econstructor; eauto. by apply no_reset_shift_context_ident. *) -(* Qed. *) - -(* Lemma prim_steps_app {S} nm1 nm2 (e1 e2 e3 : expr S) : *) -(* prim_steps e1 e2 nm1 → prim_steps e2 e3 nm2 → *) -(* prim_steps e1 e3 (plus nm1.1 nm2.1, plus nm1.2 nm2.2). *) -(* Proof. *) -(* intros Hst. revert nm2. *) -(* induction Hst; intros [n' m']; simplify_eq/=; first done. *) -(* rewrite -!Nat.add_assoc. intros Hsts. *) -(* econstructor; eauto. *) -(* by apply (IHHst (n',m')). *) -(* Qed. *) - -(* Lemma prim_step_steps {S} nm (e1 e2 : expr S) : *) -(* prim_step e1 e2 nm → prim_steps e1 e2 nm. *) -(* Proof. *) -(* destruct nm as [n m]. intro Hs. *) -(* rewrite -(Nat.add_0_r n). *) -(* rewrite -(Nat.add_0_r m). *) -(* econstructor; eauto. *) -(* by constructor. *) -(* Qed. *) - -(* Lemma prim_step_steps_steps {S} (e1 e2 e3 : expr S) nm1 nm2 nm3 : *) -(* nm3 = (plus nm1.1 nm2.1, plus nm1.2 nm2.2) -> *) -(* prim_step e1 e2 nm1 → prim_steps e2 e3 nm2 -> prim_steps e1 e3 nm3. *) -(* Proof. *) -(* intros -> H G. *) -(* eapply prim_steps_app; last apply G. *) -(* apply prim_step_steps, H. *) -(* Qed. *) - -(* Lemma head_step_prim_step {S} (e1 e2 : expr S) nm : *) -(* head_step e1 [] e2 [] [] nm -> prim_step e1 e2 nm. *) -(* Proof. *) -(* move => H; apply Ectx_step' in H => //=. apply not_elem_of_nil. *) -(* Qed. *) - - (*** Abstract Machine semantics *) Definition Mcont {S} := list $ cont S. @@ -685,10 +433,6 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := Ccont (AppContLK v k) (ContV k') mk ===> Ccont k' v (k :: mk) / (2, 1) - (* | Ccont_cont : forall v k k' mk, *) - (* Ccont (AppLK v k) (ContV k') mk ===> *) - (* Ccont (cont_compose k k') v mk / (2, 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) @@ -707,7 +451,7 @@ Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := Cmcont (k :: mk) v ===> Ccont k v mk / (1,1) | Cmcont_ret : forall v, - Cmcont [] v ===> Cret v / (1, 1) + Cmcont [] v ===> Cret v / (1, 1) where "c ===> c' / nm" := (Cred c c' nm). @@ -739,93 +483,90 @@ Inductive steps {S} : config S -> config S -> (nat * nat) -> Prop := (* - *) -(* (* One of the rule has been changed slightly *) *) -(* Lemma old_new_confluence {S} : forall (K K' : cont S) mk v v' n m, *) -(* steps (Ccont K' v (K::mk)) (Ccont K v' mk) (n, m+1) -> *) -(* steps (Ccont (cont_compose K K') v mk) (Ccont K v' mk) (n, m). *) -(* Proof. *) -(* intros until K'. revert K. induction K'; intros. *) -(* - simpl in *. inversion H as []; subst. *) -(* { contradict H3. clear H. induction mk; congruence. } *) -(* inversion H0; subst. *) -(* inversion H1; subst. *) -(* inversion H7; subst. *) -(* simpl in H5. *) -(* replace (0 + (0 + n'0)) with (n'0) by lia. *) -(* assert (m'0 = m) as -> by lia. *) -(* eapply H8. *) -(* - simpl in *. inversion H as []; subst; first lia. *) -(* inversion H0; subst. simpl in *. *) -(* (* inversion H1; subst. *) *) -(* replace m with (0+m) by lia. *) -(* replace n' with (0+n') by lia. *) -(* constructor 2 with (Ceval (if n =? 0 then e2 else e1) (cont_compose K K') mk); first constructor. *) -(* subst. *) - - -Definition config_to_expr {S} (c : config S) := - match c with - | Ceval e k mk => meta_fill mk (fill k e) - | Ccont k v mk => meta_fill mk (fill k (Val v)) - | Cmcont mk v => meta_fill mk (Val v) - | Cexpr e => e - | Cret v => Val v - end. -(* i mean not really bcause missing [reset]s *) -(* is the solution just adding a reset between each metacontext? - maybe? but idk if we would want that *) - -(* Definition meta_fill_reset {S} (mk : Mcont S) e := *) -(* fold_left (λ e k, Reset (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 | Tcont : ty → ty. - -Inductive typed {S : Set} (Γ : S -> ty) : expr S → ty → Prop := -| 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) : val S → ty → Prop := -| typed_Lit n : - typed_val Γ (LitV n) Tnat -| typed_RecV (τ1 τ2 : ty) (e : expr (inc (inc S))) : - typed (Γ ▹ (Tarr τ1 τ2) ▹ τ1) e τ2 → - typed_val Γ (RecV e) (Tarr τ1 τ2) -. +| 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) *) +(* . *) Declare Scope syn_scope. Delimit Scope syn_scope with syn. -Coercion Val : val >-> expr. Coercion App : expr >-> Funclass. (* Coercion AppLK : expr >-> Funclass. *) @@ -952,8 +693,8 @@ 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. +(* Notation "A 'Cont'" := (Tcont A%typ) *) +(* (at level 60) : typ_scope. *) Declare Scope typing_scope. Delimit Scope typing_scope with typing. @@ -962,13 +703,13 @@ 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 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 τ - }. +(* Global Instance TypingNotationVal {S : Set} : TypingNotation (S -> ty) (val S) ty := { *) +(* __typing Γ e τ := typed_val Γ e τ *) +(* }. *) Module SynExamples. @@ -985,7 +726,7 @@ Module SynExamples. Open Scope typing_scope. - Example test8 : Prop := (empty_env ⊢ (# 0) : ℕ). + (* Example test8 : Prop := (empty_env ⊢ (# 0) : ℕ). *) End SynExamples. (* Definition compute_head_step {S} *) From b2c94538a8dbfc69bf3b98060eb8f9b54cc29849 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Mon, 26 Feb 2024 17:32:26 +0100 Subject: [PATCH 105/114] fixed some rules + a tiny example that takes way too long to prove Needs more automation --- theories/input_lang_delim/interp.v | 31 ++++++++++++++++++++++++------ theories/input_lang_delim/lang.v | 15 +++++++++++++++ 2 files changed, 40 insertions(+), 6 deletions(-) diff --git a/theories/input_lang_delim/interp.v b/theories/input_lang_delim/interp.v index ef7fc8d..9de0fb9 100644 --- a/theories/input_lang_delim/interp.v +++ b/theories/input_lang_delim/interp.v @@ -277,34 +277,53 @@ Section weakestpre. Qed. - Lemma wp_pop_end (v : ITV) (k : IT -n> IT) {Hk : IT_hom k} + Lemma wp_pop_end (v : ITV) Φ s : has_substate [] -∗ ▷ (£ 1 -∗ has_substate [] -∗ WP@{rs} IT_of_V v @ s {{ Φ }}) -∗ - WP@{rs} k $ 𝒫 (IT_of_V v) @ s {{ Φ }}. + WP@{rs} 𝒫 (IT_of_V v) @ s {{ Φ }}. Proof. iIntros "Hs Ha". - rewrite get_val_ITV. simpl. rewrite hom_vis. + rewrite get_val_ITV. simpl. iApply (wp_subreify _ _ _ _ _ _ _ ((Next $ IT_of_V v)) with "Hs"). - simpl. reflexivity. - reflexivity. - done. Qed. - Lemma wp_pop_cons (σ : state) (v : ITV) (k : IT -n> IT) {Hk : IT_hom k} + 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} k $ 𝒫 (IT_of_V v) @ s {{ Φ }}. + WP@{rs} 𝒫 (IT_of_V v) @ s {{ Φ }}. Proof. iIntros "Hs Ha". - rewrite get_val_ITV. simpl. rewrite hom_vis. + rewrite get_val_ITV. simpl. iApply (wp_subreify _ _ _ _ _ _ _ ((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 : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ + WP@{rs} later_car (laterO_ap k' e) @ s {{ Φ }}) -∗ + WP@{rs} k (APP_CONT e k') @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + unfold APP_CONT. simpl. rewrite hom_vis. + iApply (wp_subreify _ _ _ _ _ _ _ (laterO_ap k' e) with "Hs"). + - simpl. 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. diff --git a/theories/input_lang_delim/lang.v b/theories/input_lang_delim/lang.v index aaa60b5..66aadb3 100644 --- a/theories/input_lang_delim/lang.v +++ b/theories/input_lang_delim/lang.v @@ -655,9 +655,24 @@ Global Instance AppNotationRK {S : Set} {F : Set -> Type} `{AsSynExpr F} : AppNo __app e K := cont_compose K (AppRK (__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) := { + __app_cont e₁ e₂ := AppCont (__asSynExpr e₁) (__asSynExpr e₂) + }. + +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) := { + __app_cont e K := cont_compose K (AppContRK (__asSynExpr e) END) + }. + 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" := (__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. From 40d672bb7cd00ceb2e7bb499240db9165029efaa Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 27 Feb 2024 09:04:17 +0100 Subject: [PATCH 106/114] Add the delim language --- theories/examples/input_lang_delim/example.v | 204 ++++ theories/examples/input_lang_delim/interp.v | 1136 ++++++++++++++++++ theories/examples/input_lang_delim/lang.v | 838 +++++++++++++ theories/examples/input_lang_delim/logrel.v | 789 ++++++++++++ 4 files changed, 2967 insertions(+) create mode 100644 theories/examples/input_lang_delim/example.v create mode 100644 theories/examples/input_lang_delim/interp.v create mode 100644 theories/examples/input_lang_delim/lang.v create mode 100644 theories/examples/input_lang_delim/logrel.v diff --git a/theories/examples/input_lang_delim/example.v b/theories/examples/input_lang_delim/example.v new file mode 100644 index 0000000..940ae93 --- /dev/null +++ b/theories/examples/input_lang_delim/example.v @@ -0,0 +1,204 @@ +From gitrees Require Import gitree. +From gitrees.examples.input_lang_delim Require Import lang interp. +Require Import gitrees.lang_generic. +From iris.algebra Require Import gmap excl auth gmap_view. +From iris.proofmode Require Import base classes tactics environments. +From iris.base_logic Require Import algebra. + +Open Scope syn_scope. + +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). + +Example 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 Σ). + +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 *) + lazymatch goal with + | |- context G [ofe_mor_car _ _ RESET ?t] => set (e := t) + end. + lazymatch goal with + | |- context G [ofe_mor_car _ _ 𝒫 (?kk (ofe_mor_car _ _ RESET e))] => remember (𝒫 ◎ kk) as k + end. + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) + end. + assert (NonExpansive k). + { subst. intros ????. solve_proper. } + assert (α ≡ (λne x, k x) (RESET e)) as -> by (by simpl; subst). + clear α. + iApply (wp_reset with "Hσ"). + { subst. simpl. apply IT_hom_compose; first apply _. + refine (IT_HOM _ _ _ _ _ ). + - apply NATOP_Tick. by rewrite !hom_tick. + - rewrite !hom_vis. f_equiv. intro. simpl. done. + - by rewrite !hom_err. + } + iIntros "!> Hl Hσ". + simpl. + + (* then, shift *) + lazymatch goal with + | |- context G [ofe_mor_car _ _ SHIFT ?e] => set (f := e) + (* envs_entails _ (wp _ (ofe_mor_car _ _ SHIFT ?e) _ _ _) => idtac *) + end. + lazymatch goal with + | |- context G [?kk (ofe_mor_car _ _ SHIFT f)] => remember (𝒫 ◎ kk) as k' + end. + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) + end. + assert (NonExpansive k'). + { subst. intros ????. solve_proper. } + assert (α ≡ (λne y, k' y) (SHIFT f)) as -> by (by simpl; subst). + clear α. + iApply (wp_shift with "Hσ"). + { subst. simpl. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. f_equiv. by intro. + - by rewrite !hom_err. + } + iIntros "!>_ Hσ". + simpl. + + (* the rest *) + lazymatch goal with + | |- context G [ofe_mor_car _ _ (get_val ?f) (_ 5)] => remember f as func + end. + lazymatch goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ (NATOP _) ?x) ?y] => + remember x as ex; remember y as ey + end. + remember (λ (x y : IT), 𝒫 $ NATOP (do_natop lang.Add) x y) as kplus. + assert (NonExpansive2 kplus). + { subst. intros ???????. solve_proper. } + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) + end. + assert (α ≡ kplus (func (Ret 5)) (func (Ret 6))) as ->. + { subst kplus α ex ey. f_equiv. f_equiv. + - f_equiv. rewrite -IT_of_V_Ret. apply get_val_ITV'. + - rewrite -IT_of_V_Ret. apply get_val_ITV'. + } + subst func. simpl. + clear α. + lazymatch goal with + | |- context G [kplus ?scd (ofe_mor_car _ _ (get_fun ?f) + (ofe_mor_car _ _ Fun ?g))] => remember f as func1; remember g as gfunc; remember scd as snd + end. + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) + end. + assert (α ≡ kplus snd (func1 gfunc)) as ->. + { subst α kplus func1 gfunc. repeat f_equiv; first by subst. + simpl. by rewrite get_fun_fun. + } + subst func1 gfunc. simpl. + remember (λ x, kplus snd x) as kkkk. + assert (NonExpansive kkkk) by solve_proper. + clear α. + lazymatch goal with + | |- context G [kkkk ?e] => remember e as newe + end. + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) + end. + + assert (α ≡ (λne x, kkkk x) newe) as -> by (by subst). + subst newe; clear α. + iApply (wp_app_cont with "Hσ"). + { subst. simpl. + simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite !hom_tick. + - rewrite !hom_vis. f_equiv. intro. by simpl. + - by rewrite !hom_err. + } + simpl. + iIntros "!> _ Hσ". + rewrite later_map_Next -Tick_eq. + iApply wp_tick. iNext. + subst. simpl. + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) + end. + assert (α ≡ 𝒫 (IT_of_V $ RetV 9)) as ->. + { subst α. f_equiv. by rewrite NATOP_Ret. } + iApply (wp_pop_cons with "Hσ"). + iIntros "!> _ Hσ". + simpl. + lazymatch goal with + | |- context G [ofe_mor_car _ _ (get_fun ?f) + (ofe_mor_car _ _ Fun ?g)] => remember f as func1; remember g as gfunc + end. + clear α. + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => + assert (t ≡ 𝒫 $ NATOP (do_natop lang.Add) (func1 gfunc) (IT_of_V (RetV 9))) + as -> by (repeat f_equiv; apply get_fun_fun) + end. + subst. simpl. + remember (λ x : IT, 𝒫 (NATOP (do_natop lang.Add) x (IT_of_V (RetV 9)))) as kkkk. + assert (NonExpansive kkkk) by solve_proper. + + lazymatch goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ (NATOP _) ?e) (IT_of_V (ofe_mor_car _ _ RetV 9))] => remember e as newe + end. + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => + assert (t ≡ (λne x, kkkk x) newe) + as -> by by subst + end. + subst newe. + iApply (wp_app_cont with "Hσ"). + { subst. simpl. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite NATOP_ITV_Tick_l hom_tick. + - rewrite NATOP_ITV_Vis_l hom_vis. f_equiv. by intro. + - by rewrite NATOP_Err_l hom_err. + } + iIntros "!> _ Hσ". simpl. + rewrite later_map_Next -Tick_eq. iApply wp_tick. iNext. + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => assert (t ≡ 𝒫 (IT_of_V $ RetV 8)) + as -> by (f_equiv; by rewrite NATOP_Ret) + end. + iApply (wp_pop_cons with "Hσ"). + iIntros "!> _ Hσ". + simpl. subst kkkk. + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => assert (t ≡ 𝒫 (IT_of_V $ RetV 17)) + as -> by (f_equiv; by rewrite NATOP_Ret) + end. + iApply (wp_pop_cons with "Hσ"). + iIntros "!> _ Hσ". + simpl. + lazymatch goal with + | |- envs_entails _ (wp _ ?t _ _ _) => assert (t ≡ 𝒫 (IT_of_V $ RetV 18)) + as -> by (f_equiv; by rewrite NATOP_Ret) + end. + iApply (wp_pop_end with "Hσ"). + iIntros "!> _ _". + iApply wp_val. done. +Qed. diff --git a/theories/examples/input_lang_delim/interp.v b/theories/examples/input_lang_delim/interp.v new file mode 100644 index 0000000..9cbe6f5 --- /dev/null +++ b/theories/examples/input_lang_delim/interp.v @@ -0,0 +1,1136 @@ +(* From Equations Require Import Equations. *) +From gitrees Require Import gitree. +From gitrees.examples.input_lang_delim Require Import lang. +Require Import gitrees.lang_generic. +From iris.algebra Require Import gmap excl auth gmap_view. +From iris.proofmode Require Import classes tactics. +From iris.base_logic Require Import algebra. +From iris.heap_lang Require Export locations. + +Require Import Binding.Lib. +Require Import Binding.Set. + + +(** * State *) + +(* Definition stateF : oFunctor := (gmapOF unitO (▶ ∙))%OF. *) + +(* #[local] Instance state_inhabited : Inhabited (stateF ♯ unitO). *) +(* Proof. apply _. Qed. *) +(* #[local] Instance state_cofe X `{!Cofe X} : Cofe (stateF ♯ X). *) +(* Proof. apply _. Qed. *) + +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. +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 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 : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} 𝒫 (later_car ( f (laterO_map k))) @ s {{ Φ }}) -∗ + WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + unfold SHIFT. simpl. + rewrite hom_vis. + iApply (wp_subreify _ _ _ _ _ _ _ (later_map 𝒫 $ f (laterO_map k)) with "Hs"). + { + simpl. + repeat f_equiv. + - rewrite ccompose_id_l. intro. simpl. by rewrite ofe_iso_21. + - reflexivity. + } + { by rewrite later_map_Next. } + iModIntro. + iApply "Ha". + Qed. + + + + Lemma wp_reset (σ : state) (e : laterO IT) (k : IT -n> IT) {Hk : IT_hom k} + Φ s : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ + WP@{rs} 𝒫 (later_car e) @ s {{ Φ }}) -∗ + WP@{rs} k $ (RESET e) @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + unfold RESET. simpl. rewrite hom_vis. + iApply (wp_subreify _ _ _ _ _ _ _ (laterO_map 𝒫 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 : 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 _ _ _ _ _ _ _ ((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 _ _ _ _ _ _ _ ((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 : + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ + WP@{rs} later_car (laterO_ap k' e) @ s {{ Φ }}) -∗ + WP@{rs} k (APP_CONT e k') @ s {{ Φ }}. + Proof. + iIntros "Hs Ha". + unfold APP_CONT. simpl. rewrite hom_vis. + iApply (wp_subreify _ _ _ _ _ _ _ (laterO_ap k' e) with "Hs"). + - simpl. 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 sz). + Context {subR : subReifier reify_delim rs}. + Context {R} `{CR : !Cofe R}. + Context `{!SubOfe natO R}. + Context `{!SubOfe unitO R}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Notation state := (stateF ♯ IT). + 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. + + (** * Interpreting individual operators *) + + (** ** RESET *) + + Program Definition interp_reset {S} (e : S -n> IT) : S -n> IT := + λne env, RESET (Next $ e env). + Solve All Obligations with solve_proper. + + (** ** SHIFT *) + + Program Definition interp_shift {S} (e : @interp_scope F R _ (inc S) -n> IT) : + interp_scope S -n> IT := + λne env, SHIFT (λne (k : laterO IT -n> laterO IT), + Next (e (@extend_scope F R _ _ env (λit x, Tau (k (Next x)))))). + Next Obligation. solve_proper. Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros [| a]; simpl; last solve_proper. + repeat f_equiv. + intros ?; simpl. + by repeat f_equiv. + Qed. + Next Obligation. + solve_proper_prepare. + repeat f_equiv. + intros ?; simpl. + repeat f_equiv. + intros [| a]; simpl; last solve_proper. + 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). + Solve All Obligations with solve_proper_please. + + Global Instance interp_natop_ne A op : NonExpansive2 (@interp_natop A op). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_natop. + + + (** ** REC *) + Opaque laterO_map. + Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) + : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := + λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), + body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + f_equiv; intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + do 3 f_equiv; intros ??; simpl; f_equiv; + intros [| [| y']]; simpl; solve_proper. + Qed. + Next Obligation. + intros. + solve_proper_prepare. + by do 2 f_equiv. + Qed. + + Program Definition interp_rec {S : Set} + (body : @interp_scope F R _ (inc (inc S)) -n> IT) : + @interp_scope F R _ S -n> IT := + mmuu (interp_rec_pre body). + + Program Definition ir_unf {S : Set} + (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (@extend_scope F R _ _ + (@extend_scope F R _ _ env (interp_rec body env)) + a). + Next Obligation. + intros. + solve_proper_prepare. + f_equiv. intros [| [| y']]; simpl; solve_proper. + Qed. + + Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : + interp_rec body env ≡ Fun $ Next $ ir_unf body env. + Proof. + trans (interp_rec_pre body (Next (interp_rec body)) env). + { f_equiv. rewrite /interp_rec. apply mmuu_unfold. } + simpl. rewrite laterO_map_Next. repeat f_equiv. + simpl. unfold ir_unf. intro. simpl. reflexivity. + Qed. + + + (** ** APP *) + 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 ]. + Global Instance interp_app_ne A : NonExpansive2 (@interp_app A). + Proof. solve_proper. Qed. + Typeclasses Opaque interp_app. + + (** ** APP_CONT *) + + 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)), + APP_CONT (Next x) f) + (k env)) + (e env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_app_cont_ne A : NonExpansive2 (@interp_app_cont A). + Proof. + intros n??????. rewrite /interp_app_cont. intro. simpl. + repeat f_equiv; last done. intro. simpl. by repeat f_equiv. + Qed. + (* Typeclasses Opaque interp_app_cont. *) + + (** ** IF *) + Program Definition interp_if {A} (t0 t1 t2 : A -n> IT) : A -n> IT := + λne env, IF (t0 env) (t1 env) (t2 env). + Solve All Obligations with first [ solve_proper | solve_proper_please ]. + Global Instance interp_if_ne A n : + Proper ((dist n) ==> (dist n) ==> (dist n) ==> (dist n)) (@interp_if A). + Proof. solve_proper. Qed. + + (** ** NAT *) + Program Definition interp_nat (n : nat) {A} : A -n> IT := + λne env, Ret n. + + (** ** CONT *) + Program Definition interp_cont_val {S} (K : S -n> (IT -n> IT)) : S -n> IT := + λne env, (λit x, Tau (laterO_map (𝒫 ◎ K env) (Next x))). + Solve All Obligations with solve_proper_please. + + (* Program Definition interp_cont {S} (e : @interp_scope F R _ (inc S) -n> IT) : *) + (* interp_scope S -n> IT := *) + (* λne env, (Fun (Next (λne x, Tick $ e (@extend_scope F R _ _ env x)))). *) + (* Next Obligation. *) + (* solve_proper_prepare. repeat f_equiv. *) + (* intros [|a]; eauto. *) + (* Qed. *) + (* Next Obligation. *) + (* solve_proper_prepare. *) + (* repeat f_equiv. *) + (* intro. simpl. repeat f_equiv. *) + (* intros [|z]; eauto. *) + (* Qed. *) + + (* #[local] Instance interp_reset_full_ne {S} (f : @interp_scope F R _ S -n> IT): *) + (* NonExpansive (λ env, interp_reset (f env)). *) + (* Proof. solve_proper. Qed. *) + + Program Definition interp_ifk {A} (e1 e2 : A -n> IT) (K : A -n> IT -n> IT) : + A -n> (IT -n> IT) := + λne env b, (K env) $ interp_if (λne env, b) e1 e2 env. + Solve All Obligations with solve_proper. + + 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. + + 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. + + Program Definition interp_app_contrk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_app_cont q (λne env, t) env. + Next Obligation. intros A q K t n ????. done. Qed. + Next Obligation. + intros A q K env n ???. simpl. by repeat f_equiv. + Qed. + Next Obligation. + intros A q K n ???. intro. simpl. f_equiv. + - by f_equiv. + - f_equiv. f_equiv. intro. simpl. by repeat f_equiv. + Qed. + + Program Definition interp_app_contlk {A} (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_app_cont (λne env, t) q env. + Next Obligation. intros A q K t n ????. done. Qed. + Next Obligation. + intros A q K env n ???. simpl. repeat f_equiv. + intro. simpl. by repeat f_equiv. + Qed. + Next Obligation. + intros A q K n ???. intro. simpl. f_equiv. + - by f_equiv. + - f_equiv; last by f_equiv. f_equiv. intro. simpl. repeat f_equiv. + Qed. + + Program Definition interp_natoprk {A} (op : nat_op) (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_natop op q (λne env, t) env. + Solve All Obligations with solve_proper. + + Program Definition interp_natoplk {A} (op : nat_op) (q : A -n> IT) (K : A -n> IT -n> IT) : + A -n> IT -n> IT := + λne env t, (K env) $ interp_natop op (λne env, t) q env. + Solve All Obligations with solve_proper. + + (** Interpretation for all the syntactic categories: values, expressions, contexts *) + Fixpoint interp_val {S} (v : val S) : interp_scope S -n> IT := + match v with + | LitV n => interp_nat n + | RecV e => interp_rec (interp_expr e) + | ContV K => interp_cont_val (interp_cont K) + end + with + interp_expr {S} (e : expr S) : interp_scope S -n> IT := + match e with + | Val v => interp_val v + | Var x => interp_var x + | App e1 e2 => interp_app (interp_expr e1) (interp_expr e2) + | AppCont e1 e2 => interp_app_cont (interp_expr e1) (interp_expr e2) + | NatOp op e1 e2 => interp_natop op (interp_expr e1) (interp_expr e2) + | If e e1 e2 => interp_if (interp_expr e) (interp_expr e1) (interp_expr e2) + | Shift e => interp_shift (interp_expr e) + | Reset e => interp_reset (interp_expr e) + end + with + interp_cont {S} (K : cont S) : interp_scope S -n> (IT -n> IT) := + 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) + | 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) + | NatOpRK op e K => interp_natoprk op (interp_expr e) (interp_cont K) + end. + + (** ** Interpretation of configurations *) + + Program Definition map_meta_cont {S} (mk : Mcont S) : @interp_scope F R _ S -n> state := + λne env, list_fmap _ _ (λ k, laterO_map (𝒫 ◎ (interp_cont k env))) mk. + Next Obligation. intros S mk n ???. apply list_fmap_ext_ne. intro. by repeat f_equiv. Qed. + + Lemma map_meta_cont_nil {S} env : + map_meta_cont ([] : Mcont S) env = []. + Proof. done. Qed. + + Lemma map_meta_cont_cons {S} (k : cont S) (mk : Mcont S) env : + map_meta_cont (k::mk) env = (laterO_map (𝒫 ◎ interp_cont k env)) :: (map_meta_cont mk env). + Proof. done. Qed. + + Program Definition interp_config {S} (C : config S) : @interp_scope F R _ S -n> (prodO IT state) := + match C with + | Cexpr e => λne env, (𝒫 (interp_expr e env), []) : prodO IT state + | Ceval e K mk => λne env, (𝒫 (interp_cont K env (interp_expr e env)), + map_meta_cont mk env) + | Ccont K v mk => λne env, (𝒫 (interp_cont K env (interp_val v env)), + map_meta_cont mk env) + | Cmcont mk v => λne env, (𝒫 (interp_val v env), + map_meta_cont mk env) + | Cret v => λne env, (interp_val v env, []) + end. + Solve Obligations with try solve_proper. + Next Obligation. + intros S C e K mk <- n???. by repeat f_equiv. + Qed. + Next Obligation. + intros S C v K mk <- n???. by repeat f_equiv. + Qed. + Next Obligation. + intros S C v mk <- n???. by repeat f_equiv. + Qed. + + + Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) + : AsVal (interp_val v D). + Proof. + destruct v; simpl. + - apply _. + - rewrite interp_rec_unfold. apply _. + - apply _. + Qed. + + Global Instance ArrEquiv {A B : Set} : Equiv (A [→] B) := + fun f g => ∀ x, f x = g x. + + Global Instance ArrDist {A B : Set} `{Dist B} : Dist (A [→] B) := + fun n => fun f g => ∀ x, f x ≡{n}≡ g x. + + Global Instance ren_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@ren_scope F _ CR S S'). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - apply Hs. + - apply HE. + Qed. + + Lemma interp_expr_ren {S S'} env + (δ : S [→] S') (e : expr S) : + interp_expr (fmap δ e) env ≡ interp_expr e (ren_scope δ env) + with interp_val_ren {S S'} env + (δ : S [→] S') (e : val S) : + interp_val (fmap δ e) env ≡ interp_val e (ren_scope δ env) + with interp_cont_ren {S S'} env + (δ : S [→] S') (K : cont S) : + interp_cont (fmap δ K) env ≡ interp_cont K (ren_scope δ env). + Proof. + - destruct e; simpl; try by repeat 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. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_ren. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done; last done. + by iRewrite - "IH". + + repeat f_equiv. + intro. simpl. repeat f_equiv. + 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. + Qed. + + + (* Lemma interp_ectx_ren {S S'} env (δ : S [→] S') (K : ectx S) : *) + (* interp_ectx (fmap δ K) env ≡ interp_ectx K (ren_scope δ env). *) + (* Proof. *) + (* induction K; intros ?; simpl; eauto. *) + (* destruct a; simpl; try (etrans; first by apply IHK); repeat f_equiv; *) + (* try solve [by apply interp_expr_ren | by apply interp_val_ren]. *) + (* 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. + Qed. + + Program Definition sub_scope {S S'} (δ : S [⇒] S') (env : interp_scope S') + : interp_scope S := λne x, interp_expr (δ x) env. + + Global Instance SubEquiv {A B : Set} : Equiv (A [⇒] B) := fun f g => ∀ x, f x = g x. + + Global Instance sub_scope_proper {S S'} : + Proper ((≡) ==> (≡) ==> (≡)) (@sub_scope S S'). + Proof. + intros D D' HE s1 s2 Hs. + intros x; simpl. + f_equiv. + - f_equiv. + apply HE. + - apply Hs. + Qed. + + Lemma interp_expr_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_expr (bind δ e) env ≡ interp_expr e (sub_scope δ env) + with interp_val_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') e : + interp_val (bind δ e) env ≡ interp_val e (sub_scope δ env) + with interp_cont_subst {S S'} (env : interp_scope S') + (δ : S [⇒] S') K : + interp_cont (bind δ K) env ≡ interp_cont K (sub_scope δ env). + Proof. + - destruct e; simpl; try 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. + - destruct e; simpl. + + reflexivity. + + clear -interp_expr_subst. + apply bi.siProp.internal_eq_soundness. + iLöb as "IH". + rewrite {2}interp_rec_unfold. + rewrite {2}(interp_rec_unfold (interp_expr e)). + do 1 iApply f_equivI. iNext. + iApply internal_eq_pointwise. + rewrite /ir_unf. iIntros (x). simpl. + rewrite interp_expr_subst. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (y'). + destruct y' as [| [| y]]; simpl; first done. + * by iRewrite - "IH". + * do 2 rewrite interp_expr_ren. + iApply f_equivI. + iApply internal_eq_pointwise. + iIntros (z). + done. + + repeat f_equiv. intro. simpl. repeat f_equiv. + 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)]. + + 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 is a homomorphism (for some constructors) *) + + #[global] Instance interp_cont_hom_emp {S} env : + IT_hom (interp_cont (END : cont S) env). + Proof. + simple refine (IT_HOM _ _ _ _ _); intros; auto. + simpl. f_equiv. intro. simpl. + by rewrite laterO_map_id. + Qed. + + + #[global] Instance interp_cont_hom_if {S} + (K : cont S) (e1 e2 : expr S) env : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (IfK e1 e2 K) env). + Proof. + intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - by rewrite -hom_tick -IF_Tick. + - trans (Vis op i (laterO_map (λne y, + (λne t : IT, interp_cont K env (IF t (interp_expr e1 env) (interp_expr e2 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 IF_Err). + apply hom_err. + Qed. + + + #[global] Instance interp_cont_hom_appr {S} (K : cont S) + (e : expr S) env : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppRK e 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. + Qed. + + #[global] Instance interp_cont_hom_appl {S} (K : cont S) + (v : val S) (env : interp_scope S) : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppLK v 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. + Qed. + + + #[global] Instance interp_cont_hom_app_contr {S} (K : cont S) + (e : expr S) env : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppContRK e 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. + Qed. + + #[global] Instance interp_cont_hom_app_contl {S} (K : cont S) + (v : val S) (env : interp_scope S) : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (AppContLK v K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -hom_tick. f_equiv. + rewrite get_val_ITV. simpl. rewrite hom_tick. + f_equiv. by rewrite get_val_ITV. + - rewrite get_val_ITV. simpl. rewrite get_fun_vis. rewrite hom_vis. + f_equiv. intro. simpl. rewrite -laterO_map_compose. + f_equiv. f_equiv. intro. simpl. + f_equiv. by rewrite get_val_ITV. + - rewrite get_val_ITV. simpl. rewrite get_fun_err. apply hom_err. + Qed. + + + #[global] Instance interp_cont_hom_natopr {S} (K : cont S) + (e : expr S) op env : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (NatOpRK op e K) env). + Proof. + intros H. 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. + Qed. + + #[global] Instance interp_cont_hom_natopl {S} (K : cont S) + (v : val S) op (env : interp_scope S) : + IT_hom (interp_cont K env) -> + IT_hom (interp_cont (NatOpLK op v K) env). + Proof. + intros H. simple refine (IT_HOM _ _ _ _ _); intros; simpl. + - rewrite -hom_tick. f_equiv. by rewrite -NATOP_ITV_Tick_l. + - trans (Vis op0 i (laterO_map (λne y, + (λne t : IT, interp_cont K env (NATOP (do_natop op) t (interp_val v env))) y) ◎ ko)); + last (simpl; do 3 f_equiv; by intro). + rewrite NATOP_ITV_Vis_l hom_vis. f_equiv. intro. simpl. + by rewrite -laterO_map_compose. + - trans (interp_cont K env (Err e)). + + f_equiv. by apply NATOP_Err_l, interp_val_asval. + + apply hom_err. + Qed. + + + Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). + Proof. + intros. + by rewrite IT_rec1_ret. + Qed. + + + #[global] Instance interp_cont_hom {S} + (K : cont S) env : + IT_hom (interp_cont K env). + Proof. + induction K; simpl; apply _. + Qed. + + + + (** ** Finally, preservation of reductions *) + Lemma interp_cred_no_reify {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) n : + C ===> C' / (n, 0) -> + (interp_config C env) = (t, σ) -> + (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. + - 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. + simplify_eq. + rewrite !interp_expr_subst. + f_equiv. + intros [| [| x]]; simpl; [| reflexivity | reflexivity]. + rewrite interp_val_ren. + f_equiv. + intros ?; simpl; reflexivity. + - subst. + destruct n0; simpl. + + by rewrite IF_False; last lia. + + by rewrite IF_True; last lia. + - do 2 f_equiv. simplify_eq. + destruct v1,v0; try naive_solver. simpl in *. + rewrite NATOP_Ret. + destruct op; simplify_eq/=; done. + Qed. + + Lemma interp_cred_no_reify_state {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) n : + C ===> C' / (n, 0) -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> + σ = σ'. + Proof. + inversion 1; cbn; intros Ht Ht'; inversion Ht; inversion Ht'; subst; reflexivity. + Qed. + + Opaque map_meta_cont. + Opaque extend_scope. + Opaque Ret. + + Lemma interp_cred_yes_reify {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) (σr : gState_rest sR_idx rs ♯ IT) n : + C ===> C' / (n, 1) -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> + reify (gReifiers_sReifier rs) t (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ t'). + Proof. + inversion 1; cbn-[IF APP' Tick get_ret2 gState_recomp]; intros Ht Ht'; inversion Ht; inversion Ht'; subst; + try rewrite !map_meta_cont_cons in Ht, Ht'|-*. + - trans (reify (gReifiers_sReifier rs) + (RESET_ (laterO_map (𝒫 ◎ (interp_cont k env))) + (Next (interp_expr e env))) + (gState_recomp σr (sR_state (map_meta_cont mk env)))). + { + repeat f_equiv. rewrite !hom_vis. simpl. f_equiv. + rewrite ccompose_id_l. by intro. + } + rewrite reify_vis_eq//; last first. + { + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_reset) + (laterO_map 𝒫 (Next (interp_expr e env))) + _ (laterO_map (𝒫 ◎ interp_cont k env)) (map_meta_cont mk env) + (laterO_map (𝒫 ◎ interp_cont k env) :: map_meta_cont mk env) σr) as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last done. solve_proper. + } + f_equiv. by rewrite laterO_map_Next. + - remember (map_meta_cont mk env) as σ. + match goal with + | |- context G [Vis ?o ?f ?κ] => set (fin := f); set (op := o); set (kout := κ) + end. + trans (reify (gReifiers_sReifier rs) + (Vis op fin ((laterO_map (𝒫 ◎ interp_cont k env)) ◎ kout)) + (gState_recomp σr (sR_state σ))). + { + repeat f_equiv. rewrite !hom_vis. f_equiv. by intro. + } + rewrite reify_vis_eq//; last first. + { + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_shift) + _ _ (laterO_map (𝒫 ◎ interp_cont k env)) + σ σ σr) as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last first. + - subst kout. by rewrite ccompose_id_l. + - subst fin. reflexivity. + - solve_proper. + } + rewrite -Tick_eq. do 3 f_equiv. + rewrite interp_expr_subst. + simpl. f_equiv. + intros [|s]; simpl; eauto. + Transparent extend_scope. + simpl. f_equiv. f_equiv. by intro. + Opaque extend_scope. + - remember (map_meta_cont mk env) as σ. + remember (laterO_map (𝒫 ◎ interp_cont k env)) as kk. + match goal with + | |- context G [ofe_mor_car _ _ (get_fun _) + (ofe_mor_car _ _ Fun ?f)] => set (fin := f) + end. + trans (reify (gReifiers_sReifier rs) + (APP_CONT_ (Next (interp_val v env)) + fin kk) + (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. + rewrite laterO_map_compose. done. + } + rewrite reify_vis_eq//; last first. + { + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_app_cont) + (Next (interp_val v env), fin) _ kk σ (kk :: σ) σr) + as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; eauto. solve_proper. + } + f_equiv. by rewrite -!Tick_eq. + - 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) :: σ)))). + { + do 2 f_equiv; last repeat f_equiv. + apply get_val_ITV. + } + rewrite reify_vis_eq//; last first. + { + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_pop) + (Next (interp_val v env)) _ _ + (laterO_map (𝒫 ◎ interp_cont k env) :: σ) σ σr) + as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last reflexivity. + solve_proper. + } + f_equiv. rewrite laterO_map_Next -Tick_eq. + by f_equiv. + - trans (reify (gReifiers_sReifier rs) (POP (interp_val v env)) + (gState_recomp σr (sR_state []))). + { + do 2 f_equiv; last first. + { f_equiv. by rewrite map_meta_cont_nil. } + apply get_val_ITV. + } + rewrite reify_vis_eq//; last first. + { + epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_pop) + (Next (interp_val v env)) _ _ + [] [] σr) + as Hr. + simpl in Hr|-*. + erewrite <-Hr; last reflexivity. + repeat f_equiv; last reflexivity. + solve_proper. + } + f_equiv. by rewrite -Tick_eq. + Qed. + + + (** * SOUNDNESS *) + Lemma soundness {S : Set} (env : interp_scope S) (C C' : config S) + (t t' : IT) (σ σ' : state) (σr : gState_rest sR_idx rs ♯ IT) n nm : + steps C C' nm -> + fst nm = n -> + (interp_config C env) = (t, σ) -> + (interp_config C' env) = (t', σ') -> + ssteps (gReifiers_sReifier rs) + t (gState_recomp σr (sR_state σ)) + t' (gState_recomp σr (sR_state σ')) n. + Proof. + intros H. + revert n t t' σ σ'. + induction (H); intros n0 t t' σ σ' Hnm Ht Ht'; subst; simpl. + - rewrite Ht' in Ht. constructor; inversion Ht; done. + - destruct (interp_config c2 env) as [t2 σ2] eqn:Heqc2. + 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 <-; + 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; + 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 <-. + simpl in Heq|-*; rewrite Heq. constructor; eauto. + + specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq. + simpl in Heq|-*. + change (2+n') with (1+(1+n')). + eapply ssteps_many; last first. + * eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. + eapply sstep_tick; reflexivity. + * eapply sstep_reify; last apply Heq. + cbn in Ht. inversion Ht. + 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. + 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. + 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. + * f_equiv. reflexivity. + Qed. + +End interp. +#[global] Opaque SHIFT_ RESET_ POP APP_CONT_. diff --git a/theories/examples/input_lang_delim/lang.v b/theories/examples/input_lang_delim/lang.v new file mode 100644 index 0000000..66aadb3 --- /dev/null +++ b/theories/examples/input_lang_delim/lang.v @@ -0,0 +1,838 @@ +From stdpp Require Export strings. +From gitrees Require Export prelude. +(* From Equations Require Import Equations. *) +Require Import List. +Import ListNotations. + +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. + +Require Import FunctionalExtensionality. + + +Variant nat_op := Add | Sub | Mult. + +Inductive expr {X : Set} := +(* Values *) +| Val (v : val) : expr +| Var (x : X) : expr +(* Base lambda calculus *) +| App (e₁ : expr) (e₂ : expr) : expr +(* special application for continuations *) +| AppCont (e₁ : expr) (e₂ : expr) : expr +(* Base types and their operations *) +| NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr +| If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr +(* The effects *) +(* | Input : expr *) +(* | Output (e : expr) : expr *) +| Shift (e : @expr (inc X)) : expr +| Reset (e : expr) : expr +with val {X : Set} := +| LitV (n : nat) : val +| RecV (e : @expr (inc (inc X))) : val +| ContV (k : cont) : val +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 ◻ *) +| 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 + ◻ *) + +(* 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. + + + + +Local Open Scope bind_scope. + + +Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := + match e with + | Val v => Val (vmap f v) + | Var x => Var (f x) + | App e₁ e₂ => App (emap f e₁) (emap f e₂) + | AppCont e₁ e₂ => AppCont (emap f e₁) (emap f e₂) + | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) + | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) + (* | Input => Input *) + (* | Output e => Output (emap f e) *) + | Shift e => Shift (emap (f ↑) e) + | Reset e => Reset (emap f e) + end +with +vmap {A B : Set} (f : A [→] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (emap ((f ↑) ↑) e) + | ContV k => ContV (kmap f k) + end +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) + | 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) + | NatOpRK op e k => NatOpRK op (emap f e) (kmap f k) + end. + + +#[export] Instance FMap_expr : FunctorCore expr := @emap. +#[export] Instance FMap_val : FunctorCore val := @vmap. +#[export] Instance FMap_cont : FunctorCore cont := @kmap. + +#[export] Instance SPC_expr : SetPureCore expr := @Var. + +Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := + match e with + | Val v => Val (vbind f v) + | Var x => f x + | App e₁ e₂ => App (ebind f e₁) (ebind f e₂) + | AppCont e₁ e₂ => AppCont (ebind f e₁) (ebind f e₂) + | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) + | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) + (* | Input => Input *) + (* | Output e => Output (ebind f e) *) + | Shift e => Shift (ebind (f ↑) e) + | Reset e => Reset (ebind f e) + end +with +vbind {A B : Set} (f : A [⇒] B) (v : val A) : val B := + match v with + | LitV n => LitV n + | RecV e => RecV (ebind ((f ↑) ↑) e) + | ContV k => ContV (kbind f k) + end +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) + | 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) + | NatOpRK op e k => NatOpRK op (ebind f e) (kbind f k) + end. + +#[export] Instance BindCore_expr : BindCore expr := @ebind. +#[export] Instance BindCore_val : BindCore val := @vbind. +#[export] Instance BindCore_cont : BindCore cont := @kbind. + +#[export] Instance IP_typ : SetPure expr. +Proof. + split; intros; reflexivity. +Qed. + +Fixpoint vmap_id X (δ : X [→] X) (v : val X) : δ ≡ ı → fmap δ v = v +with emap_id X (δ : X [→] X) (e : expr X) : δ ≡ ı → fmap δ e = e +with kmap_id X (δ : X [→] X) (k : cont X) : δ ≡ ı → fmap δ k = k. +Proof. + - auto_map_id. + - auto_map_id. + - auto_map_id. +Qed. + +Fixpoint vmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (v : val A) : + f ∘ g ≡ h → fmap f (fmap g v) = fmap h v +with emap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : expr A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e +with kmap_comp (A B C : Set) (f : B [→] C) (g : A [→] B) h (e : cont A) : + f ∘ g ≡ h → fmap f (fmap g e) = fmap h e. +Proof. + - auto_map_comp. + - auto_map_comp. + - auto_map_comp. +Qed. + +#[export] Instance Functor_val : Functor val. +Proof. + split; [exact vmap_id | exact vmap_comp]. +Qed. +#[export] Instance Functor_expr : Functor expr. +Proof. + split; [exact emap_id | exact emap_comp]. +Qed. +#[export] Instance Functor_cont : Functor cont. +Proof. + split; [exact kmap_id | exact kmap_comp]. +Qed. + +Fixpoint vmap_vbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (v : val A) : + f ̂ ≡ g → fmap f v = bind g v +with emap_ebind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : expr A) : + f ̂ ≡ g → fmap f e = bind g e +with kmap_kbind_pure (A B : Set) (f : A [→] B) (g : A [⇒] B) (e : cont A) : + f ̂ ≡ g → fmap f e = bind g e. +Proof. + - auto_map_bind_pure. + erewrite emap_ebind_pure; [reflexivity |]. + intros [| [| x]]; term_simpl; [reflexivity | reflexivity |]. + rewrite <-(EQ x). + reflexivity. + - auto_map_bind_pure. + - auto_map_bind_pure. +Qed. + +#[export] Instance BindMapPure_val : BindMapPure val. +Proof. + split; intros; now apply vmap_vbind_pure. +Qed. +#[export] Instance BindMapPure_expr : BindMapPure expr. +Proof. + split; intros; now apply emap_ebind_pure. +Qed. +#[export] Instance BindMapPure_cont : BindMapPure cont. +Proof. + split; intros; now apply kmap_kbind_pure. +Qed. + +Fixpoint vmap_vbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (v : val A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ v) = fmap f₁ (bind g₁ v) +with emap_ebind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : expr A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e) +with kmap_kbind_comm (A B₁ B₂ C : Set) (f₁ : B₁ [→] C) (f₂ : A [→] B₂) + (g₁ : A [⇒] B₁) (g₂ : B₂ [⇒] C) (e : cont A) : + g₂ ∘ f₂ ̂ ≡ f₁ ̂ ∘ g₁ → bind g₂ (fmap f₂ e) = fmap f₁ (bind g₁ e). +Proof. + - auto_map_bind_comm. + erewrite emap_ebind_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity |]. + erewrite lift_comm; [reflexivity | assumption]. + - auto_map_bind_comm. + - auto_map_bind_comm. +Qed. + +#[export] Instance BindMapComm_val : BindMapComm val. +Proof. + split; intros; now apply vmap_vbind_comm. +Qed. +#[export] Instance BindMapComm_expr : BindMapComm expr. +Proof. + split; intros; now apply emap_ebind_comm. +Qed. +#[export] Instance BindMapComm_cont : BindMapComm cont. +Proof. + split; intros; now apply kmap_kbind_comm. +Qed. + +Fixpoint vbind_id (A : Set) (f : A [⇒] A) (v : val A) : + f ≡ ı → bind f v = v +with ebind_id (A : Set) (f : A [⇒] A) (e : expr A) : + f ≡ ı → bind f e = e +with kbind_id (A : Set) (f : A [⇒] A) (e : cont A) : + f ≡ ı → bind f e = e. +Proof. + - auto_bind_id. + rewrite ebind_id; [reflexivity |]. + apply lift_id, lift_id; assumption. + - auto_bind_id. + - auto_bind_id. +Qed. + + +Fixpoint vbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (v : val A) : + f ∘ g ≡ h → bind f (bind g v) = bind h v +with ebind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : expr A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e +with kbind_comp (A B C : Set) (f : B [⇒] C) (g : A [⇒] B) h (e : cont A) : + f ∘ g ≡ h → bind f (bind g e) = bind h e. +Proof. + - auto_bind_comp. + erewrite ebind_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity |]. + erewrite lift_comp; [reflexivity | assumption]. + - auto_bind_comp. + - auto_bind_comp. +Qed. + + +#[export] Instance Bind_val : Bind val. +Proof. + split; intros; [now apply vbind_id | now apply vbind_comp]. +Qed. +#[export] Instance Bind_expr : Bind expr. +Proof. + split; intros; [now apply ebind_id | now apply ebind_comp]. +Qed. +#[export] Instance Bind_cont : Bind cont. +Proof. + split; intros; [now apply kbind_id | now apply kbind_comp]. +Qed. + + +Definition to_val {S} (e : expr S) : option (val S) := + match e with + | Val v => Some v + | _ => None + end. + +Definition do_natop (op : nat_op) (x y : nat) : nat := + match op with + | Add => plus x y + | Sub => minus x y + | Mult => mult x y + end. + +Definition nat_op_interp {S} (n : nat_op) (x y : val S) : option (val S) := + match x, y with + | LitV x, LitV y => Some $ LitV $ do_natop n x y + | _,_ => None + end. + +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) + | 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)) + | NatOpRK op el K => fill K (NatOp op el e) + end. + + + +(* Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) *) +(* : fmap f (fill K e) = fill (fmap f K) (fmap f e). *) +(* Proof. *) +(* revert f. *) +(* induction K as *) +(* [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH *) +(* | ??? IH | ?? IH ]; *) +(* intros f; term_simpl; first done; rewrite IH; reflexivity. *) +(* Qed. *) + +(*** Operational semantics *) + + +Global Instance fill_inj {S} (Ki : cont S) : Inj (=) (=) (fill Ki). +Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. + +(* Lemma ctx_el_to_expr_val {S} C (e : expr S) : *) +(* is_Some (to_val (ctx_el_to_expr C e)) → is_Some (to_val e). *) +(* Proof. case : C => [] > H; simpl in H; try by apply is_Some_None in H. Qed. *) + +Lemma fill_val {S} Ki (e : expr S) : + is_Some (to_val (fill Ki e)) → is_Some (to_val e). +Proof. + elim: Ki e; simpl in *; intros; first done; + apply H in H0; simpl in H0; contradiction (is_Some_None H0). +Qed. + +(* (* CHECK *) *) +(* Lemma val_head_stuck {S} (e1 : expr S) e2 K K' Ko m : *) +(* head_step e1 K e2 K' Ko m → to_val e1 = None. *) +(* Proof. destruct 1; naive_solver. Qed. *) + + +(* K1 ∘ K2 *) +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) + | 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) + | NatOpRK op e K => NatOpRK op e (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). +Proof. + elim: K2 K1 e =>>; eauto; + 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. + +Variant config {S} : Type := + | 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 + | Cret : val S -> config. + +Reserved Notation "c '===>' c' / nm" + (at level 40, c', nm at level 30). + +Variant Cred {S : Set} : config -> config -> (nat * nat) -> Prop := + + (* init *) + | 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) + + | 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_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_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_appr : forall e v k mk, + Ccont (AppRK e k) v mk ===> Ceval e (AppLK 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 ===> + Ceval (subst (Inc := inc) + (subst (F := expr) (Inc := inc) e + (Val (shift (Inc := inc) v))) + (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_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_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) + + (* meta-cont *) + | 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) + +where "c ===> c' / nm" := (Cred c c' nm). + +Arguments Mcont S%bind : clear implicits. +Arguments config S%bind : clear implicits. + +(** ** On configs & meta-contexts *) + +Definition meta_fill {S} (mk : Mcont S) e := + fold_left (λ e k, fill k e) mk e. + + + +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', + c1 ===> c2 / (n,m) -> + steps c2 c3 (n',m') -> + steps c1 c3 (n+n',m+m'). + + +(* Lemma ceval_expr_to_val {S} : *) +(* forall (e : expr S) k mk, exists v nm, steps (Ceval e k mk) (Ceval v k mk) nm. *) +(* Proof. *) +(* intros. *) +(* induction 1; intros. *) +(* - exists (Val v), (0,0). constructor. *) +(* - *) + + +(*** 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) *) +(* . *) + +Declare Scope syn_scope. +Delimit Scope syn_scope with syn. + + +Coercion App : expr >-> Funclass. +(* Coercion AppLK : expr >-> Funclass. *) +(* Coercion AppRK : expr >-> Funclass. *) + +Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. + +Arguments __asSynExpr {_} {_} {_}. + +Global Instance AsSynExprValue : AsSynExpr val := { + __asSynExpr _ v := Val v + }. +Global Instance AsSynExprExpr : AsSynExpr expr := { + __asSynExpr _ e := e + }. + +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) := { + __op e₁ op e₂ := NatOp op (__asSynExpr e₁) (__asSynExpr e₂) + }. + +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) := { + __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) := { + __if e₁ e₂ e₃ := If (__asSynExpr e₁) (__asSynExpr e₂) (__asSynExpr e₃) + }. + +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) + }. + + +(* 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) := { + __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} {F : Set -> Type} `{AsSynExpr F} : AppNotation (F S) (cont S) (cont S) := { + __app e K := cont_compose K (AppRK (__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) := { + __app_cont e₁ e₂ := AppCont (__asSynExpr e₁) (__asSynExpr e₂) + }. + +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) := { + __app_cont e K := cont_compose K (AppContRK (__asSynExpr e) END) + }. + +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" := (__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) : ℕ). *) +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_delim/logrel.v b/theories/examples/input_lang_delim/logrel.v new file mode 100644 index 0000000..6b03fa6 --- /dev/null +++ b/theories/examples/input_lang_delim/logrel.v @@ -0,0 +1,789 @@ +(** Logical relation for adequacy for the IO lang *) +From Equations Require Import Equations. +From gitrees Require Import gitree. +From gitrees.examples.input_lang_callcc Require Import lang interp hom. +Require Import gitrees.lang_generic. +Require Import Binding.Lib Binding.Set Binding.Env. + +Open Scope stdpp_scope. + +Section logrel. + Context {sz : nat}. + Variable (rs : gReifiers sz). + Context {subR : subReifier reify_io rs}. + Notation F := (gReifiers_ops rs). + Notation IT := (IT F natO). + Notation ITV := (ITV F natO). + Context `{!invGS Σ, !stateG rs natO Σ}. + Notation iProp := (iProp Σ). + Notation restO := (gState_rest sR_idx rs ♯ IT). + + Canonical Structure exprO S := leibnizO (expr S). + Canonical Structure valO S := leibnizO (val S). + Canonical Structure ectxO S := leibnizO (ectx 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} (βv : ITV) (v : val S) : iProp := + (∃ n, βv ≡ RetV n ∧ ⌜v = LitV n⌝)%I. + + Definition obs_ref {S} (α : IT) (e : expr S) : iProp := + (∀ (σ : stateO), + has_substate σ -∗ + WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ + ∗ logrel_nat βv v ∗ has_substate σ' }})%I. + + Definition logrel_ectx {S} V (κ : HOM) (K : ectx S) : iProp := + (□ ∀ (βv : ITV) (v : val S), V βv v -∗ obs_ref (`κ (IT_of_V βv)) (fill K (Val v)))%I. + + Definition logrel_expr {S} V (α : IT) (e : expr S) : iProp := + (∀ (κ : HOM) (K : ectx S), + logrel_ectx V κ K -∗ obs_ref (`κ α) (fill K e))%I. + + Definition logrel_arr {S} V1 V2 (βv : ITV) (vf : val S) : iProp := + (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ + logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. + + + Definition logrel_cont {S} V (βv : ITV) (v : val S) : iProp := + (∃ (κ : HOM) K, (IT_of_V βv) ≡ (Fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))) + ∧ ⌜v = ContV K⌝ + ∧ □ logrel_ectx V κ K)%I. + + Fixpoint logrel_val {S} (τ : ty) : ITV → (val S) → iProp + := match τ with + | Tnat => logrel_nat + | Tarr τ1 τ2 => logrel_arr (logrel_val τ1) (logrel_val τ2) + | Tcont τ => logrel_cont (logrel_val τ) + end. + + Definition logrel {S} (τ : ty) : IT → (expr S) → iProp + := logrel_expr (logrel_val τ). + + #[export] Instance obs_ref_ne {S} : + NonExpansive2 (@obs_ref S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_expr_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V → NonExpansive2 (logrel_expr V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_nat_ne {S} : NonExpansive2 (@logrel_nat S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_val_ne {S} (τ : ty) : NonExpansive2 (@logrel_val S τ). + Proof. + induction τ; simpl; solve_proper. + Qed. + + #[export] Instance logrel_ectx_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V → NonExpansive2 (logrel_ectx V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_arr_ne {S} (V1 V2 : ITV → val S → iProp) : + NonExpansive2 V1 -> NonExpansive2 V2 → NonExpansive2 (logrel_arr V1 V2). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_cont_ne {S} (V : ITV → val S → iProp) : + NonExpansive2 V -> NonExpansive2 (logrel_cont V). + Proof. + solve_proper. + Qed. + + #[export] Instance obs_ref_proper {S} : + Proper ((≡) ==> (≡) ==> (≡)) (@obs_ref S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_expr_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_expr V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_nat_proper {S} : + Proper ((≡) ==> (≡) ==> (≡)) (@logrel_nat S). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_val_proper {S} (τ : ty) : + Proper ((≡) ==> (≡) ==> (≡)) (@logrel_val S τ). + Proof. + induction τ; simpl; solve_proper. + Qed. + + #[export] Instance logrel_ectx_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_ectx V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_arr_proper {S} (V1 V2 : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V1 -> + Proper ((≡) ==> (≡) ==> (≡)) V2 → + Proper ((≡) ==> (≡) ==> (≡)) (logrel_arr V1 V2). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_cont_proper {S} (V : ITV → val S → iProp) : + Proper ((≡) ==> (≡) ==> (≡)) V -> + Proper ((≡) ==> (≡) ==> (≡)) (logrel_cont V). + Proof. + solve_proper. + Qed. + + #[export] Instance logrel_val_persistent {S} (τ : ty) α v : + Persistent (@logrel_val S τ α v). + Proof. + revert α v. induction τ=> α v; simpl. + - unfold logrel_nat. apply _. + - unfold logrel_arr. apply _. + - unfold logrel_cont. apply _. + Qed. + + #[export] Instance logrel_ectx_persistent {S} V κ K : + Persistent (@logrel_ectx S V κ K). + Proof. + apply _. + Qed. + + Lemma logrel_of_val {S} τ αv (v : val S) : + logrel_val τ αv v -∗ logrel τ (IT_of_V αv) (Val v). + Proof. + iIntros "H1". iIntros (κ K) "HK". + iIntros (σ) "Hs". + by iApply ("HK" $! αv v with "[$H1] [$Hs]"). + Qed. + + Lemma logrel_head_step_pure_ectx {S} n K (e' e : expr S) α V : + (∀ σ K, head_step e σ e' σ K (n, 0)) → + ⊢ logrel_expr V α (fill K e') -∗ logrel_expr V α (fill K e). + Proof. + intros Hpure. + iIntros "H". + iIntros (κ' K') "#HK'". + iIntros (σ) "Hs". + iSpecialize ("H" with "HK'"). + iSpecialize ("H" with "Hs"). + iApply (wp_wand with "H"). + iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". + iExists ((Nat.add n m),m'),v,σ'. iFrame "H2 Hs". + iPureIntro. + eapply (prim_steps_app (n, 0) (m, m')); eauto. + eapply prim_step_steps. + rewrite !fill_comp. + eapply Ectx_step; last apply Hpure; done. + Qed. + + Lemma obs_ref_bind {S} (f : HOM) (K : ectx S) e α τ1 : + ⊢ logrel τ1 α e -∗ + logrel_ectx (logrel_val τ1) f K -∗ + obs_ref (`f α) (fill K e). + Proof. + iIntros "H1 #H2". + iIntros (σ) "Hs". + iApply (wp_wand with "[H1 H2 Hs] []"); first iApply ("H1" with "[H2] [$Hs]"). + - iIntros (βv v). iModIntro. + iIntros "#Hv". + by iApply "H2". + - iIntros (βv). + iIntros "?". + iModIntro. + iFrame. + Qed. + + Definition ssubst2_valid {S : Set} + (Γ : S -> ty) + (ss : @interp_scope F natO _ S) + (γ : S [⇒] Empty_set) : iProp := + (∀ x, □ logrel (Γ x) (ss x) (γ x))%I. + + Definition logrel_valid {S : Set} + (Γ : S -> ty) + (e : expr S) + (α : @interp_scope F natO _ S -n> IT) + (τ : ty) : iProp := + (□ ∀ (ss : @interp_scope F natO _ S) + (γ : S [⇒] Empty_set), + ssubst2_valid Γ ss γ → logrel τ (α ss) (bind γ e))%I. + + Lemma compat_var {S : Set} (Γ : S -> ty) (x : S) : + ⊢ logrel_valid Γ (Var x) (interp_var x) (Γ x). + Proof. + iModIntro. iIntros (ss γ) "Hss". iApply "Hss". + Qed. + + Lemma compat_recV {S : Set} (Γ : S -> ty) (e : expr (inc (inc S))) τ1 τ2 α : + ⊢ □ logrel_valid ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) e α τ2 -∗ + logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). + Proof. + iIntros "#H !> %env %γ #Henv". + set (f := (ir_unf rs α env)). + iAssert (interp_rec rs α env ≡ 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 v) "#Hw". + rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. + pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V αv))). + set (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) + ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)))%bind). + rewrite /logrel. + iSpecialize ("H" $! ss' γ'). + set (γ1 := ((γ ↑) ↑)%bind). + iApply (logrel_head_step_pure_ectx _ EmptyK _ + ((rec bind γ1 e)%syn v) + (Tick (later_car (Next f) (IT_of_V αv))) + (logrel_val τ2) with "[]"); last first. + + rewrite {2}/ss'. rewrite /f. + iIntros (κ K) "#HK". iIntros (σ) "Hs". + rewrite hom_tick. iApply wp_tick. iNext. + iApply "H"; eauto. + rewrite /ss' /γ'. + iIntros (x'); destruct x' as [| [| x']]; term_simpl; iModIntro. + * by iApply logrel_of_val. + * iRewrite "Hf". + iIntros (κ' K') "#HK'". + iApply "HK'". + simpl. + unfold logrel_arr. + _iExists (Next (ir_unf rs α env)). + iSplit; first done. + iModIntro. + iApply "IH". + * iApply "Henv". + + term_simpl. intros. subst γ1 γ'. + rewrite -!bind_bind_comp'. + apply BetaS. + Qed. + + Lemma compat_if {S : Set} (Γ : S -> ty) (e0 e1 e2 : expr S) α0 α1 α2 τ : + ⊢ logrel_valid Γ e0 α0 Tnat -∗ + logrel_valid Γ e1 α1 τ -∗ + logrel_valid Γ e2 α2 τ -∗ + logrel_valid Γ (If e0 e1 e2) (interp_if rs α0 α1 α2) τ. + Proof. + iIntros "#H0 #H1 #H2". + iModIntro. + iIntros (ss γ) "#Hss". + simpl. + pose (κ' := (IFSCtx_HOM (α1 ss) (α2 ss))). + assert ((IF (α0 ss) (α1 ss) (α2 ss)) = ((`κ') (α0 ss))) as -> by reflexivity. + term_simpl. + iIntros (κ K) "#HK". + assert ((`κ) ((IFSCtx (α1 ss) (α2 ss)) (α0 ss)) = ((`κ) ◎ (`κ')) (α0 ss)) + as -> by reflexivity. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (If (bind γ e0) (bind γ e1) (bind γ e2))%syn = + fill (ectx_compose K (IfK EmptyK (bind γ e1) (bind γ e2))) (bind γ e0)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (obs_ref_bind with "[H0] [H1 H2]"); first by iApply "H0". + iIntros (βv v). iModIntro. iIntros "#HV". + term_simpl. + unfold logrel_nat. + iDestruct "HV" as "(%n & #Hn & ->)". + iRewrite "Hn". + unfold IFSCtx. + destruct (decide (0 < n)) as [H|H]. + - rewrite -fill_comp. + simpl. + rewrite IF_True//. + iSpecialize ("H1" with "Hss"). + term_simpl. rewrite /logrel. + iPoseProof (logrel_head_step_pure_ectx _ EmptyK + (bind γ e1)%syn _ (α1 ss) (logrel_val τ) with "H1") + as "Hrel"; last iApply ("Hrel" $! κ K with "HK"). + intros σ K0. by apply IfTrueS. + - rewrite -fill_comp. + simpl. + unfold IFSCtx. + rewrite IF_False//; last lia. + iSpecialize ("H2" with "Hss"). + term_simpl. rewrite /logrel. + iPoseProof (logrel_head_step_pure_ectx _ EmptyK + (bind γ e2)%syn _ (α2 ss) (logrel_val τ) with "H2") + as "Hrel"; last iApply ("Hrel" $! κ K with "HK"). + intros σ K0. apply IfFalseS. lia. + Qed. + + Lemma compat_input {S} Γ : + ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. + Proof. + iModIntro. + iIntros (ss γ) "#Hss". + iIntros (κ K) "#HK". + unfold interp_input. + term_simpl. + iIntros (σ) "Hs". + destruct (update_input σ) as [n σ'] eqn:Hinp. + iApply (wp_input' with "Hs []"); first done. + iNext. iIntros "Hlc Hs". term_simpl. + iSpecialize ("HK" $! (RetV n) (LitV n) with "[]"); first by iExists n. + iSpecialize ("HK" $! σ' with "Hs"). + rewrite IT_of_V_Ret. + iApply (wp_wand with "[$HK] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + iModIntro. + destruct m as [m1 m2]. + iExists ((Nat.add 1 m1), (Nat.add 1 m2)), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (1, 1) (m1, m2)); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + by constructor. + Qed. + + Lemma compat_natop {S : Set} (Γ : S -> ty) e1 e2 α1 α2 op : + ⊢ logrel_valid Γ e1 α1 Tnat -∗ + logrel_valid Γ e2 α2 Tnat -∗ + logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. + Proof. + iIntros "#H1 #H2". iIntros (ss γ). iModIntro. iIntros "#Hss". + iSpecialize ("H1" with "Hss"). + iSpecialize ("H2" with "Hss"). + term_simpl. + iIntros (κ K) "#HK". + set (κ' := (NatOpRSCtx_HOM op α1 ss)). + assert ((NATOP (do_natop op) (α1 ss) (α2 ss)) = ((`κ') (α2 ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (NatOp op (bind γ e1) (bind γ e2))%syn = + fill (ectx_compose K (NatOpRK op (bind γ e1) EmptyK)) (bind γ e2)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (obs_ref_bind with "H2"). + iIntros (βv v). iModIntro. iIntros "(%n2 & #HV & ->)". + term_simpl. clear κ' sss. + rewrite -fill_comp. simpl. + pose (κ' := (NatOpLSCtx_HOM op (IT_of_V βv) ss _)). + assert ((NATOP (do_natop op) (α1 ss) (IT_of_V βv)) = ((`κ') (α1 ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (NatOp op (bind γ e1) (LitV n2))%syn = + fill (ectx_compose K (NatOpLK op EmptyK (LitV n2))) (bind γ e1)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply (obs_ref_bind with "H1"). + subst sss κ'. + term_simpl. + iIntros (t r). iModIntro. iIntros "(%n1 & #H & ->)". + simpl. + iAssert ((NATOP (do_natop op) (IT_of_V t) (IT_of_V βv)) ≡ Ret (do_natop op n1 n2))%I with "[HV H]" as "Hr". + { iRewrite "HV". simpl. + iRewrite "H". simpl. + iPureIntro. + by rewrite NATOP_Ret. + } + rewrite -fill_comp. simpl. + iApply (logrel_head_step_pure_ectx _ EmptyK (Val (LitV (do_natop op n1 n2))) with "[]"); + last done; last first. + + simpl. iRewrite "Hr". iApply (logrel_of_val Tnat (RetV (do_natop op n1 n2))). term_simpl. + iExists _. iSplit; eauto. + + intros. by constructor. + Qed. + + Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β e e' : + ⊢ logrel_valid Γ e α τ -∗ + logrel_valid Γ e' β (Tcont τ) -∗ + logrel_valid Γ (Throw e e') (interp_throw _ α β) τ'. + Proof. + iIntros "#H1 #H2". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + Opaque interp_throw. + term_simpl. + pose (κ' := ThrowLSCtx_HOM β ss). + assert ((interp_throw rs α β ss) = ((`κ') (α ss))) as -> by done. + rewrite HOM_ccompose. + pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. + assert (fill K (Throw (bind γ e) (bind γ e'))%syn = + fill (ectx_compose K (ThrowLK EmptyK (bind γ e'))) (bind γ e)) + as -> by by rewrite -fill_comp. + iApply obs_ref_bind; first by iApply "H1". + iIntros (βv v). iModIntro. iIntros "#Hv". + Transparent interp_throw. + simpl. + rewrite get_val_ITV' -!fill_comp. + simpl. + pose (κ'' := ThrowRSCtx_HOM (IT_of_V βv) ss _). + assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) ≡ + ((`κ'') (β ss))) as ->. + { + subst κ''. simpl. by rewrite get_val_ITV. + } + rewrite HOM_ccompose. + pose (sss' := (HOM_compose κ κ'')). rewrite (HOM_compose_ccompose κ κ'' sss')//. + assert (fill K (Throw v (bind γ e'))%syn = + fill (ectx_compose K (ThrowRK v EmptyK)) (bind γ e')) + as -> by by rewrite -fill_comp. + iApply obs_ref_bind; first by iApply "H2". + iIntros (βv' v'). iModIntro. iIntros "#Hv'". + Transparent interp_throw. + simpl. + unfold logrel_cont. + iDestruct "Hv'" as "(%f & %F & HEQ & %H & #H)". + rewrite get_val_ITV. + simpl. + iRewrite "HEQ". + rewrite get_fun_fun. + simpl. + iIntros (σ) "Hs". + iApply (wp_throw' with "Hs []"). + iNext. iIntros "Hcl Hs". term_simpl. + rewrite later_map_Next. iApply wp_tick. iNext. + iSpecialize ("H" $! βv v with "[]"); first done. + iSpecialize ("H" $! σ with "Hs"). + iApply (wp_wand with "[$H] []"). + iIntros (w) "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 2 m), m'), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (2, 0) (m, m')); eauto. + term_simpl. + eapply prim_step_steps. + eapply Throw_step; last done. + rewrite H. by rewrite -!fill_comp. + Qed. + + + Lemma compat_callcc {S : Set} (Γ : S -> ty) τ α e : + ⊢ logrel_valid (Γ ▹ Tcont τ) e α τ -∗ + logrel_valid Γ (Callcc e) (interp_callcc _ α) τ. + Proof. + iIntros "#H". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + unfold interp_callcc. + Opaque extend_scope. + term_simpl. + iIntros (σ) "Hs". + + iApply (wp_callcc with "Hs []"). + iNext. iIntros "Hcl Hs". term_simpl. + + pose (ff := (λit x : IT, Tick ((`κ) x))). + match goal with + | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ extend_scope ss )?f] => set (fff := f) + end. + assert (ff ≡ fff) as <-. + { + subst ff fff. do 1 f_equiv. + epose proof (contractive_proper Next). + rewrite H; first reflexivity. + rewrite ofe_mor_ext. intro. simpl. + by rewrite later_map_Next. + } + pose (ss' := (extend_scope ss ff)). + pose (γ' := ((mk_subst (Val (ContV K)%syn)) ∘ (γ ↑)%bind)%bind : inc S [⇒] ∅). + iSpecialize ("H" $! ss' γ' with "[HK]"). + { + iIntros (x). iModIntro. + destruct x as [| x]; term_simpl; last iApply "Hss". + Transparent extend_scope. + subst ss'; simpl. + pose proof (asval_fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))). + subst ff. destruct H as [f H]. + iIntros (t r) "#H". + simpl. rewrite -H. iApply "H". + unfold logrel_cont. + iExists κ, K. + iSplit; first done. + iSplit; first done. + iModIntro. + iApply "HK". + } + iSpecialize ("H" $! κ K with "HK"). + Opaque extend_scope. + term_simpl. + iSpecialize ("H" $! σ with "Hs"). + subst ss' γ'. + iApply (wp_wand with "[$H] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". + destruct m as [m m']. + rewrite -bind_bind_comp' in Hstep. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + eapply prim_step_steps. + eapply Ectx_step; [reflexivity | reflexivity |]. + term_simpl. + constructor. + Qed. + + Lemma compat_output {S} Γ (e: expr S) α : + ⊢ logrel_valid Γ e α Tnat -∗ + logrel_valid Γ (Output e) (interp_output rs α) Tnat. + Proof. + iIntros "#H". + iIntros (ss γ). iModIntro. iIntros "#Hss". + iIntros (κ K) "#HK". + term_simpl. + pose (κ' := OutputSCtx_HOM ss). + replace (get_ret OUTPUT (α ss)) with ((`κ') (α ss)) by reflexivity. + replace ((`κ) ((`κ') (α ss))) with (((`κ) ◎ (`κ')) (α ss)) by reflexivity. + pose (sss := (HOM_compose κ κ')). + replace (`κ ◎ `κ') with (`sss) by reflexivity. + assert (fill K (Output (bind γ e))%syn = + fill (ectx_compose K (OutputK EmptyK)) (bind γ e)) as ->. + { rewrite -fill_comp. reflexivity. } + iApply obs_ref_bind; first by iApply "H". + iIntros (βv v). iModIntro. iIntros "#Hv". + iDestruct "Hv" as (n) "[Hb ->]". + iRewrite "Hb". simpl. + iIntros (σ) "Hs". + rewrite get_ret_ret. + iApply (wp_output' with "Hs []"); first done. + iNext. iIntros "Hlc Hs". + iSpecialize ("HK" $! (RetV 0) (LitV 0) with "[]"); first by iExists 0. + iSpecialize ("HK" $! (update_output n σ) with "Hs"). + iApply (wp_wand with "[$HK] []"). + iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H')". + destruct m as [m m']. + iModIntro. + iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H'". + iPureIntro. + eapply (prim_steps_app (1, 1) (m, m')); eauto. + eapply prim_step_steps. + rewrite -fill_comp. + eapply Ectx_step; [reflexivity | reflexivity |]. + by constructor. + Qed. + + Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : + ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ + logrel_valid Γ e2 α2 τ1 -∗ + logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. + Proof. + iIntros "#H1 #H2". + iIntros (ss). + iModIntro. + iIntros (γ). + iIntros "#Hss". + iSpecialize ("H1" with "Hss"). + iSpecialize ("H2" with "Hss"). + unfold interp_app. + simpl. + assert ((bind γ (App e1 e2))%syn = (fill (AppRK (bind γ e1) EmptyK) (bind γ e2))) as ->. + { reflexivity. } + pose (κ' := (AppRSCtx_HOM α1 ss)). + assert ((α1 ss ⊙ (α2 ss)) = ((`κ') (α2 ss))) as ->. + { simpl; unfold AppRSCtx. reflexivity. } + iIntros (κ K) "#HK". + assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α2 ss)) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ')). + assert ((`κ ◎ `κ') = (`sss)) as ->. + { reflexivity. } + rewrite fill_comp. + iApply obs_ref_bind; first by iApply "H2". + subst sss κ'. + iIntros (βv v). iModIntro. iIntros "#HV". + unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. + rewrite -fill_comp. + simpl. + assert ((App (bind γ e1) v) = (fill (AppLK EmptyK v) (bind γ e1))) as ->. + { reflexivity. } + pose (κ'' := (AppLSCtx_HOM (IT_of_V βv) ss _)). + assert (((`κ) (α1 ss ⊙ (IT_of_V βv))) = (((`κ) ◎ (`κ'')) (α1 ss))) as ->. + { reflexivity. } + pose (sss := (HOM_compose κ κ'')). + assert ((`κ ◎ `κ'') = (`sss)) as ->. + { reflexivity. } + rewrite fill_comp. + iApply obs_ref_bind; first by iApply "H1". + iIntros (βv' v'). iModIntro. iIntros "#HV'". + subst sss κ''. + rewrite -fill_comp. + simpl. + unfold logrel_arr. + iDestruct "HV'" as "(%f & #Hf & #HV')". + iRewrite "Hf". + iSpecialize ("HV'" $! βv v with "HV"). + iApply "HV'"; iApply "HK". + Qed. + + Lemma compat_nat {S : Set} (Γ : S -> ty) n : + ⊢ logrel_valid Γ (# n)%syn (interp_val rs (# n)%syn) ℕ%typ. + Proof. + iIntros (ss γ). iModIntro. iIntros "#Hss". + term_simpl. + iIntros (κ K) "#HK". + iSpecialize ("HK" $! (RetV n) (LitV n)). + rewrite IT_of_V_Ret. + iApply "HK". + simpl. + unfold logrel_nat. + iExists n; eauto. + Qed. + + Lemma fundamental {S : Set} (Γ : S -> ty) τ e : + typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ + with fundamental_val {S : Set} (Γ : S -> ty) τ v : + typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. + Proof. + - induction 1; simpl. + + by apply fundamental_val. + + rewrite -H. + by apply compat_var. + + iApply compat_app. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_natop. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_if. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + ++ iApply IHtyped3. + + iApply compat_input. + + iApply compat_output. + iApply IHtyped. + + iApply compat_throw. + ++ iApply IHtyped1. + ++ iApply IHtyped2. + + iApply compat_callcc. + iApply IHtyped. + - induction 1; simpl. + + iApply compat_nat. + + iApply compat_recV. by iApply fundamental. + Qed. + +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. +Definition rs : gReifiers 1 := gReifiers_cons reify_io gReifiers_nil. + +Require Import gitrees.gitree.greifiers. + +Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} + (α : IT (gReifiers_ops rs) natO) + (e : expr S) n σ σ' k : + (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (⊢ logrel rs Tnat α e)%I) → + ssteps (gReifiers_sReifier rs) α (σ, ()) (Ret n) σ' k → + ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. +Proof. + intros Hlog Hst. + pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), + ∃ m σ', prim_steps e σ (Val $ κ βv) σ' m). + cut (ϕ (RetV n)). + { + destruct 1 as ( m' & σ2 & Hm). + exists m', σ2. revert Hm. by rewrite κ_Ret. + } + eapply (wp_adequacy 0); eauto. + intros Hinv1 Hst1. + pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), + ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) + ∗ ⌜∃ m σ', prim_steps e σ (Val $ 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 σ) with "[Hs]" as "Hs". + { + unfold has_substate, has_full_state. + assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ())) ≡ + (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ))) + as -> ; last done. + intros 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" $! HOM_id EmptyK with "[]"). + { + iIntros (βv v); iModIntro. iIntros "Hv". iIntros (σ'') "HS". + iApply wp_val. + iModIntro. + iExists (0, 0), v, σ''. + iSplit; first iPureIntro. + - apply prim_steps_zero. + - by iFrame. + } + simpl. + iSpecialize ("Hlog" $! σ with "Hs"). + iApply (wp_wand with"Hlog"). + iIntros ( βv). iIntros "H". + iDestruct "H" as (m' v σ1' Hsts) "[Hi Hsts]". + unfold Φ. iDestruct "Hi" as (l) "[Hβ %]". simplify_eq/=. + iExists l. iModIntro. iSplit; eauto. + iExists l. iSplit; eauto. +Qed. + +Program Definition ı_scope : @interp_scope (gReifiers_ops rs) natO _ Empty_set := λne (x : ∅), match x with end. + +Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : + typed □ e Tnat → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → + ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. +Proof. + intros Hty Hst. + pose (Σ:=#[invΣ;stateΣ rs natO]). + eapply (logrel_nat_adequacy Σ (interp_expr rs e ı_scope)); last eassumption. + intros ? ?. + iPoseProof (fundamental rs) as "H". + { apply Hty. } + unfold logrel_valid. + unshelve iSpecialize ("H" $! ı_scope _ with "[]"). + { apply ı%bind. } + { iIntros (x); destruct x. } + rewrite ebind_id; first last. + { intros ?; reflexivity. } + iApply "H". +Qed. From ebe09ac4317f9251acd3fe5fc5359543dab1a3f0 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 27 Feb 2024 09:24:23 +0100 Subject: [PATCH 107/114] Adapted for CtxDep + some fix --- theories/examples/input_lang_delim/example.v | 8 +- theories/examples/input_lang_delim/interp.v | 80 ++++++++++---------- 2 files changed, 44 insertions(+), 44 deletions(-) diff --git a/theories/examples/input_lang_delim/example.v b/theories/examples/input_lang_delim/example.v index 940ae93..45bfefd 100644 --- a/theories/examples/input_lang_delim/example.v +++ b/theories/examples/input_lang_delim/example.v @@ -10,7 +10,7 @@ Open Scope syn_scope. 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 rs : gReifiers _ _ := gReifiers_cons reify_delim gReifiers_nil. (* Local Definition Hrs : subReifier reify_delim rs. *) (* Proof. unfold rs. apply subReifier_here. Qed. *) @@ -51,9 +51,9 @@ Proof. assert (α ≡ (λne x, k x) (RESET e)) as -> by (by simpl; subst). clear α. iApply (wp_reset with "Hσ"). - { subst. simpl. apply IT_hom_compose; first apply _. - refine (IT_HOM _ _ _ _ _ ). - - apply NATOP_Tick. by rewrite !hom_tick. + { subst. simpl. + simple refine (IT_HOM _ _ _ _ _ ); intros; simpl. + - by rewrite !hom_tick. - rewrite !hom_vis. f_equiv. intro. simpl. done. - by rewrite !hom_err. } diff --git a/theories/examples/input_lang_delim/interp.v b/theories/examples/input_lang_delim/interp.v index 9cbe6f5..c82d255 100644 --- a/theories/examples/input_lang_delim/interp.v +++ b/theories/examples/input_lang_delim/interp.v @@ -127,7 +127,7 @@ Section reifiers. End reifiers. -Canonical Structure reify_delim : sReifier. +Canonical Structure reify_delim : sReifier CtxDep. Proof. simple refine {| sReifier_ops := delimE; @@ -220,7 +220,7 @@ Notation 𝒫 := (get_val POP). Section weakestpre. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers CtxDep sz). Context {subR : subReifier reify_delim rs}. Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. @@ -245,7 +245,7 @@ Section weakestpre. iIntros "Hs Ha". unfold SHIFT. simpl. rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ (later_map 𝒫 $ f (laterO_map k)) with "Hs"). + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (later_map 𝒫 $ f (laterO_map k)) with "Hs"). { simpl. repeat f_equiv. @@ -268,7 +268,7 @@ Section weakestpre. Proof. iIntros "Hs Ha". unfold RESET. simpl. rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ (laterO_map 𝒫 e) with "Hs"). + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (laterO_map 𝒫 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. @@ -285,7 +285,7 @@ Section weakestpre. Proof. iIntros "Hs Ha". rewrite get_val_ITV. simpl. - iApply (wp_subreify _ _ _ _ _ _ _ ((Next $ IT_of_V v)) with "Hs"). + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ ((Next $ IT_of_V v)) with "Hs"). - simpl. reflexivity. - reflexivity. - done. @@ -299,7 +299,7 @@ Section weakestpre. Proof. iIntros "Hs Ha". rewrite get_val_ITV. simpl. - iApply (wp_subreify _ _ _ _ _ _ _ ((laterO_map k (Next $ IT_of_V v))) with "Hs"). + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ ((laterO_map k (Next $ IT_of_V v))) with "Hs"). - simpl. reflexivity. - reflexivity. - done. @@ -315,7 +315,7 @@ Section weakestpre. Proof. iIntros "Hs Ha". unfold APP_CONT. simpl. rewrite hom_vis. - iApply (wp_subreify _ _ _ _ _ _ _ (laterO_ap k' e) with "Hs"). + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (laterO_ap k' e) with "Hs"). - simpl. do 2 f_equiv. trans (laterO_map k :: σ); last reflexivity. rewrite ccompose_id_l. f_equiv. intro. simpl. by rewrite ofe_iso_21. @@ -328,7 +328,7 @@ End weakestpre. Section interp. Context {sz : nat}. - Variable (rs : gReifiers sz). + Variable (rs : gReifiers CtxDep sz). Context {subR : subReifier reify_delim rs}. Context {R} `{CR : !Cofe R}. Context `{!SubOfe natO R}. @@ -952,26 +952,26 @@ Section interp. Opaque Ret. Lemma interp_cred_yes_reify {S : Set} (env : interp_scope S) (C C' : config S) - (t t' : IT) (σ σ' : state) (σr : gState_rest sR_idx rs ♯ IT) n : + (t t' : IT) (σ σ' : state) (σr : gState_rest CtxDep sR_idx rs ♯ IT) n : C ===> C' / (n, 1) -> (interp_config C env) = (t, σ) -> (interp_config C' env) = (t', σ') -> - reify (gReifiers_sReifier rs) t (gState_recomp σr (sR_state σ)) - ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ t'). + reify (gReifiers_sReifier CtxDep rs) t (gState_recomp CtxDep σr (sR_state σ)) + ≡ (gState_recomp CtxDep σr (sR_state σ'), Tick_n n $ t'). Proof. inversion 1; cbn-[IF APP' Tick get_ret2 gState_recomp]; intros Ht Ht'; inversion Ht; inversion Ht'; subst; try rewrite !map_meta_cont_cons in Ht, Ht'|-*. - - trans (reify (gReifiers_sReifier rs) + - trans (reify (gReifiers_sReifier CtxDep rs) (RESET_ (laterO_map (𝒫 ◎ (interp_cont k env))) (Next (interp_expr e env))) - (gState_recomp σr (sR_state (map_meta_cont mk env)))). + (gState_recomp CtxDep σr (sR_state (map_meta_cont mk env)))). { repeat f_equiv. rewrite !hom_vis. simpl. f_equiv. rewrite ccompose_id_l. by intro. } - rewrite reify_vis_eq//; last first. + rewrite reify_vis_eq_ctx_dep//; last first. { - epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_reset) + epose proof (@subReifier_reify sz CtxDep reify_delim rs _ IT _ (op_reset) (laterO_map 𝒫 (Next (interp_expr e env))) _ (laterO_map (𝒫 ◎ interp_cont k env)) (map_meta_cont mk env) (laterO_map (𝒫 ◎ interp_cont k env) :: map_meta_cont mk env) σr) as Hr. @@ -984,15 +984,15 @@ Section interp. match goal with | |- context G [Vis ?o ?f ?κ] => set (fin := f); set (op := o); set (kout := κ) end. - trans (reify (gReifiers_sReifier rs) + trans (reify (gReifiers_sReifier CtxDep rs) (Vis op fin ((laterO_map (𝒫 ◎ interp_cont k env)) ◎ kout)) - (gState_recomp σr (sR_state σ))). + (gState_recomp CtxDep σr (sR_state σ))). { repeat f_equiv. rewrite !hom_vis. f_equiv. by intro. } - rewrite reify_vis_eq//; last first. + rewrite reify_vis_eq_ctx_dep//; last first. { - epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_shift) + epose proof (@subReifier_reify sz CtxDep reify_delim rs _ IT _ (op_shift) _ _ (laterO_map (𝒫 ◎ interp_cont k env)) σ σ σr) as Hr. simpl in Hr|-*. @@ -1015,18 +1015,18 @@ Section interp. | |- context G [ofe_mor_car _ _ (get_fun _) (ofe_mor_car _ _ Fun ?f)] => set (fin := f) end. - trans (reify (gReifiers_sReifier rs) + trans (reify (gReifiers_sReifier CtxDep rs) (APP_CONT_ (Next (interp_val v env)) fin kk) - (gState_recomp σr (sR_state (σ)))). + (gState_recomp CtxDep σ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. rewrite laterO_map_compose. done. } - rewrite reify_vis_eq//; last first. + rewrite reify_vis_eq_ctx_dep//; last first. { - epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_app_cont) + epose proof (@subReifier_reify sz CtxDep reify_delim rs _ IT _ (op_app_cont) (Next (interp_val v env), fin) _ kk σ (kk :: σ) σr) as Hr. simpl in Hr|-*. @@ -1035,15 +1035,15 @@ Section interp. } f_equiv. by rewrite -!Tick_eq. - 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) :: σ)))). + trans (reify (gReifiers_sReifier CtxDep rs) (POP (interp_val v env)) + (gState_recomp CtxDep σr (sR_state (laterO_map (𝒫 ◎ interp_cont k env) :: σ)))). { do 2 f_equiv; last repeat f_equiv. apply get_val_ITV. } - rewrite reify_vis_eq//; last first. + rewrite reify_vis_eq_ctx_dep//; last first. { - epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_pop) + epose proof (@subReifier_reify sz CtxDep reify_delim rs _ IT _ (op_pop) (Next (interp_val v env)) _ _ (laterO_map (𝒫 ◎ interp_cont k env) :: σ) σ σr) as Hr. @@ -1054,16 +1054,16 @@ Section interp. } f_equiv. rewrite laterO_map_Next -Tick_eq. by f_equiv. - - trans (reify (gReifiers_sReifier rs) (POP (interp_val v env)) - (gState_recomp σr (sR_state []))). + - trans (reify (gReifiers_sReifier CtxDep rs) (POP (interp_val v env)) + (gState_recomp CtxDep σr (sR_state []))). { do 2 f_equiv; last first. { f_equiv. by rewrite map_meta_cont_nil. } apply get_val_ITV. } - rewrite reify_vis_eq//; last first. + rewrite reify_vis_eq_ctx_dep//; last first. { - epose proof (@subReifier_reify sz reify_delim rs _ IT _ (op_pop) + epose proof (@subReifier_reify sz CtxDep reify_delim rs _ IT _ (op_pop) (Next (interp_val v env)) _ _ [] [] σr) as Hr. @@ -1078,14 +1078,14 @@ Section interp. (** * SOUNDNESS *) Lemma soundness {S : Set} (env : interp_scope S) (C C' : config S) - (t t' : IT) (σ σ' : state) (σr : gState_rest sR_idx rs ♯ IT) n nm : + (t t' : IT) (σ σ' : state) (σr : gState_rest CtxDep sR_idx rs ♯ IT) n nm : steps C C' nm -> fst nm = n -> (interp_config C env) = (t, σ) -> (interp_config C' env) = (t', σ') -> - ssteps (gReifiers_sReifier rs) - t (gState_recomp σr (sR_state σ)) - t' (gState_recomp σr (sR_state σ')) n. + ssteps (gReifiers_sReifier CtxDep rs) + t (gState_recomp CtxDep σr (sR_state σ)) + t' (gState_recomp CtxDep σr (sR_state σ')) n. Proof. intros H. revert n t t' σ σ'. @@ -1100,11 +1100,11 @@ Section interp. specialize (interp_cred_no_reify_state env _ _ _ _ _ _ _ H0 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; + [eapply ssteps_many with t2 (gState_recomp CtxDep σr (sR_state σ2)); last done; specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 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. + + eapply ssteps_many with t2 (gState_recomp CtxDep σ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 <-. simpl in Heq|-*; rewrite Heq. constructor; eauto. @@ -1112,19 +1112,19 @@ Section interp. simpl in Heq|-*. change (2+n') with (1+(1+n')). eapply ssteps_many; last first. - * eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. + * eapply ssteps_many with t2 (gState_recomp CtxDep σr (sR_state σ2)); last done. eapply sstep_tick; reflexivity. * eapply sstep_reify; last apply Heq. cbn in Ht. inversion Ht. 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. + + eapply ssteps_many with t2 (gState_recomp CtxDep σr (sR_state σ2)); last done. specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 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. + + eapply ssteps_many with t2 (gState_recomp CtxDep σr (sR_state σ2)); last done. specialize (interp_cred_yes_reify env _ _ _ _ _ _ σr _ H0 Ht Heqc2) as Heq. cbn in Ht; inversion Ht. subst. rewrite get_val_ITV. simpl. eapply sstep_reify; simpl in Heq; last first. From 4ce07059b3621135dcc2ddcb4f49447432658482 Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 27 Feb 2024 09:32:11 +0100 Subject: [PATCH 108/114] removed hom file from delim example while not implemented --- _CoqProject | 1 - 1 file changed, 1 deletion(-) diff --git a/_CoqProject b/_CoqProject index c97c206..19aab97 100644 --- a/_CoqProject +++ b/_CoqProject @@ -31,7 +31,6 @@ theories/program_logic.v theories/examples/input_lang_delim/lang.v theories/examples/input_lang_delim/interp.v -theories/examples/input_lang_delim/hom.v theories/examples/input_lang_delim/logrel.v theories/examples/input_lang_callcc/lang.v From b3c82d19fc17a891e5679640dc40ba016233c84a Mon Sep 17 00:00:00 2001 From: Nicolas Nardino Date: Tue, 27 Feb 2024 10:15:30 +0100 Subject: [PATCH 109/114] removed logrel while not implemented + temporary tacs for ex proof --- _CoqProject | 1 - theories/examples/input_lang_delim/example.v | 188 +++++-------------- 2 files changed, 47 insertions(+), 142 deletions(-) diff --git a/_CoqProject b/_CoqProject index 19aab97..4d1ffbf 100644 --- a/_CoqProject +++ b/_CoqProject @@ -31,7 +31,6 @@ theories/program_logic.v theories/examples/input_lang_delim/lang.v theories/examples/input_lang_delim/interp.v -theories/examples/input_lang_delim/logrel.v theories/examples/input_lang_callcc/lang.v theories/examples/input_lang_callcc/interp.v diff --git a/theories/examples/input_lang_delim/example.v b/theories/examples/input_lang_delim/example.v index 45bfefd..0110269 100644 --- a/theories/examples/input_lang_delim/example.v +++ b/theories/examples/input_lang_delim/example.v @@ -29,6 +29,25 @@ Definition σ := snd ts. 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_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}}. @@ -37,167 +56,54 @@ Proof. iIntros "Hσ". cbn. (* first, reset *) - lazymatch goal with - | |- context G [ofe_mor_car _ _ RESET ?t] => set (e := t) - end. - lazymatch goal with - | |- context G [ofe_mor_car _ _ 𝒫 (?kk (ofe_mor_car _ _ RESET e))] => remember (𝒫 ◎ kk) as k - end. - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) - end. - assert (NonExpansive k). - { subst. intros ????. solve_proper. } - assert (α ≡ (λne x, k x) (RESET e)) as -> by (by simpl; subst). - clear α. + do 2 shift_hom. iApply (wp_reset with "Hσ"). - { subst. simpl. - simple refine (IT_HOM _ _ _ _ _ ); intros; simpl. - - by rewrite !hom_tick. - - rewrite !hom_vis. f_equiv. intro. simpl. done. - - by rewrite !hom_err. - } - iIntros "!> Hl Hσ". - simpl. + iIntros "!> _ Hσ". simpl. (* then, shift *) - lazymatch goal with - | |- context G [ofe_mor_car _ _ SHIFT ?e] => set (f := e) - (* envs_entails _ (wp _ (ofe_mor_car _ _ SHIFT ?e) _ _ _) => idtac *) - end. - lazymatch goal with - | |- context G [?kk (ofe_mor_car _ _ SHIFT f)] => remember (𝒫 ◎ kk) as k' - end. - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) - end. - assert (NonExpansive k'). - { subst. intros ????. solve_proper. } - assert (α ≡ (λne y, k' y) (SHIFT f)) as -> by (by simpl; subst). - clear α. + do 2 shift_hom. iApply (wp_shift with "Hσ"). - { subst. simpl. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - by rewrite !hom_tick. - - rewrite !hom_vis. f_equiv. by intro. - - by rewrite !hom_err. - } iIntros "!>_ Hσ". simpl. (* the rest *) - lazymatch goal with - | |- context G [ofe_mor_car _ _ (get_val ?f) (_ 5)] => remember f as func - end. - lazymatch goal with - | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ (NATOP _) ?x) ?y] => - remember x as ex; remember y as ey - end. - remember (λ (x y : IT), 𝒫 $ NATOP (do_natop lang.Add) x y) as kplus. - assert (NonExpansive2 kplus). - { subst. intros ???????. solve_proper. } - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) - end. - assert (α ≡ kplus (func (Ret 5)) (func (Ret 6))) as ->. - { subst kplus α ex ey. f_equiv. f_equiv. - - f_equiv. rewrite -IT_of_V_Ret. apply get_val_ITV'. - - rewrite -IT_of_V_Ret. apply get_val_ITV'. - } - subst func. simpl. - clear α. - lazymatch goal with - | |- context G [kplus ?scd (ofe_mor_car _ _ (get_fun ?f) - (ofe_mor_car _ _ Fun ?g))] => remember f as func1; remember g as gfunc; remember scd as snd - end. - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) - end. - assert (α ≡ kplus snd (func1 gfunc)) as ->. - { subst α kplus func1 gfunc. repeat f_equiv; first by subst. - simpl. by rewrite get_fun_fun. - } - subst func1 gfunc. simpl. - remember (λ x, kplus snd x) as kkkk. - assert (NonExpansive kkkk) by solve_proper. - clear α. - lazymatch goal with - | |- context G [kkkk ?e] => remember e as newe - end. - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) - end. - - assert (α ≡ (λne x, kkkk x) newe) as -> by (by subst). - subst newe; clear α. + 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σ"). - { subst. simpl. - simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - by rewrite !hom_tick. - - rewrite !hom_vis. f_equiv. intro. by simpl. - - by rewrite !hom_err. - } - simpl. - iIntros "!> _ Hσ". + iIntros "!> _ Hσ". simpl. rewrite later_map_Next -Tick_eq. iApply wp_tick. iNext. - subst. simpl. - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => set (α := t) - end. - assert (α ≡ 𝒫 (IT_of_V $ RetV 9)) as ->. - { subst α. f_equiv. by rewrite NATOP_Ret. } + 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. - lazymatch goal with - | |- context G [ofe_mor_car _ _ (get_fun ?f) - (ofe_mor_car _ _ Fun ?g)] => remember f as func1; remember g as gfunc - end. - clear α. - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => - assert (t ≡ 𝒫 $ NATOP (do_natop lang.Add) (func1 gfunc) (IT_of_V (RetV 9))) - as -> by (repeat f_equiv; apply get_fun_fun) - end. - subst. simpl. - remember (λ x : IT, 𝒫 (NATOP (do_natop lang.Add) x (IT_of_V (RetV 9)))) as kkkk. - assert (NonExpansive kkkk) by solve_proper. - lazymatch goal with - | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ (NATOP _) ?e) (IT_of_V (ofe_mor_car _ _ RetV 9))] => remember e as newe - end. - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => - assert (t ≡ (λne x, kkkk x) newe) - as -> by by subst - end. - subst newe. + 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σ"). - { subst. simpl. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - by rewrite NATOP_ITV_Tick_l hom_tick. - - rewrite NATOP_ITV_Vis_l hom_vis. f_equiv. by intro. - - by rewrite NATOP_Err_l hom_err. - } iIntros "!> _ Hσ". simpl. - rewrite later_map_Next -Tick_eq. iApply wp_tick. iNext. - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => assert (t ≡ 𝒫 (IT_of_V $ RetV 8)) - as -> by (f_equiv; by rewrite NATOP_Ret) - end. - iApply (wp_pop_cons with "Hσ"). - iIntros "!> _ Hσ". - simpl. subst kkkk. - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => assert (t ≡ 𝒫 (IT_of_V $ RetV 17)) - as -> by (f_equiv; by rewrite NATOP_Ret) - end. + 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. - lazymatch goal with - | |- envs_entails _ (wp _ ?t _ _ _) => assert (t ≡ 𝒫 (IT_of_V $ RetV 18)) - as -> by (f_equiv; by rewrite NATOP_Ret) - end. + 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. From 426db0a6e6a750e8a56c27cefe78453e45abecef Mon Sep 17 00:00:00 2001 From: Dan Frumin Date: Mon, 26 Feb 2024 20:33:11 +0100 Subject: [PATCH 110/114] cleanup the branch and make is_ctx_dep implicit --- README.md | 19 +- _CoqProject | 3 +- coq-gitrees.opam | 5 +- theories/effects/store.v | 125 +---------- theories/examples/affine_lang/lang.v | 6 +- theories/examples/affine_lang/logrel1.v | 18 +- theories/examples/affine_lang/logrel2.v | 18 +- theories/examples/input_lang/interp.v | 53 ++--- theories/examples/input_lang/lang.v | 8 +- theories/examples/input_lang/logpred.v | 16 +- theories/examples/input_lang/logrel.v | 11 +- theories/examples/input_lang_callcc/hom.v | 6 +- theories/examples/input_lang_callcc/interp.v | 73 +++---- theories/examples/input_lang_callcc/lang.v | 5 +- theories/examples/input_lang_callcc/logrel.v | 12 +- theories/examples/input_lang_delim/example.v | 9 +- theories/examples/input_lang_delim/interp.v | 201 ++++++----------- theories/examples/input_lang_delim/lang.v | 62 +----- theories/examples/input_lang_delim/logrel.v | 1 - theories/gitree/greifiers.v | 5 + theories/gitree/weakestpre.v | 219 +++++++++---------- theories/lib/factorial.v | 2 +- 22 files changed, 317 insertions(+), 560 deletions(-) diff --git a/README.md b/README.md index 819d1b8..20a96ee 100644 --- a/README.md +++ b/README.md @@ -1,10 +1,11 @@ # Guarded Interaction Trees This is the Coq formalization of guarded interaction trees, associated examples and case studies. +Read the [GITrees POPL paper](https://iris-project.org/pdfs/2024-popl-gitrees.pdf) describing our work. ## Installation instructions -To install the formalization you will need the Iris, std++, and Equations packages. +To install the formalization you will need Iris and std++ libraries. The dependencies can be easily installed using [Opam](https://opam.ocaml.org/) with the following commands: ``` @@ -24,16 +25,20 @@ All the code lives in the `theories` folder. Below is the quick guide to the code structure. - `gitree/` -- contains the core definitions related to guarded interaction trees -- `input_lang/` -- formalization of the language with io, the soundness and adequacy -- `input_lang_callcc/` -- formalization of the language with io, throw and call/cc, the soundness and adequacy -- `affine_lang/` -- formalization of the affine language, type safety of the language interoperability -- `examples/` -- some other smaller examples -- `lang_generic.v` -- generic facts about languages with binders and their interpretations, shared by `input_lang` and `affine_lang` -- `lang_generic_sem.v` -- generic facts about languages with a different representation of binders and their interpretations, used for `input_lang_callcc` +- `lib/` -- derived combinators for gitrees +- `examples/input_lang/` -- formalization of the language with io, the soundness and adequacy +- `examples/input_lang_callcc/` -- formalization of the language with io, throw and call/cc, the soundness and adequacy +- `examples/affine_lang/` -- formalization of the affine language, type safety of the language interoperability +- `effects/` -- concrete effects, their interpretaions, and logics - `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` +- `vendor/Binding/` -- the functorial syntax library used for ### References from the paper to the code +The version of the formalization that corresponds to the paper can be found under the [tag `popl24`](https://github.com/logsem/gitrees/releases/tag/popl24). +Below we describe the correspondence per-section. + - **Section 3** + Definition of guarded interaction trees, constructors, the recursion principle, and the destructors are in `gitree/core.v` diff --git a/_CoqProject b/_CoqProject index 4d1ffbf..ee4ddbc 100644 --- a/_CoqProject +++ b/_CoqProject @@ -31,6 +31,7 @@ theories/program_logic.v theories/examples/input_lang_delim/lang.v theories/examples/input_lang_delim/interp.v +theories/examples/input_lang_delim/example.v theories/examples/input_lang_callcc/lang.v theories/examples/input_lang_callcc/interp.v @@ -53,4 +54,4 @@ theories/lib/while.v theories/lib/factorial.v theories/lib/iter.v -theories/utils/finite_sets.v \ No newline at end of file +theories/utils/finite_sets.v diff --git a/coq-gitrees.opam b/coq-gitrees.opam index 8a0f678..3056b98 100644 --- a/coq-gitrees.opam +++ b/coq-gitrees.opam @@ -2,14 +2,13 @@ opam-version: "2.0" name: "coq-gitrees" synopsis: "Guarded Interaction Trees" version: "dev" -maintainer: "..." -authors: "..." +maintainer: "Logsem" +authors: "Logsem" license: "BSD" build: [make "-j%{jobs}%"] install: [make "install"] remove: ["rm" "-rf" "%{lib}%/coq/user-contrib/gitrees"] depends: [ - "coq-equations" { (= "1.3+8.17") } "coq-iris" { (= "4.1.0") } "coq-iris-heap-lang" { (= "4.1.0") } "coq-stdpp" { (= "1.9.0") } diff --git a/theories/effects/store.v b/theories/effects/store.v index 7027cba..a7deb17 100644 --- a/theories/effects/store.v +++ b/theories/effects/store.v @@ -224,10 +224,7 @@ Section wp. Proof. iIntros (Hee) "#Hcxt H". unfold READ. simpl. - match goal with - | |- context G [Vis ?a ?b ?c] => assert (c ≡ idfun ◎ (subEff_outs ^-1)) as -> - end; first solve_proper. - iApply wp_subreify_ctx_indep'. + iApply wp_subreify_ctx_indep'. simpl. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (fupd_mask_weaken E1). { set_solver. } @@ -249,16 +246,9 @@ Section wp. iFrame "Hs". repeat iSplit. - assert ((option_bind _ _ (λ x, Some (x, σ)) (σ !! l)) ≡ - (option_bind _ _ (λ x, Some (x, σ)) (Some (Next β')))) as H. - + f_equiv. - * solve_proper. - * by rewrite Hx Hb'. - + simpl in H. - rewrite <-H. - unfold mbind. - simpl. - iPureIntro. - f_equiv; last done. + (option_bind _ _ (λ x, Some (x, σ)) (Some (Next β')))) as <-. + { rewrite Hx /= ; solve_proper. } + simpl. iPureIntro. by f_equiv. - iPureIntro. apply ofe_iso_21. - iNext. iIntros "Hlc Hs". iMod ("Hback" with "Hp") as "Hback". @@ -290,8 +280,7 @@ Section wp. WP@{rs} WRITE l β @ s {{ Φ }}. Proof. iIntros (Hee) "#Hcxt H". - unfold READ. simpl. - iApply wp_subreify_ctx_indep'. + iApply wp_subreify_ctx_indep'. simpl. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (fupd_mask_weaken E1). { set_solver. } @@ -337,7 +326,7 @@ Section wp. WP@{rs} ALLOC α k @ s {{ Φ }}. Proof. iIntros "Hh H". - iApply wp_subreify_ctx_indep'. + iApply wp_subreify_ctx_indep'. simpl. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (lc_fupd_elim_later with "Hlc"). iModIntro. @@ -365,8 +354,7 @@ Section wp. WP@{rs} DEALLOC l @ s {{ Φ }}. Proof. iIntros (Hee) "#Hcxt H". - unfold DEALLOC. simpl. - iApply wp_subreify_ctx_indep'. + iApply wp_subreify_ctx_indep'. simpl. iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl". iApply (fupd_mask_weaken E1). { set_solver. } @@ -404,105 +392,6 @@ Section wp. iModIntro. done. Qed. - (** * The logical relation TODO *) - (* Definition N := nroot.@"heh". *) - (* Definition logrel_expr V (α : IT) : iProp := *) - (* (heap_ctx -∗ WP@{rs} α {{ V }})%I. *) - - (* Context `{!SubOfe natO R, !Inhabited R}. *) - - (* Definition logrel_nat (βv : ITV) : iProp := *) - (* (∃ n : nat, βv ≡ RetV n)%I. *) - (* Definition logrel_arr V1 V2 (βv : ITV) : iProp := *) - (* (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv, V1 αv -∗ *) - (* logrel_expr V2 (APP' (Fun f) (IT_of_V αv)))%I. *) - (* Definition logrel_ref V (l : loc) : iProp := *) - (* (inv (N.@l) (∃ βv, pointsto l (IT_of_V βv) ∗ V βv))%I. *) - - (* Lemma logrel_alloc V V2 (αv :ITV) (k : locO -n> IT) `{!forall v, Persistent (V v)} *) - (* `{NonExpansive V2} : *) - (* V αv -∗ *) - (* (∀ l, logrel_ref V l -∗ logrel_expr V2 (k l)) -∗ *) - (* logrel_expr V2 (ALLOC (IT_of_V αv) k). *) - (* Proof. *) - (* iIntros "#HV H". *) - (* iIntros "#Hh". *) - (* iApply (wp_alloc with "Hh"). *) - (* iNext. iNext. *) - (* iIntros (l) "Hl". *) - (* iMod (inv_alloc (N.@l) _ (∃ βv, pointsto l (IT_of_V βv) ∗ V βv)%I with "[Hl]") *) - (* as "#Hinv". *) - (* { eauto with iFrame. } *) - (* iSpecialize ("H" with "Hinv"). *) - (* by iApply "H". *) - (* Qed. *) - - (* Opaque Ret. (*TODO*) *) - (* Lemma logrel_write V αv l `{!forall v, Persistent (V v)} : *) - (* logrel_ref V l -∗ *) - (* V αv -∗ *) - (* logrel_expr logrel_nat (WRITE l (IT_of_V αv)). *) - (* Proof. *) - (* iIntros "#Hl #Hav #Hctx". *) - (* iApply wp_subreify'. *) - (* iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl1". *) - (* iInv (N.@l) as "HH" "Hcl2". *) - (* iDestruct "HH" as (βv) "[Hbv #HV]". *) - (* iApply (lc_fupd_elim_later with "Hlc"). *) - (* iNext. *) - (* iAssert (⌜is_Some (σ !! l)⌝)%I as "%Hdom". *) - (* { iApply (istate_loc_dom with "Hh Hbv"). } *) - (* iExists σ, (),(<[l:=Next (IT_of_V αv)]>σ),(Ret ()). *) - (* iFrame "Hs". *) - (* iSimpl. repeat iSplit; [ done | done | ]. *) - (* iNext. iIntros "Hlc Hs". *) - (* iMod (istate_write _ _ (IT_of_V αv) with "Hh Hbv") as "[Hh Hlav]". *) - (* iMod ("Hcl2" with "[Hlav]") as "_". *) - (* { iNext. iExists _; by iFrame. } *) - (* iMod ("Hcl1" with "[Hlc Hh Hs]") as "_". *) - (* { iNext. iExists _; by iFrame. } *) - (* iModIntro. *) - (* iApply wp_val. iModIntro. *) - (* iExists (). unfold RetV. done. *) - (* Qed. *) - - (* Lemma logrel_read V l `{!forall v, Persistent (V v)} : *) - (* logrel_ref V l -∗ *) - (* logrel_expr V (READ l). *) - (* Proof. *) - (* iIntros "#Hr #Hctx". *) - (* iApply wp_subreify'. *) - (* iInv (nroot.@"storeE") as (σ) "[>Hlc [Hs Hh]]" "Hcl1". *) - (* iInv (N.@l) as "HH" "Hcl2". *) - (* iDestruct "HH" as (βv) "[Hbv #HV]". *) - (* iAssert (▷ (σ !! l ≡ Some (Next (IT_of_V βv))))%I as "#Hlookup". *) - (* { iNext. iApply (istate_read with "Hh Hbv"). } *) - (* iAssert (▷ ⌜is_Some (σ !! l)⌝)%I as "#Hdom". *) - (* { iNext. iApply (istate_loc_dom with "Hh Hbv"). } *) - (* iDestruct "Hdom" as ">%Hdom". *) - (* destruct Hdom as [x Hx]. *) - (* destruct (Next_uninj x) as [β' Hb']. *) - (* iAssert (▷ ▷ (β' ≡ IT_of_V βv))%I as "#Hbv'". *) - (* { iNext. rewrite Hx. rewrite option_equivI. *) - (* rewrite Hb'. by iNext. } *) - (* iClear "Hlookup". *) - (* iApply (lc_fupd_elim_later with "Hlc"). *) - (* iNext. iSimpl. *) - (* iExists σ,(Next β'),σ,β'. iFrame "Hs". *) - (* repeat iSplit. *) - (* { iPureIntro. rewrite Hx/= Hb'. done. } *) - (* { rewrite ofe_iso_21//. } *) - (* iNext. iIntros "Hlc Hs". *) - (* iMod ("Hcl2" with "[Hbv]") as "_". *) - (* { iNext. eauto with iFrame. } *) - (* iMod ("Hcl1" with "[Hlc Hh Hs]") as "_". *) - (* { iNext. eauto with iFrame. } *) - (* iModIntro. *) - (* iRewrite "Hbv'". *) - (* iApply wp_val. *) - (* iModIntro. done. *) - (* Qed. *) - End wp. Arguments heapG {_} rs R {_} Σ. diff --git a/theories/examples/affine_lang/lang.v b/theories/examples/affine_lang/lang.v index 628d2e9..14cdcb9 100644 --- a/theories/examples/affine_lang/lang.v +++ b/theories/examples/affine_lang/lang.v @@ -3,6 +3,8 @@ From gitrees.examples.input_lang Require Import lang interp. From gitrees.effects Require Import store. From gitrees.lib Require Import pairs. +Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. + (* for namespace sake *) Module io_lang. Definition state := input_lang.lang.state. @@ -14,8 +16,6 @@ Module io_lang. input_lang.interp.interp_expr rs e ı_scope. End io_lang. -Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. - Inductive ty := tBool | tInt | tUnit | tArr (τ1 τ2 : ty) | tPair (τ1 τ2 : ty) @@ -42,7 +42,7 @@ Inductive expr : ∀ (S : Set), Type := | Alloc {S : Set} : expr S → expr S | Replace {S1 S2 : Set} : expr S1 → expr S2 → expr (sum S1 S2) | Dealloc {S : Set} : expr S → expr S -| EEmbed {S : Set} {τ1 τ1'} : io_lang.expr Empty_set → ty_conv τ1 τ1' → expr S +| EEmbed {S : Set} {τ1 τ1'} : io_lang.expr ∅ → ty_conv τ1 τ1' → expr S . Section affine. diff --git a/theories/examples/affine_lang/logrel1.v b/theories/examples/affine_lang/logrel1.v index d26e888..c9c38b5 100644 --- a/theories/examples/affine_lang/logrel1.v +++ b/theories/examples/affine_lang/logrel1.v @@ -1,11 +1,11 @@ (** Unary (Kripke) logical relation for the affine lang *) -Require Import iris.algebra.gmap. From gitrees Require Export gitree program_logic greifiers. From gitrees.examples.affine_lang Require Import lang. From gitrees.effects Require Import store. From gitrees.lib Require Import pairs. From gitrees.utils Require Import finite_sets. + Inductive typed : forall {S : Set}, (S → ty) → expr S → ty → Prop := (** functions *) | typed_Var {S : Set} (Ω : S → ty) (v : S) : @@ -525,15 +525,15 @@ Lemma logrel1_adequacy cr Σ R `{!Cofe R, !SubOfe natO R, !SubOfe unitO R, !SubO (α : interp_scope ∅ -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ}, (£ cr ⊢ valid1 rs notStuck (λne _: unitO, True)%I □ α τ)%I) → - ssteps (gReifiers_sReifier NotCtxDep rs) (α ı_scope) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) + ssteps (gReifiers_sReifier rs) (α ı_scope) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). 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 NotCtxDep rs) β st' β1 st1) + cut ((∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) ∨ (∃ e, (β ≡ Err e)%stdpp ∧ notStuck e)). { intros [?|He]; first done. destruct He as [? [? []]]. } @@ -549,9 +549,9 @@ Proof. iMod (new_heapG rs σ) as (H3) "H". iAssert (has_substate σ ∗ has_substate ios)%I with "[Hst]" as "[Hs Hio]". { unfold has_substate, has_full_state. - assert (of_state NotCtxDep rs (IT (gReifiers_ops rs) _) st ≡ - of_idx NotCtxDep rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ) - ⋅ of_idx NotCtxDep rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios))%stdpp as ->; last first. + assert (of_state rs (IT (gReifiers_ops rs) _) st ≡ + of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ) + ⋅ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios))%stdpp as ->; last first. { rewrite -own_op. done. } unfold sR_idx. simpl. intro j. @@ -580,8 +580,8 @@ Definition R := sumO locO (sumO unitO natO). Lemma logrel1_safety e τ (β : IT (gReifiers_ops rs) R) st st' k : typed □ e τ → - ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ı_scope) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). Proof. intros Hty Hst. diff --git a/theories/examples/affine_lang/logrel2.v b/theories/examples/affine_lang/logrel2.v index 3db5de0..865580c 100644 --- a/theories/examples/affine_lang/logrel2.v +++ b/theories/examples/affine_lang/logrel2.v @@ -1,6 +1,4 @@ -From stdpp Require Import finite. From iris.base_logic.lib Require Import na_invariants. -From iris.algebra Require Import gmap. From gitrees Require Export gitree program_logic greifiers. From gitrees.examples.input_lang Require Import lang interp logpred. From gitrees.examples.affine_lang Require Import lang logrel1. @@ -478,15 +476,15 @@ Lemma logrel2_adequacy (cr : nat) R `{!Cofe R, !SubOfe locO R, !SubOfe natO R, ! (τ : ty) (α : interp_scope Empty_set -n> IT (gReifiers_ops rs) R) (β : IT (gReifiers_ops rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ} `{H3: !heapG rs R Σ} p, (£ cr ⊢ valid2 rs p □ α τ)%I) → - ssteps (gReifiers_sReifier NotCtxDep rs) (α ı_scope) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) + ssteps (gReifiers_sReifier rs) (α ı_scope) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) ∨ (β ≡ Err OtherError)%stdpp ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). Proof. intros Hlog Hst. destruct (IT_to_V β) as [βv|] eqn:Hb. { right. right. exists βv. apply IT_of_to_V'. rewrite Hb; eauto. } - cut ((∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) + cut ((∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) ∨ (∃ e, (β ≡ Err e)%stdpp ∧ s e)). { intros [?|He]; first eauto. right. left. destruct He as [? [? ->]]. done. } @@ -502,9 +500,9 @@ Proof. iMod (new_heapG rs σ) as (H3) "H". iAssert (has_substate σ ∗ has_substate ios)%I with "[Hst]" as "[Hs Hio]". { unfold has_substate, has_full_state. - assert (of_state NotCtxDep rs (IT (gReifiers_ops rs) _) st ≡ - of_idx NotCtxDep rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ) - ⋅ of_idx NotCtxDep rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios))%stdpp as ->; last first. + assert (of_state rs (IT (gReifiers_ops rs) _) st ≡ + of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ) + ⋅ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state ios))%stdpp as ->; last first. { rewrite -own_op. done. } unfold sR_idx. simpl. intro j. @@ -535,8 +533,8 @@ Definition R := sumO locO (sumO natO unitO). Lemma logrel2_safety e τ (β : IT (gReifiers_ops rs) R) st st' k : typed_glued □ e τ → - ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ı_scope) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) st β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) ∨ (β ≡ Err OtherError)%stdpp ∨ (∃ βv, (IT_of_V βv ≡ β)%stdpp). Proof. diff --git a/theories/examples/input_lang/interp.v b/theories/examples/input_lang/interp.v index 0f8c135..806f55a 100644 --- a/theories/examples/input_lang/interp.v +++ b/theories/examples/input_lang/interp.v @@ -443,9 +443,9 @@ Section interp. + repeat f_equiv; [by apply interp_ectx_subst | by apply interp_val_subst]. Qed. - (** ** Interpretation is a homomorphism (for some constructors) *) + (** ** Interpretation of evaluation contexts induces homomorphism *) - #[global] Instance interp_ectx_hom_emp {S} env : + #[local] Instance interp_ectx_hom_emp {S} env : IT_hom (interp_ectx (EmptyK : ectx S) env). Proof. simple refine (IT_HOM _ _ _ _ _); intros; auto. @@ -453,7 +453,7 @@ Section interp. by rewrite laterO_map_id. Qed. - #[global] Instance interp_ectx_hom_output {S} (K : ectx S) env : + #[local] Instance interp_ectx_hom_output {S} (K : ectx S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (OutputK K) env). Proof. @@ -465,7 +465,7 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_hom_if {S} + #[local] Instance interp_ectx_hom_if {S} (K : ectx S) (e1 e2 : expr S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (IfK K e1 e2) env). @@ -485,7 +485,7 @@ Section interp. apply IF_Err. Qed. - #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) + #[local] Instance interp_ectx_hom_appr {S} (K : ectx S) (e : expr S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (AppRK e K) env). @@ -497,7 +497,7 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) + #[local] Instance interp_ectx_hom_appl {S} (K : ectx S) (v : val S) (env : interp_scope S) : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (AppLK K v) env). @@ -514,7 +514,7 @@ Section interp. apply APP'_Err_l, interp_val_asval. Qed. - #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) + #[local] Instance interp_ectx_hom_natopr {S} (K : ectx S) (e : expr S) op env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (NatOpRK op e K) env). @@ -526,7 +526,7 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) + #[local] Instance interp_ectx_hom_natopl {S} (K : ectx S) (v : val S) op (env : interp_scope S) : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (NatOpLK op K v) env). @@ -544,14 +544,7 @@ Section interp. + by apply NATOP_Err_l, interp_val_asval. Qed. - Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). - Proof. - intros. - by rewrite IT_rec1_ret. - Qed. - - #[global] Instance interp_ectx_hom {S} - (K : ectx S) env : + #[global] Instance interp_ectx_hom {S} (K : ectx S) env : IT_hom (interp_ectx K env). Proof. induction K; apply _. @@ -607,18 +600,18 @@ Section interp. Opaque Ret. Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) - (σ σ' : stateO) (σr : gState_rest NotCtxDep sR_idx rs ♯ IT) n : + (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : head_step e σ e' σ' (n, 1) → - reify (gReifiers_sReifier NotCtxDep rs) - (interp_expr (fill K e) env) (gState_recomp NotCtxDep σr (sR_state σ)) - ≡ (gState_recomp NotCtxDep σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). + reify (gReifiers_sReifier rs) + (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). Proof. intros Hst. - trans (reify (gReifiers_sReifier NotCtxDep rs) (interp_ectx K env (interp_expr e env)) - (gState_recomp NotCtxDep σr (sR_state σ))). + trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) + (gState_recomp σr (sR_state σ))). { f_equiv. by rewrite interp_comp. } inversion Hst; simplify_eq; cbn-[gState_recomp]. - - trans (reify (gReifiers_sReifier NotCtxDep rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp NotCtxDep σr (sR_state σ))). + - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). { repeat f_equiv; eauto. rewrite hom_INPUT. @@ -639,19 +632,19 @@ Section interp. rewrite ofe_iso_21. simpl. reflexivity. - - trans (reify (gReifiers_sReifier NotCtxDep rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp NotCtxDep σr (sR_state σ))). + - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). { do 3 f_equiv; eauto. rewrite get_ret_ret//. } - trans (reify (gReifiers_sReifier NotCtxDep rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp NotCtxDep σr (sR_state σ))). + trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). { do 2 f_equiv; eauto. by rewrite hom_OUTPUT_. } rewrite reify_vis_eq_ctx_indep //; last first. { - epose proof (@subReifier_reify sz NotCtxDep reify_io rs _ IT _ (inr (inl ())) n0 _ σ (update_output n0 σ) σr) as H. + epose proof (@subReifier_reify sz _ reify_io rs _ IT _ (inr (inl ())) n0 _ σ (update_output n0 σ) σr) as H. simpl in H. simpl. erewrite <-H; last reflexivity. @@ -663,11 +656,11 @@ Section interp. reflexivity. Qed. - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest NotCtxDep sR_idx rs ♯ IT) n m (env : interp_scope S) : + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : prim_step e1 σ1 e2 σ2 (n,m) → - ssteps (gReifiers_sReifier NotCtxDep rs) - (interp_expr e1 env) (gState_recomp NotCtxDep σr (sR_state σ1)) - (interp_expr e2 env) (gState_recomp NotCtxDep σr (sR_state σ2)) n. + ssteps (gReifiers_sReifier rs) + (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. Proof. Opaque gState_decomp gState_recomp. inversion 1; simplify_eq/=. diff --git a/theories/examples/input_lang/lang.v b/theories/examples/input_lang/lang.v index bd6939f..a9d15f4 100644 --- a/theories/examples/input_lang/lang.v +++ b/theories/examples/input_lang/lang.v @@ -1,9 +1,7 @@ From gitrees Require Export prelude. -Require Import List. -Import ListNotations. - Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. + Inductive nat_op := Add | Sub | Mult. Inductive expr {X : Set} : Type := @@ -509,6 +507,10 @@ Coercion App : expr >-> Funclass. Coercion AppLK : ectx >-> Funclass. Coercion AppRK : expr >-> Funclass. +(* XXX: We use these typeclasses to share the notaiton between the +expressions and the evaluation contexts, for readability. It will be +good to also share the notation between different languages. *) + Class AsSynExpr (F : Set -> Type) := { __asSynExpr : ∀ S, F S -> expr S }. Arguments __asSynExpr {_} {_} {_}. diff --git a/theories/examples/input_lang/logpred.v b/theories/examples/input_lang/logpred.v index 303d9d4..6f1471b 100644 --- a/theories/examples/input_lang/logpred.v +++ b/theories/examples/input_lang/logpred.v @@ -256,15 +256,15 @@ Lemma logpred_adequacy cr Σ R `{!Cofe R, SubOfe natO R} (β : IT (gReifiers_ops rs) R) st st' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs R Σ}, (£ cr ⊢ valid1 rs notStuck (λne _ : unitO, True)%I □ α τ)%I) → - ssteps (gReifiers_sReifier NotCtxDep rs) (α ı_scope) st β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) + 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 NotCtxDep rs) β st' β1 st1) + cut ((∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) ∨ (∃ e, β ≡ Err e ∧ notStuck e)). { intros [?|He]; first done. destruct He as [? [? []]]. } @@ -279,8 +279,8 @@ Proof. destruct st as [σ []]. iAssert (has_substate σ) with "[Hst]" as "Hs". { unfold has_substate, has_full_state. - assert (of_state NotCtxDep rs (IT (gReifiers_ops rs) _) (σ,()) ≡ - of_idx NotCtxDep rs (IT (gReifiers_ops rs) _) sR_idx (sR_state σ)) as ->; last done. + 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. @@ -302,10 +302,10 @@ Proof. done. Qed. -Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier NotCtxDep rs)) natO) k : +Lemma io_lang_safety e τ σ st' (β : IT (sReifier_ops (gReifiers_sReifier rs)) natO) k : typed □ e τ → - ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ı_scope) (σ, ()) β st' k → - (∃ β1 st1, sstep (gReifiers_sReifier NotCtxDep rs) β st' β1 st1) + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ, ()) β st' k → + (∃ β1 st1, sstep (gReifiers_sReifier rs) β st' β1 st1) ∨ (∃ βv, IT_of_V βv ≡ β). Proof. intros Htyped Hsteps. diff --git a/theories/examples/input_lang/logrel.v b/theories/examples/input_lang/logrel.v index c058fd2..30b1a2d 100644 --- a/theories/examples/input_lang/logrel.v +++ b/theories/examples/input_lang/logrel.v @@ -359,7 +359,7 @@ Definition rs : gReifiers NotCtxDep 1 := gReifiers_cons reify_io gReifiers_nil. Lemma logrel_nat_adequacy Σ `{!invGpreS Σ}`{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (True ⊢ logrel rs Tnat α e)%I) → - ssteps (gReifiers_sReifier NotCtxDep rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. + ssteps (gReifiers_sReifier rs) α (σ,()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), @@ -391,8 +391,8 @@ Proof. iPoseProof (Hlog with "[//]") as "Hlog". iAssert (has_substate σ) with "[Hs]" as "Hs". { unfold has_substate, has_full_state. - assert (of_state NotCtxDep rs (IT (gReifiers_ops rs) natO) (σ, ()) ≡ - of_idx NotCtxDep rs (IT (gReifiers_ops rs) natO) 0 σ)%stdpp as ->; last done. + assert (of_state rs (IT (gReifiers_ops rs) natO) (σ, ()) ≡ + of_idx rs (IT (gReifiers_ops rs) natO) 0 σ)%stdpp as ->; last done. intro j. unfold sR_idx. simpl. unfold of_state, of_idx. destruct decide as [Heq|]; last first. @@ -413,7 +413,7 @@ Qed. Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : typed □ e Tnat → - ssteps (gReifiers_sReifier NotCtxDep rs) (interp_expr rs e ı_scope) (σ,()) (Ret k : IT _ natO) σ' n → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ,()) (Ret k : IT _ natO) σ' n → ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. Proof. intros Hty Hst. @@ -424,8 +424,7 @@ Proof. { apply Hty. } unfold logrel_valid. iIntros "_". - unshelve iSpecialize ("H" $! ı_scope _ with "[]"). - { apply ı%bind. } + iSpecialize ("H" $! ı_scope ı%bind with "[]"). { iIntros (x); destruct x. } rewrite ebind_id; first last. { intros ?; reflexivity. } diff --git a/theories/examples/input_lang_callcc/hom.v b/theories/examples/input_lang_callcc/hom.v index 661374b..66f3f2d 100644 --- a/theories/examples/input_lang_callcc/hom.v +++ b/theories/examples/input_lang_callcc/hom.v @@ -1,6 +1,7 @@ -From gitrees Require Import gitree. +(** 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.examples.input_lang_callcc Require Import lang interp. -Require Import gitrees.lang_generic. Require Import Binding.Lib Binding.Set Binding.Env. Open Scope stdpp_scope. @@ -42,6 +43,7 @@ Section hom. `f ◎ `g = `h. Proof. intros ->. done. Qed. + (** Specific packaged homomorphisms *) Program Definition IFSCtx_HOM α β : HOM := exist _ (λne x, IFSCtx α β x) _. Next Obligation. intros; simpl. diff --git a/theories/examples/input_lang_callcc/interp.v b/theories/examples/input_lang_callcc/interp.v index 5daeec3..e9e94ec 100644 --- a/theories/examples/input_lang_callcc/interp.v +++ b/theories/examples/input_lang_callcc/interp.v @@ -1,9 +1,6 @@ -From gitrees Require Import gitree. +From gitrees Require Import gitree lang_generic. From gitrees.examples.input_lang_callcc Require Import lang. -Require Import gitrees.lang_generic. - -Require Import Binding.Lib. -Require Import Binding.Set. +Require Import Binding.Lib Binding.Set. Notation stateO := (leibnizO state). @@ -512,14 +509,6 @@ Section interp. end. Solve All Obligations with first [ solve_proper | solve_proper_please ]. - (* Open Scope syn_scope. *) - - (* Example callcc_ex : expr ∅ := *) - (* NatOp + (# 1) (Callcc (NatOp + (# 1) (Throw (# 2) ($ 0)))). *) - (* Eval cbn in callcc_ex. *) - (* Eval cbn in interp_expr callcc_ex *) - (* (λne (x : leibnizO ∅), match x with end). *) - Global Instance interp_val_asval {S} {D : interp_scope S} (v : val S) : AsVal (interp_val v D). Proof. @@ -712,9 +701,9 @@ Section interp. intros ?; simpl; repeat f_equiv; first by apply interp_ectx_subst. Qed. - (** ** Interpretation is a homomorphism (for some constructors) *) + (** ** Interpretation of evaluation contexts induces homomorphism *) - #[global] Instance interp_ectx_hom_emp {S} env : + #[local] Instance interp_ectx_hom_emp {S} env : IT_hom (interp_ectx (EmptyK : ectx S) env). Proof. simple refine (IT_HOM _ _ _ _ _); intros; auto. @@ -722,7 +711,7 @@ Section interp. by rewrite laterO_map_id. Qed. - #[global] Instance interp_ectx_hom_output {S} (K : ectx S) env : + #[local] Instance interp_ectx_hom_output {S} (K : ectx S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (OutputK K) env). Proof. @@ -734,7 +723,7 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_hom_if {S} + #[local] Instance interp_ectx_hom_if {S} (K : ectx S) (e1 e2 : expr S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (IfK K e1 e2) env). @@ -754,7 +743,7 @@ Section interp. apply IF_Err. Qed. - #[global] Instance interp_ectx_hom_appr {S} (K : ectx S) + #[local] Instance interp_ectx_hom_appr {S} (K : ectx S) (e : expr S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (AppRK e K) env). @@ -766,7 +755,7 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_hom_appl {S} (K : ectx S) + #[local] Instance interp_ectx_hom_appl {S} (K : ectx S) (v : val S) (env : interp_scope S) : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (AppLK K v) env). @@ -783,7 +772,7 @@ Section interp. apply APP'_Err_l, interp_val_asval. Qed. - #[global] Instance interp_ectx_hom_natopr {S} (K : ectx S) + #[local] Instance interp_ectx_hom_natopr {S} (K : ectx S) (e : expr S) op env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (NatOpRK op e K) env). @@ -795,7 +784,7 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_ectx_hom_natopl {S} (K : ectx S) + #[local] Instance interp_ectx_hom_natopl {S} (K : ectx S) (v : val S) op (env : interp_scope S) : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (NatOpLK op K v) env). @@ -813,13 +802,7 @@ Section interp. + by apply NATOP_Err_l, interp_val_asval. Qed. - Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). - Proof. - intros. - by rewrite IT_rec1_ret. - Qed. - - #[global] Instance interp_ectx_hom_throwr {S} + #[local] Instance interp_ectx_hom_throwr {S} (K : ectx S) (v : val S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (ThrowRK v K) env). @@ -832,7 +815,7 @@ Section interp. destruct (IT_dont_confuse ((interp_ectx K env α))) as [(e' & HEQ) |[(n & HEQ) |[(f & HEQ) |[(β & HEQ) | (op & i & k & HEQ)]]]]. + rewrite HEQ !get_fun_tick !get_fun_err. reflexivity. - + rewrite HEQ !get_fun_tick !get_fun_ret'. + + rewrite HEQ !get_fun_tick. reflexivity. + rewrite HEQ !get_fun_tick !get_fun_fun//=. + rewrite HEQ !get_fun_tick. @@ -860,7 +843,7 @@ Section interp. reflexivity. Qed. - #[global] Instance interp_ectx_hom_throwl {S} + #[local] Instance interp_ectx_hom_throwl {S} (K : ectx S) (e : expr S) env : IT_hom (interp_ectx K env) -> IT_hom (interp_ectx (ThrowLK K e) env). @@ -930,18 +913,18 @@ Section interp. Opaque Ret. Lemma interp_expr_fill_yes_reify {S} K env (e e' : expr S) - (σ σ' : stateO) (σr : gState_rest CtxDep sR_idx rs ♯ IT) n : + (σ σ' : stateO) (σr : gState_rest sR_idx rs ♯ IT) n : head_step e σ e' σ' K (n, 1) → - reify (gReifiers_sReifier CtxDep rs) - (interp_expr (fill K e) env) (gState_recomp CtxDep σr (sR_state σ)) - ≡ (gState_recomp CtxDep σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). + reify (gReifiers_sReifier rs) + (interp_expr (fill K e) env) (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ interp_expr (fill K e') env). Proof. intros Hst. - trans (reify (gReifiers_sReifier CtxDep rs) (interp_ectx K env (interp_expr e env)) - (gState_recomp CtxDep σr (sR_state σ))). + trans (reify (gReifiers_sReifier rs) (interp_ectx K env (interp_expr e env)) + (gState_recomp σr (sR_state σ))). { f_equiv. by rewrite interp_comp. } inversion Hst; simplify_eq; cbn-[gState_recomp]. - - trans (reify (gReifiers_sReifier CtxDep rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp CtxDep σr (sR_state σ))). + - trans (reify (gReifiers_sReifier rs) (INPUT (interp_ectx K env ◎ Ret)) (gState_recomp σr (sR_state σ))). { repeat f_equiv; eauto. rewrite hom_INPUT. @@ -960,12 +943,12 @@ Section interp. repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. reflexivity. - - trans (reify (gReifiers_sReifier CtxDep rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp CtxDep σr (sR_state σ))). + - trans (reify (gReifiers_sReifier rs) (interp_ectx K env (OUTPUT n0)) (gState_recomp σr (sR_state σ))). { do 3 f_equiv; eauto. rewrite get_ret_ret//. } - trans (reify (gReifiers_sReifier CtxDep rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp CtxDep σr (sR_state σ))). + trans (reify (gReifiers_sReifier rs) (OUTPUT_ n0 (interp_ectx K env (Ret 0))) (gState_recomp σr (sR_state σ))). { do 2 f_equiv; eauto. by rewrite hom_OUTPUT_. @@ -992,7 +975,7 @@ Section interp. unfold CALLCC. simpl. set (subEff1 := @subReifier_subEff sz CtxDep reify_io rs subR). - trans (reify (gReifiers_sReifier CtxDep rs) (CALLCC_ f (laterO_map (interp_ectx K env))) gσ). + trans (reify (gReifiers_sReifier rs) (CALLCC_ f (laterO_map (interp_ectx K env))) gσ). { do 2 f_equiv. rewrite hom_CALLCC_. @@ -1021,11 +1004,11 @@ Section interp. do 2 f_equiv. by intro. Qed. - Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest CtxDep sR_idx rs ♯ IT) n m (env : interp_scope S) : + Lemma soundness {S} (e1 e2 : expr S) σ1 σ2 (σr : gState_rest sR_idx rs ♯ IT) n m (env : interp_scope S) : prim_step e1 σ1 e2 σ2 (n,m) → - ssteps (gReifiers_sReifier CtxDep rs) - (interp_expr e1 env) (gState_recomp CtxDep σr (sR_state σ1)) - (interp_expr e2 env) (gState_recomp CtxDep σr (sR_state σ2)) n. + ssteps (gReifiers_sReifier rs) + (interp_expr e1 env) (gState_recomp σr (sR_state σ1)) + (interp_expr e2 env) (gState_recomp σr (sR_state σ2)) n. Proof. Opaque gState_decomp gState_recomp. inversion 1; simplify_eq/=. @@ -1097,7 +1080,7 @@ Section interp. match goal with | |- context G [ofe_mor_car _ _ _ (Next ?f)] => set (f' := f) end. - trans (reify (gReifiers_sReifier CtxDep rs) (THROW (interp_val v env) (Next f')) (gState_recomp CtxDep σr (sR_state σ2))). + trans (reify (gReifiers_sReifier rs) (THROW (interp_val v env) (Next f')) (gState_recomp σr (sR_state σ2))). { f_equiv; last done. f_equiv. diff --git a/theories/examples/input_lang_callcc/lang.v b/theories/examples/input_lang_callcc/lang.v index e7cb712..65eabcb 100644 --- a/theories/examples/input_lang_callcc/lang.v +++ b/theories/examples/input_lang_callcc/lang.v @@ -1,12 +1,9 @@ From gitrees Require Export prelude. -Require Import List. -Import ListNotations. - Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. Inductive nat_op := Add | Sub | Mult. -Inductive expr {X : Set} := +Inductive expr {X : Set} : Type := (* Values *) | Val (v : val) : expr | Var (x : X) : expr diff --git a/theories/examples/input_lang_callcc/logrel.v b/theories/examples/input_lang_callcc/logrel.v index cbfd44f..717256c 100644 --- a/theories/examples/input_lang_callcc/logrel.v +++ b/theories/examples/input_lang_callcc/logrel.v @@ -1,8 +1,6 @@ (** Logical relation for adequacy for the IO lang *) -From gitrees Require Import gitree. +From gitrees Require Import gitree lang_generic. From gitrees.examples.input_lang_callcc Require Import lang interp hom. -Require Import gitrees.lang_generic. -Require Import gitrees.gitree.greifiers. Require Import Binding.Lib Binding.Set Binding.Env. Open Scope stdpp_scope. @@ -692,7 +690,7 @@ Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (⊢ logrel rs Tnat α e)%I) → - ssteps (gReifiers_sReifier CtxDep rs) α (σ, ()) (Ret n) σ' k → + ssteps (gReifiers_sReifier rs) α (σ, ()) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. @@ -731,8 +729,8 @@ Proof. iAssert (has_substate σ) with "[Hs]" as "Hs". { unfold has_substate, has_full_state. - assert ((of_state CtxDep rs (IT (sReifier_ops (gReifiers_sReifier CtxDep rs)) natO) (σ, ())) ≡ - (of_idx CtxDep rs (IT (sReifier_ops (gReifiers_sReifier CtxDep rs)) natO) sR_idx (sR_state σ))) + assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ())) ≡ + (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ))) as -> ; last done. intros j. unfold sR_idx. simpl. unfold of_state, of_idx. @@ -767,7 +765,7 @@ Qed. Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : typed □ e Tnat → - ssteps (gReifiers_sReifier CtxDep rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. Proof. intros Hty Hst. diff --git a/theories/examples/input_lang_delim/example.v b/theories/examples/input_lang_delim/example.v index 0110269..9389c3e 100644 --- a/theories/examples/input_lang_delim/example.v +++ b/theories/examples/input_lang_delim/example.v @@ -1,7 +1,5 @@ -From gitrees Require Import gitree. +From gitrees Require Import gitree lang_generic. From gitrees.examples.input_lang_delim Require Import lang interp. -Require Import gitrees.lang_generic. -From iris.algebra Require Import gmap excl auth gmap_view. From iris.proofmode Require Import base classes tactics environments. From iris.base_logic Require Import algebra. @@ -63,6 +61,7 @@ Proof. (* then, shift *) do 2 shift_hom. iApply (wp_shift with "Hσ"). + { rewrite laterO_map_Next. done. } iIntros "!>_ Hσ". simpl. @@ -70,7 +69,7 @@ Proof. 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σ"). + iApply (wp_app_cont with "Hσ"); first done. iIntros "!> _ Hσ". simpl. rewrite later_map_Next -Tick_eq. iApply wp_tick. iNext. @@ -86,7 +85,7 @@ Proof. shift_hom. shift_natop_l. rewrite get_fun_fun. simpl. shift_hom. shift_natop_l. - iApply (wp_app_cont with "Hσ"). + iApply (wp_app_cont with "Hσ"); first done. iIntros "!> _ Hσ". simpl. rewrite later_map_Next -Tick_eq. iApply wp_tick. iNext. diff --git a/theories/examples/input_lang_delim/interp.v b/theories/examples/input_lang_delim/interp.v index c82d255..3f0b2db 100644 --- a/theories/examples/input_lang_delim/interp.v +++ b/theories/examples/input_lang_delim/interp.v @@ -1,25 +1,14 @@ (* From Equations Require Import Equations. *) -From gitrees Require Import gitree. +From gitrees Require Import gitree lang_generic. From gitrees.examples.input_lang_delim Require Import lang. -Require Import gitrees.lang_generic. -From iris.algebra Require Import gmap excl auth gmap_view. +From iris.algebra Require Import list. From iris.proofmode Require Import classes tactics. From iris.base_logic Require Import algebra. -From iris.heap_lang Require Export locations. -Require Import Binding.Lib. -Require Import Binding.Set. +Require Import Binding.Lib Binding.Set. -(** * State *) - -(* Definition stateF : oFunctor := (gmapOF unitO (▶ ∙))%OF. *) - -(* #[local] Instance state_inhabited : Inhabited (stateF ♯ unitO). *) -(* Proof. apply _. Qed. *) -(* #[local] Instance state_cofe X `{!Cofe X} : Cofe (stateF ♯ X). *) -(* Proof. apply _. Qed. *) - +(** * State, corresponding to a meta-continuation *) Definition stateF : oFunctor := (listOF (▶ ∙ -n> ▶ ∙))%OF. #[local] Instance state_inhabited : Inhabited (stateF ♯ unitO). @@ -237,38 +226,35 @@ Section weakestpre. (** ** SHIFT *) Lemma wp_shift (σ : state) (f : (laterO IT -n> laterO IT) -n> laterO IT) - (k : IT -n> IT) {Hk : IT_hom k} Φ s : + (k : IT -n> IT) β {Hk : IT_hom k} Φ s : + laterO_map 𝒫 (f (laterO_map k)) ≡ Next β → has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} 𝒫 (later_car ( f (laterO_map k))) @ s {{ Φ }}) -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} β @ s {{ Φ }}) -∗ WP@{rs} (k (SHIFT f)) @ s {{ Φ }}. Proof. - iIntros "Hs Ha". + iIntros (Hp) "Hs Ha". unfold SHIFT. simpl. rewrite hom_vis. - iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (later_map 𝒫 $ f (laterO_map k)) with "Hs"). + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (laterO_map 𝒫 $ f (laterO_map k)) with "Hs"). { - simpl. - repeat f_equiv. - - rewrite ccompose_id_l. intro. simpl. by rewrite ofe_iso_21. - - reflexivity. + simpl. do 2 f_equiv; last done. do 2 f_equiv. + rewrite ccompose_id_l. intro. simpl. by rewrite ofe_iso_21. } - { by rewrite later_map_Next. } + { exact Hp. } iModIntro. iApply "Ha". Qed. - - - Lemma wp_reset (σ : state) (e : laterO IT) (k : IT -n> IT) {Hk : IT_hom k} + 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} 𝒫 (later_car e) @ s {{ Φ }}) -∗ - WP@{rs} k $ (RESET e) @ s {{ Φ }}. + 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 _ _ _ _ _ _ _ (laterO_map 𝒫 e) with "Hs"). + 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. @@ -276,7 +262,7 @@ Section weakestpre. - iApply "Ha". Qed. - + (** XXX: Formulate the rules using AsVal *) Lemma wp_pop_end (v : ITV) Φ s : has_substate [] -∗ @@ -306,24 +292,24 @@ Section weakestpre. Qed. Lemma wp_app_cont (σ : state) (e : laterO IT) (k' : laterO (IT -n> IT)) - (k : IT -n> IT) {Hk : IT_hom k} + (k : IT -n> IT) β {Hk : IT_hom k} Φ s : + laterO_ap k' e ≡ Next β → has_substate σ -∗ ▷ (£ 1 -∗ has_substate ((laterO_map k) :: σ) -∗ - WP@{rs} later_car (laterO_ap k' e) @ s {{ Φ }}) -∗ + WP@{rs} β @ s {{ Φ }}) -∗ WP@{rs} k (APP_CONT e k') @ s {{ Φ }}. Proof. - iIntros "Hs Ha". + iIntros (Hb) "Hs Ha". unfold APP_CONT. simpl. rewrite hom_vis. - iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (laterO_ap k' e) with "Hs"). - - simpl. do 2 f_equiv. + 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. @@ -359,15 +345,13 @@ Section interp. Program Definition interp_shift {S} (e : @interp_scope F R _ (inc S) -n> IT) : interp_scope S -n> IT := λne env, SHIFT (λne (k : laterO IT -n> laterO IT), - Next (e (@extend_scope F R _ _ env (λit x, Tau (k (Next x)))))). + Next (e (extend_scope env (λit x, Tau (k (Next x)))))). Next Obligation. solve_proper. Qed. Next Obligation. solve_proper_prepare. repeat f_equiv. intros [| a]; simpl; last solve_proper. - repeat f_equiv. - intros ?; simpl. - by repeat f_equiv. + repeat f_equiv. solve_proper. Qed. Next Obligation. solve_proper_prepare. @@ -391,49 +375,42 @@ Section interp. (** ** REC *) Opaque laterO_map. - Program Definition interp_rec_pre {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) - : laterO (@interp_scope F R _ S -n> IT) -n> @interp_scope F R _ S -n> IT := - λne self env, Fun $ laterO_map (λne (self : @interp_scope F R _ S -n> IT) (a : IT), - body (@extend_scope F R _ _ (@extend_scope F R _ _ env (self env)) a)) self. + Program Definition interp_rec_pre {S : Set} (body : interp_scope (inc (inc S)) -n> IT) + : laterO (interp_scope S -n> IT) -n> interp_scope S -n> IT := + λne self env, Fun $ laterO_map (λne (self : interp_scope S -n> IT) (a : IT), + body (extend_scope (extend_scope env (self env)) a)) self. Next Obligation. - intros. solve_proper_prepare. f_equiv; intros [| [| y']]; simpl; solve_proper. Qed. Next Obligation. - intros. solve_proper_prepare. f_equiv; intros [| [| y']]; simpl; solve_proper. Qed. Next Obligation. - intros. solve_proper_prepare. do 3 f_equiv; intros ??; simpl; f_equiv; intros [| [| y']]; simpl; solve_proper. Qed. Next Obligation. - intros. solve_proper_prepare. by do 2 f_equiv. Qed. Program Definition interp_rec {S : Set} - (body : @interp_scope F R _ (inc (inc S)) -n> IT) : - @interp_scope F R _ S -n> IT := + (body : interp_scope (inc (inc S)) -n> IT) : interp_scope S -n> IT := mmuu (interp_rec_pre body). Program Definition ir_unf {S : Set} - (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : IT -n> IT := - λne a, body (@extend_scope F R _ _ - (@extend_scope F R _ _ env (interp_rec body env)) - a). + (body : interp_scope (inc (inc S)) -n> IT) env : IT -n> IT := + λne a, body (extend_scope + (extend_scope env (interp_rec body env)) a). Next Obligation. - intros. solve_proper_prepare. f_equiv. intros [| [| y']]; simpl; solve_proper. Qed. - Lemma interp_rec_unfold {S : Set} (body : @interp_scope F R _ (inc (inc S)) -n> IT) env : + Lemma interp_rec_unfold {S : Set} (body : interp_scope (inc (inc S)) -n> IT) env : interp_rec body env ≡ Fun $ Next $ ir_unf body env. Proof. trans (interp_rec_pre body (Next (interp_rec body)) env). @@ -480,28 +457,11 @@ Section interp. λne env, Ret n. (** ** CONT *) + (** XXX DF: why do we need a tick here? Seems to be necessary for soundness *) Program Definition interp_cont_val {S} (K : S -n> (IT -n> IT)) : S -n> IT := - λne env, (λit x, Tau (laterO_map (𝒫 ◎ K env) (Next x))). + λne env, (λit x, Tick $ 𝒫 (K env x)). Solve All Obligations with solve_proper_please. - (* Program Definition interp_cont {S} (e : @interp_scope F R _ (inc S) -n> IT) : *) - (* interp_scope S -n> IT := *) - (* λne env, (Fun (Next (λne x, Tick $ e (@extend_scope F R _ _ env x)))). *) - (* Next Obligation. *) - (* solve_proper_prepare. repeat f_equiv. *) - (* intros [|a]; eauto. *) - (* Qed. *) - (* Next Obligation. *) - (* solve_proper_prepare. *) - (* repeat f_equiv. *) - (* intro. simpl. repeat f_equiv. *) - (* intros [|z]; eauto. *) - (* Qed. *) - - (* #[local] Instance interp_reset_full_ne {S} (f : @interp_scope F R _ S -n> IT): *) - (* NonExpansive (λ env, interp_reset (f env)). *) - (* Proof. solve_proper. Qed. *) - Program Definition interp_ifk {A} (e1 e2 : A -n> IT) (K : A -n> IT -n> IT) : A -n> (IT -n> IT) := λne env b, (K env) $ interp_if (λne env, b) e1 e2 env. @@ -692,16 +652,6 @@ Section interp. intro. simpl. by repeat f_equiv. Qed. - - (* Lemma interp_ectx_ren {S S'} env (δ : S [→] S') (K : ectx S) : *) - (* interp_ectx (fmap δ K) env ≡ interp_ectx K (ren_scope δ env). *) - (* Proof. *) - (* induction K; intros ?; simpl; eauto. *) - (* destruct a; simpl; try (etrans; first by apply IHK); repeat f_equiv; *) - (* try solve [by apply interp_expr_ren | by apply interp_val_ren]. *) - (* 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. @@ -772,9 +722,9 @@ Section interp. - (** ** Interpretation is a homomorphism (for some constructors) *) + (** ** Interpretation of continuations is a homormophism *) - #[global] Instance interp_cont_hom_emp {S} env : + #[local] Instance interp_cont_hom_emp {S} env : IT_hom (interp_cont (END : cont S) env). Proof. simple refine (IT_HOM _ _ _ _ _); intros; auto. @@ -782,8 +732,7 @@ Section interp. by rewrite laterO_map_id. Qed. - - #[global] Instance interp_cont_hom_if {S} + #[local] Instance interp_cont_hom_if {S} (K : cont S) (e1 e2 : expr S) env : IT_hom (interp_cont K env) -> IT_hom (interp_cont (IfK e1 e2 K) env). @@ -800,7 +749,7 @@ Section interp. Qed. - #[global] Instance interp_cont_hom_appr {S} (K : cont S) + #[local] Instance interp_cont_hom_appr {S} (K : cont S) (e : expr S) env : IT_hom (interp_cont K env) -> IT_hom (interp_cont (AppRK e K) env). @@ -812,7 +761,7 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_cont_hom_appl {S} (K : cont S) + #[local] Instance interp_cont_hom_appl {S} (K : cont S) (v : val S) (env : interp_scope S) : IT_hom (interp_cont K env) -> IT_hom (interp_cont (AppLK v K) env). @@ -830,19 +779,19 @@ Section interp. Qed. - #[global] Instance interp_cont_hom_app_contr {S} (K : cont S) + #[local] Instance interp_cont_hom_app_contr {S} (K : cont S) (e : expr S) env : IT_hom (interp_cont K env) -> IT_hom (interp_cont (AppContRK e K) env). Proof. intros. simple refine (IT_HOM _ _ _ _ _); intros; simpl. - - by rewrite -!hom_tick. + - by rewrite -!hom_tick. - rewrite !hom_vis. f_equiv. intro x. simpl. by rewrite -laterO_map_compose. - by rewrite !hom_err. Qed. - #[global] Instance interp_cont_hom_app_contl {S} (K : cont S) + #[local] Instance interp_cont_hom_app_contl {S} (K : cont S) (v : val S) (env : interp_scope S) : IT_hom (interp_cont K env) -> IT_hom (interp_cont (AppContLK v K) env). @@ -859,7 +808,7 @@ Section interp. Qed. - #[global] Instance interp_cont_hom_natopr {S} (K : cont S) + #[local] Instance interp_cont_hom_natopr {S} (K : cont S) (e : expr S) op env : IT_hom (interp_cont K env) -> IT_hom (interp_cont (NatOpRK op e K) env). @@ -871,7 +820,7 @@ Section interp. - by rewrite !hom_err. Qed. - #[global] Instance interp_cont_hom_natopl {S} (K : cont S) + #[local] Instance interp_cont_hom_natopl {S} (K : cont S) (v : val S) op (env : interp_scope S) : IT_hom (interp_cont K env) -> IT_hom (interp_cont (NatOpLK op v K) env). @@ -888,14 +837,6 @@ Section interp. + apply hom_err. Qed. - - Lemma get_fun_ret' E A `{Cofe A} n : (∀ f, @get_fun E A _ f (core.Ret n) ≡ Err RuntimeErr). - Proof. - intros. - by rewrite IT_rec1_ret. - Qed. - - #[global] Instance interp_cont_hom {S} (K : cont S) env : IT_hom (interp_cont K env). @@ -903,8 +844,6 @@ Section interp. induction K; simpl; apply _. Qed. - - (** ** Finally, preservation of reductions *) Lemma interp_cred_no_reify {S : Set} (env : interp_scope S) (C C' : config S) (t t' : IT) (σ σ' : state) n : @@ -943,28 +882,27 @@ Section interp. (interp_config C env) = (t, σ) -> (interp_config C' env) = (t', σ') -> σ = σ'. - Proof. + Proof. inversion 1; cbn; intros Ht Ht'; inversion Ht; inversion Ht'; subst; reflexivity. Qed. Opaque map_meta_cont. Opaque extend_scope. - Opaque Ret. Lemma interp_cred_yes_reify {S : Set} (env : interp_scope S) (C C' : config S) - (t t' : IT) (σ σ' : state) (σr : gState_rest CtxDep sR_idx rs ♯ IT) n : + (t t' : IT) (σ σ' : state) (σr : gState_rest sR_idx rs ♯ IT) n : C ===> C' / (n, 1) -> (interp_config C env) = (t, σ) -> (interp_config C' env) = (t', σ') -> - reify (gReifiers_sReifier CtxDep rs) t (gState_recomp CtxDep σr (sR_state σ)) - ≡ (gState_recomp CtxDep σr (sR_state σ'), Tick_n n $ t'). + reify (gReifiers_sReifier rs) t (gState_recomp σr (sR_state σ)) + ≡ (gState_recomp σr (sR_state σ'), Tick_n n $ t'). Proof. inversion 1; cbn-[IF APP' Tick get_ret2 gState_recomp]; intros Ht Ht'; inversion Ht; inversion Ht'; subst; try rewrite !map_meta_cont_cons in Ht, Ht'|-*. - - trans (reify (gReifiers_sReifier CtxDep rs) + - trans (reify (gReifiers_sReifier rs) (RESET_ (laterO_map (𝒫 ◎ (interp_cont k env))) (Next (interp_expr e env))) - (gState_recomp CtxDep σr (sR_state (map_meta_cont mk env)))). + (gState_recomp σr (sR_state (map_meta_cont mk env)))). { repeat f_equiv. rewrite !hom_vis. simpl. f_equiv. rewrite ccompose_id_l. by intro. @@ -984,9 +922,9 @@ Section interp. match goal with | |- context G [Vis ?o ?f ?κ] => set (fin := f); set (op := o); set (kout := κ) end. - trans (reify (gReifiers_sReifier CtxDep rs) + trans (reify (gReifiers_sReifier rs) (Vis op fin ((laterO_map (𝒫 ◎ interp_cont k env)) ◎ kout)) - (gState_recomp CtxDep σr (sR_state σ))). + (gState_recomp σr (sR_state σ))). { repeat f_equiv. rewrite !hom_vis. f_equiv. by intro. } @@ -1002,6 +940,7 @@ Section interp. - subst fin. reflexivity. - solve_proper. } + simpl. rewrite -Tick_eq. do 3 f_equiv. rewrite interp_expr_subst. simpl. f_equiv. @@ -1015,10 +954,10 @@ Section interp. | |- context G [ofe_mor_car _ _ (get_fun _) (ofe_mor_car _ _ Fun ?f)] => set (fin := f) end. - trans (reify (gReifiers_sReifier CtxDep rs) + trans (reify (gReifiers_sReifier rs) (APP_CONT_ (Next (interp_val v env)) fin kk) - (gState_recomp CtxDep σ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. @@ -1035,8 +974,8 @@ Section interp. } f_equiv. by rewrite -!Tick_eq. - remember (map_meta_cont mk env) as σ. - trans (reify (gReifiers_sReifier CtxDep rs) (POP (interp_val v env)) - (gState_recomp CtxDep σr (sR_state (laterO_map (𝒫 ◎ interp_cont k env) :: σ)))). + trans (reify (gReifiers_sReifier rs) (POP (interp_val v env)) + (gState_recomp σr (sR_state (laterO_map (𝒫 ◎ interp_cont k env) :: σ)))). { do 2 f_equiv; last repeat f_equiv. apply get_val_ITV. @@ -1054,8 +993,8 @@ Section interp. } f_equiv. rewrite laterO_map_Next -Tick_eq. by f_equiv. - - trans (reify (gReifiers_sReifier CtxDep rs) (POP (interp_val v env)) - (gState_recomp CtxDep σr (sR_state []))). + - trans (reify (gReifiers_sReifier rs) (POP (interp_val v env)) + (gState_recomp σr (sR_state []))). { do 2 f_equiv; last first. { f_equiv. by rewrite map_meta_cont_nil. } @@ -1078,14 +1017,14 @@ Section interp. (** * SOUNDNESS *) Lemma soundness {S : Set} (env : interp_scope S) (C C' : config S) - (t t' : IT) (σ σ' : state) (σr : gState_rest CtxDep sR_idx rs ♯ IT) n nm : + (t t' : IT) (σ σ' : state) (σr : gState_rest sR_idx rs ♯ IT) n nm : steps C C' nm -> fst nm = n -> (interp_config C env) = (t, σ) -> (interp_config C' env) = (t', σ') -> - ssteps (gReifiers_sReifier CtxDep rs) - t (gState_recomp CtxDep σr (sR_state σ)) - t' (gState_recomp CtxDep σr (sR_state σ')) n. + ssteps (gReifiers_sReifier rs) + t (gState_recomp σr (sR_state σ)) + t' (gState_recomp σr (sR_state σ')) n. Proof. intros H. revert n t t' σ σ'. @@ -1100,11 +1039,11 @@ Section interp. specialize (interp_cred_no_reify_state env _ _ _ _ _ _ _ H0 Ht Heqc2) as <-; simpl in Heq|-*; rewrite Heq; eapply IHs]; try solve - [eapply ssteps_many with t2 (gState_recomp CtxDep σr (sR_state σ2)); last 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; cbn in Ht; eapply sstep_reify; last done; inversion Ht; rewrite !hom_vis; done]. - + eapply ssteps_many with t2 (gState_recomp CtxDep σr (sR_state σ2)); last 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 <-. simpl in Heq|-*; rewrite Heq. constructor; eauto. @@ -1112,19 +1051,19 @@ Section interp. simpl in Heq|-*. change (2+n') with (1+(1+n')). eapply ssteps_many; last first. - * eapply ssteps_many with t2 (gState_recomp CtxDep σr (sR_state σ2)); last done. + * eapply ssteps_many with t2 (gState_recomp σr (sR_state σ2)); last done. eapply sstep_tick; reflexivity. * eapply sstep_reify; last apply Heq. cbn in Ht. inversion Ht. rewrite get_val_ITV. simpl. rewrite get_fun_fun. simpl. rewrite !hom_vis. done. - + eapply ssteps_many with t2 (gState_recomp CtxDep σr (sR_state σ2)); last 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. 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 CtxDep σr (sR_state σ2)); last 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. cbn in Ht; inversion Ht. subst. rewrite get_val_ITV. simpl. eapply sstep_reify; simpl in Heq; last first. diff --git a/theories/examples/input_lang_delim/lang.v b/theories/examples/input_lang_delim/lang.v index 66aadb3..dbd9688 100644 --- a/theories/examples/input_lang_delim/lang.v +++ b/theories/examples/input_lang_delim/lang.v @@ -1,13 +1,7 @@ -From stdpp Require Export strings. From gitrees Require Export prelude. -(* From Equations Require Import Equations. *) -Require Import List. -Import ListNotations. Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. - -Require Import FunctionalExtensionality. - +(* Require Import FunctionalExtensionality. *) Variant nat_op := Add | Sub | Mult. @@ -23,8 +17,6 @@ Inductive expr {X : Set} := | NatOp (op : nat_op) (e₁ : expr) (e₂ : expr) : expr | If (e₁ : expr) (e₂ : expr) (e₃ : expr) : expr (* The effects *) -(* | Input : expr *) -(* | Output (e : expr) : expr *) | Shift (e : @expr (inc X)) : expr | Reset (e : expr) : expr with val {X : Set} := @@ -49,12 +41,8 @@ Arguments val X%bind : clear implicits. Arguments expr X%bind : clear implicits. Arguments cont X%bind : clear implicits. - - - Local Open Scope bind_scope. - Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := match e with | Val v => Val (vmap f v) @@ -63,8 +51,6 @@ Fixpoint emap {A B : Set} (f : A [→] B) (e : expr A) : expr B := | AppCont e₁ e₂ => AppCont (emap f e₁) (emap f e₂) | NatOp o e₁ e₂ => NatOp o (emap f e₁) (emap f e₂) | If e₁ e₂ e₃ => If (emap f e₁) (emap f e₂) (emap f e₃) - (* | Input => Input *) - (* | Output e => Output (emap f e) *) | Shift e => Shift (emap (f ↑) e) | Reset e => Reset (emap f e) end @@ -102,8 +88,6 @@ Fixpoint ebind {A B : Set} (f : A [⇒] B) (e : expr A) : expr B := | AppCont e₁ e₂ => AppCont (ebind f e₁) (ebind f e₂) | NatOp o e₁ e₂ => NatOp o (ebind f e₁) (ebind f e₂) | If e₁ e₂ e₃ => If (ebind f e₁) (ebind f e₂) (ebind f e₃) - (* | Input => Input *) - (* | Output e => Output (ebind f e) *) | Shift e => Shift (ebind (f ↑) e) | Reset e => Reset (ebind f e) end @@ -306,27 +290,12 @@ Fixpoint fill {X : Set} (K : cont X) (e : expr X) : expr X := end. - -(* Lemma fill_emap {X Y : Set} (f : X [→] Y) (K : ectx X) (e : expr X) *) -(* : fmap f (fill K e) = fill (fmap f K) (fmap f e). *) -(* Proof. *) -(* revert f. *) -(* induction K as *) -(* [ | ?? IH | ?? IH | ?? IH | ??? IH | ???? IH *) -(* | ??? IH | ?? IH ]; *) -(* intros f; term_simpl; first done; rewrite IH; reflexivity. *) -(* Qed. *) - -(*** Operational semantics *) +(*** Continuation operations *) Global Instance fill_inj {S} (Ki : cont S) : Inj (=) (=) (fill Ki). Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed. -(* Lemma ctx_el_to_expr_val {S} C (e : expr S) : *) -(* is_Some (to_val (ctx_el_to_expr C e)) → is_Some (to_val e). *) -(* Proof. case : C => [] > H; simpl in H; try by apply is_Some_None in H. Qed. *) - Lemma fill_val {S} Ki (e : expr S) : is_Some (to_val (fill Ki e)) → is_Some (to_val e). Proof. @@ -334,12 +303,6 @@ Proof. apply H in H0; simpl in H0; contradiction (is_Some_None H0). Qed. -(* (* CHECK *) *) -(* Lemma val_head_stuck {S} (e1 : expr S) e2 K K' Ko m : *) -(* head_step e1 K e2 K' Ko m → to_val e1 = None. *) -(* Proof. destruct 1; naive_solver. Qed. *) - - (* K1 ∘ K2 *) Fixpoint cont_compose {S} (K1 K2 : cont S) : cont S := match K2 with @@ -353,7 +316,6 @@ Fixpoint cont_compose {S} (K1 K2 : cont S) : cont S := | NatOpRK op e K => NatOpRK op e (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). Proof. elim: K2 K1 e =>>; eauto; @@ -458,13 +420,6 @@ where "c ===> c' / nm" := (Cred c c' nm). Arguments Mcont S%bind : clear implicits. Arguments config S%bind : clear implicits. -(** ** On configs & meta-contexts *) - -Definition meta_fill {S} (mk : Mcont S) e := - fold_left (λ e k, fill k e) mk e. - - - Inductive steps {S} : config S -> config S -> (nat * nat) -> Prop := | steps_zero : forall c, steps c c (0,0) @@ -473,15 +428,8 @@ Inductive steps {S} : config S -> config S -> (nat * nat) -> Prop := steps c2 c3 (n',m') -> steps c1 c3 (n+n',m+m'). - -(* Lemma ceval_expr_to_val {S} : *) -(* forall (e : expr S) k mk, exists v nm, steps (Ceval e k mk) (Ceval v k mk) nm. *) -(* Proof. *) -(* intros. *) -(* induction 1; intros. *) -(* - exists (Val v), (0,0). constructor. *) -(* - *) - +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 *) @@ -564,6 +512,8 @@ Inductive ty := (* typed_val Γ (RecV e) (Tarr τ1 τ2) *) (* . *) +(*** Notations *) + Declare Scope syn_scope. Delimit Scope syn_scope with syn. diff --git a/theories/examples/input_lang_delim/logrel.v b/theories/examples/input_lang_delim/logrel.v index 6b03fa6..eb41879 100644 --- a/theories/examples/input_lang_delim/logrel.v +++ b/theories/examples/input_lang_delim/logrel.v @@ -1,5 +1,4 @@ (** Logical relation for adequacy for the IO lang *) -From Equations Require Import Equations. From gitrees Require Import gitree. From gitrees.examples.input_lang_callcc Require Import lang interp hom. Require Import gitrees.lang_generic. diff --git a/theories/gitree/greifiers.v b/theories/gitree/greifiers.v index 1e549a4..e1847c8 100644 --- a/theories/gitree/greifiers.v +++ b/theories/gitree/greifiers.v @@ -566,7 +566,12 @@ Arguments gReifiers_cons {_ _}. Arguments gReifiers_nil {_}. Arguments gReifiers_ops {_ _}. Arguments gReifiers_re {_ _}. +Arguments gState_rest {_ _}. +Arguments gState_recomp {_ _ _ _ _ _}. +Arguments gState_decomp {_ _} _ {_ _ _}. +Arguments gState_decomp' {_ _} _ {_ _ _}. Arguments gReifiers_state {_ _}. Arguments gReifiers_re_idx {_ _}. Arguments gReifiers_re_idx_type {_ _}. Arguments gReifiers_re_type {_ _}. +Arguments gReifiers_sReifier {_ _}. diff --git a/theories/gitree/weakestpre.v b/theories/gitree/weakestpre.v index 45d4d16..e6e343f 100644 --- a/theories/gitree/weakestpre.v +++ b/theories/gitree/weakestpre.v @@ -6,32 +6,32 @@ From gitrees.gitree Require Import core reify greifiers reductions. (** * Ghost state from gReifiers *) -Definition gReifiers_ucmra {n} (a : is_ctx_dep) (rs : gReifiers a n) +Definition gReifiers_ucmra {n} {a : is_ctx_dep} (rs : gReifiers a n) (X : ofe) `{!Cofe X} : ucmra := discrete_funUR (λ (i : fin n), optionUR (exclR (sReifier_state (rs !!! i) ♯ X))). (** The resource corresponding to the whole global state *) -Definition of_state {n} (a : is_ctx_dep) (rs : gReifiers a n) +Definition of_state {n} {a : is_ctx_dep} (rs : gReifiers a n) (X : ofe) `{!Cofe X} (st : gReifiers_state rs ♯ X) - : gReifiers_ucmra a rs X := - λ i, Excl' (fstO (gState_decomp a i st)). + : gReifiers_ucmra rs X := + λ i, Excl' (fstO (gState_decomp i st)). (** The resource corresponding to a speicific projection out of the global state *) -Definition of_idx {n} (a : is_ctx_dep) (rs : gReifiers a n) +Definition of_idx {n} {a : is_ctx_dep} (rs : gReifiers a n) (X : ofe) `{!Cofe X} (i : fin n) - (st : sReifier_state (rs !!! i) ♯ X) : gReifiers_ucmra a rs X. + (st : sReifier_state (rs !!! i) ♯ X) : gReifiers_ucmra rs X. Proof. simple refine (λ j, if (decide (j = i)) then _ else None). simpl. induction e. exact (Excl' st). Defined. -Lemma of_state_recomp_lookup_ne {n} (a : is_ctx_dep) (rs : gReifiers a n) +Lemma of_state_recomp_lookup_ne {n} {a : is_ctx_dep} (rs : gReifiers a n) (X : ofe) `{!Cofe X} i j (σ1 σ2 : sReifier_state (rs !!! i) ♯ X) rest : i ≠ j → - of_state a rs X (gState_recomp a rest σ1) j - ≡ of_state a rs X (gState_recomp a rest σ2) j. + of_state rs X (gState_recomp rest σ1) j + ≡ of_state rs X (gState_recomp rest σ2) j. Proof. intros Hij. revert σ1 σ2 rest. unfold of_state. @@ -50,11 +50,11 @@ Proof. Qed. Section ucmra. - Context {n : nat} (a : is_ctx_dep) (rs : gReifiers a n). + Context {n : nat} {a : is_ctx_dep} (rs : gReifiers a n). Context (X : ofe) `{!Cofe X}. - Notation gReifiers_ucmra := (gReifiers_ucmra a rs X). - Notation of_state := (of_state a rs X). - Notation of_idx := (of_idx a rs X). + Notation gReifiers_ucmra := (gReifiers_ucmra rs X). + Notation of_state := (of_state rs X). + Notation of_idx := (of_idx rs X). #[export] Instance of_state_ne : NonExpansive of_state. Proof. solve_proper. Qed. @@ -65,14 +65,14 @@ Section ucmra. Proof. intro; done. Qed. Lemma of_state_recomp_lookup i (σ : sReifier_state (rs !!! i) ♯ X) rest : - of_state (gState_recomp a rest σ) i ≡ Excl' σ. + of_state (gState_recomp rest σ) i ≡ Excl' σ. Proof. unfold of_state. rewrite gState_decomp_recomp. done. Qed. Lemma of_state_decomp_local_update i (σ σ1 σ2 : sReifier_state (rs !!! i) ♯ X) rest : - (of_state (gState_recomp a rest σ1), of_idx i σ2) - ~l~> (of_state (gState_recomp a rest σ), of_idx i σ). + (of_state (gState_recomp rest σ1), of_idx i σ2) + ~l~> (of_state (gState_recomp rest σ), of_idx i σ). Proof. apply discrete_fun_local_update. intros j. @@ -88,7 +88,7 @@ Section ucmra. Qed. Lemma of_state_of_idx_agree i σ1 σ2 rest f Σ : - of_state (gState_recomp a rest σ1) ≡ of_idx i σ2 ⋅ f ⊢@{iProp Σ} σ1 ≡ σ2. + of_state (gState_recomp rest σ1) ≡ of_idx i σ2 ⋅ f ⊢@{iProp Σ} σ1 ≡ σ2. Proof. iIntros "Hs". rewrite discrete_fun_equivI. @@ -106,16 +106,16 @@ Section ucmra. End ucmra. Section weakestpre. - Context {n : nat} (a : is_ctx_dep) (rs : gReifiers a n) {A} `{!Cofe A}. - Notation rG := (gReifiers_sReifier a rs). + Context {n : nat} {a : is_ctx_dep} (rs : gReifiers a n) {A} `{!Cofe A}. + Notation rG := (gReifiers_sReifier rs). Notation F := (sReifier_ops rG). Notation IT := (IT F A). Notation ITV := (ITV F A). Notation stateF := (gReifiers_state rs). Notation stateO := (stateF ♯ IT). - Notation stateR := (gReifiers_ucmra a rs IT). - Let of_state := (of_state a rs IT). - Let of_idx := (of_idx a rs IT). + Notation stateR := (gReifiers_ucmra rs IT). + Let of_state := (of_state rs IT). + Let of_idx := (of_idx rs IT). Notation reify := (reify rG). Notation istep := (istep rG). Notation isteps := (isteps rG). @@ -164,8 +164,8 @@ Section weakestpre. Lemma state_interp_has_state_idx_agree (i : fin n) (σ1 σ2 : sReifier_state (rs !!! i) ♯ IT) - (rest : gState_rest a i rs ♯ IT) `{!stateG Σ} : - state_interp (gState_recomp a rest σ1) -∗ has_state_idx i σ2 -∗ σ1 ≡ σ2. + (rest : gState_rest i rs ♯ IT) `{!stateG Σ} : + state_interp (gState_recomp rest σ1) -∗ has_state_idx i σ2 -∗ σ1 ≡ σ2. Proof. iIntros "H1 H2". iDestruct (own_valid_2 with "H1 H2") as "Hs". @@ -177,14 +177,14 @@ Section weakestpre. Lemma state_interp_has_state_idx_update (i : fin n) (σ σ1 σ2 : sReifier_state (rs !!! i) ♯ IT) - (rest : gState_rest a i rs ♯ IT) `{!stateG Σ} : - state_interp (gState_recomp a rest σ1) -∗ has_state_idx i σ2 ==∗ - state_interp (gState_recomp a rest σ) ∗ has_state_idx i σ. + (rest : gState_rest i rs ♯ IT) `{!stateG Σ} : + state_interp (gState_recomp rest σ1) -∗ has_state_idx i σ2 ==∗ + state_interp (gState_recomp rest σ) ∗ has_state_idx i σ. Proof. iIntros "H1 H2". iMod (own_update_2 with "H1 H2") as "H". { apply auth_update. - apply (of_state_decomp_local_update a _ _ _ σ). } + apply (of_state_decomp_local_update _ _ _ σ). } iDestruct "H" as "[$ $]". done. Qed. @@ -407,8 +407,8 @@ Section weakestpre. forall (x : Ins (F op) ♯ IT) (k : Outs (F op) ♯ IT -n> laterO IT), (|={E1,E2}=> ∃ σ σ' β, has_state_idx i σ ∗ - ∀ rest, reify (Vis op x k) (gState_recomp a rest σ) - ≡ (gState_recomp a rest σ', Tick β) ∗ + ∀ rest, reify (Vis op x k) (gState_recomp rest σ) + ≡ (gState_recomp rest σ', Tick β) ∗ ▷ (£ 1 -∗ has_state_idx i σ' -∗ |={E2,E1}=> WP β @ s;E1 {{ Φ }})) -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. Proof. @@ -418,8 +418,8 @@ Section weakestpre. iRight. iSplit. { iPureIntro. apply IT_to_V_Vis. } iIntros (fs) "Hgst". - destruct (gState_decomp a i fs) as [σ0 rest] eqn:Hdecomp. - assert (fs ≡ gState_recomp a rest σ0) as Hfs. + destruct (gState_decomp i fs) as [σ0 rest] eqn:Hdecomp. + assert (fs ≡ gState_recomp rest σ0) as Hfs. { symmetry. apply gState_recomp_decomp. by rewrite Hdecomp. } iMod "H" as (σ σ' β) "[Hlst H]". @@ -434,10 +434,10 @@ Section weakestpre. iSplit. { (* it is safe *) iLeft. - iExists β,(gState_recomp a rest σ'). iRight. - iExists op,x,k; eauto. } + iExists β, (gState_recomp rest σ'). iRight. + iExists op, x, k; eauto. } iIntros (fs' α0) "Hst Hlc". rewrite istep_vis. - iAssert (gState_recomp a rest σ' ≡ fs' ∧ Tick β ≡ Tick α0)%I + iAssert (gState_recomp rest σ' ≡ fs' ∧ Tick β ≡ Tick α0)%I with "[Hreify Hst]" as "[Hst Hb]". { iRewrite "Hreify" in "Hst". by rewrite prod_equivI. } @@ -453,7 +453,7 @@ Section weakestpre. Lemma wp_reify E1 s Φ i (lop : opid (sReifier_ops (rs !!! i))) x k σ σ' β : let op : opid F := (existT i lop) in - (∀ rest, reify (Vis op x k) (gState_recomp a rest σ) ≡ (gState_recomp a rest σ', Tick β)) → + (∀ rest, reify (Vis op x k) (gState_recomp rest σ) ≡ (gState_recomp rest σ', Tick β)) → has_state_idx i σ -∗ ▷ (£ 1 -∗ has_state_idx i σ' -∗ WP β @ s;E1 {{ Φ }}) -∗ WP (Vis op x k) @ s;E1 {{ Φ }}. @@ -667,21 +667,20 @@ End weakestpre. Section weakestpre_specific. Context {n : nat} {A} `{!Cofe A}. - Notation rG a rs := (gReifiers_sReifier (n := n) a rs). - Notation F a rs := (sReifier_ops (rG a rs)). - Notation IT a rs := (IT (F a rs) A). - Notation ITV a rs := (ITV (F a rs) A). - Notation stateF a rs := (gReifiers_state a rs). - Notation stateO a rs := (stateF a rs ♯ IT a rs). - Notation stateR a rs := (gReifiers_ucmra a rs (IT a rs)). - Let of_state a rs := (of_state a rs (IT a rs)). - Let of_idx a rs := (of_idx a rs (IT a rs)). - Notation reify a rs := (reify (rG a rs)). - Notation istep a rs := (istep (rG a rs)). - Notation isteps a rs := (isteps (rG a rs)). - Notation sstep a rs := (sstep (rG a rs)). - Notation ssteps a rs := (ssteps (rG a rs)). - Notation wp a rs := (wp a rs). + Notation rG rs := (gReifiers_sReifier (n := n) rs). + Notation F rs := (sReifier_ops (rG rs)). + Notation IT rs := (IT (F rs) A). + Notation ITV rs := (ITV (F rs) A). + Notation stateF rs := (gReifiers_state rs). + Notation stateO rs := (stateF rs ♯ IT rs). + Notation stateR rs := (gReifiers_ucmra rs (IT rs)). + Let of_state {a} rs := (of_state (a:=a) rs (IT rs)). + Let of_idx {a} rs := (of_idx (a:=a) rs (IT rs)). + Notation reify rs := (reify (rG rs)). + Notation istep rs := (istep (rG rs)). + Notation isteps rs := (isteps (rG rs)). + Notation sstep rs := (sstep (rG rs)). + Notation ssteps rs := (ssteps (rG rs)). Context `{!invGS Σ}. Notation iProp := (iProp Σ). @@ -690,15 +689,15 @@ Section weakestpre_specific. Lemma wp_reify_idx_ctx_dep (rs : gReifiers CtxDep n) `{!@stateG _ CtxDep rs A _ Σ} E1 E2 s Φ i (lop : opid (sReifier_ops (rs !!! i))) : - let op : opid (F CtxDep rs) := (existT i lop) in - forall (x : Ins (F CtxDep rs op) ♯ IT CtxDep rs) - (k : Outs (F CtxDep rs op) ♯ IT CtxDep rs -n> laterO (IT CtxDep rs)), + let op : opid (F rs) := (existT i lop) in + forall (x : Ins (F rs op) ♯ IT rs) + (k : Outs (F rs op) ♯ IT rs -n> laterO (IT rs)), (|={E1,E2}=> - ∃ σ y σ' β, has_state_idx CtxDep rs i σ + ∃ σ y σ' β, has_state_idx rs i σ ∗ sReifier_re (rs !!! i) lop (x, σ, k) ≡ Some (y, σ') ∗ y ≡ Next β - ∗ ▷ (£ 1 -∗ has_state_idx CtxDep rs i σ' ={E2,E1}=∗ wp CtxDep rs β s E1 Φ)) - -∗ wp CtxDep rs (Vis op x k) s E1 Φ. + ∗ ▷ (£ 1 -∗ has_state_idx rs i σ' ={E2,E1}=∗ wp rs β s E1 Φ)) + -∗ wp rs (Vis op x k) s E1 Φ. Proof. intros op x k. iIntros "H". @@ -708,13 +707,13 @@ Section weakestpre_specific. iFrame "Hlst". iIntros (rest). iFrame "H". - iAssert (gReifiers_re rs _ _ op (x, gState_recomp CtxDep rest σ, _) - ≡ Some (y, gState_recomp CtxDep rest σ'))%I + iAssert (gReifiers_re rs _ _ op (x, gState_recomp rest σ, _) + ≡ Some (y, gState_recomp rest σ'))%I with "[Hreify]" as "Hgreify". { rewrite (@gReifiers_re_idx _ CtxDep). - iAssert (optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) + iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) (sReifier_re (rs !!! i) lop (x, σ, k)) - ≡ optionO_map (prodO_map idfun (gState_recomp CtxDep rest)) + ≡ optionO_map (prodO_map idfun (gState_recomp rest)) (Some (y, σ')))%I with "[Hreify]" as "H". - iApply (f_equivI with "Hreify"). - simpl. iExact "H". @@ -727,14 +726,14 @@ Section weakestpre_specific. Lemma wp_reify_idx_ctx_indep (rs : gReifiers NotCtxDep n) `{!@stateG _ NotCtxDep rs A _ Σ} E1 E2 s Φ i (lop : opid (sReifier_ops (rs !!! i))) : - let op : opid (F NotCtxDep rs) := (existT i lop) in - forall (x : Ins (F NotCtxDep rs op) ♯ IT NotCtxDep rs) - (k : Outs (F NotCtxDep rs op) ♯ IT NotCtxDep rs -n> laterO (IT NotCtxDep rs)), - (|={E1,E2}=> ∃ σ y σ' β, has_state_idx NotCtxDep rs i σ + let op : opid (F rs) := (existT i lop) in + forall (x : Ins (F rs op) ♯ IT rs) + (k : Outs (F rs op) ♯ IT rs -n> laterO (IT rs)), + (|={E1,E2}=> ∃ σ y σ' β, has_state_idx rs i σ ∗ sReifier_re (rs !!! i) lop (x, σ) ≡ Some (y, σ') ∗ k y ≡ Next β - ∗ ▷ (£ 1 -∗ has_state_idx NotCtxDep rs i σ' ={E2,E1}=∗ wp NotCtxDep rs β s E1 Φ)) - -∗ wp NotCtxDep rs (Vis op x k) s E1 Φ. + ∗ ▷ (£ 1 -∗ has_state_idx rs i σ' ={E2,E1}=∗ wp rs β s E1 Φ)) + -∗ wp rs (Vis op x k) s E1 Φ. Proof. intros op x k. iIntros "H". @@ -744,16 +743,16 @@ Section weakestpre_specific. iFrame "Hlst". iIntros (rest). iFrame "H". - iAssert (@gReifiers_re _ NotCtxDep rs _ _ op (x, gState_recomp NotCtxDep rest σ) - ≡ Some (y, gState_recomp NotCtxDep rest σ'))%I + iAssert (@gReifiers_re _ NotCtxDep rs _ _ op (x, gState_recomp rest σ) + ≡ Some (y, gState_recomp rest σ'))%I with "[Hreify]" as "Hgreify". - { pose proof (@gReifiers_re_idx n NotCtxDep i rs (IT NotCtxDep rs)) as J. + { pose proof (@gReifiers_re_idx n NotCtxDep i rs (IT rs)) as J. simpl in J. simpl. rewrite J; clear J. - iAssert (optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) + iAssert (optionO_map (prodO_map idfun (gState_recomp rest)) (sReifier_re (rs !!! i) lop (x, σ)) - ≡ optionO_map (prodO_map idfun (gState_recomp NotCtxDep rest)) + ≡ optionO_map (prodO_map idfun (gState_recomp rest)) (Some (y, σ')))%I with "[Hreify]" as "H". - iApply (f_equivI with "Hreify"). - simpl. iExact "H". @@ -765,13 +764,13 @@ Section weakestpre_specific. Lemma wp_subreify_ctx_dep' (rs : gReifiers CtxDep n) `{!@stateG _ CtxDep rs A _ Σ} E1 E2 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ (IT CtxDep rs)) - (k : Outs (F CtxDep rs (subEff_opid op)) ♯ IT CtxDep rs -n> laterO (IT CtxDep rs)) : - (|={E1,E2}=> ∃ σ y σ' β, has_substate CtxDep rs σ ∗ + (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ (IT rs)) + (k : Outs (F rs (subEff_opid op)) ♯ IT rs -n> laterO (IT rs)) : + (|={E1,E2}=> ∃ σ y σ' β, has_substate rs σ ∗ sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') ∗ y ≡ Next β - ∗ ▷ (£ 1 -∗ has_substate CtxDep rs σ' ={E2,E1}=∗ wp CtxDep rs β s E1 Φ)) - -∗ wp CtxDep rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + ∗ ▷ (£ 1 -∗ has_substate rs σ' ={E2,E1}=∗ wp rs β s E1 Φ)) + -∗ wp rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. Proof. iIntros "H". iApply wp_reify_idx_ctx_dep. @@ -791,13 +790,13 @@ Section weakestpre_specific. Lemma wp_subreify_ctx_indep' (rs : gReifiers NotCtxDep n) `{!@stateG _ NotCtxDep rs A _ Σ} E1 E2 s Φ sR `{!subReifier sR rs} - (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ (IT NotCtxDep rs)) - (k : Outs (F NotCtxDep rs (subEff_opid op)) ♯ IT NotCtxDep rs -n> laterO (IT NotCtxDep rs)) : - (|={E1,E2}=> ∃ σ y σ' β, has_substate NotCtxDep rs σ ∗ + (op : opid (sReifier_ops sR)) (x : Ins (sReifier_ops sR op) ♯ (IT rs)) + (k : Outs (F rs (subEff_opid op)) ♯ IT rs -n> laterO (IT rs)) : + (|={E1,E2}=> ∃ σ y σ' β, has_substate rs σ ∗ sReifier_re sR op (x, σ) ≡ Some (y, σ') ∗ k (subEff_outs y) ≡ Next β - ∗ ▷ (£ 1 -∗ has_substate NotCtxDep rs σ' ={E2,E1}=∗ wp NotCtxDep rs β s E1 Φ)) - -∗ wp NotCtxDep rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + ∗ ▷ (£ 1 -∗ has_substate rs σ' ={E2,E1}=∗ wp rs β s E1 Φ)) + -∗ wp rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. Proof. iIntros "H". iApply wp_reify_idx_ctx_indep. @@ -811,15 +810,15 @@ Section weakestpre_specific. Lemma wp_subreify_ctx_dep (rs : gReifiers CtxDep n) `{!@stateG _ CtxDep rs A _ Σ} E1 s Φ sR `{!subReifier sR rs} (op : opid (sReifier_ops sR)) - (x : Ins (sReifier_ops sR op) ♯ IT CtxDep rs) (y : laterO (IT CtxDep rs)) - (k : Outs (F CtxDep rs (subEff_opid op)) ♯ IT CtxDep rs -n> laterO (IT CtxDep rs)) - (σ σ' : sReifier_state sR ♯ IT CtxDep rs) β : + (x : Ins (sReifier_ops sR op) ♯ IT rs) (y : laterO (IT rs)) + (k : Outs (F rs (subEff_opid op)) ♯ IT rs -n> laterO (IT rs)) + (σ σ' : sReifier_state sR ♯ IT rs) β : sReifier_re sR op (x, σ, (k ◎ subEff_outs)) ≡ Some (y, σ') → y ≡ Next β → - has_substate CtxDep rs σ -∗ - ▷ (£ 1 -∗ has_substate CtxDep rs σ' -∗ wp CtxDep rs β s E1 Φ) + has_substate rs σ -∗ + ▷ (£ 1 -∗ has_substate rs σ' -∗ wp rs β s E1 Φ) -∗ - wp CtxDep rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + wp rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. Proof. intros HSR Hk. iIntros "Hlst H". @@ -828,7 +827,7 @@ Section weakestpre_specific. rewrite Tick_eq. rewrite -Hk. rewrite reify_vis_eq_ctx_dep //. pose proof (@subReifier_reify n CtxDep sR rs _ - (IT CtxDep rs) _ op x y (k ◎ subEff_outs) σ σ' rest) as H'. + (IT rs) _ op x y (k ◎ subEff_outs) σ σ' rest) as H'. simpl in H'. rewrite <-H'. - simpl. @@ -845,16 +844,16 @@ Section weakestpre_specific. Lemma wp_subreify_ctx_indep (rs : gReifiers NotCtxDep n) `{!@stateG _ NotCtxDep rs A _ Σ} E1 s Φ sR `{!subReifier sR rs} (op : opid (sReifier_ops sR)) - (x : Ins (sReifier_ops sR op) ♯ IT NotCtxDep rs) - (y : Outs (sReifier_ops sR op) ♯ IT NotCtxDep rs) - (k : Outs (F NotCtxDep rs (subEff_opid op)) ♯ IT NotCtxDep rs -n> laterO (IT NotCtxDep rs)) - (σ σ' : sReifier_state sR ♯ IT NotCtxDep rs) β : + (x : Ins (sReifier_ops sR op) ♯ IT rs) + (y : Outs (sReifier_ops sR op) ♯ IT rs) + (k : Outs (F rs (subEff_opid op)) ♯ IT rs -n> laterO (IT rs)) + (σ σ' : sReifier_state sR ♯ IT rs) β : sReifier_re sR op (x, σ) ≡ Some (y, σ') → k (subEff_outs y) ≡ Next β → - has_substate NotCtxDep rs σ -∗ - ▷ (£ 1 -∗ has_substate NotCtxDep rs σ' -∗ wp NotCtxDep rs β s E1 Φ) + has_substate rs σ -∗ + ▷ (£ 1 -∗ has_substate rs σ' -∗ wp rs β s E1 Φ) -∗ - wp NotCtxDep rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. + wp rs (Vis (subEff_opid op) (subEff_ins x) k) s E1 Φ. Proof. intros HSR Hk. iIntros "Hlst H". @@ -869,26 +868,26 @@ End weakestpre_specific. Section weakestpre_bind. Context {n : nat} (rs : gReifiers NotCtxDep n) {A} `{!Cofe A}. - Notation rG := (gReifiers_sReifier NotCtxDep rs). + Notation rG := (gReifiers_sReifier rs). Notation F := (sReifier_ops rG). Notation IT := (IT F A). Notation ITV := (ITV F A). - Notation stateF := (gReifiers_state NotCtxDep rs). + Notation stateF := (gReifiers_state rs). Notation stateO := (stateF ♯ IT). - Notation stateR := (gReifiers_ucmra NotCtxDep rs IT). - Let of_state := (of_state NotCtxDep rs IT). - Let of_idx := (of_idx NotCtxDep rs IT). + Notation stateR := (gReifiers_ucmra rs IT). + Let of_state := (of_state rs IT). + Let of_idx := (of_idx rs IT). Notation reify := (reify rG). Notation istep := (istep rG). Notation isteps := (isteps rG). Notation sstep := (sstep rG). Notation ssteps := (ssteps rG). - Notation wp := (wp NotCtxDep rs). + Notation wp := (wp rs). Implicit Type op : opid F. Implicit Type α β : IT. - Context `{!invGS Σ} `{!@stateG _ NotCtxDep rs A _ Σ}. + Context `{!invGS Σ} `{!stateG rs (A:=A) Σ}. Notation iProp := (iProp Σ). Notation coPsetO := (leibnizO coPset). @@ -905,7 +904,7 @@ Section weakestpre_bind. assert (NonExpansive (λ βv0, WP f (IT_of_V βv0) @ s;E1 {{ βv1, Φ βv1 }})%I). { solve_proper. } iIntros "H". iLöb as "IH" forall (α). - rewrite (wp_unfold _ _ (f _)). + rewrite (wp_unfold _ (f _)). destruct (IT_to_V (f α)) as [βv|] eqn:Hfa. - iLeft. iExists βv. iSplit; first done. assert (is_Some (IT_to_V α)) as [αv Ha]. @@ -999,7 +998,7 @@ Notation "'WP@{' re } α {{ Φ } }" := Lemma wp_adequacy cr Σ `{!invGpreS Σ} n a (rs : gReifiers a n) {A} `{!Cofe A} `{!statePreG rs A Σ} (α : IT _ A) σ βv σ' s k (ψ : (ITV (gReifiers_ops rs) A) → Prop) : - ssteps (gReifiers_sReifier a rs) α σ (IT_of_V βv) σ' k → + ssteps (gReifiers_sReifier rs) α σ (IT_of_V βv) σ' k → (∀ `{H1 : !invGS Σ} `{H2: !stateG rs A Σ}, ∃ Φ, NonExpansive Φ ∧ (∀ βv, Φ βv ⊢ ⌜ψ βv⌝) ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → @@ -1010,7 +1009,7 @@ Proof. { intros HH. eapply uPred.pure_soundness; eauto. } eapply (step_fupdN_soundness_lc _ 0 (cr + 3*k)). intros Hinv. iIntros "[Hcr Hlc]". - iMod (new_state_interp a rs σ) as (sg) "[Hs Hs2]". + iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". destruct (Hprf Hinv sg) as (Φ & HΦ & HΦψ & Hprf'). iPoseProof (Hprf' with "[$Hcr $Hs2]") as "Hic". iPoseProof (wp_ssteps with "[$Hs $Hic]") as "Hphi". @@ -1026,16 +1025,16 @@ Lemma wp_safety cr Σ `{!invGpreS Σ} n a (rs : gReifiers a n) {A} `{!Cofe A} `{!statePreG rs A Σ} s k (α β : IT (gReifiers_ops rs) A) (σ σ' : gReifiers_state rs ♯ IT (gReifiers_ops rs) A) : (∀ Σ P Q, @disjunction_property Σ P Q) → - ssteps (gReifiers_sReifier a rs) α σ β σ' k → + ssteps (gReifiers_sReifier rs) α σ β σ' k → IT_to_V β ≡ None → (∀ `{H1 : !invGS_gen HasLc Σ} `{H2: !stateG rs A Σ}, ∃ Φ, NonExpansive Φ ∧ (£ cr ∗ has_full_state σ ⊢ WP@{rs} α @ s {{ Φ }})%I) → - ((∃ β1 σ1, sstep (gReifiers_sReifier a rs) β σ' β1 σ1) + ((∃ β1 σ1, sstep (gReifiers_sReifier rs) β σ' β1 σ1) ∨ (∃ e, β ≡ Err e ∧ s e)). Proof. Opaque istep. intros Hdisj Hstep Hbv Hwp. - cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier a rs) β σ' β1 σ1) + cut (⊢@{iProp Σ} (∃ β1 σ1, istep (gReifiers_sReifier rs) β σ' β1 σ1) ∨ (∃ e, β ≡ Err e ∧ ⌜s e⌝))%I. { intros [Hprf | Hprf]%Hdisj. - left. @@ -1069,7 +1068,7 @@ Proof. iApply (IT_vis_err_ne with "Ha"). } eapply (step_fupdN_soundness_lc _ 0 (cr + (3*k+2))). intros Hinv. iIntros "[Hcr Hlc]". - iMod (new_state_interp a rs σ) as (sg) "[Hs Hs2]". + iMod (new_state_interp rs σ) as (sg) "[Hs Hs2]". destruct (Hwp Hinv sg) as (Φ & HΦ & Hprf'). iPoseProof (Hprf' with "[$Hs2 $Hcr]") as "Hic". iPoseProof (wp_ssteps_isafe with "[$Hs $Hic]") as "H". diff --git a/theories/lib/factorial.v b/theories/lib/factorial.v index 3d8b324..c85c4be 100644 --- a/theories/lib/factorial.v +++ b/theories/lib/factorial.v @@ -111,7 +111,7 @@ Section fact. iIntros (ℓ) "Hl". simpl. iApply wp_seq. { solve_proper. } - iApply (wp_wand _ _ (λ _, pointsto acc (Ret $ fact n)) with "[-]"); last first. + iApply (wp_wand _ (λ _, pointsto acc (Ret $ fact n)) with "[-]"); last first. { simpl. iIntros (_) "Hacc". iModIntro. iApply (wp_read with "Hctx Hacc"). iNext. iNext. iIntros "Hacc". From 195a7b03b0613cf889fe8c54cfd6ed644cc5f36a Mon Sep 17 00:00:00 2001 From: Dan Frumin Date: Tue, 27 Feb 2024 11:33:10 +0100 Subject: [PATCH 111/114] rename input_lang_delim -> delim_lang --- _CoqProject | 6 +++--- .../examples/{input_lang_delim => delim_lang}/example.v | 2 +- theories/examples/{input_lang_delim => delim_lang}/interp.v | 2 +- theories/examples/{input_lang_delim => delim_lang}/lang.v | 0 theories/examples/{input_lang_delim => delim_lang}/logrel.v | 0 5 files changed, 5 insertions(+), 5 deletions(-) rename theories/examples/{input_lang_delim => delim_lang}/example.v (97%) rename theories/examples/{input_lang_delim => delim_lang}/interp.v (99%) rename theories/examples/{input_lang_delim => delim_lang}/lang.v (100%) rename theories/examples/{input_lang_delim => delim_lang}/logrel.v (100%) diff --git a/_CoqProject b/_CoqProject index ee4ddbc..f470788 100644 --- a/_CoqProject +++ b/_CoqProject @@ -29,9 +29,9 @@ theories/gitree.v theories/program_logic.v -theories/examples/input_lang_delim/lang.v -theories/examples/input_lang_delim/interp.v -theories/examples/input_lang_delim/example.v +theories/examples/delim_lang/lang.v +theories/examples/delim_lang/interp.v +theories/examples/delim_lang/example.v theories/examples/input_lang_callcc/lang.v theories/examples/input_lang_callcc/interp.v diff --git a/theories/examples/input_lang_delim/example.v b/theories/examples/delim_lang/example.v similarity index 97% rename from theories/examples/input_lang_delim/example.v rename to theories/examples/delim_lang/example.v index 9389c3e..60d32fc 100644 --- a/theories/examples/input_lang_delim/example.v +++ b/theories/examples/delim_lang/example.v @@ -1,5 +1,5 @@ From gitrees Require Import gitree lang_generic. -From gitrees.examples.input_lang_delim Require Import lang interp. +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. diff --git a/theories/examples/input_lang_delim/interp.v b/theories/examples/delim_lang/interp.v similarity index 99% rename from theories/examples/input_lang_delim/interp.v rename to theories/examples/delim_lang/interp.v index 3f0b2db..5578614 100644 --- a/theories/examples/input_lang_delim/interp.v +++ b/theories/examples/delim_lang/interp.v @@ -1,6 +1,6 @@ (* From Equations Require Import Equations. *) From gitrees Require Import gitree lang_generic. -From gitrees.examples.input_lang_delim Require Import lang. +From gitrees.examples.delim_lang Require Import lang. From iris.algebra Require Import list. From iris.proofmode Require Import classes tactics. From iris.base_logic Require Import algebra. diff --git a/theories/examples/input_lang_delim/lang.v b/theories/examples/delim_lang/lang.v similarity index 100% rename from theories/examples/input_lang_delim/lang.v rename to theories/examples/delim_lang/lang.v diff --git a/theories/examples/input_lang_delim/logrel.v b/theories/examples/delim_lang/logrel.v similarity index 100% rename from theories/examples/input_lang_delim/logrel.v rename to theories/examples/delim_lang/logrel.v From aa9ae7affe91d1b6df0fbb177b2f2c89098b0a21 Mon Sep 17 00:00:00 2001 From: Dan Frumin Date: Tue, 27 Feb 2024 11:44:52 +0100 Subject: [PATCH 112/114] get rid of later_car --- theories/examples/delim_lang/logrel.v | 788 ------------------- theories/examples/input_lang_callcc/interp.v | 37 +- theories/examples/input_lang_callcc/logrel.v | 3 +- 3 files changed, 19 insertions(+), 809 deletions(-) delete mode 100644 theories/examples/delim_lang/logrel.v diff --git a/theories/examples/delim_lang/logrel.v b/theories/examples/delim_lang/logrel.v deleted file mode 100644 index eb41879..0000000 --- a/theories/examples/delim_lang/logrel.v +++ /dev/null @@ -1,788 +0,0 @@ -(** Logical relation for adequacy for the IO lang *) -From gitrees Require Import gitree. -From gitrees.examples.input_lang_callcc Require Import lang interp hom. -Require Import gitrees.lang_generic. -Require Import Binding.Lib Binding.Set Binding.Env. - -Open Scope stdpp_scope. - -Section logrel. - Context {sz : nat}. - Variable (rs : gReifiers sz). - Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). - Notation IT := (IT F natO). - Notation ITV := (ITV F natO). - Context `{!invGS Σ, !stateG rs natO Σ}. - Notation iProp := (iProp Σ). - Notation restO := (gState_rest sR_idx rs ♯ IT). - - Canonical Structure exprO S := leibnizO (expr S). - Canonical Structure valO S := leibnizO (val S). - Canonical Structure ectxO S := leibnizO (ectx 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} (βv : ITV) (v : val S) : iProp := - (∃ n, βv ≡ RetV n ∧ ⌜v = LitV n⌝)%I. - - Definition obs_ref {S} (α : IT) (e : expr S) : iProp := - (∀ (σ : stateO), - has_substate σ -∗ - WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ - ∗ logrel_nat βv v ∗ has_substate σ' }})%I. - - Definition logrel_ectx {S} V (κ : HOM) (K : ectx S) : iProp := - (□ ∀ (βv : ITV) (v : val S), V βv v -∗ obs_ref (`κ (IT_of_V βv)) (fill K (Val v)))%I. - - Definition logrel_expr {S} V (α : IT) (e : expr S) : iProp := - (∀ (κ : HOM) (K : ectx S), - logrel_ectx V κ K -∗ obs_ref (`κ α) (fill K e))%I. - - Definition logrel_arr {S} V1 V2 (βv : ITV) (vf : val S) : iProp := - (∃ f, IT_of_V βv ≡ Fun f ∧ □ ∀ αv v, V1 αv v -∗ - logrel_expr V2 (APP' (Fun f) (IT_of_V αv)) (App (Val vf) (Val v)))%I. - - - Definition logrel_cont {S} V (βv : ITV) (v : val S) : iProp := - (∃ (κ : HOM) K, (IT_of_V βv) ≡ (Fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))) - ∧ ⌜v = ContV K⌝ - ∧ □ logrel_ectx V κ K)%I. - - Fixpoint logrel_val {S} (τ : ty) : ITV → (val S) → iProp - := match τ with - | Tnat => logrel_nat - | Tarr τ1 τ2 => logrel_arr (logrel_val τ1) (logrel_val τ2) - | Tcont τ => logrel_cont (logrel_val τ) - end. - - Definition logrel {S} (τ : ty) : IT → (expr S) → iProp - := logrel_expr (logrel_val τ). - - #[export] Instance obs_ref_ne {S} : - NonExpansive2 (@obs_ref S). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_expr_ne {S} (V : ITV → val S → iProp) : - NonExpansive2 V → NonExpansive2 (logrel_expr V). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_nat_ne {S} : NonExpansive2 (@logrel_nat S). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_val_ne {S} (τ : ty) : NonExpansive2 (@logrel_val S τ). - Proof. - induction τ; simpl; solve_proper. - Qed. - - #[export] Instance logrel_ectx_ne {S} (V : ITV → val S → iProp) : - NonExpansive2 V → NonExpansive2 (logrel_ectx V). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_arr_ne {S} (V1 V2 : ITV → val S → iProp) : - NonExpansive2 V1 -> NonExpansive2 V2 → NonExpansive2 (logrel_arr V1 V2). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_cont_ne {S} (V : ITV → val S → iProp) : - NonExpansive2 V -> NonExpansive2 (logrel_cont V). - Proof. - solve_proper. - Qed. - - #[export] Instance obs_ref_proper {S} : - Proper ((≡) ==> (≡) ==> (≡)) (@obs_ref S). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_expr_proper {S} (V : ITV → val S → iProp) : - Proper ((≡) ==> (≡) ==> (≡)) V → - Proper ((≡) ==> (≡) ==> (≡)) (logrel_expr V). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_nat_proper {S} : - Proper ((≡) ==> (≡) ==> (≡)) (@logrel_nat S). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_val_proper {S} (τ : ty) : - Proper ((≡) ==> (≡) ==> (≡)) (@logrel_val S τ). - Proof. - induction τ; simpl; solve_proper. - Qed. - - #[export] Instance logrel_ectx_proper {S} (V : ITV → val S → iProp) : - Proper ((≡) ==> (≡) ==> (≡)) V → - Proper ((≡) ==> (≡) ==> (≡)) (logrel_ectx V). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_arr_proper {S} (V1 V2 : ITV → val S → iProp) : - Proper ((≡) ==> (≡) ==> (≡)) V1 -> - Proper ((≡) ==> (≡) ==> (≡)) V2 → - Proper ((≡) ==> (≡) ==> (≡)) (logrel_arr V1 V2). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_cont_proper {S} (V : ITV → val S → iProp) : - Proper ((≡) ==> (≡) ==> (≡)) V -> - Proper ((≡) ==> (≡) ==> (≡)) (logrel_cont V). - Proof. - solve_proper. - Qed. - - #[export] Instance logrel_val_persistent {S} (τ : ty) α v : - Persistent (@logrel_val S τ α v). - Proof. - revert α v. induction τ=> α v; simpl. - - unfold logrel_nat. apply _. - - unfold logrel_arr. apply _. - - unfold logrel_cont. apply _. - Qed. - - #[export] Instance logrel_ectx_persistent {S} V κ K : - Persistent (@logrel_ectx S V κ K). - Proof. - apply _. - Qed. - - Lemma logrel_of_val {S} τ αv (v : val S) : - logrel_val τ αv v -∗ logrel τ (IT_of_V αv) (Val v). - Proof. - iIntros "H1". iIntros (κ K) "HK". - iIntros (σ) "Hs". - by iApply ("HK" $! αv v with "[$H1] [$Hs]"). - Qed. - - Lemma logrel_head_step_pure_ectx {S} n K (e' e : expr S) α V : - (∀ σ K, head_step e σ e' σ K (n, 0)) → - ⊢ logrel_expr V α (fill K e') -∗ logrel_expr V α (fill K e). - Proof. - intros Hpure. - iIntros "H". - iIntros (κ' K') "#HK'". - iIntros (σ) "Hs". - iSpecialize ("H" with "HK'"). - iSpecialize ("H" with "Hs"). - iApply (wp_wand with "H"). - iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". - iExists ((Nat.add n m),m'),v,σ'. iFrame "H2 Hs". - iPureIntro. - eapply (prim_steps_app (n, 0) (m, m')); eauto. - eapply prim_step_steps. - rewrite !fill_comp. - eapply Ectx_step; last apply Hpure; done. - Qed. - - Lemma obs_ref_bind {S} (f : HOM) (K : ectx S) e α τ1 : - ⊢ logrel τ1 α e -∗ - logrel_ectx (logrel_val τ1) f K -∗ - obs_ref (`f α) (fill K e). - Proof. - iIntros "H1 #H2". - iIntros (σ) "Hs". - iApply (wp_wand with "[H1 H2 Hs] []"); first iApply ("H1" with "[H2] [$Hs]"). - - iIntros (βv v). iModIntro. - iIntros "#Hv". - by iApply "H2". - - iIntros (βv). - iIntros "?". - iModIntro. - iFrame. - Qed. - - Definition ssubst2_valid {S : Set} - (Γ : S -> ty) - (ss : @interp_scope F natO _ S) - (γ : S [⇒] Empty_set) : iProp := - (∀ x, □ logrel (Γ x) (ss x) (γ x))%I. - - Definition logrel_valid {S : Set} - (Γ : S -> ty) - (e : expr S) - (α : @interp_scope F natO _ S -n> IT) - (τ : ty) : iProp := - (□ ∀ (ss : @interp_scope F natO _ S) - (γ : S [⇒] Empty_set), - ssubst2_valid Γ ss γ → logrel τ (α ss) (bind γ e))%I. - - Lemma compat_var {S : Set} (Γ : S -> ty) (x : S) : - ⊢ logrel_valid Γ (Var x) (interp_var x) (Γ x). - Proof. - iModIntro. iIntros (ss γ) "Hss". iApply "Hss". - Qed. - - Lemma compat_recV {S : Set} (Γ : S -> ty) (e : expr (inc (inc S))) τ1 τ2 α : - ⊢ □ logrel_valid ((Γ ▹ (Tarr τ1 τ2) ▹ τ1)) e α τ2 -∗ - logrel_valid Γ (Val $ RecV e) (interp_rec rs α) (Tarr τ1 τ2). - Proof. - iIntros "#H !> %env %γ #Henv". - set (f := (ir_unf rs α env)). - iAssert (interp_rec rs α env ≡ 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 v) "#Hw". - rewrite APP_APP'_ITV APP_Fun laterO_map_Next -Tick_eq. - pose (ss' := (extend_scope (extend_scope env (interp_rec rs α env)) (IT_of_V αv))). - set (γ' := ((mk_subst (Val (rec bind ((γ ↑) ↑)%bind e)%syn)) - ∘ ((mk_subst (shift (Val v))) ∘ ((γ ↑) ↑)))%bind). - rewrite /logrel. - iSpecialize ("H" $! ss' γ'). - set (γ1 := ((γ ↑) ↑)%bind). - iApply (logrel_head_step_pure_ectx _ EmptyK _ - ((rec bind γ1 e)%syn v) - (Tick (later_car (Next f) (IT_of_V αv))) - (logrel_val τ2) with "[]"); last first. - + rewrite {2}/ss'. rewrite /f. - iIntros (κ K) "#HK". iIntros (σ) "Hs". - rewrite hom_tick. iApply wp_tick. iNext. - iApply "H"; eauto. - rewrite /ss' /γ'. - iIntros (x'); destruct x' as [| [| x']]; term_simpl; iModIntro. - * by iApply logrel_of_val. - * iRewrite "Hf". - iIntros (κ' K') "#HK'". - iApply "HK'". - simpl. - unfold logrel_arr. - _iExists (Next (ir_unf rs α env)). - iSplit; first done. - iModIntro. - iApply "IH". - * iApply "Henv". - + term_simpl. intros. subst γ1 γ'. - rewrite -!bind_bind_comp'. - apply BetaS. - Qed. - - Lemma compat_if {S : Set} (Γ : S -> ty) (e0 e1 e2 : expr S) α0 α1 α2 τ : - ⊢ logrel_valid Γ e0 α0 Tnat -∗ - logrel_valid Γ e1 α1 τ -∗ - logrel_valid Γ e2 α2 τ -∗ - logrel_valid Γ (If e0 e1 e2) (interp_if rs α0 α1 α2) τ. - Proof. - iIntros "#H0 #H1 #H2". - iModIntro. - iIntros (ss γ) "#Hss". - simpl. - pose (κ' := (IFSCtx_HOM (α1 ss) (α2 ss))). - assert ((IF (α0 ss) (α1 ss) (α2 ss)) = ((`κ') (α0 ss))) as -> by reflexivity. - term_simpl. - iIntros (κ K) "#HK". - assert ((`κ) ((IFSCtx (α1 ss) (α2 ss)) (α0 ss)) = ((`κ) ◎ (`κ')) (α0 ss)) - as -> by reflexivity. - pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. - assert (fill K (If (bind γ e0) (bind γ e1) (bind γ e2))%syn = - fill (ectx_compose K (IfK EmptyK (bind γ e1) (bind γ e2))) (bind γ e0)) as ->. - { rewrite -fill_comp. reflexivity. } - iApply (obs_ref_bind with "[H0] [H1 H2]"); first by iApply "H0". - iIntros (βv v). iModIntro. iIntros "#HV". - term_simpl. - unfold logrel_nat. - iDestruct "HV" as "(%n & #Hn & ->)". - iRewrite "Hn". - unfold IFSCtx. - destruct (decide (0 < n)) as [H|H]. - - rewrite -fill_comp. - simpl. - rewrite IF_True//. - iSpecialize ("H1" with "Hss"). - term_simpl. rewrite /logrel. - iPoseProof (logrel_head_step_pure_ectx _ EmptyK - (bind γ e1)%syn _ (α1 ss) (logrel_val τ) with "H1") - as "Hrel"; last iApply ("Hrel" $! κ K with "HK"). - intros σ K0. by apply IfTrueS. - - rewrite -fill_comp. - simpl. - unfold IFSCtx. - rewrite IF_False//; last lia. - iSpecialize ("H2" with "Hss"). - term_simpl. rewrite /logrel. - iPoseProof (logrel_head_step_pure_ectx _ EmptyK - (bind γ e2)%syn _ (α2 ss) (logrel_val τ) with "H2") - as "Hrel"; last iApply ("Hrel" $! κ K with "HK"). - intros σ K0. apply IfFalseS. lia. - Qed. - - Lemma compat_input {S} Γ : - ⊢ logrel_valid Γ (Input : expr S) (interp_input rs) Tnat. - Proof. - iModIntro. - iIntros (ss γ) "#Hss". - iIntros (κ K) "#HK". - unfold interp_input. - term_simpl. - iIntros (σ) "Hs". - destruct (update_input σ) as [n σ'] eqn:Hinp. - iApply (wp_input' with "Hs []"); first done. - iNext. iIntros "Hlc Hs". term_simpl. - iSpecialize ("HK" $! (RetV n) (LitV n) with "[]"); first by iExists n. - iSpecialize ("HK" $! σ' with "Hs"). - rewrite IT_of_V_Ret. - iApply (wp_wand with "[$HK] []"). - iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". - iModIntro. - destruct m as [m1 m2]. - iExists ((Nat.add 1 m1), (Nat.add 1 m2)), v'', σ''. iFrame "H". - iPureIntro. - eapply (prim_steps_app (1, 1) (m1, m2)); eauto. - eapply prim_step_steps. - eapply Ectx_step; [reflexivity | reflexivity |]. - by constructor. - Qed. - - Lemma compat_natop {S : Set} (Γ : S -> ty) e1 e2 α1 α2 op : - ⊢ logrel_valid Γ e1 α1 Tnat -∗ - logrel_valid Γ e2 α2 Tnat -∗ - logrel_valid Γ (NatOp op e1 e2) (interp_natop rs op α1 α2) Tnat. - Proof. - iIntros "#H1 #H2". iIntros (ss γ). iModIntro. iIntros "#Hss". - iSpecialize ("H1" with "Hss"). - iSpecialize ("H2" with "Hss"). - term_simpl. - iIntros (κ K) "#HK". - set (κ' := (NatOpRSCtx_HOM op α1 ss)). - assert ((NATOP (do_natop op) (α1 ss) (α2 ss)) = ((`κ') (α2 ss))) as -> by done. - rewrite HOM_ccompose. - pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. - assert (fill K (NatOp op (bind γ e1) (bind γ e2))%syn = - fill (ectx_compose K (NatOpRK op (bind γ e1) EmptyK)) (bind γ e2)) as ->. - { rewrite -fill_comp. reflexivity. } - iApply (obs_ref_bind with "H2"). - iIntros (βv v). iModIntro. iIntros "(%n2 & #HV & ->)". - term_simpl. clear κ' sss. - rewrite -fill_comp. simpl. - pose (κ' := (NatOpLSCtx_HOM op (IT_of_V βv) ss _)). - assert ((NATOP (do_natop op) (α1 ss) (IT_of_V βv)) = ((`κ') (α1 ss))) as -> by done. - rewrite HOM_ccompose. - pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. - assert (fill K (NatOp op (bind γ e1) (LitV n2))%syn = - fill (ectx_compose K (NatOpLK op EmptyK (LitV n2))) (bind γ e1)) as ->. - { rewrite -fill_comp. reflexivity. } - iApply (obs_ref_bind with "H1"). - subst sss κ'. - term_simpl. - iIntros (t r). iModIntro. iIntros "(%n1 & #H & ->)". - simpl. - iAssert ((NATOP (do_natop op) (IT_of_V t) (IT_of_V βv)) ≡ Ret (do_natop op n1 n2))%I with "[HV H]" as "Hr". - { iRewrite "HV". simpl. - iRewrite "H". simpl. - iPureIntro. - by rewrite NATOP_Ret. - } - rewrite -fill_comp. simpl. - iApply (logrel_head_step_pure_ectx _ EmptyK (Val (LitV (do_natop op n1 n2))) with "[]"); - last done; last first. - + simpl. iRewrite "Hr". iApply (logrel_of_val Tnat (RetV (do_natop op n1 n2))). term_simpl. - iExists _. iSplit; eauto. - + intros. by constructor. - Qed. - - Lemma compat_throw {S : Set} (Γ : S -> ty) τ τ' α β e e' : - ⊢ logrel_valid Γ e α τ -∗ - logrel_valid Γ e' β (Tcont τ) -∗ - logrel_valid Γ (Throw e e') (interp_throw _ α β) τ'. - Proof. - iIntros "#H1 #H2". - iIntros (ss γ). iModIntro. iIntros "#Hss". - iIntros (κ K) "#HK". - Opaque interp_throw. - term_simpl. - pose (κ' := ThrowLSCtx_HOM β ss). - assert ((interp_throw rs α β ss) = ((`κ') (α ss))) as -> by done. - rewrite HOM_ccompose. - pose (sss := (HOM_compose κ κ')). rewrite (HOM_compose_ccompose κ κ' sss)//. - assert (fill K (Throw (bind γ e) (bind γ e'))%syn = - fill (ectx_compose K (ThrowLK EmptyK (bind γ e'))) (bind γ e)) - as -> by by rewrite -fill_comp. - iApply obs_ref_bind; first by iApply "H1". - iIntros (βv v). iModIntro. iIntros "#Hv". - Transparent interp_throw. - simpl. - rewrite get_val_ITV' -!fill_comp. - simpl. - pose (κ'' := ThrowRSCtx_HOM (IT_of_V βv) ss _). - assert ((get_fun (λne f : laterO (IT -n> IT), THROW (IT_of_V βv) f) (β ss)) ≡ - ((`κ'') (β ss))) as ->. - { - subst κ''. simpl. by rewrite get_val_ITV. - } - rewrite HOM_ccompose. - pose (sss' := (HOM_compose κ κ'')). rewrite (HOM_compose_ccompose κ κ'' sss')//. - assert (fill K (Throw v (bind γ e'))%syn = - fill (ectx_compose K (ThrowRK v EmptyK)) (bind γ e')) - as -> by by rewrite -fill_comp. - iApply obs_ref_bind; first by iApply "H2". - iIntros (βv' v'). iModIntro. iIntros "#Hv'". - Transparent interp_throw. - simpl. - unfold logrel_cont. - iDestruct "Hv'" as "(%f & %F & HEQ & %H & #H)". - rewrite get_val_ITV. - simpl. - iRewrite "HEQ". - rewrite get_fun_fun. - simpl. - iIntros (σ) "Hs". - iApply (wp_throw' with "Hs []"). - iNext. iIntros "Hcl Hs". term_simpl. - rewrite later_map_Next. iApply wp_tick. iNext. - iSpecialize ("H" $! βv v with "[]"); first done. - iSpecialize ("H" $! σ with "Hs"). - iApply (wp_wand with "[$H] []"). - iIntros (w) "(%m & %v'' & %σ'' & %Hstep & H)". - destruct m as [m m']. - iModIntro. - iExists ((Nat.add 2 m), m'), v'', σ''. iFrame "H". - iPureIntro. - eapply (prim_steps_app (2, 0) (m, m')); eauto. - term_simpl. - eapply prim_step_steps. - eapply Throw_step; last done. - rewrite H. by rewrite -!fill_comp. - Qed. - - - Lemma compat_callcc {S : Set} (Γ : S -> ty) τ α e : - ⊢ logrel_valid (Γ ▹ Tcont τ) e α τ -∗ - logrel_valid Γ (Callcc e) (interp_callcc _ α) τ. - Proof. - iIntros "#H". - iIntros (ss γ). iModIntro. iIntros "#Hss". - iIntros (κ K) "#HK". - unfold interp_callcc. - Opaque extend_scope. - term_simpl. - iIntros (σ) "Hs". - - iApply (wp_callcc with "Hs []"). - iNext. iIntros "Hcl Hs". term_simpl. - - pose (ff := (λit x : IT, Tick ((`κ) x))). - match goal with - | |- context G [ofe_mor_car _ _ (ofe_mor_car _ _ extend_scope ss )?f] => set (fff := f) - end. - assert (ff ≡ fff) as <-. - { - subst ff fff. do 1 f_equiv. - epose proof (contractive_proper Next). - rewrite H; first reflexivity. - rewrite ofe_mor_ext. intro. simpl. - by rewrite later_map_Next. - } - pose (ss' := (extend_scope ss ff)). - pose (γ' := ((mk_subst (Val (ContV K)%syn)) ∘ (γ ↑)%bind)%bind : inc S [⇒] ∅). - iSpecialize ("H" $! ss' γ' with "[HK]"). - { - iIntros (x). iModIntro. - destruct x as [| x]; term_simpl; last iApply "Hss". - Transparent extend_scope. - subst ss'; simpl. - pose proof (asval_fun (Next (λne x, Tau (laterO_map (`κ) (Next x))))). - subst ff. destruct H as [f H]. - iIntros (t r) "#H". - simpl. rewrite -H. iApply "H". - unfold logrel_cont. - iExists κ, K. - iSplit; first done. - iSplit; first done. - iModIntro. - iApply "HK". - } - iSpecialize ("H" $! κ K with "HK"). - Opaque extend_scope. - term_simpl. - iSpecialize ("H" $! σ with "Hs"). - subst ss' γ'. - iApply (wp_wand with "[$H] []"). - iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". - destruct m as [m m']. - rewrite -bind_bind_comp' in Hstep. - iModIntro. - iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H". - iPureIntro. - eapply (prim_steps_app (1, 1) (m, m')); eauto. - eapply prim_step_steps. - eapply Ectx_step; [reflexivity | reflexivity |]. - term_simpl. - constructor. - Qed. - - Lemma compat_output {S} Γ (e: expr S) α : - ⊢ logrel_valid Γ e α Tnat -∗ - logrel_valid Γ (Output e) (interp_output rs α) Tnat. - Proof. - iIntros "#H". - iIntros (ss γ). iModIntro. iIntros "#Hss". - iIntros (κ K) "#HK". - term_simpl. - pose (κ' := OutputSCtx_HOM ss). - replace (get_ret OUTPUT (α ss)) with ((`κ') (α ss)) by reflexivity. - replace ((`κ) ((`κ') (α ss))) with (((`κ) ◎ (`κ')) (α ss)) by reflexivity. - pose (sss := (HOM_compose κ κ')). - replace (`κ ◎ `κ') with (`sss) by reflexivity. - assert (fill K (Output (bind γ e))%syn = - fill (ectx_compose K (OutputK EmptyK)) (bind γ e)) as ->. - { rewrite -fill_comp. reflexivity. } - iApply obs_ref_bind; first by iApply "H". - iIntros (βv v). iModIntro. iIntros "#Hv". - iDestruct "Hv" as (n) "[Hb ->]". - iRewrite "Hb". simpl. - iIntros (σ) "Hs". - rewrite get_ret_ret. - iApply (wp_output' with "Hs []"); first done. - iNext. iIntros "Hlc Hs". - iSpecialize ("HK" $! (RetV 0) (LitV 0) with "[]"); first by iExists 0. - iSpecialize ("HK" $! (update_output n σ) with "Hs"). - iApply (wp_wand with "[$HK] []"). - iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H')". - destruct m as [m m']. - iModIntro. - iExists ((Nat.add 1 m), (Nat.add 1 m')), v'', σ''. iFrame "H'". - iPureIntro. - eapply (prim_steps_app (1, 1) (m, m')); eauto. - eapply prim_step_steps. - rewrite -fill_comp. - eapply Ectx_step; [reflexivity | reflexivity |]. - by constructor. - Qed. - - Lemma compat_app {S} Γ (e1 e2 : expr S) τ1 τ2 α1 α2 : - ⊢ logrel_valid Γ e1 α1 (Tarr τ1 τ2) -∗ - logrel_valid Γ e2 α2 τ1 -∗ - logrel_valid Γ (App e1 e2) (interp_app rs α1 α2) τ2. - Proof. - iIntros "#H1 #H2". - iIntros (ss). - iModIntro. - iIntros (γ). - iIntros "#Hss". - iSpecialize ("H1" with "Hss"). - iSpecialize ("H2" with "Hss"). - unfold interp_app. - simpl. - assert ((bind γ (App e1 e2))%syn = (fill (AppRK (bind γ e1) EmptyK) (bind γ e2))) as ->. - { reflexivity. } - pose (κ' := (AppRSCtx_HOM α1 ss)). - assert ((α1 ss ⊙ (α2 ss)) = ((`κ') (α2 ss))) as ->. - { simpl; unfold AppRSCtx. reflexivity. } - iIntros (κ K) "#HK". - assert ((`κ) ((`κ') (α2 ss)) = ((`κ) ◎ (`κ')) (α2 ss)) as ->. - { reflexivity. } - pose (sss := (HOM_compose κ κ')). - assert ((`κ ◎ `κ') = (`sss)) as ->. - { reflexivity. } - rewrite fill_comp. - iApply obs_ref_bind; first by iApply "H2". - subst sss κ'. - iIntros (βv v). iModIntro. iIntros "#HV". - unfold AppRSCtx_HOM; simpl; unfold AppRSCtx. - rewrite -fill_comp. - simpl. - assert ((App (bind γ e1) v) = (fill (AppLK EmptyK v) (bind γ e1))) as ->. - { reflexivity. } - pose (κ'' := (AppLSCtx_HOM (IT_of_V βv) ss _)). - assert (((`κ) (α1 ss ⊙ (IT_of_V βv))) = (((`κ) ◎ (`κ'')) (α1 ss))) as ->. - { reflexivity. } - pose (sss := (HOM_compose κ κ'')). - assert ((`κ ◎ `κ'') = (`sss)) as ->. - { reflexivity. } - rewrite fill_comp. - iApply obs_ref_bind; first by iApply "H1". - iIntros (βv' v'). iModIntro. iIntros "#HV'". - subst sss κ''. - rewrite -fill_comp. - simpl. - unfold logrel_arr. - iDestruct "HV'" as "(%f & #Hf & #HV')". - iRewrite "Hf". - iSpecialize ("HV'" $! βv v with "HV"). - iApply "HV'"; iApply "HK". - Qed. - - Lemma compat_nat {S : Set} (Γ : S -> ty) n : - ⊢ logrel_valid Γ (# n)%syn (interp_val rs (# n)%syn) ℕ%typ. - Proof. - iIntros (ss γ). iModIntro. iIntros "#Hss". - term_simpl. - iIntros (κ K) "#HK". - iSpecialize ("HK" $! (RetV n) (LitV n)). - rewrite IT_of_V_Ret. - iApply "HK". - simpl. - unfold logrel_nat. - iExists n; eauto. - Qed. - - Lemma fundamental {S : Set} (Γ : S -> ty) τ e : - typed Γ e τ → ⊢ logrel_valid Γ e (interp_expr rs e) τ - with fundamental_val {S : Set} (Γ : S -> ty) τ v : - typed_val Γ v τ → ⊢ logrel_valid Γ (Val v) (interp_val rs v) τ. - Proof. - - induction 1; simpl. - + by apply fundamental_val. - + rewrite -H. - by apply compat_var. - + iApply compat_app. - ++ iApply IHtyped1. - ++ iApply IHtyped2. - + iApply compat_natop. - ++ iApply IHtyped1. - ++ iApply IHtyped2. - + iApply compat_if. - ++ iApply IHtyped1. - ++ iApply IHtyped2. - ++ iApply IHtyped3. - + iApply compat_input. - + iApply compat_output. - iApply IHtyped. - + iApply compat_throw. - ++ iApply IHtyped1. - ++ iApply IHtyped2. - + iApply compat_callcc. - iApply IHtyped. - - induction 1; simpl. - + iApply compat_nat. - + iApply compat_recV. by iApply fundamental. - Qed. - -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. -Definition rs : gReifiers 1 := gReifiers_cons reify_io gReifiers_nil. - -Require Import gitrees.gitree.greifiers. - -Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} - (α : IT (gReifiers_ops rs) natO) - (e : expr S) n σ σ' k : - (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (⊢ logrel rs Tnat α e)%I) → - ssteps (gReifiers_sReifier rs) α (σ, ()) (Ret n) σ' k → - ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. -Proof. - intros Hlog Hst. - pose (ϕ := λ (βv : ITV (gReifiers_ops rs) natO), - ∃ m σ', prim_steps e σ (Val $ κ βv) σ' m). - cut (ϕ (RetV n)). - { - destruct 1 as ( m' & σ2 & Hm). - exists m', σ2. revert Hm. by rewrite κ_Ret. - } - eapply (wp_adequacy 0); eauto. - intros Hinv1 Hst1. - pose (Φ := (λ (βv : ITV (gReifiers_ops rs) natO), - ∃ n, logrel_val rs Tnat (Σ:=Σ) (S:=S) βv (LitV n) - ∗ ⌜∃ m σ', prim_steps e σ (Val $ 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 σ) with "[Hs]" as "Hs". - { - unfold has_substate, has_full_state. - assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ())) ≡ - (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ))) - as -> ; last done. - intros 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" $! HOM_id EmptyK with "[]"). - { - iIntros (βv v); iModIntro. iIntros "Hv". iIntros (σ'') "HS". - iApply wp_val. - iModIntro. - iExists (0, 0), v, σ''. - iSplit; first iPureIntro. - - apply prim_steps_zero. - - by iFrame. - } - simpl. - iSpecialize ("Hlog" $! σ with "Hs"). - iApply (wp_wand with"Hlog"). - iIntros ( βv). iIntros "H". - iDestruct "H" as (m' v σ1' Hsts) "[Hi Hsts]". - unfold Φ. iDestruct "Hi" as (l) "[Hβ %]". simplify_eq/=. - iExists l. iModIntro. iSplit; eauto. - iExists l. iSplit; eauto. -Qed. - -Program Definition ı_scope : @interp_scope (gReifiers_ops rs) natO _ Empty_set := λne (x : ∅), match x with end. - -Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : - typed □ e Tnat → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → - ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. -Proof. - intros Hty Hst. - pose (Σ:=#[invΣ;stateΣ rs natO]). - eapply (logrel_nat_adequacy Σ (interp_expr rs e ı_scope)); last eassumption. - intros ? ?. - iPoseProof (fundamental rs) as "H". - { apply Hty. } - unfold logrel_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/examples/input_lang_callcc/interp.v b/theories/examples/input_lang_callcc/interp.v index e9e94ec..4262221 100644 --- a/theories/examples/input_lang_callcc/interp.v +++ b/theories/examples/input_lang_callcc/interp.v @@ -232,47 +232,44 @@ Section weakestpre. iApply wp_val. iApply ("Ha" with "Hcl Hs"). Qed. - Lemma wp_throw' (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) + Lemma wp_throw' (σ : stateO) (f : IT -n> IT) (x : IT) (κ : IT -n> IT) `{!IT_hom κ} Φ s : has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} (later_car f) x @ s {{ Φ }}) -∗ - WP@{rs} κ (THROW x f) @ s {{ Φ }}. + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} f x @ s {{ Φ }}) -∗ + WP@{rs} κ (THROW x (Next f)) @ s {{ Φ }}. Proof. iIntros "Hs Ha". rewrite /THROW. simpl. rewrite hom_vis. iApply (wp_subreify_ctx_dep with "Hs"); simpl; done. Qed. - Lemma wp_throw (σ : stateO) (f : laterO (IT -n> IT)) (x : IT) Φ s : + Lemma wp_throw (σ : stateO) (f : IT -n> IT) (x : IT) Φ s : has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} later_car f x @ s {{ Φ }}) -∗ - WP@{rs} (THROW x f) @ s {{ Φ }}. + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} f x @ s {{ Φ }}) -∗ + WP@{rs} (THROW x (Next f)) @ s {{ Φ }}. Proof. iApply (wp_throw' _ _ _ idfun). Qed. - Lemma wp_callcc (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} Φ s : + Lemma wp_callcc (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} β Φ s : + f (laterO_map k) ≡ Next β → has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k (later_car (f (laterO_map k))) @ s {{ Φ }}) -∗ + ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k β @ s {{ Φ }}) -∗ WP@{rs} (k (CALLCC f)) @ s {{ Φ }}. Proof. - iIntros "Hs Ha". + iIntros (Hp) "Hs Ha". unfold CALLCC. simpl. rewrite hom_vis. - iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ ((later_map k ((f (laterO_map k))))) with "Hs"). + iApply (wp_subreify_ctx_dep _ _ _ _ _ _ _ (laterO_map k (Next β)) with "Hs"). { - simpl. - repeat f_equiv. - - rewrite ofe_iso_21. - f_equiv. - intro; simpl. - f_equiv. - apply ofe_iso_21. - - reflexivity. + simpl. rewrite -Hp. repeat f_equiv; last done. + rewrite ccompose_id_l. rewrite ofe_iso_21. + repeat f_equiv. intro. + simpl. f_equiv. + apply ofe_iso_21. } { - rewrite later_map_Next. - reflexivity. + simpl. by rewrite later_map_Next. } iModIntro. iApply "Ha". diff --git a/theories/examples/input_lang_callcc/logrel.v b/theories/examples/input_lang_callcc/logrel.v index 717256c..8d2891a 100644 --- a/theories/examples/input_lang_callcc/logrel.v +++ b/theories/examples/input_lang_callcc/logrel.v @@ -257,7 +257,7 @@ Section logrel. set (γ1 := ((γ ↑) ↑)%bind). iApply (logrel_head_step_pure_ectx _ EmptyK _ ((rec bind γ1 e)%syn v) - (Tick (later_car (Next f) (IT_of_V αv))) + (Tick (f (IT_of_V αv))) (logrel_val τ2) with "[]"); last first. + rewrite {2}/ss'. rewrite /f. iIntros (κ K) "#HK". iIntros (σ) "Hs". @@ -482,6 +482,7 @@ Section logrel. iIntros (σ) "Hs". iApply (wp_callcc with "Hs []"). + { simpl. done. } iNext. iIntros "Hcl Hs". term_simpl. pose (ff := (λit x : IT, Tick ((`κ) x))). From 15dc2a2a569306f80383caeb3f68e6f091efce32 Mon Sep 17 00:00:00 2001 From: Dan Frumin Date: Tue, 27 Feb 2024 14:12:00 +0100 Subject: [PATCH 113/114] factor out the IO tape effects --- _CoqProject | 14 +- theories/effects/io_tape.v | 144 +++++++++ theories/effects/store.v | 1 + theories/examples/affine_lang/lang.v | 2 +- theories/examples/affine_lang/logrel1.v | 6 +- theories/examples/affine_lang/logrel2.v | 2 +- theories/examples/input_lang/interp.v | 127 +------- theories/examples/input_lang/lang.v | 17 +- theories/examples/input_lang_callcc/hom.v | 3 +- theories/examples/input_lang_callcc/interp.v | 299 ++++++++----------- theories/examples/input_lang_callcc/lang.v | 18 +- theories/examples/input_lang_callcc/logrel.v | 96 +++--- theories/gitree/greifiers.v | 11 + 13 files changed, 344 insertions(+), 396 deletions(-) create mode 100644 theories/effects/io_tape.v diff --git a/_CoqProject b/_CoqProject index f470788..2337a45 100644 --- a/_CoqProject +++ b/_CoqProject @@ -28,6 +28,13 @@ theories/gitree.v theories/program_logic.v +theories/effects/store.v +theories/effects/io_tape.v + +theories/lib/pairs.v +theories/lib/while.v +theories/lib/factorial.v +theories/lib/iter.v theories/examples/delim_lang/lang.v theories/examples/delim_lang/interp.v @@ -47,11 +54,4 @@ theories/examples/affine_lang/lang.v theories/examples/affine_lang/logrel1.v theories/examples/affine_lang/logrel2.v -theories/effects/store.v - -theories/lib/pairs.v -theories/lib/while.v -theories/lib/factorial.v -theories/lib/iter.v - theories/utils/finite_sets.v diff --git a/theories/effects/io_tape.v b/theories/effects/io_tape.v new file mode 100644 index 0000000..fd34746 --- /dev/null +++ b/theories/effects/io_tape.v @@ -0,0 +1,144 @@ +(** I/O on a tape effect *) +From gitrees Require Import prelude gitree. + +Record state := State { + inputs : list nat; + outputs : list nat; + }. +#[export] Instance state_inhabited : Inhabited state := populate (State [] []). + +Definition update_input (s : state) : nat * state := + match s.(inputs) with + | [] => (0, s) + | n::ns => + (n, {| inputs := ns; outputs := s.(outputs) |}) + end. +Definition update_output (n:nat) (s : state) : state := + {| inputs := s.(inputs); outputs := n::s.(outputs) |}. + +Notation stateO := (leibnizO state). + +Program Definition inputE : opInterp := + {| + Ins := unitO; + Outs := natO; + |}. + +Program Definition outputE : opInterp := + {| + Ins := natO; + Outs := unitO; + |}. + +Definition ioE := @[inputE;outputE]. + +(* INPUT *) +Definition reify_input X `{Cofe X} : unitO * stateO → + option (natO * stateO) := + λ '(o, σ), Some (update_input σ : prodO natO stateO). +#[export] Instance reify_input_ne X `{Cofe X} : + NonExpansive (reify_input X). +Proof. + intros ?[[]][[]][_?]. simpl in *. f_equiv. + repeat f_equiv. done. +Qed. + +(* OUTPUT *) +Definition reify_output X `{Cofe X} : (natO * stateO) → + option (unitO * stateO) := + λ '(n, σ), Some((), update_output n σ : stateO). +#[export] Instance reify_output_ne X `{Cofe X} : + NonExpansive (reify_output X). +Proof. + intros ?[][][]. simpl in *. + repeat f_equiv; done. +Qed. + +Canonical Structure reify_io : sReifier NotCtxDep. +Proof. + simple refine {| sReifier_ops := ioE; + sReifier_state := stateO + |}. + intros X HX op. + destruct op as [[] | [ | []]]; simpl. + - simple refine (OfeMor (reify_input X)). + - simple refine (OfeMor (reify_output X)). +Defined. + +Section constructors. + Context {E : opsInterp} {A} `{!Cofe A}. + Context {subEff0 : subEff ioE E}. + Context {subOfe0 : SubOfe natO A}. + Notation IT := (IT E A). + Notation ITV := (ITV E A). + + Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) + (subEff_ins (F:=ioE) (op:=(inl ())) ()) + (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). + Solve Obligations with solve_proper. + Program Definition OUTPUT_ : nat -n> IT -n> IT := + λne m α, Vis (E:=E) (subEff_opid (inr (inl ()))) + (subEff_ins (F:=ioE) (op:=(inr (inl ()))) m) + (λne _, NextO α). + Solve All Obligations with solve_proper_please. + Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). + + Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). + Proof. + unfold INPUT. + rewrite hom_vis/=. repeat f_equiv. + intro x. cbn-[laterO_map]. rewrite laterO_map_Next. + done. + Qed. + Lemma hom_OUTPUT_ m α f `{!IT_hom f} : f (OUTPUT_ m α) ≡ OUTPUT_ m (f α). + Proof. + unfold OUTPUT. + rewrite hom_vis/=. repeat f_equiv. + intro x. cbn-[laterO_map]. rewrite laterO_map_Next. + done. + Qed. + +End constructors. + +Section weakestpre. + Context {sz : nat}. + Variable (rs : gReifiers NotCtxDep sz). + Context {subR : subReifier reify_io rs}. + Notation F := (gReifiers_ops rs). + Context {R} `{!Cofe R}. + Context `{!SubOfe natO R}. + Notation IT := (IT F R). + Notation ITV := (ITV F R). + Context `{!invGS Σ, !stateG rs R Σ}. + Notation iProp := (iProp Σ). + + Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : + update_input σ = (n, σ') → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ + WP@{rs} (INPUT k) @ s {{ Φ }}. + Proof. + intros Hs. iIntros "Hs Ha". + unfold INPUT. simpl. + iApply (wp_subreify_ctx_indep with "Hs"). + { simpl. rewrite Hs//=. } + { simpl. by rewrite ofe_iso_21. } + iModIntro. done. + Qed. + + Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : + update_output n σ = σ' → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ + WP@{rs} (OUTPUT n) @ s {{ Φ }}. + Proof. + intros Hs. iIntros "Hs Ha". + unfold OUTPUT. simpl. + iApply (wp_subreify_ctx_indep rs with "Hs"). + { simpl. by rewrite Hs. } + { simpl. done. } + iModIntro. iIntros "H1 H2". + iApply wp_val. by iApply ("Ha" with "H1 H2"). + Qed. + +End weakestpre. diff --git a/theories/effects/store.v b/theories/effects/store.v index a7deb17..f11e23e 100644 --- a/theories/effects/store.v +++ b/theories/effects/store.v @@ -1,3 +1,4 @@ +(** Higher-order store effect *) From iris.algebra Require Import gmap excl auth gmap_view. From iris.proofmode Require Import classes tactics. From iris.base_logic Require Import algebra. diff --git a/theories/examples/affine_lang/lang.v b/theories/examples/affine_lang/lang.v index 14cdcb9..6076ca1 100644 --- a/theories/examples/affine_lang/lang.v +++ b/theories/examples/affine_lang/lang.v @@ -7,7 +7,7 @@ Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env (* for namespace sake *) Module io_lang. - Definition state := input_lang.lang.state. + Definition state := io_tape.state. Definition ty := input_lang.lang.ty. Definition expr := input_lang.lang.expr. Definition tyctx {S : Set} := S → ty. diff --git a/theories/examples/affine_lang/logrel1.v b/theories/examples/affine_lang/logrel1.v index c9c38b5..c5d68af 100644 --- a/theories/examples/affine_lang/logrel1.v +++ b/theories/examples/affine_lang/logrel1.v @@ -1,7 +1,7 @@ (** Unary (Kripke) logical relation for the affine lang *) From gitrees Require Export gitree program_logic greifiers. From gitrees.examples.affine_lang Require Import lang. -From gitrees.effects Require Import store. +From gitrees.effects Require Import io_tape store. From gitrees.lib Require Import pairs. From gitrees.utils Require Import finite_sets. @@ -51,7 +51,7 @@ Section logrel. Context {sz : nat}. Variable rs : gReifiers NotCtxDep sz. Context `{!subReifier reify_store rs}. - Context `{!subReifier input_lang.interp.reify_io rs}. + Context `{!subReifier reify_io rs}. Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. Context `{!SubOfe natO R}. @@ -516,7 +516,7 @@ Arguments compat_destruct {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. Arguments compat_replace {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}. Local Definition rs : gReifiers NotCtxDep 2 := - gReifiers_cons reify_store (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). + gReifiers_cons reify_store (gReifiers_cons reify_io gReifiers_nil). Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. diff --git a/theories/examples/affine_lang/logrel2.v b/theories/examples/affine_lang/logrel2.v index 865580c..3eaeb0c 100644 --- a/theories/examples/affine_lang/logrel2.v +++ b/theories/examples/affine_lang/logrel2.v @@ -467,7 +467,7 @@ End glue. Local Definition rs : gReifiers NotCtxDep 2 := gReifiers_cons reify_store - (gReifiers_cons input_lang.interp.reify_io gReifiers_nil). + (gReifiers_cons reify_io gReifiers_nil). Variable Hdisj : ∀ (Σ : gFunctors) (P Q : iProp Σ), disjunction_property P Q. diff --git a/theories/examples/input_lang/interp.v b/theories/examples/input_lang/interp.v index 806f55a..202bc12 100644 --- a/theories/examples/input_lang/interp.v +++ b/theories/examples/input_lang/interp.v @@ -1,134 +1,9 @@ From gitrees Require Import gitree lang_generic. +From gitrees.effects Require Export io_tape. From gitrees.examples.input_lang Require Import lang. Require Import Binding.Lib Binding.Set. -Notation stateO := (leibnizO state). - -Program Definition inputE : opInterp := - {| - Ins := unitO; - Outs := natO; - |}. - -Program Definition outputE : opInterp := - {| - Ins := natO; - Outs := unitO; - |}. - -Definition ioE := @[inputE;outputE]. - -(* INPUT *) -Definition reify_input X `{Cofe X} : unitO * stateO → - option (natO * stateO) := - λ '(o, σ), Some (update_input σ : prodO natO stateO). -#[export] Instance reify_input_ne X `{Cofe X} : - NonExpansive (reify_input X). -Proof. - intros ?[[]][[]][_?]. simpl in *. f_equiv. - repeat f_equiv. done. -Qed. - -(* OUTPUT *) -Definition reify_output X `{Cofe X} : (natO * stateO) → - option (unitO * stateO) := - λ '(n, σ), Some((), update_output n σ : stateO). -#[export] Instance reify_output_ne X `{Cofe X} : - NonExpansive (reify_output X). -Proof. - intros ?[][][]. simpl in *. - repeat f_equiv; done. -Qed. - -Canonical Structure reify_io : sReifier NotCtxDep. -Proof. - simple refine {| sReifier_ops := ioE; - sReifier_state := stateO - |}. - intros X HX op. - destruct op as [[] | [ | []]]; simpl. - - simple refine (OfeMor (reify_input X)). - - simple refine (OfeMor (reify_output X)). -Defined. - -Section constructors. - Context {E : opsInterp} {A} `{!Cofe A}. - Context {subEff0 : subEff ioE E}. - Context {subOfe0 : SubOfe natO A}. - Notation IT := (IT E A). - Notation ITV := (ITV E A). - - Program Definition INPUT : (nat -n> IT) -n> IT := λne k, Vis (E:=E) (subEff_opid (inl ())) - (subEff_ins (F:=ioE) (op:=(inl ())) ()) - (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). - Solve Obligations with solve_proper. - Program Definition OUTPUT_ : nat -n> IT -n> IT := - λne m α, Vis (E:=E) (subEff_opid (inr (inl ()))) - (subEff_ins (F:=ioE) (op:=(inr (inl ()))) m) - (λne _, NextO α). - Solve All Obligations with solve_proper_please. - Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). - - Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). - Proof. - unfold INPUT. - rewrite hom_vis/=. repeat f_equiv. - intro x. cbn-[laterO_map]. rewrite laterO_map_Next. - done. - Qed. - Lemma hom_OUTPUT_ m α f `{!IT_hom f} : f (OUTPUT_ m α) ≡ OUTPUT_ m (f α). - Proof. - unfold OUTPUT. - rewrite hom_vis/=. repeat f_equiv. - intro x. cbn-[laterO_map]. rewrite laterO_map_Next. - done. - Qed. - -End constructors. - -Section weakestpre. - Context {sz : nat}. - Variable (rs : gReifiers NotCtxDep sz). - Context {subR : subReifier reify_io rs}. - Notation F := (gReifiers_ops rs). - Context {R} `{!Cofe R}. - Context `{!SubOfe natO R}. - Notation IT := (IT F R). - Notation ITV := (ITV F R). - Context `{!invGS Σ, !stateG rs R Σ}. - Notation iProp := (iProp Σ). - - Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : - update_input σ = (n, σ') → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ - WP@{rs} (INPUT k) @ s {{ Φ }}. - Proof. - intros Hs. iIntros "Hs Ha". - unfold INPUT. simpl. - iApply (wp_subreify_ctx_indep with "Hs"). - { simpl. rewrite Hs//=. } - { simpl. by rewrite ofe_iso_21. } - iModIntro. done. - Qed. - - Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : - update_output n σ = σ' → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ - WP@{rs} (OUTPUT n) @ s {{ Φ }}. - Proof. - intros Hs. iIntros "Hs Ha". - unfold OUTPUT. simpl. - iApply (wp_subreify_ctx_indep rs with "Hs"). - { simpl. by rewrite Hs. } - { simpl. done. } - iModIntro. iIntros "H1 H2". - iApply wp_val. by iApply ("Ha" with "H1 H2"). - Qed. - -End weakestpre. Section interp. Context {sz : nat}. diff --git a/theories/examples/input_lang/lang.v b/theories/examples/input_lang/lang.v index a9d15f4..0afca04 100644 --- a/theories/examples/input_lang/lang.v +++ b/theories/examples/input_lang/lang.v @@ -1,4 +1,4 @@ -From gitrees Require Export prelude. +From gitrees Require Export prelude effects.io_tape. Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. @@ -281,21 +281,6 @@ Qed. (*** Operational semantics *) -Record state := State { - inputs : list nat; - outputs : list nat; - }. -#[export] Instance state_inhabited : Inhabited state := populate (State [] []). - -Definition update_input (s : state) : nat * state := - match s.(inputs) with - | [] => (0, s) - | n::ns => - (n, {| inputs := ns; outputs := s.(outputs) |}) - end. -Definition update_output (n:nat) (s : state) : state := - {| inputs := s.(inputs); outputs := n::s.(outputs) |}. - Inductive head_step {S} : expr S → state → expr S → state → nat*nat → Prop := | BetaS e1 v2 σ : head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) (Val (shift (Inc := inc) v2))) (Val (RecV e1))) σ (1,0) diff --git a/theories/examples/input_lang_callcc/hom.v b/theories/examples/input_lang_callcc/hom.v index 66f3f2d..17d197e 100644 --- a/theories/examples/input_lang_callcc/hom.v +++ b/theories/examples/input_lang_callcc/hom.v @@ -9,7 +9,8 @@ Open Scope stdpp_scope. Section hom. Context {sz : nat}. Context {rs : gReifiers CtxDep sz}. - Context {subR : subReifier reify_io rs}. + 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). diff --git a/theories/examples/input_lang_callcc/interp.v b/theories/examples/input_lang_callcc/interp.v index 4262221..e87f55d 100644 --- a/theories/examples/input_lang_callcc/interp.v +++ b/theories/examples/input_lang_callcc/interp.v @@ -1,20 +1,7 @@ -From gitrees Require Import gitree lang_generic. +From gitrees Require Import gitree lang_generic effects.io_tape. From gitrees.examples.input_lang_callcc Require Import lang. Require Import Binding.Lib Binding.Set. -Notation stateO := (leibnizO state). - -Program Definition inputE : opInterp := - {| - Ins := unitO; - Outs := natO; - |}. -Program Definition outputE : opInterp := - {| - Ins := natO; - Outs := unitO; - |}. - Program Definition callccE : opInterp := {| Ins := ((▶ ∙ -n> ▶ ∙) -n> ▶ ∙); @@ -26,115 +13,57 @@ Program Definition throwE : opInterp := Outs := Empty_setO; |}. -Definition ioE := @[inputE;outputE;callccE;throwE]. - -Definition reify_input X `{Cofe X} : unitO * stateO * (natO -n> laterO X) → - option (laterO X * stateO) := - λ '(_, σ, k), let '(n, σ') := (update_input σ : prodO natO stateO) in - Some (k n, σ'). -#[export] Instance reify_input_ne X `{Cofe X} : - NonExpansive (reify_input X : prodO (prodO unitO stateO) - (natO -n> laterO X) → - optionO (prodO (laterO X) stateO)). -Proof. - intros n [[? σ1] k1] [[? σ2] k2]. simpl. - intros [[_ ->] Hk]. simpl in *. - repeat f_equiv. assumption. -Qed. - -Definition reify_output X `{Cofe X} : (natO * stateO * (unitO -n> laterO X)) → - optionO (prodO (laterO X) stateO) := - λ '(n, σ, k), Some (k (), ((update_output n σ) : stateO)). -#[export] Instance reify_output_ne X `{Cofe X} : - NonExpansive (reify_output X : prodO (prodO natO stateO) - (unitO -n> laterO X) → - optionO (prodO (laterO X) stateO)). -Proof. - intros ? [[]] [[]] []; simpl in *. - repeat f_equiv; first assumption; apply H0. -Qed. +Definition contE := @[callccE;throwE]. Definition reify_callcc X `{Cofe X} : ((laterO X -n> laterO X) -n> laterO X) * - stateO * (laterO X -n> laterO X) → - option (laterO X * stateO) := - λ '(f, σ, k), Some ((k (f k): laterO X), σ : stateO). + unitO * (laterO X -n> laterO X) → + option (laterO X * unitO) := + λ '(f, σ, k), Some ((k (f k): laterO X), σ : unitO). #[export] Instance reify_callcc_ne X `{Cofe X} : NonExpansive (reify_callcc X : - prodO (prodO ((laterO X -n> laterO X) -n> laterO X) stateO) + prodO (prodO ((laterO X -n> laterO X) -n> laterO X) unitO) (laterO X -n> laterO X) → - optionO (prodO (laterO X) stateO)). + optionO (prodO (laterO X) unitO)). Proof. intros ?[[]][[]][[]]. simpl in *. repeat f_equiv; auto. Qed. Definition reify_throw X `{Cofe X} : - ((laterO X * (laterO (X -n> X))) * stateO * (Empty_setO -n> laterO X)) → - option (laterO X * stateO) := + ((laterO X * (laterO (X -n> X))) * unitO * (Empty_setO -n> laterO X)) → + option (laterO X * unitO) := λ '((e, k'), σ, _), - Some (((laterO_ap k' : laterO X -n> laterO X) e : laterO X), σ : stateO). + Some (((laterO_ap k' : laterO X -n> laterO X) e : laterO X), σ : unitO). #[export] Instance reify_throw_ne X `{Cofe X} : NonExpansive (reify_throw X : - prodO (prodO (prodO (laterO X) (laterO (X -n> X))) stateO) + prodO (prodO (prodO (laterO X) (laterO (X -n> X))) unitO) (Empty_setO -n> laterO X) → - optionO (prodO (laterO X) (stateO))). + optionO (prodO (laterO X) (unitO))). Proof. intros ?[[[]]][[[]]]?. rewrite /reify_throw. repeat f_equiv; apply H0. Qed. -Canonical Structure reify_io : sReifier CtxDep. +Canonical Structure reify_cont : sReifier CtxDep. Proof. - simple refine {| sReifier_ops := ioE; - sReifier_state := stateO + simple refine {| sReifier_ops := contE; + sReifier_state := unitO |}. intros X HX op. - destruct op as [ | [ | [ | [| []]]]]; simpl. - - simple refine (OfeMor (reify_input X)). - - simple refine (OfeMor (reify_output X)). + destruct op as [|[|[]]]; simpl. - simple refine (OfeMor (reify_callcc X)). - simple refine (OfeMor (reify_throw X)). Defined. Section constructors. Context {E : opsInterp} {A} `{!Cofe A}. - Context {subEff0 : subEff ioE E}. - Context {subOfe0 : SubOfe natO A}. + Context {subEff0 : subEff contE E}. Notation IT := (IT E A). Notation ITV := (ITV E A). - Program Definition INPUT : (nat -n> IT) -n> IT := - λne k, Vis (E:=E) (subEff_opid (inl ())) - (subEff_ins (F:=ioE) (op:=(inl ())) ()) - (NextO ◎ k ◎ (subEff_outs (F:=ioE) (op:=(inl ())))^-1). - Solve Obligations with solve_proper. - - Program Definition OUTPUT_ : nat -n> IT -n> IT := - λne m α, Vis (E:=E) (subEff_opid (inr (inl ()))) - (subEff_ins (F:=ioE) (op:=(inr (inl ()))) m) - (λne _, NextO α). - Solve All Obligations with solve_proper_please. - Program Definition OUTPUT : nat -n> IT := λne m, OUTPUT_ m (Ret 0). - - Lemma hom_INPUT k f `{!IT_hom f} : f (INPUT k) ≡ INPUT (OfeMor f ◎ k). - Proof. - unfold INPUT. - rewrite hom_vis/=. repeat f_equiv. - intro x. cbn-[laterO_map]. rewrite laterO_map_Next. - done. - Qed. - Lemma hom_OUTPUT_ m α f `{!IT_hom f} : f (OUTPUT_ m α) ≡ OUTPUT_ m (f α). - Proof. - unfold OUTPUT. - rewrite hom_vis/=. repeat f_equiv. - intro x. cbn-[laterO_map]. rewrite laterO_map_Next. - done. - Qed. - - Program Definition CALLCC_ : ((laterO IT -n> laterO IT) -n> laterO IT) -n> (laterO IT -n> laterO IT) -n> IT := - λne f k, Vis (E:=E) (subEff_opid (inr (inr (inl ())))) - (subEff_ins (F:=ioE) (op:=(inr (inr (inl ())))) f) - (k ◎ (subEff_outs (F:=ioE) (op:=(inr (inr (inl ())))))^-1). + λne f k, Vis (E:=E) (subEff_opid (inl ())) + (subEff_ins (F:=contE) (op:=(inl ())) f) + (k ◎ (subEff_outs (F:=contE) (op:=(inl ())))^-1). Solve All Obligations with solve_proper. Program Definition CALLCC : ((laterO IT -n> laterO IT) -n> laterO IT) -n> IT := @@ -150,10 +79,10 @@ Section constructors. Qed. Program Definition THROW : IT -n> (laterO (IT -n> IT)) -n> IT := - λne e k, Vis (E:=E) (subEff_opid (inr (inr (inr (inl ()))))) - (subEff_ins (F:=ioE) (op:=(inr (inr (inr (inl ()))))) + λne e k, Vis (E:=E) (subEff_opid (inr (inl ()))) + (subEff_ins (F:=contE) (op:=(inr (inl ()))) (NextO e, k)) - (λne x, Empty_setO_rec _ ((subEff_outs (F:=ioE) (op:=(inr (inr (inr (inl ()))))))^-1 x)). + (λne x, Empty_setO_rec _ ((subEff_outs (F:=contE) (op:=(inr (inl ()))))^-1 x)). Next Obligation. solve_proper_prepare. destruct ((subEff_outs ^-1) x). @@ -172,68 +101,20 @@ End constructors. Section weakestpre. Context {sz : nat}. Variable (rs : gReifiers CtxDep sz). - Context {subR : subReifier reify_io rs}. + Context {subR : subReifier reify_cont rs}. Notation F := (gReifiers_ops rs). Context {R} `{!Cofe R}. - Context `{!SubOfe natO R}. Notation IT := (IT F R). Notation ITV := (ITV F R). Context `{!invGS Σ, !stateG rs R Σ}. Notation iProp := (iProp Σ). - Lemma wp_input' (σ σ' : stateO) (n : nat) (k : natO -n> IT) (κ : IT -n> IT) - `{!IT_hom κ} Φ s : - update_input σ = (n, σ') -> - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ ◎ k $ n) @ s {{ Φ }}) -∗ - WP@{rs} κ (INPUT k) @ s {{ Φ }}. - Proof. - iIntros (Hσ) "Hs Ha". - rewrite hom_INPUT. simpl. - iApply (wp_subreify_ctx_dep with "Hs"). - + simpl. by rewrite Hσ. - + by rewrite ofe_iso_21. - + done. - Qed. - - Lemma wp_input (σ σ' : stateO) (n : nat) (k : natO -n> IT) Φ s : - update_input σ = (n, σ') → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (k n) @ s {{ Φ }}) -∗ - WP@{rs} (INPUT k) @ s {{ Φ }}. - Proof. - eapply (wp_input' σ σ' n k idfun). - Qed. + Implicit Type σ : unitO. + Implicit Type κ : IT -n> IT. + Implicit Type x : IT. - Lemma wp_output' (σ σ' : stateO) (n : nat) (κ : IT -n> IT) + Lemma wp_throw' σ κ (f : IT -n> IT) (x : IT) `{!IT_hom κ} Φ s : - update_output n σ = σ' → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ (Ret 0)) @ s {{ Φ }}) -∗ - WP@{rs} κ (OUTPUT n) @ s {{ Φ }}. - Proof. - iIntros (Hσ) "Hs Ha". - rewrite /OUTPUT hom_OUTPUT_. - iApply (wp_subreify_ctx_dep with "Hs"). - + simpl. by rewrite Hσ. - + done. - + done. - Qed. - - Lemma wp_output (σ σ' : stateO) (n : nat) Φ s : - update_output n σ = σ' → - has_substate σ -∗ - ▷ (£ 1 -∗ has_substate σ' -∗ Φ (RetV 0)) -∗ - WP@{rs} (OUTPUT n) @ s {{ Φ }}. - Proof. - iIntros (Hσ) "Hs Ha". - iApply (wp_output' _ _ _ idfun with "Hs [Ha]"); first done. - simpl. iNext. iIntros "Hcl Hs". - iApply wp_val. iApply ("Ha" with "Hcl Hs"). - Qed. - - Lemma wp_throw' (σ : stateO) (f : IT -n> IT) (x : IT) - (κ : IT -n> IT) `{!IT_hom κ} Φ s : has_substate σ -∗ ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} f x @ s {{ Φ }}) -∗ WP@{rs} κ (THROW x (Next f)) @ s {{ Φ }}. @@ -243,15 +124,15 @@ Section weakestpre. iApply (wp_subreify_ctx_dep with "Hs"); simpl; done. Qed. - Lemma wp_throw (σ : stateO) (f : IT -n> IT) (x : IT) Φ s : + Lemma wp_throw σ (f : IT -n> IT) (x : IT) Φ s : has_substate σ -∗ ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} f x @ s {{ Φ }}) -∗ WP@{rs} (THROW x (Next f)) @ s {{ Φ }}. Proof. - iApply (wp_throw' _ _ _ idfun). + iApply (wp_throw' _ idfun). Qed. - Lemma wp_callcc (σ : stateO) (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} β Φ s : + Lemma wp_callcc σ (f : (laterO IT -n> laterO IT) -n> laterO IT) (k : IT -n> IT) {Hk : IT_hom k} β Φ s : f (laterO_map k) ≡ Next β → has_substate σ -∗ ▷ (£ 1 -∗ has_substate σ -∗ WP@{rs} k β @ s {{ Φ }}) -∗ @@ -275,12 +156,45 @@ Section weakestpre. iApply "Ha". Qed. + (* XXX TODO: this duplicates wp_input and wp_output *) + Context `{!subReifier (sReifier_NotCtxDep_CtxDep reify_io) rs}. + Context `{!SubOfe natO R}. + Lemma wp_input' (σ σ' : stateO) (n : nat) (k : natO -n> IT) (κ : IT -n> IT) + `{!IT_hom κ} Φ s : + update_input σ = (n, σ') -> + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ ◎ k $ n) @ s {{ Φ }}) -∗ + WP@{rs} κ (INPUT k) @ s {{ Φ }}. + Proof. + iIntros (Hσ) "Hs Ha". + rewrite hom_INPUT. + iApply (wp_subreify_ctx_dep with "Hs"). + + simpl. rewrite Hσ. simpl. done. + + by rewrite ofe_iso_21. + + done. + Qed. + Lemma wp_output' (σ σ' : stateO) (n : nat) (κ : IT -n> IT) + `{!IT_hom κ} Φ s : + update_output n σ = σ' → + has_substate σ -∗ + ▷ (£ 1 -∗ has_substate σ' -∗ WP@{rs} (κ (Ret 0)) @ s {{ Φ }}) -∗ + WP@{rs} κ (OUTPUT n) @ s {{ Φ }}. + Proof. + iIntros (Hσ) "Hs Ha". + rewrite /OUTPUT hom_OUTPUT_. + iApply (wp_subreify_ctx_dep with "Hs"). + + simpl. by rewrite Hσ. + + done. + + done. + Qed. + End weakestpre. Section interp. Context {sz : nat}. Variable (rs : gReifiers CtxDep sz). - Context {subR : subReifier reify_io rs}. + Context {subR1 : subReifier reify_cont rs}. + Context {subR2 : subReifier (sReifier_NotCtxDep_CtxDep reify_io) rs}. Context {R} `{CR : !Cofe R}. Context `{!SubOfe natO R}. Notation F := (gReifiers_ops rs). @@ -929,13 +843,11 @@ Section interp. } rewrite reify_vis_eq_ctx_dep //; first last. { - epose proof (@subReifier_reify sz CtxDep reify_io rs _ IT _ (inl ()) () (Next (interp_ectx K env (Ret n0))) (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr) as H. - simpl in H. - simpl. - erewrite <-H; last first. - - rewrite H5. reflexivity. - - f_equiv; - solve_proper. + apply (subReifier_reify + (sReifier_NotCtxDep_CtxDep reify_io) rs (inl ()) + () (Next (interp_ectx K env (Ret n0))) + (NextO ◎ (interp_ectx K env ◎ Ret)) σ σ' σr). + simpl. rewrite H5. reflexivity. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. rewrite interp_comp. @@ -952,12 +864,14 @@ Section interp. } rewrite reify_vis_eq_ctx_dep //; last first. { - epose proof (@subReifier_reify sz CtxDep reify_io rs _ IT _ (inr (inl ())) n0 (Next (interp_ectx K env ((Ret 0)))) (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. - simpl in H. simpl. - erewrite <-H; last reflexivity. + pose proof (subReifier_reify + (sReifier_NotCtxDep_CtxDep reify_io) rs (inr (inl ())) + n0 (Next (interp_ectx K env (Ret 0))) + (constO (Next (interp_ectx K env ((Ret 0))))) σ (update_output n0 σ) σr) as H. + simpl in H. erewrite <-H; last reflexivity. f_equiv. - + intros ???. by rewrite /prod_map H0. + + do 3 intro. by rewrite /prod_map H0. + do 2 f_equiv. by intro. } repeat f_equiv. rewrite Tick_eq/=. repeat f_equiv. @@ -971,7 +885,6 @@ Section interp. Transparent CALLCC. unfold CALLCC. simpl. - set (subEff1 := @subReifier_subEff sz CtxDep reify_io rs subR). trans (reify (gReifiers_sReifier rs) (CALLCC_ f (laterO_map (interp_ectx K env))) gσ). { do 2 f_equiv. @@ -981,17 +894,28 @@ Section interp. rewrite reify_vis_eq_ctx_dep//; last first. { simpl. - epose proof (@subReifier_reify sz CtxDep reify_io rs subR IT _ - (inr (inr (inl ()))) f _ - (laterO_map (interp_ectx K env)) σ' σ' σr) as H. + set (ss := gState_decomp (@sR_idx _ _ _ _ subR1) gσ). + pose (s1 := (sR_state^-1 ss.1)). simpl in s1. + epose proof (subReifier_reify reify_cont rs (inl ()) f _ + (laterO_map (interp_ectx K env)) + s1 s1 (ss.2)) as H. simpl in H. erewrite <-H; last reflexivity. - f_equiv; last done. - intros ???. by rewrite /prod_map H0. + f_equiv. + + intros ???. rewrite /prod_map H0. repeat f_equiv. + rewrite ofe_iso_12. + destruct ss; f_equiv; eauto. simpl. + symmetry. apply ofe_iso_12. + + repeat f_equiv; eauto. + rewrite ofe_iso_12. + destruct ss; f_equiv; eauto. + symmetry. apply ofe_iso_12. } rewrite interp_comp. rewrite interp_expr_subst. f_equiv. + { setoid_rewrite ofe_iso_12. + by apply gState_recomp_decomp. } rewrite Tick_eq. f_equiv. rewrite laterO_map_Next. @@ -1094,19 +1018,36 @@ Section interp. match goal with | |- context G [(_, _, ?a)] => set (κ := a) end. - epose proof (@subReifier_reify sz CtxDep reify_io rs subR IT _ - (inr (inr (inr (inl ())))) (Next (interp_val v env), Next f') + set (gσ := (gState_recomp σr (sR_state (σ2 : sReifier_state (sReifier_NotCtxDep_CtxDep reify_io) ♯ IT)))). + (* set (gσ := (gState_recomp σr (sR_state σ2))). *) + set (ss := gState_decomp (@sR_idx _ _ _ _ subR1) gσ). + pose (s1 := (sR_state^-1 ss.1)). simpl in gσ, s1. + epose proof (subReifier_reify reify_cont rs (inr (inl ())) + (Next (interp_val v env), Next f') (Next (Tau (Next ((interp_ectx K' env) (interp_val v env))))) - (Empty_setO_rec _) σ2 σ2 σr) as H'. - subst κ. + (Empty_setO_rec _) s1 s1 ss.2) as H'. simpl in H'. - erewrite <-H'; last reflexivity. - rewrite /prod_map. - f_equiv; first solve_proper. - do 2 f_equiv; first reflexivity. - intro; simpl. - f_equiv. - } + subst κ. + simpl. trans (Some + (Next (Tau (Next (interp_ectx K' env (interp_val v env)))), + gState_recomp ss.2 (sR_state (s1 : sReifier_state reify_cont ♯ IT)))). + - erewrite <-H'; last reflexivity. + rewrite /prod_map. + f_equiv. + + repeat intro. repeat f_equiv; eauto. + unfold s1. + setoid_rewrite ofe_iso_12. + symmetry. by apply gState_recomp_decomp. + + do 2 f_equiv. + * repeat f_equiv. unfold s1. + setoid_rewrite ofe_iso_12. + symmetry. by apply gState_recomp_decomp. + * intro; simpl. + f_equiv. done. + - rewrite Tick_eq. repeat f_equiv. + unfold s1. + setoid_rewrite ofe_iso_12. + by apply gState_recomp_decomp. } Qed. End interp. diff --git a/theories/examples/input_lang_callcc/lang.v b/theories/examples/input_lang_callcc/lang.v index 65eabcb..8f5cb94 100644 --- a/theories/examples/input_lang_callcc/lang.v +++ b/theories/examples/input_lang_callcc/lang.v @@ -1,4 +1,4 @@ -From gitrees Require Export prelude. +From gitrees Require Export prelude effects.io_tape. Require Import Binding.Resolver Binding.Lib Binding.Set Binding.Auto Binding.Env. Inductive nat_op := Add | Sub | Mult. @@ -299,22 +299,6 @@ Qed. (*** Operational semantics *) -Record state := State { - inputs : list nat; - outputs : list nat; - }. -#[export] Instance state_inhabited : Inhabited state := populate (State [] []). - -Definition update_input (s : state) : nat * state := - match s.(inputs) with - | [] => (0, s) - | n::ns => - (n, {| inputs := ns; outputs := s.(outputs) |}) - end. -Definition update_output (n:nat) (s : state) : state := - {| inputs := s.(inputs); outputs := n::s.(outputs) |}. - - Inductive head_step {S} : expr S → state → expr S → state → ectx S → nat * nat → Prop := | BetaS e1 v2 σ K : head_step (App (Val $ RecV e1) (Val v2)) σ (subst (Inc := inc) ((subst (F := expr) (Inc := inc) e1) (Val (shift (Inc := inc) v2))) (Val (RecV e1))) σ K (1,0) diff --git a/theories/examples/input_lang_callcc/logrel.v b/theories/examples/input_lang_callcc/logrel.v index 8d2891a..677579a 100644 --- a/theories/examples/input_lang_callcc/logrel.v +++ b/theories/examples/input_lang_callcc/logrel.v @@ -1,5 +1,5 @@ (** Logical relation for adequacy for the IO lang *) -From gitrees Require Import gitree lang_generic. +From gitrees Require Import gitree lang_generic effects.io_tape. From gitrees.examples.input_lang_callcc Require Import lang interp hom. Require Import Binding.Lib Binding.Set Binding.Env. @@ -8,13 +8,14 @@ Open Scope stdpp_scope. Section logrel. Context {sz : nat}. Variable (rs : gReifiers CtxDep sz). - Context {subR : subReifier reify_io rs}. + 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). Context `{!invGS Σ, !stateG rs natO Σ}. Notation iProp := (iProp Σ). - Notation restO := (gState_rest sR_idx rs ♯ IT). + Notation restO := (gState_rest (@sR_idx _ _ (sReifier_NotCtxDep_CtxDep reify_io)) rs ♯ IT). Canonical Structure exprO S := leibnizO (expr S). Canonical Structure valO S := leibnizO (val S). @@ -31,11 +32,13 @@ Section logrel. Definition logrel_nat {S} (βv : ITV) (v : val S) : iProp := (∃ n, βv ≡ RetV n ∧ ⌜v = LitV n⌝)%I. + Definition cont_ctx : iProp := has_substate (() : sReifier_state reify_cont ♯ IT). + Definition obs_ref {S} (α : IT) (e : expr S) : iProp := (∀ (σ : stateO), - has_substate σ -∗ + has_substate σ -∗ cont_ctx -∗ WP α {{ βv, ∃ m v σ', ⌜prim_steps e σ (Val v) σ' m⌝ - ∗ logrel_nat βv v ∗ has_substate σ' }})%I. + ∗ logrel_nat βv v ∗ has_substate σ' ∗ cont_ctx }})%I. Definition logrel_ectx {S} V (κ : HOM) (K : ectx S) : iProp := (□ ∀ (βv : ITV) (v : val S), V βv v -∗ obs_ref (`κ (IT_of_V βv)) (fill K (Val v)))%I. @@ -181,9 +184,8 @@ Section logrel. intros Hpure. iIntros "H". iIntros (κ' K') "#HK'". - iIntros (σ) "Hs". - iSpecialize ("H" with "HK'"). - iSpecialize ("H" with "Hs"). + iIntros (σ) "Hs Hcont". + iSpecialize ("H" with "HK' Hs Hcont"). iApply (wp_wand with "H"). iIntros (βv). iDestruct 1 as ([m m'] v σ' Hsteps) "[H2 Hs]". iExists ((Nat.add n m),m'),v,σ'. iFrame "H2 Hs". @@ -200,8 +202,8 @@ Section logrel. obs_ref (`f α) (fill K e). Proof. iIntros "H1 #H2". - iIntros (σ) "Hs". - iApply (wp_wand with "[H1 H2 Hs] []"); first iApply ("H1" with "[H2] [$Hs]"). + iIntros (σ) "Hs Hcont". + iApply (wp_wand with "[H1 H2 Hs Hcont] []"); first iApply ("H1" with "[H2] [$Hs] Hcont"). - iIntros (βv v). iModIntro. iIntros "#Hv". by iApply "H2". @@ -260,9 +262,9 @@ Section logrel. (Tick (f (IT_of_V αv))) (logrel_val τ2) with "[]"); last first. + rewrite {2}/ss'. rewrite /f. - iIntros (κ K) "#HK". iIntros (σ) "Hs". + iIntros (κ K) "#HK". iIntros (σ) "Hs Hcont". rewrite hom_tick. iApply wp_tick. iNext. - iApply "H"; eauto. + iApply ("H" with "[] [] Hs Hcont"); eauto. rewrite /ss' /γ'. iIntros (x'); destruct x' as [| [| x']]; term_simpl; iModIntro. * by iApply logrel_of_val. @@ -338,12 +340,12 @@ Section logrel. iIntros (κ K) "#HK". unfold interp_input. term_simpl. - iIntros (σ) "Hs". + iIntros (σ) "Hs Hcont". destruct (update_input σ) as [n σ'] eqn:Hinp. - iApply (wp_input' with "Hs []"); first done. + iApply (wp_input' with "Hs [-]"); first done. iNext. iIntros "Hlc Hs". term_simpl. iSpecialize ("HK" $! (RetV n) (LitV n) with "[]"); first by iExists n. - iSpecialize ("HK" $! σ' with "Hs"). + iSpecialize ("HK" $! σ' with "Hs Hcont"). rewrite IT_of_V_Ret. iApply (wp_wand with "[$HK] []"). iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". @@ -449,12 +451,12 @@ Section logrel. iRewrite "HEQ". rewrite get_fun_fun. simpl. - iIntros (σ) "Hs". - iApply (wp_throw' with "Hs []"). - iNext. iIntros "Hcl Hs". term_simpl. + iIntros (σ) "Hs Hcont". + iApply (wp_throw' with "Hcont"). + iNext. iIntros "Hcl Hcont". term_simpl. rewrite later_map_Next. iApply wp_tick. iNext. iSpecialize ("H" $! βv v with "[]"); first done. - iSpecialize ("H" $! σ with "Hs"). + iSpecialize ("H" $! σ with "Hs Hcont"). iApply (wp_wand with "[$H] []"). iIntros (w) "(%m & %v'' & %σ'' & %Hstep & H)". destruct m as [m m']. @@ -479,11 +481,11 @@ Section logrel. unfold interp_callcc. Opaque extend_scope. term_simpl. - iIntros (σ) "Hs". + iIntros (σ) "Hs Hcont". - iApply (wp_callcc with "Hs []"). + iApply (wp_callcc with "Hcont"). { simpl. done. } - iNext. iIntros "Hcl Hs". term_simpl. + iNext. iIntros "Hcl Hcont". term_simpl. pose (ff := (λit x : IT, Tick ((`κ) x))). match goal with @@ -519,7 +521,7 @@ Section logrel. iSpecialize ("H" $! κ K with "HK"). Opaque extend_scope. term_simpl. - iSpecialize ("H" $! σ with "Hs"). + iSpecialize ("H" $! σ with "Hs Hcont"). subst ss' γ'. iApply (wp_wand with "[$H] []"). iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H)". @@ -555,12 +557,12 @@ Section logrel. iIntros (βv v). iModIntro. iIntros "#Hv". iDestruct "Hv" as (n) "[Hb ->]". iRewrite "Hb". simpl. - iIntros (σ) "Hs". + iIntros (σ) "Hs Hcont". rewrite get_ret_ret. - iApply (wp_output' with "Hs []"); first done. + iApply (wp_output' with "Hs"); first done. iNext. iIntros "Hlc Hs". iSpecialize ("HK" $! (RetV 0) (LitV 0) with "[]"); first by iExists 0. - iSpecialize ("HK" $! (update_output n σ) with "Hs"). + iSpecialize ("HK" $! (update_output n σ) with "Hs Hcont"). iApply (wp_wand with "[$HK] []"). iIntros (v') "(%m & %v'' & %σ'' & %Hstep & H')". destruct m as [m m']. @@ -685,13 +687,15 @@ Lemma κ_Ret {S} {E} n : κ ((RetV n) : ITV E natO) = (LitV n : val S). Proof. Transparent RetV. unfold RetV. simpl. done. Opaque RetV. Qed. -Definition rs : gReifiers CtxDep 1 := gReifiers_cons reify_io gReifiers_nil. +Definition rs : gReifiers CtxDep 2 := + gReifiers_cons (sReifier_NotCtxDep_CtxDep reify_io) + (gReifiers_cons reify_cont gReifiers_nil). Lemma logrel_nat_adequacy Σ `{!invGpreS Σ} `{!statePreG rs natO Σ} {S} (α : IT (gReifiers_ops rs) natO) (e : expr S) n σ σ' k : (∀ `{H1 : !invGS Σ} `{H2: !stateG rs natO Σ}, (⊢ logrel rs Tnat α e)%I) → - ssteps (gReifiers_sReifier rs) α (σ, ()) (Ret n) σ' k → + ssteps (gReifiers_sReifier rs) α (σ, ((), ())) (Ret n) σ' k → ∃ m σ', prim_steps e σ (Val $ LitV n) σ' m. Proof. intros Hlog Hst. @@ -727,26 +731,28 @@ Proof. eauto. - iIntros "[_ Hs]". iPoseProof (Hlog) as "Hlog". - iAssert (has_substate σ) with "[Hs]" as "Hs". + iAssert (has_substate σ ∗ cont_ctx rs)%I with "[Hs]" as "[Hs Hcont]". { unfold has_substate, has_full_state. - assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ())) ≡ - (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ))) - as -> ; last done. - intros 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)//. + assert ((of_state rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) (σ, ((),()))) ≡ + (of_idx rs (IT (sReifier_ops (gReifiers_sReifier rs)) natO) sR_idx (sR_state σ)) + ⋅ of_idx rs (IT (gReifiers_ops rs) _) sR_idx (sR_state (() : sReifier_state reify_cont ♯ IT _ _))) + as -> ; last first. + { rewrite -own_op. done. } + unfold sR_idx. simpl. + intro j. + rewrite discrete_fun_lookup_op. + inv_fin j. + { unfold of_state, of_idx. simpl. + erewrite (eq_pi _ _ _ (@eq_refl _ 0%fin)). done. } + intros j. inv_fin j. + { unfold of_state, of_idx. simpl. + erewrite (eq_pi _ _ _ (@eq_refl _ 1%fin)). done. } + intros i. inversion i. } iSpecialize ("Hlog" $! HOM_id EmptyK with "[]"). { - iIntros (βv v); iModIntro. iIntros "Hv". iIntros (σ'') "HS". + iIntros (βv v); iModIntro. iIntros "Hv". iIntros (σ'') "HS Hcont". iApply wp_val. iModIntro. iExists (0, 0), v, σ''. @@ -755,7 +761,7 @@ Proof. - by iFrame. } simpl. - iSpecialize ("Hlog" $! σ with "Hs"). + iSpecialize ("Hlog" $! σ with "Hs Hcont"). iApply (wp_wand with"Hlog"). iIntros ( βv). iIntros "H". iDestruct "H" as (m' v σ1' Hsts) "[Hi Hsts]". @@ -766,7 +772,7 @@ Qed. Theorem adequacy (e : expr ∅) (k : nat) σ σ' n : typed □ e Tnat → - ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ, ()) (Ret k : IT _ natO) σ' n → + ssteps (gReifiers_sReifier rs) (interp_expr rs e ı_scope) (σ,((), ())) (Ret k : IT _ natO) σ' n → ∃ mm σ', prim_steps e σ (Val $ LitV k) σ' mm. Proof. intros Hty Hst. diff --git a/theories/gitree/greifiers.v b/theories/gitree/greifiers.v index e1847c8..db4d41c 100644 --- a/theories/gitree/greifiers.v +++ b/theories/gitree/greifiers.v @@ -346,6 +346,17 @@ Section greifiers. apply subEff_outs. Defined. + #[export] Instance reifier_coercion_subEff {sz} r (rs : gReifiers CtxDep sz) + `{H : !subReifier (sReifier_NotCtxDep_CtxDep r) rs} : + subEff (sReifier_ops r) (gReifiers_ops _ rs) | 100. + Proof. + simple refine + {| subEff_opid (op : opid (sReifier_ops (sReifier_NotCtxDep_CtxDep r))) + := subEff_opid op |}. + - intros. apply subEff_ins. + - intros. apply subEff_outs. + Defined. + Program Definition subReifier_reify_idx_type {n} (a : is_ctx_dep) (r : sReifier a) (rs : gReifiers a n) `{!subReifier r rs} X `{!Cofe X} (op : opid (sReifier_ops r)) : Type. From cfb890ad6910e09ef97f645e757a517afd0261bf Mon Sep 17 00:00:00 2001 From: Dan Frumin Date: Tue, 27 Feb 2024 14:19:06 +0100 Subject: [PATCH 114/114] final tweaks --- .github/workflows/build.yml | 1 + README.md | 19 +++++++------------ TODO.md | 18 ------------------ 3 files changed, 8 insertions(+), 30 deletions(-) delete mode 100644 TODO.md diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 6f094f0..7fcfe94 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -19,6 +19,7 @@ jobs: matrix: image: - 'coqorg/coq:8.17' + - 'coqorg/coq:8.18' max-parallel: 4 fail-fast: false diff --git a/README.md b/README.md index 20a96ee..c74eddd 100644 --- a/README.md +++ b/README.md @@ -26,13 +26,17 @@ to the code structure. - `gitree/` -- contains the core definitions related to guarded interaction trees - `lib/` -- derived combinators for gitrees +- `effects/` -- concrete effects, their semantics, and program logic rules - `examples/input_lang/` -- formalization of the language with io, the soundness and adequacy -- `examples/input_lang_callcc/` -- formalization of the language with io, throw and call/cc, the soundness and adequacy - `examples/affine_lang/` -- formalization of the affine language, type safety of the language interoperability -- `effects/` -- concrete effects, their interpretaions, and logics +- `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 - `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` -- `vendor/Binding/` -- the functorial syntax library used for + +For the representation of binders we use a library implemented by +Filip Sieczkowski and Piotr Polesiuk, located in the `vendor/Binding/` +folder. ### References from the paper to the code @@ -76,15 +80,6 @@ Below we describe the correspondence per-section. ## Notes -### Representations of binders 1 -For the representation of languages with binders, we follow the -approach of (Benton, Hur, Kennedy, McBride, JAR 2012) with well-scoped -terms and substitutions/renamings. (`input_lang`, `affine_lang`) - -### Representations of binders 2 -For `input_lang_callcc` we use a binder library, implemented by Filip -Sieczkowski and Piotr Polesiuk. - ### Disjunction property Some results in the formalization make use of the disjunction property of Iris: if (P ∨ Q) is provable, then either P or Q are provable on diff --git a/TODO.md b/TODO.md deleted file mode 100644 index 1038abe..0000000 --- a/TODO.md +++ /dev/null @@ -1,18 +0,0 @@ -# Now -- cleanup code - + especially implicit arguments, inserted by typeclasses - + lemmas for logrel -- backward compatibility - + instances of CtxIndep from individual effects, from sreifiers to greifiers -- write summary - + reifiers changes - + non-cps vs cps - + extra ticks for throw -# Later -- (ctrees)[https://perso.ens-lyon.fr/yannick.zakowski/papers/ctrees.pdf] -- Nondet : (n : nat) (f : fin n -n> \later IT) -n> IT -- (Nondet : (f : nat -n> \later IT) -n> IT) (might require transfinite iris) -- Cooperative concurrency -# Later later -- bisimularity for gitrees (might require transfinite iris) -- concurrency