From 1594ef0bd2c93b1ce2c98f0d519fb9a78dd3ae2c Mon Sep 17 00:00:00 2001 From: mueck Date: Wed, 20 Dec 2023 10:58:10 +0100 Subject: [PATCH 1/2] solution for exercise 07 --- _CoqProject | 3 + .../systemf_mu_state/exercises07_sol.v | 202 ++ .../systemf_mu_state/logrel_sol.v | 1772 +++++++++++++++++ .../type_systems/systemf_mu_state/types_sol.v | 1337 +++++++++++++ 4 files changed, 3314 insertions(+) create mode 100644 theories/type_systems/systemf_mu_state/exercises07_sol.v create mode 100644 theories/type_systems/systemf_mu_state/logrel_sol.v create mode 100644 theories/type_systems/systemf_mu_state/types_sol.v diff --git a/_CoqProject b/_CoqProject index 42ca85c..45f39cf 100644 --- a/_CoqProject +++ b/_CoqProject @@ -69,10 +69,12 @@ theories/type_systems/systemf_mu_state/locations.v theories/type_systems/systemf_mu_state/lang.v theories/type_systems/systemf_mu_state/notation.v theories/type_systems/systemf_mu_state/types.v +theories/type_systems/systemf_mu_state/types_sol.v theories/type_systems/systemf_mu_state/tactics.v theories/type_systems/systemf_mu_state/execution.v theories/type_systems/systemf_mu_state/parallel_subst.v theories/type_systems/systemf_mu_state/logrel.v +theories/type_systems/systemf_mu_state/logrel_sol.v # By removing the # below, you can add the exercise sheets to make #theories/type_systems/warmup/warmup.v @@ -92,3 +94,4 @@ theories/type_systems/systemf_mu_state/logrel.v #theories/type_systems/systemf_mu/exercises06.v #theories/type_systems/systemf_mu/exercises06_sol.v #theories/type_systems/systemf_mu_state/exercises07.v +#theories/type_systems/systemf_mu_state/exercises07_sol.v diff --git a/theories/type_systems/systemf_mu_state/exercises07_sol.v b/theories/type_systems/systemf_mu_state/exercises07_sol.v new file mode 100644 index 0000000..80c9047 --- /dev/null +++ b/theories/type_systems/systemf_mu_state/exercises07_sol.v @@ -0,0 +1,202 @@ +From iris Require Import prelude. +From semantics.ts.systemf_mu_state Require Import lang notation parallel_subst tactics execution. + +(** * Exercise Sheet 7 *) + +(** Exercise 1: Stack (LN Exercise 45) *) +(* We use lists to model our stack *) +Section lists. + Context (A : type). + Definition list_type : type := + μ: Unit + (A.[ren (+1)] × #0). + + Definition nil_val : val := + RollV (InjLV (LitV LitUnit)). + Definition cons_val (v : val) (xs : val) : val := + RollV (InjRV (v, xs)). + Definition cons_expr (v : expr) (xs : expr) : expr := + roll (InjR (v, xs)). + + Definition list_case : val := + Λ, λ: "l" "n" "hf", match: unroll "l" with InjL <> => "n" | InjR "h" => "hf" (Fst "h") (Snd "h") end. + + Lemma nil_val_typed Σ n Γ : + type_wf n A → + TY Σ; n; Γ ⊢ nil_val : list_type. + Proof. + intros. solve_typing. + Qed. + + Lemma cons_val_typed Σ n Γ (v xs : val) : + type_wf n A → + TY Σ; n; Γ ⊢ v : A → + TY Σ; n; Γ ⊢ xs : list_type → + TY Σ; n; Γ ⊢ cons_val v xs : list_type. + Proof. + intros. simpl. solve_typing. + Qed. + + Lemma cons_expr_typed Σ n Γ (x xs : expr) : + type_wf n A → + TY Σ; n; Γ ⊢ x : A → + TY Σ; n; Γ ⊢ xs : list_type → + TY Σ; n; Γ ⊢ cons_expr x xs : list_type. + Proof. + intros. simpl. solve_typing. + Qed. + + Lemma list_case_typed Σ n Γ : + type_wf n A → + TY Σ; n; Γ ⊢ list_case : (∀: list_type.[ren (+1)] → #0 → (A.[ren(+1)] → list_type.[ren (+1)] → #0) → #0). + Proof. + intros. simpl. solve_typing. + Qed. +End lists. + +(* The stack interface *) +Definition stack_t A : type := + ∃: ((Unit → #0) (* new *) + × (#0 → A.[ren (+1)] → Unit) (* push *) + × (#0 → Unit + A.[ren (+1)])) (* pop *) + . + +(** We assume an abstract implementation of lists (an example implementation is provided above) *) +Definition list_t (A : type) : type := + ∃: (#0 (* mynil *) + × (A.[ren (+1)] → #0 → #0) (* mycons *) + × (∀: #1 → #0 → (A.[ren (+2)] → #1 → #0) → #0)) (* mylistcase *) + . + +Definition mystack : val := + (* define your stack implementation, assuming "lc" is a list implementation *) + λ: "lc", + ((λ: <>, New (Fst (Fst "lc"))), + (λ: "st" "el", + let: "stv" := !"st" in + "st" <- Snd (Fst "lc") "el" "stv"), + (λ: "st", + let: "stv" := !"st" in + (Snd "lc") <> "stv" (InjL #())%V (λ: "h" "rstv", + "st" <- "rstv";; + InjR "h"))). + +Definition make_mystack : val := + Λ, λ: "lc", + unpack "lc" as "lc" in + pack (mystack "lc"). + +Lemma make_mystack_typed Σ n Γ : + TY Σ; n; Γ ⊢ make_mystack : (∀: list_t #0 → stack_t #0). +Proof. + repeat solve_typing_fast. +Qed. + + +(** Exercise 2 (LN Exercise 46): Obfuscated code *) +Definition obf_expr : expr := + let: "x" := new (λ: "x", "x" + "x") in + let: "f" := (λ: "g", let: "f" := !"x" in "x" <- "g";; "f" #11) in + "f" (λ: "x", "f" (λ: <>, "x")) + "f" (λ: "x", "x" + #9). + +(* The following contextual lifting lemma will be helpful *) +Lemma rtc_contextual_step_fill K e e' h h' : + rtc contextual_step (e, h) (e', h') → + rtc contextual_step (fill K e, h) (fill K e', h'). +Proof. + remember (e, h) as a eqn:Heqa. remember (e', h') as b eqn:Heqb. + induction 1 as [ | ? c ? Hstep ? IH] in e', h', e, h, Heqa, Heqb |-*; subst. + - simplify_eq. done. + - destruct c as (e1, h1). + econstructor 2. + + apply fill_contextual_step. apply Hstep. + + apply IH; done. +Qed. + +(* You may use the [new_fresh] and [init_heap_singleton] lemmas to allocate locations *) + +Lemma obf_expr_eval : + ∃ h', rtc contextual_step (obf_expr, ∅) (of_val #42, h'). +Proof. + eexists. unfold obf_expr. + econstructor 2. + { eapply fill_contextual_step with (K := [AppRCtx _]). + eapply base_contextual_step. + eapply (new_fresh (LamV _ _)). + } + rewrite init_heap_singleton. + simpl. + econstructor 2. + { apply base_contextual_step. econstructor; done. } + simpl. + econstructor 2. + { apply base_contextual_step. econstructor; done. } + simpl. etrans. + { apply rtc_contextual_step_fill with (K := [BinOpRCtx _ _]). + econstructor 2. + { apply base_contextual_step. econstructor; done. } + simpl. econstructor 2. + { apply fill_contextual_step with (K := [AppRCtx _]). + apply base_contextual_step. + econstructor. rewrite lookup_insert. done. + } + simpl. econstructor 2. + { apply base_contextual_step. econstructor; done. } + simpl. econstructor 2. + { apply fill_contextual_step with (K := [AppRCtx _]). + apply base_contextual_step. econstructor; done. + } + rewrite insert_insert. simpl. econstructor 2. + { apply base_contextual_step. econstructor; done. } + simpl. econstructor 2. + { apply base_contextual_step. econstructor; done. } + simpl. econstructor 2. + { apply base_contextual_step. econstructor; done. } + reflexivity. + } + simpl. etrans. + { apply rtc_contextual_step_fill with (K := [BinOpLCtx _ (LitV _)]). + econstructor 2. + { apply base_contextual_step. econstructor; done. } + simpl. econstructor 2. + { apply fill_contextual_step with (K := [AppRCtx _]). + apply base_contextual_step. + econstructor. rewrite lookup_insert. done. + } + simpl. econstructor 2. + { apply base_contextual_step. econstructor; done. } + simpl. econstructor 2. + { apply fill_contextual_step with (K := [AppRCtx _]). + apply base_contextual_step. econstructor; done. + } + rewrite insert_insert. simpl. econstructor 2. + { apply base_contextual_step. econstructor; done. } + simpl. econstructor 2. + { apply base_contextual_step. econstructor; done. } + simpl. econstructor 2. + { apply base_contextual_step. econstructor; done. } + reflexivity. + } + simpl. + econstructor 2. + { apply base_contextual_step. econstructor; simpl; done. } + reflexivity. +Qed. + + +(** Exercise 4 (LN Exercise 48): Fibonacci *) +Definition knot : val := + λ: "f", + let: "x" := new (λ: "x", #0) in + let: "g" := "f" (λ: "y", (! "x") "y") in + "x" <- "g";; "g". + +Definition fibonacci : val := + λ: "n", knot (λ: "rec" "n", + if: "n" = #0 then #0 else + if: "n" = #1 then #1 else + "rec" ("n" - #1) + "rec" ("n" - #2)) "n". +Lemma fibonacci_typed Σ n Γ : + TY Σ; n; Γ ⊢ fibonacci : (Int → Int). +Proof. + repeat solve_typing_fast. +Qed. diff --git a/theories/type_systems/systemf_mu_state/logrel_sol.v b/theories/type_systems/systemf_mu_state/logrel_sol.v new file mode 100644 index 0000000..532cf73 --- /dev/null +++ b/theories/type_systems/systemf_mu_state/logrel_sol.v @@ -0,0 +1,1772 @@ +From stdpp Require Import gmap base relations. +From iris Require Import prelude. +From semantics.lib Require Export facts maps. +From semantics.ts.systemf_mu_state Require Import lang notation parallel_subst execution. +From Equations Require Export Equations. +From Autosubst Require Export Autosubst. + +(** * Logical relation for SystemF + recursive types *) + +(** ** First-order typing for heaps *) +(* We have to explicitly specify the type of first-order types here. + + One alternative approach would be to just require first-orderness in the ref case of the logrel, + but this breaks the boring lemma about moving substitution: (A.[σ]) might be first-order + even if A is not (because it contains a type variable), so we fail to prove the equivalence. + Explicitly defining fotypes in this way prevents type substitution from going below Ref entirely, + which fixes this problem. +*) + +Inductive fotype : Type := + | FOInt + | FOBool + | FOUnit + | FOProd (A B : fotype) + | FOSum (A B : fotype). + +Inductive type : Type := + (** [var] is the type of variables of Autosubst -- it unfolds to [nat] *) + | TVar : var → type + | Int + | Bool + | Unit + (** The [{bind 1 of type}] tells Autosubst to put a De Bruijn binder here *) + | TForall : {bind 1 of type} → type + | TExists : {bind 1 of type} → type + | Fun (A B : type) + | Prod (A B : type) + | Sum (A B : type) + | TMu : {bind 1 of type} → type + | Ref (a : fotype) +. + +Fixpoint of_fotype (a : fotype) : type := + match a with + | FOInt => Int + | FOBool => Bool + | FOUnit => Unit + | FOProd a b => Prod (of_fotype a) (of_fotype b) + | FOSum a b => Sum (of_fotype a) (of_fotype b) + end. +Coercion of_fotype : fotype >-> type. + +(** Autosubst instances. + This lets Autosubst do its magic and derive all the substitution functions, etc. + *) +#[export] Instance Ids_type : Ids type. derive. Defined. +#[export] Instance Rename_type : Rename type. derive. Defined. +#[export] Instance Subst_type : Subst type. derive. Defined. +#[export] Instance SubstLemmas_typer : SubstLemmas type. derive. Qed. + +Definition typing_context := gmap string type. +Implicit Types + (Γ : typing_context) + (v : val) + (e : expr) + (A B : type) + (* we use lower-case letters for first-order types *) + (a : fotype) +. + +Declare Scope FType_scope. +Delimit Scope FType_scope with ty. +Bind Scope FType_scope with type. +Notation "# x" := (TVar x) : FType_scope. +Infix "→" := Fun : FType_scope. +Notation "(→)" := Fun (only parsing) : FType_scope. +Notation "∀: τ" := + (TForall τ%ty) + (at level 100, τ at level 200) : FType_scope. +Notation "∃: τ" := + (TExists τ%ty) + (at level 100, τ at level 200) : FType_scope. +Infix "×" := Prod (at level 70) : FType_scope. +Notation "(×)" := Prod (only parsing) : FType_scope. +Infix "+" := Sum : FType_scope. +Notation "(+)" := Sum (only parsing) : FType_scope. +Notation "μ: A" := + (TMu A%ty) + (at level 100, A at level 200) : FType_scope. + +Notation "⤉ Γ" := (Autosubst_Classes.subst (ren (+1)) <$> Γ) (at level 10, format "⤉ Γ"). + +Implicit Types + (α : var) +. +Inductive type_wf : nat → type → Prop := + | type_wf_TVar m n: + m < n → + type_wf n (TVar m) + | type_wf_Int n: type_wf n Int + | type_wf_Bool n : type_wf n Bool + | type_wf_Unit n : type_wf n Unit + | type_wf_TForall n A : + type_wf (S n) A → + type_wf n (TForall A) + | type_wf_TExists n A : + type_wf (S n) A → + type_wf n (TExists A) + | type_wf_Fun n A B: + type_wf n A → + type_wf n B → + type_wf n (Fun A B) + | type_wf_Prod n A B : + type_wf n A → + type_wf n B → + type_wf n (Prod A B) + | type_wf_Sum n A B : + type_wf n A → + type_wf n B → + type_wf n (Sum A B) + | type_wf_mu n A : + type_wf (S n) A → + type_wf n (μ: A) + | type_wf_ref n a : + type_wf n (Ref a). +#[export] Hint Constructors type_wf : core. + +Inductive bin_op_typed : bin_op → type → type → type → Prop := + | plus_op_typed : bin_op_typed PlusOp Int Int Int + | minus_op_typed : bin_op_typed MinusOp Int Int Int + | mul_op_typed : bin_op_typed MultOp Int Int Int + | lt_op_typed : bin_op_typed LtOp Int Int Bool + | le_op_typed : bin_op_typed LeOp Int Int Bool + | eq_op_typed : bin_op_typed EqOp Int Int Bool. +#[export] Hint Constructors bin_op_typed : core. + +Inductive un_op_typed : un_op → type → type → Prop := + | neg_op_typed : un_op_typed NegOp Bool Bool + | minus_un_op_typed : un_op_typed MinusUnOp Int Int. + +Reserved Notation "'TY' Δ ; Γ ⊢ e : A" (at level 74, e, A at next level). +Inductive syn_typed : nat → typing_context → expr → type → Prop := + | typed_var n Γ x A : + Γ !! x = Some A → + TY n; Γ ⊢ (Var x) : A + | typed_lam n Γ x e A B : + TY n ; (<[ x := A]> Γ) ⊢ e : B → + type_wf n A → + TY n; Γ ⊢ (Lam (BNamed x) e) : (A → B) + | typed_lam_anon n Γ e A B : + TY n ; Γ ⊢ e : B → + type_wf n A → + TY n; Γ ⊢ (Lam BAnon e) : (A → B) + | typed_tlam n Γ e A : + (* we need to shift the context up as we descend under a binder *) + TY S n; (⤉ Γ) ⊢ e : A → + TY n; Γ ⊢ (Λ, e) : (∀: A) + | typed_tapp n Γ A B e : + TY n; Γ ⊢ e : (∀: A) → + type_wf n B → + (* A.[B/] is the notation for Autosubst's substitution operation that + replaces variable 0 by [B] *) + TY n; Γ ⊢ (e <>) : (A.[B/]) + | typed_pack n Γ A B e : + type_wf n B → + type_wf (S n) A → + TY n; Γ ⊢ e : (A.[B/]) → + TY n; Γ ⊢ (pack e) : (∃: A) + | typed_unpack n Γ A B e e' x : + type_wf n B → (* we should not leak the existential! *) + TY n; Γ ⊢ e : (∃: A) → + (* As we descend under a type variable binder for the typing of [e'], + we need to shift the indices in [Γ] and [B] up by one. + On the other hand, [A] is already defined under this binder, so we need not shift it. + *) + TY (S n); (<[x := A]>(⤉Γ)) ⊢ e' : (B.[ren (+1)]) → + TY n; Γ ⊢ (unpack e as BNamed x in e') : B + | typed_int n Γ z : TY n; Γ ⊢ (Lit $ LitInt z) : Int + | typed_bool n Γ b : TY n; Γ ⊢ (Lit $ LitBool b) : Bool + | typed_unit n Γ : TY n; Γ ⊢ (Lit $ LitUnit) : Unit + | typed_if n Γ e0 e1 e2 A : + TY n; Γ ⊢ e0 : Bool → + TY n; Γ ⊢ e1 : A → + TY n; Γ ⊢ e2 : A → + TY n; Γ ⊢ If e0 e1 e2 : A + | typed_app n Γ e1 e2 A B : + TY n; Γ ⊢ e1 : (A → B) → + TY n; Γ ⊢ e2 : A → + TY n; Γ ⊢ (e1 e2)%E : B + | typed_binop n Γ e1 e2 op A B C : + bin_op_typed op A B C → + TY n; Γ ⊢ e1 : A → + TY n; Γ ⊢ e2 : B → + TY n; Γ ⊢ BinOp op e1 e2 : C + | typed_unop n Γ e op A B : + un_op_typed op A B → + TY n; Γ ⊢ e : A → + TY n; Γ ⊢ UnOp op e : B + | typed_pair n Γ e1 e2 A B : + TY n; Γ ⊢ e1 : A → + TY n; Γ ⊢ e2 : B → + TY n; Γ ⊢ (e1, e2) : A × B + | typed_fst n Γ e A B : + TY n; Γ ⊢ e : A × B → + TY n; Γ ⊢ Fst e : A + | typed_snd n Γ e A B : + TY n; Γ ⊢ e : A × B → + TY n; Γ ⊢ Snd e : B + | typed_injl n Γ e A B : + type_wf n B → + TY n; Γ ⊢ e : A → + TY n; Γ ⊢ InjL e : A + B + | typed_injr n Γ e A B : + type_wf n A → + TY n; Γ ⊢ e : B → + TY n; Γ ⊢ InjR e : A + B + | typed_case n Γ e e1 e2 A B C : + TY n; Γ ⊢ e : B + C → + TY n; Γ ⊢ e1 : (B → A) → + TY n; Γ ⊢ e2 : (C → A) → + TY n; Γ ⊢ Case e e1 e2 : A + | typed_roll n Γ e A : + TY n; Γ ⊢ e : (A.[(μ: A)/]) → + TY n; Γ ⊢ (roll e) : (μ: A) + | typed_unroll n Γ e A : + TY n; Γ ⊢ e : (μ: A) → + TY n; Γ ⊢ (unroll e) : (A.[(μ: A)/]) + (** Typing rules for state *) + (* We use lower-case letters, which imposes the requirement to use first-order types. + (The coercion [of_fotype] does a lot of work here.) *) + | typed_load n Γ e a : + TY n; Γ ⊢ e : (Ref a) → + TY n; Γ ⊢ !e : a + | typed_store n Γ e1 e2 a : + TY n; Γ ⊢ e1 : (Ref a) → + TY n; Γ ⊢ e2 : a → + TY n; Γ ⊢ (e1 <- e2) : Unit + | typed_new n Γ e a : + TY n; Γ ⊢ e : a → + TY n; Γ ⊢ (new e) : Ref a +where "'TY' Δ ; Γ ⊢ e : A" := (syn_typed Δ Γ e%E A%ty). +#[export] Hint Constructors syn_typed : core. + +Lemma syn_typed_closed Δ Γ e A X : + TY Δ; Γ ⊢ e : A → + (∀ x, x ∈ dom Γ → x ∈ X) → + is_closed X e. +Proof. + induction 1 as [ | ??????? IH | | n Γ e A H IH | | | n Γ A B e e' x Hwf H1 IH1 H2 IH2 | | | | | | | | | | | | | | | | | | ] in X |-*; simpl; intros Hx; try done. + { (* var *) apply bool_decide_pack, Hx. apply elem_of_dom; eauto. } + { (* lam *) apply IH. + intros y. rewrite elem_of_dom lookup_insert_is_Some. + intros [<- | [? Hy]]; first by apply elem_of_cons; eauto. + apply elem_of_cons. right. eapply Hx. by apply elem_of_dom. + } + { (* anon lam *) naive_solver. } + { (* tlam *) + eapply IH. intros x Hel. apply Hx. + by rewrite dom_fmap in Hel. + } + 3: { (* unpack *) + apply andb_True; split. + - apply IH1. apply Hx. + - apply IH2. intros y. rewrite elem_of_dom lookup_insert_is_Some. + intros [<- | [? Hy]]; first by apply elem_of_cons; eauto. + apply elem_of_cons. right. eapply Hx. + apply elem_of_dom. revert Hy. rewrite lookup_fmap fmap_is_Some. done. + } + (* everything else *) + all: repeat match goal with + | |- Is_true (_ && _) => apply andb_True; split + end. + all: try naive_solver. +Qed. + +Goal TY 0; ∅ ⊢ (λ: "x", #1 + "x") : (Int → Int). +Proof. eauto. Qed. +Goal TY 0; ∅ ⊢ (Λ, λ: "x", "x") : (∀: #0 → #0). +Proof. eauto 8. Qed. +Goal TY 0; ∅ ⊢ (new #42 <- #1337) : Unit. +Proof. eapply (typed_store _ _ _ _ FOInt); eauto. Qed. + +(** ** Worlds *) +(** We represent heap invariants as predicates on heaps, + and worlds as lists of such invariants. + *) +Definition heap_inv := heap → Prop. +Definition world := list heap_inv. +Implicit Types (W : world) (INV : heap_inv). +(** [W'] extends [W] if [W] is a suffix of [W'] *) +Definition wext W W' := suffix W W'. +Notation "W' ⊒ W" := (wext W W') (at level 40). +#[export] Instance wext_preorder : PreOrder wext. +Proof. apply _. Qed. + +(** Satisfaction is defined straightforwardly by recursion. + We use map difference ∖ that computes the difference of two maps + based on the domain. + *) +Fixpoint wsat W σ := + match W with + | INV :: W' => + ∃ σ0, INV σ0 ∧ σ0 ⊆ σ ∧ wsat W' (σ ∖ σ0) + | [] => True + end. + +Lemma wsat_mono σ σ' W : + σ ⊆ σ' → + wsat W σ → wsat W σ'. +Proof. + induction W as [ | INV W' IH] in σ, σ' |-*; first done. + simpl. intros Hincl (σ0 & Hinv & Hincl' & Hsat). + exists σ0; split; first done. split; first by etrans. + eapply IH; last done. + by apply map_difference_mono. +Qed. + +Lemma wsat_wext W W' σ : + W' ⊒ W → + wsat W' σ → + wsat W σ. +Proof. + intros (L & ->). induction L as [ | INV L' IH] in σ |-*; first done. + simpl. intros (σ0 & Hinv & Hincl & ?%IH). eapply wsat_mono; last done. + by apply map_subseteq_difference_l. +Qed. + +Lemma wsat_lookup W σ i P : + wsat W σ → W !! i = Some P → + ∃ σ0, σ0 ⊆ σ ∧ P σ0. +Proof. + induction W as [ | INV W IH] in i, σ |-*; first done. + simpl. intros (σ0 & HINV & Hincl & Hsat). + destruct i as [ | i]; simpl. + - intros [= ->]. eauto. + - intros Hlook. destruct (IH _ _ Hsat Hlook) as (σ1 & ? & ?). + exists σ1; split; last done. etrans; eauto. + by apply map_subseteq_difference_l. +Qed. + +Lemma wext_lookup W' W i INV : + W' ⊒ W → W !! i = Some INV → ∃ i', W' !! i' = Some INV. +Proof. + unfold wext. + intros Hincl Hlook. + destruct Hincl as (W''& ->). + exists (length W'' + i). + rewrite lookup_app_r; last lia. + by rewrite Nat.add_comm Nat.add_sub. +Qed. + +Lemma wsat_merge σ1 σ2 W1 W2 : + σ1 ##ₘ σ2 → + wsat W1 σ1 → + wsat W2 σ2 → + wsat (W1 ++ W2) (σ1 ∪ σ2). +Proof. + intros Hdisj. induction W1 as [ | INV W1 IH] in W2, σ1, σ2, Hdisj |-*. + - simpl. intros _ Hs. eapply wsat_mono; last done. by apply map_union_subseteq_r. + - simpl. intros (σ0 & Hinv & Hincl & Hsat1) Hsat2. + exists σ0. split_and!; [ done | | ]. + + by apply map_union_subseteq_l'. + + rewrite map_difference_union'; last done. + assert ((σ2 ∖ σ0) = σ2) as H. + { symmetry; apply map_disjoint_difference. + symmetry. eapply map_disjoint_weaken_l; done. + } + rewrite H. + apply IH; [ | done..]. + eapply map_disjoint_weaken_l; first done. by apply map_subseteq_difference_l. +Qed. + +(** Assuming that we have found a heap invariant [P] talking about [l] and that is invariant wrt the concrete value, we can update [l]. + *) +Lemma wsat_update W σ i (l : loc) (v : val) (P : heap_inv) : + wsat W σ → W !! i = Some P → + (∀ σ : heap, P σ → is_Some (σ !! l) ∧ P (<[l := v]> σ)) → + wsat W (<[l := v]> σ). +Proof. + induction W as [ | INV W IH] in i, σ |-*; first done. + destruct i as [ | i]. + - intros (σ0 & HINV & Hincl & Hsat). + intros [= ->] Hupd. eexists. split_and!; [eapply Hupd, HINV | | ]. + + by apply insert_mono. + + apply Hupd in HINV as [[v0 Hs] _]. eapply wsat_mono; last apply Hsat. + rewrite (difference_insert _ _ _ _ _ v0). rewrite insert_id; done. + - intros Hsat Hlook Hupd. + destruct Hsat as (σ0 & HINV & Hincl & Hsat). simpl in *. + specialize (wsat_lookup _ _ _ _ Hsat Hlook) as (σ1 & Hincl' & [Hs ?]%Hupd). + specialize (IH _ _ Hsat Hlook Hupd). + assert (σ0 !! l = None) as H0l. + { eapply lookup_weaken_is_Some in Hincl'; last done. + apply lookup_difference_is_Some in Hincl'. apply Hincl'. + } + exists σ0. split_and!; [ done | | ]. + + etrans; first by eapply (insert_subseteq _ l v). + by apply insert_mono. + + assert (<[l:=v]> σ ∖ σ0 = <[l:=v]> (σ ∖ σ0)) as ->; last done. + symmetry. apply insert_difference'. done. +Qed. + +(** ** Definition of the logrel *) + +(** A semantic type consists of a value-predicate parameterized over a step-index and a world, + a proof of closedness, and a proof of downwards-closure wrt step-indices, + and a proof of upwards-closure wrt world extension. + *) +Record sem_type := mk_ST { + sem_type_car :> nat → world → val → Prop; + sem_type_closed_val k W v : sem_type_car k W v → is_closed [] (of_val v); + sem_type_mono : ∀ k k' W v, sem_type_car k W v → k' ≤ k → sem_type_car k' W v; + sem_type_mono_world : ∀ k W W' v, sem_type_car k W v → W' ⊒ W → sem_type_car k W' v + }. + +(** Two tactics we will use later on. + [pose_sem_type P as N] defines a semantic type at name [N] with the value predicate [P]. + *) +(* slightly complicated formulation to make the proof term [p] opaque and prevent it from polluting the context *) +Tactic Notation "pose_sem_type" uconstr(P) "as" ident(N) := + let p := fresh "__p" in + let p2 := fresh "__p2" in + let p3 := fresh "__p3" in + unshelve refine ((λ p p2 p3, let N := (mk_ST P p p2 p3) in _) _ _ _); first (simpl in p, p2, p3); cycle 1. +Tactic Notation "specialize_sem_type" constr(S) "with" uconstr(P) "as" ident(N) := + pose_sem_type P as N; last specialize (S N). + +(** We represent type variable assignments [δ] as functions [f] into semantic types. + The variable [#n] (in De Bruijn representation) is mapped to [f n]. + *) +Definition tyvar_interp := var → sem_type. +Implicit Types + (δ : tyvar_interp) + (τ : sem_type) +. + +(** + In Coq, we need to make argument why the logical relation is well-defined precise: + (for Coq, that means: we need to show that the recursion is terminating). + + To make this formal, we define a well-founded relation that allows to either decrease the step-index, the type, or switch from the expression case to the value case for recursive calls. + We define size measures for for all three of these things, and then combine them into a big lexicographic ordering [term_rel]. + + Adding in state does not provide much of a complication, _as long as we only consider first-order state_. + (higher-order state makes the argument quite a bit more difficult, since worlds then also need to be step-indexed). + *) +Equations type_size (A : type) : nat := + type_size Int := 1; + type_size Bool := 1; + type_size Unit := 1; + type_size (A → B) := type_size A + type_size B + 1; + type_size (#α) := 1; + type_size (∀: A) := type_size A + 2; + type_size (∃: A) := type_size A + 2; + type_size (A × B) := type_size A + type_size B + 1; + type_size (A + B) := max (type_size A) (type_size B) + 1; + type_size (μ: A) := type_size A + 2; + type_size (Ref A) := 2 +. +(* [ltof A R] defines a well-founded measure on type [A] by using a mapping [R] from [A] to [nat] + (it lifts the < relation on natural numbers to [A]) *) +Definition type_lt := ltof type type_size. +#[local] Instance type_lt_wf : WellFounded type_lt. +Proof. apply well_founded_ltof. Qed. + +Inductive type_case : Set := + | expr_case | val_case. +Definition type_case_size (c : type_case) : nat := + match c with | expr_case => 1 | val_case => 0 end. +Definition type_case_lt := ltof type_case type_case_size. +#[local] Instance type_case_lt_wf : WellFounded type_case_lt. +Proof. apply well_founded_ltof. Qed. + +Definition term_rel := Subterm.lexprod nat (type * type_case) lt (Subterm.lexprod type type_case type_lt type_case_lt). +#[local] Instance term_rel_wf : WellFounded term_rel. apply _. Qed. + +(** *** The logical relation *) +(** Since the relation is step-indexed now, and the argument that the case for recursive types is well-formed + fundamentally requires decreasing the step-index, we also need to convince Equations that this definition is well-formed! + We do this by providing a well-founded termination relation [term_rel] that decreases for each recursive call. + *) +Equations type_interp (c : type_case) (t : type) δ (k : nat) (W : world) (v : match c with val_case => val | expr_case => expr end) : Prop + by wf (k, (t, c)) term_rel := { + + type_interp val_case Int δ k W v => + ∃ z : Z, v = #z ; + type_interp val_case Bool δ k W v => + ∃ b : bool, v = #b ; + type_interp val_case Unit δ k W v => + v = #LitUnit ; + type_interp val_case (A × B) δ k W v => + ∃ v1 v2 : val, v = (v1, v2)%V ∧ type_interp val_case A δ k W v1 ∧ type_interp val_case B δ k W v2; + type_interp val_case (A + B) δ k W v => + (∃ v' : val, v = InjLV v' ∧ type_interp val_case A δ k W v') ∨ + (∃ v' : val, v = InjRV v' ∧ type_interp val_case B δ k W v'); + + type_interp val_case (A → B) δ k W v => + ∃ x e, v = LamV x e ∧ is_closed (x :b: nil) e ∧ + (* Slightly weird formulation: for down-closure, we want to quantify over all k' ≤ k -- + but with that formulation, the termination checker will not be able to see that k' will really be smaller! + Thus, we quantify over the difference kd and subtract *) + ∀ v' kd W', W' ⊒ W → + type_interp val_case A δ (k - kd) W' v' → + type_interp expr_case B δ (k - kd) W' (subst' x (of_val v') e); + type_interp val_case (#α) δ k W v => + (δ α).(sem_type_car) k W v; + type_interp val_case (∀: A) δ k W v => + ∃ e, v = TLamV e ∧ is_closed [] e ∧ + ∀ τ, type_interp expr_case A (τ .: δ) k W e; + type_interp val_case (∃: A) δ k W v => + ∃ v', v = PackV v' ∧ + ∃ τ : sem_type, type_interp val_case A (τ .: δ) k W v'; + (** Defined with two cases: ordinarily, we might require [k > 0] in the body as a guard for the recursive call, + but this does not count as a proper guard for termination for Coq -- therefore we handle the 0-case separately. + *) + type_interp val_case (μ: A) δ (S k) W v => + ∃ v', v = (roll v')%V ∧ is_closed [] v' ∧ ∀ kd, type_interp val_case (A.[μ: A/]%ty) δ (k - kd) W v'; + type_interp val_case (μ: A) δ 0 W v => + ∃ v', v = (roll v')%V ∧ is_closed [] v'; + (** The reference case *) + type_interp val_case (Ref a) δ k W v => + ∃ (l : loc), v = LitV $ LitLoc l ∧ ∃ i INV, W !! i = Some INV ∧ + INV = (λ σ', ∃ v, σ' = <[ l := v ]> ∅ ∧ TY 0; ∅ ⊢ (of_val v) : a); + + type_interp expr_case t δ k W e => + ∀ e' h h' W' n, W' ⊒ W → wsat W' h → n < k → red_nsteps n e h e' h' → ∃ v W'', to_val e' = Some v ∧ + W'' ⊒ W' ∧ wsat W'' h' ∧ type_interp val_case t δ (k - n) W'' v +}. + +(** Proving that the arguments are decreasing for recursive calls is a bit more messy now, but it's mostly systematic. + Therefore we provide a simple automation tactic that will also become useful a few times below. +*) +Ltac dsimpl := + repeat match goal with + | |- term_rel (?k, _) (?k, _) => + (* step-index is not decreasing, go right *) + right + | |- term_rel (?k1, _) (?k2, _) => + (* use [lia] to decide where to go *) + destruct (decide (k1 < k2)) as [ ? | ?]; [left; lia | assert (k1 = k2) as -> by lia; right] + | |- Subterm.lexprod type type_case _ _ (?t, _) (?t, _) => + (* type is not decreasing, go right *) + right + | |- Subterm.lexprod type type_case _ _ (_, ?a) (_, ?a) => + (* type case is not decreasing, go left *) + left + | |- term_rel (_, _) (_, _) => + (* branch non-deterministically and try to solve the remaining goal *) + first [left; solve [dsimpl] | right; solve [dsimpl]] + | |- Subterm.lexprod type type_case _ _ _ _ => + (* branch non-deterministically *) + first [left; solve [dsimpl] | right; solve [dsimpl]] + | _ => + (* try to solve a leaf, i.e. a [type_lt], [type_case_lt] or [lt] goal *) + unfold type_case_lt, type_lt, ltof; simp type_size; simpl; try lia + end. +(** The tactic solves all of Equations' obligations for showing that the argument decreases. *) +Solve Obligations with (intros; dsimpl). + +(** *** Value relation and expression relation *) +Definition sem_val_rel A δ k W v := type_interp val_case A δ k W v. +Definition sem_expr_rel A δ k W e := type_interp expr_case A δ k W e. + +Notation 𝒱 := (type_interp val_case). +Notation ℰ := (type_interp expr_case). + +Lemma val_rel_is_closed v δ k W A: + 𝒱 A δ k W v → is_closed [] (of_val v). +Proof. + induction A as [ | | | | | A IHA | | A IH1 B IH2 | A IH1 B IH2 | A IHA | A] in k, v, δ |-*; simp type_interp. + - by eapply sem_type_closed_val. + - intros [z ->]. done. + - intros [b ->]. done. + - intros ->. done. + - intros (e & -> & ? & _). done. + - intros (v' & -> & (τ & Hinterp)). simpl. by eapply IHA. + - intros (x & e & -> & ? & _). done. + - intros (v1 & v2 & -> & ? & ?). simpl; apply andb_True; split; eauto. + - intros [(v' & -> & ?) | (v' & -> & ?)]; simpl; eauto. + - destruct k; simp type_interp. + + intros (v' & -> & ?); done. + + intros (v' & -> & ? & Ha); done. + - intros (l & -> & _). done. +Qed. + +(** Downwards closure wrt step-index *) +Lemma type_interp_mono : ∀ '(k, (A, c)) δ W k' x, k' ≤ k → type_interp c A δ k W x → type_interp c A δ k' W x. +Proof. + eapply (well_founded_ind (R := term_rel) term_rel_wf). + intros (k & A & []) IH δ W k'. + { (* expression rel *) + intros e Hk He. simp type_interp in He. simp type_interp. intros e' h h' W' n Hincl Hsat Hn Hred. + destruct (He e' h h' W' n ltac:(done) ltac:(done) ltac:(lia) Hred) as (v & W'' & Hval & Hincl' & Hsat' & Hv). + exists v, W''. split; first done. + split_and!; [done.. | ]. + eapply (IH (k-n, (A, val_case))); [ | lia | done]. + (* show that the induction is decreasing *) + dsimpl. + } + intros v Hk Hv. + destruct A as [x | | | | A | A | A B | A B | A B | A | A ]; simp type_interp; simp type_interp in Hv. + - (* var case *) + by eapply sem_type_mono. + - (* universal case *) + destruct Hv as (e & -> & ? & Hv). + exists e. split_and!; [done.. | ]. intros τ. + eapply (IH (k, (A, expr_case))); [ dsimpl | done | done]. + - (* existential case *) + destruct Hv as (v' & -> & (τ & Hv)). exists v'. split; first done. + exists τ. eapply (IH (k, (A, _))); [ dsimpl | done..]. + - (* fun case *) + destruct Hv as (x & e & -> & ? & Hv). exists x, e. split_and!; [done..| ]. + intros v' kd W' Hv' Hincl. + (* slightly tricky due to the contravariant recursive occurrence *) + set (kd' := k - k'). + specialize (Hv v' (kd + kd')). + replace (k - (kd + kd')) with (k' - kd) in Hv by lia. + eapply (IH (k' - kd, (B, expr_case))); [ | lia | by eapply Hv]. + destruct (decide (k' - kd < k)) as [ ? | ?]; first (left; lia). + assert (k' - kd = k) as -> by lia. dsimpl. + - (* pair case *) + destruct Hv as (v1 & v2 & -> & Hv1 & Hv2). + exists v1, v2. split_and!; first done. + all: eapply (IH (k, (_, _))); [ dsimpl | done..]. + - (* sum case *) + destruct Hv as [(v' & -> & Hv) | (v' & -> & Hv)]; [ left | right]. + all: exists v'; split; first done. + all: eapply (IH (k, (_, _))); [ dsimpl | done..]. + - (* rec case *) + destruct k; simp type_interp in Hv. + { assert (k' = 0) as -> by lia. simp type_interp. } + destruct Hv as (v' & -> & ? & Hv). + destruct k' as [ | k']; simp type_interp. + { eauto. } + exists v'. split_and!; [ done.. | ]. + intros kd. + (* here we crucially use that we can decrease the index *) + eapply (IH (k - kd, (A.[(μ: A)%ty/], val_case))); [ | lia | done]. + left. lia. +Qed. + +(** We can now derive the two desired lemmas *) +Lemma val_rel_mono_idx A δ k k' W v : k' ≤ k → 𝒱 A δ k W v → 𝒱 A δ k' W v. +Proof. apply (type_interp_mono (k, (A, val_case))). Qed. +Lemma expr_rel_mono_idx A δ k k' W e : k' ≤ k → ℰ A δ k W e → ℰ A δ k' W e. +Proof. apply (type_interp_mono (k, (A, expr_case))). Qed. + +(** Up-closure wrt worlds *) +Lemma type_interp_mono_world : ∀ '(k, (A, c)) δ W W' x, W' ⊒ W → type_interp c A δ k W x → type_interp c A δ k W' x. +Proof. + eapply (well_founded_ind (R := term_rel) term_rel_wf). + intros (k & A & []) IH δ W W'. + { (* expression rel *) + intros e HW He. simp type_interp in He. simp type_interp. intros e' h h' W'' n Hincl Hsat Hn Hred. + destruct (He e' h h' W'' n ltac:(etrans; done) ltac:(done) ltac:(lia) Hred) as (v & W''' & Hval & Hincl' & Hsat' & Hv). + exists v, W'''. split; first done. + split_and!; [done.. | ]. + eapply (IH (k-n, (A, val_case))); [ | | apply Hv]. + - dsimpl. + - done. + } + intros v HW Hv. + destruct A as [x | | | | A | A | A B | A B | A B | A | A ]; simp type_interp; simp type_interp in Hv. + - (* var case *) + by eapply sem_type_mono_world. + - (* universal case *) + destruct Hv as (e & -> & ? & Hv). + exists e. split_and!; [done.. | ]. intros τ. + eapply (IH (k, (A, expr_case))); [ dsimpl | done | done]. + - (* existential case *) + destruct Hv as (v' & -> & (τ & Hv)). exists v'. split; first done. + exists τ. eapply (IH (k, (A, _))); [ dsimpl | done..]. + - (* fun case *) + destruct Hv as (x & e & -> & ? & Hv). exists x, e. split_and!; [done..| ]. + intros v' kd W'' Hincl Hv'. + specialize (Hv v' kd W''). + eapply (IH (k - kd, (B, expr_case))); [ dsimpl | | eapply Hv]. + + done. + + etrans; done. + + eapply (IH (k -kd, (A, val_case))); last done; last done. dsimpl. + - (* pair case *) + destruct Hv as (v1 & v2 & -> & Hv1 & Hv2). + exists v1, v2. split_and!; first done. + all: eapply (IH (k, (_, _))); [ dsimpl | done..]. + - (* sum case *) + destruct Hv as [(v' & -> & Hv) | (v' & -> & Hv)]; [ left | right]. + all: exists v'; split; first done. + all: eapply (IH (k, (_, _))); [ dsimpl | done..]. + - (* rec case *) + destruct k; simp type_interp in Hv. + { simp type_interp. } + destruct Hv as (v' & -> & ? & Hv). + simp type_interp. + exists v'. split_and!; [ done.. | ]. + intros kd. + (* here we crucially use that we can decrease the index *) + eapply (IH (k - kd, (A.[(μ: A)%ty/], val_case))); [ | done | done]. + left. lia. + - (* loc case *) + destruct Hv as (l & -> & (i & INV & Hlook & Heq)). + exists l. split; first done. + destruct (wext_lookup _ _ _ _ HW Hlook) as (i' & Hlook'). + exists i', INV. done. +Qed. + +Lemma val_rel_mono_world A δ k W W' v : W' ⊒ W → 𝒱 A δ k W v → 𝒱 A δ k W' v. +Proof. apply (type_interp_mono_world (k, (A, val_case))). Qed. +Lemma expr_rel_mono_world A δ k W W' e : W' ⊒ W → ℰ A δ k W e → ℰ A δ k W' e. +Proof. apply (type_interp_mono_world (k, (A, expr_case))). Qed. + +Lemma val_rel_mono A δ k k' W W' v : k' ≤ k → W' ⊒ W → 𝒱 A δ k W v → 𝒱 A δ k' W' v. +Proof. + intros. eapply val_rel_mono_idx; last eapply val_rel_mono_world; done. +Qed. +Lemma expr_rel_mono A δ k k' W W' e : k' ≤ k → W' ⊒ W → ℰ A δ k W e → ℰ A δ k' W' e. +Proof. + intros. eapply expr_rel_mono_idx; last eapply expr_rel_mono_world; done. +Qed. + +(** This is the Value Inclusion lemma from the lecture notes *) +Lemma sem_val_expr_rel A δ k W v : + 𝒱 A δ k W v → ℰ A δ k W (of_val v). +Proof. + simp type_interp. intros Hv e' h h' W' n Hincl HW Hn (-> & -> & ->)%nsteps_val_inv. + rewrite to_of_val. eexists _, W'; split; first done. + replace (k - 0) with k by lia. + split_and!; [done | done | ]. + by eapply val_rel_mono_world. +Qed. + +Lemma sem_expr_rel_zero_trivial A δ W e : + ℰ A δ 0 W e. +Proof. + simp type_interp. intros ???. lia. +Qed. + +(** Interpret a syntactic type *) +Program Definition interp_type A δ : sem_type := {| + sem_type_car := 𝒱 A δ; +|}. +Next Obligation. by eapply val_rel_is_closed. Qed. +Next Obligation. by eapply val_rel_mono. Qed. +Next Obligation. by eapply val_rel_mono_world. Qed. + +(** Semantic typing of contexts *) +Implicit Types + (θ : gmap string expr). + +(** Context relation *) +Inductive sem_context_rel (δ : tyvar_interp) (k : nat) (W : world) : typing_context → (gmap string expr) → Prop := + | sem_context_rel_empty : sem_context_rel δ k W ∅ ∅ + | sem_context_rel_insert Γ θ v x A : + 𝒱 A δ k W v → + sem_context_rel δ k W Γ θ → + sem_context_rel δ k W (<[x := A]> Γ) (<[x := of_val v]> θ). + +Notation 𝒢 := sem_context_rel. + +Lemma sem_context_rel_vals {δ k W Γ θ x A} : + sem_context_rel δ k W Γ θ → + Γ !! x = Some A → + ∃ e v, θ !! x = Some e ∧ to_val e = Some v ∧ 𝒱 A δ k W v. +Proof. + induction 1 as [|Γ θ v y B Hvals Hctx IH]. + - naive_solver. + - rewrite lookup_insert_Some. intros [[-> ->]|[Hne Hlook]]. + + do 2 eexists. split; first by rewrite lookup_insert. + split; first by eapply to_of_val. done. + + eapply IH in Hlook as (e & w & Hlook & He & Hval). + do 2 eexists; split; first by rewrite lookup_insert_ne. + split; first done. done. +Qed. + +Lemma sem_context_rel_subset δ k W Γ θ : + 𝒢 δ k W Γ θ → dom Γ ⊆ dom θ. +Proof. + intros Hctx. apply elem_of_subseteq. intros x (A & Hlook)%elem_of_dom. + eapply sem_context_rel_vals in Hlook as (e & v & Hlook & Heq & Hval); last done. + eapply elem_of_dom; eauto. +Qed. + +Lemma sem_context_rel_dom_eq δ k W Γ θ : + 𝒢 δ k W Γ θ → dom Γ = dom θ. +Proof. + induction 1 as [ | ??????? IH]. + - rewrite !dom_empty //. + - rewrite !dom_insert IH //. +Qed. + +Lemma sem_context_rel_closed δ k W Γ θ: + 𝒢 δ k W Γ θ → subst_is_closed [] θ. +Proof. + induction 1 as [ | Γ θ v x A Hv Hctx IH]; rewrite /subst_is_closed. + - naive_solver. + - intros y e. rewrite lookup_insert_Some. + intros [[-> <-]|[Hne Hlook]]. + + by eapply val_rel_is_closed. + + eapply IH; last done. +Qed. + +Lemma sem_context_rel_mono_idx Γ δ k k' W θ : + k' ≤ k → 𝒢 δ k W Γ θ → 𝒢 δ k' W Γ θ. +Proof. + intros Hk. induction 1 as [|Γ θ v y B Hvals Hctx IH]; constructor. + - eapply val_rel_mono_idx; done. + - apply IH. +Qed. +Lemma sem_context_rel_mono_world Γ δ k W W' θ : + W' ⊒ W → 𝒢 δ k W Γ θ → 𝒢 δ k W' Γ θ. +Proof. + intros HW. induction 1 as [|Γ θ v y B Hvals Hctx IH]; constructor. + - eapply val_rel_mono_world; done. + - apply IH. +Qed. +Lemma sem_context_rel_mono Γ δ k k' W W' θ : + k' ≤ k → W' ⊒ W → 𝒢 δ k W Γ θ → 𝒢 δ k' W' Γ θ. +Proof. + intros. eapply sem_context_rel_mono_idx; last eapply sem_context_rel_mono_world; done. +Qed. + +(** *** Semantic typing judgment *) +Definition sem_typed (Δ : nat) Γ e A := + ∀ θ δ k W, 𝒢 δ k W Γ θ → ℰ A δ k W (subst_map θ e). +Notation "'TY' Δ ; Γ ⊨ e : A" := (sem_typed Δ Γ e A) (at level 74, e, A at next level). + +Section boring_lemmas. + (** The lemmas in this section are all quite boring and expected statements, + but are quite technical to prove due to De Bruijn binders. + We encourage to skip over the proofs of these lemmas. + *) + + Lemma type_interp_ext : + ∀ '(k, (B, c)), ∀ δ δ' W x, + (∀ n k v W', W' ⊒ W → δ n k W' v ↔ δ' n k W' v) → + type_interp c B δ k W x ↔ type_interp c B δ' k W x. + Proof. + eapply (well_founded_ind (R := term_rel) term_rel_wf). + intros (k & A & []) IH δ δ'. + { (* expression rel *) + intros W e Hd. simp type_interp. eapply forall_proper; intros e'. + eapply forall_proper; intros h. eapply forall_proper; intros h'. + eapply forall_proper; intros W'. eapply forall_proper; intros n. + eapply if_iff'; intros. eapply if_iff'; intros _. eapply if_iff'; intros _. + eapply if_iff; first done. f_equiv. intros v. f_equiv. intros W''. + f_equiv. apply and_iff'; intros. f_equiv. + eapply (IH ((k - n), (A, val_case))); first dsimpl. + intros; apply Hd. etrans; last etrans; done. + } + intros W v Hd. destruct A as [x | | | | A | A | A B | A B | A B | A | A ]; simp type_interp; eauto. + - apply Hd. done. + - f_equiv; intros e. f_equiv. f_equiv. + eapply forall_proper; intros τ. + eapply (IH (_, (_, _))); first dsimpl. + intros [|m] ?; simpl; eauto. + - f_equiv; intros w. f_equiv. f_equiv. intros τ. + eapply (IH (_, (_, _))); first dsimpl. + intros [|m] ?; simpl; eauto. + - f_equiv. intros ?. f_equiv. intros ?. + f_equiv. f_equiv. eapply forall_proper. intros ?. + eapply forall_proper. intros ?. + eapply forall_proper. intros W'. + eapply if_iff'; intros. + eapply if_iff; (eapply (IH (_, (_, _))); first dsimpl). + all: intros; eapply Hd; etrans; done. + - f_equiv. intros ?. f_equiv. intros ?. + f_equiv. f_equiv; by eapply (IH (_, (_, _))); first dsimpl. + - f_equiv; f_equiv; intros ?; f_equiv; by eapply (IH (_, (_, _))); first dsimpl. + - destruct k; simp type_interp. + + done. + + f_equiv; intros ?. f_equiv. f_equiv. + eapply forall_proper; intros ?. + by eapply (IH (_, (_, _))); first dsimpl. + Qed. + + Lemma type_interp_move_ren : + ∀ '(k, (B, c)), ∀ δ W σ x, type_interp c B (λ n, δ (σ n)) k W x ↔ type_interp c (rename σ B) δ k W x. + Proof. + eapply (well_founded_ind (R := term_rel) term_rel_wf). + intros (k & A & []) IH δ W σ. + { (* expression rel *) + intros e. simp type_interp. eapply forall_proper; intros e'. + eapply forall_proper; intros h. eapply forall_proper; intros h'. + eapply forall_proper; intros W'. eapply forall_proper; intros n. + + eapply if_iff; first done. eapply if_iff; first done. + eapply if_iff; first done. eapply if_iff; first done. + f_equiv. intros v. f_equiv. intros W''. f_equiv. f_equiv. f_equiv. + eapply (IH (_, (_, _))). + (* show that the induction is decreasing *) + dsimpl. + } + intros v. destruct A as [x | | | | A | A | A B | A B | A B | A | A ]; simpl; simp type_interp; eauto. + - f_equiv; intros e. f_equiv. f_equiv. + eapply forall_proper; intros τ. + etransitivity; last eapply (IH (_, (_, _))); last dsimpl. + eapply (type_interp_ext (_, (_, _))). + intros [|m] ?; simpl; eauto. + - f_equiv; intros w. f_equiv. f_equiv. intros τ. + etransitivity; last eapply (IH (_, (_, _))); last dsimpl. + eapply (type_interp_ext (_, (_, _))). + intros [|m] ?; simpl; eauto. + - f_equiv. intros ?. f_equiv. intros ?. + f_equiv. f_equiv. eapply forall_proper. intros ?. + eapply forall_proper. intros ?. eapply forall_proper. intros ?. + eapply if_iff; first done. eapply if_iff; by eapply (IH (_, (_, _))); first dsimpl. + - f_equiv. intros ?. f_equiv. intros ?. + f_equiv. f_equiv; by eapply (IH (_, (_, _))); first dsimpl. + - f_equiv; f_equiv; intros ?; f_equiv; by eapply (IH (_, (_, _))); first dsimpl. + - destruct k; simp type_interp. + + done. + + f_equiv; intros ?. f_equiv. f_equiv. + eapply forall_proper; intros ?. + etransitivity; first eapply (IH (_, (_, _))); first dsimpl. + asimpl. done. + Qed. + + Lemma type_interp_move_subst : + ∀ '(k, (B, c)), ∀ δ W σ x, type_interp c B (λ n, interp_type (σ n) δ) k W x ↔ type_interp c (B.[σ]) δ k W x. + Proof. + eapply (well_founded_ind (R := term_rel) term_rel_wf). + intros (k & A & []) IH δ W σ. + { (* expression rel *) + intros e. simp type_interp. eapply forall_proper; intros e'. + eapply forall_proper; intros h. eapply forall_proper; intros h'. + eapply forall_proper; intros W'. eapply forall_proper; intros n. + + eapply if_iff; first done. eapply if_iff; first done. + eapply if_iff; first done. eapply if_iff; first done. + f_equiv. intros v. f_equiv. intros W''. f_equiv. f_equiv. f_equiv. + eapply (IH (_, (_, _))). + (* show that the induction is decreasing *) + dsimpl. + } + intros v. destruct A as [x | | | | A | A | A B | A B | A B | A | A]; simpl; simp type_interp; eauto. + - f_equiv; intros e. f_equiv. f_equiv. + eapply forall_proper; intros τ. + etransitivity; last eapply (IH (_, (_, _))); last dsimpl. + eapply (type_interp_ext (_, (_, _))). + intros [|m] ??? ?; simpl. + + asimpl. simp type_interp. done. + + unfold up; simpl. etransitivity; + last eapply (type_interp_move_ren (_, (_, _))). + done. + - f_equiv; intros w. f_equiv. f_equiv. intros τ. + etransitivity; last eapply (IH (_, (_, _))); last dsimpl. + eapply (type_interp_ext (_, (_, _))). + intros [|m] ? ???; simpl. + + asimpl. simp type_interp. done. + + unfold up; simpl. etransitivity; + last eapply (type_interp_move_ren (_, (_, _))). + done. + - f_equiv. intros ?. f_equiv. intros ?. + f_equiv. f_equiv. eapply forall_proper. intros ?. + eapply forall_proper. intros ?. eapply forall_proper. intros W'. + eapply if_iff; first done. + eapply if_iff; by eapply (IH (_, (_, _))); first dsimpl. + - f_equiv. intros ?. f_equiv. intros ?. + f_equiv. f_equiv; by eapply (IH (_, (_, _))); first dsimpl. + - f_equiv; f_equiv; intros ?; f_equiv; by eapply (IH (_, (_, _))); first dsimpl. + - destruct k; simp type_interp. + + done. + + f_equiv; intros ?. f_equiv. f_equiv. + eapply forall_proper; intros ?. + etransitivity; first eapply (IH (_, (_, _))); first dsimpl. + asimpl. done. + Qed. + + + Lemma sem_val_rel_move_single_subst A B δ k v W : + 𝒱 B (interp_type A δ .: δ) k W v ↔ 𝒱 (B.[A/]) δ k W v. + Proof. + etransitivity; last eapply (type_interp_move_subst (_, (_, _))). + eapply (type_interp_ext (_, (_, _))). + intros [| n] ? w W' ?; simpl; simp type_interp; done. + Qed. + + Lemma sem_expr_rel_move_single_subst A B δ k W e : + ℰ B (interp_type A δ .: δ) k W e ↔ ℰ (B.[A/]) δ k W e. + Proof. + etransitivity; last eapply (type_interp_move_subst (_, (_, _))). + eapply (type_interp_ext (_, (_, _))). + intros [| n] ? w W' ?; simpl; simp type_interp; done. + Qed. + + Lemma sem_val_rel_cons A δ k v W τ : + 𝒱 A δ k W v ↔ 𝒱 A.[ren (+1)] (τ .: δ) k W v. + Proof. + etransitivity; last eapply (type_interp_move_subst (_, (_, _))). + eapply (type_interp_ext (_, (_, _))). + intros [| n] ? w W' ?; simpl; simp type_interp; done. + Qed. + + Lemma sem_expr_rel_cons A δ k e W τ : + ℰ A δ k W e ↔ ℰ A.[ren (+1)] (τ .: δ) k W e. + Proof. + etransitivity; last eapply (type_interp_move_subst (_, (_, _))). + eapply (type_interp_ext (_, (_, _))). + intros [| n] ? w W' ?; simpl; simp type_interp; done. + Qed. + + Lemma sem_context_rel_cons Γ k δ θ τ W : + 𝒢 δ k W Γ θ → + 𝒢 (τ .: δ) k W (⤉ Γ) θ. + Proof. + induction 1 as [ | Γ θ v x A Hv Hctx IH]; simpl. + - rewrite fmap_empty. constructor. + - rewrite fmap_insert. constructor; last done. + rewrite -sem_val_rel_cons. done. + Qed. +End boring_lemmas. + +(** Bind lemma *) +Lemma bind K e k W δ A B : + ℰ A δ k W e → + (∀ j v W', j ≤ k → W' ⊒ W → 𝒱 A δ j W' v → ℰ B δ j W' (fill K (of_val v))) → + ℰ B δ k W (fill K e). +Proof. + intros H1 H2. simp type_interp in H1. simp type_interp. + intros e' h h' W' n HW Hsat Hn (j & e'' & h'' & Hj & Hred1 & Hred2)%red_nsteps_fill. + specialize (H1 e'' h h'' W' j ltac:(done) ltac:(done) ltac:(lia) Hred1) as (v & W'' & Hev & Hincl' & Hsat' & Hv). + specialize (H2 (k-j) v W'' ltac:(lia) ltac:(etrans; done) Hv). + simp type_interp in H2. + rewrite (of_to_val _ _ Hev) in H2. + eapply H2 in Hred2; cycle 1; [ reflexivity | done | lia | ]. + assert (k - n = k - j - (n - j)) as -> by lia. + destruct Hred2 as (v' & W''' & ? & ? & ? & Hred2). + exists v', W'''. split_and!; [done | | done | done]. + etrans; done. +Qed. + +(** This is the closure-under-expansion lemma from the lecture notes *) +Lemma expr_det_step_closure e e' A δ k W : + det_step e e' → + ℰ A δ (k - 1) W e' → + ℰ A δ k W e. +Proof. + simp type_interp. intros Hdet Hexpr e'' h h' W' n Hincl Hsat Hn [? Hred]%(det_step_red _ e'); last done. + destruct (Hexpr e'' h h' W' (n -1) Hincl Hsat ) as (v & W'' & Hev & Hincl' & Hsat' & Hv); [lia | done | ]. + exists v, W''. split; first done. split; first done. + replace (k - n) with (k - 1 - (n - 1)) by lia. done. +Qed. + +Lemma expr_det_steps_closure e e' A δ k W n : + nsteps det_step n e e' → ℰ A δ (k - n) W e' → ℰ A δ k W e. +Proof. + induction 1 as [ | n e1 e2 e3 Hstep Hsteps IH] in k |-* . + - replace (k - 0) with k by lia. done. + - intros He. + eapply expr_det_step_closure; first done. + apply IH. replace (k - 1 - n) with (k - (S n)) by lia. done. +Qed. + +(** ** Compatibility lemmas *) + +Lemma compat_int Δ Γ z : TY Δ; Γ ⊨ (Lit $ LitInt z) : Int. +Proof. + intros θ δ k W _. + eapply (sem_val_expr_rel _ _ _ _ #z). + simp type_interp. eauto. +Qed. + +Lemma compat_bool Δ Γ b : TY Δ; Γ ⊨ (Lit $ LitBool b) : Bool. +Proof. + intros θ δ k W _. + eapply (sem_val_expr_rel _ _ _ _ #b). simp type_interp. eauto. +Qed. + +Lemma compat_unit Δ Γ : TY Δ; Γ ⊨ (Lit $ LitUnit) : Unit. +Proof. + intros θ δ k W _. + eapply (sem_val_expr_rel _ _ _ _ #LitUnit). + simp type_interp. eauto. +Qed. + +Lemma compat_var Δ Γ x A : + Γ !! x = Some A → + TY Δ; Γ ⊨ (Var x) : A. +Proof. + intros Hx θ δ k W Hctx; simpl. + specialize (sem_context_rel_vals Hctx Hx) as (e & v & He & Heq & Hv). + rewrite He. simp type_interp. + rewrite -(of_to_val _ _ Heq). + intros e' h h' W' n Hincl Hsat Hn (-> & -> & ->)%nsteps_val_inv. + rewrite to_of_val. eexists _, _. + split_and!; [done.. | ]. + replace (k -0) with k by lia. + eapply val_rel_mono_world; done. +Qed. + +Lemma compat_app Δ Γ e1 e2 A B : + TY Δ; Γ ⊨ e1 : (A → B) → + TY Δ; Γ ⊨ e2 : A → + TY Δ; Γ ⊨ (e1 e2) : B. +Proof. + intros Hfun Harg θ δ k W Hctx; simpl. + specialize (Hfun _ _ _ _ Hctx). + specialize (Harg _ _ _ _ Hctx). + + eapply (bind [AppRCtx _]); first done. + intros j v W' Hj HW Hv. simpl. + + eapply (bind [AppLCtx _ ]). + { eapply expr_rel_mono; cycle -1; [done | lia | done]. } + intros j' f W'' Hj' HW' Hf. + + simp type_interp in Hf. destruct Hf as (x & e & -> & Hcl & Hf). + specialize (Hf v 0). + replace (j' - 0) with j' in Hf by lia. + eapply expr_det_step_closure. + { eapply det_step_beta. apply is_val_of_val. } + eapply expr_rel_mono_idx; last apply Hf; [lia | reflexivity | ]. + eapply val_rel_mono; last done; [lia | done]. +Qed. + +Lemma is_closed_subst_map_delete X Γ (x: string) θ A e: + closed X e → + subst_is_closed [] θ → + dom Γ ⊆ dom θ → + (∀ y : string, y ∈ X → y ∈ dom (<[x:=A]> Γ)) → + is_closed (x :b: []) (subst_map (delete x θ) e). +Proof. + intros He Hθ Hdom1 Hdom2. + eapply closed_subst_weaken; [ | | apply He]. + - eapply subst_is_closed_subseteq; last done. + apply map_delete_subseteq. + - intros y Hy%Hdom2 Hn. apply elem_of_list_singleton. + apply not_elem_of_dom in Hn. apply elem_of_dom in Hy. + destruct (decide (x = y)) as [<- | Hneq]; first done. + rewrite lookup_delete_ne in Hn; last done. + rewrite lookup_insert_ne in Hy; last done. + move: Hdom1. rewrite elem_of_subseteq. + move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom. + naive_solver. +Qed. + +(** Lambdas need to be closed by the context *) +Lemma compat_lam_named Δ Γ x e A B X : + closed X e → + (∀ y, y ∈ X → y ∈ dom (<[x := A]> Γ)) → + TY Δ; (<[ x := A ]> Γ) ⊨ e : B → + TY Δ; Γ ⊨ (Lam (BNamed x) e) : (A → B). +Proof. + intros Hcl Hsub Hbody θ δ k W Hctxt. simpl. + eapply (sem_val_expr_rel _ _ _ _ (LamV x _)). + simp type_interp. + eexists (BNamed x), _. split_and!; [done| | ]. + { eapply is_closed_subst_map_delete; eauto. + + eapply sem_context_rel_closed in Hctxt. naive_solver. + + eapply sem_context_rel_subset in Hctxt; naive_solver. + } + + intros v' kd W' Hv' Hincl. + specialize (Hbody (<[ x := of_val v']> θ) δ (k - kd) W'). + simpl. rewrite subst_subst_map. + 2: { by eapply sem_context_rel_closed. } + apply Hbody. + apply sem_context_rel_insert; first done. + eapply sem_context_rel_mono; [| done| done]. lia. +Qed. + +Lemma is_closed_subst_map_anon X Γ θ e: + closed X e → + subst_is_closed [] θ → + dom Γ ⊆ dom θ → + (∀ y, y ∈ X → y ∈ dom Γ) → + is_closed [] (subst_map θ e). +Proof. + intros He Hθ Hdom1 Hdom2. + eapply closed_subst_weaken; [ | | apply He]. + - eapply subst_is_closed_subseteq; done. + - intros y Hy%Hdom2 Hn. + apply not_elem_of_dom in Hn. apply elem_of_dom in Hy. + move: Hdom1. rewrite elem_of_subseteq. + move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom. + naive_solver. +Qed. + +Lemma compat_lam_anon Δ Γ e A B X : + closed X e → + (∀ y, y ∈ X → y ∈ dom Γ) → + TY Δ; Γ ⊨ e : B → + TY Δ; Γ ⊨ (Lam BAnon e) : (A → B). +Proof. + intros Hcl Hsub Hbody θ δ k W Hctxt. simpl. + eapply (sem_val_expr_rel _ _ _ _ (LamV BAnon _)). + simp type_interp. + eexists BAnon, _. split_and!; [done| | ]. + { eapply is_closed_subst_map_anon; eauto. + + eapply sem_context_rel_closed in Hctxt. naive_solver. + + eapply sem_context_rel_subset in Hctxt; naive_solver. + } + + intros v' kd W' Hv' Hincl. + apply (Hbody θ δ (k - kd) W'). + eapply sem_context_rel_mono; [ | done..]. lia. +Qed. + +Lemma compat_int_binop Δ Γ op e1 e2 : + bin_op_typed op Int Int Int → + TY Δ; Γ ⊨ e1 : Int → + TY Δ; Γ ⊨ e2 : Int → + TY Δ; Γ ⊨ (BinOp op e1 e2) : Int. +Proof. + intros Hop He1 He2 θ δ k W Hctx. simpl. + specialize (He1 _ _ _ _ Hctx). + specialize (He2 _ _ _ _ Hctx). + + eapply (bind [BinOpRCtx _ _]); first done. + intros j v2 W' Hj HW Hv2. simpl. + + eapply (bind [BinOpLCtx _ _ ]). + { eapply expr_rel_mono; last done; [lia | done]. } + intros j' v1 W'' Hj' HW' Hv1. + + simp type_interp. intros e' h h' W''' n Hincl' Hsat' Hn Hred. + simp type_interp in Hv1. simp type_interp in Hv2. + destruct Hv1 as (z1 & ->). destruct Hv2 as (z2 & ->). + + inversion Hop; subst; simpl. + all: eapply det_step_red in Hred as [ ? Hred]; [ | eapply det_step_binop; done]. + all: apply nsteps_val_inv in Hred as (? & -> & ->). + all: eexists _, W'''; simpl; split_and!; [done.. | ]. + all: simp type_interp; eauto. +Qed. + +Lemma compat_int_bool_binop Δ Γ op e1 e2 : + bin_op_typed op Int Int Bool → + TY Δ; Γ ⊨ e1 : Int → + TY Δ; Γ ⊨ e2 : Int → + TY Δ; Γ ⊨ (BinOp op e1 e2) : Bool. +Proof. + intros Hop He1 He2 θ δ k W Hctx. simpl. + specialize (He1 _ _ _ _ Hctx). + specialize (He2 _ _ _ _ Hctx). + + eapply (bind [BinOpRCtx _ _]); first done. + intros j v2 W' Hj HW Hv2. simpl. + + eapply (bind [BinOpLCtx _ _ ]). + { eapply expr_rel_mono; last done; [lia | done]. } + intros j' v1 W'' Hj' HW' Hv1. + + simp type_interp. intros e' h h' W''' n Hincl' Hsat' Hn Hred. + simp type_interp in Hv1. simp type_interp in Hv2. + destruct Hv1 as (z1 & ->). destruct Hv2 as (z2 & ->). + + inversion Hop; subst; simpl. + all: eapply det_step_red in Hred as [ ? Hred]; [ | eapply det_step_binop; done]. + all: apply nsteps_val_inv in Hred as (? & -> & ->). + all: eexists _, _; simpl; split_and!; [done.. | ]. + all: simp type_interp; eauto. +Qed. + +Lemma compat_unop Δ Γ op A B e : + un_op_typed op A B → + TY Δ; Γ ⊨ e : A → + TY Δ; Γ ⊨ (UnOp op e) : B. +Proof. + intros Hop He θ δ k W Hctx. simpl. + specialize (He _ _ _ _ Hctx). + + eapply (bind [UnOpCtx _]); first done. + intros j v W' Hj HW' Hv. simpl. + + simp type_interp. intros e' h h' W'' n HWincl' Hsat' Hn Hred. + inversion Hop; subst. + all: simp type_interp in Hv; destruct Hv as (? & ->). + all: eapply det_step_red in Hred as [ ? Hred]; [ | eapply det_step_unop; done]. + all: apply nsteps_val_inv in Hred as (? & -> & ->). + all: eexists _, _; simpl; split_and!; [done.. | ]. + all: simp type_interp; eauto. +Qed. + +Lemma compat_tlam Δ Γ e A X : + closed X e → + (∀ y, y ∈ X → y ∈ dom Γ) → + TY S Δ; (⤉ Γ) ⊨ e : A → + TY Δ; Γ ⊨ (Λ, e) : (∀: A). +Proof. + intros Hcl Hsub He θ δ k W Hctx. simpl. + simp type_interp. + intros e' h h' W' n HW Hsat' Hn Hred. eapply nsteps_val_inv' in Hred as ( -> & -> & ->); last done. + eexists _, _; split_and!; [done..| ]. + simp type_interp. + eexists _. split_and!; [ done | | ]. + { eapply is_closed_subst_map_anon; eauto. + + eapply sem_context_rel_closed in Hctx; naive_solver. + + eapply sem_context_rel_subset in Hctx; naive_solver. + } + intros τ. eapply He. + replace (k -0) with k by lia. eapply sem_context_rel_cons. + eapply sem_context_rel_mono_world; done. +Qed. + +Lemma compat_tapp Δ Γ e A B : + type_wf Δ B → + TY Δ; Γ ⊨ e : (∀: A) → + TY Δ; Γ ⊨ (e <>) : (A.[B/]). +Proof. + intros Hwf He θ δ k W Hctx. simpl. + + specialize (He _ _ _ _ Hctx). + eapply (bind [TAppCtx]); first done. + intros j v W' Hj HW Hv. + simp type_interp in Hv. + destruct Hv as (e' & -> & ? & He'). + + set (τ := interp_type B δ). + specialize (He' τ). simpl. + eapply expr_det_step_closure. + { apply det_step_tbeta. } + eapply sem_expr_rel_move_single_subst. + eapply expr_rel_mono_idx; last done. + lia. +Qed. + +Lemma compat_pack Γ e n A B : + type_wf n B → + type_wf (S n) A → + TY n; Γ ⊨ e : A.[B/] → + TY n; Γ ⊨ (pack e) : (∃: A). +Proof. + intros Hwf Hwf' He θ δ k W Hctx. simpl. + + specialize (He _ _ _ _ Hctx). + eapply (bind [PackCtx]); first done. + intros j v W' Hj HW Hv. + simpl. eapply (sem_val_expr_rel _ _ _ _ (PackV v)). + simp type_interp. exists v; split; first done. + exists (interp_type B δ). + apply sem_val_rel_move_single_subst. done. +Qed. + +Lemma compat_unpack n Γ A B e e' x : + type_wf n B → + TY n; Γ ⊨ e : (∃: A) → + TY S n; <[x:=A]> (⤉Γ) ⊨ e' : B.[ren (+1)] → + TY n; Γ ⊨ (unpack e as BNamed x in e') : B. +Proof. + intros Hwf He He' θ δ k W Hctx. simpl. + + specialize (He _ _ _ _ Hctx). + eapply (bind [UnpackCtx _ _]); first done. + intros j v W' Hj HW Hv. + simp type_interp in Hv. destruct Hv as (v' & -> & τ & Hv'). + simpl. + + eapply expr_det_step_closure. + { apply det_step_unpack. apply is_val_of_val. } + simpl. rewrite subst_subst_map; last by eapply sem_context_rel_closed. + + specialize (He' (<[x := of_val v']> θ) (τ.:δ) (j - 1) W'). + rewrite <-sem_expr_rel_cons in He'. + apply He'. + constructor. + { eapply val_rel_mono_idx; last done. lia. } + apply sem_context_rel_cons. + eapply sem_context_rel_mono; last done; [lia | done]. +Qed. + +Lemma compat_if n Γ e0 e1 e2 A : + TY n; Γ ⊨ e0 : Bool → + TY n; Γ ⊨ e1 : A → + TY n; Γ ⊨ e2 : A → + TY n; Γ ⊨ (if: e0 then e1 else e2) : A. +Proof. + intros He0 He1 He2 θ δ k W Hctx. simpl. + specialize (He0 _ _ _ _ Hctx). + specialize (He1 _ _ _ _ Hctx). + specialize (He2 _ _ _ _ Hctx). + + eapply (bind [IfCtx _ _]); first done. + intros j v W' Hj HW Hv. + simp type_interp in Hv. destruct Hv as (b & ->). + simpl. + + destruct b. + - eapply expr_det_step_closure. + { apply det_step_if_true. } + eapply expr_rel_mono; last done; [lia | done]. + - eapply expr_det_step_closure. + { apply det_step_if_false. } + eapply expr_rel_mono; last done; [lia | done]. +Qed. + +Lemma compat_pair Δ Γ e1 e2 A B : + TY Δ; Γ ⊨ e1 : A → + TY Δ; Γ ⊨ e2 : B → + TY Δ; Γ ⊨ (e1, e2) : A × B. +Proof. + intros He1 He2 θ δ k W Hctx. simpl. + specialize (He1 _ _ _ _ Hctx). + specialize (He2 _ _ _ _ Hctx). + + eapply (bind [PairRCtx _]); first done. + intros j v2 W' Hj HW Hv2. + eapply (bind [PairLCtx _]). + { eapply expr_rel_mono; last done; [lia | done]. } + intros j' v1 W'' Hj' HW' Hv1. + + simpl. + eapply (sem_val_expr_rel _ _ _ _ (v1, v2)%V). + simp type_interp. exists v1, v2. split_and!; first done. + - done. + - eapply val_rel_mono; last done; [lia | done]. +Qed. + +Lemma compat_fst Δ Γ e A B : + TY Δ; Γ ⊨ e : A × B → + TY Δ; Γ ⊨ Fst e : A. +Proof. + intros He θ δ k W Hctx. + specialize (He _ _ _ _ Hctx). + simpl. eapply (bind [FstCtx]); first done. + intros j v W' Hj HW Hv. + simp type_interp in Hv. destruct Hv as (v1 & v2 & -> & Hv1 & Hv2). + + eapply expr_det_step_closure. + { simpl. apply det_step_fst; apply is_val_of_val. } + eapply sem_val_expr_rel. eapply val_rel_mono_idx; last done. lia. +Qed. + +Lemma compat_snd Δ Γ e A B : + TY Δ; Γ ⊨ e : A × B → + TY Δ; Γ ⊨ Snd e : B. +Proof. + intros He θ δ k w Hctx. + specialize (He _ _ _ _ Hctx). + simpl. eapply (bind [SndCtx]); first done. + intros j v W' Hj HW Hv. + simp type_interp in Hv. destruct Hv as (v1 & v2 & -> & Hv1 & Hv2). + + eapply expr_det_step_closure. + { simpl. apply det_step_snd; apply is_val_of_val. } + eapply sem_val_expr_rel. eapply val_rel_mono_idx; last done. lia. +Qed. + +Lemma compat_injl Δ Γ e A B : + TY Δ; Γ ⊨ e : A → + TY Δ; Γ ⊨ InjL e : A + B. +Proof. + intros He θ δ k W Hctx. simpl. + specialize (He _ _ _ _ Hctx). + eapply (bind [InjLCtx]); first done. + intros j v W' Hj HW Hv. + eapply (sem_val_expr_rel _ _ _ _ (InjLV v)). + simp type_interp. left. eauto. +Qed. + +Lemma compat_injr Δ Γ e A B : + TY Δ; Γ ⊨ e : B → + TY Δ; Γ ⊨ InjR e : A + B. +Proof. + intros He θ δ k W Hctx. simpl. + specialize (He _ _ _ _ Hctx). + eapply (bind [InjRCtx]); first done. + intros j v W' Hj HW Hv. + eapply (sem_val_expr_rel _ _ _ _ (InjRV v)). + simp type_interp. eauto. +Qed. + +Lemma compat_case Δ Γ e e1 e2 A B C : + TY Δ; Γ ⊨ e : B + C → + TY Δ; Γ ⊨ e1 : (B → A) → + TY Δ; Γ ⊨ e2 : (C → A) → + TY Δ; Γ ⊨ Case e e1 e2 : A. +Proof. + intros He He1 He2 θ δ k W Hctx. simpl. + specialize (He _ _ _ _ Hctx). + specialize (He1 _ _ _ _ Hctx). + specialize (He2 _ _ _ _ Hctx). + eapply (bind [CaseCtx _ _]); first done. + intros j v W' Hj HW Hv. + simp type_interp in Hv. destruct Hv as [(v' & -> & Hv') | (v' & -> & Hv')]. + - simpl. eapply expr_det_step_closure. + { apply det_step_casel. apply is_val_of_val. } + eapply (bind [AppLCtx _]). + { eapply expr_rel_mono; last done; [lia | done]. } + intros j' v W'' Hj' HW' Hv. simpl. + simp type_interp in Hv. destruct Hv as (x & e' & -> & ? & Hv). + eapply expr_det_step_closure. { apply det_step_beta. apply is_val_of_val. } + apply Hv; first done. eapply val_rel_mono; last done; [lia | done]. + - simpl. eapply expr_det_step_closure. + { apply det_step_caser. apply is_val_of_val. } + eapply (bind [AppLCtx _]). + { eapply expr_rel_mono; last done; [lia | done]. } + intros j' v W'' Hj' HW' Hv. simpl. + simp type_interp in Hv. destruct Hv as (x & e' & -> & ? & Hv). + eapply expr_det_step_closure. { apply det_step_beta. apply is_val_of_val. } + apply Hv; first done. eapply val_rel_mono; last done; [lia | done]. +Qed. + +Lemma compat_roll n Γ e A : + TY n; Γ ⊨ e : (A.[(μ: A)%ty/]) → + TY n; Γ ⊨ (roll e) : (μ: A). +Proof. + intros He θ δ k W Hctx. simpl. + specialize (He _ _ _ _ Hctx). + + eapply (bind [RollCtx]); first done. + intros j v W' Hj HW Hv. + eapply (sem_val_expr_rel _ _ _ _ (RollV v)). + + specialize (val_rel_is_closed _ _ _ _ _ Hv) as ?. + destruct j as [ | j]; simp type_interp; first by eauto. + exists v. split_and!; [done.. | ]. + intros kd. eapply val_rel_mono_idx; last done. lia. +Qed. + +Lemma compat_unroll n Γ e A : + TY n; Γ ⊨ e : (μ: A) → + TY n; Γ ⊨ (unroll e) : (A.[(μ: A)%ty/]). +Proof. + intros He θ δ k W Hctx. simpl. + specialize (He _ _ _ _ Hctx). + + eapply (bind [UnrollCtx]); first done. + intros j v W' Hj HW Hv. + destruct j as [ | j]; first by apply sem_expr_rel_zero_trivial. + simp type_interp in Hv. destruct Hv as (v' & -> & ? & Hv). + eapply expr_det_step_closure. + { simpl. apply det_step_unroll. apply is_val_of_val. } + eapply sem_val_expr_rel. apply Hv. +Qed. + + +(** A bit of theory about first-order types *) +Lemma canonical_values_int n Γ e: + TY n; Γ ⊢ e : Int → + is_val e → + ∃ n: Z, e = (#n)%E. +Proof. inversion 1; simpl; naive_solver. Qed. + +Lemma canonical_values_bool n Γ e: + TY n; Γ ⊢ e : Bool → + is_val e → + ∃ b: bool, e = (#b)%E. +Proof. inversion 1; simpl; naive_solver. Qed. + +Lemma canonical_values_unit n Γ e: + TY n; Γ ⊢ e : Unit → + is_val e → + e = (#LitUnit)%E. +Proof. inversion 1; simpl; naive_solver. Qed. + +Lemma canonical_values_prod n Γ e A B : + TY n; Γ ⊢ e : A × B → + is_val e → + ∃ e1 e2, e = (e1, e2)%E ∧ is_val e1 ∧ is_val e2 ∧ + TY n; Γ ⊢ e1 : A ∧ TY n; Γ ⊢ e2 : B . +Proof. inversion 1; simpl; naive_solver. Qed. + +Lemma canonical_values_sum n Γ e A B : + TY n; Γ ⊢ e : A + B → + is_val e → + (∃ e', e = InjL e' ∧ is_val e' ∧ TY n; Γ ⊢ e' : A) ∨ (∃ e', e = InjR e' ∧ is_val e' ∧ TY n; Γ ⊢ e' : B). +Proof. inversion 1; simpl; naive_solver. Qed. + +Lemma type_wf_fotype a : type_wf 0 a. +Proof. induction a; simpl; eauto. Qed. + +(* First-order types are simple. *) +Lemma syn_fo_typed_val a δ k W v : + TY 0; ∅ ⊢ of_val v : a ↔ 𝒱 a δ k W v. +Proof. + induction a as [ | | | a1 IH1 a2 IH2 | a1 IH1 a2 IH2 ] in v |-*. + - split. + + intros [z Heq]%canonical_values_int; simplify_val; last eauto. + simp type_interp. eauto. + + simp type_interp. intros (z & ->). constructor. + - split. + + intros (b & Heq)%canonical_values_bool; simplify_val; last eauto. + simp type_interp. eauto. + + simp type_interp. intros (b & ->). constructor. + - split. + + intros Heq%canonical_values_unit; simplify_val; last eauto. + simp type_interp; eauto. + + simp type_interp. intros ->. econstructor. + - split. + + simpl. intros (e1 & e2 & ? & (v1 & Heq1)%is_val_spec & (v2 & Heq2)%is_val_spec & H1 & H2)%canonical_values_prod; last eauto. + simplify_val. apply of_val_pair_inv in H; subst v. + simp type_interp. exists v1, v2. naive_solver. + + simpl. simp type_interp. intros (v1 & v2 & -> & Hv1%IH1 & Hv2%IH2). econstructor; done. + - split. + + simpl. intros [(e & ? & (v' & Heq)%is_val_spec & H) | (e & ? & (v' & Heq)%is_val_spec & H)]%canonical_values_sum; last eauto. + * simplify_val. apply of_val_injl_inv in H0; subst v. + simp type_interp. left. naive_solver. + * simplify_val. apply of_val_injr_inv in H0; subst v. + simp type_interp. right. naive_solver. + + simpl. simp type_interp. intros [(v' & -> & Hv%IH1) | (v' & -> & Hv%IH2)]. + * simpl. eapply typed_injl; last done. apply type_wf_fotype. + * simpl. eapply typed_injr; last done. apply type_wf_fotype. +Qed. + +Lemma wsat_init_heap σ l v a W : + σ !! l = None → + wsat W σ → + TY 0; ∅ ⊢ v : a → + wsat ((λ σ, ∃ v, σ = <[l := v]> ∅ ∧ TY 0; ∅ ⊢ v : a) :: W) (init_heap l 1 v σ). +Proof. + intros. simpl. eexists. split; [exists v; split; [reflexivity | ] | split ]. + - done. + - unfold init_heap. simpl. rewrite right_id. + rewrite -insert_union_singleton_l. apply insert_mono. + apply map_empty_subseteq. + - unfold init_heap. simpl. rewrite right_id. rewrite -delete_difference map_difference_empty. + rewrite delete_union delete_singleton left_id. + rewrite delete_notin; done. +Qed. + +Lemma compat_new Δ Γ e a : + TY Δ; Γ ⊨ e : a → + TY Δ; Γ ⊨ new e : (Ref a). +Proof. + intros He θ δ k W Hctx. + eapply (bind [NewCtx]). { eapply He; done. } + intros j v W' Hj Hext Hv. + simp type_interp. + + intros e' σ σ' W'' n Hext' Hsat' Hn Hred. + eapply new_nsteps_inv in Hred as [-> Hstep]; last apply to_of_val. + eapply new_step_inv in Hstep as (l & -> & -> & ?); last apply to_of_val. + exists #l, ((λ σ', ∃ v, σ' = <[ l := v ]> ∅ ∧ TY 0; ∅ ⊢ (of_val v) : a) :: W''). + split_and!; [done | eapply suffix_cons_l; reflexivity | .. ]. + { apply wsat_init_heap; [ done.. | ]. + by eapply syn_fo_typed_val. + } + simp type_interp. + exists l. split; first done. eexists 0, _. split; done. +Qed. + +Lemma compat_load Δ Γ e a : + TY Δ; Γ ⊨ e : Ref a → + TY Δ; Γ ⊨ !e : a. +Proof. + intros He θ δ k W Hctx. + eapply (bind [LoadCtx]). { eapply He; done. } + intros j v W' Hj Hext Hv. + simp type_interp in Hv. + destruct Hv as (l & -> & (i & INV & Hlook & ->)). + + simp type_interp. + + intros e' σ σ' W'' n Hext' Hsat' Hn. + eapply wsat_lookup in Hlook; last by eapply wsat_wext. + destruct Hlook as (? & Hincl & (v & -> & ?)). + intros Hred. eapply load_nsteps_inv in Hred as [(-> & -> & -> & Hirred) | [-> Hstep]]; last apply to_of_val. + { exfalso; apply Hirred. + exists (of_val v), σ. apply base_contextual_step. + econstructor. eapply lookup_weaken; last done. apply lookup_insert. + } + eapply load_step_inv in Hstep; last apply to_of_val. + destruct Hstep as (? & v' & [= <-] & Hl & -> & ->). + eapply lookup_weaken_inv in Hincl; [ | apply lookup_insert | done]. subst v'. + rewrite to_of_val. eexists _, _. split_and!; [reflexivity | reflexivity | done | ]. + + (* use that FO types are simple. *) + apply syn_fo_typed_val; done. +Qed. + +Lemma compat_store Δ Γ e1 e2 a : + TY Δ; Γ ⊨ e1 : Ref a → + TY Δ; Γ ⊨ e2 : a → + TY Δ; Γ ⊨ (e1 <- e2) : Unit. +Proof. + (* you may find the lemmas [wsat_lookup, wsat_update] above helpful. *) + intros He1 He2 θ δ k W Hctx. simpl. + eapply (bind [StoreRCtx _]). { eapply He2; done. } + intros j v W' Hj Hext Hv2. + + eapply (bind [StoreLCtx _]). + { eapply expr_rel_mono; last eapply He1; done. } + intros j' v' W'' Hj' Hext' Hv1. + simp type_interp in Hv1. + destruct Hv1 as (l & -> & (i & INV & Hlook & ->)). + + simp type_interp. + intros e' σ σ' W''' n Hext'' Hsat' Hn. + specialize (wsat_lookup W'' _ i _ ltac:(by eapply wsat_wext) Hlook) as (? & Hincl & (vm & -> & ?)). + + intros [(-> & -> & -> & Hirred) | [-> Hstep]]%store_nsteps_inv. + { exfalso; apply Hirred. + exists (Lit LitUnit), (<[l := v]> σ). apply base_contextual_step. + econstructor. 2: by rewrite to_of_val. + eapply lookup_weaken; last done. apply lookup_insert. + } + apply store_step_inv in Hstep. + destruct Hstep as (? & v' & [= <-] & Hl & -> & ->). + eexists _, _. split_and!; [reflexivity | reflexivity | | ]. + 2: { simp type_interp. done. } + + (* restore the invariant *) + destruct Hext'' as (Pre & ->). + eapply (wsat_update _ _ (length Pre + i) _ _ ); [ done | ..]. + { rewrite lookup_app_r; last lia. + replace (length Pre + i - length Pre) with i by lia. + done. + } + intros σ' (v'' & -> & _). split. + { apply lookup_insert_is_Some. by left. } + exists v. rewrite insert_insert. split; first done. + eapply syn_fo_typed_val; done. +Qed. + + +Local Hint Resolve compat_var compat_lam_named compat_lam_anon compat_tlam compat_int compat_bool compat_unit compat_if compat_app compat_tapp compat_pack compat_unpack compat_int_binop compat_int_bool_binop compat_unop compat_pair compat_fst compat_snd compat_injl compat_injr compat_case compat_roll compat_unroll compat_new compat_store compat_load: core. + +Lemma sem_soundness Δ Γ e A : + TY Δ; Γ ⊢ e : A → + TY Δ; Γ ⊨ e : A. +Proof. + induction 1 as [ | Δ Γ x e A B Hsyn IH | Δ Γ e A B Hsyn IH| Δ Γ e A Hsyn IH| | | | | | | | | n Γ e1 e2 op A B C Hop ? ? ? ? | | | | | | | | | | | | ]; eauto. + - (* lambda *) + set (X := elements (dom (<[x := A]>Γ))). + specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl. + eapply compat_lam_named; last done. + + apply Hcl. apply elem_of_elements. + + intros ??. by apply elem_of_elements. + - (* lambda anon *) + set (X := elements (dom Γ)). + specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl. + eapply compat_lam_anon; last done. + + apply Hcl. apply elem_of_elements. + + intros ??. by apply elem_of_elements. + - (* tlam *) + set (X := elements (dom Γ)). + specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl. + eapply compat_tlam; last done. + + apply Hcl. rewrite dom_fmap. apply elem_of_elements. + + intros ??. by apply elem_of_elements. + - (* binop *) inversion Hop; subst; eauto. +Qed. + +(* dummy delta which we can use if we don't care *) +Program Definition any_type : sem_type := {| sem_type_car := λ k W v, is_closed [] v |}. +Definition δ_any : var → sem_type := λ _, any_type. + + +Definition safe e h := + ∀ e' h' n, red_nsteps n e h e' h' → is_val e'. + +Lemma type_safety e A : + TY 0; ∅ ⊢ e : A → + safe e ∅. +Proof. + intros He%sem_soundness e' h' n Hred. + specialize (He ∅ δ_any (S n) []). simp type_interp in He. + rewrite subst_map_empty in He. + edestruct (He ) as (v & W' & Hv & _); [ | done | | | eassumption | ]. + - constructor. + - done. + - lia. + - rewrite <- (of_to_val _ _ Hv). apply is_val_of_val. +Qed. + + +(** Additional lemmas *) +Lemma semantic_app A B δ k W e1 e2 : + ℰ (A → B) δ k W e1 → + ℰ A δ k W e2 → + ℰ B δ k W (e1 e2). +Proof. + intros He1 He2. + eapply (bind [AppRCtx e1]); first done. + intros j v W' Hj Hincl Hv. eapply (bind [AppLCtx _]). + { eapply expr_rel_mono; [ | done..]. lia. } + intros j' v' W'' Hj' Hincl' Hf. + simp type_interp in Hf. destruct Hf as (x & e & -> & Hcl & Hf). + eapply expr_det_step_closure. + { apply det_step_beta. apply is_val_of_val. } + apply Hf; first done. + eapply val_rel_mono; [ | done..]. lia. +Qed. diff --git a/theories/type_systems/systemf_mu_state/types_sol.v b/theories/type_systems/systemf_mu_state/types_sol.v new file mode 100644 index 0000000..79f3741 --- /dev/null +++ b/theories/type_systems/systemf_mu_state/types_sol.v @@ -0,0 +1,1337 @@ +From stdpp Require Import base relations. +From iris Require Import prelude. +From semantics.lib Require Import maps. +From semantics.ts.systemf_mu_state Require Import lang notation. +From Autosubst Require Export Autosubst. + +(** ** Syntactic typing *) +(** We use De Bruijn indices with the help of the Autosubst library. *) +Inductive type : Type := + (** [var] is the type of variables of Autosubst -- it unfolds to [nat] *) + | TVar : var → type + | Int + | Bool + | Unit + (** The [{bind 1 of type}] tells Autosubst to put a De Bruijn binder here *) + | TForall : {bind 1 of type} → type + | TExists : {bind 1 of type} → type + | Fun (A B : type) + | Prod (A B : type) + | Sum (A B : type) + | TMu : {bind 1 of type} → type + | Ref (A : type) +. + +(** Autosubst instances. + This lets Autosubst do its magic and derive all the substitution functions, etc. + *) +#[export] Instance Ids_type : Ids type. derive. Defined. +#[export] Instance Rename_type : Rename type. derive. Defined. +#[export] Instance Subst_type : Subst type. derive. Defined. +#[export] Instance SubstLemmas_typer : SubstLemmas type. derive. Qed. + +Definition typing_context := gmap string type. +Definition heap_context := gmap loc type. +Implicit Types + (Γ : typing_context) + (Σ : heap_context) + (v : val) + (e : expr) + (A B : type) +. + +Declare Scope FType_scope. +Delimit Scope FType_scope with ty. +Bind Scope FType_scope with type. +Notation "# x" := (TVar x) : FType_scope. +Infix "→" := Fun : FType_scope. +Notation "(→)" := Fun (only parsing) : FType_scope. +Notation "∀: τ" := + (TForall τ%ty) + (at level 100, τ at level 200) : FType_scope. +Notation "∃: τ" := + (TExists τ%ty) + (at level 100, τ at level 200) : FType_scope. +Infix "×" := Prod (at level 70) : FType_scope. +Notation "(×)" := Prod (only parsing) : FType_scope. +Infix "+" := Sum : FType_scope. +Notation "(+)" := Sum (only parsing) : FType_scope. +Notation "μ: A" := + (TMu A%ty) + (at level 100, A at level 200) : FType_scope. + +(** Shift all the indices in the context by one, + used when inserting a new type interpretation in Δ. *) +(* [<$>] is notation for the [fmap] operation that maps the substitution over the whole map. *) +(* [ren] is Autosubst's renaming operation -- it renames all type variables according to the given function, + in this case [(+1)] to shift the variables up by 1. *) +Notation "⤉ Γ" := (Autosubst_Classes.subst (ren (+1)) <$> Γ) (at level 10, format "⤉ Γ"). + + +(** [type_wf n A] states that a type [A] has only free variables up to < [n]. + (in other words, all variables occurring free are strictly bounded by [n]). *) +Inductive type_wf : nat → type → Prop := + | type_wf_TVar m n: + m < n → + type_wf n (TVar m) + | type_wf_Int n: type_wf n Int + | type_wf_Bool n : type_wf n Bool + | type_wf_Unit n : type_wf n Unit + | type_wf_TForall n A : + type_wf (S n) A → + type_wf n (TForall A) + | type_wf_TExists n A : + type_wf (S n) A → + type_wf n (TExists A) + | type_wf_Fun n A B: + type_wf n A → + type_wf n B → + type_wf n (Fun A B) + | type_wf_Prod n A B : + type_wf n A → + type_wf n B → + type_wf n (Prod A B) + | type_wf_Sum n A B : + type_wf n A → + type_wf n B → + type_wf n (Sum A B) + | type_wf_mu n A : + type_wf (S n) A → + type_wf n (μ: A) + | type_wf_ref n A : + type_wf n A → + type_wf n (Ref A) +. +#[export] Hint Constructors type_wf : core. + +Inductive bin_op_typed : bin_op → type → type → type → Prop := + | plus_op_typed : bin_op_typed PlusOp Int Int Int + | minus_op_typed : bin_op_typed MinusOp Int Int Int + | mul_op_typed : bin_op_typed MultOp Int Int Int + | lt_op_typed : bin_op_typed LtOp Int Int Bool + | le_op_typed : bin_op_typed LeOp Int Int Bool + | eq_op_typed : bin_op_typed EqOp Int Int Bool. +#[export] Hint Constructors bin_op_typed : core. + +Inductive un_op_typed : un_op → type → type → Prop := + | neg_op_typed : un_op_typed NegOp Bool Bool + | minus_un_op_typed : un_op_typed MinusUnOp Int Int. + +Reserved Notation "'TY' Σ ; n ; Γ ⊢ e : A" (at level 74, e, A at next level). +Inductive syn_typed : heap_context → nat → typing_context → expr → type → Prop := + | typed_var Σ n Γ x A : + Γ !! x = Some A → + TY Σ; n; Γ ⊢ (Var x) : A + | typed_lam Σ n Γ x e A B : + TY Σ; n ; (<[ x := A]> Γ) ⊢ e : B → + type_wf n A → + TY Σ; n; Γ ⊢ (Lam (BNamed x) e) : (A → B) + | typed_lam_anon Σ n Γ e A B : + TY Σ; n ; Γ ⊢ e : B → + type_wf n A → + TY Σ; n; Γ ⊢ (Lam BAnon e) : (A → B) + | typed_tlam Σ n Γ e A : + (* we need to shift the context up as we descend under a binder *) + TY (⤉ Σ); S n; (⤉ Γ) ⊢ e : A → + TY Σ; n; Γ ⊢ (Λ, e) : (∀: A) + | typed_tapp Σ n Γ A B e : + TY Σ; n; Γ ⊢ e : (∀: A) → + type_wf n B → + (* A.[B/] is the notation for Autosubst's substitution operation that + replaces variable 0 by [B] *) + TY Σ; n; Γ ⊢ (e <>) : (A.[B/]) + | typed_pack Σ n Γ A B e : + type_wf n B → + type_wf (S n) A → + TY Σ; n; Γ ⊢ e : (A.[B/]) → + TY Σ; n; Γ ⊢ (pack e) : (∃: A) + | typed_unpack Σ n Γ A B e e' x : + type_wf n B → (* we should not leak the existential! *) + TY Σ; n; Γ ⊢ e : (∃: A) → + (* As we descend under a type variable binder for the typing of [e'], + we need to shift the indices in [Γ] and [B] up by one. + On the other hand, [A] is already defined under this binder, so we need not shift it. + *) + TY (⤉ Σ); (S n); (<[x := A]>(⤉Γ)) ⊢ e' : (B.[ren (+1)]) → + TY Σ; n; Γ ⊢ (unpack e as BNamed x in e') : B + | typed_int Σ n Γ z : TY Σ; n; Γ ⊢ (Lit $ LitInt z) : Int + | typed_bool Σ n Γ b : TY Σ; n; Γ ⊢ (Lit $ LitBool b) : Bool + | typed_unit Σ n Γ : TY Σ; n; Γ ⊢ (Lit $ LitUnit) : Unit + | typed_if Σ n Γ e0 e1 e2 A : + TY Σ; n; Γ ⊢ e0 : Bool → + TY Σ; n; Γ ⊢ e1 : A → + TY Σ; n; Γ ⊢ e2 : A → + TY Σ; n; Γ ⊢ If e0 e1 e2 : A + | typed_app Σ n Γ e1 e2 A B : + TY Σ; n; Γ ⊢ e1 : (A → B) → + TY Σ; n; Γ ⊢ e2 : A → + TY Σ; n; Γ ⊢ (e1 e2)%E : B + | typed_binop Σ n Γ e1 e2 op A B C : + bin_op_typed op A B C → + TY Σ; n; Γ ⊢ e1 : A → + TY Σ; n; Γ ⊢ e2 : B → + TY Σ; n; Γ ⊢ BinOp op e1 e2 : C + | typed_unop Σ n Γ e op A B : + un_op_typed op A B → + TY Σ; n; Γ ⊢ e : A → + TY Σ; n; Γ ⊢ UnOp op e : B + | typed_pair Σ n Γ e1 e2 A B : + TY Σ; n; Γ ⊢ e1 : A → + TY Σ; n; Γ ⊢ e2 : B → + TY Σ; n; Γ ⊢ (e1, e2) : A × B + | typed_fst Σ n Γ e A B : + TY Σ; n; Γ ⊢ e : A × B → + TY Σ; n; Γ ⊢ Fst e : A + | typed_snd Σ n Γ e A B : + TY Σ; n; Γ ⊢ e : A × B → + TY Σ; n; Γ ⊢ Snd e : B + | typed_injl Σ n Γ e A B : + type_wf n B → + TY Σ; n; Γ ⊢ e : A → + TY Σ; n; Γ ⊢ InjL e : A + B + | typed_injr Σ n Γ e A B : + type_wf n A → + TY Σ; n; Γ ⊢ e : B → + TY Σ; n; Γ ⊢ InjR e : A + B + | typed_case Σ n Γ e e1 e2 A B C : + TY Σ; n; Γ ⊢ e : B + C → + TY Σ; n; Γ ⊢ e1 : (B → A) → + TY Σ; n; Γ ⊢ e2 : (C → A) → + TY Σ; n; Γ ⊢ Case e e1 e2 : A + | typed_roll Σ n Γ e A : + TY Σ; n; Γ ⊢ e : (A.[(μ: A)/]) → + TY Σ; n; Γ ⊢ (roll e) : (μ: A) + | typed_unroll Σ n Γ e A : + TY Σ; n; Γ ⊢ e : (μ: A) → + TY Σ; n; Γ ⊢ (unroll e) : (A.[(μ: A)/]) + | typed_loc Σ Δ Γ l A : + Σ !! l = Some A → + TY Σ; Δ; Γ ⊢ (Lit $ LitLoc l) : (Ref A) + | typed_load Σ Δ Γ e A : + TY Σ; Δ; Γ ⊢ e : (Ref A) → + TY Σ; Δ; Γ ⊢ !e : A + | typed_store Σ Δ Γ e1 e2 A : + TY Σ; Δ; Γ ⊢ e1 : (Ref A) → + TY Σ; Δ; Γ ⊢ e2 : A → + TY Σ; Δ; Γ ⊢ (e1 <- e2) : Unit + | typed_new Σ Δ Γ e A : + TY Σ; Δ; Γ ⊢ e : A → + TY Σ; Δ; Γ ⊢ (new e) : Ref A +where "'TY' Σ ; n ; Γ ⊢ e : A" := (syn_typed Σ n Γ e%E A%ty). +#[export] Hint Constructors syn_typed : core. + +(** Examples *) +Goal TY ∅; 0; ∅ ⊢ (λ: "x", #1 + "x")%E : (Int → Int). +Proof. eauto. Qed. +(** [∀: #0 → #0] corresponds to [∀ α. α → α] with named binders. *) +Goal TY ∅; 0; ∅ ⊢ (Λ, λ: "x", "x")%E : (∀: #0 → #0). +Proof. repeat econstructor. Qed. +Goal TY ∅; 0; ∅ ⊢ (pack ((λ: "x", "x"), #42)) : ∃: (#0 → #0) × #0. +Proof. + apply (typed_pack _ _ _ _ Int). + - eauto. + - repeat econstructor. + - (* [asimpl] is Autosubst's tactic for simplifying goals involving type substitutions. *) + asimpl. eauto. +Qed. +Goal TY ∅; 0; ∅ ⊢ (unpack (pack ((λ: "x", "x"), #42)) as "y" in (λ: "x", #1337) ((Fst "y") (Snd "y"))) : Int. +Proof. + (* if we want to typecheck stuff with existentials, we need a bit more explicit proofs. + Letting eauto try to instantiate the evars becomes too expensive. *) + apply (typed_unpack _ _ _ ((#0 → #0) × #0)%ty). + - done. + - apply (typed_pack _ _ _ _ Int); asimpl; eauto. + repeat econstructor. + - eapply (typed_app _ _ _ _ _ (#0)%ty); eauto 10. +Qed. + +(** fails: we are not allowed to leak the existential *) +Goal TY ∅; 0; ∅ ⊢ (unpack (pack ((λ: "x", "x"), #42)) as "y" in (Fst "y") (Snd "y")) : #0. +Proof. + apply (typed_unpack _ _ _ ((#0 → #0) × #0)%ty). +Abort. + +(* derived typing rule for match *) +Lemma typed_match Σ n Γ e e1 e2 x1 x2 A B C : + type_wf n B → + type_wf n C → + TY Σ; n; Γ ⊢ e : B + C → + TY Σ; n; <[x1 := B]> Γ ⊢ e1 : A → + TY Σ; n; <[x2 := C]> Γ ⊢ e2 : A → + TY Σ; n; Γ ⊢ match: e with InjL (BNamed x1) => e1 | InjR (BNamed x2) => e2 end : A. +Proof. eauto. Qed. + +Lemma syn_typed_closed Σ n Γ e A X : + TY Σ; n; Γ ⊢ e : A → + (∀ x, x ∈ dom Γ → x ∈ X) → + is_closed X e. +Proof. + induction 1 as [ | ???????? IH | | Σ n Γ e A H IH | | | Σ n Γ A B e e' x Hwf H1 IH1 H2 IH2 | | | | | | | | | | | | | | | | | | | ] in X |-*; simpl; intros Hx; try done. + + { (* var *) apply bool_decide_pack, Hx. apply elem_of_dom; eauto. } + { (* lam *) apply IH. + intros y. rewrite elem_of_dom lookup_insert_is_Some. + intros [<- | [? Hy]]; first by apply elem_of_cons; eauto. + apply elem_of_cons. right. eapply Hx. by apply elem_of_dom. + } + { (* anon lam *) naive_solver. } + { (* tlam *) + eapply IH. intros x Hel. apply Hx. + by rewrite dom_fmap in Hel. + } + 3: { (* unpack *) + apply andb_True; split. + - apply IH1. apply Hx. + - apply IH2. intros y. rewrite elem_of_dom lookup_insert_is_Some. + intros [<- | [? Hy]]; first by apply elem_of_cons; eauto. + apply elem_of_cons. right. eapply Hx. + apply elem_of_dom. revert Hy. rewrite lookup_fmap fmap_is_Some. done. + } + (* everything else *) + all: repeat match goal with + | |- Is_true (_ && _) => apply andb_True; split + end. + all: try naive_solver. +Qed. + +(** *** Lemmas about [type_wf] *) +Lemma type_wf_mono n m A: + type_wf n A → n ≤ m → type_wf m A. +Proof. + induction 1 in m |-*; eauto with lia. +Qed. + +Lemma type_wf_rename n A δ: + type_wf n A → + (∀ i j, i < j → δ i < δ j) → + type_wf (δ n) (rename δ A). +Proof. + induction 1 in δ |-*; intros Hmon; simpl; eauto. + all: econstructor; eapply type_wf_mono; first eapply IHtype_wf; last done. + all: intros i j Hlt; destruct i, j; simpl; try lia. + all: rewrite -Nat.succ_lt_mono; eapply Hmon; lia. +Qed. + +(** [A.[σ]], i.e. [A] with the substitution [σ] applied to it, is well-formed under [m] if + [A] is well-formed under [n] and all the things we substitute up to [n] are well-formed under [m]. + *) +Lemma type_wf_subst n m A σ: + type_wf n A → + (∀ x, x < n → type_wf m (σ x)) → + type_wf m A.[σ]. +Proof. + induction 1 in m, σ |-*; intros Hsub; simpl; eauto. + + econstructor; eapply IHtype_wf. + intros [|x]; rewrite /up //=. + - econstructor. lia. + - intros Hlt % Nat.succ_lt_mono. eapply type_wf_rename; eauto. + intros i j Hlt'; simpl; lia. + + econstructor; eapply IHtype_wf. + intros [|x]; rewrite /up //=. + - econstructor. lia. + - intros Hlt % Nat.succ_lt_mono. eapply type_wf_rename; eauto. + intros i j Hlt'; simpl; lia. + + econstructor. eapply IHtype_wf. + intros [|x]; rewrite /up //=. + - econstructor. lia. + - intros Hlt % Nat.succ_lt_mono. eapply type_wf_rename; eauto. + intros ???. simpl; lia. +Qed. + +Fixpoint free_vars A : nat → Prop := + match A with + | TVar n => λ m, m = n + | Int => λ _, False + | Bool => λ _, False + | Unit => λ _, False + | Fun A B => λ n, free_vars A n ∨ free_vars B n + | Prod A B => λ n, free_vars A n ∨ free_vars B n + | Sum A B => λ n, free_vars A n ∨ free_vars B n + | TForall A => λ n, free_vars A (S n) + | TExists A => λ n, free_vars A (S n) + | TMu A => λ n, free_vars A (S n) + | Ref A => λ n, free_vars A n + end. + +Definition bounded n A := + (∀ x, free_vars A x → x < n). + +Lemma type_wf_bounded n A: + type_wf n A ↔ bounded n A. +Proof. + rewrite /bounded; split. + - induction 1; simpl; try naive_solver. + + intros x Hfree % IHtype_wf. lia. + + intros x Hfree % IHtype_wf. lia. + + intros x Hfree % IHtype_wf. lia. + - induction A in n |-*; simpl; eauto. + + intros Hsub. econstructor. eapply IHA. + intros ??. destruct x as [|x]; first lia. + eapply Hsub in H. lia. + + intros Hsub. econstructor. eapply IHA. + intros ??. destruct x as [|x]; first lia. + eapply Hsub in H. lia. + + intros Hsub. econstructor; eauto. + + intros Hsub. econstructor; eauto. + + intros Hsub. econstructor; eauto. + + intros Hsub. econstructor. eapply IHA. + intros ??. destruct x as [|x]; first lia. + eapply Hsub in H. lia. +Qed. + +Lemma free_vars_rename A x δ: + free_vars A x → free_vars (rename δ A) (δ x). +Proof. + induction A in x, δ |-*; simpl; try naive_solver. + - intros Hf. apply (IHA (S x) (upren δ) Hf). + - intros Hf. apply (IHA (S x) (upren δ) Hf). + - intros Hf. apply (IHA (S x) (upren δ) Hf). +Qed. + +Lemma free_vars_subst x n A σ : + bounded n A.[σ] → free_vars A x → bounded n (σ x). +Proof. + induction A in n, σ, x |-*; simpl; try naive_solver. + - rewrite -type_wf_bounded. inversion 1; subst. revert H2; clear H. + rewrite type_wf_bounded. + intros Hbd Hfree. eapply IHA in Hbd; last done. + revert Hbd. rewrite /up //=. + intros Hbd y Hf. enough (S y < S n) by lia. + eapply Hbd. simpl. by eapply free_vars_rename. + - rewrite -type_wf_bounded. inversion 1; subst. revert H2; clear H. + rewrite type_wf_bounded. + intros Hbd Hfree. eapply IHA in Hbd; last done. + revert Hbd. rewrite /up //=. + intros Hbd y Hf. enough (S y < S n) by lia. + eapply Hbd. simpl. by eapply free_vars_rename. + - rewrite -!type_wf_bounded. inversion 1; subst. + revert H3 H4. rewrite !type_wf_bounded. naive_solver. + - rewrite -!type_wf_bounded. inversion 1; subst. + revert H3 H4. rewrite !type_wf_bounded. naive_solver. + - rewrite -!type_wf_bounded. inversion 1; subst. + revert H3 H4. rewrite !type_wf_bounded. naive_solver. + - rewrite -type_wf_bounded. inversion 1; subst. revert H2; clear H. + rewrite type_wf_bounded. + intros Hbd Hfree. eapply IHA in Hbd; last done. + revert Hbd. rewrite /up //=. + intros Hbd y Hf. enough (S y < S n) by lia. + eapply Hbd. simpl. by eapply free_vars_rename. +Qed. + +Lemma type_wf_rec_type n A: + type_wf n A.[(μ: A)%ty/] → type_wf (S n) A. +Proof. + rewrite !type_wf_bounded. intros Hbound x Hfree. + eapply free_vars_subst in Hbound; last done. + destruct x as [|x]; first lia; simpl in Hbound. + eapply type_wf_bounded in Hbound. inversion Hbound; subst; lia. +Qed. + +Lemma type_wf_single_subst n A B: type_wf n B → type_wf (S n) A → type_wf n A.[B/]. +Proof. + intros HB HA. eapply type_wf_subst; first done. + intros [|x]; simpl; eauto. + intros ?; econstructor. lia. +Qed. + +(** We lift [type_wf] to well-formedness of contexts *) +Definition ctx_wf n Γ := (∀ x A, Γ !! x = Some A → type_wf n A). + +Lemma ctx_wf_empty n : ctx_wf n ∅. +Proof. rewrite /ctx_wf. set_solver. Qed. + +Lemma ctx_wf_insert n x Γ A: ctx_wf n Γ → type_wf n A → ctx_wf n (<[x := A]> Γ). +Proof. intros H1 H2 y B. rewrite lookup_insert_Some. naive_solver. Qed. + +Lemma ctx_wf_up n Γ: + ctx_wf n Γ → ctx_wf (S n) (⤉Γ). +Proof. + intros Hwf x A; rewrite lookup_fmap. + intros (B & Hlook & ->) % fmap_Some. + asimpl. eapply type_wf_subst; first eauto. + intros y Hlt. simpl. econstructor. lia. +Qed. + +Definition heap_ctx_wf Δ (Σ: heap_context) := (∀ x A, Σ !! x = Some A → type_wf Δ A). + +Lemma heap_ctx_wf_empty n : heap_ctx_wf n ∅. +Proof. rewrite /heap_ctx_wf. set_solver. Qed. + +Lemma heap_ctx_wf_insert n l Σ A: heap_ctx_wf n Σ → type_wf n A → heap_ctx_wf n (<[l := A]> Σ). +Proof. intros H1 H2 y B. rewrite lookup_insert_Some. naive_solver. Qed. + +Lemma heap_ctx_wf_up n Σ: + heap_ctx_wf n Σ → heap_ctx_wf (S n) (⤉Σ). +Proof. + intros Hwf x A; rewrite lookup_fmap. + intros (B & Hlook & ->) % fmap_Some. + asimpl. eapply type_wf_subst; first eauto. + intros y Hlt. simpl. econstructor. lia. +Qed. + +#[global] +Hint Resolve ctx_wf_empty ctx_wf_insert ctx_wf_up heap_ctx_wf_up heap_ctx_wf_empty heap_ctx_wf_empty : core. + +(** Well-typed terms at [A] under a well-formed context have well-formed types [A].*) +Lemma syn_typed_wf Σ n Γ e A: + ctx_wf n Γ → + heap_ctx_wf n Σ → + TY Σ; n; Γ ⊢ e : A → + type_wf n A. +Proof. + intros Hwf Hhwf; induction 1 as [ | Σ n Γ x e A B Hty IH Hwfty | | Σ n Γ e A Hty IH | Σ n Γ A B e Hty IH Hwfty | Σ n Γ A B e Hwfty Hty IH| | | | | | Σ n Γ e1 e2 A B HtyA IHA HtyB IHB | Σ n Γ e1 e2 op A B C Hop HtyA IHA HtyB IHB | Σ n Γ e op A B Hop H IH | Σ n Γ e1 e2 A B HtyA IHA HtyB IHB | Σ n Γ e A B Hty IH | Σ n Γ e A B Hty IH | Σ n Γ e A B Hwfty Hty IH | Σ n Γ e A B Hwfty Hty IH| Σ n Γ e e1 e2 A B C Htye IHe Htye1 IHe1 Htye2 IHe2 | Σ n Γ e A Hty IH | Σ n Γ e A Hty IH | Σ n Γ l A Hlook| Σ n Γ e A Hty IH | Σ n Γ e1 e2 A Hty1 IH1 Hty2 IH2 | Σ n Γ e A Hty IH]; eauto. + - eapply type_wf_single_subst; first done. + specialize (IH Hwf Hhwf) as Hwf'. + by inversion Hwf'. + - specialize (IHA Hwf Hhwf) as Hwf'. + by inversion Hwf'; subst. + - inversion Hop; subst; eauto. + - inversion Hop; subst; eauto. + - specialize (IH Hwf Hhwf) as Hwf'. by inversion Hwf'; subst. + - specialize (IH Hwf Hhwf) as Hwf'. by inversion Hwf'; subst. + - specialize (IHe1 Hwf Hhwf) as Hwf''. by inversion Hwf''; subst. + - specialize (IH Hwf Hhwf) as Hwf'%type_wf_rec_type. + by econstructor. + - eapply type_wf_single_subst; first by apply IH. + specialize (IH Hwf Hhwf) as Hwf'. + by inversion Hwf'. + - specialize (IH Hwf Hhwf) as Hwf'. by inversion Hwf'. +Qed. + +Lemma renaming_ctx_inclusion Γ Δ : Γ ⊆ Δ → ⤉Γ ⊆ ⤉Δ. +Proof. + eapply map_fmap_mono. +Qed. + +Lemma renaming_heap_ctx_inclusion Σ Σ' : Σ ⊆ Σ' → ⤉Σ ⊆ ⤉Σ'. +Proof. + eapply map_fmap_mono. +Qed. + +Lemma typed_weakening n m Γ Δ e A Σ Σ' : + TY Σ; n; Γ ⊢ e : A → + Γ ⊆ Δ → + Σ ⊆ Σ' → + n ≤ m → + TY Σ'; m; Δ ⊢ e : A. +Proof. + induction 1 as [| Σ n Γ x e A B Htyp IH | | Σ n Γ e A Htyp IH | | | Σ n Γ A B e e' x Hwf H1 IH1 H2 IH2 | | | | | | | | | | | | | | | | Σ n Γ l A Hlook | | | ] in Σ', Δ, m |-*; intros Hsub1 Hsub2 Hle; eauto using type_wf_mono. + - (* var *) econstructor. by eapply lookup_weaken. + - (* lam *) econstructor; last by eapply type_wf_mono. eapply IH; eauto. by eapply insert_mono. + - (* tlam *) econstructor. eapply IH; last by lia. + + by eapply renaming_ctx_inclusion. + + by eapply renaming_heap_ctx_inclusion. + - (* pack *) + econstructor; last naive_solver. all: (eapply type_wf_mono; [ done | lia]). + - (* unpack *) econstructor. + + eapply type_wf_mono; done. + + eapply IH1; done. + + eapply IH2; last lia. + * apply insert_mono. by apply renaming_ctx_inclusion. + * by apply renaming_heap_ctx_inclusion. + - (* loc *) + econstructor; by eapply lookup_weaken. +Qed. + +Lemma type_wf_subst_dom σ τ n A: + type_wf n A → + (∀ m, m < n → σ m = τ m) → + A.[σ] = A.[τ]. +Proof. + induction 1 in σ, τ |-*; simpl; eauto. + - (* tforall *) + intros Heq; asimpl. f_equal. + eapply IHtype_wf; intros [|m]; rewrite /up; simpl; first done. + intros Hlt. f_equal. eapply Heq. lia. + - (* texists *) + intros Heq; asimpl. f_equal. + eapply IHtype_wf. intros [ | m]; rewrite /up; simpl; first done. + intros Hlt. f_equal. apply Heq. lia. + - (* fun *) intros ?. f_equal; eauto. + - (* prod *) intros ?. f_equal; eauto. + - (* sum *) intros ?. f_equal; eauto. + - (* rec *) + intros Heq; asimpl. f_equal. + eapply IHtype_wf; intros [|m]; rewrite /up; simpl; first done. + intros Hlt. f_equal. eapply Heq. lia. + - (* ref *) + intros ?. f_equal. eapply IHtype_wf. done. +Qed. + +Lemma type_wf_closed A σ: + type_wf 0 A → + A.[σ] = A. +Proof. + intros Hwf; erewrite (type_wf_subst_dom _ (ids) 0). + - by asimpl. + - done. + - intros ??; lia. +Qed. + +Lemma heap_ctx_closed Σ σ: + heap_ctx_wf 0 Σ → + fmap (subst σ) Σ = Σ. +Proof. + intros Hwf. eapply stdpp.fin_maps.map_eq; intros l. + rewrite lookup_fmap. destruct lookup as [A|]eqn: H; last done; simpl. + f_equal. eapply type_wf_closed. by eapply Hwf. +Qed. + + + +(** Typing inversion lemmas *) +Lemma var_inversion Σ Γ n (x: string) A: TY Σ; n; Γ ⊢ x : A → Γ !! x = Some A. +Proof. inversion 1; subst; auto. Qed. + +Lemma lam_inversion Σ n Γ (x: string) e C: + TY Σ; n; Γ ⊢ (λ: x, e) : C → + ∃ A B, C = (A → B)%ty ∧ type_wf n A ∧ TY Σ; n; <[x:=A]> Γ ⊢ e : B. +Proof. inversion 1; subst; eauto 10. Qed. + +Lemma lam_anon_inversion Σ n Γ e C: + TY Σ; n; Γ ⊢ (λ: <>, e) : C → + ∃ A B, C = (A → B)%ty ∧ type_wf n A ∧ TY Σ; n; Γ ⊢ e : B. +Proof. inversion 1; subst; eauto 10. Qed. + +Lemma app_inversion Σ n Γ e1 e2 B: + TY Σ; n; Γ ⊢ e1 e2 : B → + ∃ A, TY Σ; n; Γ ⊢ e1 : (A → B) ∧ TY Σ; n; Γ ⊢ e2 : A. +Proof. inversion 1; subst; eauto. Qed. + +Lemma if_inversion Σ n Γ e0 e1 e2 B: + TY Σ; n; Γ ⊢ If e0 e1 e2 : B → + TY Σ; n; Γ ⊢ e0 : Bool ∧ TY Σ; n; Γ ⊢ e1 : B ∧ TY Σ; n; Γ ⊢ e2 : B. +Proof. inversion 1; subst; eauto. Qed. + +Lemma binop_inversion Σ n Γ op e1 e2 B: + TY Σ; n; Γ ⊢ BinOp op e1 e2 : B → + ∃ A1 A2, bin_op_typed op A1 A2 B ∧ TY Σ; n; Γ ⊢ e1 : A1 ∧ TY Σ; n; Γ ⊢ e2 : A2. +Proof. inversion 1; subst; eauto. Qed. + +Lemma unop_inversion Σ n Γ op e B: + TY Σ; n; Γ ⊢ UnOp op e : B → + ∃ A, un_op_typed op A B ∧ TY Σ; n; Γ ⊢ e : A. +Proof. inversion 1; subst; eauto. Qed. + +Lemma type_app_inversion Σ n Γ e B: + TY Σ; n; Γ ⊢ e <> : B → + ∃ A C, B = A.[C/] ∧ type_wf n C ∧ TY Σ; n; Γ ⊢ e : (∀: A). +Proof. inversion 1; subst; eauto. Qed. + +Lemma type_lam_inversion Σ n Γ e B: + TY Σ; n; Γ ⊢ (Λ,e) : B → + ∃ A, B = (∀: A)%ty ∧ TY ⤉Σ; (S n); ⤉Γ ⊢ e : A. +Proof. inversion 1; subst; eauto. Qed. + +Lemma type_pack_inversion Σ n Γ e B : + TY Σ; n; Γ ⊢ (pack e) : B → + ∃ A C, B = (∃: A)%ty ∧ TY Σ; n; Γ ⊢ e : (A.[C/])%ty ∧ type_wf n C ∧ type_wf (S n) A. +Proof. inversion 1; subst; eauto 10. Qed. + +Lemma type_unpack_inversion Σ n Γ e e' x B : + TY Σ; n; Γ ⊢ (unpack e as x in e') : B → + ∃ A x', x = BNamed x' ∧ type_wf n B ∧ TY Σ; n; Γ ⊢ e : (∃: A) ∧ TY ⤉Σ; S n; <[x' := A]> (⤉Γ) ⊢ e' : (B.[ren (+1)]). +Proof. inversion 1; subst; eauto 10. Qed. + +Lemma pair_inversion Σ n Γ e1 e2 C : + TY Σ; n; Γ ⊢ (e1, e2) : C → + ∃ A B, C = (A × B)%ty ∧ TY Σ; n; Γ ⊢ e1 : A ∧ TY Σ; n; Γ ⊢ e2 : B. +Proof. inversion 1; subst; eauto. Qed. + +Lemma fst_inversion Σ n Γ e A : + TY Σ; n; Γ ⊢ Fst e : A → + ∃ B, TY Σ; n; Γ ⊢ e : A × B. +Proof. inversion 1; subst; eauto. Qed. + +Lemma snd_inversion Σ n Γ e B : + TY Σ; n; Γ ⊢ Snd e : B → + ∃ A, TY Σ; n; Γ ⊢ e : A × B. +Proof. inversion 1; subst; eauto. Qed. + +Lemma injl_inversion Σ n Γ e C : + TY Σ; n; Γ ⊢ InjL e : C → + ∃ A B, C = (A + B)%ty ∧ TY Σ; n; Γ ⊢ e : A ∧ type_wf n B. +Proof. inversion 1; subst; eauto. Qed. + +Lemma injr_inversion Σ n Γ e C : + TY Σ; n; Γ ⊢ InjR e : C → + ∃ A B, C = (A + B)%ty ∧ TY Σ; n; Γ ⊢ e : B ∧ type_wf n A. +Proof. inversion 1; subst; eauto. Qed. + +Lemma case_inversion Σ n Γ e e1 e2 A : + TY Σ; n; Γ ⊢ Case e e1 e2 : A → + ∃ B C, TY Σ; n; Γ ⊢ e : B + C ∧ TY Σ; n; Γ ⊢ e1 : (B → A) ∧ TY Σ; n; Γ ⊢ e2 : (C → A). +Proof. inversion 1; subst; eauto. Qed. + +Lemma roll_inversion Σ n Γ e B: + TY Σ; n; Γ ⊢ (roll e) : B → + ∃ A, B = (μ: A)%ty ∧ TY Σ; n; Γ ⊢ e : A.[μ: A/]. +Proof. inversion 1; subst; eauto. Qed. + +Lemma unroll_inversion Σ n Γ e B: + TY Σ; n; Γ ⊢ (unroll e) : B → + ∃ A, B = (A.[μ: A/])%ty ∧ TY Σ; n; Γ ⊢ e : μ: A. +Proof. inversion 1; subst; eauto. Qed. + +Lemma new_inversion Σ n Γ e B : + TY Σ; n; Γ ⊢ (new e) : B → + ∃ A, B = Ref A ∧ TY Σ; n; Γ ⊢ e : A. +Proof. inversion 1; subst; eauto. Qed. + +Lemma load_inversion Σ n Γ e B: + TY Σ; n; Γ ⊢ ! e : B → + TY Σ; n; Γ ⊢ e : Ref B. +Proof. inversion 1; subst; eauto. Qed. + +Lemma store_inversion Σ n Γ e1 e2 B: + TY Σ; n; Γ ⊢ (e1 <- e2) : B → + ∃ A, B = Unit ∧ TY Σ; n; Γ ⊢ e1 : Ref A ∧ TY Σ; n; Γ ⊢ e2 : A. +Proof. inversion 1; subst; eauto. Qed. + +Lemma typed_substitutivity Σ n e e' Γ (x: string) A B : + heap_ctx_wf 0 Σ → + TY Σ; 0; ∅ ⊢ e' : A → + TY Σ; n; (<[x := A]> Γ) ⊢ e : B → + TY Σ; n; Γ ⊢ lang.subst x e' e : B. +Proof. + intros HwfΣ He'. induction e as [| y | y | | | | | | | | | | | | | | | | | | | ] in n, B, Γ |-*; simpl. + - inversion 1; subst; auto. + - intros Hp % var_inversion. + destruct (decide (x = y)). + + subst. rewrite lookup_insert in Hp. injection Hp as ->. + eapply typed_weakening; [done| | done |lia]. apply map_empty_subseteq. + + rewrite lookup_insert_ne in Hp; last done. auto. + - destruct y as [ | y]. + { intros (A' & C & -> & Hwf & Hty) % lam_anon_inversion. + econstructor; last done. destruct decide as [Heq|]. + + congruence. + + eauto. + } + intros (A' & C & -> & Hwf & Hty) % lam_inversion. + econstructor; last done. destruct decide as [Heq|]. + + injection Heq as [= ->]. by rewrite insert_insert in Hty. + + rewrite insert_commute in Hty; last naive_solver. eauto. + - intros (C & Hty1 & Hty2) % app_inversion. eauto. + - intros (? & Hop & H1) % unop_inversion. + destruct op; inversion Hop; subst; eauto. + - intros (? & ? & Hop & H1 & H2) % binop_inversion. + destruct op; inversion Hop; subst; eauto. + - intros (H1 & H2 & H3)%if_inversion. naive_solver. + - intros (C & D & -> & Hwf & Hty) % type_app_inversion. eauto. + - intros (C & -> & Hty)%type_lam_inversion. econstructor. + rewrite heap_ctx_closed //=. + eapply IHe. revert Hty. rewrite fmap_insert. + eapply syn_typed_wf in He'; eauto. + rewrite heap_ctx_closed //=. + rewrite type_wf_closed; eauto. + - intros (C & D & -> & Hty & Hwf1 & Hwf2)%type_pack_inversion. + econstructor; [done..|]. apply IHe. done. + - intros (C & x' & -> & Hwf & Hty1 & Hty2)%type_unpack_inversion. + econstructor; first done. + + eapply IHe1. done. + + destruct decide as [Heq | ]. + * injection Heq as [= ->]. by rewrite fmap_insert insert_insert in Hty2. + * rewrite fmap_insert in Hty2. rewrite insert_commute in Hty2; last naive_solver. + revert Hty2. rewrite heap_ctx_closed//=. intros Hty2. + eapply IHe2. rewrite type_wf_closed in Hty2; first done. + eapply syn_typed_wf; last apply He'; eauto. + - intros (? & ? & -> & ? & ?) % pair_inversion. eauto. + - intros (? & ?)%fst_inversion. eauto. + - intros (? & ?)%snd_inversion. eauto. + - intros (? & ? & -> & ? & ?)%injl_inversion. eauto. + - intros (? & ? & -> & ? & ?)%injr_inversion. eauto. + - intros (? & ? & ? & ? & ?)%case_inversion. eauto. + - intros (C & -> & Hty) % roll_inversion. eauto. + - intros (C & -> & Hty) % unroll_inversion. eauto. + - intros Hty % load_inversion. eauto. + - intros (C & -> & Hty1 & Hty2)% store_inversion. eauto. + - intros (C & -> & Hty) % new_inversion. eauto. +Qed. + +(** Canonical values *) +Lemma canonical_values_arr Σ n Γ e A B: + TY Σ; n; Γ ⊢ e : (A → B) → + is_val e → + ∃ x e', e = (λ: x, e')%E. +Proof. + inversion 1; simpl; naive_solver. +Qed. + +Lemma canonical_values_forall Σ n Γ e A: + TY Σ; n; Γ ⊢ e : (∀: A)%ty → + is_val e → + ∃ e', e = (Λ, e')%E. +Proof. + inversion 1; simpl; naive_solver. +Qed. + +Lemma canonical_values_exists Σ n Γ e A : + TY Σ; n; Γ ⊢ e : (∃: A) → + is_val e → + ∃ e', e = (pack e')%E. +Proof. inversion 1; simpl; naive_solver. Qed. + +Lemma canonical_values_int Σ n Γ e: + TY Σ; n; Γ ⊢ e : Int → + is_val e → + ∃ n: Z, e = (#n)%E. +Proof. + inversion 1; simpl; naive_solver. +Qed. + +Lemma canonical_values_bool Σ n Γ e: + TY Σ; n; Γ ⊢ e : Bool → + is_val e → + ∃ b: bool, e = (#b)%E. +Proof. + inversion 1; simpl; naive_solver. +Qed. + +Lemma canonical_values_unit Σ n Γ e: + TY Σ; n; Γ ⊢ e : Unit → + is_val e → + e = (#LitUnit)%E. +Proof. + inversion 1; simpl; naive_solver. +Qed. + +Lemma canonical_values_prod Σ n Γ e A B : + TY Σ; n; Γ ⊢ e : A × B → + is_val e → + ∃ e1 e2, e = (e1, e2)%E ∧ is_val e1 ∧ is_val e2. +Proof. + inversion 1; simpl; naive_solver. +Qed. + +Lemma canonical_values_sum Σ n Γ e A B : + TY Σ; n; Γ ⊢ e : A + B → + is_val e → + (∃ e', e = InjL e' ∧ is_val e') ∨ (∃ e', e = InjR e' ∧ is_val e'). +Proof. + inversion 1; simpl; naive_solver. +Qed. + +Lemma canonical_values_rec Σ n Γ e A: + TY Σ; n; Γ ⊢ e : (μ: A) → + is_val e → + ∃ e', e = (roll e')%E ∧ is_val e'. +Proof. + inversion 1; simpl; subst; naive_solver. +Qed. + +Lemma canonical_values_ref Σ n Γ e A: + TY Σ; n; Γ ⊢ e : Ref A → + is_val e → + ∃ l: loc, e = (#l)%E ∧ Σ !! l = Some A. +Proof. + inversion 1; simpl; subst; naive_solver. +Qed. + +(** Progress *) +Definition heap_type (h: heap) Σ := + ∀ l A, Σ !! l = Some A → ∃ v, h !! l = Some v ∧ TY Σ; 0; ∅ ⊢ of_val v : A. + +Lemma typed_progress Σ e h A: + heap_type h Σ → + TY Σ; 0; ∅ ⊢ e : A → + is_val e ∨ reducible e h. +Proof. + intros Hheap. remember ∅ as Γ. remember 0 as n. + induction 1 as [| | | | Σ n Γ A B e Hty IH | Σ n Γ A B e Hwf Hwf' Hty IH | Σ n Γ A B e e' x Hwf Hty1 IH1 Hty2 IH2 | | | | Σ n Γ e0 e1 e2 A Hty1 IH1 Hty2 IH2 Hty3 IH3 | Σ n Γ e1 e2 A B Hty IH1 _ IH2 | Σ n Γ e1 e2 op A B C Hop Hty1 IH1 Hty2 IH2 | Σ n Γ e op A B Hop Hty IH | Σ n Γ e1 e2 A B Hty1 IH1 Hty2 IH2 | Σ n Γ e A B Hty IH | Σ n Γ e A B Hty IH | Σ n Γ e A B Hwf Hty IH | Σ n Γ e A B Hwf Hty IH| Σ n Γ e e1 e2 A B C Htye IHe Htye1 IHe1 Htye2 IHe2 | Σ n Γ e A Hty IH | Σ n Γ e A Hty IH | Σ n Γ l A Hlook | Σ n Γ e A Hty IH | Σ n Γ e1 e2 A Hty1 IH1 Hty2 IH2 | Σ n Γ e A Hty IH ]. + - subst. naive_solver. + - left. done. + - left. done. + - left; done. + - right. destruct (IH Hheap HeqΓ Heqn) as [H1|H1]. + + eapply canonical_values_forall in Hty as [e' ->]; last done. + eexists _, _. eapply base_contextual_step. eapply TBetaS. + + destruct H1 as (e' & h' & H1). eexists _, _. + eapply (fill_contextual_step [TAppCtx]). done. + - (* pack *) + destruct (IH Hheap HeqΓ Heqn) as [H | H]. + + by left. + + right. destruct H as (e' & h' & H). eexists _, _. eapply (fill_contextual_step [PackCtx]). done. + - (* unpack *) + destruct (IH1 Hheap HeqΓ Heqn) as [H | H]. + + eapply canonical_values_exists in Hty1 as [e'' ->]; last done. + right. eexists _, _. eapply base_contextual_step. constructor; last done. + done. + + right. destruct H as (e'' & h'' & H). eexists _, _. + eapply (fill_contextual_step [UnpackCtx _ _]). done. + - (* int *)left. done. + - (* bool*) left. done. + - (* unit *) left. done. + - (* if *) + destruct (IH1 Hheap HeqΓ Heqn) as [H1 | H1]. + + eapply canonical_values_bool in Hty1 as (b & ->); last done. + right. destruct b; eexists _, _; eapply base_contextual_step; constructor. + + right. destruct H1 as (e0' & h' & Hstep). + eexists _, _. by eapply (fill_contextual_step [IfCtx _ _]). + - (* app *) + destruct (IH2 Hheap HeqΓ Heqn) as [H2|H2]; [destruct (IH1 Hheap HeqΓ Heqn) as [H1|H1]|]. + + eapply canonical_values_arr in Hty as (x & e & ->); last done. + right. eexists _, _. + eapply base_contextual_step, BetaS; eauto. + + right. eapply is_val_spec in H2 as [v Heq]. + replace e2 with (of_val v); last by eapply of_to_val. + destruct H1 as (e1' & h' & Hstep). + eexists _, _. eapply (fill_contextual_step [AppLCtx v]). done. + + right. destruct H2 as (e2' & h' & H2). + eexists _, _. eapply (fill_contextual_step [AppRCtx e1]). done. + - (* binop *) + assert (A = Int ∧ B = Int) as [-> ->]. + { inversion Hop; subst A B C; done. } + destruct (IH2 Hheap HeqΓ Heqn) as [H2|H2]; [destruct (IH1 Hheap HeqΓ Heqn) as [H1|H1]|]. + + right. eapply canonical_values_int in Hty1 as [n1 ->]; last done. + eapply canonical_values_int in Hty2 as [n2 ->]; last done. + inversion Hop; subst; simpl. + all: eexists _, _; eapply base_contextual_step; eapply BinOpS; eauto. + + right. eapply is_val_spec in H2 as [v Heq]. + replace e2 with (of_val v); last by eapply of_to_val. + destruct H1 as (e1' & h' & Hstep). + eexists _, _. eapply (fill_contextual_step [BinOpLCtx op v]). done. + + right. destruct H2 as (e2' & h' & H2). + eexists _, _. eapply (fill_contextual_step [BinOpRCtx op e1]). done. + - (* unop *) + inversion Hop; subst A B op. + + right. destruct (IH Hheap HeqΓ Heqn) as [H2 | H2]. + * eapply canonical_values_bool in Hty as [b ->]; last done. + eexists _, _; eapply base_contextual_step; eapply UnOpS; eauto. + * destruct H2 as (e' & h' & H2). eexists _, _. + eapply (fill_contextual_step [UnOpCtx _]). done. + + right. destruct (IH Hheap HeqΓ Heqn) as [H2 | H2]. + * eapply canonical_values_int in Hty as [z ->]; last done. + eexists _, _; eapply base_contextual_step; eapply UnOpS; eauto. + * destruct H2 as (e' & h' & H2). eexists _, _. + eapply (fill_contextual_step [UnOpCtx _]). done. + - (* pair *) + destruct (IH2 Hheap HeqΓ Heqn) as [H2|H2]; [destruct (IH1 Hheap HeqΓ Heqn) as [H1|H1]|]. + + left. done. + + right. eapply is_val_spec in H2 as [v Heq]. + replace e2 with (of_val v); last by eapply of_to_val. + destruct H1 as (e1' & h' & Hstep). + eexists _, _. eapply (fill_contextual_step [PairLCtx v]). done. + + right. destruct H2 as (e2' & h' & H2). + eexists _, _. eapply (fill_contextual_step [PairRCtx e1]). done. + - (* fst *) + destruct (IH Hheap HeqΓ Heqn) as [H | H]. + + eapply canonical_values_prod in Hty as (e1 & e2 & -> & ? & ?); last done. + right. eexists _, _. eapply base_contextual_step. econstructor; done. + + right. destruct H as (e' & h' & H). + eexists _, _. eapply (fill_contextual_step [FstCtx]). done. + - (* snd *) + destruct (IH Hheap HeqΓ Heqn) as [H | H]. + + eapply canonical_values_prod in Hty as (e1 & e2 & -> & ? & ?); last done. + right. eexists _, _. eapply base_contextual_step. econstructor; done. + + right. destruct H as (e' & h' & H). + eexists _, _. eapply (fill_contextual_step [SndCtx]). done. + - (* injl *) + destruct (IH Hheap HeqΓ Heqn) as [H | H]. + + left. done. + + right. destruct H as (e' & h' & H). + eexists _, _. eapply (fill_contextual_step [InjLCtx]). done. + - (* injr *) + destruct (IH Hheap HeqΓ Heqn) as [H | H]. + + left. done. + + right. destruct H as (e' & h' & H). + eexists _, _. eapply (fill_contextual_step [InjRCtx]). done. + - (* case *) + right. destruct (IHe Hheap HeqΓ Heqn) as [H1|H1]. + + eapply canonical_values_sum in Htye as [(e' & -> & ?) | (e' & -> & ?)]; last done. + * eexists _, _. eapply base_contextual_step. econstructor. done. + * eexists _, _. eapply base_contextual_step. econstructor. done. + + destruct H1 as (e' & h' & H1). eexists _, _. + eapply (fill_contextual_step [CaseCtx e1 e2]). done. + - (* roll *) + destruct (IH Hheap HeqΓ Heqn) as [Hval|Hred]. + + by left. + + right. destruct Hred as (e' & h' & Hred). + eexists _, _. eapply (fill_contextual_step [RollCtx]). done. + - (* unroll *) + destruct (IH Hheap HeqΓ Heqn) as [Hval|Hred]. + + eapply canonical_values_rec in Hty as (e' & -> & Hval'); last done. + right. eexists _, _. eapply base_contextual_step. by econstructor. + + right. destruct Hred as (e' & h' & Hred). + eexists _, _. eapply (fill_contextual_step [UnrollCtx]). done. + - (* loc *) + by left. + - (* load *) + destruct (IH Hheap HeqΓ Heqn) as [Hval|Hred]. + + eapply canonical_values_ref in Hty as (l & -> & Hlook); last done. + eapply Hheap in Hlook as (v & Hlook & Hty'). + right. do 2 eexists. eapply base_contextual_step. by econstructor. + + right. destruct Hred as (e' & h' & Hred). + do 2 eexists. eapply (fill_contextual_step [LoadCtx]). done. + - (* store *) + destruct (IH2 Hheap HeqΓ Heqn) as [H2|H2]; [destruct (IH1 Hheap HeqΓ Heqn) as [H1|H1]|]. + + right. eapply canonical_values_ref in Hty1 as (l & -> & Hlook); last done. + eapply Hheap in Hlook as (v & Hlook & Hty'). + eapply is_val_spec in H2 as (w & Heq). + do 2 eexists. eapply base_contextual_step. + econstructor; eauto. + + right. eapply is_val_spec in H2 as [v Heq]. + replace e2 with (of_val v); last by eapply of_to_val. + destruct H1 as (e1' & h' & Hstep). + do 2 eexists. eapply (fill_contextual_step [StoreLCtx v]). done. + + right. destruct H2 as (e2' & h' & H2). + do 2 eexists. eapply (fill_contextual_step [StoreRCtx e1]). done. + - (* new *) + destruct (IH Hheap HeqΓ Heqn) as [Hval|Hred]. + + right. eapply is_val_spec in Hval as [v Heq]. + do 2 eexists. eapply base_contextual_step. + eapply (NewS _ _ _ (fresh (dom h))); last done. + eapply not_elem_of_dom, is_fresh. + + right. destruct Hred as (e' & h' & Hred). + do 2 eexists. eapply (fill_contextual_step [NewCtx]). done. +Qed. + +Definition ectx_item_typing Σ (K: ectx_item) (A B: type) := + ∀ e Σ', Σ ⊆ Σ' → TY Σ'; 0; ∅ ⊢ e : A → TY Σ'; 0; ∅ ⊢ (fill_item K e) : B. + +Notation ectx := (list ectx_item). +Definition ectx_typing Σ (K: ectx) (A B: type) := + ∀ e Σ', Σ ⊆ Σ' → TY Σ'; 0; ∅ ⊢ e : A → TY Σ'; 0; ∅ ⊢ (fill K e) : B. + +Lemma ectx_item_typing_weaking Σ Σ' k B A : + Σ ⊆ Σ' → ectx_item_typing Σ k B A → ectx_item_typing Σ' k B A. +Proof. + intros Hsub Hty e Σ'' Hsub'' Hty'. eapply Hty; last done. + by transitivity Σ'. +Qed. + +Lemma ectx_typing_weaking Σ Σ' K B A : + Σ ⊆ Σ' → ectx_typing Σ K B A → ectx_typing Σ' K B A. +Proof. + intros Hsub Hty e Σ'' Hsub'' Hty'. eapply Hty; last done. + by transitivity Σ'. +Qed. + +Lemma fill_item_typing_decompose Σ k e A: + TY Σ; 0; ∅ ⊢ fill_item k e : A → + ∃ B, TY Σ; 0; ∅ ⊢ e : B ∧ ectx_item_typing Σ k B A. +Proof. + unfold ectx_item_typing; destruct k; simpl; inversion 1; subst; eauto 6 using typed_weakening, map_fmap_mono. +Qed. + +Lemma fill_typing_decompose Σ K e A: + TY Σ; 0; ∅ ⊢ fill K e : A → + ∃ B, TY Σ; 0; ∅ ⊢ e : B ∧ ectx_typing Σ K B A. +Proof. + unfold ectx_typing; revert e; induction K as [|k K]; intros e; simpl; eauto. + intros [B [Hit Hty]] % IHK. + eapply fill_item_typing_decompose in Hit as [B' [? ?]]; eauto. +Qed. + +Lemma fill_typing_compose Σ K e A B: + TY Σ; 0; ∅ ⊢ e : B → + ectx_typing Σ K B A → + TY Σ; 0; ∅ ⊢ fill K e : A. +Proof. + intros H1 H2; by eapply H2. +Qed. + +Lemma fmap_up_subst_ctx σ Γ: ⤉(subst σ <$> Γ) = subst (up σ) <$> ⤉Γ. +Proof. + rewrite -!map_fmap_compose. + eapply map_fmap_ext. intros x A _. by asimpl. +Qed. + +Lemma fmap_up_subst_heap_ctx σ Σ: ⤉(subst σ <$> Σ) = subst (up σ) <$> ⤉Σ. +Proof. + rewrite -!map_fmap_compose. + eapply map_fmap_ext. intros x A _. by asimpl. +Qed. + +Lemma typed_subst_type Σ n m Γ e A σ: + TY Σ; n; Γ ⊢ e : A → (∀ k, k < n → type_wf m (σ k)) → TY (subst σ) <$> Σ; m; (subst σ) <$> Γ ⊢ e : A.[σ]. +Proof. + induction 1 as [ Σ n Γ x A Heq | | | Σ n Γ e A Hty IH | | Σ n Γ A B e Hwf Hwf' Hty IH | Σ n Γ A B e e' x Hwf Hty1 IH1 Hty2 IH2 | | | | | |? ? ? ? ? ? ? ? ? Hop | ? ? ? ? ? ? ? Hop | | | | | | | | | | | | ] in σ, m |-*; simpl; intros Hlt; eauto. + - econstructor. rewrite lookup_fmap Heq //=. + - econstructor; last by eapply type_wf_subst. + rewrite -fmap_insert. eauto. + - econstructor; last by eapply type_wf_subst. eauto. + - econstructor. rewrite fmap_up_subst_ctx fmap_up_subst_heap_ctx. eapply IH. + intros [| x] Hlt'; rewrite /up //=. + + econstructor. lia. + + eapply type_wf_rename; last by (intros ???; simpl; lia). + eapply Hlt. lia. + - replace (A.[B/].[σ]) with (A.[up σ].[B.[σ]/]) by by asimpl. + eauto using type_wf_subst. + - (* pack *) + eapply (typed_pack _ _ _ _ (subst σ B)). + + eapply type_wf_subst; done. + + eapply type_wf_subst; first done. + intros [ | k] Hk; first ( asimpl;constructor; lia). + rewrite /up //=. eapply type_wf_rename; last by (intros ???; simpl; lia). + eapply Hlt. lia. + + replace (A.[up σ].[B.[σ]/]) with (A.[B/].[σ]) by by asimpl. + eauto using type_wf_subst. + - (* unpack *) + eapply (typed_unpack _ _ _ A.[up σ]). + + eapply type_wf_subst; done. + + replace (∃: A.[up σ])%ty with ((∃: A).[σ])%ty by by asimpl. + eapply IH1. done. + + rewrite fmap_up_subst_ctx fmap_up_subst_heap_ctx. rewrite -fmap_insert. + replace (B.[σ].[ren (+1)]) with (B.[ren(+1)].[up σ]) by by asimpl. + eapply IH2. + intros [ | k] Hk; asimpl; first (constructor; lia). + eapply type_wf_subst; first (eapply Hlt; lia). + intros k' Hk'. asimpl. constructor. lia. + - (* binop *) + inversion Hop; subst. + all: econstructor; naive_solver. + - (* unop *) + inversion Hop; subst. + all: econstructor; naive_solver. + - econstructor; last naive_solver. by eapply type_wf_subst. + - econstructor; last naive_solver. by eapply type_wf_subst. + - (* roll *) + econstructor. + replace (A.[up σ].[μ: A.[up σ]/])%ty with (A.[μ: A/].[σ])%ty by by asimpl. eauto. + - (* unroll *) + replace (A.[μ: A/].[σ])%ty with (A.[up σ].[μ: A.[up σ]/])%ty by by asimpl. + econstructor. eapply IHsyn_typed. done. + - (* loc *) + econstructor. rewrite lookup_fmap H //=. +Qed. + +Lemma typed_subst_type_closed Σ C e A: + type_wf 0 C → + heap_ctx_wf 0 Σ → + TY ⤉Σ; 1; ⤉∅ ⊢ e : A → TY Σ; 0; ∅ ⊢ e : A.[C/]. +Proof. + intros Hwf Hwf' Hty. eapply typed_subst_type with (σ := C .: ids) (m := 0) in Hty; last first. + { intros [|k] Hlt; last lia. done. } + revert Hty. rewrite !fmap_empty. + rewrite !(heap_ctx_closed Σ); eauto. +Qed. + +Lemma typed_subst_type_closed' Σ x C B e A: + type_wf 0 A → + type_wf 1 C → + type_wf 0 B → + heap_ctx_wf 0 Σ → + TY ⤉Σ; 1; <[x := C]> ∅ ⊢ e : A → + TY Σ; 0; <[x := C.[B/]]> ∅ ⊢ e : A. +Proof. + intros ???? Hty. + set (s := (subst (B.:ids))). + rewrite -(fmap_empty s) -(fmap_insert s). + replace A with (A.[B/]). + 2: { replace A with (A.[ids]) at 2 by by asimpl. + eapply type_wf_subst_dom; first done. lia. + } + rewrite -(heap_ctx_closed Σ (B.:ids)); last done. + eapply typed_subst_type. + { rewrite -(heap_ctx_closed Σ (ren (+1))); done. } + intros [ | k] Hk; last lia. done. +Qed. + +Lemma heap_ctx_insert h l A Σ: + heap_type h Σ → h !! l = None → Σ ⊆ <[l:=A]> Σ. +Proof. + intros Hheap Hlook. eapply insert_subseteq. + specialize (Hheap l). destruct (lookup) as [B|]; last done. + specialize (Hheap B eq_refl) as (w & Hsome & _). congruence. +Qed. + +Lemma heap_type_insert h Σ e v l B : + heap_type h Σ → + h !! l = None → + TY Σ; 0; ∅ ⊢ e : B → + to_val e = Some v → + heap_type ({[l := v]} ∪ h) (<[l:=B]> Σ). +Proof. + intros Hheap Hlook Hty Hval l' A. rewrite lookup_insert_Some. + intros [(-> & ->)|(Hne & Hlook')]. + - exists v. split; first eapply lookup_union_Some_l, lookup_insert. + eapply of_to_val in Hval as ->. + eapply typed_weakening; first eapply Hty; eauto. + by eapply heap_ctx_insert. + - eapply Hheap in Hlook' as (w & Hlook' & Hty'). + eexists; split. + + rewrite lookup_union_r; eauto. + rewrite lookup_insert_ne //=. + + eapply typed_weakening; first eapply Hty'; eauto. + by eapply heap_ctx_insert. +Qed. + +Lemma heap_type_update h Σ e v l B : + heap_type h Σ → + Σ !! l = Some B → + TY Σ; 0; ∅ ⊢ e : B → + to_val e = Some v → + heap_type (<[l:=v]> h) Σ. +Proof. + intros Hheap Hlook Hty Hval l' A Hlook'. + eapply Hheap in Hlook' as Hlook''. + destruct Hlook'' as (w & Hold & Hval'). + destruct (decide (l = l')); subst. + - exists v. split; first eapply lookup_insert. + eapply of_to_val in Hval as ->. + rewrite Hlook in Hlook'. by injection Hlook' as ->. + - rewrite lookup_insert_ne //=. eauto. +Qed. + + + +Lemma typed_preservation_base_step Σ e e' h h' A: + heap_ctx_wf 0 Σ → + TY Σ; 0; ∅ ⊢ e : A → + heap_type h Σ → + base_step (e, h) (e', h') → + ∃ Σ', Σ ⊆ Σ' ∧ heap_type h' Σ' ∧ heap_ctx_wf 0 Σ' ∧ TY Σ'; 0; ∅ ⊢ e' : A. +Proof. + intros Hwf' Hty Hhty Hstep. inversion Hstep as [ | | | op e1 v v' h1 Heq Heval | op e1 v1 e2 v2 v3 h1 Heq1 Heq2 Heval | | | | | | | | | | ]; subst. + - eapply app_inversion in Hty as (B & H1 & H2). + destruct x as [|x]. + { eapply lam_anon_inversion in H1 as (C & D & [= -> ->] & Hwf & Hty). + exists Σ. do 3 (split; first done). done. } + eapply lam_inversion in H1 as (C & D & Heq & Hwf & Hty). + injection Heq as -> ->. + exists Σ. do 3 (split; first done). + eapply typed_substitutivity; eauto. + - eapply type_app_inversion in Hty as (B & C & -> & Hwf & Hty). + eapply type_lam_inversion in Hty as (A & Heq & Hty). + injection Heq as ->. exists Σ. split_and!; [done.. | ]. by eapply typed_subst_type_closed. + - eapply type_unpack_inversion in Hty as (B & x' & -> & Hwf & Hty1 & Hty2). + eapply type_pack_inversion in Hty1 as (B' & C & [= <-] & Hty1 & ? & ?). + exists Σ. split_and!; [done.. | ]. + eapply typed_substitutivity. + { done. } + { apply Hty1. } + rewrite fmap_empty in Hty2. + eapply typed_subst_type_closed'; eauto. + replace A with A.[ids] by by asimpl. + enough (A.[ids] = A.[ren (+1)]) as -> by done. + eapply type_wf_subst_dom; first done. intros; lia. + - (* unop *) + eapply unop_inversion in Hty as (A1 & Hop & Hty). + assert ((A1 = Int ∧ A = Int) ∨ (A1 = Bool ∧ A = Bool)) as [(-> & ->) | (-> & ->)]. + { inversion Hop; subst; eauto. } + + eapply canonical_values_int in Hty as [n ->]; last by eapply is_val_spec; eauto. + simpl in Heq. injection Heq as <-. + exists Σ; split_and!; [done..|]. + inversion Hop; subst; simpl in *; injection Heval as <-; constructor. + + eapply canonical_values_bool in Hty as [b ->]; last by eapply is_val_spec; eauto. + simpl in Heq. injection Heq as <-. + exists Σ; split_and!; [done..|]. + inversion Hop; subst; simpl in *; injection Heval as <-; constructor. + - (* binop *) + eapply binop_inversion in Hty as (A1 & A2 & Hop & Hty1 & Hty2). + assert (A1 = Int ∧ A2 = Int ∧ (A = Int ∨ A = Bool)) as (-> & -> & HC). + { inversion Hop; subst; eauto. } + eapply canonical_values_int in Hty1 as [n ->]; last by eapply is_val_spec; eauto. + eapply canonical_values_int in Hty2 as [m ->]; last by eapply is_val_spec; eauto. + simpl in Heq1, Heq2. injection Heq1 as <-. injection Heq2 as <-. + simpl in Heval. + exists Σ; split_and!; [done..|]. + inversion Hop; subst; simpl in *; injection Heval as <-; constructor. + - exists Σ; split_and!; [done..|]. + by eapply if_inversion in Hty as (H1 & H2 & H3). + - exists Σ; split_and!; [done..|]. + by eapply if_inversion in Hty as (H1 & H2 & H3). + - exists Σ; split_and!; [done..|]. + by eapply fst_inversion in Hty as (B & (? & ? & [= <- <-] & ? & ?)%pair_inversion). + - exists Σ; split_and!; [done..|]. + by eapply snd_inversion in Hty as (B & (? & ? & [= <- <-] & ? & ?)%pair_inversion). + - exists Σ; split_and!; [done..|]. + eapply case_inversion in Hty as (B & C & (? & ? & [= <- <-] & Hty & ?)%injl_inversion & ? & ?). + eauto. + - exists Σ; split_and!; [done..|]. + eapply case_inversion in Hty as (B & C & (? & ? & [= <- <-] & Hty & ?)%injr_inversion & ? & ?). + eauto. + - (* unroll *) + exists Σ; split_and!; [done..|]. + eapply unroll_inversion in Hty as (B & -> & Hty). + eapply roll_inversion in Hty as (C & Heq & Hty). injection Heq as ->. done. + +- (* new *) + eapply new_inversion in Hty as (B & -> & Hty). + exists (<[l := B]> Σ). repeat split. + + by eapply heap_ctx_insert. + + rewrite /init_heap; simpl; rewrite right_id. + by eapply heap_type_insert. + + eapply heap_ctx_wf_insert; first done. + eapply syn_typed_wf; eauto. + + econstructor. by rewrite lookup_insert. + - (* load *) + exists Σ. do 3 (split; first done). + eapply load_inversion in Hty. + eapply canonical_values_ref in Hty as (l' & Heq & Hlook); last done. + injection Heq as <-. eapply Hhty in Hlook as (w & Hlook & Hty). + naive_solver. + - (* store *) + eapply store_inversion in Hty as (B & -> & Hty1 & Hty2). + exists Σ. repeat split; try eauto. + eapply heap_type_update; eauto. inversion Hty1; subst; done. +Qed. + +Lemma typed_preservation Σ e e' h h' A: + heap_ctx_wf 0 Σ → + TY Σ; 0; ∅ ⊢ e : A → + heap_type h Σ → + contextual_step (e, h) (e', h') → + ∃ Σ', Σ ⊆ Σ' ∧ heap_type h' Σ' ∧ heap_ctx_wf 0 Σ' ∧ TY Σ'; 0; ∅ ⊢ e' : A. +Proof. + intros Hwf Hty Hheap Hstep. inversion Hstep as [K e1' e2' σ1 σ2 e1 e2 -> -> Hstep']; subst. + eapply fill_typing_decompose in Hty as [B [H1 H2]]. + eapply typed_preservation_base_step in H1 as (Σ' & Hsub & Hheap' & Hwf' & Hty'); eauto. + eexists; repeat split; try done. + eapply fill_typing_compose, ectx_typing_weaking; eauto. +Qed. + +Lemma typed_preservation_steps Σ e e' h h' A: + heap_ctx_wf 0 Σ → + TY Σ; 0; ∅ ⊢ e : A → + heap_type h Σ → + rtc contextual_step (e, h) (e', h') → + ∃ Σ', Σ ⊆ Σ' ∧ heap_type h' Σ' ∧ heap_ctx_wf 0 Σ' ∧ TY Σ'; 0; ∅ ⊢ e' : A. +Proof. + intros Hwf Hty Hheap Hsteps. remember (e, h) as c1. remember (e', h') as c2. + induction Hsteps as [|? [] ? Hstep Hsteps IH] in Σ, h, h',e, e', Heqc1, Heqc2, Hwf, Hty, Hheap |-*. + - rewrite Heqc1 in Heqc2. injection Heqc2 as -> ->. eauto. + - subst; eapply typed_preservation in Hty as (Σ' & Hsub' & Hheap' & Hwf' & Hty'); [|eauto..]. + eapply IH in Hty' as (Σ'' & Hsub'' & Hheap'' & Hwf'' & Hty''); [|eauto..]. + exists Σ''; repeat split; eauto. by trans Σ'. +Qed. + +Lemma type_safety Σ e1 e2 h1 h2 A: + heap_ctx_wf 0 Σ → + TY Σ; 0; ∅ ⊢ e1 : A → + heap_type h1 Σ → + rtc contextual_step (e1, h1) (e2, h2) → + is_val e2 ∨ reducible e2 h2. +Proof. + intros Hwf Hy Hheap Hsteps. + eapply typed_preservation_steps in Hsteps as (Σ' & Hsub & Hheap' & Hwf' & Hty'); eauto. + eapply typed_progress; eauto. +Qed. + +(* applies to terms containing no free locations (like the erasure of source terms) *) +Corollary closed_type_safety e e' h A: + TY ∅; 0; ∅ ⊢ e : A → + rtc contextual_step (e, ∅) (e', h) → + is_val e' ∨ reducible e' h. +Proof. + intros Hty Hsteps. eapply type_safety; eauto. + intros ??. set_solver. +Qed. + +(** Derived typing rules *) +Lemma typed_unroll' Σ n Γ e A B: + TY Σ; n; Γ ⊢ e : (μ: A) → + B = A.[(μ: A)%ty/] → + TY Σ; n; Γ ⊢ (unroll e) : B. +Proof. + intros ? ->. by eapply typed_unroll. +Qed. + +Lemma typed_tapp' Σ n Γ A B C e : + TY Σ; n; Γ ⊢ e : (∀: A) → + type_wf n B → + C = A.[B/] → + TY Σ; n; Γ ⊢ e <> : C. +Proof. + intros; subst C; by eapply typed_tapp. +Qed. From 6cc382131f1ff0ca325bd5a6bd8b8219e1303f95 Mon Sep 17 00:00:00 2001 From: Benjamin Peters Date: Thu, 21 Dec 2023 11:28:32 +0100 Subject: [PATCH 2/2] release exercise 8 --- _CoqProject | 17 + theories/program_logics/heap_lang/adequacy.v | 29 + .../program_logics/heap_lang/derived_laws.v | 172 ++++ .../program_logics/heap_lang/primitive_laws.v | 177 +++++ .../heap_lang/primitive_laws_nolater.v | 112 +++ theories/program_logics/heap_lang/proofmode.v | 387 +++++++++ theories/program_logics/hoare.v | 751 ++++++++++++++++++ theories/program_logics/hoare_lib.v | 725 +++++++++++++++++ .../program_logics/program_logic/adequacy.v | 229 ++++++ .../program_logic/ectx_lifting.v | 85 ++ .../program_logics/program_logic/lifting.v | 148 ++++ .../program_logics/program_logic/notation.v | 69 ++ .../program_logic/sequential_wp.v | 372 +++++++++ 13 files changed, 3273 insertions(+) create mode 100644 theories/program_logics/heap_lang/adequacy.v create mode 100644 theories/program_logics/heap_lang/derived_laws.v create mode 100644 theories/program_logics/heap_lang/primitive_laws.v create mode 100644 theories/program_logics/heap_lang/primitive_laws_nolater.v create mode 100644 theories/program_logics/heap_lang/proofmode.v create mode 100644 theories/program_logics/hoare.v create mode 100644 theories/program_logics/hoare_lib.v create mode 100644 theories/program_logics/program_logic/adequacy.v create mode 100644 theories/program_logics/program_logic/ectx_lifting.v create mode 100644 theories/program_logics/program_logic/lifting.v create mode 100644 theories/program_logics/program_logic/notation.v create mode 100644 theories/program_logics/program_logic/sequential_wp.v diff --git a/_CoqProject b/_CoqProject index 45f39cf..a7ea32a 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,4 +1,5 @@ -Q theories/lib semantics.lib +-Q theories/program_logics semantics.pl -Q theories/type_systems semantics.ts # We sometimes want to locally override notation, and there is no good way to do that with scopes. -arg -w -arg -notation-overridden @@ -76,6 +77,22 @@ theories/type_systems/systemf_mu_state/parallel_subst.v theories/type_systems/systemf_mu_state/logrel.v theories/type_systems/systemf_mu_state/logrel_sol.v +# Program logic library +theories/program_logics/program_logic/notation.v +theories/program_logics/program_logic/sequential_wp.v +theories/program_logics/program_logic/lifting.v +theories/program_logics/program_logic/ectx_lifting.v +theories/program_logics/program_logic/adequacy.v +theories/program_logics/heap_lang/primitive_laws.v +theories/program_logics/heap_lang/derived_laws.v +theories/program_logics/heap_lang/proofmode.v +theories/program_logics/heap_lang/adequacy.v +theories/program_logics/heap_lang/primitive_laws_nolater.v + +# Program logic chapter +theories/program_logics/hoare_lib.v +theories/program_logics/hoare.v + # By removing the # below, you can add the exercise sheets to make #theories/type_systems/warmup/warmup.v #theories/type_systems/warmup/warmup_sol.v diff --git a/theories/program_logics/heap_lang/adequacy.v b/theories/program_logics/heap_lang/adequacy.v new file mode 100644 index 0000000..8592094 --- /dev/null +++ b/theories/program_logics/heap_lang/adequacy.v @@ -0,0 +1,29 @@ +From iris.algebra Require Import auth. +From iris.proofmode Require Import proofmode. +From semantics.pl.program_logic Require Export sequential_wp adequacy. +From iris.heap_lang Require Import notation. +From semantics.pl.heap_lang Require Export proofmode. +From iris.prelude Require Import options. + +Class heapGpreS Σ := HeapGpreS { + heapGpreS_iris : invGpreS Σ; + heapGpreS_heap : gen_heapGpreS loc (option val) Σ; +}. +#[export] Existing Instance heapGpreS_iris. +#[export] Existing Instance heapGpreS_heap. + +Definition heapΣ : gFunctors := + #[invΣ; gen_heapΣ loc (option val)]. +Global Instance subG_heapGpreS {Σ} : subG heapΣ Σ → heapGpreS Σ. +Proof. solve_inG. Qed. + +Definition heap_adequacy Σ `{!heapGpreS Σ} s e σ φ : + (∀ `{!heapGS Σ}, ⊢ WP e @ s; ⊤ {{ v, ⌜φ v⌝ }}) → + adequate s e σ (λ v _, φ v). +Proof. + intros Hwp; eapply (wp_adequacy _ _); iIntros (?). + iMod (gen_heap_init σ.(heap)) as (?) "[Hh _]". + iModIntro. iExists + (λ σ, (gen_heap_interp σ.(heap))%I). + iFrame. iApply (Hwp (HeapGS _ _ _)). +Qed. diff --git a/theories/program_logics/heap_lang/derived_laws.v b/theories/program_logics/heap_lang/derived_laws.v new file mode 100644 index 0000000..e43905d --- /dev/null +++ b/theories/program_logics/heap_lang/derived_laws.v @@ -0,0 +1,172 @@ +(** This file extends the HeapLang program logic with some derived laws (not +using the lifting lemmas) about arrays and prophecies. + +For utility functions on arrays (e.g., freeing/copying an array), see +[heap_lang.lib.array]. *) + +From stdpp Require Import fin_maps. +From iris.bi Require Import lib.fractional. +From iris.proofmode Require Import proofmode. +From iris.heap_lang Require Import tactics notation. +From semantics.pl.heap_lang Require Export primitive_laws. +From iris.prelude Require Import options. + +(** The [array] connective is a version of [mapsto] that works +with lists of values. *) + +Definition array `{!heapGS Σ} (l : loc) (dq : dfrac) (vs : list val) : iProp Σ := + [∗ list] i ↦ v ∈ vs, (l +ₗ i) ↦{dq} v. + +(** FIXME: Refactor these notations using custom entries once Coq bug #13654 +has been fixed. *) +Notation "l ↦∗{ dq } vs" := (array l dq vs) + (at level 20, format "l ↦∗{ dq } vs") : bi_scope. +Notation "l ↦∗□ vs" := (array l DfracDiscarded vs) + (at level 20, format "l ↦∗□ vs") : bi_scope. +Notation "l ↦∗{# q } vs" := (array l (DfracOwn q) vs) + (at level 20, format "l ↦∗{# q } vs") : bi_scope. +Notation "l ↦∗ vs" := (array l (DfracOwn 1) vs) + (at level 20, format "l ↦∗ vs") : bi_scope. + +(** We have [FromSep] and [IntoSep] instances to split the fraction (via the +[AsFractional] instance below), but not for splitting the list, as that would +lead to overlapping instances. *) + +Section lifting. +Context `{!heapGS Σ}. +Implicit Types P Q : iProp Σ. +Implicit Types Φ : val → iProp Σ. +Implicit Types σ : state. +Implicit Types v : val. +Implicit Types vs : list val. +Implicit Types l : loc. +Implicit Types sz off : nat. + +Global Instance array_timeless l q vs : Timeless (array l q vs) := _. + +Global Instance array_fractional l vs : Fractional (λ q, l ↦∗{#q} vs)%I := _. +Global Instance array_as_fractional l q vs : + AsFractional (l ↦∗{#q} vs) (λ q, l ↦∗{#q} vs)%I q. +Proof. split; done || apply _. Qed. + +Lemma array_nil l dq : l ↦∗{dq} [] ⊣⊢ emp. +Proof. by rewrite /array. Qed. + +Lemma array_singleton l dq v : l ↦∗{dq} [v] ⊣⊢ l ↦{dq} v. +Proof. by rewrite /array /= right_id Loc.add_0. Qed. + +Lemma array_app l dq vs ws : + l ↦∗{dq} (vs ++ ws) ⊣⊢ l ↦∗{dq} vs ∗ (l +ₗ length vs) ↦∗{dq} ws. +Proof. + rewrite /array big_sepL_app. + setoid_rewrite Nat2Z.inj_add. + by setoid_rewrite Loc.add_assoc. +Qed. + +Lemma array_cons l dq v vs : l ↦∗{dq} (v :: vs) ⊣⊢ l ↦{dq} v ∗ (l +ₗ 1) ↦∗{dq} vs. +Proof. + rewrite /array big_sepL_cons Loc.add_0. + setoid_rewrite Loc.add_assoc. + setoid_rewrite Nat2Z.inj_succ. + by setoid_rewrite Z.add_1_l. +Qed. + +Global Instance array_cons_frame l dq v vs R Q : + Frame false R (l ↦{dq} v ∗ (l +ₗ 1) ↦∗{dq} vs) Q → + Frame false R (l ↦∗{dq} (v :: vs)) Q | 2. +Proof. by rewrite /Frame array_cons. Qed. + +Lemma update_array l dq vs off v : + vs !! off = Some v → + ⊢ l ↦∗{dq} vs -∗ ((l +ₗ off) ↦{dq} v ∗ ∀ v', (l +ₗ off) ↦{dq} v' -∗ l ↦∗{dq} <[off:=v']>vs). +Proof. + iIntros (Hlookup) "Hl". + rewrite -[X in (l ↦∗{_} X)%I](take_drop_middle _ off v); last done. + iDestruct (array_app with "Hl") as "[Hl1 Hl]". + iDestruct (array_cons with "Hl") as "[Hl2 Hl3]". + assert (off < length vs) as H by (apply lookup_lt_is_Some; by eexists). + rewrite take_length min_l; last by lia. iFrame "Hl2". + iIntros (w) "Hl2". + clear Hlookup. assert (<[off:=w]> vs !! off = Some w) as Hlookup. + { apply list_lookup_insert. lia. } + rewrite -[in (l ↦∗{_} <[off:=w]> vs)%I](take_drop_middle (<[off:=w]> vs) off w Hlookup). + iApply array_app. rewrite take_insert; last by lia. iFrame. + iApply array_cons. rewrite take_length min_l; last by lia. iFrame. + rewrite drop_insert_gt; last by lia. done. +Qed. + +(** * Rules for allocation *) +Lemma mapsto_seq_array l dq v n : + ([∗ list] i ∈ seq 0 n, (l +ₗ (i : nat)) ↦{dq} v) -∗ + l ↦∗{dq} replicate n v. +Proof. + rewrite /array. iInduction n as [|n'] "IH" forall (l); simpl. + { done. } + iIntros "[$ Hl]". rewrite -fmap_S_seq big_sepL_fmap. + setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l. + setoid_rewrite <-Loc.add_assoc. iApply "IH". done. +Qed. + +Lemma wp_allocN s E v n Φ : + (0 < n)%Z → + ▷ (∀ l, l ↦∗ replicate (Z.to_nat n) v -∗ Φ (LitV $ LitLoc l)) -∗ + WP AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E; E {{ Φ }}. +Proof. + iIntros (Hzs) "HΦ". iApply wp_allocN_seq; [done..|]. + iNext. iIntros (l) "Hlm". iApply "HΦ". + by iApply mapsto_seq_array. +Qed. + +Lemma wp_allocN_vec s E v n Φ : + (0 < n)%Z → + ▷ (∀ l, l ↦∗ vreplicate (Z.to_nat n) v -∗ Φ (#l)) -∗ + WP AllocN #n v @ s ; E; E {{ Φ }}. +Proof. + iIntros (Hzs) "HΦ". iApply wp_allocN; [ lia | .. ]. + iNext. iIntros (l) "Hl". iApply "HΦ". rewrite vec_to_list_replicate. iFrame. +Qed. + +(** * Rules for accessing array elements *) +Lemma wp_load_offset s E l dq off vs v Φ : + vs !! off = Some v → + l ↦∗{dq} vs -∗ + ▷ (l ↦∗{dq} vs -∗ Φ v) -∗ + WP ! #(l +ₗ off) @ s; E; E {{ Φ }}. +Proof. + iIntros (Hlookup) "Hl HΦ". + iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]". + iApply (wp_load with "Hl1"). iIntros "!> Hl1". iApply "HΦ". + iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done. + iApply "Hl2". iApply "Hl1". +Qed. + +Lemma wp_load_offset_vec s E l dq sz (off : fin sz) (vs : vec val sz) Φ : + l ↦∗{dq} vs -∗ + ▷ (l ↦∗{dq} vs -∗ Φ (vs !!! off)) -∗ + WP ! #(l +ₗ off) @ s; E; E {{ Φ }}. +Proof. apply wp_load_offset. by apply vlookup_lookup. Qed. + +Lemma wp_store_offset s E l off vs v Φ : + is_Some (vs !! off) → + l ↦∗ vs -∗ + ▷ (l ↦∗ <[off:=v]> vs -∗ Φ #()) -∗ + WP #(l +ₗ off) <- v @ s; E; E {{ Φ }}. +Proof. + iIntros ([w Hlookup]) "Hl HΦ". + iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]". + iApply (wp_store with "Hl1"). iIntros "!> Hl1". + iApply "HΦ". iApply "Hl2". iApply "Hl1". +Qed. + +Lemma wp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v Φ : + l ↦∗ vs -∗ + ▷ (l ↦∗ vinsert off v vs -∗ Φ #()) -∗ + WP #(l +ₗ off) <- v @ s; E; E {{ Φ }}. +Proof. + setoid_rewrite vec_to_list_insert. apply wp_store_offset. + eexists. by apply vlookup_lookup. +Qed. + +End lifting. + +#[global] Typeclasses Opaque array. diff --git a/theories/program_logics/heap_lang/primitive_laws.v b/theories/program_logics/heap_lang/primitive_laws.v new file mode 100644 index 0000000..e31f12f --- /dev/null +++ b/theories/program_logics/heap_lang/primitive_laws.v @@ -0,0 +1,177 @@ +(** This file proves the basic laws of the HeapLang program logic by applying +the Iris lifting lemmas. *) + +From iris.proofmode Require Import proofmode. +From iris.bi.lib Require Import fractional. +From iris.base_logic.lib Require Export gen_heap. +From semantics.pl.program_logic Require Export sequential_wp. +From semantics.pl.program_logic Require Import ectx_lifting. +From iris.heap_lang Require Export class_instances. +From iris.heap_lang Require Import tactics notation. +From semantics.pl.program_logic Require Export notation. +From iris.prelude Require Import options. + +Class heapGS Σ := HeapGS { + heapGS_invGS : invGS_gen HasNoLc Σ; + heapGS_gen_heapGS : gen_heapGS loc (option val) Σ; +}. +#[export] Existing Instance heapGS_gen_heapGS. + +Global Instance heapGS_irisGS `{!heapGS Σ} : irisGS heap_lang Σ := { + iris_invGS := heapGS_invGS; + state_interp σ := (gen_heap_interp σ.(heap))%I; +}. + +(** Since we use an [option val] instance of [gen_heap], we need to overwrite +the notations. That also helps for scopes and coercions. *) +(** FIXME: Refactor these notations using custom entries once Coq bug #13654 +has been fixed. *) +Notation "l ↦{ dq } v" := (mapsto (L:=loc) (V:=option val) l dq (Some v%V)) + (at level 20, format "l ↦{ dq } v") : bi_scope. +Notation "l ↦□ v" := (mapsto (L:=loc) (V:=option val) l DfracDiscarded (Some v%V)) + (at level 20, format "l ↦□ v") : bi_scope. +Notation "l ↦{# q } v" := (mapsto (L:=loc) (V:=option val) l (DfracOwn q) (Some v%V)) + (at level 20, format "l ↦{# q } v") : bi_scope. +Notation "l ↦ v" := (mapsto (L:=loc) (V:=option val) l (DfracOwn 1) (Some v%V)) + (at level 20, format "l ↦ v") : bi_scope. + +Section lifting. +Context `{!heapGS Σ}. +Implicit Types P Q : iProp Σ. +Implicit Types Φ Ψ : val → iProp Σ. +Implicit Types efs : list expr. +Implicit Types σ : state. +Implicit Types v : val. +Implicit Types l : loc. + +(** Recursive functions: we do not use this lemmas as it is easier to use Löb +induction directly, but this demonstrates that we can state the expected +reasoning principle for recursive functions, without any visible ▷. *) +Lemma wp_rec_löb s E1 E2 f x e Φ Ψ : + □ ( □ (∀ v, Ψ v -∗ WP (rec: f x := e)%V v @ s; E1; E2 {{ Φ }}) -∗ + ∀ v, Ψ v -∗ WP (subst' x v (subst' f (rec: f x := e) e)) @ s; E1; E2 {{ Φ }}) -∗ + ∀ v, Ψ v -∗ WP (rec: f x := e)%V v @ s; E1; E2 {{ Φ }}. +Proof. + iIntros "#Hrec". iLöb as "IH". iIntros (v) "HΨ". + iApply lifting.wp_pure_step_later; first done. + iNext. iApply ("Hrec" with "[] HΨ"). iIntros "!>" (w) "HΨ". + iApply ("IH" with "HΨ"). +Qed. + +(** Heap *) + +(** We need to adjust the [gen_heap] and [gen_inv_heap] lemmas because of our +value type being [option val]. *) + +Lemma mapsto_valid l dq v : l ↦{dq} v -∗ ⌜✓ dq⌝. +Proof. apply mapsto_valid. Qed. +Lemma mapsto_valid_2 l dq1 dq2 v1 v2 : + l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝. +Proof. + iIntros "H1 H2". + iDestruct (mapsto_valid_2 with "H1 H2") as %[? [=]]. done. +Qed. +Lemma mapsto_agree l dq1 dq2 v1 v2 : l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜v1 = v2⌝. +Proof. iIntros "H1 H2". iDestruct (mapsto_agree with "H1 H2") as %[=]. done. Qed. + +Lemma mapsto_combine l dq1 dq2 v1 v2 : + l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ l ↦{dq1 ⋅ dq2} v1 ∗ ⌜v1 = v2⌝. +Proof. + iIntros "Hl1 Hl2". iDestruct (mapsto_combine with "Hl1 Hl2") as "[$ Heq]". + by iDestruct "Heq" as %[= ->]. +Qed. + +Lemma mapsto_frac_ne l1 l2 dq1 dq2 v1 v2 : + ¬ ✓(dq1 ⋅ dq2) → l1 ↦{dq1} v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝. +Proof. apply mapsto_frac_ne. Qed. +Lemma mapsto_ne l1 l2 dq2 v1 v2 : l1 ↦ v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝. +Proof. apply mapsto_ne. Qed. + +Lemma mapsto_persist l dq v : l ↦{dq} v ==∗ l ↦□ v. +Proof. apply mapsto_persist. Qed. + +Lemma heap_array_to_seq_mapsto l v (n : nat) : + ([∗ map] l' ↦ ov ∈ heap_array l (replicate n v), gen_heap.mapsto l' (DfracOwn 1) ov) -∗ + [∗ list] i ∈ seq 0 n, (l +ₗ (i : nat)) ↦ v. +Proof. + iIntros "Hvs". iInduction n as [|n] "IH" forall (l); simpl. + { done. } + rewrite big_opM_union; last first. + { apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _]. + intros (j&w&?&Hjl&_)%heap_array_lookup. + rewrite Loc.add_assoc -{1}[l']Loc.add_0 in Hjl. simplify_eq; lia. } + rewrite Loc.add_0 -fmap_S_seq big_sepL_fmap. + setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l. + setoid_rewrite <-Loc.add_assoc. + rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". by iApply "IH". +Qed. + +Lemma wp_allocN_seq s E v n Φ : + (0 < n)%Z → + ▷ (∀ l, ([∗ list] i ∈ seq 0 (Z.to_nat n), (l +ₗ (i : nat)) ↦ v) -∗ Φ (LitV $ LitLoc l)) -∗ + WP AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E; E {{ Φ }}. +Proof. + iIntros (Hn) "HΦ". + iApply wp_lift_head_step_fupd_nomask; first done. + iIntros (σ1) "Hσ !>"; iSplit; first by destruct n; auto with lia head_step. + iIntros (e2 σ2 κ efs Hstep); inv_head_step. + iMod (gen_heap_alloc_big _ (heap_array _ (replicate (Z.to_nat n) v)) with "Hσ") + as "(Hσ & Hl & Hm)". + { apply heap_array_map_disjoint. + rewrite replicate_length Z2Nat.id; auto with lia. } + iApply step_fupd_intro; first done. + iModIntro. iFrame "Hσ". do 2 (iSplit; first done). + iApply wp_value_fupd. iApply "HΦ". + by iApply heap_array_to_seq_mapsto. +Qed. + +Lemma wp_alloc s E v Φ : + ▷ (∀ l, l ↦ v -∗ Φ (LitV $ LitLoc l)) -∗ + WP Alloc (Val v) @ s; E; E {{ Φ }}. +Proof. + iIntros "HΦ". iApply wp_allocN_seq; [auto with lia..|]. + iIntros "!>" (l) "/= (? & _)". rewrite Loc.add_0. iApply "HΦ"; iFrame. +Qed. + +Lemma wp_free s E l v Φ : + ▷ l ↦ v -∗ + (▷ Φ (LitV LitUnit)) -∗ + WP Free (Val $ LitV $ LitLoc l) @ s; E; E {{ Φ }}. +Proof. + iIntros ">Hl HΦ". iApply wp_lift_head_step_fupd_nomask; first done. + iIntros (σ1) "Hσ !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?. + iSplit; first by eauto with head_step. + iIntros (e2 σ2 κ efs Hstep); inv_head_step. + iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]". + iIntros "!>!>!>". iSplit; first done. iSplit; first done. + iApply wp_value. by iApply "HΦ". +Qed. + +Lemma wp_load s E l dq v Φ : + ▷ l ↦{dq} v -∗ + ▷ (l ↦{dq} v -∗ Φ v) -∗ + WP Load (Val $ LitV $ LitLoc l) @ s; E; E {{ Φ }}. +Proof. + iIntros ">Hl HΦ". iApply wp_lift_head_step_fupd_nomask; first done. + iIntros (σ1) "Hσ !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?. + iSplit; first by eauto with head_step. + iIntros (e2 σ2 κ efs Hstep); inv_head_step. + iApply step_fupd_intro; first done. iNext. iFrame. + iSplitR; first done. iSplitR; first done. iApply wp_value. by iApply "HΦ". +Qed. + +Lemma wp_store s E l v' v Φ : + ▷ l ↦ v' -∗ + ▷ (l ↦ v -∗ Φ (LitV LitUnit)) -∗ + WP Store (Val $ LitV $ LitLoc l) (Val v) @ s; E; E {{ Φ }}. +Proof. + iIntros ">Hl HΦ". iApply wp_lift_head_step_fupd_nomask; first done. + iIntros (σ1) "Hσ !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?. + iSplit; first by eauto with head_step. + iIntros (e2 σ2 κ efs Hstep); inv_head_step. + iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]". + iApply step_fupd_intro; first done. iNext. + iSplit; first done. iSplit; first done. + iApply wp_value. by iApply "HΦ". +Qed. +End lifting. diff --git a/theories/program_logics/heap_lang/primitive_laws_nolater.v b/theories/program_logics/heap_lang/primitive_laws_nolater.v new file mode 100644 index 0000000..cce84ff --- /dev/null +++ b/theories/program_logics/heap_lang/primitive_laws_nolater.v @@ -0,0 +1,112 @@ +From stdpp Require Import fin_maps. +From iris.proofmode Require Import proofmode. +From iris.bi.lib Require Import fractional. +From semantics.pl.heap_lang Require Export primitive_laws derived_laws. +From iris.base_logic.lib Require Export gen_heap gen_inv_heap. +From semantics.pl.program_logic Require Export sequential_wp. +From semantics.pl.program_logic Require Import ectx_lifting. +From iris.heap_lang Require Export class_instances. +From iris.heap_lang Require Import tactics notation. +From iris.prelude Require Import options. + +Section lifting. +Context `{!heapGS Σ}. +Implicit Types P Q : iProp Σ. +Implicit Types Φ Ψ : val → iProp Σ. +Implicit Types efs : list expr. +Implicit Types σ : state. +Implicit Types v : val. +Implicit Types l : loc. + +(** Heap *) +Lemma wp_allocN_seq s E v n Φ : + (0 < n)%Z → + (∀ l, ([∗ list] i ∈ seq 0 (Z.to_nat n), (l +ₗ (i : nat)) ↦ v) -∗ Φ (LitV $ LitLoc l)) -∗ + WP AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E; E {{ Φ }}. +Proof. + iIntros (Hn) "HΦ". iApply wp_allocN_seq; done. +Qed. + +Lemma wp_alloc s E v Φ : + (∀ l, l ↦ v -∗ Φ (LitV $ LitLoc l)) -∗ + WP Alloc (Val v) @ s; E; E {{ Φ }}. +Proof. + iIntros "HΦ". by iApply wp_alloc. +Qed. + +Lemma wp_free s E l v Φ : + l ↦ v -∗ + (Φ (LitV LitUnit)) -∗ + WP Free (Val $ LitV $ LitLoc l) @ s; E; E {{ Φ }}. +Proof. + iIntros "Hl HΦ". iApply (wp_free with "Hl HΦ"). +Qed. + +Lemma wp_load s E l dq v Φ : + l ↦{dq} v -∗ + (l ↦{dq} v -∗ Φ v) -∗ + WP Load (Val $ LitV $ LitLoc l) @ s; E; E {{ Φ }}. +Proof. + iIntros "Hl HΦ". iApply (wp_load with "Hl HΦ"). +Qed. + +Lemma wp_store s E l v' v Φ : + l ↦ v' -∗ + (l ↦ v -∗ Φ (LitV LitUnit)) -∗ + WP Store (Val $ LitV $ LitLoc l) (Val v) @ s; E; E {{ Φ }}. +Proof. + iIntros "Hl HΦ". + iApply (wp_store with "Hl HΦ"). +Qed. + + +(*** Derived *) +Lemma wp_allocN s E v n Φ : + (0 < n)%Z → + (∀ l, l ↦∗ replicate (Z.to_nat n) v -∗ Φ (LitV $ LitLoc l)) -∗ + WP AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E; E {{ Φ }}. +Proof. + iIntros. by iApply wp_allocN. +Qed. + +Lemma wp_allocN_vec s E v n Φ : + (0 < n)%Z → + (∀ l, l ↦∗ vreplicate (Z.to_nat n) v -∗ Φ (#l)) -∗ + WP AllocN #n v @ s ; E; E {{ Φ }}. +Proof. + iIntros. by iApply wp_allocN_vec. +Qed. + +(** * Rules for accessing array elements *) +Lemma wp_load_offset s E l dq (off : nat) vs v Φ : + vs !! off = Some v → + l ↦∗{dq} vs -∗ + (l ↦∗{dq} vs -∗ Φ v) -∗ + WP ! #(l +ₗ off) @ s; E; E {{ Φ }}. +Proof. + iIntros (?) "Hl HΦ". by iApply (wp_load_offset with "Hl HΦ"). +Qed. + +Lemma wp_load_offset_vec s E l dq sz (off : fin sz) (vs : vec val sz) Φ : + l ↦∗{dq} vs -∗ + (l ↦∗{dq} vs -∗ Φ (vs !!! off)) -∗ + WP ! #(l +ₗ off) @ s; E; E {{ Φ }}. +Proof. apply wp_load_offset. by apply vlookup_lookup. Qed. + +Lemma wp_store_offset s E l (off : nat) vs v Φ : + is_Some (vs !! off) → + l ↦∗ vs -∗ + (l ↦∗ <[off:=v]> vs -∗ Φ #()) -∗ + WP #(l +ₗ off) <- v @ s; E; E {{ Φ }}. +Proof. + iIntros (?) "Hl HΦ". by iApply (wp_store_offset with "Hl HΦ"). +Qed. + +Lemma wp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v Φ : + l ↦∗ vs -∗ + (l ↦∗ vinsert off v vs -∗ Φ #()) -∗ + WP #(l +ₗ off) <- v @ s; E; E {{ Φ }}. +Proof. + iIntros "Hl HΦ". by iApply (wp_store_offset_vec with "Hl HΦ"). +Qed. +End lifting. diff --git a/theories/program_logics/heap_lang/proofmode.v b/theories/program_logics/heap_lang/proofmode.v new file mode 100644 index 0000000..2f0ec79 --- /dev/null +++ b/theories/program_logics/heap_lang/proofmode.v @@ -0,0 +1,387 @@ +From iris.proofmode Require Import coq_tactics reduction spec_patterns. +From iris.proofmode Require Export tactics. +From iris.heap_lang Require Export tactics. +From iris.heap_lang Require Import notation. +From semantics.pl.heap_lang Require Export derived_laws. +From semantics.pl.program_logic Require Export notation. +From iris.prelude Require Import options. +Import uPred. + +Lemma tac_wp_expr_eval `{!heapGS Σ} Δ s E1 E2 Φ e e' : + (∀ (e'':=e'), e = e'') → + envs_entails Δ (WP e' @ s; E1; E2 {{ Φ }}) → envs_entails Δ (WP e @ s; E1; E2 {{ Φ }}). +Proof. by intros ->. Qed. + +Tactic Notation "wp_expr_eval" tactic3(t) := + iStartProof; + lazymatch goal with + | |- envs_entails _ (wp ?s ?E1 ?E2 ?e ?Q) => + notypeclasses refine (tac_wp_expr_eval _ _ _ _ _ e _ _ _); + [let x := fresh in intros x; t; unfold x; notypeclasses refine eq_refl|] + | _ => fail "wp_expr_eval: not a 'wp'" + end. +Ltac wp_expr_simpl := wp_expr_eval simpl. + +Lemma tac_wp_pure `{!heapGS Σ} Δ Δ' s E1 E2 K e1 e2 φ n Φ : + PureExec φ n e1 e2 → + φ → + MaybeIntoLaterNEnvs n Δ Δ' → + envs_entails Δ' (WP (fill K e2) @ s; E1; E2 {{ Φ }}) → + envs_entails Δ (WP (fill K e1) @ s; E1; E2 {{ Φ }}). +Proof. + rewrite envs_entails_unseal=> ??? HΔ'. rewrite into_laterN_env_sound /=. + (* We want [pure_exec_fill] to be available to TC search locally. *) + pose proof @pure_exec_fill. + rewrite HΔ' -lifting.wp_pure_step_later //. +Qed. + +Lemma tac_wp_value_nofupd `{!heapGS Σ} Δ s E Φ v : + envs_entails Δ (Φ v) → envs_entails Δ (WP (Val v) @ s; E; E {{ Φ }}). +Proof. rewrite envs_entails_unseal=> ->. by apply wp_value. Qed. + +(** Simplify the goal if it is [WP] of a value. + If the postcondition already allows a fupd, do not add a second one. + But otherwise, *do* add a fupd. This ensures that all the lemmas applied + here are bidirectional, so we never will make a goal unprovable. *) +Ltac wp_value_head := + lazymatch goal with + | |- envs_entails _ (wp ?s ?E1 ?E2 (Val _) _) => + eapply tac_wp_value_nofupd + end. + +Ltac wp_finish := + wp_expr_simpl; (* simplify occurences of subst/fill *) + pm_prettify. (* prettify ▷s caused by [MaybeIntoLaterNEnvs] and + λs caused by wp_value *) + +Ltac solve_vals_compare_safe := + (* The first branch is for when we have [vals_compare_safe] in the context. + The other two branches are for when either one of the branches reduces to + [True] or we have it in the context. *) + fast_done || (left; fast_done) || (right; fast_done). + +(** The argument [efoc] can be used to specify the construct that should be +reduced. For example, you can write [wp_pure (EIf _ _ _)], which will search +for an [EIf _ _ _] in the expression, and reduce it. + +The use of [open_constr] in this tactic is essential. It will convert all holes +(i.e. [_]s) into evars, that later get unified when an occurences is found +(see [unify e' efoc] in the code below). *) +Tactic Notation "wp_pure" open_constr(efoc) := + iStartProof; + lazymatch goal with + | |- envs_entails _ (wp ?s ?E1 ?E2 ?e ?Q) => + let e := eval simpl in e in + reshape_expr e ltac:(fun K e' => + unify e' efoc; + eapply (tac_wp_pure _ _ _ _ _ K e'); + [tc_solve (* PureExec *) + |try solve_vals_compare_safe (* The pure condition for PureExec -- + handles trivial goals, including [vals_compare_safe] *) + |tc_solve (* IntoLaters *) + |wp_finish (* new goal *) + ]) + || fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex" + | _ => fail "wp_pure: not a 'wp'" + end. + +Ltac wp_pures := + iStartProof; + first [ (* The `;[]` makes sure that no side-condition magically spawns. *) + progress repeat (wp_pure _; []) + | wp_finish (* In case wp_pure never ran, make sure we do the usual cleanup. *) + ]. + +(** Unlike [wp_pures], the tactics [wp_rec] and [wp_lam] should also reduce +lambdas/recs that are hidden behind a definition, i.e. they should use +[AsRecV_recv] as a proper instance instead of a [Hint Extern]. + +We achieve this by putting [AsRecV_recv] in the current environment so that it +can be used as an instance by the typeclass resolution system. We then perform +the reduction, and finally we clear this new hypothesis. *) +Tactic Notation "wp_rec" := + let H := fresh in + assert (H := AsRecV_recv); + wp_pure (App _ _); + clear H. + +Tactic Notation "wp_if" := wp_pure (If _ _ _). +Tactic Notation "wp_if_true" := wp_pure (If (LitV (LitBool true)) _ _). +Tactic Notation "wp_if_false" := wp_pure (If (LitV (LitBool false)) _ _). +Tactic Notation "wp_unop" := wp_pure (UnOp _ _). +Tactic Notation "wp_binop" := wp_pure (BinOp _ _ _). +Tactic Notation "wp_op" := wp_unop || wp_binop. +Tactic Notation "wp_lam" := wp_rec. +Tactic Notation "wp_let" := wp_pure (Rec BAnon (BNamed _) _); wp_lam. +Tactic Notation "wp_seq" := wp_pure (Rec BAnon BAnon _); wp_lam. +Tactic Notation "wp_proj" := wp_pure (Fst _) || wp_pure (Snd _). +Tactic Notation "wp_case" := wp_pure (Case _ _ _). +Tactic Notation "wp_match" := wp_case; wp_pure (Rec _ _ _); wp_lam. +Tactic Notation "wp_inj" := wp_pure (InjL _) || wp_pure (InjR _). +Tactic Notation "wp_pair" := wp_pure (Pair _ _). +Tactic Notation "wp_closure" := wp_pure (Rec _ _ _). + +(* will spawn an evar for [E2] *) +Lemma tac_wp_bind `{!heapGS Σ} K Δ s E1 E2 E3 Φ e f : + f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *) + envs_entails Δ (WP e @ s; E1; E2 {{ v, WP f (Val v) @ s; E2; E3 {{ Φ }} }})%I → + envs_entails Δ (WP fill K e @ s; E1; E3 {{ Φ }}). +Proof. rewrite envs_entails_unseal=> -> ->. by apply: wp_bind. Qed. + +(* don't change masks for bound expression *) +Lemma tac_wp_bind_nomask `{!heapGS Σ} K Δ s E1 E2 Φ e f : + f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *) + envs_entails Δ (WP e @ s; E1; E1 {{ v, WP f (Val v) @ s; E1; E2 {{ Φ }} }})%I → + envs_entails Δ (WP fill K e @ s; E1; E2 {{ Φ }}). +Proof. rewrite envs_entails_unseal=> -> ->. by apply: wp_bind. Qed. + +Ltac wp_bind_core K := + lazymatch eval hnf in K with + | [] => idtac + | _ => eapply (tac_wp_bind_nomask K); [simpl; reflexivity|reduction.pm_prettify] + end. + +Tactic Notation "wp_bind" open_constr(efoc) := + iStartProof; + lazymatch goal with + | |- envs_entails _ (wp ?s ?E1 ?E2 ?e ?Q) => + first [ reshape_expr e ltac:(fun K e' => unify e' efoc; wp_bind_core K) + | fail 1 "wp_bind: cannot find" efoc "in" e ] + | _ => fail "wp_bind: not a 'wp'" + end. + +Ltac wp_bind_core' K := + lazymatch eval hnf in K with + | [] => idtac + | _ => eapply (tac_wp_bind K); [simpl; reflexivity|reduction.pm_prettify] + end. + +Tactic Notation "wp_bind'" open_constr(efoc) := + iStartProof; + lazymatch goal with + | |- envs_entails _ (wp ?s ?E1 ?E2 ?e ?Q) => + first [ reshape_expr e ltac:(fun K e' => unify e' efoc; wp_bind_core' K) + | fail 1 "wp_bind: cannot find" efoc "in" e ] + | _ => fail "wp_bind: not a 'wp'" + end. + +(** Heap tactics *) +Section heap. +Context `{!heapGS Σ}. +Implicit Types P Q : iProp Σ. +Implicit Types Φ : val → iProp Σ. +Implicit Types Δ : envs (uPredI (iResUR Σ)). +Implicit Types v : val. +Implicit Types z : Z. + +Lemma wand_apply' (P R Q : iProp Σ) : + (P ⊢ R) → + (R -∗ Q) → + P ⊢ Q. +Proof. + intros Ha Hb. iIntros "HP". iApply Hb. iApply Ha. done. +Qed. + +Lemma tac_wp_allocN Δ Δ' s E1 E2 j K v n Φ : + (0 < n)%Z → + MaybeIntoLaterNEnvs 1 Δ Δ' → + (∀ l, + match envs_app false (Esnoc Enil j (array l (DfracOwn 1) (replicate (Z.to_nat n) v))) Δ' with + | Some Δ'' => + envs_entails Δ'' (WP fill K (Val $ LitV $ LitLoc l) @ s; E1; E2 {{ Φ }}) + | None => False + end) → + envs_entails Δ (WP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) @ s; E1; E2 {{ Φ }}). +Proof. + rewrite envs_entails_unseal=> ? ? HΔ. + rewrite -wp_bind. eapply wand_apply'; last exact: wp_allocN. + rewrite into_laterN_env_sound; apply later_mono, forall_intro=> l. + specialize (HΔ l). + destruct (envs_app _ _ _) as [Δ''|] eqn:HΔ'; [ | contradiction ]. + rewrite envs_app_sound //; simpl. + apply wand_intro_l. by rewrite right_id wand_elim_r. +Qed. + +Lemma tac_wp_alloc Δ Δ' s E1 E2 j K v Φ : + MaybeIntoLaterNEnvs 1 Δ Δ' → + (∀ l, + match envs_app false (Esnoc Enil j (l ↦ v)) Δ' with + | Some Δ'' => + envs_entails Δ'' (WP fill K (Val $ LitV l) @ s; E1; E2 {{ Φ }}) + | None => False + end) → + envs_entails Δ (WP fill K (Alloc (Val v)) @ s; E1; E2 {{ Φ }}). +Proof. + rewrite envs_entails_unseal=> ? HΔ. + rewrite -wp_bind. eapply wand_apply'; last exact: wp_alloc. + rewrite into_laterN_env_sound; apply later_mono, forall_intro=> l. + specialize (HΔ l). + destruct (envs_app _ _ _) as [Δ''|] eqn:HΔ'; [ | contradiction ]. + rewrite envs_app_sound //; simpl. + apply wand_intro_l. by rewrite right_id wand_elim_r. +Qed. + +Lemma tac_wp_free Δ Δ' s E1 E2 i K l v Φ : + MaybeIntoLaterNEnvs 1 Δ Δ' → + envs_lookup i Δ' = Some (false, l ↦ v)%I → + (let Δ'' := envs_delete false i false Δ' in + envs_entails Δ'' (WP fill K (Val $ LitV LitUnit) @ s; E1; E2 {{ Φ }})) → + envs_entails Δ (WP fill K (Free (LitV l)) @ s; E1; E2 {{ Φ }}). +Proof. + rewrite envs_entails_unseal=> ? Hlk Hfin. + rewrite -wp_bind. eapply wand_apply; first apply wand_entails, wp_free. + rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl. + rewrite -Hfin wand_elim_r (envs_lookup_sound' _ _ _ _ _ Hlk). + by apply later_mono, sep_mono_r. +Qed. + +Lemma tac_wp_load Δ Δ' s E1 E2 i K b l q v Φ : + MaybeIntoLaterNEnvs 1 Δ Δ' → + envs_lookup i Δ' = Some (b, l ↦{q} v)%I → + envs_entails Δ' (WP fill K (Val v) @ s; E1; E2 {{ Φ }}) → + envs_entails Δ (WP fill K (Load (LitV l)) @ s; E1; E2 {{ Φ }}). +Proof. + rewrite envs_entails_unseal=> ?? Hi. + rewrite -wp_bind. eapply wand_apply; first apply wand_entails, wp_load. + rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl. + apply later_mono. + destruct b; simpl. + * iIntros "[#$ He]". iIntros "_". iApply Hi. iApply "He". iFrame "#". + * by apply sep_mono_r, wand_mono. +Qed. + +Lemma tac_wp_store Δ Δ' s E1 E2 i K l v v' Φ : + MaybeIntoLaterNEnvs 1 Δ Δ' → + envs_lookup i Δ' = Some (false, l ↦ v)%I → + match envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ' with + | Some Δ'' => envs_entails Δ'' (WP fill K (Val $ LitV LitUnit) @ s; E1; E2 {{ Φ }}) + | None => False + end → + envs_entails Δ (WP fill K (Store (LitV l) (Val v')) @ s; E1; E2 {{ Φ }}). +Proof. + rewrite envs_entails_unseal=> ???. + destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ]. + rewrite -wp_bind. eapply wand_apply; first apply wand_entails, wp_store. + rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl. + rewrite right_id. by apply later_mono, sep_mono_r, wand_mono. +Qed. +End heap. + +(** The tactic [wp_apply_core lem tac_suc tac_fail] evaluates [lem] to a +hypothesis [H] that can be applied, and then runs [wp_bind_core K; tac_suc H] +for every possible evaluation context [K]. + +- The tactic [tac_suc] should do [iApplyHyp H] to actually apply the hypothesis, + but can perform other operations in addition (see [wp_apply] and [awp_apply] + below). +- The tactic [tac_fail cont] is called when [tac_suc H] fails for all evaluation + contexts [K], and can perform further operations before invoking [cont] to + try again. + +TC resolution of [lem] premises happens *after* [tac_suc H] got executed. *) +Ltac wp_apply_core lem tac_suc tac_fail := first + [iPoseProofCore lem as false (fun H => + lazymatch goal with + | |- envs_entails _ (wp ?s ?E1 ?E2 ?e ?Q) => + reshape_expr e ltac:(fun K e' => + wp_bind_core K; tac_suc H) + | _ => fail 1 "wp_apply: not a 'wp'" + end) + |tac_fail ltac:(fun _ => wp_apply_core lem tac_suc tac_fail) + |let P := type of lem in + fail "wp_apply: cannot apply" lem ":" P ]. + +Tactic Notation "wp_apply" open_constr(lem) := + wp_apply_core lem ltac:(fun H => iApplyHyp H; try iNext; try wp_expr_simpl) + ltac:(fun cont => fail). +Tactic Notation "wp_smart_apply" open_constr(lem) := + wp_apply_core lem ltac:(fun H => iApplyHyp H; try iNext; try wp_expr_simpl) + ltac:(fun cont => wp_pure _; []; cont ()). + +Tactic Notation "wp_alloc" ident(l) "as" constr(H) := + let Htmp := iFresh in + let finish _ := + first [intros l | fail 1 "wp_alloc:" l "not fresh"]; + pm_reduce; + lazymatch goal with + | |- False => fail 1 "wp_alloc:" H "not fresh" + | _ => iDestructHyp Htmp as H; wp_finish + end in + wp_pures; + (** The code first tries to use allocation lemma for a single reference, + ie, [tac_wp_alloc] (respectively, [tac_twp_alloc]). + If that fails, it tries to use the lemma [tac_wp_allocN] + (respectively, [tac_twp_allocN]) for allocating an array. + Notice that we could have used the array allocation lemma also for single + references. However, that would produce the resource l ↦∗ [v] instead of + l ↦ v for single references. These are logically equivalent assertions + but are not equal. *) + lazymatch goal with + | |- envs_entails _ (wp ?s ?E1 ?E2 ?e ?Q) => + let process_single _ := + first + [reshape_expr e ltac:(fun K e' => eapply (tac_wp_alloc _ _ _ _ _ Htmp K)) + |fail 1 "wp_alloc: cannot find 'Alloc' in" e]; + [tc_solve + |finish ()] + in + let process_array _ := + first + [reshape_expr e ltac:(fun K e' => eapply (tac_wp_allocN _ _ _ _ _ Htmp K)) + |fail 1 "wp_alloc: cannot find 'Alloc' in" e]; + [idtac|tc_solve + |finish ()] + in (process_single ()) || (process_array ()) + | _ => fail "wp_alloc: not a 'wp'" + end. + +Tactic Notation "wp_alloc" ident(l) := + wp_alloc l as "?". + +Tactic Notation "wp_free" := + let solve_mapsto _ := + let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in + iAssumptionCore || fail "wp_free: cannot find" l "↦ ?" in + wp_pures; + lazymatch goal with + | |- envs_entails _ (wp ?s ?E1 ?E2 ?e ?Q) => + first + [reshape_expr e ltac:(fun K e' => eapply (tac_wp_free _ _ _ _ _ _ K)) + |fail 1 "wp_free: cannot find 'Free' in" e]; + [tc_solve + |solve_mapsto () + |pm_reduce; wp_finish] + | _ => fail "wp_free: not a 'wp'" + end. + +Tactic Notation "wp_load" := + let solve_mapsto _ := + let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in + iAssumptionCore || fail "wp_load: cannot find" l "↦ ?" in + wp_pures; + lazymatch goal with + | |- envs_entails _ (wp ?s ?E1 ?E2 ?e ?Q) => + first + [reshape_expr e ltac:(fun K e' => eapply (tac_wp_load _ _ _ _ _ _ K)) + |fail 1 "wp_load: cannot find 'Load' in" e]; + [tc_solve + |solve_mapsto () + |wp_finish] + | _ => fail "wp_load: not a 'wp'" + end. + +Tactic Notation "wp_store" := + let solve_mapsto _ := + let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in + iAssumptionCore || fail "wp_store: cannot find" l "↦ ?" in + wp_pures; + lazymatch goal with + | |- envs_entails _ (wp ?s ?E1 ?E2 ?e ?Q) => + first + [reshape_expr e ltac:(fun K e' => eapply (tac_wp_store _ _ _ _ _ _ K)) + |fail 1 "wp_store: cannot find 'Store' in" e]; + [tc_solve + |solve_mapsto () + |pm_reduce; first [wp_seq|wp_finish]] + | _ => fail "wp_store: not a 'wp'" + end. diff --git a/theories/program_logics/hoare.v b/theories/program_logics/hoare.v new file mode 100644 index 0000000..b355491 --- /dev/null +++ b/theories/program_logics/hoare.v @@ -0,0 +1,751 @@ +From iris.prelude Require Import options. +From iris.proofmode Require Import tactics. +From iris.heap_lang Require Import lang notation. +From semantics.pl Require Export hoare_lib. + +Import hoare. +Implicit Types + (P Q: iProp) + (φ ψ: Prop) + (e: expr) + (v: val). + + +(** * Hoare logic *) + +(** Entailment rules *) +Check ent_equiv. +Check ent_refl. +Check ent_trans. +(* NOTE: True = ⌜True⌝ *) +(* NOTE: False = ⌜False⌝ *) +Check ent_prove_pure. +Check ent_assume_pure. +Check ent_and_elim_r. +Check ent_and_elim_l. +Check ent_and_intro. +Check ent_or_introl. +Check ent_or_intror. +Check ent_or_elim. +Check ent_all_intro. +Check ent_all_elim. +Check ent_exist_intro. +Check ent_exist_elim. + +(** Derived entailment rules *) +Lemma ent_weakening P Q R : + (P ⊢ R) → + P ∧ Q ⊢ R. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma ent_true P : + P ⊢ True. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma ent_false P : + False ⊢ P. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma ent_and_comm P Q : + P ∧ Q ⊢ Q ∧ P. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma ent_or_comm P Q : + P ∨ Q ⊢ Q ∨ P. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma ent_all_comm {X} (Φ : X → X → iProp) : + (∀ x y, Φ x y) ⊢ (∀ y x, Φ x y). +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma ent_exist_comm {X} (Φ : X → X → iProp) : + (∃ x y, Φ x y) ⊢ (∃ y x, Φ x y). +Proof. + (* TODO: exercise *) +Admitted. + + +(** Derived Hoare rules *) +Lemma hoare_con_pre P Q Φ e: + (P ⊢ Q) → + {{ Q }} e {{ Φ }} → + {{ P }} e {{ Φ }}. +Proof. + intros ??. eapply hoare_con; eauto. +Qed. + +Lemma hoare_con_post P Φ Ψ e: + (∀ v, Ψ v ⊢ Φ v) → + {{ P }} e {{ Ψ }} → + {{ P }} e {{ Φ }}. +Proof. + intros ??. eapply hoare_con; last done; eauto. +Qed. + +Lemma hoare_value_con P Φ v : + (P ⊢ Φ v) → + {{ P }} v {{ Φ }}. +Proof. + intros H. eapply hoare_con; last apply hoare_value. + - apply H. + - eauto. +Qed. + +Lemma hoare_value' P v : + {{ P }} v {{ w, P ∗ ⌜w = v⌝}}. +Proof. + eapply hoare_con; last apply hoare_value with (Φ := (λ v', P ∗ ⌜v' = v⌝)%I). + - etrans; first apply ent_sep_true. rewrite ent_sep_comm. apply ent_sep_split; first done. + by apply ent_prove_pure. + - done. +Qed. + +Lemma hoare_rec P Φ f x e v: + ({{ P }} subst' x v (subst' f (rec: f x := e) e) {{Φ}}) → + {{ P }} (rec: f x := e)%V v {{Φ}}. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma hoare_let P Φ x e v: + ({{ P }} subst' x v e {{Φ}}) → + {{ P }} let: x := v in e {{Φ}}. +Proof. + intros Ha. eapply hoare_pure_steps. + { eapply (rtc_pure_step_fill [AppLCtx _]). + apply pure_step_val. done. + } + eapply hoare_pure_step; last done. + apply pure_step_beta. +Qed. + +Lemma hoare_eq_num (n m: Z): + {{ ⌜n = m⌝ }} #n = #m {{ u, ⌜u = #true⌝ }}. +Proof. + eapply hoare_pure; first reflexivity. + intros ->. eapply hoare_pure_step. + { apply pure_step_eq. done. } + apply hoare_value_con. + by apply ent_prove_pure. +Qed. + +Lemma hoare_neq_num (n m: Z): + {{ ⌜n ≠ m⌝ }} #n = #m {{ u, ⌜u = #false⌝ }}. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma hoare_sub (z1 z2: Z): + {{ True }} #z1 - #z2 {{ v, ⌜v = #(z1 - z2)⌝ }}. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma hoare_add (z1 z2: Z): + {{ True }} #z1 + #z2 {{ v, ⌜v = #(z1 + z2)⌝ }}. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma hoare_if_false P e1 e2 Φ: + {{ P }} e2 {{ Φ }} → + ({{ P }} if: #false then e1 else e2 {{ Φ }}). +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma hoare_if_true P e1 e2 Φ: + {{ P }} e1 {{ Φ }} → + ({{ P }} if: #true then e1 else e2 {{ Φ }}). +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma hoare_pure_pre φ Φ e: + {{ ⌜φ⌝ }} e {{ Φ }} ↔ (φ → {{ True }} e {{ Φ }}). +Proof. + (* TODO: exercise *) +Admitted. + + +(** Example: Fibonacci *) +Definition fib: val := + rec: "fib" "n" := + if: "n" = #0 then #0 + else if: "n" = #1 then #1 + else "fib" ("n" - #1) + "fib" ("n" - #2). + +Lemma fib_zero: + {{ True }} fib #0 {{ v, ⌜v = #0⌝ }}. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma fib_one: + {{ True }} fib #1 {{ v, ⌜v = #1⌝ }}. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma fib_succ (z n m: Z): + {{ True }} fib #(z - 1)%Z {{ v, ⌜v = #n⌝ }} → + {{ True }} fib #(z - 2)%Z {{ v, ⌜v = #m⌝ }} → + {{ ⌜z > 1⌝%Z }} fib #z {{ v, ⌜v = #(n + m)⌝ }}. +Proof. + intros H1 H2. eapply hoare_pure_pre. intros Hgt. + unfold fib. + eapply hoare_pure_steps. + { econstructor 2. + { apply pure_step_beta. } + simpl. econstructor 2. { apply (pure_step_fill [IfCtx _ _]). apply pure_step_neq. lia. } + simpl. econstructor 2. { apply pure_step_if_false. } + econstructor 2. { apply (pure_step_fill [IfCtx _ _]). apply pure_step_neq. lia. } + simpl. econstructor 2. { apply pure_step_if_false. } + fold fib. reflexivity. + } + eapply (hoare_bind [BinOpRCtx _ _]). + { eapply (hoare_bind [AppRCtx _]). { apply hoare_sub. } + intros v. eapply hoare_pure_pre. intros ->. apply H2. + } + intros v. apply hoare_pure_pre. intros ->. simpl. + eapply (hoare_bind [BinOpLCtx _ _]). + { eapply (hoare_bind [AppRCtx _]). { apply hoare_sub. } + intros v. eapply hoare_pure_pre. intros ->. apply H1. + } + intros v. apply hoare_pure_pre. intros ->. simpl. + eapply hoare_pure_step. { apply pure_step_add. } + eapply hoare_value_con. by apply ent_prove_pure. +Qed. + +Lemma fib_succ_oldschool (z n m: Z): + {{ True }} fib #(z - 1)%Z {{ v, ⌜v = #n⌝ }} → + {{ True }} fib #(z - 2)%Z {{ v, ⌜v = #m⌝ }} → + {{ ⌜z > 1⌝%Z }} fib #z {{ v, ⌜v = #(n + m)⌝ }}. +Proof. + (* TODO: exercise *) +Admitted. + + +Fixpoint Fib (n: nat) := + match n with + | 0 => 0 + | S n => + match n with + | 0 => 1 + | S m => Fib n + Fib m + end + end. + +Lemma fib_computes_Fib (n: nat): + {{ True }} fib #n {{ v, ⌜v = #(Fib n)⌝ }}. +Proof. + induction (lt_wf n) as [n _ IH]. + destruct n as [|[|n]]. + - simpl. eapply fib_zero. + - simpl. eapply fib_one. + - replace (Fib (S (S n)): Z) with (Fib (S n) + Fib n)%Z by (simpl; lia). + edestruct (hoare_pure_pre (S (S n) > 1))%Z as [H1 _]; eapply H1; last lia. + eapply fib_succ. + + replace (S (S n) - 1)%Z with (S n: Z) by lia. eapply IH. lia. + + replace (S (S n) - 2)%Z with (n: Z) by lia. eapply IH. lia. +Qed. + +(** ** Example: gcd *) +Definition mod_val : val := + λ: "a" "b", "a" - ("a" `quot` "b") * "b". +Definition euclid: val := + rec: "euclid" "a" "b" := + if: "b" = #0 then "a" else "euclid" "b" (mod_val "a" "b"). + +Lemma quot_diff a b : + (0 ≤ a)%Z → (0 < b)%Z → (0 ≤ a - a `quot` b * b < b)%Z. +Proof. + intros. split. + - rewrite Z.mul_comm -Z.rem_eq; last lia. apply Z.rem_nonneg; lia. + - rewrite Z.mul_comm -Z.rem_eq; last lia. + specialize (Z.rem_bound_pos_pos a b ltac:(lia) ltac:(lia)). lia. +Qed. +Lemma Z_nonneg_ind (P : Z → Prop) : + (∀ x, (0 ≤ x)%Z → (∀ y, (0 ≤ y < x)%Z → P y) → P x) → + ∀ x, (0 ≤ x)%Z → P x. +Proof. + intros IH x Hle. generalize Hle. + revert x Hle. refine (Z_lt_induction (λ x, (0 ≤ x)%Z → P x) _). + naive_solver. +Qed. + +Lemma mod_spec (a b : Z) : + {{ ⌜(b > 0)%Z⌝ ∧ ⌜(a >= 0)%Z⌝ }} + mod_val #a #b + {{ cv, ∃ (c k : Z), ⌜cv = #c ∧ (0 <= k)%Z ∧ (a = b * k + c)%Z ∧ (0 <= c < b)%Z⌝ }}. +Proof. + eapply (hoare_pure _ (b > 0 ∧ a >= 0)%Z). + { eapply ent_assume_pure. { eapply ent_and_elim_l. } + intros ?. eapply ent_assume_pure. { eapply ent_and_elim_r. } + intros ?. eapply ent_assume_pure. { eapply ent_and_elim_l. } + intros ?. apply ent_prove_pure. done. + } + intros (? & ?). + unfold mod_val. eapply hoare_pure_step. + { apply pure_step_fill with (K := [AppLCtx _]). apply pure_step_beta. } + fold mod_val. simpl. + apply hoare_let. simpl. + eapply hoare_pure_step. + { apply pure_step_fill with (K := [BinOpLCtx _ _; BinOpRCtx _ _]). + apply pure_step_quot. lia. + } + simpl. eapply hoare_pure_step. + { apply pure_step_fill with (K := [BinOpRCtx _ _]). apply pure_step_mul. } + simpl. eapply hoare_pure_step. + { apply pure_step_sub. } + eapply hoare_value_con. + eapply ent_exist_intro. apply ent_exist_intro with (x := (a `quot` b)%Z). + (* MATH *) + apply ent_prove_pure. split; last split; last split. + - reflexivity. + - apply Z.quot_pos; lia. + - lia. + - apply quot_diff; lia. +Qed. + +Lemma gcd_step (b c k : Z) : + Z.gcd b c = Z.gcd (b * k + c) b. +Proof. + rewrite Z.add_comm (Z.gcd_comm _ b) Z.mul_comm Z.gcd_add_mult_diag_r. done. +Qed. + +Lemma euclid_step_gt0 (a b : Z) : + (∀ c : Z, + {{ ⌜(0 ≤ c < b)%Z⌝}} + euclid #b #c + {{ d, ⌜d = #(Z.gcd b c)⌝ }}) → + {{ ⌜(b > 0)%Z⌝ ∧ ⌜(a >= 0)%Z⌝}} euclid #a #b {{ c, ⌜c = #(Z.gcd a b)⌝ }}. +Proof. + intros Ha. + eapply (hoare_pure _ (a >= 0 ∧ b > 0)%Z). + { eapply ent_assume_pure. { eapply ent_and_elim_l. } + intros ?. eapply ent_assume_pure. { eapply ent_and_elim_r. } + intros ?. eapply ent_assume_pure. { eapply ent_and_elim_l. } + intros ?. apply ent_prove_pure. done. + } + intros (? & ?). + unfold euclid. eapply hoare_pure_step. + { apply (pure_step_fill [AppLCtx _]). apply pure_step_beta. } + fold euclid. simpl. apply hoare_let. simpl. + eapply hoare_pure_step. + { apply (pure_step_fill [IfCtx _ _]). apply pure_step_neq. lia. } + simpl. apply hoare_if_false. + + eapply hoare_bind with (K := [AppRCtx _]). + { apply mod_spec. } + intros v. simpl. + apply hoare_exist_pre. intros d. + apply hoare_exist_pre. intros k. + apply hoare_pure_pre. + intros (-> & ? & -> & ?). + eapply hoare_con; last apply Ha. + { apply ent_prove_pure. split_and!; lia. } + { simpl. intros v. eapply ent_assume_pure; first done. intros ->. + apply ent_prove_pure. f_equiv. f_equiv. apply gcd_step. + } +Qed. + +Lemma euclid_step_0 (a : Z) : + {{ True }} euclid #a #0 {{ v, ⌜v = #a⌝ }}. +Proof. + unfold euclid. eapply hoare_pure_step. + { apply (pure_step_fill [AppLCtx _]). apply pure_step_beta. } + fold euclid. simpl. apply hoare_let. simpl. + eapply hoare_pure_step. + { apply (pure_step_fill [IfCtx _ _]). apply pure_step_eq. lia. } + simpl. apply hoare_if_true. + apply hoare_value_con. by apply ent_prove_pure. +Qed. + +Lemma euclid_proof (a b : Z) : + {{ ⌜(0 ≤ a ∧ 0 ≤ b)%Z⌝ }} euclid #a #b {{ c, ⌜c = #(Z.gcd a b)⌝ }}. +Proof. + eapply hoare_pure_pre. intros (Ha & Hb). + revert b Hb a Ha. refine (Z_nonneg_ind _ _). + intros b Hb IH a Ha. + destruct (decide (b = 0)) as [ -> | Hneq0]. + - eapply hoare_con; last apply euclid_step_0. + { done. } + { intros v. simpl. eapply ent_assume_pure; first done. intros ->. + apply ent_prove_pure. + rewrite Z.gcd_0_r Z.abs_eq; first done. lia. + } + - (* use a mod b < b *) + eapply hoare_con; last apply euclid_step_gt0. + { apply ent_and_intro; apply ent_prove_pure; lia. } + { done. } + intros c. apply hoare_pure_pre. intros. + eapply hoare_con; last eapply IH; [ done | done | lia.. ]. +Qed. + +(** Exercise: Factorial *) +Definition fac : val := + rec: "fac" "n" := + if: "n" = #0 then #1 + else "n" * "fac" ("n" - #1). + + + +Fixpoint Fac (n : nat) := + match n with + | 0 => 1 + | S n => (S n) * Fac n + end. +Lemma fac_computes_Fac (n : nat) : + {{ True }} fac #n {{ v, ⌜v = #(Fac n)⌝ }}. +Proof. + (* TODO: exercise *) +Admitted. + + +(** * Separation Logic *) +(*Check ent_sep_weaken.*) +(*Check ent_sep_true.*) +(*Check ent_sep_comm.*) +(*Check ent_sep_split.*) +(*Check ent_sep_assoc.*) +(*Check ent_pointsto_sep.*) +(*Check ent_exists_sep.*) + +(* Note: The separating conjunction can usually be typed with \ast or \sep *) + + +Lemma ent_pointsto_disj l l' v w : + l ↦ v ∗ l' ↦ w ⊢ ⌜l ≠ l'⌝. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma ent_sep_exists {X} (Φ : X → iProp) P : + (∃ x : X, Φ x ∗ P) ⊣⊢ (∃ x : X, Φ x) ∗ P. +Proof. + (* TODO: exercise *) +Admitted. + + + +(** ** Example: Chains *) +Fixpoint chain_pre n l r : iProp := + match n with + | 0 => ⌜l = r⌝ + | S n => ∃ t : loc, l ↦ #t ∗ chain_pre n t r + end. +Definition chain l r : iProp := ∃ n, ⌜n > 0⌝ ∗ chain_pre n l r. + +Lemma chain_single (l r : loc) : + l ↦ #r ⊢ chain l r. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma chain_cons (l r t : loc) : + l ↦ #r ∗ chain r t ⊢ chain l t. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma chain_trans (l r t : loc) : + chain l r ∗ chain r t ⊢ chain l t. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma chain_sep_false (l r t : loc) : + chain l r ∗ chain l t ⊢ False. +Proof. + (* TODO: exercise *) +Admitted. + + +Definition cycle l := chain l l. +Lemma chain_cycle l r : + chain l r ∗ chain r l ⊢ cycle l. +Proof. + apply chain_trans. +Qed. + + +(** New Hoare rules *) +(*Check hoare_frame.*) +(*Check hoare_new.*) +(*Check hoare_store.*) +(*Check hoare_load.*) + +Lemma hoare_pure_pre_sep_l (ϕ : Prop) Q Φ e : + (ϕ → {{ Q }} e {{ Φ }}) → + {{ ⌜ϕ⌝ ∗ Q }} e {{ Φ }}. +Proof. + intros He. + eapply hoare_pure. + { apply ent_sep_weaken. } + intros ?. + eapply hoare_con; last by apply He. + - rewrite ent_sep_comm. apply ent_sep_weaken. + - done. +Qed. + +(* Enables rewriting with equivalences ⊣⊢ in pre/post condition *) +#[export] Instance hoare_proper : + Proper (equiv ==> eq ==> (pointwise_relation val (⊢)) ==> impl) hoare. +Proof. + intros P1 P2 HP%ent_equiv e1 e2 <- Φ1 Φ2 HΦ Hp. + eapply hoare_con; last done. + - apply HP. + - done. +Qed. + +Definition assert e := (if: e then #() else #0 #0)%E. + +Lemma hoare_assert P e : + {{ P }} e {{ v, ⌜v = #true⌝ }} → + {{ P }} assert e {{ v, ⌜v = #()⌝ }}. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma frame_example (f : val) : + (∀ l l' : loc, {{ l ↦ #0 }} f #l #l' {{ _, l ↦ #42 }}) → + {{ True }} + let: "x" := ref #0 in + let: "y" := ref #42 in + (f "x" "y";; + assert (!"x" = !"y")) + {{ _, True }}. +Proof. + intros Hf. + eapply hoare_bind with (K := [AppRCtx _]). + { apply hoare_new. } + intros v. simpl. + apply hoare_exist_pre. intros l. + apply hoare_pure_pre_sep_l. intros ->. + eapply hoare_let. simpl. + + eapply hoare_bind with (K := [AppRCtx _]). + { eapply hoare_con_pre. { apply ent_sep_true. } + eapply hoare_frame. apply hoare_new. } + intros v. simpl. + + rewrite -ent_sep_exists. apply hoare_exist_pre. intros l'. + rewrite -ent_sep_assoc. eapply hoare_pure_pre_sep_l. intros ->. + eapply hoare_let. simpl. + eapply hoare_bind with (K := [AppRCtx _]). + { rewrite ent_sep_comm. eapply hoare_frame. apply Hf. } + intros v. simpl. + + apply hoare_let. simpl. + eapply hoare_con_post; first last. + { apply hoare_assert. + eapply hoare_bind with (K := [BinOpRCtx _ _]). + { rewrite ent_sep_comm. apply hoare_frame. apply hoare_load. } + intros v'. simpl. rewrite -ent_sep_assoc. apply hoare_pure_pre_sep_l. + intros ->. + + eapply hoare_bind with (K := [BinOpLCtx _ _]). + { rewrite ent_sep_comm. apply hoare_frame. apply hoare_load. } + intros v'. simpl. rewrite -ent_sep_assoc. apply hoare_pure_pre_sep_l. + intros ->. + + eapply hoare_pure_step. { by apply pure_step_eq. } + eapply hoare_value_con. by apply ent_prove_pure. + } + intros. apply ent_true. +Qed. + +(** Exercise: swap *) +Definition swap : val := + λ: "l" "r", let: "t" := ! "r" in "r" <- !"l";; "l" <- "t". + +Lemma swap_correct (l r: loc) (v w: val): + {{ l ↦ v ∗ r ↦ w }} swap #l #r {{ _, l ↦ w ∗ r ↦ v }}. +Proof. + (* TODO: exercise *) +Admitted. + + + + +(** ** Case study: lists *) +Fixpoint is_ll (xs : list val) (v : val) : iProp := + match xs with + | [] => ⌜v = NONEV⌝ + | x :: xs => + ∃ (l : loc) (w : val), + ⌜v = SOMEV #l⌝ ∗ l ↦ (x, w) ∗ is_ll xs w + end. + +Definition new_ll : val := + λ: <>, NONEV. + +Definition cons_ll : val := + λ: "h" "l", SOME (ref ("h", "l")). + +Definition head_ll : val := + λ: "x", match: "x" with NONE => #() | SOME "r" => Fst (!"r") end. +Definition tail_ll : val := + λ: "x", match: "x" with NONE => #() | SOME "r" => Snd (!"r") end. + +Definition len_ll : val := + rec: "len" "x" := match: "x" with NONE => #0 | SOME "r" => #1 + "len" (Snd !"r") end. + +Definition app_ll : val := + rec: "app" "x" "y" := + match: "x" with NONE => "y" | SOME "r" => + let: "rs" := !"r" in + "r" <- (Fst "rs", "app" (Snd "rs") "y");; + SOME "r" + end. + + +Lemma app_ll_correct xs ys v w : + {{ is_ll xs v ∗ is_ll ys w }} app_ll v w {{ u, is_ll (xs ++ ys) u }}. +Proof. + induction xs as [ | x xs IH] in v |-*. + - simpl. apply hoare_pure_pre_sep_l. intros ->. + eapply hoare_bind with (K := [AppLCtx _]). + { apply hoare_rec. simpl. + eapply hoare_pure_steps. + { apply pure_step_val. done. } + eapply hoare_value'. + } + intros v'. simpl. rewrite ent_sep_comm. apply hoare_pure_pre_sep_l. intros ->. + + apply hoare_rec. simpl. + eapply hoare_pure_step. { apply pure_step_match_injl. } + apply hoare_let. simpl. apply hoare_value. + - simpl. rewrite -ent_sep_exists. apply hoare_exist_pre. + intros l. rewrite -ent_sep_exists. apply hoare_exist_pre. + intros w'. rewrite -ent_sep_assoc. apply hoare_pure_pre_sep_l. intros ->. + + eapply hoare_bind with (K := [AppLCtx _ ]). + { apply hoare_rec. simpl. + eapply hoare_pure_steps. {apply pure_step_val. done. } + eapply hoare_value'. + } + intros v'. simpl. rewrite ent_sep_comm. apply hoare_pure_pre_sep_l. intros ->. + + apply hoare_rec. simpl. + eapply hoare_pure_step. {apply pure_step_match_injr. } + apply hoare_let. simpl. + eapply hoare_bind with (K := [AppRCtx _]). + { apply hoare_frame. apply hoare_frame. apply hoare_load. } + intros v. simpl. + rewrite -!ent_sep_assoc. apply hoare_pure_pre_sep_l. intros ->. + apply hoare_let. simpl. + + eapply hoare_bind with (K := [PairRCtx _; StoreRCtx _; AppRCtx _]). + { eapply hoare_bind with (K := [AppRCtx _; AppLCtx _]). + { eapply hoare_pure_step. { apply pure_step_snd. } + apply hoare_value'. + } + intros v. simpl. fold app_ll. + rewrite ent_sep_comm. apply hoare_pure_pre_sep_l. intros ->. + rewrite ent_sep_comm. eapply hoare_frame. + apply IH. + } + intros v. simpl. + eapply hoare_bind with (K := [PairLCtx _; StoreRCtx _; AppRCtx _]). + { eapply hoare_pure_step. { apply pure_step_fst. } + apply hoare_value'. + } + intros v'. simpl. rewrite ent_sep_comm. apply hoare_pure_pre_sep_l. intros ->. + eapply hoare_bind with (K := [AppRCtx _]). + { rewrite ent_sep_comm. apply hoare_frame. + eapply hoare_bind with (K := [StoreRCtx _]). + { eapply hoare_pure_steps. + { eapply pure_step_val. eauto. } + eapply hoare_value'. + } + intros v'. simpl. rewrite ent_sep_comm. apply hoare_pure_pre_sep_l. intros ->. + apply hoare_store. + } + intros v'. simpl. apply hoare_let. simpl. + eapply hoare_pure_steps. + { eapply pure_step_val. eauto. } + eapply hoare_value_con. + eapply ent_exist_intro. eapply ent_exist_intro. + etrans. { apply ent_sep_true. } + eapply ent_sep_split. + { apply ent_prove_pure. done. } + apply ent_sep_split; reflexivity. +Qed. + +(** Exercise: linked lists *) +Lemma new_ll_correct : + {{ True }} new_ll #() {{ v, is_ll [] v }}. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma cons_ll_correct (v x : val) xs : + {{ is_ll xs v }} cons_ll x v {{ u, is_ll (x :: xs) u }}. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma head_ll_correct (v x : val) xs : + {{ is_ll (x :: xs) v }} head_ll v {{ w, ⌜w = x⌝ }}. +Proof. + (* TODO: exercise *) +Admitted. + + +Lemma tail_ll_correct v x xs : + {{ is_ll (x :: xs) v }} tail_ll v {{ w, is_ll xs w }}. +Proof. + (* TODO: exercise *) +Admitted. + + + +Lemma len_ll_correct v xs : + {{ is_ll xs v }} len_ll v {{ w, ⌜w = #(length xs)⌝ ∗ is_ll xs v }}. +Proof. + (* TODO: exercise *) +Admitted. + + +(** Exercise: State and prove a strengthened specification for [tail]. *) +Lemma tail_ll_strengthened v x xs : + {{ is_ll (x :: xs) v }} tail_ll v {{ w, False (* FIXME *) }}. +Proof. + (* FIXME: exercise *) +Abort. + diff --git a/theories/program_logics/hoare_lib.v b/theories/program_logics/hoare_lib.v new file mode 100644 index 0000000..aa20491 --- /dev/null +++ b/theories/program_logics/hoare_lib.v @@ -0,0 +1,725 @@ +From iris.prelude Require Import options. +From iris.proofmode Require Import tactics. +From iris.heap_lang Require Import lang notation. +From iris.base_logic Require Export invariants. +From semantics.pl.heap_lang Require Export primitive_laws_nolater. +From semantics.pl.heap_lang Require Import adequacy proofmode. + + +Module hoare. + (* We make "ghost_state" an axiom for now to simplify the Coq development. + In the future, we will quantify over it. *) + Axiom ghost_state: heapGS heapΣ. + #[export] Existing Instance ghost_state. + + (* the type of preconditions and postconditions *) + Notation iProp := (iProp heapΣ). + Implicit Types + (P Q R: iProp) + (φ ψ: Prop) + (e: expr) + (v: val). + + Lemma ent_equiv P Q : + (P ⊣⊢ Q) ↔ (P ⊢ Q) ∧ (Q ⊢ P). + Proof. apply bi.equiv_entails. Qed. + + (* Rules for entailment *) + Lemma ent_refl P: + P ⊢ P. + Proof. eauto. Qed. + + Lemma ent_trans P Q R: + (P ⊢ Q) → (Q ⊢ R) → (P ⊢ R). + Proof. by intros ->. Qed. + + (* NOTE: True = ⌜True⌝ *) + + (* NOTE: False = ⌜False⌝ *) + + Lemma ent_prove_pure P φ: + φ → P ⊢ ⌜φ⌝. + Proof. eauto. Qed. + + Lemma ent_assume_pure P Q φ: + (P ⊢ ⌜φ⌝) → + (φ → P ⊢ Q) → + P ⊢ Q. + Proof. + iIntros (Hent Hpost) "P". iPoseProof (Hent with "P") as "%". + by iApply Hpost. + Qed. + + Lemma ent_and_elim_r P Q : + P ∧ Q ⊢ Q. + Proof. + iIntros "[_ $]". + Qed. + + Lemma ent_and_elim_l P Q : + P ∧ Q ⊢ P. + Proof. + iIntros "[$ _ ]". + Qed. + + Lemma ent_and_intro P Q R : + (P ⊢ Q) → + (P ⊢ R) → + P ⊢ Q ∧ R. + Proof. + iIntros (HQ HR) "HP". iSplit. + + by iApply HQ. + + by iApply HR. + Qed. + + Lemma ent_or_introl P Q : + P ⊢ P ∨ Q. + Proof. eauto. Qed. + + Lemma ent_or_intror P Q : + Q ⊢ P ∨ Q. + Proof. eauto. Qed. + + Lemma ent_or_elim P Q R : + (P ⊢ R) → + (Q ⊢ R) → + P ∨ Q ⊢ R. + Proof. + iIntros (HP HQ) "[HP | HQ]"; [by iApply HP | by iApply HQ]. + Qed. + + Lemma ent_all_intro {X} P Φ : + (∀ x : X, P ⊢ Φ x) → + P ⊢ ∀ x : X, Φ x. + Proof. + iIntros (Hx) "HP". iIntros(x). + by iApply Hx. + Qed. + + Lemma ent_all_elim {X} (x : X) (Φ : _ → iProp) : + (∀ x, Φ x) ⊢ Φ x. + Proof. eauto. Qed. + + Lemma ent_exist_intro {X} (x : X) P Φ : + (P ⊢ Φ x) → + P ⊢ ∃ x, Φ x. + Proof. + iIntros (HP) "HP". iExists x. by iApply HP. + Qed. + + Lemma ent_exist_elim {X} Φ Q : + (∀ x : X, (Φ x ⊢ Q)) → + (∃ x, Φ x) ⊢ Q. + Proof. + iIntros (HQ) "(%x & Hx)". by iApply HQ. + Qed. + + (** Separating conjunction rules *) + Lemma ent_sep_comm P Q: + P ∗ Q ⊣⊢ Q ∗ P. + Proof. iSplit; iIntros "[$ $]". Qed. + + Lemma ent_sep_assoc P1 P2 P3: + P1 ∗ (P2 ∗ P3) ⊣⊢ (P1 ∗ P2) ∗ P3. + Proof. + iSplit. + - iIntros "[$ [$ $]]". + - iIntros "[[$ $] $]". + Qed. + + Lemma ent_sep_split P P' Q Q': + (P ⊢ Q) → (P' ⊢ Q') → (P ∗ P') ⊢ Q ∗ Q'. + Proof. + by intros -> ->. + Qed. + + Lemma ent_sep_true P : + P ⊢ True ∗ P. + Proof. + iIntros "$". + Qed. + + Lemma ent_sep_weaken P Q: + P ∗ Q ⊢ P. + Proof. + iIntros "[$ _]". + Qed. + + Lemma ent_pointsto_sep l v w : + l ↦ v ∗ l ↦ w ⊢ False. + Proof. + iIntros "[Ha Hb]". + iPoseProof (mapsto_ne with "Ha Hb") as "%Hneq". + done. + Qed. + + Lemma ent_exists_sep {X} (Φ : X → iProp) P : + (∃ x : X, Φ x) ∗ P ⊢ (∃ x : X, Φ x ∗ P). + Proof. + iIntros "((%x & Hx) & Hp)". eauto with iFrame. + Qed. + + (** Magic wand rules *) + Lemma ent_wand_intro P Q R : + (P ∗ Q ⊢ R) → + (P ⊢ Q -∗ R). + Proof. + iIntros (Hr) "HP HQ". iApply Hr. iFrame. + Qed. + + Lemma ent_wand_elim P Q R : + (P ⊢ Q -∗ R) → + P ∗ Q ⊢ R. + Proof. + iIntros (Hr) "[HP HQ]". iApply (Hr with "HP HQ"). + Qed. + + + (** Hoare rules *) + Implicit Types + (Φ Ψ: val → iProp). + Definition hoare P (e: expr) Φ := P ⊢ WP e {{ Φ }}. + + Global Notation "{{ P } } e {{ Φ } }" := (hoare P%I e%E Φ%I) + (at level 20, P, e, Φ at level 200, + format "{{ P } } e {{ Φ } }") : stdpp_scope. + + Global Notation "{{ P } } e {{ v , Q } }" := (hoare P%I e%E (λ v, Q)%I) + (at level 20, P, e, Q at level 200, + format "{{ P } } e {{ v , Q } }") : stdpp_scope. + + (* Rules for Hoare triples *) + Lemma hoare_value v Φ: + {{ Φ v }} v {{ Φ }}. + Proof. + iIntros "H". by iApply wp_value. + Qed. + + Lemma hoare_con P Q Φ Ψ e: + (P ⊢ Q) → + (∀ v, Ψ v ⊢ Φ v) → + {{ Q }} e {{ Ψ }} → + {{ P }} e {{ Φ }}. + Proof. + iIntros (Hpre Hpost Hhoare) "P". + iApply wp_mono; eauto. + iApply Hhoare. by iApply Hpre. + Qed. + + + Lemma hoare_bind K P Φ Ψ e: + {{ P }} e {{ Ψ }} → + (∀ v, {{ Ψ v }} fill K (Val v) {{ Φ }}) → + {{ P }} (fill K e) {{ Φ }}. + Proof. + iIntros (Hexpr Hctx) "P". + iApply wp_bind'. + iApply wp_mono; eauto. + by iApply Hexpr. + Qed. + + Lemma hoare_pure P φ Φ e: + (P ⊢ ⌜φ⌝) → + (φ → {{ P }} e {{ Φ }}) → + {{ P }} e {{ Φ }}. + Proof. + intros Hent Hhoare. + iIntros "P". iPoseProof (Hent with "P") as "%". + by iApply Hhoare. + Qed. + + Lemma hoare_exist_pre {X} (Φ : X → _) Ψ e : + (∀ x : X, {{ Φ x }} e {{ Ψ }}) → + {{ ∃ x : X, Φ x }} e {{ Ψ }}. + Proof. + iIntros (Hs) "(%x & Hx)". by iApply Hs. + Qed. + + Lemma hoare_pure_step P Ψ e1 e2 : + pure_step e1 e2 → + {{ P }} e2 {{ Ψ }} → + {{ P }} e1 {{ Ψ }}. + Proof. + iIntros (Hpure He2) "HP". + iApply (lifting.wp_pure_step_later _ _ _ _ _ True). + - intros _. econstructor 2; [done | econstructor]. + - done. + - iNext. iApply He2. done. + Qed. + + Lemma hoare_pure_steps P Ψ e1 e2 : + rtc pure_step e1 e2 → + {{ P }} e2 {{ Ψ }} → + {{ P }} e1 {{ Ψ }}. + Proof. + induction 1; eauto using hoare_pure_step. + Qed. + + (** Pure step rules *) + Lemma PureExec_1_equiv e1 e2 : + (∃ ϕ, ϕ ∧ PureExec ϕ 1 e1 e2) ↔ + pure_step e1 e2. + Proof. + split. + - intros (ϕ & H & Hp). by specialize (Hp H) as ?%nsteps_once_inv. + - intros Hp. exists True. split; first done. + intros _. econstructor; first done. constructor. + Qed. + + Lemma PureExec_1_elim (ϕ : Prop) e1 e2 : + ϕ → PureExec ϕ 1 e1 e2 → + pure_step e1 e2. + Proof. + intros H Hp. apply PureExec_1_equiv. eauto. + Qed. + + Lemma pure_step_fill K (e1 e2: expr): + pure_step e1 e2 → pure_step (fill K e1) (fill K e2). + Proof. + intros Hp. apply PureExec_1_equiv. + exists True. split; first done. + apply pure_exec_ctx; first apply _. + intros _. apply nsteps_once. done. + Qed. + + Lemma rtc_pure_step_fill K (e1 e2: expr): + rtc pure_step e1 e2 → rtc pure_step (fill K e1) (fill K e2). + Proof. + induction 1; first reflexivity. + econstructor; last done. by eapply pure_step_fill. + Qed. + Lemma pure_step_add (n m : Z) : + pure_step (#n + #m) (#(n + m)). + Proof. + eapply PureExec_1_elim; last apply _. done. + Qed. + Lemma pure_step_sub (n m : Z) : + pure_step (#n - #m) (#(n - m)). + Proof. + eapply PureExec_1_elim; last apply _. done. + Qed. + Lemma pure_step_mul (n m : Z) : + pure_step (#n * #m) (#(n * m)). + Proof. + eapply PureExec_1_elim; last apply _. done. + Qed. + Lemma pure_step_quot (n m : Z) : + m ≠ 0 → pure_step (#n `quot` #m) (#(Z.quot n m)). + Proof. + intros _. eapply PureExec_1_elim; last apply _. done. + Qed. + Lemma pure_step_eq (n m : Z) : + n = m → pure_step (#n = #m) #true. + Proof. + intros. eapply PureExec_1_elim; last apply _. + unfold bin_op_eval. simpl. + rewrite bool_decide_eq_true_2; subst; done. + Qed. + Lemma pure_step_neq (n m : Z) : + n ≠ m → pure_step (#n = #m) #false. + Proof. + intros. eapply PureExec_1_elim; last apply _. + unfold bin_op_eval. simpl. + rewrite bool_decide_eq_false_2; first done. + intros [= Heq]; done. + Qed. + Lemma pure_step_beta f x e v : + pure_step ((rec: f x := e)%V v) (subst' x v (subst' f (rec: f x := e) e)). + Proof. + eapply PureExec_1_elim; last apply _. done. + Qed. + Lemma pure_step_if_true e1 e2 : + pure_step (if: #true then e1 else e2) e1. + Proof. + eapply PureExec_1_elim; last apply _. done. + Qed. + Lemma pure_step_if_false e1 e2 : + pure_step (if: #false then e1 else e2) e2. + Proof. + eapply PureExec_1_elim; last apply _. done. + Qed. + Lemma pure_step_match_injl v x1 x2 e1 e2 : + pure_step (match: InjLV v with InjL x1 => e1 | InjR x2 => e2 end) ((λ: x1, e1) v). + Proof. + by eapply PureExec_1_elim; last apply _. + Qed. + Lemma pure_step_match_injr v x1 x2 e1 e2 : + pure_step (match: InjRV v with InjL x1 => e1 | InjR x2 => e2 end) ((λ: x2, e2) v). + Proof. + by eapply PureExec_1_elim; last apply _. + Qed. + Lemma pure_step_fst v1 v2 : + pure_step (Fst (v1, v2)%V) v1. + Proof. + by eapply PureExec_1_elim; last apply _. + Qed. + Lemma pure_step_snd v1 v2 : + pure_step (Snd (v1, v2)%V) v2. + Proof. + by eapply PureExec_1_elim; last apply _. + Qed. + + (** In our Coq formalization, a bit of an additional effort arises due to the handling of values: + values are always represented using the [Val] constructor, and fully reduced expressions take an additional + step of computation to get to a [Val]. + See for instance the constructors [PairS], [InjLS], [InjRS]. + + Therefore, we need an additional rule, [pure_step_val]. + *) + Lemma pure_step_val_fun f x e : + rtc pure_step (rec: f x := e)%E (rec: f x := e)%V. + Proof. + eapply rtc_nsteps. exists 1. eapply pure_exec. done. + Qed. + Lemma pure_step_val_pair e1 e2 v1 v2 : + rtc pure_step e1 v1 → + rtc pure_step e2 v2 → + rtc pure_step (e1, e2)%E (v1, v2)%V. + Proof. + etransitivity; first etransitivity. + + by eapply rtc_pure_step_fill with (K := [PairRCtx _]). + + by eapply rtc_pure_step_fill with (K := [PairLCtx _]). + + simpl. eapply rtc_nsteps. exists 1. eapply pure_exec. done. + Qed. + Lemma pure_step_val_injl e1 v1 : + rtc pure_step e1 v1 → + rtc pure_step (InjL e1) (InjLV v1). + Proof. + etransitivity. + + by eapply rtc_pure_step_fill with (K := [InjLCtx]). + + simpl. eapply rtc_nsteps. exists 1. eapply pure_exec. done. + Qed. + Lemma pure_step_val_injr e1 v1 : + rtc pure_step e1 v1 → + rtc pure_step (InjR e1) (InjRV v1). + Proof. + etransitivity. + + by eapply rtc_pure_step_fill with (K := [InjRCtx]). + + simpl. eapply rtc_nsteps. exists 1. eapply pure_exec. done. + Qed. + Local Hint Resolve pure_step_val_fun pure_step_val_pair pure_step_val_injl pure_step_val_injr : core. + + (** For convenience: a lemma to cover all of these cases, with a precondition that + can be easily solved by eatuto *) + Inductive expr_is_val : expr → val → Prop := + | expr_is_val_base v: + expr_is_val (Val v) v + | expr_is_val_fun f x e: + expr_is_val (rec: f x := e)%E (rec: f x := e)%V + | expr_is_val_pair e1 e2 v1 v2: + expr_is_val e1 v1 → + expr_is_val e2 v2 → + expr_is_val (e1, e2)%E (v1, v2)%V + | expr_is_val_inj_l e v: + expr_is_val e v → + expr_is_val (InjL e)%E (InjLV v)%V + | expr_is_val_inj_r e v: + expr_is_val e v → + expr_is_val (InjR e)%E (InjRV v)%V. + #[export] + Hint Constructors expr_is_val : core. + Lemma expr_is_val_of_val v : + expr_is_val (of_val v) v. + Proof. + destruct v; simpl; constructor. + Qed. + #[export] + Hint Resolve expr_is_val_of_val : core. + + Lemma pure_step_val e v: + expr_is_val e v → + rtc pure_step e v. + Proof. + intros Hexpr. induction Hexpr; eauto. econstructor. + Qed. + + Lemma hoare_new v : + {{ True }} ref v {{ w, ∃ l : loc, ⌜w = #l⌝ ∗ l ↦ v }}. + Proof. + iIntros "_". wp_alloc l as "Hl". iApply wp_value. eauto with iFrame. + Qed. + + Lemma hoare_load l v: + {{ l ↦ v }} ! #l {{ w, ⌜w = v⌝ ∗ l ↦ v }}. + Proof. + iIntros "Hl". wp_load. iApply wp_value. iFrame. done. + Qed. + + Lemma hoare_store l (v w: val): + {{ l ↦ v }} #l <- w {{ _, l ↦ w }}. + Proof. + iIntros "Hl". wp_store. iApply wp_value. iFrame. + Qed. + + Lemma hoare_frame P F Φ e: + {{ P }} e {{ Φ }} → + {{ P ∗ F }} e {{ v, Φ v ∗ F }}. + Proof. + iIntros (Hhoare) "[P $]". by iApply Hhoare. + Qed. + + (* Prevent printing of magic wands *) + Notation "P -∗ Q" := (bi_entails P Q) (only parsing) : stdpp_scope. + + + (** Weakest precondition rules *) + Lemma ent_wp_value Φ v : + Φ v ⊢ WP of_val v {{ w, Φ w }}. + Proof. + iIntros "Hv". by iApply wp_value. + Qed. + + Lemma ent_wp_wand' Φ Ψ e : + (∀ v, Φ v -∗ Ψ v) -∗ WP e {{ Φ }} -∗ WP e {{ Ψ }}. + Proof. + iIntros "Hp Hwp". iApply (wp_wand with "Hwp Hp"). + Qed. + + Lemma ent_wp_wand Φ Ψ e : + (∀ v, Φ v -∗ Ψ v) ∗ WP e {{ Φ }} ⊢ WP e {{ Ψ }}. + Proof. + iIntros "[Hp Hwp]". iApply (wp_wand with "Hwp Hp"). + Qed. + + Lemma ent_wp_bind e K Φ : + WP e {{ v, WP fill K (Val v) {{ Φ }} }} ⊢ WP fill K e {{ Φ }}. + Proof. + iApply wp_bind. + Qed. + + Lemma ent_wp_pure_step e e' Φ : + pure_step e e' → + WP e' {{ Φ }} ⊢ WP e {{ Φ }}. + Proof. + iIntros (Hpure) "Hwp". iApply (lifting.wp_pure_step_later _ _ _ _ _ True 1); last iApply "Hwp"; last done. + intros _. apply nsteps_once. apply Hpure. + Qed. + + Lemma ent_wp_new v Φ : + (∀ l : loc, l ↦ v -∗ Φ #l) ⊢ WP ref (Val v) {{ Φ }}. + Proof. + iIntros "Hs". wp_alloc l as "Hl". wp_value_head. by iApply "Hs". + Qed. + + Lemma ent_wp_load l v Φ : + l ↦ v ∗ (l ↦ v -∗ Φ v) ⊢ WP !#l {{ Φ }}. + Proof. + iIntros "(Hl & Hp)". wp_load. wp_value_head. by iApply "Hp". + Qed. + + Lemma ent_wp_store l v w Φ : + l ↦ w ∗ (l ↦ v -∗ Φ #()) ⊢ WP #l <- Val v {{ Φ }}. + Proof. + iIntros "(Hl & Hp)". wp_store. wp_value_head. by iApply "Hp". + Qed. + + + (** Persistency *) + Lemma ent_pers_dup P : + □ P ⊢ (□ P) ∗ (□ P). + Proof. + iIntros "#HP". eauto. + Qed. + + Lemma ent_pers_elim P : + □ P ⊢ P. + Proof. + iIntros "#$". + Qed. + + Lemma ent_pers_mono P Q : + (P ⊢ Q) → + □ P ⊢ □ Q. + Proof. + iIntros (HPQ) "#HP !>". by iApply HPQ. + Qed. + + Lemma ent_pers_pure (ϕ : Prop) : + ⌜ϕ⌝ ⊢ (□ ⌜ϕ⌝ : iProp). + Proof. + iIntros "#$". + Qed. + + Lemma ent_pers_and_sep P Q : + (□ P) ∧ Q ⊢ (□ P) ∗ Q. + Proof. + iIntros "(#$ & $)". + Qed. + + Lemma ent_pers_idemp P : + □ P ⊢ □ □ P. + Proof. + iIntros "#$". + Qed. + + Lemma ent_pers_all {X} (Φ : X → iProp) : + (∀ x : X, □ Φ x) ⊢ □ ∀ x : X, Φ x. + Proof. + iIntros "#Hx" (x). iApply "Hx". + Qed. + + Lemma ent_pers_exists {X} (Φ : X → iProp) : + (□ ∃ x : X, Φ x) ⊢ ∃ x : X, □ Φ x. + Proof. + iIntros "(%x & #Hx)". iExists x. done. + Qed. + + (** Invariants *) + Implicit Type + (F : iProp) + (N : namespace) + (E : coPset) + . + Lemma ent_inv_pers F N : + inv N F ⊢ □ inv N F. + Proof. + iIntros "#$". + Qed. + Lemma ent_inv_alloc F P N E e Φ : + (P ∗ inv N F ⊢ WP e @ E {{ Φ }}) → + (P ∗ F ⊢ WP e @ E {{ Φ }}). + Proof. + iIntros (Ha) "[HP HF]". + iMod (inv_alloc N with "HF") as "#Hinv". + iApply Ha. iFrame "Hinv ∗". + Qed. + Lemma inv_alloc N F E e Φ : + F -∗ + (inv N F -∗ WP e @ E {{ Φ }}) -∗ + WP e @ E {{ Φ }}. + Proof. + iIntros "HF Hs". + iMod (inv_alloc N with "HF") as "#Hinv". + by iApply "Hs". + Qed. + + (** We require a sidecondition here, namely that [F] is "timeless". All propositions we have seen up to now are in fact timeless. + We will see propositions that do not satisfy this requirement and which need a stronger rule for invariants soon. + *) + Lemma ent_inv_open `{!Timeless F} P N E e Φ : + (P ∗ F ⊢ WP e @ (E ∖ ↑N) {{ v, F ∗ Φ v }}) → + ↑N ⊆ E → + (P ∗ inv N F ⊢ WP e @ E {{ Φ }}). + Proof. + iIntros (Ha Hincl) "(HP & #Hinv)". + iMod (inv_acc_timeless with "Hinv") as "(HF & Hcl)"; first done. + iApply wp_fupd'. iApply wp_wand_r. + iSplitR "Hcl". { iApply Ha. iFrame. } + iIntros (v) "[HF Hphi]". iMod ("Hcl" with "HF"). done. + Qed. + Lemma inv_open `{!Timeless F} N E e Φ : + ↑N ⊆ E → + inv N F -∗ + (F -∗ WP e @ (E ∖ ↑N) {{ v, F ∗ Φ v }})%I -∗ + WP e @ E {{ Φ }}. + Proof. + iIntros (Hincl) "#Hinv Hs". + iMod (inv_acc_timeless with "Hinv") as "(HF & Hcl)"; first done. + iApply wp_fupd'. iApply wp_wand_r. + iSplitR "Hcl". { iApply "Hs". iFrame. } + iIntros (v) "[HF Hphi]". iMod ("Hcl" with "HF"). done. + Qed. + + + (** Later *) + Lemma ent_later_intro P : + P ⊢ ▷ P. + Proof. + iIntros "$". + Qed. + + Lemma ent_later_mono P Q : + (P ⊢ Q) → + (▷ P ⊢ ▷ Q). + Proof. + iIntros (Hs) "HP!>". by iApply Hs. + Qed. + + Lemma ent_löb P : + (▷ P ⊢ P) → + True ⊢ P. + Proof. + iIntros (Hs) "_". + iLöb as "IH". by iApply Hs. + Qed. + + Lemma ent_later_sep P Q : + ▷ (P ∗ Q) ⊣⊢ (▷ P) ∗ (▷ Q). + Proof. + iSplit; iIntros "[$ $]". + Qed. + + Lemma ent_later_exists `{Inhabited X} (Φ : X → iProp) : + (▷ (∃ x : X, Φ x)) ⊣⊢ ∃ x : X, ▷ Φ x. + Proof. apply bi.later_exist. Qed. + + Lemma ent_later_all {X} (Φ : X → iProp) : + ▷ (∀ x : X, Φ x) ⊣⊢ ∀ x : X, ▷ Φ x. + Proof. apply bi.later_forall. Qed. + + Lemma ent_later_pers P : + ▷ □ P ⊣⊢ □ ▷ P. + Proof. + iSplit; iIntros "#H !> !>"; done. + Qed. + + Lemma ent_later_wp_pure_step e e' Φ : + pure_step e e' → + ▷ WP e' {{ Φ }} ⊢ WP e {{ Φ }}. + Proof. + iIntros (Hpure%PureExec_1_equiv) "Hwp". + destruct Hpure as (ϕ & Hphi & Hpure). + iApply (lifting.wp_pure_step_later _ _ _ _ _ _ 1); done. + Qed. + + Lemma ent_later_wp_new v Φ : + ▷ (∀ l : loc, l ↦ v -∗ Φ #l) ⊢ WP ref v {{ Φ }}. + Proof. + iIntros "Hp". wp_alloc l as "Hl". iApply wp_value. by iApply "Hp". + Qed. + + Lemma ent_later_wp_load l v Φ : + l ↦ v ∗ ▷ (l ↦ v -∗ Φ v) ⊢ WP ! #l {{ Φ }}. + Proof. + iIntros "[Hl Hp]". wp_load. iApply wp_value. by iApply "Hp". + Qed. + + Lemma ent_later_wp_store l v w Φ : + l ↦ v ∗ ▷ (l ↦ w -∗ Φ #()) ⊢ WP #l <- w {{ Φ }}. + Proof. + iIntros "[Hl Hp]". wp_store. iApply wp_value. by iApply "Hp". + Qed. +End hoare. + +Module impred_invariants. + Import hoare. +Implicit Type + (F : iProp) + (N : namespace) + (E : coPset) +. + +Lemma ent_inv_open P F N E e Φ : + (P ∗ ▷ F ⊢ WP e @ (E ∖ ↑N) {{ v, ▷ F ∗ Φ v }}) → + ↑N ⊆ E → + (P ∗ inv N F ⊢ WP e @ E {{ Φ }}). +Proof. + iIntros (Ha Hincl) "(HP & #Hinv)". + iMod (inv_acc with "Hinv") as "(HF & Hcl)"; first done. + iApply wp_fupd'. iApply wp_wand_r. + iSplitR "Hcl". { iApply Ha. iFrame. } + iIntros (v) "[HF Hphi]". iMod ("Hcl" with "HF"). done. +Qed. +Lemma inv_open N E F e Φ : + ↑N ⊆ E → + inv N F -∗ + (▷ F -∗ WP e @ (E ∖ ↑N) {{ v, ▷ F ∗ Φ v }})%I -∗ + WP e @ E {{ Φ }}. +Proof. + iIntros (Hincl) "#Hinv Hs". + iMod (inv_acc with "Hinv") as "(HF & Hcl)"; first done. + iApply wp_fupd'. iApply wp_wand_r. + iSplitR "Hcl". { iApply "Hs". iFrame. } + iIntros (v) "[HF Hphi]". iMod ("Hcl" with "HF"). done. +Qed. +End impred_invariants. diff --git a/theories/program_logics/program_logic/adequacy.v b/theories/program_logics/program_logic/adequacy.v new file mode 100644 index 0000000..499558f --- /dev/null +++ b/theories/program_logics/program_logic/adequacy.v @@ -0,0 +1,229 @@ +From iris.algebra Require Import gmap auth agree gset coPset. +From iris.proofmode Require Import proofmode. +From iris.base_logic.lib Require Import wsat. +From semantics.pl.program_logic Require Export sequential_wp. +From iris.prelude Require Import options. +Import uPred. + +(** This file contains the adequacy statements of the Iris program logic. First +we prove a number of auxilary results. *) + +Section adequacy. +Context `{!irisGS Λ Σ}. +Implicit Types e : expr Λ. +Implicit Types P Q : iProp Σ. +Implicit Types Φ : val Λ → iProp Σ. +Implicit Types Φs : list (val Λ → iProp Σ). + +Notation wptp s t Φs := ([∗ list] e;Φ ∈ t;Φs, wp' s ∅ e Φ)%I. + +Lemma wp'_step s e1 σ1 e2 σ2 E κs efs Φ : + prim_step e1 σ1 κs e2 σ2 efs → + state_interp σ1 -∗ wp' s E e1 Φ + ={E,∅}=∗ |={∅}▷=> |={∅, E}=> + state_interp σ2 ∗ wp' s E e2 Φ ∗ ⌜efs = []⌝ ∗ ⌜κs = []⌝. +Proof. + rewrite wp'_unfold /wp_pre. + iIntros (?) "Hσ H". + rewrite (val_stuck e1 σ1 κs e2 σ2 efs) //. + iMod ("H" $! σ1 with "Hσ") as "(_ & H)". iSpecialize ("H" with "[//]"). + iModIntro. iApply (step_fupd_wand with "[H]"); first by iApply "H". + iIntros ">(-> & -> & Hσ & H)". eauto with iFrame. +Qed. + +Lemma wptp_step s es1 es2 κ σ1 σ2 Φs : + step (es1,σ1) κ (es2, σ2) → + state_interp σ1 -∗ wptp s es1 Φs -∗ + |={∅,∅}=> |={∅}▷=> |={∅,∅}=> + state_interp σ2 ∗ + wptp s es2 Φs ∗ + ⌜κ= []⌝ ∗ + ⌜length es1 = length es2⌝. +Proof. + iIntros (Hstep) "Hσ Ht". + destruct Hstep as [e1' σ1' e2' σ2' efs t2' t3 Hstep]; simplify_eq/=. + iDestruct (big_sepL2_app_inv_l with "Ht") as (Φs1 Φs2 ->) "[? Ht]". + iDestruct (big_sepL2_cons_inv_l with "Ht") as (Φ Φs3 ->) "[Ht ?]". + iMod (wp'_step with "Hσ Ht") as "H"; first done. iModIntro. + iApply (step_fupd_wand with "H"). iIntros ">($ & He2 & -> & ->) !>". + rewrite !app_nil_r; iFrame. + iPureIntro; split; first done. + rewrite !app_length; simpl; lia. +Qed. + +Lemma wptp_steps s n es1 es2 κs σ1 σ2 Φs : + nsteps n (es1, σ1) κs (es2, σ2) → + state_interp σ1 -∗ wptp s es1 Φs + ={∅,∅}=∗ |={∅}▷=>^n |={∅,∅}=> + state_interp σ2 ∗ + wptp s es2 Φs ∗ + ⌜κs= []⌝ ∗ + ⌜length es1 = length es2⌝. +Proof. + revert es1 es2 κs σ1 σ2 Φs. + induction n as [|n IH]=> es1 es2 κs σ1 σ2 Φs /=. + { inversion_clear 1; iIntros "? ?". iFrame. done. } + iIntros (Hsteps) "Hσ He". inversion_clear Hsteps as [|?? [t1' σ1']]. + iDestruct (wptp_step with "Hσ He") as ">H"; first eauto; simplify_eq. + iModIntro. iApply step_fupd_fupd. iApply (step_fupd_wand with "H"). + iIntros ">(Hσ & He & -> & %)". iMod (IH with "Hσ He") as "IH"; first done. iModIntro. + iApply (step_fupdN_wand with "IH"). iIntros ">IH". + iDestruct "IH" as "(? & ? & -> & %)". + iFrame. iPureIntro. split; first done. lia. +Qed. + +Lemma wp_not_stuck e σ E Φ : + state_interp σ -∗ wp' NotStuck E e Φ ={E}=∗ ⌜not_stuck e σ⌝. +Proof. + rewrite wp'_unfold /wp_pre /not_stuck. iIntros "Hσ H". + destruct (to_val e) as [v|] eqn:?; first by eauto. + iSpecialize ("H" $! σ with "Hσ"). rewrite sep_elim_l. + iMod (fupd_plain_mask with "H") as %?; eauto. +Qed. + +Lemma wptp_strong_adequacy Φs s n es1 es2 κs σ1 σ2 : + nsteps n (es1, σ1) κs (es2, σ2) → + state_interp σ1 -∗ wptp s es1 Φs + ={∅,∅}=∗ |={∅}▷=>^n |={∅,∅}=> + ⌜ ∀ e2, s = NotStuck → e2 ∈ es2 → not_stuck e2 σ2 ⌝ ∗ + state_interp σ2 ∗ + ([∗ list] e;Φ ∈ es2;Φs, from_option Φ True (to_val e)) ∗ + ⌜length es1 = length es2⌝ ∗ + ⌜κs = []⌝. +Proof. + iIntros (Hstep) "Hσ He". iMod (wptp_steps with "Hσ He") as "Hwp"; first done. + iModIntro. iApply (step_fupdN_wand with "Hwp"). + iMod 1 as "(Hσ & Ht & $ & $)"; simplify_eq/=. + iMod (fupd_plain_keep_l ∅ + ⌜ ∀ e2, s = NotStuck → e2 ∈ es2 → not_stuck e2 σ2 ⌝%I + (state_interp σ2 ∗ + wptp s es2 (Φs))%I + with "[$Hσ $Ht]") as "(%&Hσ&Hwp)". + { iIntros "(Hσ & Ht)" (e' -> He'). + move: He' => /(elem_of_list_split _ _)[?[?->]]. + iDestruct (big_sepL2_app_inv_l with "Ht") as (Φs1 Φs2 ?) "[? Hwp]". + iDestruct (big_sepL2_cons_inv_l with "Hwp") as (Φ Φs3 ->) "[Hwp ?]". + iMod (wp_not_stuck with "Hσ Hwp") as "$"; auto. } + iSplitR; first done. iFrame "Hσ". + iApply big_sepL2_fupd. + iApply (big_sepL2_impl with "Hwp"). + iIntros "!#" (? e Φ ??) "Hwp". + destruct (to_val e) as [v2|] eqn:He2'; last done. + apply of_to_val in He2' as <-. simpl. iApply wp'_value_fupd'. done. +Qed. +End adequacy. + +(** Iris's generic adequacy result *) +Theorem wp_strong_adequacy Σ Λ `{!invGpreS Σ} e σ1 n κs t2 σ2 φ : + (∀ `{Hinv : !invGS_gen HasNoLc Σ}, + ⊢ |={⊤}=> ∃ + (s: stuckness) + (stateI : state Λ → iProp Σ) + (Φ : (val Λ → iProp Σ)), + let _ : irisGS Λ Σ := IrisG _ _ Hinv stateI + in + stateI σ1 ∗ + (WP e @ s; ⊤ {{ Φ }}) ∗ + (∀ e', + (* there will only be a single thread *) + ⌜ t2 = [e'] ⌝ -∗ + (* If this is a stuck-free triple (i.e. [s = NotStuck]), then the thread is not stuck *) + ⌜ s = NotStuck → not_stuck e' σ2 ⌝ -∗ + (* The state interpretation holds for [σ2] *) + stateI σ2 -∗ + (* If the thread is done, the post-condition [Φ] holds. + Additionally, we can establish that all invariants will hold in this case. + *) + (from_option (λ v, |={∅,⊤}=> Φ v) True (to_val e')) -∗ + (* Under all these assumptions, we can conclude [φ] in the logic. + In the case that the thread is done, we can use the last assumption to + establish that all invariants hold. + After opening all required invariants, one can use [fupd_mask_subseteq] to introduce the fancy update. *) + |={∅,∅}=> ⌜ φ ⌝)) → + nsteps n ([e], σ1) κs (t2, σ2) → + (* Then we can conclude [φ] at the meta-level. *) + φ. +Proof. + intros Hwp ?. + eapply pure_soundness. + apply (step_fupdN_soundness_no_lc _ n 0)=> Hinv. + iIntros "_". + iMod Hwp as (s stateI Φ) "(Hσ & Hwp & Hφ)". + rewrite /wp swp_eq /swp_def. iMod "Hwp". + iMod (@wptp_strong_adequacy _ _ (IrisG _ _ Hinv stateI) [_] + with "[Hσ] [Hwp]") as "H";[ done | done | | ]. + { by iApply big_sepL2_singleton. } + iAssert (|={∅}▷=>^n |={∅}=> ⌜φ⌝)%I + with "[-]" as "H"; last first. + { destruct n as [ | n ]; first done. iModIntro. by iApply step_fupdN_S_fupd. } + iApply (step_fupdN_wand with "H"). + iMod 1 as "(%Hns & Hσ & Hval & %Hlen & ->) /=". + destruct t2 as [ | e' []]; simpl in Hlen; [lia | | lia]. + rewrite big_sepL2_singleton. + iApply ("Hφ" with "[//] [%] Hσ Hval"). + intros ->. apply Hns; first done. by rewrite elem_of_list_singleton. +Qed. + +(** Since the full adequacy statement is quite a mouthful, we prove some more +intuitive and simpler corollaries. These lemmas are morover stated in terms of +[rtc erased_step] so one does not have to provide the trace. *) +Record adequate {Λ} (s : stuckness) (e1 : expr Λ) (σ1 : state Λ) + (φ : val Λ → state Λ → Prop) := { + adequate_result t2 σ2 v2 : + rtc erased_step ([e1], σ1) (of_val v2 :: t2, σ2) → φ v2 σ2; + adequate_not_stuck t2 σ2 e2 : + s = NotStuck → + rtc erased_step ([e1], σ1) (t2, σ2) → + e2 ∈ t2 → not_stuck e2 σ2 +}. + +Lemma adequate_alt {Λ} s e1 σ1 (φ : val Λ → state Λ → Prop) : + adequate s e1 σ1 φ ↔ ∀ t2 σ2, + rtc erased_step ([e1], σ1) (t2, σ2) → + (∀ v2 t2', t2 = of_val v2 :: t2' → φ v2 σ2) ∧ + (∀ e2, s = NotStuck → e2 ∈ t2 → not_stuck e2 σ2). +Proof. + split. + - intros []; naive_solver. + - constructor; naive_solver. +Qed. + +Theorem adequate_tp_safe {Λ} (e1 : expr Λ) t2 σ1 σ2 φ : + adequate NotStuck e1 σ1 φ → + rtc erased_step ([e1], σ1) (t2, σ2) → + Forall (λ e, is_Some (to_val e)) t2 ∨ ∃ t3 σ3, erased_step (t2, σ2) (t3, σ3). +Proof. + intros Had ?. + destruct (decide (Forall (λ e, is_Some (to_val e)) t2)) as [|Ht2]; [by left|]. + apply (not_Forall_Exists _), Exists_exists in Ht2; destruct Ht2 as (e2&?&He2). + destruct (adequate_not_stuck NotStuck e1 σ1 φ Had t2 σ2 e2) as [?|(κ&e3&σ3&efs&?)]; + rewrite ?eq_None_not_Some; auto. + { exfalso. eauto. } + destruct (elem_of_list_split t2 e2) as (t2'&t2''&->); auto. + right; exists (t2' ++ e3 :: t2'' ++ efs), σ3, κ; econstructor; eauto. +Qed. + +Corollary wp_adequacy Σ Λ `{!invGpreS Σ} s e σ φ : + (∀ `{Hinv : !invGS_gen HasNoLc Σ}, + ⊢ |={⊤}=> ∃ (stateI : state Λ → iProp Σ), + let _ : irisGS Λ Σ := IrisG _ _ Hinv stateI + in + stateI σ ∗ WP e @ s; ⊤ {{ v, ⌜φ v⌝ }}) → + adequate s e σ (λ v _, φ v). +Proof. + intros Hwp. apply adequate_alt; intros t2 σ2 [n [κs ?]]%erased_steps_nsteps. + eapply (wp_strong_adequacy Σ _); [|done]=> ?. + iMod Hwp as (stateI) "[Hσ Hwp]". + iExists s, stateI, (λ v, ⌜φ v⌝%I) => /=. + iIntros "{$Hσ $Hwp} !>" (e2 ->) "% H Hv". + destruct (to_val e2) as [ v2 | ] eqn:Hv. + - simpl. iMod "Hv" as "%". iApply fupd_mask_intro_discard; [done|]. + iSplit; iPureIntro. + + intros ??. destruct t2'; last done. intros [= ->]. + rewrite to_of_val in Hv. injection Hv as ->. done. + + intros ? ?. rewrite elem_of_list_singleton. naive_solver. + - iModIntro. iSplit; iPureIntro. + + intros ??. destruct t2'; last done. intros [= ->]. + rewrite to_of_val in Hv. done. + + intros ? ?. rewrite elem_of_list_singleton. naive_solver. +Qed. diff --git a/theories/program_logics/program_logic/ectx_lifting.v b/theories/program_logics/program_logic/ectx_lifting.v new file mode 100644 index 0000000..b05640f --- /dev/null +++ b/theories/program_logics/program_logic/ectx_lifting.v @@ -0,0 +1,85 @@ +(** Some derived lemmas for ectx-based languages *) +From iris.proofmode Require Import proofmode. +From iris.program_logic Require Export ectx_language. +From semantics.pl.program_logic Require Export sequential_wp lifting. +From iris.prelude Require Import options. + +Section wp. +Context {Λ : ectxLanguage} `{!irisGS Λ Σ} {Hinh : Inhabited (state Λ)}. +Implicit Types s : stuckness. +Implicit Types P : iProp Σ. +Implicit Types Φ : val Λ → iProp Σ. +Implicit Types v : val Λ. +Implicit Types e : expr Λ. +Local Hint Resolve head_prim_reducible head_reducible_prim_step : core. +Local Definition reducible_not_val_inhabitant e := reducible_not_val e inhabitant. +Local Hint Resolve reducible_not_val_inhabitant : core. +Local Hint Resolve head_stuck_stuck : core. + +Lemma wp_lift_head_step_fupd {s E1 E2 Φ} e1 : + to_val e1 = None → + (|={E1, ∅}=> ∀ σ1, state_interp σ1 ={∅,∅}=∗ + ⌜head_reducible e1 σ1⌝ ∗ + ∀ e2 σ2 κ efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={∅}=∗ ▷ |={∅}=> + state_interp σ2 ∗ ⌜efs = []⌝ ∗ ⌜κ = []⌝ ∗ + WP e2 @ s; ∅; E2 {{ Φ }}) + ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof. + iIntros (?) "H". iApply wp_lift_step_fupd=>//. iMod "H". iIntros "!>" (σ1) "Hσ". + iMod ("H" with "Hσ") as "[% H]"; iModIntro. + iSplit; first by destruct s; eauto. iIntros (e2 σ2 κ efs ?). + iApply (step_fupd_wand with "(H []) []"); first eauto. + iIntros "($ & $ & $)". +Qed. + +Lemma wp_lift_head_step {s E1 E2 Φ} e1 : + to_val e1 = None → + (|={E1, ∅}=> ∀ σ1, state_interp σ1 ={∅}=∗ + ⌜head_reducible e1 σ1⌝ ∗ + ▷ ∀ e2 σ2 κ efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={∅}=∗ + state_interp σ2 ∗ ⌜efs = []⌝ ∗ ⌜κ = []⌝ ∗ WP e2 @ s; ∅; E2 {{ Φ }}) + ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof. + iIntros (?) "H". iApply wp_lift_head_step_fupd; [done|]. iMod "H". + iIntros "!>" (?) "?". + iMod ("H" with "[$]") as "[$ H]". iIntros "!>" (e2 σ2 κ efs ?) "!> !>". by iApply "H". +Qed. + +Lemma wp_lift_head_step_fupd_nomask {s E1 E2 E3 Φ} e1 : + to_val e1 = None → + (∀ σ1, state_interp σ1 ={E1}=∗ + ⌜head_reducible e1 σ1⌝ ∗ + ∀ e2 σ2 κ efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ ={E1}[E3]▷=∗ + state_interp σ2 ∗ ⌜efs = []⌝ ∗ ⌜κ = []⌝ ∗ + WP e2 @ s; E1; E2 {{ Φ }}) + ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof. + iIntros (?) "H". iApply wp_lift_step_fupd_nomask; [done|]. + iIntros (σ1) "Hσ1". iMod ("H" with "Hσ1") as "[% H]"; iModIntro. + iSplit; first by destruct s; auto. iIntros (e2 σ2 κ efs Hstep). + iApply (step_fupd_wand with "(H []) []"); first by eauto. + iIntros "($ & $)". +Qed. + +Lemma wp_lift_pure_det_head_step {s E1 E2 E' Φ} e1 e2 : + to_val e1 = None → + (∀ σ1, head_reducible e1 σ1) → + (∀ σ1 κ e2' σ2 efs', + head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) → + (|={E1}[E']▷=> WP e2 @ s; E1; E2 {{ Φ }}) ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof using Hinh. + intros. rewrite -(wp_lift_pure_det_step e1 e2); eauto. + destruct s; by auto. +Qed. + +Lemma wp_lift_pure_det_head_step' {s E1 E2 Φ} e1 e2 : + to_val e1 = None → + (∀ σ1, head_reducible e1 σ1) → + (∀ σ1 κ e2' σ2 efs', + head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) → + ▷ WP e2 @ s; E1; E2 {{ Φ }} ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof using Hinh. + intros. rewrite -[(WP e1 @ s; _ {{ _ }})%I]wp_lift_pure_det_head_step //. + rewrite -step_fupd_intro //. +Qed. +End wp. diff --git a/theories/program_logics/program_logic/lifting.v b/theories/program_logics/program_logic/lifting.v new file mode 100644 index 0000000..c48a7bd --- /dev/null +++ b/theories/program_logics/program_logic/lifting.v @@ -0,0 +1,148 @@ +(** The "lifting lemmas" in this file serve to lift the rules of the operational +semantics to the program logic. *) + +From iris.proofmode Require Import proofmode. +From semantics.pl.program_logic Require Export sequential_wp. +From iris.prelude Require Import options. + +Section lifting. +Context `{!irisGS Λ Σ}. +Implicit Types s : stuckness. +Implicit Types v : val Λ. +Implicit Types e : expr Λ. +Implicit Types σ : state Λ. +Implicit Types P Q : iProp Σ. +Implicit Types Φ : val Λ → iProp Σ. + +Local Hint Resolve reducible_no_obs_reducible : core. + +Lemma wp_lift_step_fupd s E1 E2 Φ e1 : + to_val e1 = None → + (|={E1, ∅}=> ∀ σ1, state_interp σ1 ={∅}=∗ + ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ + ∀ e2 σ2 κ efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ + ={∅}▷=∗ ⌜efs = []⌝ ∗ ⌜κ = []⌝ ∗ state_interp σ2 ∗ WP e2 @ s; ∅; E2 {{ Φ }}) + ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof. + rewrite /wp swp_eq /swp_def wp'_unfold /wp_pre=>->. + iIntros ">Hs !>" (σ1). iIntros "Hstate". + iDestruct ("Hs" with "Hstate") as ">($ & Hs)". + iIntros "!>" (e2 σ2 κ efs Hstep). iApply (step_fupd_wand with "(Hs [//]) []"). + iIntros "(-> & -> & $ & >Hwp)". eauto. +Qed. + +(* +Lemma wp_lift_stuck E1 E2 Φ e : + to_val e = None → + (∀ σ, state_interp σ ={E1,∅}=∗ ⌜stuck e σ⌝) + ⊢ WP e @ E1; E2 ?{{ Φ }}. +Proof. + rewrite /wp swp_eq /swp_def wp'_unfold /wp_pre=>->. iIntros "H" (σ1). "Hσ". + iMod ("H" with "Hσ") as %[? Hirr]. iModIntro. iSplit; first done. + iIntros (e2 σ2 efs ?). by case: (Hirr κ e2 σ2 efs). +Qed. + *) + +(** Derived lifting lemmas. *) +Lemma wp_lift_step s E1 E2 Φ e1 : + to_val e1 = None → + (|={E1, ∅}=> ∀ σ1, state_interp σ1 ={∅}=∗ + ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ + ▷ ∀ e2 σ2 κ efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={∅}=∗ + ⌜efs = []⌝ ∗ ⌜κ = []⌝ ∗ state_interp σ2 ∗ + WP e2 @ s; ∅; E2 {{ Φ }}) + ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof. + iIntros (?) "H". iApply wp_lift_step_fupd; [done|]. + iMod "H" as "H". iIntros "!>" (σ1) "Hσ". iMod ("H" with "Hσ") as "($ & Hstep)". + iIntros "!> * % !> !>". by iApply "Hstep". +Qed. + +Lemma wp_lift_pure_step `{!Inhabited (state Λ)} s E1 E2 E' Φ e1 : + (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) → + (∀ κ σ1 e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) → + (|={E1}[E']▷=> ∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌝ → WP e2 @ s; E1; E2 {{ Φ }}) + ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof. + iIntros (Hsafe Hstep) "H". iApply wp_lift_step. + { specialize (Hsafe inhabitant). destruct s; eauto using reducible_not_val. } + iMod "H" as "H". + iApply fupd_mask_intro; first set_solver. iIntros "Hclose". + iIntros (σ1) "Hσ !>". iSplit. + { iPureIntro. destruct s; done. } + iNext. iIntros (e2 σ2 κ efs ?). + destruct (Hstep κ σ1 e2 σ2 efs) as (-> & <- & ->); auto. + iFrame "Hσ". iSplitR; first done. iSplitR; first done. + iModIntro. + iMod "Hclose". iMod "H". by iApply "H". +Qed. + +(* +Lemma wp_lift_pure_stuck `{!Inhabited (state Λ)} E Φ e : + (∀ σ, stuck e σ) → + True ⊢ WP e @ E ?{{ Φ }}. +Proof. + iIntros (Hstuck) "_". iApply wp_lift_stuck. + - destruct(to_val e) as [v|] eqn:He; last done. + rewrite -He. by case: (Hstuck inhabitant). + - iIntros (σ ns κs nt) "_". iApply fupd_mask_intro; auto with set_solver. +Qed. +*) + +Lemma wp_lift_step_fupd_nomask {s E1 E2 E3 Φ} e1 : + to_val e1 = None → + (∀ σ1, state_interp σ1 ={E1}=∗ + ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ + ∀ e2 σ2 κ efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={E1}[E3]▷=∗ + state_interp σ2 ∗ ⌜efs = []⌝ ∗ ⌜κ = []⌝ ∗ + WP e2 @ s; E1; E2 {{ Φ }}) + ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof. + iIntros (?) "H". + iApply (wp_lift_step_fupd s E1 _ _ e1)=>//. + iApply fupd_mask_intro; first set_solver. iIntros "Hcl". + iIntros (σ1) "Hσ1". iMod "Hcl" as "_". + iMod ("H" with "Hσ1") as "($ & H)". + iApply fupd_mask_intro; first set_solver. + iIntros "Hclose" (e2 σ2 κ efs ?). iMod "Hclose" as "_". + iMod ("H" $! e2 σ2 κ efs with "[#]") as "H"; [done|]. + iApply fupd_mask_intro; first set_solver. iIntros "Hclose !>". + iMod "Hclose" as "_". iMod "H" as "($ & $ & $ & ?)". + iApply fupd_mask_intro; first set_solver. iIntros "Hcl". + iMod "Hcl" as "_". done. +Qed. + +Lemma wp_lift_pure_det_step `{!Inhabited (state Λ)} {s E1 E2 E' Φ} e1 e2 : + (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) → + (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' → + κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) → + (|={E1}[E']▷=> WP e2 @ s; E1; E2 {{ Φ }}) ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof. + iIntros (? Hpuredet) "H". iApply (wp_lift_pure_step s E1 E2 E'); try done. + { naive_solver. } + iApply (step_fupd_wand with "H"); iIntros "H". + iIntros (κ e' efs' σ (_&?&->&?)%Hpuredet); auto. +Qed. + +Lemma wp_pure_step_fupd `{!Inhabited (state Λ)} s E1 E2 E' e1 e2 φ n Φ : + PureExec φ n e1 e2 → + φ → + (|={E1}[E']▷=>^n WP e2 @ s; E1; E2 {{ Φ }}) ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof. + iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ). + iInduction Hexec as [e|n e1 e2 e3 [Hsafe ?]] "IH"; simpl; first done. + iApply wp_lift_pure_det_step. + - intros σ. specialize (Hsafe σ). destruct s; eauto using reducible_not_val. + - done. + - by iApply (step_fupd_wand with "Hwp"). +Qed. + +Lemma wp_pure_step_later `{!Inhabited (state Λ)} s E1 E2 e1 e2 φ n Φ : + PureExec φ n e1 e2 → + φ → + ▷^n WP e2 @ s; E1; E2 {{ Φ }} ⊢ WP e1 @ s; E1; E2 {{ Φ }}. +Proof. + intros Hexec ?. rewrite -wp_pure_step_fupd //. clear Hexec. + induction n as [|n IH]; by rewrite //= -step_fupd_intro // IH. +Qed. +End lifting. diff --git a/theories/program_logics/program_logic/notation.v b/theories/program_logics/program_logic/notation.v new file mode 100644 index 0000000..88b1855 --- /dev/null +++ b/theories/program_logics/program_logic/notation.v @@ -0,0 +1,69 @@ +From stdpp Require Export coPset. +From iris.bi Require Import interface derived_connectives. +From iris.prelude Require Import options. + +Declare Scope expr_scope. +Delimit Scope expr_scope with E. + +Declare Scope val_scope. +Delimit Scope val_scope with V. + +Inductive stuckness := NotStuck | MaybeStuck. + +Definition stuckness_leb (s1 s2 : stuckness) : bool := + match s1, s2 with + | MaybeStuck, NotStuck => false + | _, _ => true + end. +Global Instance stuckness_le : SqSubsetEq stuckness := stuckness_leb. +Global Instance stuckness_le_po : PreOrder stuckness_le. +Proof. split; by repeat intros []. Qed. + + +Class Swp (PROP EXPR VAL A : Type) := + wp : A → coPset → coPset → EXPR → (VAL → PROP) → PROP. +Global Arguments wp {_ _ _ _ _} _ _ _ _%E _%I. +Global Instance: Params (@wp) 9 := {}. + +Notation "'WP' e @ s ; E1 ; E2 {{ Φ } }" := (wp s E1 E2 e%E Φ) + (at level 20, e, Φ at level 200, only parsing) : bi_scope. +Notation "'WP' e @ E1 ; E2 {{ Φ } }" := (wp NotStuck E1 E2 e%E Φ) + (at level 20, e, Φ at level 200, only parsing) : bi_scope. +Notation "'WP' e @ E1 ; E2 ? {{ Φ } }" := (wp MaybeStuck E1 E2 e%E Φ) + (at level 20, e, Φ at level 200, only parsing) : bi_scope. +Notation "'WP' e @ s ; E1 {{ Φ } }" := (wp s E1 E1 e%E Φ) + (at level 20, e, Φ at level 200, only parsing) : bi_scope. +Notation "'WP' e @ E1 {{ Φ } }" := (wp NotStuck E1 E1 e%E Φ) + (at level 20, e, Φ at level 200, only parsing) : bi_scope. +Notation "'WP' e @ E1 ? {{ Φ } }" := (wp MaybeStuck E1 E1 e%E Φ) + (at level 20, e, Φ at level 200, only parsing) : bi_scope. +Notation "'WP' e {{ Φ } }" := (wp NotStuck ⊤ ⊤ e%E Φ) + (at level 20, e, Φ at level 200, only parsing) : bi_scope. +Notation "'WP' e ? {{ Φ } }" := (wp MaybeStuck ⊤ ⊤ e%E Φ) + (at level 20, e, Φ at level 200, only parsing) : bi_scope. + +Notation "'WP' e @ s ; E1 ; E2 {{ v , Q } }" := (wp s E1 E2 e%E (λ v, Q)) + (at level 20, e, Q at level 200, + format "'[hv' 'WP' e '/' @ '[' s ; '/' E1 ; '/' E2 ']' '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. +Notation "'WP' e @ E1 ; E2 {{ v , Q } }" := (wp NotStuck E1 E2 e%E (λ v, Q)) + (at level 20, e, Q at level 200, + format "'[hv' 'WP' e '/' @ '[' E1 ; '/' E2 ']' '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. +Notation "'WP' e @ E1 ; E2 ? {{ v , Q } }" := (wp MaybeStuck E1 E2 e%E (λ v, Q)) + (at level 20, e, Q at level 200, + format "'[hv' 'WP' e '/' @ '[' E1 ; '/' E2 ']' '/' ? {{ '[' v , '/' Q ']' } } ']'") : bi_scope. +Notation "'WP' e @ s ; E {{ v , Q } }" := (wp s E E e%E (λ v, Q)) + (at level 20, e, Q at level 200, + format "'[hv' 'WP' e '/' @ '[' s ; '/' E ']' '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. +Notation "'WP' e @ E {{ v , Q } }" := (wp NotStuck E E e%E (λ v, Q)) + (at level 20, e, Q at level 200, + format "'[hv' 'WP' e '/' @ E '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. +Notation "'WP' e @ E ? {{ v , Q } }" := (wp MaybeStuck E E e%E (λ v, Q)) + (at level 20, e, Q at level 200, + format "'[hv' 'WP' e '/' @ E '/' ? {{ '[' v , '/' Q ']' } } ']'") : bi_scope. +Notation "'WP' e {{ v , Q } }" := (wp NotStuck ⊤ ⊤ e%E (λ v, Q)) + (at level 20, e, Q at level 200, + format "'[hv' 'WP' e '/' {{ '[' v , '/' Q ']' } } ']'") : bi_scope. +Notation "'WP' e ? {{ v , Q } }" := (wp MaybeStuck ⊤ ⊤ e%E (λ v, Q)) + (at level 20, e, Q at level 200, + format "'[hv' 'WP' e '/' ? {{ '[' v , '/' Q ']' } } ']'") : bi_scope. + diff --git a/theories/program_logics/program_logic/sequential_wp.v b/theories/program_logics/program_logic/sequential_wp.v new file mode 100644 index 0000000..c4c0de5 --- /dev/null +++ b/theories/program_logics/program_logic/sequential_wp.v @@ -0,0 +1,372 @@ +From iris.proofmode Require Import base proofmode classes. +From iris.base_logic.lib Require Export fancy_updates. +From iris.program_logic Require Export language. +From semantics.pl.program_logic Require Export notation. +From iris.prelude Require Import options. +Import uPred. + +Class irisGS (Λ : language) (Σ : gFunctors) := IrisG { + iris_invGS : invGS_gen HasNoLc Σ; + + (** The state interpretation is an invariant that should hold in + between each step of reduction. Here [state Λ] is the global state. *) + state_interp : state Λ → iProp Σ; +}. +#[export] Existing Instance iris_invGS. +Global Opaque iris_invGS. + +Definition wp_pre `{!irisGS Λ Σ} (s : stuckness) + (wp : coPset -d> expr Λ -d> (val Λ -d> iPropO Σ) -d> iPropO Σ) : + coPset -d> expr Λ -d> (val Λ -d> iPropO Σ) -d> iPropO Σ := λ E e1 Φ, + match to_val e1 with + | Some v => |={E}=> Φ v + | None => ∀ σ1, + state_interp σ1 ={E,∅}=∗ + ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗ + ∀ e2 σ2 κ efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ + ={∅}▷=∗ |={∅,E}=> + ⌜efs = []⌝ ∗ ⌜κ = []⌝ ∗ state_interp σ2 ∗ wp E e2 Φ + end%I. + +Local Instance wp_pre_contractive `{!irisGS Λ Σ} s : Contractive (wp_pre s). +Proof. + rewrite /wp_pre /= => n wp wp' Hwp E e1 Φ. + do 22 (f_contractive || f_equiv). + apply Hwp. +Qed. + +Definition wp_def `{!irisGS Λ Σ} := λ (s : stuckness), fixpoint (wp_pre s). +Definition wp_aux : seal (@wp_def). Proof. by eexists. Qed. +Definition wp' := wp_aux.(unseal). +Global Arguments wp' {Λ Σ _}. +Lemma wp_eq `{!irisGS Λ Σ} : wp' = @wp_def Λ Σ _. +Proof. rewrite -wp_aux.(seal_eq) //. Qed. + +(* sequential version that allows opening invariants *) +Definition swp_def `{!irisGS Λ Σ} : Swp (iProp Σ) (expr Λ) (val Λ) stuckness := λ s E1 E2 e Φ, (|={E1, ∅}=> wp' s ∅ e (λ v, |={∅, E2}=> Φ v))%I. +Definition swp_aux : seal (@swp_def). Proof. by eexists. Qed. +Definition swp := swp_aux.(unseal). +Global Arguments swp {Λ Σ _}. +Global Existing Instance swp. +Lemma swp_eq `{!irisGS Λ Σ} : swp = @swp_def Λ Σ _. +Proof. rewrite -swp_aux.(seal_eq) //. Qed. + +Section wp. +Context `{!irisGS Λ Σ}. +Implicit Types s : stuckness. +Implicit Types P : iProp Σ. +Implicit Types Φ : val Λ → iProp Σ. +Implicit Types v : val Λ. +Implicit Types e : expr Λ. + +(* Weakest pre *) +Lemma wp'_unfold s E e Φ : + wp' s E e Φ ⊣⊢ wp_pre s (wp' s) E e Φ. +Proof. rewrite wp_eq. apply (fixpoint_unfold (wp_pre s)). Qed. + +Global Instance wp'_ne s E e n : + Proper (pointwise_relation _ (dist n) ==> dist n) (wp' s E e). +Proof. + revert e. induction (lt_wf n) as [n _ IH]=> e Φ Ψ HΦ. + rewrite !wp'_unfold /wp_pre /=. + (* FIXME: figure out a way to properly automate this proof *) + (* FIXME: reflexivity, as being called many times by f_equiv and f_contractive + is very slow here *) + do 22 (f_contractive || f_equiv). + rewrite IH; [done | lia | ]. intros v. eapply dist_lt; done. +Qed. +Global Instance wp'_proper s E e : + Proper (pointwise_relation _ (≡) ==> (≡)) (wp' s E e). +Proof. + by intros Φ Φ' ?; apply equiv_dist=>n; apply wp'_ne=>v; apply equiv_dist. +Qed. +Global Instance wp'_contractive s E e n : + TCEq (to_val e) None → + Proper (pointwise_relation _ (dist_later n) ==> dist n) (wp' s E e). +Proof. + intros He Φ Ψ HΦ. rewrite !wp'_unfold /wp_pre He /=. + do 23 (f_contractive || f_equiv). + by do 4 f_equiv. +Qed. + +Lemma wp'_value_fupd' s E Φ v : wp' s E (of_val v) Φ ⊣⊢ |={E}=> Φ v. +Proof. rewrite wp'_unfold /wp_pre to_of_val. auto. Qed. + +Lemma wp'_strong_mono s1 s2 E1 E2 e Φ Ψ : + s1 ⊑ s2 → E1 ⊆ E2 → + wp' s1 E1 e Φ -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ wp' s2 E2 e Ψ. +Proof. + iIntros (? HE) "H HΦ". iLöb as "IH" forall (e E1 E2 HE Φ Ψ). + rewrite !wp'_unfold /wp_pre /=. + destruct (to_val e) as [v|] eqn:?. + { iApply ("HΦ" with "[> -]"). by iApply (fupd_mask_mono E1 _). } + iIntros (σ1) "Hσ". + iMod (fupd_mask_subseteq E1) as "Hclose"; first done. + iMod ("H" with "[$]") as "[% H]". + iModIntro. iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 κ efs Hstep). + iMod ("H" with "[//]") as "H". iIntros "!> !>". iMod "H". iModIntro. + iMod "H" as "($ & $ & $ & H)". + iMod "Hclose" as "_". iModIntro. + iApply ("IH" with "[//] H HΦ"). +Qed. + +Lemma fupd_wp' s E e Φ : (|={E}=> wp' s E e Φ) ⊢ wp' s E e Φ. +Proof. + rewrite wp'_unfold /wp_pre. iIntros "H". destruct (to_val e) as [v|] eqn:?. + { by iMod "H". } + iIntros (σ1) "Hσ1". iMod "H". by iApply "H". +Qed. +Lemma wp'_fupd s E e Φ : wp' s E e (λ v, |={E}=> Φ v) ⊢ wp' s E e Φ. +Proof. iIntros "H". iApply (wp'_strong_mono s s E with "H"); auto. Qed. + +Lemma wp'_bind K `{!LanguageCtx K} s E e Φ : + wp' s E e (λ v, wp' s E (K (of_val v)) Φ) ⊢ wp' s E (K e) Φ. +Proof. + iIntros "H". iLöb as "IH" forall (E e Φ). rewrite wp'_unfold /wp_pre. + destruct (to_val e) as [v|] eqn:He. + { apply of_to_val in He as <-. by iApply fupd_wp'. } + rewrite wp'_unfold /wp_pre fill_not_val /=; [|done]. + iIntros (σ1) "Hσ". iMod ("H" with "[$]") as "[% H]". + iModIntro; iSplit. + { destruct s; eauto using reducible_fill. } + iIntros (e2 σ2 κ efs Hstep). + destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto. + iMod ("H" $! e2' σ2 κ efs with "[//]") as "H". iIntros "!>!>". + iMod "H". iModIntro. iMod "H" as "($ & $ & $ & H)". iModIntro. by iApply "IH". +Qed. + +Lemma wp'_step_fupd s E1 E2 e P Φ : + TCEq (to_val e) None → E2 ⊆ E1 → + (|={E1}[E2]▷=> P) -∗ wp' s E2 e (λ v, P ={E1}=∗ Φ v) -∗ wp' s E1 e Φ. +Proof. + iIntros (?%TCEq_eq ?) "HR H". + rewrite !wp'_unfold /wp_pre /=. + destruct (to_val e) as [v|] eqn:He. + { apply of_to_val in He as <-. done. } + iIntros (σ1) "Hσ". + iMod "HR". + iMod ("H" with "[$]") as "[% H]". + iModIntro; iSplit. + { destruct s; eauto. } + iIntros (e2 σ2 κ efs Hstep). + iMod ("H" $! _ _ _ with "[//]") as "H". iIntros "!>!>!>". + iMod "H". iMod "H" as "($ & $ & $ & H)". iMod "HR". iModIntro. + iApply (wp'_strong_mono with "H [HR]"); [done | done | ]. + iIntros (v) "HΦ". by iApply "HΦ". +Qed. +End wp. + +Section swp. +Context `{!irisGS Λ Σ}. +Implicit Types s : stuckness. +Implicit Types P : iProp Σ. +Implicit Types Φ : val Λ → iProp Σ. +Implicit Types v : val Λ. +Implicit Types e : expr Λ. + +(* Weakest pre *) +Global Instance wp_ne s E1 E2 e n : + Proper (pointwise_relation _ (dist n) ==> dist n) (wp s E1 E2 e). +Proof. + intros ???. + rewrite /wp swp_eq /swp_def /=. + do 2 f_equiv. intros ?. f_equiv. done. +Qed. +Global Instance wp_proper s E1 E2 e : + Proper (pointwise_relation _ (≡) ==> (≡)) (wp s E1 E2 e). +Proof. + intros ???. rewrite /wp swp_eq /swp_def /=. + do 2 f_equiv. intros ?. f_equiv. done. +Qed. + +Lemma wp_value_fupd' s E1 E2 Φ v : wp s E1 E2 (of_val v) Φ ⊣⊢ |={E1, E2}=> Φ v. +Proof. + rewrite /wp swp_eq /swp_def wp'_value_fupd'. + iSplit. + - iIntros "H". iMod "H". iMod "H". iMod "H". done. + - iIntros "H". iMod (fupd_mask_subseteq ∅) as "Hcl"; first set_solver. + iModIntro. iModIntro. iMod "Hcl" as "_". done. +Qed. + +Lemma wp_strong_mono s1 s2 E1 E2 E3 e Φ Ψ : + s1 ⊑ s2 → + wp s1 E1 E2 e Φ -∗ (∀ v, Φ v ={E2, E3}=∗ Ψ v) -∗ wp s2 E1 E3 e Ψ. +Proof. + iIntros (?) "H HΦ". + rewrite /wp swp_eq /swp_def. + iMod "H". iModIntro. + iApply (wp'_strong_mono _ _ ∅ ∅ with "H [HΦ]"); [done | done | ]. + iIntros (v) "H". iModIntro. iMod "H". by iApply "HΦ". +Qed. + +Lemma fupd_wp s E1 E2 E3 e Φ : (|={E1, E2}=> wp s E2 E3 e Φ) ⊢ wp s E1 E3 e Φ. +Proof. + rewrite /wp swp_eq /swp_def. iIntros "H". iApply fupd_wp'. + iMod "H". iMod "H". iModIntro. iModIntro. done. +Qed. +Lemma wp_fupd' s E1 E2 e Φ : wp s E1 E1 e (λ v, |={E1, E2}=> Φ v) ⊢ wp s E1 E2 e Φ. +Proof. iIntros "H". iApply (wp_strong_mono s s E1 E1 with "H"); auto. Qed. +Lemma wp_fupd s E1 E2 e Φ : wp s E1 E2 e (λ v, |={E2}=> Φ v) ⊢ wp s E1 E2 e Φ. +Proof. iIntros "H". iApply (wp_strong_mono s s E1 E2 with "H"); auto. Qed. + +Lemma wp_bind K `{!LanguageCtx K} s E1 E2 E3 e Φ : + wp s E1 E2 e (λ v, wp s E2 E3 (K (of_val v)) Φ) ⊢ wp s E1 E3 (K e) Φ. +Proof. + iIntros "H". + rewrite /wp swp_eq /swp_def. iMod "H". iApply wp'_bind. + iModIntro. iApply (wp'_strong_mono with "H"); [done | done | ]. + iIntros (v) "H". iMod "H". iMod "H". done. +Qed. + +Lemma wp_step_fupd s E1 E2 E3 e P Φ : + TCEq (to_val e) None → + (|={E1}[E2]▷=> P) -∗ wp s E2 E2 e (λ v, P ={E1, E3}=∗ Φ v) -∗ wp s E1 E3 e Φ. +Proof. + iIntros (?) "HR H". + rewrite /wp swp_eq /swp_def. + iMod "HR". iMod "H". iModIntro. + iApply (wp'_step_fupd _ ∅ ∅ _ (|={E2, E1}=> P) with "[HR] [H]"); [done | | ]. + { iApply (step_fupd_intro ∅ ∅); done. } + iApply (wp'_strong_mono with "H"); [done | done | ]. + iIntros (v) "H1 !> H2 !>". + iMod "H1". iMod "H2". by iMod ("H1" with "H2"). +Qed. + +(** * Derived rules *) +Lemma wp_mono s E1 E2 e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → WP e @ s; E1; E2 {{ Φ }} ⊢ WP e @ s; E1; E2 {{ Ψ }}. +Proof. + iIntros (HΦ) "H"; iApply (wp_strong_mono with "H"); auto. + iIntros (v) "?". by iApply HΦ. +Qed. +Lemma wp_stuck_mono s1 s2 E1 E2 e Φ : + s1 ⊑ s2 → WP e @ s1; E1; E2 {{ Φ }} ⊢ WP e @ s2; E1; E2 {{ Φ }}. +Proof. iIntros (?) "H". iApply (wp_strong_mono with "H"); auto. Qed. +Lemma wp_stuck_weaken s E1 E2 e Φ : + WP e @ s; E1; E2 {{ Φ }} ⊢ WP e @ E1; E2 ?{{ Φ }}. +Proof. apply wp_stuck_mono. by destruct s. Qed. +Global Instance wp_mono' s E1 E2 e : + Proper (pointwise_relation _ (⊢) ==> (⊢)) (wp (PROP:=iProp Σ) s E1 E2 e). +Proof. by intros Φ Φ' ?; apply wp_mono. Qed. +Global Instance wp_flip_mono' s E1 E2 e : + Proper (pointwise_relation _ (flip (⊢)) ==> (flip (⊢))) (wp (PROP:=iProp Σ) s E1 E2 e). +Proof. by intros Φ Φ' ?; apply wp_mono. Qed. + +Lemma wp_value_fupd s E1 E2 Φ e v : IntoVal e v → WP e @ s; E1; E2 {{ Φ }} ⊣⊢ |={E1, E2}=> Φ v. +Proof. intros <-. by apply wp_value_fupd'. Qed. +Lemma wp_value' s E Φ v : Φ v ⊢ WP (of_val v) @ s; E {{ Φ }}. +Proof. rewrite wp_value_fupd'. auto. Qed. +Lemma wp_value s E Φ e v : IntoVal e v → Φ v ⊢ WP e @ s; E {{ Φ }}. +Proof. intros <-. apply wp_value'. Qed. + +Lemma wp_frame_l s E1 E2 e Φ R : R ∗ WP e @ s; E1; E2 {{ Φ }} ⊢ WP e @ s; E1; E2 {{ v, R ∗ Φ v }}. +Proof. iIntros "[? H]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed. +Lemma wp_frame_r s E1 E2 e Φ R : WP e @ s; E1; E2 {{ Φ }} ∗ R ⊢ WP e @ s; E1; E2 {{ v, Φ v ∗ R }}. +Proof. iIntros "[H ?]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed. + + +Lemma wp_frame_step_l s E1 E2 E3 e Φ R : + TCEq (to_val e) None → + (|={E1}[E2]▷=> R) ∗ WP e @ s; E2; E2 {{ v, |={E1, E3}=> Φ v }} ⊢ WP e @ s; E1; E3 {{ v, R ∗ Φ v }}. +Proof. + iIntros (?) "[Hu Hwp]". iApply (wp_step_fupd with "Hu"); try done. + iApply (wp_mono with "Hwp"). iIntros (?) "Hf $". iApply "Hf". +Qed. +Lemma wp_frame_step_r s E1 E2 E3 e Φ R : + TCEq (to_val e) None → + WP e @ s; E2; E2 {{ v, |={E1, E3}=> Φ v }} ∗ (|={E1}[E2]▷=> R) ⊢ WP e @ s; E1; E3 {{ v, Φ v ∗ R }}. +Proof. + rewrite [(WP _ @ _; _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply wp_frame_step_l. +Qed. +Lemma wp_frame_step_l' s E1 E2 e Φ R : + TCEq (to_val e) None → E1 ⊆ E2 → ▷ R ∗ WP e @ s; E1; E2 {{ Φ }} ⊢ WP e @ s; E1; E2 {{ v, R ∗ Φ v }}. +Proof. + iIntros (??) "[??]". iApply (wp_frame_step_l s E1 E1 E2). + iFrame. iSplitR; first eauto. iApply (wp_strong_mono with "[$]"); first done. + iIntros (v) "?". iMod (fupd_mask_subseteq E1) as "Hcl"; first done. iModIntro. iMod "Hcl". eauto. +Qed. +Lemma wp_frame_step_r' s E1 E2 e Φ R : + TCEq (to_val e) None → E1 ⊆ E2 → WP e @ s; E1; E2 {{ Φ }} ∗ ▷ R ⊢ WP e @ s; E1; E2 {{ v, Φ v ∗ R }}. +Proof. + rewrite [(WP _ @ _; _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R). + apply wp_frame_step_l'. +Qed. + +Lemma wp_wand s E1 E2 e Φ Ψ : + WP e @ s; E1; E2 {{ Φ }} -∗ (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s; E1; E2 {{ Ψ }}. +Proof. + iIntros "Hwp H". iApply (wp_strong_mono with "Hwp"); auto. + iIntros (?) "?". by iApply "H". +Qed. +Lemma wp_wand_l s E1 E2 e Φ Ψ : + (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s; E1; E2 {{ Φ }} ⊢ WP e @ s; E1; E2 {{ Ψ }}. +Proof. iIntros "[H Hwp]". iApply (wp_wand with "Hwp H"). Qed. +Lemma wp_wand_r s E1 E2 e Φ Ψ : + WP e @ s; E1; E2 {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WP e @ s; E1; E2 {{ Ψ }}. +Proof. iIntros "[Hwp H]". iApply (wp_wand with "Hwp H"). Qed. +Lemma wp_frame_wand s E1 E2 e Φ R : + R -∗ WP e @ s; E1; E2 {{ v, R -∗ Φ v }} -∗ WP e @ s; E1; E2 {{ Φ }}. +Proof. + iIntros "HR HWP". iApply (wp_wand with "HWP"). + iIntros (v) "HΦ". by iApply "HΦ". +Qed. + +Lemma wp_bind' K `{!LanguageCtx K} s E1 E2 e Φ : + wp s E1 E1 e (λ v, wp s E1 E2 (K (of_val v)) Φ) ⊢ wp s E1 E2 (K e) Φ. +Proof. iApply wp_bind. Qed. +End swp. + +(** Proofmode class instances *) +Section proofmode_classes. + Context `{!irisGS Λ Σ}. + Implicit Types P Q : iProp Σ. + Implicit Types Φ : val Λ → iProp Σ. + Implicit Types v : val Λ. + Implicit Types e : expr Λ. + + Global Instance frame_wp p s E1 E2 e R Φ Ψ : + (∀ v, Frame p R (Φ v) (Ψ v)) → + Frame p R (WP e @ s; E1; E2 {{ Φ }}) (WP e @ s; E1; E2 {{ Ψ }}) | 2. + Proof. rewrite /Frame=> HR. rewrite wp_frame_l. apply wp_mono, HR. Qed. + + Global Instance is_except_0_wp s E1 E2 e Φ : IsExcept0 (WP e @ s; E1; E2 {{ Φ }}). + Proof. by rewrite /IsExcept0 -{2}(fupd_wp _ E1 E1) -except_0_fupd -fupd_intro. Qed. + + Global Instance elim_modal_bupd_wp p s E1 E2 e P Φ : + ElimModal True p false (|==> P) P (WP e @ s; E1; E2 {{ Φ }}) (WP e @ s; E1; E2 {{ Φ }}). + Proof. + by rewrite /ElimModal intuitionistically_if_elim + (bupd_fupd E1) fupd_frame_r wand_elim_r fupd_wp. + Qed. + + Global Instance elim_modal_fupd_wp p s E1 E2 e P Φ : + ElimModal True p false (|={E1}=> P) P (WP e @ s; E1; E2 {{ Φ }}) (WP e @ s; E1; E2 {{ Φ }}). + Proof. + by rewrite /ElimModal intuitionistically_if_elim + fupd_frame_r wand_elim_r fupd_wp. + Qed. + + Global Instance elim_modal_fupd_wp_ne p s E1 E2 E3 e P Φ : + ElimModal True p false + (|={E1,E2}=> P) P + (WP e @ s; E1; E3 {{ Φ }}) (WP e @ s; E2; E3 {{ Φ }})%I | 100. + Proof. + intros ?. rewrite intuitionistically_if_elim fupd_frame_r wand_elim_r. + rewrite fupd_wp //. + Qed. + + Global Instance add_modal_fupd_wp s E1 E2 e P Φ : + AddModal (|={E1}=> P) P (WP e @ s; E1; E2 {{ Φ }}). + Proof. by rewrite /AddModal fupd_frame_r wand_elim_r fupd_wp. Qed. + + Global Instance elim_acc_wp_nonatomic {X} E0 E1 E2 α β γ e s Φ : + ElimAcc (X:=X) True (fupd E1 E0) (fupd E2 E2) + α β γ (WP e @ s; E1; E2 {{ Φ }}) + (λ x, WP e @ s; E0; E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I. + Proof. + iIntros (_) "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]". + iApply wp_fupd. + iApply (wp_wand with "(Hinner Hα)"). + iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose". + Qed. +End proofmode_classes.