From 858c1fddf361ab2ab3fa04bff63cc09ca6b78fcb Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Tue, 16 Jun 2026 15:24:50 -0400 Subject: [PATCH 01/33] upload --- Iris/Iris/HeapLang/Instances.lean | 389 +++++++++++++++++----- Iris/Iris/ProgramLogic/EctxiLanguage.lean | 9 + 2 files changed, 321 insertions(+), 77 deletions(-) diff --git a/Iris/Iris/HeapLang/Instances.lean b/Iris/Iris/HeapLang/Instances.lean index 9cf75c38c..6031f79d5 100644 --- a/Iris/Iris/HeapLang/Instances.lean +++ b/Iris/Iris/HeapLang/Instances.lean @@ -1,6 +1,7 @@ /- Copyright (c) 2026 Sergei Stepanenko. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sergei Stepanenko, Markus de Medeiros -/ module @@ -11,11 +12,12 @@ public import Iris.ProgramLogic.EctxiLanguage public import Std.Data.ExtTreeMap public import Std.Data.ExtTreeSet public import Iris.Std.FromMathlib +public import Iris.Std.GenSetsInstances @[expose] public section namespace Iris.HeapLang -open ProgramLogic +open ProgramLogic ProgramLogic.Language FromMathlib EctxItemLanguage EctxLanguage instance instEctxItemLanguageExp : EctxItemLanguage Exp ECtxItem State Observation Val where baseStep := fun ⟨e, σ⟩ obs ⟨e', σ', eps⟩ => BaseStep e σ obs e' σ' eps @@ -49,210 +51,443 @@ instance instEctxItemLanguageExp : EctxItemLanguage Exp ECtxItem State Observati intro σ obs e' σ' eps h cases h <;> rfl -theorem mk_pure_prim_step {e1 e2 : Exp} - (hstep : ∀ σ, BaseStep e1 σ [] e2 σ []) - (hpure : ∀ σ1 κs e2' σ2 efs, BaseStep e1 σ1 κs e2' σ2 efs → κs = [] ∧ σ1 = σ2 ∧ e2 = e2' ∧ efs = []) - (hsub : EctxLanguage.SubredexesAreValues e1) : - Language.PurePrimStep e1 e2 := by - constructor - · intro σ - exists e2, σ, [] - refine BaseStep.ContextStep.intro (K := []) (hstep _) - · intro σ1 σ2 κs e2' efs Hstep - have h := (EctxLanguage.baseStep_of_primStep Hstep hsub) - apply hpure; apply h - -instance instPureExecIfTrue: Language.PureExec True 1 hl(if #true then &e1 else &e2) e1 where +@[simp] +theorem fillItem_expToVal_none (Ki : ECtxItem) (e : Exp) : toVal (fillItem Ki e) = none := by + cases Ki <;> rfl + +theorem fill_isSome_empty {K : List ECtxItem} {e : Exp} + (h : (toVal (fill K e)).isSome) : K = [] := by + cases K with + | nil => rfl + | cons Ki K' => + rw [fill_cons] at h + have h2 := EctxLanguage.fill_val (K := K') (e := fillItem Ki e) h + simp [fillItem_expToVal_none] at h2 + +theorem mk_pure_prim_step {e1 e2 : Exp} (hstep : ∀ σ, BaseStep e1 σ [] e2 σ []) + (hpure : ∀ {σ1 κs e2' σ2 efs}, BaseStep e1 σ1 κs e2' σ2 efs → κs = [] ∧ σ1 = σ2 ∧ e2 = e2' ∧ efs = []) + (hsub : SubredexesAreValues e1) : PurePrimStep e1 e2 := by + refine ⟨fun σ => ?_, fun Hstep => ?_⟩ + · exact ⟨e2, σ, [], BaseStep.ContextStep.intro (K := []) (hstep _)⟩ + · exact hpure (baseStep_of_primStep Hstep hsub) + +instance instPureExecIfTrue: PureExec True 1 hl(if #true then &e1 else &e2) e1 where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq rfl -instance instPureExecIfFalse : Language.PureExec True 1 hl(if #false then &e1 else &e2) e2 where +instance instPureExecIfFalse : PureExec True 1 hl(if #false then &e1 else &e2) e2 where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq rfl instance instPureExecCaseInjl {v e1 e2} : - Language.PureExec True 1 (Exp.case hl(v(injl(&v))) e1 e2) (.app e1 (.ofVal v)) where + PureExec True 1 (Exp.case hl(v(injl(&v))) e1 e2) (.app e1 (.ofVal v)) where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq rfl instance instPureExecCaseInjr {v e1 e2} : - Language.PureExec True 1 (Exp.case hl(v(injr(&v))) e1 e2) (.app e2 (.ofVal v)) where + PureExec True 1 (Exp.case hl(v(injr(&v))) e1 e2) (.app e2 (.ofVal v)) where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq rfl -instance PureExec_injl {v : Val} : Language.PureExec True 1 hl(injl(&v)) hl(v(injl(&v))) where +instance instPureExecInjl {v : Val} : PureExec True 1 hl(injl(&v)) hl(v(injl(&v))) where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq rfl -instance PureExec_injr {v : Val} : Language.PureExec True 1 hl(injr(&v)) hl(v(injr(&v))) where +instance instPureExecInjr {v : Val} : PureExec True 1 hl(injr(&v)) hl(v(injr(&v))) where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq rfl instance instPureExecBeta {f x : Binder} {e : Exp} {v : Val} : - Language.PureExec True 1 hl(v(rec &f &x := &e) &v) ((e.subst f (.rec_ f x e)).subst x v) where + PureExec True 1 hl(v(rec &f &x := &e) &v) ((e.subst f (.rec_ f x e)).subst x v) where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp · cases hs <;> simp [*] - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq <;> rfl -instance instPureExecRec {f x e} : Language.PureExec True 1 hl(rec &f &x := &e) hl(v(rec &f &x := &e)) where +instance instPureExecRec {f x e} : + PureExec True 1 hl(rec &f &x := &e) hl(v(rec &f &x := &e)) where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp · cases hs <;> simp [*] - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq <;> rfl -instance PureExec_fst {v1 v2 : Val} : Language.PureExec True 1 hl(fst(v((&v1, &v2)))) v1 where +instance instPureExecFst {v1 v2 : Val} : PureExec True 1 hl(fst(v((&v1, &v2)))) v1 where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp · cases hs <;> simp [*] - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq <;> rfl -instance PureExec_snd {v1 v2 : Val} : Language.PureExec True 1 hl(snd(v((&v1, &v2)))) v2 where +instance instPureExecSnd {v1 v2 : Val} : PureExec True 1 hl(snd(v((&v1, &v2)))) v2 where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp · cases hs <;> simp [*] - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq <;> rfl -instance PureExec_pair {v1 v2 : Val} : Language.PureExec True 1 hl((&v1, &v2)) hl(v((&v1, &v2))) where +instance instPureExecPair {v1 v2 : Val} : PureExec True 1 hl((&v1, &v2)) hl(v((&v1, &v2))) where pureExec _ := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp · cases hs <;> simp [*] - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq <;> rfl set_option synthInstance.checkSynthOrder false in instance instPureExecUnOp {op : UnOp} {v v' : Val} : - Language.PureExec (op.eval v = some v') 1 (Exp.unop op (.ofVal v)) (.ofVal v') where + PureExec (op.eval v = some v') 1 (Exp.unop op (.ofVal v)) (.ofVal v') where pureExec h := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp [*] · cases hs <;> simp_all [UnOp.eval] - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq <;> rfl set_option synthInstance.checkSynthOrder false in instance instPureExecBinOp {op : BinOp} {v1 v2 v' : Val} : - Language.PureExec (op.eval v1 v2 = some v') 1 + PureExec (op.eval v1 v2 = some v') 1 (Exp.binop op (.ofVal v1) (.ofVal v2)) (.ofVal v') where pureExec h := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp [*] · cases hs <;> simp_all [BinOp.eval] - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq <;> rfl -- higher priority than the generic binop instance instance (priority := default + 10) instPureExecEqOp {v1 v2 : Val} : - Language.PureExec (v1.compareSafe v2) 1 + PureExec (v1.compareSafe v2) 1 (Exp.binop .eq (.ofVal v1) (.ofVal v2)) (.ofVal (.lit (.bool (v1 == v2)))) where pureExec h := by - refine .once <| mk_pure_prim_step (fun _ => ?_) (fun _ _ _ _ _ hs => ?_) ?_ + refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp [BinOp.eval, *] · cases hs <;> simp_all [BinOp.eval] - · apply EctxItemLanguage.subredexes_are_values + · apply subredexes_are_values intro Ki e_inner heq cases Ki <;> cases heq <;> rfl -instance instAtomicLoad {s} {v : Val} : Language.Atomic s hl(!&v) where +instance instAtomicLoad {s} {v : Val} : Atomic s hl(!&v) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : EctxLanguage.SubredexesAreValues hl(!&v) := by - apply EctxItemLanguage.subredexes_are_values + have hsr : SubredexesAreValues hl(!&v) := by + apply subredexes_are_values intro Ki e_inner heq cases Ki <;> try (cases heq; done) all_goals (cases heq; rfl) - cases (EctxLanguage.baseStep_of_primStep Hstep hsr) + cases (baseStep_of_primStep Hstep hsr) cases s - · exact Language.val_irreducible rfl _ + · exact val_irreducible rfl _ · rfl - -instance instAtomicStore {s} {v1 v2 : Val} : Language.Atomic s hl(&v1 ← &v2) where +instance instAtomicStore {s} {v1 v2 : Val} : Atomic s hl(&v1 ← &v2) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : EctxLanguage.SubredexesAreValues hl(&v1 ← &v2) := by - apply EctxItemLanguage.subredexes_are_values + have hsr : SubredexesAreValues hl(&v1 ← &v2) := by + apply subredexes_are_values intro Ki e_inner heq cases Ki <;> try (cases heq; done) all_goals (cases heq; rfl) - cases (EctxLanguage.baseStep_of_primStep Hstep hsr) + cases (baseStep_of_primStep Hstep hsr) rename_i l v Heq cases s - · exact Language.val_irreducible rfl _ + · exact val_irreducible rfl _ · rfl -instance instAtomicSnd {s} {v1 : Val} : Language.Atomic s hl(snd(&v1)) where +instance instAtomicFst {s} {v1 : Val} : Atomic s hl(fst(&v1)) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : EctxLanguage.SubredexesAreValues hl(snd(&v1)) := by - apply EctxItemLanguage.subredexes_are_values + have hsr : SubredexesAreValues hl(fst(&v1)) := by + apply subredexes_are_values intro Ki e_inner heq cases Ki <;> try (cases heq; done) · cases heq; rfl - cases (EctxLanguage.baseStep_of_primStep Hstep hsr) + cases (baseStep_of_primStep Hstep hsr) + cases s + · exact val_irreducible rfl _ + · rfl + +instance instAtomicSnd {s} {v1 : Val} : Atomic s hl(snd(&v1)) where + atomic {σ obs e' σ' eₜ} Hstep := by + have hsr : SubredexesAreValues hl(snd(&v1)) := by + apply subredexes_are_values + intro Ki e_inner heq + cases Ki <;> try (cases heq; done) + · cases heq; rfl + cases (baseStep_of_primStep Hstep hsr) + cases s + · exact val_irreducible rfl _ + · rfl + +instance instAtomicAllocN {s} {v1 v2 : Val} : Atomic s hl(allocn(&v1, &v2)) where + atomic {σ obs e' σ' eₜ} Hstep := by + have hsr : SubredexesAreValues hl(allocn(&v1, &v2)) := by + apply subredexes_are_values + intro Ki e_inner heq + cases Ki <;> try (cases heq; done) + all_goals (cases heq; rfl) + cases (baseStep_of_primStep Hstep hsr) cases s - · exact Language.val_irreducible rfl _ + · exact val_irreducible rfl _ · rfl -instance instAtomicCmpXChg {s} {v1 v2 v3 : Val} : Language.Atomic s hl(cmpXchg(&v1, &v2, &v3)) where +instance instAtomicFree {s} {v : Val} : Atomic s hl(free(&v)) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : EctxLanguage.SubredexesAreValues hl(cmpXchg(&v1, &v2, &v3)) := by - apply EctxItemLanguage.subredexes_are_values + have hsr : SubredexesAreValues hl(free(&v)) := by + apply subredexes_are_values intro Ki e_inner heq cases Ki <;> try (cases heq; done) all_goals (cases heq; rfl) - cases (EctxLanguage.baseStep_of_primStep Hstep hsr) + cases (baseStep_of_primStep Hstep hsr) cases s - · exact Language.val_irreducible rfl _ + · exact val_irreducible rfl _ · rfl +instance instAtomicXchg {s} {v1 v2 : Val} : Atomic s hl(xchg(&v1, &v2)) where + atomic {σ obs e' σ' eₜ} Hstep := by + have hsr : SubredexesAreValues hl(xchg(&v1, &v2)) := by + apply subredexes_are_values + intro Ki e_inner heq + cases Ki <;> try (cases heq; done) + all_goals (cases heq; rfl) + cases (baseStep_of_primStep Hstep hsr) + cases s + · exact val_irreducible rfl _ + · rfl + +instance instAtomicFaa {s} {v1 v2 : Val} : Atomic s hl(faa(&v1, &v2)) where + atomic {σ obs e' σ' eₜ} Hstep := by + have hsr : SubredexesAreValues hl(faa(&v1, &v2)) := by + apply subredexes_are_values + intro Ki e_inner heq + cases Ki <;> try (cases heq; done) + all_goals (cases heq; rfl) + cases (baseStep_of_primStep Hstep hsr) + cases s + · exact val_irreducible rfl _ + · rfl + +instance instAtomicFork {s} {e : Exp} : Atomic s hl(fork(&e)) where + atomic {σ obs e' σ' eₜ} Hstep := by + have hsr : SubredexesAreValues hl(fork(&e)) := by + apply subredexes_are_values + intro Ki e_inner heq + cases Ki <;> try (cases heq; done) + all_goals (cases heq; rfl) + cases (baseStep_of_primStep Hstep hsr) + cases s + · exact val_irreducible rfl _ + · rfl + +instance instAtomicNewProph {s} : Atomic s (State := State) Exp.newProph where + atomic {σ obs e' σ' eₜ} Hstep := by + have hsr : SubredexesAreValues (Exp.newProph) := by + apply subredexes_are_values + intro Ki e_inner heq + cases Ki <;> try (cases heq; done) + all_goals (cases heq; rfl) + cases (baseStep_of_primStep Hstep hsr) + cases s + · exact val_irreducible rfl _ + · rfl + +instance instAtomicCmpXChg {s} {v1 v2 v3 : Val} : Atomic s hl(cmpXchg(&v1, &v2, &v3)) where + atomic {σ obs e' σ' eₜ} Hstep := by + have hsr : SubredexesAreValues hl(cmpXchg(&v1, &v2, &v3)) := by + apply subredexes_are_values + intro Ki e_inner heq + cases Ki <;> try (cases heq; done) + all_goals (cases heq; rfl) + cases (baseStep_of_primStep Hstep hsr) + cases s + · exact val_irreducible rfl _ + · rfl + +@[rocq_alias prim_step_to_val_is_base_step] +theorem primStep_val_baseStep {e : Exp} {σ : State} {obs : List Observation} + {v : Val} {σ' : State} {efs : List Exp} + (h : PrimStep.primStep (e, σ) obs (Exp.val v, σ', efs)) : + BaseStep e σ obs (Exp.val v) σ' efs := by + generalize hg : (Exp.val v : Exp) = g at h + obtain ⟨Hbase⟩ := h + rename_i a b K + obtain rfl : K = [] := fill_isSome_empty (e := b) (by simp [← hg]) + simp only [EvContext.fill, List.foldl_nil] at hg ⊢ + subst hg + exact Hbase + +theorem base_step_to_val_always_to_val + {e₁ : Exp} {σ₁ₐ : State} {κsₐ : List Observation} {v₂ₐ : Val} {σ₂ₐ : State} + {efsₐ : List Exp} {σ₁ᵦ : State} {κsᵦ : List Observation} + {e₂ᵦ : Exp} {σ₂ᵦ : State} {efsᵦ : List Exp} + (h₁ : BaseStep e₁ σ₁ₐ κsₐ (Exp.val v₂ₐ) σ₂ₐ efsₐ) + (h₂ : BaseStep e₁ σ₁ᵦ κsᵦ e₂ᵦ σ₂ᵦ efsᵦ) : + (toVal e₂ᵦ).isSome := by + cases h₁ <;> cases h₂ <;> simp_all [] <;> grind + +theorem prim_step_to_val_always_to_val + {e₁ : Exp} {σ₁ₐ : State} {κsₐ : List Observation} {v₂ₐ : Val} {σ₂ₐ : State} + {efsₐ : List Exp} {σ₁ᵦ : State} {κsᵦ : List Observation} + {e₂ᵦ : Exp} {σ₂ᵦ : State} {efsᵦ : List Exp} + (h₁ : PrimStep.primStep (e₁, σ₁ₐ) κsₐ (Exp.val v₂ₐ, σ₂ₐ, efsₐ)) + (h₂ : PrimStep.primStep (e₁, σ₁ᵦ) κsᵦ (e₂ᵦ, σ₂ᵦ, efsᵦ)) : + (toVal e₂ᵦ).isSome := by + have Hbase₁ := primStep_val_baseStep h₁ + have hsr : SubredexesAreValues e₁ := by + intro K e' heq hnv + rcases base_ctx_step_val (K := K) (e := e') (heq ▸ Hbase₁) with h | h + · rw [hnv] at h; simp at h + · exact h + exact base_step_to_val_always_to_val Hbase₁ (baseStep_of_primStep h₂ hsr) + +theorem base_step_to_val_atomic {e₁ : Exp} {σ₁ₐ : State} {κsₐ : List Observation} {v₂ₐ : Val} + {σ₂ₐ : State} {efsₐ : List Exp} (a : Atomicity) (h : BaseStep e₁ σ₁ₐ κsₐ (Exp.val v₂ₐ) σ₂ₐ efsₐ) : + Atomic (State := State) a e₁ := + stronglyAtomic_atomic ⟨prim_step_to_val_always_to_val (primStep_of_baseStep h)⟩ + +/- TODO: Coq has a `Hint Extern (Atomic _ _) => by eapply base_step_to_val_atomic`. + No Lean equivalent — `BaseStep` is not a typeclass, so we can't make this + a real instance. At use sites, manually apply `base_step_to_val_atomic`. -/ + +/-- One cannot deallocate prophecy variables: any base step preserves +`usedProphId` modulo extension. Mirrors Rocq's `base_step_more_proph_ids`. -/ +@[rocq_alias base_step_more_proph_ids] +theorem base_step_more_proph_ids {e : Exp} {σ : State} {κs : List Observation} + {e' : Exp} {σ' : State} {efs : List Exp} (h : BaseStep e σ κs e' σ' efs) : + σ.usedProphId ⊆ σ'.usedProphId := by + induction h with + | newProphS _ p _ => intro x hx; rw [Std.ExtTreeSet.mem_insert]; right; exact hx + | resolveS _ _ _ _ _ _ _ _ _ _ IH => exact IH + | cmpXchgS _ _ _ _ _ b _ _ _ => cases b <;> intro _ hx <;> exact hx + | _ => intro _ hx; exact hx + +@[rocq_alias step_resolve] +theorem step_resolve {e : Exp} {vp vt : Val} {σ₁ σ₂ : State} {κ : List Observation} {e₂ : Exp} {efs : List Exp} + [hatom : Atomic .StronglyAtomic e] + (hprim : PrimStep.primStep (Exp.resolve e (.val vp) (.val vt), σ₁) κ (e₂, σ₂, efs)) : + BaseStep (Exp.resolve e (.val vp) (.val vt)) σ₁ κ e₂ σ₂ efs := by + generalize hsrc : Exp.resolve e (.val vp) (.val vt) = src at hprim + obtain ⟨Hbase⟩ := hprim + rename_i e₁' e₂' K + cases K using List.reverseRec with + | nil => simp only [fill_nil] at hsrc ⊢; subst hsrc; exact Hbase + | append_singleton K' Ki ih => + clear ih + exfalso + cases Ki <;> + simp only [fillItem, ECtxItem.fill, fill_append, fill_cons, fill_nil, + Exp.resolve.injEq, reduceCtorEq] at hsrc + case resolveL K_inner _ _ => + have hp : PrimStep.primStep (e, σ₁) κ (fillItem K_inner (fill K' e₂'), σ₂, efs) := by + rw [hsrc.1] + exact fill_primStep [K_inner] (fill_primStep K' (primStep_of_baseStep Hbase)) + exact absurd (hatom.atomic hp) (by simp [fillItem_expToVal_none]) + case resolveM => exact baseStep_fill_eq_val_absurd Hbase hsrc.2.1 + case resolveR => exact baseStep_fill_eq_val_absurd Hbase hsrc.2.2 + +theorem prim_step_resolve_of_inner {e : Exp} {σ σ_e : State} {κ_e : List Observation} + {v_e w : Val} {efs_e : List Exp} {p : ProphId} (Hbase_e : BaseStep e σ κ_e (.val v_e) σ_e efs_e) + (hp_contains : σ.usedProphId.contains p) : + PrimStep.primStep (Exp.resolve e (.val (.lit (.prophecy p))) (.val w), σ) + (κ_e ++ [(p, (v_e, w))]) (Exp.val v_e, σ_e, efs_e) := + primStep_of_baseStep (BaseStep.resolveS p v_e e σ w σ_e κ_e efs_e Hbase_e hp_contains) + +theorem step_resolve_decompose {e : Exp} {p : ProphId} {w : Val} {σ₁ σ₂ : State} {κ : List Observation} + {e₂ : Exp} {efs : List Exp} [hatom : Atomic .StronglyAtomic e] + (hstep : PrimStep.primStep (Exp.resolve e (.val (.lit (.prophecy p))) (.val w), σ₁) κ (e₂, σ₂, efs)) : + ∃ (κ_inner : List Observation) (v_inner : Val), + κ = κ_inner ++ [(p, (v_inner, w))] ∧ + e₂ = Exp.val v_inner ∧ + BaseStep e σ₁ κ_inner (.val v_inner) σ₂ efs := + match step_resolve hstep with + | .resolveS _ v_n _ _ _ _ κs_n _ hb _ => ⟨κs_n, v_n, rfl, rfl, hb⟩ + +@[rocq_alias resolve_reducible] +theorem resolve_reducible {e : Exp} {σ : State} {p : ProphId} {v : Val} + [hatom : Atomic .StronglyAtomic e] (hred : BaseStep.Reducible (e, σ)) + (hin : σ.usedProphId.contains p) : + BaseStep.Reducible (Exp.resolve e (.val (.lit (.prophecy p))) (.val v), σ) := by + obtain ⟨κ, e', σ', efs, hstep⟩ := hred + have hprim : PrimStep.primStep (e, σ) κ (e', σ', efs) := primStep_of_baseStep hstep + have hval : (toVal e').isSome := hatom.atomic hprim + obtain ⟨w', rfl⟩ : ∃ w', e' = Exp.val w' := by + cases e' with | val w' => exact ⟨w', rfl⟩ | _ => simp [toVal] at hval + refine ⟨κ ++ [(p, (w', v))], Exp.val w', σ', efs, ?_⟩ + exact .resolveS p w' e σ v σ' κ efs hstep hin + +theorem prim_step_reducible_resolve {e : Exp} {σ : State} {p : ProphId} {w : Val} + [hatom : Atomic .StronglyAtomic e] (hp_contains : σ.usedProphId.contains p) + (hred : PrimStep.Reducible (e, σ)) : + PrimStep.Reducible (Exp.resolve e (.val (.lit (.prophecy p))) (.val w), σ) := by + obtain ⟨κ, e', σ', efs, hprim⟩ := hred + have hval : (toVal e').isSome := hatom.atomic hprim + obtain ⟨v, rfl⟩ : ∃ v, e' = Exp.val v := by + match e', hval with | .val v, _ => exact ⟨v, rfl⟩ + exact primStep_reducible_of_baseStep_reducible + (resolve_reducible ⟨κ, _, σ', efs, primStep_val_baseStep hprim⟩ hp_contains) + +@[rocq_alias prim_step_more_proph_ids] +theorem prim_step_more_proph_ids {e : Exp} {σ : State} {κs : List Observation} {e' : Exp} + {σ' : State} {efs : List Exp} (h : PrimStep.primStep (e, σ) κs (e', σ', efs)) : + σ.usedProphId ⊆ σ'.usedProphId := by + obtain ⟨hbase⟩ := h + exact base_step_more_proph_ids hbase + +/-- `resolve e &vp &vt` is atomic whenever its subexpression `e` is strongly +atomic: any step of the whole expression is a `resolveS` base step, which runs +`e` to a value and produces a value. Mirrors `resolve_atomic` in Rocq. -/ +instance instAtomicResolve {s} {e : Exp} {vp vt : Val} [hatom : Atomic .StronglyAtomic e] : + Atomic s (Exp.resolve e (.val vp) (.val vt)) where + atomic {σ obs e' σ' eₜ} Hstep := by + cases step_resolve Hstep with + | resolveS _ v _ _ _ _ _ _ _ _ => + cases s + · exact val_irreducible rfl _ + · rfl + end Iris.HeapLang diff --git a/Iris/Iris/ProgramLogic/EctxiLanguage.lean b/Iris/Iris/ProgramLogic/EctxiLanguage.lean index 970192711..74e23d39a 100644 --- a/Iris/Iris/ProgramLogic/EctxiLanguage.lean +++ b/Iris/Iris/ProgramLogic/EctxiLanguage.lean @@ -81,6 +81,15 @@ theorem fill_append (K₁ K₂ : Λ.Ectx) (e : Expr) : fill (K₁ ++ K₂) e = f theorem fill_val {K} {e : Expr} : (toVal (fill K e)).isSome = true → (toVal e).isSome = true := by induction K generalizing e <;> grind [fillItem_val] +theorem baseStep_fill_eq_val_absurd {K : Ectx} {e e' : Expr} {σ σ' : State} + {obs : List Obs} {efs : List Expr} {v : Val} + (hbase : (e, σ) -->ᵇ (e', σ', efs)) + (heq : (v : Expr) = fill K e) : False := by + have hfill_isval : (toVal (fill K e)).isSome := heq ▸ by simp + have h_e_val : (toVal e).isSome := fill_val hfill_isval + rw [val_stuck hbase] at h_e_val + simp at h_e_val + -- NOTE: Would it be worth having an `isVal` predicate for `Expr`, basically defined -- as `toVal e |>.isSome`, so that we could rephrase all instances of `(toVal e).isSome` -- as `isVal e` and `toVal e = none` as `¬ isVal e`. That way tactics like `grind` would From 1a11681c79b49559179f982705bc5bfee8bc132b Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Tue, 16 Jun 2026 15:29:51 -0400 Subject: [PATCH 02/33] more golf --- Iris/Iris/HeapLang/Instances.lean | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/Iris/Iris/HeapLang/Instances.lean b/Iris/Iris/HeapLang/Instances.lean index 6031f79d5..2964f5a23 100644 --- a/Iris/Iris/HeapLang/Instances.lean +++ b/Iris/Iris/HeapLang/Instances.lean @@ -394,8 +394,6 @@ theorem base_step_to_val_atomic {e₁ : Exp} {σ₁ₐ : State} {κsₐ : List O No Lean equivalent — `BaseStep` is not a typeclass, so we can't make this a real instance. At use sites, manually apply `base_step_to_val_atomic`. -/ -/-- One cannot deallocate prophecy variables: any base step preserves -`usedProphId` modulo extension. Mirrors Rocq's `base_step_more_proph_ids`. -/ @[rocq_alias base_step_more_proph_ids] theorem base_step_more_proph_ids {e : Exp} {σ : State} {κs : List Observation} {e' : Exp} {σ' : State} {efs : List Exp} (h : BaseStep e σ κs e' σ' efs) : @@ -423,10 +421,10 @@ theorem step_resolve {e : Exp} {vp vt : Val} {σ₁ σ₂ : State} {κ : List Ob simp only [fillItem, ECtxItem.fill, fill_append, fill_cons, fill_nil, Exp.resolve.injEq, reduceCtorEq] at hsrc case resolveL K_inner _ _ => - have hp : PrimStep.primStep (e, σ₁) κ (fillItem K_inner (fill K' e₂'), σ₂, efs) := by - rw [hsrc.1] - exact fill_primStep [K_inner] (fill_primStep K' (primStep_of_baseStep Hbase)) - exact absurd (hatom.atomic hp) (by simp [fillItem_expToVal_none]) + suffices hp : PrimStep.primStep (e, σ₁) κ (fillItem K_inner (fill K' e₂'), σ₂, efs) by + exact absurd (hatom.atomic hp) (by simp [fillItem_expToVal_none]) + rw [hsrc.1] + exact fill_primStep [K_inner] (fill_primStep K' (primStep_of_baseStep Hbase)) case resolveM => exact baseStep_fill_eq_val_absurd Hbase hsrc.2.1 case resolveR => exact baseStep_fill_eq_val_absurd Hbase hsrc.2.2 @@ -453,9 +451,8 @@ theorem resolve_reducible {e : Exp} {σ : State} {p : ProphId} {v : Val} (hin : σ.usedProphId.contains p) : BaseStep.Reducible (Exp.resolve e (.val (.lit (.prophecy p))) (.val v), σ) := by obtain ⟨κ, e', σ', efs, hstep⟩ := hred - have hprim : PrimStep.primStep (e, σ) κ (e', σ', efs) := primStep_of_baseStep hstep - have hval : (toVal e').isSome := hatom.atomic hprim obtain ⟨w', rfl⟩ : ∃ w', e' = Exp.val w' := by + have hval : (toVal e').isSome := hatom.atomic (primStep_of_baseStep hstep) cases e' with | val w' => exact ⟨w', rfl⟩ | _ => simp [toVal] at hval refine ⟨κ ++ [(p, (w', v))], Exp.val w', σ', efs, ?_⟩ exact .resolveS p w' e σ v σ' κ efs hstep hin @@ -465,9 +462,8 @@ theorem prim_step_reducible_resolve {e : Exp} {σ : State} {p : ProphId} {w : Va (hred : PrimStep.Reducible (e, σ)) : PrimStep.Reducible (Exp.resolve e (.val (.lit (.prophecy p))) (.val w), σ) := by obtain ⟨κ, e', σ', efs, hprim⟩ := hred - have hval : (toVal e').isSome := hatom.atomic hprim obtain ⟨v, rfl⟩ : ∃ v, e' = Exp.val v := by - match e', hval with | .val v, _ => exact ⟨v, rfl⟩ + match e', (hatom.atomic hprim) with | .val v, _ => exact ⟨v, rfl⟩ exact primStep_reducible_of_baseStep_reducible (resolve_reducible ⟨κ, _, σ', efs, primStep_val_baseStep hprim⟩ hp_contains) From 65d12bda9e909cf7b9af111ef413339f1f449e90 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Tue, 16 Jun 2026 15:34:20 -0400 Subject: [PATCH 03/33] remove stale aliases --- Iris/Iris/HeapLang/Instances.lean | 5 ----- 1 file changed, 5 deletions(-) diff --git a/Iris/Iris/HeapLang/Instances.lean b/Iris/Iris/HeapLang/Instances.lean index 2964f5a23..b807120cd 100644 --- a/Iris/Iris/HeapLang/Instances.lean +++ b/Iris/Iris/HeapLang/Instances.lean @@ -348,7 +348,6 @@ instance instAtomicCmpXChg {s} {v1 v2 v3 : Val} : Atomic s hl(cmpXchg(&v1, &v2, · exact val_irreducible rfl _ · rfl -@[rocq_alias prim_step_to_val_is_base_step] theorem primStep_val_baseStep {e : Exp} {σ : State} {obs : List Observation} {v : Val} {σ' : State} {efs : List Exp} (h : PrimStep.primStep (e, σ) obs (Exp.val v, σ', efs)) : @@ -394,7 +393,6 @@ theorem base_step_to_val_atomic {e₁ : Exp} {σ₁ₐ : State} {κsₐ : List O No Lean equivalent — `BaseStep` is not a typeclass, so we can't make this a real instance. At use sites, manually apply `base_step_to_val_atomic`. -/ -@[rocq_alias base_step_more_proph_ids] theorem base_step_more_proph_ids {e : Exp} {σ : State} {κs : List Observation} {e' : Exp} {σ' : State} {efs : List Exp} (h : BaseStep e σ κs e' σ' efs) : σ.usedProphId ⊆ σ'.usedProphId := by @@ -404,7 +402,6 @@ theorem base_step_more_proph_ids {e : Exp} {σ : State} {κs : List Observation} | cmpXchgS _ _ _ _ _ b _ _ _ => cases b <;> intro _ hx <;> exact hx | _ => intro _ hx; exact hx -@[rocq_alias step_resolve] theorem step_resolve {e : Exp} {vp vt : Val} {σ₁ σ₂ : State} {κ : List Observation} {e₂ : Exp} {efs : List Exp} [hatom : Atomic .StronglyAtomic e] (hprim : PrimStep.primStep (Exp.resolve e (.val vp) (.val vt), σ₁) κ (e₂, σ₂, efs)) : @@ -445,7 +442,6 @@ theorem step_resolve_decompose {e : Exp} {p : ProphId} {w : Val} {σ₁ σ₂ : match step_resolve hstep with | .resolveS _ v_n _ _ _ _ κs_n _ hb _ => ⟨κs_n, v_n, rfl, rfl, hb⟩ -@[rocq_alias resolve_reducible] theorem resolve_reducible {e : Exp} {σ : State} {p : ProphId} {v : Val} [hatom : Atomic .StronglyAtomic e] (hred : BaseStep.Reducible (e, σ)) (hin : σ.usedProphId.contains p) : @@ -467,7 +463,6 @@ theorem prim_step_reducible_resolve {e : Exp} {σ : State} {p : ProphId} {w : Va exact primStep_reducible_of_baseStep_reducible (resolve_reducible ⟨κ, _, σ', efs, primStep_val_baseStep hprim⟩ hp_contains) -@[rocq_alias prim_step_more_proph_ids] theorem prim_step_more_proph_ids {e : Exp} {σ : State} {κs : List Observation} {e' : Exp} {σ' : State} {efs : List Exp} (h : PrimStep.primStep (e, σ) κs (e', σ', efs)) : σ.usedProphId ⊆ σ'.usedProphId := by From 100afe7bf8ce622d6442b9b1378f4d45d0aaa1da Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Thu, 18 Jun 2026 15:02:36 -0400 Subject: [PATCH 04/33] solve SubredexesAreValues via local macro --- Iris/Iris/HeapLang/Instances.lean | 157 +++++++----------------------- 1 file changed, 36 insertions(+), 121 deletions(-) diff --git a/Iris/Iris/HeapLang/Instances.lean b/Iris/Iris/HeapLang/Instances.lean index b807120cd..77c1bc56b 100644 --- a/Iris/Iris/HeapLang/Instances.lean +++ b/Iris/Iris/HeapLang/Instances.lean @@ -64,6 +64,12 @@ theorem fill_isSome_empty {K : List ECtxItem} {e : Exp} have h2 := EctxLanguage.fill_val (K := K') (e := fillItem Ki e) h simp [fillItem_expToVal_none] at h2 +macro "solve_subredex_values" : tactic => + `(tactic| + (apply subredexes_are_values + intro Ki e_inner heq + cases Ki <;> cases heq <;> try rfl <;> try done)) + theorem mk_pure_prim_step {e1 e2 : Exp} (hstep : ∀ σ, BaseStep e1 σ [] e2 σ []) (hpure : ∀ {σ1 κs e2' σ2 efs}, BaseStep e1 σ1 κs e2' σ2 efs → κs = [] ∧ σ1 = σ2 ∧ e2 = e2' ∧ efs = []) (hsub : SubredexesAreValues e1) : PurePrimStep e1 e2 := by @@ -76,20 +82,14 @@ instance instPureExecIfTrue: PureExec True 1 hl(if #true then &e1 else &e2) e1 w refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq - rfl + · solve_subredex_values instance instPureExecIfFalse : PureExec True 1 hl(if #false then &e1 else &e2) e2 where pureExec _ := by refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq - rfl + · solve_subredex_values instance instPureExecCaseInjl {v e1 e2} : PureExec True 1 (Exp.case hl(v(injl(&v))) e1 e2) (.app e1 (.ofVal v)) where @@ -97,10 +97,7 @@ instance instPureExecCaseInjl {v e1 e2} : refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq - rfl + · solve_subredex_values instance instPureExecCaseInjr {v e1 e2} : PureExec True 1 (Exp.case hl(v(injr(&v))) e1 e2) (.app e2 (.ofVal v)) where @@ -108,30 +105,21 @@ instance instPureExecCaseInjr {v e1 e2} : refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq - rfl + · solve_subredex_values instance instPureExecInjl {v : Val} : PureExec True 1 hl(injl(&v)) hl(v(injl(&v))) where pureExec _ := by refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq - rfl + · solve_subredex_values instance instPureExecInjr {v : Val} : PureExec True 1 hl(injr(&v)) hl(v(injr(&v))) where pureExec _ := by refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor · cases hs <;> simp - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq - rfl + · solve_subredex_values instance instPureExecBeta {f x : Binder} {e : Exp} {v : Val} : PureExec True 1 hl(v(rec &f &x := &e) &v) ((e.subst f (.rec_ f x e)).subst x v) where @@ -139,9 +127,7 @@ instance instPureExecBeta {f x : Binder} {e : Exp} {v : Val} : refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp · cases hs <;> simp [*] - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq <;> rfl + · solve_subredex_values instance instPureExecRec {f x e} : PureExec True 1 hl(rec &f &x := &e) hl(v(rec &f &x := &e)) where @@ -149,36 +135,28 @@ instance instPureExecRec {f x e} : refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp · cases hs <;> simp [*] - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq <;> rfl + · solve_subredex_values instance instPureExecFst {v1 v2 : Val} : PureExec True 1 hl(fst(v((&v1, &v2)))) v1 where pureExec _ := by refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp · cases hs <;> simp [*] - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq <;> rfl + · solve_subredex_values instance instPureExecSnd {v1 v2 : Val} : PureExec True 1 hl(snd(v((&v1, &v2)))) v2 where pureExec _ := by refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp · cases hs <;> simp [*] - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq <;> rfl + · solve_subredex_values instance instPureExecPair {v1 v2 : Val} : PureExec True 1 hl((&v1, &v2)) hl(v((&v1, &v2))) where pureExec _ := by refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp · cases hs <;> simp [*] - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq <;> rfl + · solve_subredex_values set_option synthInstance.checkSynthOrder false in instance instPureExecUnOp {op : UnOp} {v v' : Val} : @@ -187,9 +165,7 @@ instance instPureExecUnOp {op : UnOp} {v v' : Val} : refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp [*] · cases hs <;> simp_all [UnOp.eval] - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq <;> rfl + · solve_subredex_values set_option synthInstance.checkSynthOrder false in instance instPureExecBinOp {op : BinOp} {v1 v2 v' : Val} : @@ -199,9 +175,7 @@ instance instPureExecBinOp {op : BinOp} {v1 v2 v' : Val} : refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp [*] · cases hs <;> simp_all [BinOp.eval] - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq <;> rfl + · solve_subredex_values -- higher priority than the generic binop instance instance (priority := default + 10) instPureExecEqOp {v1 v2 : Val} : @@ -211,30 +185,18 @@ instance (priority := default + 10) instPureExecEqOp {v1 v2 : Val} : refine .once <| mk_pure_prim_step (fun _ => ?_) (fun hs => ?_) ?_ · constructor <;> simp [BinOp.eval, *] · cases hs <;> simp_all [BinOp.eval] - · apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> cases heq <;> rfl + · solve_subredex_values instance instAtomicLoad {s} {v : Val} : Atomic s hl(!&v) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues hl(!&v) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - all_goals (cases heq; rfl) - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) cases s · exact val_irreducible rfl _ · rfl instance instAtomicStore {s} {v1 v2 : Val} : Atomic s hl(&v1 ← &v2) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues hl(&v1 ← &v2) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - all_goals (cases heq; rfl) - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) rename_i l v Heq cases s · exact val_irreducible rfl _ @@ -242,108 +204,63 @@ instance instAtomicStore {s} {v1 v2 : Val} : Atomic s hl(&v1 ← &v2) where instance instAtomicFst {s} {v1 : Val} : Atomic s hl(fst(&v1)) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues hl(fst(&v1)) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - · cases heq; rfl - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) cases s · exact val_irreducible rfl _ · rfl instance instAtomicSnd {s} {v1 : Val} : Atomic s hl(snd(&v1)) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues hl(snd(&v1)) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - · cases heq; rfl - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) cases s · exact val_irreducible rfl _ · rfl instance instAtomicAllocN {s} {v1 v2 : Val} : Atomic s hl(allocn(&v1, &v2)) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues hl(allocn(&v1, &v2)) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - all_goals (cases heq; rfl) - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) cases s · exact val_irreducible rfl _ · rfl instance instAtomicFree {s} {v : Val} : Atomic s hl(free(&v)) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues hl(free(&v)) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - all_goals (cases heq; rfl) - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) cases s · exact val_irreducible rfl _ · rfl instance instAtomicXchg {s} {v1 v2 : Val} : Atomic s hl(xchg(&v1, &v2)) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues hl(xchg(&v1, &v2)) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - all_goals (cases heq; rfl) - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) cases s · exact val_irreducible rfl _ · rfl instance instAtomicFaa {s} {v1 v2 : Val} : Atomic s hl(faa(&v1, &v2)) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues hl(faa(&v1, &v2)) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - all_goals (cases heq; rfl) - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) cases s · exact val_irreducible rfl _ · rfl instance instAtomicFork {s} {e : Exp} : Atomic s hl(fork(&e)) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues hl(fork(&e)) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - all_goals (cases heq; rfl) - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) cases s · exact val_irreducible rfl _ · rfl instance instAtomicNewProph {s} : Atomic s (State := State) Exp.newProph where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues (Exp.newProph) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - all_goals (cases heq; rfl) - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) cases s · exact val_irreducible rfl _ · rfl instance instAtomicCmpXChg {s} {v1 v2 v3 : Val} : Atomic s hl(cmpXchg(&v1, &v2, &v3)) where atomic {σ obs e' σ' eₜ} Hstep := by - have hsr : SubredexesAreValues hl(cmpXchg(&v1, &v2, &v3)) := by - apply subredexes_are_values - intro Ki e_inner heq - cases Ki <;> try (cases heq; done) - all_goals (cases heq; rfl) - cases (baseStep_of_primStep Hstep hsr) + cases baseStep_of_primStep Hstep (by solve_subredex_values) cases s · exact val_irreducible rfl _ · rfl @@ -376,13 +293,11 @@ theorem prim_step_to_val_always_to_val (h₁ : PrimStep.primStep (e₁, σ₁ₐ) κsₐ (Exp.val v₂ₐ, σ₂ₐ, efsₐ)) (h₂ : PrimStep.primStep (e₁, σ₁ᵦ) κsᵦ (e₂ᵦ, σ₂ᵦ, efsᵦ)) : (toVal e₂ᵦ).isSome := by - have Hbase₁ := primStep_val_baseStep h₁ - have hsr : SubredexesAreValues e₁ := by - intro K e' heq hnv - rcases base_ctx_step_val (K := K) (e := e') (heq ▸ Hbase₁) with h | h - · rw [hnv] at h; simp at h - · exact h - exact base_step_to_val_always_to_val Hbase₁ (baseStep_of_primStep h₂ hsr) + refine base_step_to_val_always_to_val (primStep_val_baseStep h₁) (baseStep_of_primStep h₂ ?_) + intro K e' heq hnv + rcases base_ctx_step_val (K := K) (e := e') (heq ▸primStep_val_baseStep h₁) with h | h + · rw [hnv] at h; simp at h + · exact h theorem base_step_to_val_atomic {e₁ : Exp} {σ₁ₐ : State} {κsₐ : List Observation} {v₂ₐ : Val} {σ₂ₐ : State} {efsₐ : List Exp} (a : Atomicity) (h : BaseStep e₁ σ₁ₐ κsₐ (Exp.val v₂ₐ) σ₂ₐ efsₐ) : From d308de0b52e29176d8c18483c7be08052696bba3 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Thu, 18 Jun 2026 16:09:05 -0400 Subject: [PATCH 05/33] copy files from completeness branch --- Iris/Iris/Algebra/Frac.lean | 36 ++++++++ Iris/Iris/BI/BigOp/BigSepMap.lean | 18 +++- Iris/Iris/BI/Lib/Fractional.lean | 106 ++++++++++++++++++++++- Iris/Iris/Instances/Lib/CInvariants.lean | 12 +++ Iris/Iris/Instances/Lib/GhostMap.lean | 2 + Iris/Iris/Instances/Lib/Invariants.lean | 13 +++ Iris/Iris/ProgramLogic/EctxLanguage.lean | 2 + Iris/Iris/ProgramLogic/Language.lean | 9 ++ Iris/Iris/ProgramLogic/WeakestPre.lean | 4 + Iris/Iris/Std/FromMathlib.lean | 47 ++++++++++ Iris/Iris/Std/PartialMap.lean | 32 +++++++ 11 files changed, 277 insertions(+), 4 deletions(-) diff --git a/Iris/Iris/Algebra/Frac.lean b/Iris/Iris/Algebra/Frac.lean index 537d72f2a..bb53d234b 100644 --- a/Iris/Iris/Algebra/Frac.lean +++ b/Iris/Iris/Algebra/Frac.lean @@ -19,6 +19,21 @@ This version follows Iris Rocq in fixing the underlying type of fractions to be @[expose] public section +/-! ## Ordered-field lemmas for `Rat` + +This environment has no Mathlib, so `Rat` is missing the ordered-field API (and the +`positivity`/`field_simp` tactics) needed to reason about division. These few lemmas fill the +gap that the `Qp` API below relies on. -/ +namespace Rat + +protected theorem div_pos {a b : Rat} (ha : 0 < a) (hb : 0 < b) : 0 < a / b := by + rw [Rat.div_def]; exact Rat.mul_pos ha (Rat.inv_pos.mpr hb) + +protected theorem mul_div_cancel_left {a b : Rat} (ha : a ≠ 0) : a * (b / a) = b := by + rw [Rat.mul_comm, Rat.div_mul_cancel ha] + +end Rat + namespace Iris /-- The type of positive rational numbers, used as fractions -/ @@ -42,6 +57,16 @@ def Qp.half (q : Qp) : Qp where let ⟨v, P⟩ := q grind +/-- Division of fractions. -/ +def Qp.div (x y : Qp) : Qp := ⟨x.val / y.val, Rat.div_pos x.2 y.2⟩ + +instance instHDivQpQpQp : HDiv Qp Qp Qp where + hDiv := Qp.div + +/-- `q` divided into `n > 0` equal positive parts. -/ +def Qp.divide_even (q : Qp) (n : Nat) (hn : 0 < n) : Qp := + ⟨q.val / n, Rat.div_pos q.2 (by exact_mod_cast hn)⟩ + instance instCOFEQp : COFE Qp := COFE.ofDiscrete _ Eq_Equivalence instance instLeibnizQp : OFE.Leibniz Qp := ⟨id⟩ @@ -75,6 +100,9 @@ instance instCMRAQp : CMRA Qp where @[simp, grind =] theorem Qp.val_add (x y : Qp) : (x + y).val = x.val + y.val := rfl @[simp, grind =] theorem Qp.val_one : (1 : Qp).val = 1 := rfl @[simp, grind =] theorem Qp.val_half (q : Qp) : q.half.val = q.val / 2 := rfl +@[simp, grind =] theorem Qp.val_div (x y : Qp) : (x / y).val = x.val / y.val := rfl +@[simp, grind =] theorem Qp.val_divide_even (q : Qp) (n : Nat) (hn : 0 < n) : + (q.divide_even n hn).val = q.val / n := rfl @[simp, grind =] theorem Qp.val_op (x y : Qp) : (x • y).val = x.val + y.val := rfl @[simp, grind =] theorem Qp.validN_iff {n} {x : Qp} : ✓{n} x ↔ x.val ≤ 1 := Iff.rfl @[simp, grind =] theorem Qp.valid_iff {x : Qp} : ✓ x ↔ x.val ≤ 1 := Iff.rfl @@ -87,6 +115,14 @@ instance instCMRAQp : CMRA Qp where /-- The whole fraction `1` is valid. -/ @[simp, rocq_alias frac_valid_1] theorem Qp.valid_one : ✓ (1 : Qp) := by grind +/-- Two halves make a whole. -/ +@[simp, grind =] theorem Qp.half_add_half (q : Qp) : q.half + q.half = q := Subtype.ext (by grind) + +/-- `a < b` iff `b` is `a` plus some positive remainder. -/ +theorem Qp.lt_iff_exists_add {a b : Qp} : a < b ↔ ∃ c : Qp, a + c = b := by + refine ⟨fun h => ⟨⟨b.val - a.val, by have := Qp.lt_iff.mp h; grind⟩, Subtype.ext (by grind)⟩, ?_⟩ + rintro ⟨c, rfl⟩; have := c.2; grind + #rocq_ignore frac_op_instance "Use CMRA instance" #rocq_ignore frac_pcore_instance "Use CMRA instance" #rocq_ignore frac_valid_instance "Use CMRA instance" diff --git a/Iris/Iris/BI/BigOp/BigSepMap.lean b/Iris/Iris/BI/BigOp/BigSepMap.lean index f5636d7e6..faca2311a 100644 --- a/Iris/Iris/BI/BigOp/BigSepMap.lean +++ b/Iris/Iris/BI/BigOp/BigSepMap.lean @@ -568,8 +568,22 @@ theorem bigSepM_impl_strong [DecidableEq K] {M₂ : Type _ → Type _} {V₂ : T refine sep_mono_right <| sep_mono_right (equiv_iff.mp <| bigOpM_eqv_of_perm Φ fun k => ?_).2 by_cases hki : i = k <;> simp_all [get?_filter, get?_insert, get?_delete] --- TODO: `big_sepM_kmap` and `big_sepM_map_seq` require map operations --- which are not yet available in `PartialMap`. +-- TODO: `big_sepM_kmap` requires map operations which are not yet available in `PartialMap`. + +theorem bigSepM_map_seq {M' : Type _ → Type _} [LawfulFiniteMap M' Nat] {V : Type _} + {Φ : Nat → V → PROP} {start : Nat} {l : List V} : + ([∗map] k ↦ v ∈ FiniteMap.map_seq (M := M') start l, Φ k v) ⊣⊢ + ([∗list] i ↦ v ∈ l, Φ (start + i) v) := by + induction l generalizing start with + | nil => rw [LawfulFiniteMap.map_seq_nil]; simp + | cons v l ih => + have hfun : (fun i (x : V) => Φ (start + 1 + i) x) = (fun i x => Φ (start + (i + 1)) x) := by + funext i x; congr 1; omega + have ih1 := ih (start := start + 1) + rw [hfun] at ih1 + rw [LawfulFiniteMap.map_seq_cons] + exact (bigSepM_insert (by rw [LawfulFiniteMap.get?_map_seq, if_neg (by omega)])).trans + (sep_congr .rfl ih1) /-! ## Map–Set Interaction -/ diff --git a/Iris/Iris/BI/Lib/Fractional.lean b/Iris/Iris/BI/Lib/Fractional.lean index be5d234d8..fe9666c93 100644 --- a/Iris/Iris/BI/Lib/Fractional.lean +++ b/Iris/Iris/BI/Lib/Fractional.lean @@ -12,13 +12,115 @@ public import Iris.ProofMode @[expose] public section namespace Iris -open Iris.Std BI OFE +open Iris.Std BI OFE ProofMode @[rocq_alias Fractional] class Fractional [BI PROP] (Φ : Qp → PROP) where fractional p q : Φ (p + q) ⊣⊢ Φ p ∗ Φ q @[rocq_alias AsFractional] -class AsFractional {PROP: Type u} [bi: BI PROP] (P : PROP) (Φ : Qp → PROP) (q : Qp) where +class AsFractional {PROP : Type u} [BI PROP] (P : PROP) (Φ : Qp → PROP) (q : Qp) where as_fractional : P ⊣⊢ Φ q as_fractional_fractional : Fractional Φ + +section Lemmas +variable {PROP : Type _} [BI PROP] {P P1 P2 : PROP} {Φ : Qp → PROP} {q q1 q2 : Qp} + +/-- Any `Φ q` of a fractional `Φ` is `AsFractional`. -/ +@[rocq_alias fractional_as_fractional] +instance (priority := 100) fractional_as_fractional [h : Fractional Φ] (q : Qp) : + AsFractional (Φ q) Φ q where + as_fractional := .rfl + as_fractional_fractional := h + +/-- Split a fraction `q1 + q2` into the separating conjunction of its parts. -/ +@[rocq_alias fractional_split] +theorem fractional_split [hP : AsFractional P Φ (q1 + q2)] + [hP1 : AsFractional P1 Φ q1] [hP2 : AsFractional P2 Φ q2] : P ⊣⊢ P1 ∗ P2 := + have := hP.as_fractional_fractional + hP.as_fractional.trans <| (Fractional.fractional q1 q2).trans <| + sep_congr hP1.as_fractional.symm hP2.as_fractional.symm + +/-- Halve a fraction into two equal pieces. -/ +@[rocq_alias fractional_half] +theorem fractional_half [hP : AsFractional P Φ q] [hP12 : AsFractional P1 Φ q.half] : + P ⊣⊢ P1 ∗ P1 := + have := hP.as_fractional_fractional + hP.as_fractional.trans <| (Qp.half_add_half q ▸ Fractional.fractional q.half q.half).trans <| + sep_congr hP12.as_fractional.symm hP12.as_fractional.symm + +/-- Merge two fractions back into their sum. -/ +@[rocq_alias fractional_merge] +theorem fractional_merge [Fractional Φ] + [hP1 : AsFractional P1 Φ q1] [hP2 : AsFractional P2 Φ q2] : P1 ∗ P2 ⊢ Φ (q1 + q2) := + (sep_mono hP1.as_fractional.1 hP2.as_fractional.1).trans (Fractional.fractional q1 q2).2 + +set_option synthInstance.checkSynthOrder false in +@[rocq_alias from_sep_fractional] +instance (priority := default - 10) fromSepFractional [hP : AsFractional P Φ (q1 + q2)] : + FromSep P (Φ q1) (Φ q2) where + from_sep := + have := hP.as_fractional_fractional + (Fractional.fractional q1 q2).2.trans hP.as_fractional.2 + +set_option synthInstance.checkSynthOrder false in +@[rocq_alias into_sep_fractional] +instance (priority := default - 10) intoSepFractional [hP : AsFractional P Φ (q1 + q2)] : + IntoSep P (Φ q1) (Φ q2) where + into_sep := + have := hP.as_fractional_fractional + hP.as_fractional.1.trans (Fractional.fractional q1 q2).1 + +set_option synthInstance.checkSynthOrder false in +@[rocq_alias from_sep_fractional_half] +instance (priority := default - 10) fromSepFractionalHalf [hP : AsFractional P Φ q] : + FromSep P (Φ q.half) (Φ q.half) where + from_sep := + have := hP.as_fractional_fractional + (Qp.half_add_half q ▸ Fractional.fractional q.half q.half).2.trans hP.as_fractional.2 + +set_option synthInstance.checkSynthOrder false in +@[rocq_alias into_sep_fractional_half] +instance (priority := default - 10) intoSepFractionalHalf [hP : AsFractional P Φ q] : + IntoSep P (Φ q.half) (Φ q.half) where + into_sep := + have := hP.as_fractional_fractional + hP.as_fractional.1.trans (Qp.half_add_half q ▸ Fractional.fractional q.half q.half).1 + +end Lemmas + +section Divide +variable {PROP : Type _} [BI PROP] +open BI.BigSepL + +/-- Whenever `q = (k+1) * r`, the fraction `Φ q` splits into `k+1` copies of `Φ r`. -/ +theorem fractional_bigSepL_replicate {Φ : Qp → PROP} [Fractional Φ] (r : Qp) : + ∀ (k : Nat) (q : Qp), q.val = ((k : Rat) + 1) * r.val → + Φ q ⊢ [∗list] _x ∈ List.replicate (k + 1) r, Φ r := by + intro k + induction k with + | zero => + intro q hq + rw [show q = r from Subtype.ext (by grind)] + exact (bigSepL_singleton (Φ := fun _ _ => Φ r)).2 + | succ k ih => + intro q hq + have hval : q.val - r.val = ((k : Rat) + 1) * r.val := by grind + have hpos : (0 : Rat) < q.val - r.val := hval ▸ Rat.mul_pos (by grind) r.2 + have hsum : r + (⟨q.val - r.val, hpos⟩ : Qp) = q := Subtype.ext (by grind) + rw [← hsum, List.replicate_succ] + exact ((Fractional.fractional r _).1.trans (sep_mono_right (ih _ hval))).trans + (bigSepL_cons (Φ := fun _ _ => Φ r)).2 + +/-- Splitting `Φ q` into `n+1` equal pieces, each owning the fraction `q / (n+1)`. -/ +theorem fractional_divide_equal {Φ : Qp → PROP} [Fractional Φ] (q : Qp) (n : Nat) : + Φ q ⊢ [∗list] _x ∈ List.replicate (n + 1) (q.divide_even (n + 1) (Nat.succ_pos n)), + Φ (q.divide_even (n + 1) (Nat.succ_pos n)) := by + refine fractional_bigSepL_replicate _ n q ?_ + have hne : ((n : Rat) + 1) ≠ 0 := by + have : (0 : Rat) ≤ (n : Rat) := by exact_mod_cast Nat.zero_le n + grind + have hcast : ((n + 1 : Nat) : Rat) = (n : Rat) + 1 := by grind + rw [Qp.val_divide_even, hcast, Rat.mul_div_cancel_left hne] + +end Divide diff --git a/Iris/Iris/Instances/Lib/CInvariants.lean b/Iris/Iris/Instances/Lib/CInvariants.lean index ae70b3056..00bade62c 100644 --- a/Iris/Iris/Instances/Lib/CInvariants.lean +++ b/Iris/Iris/Instances/Lib/CInvariants.lean @@ -235,6 +235,8 @@ theorem acc_strong (E : CoPset) (N : Namespace) (γ : GName) (p : Qp) (P : IProp · iexfalso iapply own_one_l $$ Hown' Hown +-- FIXME: Args here should be implicit + @[rocq_alias cinv_acc] theorem acc (E : CoPset) (N : Namespace) (γ : GName) (p : Qp) (P : IProp GF) (Hsub : ↑N ⊆ E) : @@ -250,6 +252,16 @@ theorem acc (E : CoPset) (N : Namespace) (γ : GName) (p : Qp) (P : IProp GF) imodintro itrivial +theorem inv_open_fupd {E : CoPset} {N : Namespace} {P : IProp GF} (Hsub : ↑N ⊆ E) : + ⊢ cinv N γ P -∗ (▷ P ∗ Q ∗ own γ q ={E \ N}=∗ P ∗ R) -∗ + (Q ∗ own γ q) ={E}=∗ R := by + iintro #Hinv H ⟨HQ, Hown⟩ + imod acc _ _ _ _ _ Hsub $$ Hinv Hown with ⟨HP, Hown, Hclose⟩ + imod H $$ [$] with ⟨HP, HR⟩; iframe + imod Hclose $$ [HP] with - + · inext; iframe + itrivial + @[rocq_alias cinv_acc_1] theorem acc_one (E : CoPset) (N : Namespace) (γ : GName) (P : IProp GF) (Hsub : ↑N ⊆ E) : ⊢ cinv N γ P -∗ own γ (1 : Qp) ={E}=∗ diff --git a/Iris/Iris/Instances/Lib/GhostMap.lean b/Iris/Iris/Instances/Lib/GhostMap.lean index 84f47095f..71284b1da 100644 --- a/Iris/Iris/Instances/Lib/GhostMap.lean +++ b/Iris/Iris/Instances/Lib/GhostMap.lean @@ -375,6 +375,8 @@ theorem ghost_map_delete {γ} {m : H V} (k : K) (v : V) : iapply iOwn_mono $$ G exact auth_inc_of_pmap_eqv _ map_delete +-- TODO: Make these implicit + @[rocq_alias ghost_map_update] theorem ghost_map_update {γ} {m : H V} (k : K) (v : V) (w : V) : ⊢@{IProp GF} (γ ↪●MAP m) -∗ (γ ↪◯MAP[k] v) ==∗ (γ ↪●MAP insert m k w) ∗ γ ↪◯MAP[k] w := by diff --git a/Iris/Iris/Instances/Lib/Invariants.lean b/Iris/Iris/Instances/Lib/Invariants.lean index 9be9d1fbc..5ab61b6fb 100644 --- a/Iris/Iris/Instances/Lib/Invariants.lean +++ b/Iris/Iris/Instances/Lib/Invariants.lean @@ -97,6 +97,8 @@ open Iris Std LawfulSet variable {GF : BundledGFunctors} [InvGS_gen hlc GF] +-- FIXME: Use iframe + @[rocq_alias own_inv_acc] theorem own_inv_acc (E : CoPset) (N : Namespace) (P : IProp GF) (Hsub : ↑N ⊆ E) : ⊢ own_inv N P ={E, E \ ↑N}=∗ ▷ P ∗ (▷ P ={E \ ↑N, E}=∗ True) := by @@ -243,6 +245,8 @@ open Iris Std LawfulSet variable {GF : BundledGFunctors} [InvGS_gen hlc GF] +-- FIXME: Arguments E, N and P in this section should be made implicit + @[rocq_alias inv_acc] theorem inv_acc (E : CoPset) (N : Namespace) (P : IProp GF) (Hsub : ↑N ⊆ E) : ⊢ inv N P ={E, E \ ↑N}=∗ ▷ P ∗ (▷ P ={E \ ↑N, E}=∗ True) := by @@ -280,6 +284,15 @@ theorem inv_acc_timeless (E : CoPset) (N : Namespace) (P : IProp GF) [Timeless P iapply H inext; iassumption +theorem inv_open_fupd {E : CoPset} {N : Namespace} {P : IProp GF} (Hsub : ↑N ⊆ E) : + ⊢ inv N P -∗ (▷ P ∗ Q ={E \ N}=∗ P ∗ R) -∗ Q ={E}=∗ R := by + iintro #Hinv H HQ + imod inv_acc _ _ _ Hsub $$ Hinv with ⟨HP, Hclose⟩ + imod H $$ [$] with ⟨HP, HR⟩; iframe + imod Hclose $$ [HP] with - + · inext; iframe + itrivial + end Access section Modification diff --git a/Iris/Iris/ProgramLogic/EctxLanguage.lean b/Iris/Iris/ProgramLogic/EctxLanguage.lean index 4d5ac6b9b..9a53d4c3e 100644 --- a/Iris/Iris/ProgramLogic/EctxLanguage.lean +++ b/Iris/Iris/ProgramLogic/EctxLanguage.lean @@ -210,6 +210,8 @@ variable {e e' e₁ e₂ : Expr} {σ σ' σ₁ σ₂ : State} variable {K K' K₁ K₂ : Ectx} {obs obs' : List Obs} variable {eₜ eₜ : List Expr} +-- FIXME: Implicits + open EvContext in @[rocq_alias base_redex_unique] theorem base_redex_unique K K' (e e' : Expr) σ σ' (heq : fill K e = fill K' e') : diff --git a/Iris/Iris/ProgramLogic/Language.lean b/Iris/Iris/ProgramLogic/Language.lean index 84998b24e..896b146cd 100644 --- a/Iris/Iris/ProgramLogic/Language.lean +++ b/Iris/Iris/ProgramLogic/Language.lean @@ -161,6 +161,10 @@ scoped notation (name := ErasedStep) conf:40 " -·->ₜₚ " conf':41 => Languag scoped notation (name := erasedStepStar) conf:40 " -·->ₜₚ* " conf':41 => Relation.ReflTransGen Language.ErasedStep conf conf' +/-- A nonempty sequence of `Language.erasedStep`s -/ +scoped notation (name := erasedStepPlus) conf:40 " -·->ₜₚ+ " conf':41 => + Relation.TransGen Language.ErasedStep conf conf' + end Notation open Notation @@ -243,6 +247,11 @@ theorem stronglyAtomic_atomic {a} : | .StronglyAtomic => id | .WeaklyAtomic => fun ⟨h⟩ => ⟨by grind only [not_reducible_iff_irreducible, val_irreducible]⟩ +theorem prim_val_stuck (h : (↑ v, σ) --> (e', σ', eₜ)) : False := by + simpa using val_stuck h + +instance val_atomic {a : Atomicity} {v : Val} : Atomic a (Λ.ofVal v) := + ⟨fun h => by simpa using val_stuck h⟩ /-- The function `K` models an evaluation context for the language -/ @[rocq_alias LanguageCtx] diff --git a/Iris/Iris/ProgramLogic/WeakestPre.lean b/Iris/Iris/ProgramLogic/WeakestPre.lean index 30b004fc7..df405de9f 100644 --- a/Iris/Iris/ProgramLogic/WeakestPre.lean +++ b/Iris/Iris/ProgramLogic/WeakestPre.lean @@ -249,6 +249,8 @@ theorem fupd_wp_iff {s : Stuckness}{E}{e : Expr} {Φ : Val → IProp GF} : WP e @ s ; E {{ Φ }} ⊣⊢ (|={E}=> WP e @ s ; E {{ Φ }}) := ⟨fupd_mask_intro_discard LawfulSet.subset_refl, fupd_wp⟩ +-- FIXME: Implicits + @[rocq_alias wp_fupd] theorem wp_fupd (s : Stuckness) E (e : Expr) (Φ : Val → IProp GF) : WP e @ s ; E {{v, |={E}=> Φ v }} ⊢ WP e @ s ; E {{ Φ }} := by @@ -388,6 +390,8 @@ theorem wp_step_fupdN_strong {s : Stuckness} {E1 E2 : CoPset} {e : Expr} {P : IP imod interp $$ Hσ₁ with %h grind only +-- FIXME: Combine wp_bind and wp_bind_iff into a single bi-entailment + @[rocq_alias wp_bind] theorem wp_bind (K : Expr → Expr) [κ : Language.Context K] {s : Stuckness} {E : CoPset} {e : Expr} {Φ : Val → IProp GF} : diff --git a/Iris/Iris/Std/FromMathlib.lean b/Iris/Iris/Std/FromMathlib.lean index 8ba999c0c..13c65ef28 100644 --- a/Iris/Iris/Std/FromMathlib.lean +++ b/Iris/Iris/Std/FromMathlib.lean @@ -81,8 +81,55 @@ theorem head_induction_on {motive : ∀ a : α, ReflTransGen r a b → Prop} {a theorem cases_head (h : ReflTransGen r a b) : a = b ∨ ∃ c, r a c ∧ ReflTransGen r c b := by induction h using ReflTransGen.head_induction_on <;> grind +theorem trans (hab : ReflTransGen r a b) (hbc : ReflTransGen r b c) : ReflTransGen r a c := by + induction hbc with + | refl => exact hab + | tail _ hcd ih => exact ih.tail hcd + +/-- NB. Copied from Mathlib -/ +theorem single (hab : r a b) : ReflTransGen r a b := + refl.tail hab + end Relation.ReflTransGen +/-! ### Lemmas about `Relation.TransGen` (defined in Lean core, `Init.Core`). + +The transitive closure itself is in `_root_.Relation.TransGen`; we add a few +helper lemmas here under `FromMathlib.Relation.TransGen` (mirroring Mathlib's +names without colliding when Mathlib is also imported), bridging to our local +`FromMathlib.Relation.ReflTransGen`. -/ + +namespace Relation.TransGen + +/-- NB. Copied from Mathlib -/ +theorem to_reflTransGen {α} {r : α → α → Prop} {a b} + (h : _root_.Relation.TransGen r a b) : Relation.ReflTransGen r a b := by + induction h with + | single h => exact Relation.ReflTransGen.single h + | tail _ bc ab => exact Relation.ReflTransGen.tail ab bc + +/-- NB. Copied from Mathlib -/ +theorem trans_left {α} {r : α → α → Prop} {a b c} + (hab : _root_.Relation.TransGen r a b) (hbc : Relation.ReflTransGen r b c) : + _root_.Relation.TransGen r a c := by + induction hbc with + | refl => exact hab + | tail _ hcd hac => exact hac.tail hcd + +/-- NB. Copied from Mathlib -/ +theorem head' {α} {r : α → α → Prop} {a b c} + (hab : r a b) (hbc : Relation.ReflTransGen r b c) : + _root_.Relation.TransGen r a c := + trans_left (.single hab) hbc + +/-- NB. Copied from Mathlib -/ +theorem head {α} {r : α → α → Prop} {a b c} + (hab : r a b) (hbc : _root_.Relation.TransGen r b c) : + _root_.Relation.TransGen r a c := + head' hab (to_reflTransGen hbc) + +end Relation.TransGen + namespace List @[grind .] diff --git a/Iris/Iris/Std/PartialMap.lean b/Iris/Iris/Std/PartialMap.lean index 0dc2477f5..3d83baae0 100644 --- a/Iris/Iris/Std/PartialMap.lean +++ b/Iris/Iris/Std/PartialMap.lean @@ -1183,6 +1183,38 @@ theorem toList_dom_set_perm [LawfulFiniteSet S K] (m : M V) : exact ⟨(x, v), toList_get.mpr hv, rfl⟩ · grind [toList_get] +/-! ### `map_seq` -/ + +variable {M' : Type _ → Type _} [LawfulFiniteMap M' Nat] + +@[simp] theorem map_seq_nil {V : Type _} {start : Nat} : + map_seq (M := M') start ([] : List V) = ∅ := by + rw [map_seq, List.mapIdx_nil]; rfl + +theorem map_seq_cons {V : Type _} {start : Nat} {v : V} {l : List V} : + map_seq (M := M') start (v :: l) = insert (map_seq (start + 1) l) start v := by + have hfun : (fun i (x : V) => (start + (i + 1), x)) = (fun i x => (start + 1 + i, x)) := by + funext i x; congr 1; omega + show ofList ((v :: l).mapIdx fun i x => (start + i, x)) = _ + rw [List.mapIdx_cons] + simp only [Nat.add_zero, hfun] + exact ofList_cons + +theorem get?_map_seq {V : Type _} {start k : Nat} {l : List V} : + get? (map_seq (M := M') start l) k = if start ≤ k then l[k - start]? else none := by + induction l generalizing start with + | nil => rw [map_seq_nil]; simp only [List.getElem?_nil, ite_self]; exact get?_empty _ + | cons v l ih => + rw [map_seq_cons] + by_cases hk : k = start + · subst hk; rw [get?_insert_eq rfl, if_pos (Nat.le_refl _)]; simp + · rw [get?_insert_ne (by omega : start ≠ k), ih] + rcases Nat.lt_or_ge k start with h | h + · rw [if_neg (by omega), if_neg (by omega)] + · rw [if_pos h, if_pos (by omega : start + 1 ≤ k), List.getElem?_cons, + if_neg (by omega : k - start ≠ 0)] + congr 1 <;> omega + end LawfulFiniteMap end Iris.Std From 08c15ac7dcd930119eb68dba101d0693206e6dc4 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Mon, 22 Jun 2026 16:14:30 -0700 Subject: [PATCH 06/33] fix build --- Iris/Iris/HeapLang/Instances.lean | 152 ------------------------------ 1 file changed, 152 deletions(-) diff --git a/Iris/Iris/HeapLang/Instances.lean b/Iris/Iris/HeapLang/Instances.lean index 6f3bf4e2e..106d0dc85 100644 --- a/Iris/Iris/HeapLang/Instances.lean +++ b/Iris/Iris/HeapLang/Instances.lean @@ -357,156 +357,4 @@ instance instAtomicResolve {s} {e : Exp} {vp vt : Val} [hatom : Atomic .Strongly · exact val_irreducible rfl _ · rfl -instance instAtomicFork {s} {e : Exp} : Atomic s hl(fork(&e)) where - atomic {σ obs e' σ' eₜ} Hstep := by - cases baseStep_of_primStep Hstep (by solve_subredex_values) - cases s - · exact val_irreducible rfl _ - · rfl - -instance instAtomicNewProph {s} : Atomic s (State := State) Exp.newProph where - atomic {σ obs e' σ' eₜ} Hstep := by - cases baseStep_of_primStep Hstep (by solve_subredex_values) - cases s - · exact val_irreducible rfl _ - · rfl - -instance instAtomicCmpXChg {s} {v1 v2 v3 : Val} : Atomic s hl(cmpXchg(&v1, &v2, &v3)) where - atomic {σ obs e' σ' eₜ} Hstep := by - cases baseStep_of_primStep Hstep (by solve_subredex_values) - cases s - · exact val_irreducible rfl _ - · rfl - -theorem primStep_val_baseStep {e : Exp} {σ : State} {obs : List Observation} - {v : Val} {σ' : State} {efs : List Exp} - (h : PrimStep.primStep (e, σ) obs (Exp.val v, σ', efs)) : - BaseStep e σ obs (Exp.val v) σ' efs := by - generalize hg : (Exp.val v : Exp) = g at h - obtain ⟨Hbase⟩ := h - rename_i a b K - obtain rfl : K = [] := fill_isSome_empty (e := b) (by simp [← hg]) - simp only [EvContext.fill, List.foldl_nil] at hg ⊢ - subst hg - exact Hbase - -theorem base_step_to_val_always_to_val - {e₁ : Exp} {σ₁ₐ : State} {κsₐ : List Observation} {v₂ₐ : Val} {σ₂ₐ : State} - {efsₐ : List Exp} {σ₁ᵦ : State} {κsᵦ : List Observation} - {e₂ᵦ : Exp} {σ₂ᵦ : State} {efsᵦ : List Exp} - (h₁ : BaseStep e₁ σ₁ₐ κsₐ (Exp.val v₂ₐ) σ₂ₐ efsₐ) - (h₂ : BaseStep e₁ σ₁ᵦ κsᵦ e₂ᵦ σ₂ᵦ efsᵦ) : - (toVal e₂ᵦ).isSome := by - cases h₁ <;> cases h₂ <;> simp_all [] <;> grind - -theorem prim_step_to_val_always_to_val - {e₁ : Exp} {σ₁ₐ : State} {κsₐ : List Observation} {v₂ₐ : Val} {σ₂ₐ : State} - {efsₐ : List Exp} {σ₁ᵦ : State} {κsᵦ : List Observation} - {e₂ᵦ : Exp} {σ₂ᵦ : State} {efsᵦ : List Exp} - (h₁ : PrimStep.primStep (e₁, σ₁ₐ) κsₐ (Exp.val v₂ₐ, σ₂ₐ, efsₐ)) - (h₂ : PrimStep.primStep (e₁, σ₁ᵦ) κsᵦ (e₂ᵦ, σ₂ᵦ, efsᵦ)) : - (toVal e₂ᵦ).isSome := by - refine base_step_to_val_always_to_val (primStep_val_baseStep h₁) (baseStep_of_primStep h₂ ?_) - intro K e' heq hnv - rcases base_ctx_step_val (K := K) (e := e') (heq ▸primStep_val_baseStep h₁) with h | h - · rw [hnv] at h; simp at h - · exact h - -theorem base_step_to_val_atomic {e₁ : Exp} {σ₁ₐ : State} {κsₐ : List Observation} {v₂ₐ : Val} - {σ₂ₐ : State} {efsₐ : List Exp} (a : Atomicity) (h : BaseStep e₁ σ₁ₐ κsₐ (Exp.val v₂ₐ) σ₂ₐ efsₐ) : - Atomic (State := State) a e₁ := - stronglyAtomic_atomic ⟨prim_step_to_val_always_to_val (primStep_of_baseStep h)⟩ - -/- TODO: Coq has a `Hint Extern (Atomic _ _) => by eapply base_step_to_val_atomic`. - No Lean equivalent — `BaseStep` is not a typeclass, so we can't make this - a real instance. At use sites, manually apply `base_step_to_val_atomic`. -/ - -theorem base_step_more_proph_ids {e : Exp} {σ : State} {κs : List Observation} - {e' : Exp} {σ' : State} {efs : List Exp} (h : BaseStep e σ κs e' σ' efs) : - σ.usedProphId ⊆ σ'.usedProphId := by - induction h with - | newProphS _ p _ => intro x hx; rw [Std.ExtTreeSet.mem_insert]; right; exact hx - | resolveS _ _ _ _ _ _ _ _ _ _ IH => exact IH - | cmpXchgS _ _ _ _ _ b _ _ _ => cases b <;> intro _ hx <;> exact hx - | _ => intro _ hx; exact hx - -theorem step_resolve {e : Exp} {vp vt : Val} {σ₁ σ₂ : State} {κ : List Observation} {e₂ : Exp} {efs : List Exp} - [hatom : Atomic .StronglyAtomic e] - (hprim : PrimStep.primStep (Exp.resolve e (.val vp) (.val vt), σ₁) κ (e₂, σ₂, efs)) : - BaseStep (Exp.resolve e (.val vp) (.val vt)) σ₁ κ e₂ σ₂ efs := by - generalize hsrc : Exp.resolve e (.val vp) (.val vt) = src at hprim - obtain ⟨Hbase⟩ := hprim - rename_i e₁' e₂' K - cases K using List.reverseRec with - | nil => simp only [fill_nil] at hsrc ⊢; subst hsrc; exact Hbase - | append_singleton K' Ki ih => - clear ih - exfalso - cases Ki <;> - simp only [fillItem, ECtxItem.fill, fill_append, fill_cons, fill_nil, - Exp.resolve.injEq, reduceCtorEq] at hsrc - case resolveL K_inner _ _ => - suffices hp : PrimStep.primStep (e, σ₁) κ (fillItem K_inner (fill K' e₂'), σ₂, efs) by - exact absurd (hatom.atomic hp) (by simp [fillItem_expToVal_none]) - rw [hsrc.1] - exact fill_primStep [K_inner] (fill_primStep K' (primStep_of_baseStep Hbase)) - case resolveM => exact baseStep_fill_eq_val_absurd Hbase hsrc.2.1 - case resolveR => exact baseStep_fill_eq_val_absurd Hbase hsrc.2.2 - -theorem prim_step_resolve_of_inner {e : Exp} {σ σ_e : State} {κ_e : List Observation} - {v_e w : Val} {efs_e : List Exp} {p : ProphId} (Hbase_e : BaseStep e σ κ_e (.val v_e) σ_e efs_e) - (hp_contains : σ.usedProphId.contains p) : - PrimStep.primStep (Exp.resolve e (.val (.lit (.prophecy p))) (.val w), σ) - (κ_e ++ [(p, (v_e, w))]) (Exp.val v_e, σ_e, efs_e) := - primStep_of_baseStep (BaseStep.resolveS p v_e e σ w σ_e κ_e efs_e Hbase_e hp_contains) - -theorem step_resolve_decompose {e : Exp} {p : ProphId} {w : Val} {σ₁ σ₂ : State} {κ : List Observation} - {e₂ : Exp} {efs : List Exp} [hatom : Atomic .StronglyAtomic e] - (hstep : PrimStep.primStep (Exp.resolve e (.val (.lit (.prophecy p))) (.val w), σ₁) κ (e₂, σ₂, efs)) : - ∃ (κ_inner : List Observation) (v_inner : Val), - κ = κ_inner ++ [(p, (v_inner, w))] ∧ - e₂ = Exp.val v_inner ∧ - BaseStep e σ₁ κ_inner (.val v_inner) σ₂ efs := - match step_resolve hstep with - | .resolveS _ v_n _ _ _ _ κs_n _ hb _ => ⟨κs_n, v_n, rfl, rfl, hb⟩ - -theorem resolve_reducible {e : Exp} {σ : State} {p : ProphId} {v : Val} - [hatom : Atomic .StronglyAtomic e] (hred : BaseStep.Reducible (e, σ)) - (hin : σ.usedProphId.contains p) : - BaseStep.Reducible (Exp.resolve e (.val (.lit (.prophecy p))) (.val v), σ) := by - obtain ⟨κ, e', σ', efs, hstep⟩ := hred - obtain ⟨w', rfl⟩ : ∃ w', e' = Exp.val w' := by - have hval : (toVal e').isSome := hatom.atomic (primStep_of_baseStep hstep) - cases e' with | val w' => exact ⟨w', rfl⟩ | _ => simp [toVal] at hval - refine ⟨κ ++ [(p, (w', v))], Exp.val w', σ', efs, ?_⟩ - exact .resolveS p w' e σ v σ' κ efs hstep hin - -theorem prim_step_reducible_resolve {e : Exp} {σ : State} {p : ProphId} {w : Val} - [hatom : Atomic .StronglyAtomic e] (hp_contains : σ.usedProphId.contains p) - (hred : PrimStep.Reducible (e, σ)) : - PrimStep.Reducible (Exp.resolve e (.val (.lit (.prophecy p))) (.val w), σ) := by - obtain ⟨κ, e', σ', efs, hprim⟩ := hred - obtain ⟨v, rfl⟩ : ∃ v, e' = Exp.val v := by - match e', (hatom.atomic hprim) with | .val v, _ => exact ⟨v, rfl⟩ - exact primStep_reducible_of_baseStep_reducible - (resolve_reducible ⟨κ, _, σ', efs, primStep_val_baseStep hprim⟩ hp_contains) - -theorem prim_step_more_proph_ids {e : Exp} {σ : State} {κs : List Observation} {e' : Exp} - {σ' : State} {efs : List Exp} (h : PrimStep.primStep (e, σ) κs (e', σ', efs)) : - σ.usedProphId ⊆ σ'.usedProphId := by - obtain ⟨hbase⟩ := h - exact base_step_more_proph_ids hbase - -/-- `resolve e &vp &vt` is atomic whenever its subexpression `e` is strongly -atomic: any step of the whole expression is a `resolveS` base step, which runs -`e` to a value and produces a value. Mirrors `resolve_atomic` in Rocq. -/ -instance instAtomicResolve {s} {e : Exp} {vp vt : Val} [hatom : Atomic .StronglyAtomic e] : - Atomic s (Exp.resolve e (.val vp) (.val vt)) where - atomic {σ obs e' σ' eₜ} Hstep := by - cases step_resolve Hstep with - | resolveS _ v _ _ _ _ _ _ _ _ => - cases s - · exact val_irreducible rfl _ - · rfl - end Iris.HeapLang From abc786d0875f6db5f0be42a40fa4cdef0dd584dc Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Mon, 22 Jun 2026 16:18:03 -0700 Subject: [PATCH 07/33] chore: tidy frac --- Iris/Iris/Algebra/Frac.lean | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/Iris/Iris/Algebra/Frac.lean b/Iris/Iris/Algebra/Frac.lean index bb53d234b..0ea063071 100644 --- a/Iris/Iris/Algebra/Frac.lean +++ b/Iris/Iris/Algebra/Frac.lean @@ -19,17 +19,14 @@ This version follows Iris Rocq in fixing the underlying type of fractions to be @[expose] public section -/-! ## Ordered-field lemmas for `Rat` - -This environment has no Mathlib, so `Rat` is missing the ordered-field API (and the -`positivity`/`field_simp` tactics) needed to reason about division. These few lemmas fill the -gap that the `Qp` API below relies on. -/ namespace Rat -protected theorem div_pos {a b : Rat} (ha : 0 < a) (hb : 0 < b) : 0 < a / b := by +/-- ## Helper lemmas for Rat -/ + +theorem div_pos {a b : Rat} (ha : 0 < a) (hb : 0 < b) : 0 < a / b := by rw [Rat.div_def]; exact Rat.mul_pos ha (Rat.inv_pos.mpr hb) -protected theorem mul_div_cancel_left {a b : Rat} (ha : a ≠ 0) : a * (b / a) = b := by +theorem mul_div_cancel_left {a b : Rat} (ha : a ≠ 0) : a * (b / a) = b := by rw [Rat.mul_comm, Rat.div_mul_cancel ha] end Rat @@ -57,13 +54,11 @@ def Qp.half (q : Qp) : Qp where let ⟨v, P⟩ := q grind -/-- Division of fractions. -/ def Qp.div (x y : Qp) : Qp := ⟨x.val / y.val, Rat.div_pos x.2 y.2⟩ instance instHDivQpQpQp : HDiv Qp Qp Qp where hDiv := Qp.div -/-- `q` divided into `n > 0` equal positive parts. -/ def Qp.divide_even (q : Qp) (n : Nat) (hn : 0 < n) : Qp := ⟨q.val / n, Rat.div_pos q.2 (by exact_mod_cast hn)⟩ @@ -111,14 +106,9 @@ instance instCMRAQp : CMRA Qp where @[simp] theorem Qp.ext_iff {x y : Qp} : x = y ↔ x.val = y.val := Subtype.ext_iff @[simp] theorem Qp.dist_iff {n} {x y : Qp} : x ≡{n}≡ y ↔ x.val = y.val := Subtype.ext_iff @[simp] theorem Qp.equiv_iff {x y : Qp} : x ≡ y ↔ x.val = y.val := Subtype.ext_iff - -/-- The whole fraction `1` is valid. -/ @[simp, rocq_alias frac_valid_1] theorem Qp.valid_one : ✓ (1 : Qp) := by grind - -/-- Two halves make a whole. -/ @[simp, grind =] theorem Qp.half_add_half (q : Qp) : q.half + q.half = q := Subtype.ext (by grind) -/-- `a < b` iff `b` is `a` plus some positive remainder. -/ theorem Qp.lt_iff_exists_add {a b : Qp} : a < b ↔ ∃ c : Qp, a + c = b := by refine ⟨fun h => ⟨⟨b.val - a.val, by have := Qp.lt_iff.mp h; grind⟩, Subtype.ext (by grind)⟩, ?_⟩ rintro ⟨c, rfl⟩; have := c.2; grind From fcd60371e22828d50afb3e7c0d8582018c01d825 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Mon, 22 Jun 2026 16:25:43 -0700 Subject: [PATCH 08/33] chore: cleanup bigsepmap --- Iris/Iris/BI/BigOp/BigSepMap.lean | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/Iris/Iris/BI/BigOp/BigSepMap.lean b/Iris/Iris/BI/BigOp/BigSepMap.lean index faca2311a..5f644aa3d 100644 --- a/Iris/Iris/BI/BigOp/BigSepMap.lean +++ b/Iris/Iris/BI/BigOp/BigSepMap.lean @@ -575,15 +575,15 @@ theorem bigSepM_map_seq {M' : Type _ → Type _} [LawfulFiniteMap M' Nat] {V : T ([∗map] k ↦ v ∈ FiniteMap.map_seq (M := M') start l, Φ k v) ⊣⊢ ([∗list] i ↦ v ∈ l, Φ (start + i) v) := by induction l generalizing start with - | nil => rw [LawfulFiniteMap.map_seq_nil]; simp + | nil => simp [LawfulFiniteMap.map_seq_nil] | cons v l ih => - have hfun : (fun i (x : V) => Φ (start + 1 + i) x) = (fun i x => Φ (start + (i + 1)) x) := by - funext i x; congr 1; omega - have ih1 := ih (start := start + 1) - rw [hfun] at ih1 + have Hget : get? (FiniteMap.map_seq (M := M') (start + 1) l) start = none := by + rw [LawfulFiniteMap.get?_map_seq, if_neg (by omega)] rw [LawfulFiniteMap.map_seq_cons] - exact (bigSepM_insert (by rw [LawfulFiniteMap.get?_map_seq, if_neg (by omega)])).trans - (sep_congr .rfl ih1) + refine (bigSepM_insert Hget).trans (sep_congr .rfl ?_) + refine .trans (ih (start := start + 1)) ?_ + refine .of_eq ?_ + grind /-! ## Map–Set Interaction -/ From ea98f88143a32947a739a961ce5da846ec44f884 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Mon, 22 Jun 2026 16:44:28 -0700 Subject: [PATCH 09/33] chore: cleanup Fractional --- Iris/Iris/BI/Lib/Fractional.lean | 68 +++++++++++++++----------------- 1 file changed, 32 insertions(+), 36 deletions(-) diff --git a/Iris/Iris/BI/Lib/Fractional.lean b/Iris/Iris/BI/Lib/Fractional.lean index fe9666c93..87f538ad4 100644 --- a/Iris/Iris/BI/Lib/Fractional.lean +++ b/Iris/Iris/BI/Lib/Fractional.lean @@ -26,66 +26,64 @@ class AsFractional {PROP : Type u} [BI PROP] (P : PROP) (Φ : Qp → PROP) (q : section Lemmas variable {PROP : Type _} [BI PROP] {P P1 P2 : PROP} {Φ : Qp → PROP} {q q1 q2 : Qp} -/-- Any `Φ q` of a fractional `Φ` is `AsFractional`. -/ +/-- ## AsFractional manipulation lemmas + +The Rocq versions are stated using fewer AsFractional instances, and have postconditions +stated in terms of `Φ`. This version adds more typeclass instances, but has postconditons that +unify against any `IProp`. -/ + @[rocq_alias fractional_as_fractional] instance (priority := 100) fractional_as_fractional [h : Fractional Φ] (q : Qp) : AsFractional (Φ q) Φ q where as_fractional := .rfl as_fractional_fractional := h -/-- Split a fraction `q1 + q2` into the separating conjunction of its parts. -/ @[rocq_alias fractional_split] theorem fractional_split [hP : AsFractional P Φ (q1 + q2)] [hP1 : AsFractional P1 Φ q1] [hP2 : AsFractional P2 Φ q2] : P ⊣⊢ P1 ∗ P2 := - have := hP.as_fractional_fractional - hP.as_fractional.trans <| (Fractional.fractional q1 q2).trans <| - sep_congr hP1.as_fractional.symm hP2.as_fractional.symm + hP.as_fractional.trans <| + (hP.as_fractional_fractional.fractional q1 q2).trans <| + sep_congr hP1.as_fractional.symm hP2.as_fractional.symm -/-- Halve a fraction into two equal pieces. -/ @[rocq_alias fractional_half] theorem fractional_half [hP : AsFractional P Φ q] [hP12 : AsFractional P1 Φ q.half] : P ⊣⊢ P1 ∗ P1 := - have := hP.as_fractional_fractional - hP.as_fractional.trans <| (Qp.half_add_half q ▸ Fractional.fractional q.half q.half).trans <| - sep_congr hP12.as_fractional.symm hP12.as_fractional.symm + hP.as_fractional.trans <| + (Qp.half_add_half q ▸ hP.as_fractional_fractional.fractional q.half q.half).trans <| + sep_congr hP12.as_fractional.symm hP12.as_fractional.symm -/-- Merge two fractions back into their sum. -/ @[rocq_alias fractional_merge] -theorem fractional_merge [Fractional Φ] - [hP1 : AsFractional P1 Φ q1] [hP2 : AsFractional P2 Φ q2] : P1 ∗ P2 ⊢ Φ (q1 + q2) := +theorem fractional_merge [Fractional Φ] [hP1 : AsFractional P1 Φ q1] [hP2 : AsFractional P2 Φ q2] : + P1 ∗ P2 ⊢ Φ (q1 + q2) := (sep_mono hP1.as_fractional.1 hP2.as_fractional.1).trans (Fractional.fractional q1 q2).2 set_option synthInstance.checkSynthOrder false in @[rocq_alias from_sep_fractional] instance (priority := default - 10) fromSepFractional [hP : AsFractional P Φ (q1 + q2)] : FromSep P (Φ q1) (Φ q2) where - from_sep := - have := hP.as_fractional_fractional - (Fractional.fractional q1 q2).2.trans hP.as_fractional.2 + from_sep := (hP.as_fractional_fractional.fractional q1 q2).2.trans hP.as_fractional.2 set_option synthInstance.checkSynthOrder false in @[rocq_alias into_sep_fractional] instance (priority := default - 10) intoSepFractional [hP : AsFractional P Φ (q1 + q2)] : IntoSep P (Φ q1) (Φ q2) where - into_sep := - have := hP.as_fractional_fractional - hP.as_fractional.1.trans (Fractional.fractional q1 q2).1 + into_sep := hP.as_fractional.1.trans (hP.as_fractional_fractional.fractional q1 q2).1 set_option synthInstance.checkSynthOrder false in @[rocq_alias from_sep_fractional_half] instance (priority := default - 10) fromSepFractionalHalf [hP : AsFractional P Φ q] : FromSep P (Φ q.half) (Φ q.half) where from_sep := - have := hP.as_fractional_fractional - (Qp.half_add_half q ▸ Fractional.fractional q.half q.half).2.trans hP.as_fractional.2 + (Qp.half_add_half q ▸ hP.as_fractional_fractional.fractional q.half q.half).2.trans + hP.as_fractional.2 set_option synthInstance.checkSynthOrder false in @[rocq_alias into_sep_fractional_half] instance (priority := default - 10) intoSepFractionalHalf [hP : AsFractional P Φ q] : IntoSep P (Φ q.half) (Φ q.half) where into_sep := - have := hP.as_fractional_fractional - hP.as_fractional.1.trans (Qp.half_add_half q ▸ Fractional.fractional q.half q.half).1 + hP.as_fractional.1.trans + (Qp.half_add_half q ▸ hP.as_fractional_fractional.fractional q.half q.half).1 end Lemmas @@ -93,7 +91,6 @@ section Divide variable {PROP : Type _} [BI PROP] open BI.BigSepL -/-- Whenever `q = (k+1) * r`, the fraction `Φ q` splits into `k+1` copies of `Φ r`. -/ theorem fractional_bigSepL_replicate {Φ : Qp → PROP} [Fractional Φ] (r : Qp) : ∀ (k : Nat) (q : Qp), q.val = ((k : Rat) + 1) * r.val → Φ q ⊢ [∗list] _x ∈ List.replicate (k + 1) r, Φ r := by @@ -101,26 +98,25 @@ theorem fractional_bigSepL_replicate {Φ : Qp → PROP} [Fractional Φ] (r : Qp) induction k with | zero => intro q hq - rw [show q = r from Subtype.ext (by grind)] - exact (bigSepL_singleton (Φ := fun _ _ => Φ r)).2 + refine .trans ?_ (bigSepL_singleton (Φ := fun _ _ => Φ r)).2 + exact .of_eq (by grind) | succ k ih => - intro q hq - have hval : q.val - r.val = ((k : Rat) + 1) * r.val := by grind - have hpos : (0 : Rat) < q.val - r.val := hval ▸ Rat.mul_pos (by grind) r.2 - have hsum : r + (⟨q.val - r.val, hpos⟩ : Qp) = q := Subtype.ext (by grind) + rintro ⟨q, hq⟩ _ + obtain ⟨r, hr⟩ := r + have hval : q - r = ((k : Rat) + 1) * r := by grind + have hpos : (0 : Rat) < q - r := hval ▸ Rat.mul_pos (by grind) hr + have hsum : ⟨r, hr⟩ + (⟨q - r, hpos⟩ : Qp) = ⟨q, hq⟩ := Subtype.ext (by grind) rw [← hsum, List.replicate_succ] - exact ((Fractional.fractional r _).1.trans (sep_mono_right (ih _ hval))).trans - (bigSepL_cons (Φ := fun _ _ => Φ r)).2 + exact ((Fractional.fractional ⟨r, hr⟩ _).1.trans (sep_mono_right (ih _ hval))).trans + (bigSepL_cons (Φ := fun _ _ => Φ _)).2 -/-- Splitting `Φ q` into `n+1` equal pieces, each owning the fraction `q / (n+1)`. -/ theorem fractional_divide_equal {Φ : Qp → PROP} [Fractional Φ] (q : Qp) (n : Nat) : Φ q ⊢ [∗list] _x ∈ List.replicate (n + 1) (q.divide_even (n + 1) (Nat.succ_pos n)), Φ (q.divide_even (n + 1) (Nat.succ_pos n)) := by refine fractional_bigSepL_replicate _ n q ?_ - have hne : ((n : Rat) + 1) ≠ 0 := by - have : (0 : Rat) ≤ (n : Rat) := by exact_mod_cast Nat.zero_le n - grind have hcast : ((n + 1 : Nat) : Rat) = (n : Rat) + 1 := by grind - rw [Qp.val_divide_even, hcast, Rat.mul_div_cancel_left hne] + rw [Qp.val_divide_even, hcast, Rat.mul_div_cancel_left _] + have : (0 : Rat) ≤ (n : Rat) := by exact_mod_cast Nat.zero_le n + grind end Divide From ba317fbdc5c76b20457bbddb121f2fce257bed6a Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Mon, 22 Jun 2026 16:55:26 -0700 Subject: [PATCH 10/33] chore: cleanup PartialMap --- Iris/Iris/Std/PartialMap.lean | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/Iris/Iris/Std/PartialMap.lean b/Iris/Iris/Std/PartialMap.lean index 3d83baae0..034d363fb 100644 --- a/Iris/Iris/Std/PartialMap.lean +++ b/Iris/Iris/Std/PartialMap.lean @@ -1193,27 +1193,28 @@ variable {M' : Type _ → Type _} [LawfulFiniteMap M' Nat] theorem map_seq_cons {V : Type _} {start : Nat} {v : V} {l : List V} : map_seq (M := M') start (v :: l) = insert (map_seq (start + 1) l) start v := by - have hfun : (fun i (x : V) => (start + (i + 1), x)) = (fun i x => (start + 1 + i, x)) := by - funext i x; congr 1; omega show ofList ((v :: l).mapIdx fun i x => (start + i, x)) = _ rw [List.mapIdx_cons] - simp only [Nat.add_zero, hfun] + simp only [Nat.add_zero] + rw [ofList_cons] + conv => + enter [1, 1, 1, 1, i, x, 1] + rw [Nat.add_comm i, ← Nat.add_assoc] exact ofList_cons theorem get?_map_seq {V : Type _} {start k : Nat} {l : List V} : get? (map_seq (M := M') start l) k = if start ≤ k then l[k - start]? else none := by induction l generalizing start with - | nil => rw [map_seq_nil]; simp only [List.getElem?_nil, ite_self]; exact get?_empty _ + | nil => + rw [map_seq_nil] + simpa only [List.getElem?_nil, ite_self] using get?_empty _ | cons v l ih => rw [map_seq_cons] by_cases hk : k = start - · subst hk; rw [get?_insert_eq rfl, if_pos (Nat.le_refl _)]; simp + · subst hk + simp [get?_insert_eq rfl] · rw [get?_insert_ne (by omega : start ≠ k), ih] - rcases Nat.lt_or_ge k start with h | h - · rw [if_neg (by omega), if_neg (by omega)] - · rw [if_pos h, if_pos (by omega : start + 1 ≤ k), List.getElem?_cons, - if_neg (by omega : k - start ≠ 0)] - congr 1 <;> omega + grind end LawfulFiniteMap From de423d268349ba9d03d7953cce93dd59b8bdaf55 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Thu, 18 Jun 2026 16:12:04 -0400 Subject: [PATCH 11/33] upload changes from completeness --- Iris/Iris/HeapLang/PrimitiveLaws.lean | 432 ++++++++++++++++++++++++-- Iris/Iris/HeapLang/Syntax.lean | 4 + 2 files changed, 404 insertions(+), 32 deletions(-) diff --git a/Iris/Iris/HeapLang/PrimitiveLaws.lean b/Iris/Iris/HeapLang/PrimitiveLaws.lean index 0d4c736ed..49fc26d1a 100644 --- a/Iris/Iris/HeapLang/PrimitiveLaws.lean +++ b/Iris/Iris/HeapLang/PrimitiveLaws.lean @@ -8,36 +8,78 @@ public import Iris.ProgramLogic.WeakestPre public import Iris.ProgramLogic.Adequacy public import Iris.ProgramLogic.Lifting public import Iris.BI.Lib.GenHeap +public import Iris.BI.Lib.ProphMap +public import Iris.Std.GenSetsInstances public import Iris.ProofMode public import Std.Data.ExtTreeMap @[expose] public section namespace Iris.HeapLang -open Iris ProgramLogic Language.Notation Std +open Iris ProgramLogic Language.Notation Std FromMathlib section HeapLangGS abbrev HeapF := fun V => Std.ExtTreeMap Loc V compare +/-- The finite-map type used by the heap_lang prophecy ghost state: a map from +`ProphId` to the prophecy's outstanding resolution list. Mirrors the Rocq +`gmap proph_id (list val)` used in `proph_map`. -/ +abbrev ProphMapF := fun V => Std.ExtTreeMap ProphId V compare + class HeapLangGpreS (hlc : outParam HasLC) (GF : BundledGFunctors) extends InvGpreS GF where heap_pre : genHeapPreS Loc (Option Val) GF HeapF + proph_pre : prophMapPreS ProphId (Val × Val) GF ProphMapF attribute [reducible, instance] HeapLangGpreS.heap_pre +attribute [reducible, instance] HeapLangGpreS.proph_pre class HeapLangGS (hlc : outParam HasLC) (GF : BundledGFunctors) extends InvGS_gen hlc GF where heap : genHeapGS Loc (Option Val) GF HeapF + proph : prophMapGS ProphId (Val × Val) GF ProphMapF attribute [reducible, instance] HeapLangGS.heap +attribute [reducible, instance] HeapLangGS.proph instance HeapLangState [HeapLangGS hlc GF] : StateInterp State Observation GF where - stateInterp σ _ _ _ := genHeapInterp (GF := GF) (H := HeapF) σ.heap + stateInterp σ _ κs _ := iprop( + genHeapInterp (GF := GF) (H := HeapF) σ.heap ∗ + prophMapInterp (GF := GF) (H := ProphMapF) κs σ.usedProphId) + +/-- The state interpretation as a separating conjunction of the heap interp and +the prophecy-map interp. Used to destruct `Hσ` into its two conjuncts after +`wp_lift_atomic_step`. -/ +theorem stateInterp_split [HeapLangGS hlc GF] (σ : State) (ns : Nat) + (κs : List Observation) (nt : Nat) : + stateInterp (GF := GF) σ ns κs nt ⊣⊢ + iprop(genHeapInterp (GF := GF) (H := HeapF) σ.heap ∗ + prophMapInterp (GF := GF) (H := ProphMapF) κs σ.usedProphId) := + Iris.BI.BIBase.BiEntails.rfl + +/-- Normalize a `[] ++ κs` argument to `κs`. Used to rephrase `prophMapInterp` +hypotheses introduced before a step whose observations are `[]` get substituted +in by `cases`. The two sides are definitionally equal. -/ +theorem prophMapInterp_nil_append [HeapLangGS hlc GF] (κs : List Observation) + (ps : Std.ExtTreeSet ProphId) : + iprop(prophMapInterp (GF := GF) (H := ProphMapF) ([] ++ κs) ps) ⊣⊢ + iprop(prophMapInterp (GF := GF) (H := ProphMapF) κs ps) := + Iris.BI.BIBase.BiEntails.rfl instance HeapLang [HeapLangGS hlc GF] : IrisGS_gen hlc Exp GF where numLatersPerStep n := 0 forkPost v := iprop(True) stateInterp_mono σ ns obs nt := by iintro $ +/-- The state interpretation is closed under bumping the step counter. In +iris-lean this is trivial, since the heap_lang `stateInterp` ignores the step +index. Mirrors `state_interp_step` in `case_studies/heaplang/fixes.v`. -/ +theorem state_interp_step [HeapLangGS hlc GF] (σ : State) (ns : Nat) + (κs : List Observation) (nt : Nat) : + stateInterp (GF := GF) σ ns κs nt ⊢ |==> stateInterp (GF := GF) σ (ns + 1) κs nt := by + iintro H + imodintro + iexact H + def HeapLangS : BundledGFunctors | 0 => ⟨InvMapF, by infer_instance⟩ | 1 => ⟨constOF (DisjointLeibnizSet CoPset), by infer_instance⟩ @@ -46,6 +88,7 @@ def HeapLangS : BundledGFunctors | 4 => ⟨constOF (HeapView Loc (Agree (LeibnizO (Option Val))) HeapF), by infer_instance⟩ | 5 => ⟨constOF (HeapView Loc (Agree (LeibnizO GName)) HeapF), by infer_instance⟩ | 6 => ⟨constOF MetaUR, by infer_instance⟩ + | 7 => ⟨constOF (HeapView ProphId (Agree (LeibnizO (List (Val × Val)))) ProphMapF), by infer_instance⟩ | _ => ⟨constOF Unit, by infer_instance⟩ instance instHeapLangGS_HeapLangS : HeapLangGpreS HasLC.hasLC HeapLangS where @@ -64,6 +107,10 @@ instance instHeapLangGS_HeapLangS : HeapLangGpreS HasLC.hasLC HeapLangS where · constructor exists 5 · exists 6 + proph_pre := by + constructor + · constructor + exists 7 end HeapLangGS @@ -83,19 +130,25 @@ theorem heap_adequacy [HeapLangGpreS .hasLC GF] (e : Exp) σ (φ : Val → Prop) (Std.PartialMap.map (fun g : GName => toAgree (LeibnizO.mk g)) (∅ : HeapF GName))) HeapView.auth_one_valid with ⟨%γm, Hm⟩ - letI _ : HeapLangGS .hasLC GF := ⟨⟨γh, γm⟩⟩ + imod (ProphMap.init (V := Val × Val) (H := ProphMapF) κs σ.usedProphId) + with ⟨%Gproph, Hproph⟩ + letI _ : HeapLangGS .hasLC GF := ⟨⟨γh, γm⟩, Gproph⟩ imodintro - iexists (fun σ _ => Iris.genHeapInterp (GF := GF) (H := HeapF) σ.heap) + iexists (fun σ κs => iprop( + Iris.genHeapInterp (GF := GF) (H := HeapF) σ.heap ∗ + Iris.prophMapInterp (GF := GF) (H := ProphMapF) κs σ.usedProphId)) iexists (fun _ => iprop(True)) - isplitl [Hh Hm] - · simp only [Iris.genHeapInterp] - iexists (∅ : HeapF GName) - isplitr - · ipureintro - intro k hk - simp [Std.PartialMap.dom, LawfulPartialMap.get?_empty] at hk - unfold ghost_map_auth - iframe Hh Hm + isplitl [Hh Hm Hproph] + · isplitl [Hh Hm] + · simp only [Iris.genHeapInterp] + iexists (∅ : HeapF GName) + isplitr + · ipureintro + intro k hk + simp [Std.PartialMap.dom, LawfulPartialMap.get?_empty] at hk + unfold ghost_map_auth + iframe Hh Hm + · iexact Hproph · exact Hwp end Adequacy @@ -124,6 +177,7 @@ theorem wp_fork {e : Exp} : iintro HΦ Hwp iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ have Hred : BaseStep.Reducible (hl(fork(&e)), σ₁) := ⟨[], hl(#BaseLit.unit), σ₁, [e], by constructor⟩ isplitr @@ -132,8 +186,41 @@ theorem wp_fork {e : Exp} : exact (primStep_reducible_of_baseStep_reducible Hred) iintro !> %e₂ %σ₂ %eₜ %Heq Hcr cases baseStep_of_primStep_of_baseStep_reducible Hred Heq - iframe Hσ + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph imodintro + isplitl [Hσ Hproph] + · iapply (stateInterp_split σ₁ (ns + 1) obs' (nt + [e].length)).mpr + iframe Hσ Hproph + isplitr [Hwp] + · iexists _ + iframe HΦ + ipureintro; rfl + · iapply BI.BigSepL.bigSepL_singleton + iframe Hwp + +/-- Fancy-update-flavoured fork rule. Mirrors `wp_fork_fupd` in +`case_studies/heaplang/fixes.v`. -/ +theorem wp_fork_fupd {e : Exp} : + (▷ |={E}=> (WP e @ s; ⊤ {{ _v, True }} ∗ Φ (hl_val(#())))) ⊢ + WP hl(fork(&e)) @ s; E {{ Φ }} := by + iintro HeΦ + iapply wp_lift_atomic_step rfl + iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ + have Hred : BaseStep.Reducible (hl(fork(&e)), σ₁) := + ⟨[], hl(#BaseLit.unit), σ₁, [e], by constructor⟩ + isplitr + · ipureintro + cases s <;> simp only [Stuckness.MaybeReducible] + exact (primStep_reducible_of_baseStep_reducible Hred) + iintro !> %e₂ %σ₂ %eₜ %Heq Hcr + cases baseStep_of_primStep_of_baseStep_reducible Hred Heq + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + imod HeΦ with ⟨Hwp, HΦ⟩ + imodintro + isplitl [Hσ Hproph] + · iapply (stateInterp_split σ₁ (ns + 1) obs' (nt + [e].length)).mpr + iframe Hσ Hproph isplitr [Hwp] · iexists _ iframe HΦ @@ -147,7 +234,7 @@ theorem wp_alloc (v : Val) (Φ : Val → IProp GF ) : iintro HΦ iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> - simp only [stateInterp] + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ let l := (List.fresh σ₁.heap.keys).choose have Hne : σ₁.get? l = .none := by simpa [State.get?, get?, getElem?_eq_none_iff, ←Std.ExtTreeMap.mem_keys] @@ -166,14 +253,14 @@ theorem wp_alloc (v : Val) (Φ : Val → IProp GF ) : iintro !> %e₂ %σ₂ %eₜ %Heq Hcr rcases baseStep_of_primStep_of_baseStep_reducible Hred Heq rename_i l' Hpo Hi - simp only [Int.cast_ofNat_Int, Algebra.BigOpL.bigOpL_nil, Int.toNat_one, List.range_one, - List.foldl_cons, List.foldl_nil] + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + simp only [stateInterp, Int.cast_ofNat_Int, Algebra.BigOpL.bigOpL_nil, Int.toNat_one, + List.range_one, List.foldl_cons, List.foldl_nil] specialize Hi 0 (by simp) (by simp) rw [show l' + (0 : Int) = l' by cases l'; simp only [HAdd.hAdd, Loc.mk.injEq]; grind] at Hi ⊢ imod genHeap_alloc (v := some v) Hi $$ Hσ with ⟨Hσ, Hpt, _Hmt⟩ imodintro - -- FIXME: can iframe should solve emp? - iframe Hσ + iframe Hσ Hproph isplit <;> try itrivial iexists hl_val(#(BaseLit.loc l')) isplit; ipureintro; rfl @@ -186,6 +273,7 @@ theorem wp_load {l : Loc} {q} {v : Val} Φ : iintro >Hpt HΦ iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ ihave %Hpt : ⌜σ₁.get? l = v⌝ $$ [Hσ Hpt] · ihave >%_ := genHeap_valid $$ [$Hσ $Hpt] itrivial @@ -203,8 +291,9 @@ theorem wp_load {l : Loc} {q} {v : Val} Φ : rw [Hpt] at H; simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at H subst H - simp only [Algebra.BigOpL.bigOpL_nil] - iframe Hσ + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + simp only [stateInterp, Algebra.BigOpL.bigOpL_nil] + iframe Hσ Hproph imodintro isplit <;> try itrivial iexists _; isplit @@ -218,7 +307,7 @@ theorem wp_store {l : Loc} {v v' : Val} Φ : iintro >Hpt HΦ iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> - simp only [stateInterp] + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ ihave %Hpt : ⌜σ₁.get? l = .some (.some v')⌝ $$ [Hσ Hpt] · icases genHeap_valid $$ [$Hσ $Hpt] with >%Heq' itrivial @@ -236,12 +325,13 @@ theorem wp_store {l : Loc} {v v' : Val} Φ : rw [Hpt] at H; simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at H subst H - simp only [Int.toNat_one, List.range_one, List.foldl_cons, Int.cast_ofNat_Int, List.foldl_nil, - Algebra.BigOpL.bigOpL_nil] + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + simp only [stateInterp, Int.toNat_one, List.range_one, List.foldl_cons, Int.cast_ofNat_Int, + List.foldl_nil, Algebra.BigOpL.bigOpL_nil] rw [show l + (0 : Int) = l by cases l; simp only [HAdd.hAdd, Loc.mk.injEq]; grind] imod genHeap_update (v₂ := .some v) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ imodintro - iframe Hσ + iframe Hσ Hproph isplit <;> try itrivial iexists .lit .unit isplit @@ -257,7 +347,7 @@ theorem wp_cmpXchg_fail {l : Loc} {q} {v' : Val} {e1 : Exp} {v1 : Val} {e2 : Exp iintro >Hpt iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> - simp only [stateInterp] + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ ihave %Hpt : ⌜σ₁.get? l = .some (.some v')⌝ $$ [Hσ Hpt] · icases genHeap_valid $$ [$Hσ $Hpt] with >%Heq' itrivial @@ -276,18 +366,21 @@ theorem wp_cmpXchg_fail {l : Loc} {q} {v' : Val} {e1 : Exp} {v1 : Val} {e2 : Exp rw [Hpt] at H simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at H subst H + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph simp only [Algebra.BigOpL.bigOpL_nil] subst Heq4; simp only [toVal] at Heq1 Heq2 obtain ⟨rfl⟩ := Heq1 obtain ⟨rfl⟩ := Heq2 simp only [Heq4, Bool.false_eq_true, ↓reduceIte] imodintro - iframe Hσ + simp + simp [stateInterp] + iframe Hσ Hproph isplit <;> try itrivial iexists hl_val((&v', #false)) iframe Hpt - ipureintro; simp [toVal] - rfl + ipureintro + simp theorem wp_cmpXchg_true {l : Loc} {v' : Val} {e1 : Exp} {v1 : Val} {e2 : Exp} {v2 : Val} (Heq1 : toVal e1 = .some v1) (Heq2 : toVal e2 = .some v2) (Heq3 : v'.compareSafe v1) @@ -298,7 +391,7 @@ theorem wp_cmpXchg_true {l : Loc} {v' : Val} {e1 : Exp} {v1 : Val} {e2 : Exp} {v iintro >Hpt iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> - simp only [stateInterp] + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ ihave %Hpt : ⌜σ₁.get? l = .some (.some v')⌝ $$ [Hσ Hpt] · icases genHeap_valid $$ [$Hσ $Hpt] with >%Heq' itrivial @@ -317,7 +410,8 @@ theorem wp_cmpXchg_true {l : Loc} {v' : Val} {e1 : Exp} {v1 : Val} {e2 : Exp} {v rw [Hpt] at H simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at H subst H - simp only [Algebra.BigOpL.bigOpL_nil] + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + simp only [stateInterp, Algebra.BigOpL.bigOpL_nil] subst Heq4; simp only [toVal] at Heq1 Heq2 obtain ⟨rfl⟩ := Heq1 obtain ⟨rfl⟩ := Heq2 @@ -326,13 +420,287 @@ theorem wp_cmpXchg_true {l : Loc} {v' : Val} {e1 : Exp} {v1 : Val} {e2 : Exp} {v rw [show l + (0 : Int) = l by cases l; simp only [HAdd.hAdd, Loc.mk.injEq]; grind] imod genHeap_update (v₂ := .some v2) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ imodintro - iframe Hσ + iframe Hσ Hproph isplit <;> try itrivial iexists hl_val((&v', #true)) iframe Hpt ipureintro; simp [toVal] rfl +theorem wp_free {l : Loc} {v : Val} : + ▷ (l ↦ some v) + ⊢@{IProp GF} WP (Exp.free (.val (.lit (.loc l)))) @ s; E + {{ v'', ⌜v'' = Val.lit BaseLit.unit⌝ ∗ (l ↦ (none : Option Val)) }} := by + iintro >Hpt + iapply wp_lift_atomic_step rfl + iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ + ihave %Hpt : ⌜σ₁.get? l = .some (.some v)⌝ $$ [Hσ Hpt] + · icases genHeap_valid $$ [$Hσ $Hpt] with >%Heq' + itrivial + ihave %Hred : ⌜BaseStep.Reducible (Exp.free (.val (.lit (.loc l))), σ₁)⌝ $$ [] + · ipureintro + exists [], (.val (.lit .unit)), (σ₁.initHeap l 1 none), [] + refine BaseStep.freeS l v _ ?_; grind + isplitr + · ipureintro + cases s <;> simp only [Stuckness.MaybeReducible] + exact primStep_reducible_of_baseStep_reducible Hred + iintro !> %e₂ %σ₂ %eₜ %Heq Hcr + cases baseStep_of_primStep_of_baseStep_reducible Hred Heq + rename_i v'' H + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + simp only [stateInterp, Int.toNat_one, List.range_one, List.foldl_cons, Int.cast_ofNat_Int, + List.foldl_nil, Algebra.BigOpL.bigOpL_nil] + rw [show l + (0 : Int) = l by cases l; simp only [HAdd.hAdd, Loc.mk.injEq]; grind] + imod genHeap_update (v₂ := (none : Option Val)) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ + imodintro + iframe Hσ Hproph + isplit <;> try itrivial + iexists .lit .unit + iframe Hpt + ipureintro; simp [toVal]; rfl + +theorem wp_xchg {l : Loc} {v w : Val} : + ▷ (l ↦ some v) + ⊢@{IProp GF} WP (Exp.xchg (.val (.lit (.loc l))) (.val w)) @ s; E + {{ v'', ⌜v'' = v⌝ ∗ (l ↦ some w) }} := by + iintro >Hpt + iapply wp_lift_atomic_step rfl + iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ + ihave %Hpt : ⌜σ₁.get? l = .some (.some v)⌝ $$ [Hσ Hpt] + · icases genHeap_valid $$ [$Hσ $Hpt] with >%Heq' + itrivial + ihave %Hred : ⌜BaseStep.Reducible (Exp.xchg (.val (.lit (.loc l))) (.val w), σ₁)⌝ $$ [] + · ipureintro + exists [], (.val v), (σ₁.initHeap l 1 w), [] + refine BaseStep.xchgS l v w _ ?_; grind + isplitr + · ipureintro + cases s <;> simp only [Stuckness.MaybeReducible] + exact primStep_reducible_of_baseStep_reducible Hred + iintro !> %e₂ %σ₂ %eₜ %Heq Hcr + cases baseStep_of_primStep_of_baseStep_reducible Hred Heq + rename_i v1' H + obtain rfl : v = v1' := by + rw [Hpt] at H + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at H + exact H + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + simp only [stateInterp, Int.toNat_one, List.range_one, List.foldl_cons, Int.cast_ofNat_Int, + List.foldl_nil, Algebra.BigOpL.bigOpL_nil] + rw [show l + (0 : Int) = l by cases l; simp only [HAdd.hAdd, Loc.mk.injEq]; grind] + imod genHeap_update (v₂ := (some w : Option Val)) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ + imodintro + iframe Hσ Hproph + isplit <;> try itrivial + iexists v + iframe Hpt + ipureintro; simp [toVal]; rfl + +theorem wp_faa {l : Loc} {i1 i2 : Int} : + ▷ (l ↦ some (Val.lit (.int i1))) + ⊢@{IProp GF} WP (Exp.faa (.val (.lit (.loc l))) (.val (.lit (.int i2)))) @ s; E + {{ v'', ⌜v'' = Val.lit (.int i1)⌝ ∗ (l ↦ some (Val.lit (.int (i1 + i2)))) }} := by + iintro >Hpt + iapply wp_lift_atomic_step rfl + iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ + ihave %Hpt : ⌜σ₁.get? l = .some (.some (Val.lit (.int i1)))⌝ $$ [Hσ Hpt] + · icases genHeap_valid $$ [$Hσ $Hpt] with >%Heq' + itrivial + ihave %Hred : + ⌜BaseStep.Reducible (Exp.faa (.val (.lit (.loc l))) (.val (.lit (.int i2))), σ₁)⌝ $$ [] + · ipureintro + exists [], (.val (.lit (.int i1))), (σ₁.initHeap l 1 (some (.lit (.int (i1 + i2))))), [] + refine BaseStep.faaS l i1 i2 _ ?_; grind + isplitr + · ipureintro + cases s <;> simp only [Stuckness.MaybeReducible] + exact primStep_reducible_of_baseStep_reducible Hred + iintro !> %e₂ %σ₂ %eₜ %Heq Hcr + cases baseStep_of_primStep_of_baseStep_reducible Hred Heq + rename_i i1' H + obtain rfl : i1 = i1' := by + rw [Hpt] at H + simp only [Option.some.injEq, Val.lit.injEq, BaseLit.int.injEq] at H + exact H + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + simp only [stateInterp, Int.toNat_one, List.range_one, List.foldl_cons, Int.cast_ofNat_Int, + List.foldl_nil, Algebra.BigOpL.bigOpL_nil] + rw [show l + (0 : Int) = l by cases l; simp only [HAdd.hAdd, Loc.mk.injEq]; grind] + imod genHeap_update (v₂ := (some (Val.lit (.int (i1 + i2))) : Option Val)) $$ [$Hσ $Hpt] + with ⟨Hσ, Hpt⟩ + imodintro + iframe Hσ Hproph + isplit <;> try itrivial + iexists Val.lit (.int i1) + iframe Hpt + ipureintro; simp [toVal]; rfl + +/-- The state update of a `newProphS` step (insertion into `usedProphId`) is the +same set as `{p} ∪ usedProphId`, which is what `ProphMap.new_proph` returns. -/ +theorem usedProph_insert_eq {ps : Std.ExtTreeSet ProphId compare} {p : ProphId} : + ps.insert p = ({p} ∪ ps : Std.ExtTreeSet ProphId compare) := by + apply Std.ExtTreeSet.ext_mem + intro x + rw [Std.ExtTreeSet.mem_insert, Std.ExtTreeSet.mem_union_iff, + Iris.Std.LawfulSet.mem_singleton, Std.LawfulEqCmp.compare_eq_iff_eq] + constructor + · rintro (rfl | h) + · left; rfl + · right; exact h + · rintro (rfl | h) + · left; rfl + · right; exact h + +/-- Allocate a fresh prophecy variable. Mirrors `wp_new_proph` in `iris.heap_lang.lifting`. -/ +theorem wp_new_proph : + ⊢ WP (Exp.newProph : Exp) @ s; E + {{ v, ∃ p : ProphId, ∃ pvs : List (Val × Val), + ⌜v = .lit (.prophecy p)⌝ ∗ proph p pvs }} := by + iapply wp_lift_atomic_step rfl + iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ + -- Pick a prophecy id fresh in the current `usedProphId`. + obtain ⟨pf, Hpf⟩ := Iris.Std.List.fresh σ₁.usedProphId.toList + have Hpf_contains : ¬ σ₁.usedProphId.contains pf := by + intro hc; exact Hpf (Std.ExtTreeSet.mem_toList.mpr hc) + have Hred : BaseStep.Reducible (Exp.newProph, σ₁) := + ⟨[], _, _, [], BaseStep.newProphS σ₁ pf Hpf_contains⟩ + isplitr + · ipureintro + cases s <;> simp only [Stuckness.MaybeReducible] + exact primStep_reducible_of_baseStep_reducible Hred + iintro !> %e₂ %σ₂ %eₜ %Heq Hcr + cases baseStep_of_primStep_of_baseStep_reducible Hred Heq + rename_i p' Hp' + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + -- Convert `¬ contains` to `∉` for `ProphMap.new_proph`. + have Hp'_mem : p' ∉ σ₁.usedProphId := + fun hmem => Hp' (Std.ExtTreeSet.mem_iff_contains.symm.mp hmem) + imod (ProphMap.new_proph p' σ₁.usedProphId obs' Hp'_mem) $$ Hproph + with ⟨Hproph', Htok⟩ + imodintro + simp only [stateInterp] + iframe Hσ + isplitl [Hproph'] + · -- Bridge `{p'} ∪ σ₁.usedProphId` (from new_proph) and `σ₁.usedProphId.insert p'` + -- (from the newProphS constructor's output). + rw [show ({p'} ∪ σ₁.usedProphId : Std.ExtTreeSet ProphId compare) + = σ₁.usedProphId.insert p' from usedProph_insert_eq.symm] + iexact Hproph' + isplitl [Htok] + · iexists hl_val(#(BaseLit.prophecy p')) + isplit + · ipureintro; simp [toVal]; rfl + iexists p', _ + iframe Htok + ipureintro; rfl + · simp only [Algebra.BigOpL.bigOpL_nil]; itrivial + +/-- `Resolve e (Val (LitProphecy p)) (Val w)` lifts a WP for the inner expression +`e` through the `Resolve` wrapper, consuming the front observation `(v_e, w)` +from the prophecy `p`. The inner WP is allowed to use the prophecy token +`proph p pvs` while reducing `e`; on completion the postcondition is closed +under reattaching the front observation. Mirrors `wp_resolve_strong` in Rocq +heap_lang's `primitive_laws.v`. -/ +theorem wp_resolve_strong {e : Exp} {p : ProphId} {w : Val} {pvs : List (Val × Val)} + (hatom : Language.Atomic (State := State) (Obs := Observation) + Language.Atomicity.StronglyAtomic e) + (hne : toVal e = none) : + proph p pvs -∗ + (proph p pvs -∗ WP e @ s; E {{ v_e, ∃ pvs', proph p pvs' ∗ + ∀ pvs'', ⌜pvs' = (v_e, w) :: pvs''⌝ -∗ proph p pvs'' -∗ Φ v_e }}) -∗ + WP (Exp.resolve e (.val (.lit (.prophecy p))) (.val w)) @ s; E {{ Φ }} := by + -- Mirrors Rocq `iris/heap_lang/primitive_laws.v:726–758`. The proof breaks + -- the WP abstraction by unfolding `wp_unfold` directly on the inner WP for + -- `e`, reverse-inducting on the outer observation list, and threading the + -- trailing observation through the prophecy map via `ProphMap.resolve_proph`. + iintro Hp HWPe + iapply wp_lift_step_fupdN rfl + iintro %σ₁ %ns %obs %obs' %nt Hσ + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hheap, Hpmap⟩ + -- Extract `p ∈ σ₁.usedProphId` (pure conclusion via `ProphMap.agree`, + -- preserving `Hpmap` and `Hp` via the `$` frame markers). + icases ProphMap.agree (obs ++ obs') σ₁.usedProphId p pvs $$ [$Hpmap $Hp] + with %Hagree + have Hp_mem : p ∈ σ₁.usedProphId := Hagree.1 + have hp_contains : σ₁.usedProphId.contains p := + Std.ExtTreeSet.mem_iff_contains.mp Hp_mem + -- Feed the prophecy token to the inner WP wand, then open into the step + -- branch via `wp_unfold` + `wp.pre`-reduction (the Lean-eq bridge). + ihave HWPe : iprop(WP e @ s; E {{ v_e, ∃ pvs', proph p pvs' ∗ + ∀ pvs'', ⌜pvs' = (v_e, w) :: pvs''⌝ -∗ proph p pvs'' -∗ Φ v_e }}) + $$ [Hp HWPe] + · iapply HWPe; iexact Hp + ihave HWPe := (show iprop(WP e @ s; E {{ v_e, ∃ pvs', proph p pvs' ∗ + ∀ pvs'', ⌜pvs' = (v_e, w) :: pvs''⌝ -∗ proph p pvs'' -∗ Φ v_e }}) ⊢ _ + by rw [wp_unfold.to_eq]; simp only [wp.pre, hne]; exact .rfl) $$ HWPe + -- Reverse-induct on the outer observation list `obs`. + cases obs using List.reverseRec with + | nil => + -- obs = []. Apply inner WP with inner obs = [], inner obs' = obs'. + ihave Hσ_e : iprop(stateInterp σ₁ ns ([] ++ obs') nt) $$ [Hheap Hpmap] + · iapply (stateInterp_split σ₁ ns ([] ++ obs') nt).mpr + iframe Hheap + iexact Hpmap + imod HWPe $$ %_ %_ %_ %_ %_ Hσ_e with ⟨%Hred_e, HWPe⟩ + imodintro + isplitr + · ipureintro + cases s <;> simp only [Stuckness.MaybeReducible] + exact prim_step_reducible_resolve hp_contains Hred_e + iintro %e₂ %σ₂ %eₜ %Hstep _Hcred + exfalso + obtain ⟨κ_inner, _, hκ_eq, _, _⟩ := step_resolve_decompose Hstep + exact List.cons_ne_nil _ _ (List.append_eq_nil_iff.mp hκ_eq.symm).2 + | append_singleton init lastObs _ => + -- obs = init ++ [lastObs]. Apply inner WP with inner obs = init, + -- inner obs' = lastObs :: obs'. + have hassoc : (init ++ [lastObs]) ++ obs' = init ++ (lastObs :: obs') := by simp + ihave Hσ_e : iprop(stateInterp σ₁ ns (init ++ (lastObs :: obs')) nt) + $$ [Hheap Hpmap] + · iapply (stateInterp_split σ₁ ns (init ++ (lastObs :: obs')) nt).mpr + iframe Hheap + rw [← hassoc]; iexact Hpmap + imod HWPe $$ %_ %_ %_ %_ %_ Hσ_e with ⟨%Hred_e, HWPe⟩ + imodintro + isplitr + · ipureintro + cases s <;> simp only [Stuckness.MaybeReducible] + exact prim_step_reducible_resolve hp_contains Hred_e + iintro %e₂ %σ₂ %eₜ %Hstep Hcred + obtain ⟨κ_inner, v_inner, hκ_eq, he₂_eq, Hbase_e⟩ := step_resolve_decompose Hstep + have h := congrArg List.reverse hκ_eq + simp at h + obtain ⟨hκ_eq_init, hlast_eq⟩ := h + subst hκ_eq_init; subst hlast_eq; subst he₂_eq + have Hprim_e : PrimStep.primStep (e, σ₁) init (Exp.val v_inner, σ₂, eₜ) := + EctxLanguage.primStep_of_baseStep Hbase_e + ispecialize HWPe $$ %_ %_ %_ %Hprim_e Hcred + iapply step_fupdN_wand $$ HWPe + iintro HWPe + imod HWPe with ⟨Hσ_post, HWPval, Hefs⟩ + icases (stateInterp_split σ₂ (ns + 1) ((p, (v_inner, w)) :: obs') (nt + eₜ.length)).mp + $$ Hσ_post with ⟨Hheap_e, Hpmap_e⟩ + ihave HWPval := wp_value_fupd'.mp $$ HWPval + imod HWPval with ⟨%pvs', Hele, HΦ⟩ + icombine Hpmap_e Hele as Hcomb + imod (ProphMap.resolve_proph (V := Val × Val) (H := ProphMapF) + p (v_inner, w) obs' σ₂.usedProphId pvs') $$ Hcomb + with ⟨%pvs'', %hpvs'_eq, Hpmap_e, Hele⟩ + imodintro + isplitl [Hheap_e Hpmap_e] + · iapply (stateInterp_split σ₂ (ns + 1) obs' (nt + eₜ.length)).mpr + iframe Hheap_e + iexact Hpmap_e + isplitr [Hefs] + · iapply wp_value' + iapply HΦ $$ %pvs'' %hpvs'_eq Hele + · iexact Hefs + end Lifting end Iris.HeapLang diff --git a/Iris/Iris/HeapLang/Syntax.lean b/Iris/Iris/HeapLang/Syntax.lean index cc9055bd3..66a3aff68 100644 --- a/Iris/Iris/HeapLang/Syntax.lean +++ b/Iris/Iris/HeapLang/Syntax.lean @@ -69,6 +69,10 @@ instance : Std.LawfulEqOrd ProphId where intros l₁ l₂; unfold compare; unfold instOrdProphId; simp; intros h; ext; assumption +instance : InfiniteType ProphId where + enum n := .mk n + enum_inj n m := by grind + inductive Binder where | anon | named (name : String) From 35d6c43f14d711d66f7df933ab06b649209b05e4 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Tue, 23 Jun 2026 16:54:38 -0700 Subject: [PATCH 12/33] checkpoint --- Iris/Iris/HeapLang/PrimitiveLaws.lean | 127 ++++++++------------------ 1 file changed, 38 insertions(+), 89 deletions(-) diff --git a/Iris/Iris/HeapLang/PrimitiveLaws.lean b/Iris/Iris/HeapLang/PrimitiveLaws.lean index 49fc26d1a..1f18c93e9 100644 --- a/Iris/Iris/HeapLang/PrimitiveLaws.lean +++ b/Iris/Iris/HeapLang/PrimitiveLaws.lean @@ -22,9 +22,6 @@ section HeapLangGS abbrev HeapF := fun V => Std.ExtTreeMap Loc V compare -/-- The finite-map type used by the heap_lang prophecy ghost state: a map from -`ProphId` to the prophecy's outstanding resolution list. Mirrors the Rocq -`gmap proph_id (list val)` used in `proph_map`. -/ abbrev ProphMapF := fun V => Std.ExtTreeMap ProphId V compare class HeapLangGpreS (hlc : outParam HasLC) (GF : BundledGFunctors) extends InvGpreS GF where @@ -46,39 +43,23 @@ instance HeapLangState [HeapLangGS hlc GF] : StateInterp State Observation GF wh genHeapInterp (GF := GF) (H := HeapF) σ.heap ∗ prophMapInterp (GF := GF) (H := ProphMapF) κs σ.usedProphId) -/-- The state interpretation as a separating conjunction of the heap interp and -the prophecy-map interp. Used to destruct `Hσ` into its two conjuncts after -`wp_lift_atomic_step`. -/ theorem stateInterp_split [HeapLangGS hlc GF] (σ : State) (ns : Nat) - (κs : List Observation) (nt : Nat) : - stateInterp (GF := GF) σ ns κs nt ⊣⊢ - iprop(genHeapInterp (GF := GF) (H := HeapF) σ.heap ∗ - prophMapInterp (GF := GF) (H := ProphMapF) κs σ.usedProphId) := - Iris.BI.BIBase.BiEntails.rfl - -/-- Normalize a `[] ++ κs` argument to `κs`. Used to rephrase `prophMapInterp` -hypotheses introduced before a step whose observations are `[]` get substituted -in by `cases`. The two sides are definitionally equal. -/ + (κs : List Observation) (nt : Nat) : iprop% + stateInterp (GF := GF) σ ns κs nt ⊣⊢ genHeapInterp σ.heap ∗ prophMapInterp κs σ.usedProphId := + .rfl + theorem prophMapInterp_nil_append [HeapLangGS hlc GF] (κs : List Observation) - (ps : Std.ExtTreeSet ProphId) : - iprop(prophMapInterp (GF := GF) (H := ProphMapF) ([] ++ κs) ps) ⊣⊢ - iprop(prophMapInterp (GF := GF) (H := ProphMapF) κs ps) := - Iris.BI.BIBase.BiEntails.rfl + (ps : Std.ExtTreeSet ProphId) : prophMapInterp ([] ++ κs) ps ⊣⊢ prophMapInterp κs ps := + .rfl instance HeapLang [HeapLangGS hlc GF] : IrisGS_gen hlc Exp GF where numLatersPerStep n := 0 forkPost v := iprop(True) stateInterp_mono σ ns obs nt := by iintro $ -/-- The state interpretation is closed under bumping the step counter. In -iris-lean this is trivial, since the heap_lang `stateInterp` ignores the step -index. Mirrors `state_interp_step` in `case_studies/heaplang/fixes.v`. -/ theorem state_interp_step [HeapLangGS hlc GF] (σ : State) (ns : Nat) (κs : List Observation) (nt : Nat) : - stateInterp (GF := GF) σ ns κs nt ⊢ |==> stateInterp (GF := GF) σ (ns + 1) κs nt := by - iintro H - imodintro - iexact H + stateInterp (GF := GF) σ ns κs nt ⊢ |==> stateInterp σ (ns + 1) κs nt := bupd_intro def HeapLangS : BundledGFunctors | 0 => ⟨InvMapF, by infer_instance⟩ @@ -88,7 +69,8 @@ def HeapLangS : BundledGFunctors | 4 => ⟨constOF (HeapView Loc (Agree (LeibnizO (Option Val))) HeapF), by infer_instance⟩ | 5 => ⟨constOF (HeapView Loc (Agree (LeibnizO GName)) HeapF), by infer_instance⟩ | 6 => ⟨constOF MetaUR, by infer_instance⟩ - | 7 => ⟨constOF (HeapView ProphId (Agree (LeibnizO (List (Val × Val)))) ProphMapF), by infer_instance⟩ + | 7 => ⟨constOF (HeapView ProphId (Agree (LeibnizO (List (Val × Val)))) ProphMapF), + by infer_instance⟩ | _ => ⟨constOF Unit, by infer_instance⟩ instance instHeapLangGS_HeapLangS : HeapLangGpreS HasLC.hasLC HeapLangS where @@ -121,35 +103,29 @@ theorem heap_adequacy [HeapLangGpreS .hasLC GF] (e : Exp) σ (φ : Val → Prop) adequate .NotStuck e σ (fun v _ => φ v) := by refine wp_adequacy (GF := GF) .NotStuck e σ φ ?_ intro inst κs - imod iOwn_alloc (E := GhostMapG.elem (K := Loc) (V := Option Val) (H := HeapF)) - (HeapView.Auth (H := HeapF) (.own 1) + imod iOwn_alloc (E := GhostMapG.elem) (HeapView.Auth (H := HeapF) (.own 1) (Std.PartialMap.map (fun v : Option Val => toAgree (LeibnizO.mk v)) σ.heap)) HeapView.auth_one_valid with ⟨%γh, Hh⟩ - imod iOwn_alloc (E := GhostMapG.elem (K := Loc) (V := GName) (H := HeapF)) - (HeapView.Auth (H := HeapF) (.own 1) - (Std.PartialMap.map (fun g : GName => toAgree (LeibnizO.mk g)) - (∅ : HeapF GName))) + imod iOwn_alloc (E := GhostMapG.elem) (HeapView.Auth (H := HeapF) (.own 1) + (Std.PartialMap.map (fun g : GName => toAgree (LeibnizO.mk g)) (∅ : HeapF GName))) HeapView.auth_one_valid with ⟨%γm, Hm⟩ - imod (ProphMap.init (V := Val × Val) (H := ProphMapF) κs σ.usedProphId) - with ⟨%Gproph, Hproph⟩ - letI _ : HeapLangGS .hasLC GF := ⟨⟨γh, γm⟩, Gproph⟩ + imod (ProphMap.init (H := ProphMapF) κs σ.usedProphId) with ⟨%Gproph, Hproph⟩ + letI instHeapLangGS : HeapLangGS .hasLC GF := ⟨⟨γh, γm⟩, Gproph⟩ imodintro - iexists (fun σ κs => iprop( - Iris.genHeapInterp (GF := GF) (H := HeapF) σ.heap ∗ - Iris.prophMapInterp (GF := GF) (H := ProphMapF) κs σ.usedProphId)) + iexists (fun σ κs => iprop% Iris.genHeapInterp σ.heap ∗ Iris.prophMapInterp κs σ.usedProphId) iexists (fun _ => iprop(True)) - isplitl [Hh Hm Hproph] - · isplitl [Hh Hm] - · simp only [Iris.genHeapInterp] - iexists (∅ : HeapF GName) - isplitr - · ipureintro - intro k hk - simp [Std.PartialMap.dom, LawfulPartialMap.get?_empty] at hk - unfold ghost_map_auth - iframe Hh Hm - · iexact Hproph - · exact Hwp + specialize @Hwp _ + simp only [] + -- NOTE: iframe %Hwp does not work here + isplitl [Hh Hm Hproph] <;> try · exact Hwp + iframe + simp only [Iris.genHeapInterp] + iexists (∅ : HeapF GName) + unfold ghost_map_auth + iframe Hh Hm + ipureintro + intro k hk + simp [Std.PartialMap.dom, LawfulPartialMap.get?_empty] at hk end Adequacy @@ -190,7 +166,7 @@ theorem wp_fork {e : Exp} : imodintro isplitl [Hσ Hproph] · iapply (stateInterp_split σ₁ (ns + 1) obs' (nt + [e].length)).mpr - iframe Hσ Hproph + iframe isplitr [Hwp] · iexists _ iframe HΦ @@ -373,8 +349,7 @@ theorem wp_cmpXchg_fail {l : Loc} {q} {v' : Val} {e1 : Exp} {v1 : Val} {e2 : Exp obtain ⟨rfl⟩ := Heq2 simp only [Heq4, Bool.false_eq_true, ↓reduceIte] imodintro - simp - simp [stateInterp] + simp only [toVal_coe, Option.some.injEq, stateInterp] iframe Hσ Hproph isplit <;> try itrivial iexists hl_val((&v', #false)) @@ -427,6 +402,8 @@ theorem wp_cmpXchg_true {l : Loc} {v' : Val} {e1 : Exp} {v1 : Val} {e2 : Exp} {v ipureintro; simp [toVal] rfl +-- TODO: Here + theorem wp_free {l : Loc} {v : Val} : ▷ (l ↦ some v) ⊢@{IProp GF} WP (Exp.free (.val (.lit (.loc l)))) @ s; E @@ -539,23 +516,14 @@ theorem wp_faa {l : Loc} {i1 i2 : Int} : iframe Hpt ipureintro; simp [toVal]; rfl -/-- The state update of a `newProphS` step (insertion into `usedProphId`) is the -same set as `{p} ∪ usedProphId`, which is what `ProphMap.new_proph` returns. -/ theorem usedProph_insert_eq {ps : Std.ExtTreeSet ProphId compare} {p : ProphId} : ps.insert p = ({p} ∪ ps : Std.ExtTreeSet ProphId compare) := by apply Std.ExtTreeSet.ext_mem intro x rw [Std.ExtTreeSet.mem_insert, Std.ExtTreeSet.mem_union_iff, Iris.Std.LawfulSet.mem_singleton, Std.LawfulEqCmp.compare_eq_iff_eq] - constructor - · rintro (rfl | h) - · left; rfl - · right; exact h - · rintro (rfl | h) - · left; rfl - · right; exact h - -/-- Allocate a fresh prophecy variable. Mirrors `wp_new_proph` in `iris.heap_lang.lifting`. -/ + grind + theorem wp_new_proph : ⊢ WP (Exp.newProph : Exp) @ s; E {{ v, ∃ p : ProphId, ∃ pvs : List (Val × Val), @@ -563,7 +531,6 @@ theorem wp_new_proph : iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ - -- Pick a prophecy id fresh in the current `usedProphId`. obtain ⟨pf, Hpf⟩ := Iris.Std.List.fresh σ₁.usedProphId.toList have Hpf_contains : ¬ σ₁.usedProphId.contains pf := by intro hc; exact Hpf (Std.ExtTreeSet.mem_toList.mpr hc) @@ -577,7 +544,6 @@ theorem wp_new_proph : cases baseStep_of_primStep_of_baseStep_reducible Hred Heq rename_i p' Hp' ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph - -- Convert `¬ contains` to `∉` for `ProphMap.new_proph`. have Hp'_mem : p' ∉ σ₁.usedProphId := fun hmem => Hp' (Std.ExtTreeSet.mem_iff_contains.symm.mp hmem) imod (ProphMap.new_proph p' σ₁.usedProphId obs' Hp'_mem) $$ Hproph @@ -586,9 +552,7 @@ theorem wp_new_proph : simp only [stateInterp] iframe Hσ isplitl [Hproph'] - · -- Bridge `{p'} ∪ σ₁.usedProphId` (from new_proph) and `σ₁.usedProphId.insert p'` - -- (from the newProphS constructor's output). - rw [show ({p'} ∪ σ₁.usedProphId : Std.ExtTreeSet ProphId compare) + · rw [show ({p'} ∪ σ₁.usedProphId : Std.ExtTreeSet ProphId compare) = σ₁.usedProphId.insert p' from usedProph_insert_eq.symm] iexact Hproph' isplitl [Htok] @@ -614,23 +578,15 @@ theorem wp_resolve_strong {e : Exp} {p : ProphId} {w : Val} {pvs : List (Val × (proph p pvs -∗ WP e @ s; E {{ v_e, ∃ pvs', proph p pvs' ∗ ∀ pvs'', ⌜pvs' = (v_e, w) :: pvs''⌝ -∗ proph p pvs'' -∗ Φ v_e }}) -∗ WP (Exp.resolve e (.val (.lit (.prophecy p))) (.val w)) @ s; E {{ Φ }} := by - -- Mirrors Rocq `iris/heap_lang/primitive_laws.v:726–758`. The proof breaks - -- the WP abstraction by unfolding `wp_unfold` directly on the inner WP for - -- `e`, reverse-inducting on the outer observation list, and threading the - -- trailing observation through the prophecy map via `ProphMap.resolve_proph`. iintro Hp HWPe iapply wp_lift_step_fupdN rfl iintro %σ₁ %ns %obs %obs' %nt Hσ icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hheap, Hpmap⟩ - -- Extract `p ∈ σ₁.usedProphId` (pure conclusion via `ProphMap.agree`, - -- preserving `Hpmap` and `Hp` via the `$` frame markers). icases ProphMap.agree (obs ++ obs') σ₁.usedProphId p pvs $$ [$Hpmap $Hp] with %Hagree have Hp_mem : p ∈ σ₁.usedProphId := Hagree.1 have hp_contains : σ₁.usedProphId.contains p := Std.ExtTreeSet.mem_iff_contains.mp Hp_mem - -- Feed the prophecy token to the inner WP wand, then open into the step - -- branch via `wp_unfold` + `wp.pre`-reduction (the Lean-eq bridge). ihave HWPe : iprop(WP e @ s; E {{ v_e, ∃ pvs', proph p pvs' ∗ ∀ pvs'', ⌜pvs' = (v_e, w) :: pvs''⌝ -∗ proph p pvs'' -∗ Φ v_e }}) $$ [Hp HWPe] @@ -638,10 +594,8 @@ theorem wp_resolve_strong {e : Exp} {p : ProphId} {w : Val} {pvs : List (Val × ihave HWPe := (show iprop(WP e @ s; E {{ v_e, ∃ pvs', proph p pvs' ∗ ∀ pvs'', ⌜pvs' = (v_e, w) :: pvs''⌝ -∗ proph p pvs'' -∗ Φ v_e }}) ⊢ _ by rw [wp_unfold.to_eq]; simp only [wp.pre, hne]; exact .rfl) $$ HWPe - -- Reverse-induct on the outer observation list `obs`. cases obs using List.reverseRec with | nil => - -- obs = []. Apply inner WP with inner obs = [], inner obs' = obs'. ihave Hσ_e : iprop(stateInterp σ₁ ns ([] ++ obs') nt) $$ [Hheap Hpmap] · iapply (stateInterp_split σ₁ ns ([] ++ obs') nt).mpr iframe Hheap @@ -657,8 +611,6 @@ theorem wp_resolve_strong {e : Exp} {p : ProphId} {w : Val} {pvs : List (Val × obtain ⟨κ_inner, _, hκ_eq, _, _⟩ := step_resolve_decompose Hstep exact List.cons_ne_nil _ _ (List.append_eq_nil_iff.mp hκ_eq.symm).2 | append_singleton init lastObs _ => - -- obs = init ++ [lastObs]. Apply inner WP with inner obs = init, - -- inner obs' = lastObs :: obs'. have hassoc : (init ++ [lastObs]) ++ obs' = init ++ (lastObs :: obs') := by simp ihave Hσ_e : iprop(stateInterp σ₁ ns (init ++ (lastObs :: obs')) nt) $$ [Hheap Hpmap] @@ -693,13 +645,10 @@ theorem wp_resolve_strong {e : Exp} {p : ProphId} {w : Val} {pvs : List (Val × with ⟨%pvs'', %hpvs'_eq, Hpmap_e, Hele⟩ imodintro isplitl [Hheap_e Hpmap_e] - · iapply (stateInterp_split σ₂ (ns + 1) obs' (nt + eₜ.length)).mpr - iframe Hheap_e - iexact Hpmap_e - isplitr [Hefs] - · iapply wp_value' - iapply HΦ $$ %pvs'' %hpvs'_eq Hele - · iexact Hefs + · iapply (stateInterp_split σ₂ (ns + 1) obs' (nt + eₜ.length)).mpr $$ [$] + iframe Hefs + iapply wp_value' + iapply HΦ $$ %pvs'' %hpvs'_eq Hele end Lifting From c7eb1c49a9466d6af92f014f9237a2bc79e8d142 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Wed, 1 Jul 2026 14:59:40 -0700 Subject: [PATCH 13/33] fix outdated comments --- Iris/Iris/Instances/Lib/CInvariants.lean | 2 -- Iris/Iris/Instances/Lib/Invariants.lean | 2 -- 2 files changed, 4 deletions(-) diff --git a/Iris/Iris/Instances/Lib/CInvariants.lean b/Iris/Iris/Instances/Lib/CInvariants.lean index 69f04fdfb..ff321c0a5 100644 --- a/Iris/Iris/Instances/Lib/CInvariants.lean +++ b/Iris/Iris/Instances/Lib/CInvariants.lean @@ -235,8 +235,6 @@ theorem acc_strong (E : CoPset) (N : Namespace) (γ : GName) (p : Qp) (P : IProp · iexfalso iapply own_one_l $$ Hown' Hown --- FIXME: Args here should be implicit - @[rocq_alias cinv_acc] theorem acc {E : CoPset} {N : Namespace} {γ : GName} {p : Qp} {P : IProp GF} (Hsub : ↑N ⊆ E) : diff --git a/Iris/Iris/Instances/Lib/Invariants.lean b/Iris/Iris/Instances/Lib/Invariants.lean index 818997af6..66c14409a 100644 --- a/Iris/Iris/Instances/Lib/Invariants.lean +++ b/Iris/Iris/Instances/Lib/Invariants.lean @@ -230,8 +230,6 @@ open Iris Std LawfulSet variable {GF : BundledGFunctors} [InvGS_gen hlc GF] --- FIXME: Arguments E, N and P in this section should be made implicit - @[rocq_alias inv_acc] theorem inv_acc {E : CoPset} {N : Namespace} {P : IProp GF} (Hsub : ↑N ⊆ E) : ⊢ inv N P ={E, E \ ↑N}=∗ ▷ P ∗ (▷ P ={E \ ↑N, E}=∗ True) := by From 0388296efcd35a97bff8190c5d934b9696ee371e Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Wed, 1 Jul 2026 16:31:29 -0700 Subject: [PATCH 14/33] cleanup --- Iris/Iris/HeapLang/Notation.lean | 22 ++++ Iris/Iris/HeapLang/PrimitiveLaws.lean | 150 +++++++++---------------- Iris/Iris/HeapLang/Syntax.lean | 5 +- Iris/Iris/Tests/HeapLang/Notation.lean | 19 ++++ 4 files changed, 101 insertions(+), 95 deletions(-) diff --git a/Iris/Iris/HeapLang/Notation.lean b/Iris/Iris/HeapLang/Notation.lean index b576b79f5..9aa141c24 100644 --- a/Iris/Iris/HeapLang/Notation.lean +++ b/Iris/Iris/HeapLang/Notation.lean @@ -159,6 +159,11 @@ syntax:100 "fork(" hl_exp ")" : hl_exp /-- assert -/ syntax:100 "assert(" hl_exp ")" : hl_exp +/-- prophecy operations -/ +syntax:100 "newProph()" : hl_exp +syntax:100 "resolve(" hl_exp ", " hl_exp ", " hl_exp ")" : hl_exp +syntax:100 "resolveProph(" hl_exp ", " hl_exp ")" : hl_exp + /-- holes -/ syntax "_" : hl_exp @@ -265,6 +270,9 @@ macro_rules | `(hl(faa($e1, $e2))) => `(Exp.faa hl($e1) hl($e2)) | `(hl(fork($e1))) => `(Exp.fork hl($e1)) | `(hl(assert($e1))) => `(Exp.assert hl($e1)) + | `(hl(newProph())) => `(Exp.newProph) + | `(hl(resolve($e1, $e2, $e3))) => `(Exp.resolve hl($e1) hl($e2) hl($e3)) + | `(hl(resolveProph($e1, $e2))) => `(hl(resolve(#(); #(), $e1, $e2))) /-- delaborating Binders -/ @[app_unexpander Binder.anon] @@ -477,3 +485,17 @@ def unexpFork : Unexpander def unexpAssert : Unexpander | `($_ $e1) => do `(hl(assert($(← unpackHLExp e1)))) | _ => throw () + +@[app_unexpander Exp.newProph] +def unexpNewProph : Unexpander + | `($_) => `(hl(newProph())) + +partial def unexpResolveProph : Term → UnexpandM Term + | `(hl(resolve(#(); #(), $e1, $e2))) => do `(hl(resolveProph($e1, $e2))) + | x => return x + +@[app_unexpander Exp.resolve] +def unexpResolve : Unexpander + | `($_ $e1 $e2 $e3) => do + unexpResolveProph $ ← `(hl(resolve($(← unpackHLExp e1), $(← unpackHLExp e2), $(← unpackHLExp e3)))) + | _ => throw () diff --git a/Iris/Iris/HeapLang/PrimitiveLaws.lean b/Iris/Iris/HeapLang/PrimitiveLaws.lean index 1f18c93e9..2600706a5 100644 --- a/Iris/Iris/HeapLang/PrimitiveLaws.lean +++ b/Iris/Iris/HeapLang/PrimitiveLaws.lean @@ -39,13 +39,11 @@ attribute [reducible, instance] HeapLangGS.heap attribute [reducible, instance] HeapLangGS.proph instance HeapLangState [HeapLangGS hlc GF] : StateInterp State Observation GF where - stateInterp σ _ κs _ := iprop( - genHeapInterp (GF := GF) (H := HeapF) σ.heap ∗ - prophMapInterp (GF := GF) (H := ProphMapF) κs σ.usedProphId) + stateInterp σ _ κs _ := iprop% genHeapInterp σ.heap ∗ prophMapInterp κs σ.usedProphId theorem stateInterp_split [HeapLangGS hlc GF] (σ : State) (ns : Nat) (κs : List Observation) (nt : Nat) : iprop% - stateInterp (GF := GF) σ ns κs nt ⊣⊢ genHeapInterp σ.heap ∗ prophMapInterp κs σ.usedProphId := + stateInterp σ ns κs nt ⊣⊢ genHeapInterp σ.heap ∗ prophMapInterp κs σ.usedProphId := .rfl theorem prophMapInterp_nil_append [HeapLangGS hlc GF] (κs : List Observation) @@ -174,8 +172,6 @@ theorem wp_fork {e : Exp} : · iapply BI.BigSepL.bigSepL_singleton iframe Hwp -/-- Fancy-update-flavoured fork rule. Mirrors `wp_fork_fupd` in -`case_studies/heaplang/fixes.v`. -/ theorem wp_fork_fupd {e : Exp} : (▷ |={E}=> (WP e @ s; ⊤ {{ _v, True }} ∗ Φ (hl_val(#())))) ⊢ WP hl(fork(&e)) @ s; E {{ Φ }} := by @@ -188,7 +184,7 @@ theorem wp_fork_fupd {e : Exp} : isplitr · ipureintro cases s <;> simp only [Stuckness.MaybeReducible] - exact (primStep_reducible_of_baseStep_reducible Hred) + exact primStep_reducible_of_baseStep_reducible Hred iintro !> %e₂ %σ₂ %eₜ %Heq Hcr cases baseStep_of_primStep_of_baseStep_reducible Hred Heq ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph @@ -405,9 +401,7 @@ theorem wp_cmpXchg_true {l : Loc} {v' : Val} {e1 : Exp} {v1 : Val} {e2 : Exp} {v -- TODO: Here theorem wp_free {l : Loc} {v : Val} : - ▷ (l ↦ some v) - ⊢@{IProp GF} WP (Exp.free (.val (.lit (.loc l)))) @ s; E - {{ v'', ⌜v'' = Val.lit BaseLit.unit⌝ ∗ (l ↦ (none : Option Val)) }} := by + ▷ (l ↦ some v) ⊢ WP hl(free(#l)) @ s; E {{ v'', ⌜v'' = hl_val(#())⌝ ∗ l ↦ none }} := by iintro >Hpt iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> @@ -415,33 +409,33 @@ theorem wp_free {l : Loc} {v : Val} : ihave %Hpt : ⌜σ₁.get? l = .some (.some v)⌝ $$ [Hσ Hpt] · icases genHeap_valid $$ [$Hσ $Hpt] with >%Heq' itrivial - ihave %Hred : ⌜BaseStep.Reducible (Exp.free (.val (.lit (.loc l))), σ₁)⌝ $$ [] + ihave %Hred : ⌜BaseStep.Reducible (hl(free(#l)), σ₁)⌝ $$ [] · ipureintro - exists [], (.val (.lit .unit)), (σ₁.initHeap l 1 none), [] - refine BaseStep.freeS l v _ ?_; grind + exists [], hl_val(#()), σ₁.initHeap l 1 none, [] + refine BaseStep.freeS l v _ ?_ + grind isplitr · ipureintro cases s <;> simp only [Stuckness.MaybeReducible] exact primStep_reducible_of_baseStep_reducible Hred iintro !> %e₂ %σ₂ %eₜ %Heq Hcr - cases baseStep_of_primStep_of_baseStep_reducible Hred Heq - rename_i v'' H + rcases baseStep_of_primStep_of_baseStep_reducible Hred Heq with ⟨v'', H⟩ ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph simp only [stateInterp, Int.toNat_one, List.range_one, List.foldl_cons, Int.cast_ofNat_Int, List.foldl_nil, Algebra.BigOpL.bigOpL_nil] rw [show l + (0 : Int) = l by cases l; simp only [HAdd.hAdd, Loc.mk.injEq]; grind] - imod genHeap_update (v₂ := (none : Option Val)) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ + imod genHeap_update (v₂ := none) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ imodintro iframe Hσ Hproph isplit <;> try itrivial - iexists .lit .unit + iexists hl_val(#()) iframe Hpt - ipureintro; simp [toVal]; rfl + ipureintro + simp [toVal] + rfl theorem wp_xchg {l : Loc} {v w : Val} : - ▷ (l ↦ some v) - ⊢@{IProp GF} WP (Exp.xchg (.val (.lit (.loc l))) (.val w)) @ s; E - {{ v'', ⌜v'' = v⌝ ∗ (l ↦ some w) }} := by + ▷ (l ↦ some v) ⊢ WP hl(xchg(#l, &w)) @ s; E {{ v'', ⌜v'' = v⌝ ∗ l ↦ some w }} := by iintro >Hpt iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> @@ -449,26 +443,25 @@ theorem wp_xchg {l : Loc} {v w : Val} : ihave %Hpt : ⌜σ₁.get? l = .some (.some v)⌝ $$ [Hσ Hpt] · icases genHeap_valid $$ [$Hσ $Hpt] with >%Heq' itrivial - ihave %Hred : ⌜BaseStep.Reducible (Exp.xchg (.val (.lit (.loc l))) (.val w), σ₁)⌝ $$ [] + ihave %Hred : ⌜BaseStep.Reducible (hl(xchg(#l, &w)), σ₁)⌝ $$ [] · ipureintro - exists [], (.val v), (σ₁.initHeap l 1 w), [] + exists [], .val v, (σ₁.initHeap l 1 w), [] refine BaseStep.xchgS l v w _ ?_; grind isplitr · ipureintro cases s <;> simp only [Stuckness.MaybeReducible] exact primStep_reducible_of_baseStep_reducible Hred iintro !> %e₂ %σ₂ %eₜ %Heq Hcr - cases baseStep_of_primStep_of_baseStep_reducible Hred Heq + rcases baseStep_of_primStep_of_baseStep_reducible Hred Heq rename_i v1' H obtain rfl : v = v1' := by - rw [Hpt] at H - simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at H + simp only [Hpt, Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at H exact H ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph simp only [stateInterp, Int.toNat_one, List.range_one, List.foldl_cons, Int.cast_ofNat_Int, List.foldl_nil, Algebra.BigOpL.bigOpL_nil] rw [show l + (0 : Int) = l by cases l; simp only [HAdd.hAdd, Loc.mk.injEq]; grind] - imod genHeap_update (v₂ := (some w : Option Val)) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ + imod genHeap_update (v₂ := some w) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ imodintro iframe Hσ Hproph isplit <;> try itrivial @@ -477,9 +470,8 @@ theorem wp_xchg {l : Loc} {v w : Val} : ipureintro; simp [toVal]; rfl theorem wp_faa {l : Loc} {i1 i2 : Int} : - ▷ (l ↦ some (Val.lit (.int i1))) - ⊢@{IProp GF} WP (Exp.faa (.val (.lit (.loc l))) (.val (.lit (.int i2)))) @ s; E - {{ v'', ⌜v'' = Val.lit (.int i1)⌝ ∗ (l ↦ some (Val.lit (.int (i1 + i2)))) }} := by + ▷ (l ↦ some hl_val(#i1)) + ⊢ WP hl(faa(#l, #i2)) @ s; E {{ v'', ⌜v'' = hl_val(#i1)⌝ ∗ l ↦ some hl_val(#(i1 + i2)) }} := by iintro >Hpt iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> @@ -487,10 +479,9 @@ theorem wp_faa {l : Loc} {i1 i2 : Int} : ihave %Hpt : ⌜σ₁.get? l = .some (.some (Val.lit (.int i1)))⌝ $$ [Hσ Hpt] · icases genHeap_valid $$ [$Hσ $Hpt] with >%Heq' itrivial - ihave %Hred : - ⌜BaseStep.Reducible (Exp.faa (.val (.lit (.loc l))) (.val (.lit (.int i2))), σ₁)⌝ $$ [] + ihave %Hred : ⌜BaseStep.Reducible (hl(faa(#l, #i2)), σ₁)⌝ $$ [] · ipureintro - exists [], (.val (.lit (.int i1))), (σ₁.initHeap l 1 (some (.lit (.int (i1 + i2))))), [] + exists [], (.val (.lit (.int i1))), (σ₁.initHeap l 1 (some hl_val(#(i1 + i2)))), [] refine BaseStep.faaS l i1 i2 _ ?_; grind isplitr · ipureintro @@ -500,14 +491,13 @@ theorem wp_faa {l : Loc} {i1 i2 : Int} : cases baseStep_of_primStep_of_baseStep_reducible Hred Heq rename_i i1' H obtain rfl : i1 = i1' := by - rw [Hpt] at H - simp only [Option.some.injEq, Val.lit.injEq, BaseLit.int.injEq] at H + simp only [Hpt, Option.some.injEq, Val.lit.injEq, BaseLit.int.injEq] at H exact H ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph simp only [stateInterp, Int.toNat_one, List.range_one, List.foldl_cons, Int.cast_ofNat_Int, List.foldl_nil, Algebra.BigOpL.bigOpL_nil] rw [show l + (0 : Int) = l by cases l; simp only [HAdd.hAdd, Loc.mk.injEq]; grind] - imod genHeap_update (v₂ := (some (Val.lit (.int (i1 + i2))) : Option Val)) $$ [$Hσ $Hpt] + imod genHeap_update (v₂ := some hl_val(#(i1 + i2))) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ imodintro iframe Hσ Hproph @@ -518,16 +508,12 @@ theorem wp_faa {l : Loc} {i1 i2 : Int} : theorem usedProph_insert_eq {ps : Std.ExtTreeSet ProphId compare} {p : ProphId} : ps.insert p = ({p} ∪ ps : Std.ExtTreeSet ProphId compare) := by - apply Std.ExtTreeSet.ext_mem - intro x - rw [Std.ExtTreeSet.mem_insert, Std.ExtTreeSet.mem_union_iff, - Iris.Std.LawfulSet.mem_singleton, Std.LawfulEqCmp.compare_eq_iff_eq] + refine Std.ExtTreeSet.ext_mem fun x => ?_ + rw [Std.ExtTreeSet.mem_insert, Std.ExtTreeSet.mem_union_iff, Iris.Std.LawfulSet.mem_singleton] grind theorem wp_new_proph : - ⊢ WP (Exp.newProph : Exp) @ s; E - {{ v, ∃ p : ProphId, ∃ pvs : List (Val × Val), - ⌜v = .lit (.prophecy p)⌝ ∗ proph p pvs }} := by + ⊢ WP hl(newProph()) @ s; E {{ v, ∃ p, ∃ pvs, ⌜v = .lit (.prophecy p)⌝ ∗ proph p pvs }} := by iapply wp_lift_atomic_step rfl iintro %σ₁ %ns %obs %obs' %nt Hσ !> icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ @@ -546,14 +532,12 @@ theorem wp_new_proph : ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph have Hp'_mem : p' ∉ σ₁.usedProphId := fun hmem => Hp' (Std.ExtTreeSet.mem_iff_contains.symm.mp hmem) - imod (ProphMap.new_proph p' σ₁.usedProphId obs' Hp'_mem) $$ Hproph - with ⟨Hproph', Htok⟩ + imod ProphMap.new_proph p' σ₁.usedProphId obs' Hp'_mem $$ Hproph with ⟨Hproph', Htok⟩ imodintro simp only [stateInterp] iframe Hσ isplitl [Hproph'] - · rw [show ({p'} ∪ σ₁.usedProphId : Std.ExtTreeSet ProphId compare) - = σ₁.usedProphId.insert p' from usedProph_insert_eq.symm] + · rw [show {p'} ∪ σ₁.usedProphId = σ₁.usedProphId.insert p' from usedProph_insert_eq.symm] iexact Hproph' isplitl [Htok] · iexists hl_val(#(BaseLit.prophecy p')) @@ -564,32 +548,24 @@ theorem wp_new_proph : ipureintro; rfl · simp only [Algebra.BigOpL.bigOpL_nil]; itrivial -/-- `Resolve e (Val (LitProphecy p)) (Val w)` lifts a WP for the inner expression -`e` through the `Resolve` wrapper, consuming the front observation `(v_e, w)` -from the prophecy `p`. The inner WP is allowed to use the prophecy token -`proph p pvs` while reducing `e`; on completion the postcondition is closed -under reattaching the front observation. Mirrors `wp_resolve_strong` in Rocq -heap_lang's `primitive_laws.v`. -/ theorem wp_resolve_strong {e : Exp} {p : ProphId} {w : Val} {pvs : List (Val × Val)} - (hatom : Language.Atomic (State := State) (Obs := Observation) - Language.Atomicity.StronglyAtomic e) - (hne : toVal e = none) : + (hatom : Language.Atomic Language.Atomicity.StronglyAtomic e) (hne : toVal e = none) : proph p pvs -∗ (proph p pvs -∗ WP e @ s; E {{ v_e, ∃ pvs', proph p pvs' ∗ ∀ pvs'', ⌜pvs' = (v_e, w) :: pvs''⌝ -∗ proph p pvs'' -∗ Φ v_e }}) -∗ - WP (Exp.resolve e (.val (.lit (.prophecy p))) (.val w)) @ s; E {{ Φ }} := by + WP hl(resolve(&e, v(#p), v(&w))) @ s; E {{ Φ }} := by iintro Hp HWPe iapply wp_lift_step_fupdN rfl iintro %σ₁ %ns %obs %obs' %nt Hσ icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hheap, Hpmap⟩ - icases ProphMap.agree (obs ++ obs') σ₁.usedProphId p pvs $$ [$Hpmap $Hp] - with %Hagree - have Hp_mem : p ∈ σ₁.usedProphId := Hagree.1 - have hp_contains : σ₁.usedProphId.contains p := - Std.ExtTreeSet.mem_iff_contains.mp Hp_mem + icases ProphMap.agree (obs ++ obs') σ₁.usedProphId p pvs $$ [$Hpmap $Hp] with %Hagree + have hredR : Stuckness.MaybeReducible s (e, σ₁) → + Stuckness.MaybeReducible s (hl(resolve(&e, v(#p), v(&w))), σ₁) := fun Hred_e => by + cases s <;> simp only [Stuckness.MaybeReducible] at Hred_e ⊢ + refine prim_step_reducible_resolve ?_ Hred_e + exact Std.ExtTreeSet.mem_iff_contains.mp Hagree.1 ihave HWPe : iprop(WP e @ s; E {{ v_e, ∃ pvs', proph p pvs' ∗ - ∀ pvs'', ⌜pvs' = (v_e, w) :: pvs''⌝ -∗ proph p pvs'' -∗ Φ v_e }}) - $$ [Hp HWPe] + ∀ pvs'', ⌜pvs' = (v_e, w) :: pvs''⌝ -∗ proph p pvs'' -∗ Φ v_e }}) $$ [Hp HWPe] · iapply HWPe; iexact Hp ihave HWPe := (show iprop(WP e @ s; E {{ v_e, ∃ pvs', proph p pvs' ∗ ∀ pvs'', ⌜pvs' = (v_e, w) :: pvs''⌝ -∗ proph p pvs'' -∗ Φ v_e }}) ⊢ _ @@ -597,56 +573,42 @@ theorem wp_resolve_strong {e : Exp} {p : ProphId} {w : Val} {pvs : List (Val × cases obs using List.reverseRec with | nil => ihave Hσ_e : iprop(stateInterp σ₁ ns ([] ++ obs') nt) $$ [Hheap Hpmap] - · iapply (stateInterp_split σ₁ ns ([] ++ obs') nt).mpr - iframe Hheap - iexact Hpmap - imod HWPe $$ %_ %_ %_ %_ %_ Hσ_e with ⟨%Hred_e, HWPe⟩ + · iapply (stateInterp_split σ₁ ns ([] ++ obs') nt).mpr; iframe Hheap; iexact Hpmap + imod HWPe $$ %_ %_ %_ %_ %_ Hσ_e with ⟨%Hred_e, _⟩ imodintro isplitr - · ipureintro - cases s <;> simp only [Stuckness.MaybeReducible] - exact prim_step_reducible_resolve hp_contains Hred_e - iintro %e₂ %σ₂ %eₜ %Hstep _Hcred + · ipureintro; exact hredR Hred_e + iintro %e₂ %σ₂ %eₜ %Hstep _ exfalso - obtain ⟨κ_inner, _, hκ_eq, _, _⟩ := step_resolve_decompose Hstep + obtain ⟨_, _, hκ_eq, _, _⟩ := step_resolve_decompose Hstep exact List.cons_ne_nil _ _ (List.append_eq_nil_iff.mp hκ_eq.symm).2 - | append_singleton init lastObs _ => + | append_singleton init lastObs ih => + clear ih have hassoc : (init ++ [lastObs]) ++ obs' = init ++ (lastObs :: obs') := by simp - ihave Hσ_e : iprop(stateInterp σ₁ ns (init ++ (lastObs :: obs')) nt) - $$ [Hheap Hpmap] + ihave Hσ_e : iprop(stateInterp σ₁ ns (init ++ (lastObs :: obs')) nt) $$ [Hheap Hpmap] · iapply (stateInterp_split σ₁ ns (init ++ (lastObs :: obs')) nt).mpr - iframe Hheap - rw [← hassoc]; iexact Hpmap + iframe Hheap; rw [← hassoc]; iexact Hpmap imod HWPe $$ %_ %_ %_ %_ %_ Hσ_e with ⟨%Hred_e, HWPe⟩ imodintro isplitr - · ipureintro - cases s <;> simp only [Stuckness.MaybeReducible] - exact prim_step_reducible_resolve hp_contains Hred_e + · ipureintro; exact hredR Hred_e iintro %e₂ %σ₂ %eₜ %Hstep Hcred - obtain ⟨κ_inner, v_inner, hκ_eq, he₂_eq, Hbase_e⟩ := step_resolve_decompose Hstep - have h := congrArg List.reverse hκ_eq - simp at h - obtain ⟨hκ_eq_init, hlast_eq⟩ := h - subst hκ_eq_init; subst hlast_eq; subst he₂_eq - have Hprim_e : PrimStep.primStep (e, σ₁) init (Exp.val v_inner, σ₂, eₜ) := - EctxLanguage.primStep_of_baseStep Hbase_e - ispecialize HWPe $$ %_ %_ %_ %Hprim_e Hcred + obtain ⟨κ_inner, v_inner, hκ_eq, rfl, Hbase_e⟩ := step_resolve_decompose Hstep + obtain ⟨rfl, rfl⟩ := (by simpa using congrArg List.reverse hκ_eq : lastObs = _ ∧ init = κ_inner) + ispecialize HWPe $$ %_ %_ %_ %(EctxLanguage.primStep_of_baseStep Hbase_e) Hcred iapply step_fupdN_wand $$ HWPe iintro HWPe imod HWPe with ⟨Hσ_post, HWPval, Hefs⟩ icases (stateInterp_split σ₂ (ns + 1) ((p, (v_inner, w)) :: obs') (nt + eₜ.length)).mp $$ Hσ_post with ⟨Hheap_e, Hpmap_e⟩ - ihave HWPval := wp_value_fupd'.mp $$ HWPval - imod HWPval with ⟨%pvs', Hele, HΦ⟩ + imod wp_value_fupd'.mp $$ HWPval with ⟨%pvs', Hele, HΦ⟩ icombine Hpmap_e Hele as Hcomb - imod (ProphMap.resolve_proph (V := Val × Val) (H := ProphMapF) - p (v_inner, w) obs' σ₂.usedProphId pvs') $$ Hcomb + imod (ProphMap.resolve_proph p (v_inner, w) obs' σ₂.usedProphId pvs') $$ Hcomb with ⟨%pvs'', %hpvs'_eq, Hpmap_e, Hele⟩ imodintro + iframe isplitl [Hheap_e Hpmap_e] · iapply (stateInterp_split σ₂ (ns + 1) obs' (nt + eₜ.length)).mpr $$ [$] - iframe Hefs iapply wp_value' iapply HΦ $$ %pvs'' %hpvs'_eq Hele diff --git a/Iris/Iris/HeapLang/Syntax.lean b/Iris/Iris/HeapLang/Syntax.lean index 66a3aff68..b39952086 100644 --- a/Iris/Iris/HeapLang/Syntax.lean +++ b/Iris/Iris/HeapLang/Syntax.lean @@ -179,10 +179,13 @@ instance : Coe Bool BaseLit where instance : Coe Loc BaseLit where coe l := .loc l +instance : Coe ProphId BaseLit where + coe p := .prophecy p + instance : Coe Unit BaseLit where coe _ := .unit -attribute [coe] BaseLit.int BaseLit.bool BaseLit.loc +attribute [coe] BaseLit.int BaseLit.bool BaseLit.loc BaseLit.prophecy def Exp.substStr (x : String) (v : Val) (e : Exp) : Exp := match e with diff --git a/Iris/Iris/Tests/HeapLang/Notation.lean b/Iris/Iris/Tests/HeapLang/Notation.lean index a3dc86dda..02fad9f62 100644 --- a/Iris/Iris/Tests/HeapLang/Notation.lean +++ b/Iris/Iris/Tests/HeapLang/Notation.lean @@ -310,6 +310,25 @@ info: (Exp.rec_ Binder.anon (Binder.named "x") set_option pp.explicit true in #check hl(let x := ref(#0); let y := allocn(!x, #0); x ← !x + #1; fork(cmpXchg(x, #1, #2); xchg(x, #2); faa(x, #4)); assert(!x = #0); free(x)) +-- prophecy notation +variable (p : ProphId) (w : Val) + +/-- info: hl(newProph()) : Exp -/ +#guard_msgs in +#check hl(newProph()) + +/-- info: hl(resolve(newProph(), #p, v(&w))) : Exp -/ +#guard_msgs in +#check hl(resolve(newProph(), v(#p), v(&w))) + +/-- info: hl(resolveProph(#p, v(&w))) : Exp -/ +#guard_msgs in +#check hl(resolveProph(v(#p), v(&w))) + +/-- info: hl_val(#p) : Val -/ +#guard_msgs in +#check hl_val(#p) + end test end Iris.Tests.HeapLang From fc363652f724a9e579aa82fed5f4ce58eb58695e Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Thu, 18 Jun 2026 16:13:21 -0400 Subject: [PATCH 15/33] upload files from completeness branch --- .../Iris/ProgramLogic/AbstractWeakestPre.lean | 237 ++++++++++++++++++ 1 file changed, 237 insertions(+) create mode 100644 Iris/Iris/ProgramLogic/AbstractWeakestPre.lean diff --git a/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean b/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean new file mode 100644 index 000000000..c26b3001f --- /dev/null +++ b/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean @@ -0,0 +1,237 @@ +/- +Copyright (c) 2026 Markus de Medeiros. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import Iris.Algebra +public import Iris.Instances.Lib.FUpd +public import Iris.Instances.Lib.Invariants +public import Iris.BI +public import Iris.BI.WeakestPre +public import Iris.ProofMode +public import Iris.ProgramLogic.Language +public import Iris.ProgramLogic.EctxLanguage +public import Iris.Std.CoPset +public import Iris.ProgramLogic.WeakestPre + +namespace Iris + +open ProgramLogic Language Language.Notation Std + +@[expose] public section + +abbrev AbstractWP (Expr Val : Type _) (GF : BundledGFunctors) := + CoPset → Expr → (Val → IProp GF) → IProp GF + +section AbstractWP + +variable {Expr State Obs Val : Type _} [Λ : Language Expr State Obs Val] +variable {GF : BundledGFunctors} {HLC : HasLC} [IrisGS_gen HLC Expr GF] + +class InvOpenAbstractWP (wp : AbstractWP Expr Val GF) where + inv_open_maybe (e : Expr) (E₁ E₂) Φ (Hsub : E₂ ⊆ E₁) : + (|={E₁, E₂}=> + (∃ K e', ⌜Context K⌝ ∗ ⌜e = K e'⌝ ∗ ⌜Atomic .WeaklyAtomic e'⌝ + ∗ wp E₂ e' (fun v' => iprop% |={E₂, E₁}=> wp E₁ (K v') Φ)) ∨ + (|={E₂, E₁}=> wp E₁ e Φ)) + ⊢ wp E₁ e Φ + +class LawfulAbstractWP (wp : AbstractWP Expr Val GF) where + fupd_wp : (|={E}=> wp E e Φ) ⊢ wp E e Φ + wp_fupd {Φ : Val → IProp GF} : (wp E e (iprop% |={E}=> Φ ·)) ⊢ wp E e Φ + wp_value {v : Val} : wp E v Φ ⊣⊢ |={E}=> Φ v + wp_wand : wp E e Φ ⊢ (∀ v, Φ v -∗ Ψ v) -∗ wp E e Ψ + wp_atomic {e : Expr} (Hatom : Atomic .WeaklyAtomic e) : + (|={E₁, E₂}=> wp E₂ e (iprop% |={E₂, E₁}=> Φ ·)) ⊢ wp E₁ e Φ + +class BindAbstractWP (wp : AbstractWP Expr Val GF) extends LawfulAbstractWP wp where + wp_bind [Context K] : wp E e (fun (v : Val) => iprop% wp E (K v) Φ) ⊣⊢ wp E (K e) Φ + +end AbstractWP + +noncomputable section EctxLanguage + +open Classical + +variable {Expr State Obs Val Ectx : Type _} [EctxLanguage Expr Ectx State Obs Val] +variable {GF : BundledGFunctors} {HLC : HasLC} [IrisGS_gen HLC Expr GF] +variable {wp : AbstractWP Expr Val GF} [IWP : BindAbstractWP wp] + +theorem inv_open_maybe_ectxlang {e : Expr} {E₁ E₂ : CoPset} {Φ : Val → IProp GF} + (Hsub : E₂ ⊆ E₁) (Hred : ∃ σ, PrimStep.Reducible (e, σ)) : + (|={E₁, E₂}=> + (∃ (K : Ectx) (e' : Expr), + ⌜e = fill K e'⌝ ∗ ⌜Atomic .WeaklyAtomic e'⌝ ∗ ⌜∃ σ, BaseStep.Reducible (e', σ)⌝ + ∗ wp E₂ e' (fun v => iprop% |={E₂, E₁}=> wp E₁ (fill K v) Φ)) ∨ + (|={E₂, E₁}=> wp E₁ e Φ)) + ⊢ wp E₁ e Φ := by + iintro H + obtain ⟨σ, ⟨obs, e', σ', eₜ, @⟨e₁', e₂', K, Hbase⟩⟩⟩ := Hred + iapply (IWP.wp_bind (K := fill K)).mp + by_cases Atomic .WeaklyAtomic e₁' + next Hatomic => + iapply IWP.toLawfulAbstractWP.wp_atomic Hatomic (E₂ := E₂) + imod H with (⟨%K₁, %e', %Hf, %Hat, %Hred, Hwp⟩| H') + · imodintro + obtain ⟨σ'', Hred⟩ := Hred + have Hred' : BaseStep.Reducible (e₁', σ) := ⟨_, _, _, _, Hbase⟩ + obtain ⟨rfl, rfl⟩ := EctxLanguage.base_redex_unique _ _ _ _ σ _ Hf Hred' Hred + simp only [← EvContext.fill_comp, EvContext.fill_empty] + iapply IWP.toLawfulAbstractWP.wp_wand $$ Hwp + iintro %v >Hwp2 + itrivial + · imodintro + iapply IWP.toLawfulAbstractWP.wp_atomic Hatomic (E₂ := E₁) + imod H' + imodintro + ihave H' := (IWP.wp_bind (K := fill K)).mpr $$ H' + iapply IWP.wp_wand $$ H' [] + iintro %v Hwp + iapply fupd_mask_intro_subseteq Hsub $$ [$] + next Hnonatomic => + iapply IWP.toLawfulAbstractWP.fupd_wp + imod H with (⟨%K₁, %e', %Hf, %Hat, %Hred, Hwp⟩| H') + · obtain ⟨σ'', Hred⟩ := Hred + have Hred' : BaseStep.Reducible (e₁', σ) := ⟨_, _, _, _, Hbase⟩ + obtain ⟨_, rfl⟩ := EctxLanguage.base_redex_unique _ _ _ _ σ _ Hf Hred' Hred + exact Hnonatomic Hat |>.elim + · imod H' + ihave H' := (IWP.wp_bind (K := fill K)).mpr $$ H' + itrivial + +theorem inv_open_maybe_ectxlang_inv (e : Expr) (E : CoPset) (N : Namespace) + (P : IProp GF) (Φ : Val → IProp GF) + (Hsub : ↑N ⊆ E) (Hred : ∃ σ, PrimStep.Reducible (e, σ)) : + (inv N P ∗ + ((▷ P) ={E \ ↑N}=∗ + (∃ (K : Ectx) (e' : Expr), + ⌜e = fill K e'⌝ ∗ ⌜Atomic .WeaklyAtomic e'⌝ ∗ ⌜∃ σ, BaseStep.Reducible (e', σ)⌝ + ∗ wp (E \ ↑N) e' (fun v => iprop% P ∗ wp E (fill K v) Φ)) ∨ + (P ∗ wp E e Φ))) + ⊢ wp E e Φ := by + iintro ⟨#Hinv, H⟩ + iapply inv_open_maybe_ectxlang (E₂ := E \ nclose N) LawfulSet.diff_subset_left Hred + imod inv_acc _ _ _ Hsub $$ Hinv with ⟨HP, Hclose⟩ + imod H $$ HP with (⟨%K, %e', %He, %Hat, %Hred, H⟩|⟨HP, H⟩) + · imodintro + ileft + iexists K + iexists e' + iframe %He %Hat %Hred + iapply IWP.wp_wand $$ H + iintro %v ⟨HP, Hwp⟩ + imod Hclose $$ HP with - + itrivial + · iright + imod Hclose $$ HP with - + iapply fupd_mask_intro_subseteq LawfulSet.diff_subset_left $$ [$] + +end EctxLanguage + +/-! ### Instances of the abstract classes for iris-lean's real `Wp`. -/ + +section IrisWP + +variable {Expr State Obs Val : Type _} [Language Expr State Obs Val] +variable {GF : BundledGFunctors} {HLC : HasLC} [IrisGS_gen HLC Expr GF] + +/-- iris-lean's standard `WP` satisfies the abstract 5-law class. -/ +instance WP_lawful_abstract : + LawfulAbstractWP (Expr := Expr) (Val := Val) + (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where + fupd_wp := fupd_wp + wp_fupd := wp_fupd _ _ _ _ + wp_value := wp_value_fupd' + wp_wand := wp_wand + wp_atomic _ := wp_atomic + +/-- iris-lean's standard `WP` also satisfies the bind class for ectx +languages. -/ +instance WP_bind_abstract : + BindAbstractWP (Expr := Expr) (Val := Val) + (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where + wp_bind := ⟨wp_bind _, wp_bind_inv _⟩ + +theorem wp_inv_open_maybe_of_not_val {e : Expr} {E₁ E₂ : CoPset} {Φ : Val → IProp GF} + (Hnv : ToVal.toVal e = none) : + (|={E₁, E₂}=> + (∃ K e', ⌜Context K⌝ ∗ ⌜e = K e'⌝ ∗ ⌜Atomic .WeaklyAtomic e'⌝ ∗ + Wp.wp (Val := Val) Stuckness.NotStuck E₂ e' + (fun v' => iprop% |={E₂, E₁}=> Wp.wp (Val := Val) Stuckness.NotStuck E₁ (K v') Φ)) ∨ + (|={E₂, E₁}=> Wp.wp (Val := Val) Stuckness.NotStuck E₁ e Φ)) + ⊢ Wp.wp (Val := Val) Stuckness.NotStuck E₁ e Φ := by + iintro H + rw [IProp.ext wp_unfold, wp.pre, Hnv] + simp only + imod H with (⟨%K, %e', %Hctx, %Haux, %hato, Hwp⟩| >$) + subst Haux + -- FIXME: Why does this exit the proofmode? + rw [IProp.ext wp_unfold, wp.pre]; iintro Hwp + rcases He' : toVal e' with (_|v'); rotate_left + · imod Hwp; imod Hwp + rw [IProp.ext wp_unfold, wp.pre] + simp [coe_of_toVal_eq_some He', Hnv] + · dsimp only + iintro %σ %n %κ %κs %n₂ Hσ + imod Hwp $$ Hσ with ⟨%Hred, Hc⟩ + imodintro + have aux := Context.reducible_fill K Hred + iframe %aux; clear aux + iintro %e₂ %σ₂ %efs %H Hlc + obtain ⟨e₂, rfl, Hprim⟩ := Context.primStep_fill_inv (toVal_none_of_reducible Hred) H + ispecialize Hc $$ %e₂ %σ₂ %efs %Hprim Hlc + iapply step_fupdN_mono $$ Hc + iintro Hc + imod Hc with ⟨Hst, Hwp, $⟩ + replace Hprim : PrimStep.Irreducible (e₂, σ₂) := hato.atomic Hprim + -- FIXME: Why does this exit the proofmode? + rw [IProp.ext wp_unfold, wp.pre] + iintro ⟨Hst, Hwp⟩ + rcases He₂' : toVal e₂ with (_|v₂) <;> dsimp only + · imod Hwp $$ %_ %_ %κs %.nil [Hst] with ⟨%Hredu, H⟩ + · rw [List.append_nil κs]; iframe + grind + · imod Hwp with >Hwp + rw [coe_of_toVal_eq_some He₂'] + iframe + +theorem wp_inv_open_maybe (e : Expr) (E₁ E₂ : CoPset) (Φ : Val → IProp GF) : + (|={E₁, E₂}=> + (∃ K e', ⌜Context K⌝ ∗ ⌜e = K e'⌝ ∗ ⌜Atomic .WeaklyAtomic e'⌝ ∗ + Wp.wp (PROP := IProp GF) (Val := Val) Stuckness.NotStuck E₂ e' + (fun v' => iprop% |={E₂, E₁}=> Wp.wp (Val := Val) Stuckness.NotStuck E₁ (K v') Φ)) ∨ + (|={E₂, E₁}=> Wp.wp (Val := Val) Stuckness.NotStuck E₁ e Φ)) + ⊢ Wp.wp (Val := Val) Stuckness.NotStuck E₁ e Φ := by + iintro H + rcases Hv : toVal e with (_|v); + iapply wp_inv_open_maybe_of_not_val Hv $$ [$] + rw [← coe_of_toVal_eq_some Hv] + iapply wp_atomic (E2 := E₂) + imod H with (⟨%K, %e', %Hctx, %He, %Hato, H⟩| H); + · rcases Hv' : toVal e' with (_|v') + · exfalso + have h1 := Hctx.toVal_eq_none_fill Hv' + rw [← He] at h1 + simp at h1 + · rw [← coe_of_toVal_eq_some Hv'] + have hKv : K (↑v' : Expr) = ↑v := by rw [coe_of_toVal_eq_some Hv']; exact He.symm + imodintro + iapply wp_value_fupd (v := v) ⟨rfl⟩ + imodintro + imod (wp_value_fupd (v := v') ⟨rfl⟩).mp $$ H with H + imod H + ihave H := (wp_value_fupd (v := v) ⟨hKv.symm⟩).mp $$ H + iframe + · imodintro + iapply wp_value_fupd (v := v) ⟨rfl⟩ + imodintro + imod H + ihave _ := (wp_value_fupd (v := v) ⟨rfl⟩).mp $$ H + iframe + +instance WP_inv_open_abstract : + InvOpenAbstractWP (Expr := Expr) (Val := Val) (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where + inv_open_maybe e E₁ E₂ Φ _ := wp_inv_open_maybe e E₁ E₂ Φ + +end IrisWP From 7df3c66d50aba01f569e9ac80ca0dd5dab7c4730 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Wed, 1 Jul 2026 16:59:27 -0700 Subject: [PATCH 16/33] fix build --- .../Iris/ProgramLogic/AbstractWeakestPre.lean | 26 ++++++++++++------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean b/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean index c26b3001f..1b2f7ed77 100644 --- a/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean +++ b/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean @@ -76,7 +76,7 @@ theorem inv_open_maybe_ectxlang {e : Expr} {E₁ E₂ : CoPset} {Φ : Val → IP · imodintro obtain ⟨σ'', Hred⟩ := Hred have Hred' : BaseStep.Reducible (e₁', σ) := ⟨_, _, _, _, Hbase⟩ - obtain ⟨rfl, rfl⟩ := EctxLanguage.base_redex_unique _ _ _ _ σ _ Hf Hred' Hred + obtain ⟨rfl, rfl⟩ := EctxLanguage.base_redex_unique Hf Hred' Hred simp only [← EvContext.fill_comp, EvContext.fill_empty] iapply IWP.toLawfulAbstractWP.wp_wand $$ Hwp iintro %v >Hwp2 @@ -94,7 +94,7 @@ theorem inv_open_maybe_ectxlang {e : Expr} {E₁ E₂ : CoPset} {Φ : Val → IP imod H with (⟨%K₁, %e', %Hf, %Hat, %Hred, Hwp⟩| H') · obtain ⟨σ'', Hred⟩ := Hred have Hred' : BaseStep.Reducible (e₁', σ) := ⟨_, _, _, _, Hbase⟩ - obtain ⟨_, rfl⟩ := EctxLanguage.base_redex_unique _ _ _ _ σ _ Hf Hred' Hred + obtain ⟨_, rfl⟩ := EctxLanguage.base_redex_unique Hf Hred' Hred exact Hnonatomic Hat |>.elim · imod H' ihave H' := (IWP.wp_bind (K := fill K)).mpr $$ H' @@ -112,7 +112,7 @@ theorem inv_open_maybe_ectxlang_inv (e : Expr) (E : CoPset) (N : Namespace) ⊢ wp E e Φ := by iintro ⟨#Hinv, H⟩ iapply inv_open_maybe_ectxlang (E₂ := E \ nclose N) LawfulSet.diff_subset_left Hred - imod inv_acc _ _ _ Hsub $$ Hinv with ⟨HP, Hclose⟩ + imod inv_acc Hsub $$ Hinv with ⟨HP, Hclose⟩ imod H $$ HP with (⟨%K, %e', %He, %Hat, %Hred, H⟩|⟨HP, H⟩) · imodintro ileft @@ -141,18 +141,20 @@ instance WP_lawful_abstract : LawfulAbstractWP (Expr := Expr) (Val := Val) (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where fupd_wp := fupd_wp - wp_fupd := wp_fupd _ _ _ _ + wp_fupd := wp_fupd wp_value := wp_value_fupd' wp_wand := wp_wand wp_atomic _ := wp_atomic /-- iris-lean's standard `WP` also satisfies the bind class for ectx languages. -/ -instance WP_bind_abstract : - BindAbstractWP (Expr := Expr) (Val := Val) +instance WP_bind_abstract : BindAbstractWP (Expr := Expr) (Val := Val) (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where wp_bind := ⟨wp_bind _, wp_bind_inv _⟩ + +-- TODO: Any idea how to get rid of the istops? + theorem wp_inv_open_maybe_of_not_val {e : Expr} {E₁ E₂ : CoPset} {Φ : Val → IProp GF} (Hnv : ToVal.toVal e = none) : (|={E₁, E₂}=> @@ -167,10 +169,14 @@ theorem wp_inv_open_maybe_of_not_val {e : Expr} {E₁ E₂ : CoPset} {Φ : Val imod H with (⟨%K, %e', %Hctx, %Haux, %hato, Hwp⟩| >$) subst Haux -- FIXME: Why does this exit the proofmode? - rw [IProp.ext wp_unfold, wp.pre]; iintro Hwp + refine .trans wp_unfold.mp ?_ + rw (occs := [1]) [wp.pre] + iintro Hwp rcases He' : toVal e' with (_|v'); rotate_left · imod Hwp; imod Hwp - rw [IProp.ext wp_unfold, wp.pre] + istop + refine .trans wp_unfold.mp ?_ + rw (occs := [1]) [wp.pre] simp [coe_of_toVal_eq_some He', Hnv] · dsimp only iintro %σ %n %κ %κs %n₂ Hσ @@ -186,7 +192,9 @@ theorem wp_inv_open_maybe_of_not_val {e : Expr} {E₁ E₂ : CoPset} {Φ : Val imod Hc with ⟨Hst, Hwp, $⟩ replace Hprim : PrimStep.Irreducible (e₂, σ₂) := hato.atomic Hprim -- FIXME: Why does this exit the proofmode? - rw [IProp.ext wp_unfold, wp.pre] + istop + refine .trans (BI.sep_mono .rfl wp_unfold.mp) ?_ + rw (occs := [1]) [wp.pre] iintro ⟨Hst, Hwp⟩ rcases He₂' : toVal e₂ with (_|v₂) <;> dsimp only · imod Hwp $$ %_ %_ %κs %.nil [Hst] with ⟨%Hredu, H⟩ From e3c4ee1200e931a4618f0226d87da68994ed3222 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Tue, 7 Jul 2026 08:51:34 +0900 Subject: [PATCH 17/33] minor changes --- Iris/Iris/Instances/Lib/GhostMap.lean | 2 -- Iris/Iris/ProgramLogic/AbstractWeakestPre.lean | 15 ++++----------- 2 files changed, 4 insertions(+), 13 deletions(-) diff --git a/Iris/Iris/Instances/Lib/GhostMap.lean b/Iris/Iris/Instances/Lib/GhostMap.lean index 3f0ee7d0f..f342e0ab3 100644 --- a/Iris/Iris/Instances/Lib/GhostMap.lean +++ b/Iris/Iris/Instances/Lib/GhostMap.lean @@ -375,8 +375,6 @@ theorem ghost_map_delete {γ} {m : H V} (k : K) (v : V) : iapply iOwn_mono $$ G exact auth_inc_of_map_eq _ map_delete --- TODO: Make these implicit - @[rocq_alias ghost_map_update] theorem ghost_map_update {γ} {m : H V} {k : K} {v : V} (w : V) : ⊢@{IProp GF} (γ ↪●MAP m) -∗ (γ ↪◯MAP[k] v) ==∗ (γ ↪●MAP insert m k w) ∗ γ ↪◯MAP[k] w := by diff --git a/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean b/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean index 1b2f7ed77..0ebfb6e4b 100644 --- a/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean +++ b/Iris/Iris/ProgramLogic/AbstractWeakestPre.lean @@ -116,8 +116,7 @@ theorem inv_open_maybe_ectxlang_inv (e : Expr) (E : CoPset) (N : Namespace) imod H $$ HP with (⟨%K, %e', %He, %Hat, %Hred, H⟩|⟨HP, H⟩) · imodintro ileft - iexists K - iexists e' + iexists K, e' iframe %He %Hat %Hred iapply IWP.wp_wand $$ H iintro %v ⟨HP, Hwp⟩ @@ -129,30 +128,25 @@ theorem inv_open_maybe_ectxlang_inv (e : Expr) (E : CoPset) (N : Namespace) end EctxLanguage -/-! ### Instances of the abstract classes for iris-lean's real `Wp`. -/ +/-! ### Instances of the abstract classes for iris-lean's generic `Wp`. -/ section IrisWP variable {Expr State Obs Val : Type _} [Language Expr State Obs Val] variable {GF : BundledGFunctors} {HLC : HasLC} [IrisGS_gen HLC Expr GF] -/-- iris-lean's standard `WP` satisfies the abstract 5-law class. -/ instance WP_lawful_abstract : - LawfulAbstractWP (Expr := Expr) (Val := Val) - (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where + LawfulAbstractWP (Expr := Expr) (Val := Val) (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where fupd_wp := fupd_wp wp_fupd := wp_fupd wp_value := wp_value_fupd' wp_wand := wp_wand wp_atomic _ := wp_atomic -/-- iris-lean's standard `WP` also satisfies the bind class for ectx -languages. -/ instance WP_bind_abstract : BindAbstractWP (Expr := Expr) (Val := Val) (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where wp_bind := ⟨wp_bind _, wp_bind_inv _⟩ - -- TODO: Any idea how to get rid of the istops? theorem wp_inv_open_maybe_of_not_val {e : Expr} {E₁ E₂ : CoPset} {Φ : Val → IProp GF} @@ -219,8 +213,7 @@ theorem wp_inv_open_maybe (e : Expr) (E₁ E₂ : CoPset) (Φ : Val → IProp GF imod H with (⟨%K, %e', %Hctx, %He, %Hato, H⟩| H); · rcases Hv' : toVal e' with (_|v') · exfalso - have h1 := Hctx.toVal_eq_none_fill Hv' - rw [← He] at h1 + have h1 := He.symm ▸ Hctx.toVal_eq_none_fill Hv' simp at h1 · rw [← coe_of_toVal_eq_some Hv'] have hKv : K (↑v' : Expr) = ↑v := by rw [coe_of_toVal_eq_some Hv']; exact He.symm From 0994d0e8c32d52f78ce6b3344cf5bd7d6bb6227b Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Thu, 18 Jun 2026 16:16:30 -0400 Subject: [PATCH 18/33] upload --- .../AbstractEctxLangCompleteness.lean | 168 +++++++ .../AbstractLangCompleteness.lean | 435 ++++++++++++++++++ Iris/Iris/ProgramLogic/Adequacy.lean | 27 +- Iris/Iris/ProgramLogic/ThreadPool.lean | 282 ++++++++++++ 4 files changed, 910 insertions(+), 2 deletions(-) create mode 100644 Iris/Iris/ProgramLogic/AbstractEctxLangCompleteness.lean create mode 100644 Iris/Iris/ProgramLogic/AbstractLangCompleteness.lean create mode 100644 Iris/Iris/ProgramLogic/ThreadPool.lean diff --git a/Iris/Iris/ProgramLogic/AbstractEctxLangCompleteness.lean b/Iris/Iris/ProgramLogic/AbstractEctxLangCompleteness.lean new file mode 100644 index 000000000..958c00132 --- /dev/null +++ b/Iris/Iris/ProgramLogic/AbstractEctxLangCompleteness.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2026 Markus de Medeiros. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import Iris.Algebra +public import Iris.BI +public import Iris.ProofMode +public import Iris.ProgramLogic.Language +public import Iris.ProgramLogic.EctxLanguage +public import Iris.ProgramLogic.Adequacy +public import Iris.ProgramLogic.ThreadPool +public import Iris.ProgramLogic.AbstractWeakestPre +public import Iris.ProgramLogic.AbstractLangCompleteness +public import Iris.Instances.Lib.Invariants +public import Iris.Instances.Lib.CInvariants +public import Iris.Instances.Lib.GhostMap +public import Iris.Std.FromMathlib + +namespace Iris.ProgramLogic + +open Iris Iris.BI Iris.Algebra Std FromMathlib +open Iris.ProgramLogic.PrimStep +open Language Language.Notation + +@[expose] public section + +section AbstractEctxCompleteness + +variable {Expr State Obs Val Ectx : Type _} +variable [EctxLanguage Expr Ectx State Obs Val] +variable {GF : BundledGFunctors} {HLC : HasLC} [IrisGS_gen HLC Expr GF] +variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] +variable [TI : TpinvGS GF Expr H] + +/-- The body of the `ectx_lang_completeness` field of +`AbstractEctxLangCompletenessGen`; mirrors `ectx_lang_completeness` in +`framework/abstract/abstract_ectx_lang_completeness.v` lines 13–31. -/ +public def ectxLangCompletenessStmt [TI : TpinvGS GF Expr H] (wp : AbstractWP Expr Val GF) + (heap_inv : List Expr → State → IProp GF) (n : Nat) (C : List Expr) (e₁ : Expr) (σ : State) + (K : Ectx) (E : CoPset) : IProp GF := iprop% + ⌜BaseStep.Reducible (e₁, σ)⌝ -∗ + (n ↪thread (EvContext.fill K e₁)) -∗ + heap_inv C σ ∗ tpInv C ∗ ⌜cfgSafe (C, σ)⌝ ={E}=∗ + ((⌜Iris.ProgramLogic.Language.Atomic Atomicity.WeaklyAtomic e₁⌝ ∗ + (∀ Φ, + (▷ ∀ κ v₂ σ' efs, + ⌜PrimStep.primStep (e₁, σ) κ ((ToVal.ofVal v₂ : Expr), σ', efs)⌝ -∗ + isThread n (.own 1) (EvContext.fill K e₁) -∗ + tpInv C ==∗ + (heap_inv ((C.set n (EvContext.fill K (ToVal.ofVal v₂))) ++ efs) σ' -∗ + Φ v₂) ∗ + [∗list] _i ↦ etp ∈ efs, wp ⊤ etp (fun (_ : Val) => iprop(True))) -∗ + wp E e₁ Φ)) + ∨ + (heap_inv C σ ∗ tpInv C ∗ ∀ Ψ, + (▷ ∀ e₂ efs, + (∀ σ₁ C₁, + heap_inv C₁ σ₁ ∗ tpInv C₁ ∗ ⌜cfgSafe (C₁, σ₁)⌝ ={E}=∗ + ∃ κ σ₁', + ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' efs⌝ ∗ + isThread n (.own 1) (EvContext.fill K e₁) ∗ + tpInv C₁ ∗ + heap_inv ((C₁.set n (EvContext.fill K e₂)) ++ efs) σ₁') ={⊤}=∗ + wp ⊤ e₂ Ψ ∗ + ([∗list] _j ↦ etp ∈ efs, wp ⊤ etp (fun (_ : Val) => iprop(True)))) -∗ + wp ⊤ e₁ Ψ)) + +/-- *Abstract ectx-completeness theory*: the ectx-language specialization of +`AbstractLangCompletenessGen`. The soundness equation `ectx_lang_completeness` +is phrased for base steps rather than prim steps. -/ +public class AbstractEctxLangCompletenessGen + (wp : AbstractWP Expr Val GF) [BindAbstractWP wp] where + heap_inv : List Expr → State → IProp GF + heap_inv_timeless (C : List Expr) (σ : State) : Timeless (heap_inv C σ) + ectx_lang_completeness (n : Nat) (C : List Expr) (e₁ : Expr) (σ : State) (K : Ectx) (E : CoPset) : + ⊢ ectxLangCompletenessStmt wp heap_inv n C e₁ σ K E + +attribute [instance] AbstractEctxLangCompletenessGen.heap_inv_timeless + +end AbstractEctxCompleteness + +/-! ### Lifting the ectx-level soundness equation to the prim level. -/ + +section Lifting + +variable {Expr State Obs Val Ectx : Type _} +variable [EctxLanguage Expr Ectx State Obs Val] +variable {GF : BundledGFunctors} {HLC : HasLC} [IrisGS_gen HLC Expr GF] +variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] +variable [TI : TpinvGS GF Expr H] +variable {wp : AbstractWP Expr Val GF} +variable [BindAbstractWP wp] [InvOpenAbstractWP wp] +variable [AEC : AbstractEctxLangCompletenessGen wp] +variable [CInvG GF] + +omit [InvOpenAbstractWP wp] [CInvG GF] in +/-- Lift the ectx-level reduction soundness equation to a prim-level one. +Mirrors `weakestpre_ectx_to_prim_completeness` in +`framework/abstract/abstract_ectx_lang_completeness.v` lines 37–53. -/ +theorem weakestpre_ectx_to_prim_completeness : + ∀ (n : Nat) (C : List Expr) (e₁ : Expr) (σ : State) (E : CoPset), + ⊢ abstractECTXLangComplete (TI := TI) wp AEC.heap_inv n C e₁ σ E := by + iintro %n %C %e₁ %σ %E %Hred Htok ⟨Hheap, Htp, %Hsafe⟩ + obtain ⟨κ, e', σ', efs, hstep⟩ := Hred + obtain ⟨Hbase⟩ := hstep + rename_i e₁' e₂' K + have Hbred : BaseStep.Reducible (e₁', σ) := ⟨κ, e₂', σ', efs, Hbase⟩ + have key := AEC.ectx_lang_completeness (wp := wp) n C e₁' σ K E + unfold ectxLangCompletenessStmt at key + imod key $$ %Hbred Htok [Hheap Htp] + with (⟨%Hatom, HH⟩ | ⟨Hheap, Htp, HH⟩) + · iframe Hheap Htp + ipureintro; exact Hsafe + · -- Atomic redex: package the context `fill K` and forward the magic premise. + imodintro + ileft + iexists (fill (Expr := Expr) K), e₁' + have Hctx : Context (fill (Expr := Expr) K) := inferInstance + have Heq : fill (Expr := Expr) K e₁' = fill (Expr := Expr) K e₁' := rfl + have Hnv : ToVal.toVal e₁' = none := EctxLanguage.val_stuck Hbase + iframe %Hctx %Heq %Hnv %Hatom + iintro %Ψ Hpre + iapply HH $$ Hpre + · -- Non-atomic redex: reduce the prim-level WP to the ectx-level one via `wp_bind`. + imodintro + iright + iframe Hheap Htp + iintro %Ψ Hc + iapply ((‹BindAbstractWP wp›).wp_bind (K := fill (Expr := Expr) K) (e := e₁') (Φ := Ψ)).1 + iapply HH + inext + iintro %e₂ %efs H + -- Lift the ectx-level step `H` (on the redex `e₁'`) to a prim-level step under `fill K`. + ihave Hprem : iprop(∀ σ₁ C₁, + AEC.heap_inv C₁ σ₁ ∗ tpInv C₁ ∗ ⌜cfgSafe (C₁, σ₁)⌝ ={E}=∗ + ∃ κ σ₁', ⌜PrimSteps (fill (Expr := Expr) K e₁') σ₁ κ (fill (Expr := Expr) K e₂) σ₁' efs⌝ ∗ + (n ↪thread fill (Expr := Expr) K e₁') ∗ tpInv C₁ ∗ + AEC.heap_inv (C₁.set n (fill (Expr := Expr) K e₂) ++ efs) σ₁') $$ [H] + · iintro %σ₁ %C₁ ⟨Hi, Htp1, %Hs⟩ + imod H $$ [Hi Htp1] with ⟨%κ', %σ₁', %Hps, Htok2, Htp1', Hhp⟩ + · iframe Hi Htp1 + ipureintro; exact Hs + imodintro + iexists κ', σ₁' + iframe Htok2 Htp1' Hhp + ipureintro + exact Hps.fill + imod Hc $$ Hprem with ⟨Hwp, Hlist⟩ + imodintro + isplitl [Hwp] + · iapply ((‹BindAbstractWP wp›).wp_bind (K := fill (Expr := Expr) K) (e := e₂) (Φ := Ψ)).2 $$ Hwp + · iexact Hlist + +/-- Every `AbstractEctxLangCompletenessGen` gives an +`AbstractLangCompletenessGen`. -/ +instance abstract_ectx_to_completeness : + AbstractLangCompletenessGen wp where + heap_inv := AEC.heap_inv + heap_inv_timeless C σ := AEC.heap_inv_timeless C σ + lang_completeness := weakestpre_ectx_to_prim_completeness _ _ _ _ _ + +end Lifting + +end + +end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/AbstractLangCompleteness.lean b/Iris/Iris/ProgramLogic/AbstractLangCompleteness.lean new file mode 100644 index 000000000..7a0ad9198 --- /dev/null +++ b/Iris/Iris/ProgramLogic/AbstractLangCompleteness.lean @@ -0,0 +1,435 @@ +/- +Copyright (c) 2026 Markus de Medeiros. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import Iris.Algebra +public import Iris.BI +public import Iris.ProofMode +public import Iris.ProgramLogic.Language +public import Iris.ProgramLogic.Adequacy +public import Iris.ProgramLogic.ThreadPool +public import Iris.ProgramLogic.AbstractWeakestPre +public import Iris.Instances.Lib.Invariants +public import Iris.Instances.Lib.CInvariants +public import Iris.Instances.Lib.GhostMap +public import Iris.Std.FromMathlib + +namespace Iris.ProgramLogic + +open Iris Iris.BI Iris.Algebra Std FromMathlib +open Iris.ProgramLogic.PrimStep +open Language Language.Notation + +@[expose] public section + +section AbstractCompleteness + +variable {Expr State Obs Val : Type _} [Language Expr State Obs Val] +variable {GF : BundledGFunctors} {HLC : HasLC} [IrisGS_gen HLC Expr GF] +variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] +variable [TI : TpinvGS GF Expr H] + +public abbrev abstractECTXLangComplete (wp : AbstractWP Expr Val GF) (I : List Expr → State → IProp GF) + (n : Nat) (C : List Expr) (e₁ : Expr) (σ : State) (E : CoPset) : + IProp GF := iprop% + ⌜PrimStep.Reducible (e₁, σ)⌝ -∗ (n ↪thread e₁) -∗ I C σ ∗ tpInv C ∗ ⌜cfgSafe (C, σ)⌝ ={E}=∗ + ((∃ (K : Expr → Expr) (e₁' : Expr), + ⌜Context K⌝ ∗ ⌜e₁ = K e₁'⌝ ∗ ⌜ToVal.toVal e₁' = none⌝ ∗ ⌜Atomic .WeaklyAtomic e₁'⌝ ∗ + ∀ Ψ, + (▷ ∀ κ v₂ σ' efs, + ⌜PrimStep.primStep (e₁', σ) κ ((ToVal.ofVal v₂ : Expr), σ', efs)⌝ -∗ + (n ↪thread e₁) -∗ + tpInv C ==∗ + (I ((C.set n (K (ToVal.ofVal v₂))) ++ efs) σ' -∗ Ψ v₂) ∗ + [∗list] _i ↦ etp ∈ efs, wp ⊤ etp (fun (_ : Val) => iprop% True)) -∗ + wp E e₁' Ψ) ∨ + (I C σ ∗ tpInv C ∗ ∀ Ψ, + (▷ ∀ e₂ efs, + (∀ σ₁ C₁, I C₁ σ₁ ∗ tpInv C₁ ∗ ⌜cfgSafe (C₁, σ₁)⌝ ={E}=∗ + ∃ κ σ₁', + ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' efs⌝ ∗ (n ↪thread e₁) ∗ tpInv C₁ ∗ + I ((C₁.set n e₂) ++ efs) σ₁') ={⊤}=∗ + wp ⊤ e₂ Ψ ∗ ([∗list] _j ↦ etp ∈ efs, wp ⊤ etp (fun (_ : Val) => iprop% True))) -∗ + wp ⊤ e₁ Ψ)) + +/-- A weakest precondition for a Language is complete -/ +public class AbstractLangCompletenessGen + (wp : AbstractWP Expr Val GF) [LawfulAbstractWP wp] where + heap_inv : List Expr → State → IProp GF + heap_inv_timeless (C : List Expr) (σ : State) : Timeless (heap_inv C σ) + lang_completeness {n C e₁ σ E} : ⊢ abstractECTXLangComplete wp heap_inv n C e₁ σ E + +attribute [instance] AbstractLangCompletenessGen.heap_inv_timeless + +end AbstractCompleteness + +section Completeness + +variable {Expr State Obs Val : Type _} [Language Expr State Obs Val] +variable {GF : BundledGFunctors} {HLC : HasLC} [IrisGS_gen HLC Expr GF] +variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] +variable [TI : TpinvGS GF Expr H] +variable {wp : AbstractWP Expr Val GF} +variable [LWP : LawfulAbstractWP wp] [IAO : InvOpenAbstractWP wp] +variable [ACG : AbstractLangCompletenessGen wp] +variable [CInvG GF] + +/-- Namespace under which the completeness invariant lives. -/ +public def completenessN : Namespace := nroot .@ (1 : Pos) + +/-- The configuration invariant: ownership of a current configuration +(thread pool + state) reachable from the initial one, with the heap and +thread-pool invariants. -/ +public def cfgInv (Cini : List Expr × State) (f : Forking) : IProp GF := iprop% + ∃ cfg : List Expr × State, + ACG.heap_inv cfg.1 cfg.2 ∗ tpInv cfg.1 ∗ ⌜cfgSafeForking cfg f⌝ ∗ ⌜Cini -·->ₜₚ* cfg⌝ + +/-- `cfgInv` is timeless: `heap_inv` is timeless by the class field, `tpInv` by +`tpInv_timeless`, and the reachability/safety conjunct is pure. This is what +lets the later be stripped off the invariant contents after opening it. -/ +instance cfgInv_timeless (Cini : List Expr × State) (f : Forking) : + Timeless (cfgInv (wp := wp) Cini f) := by + unfold cfgInv; infer_instance + +/-- Cancelable invariant package wrapping `cfgInv`. -/ +public def isCcfg (Cini : List Expr × State) (f : Forking) (γ : GName) : IProp GF := + CancelableInvariant.cinv completenessN γ (cfgInv (wp := wp) Cini f) + +instance isCcfg_persistent (Cini : List Expr × State) (f : Forking) (γ : GName) : + Persistent (isCcfg (wp := wp) Cini f γ : IProp GF) := by + unfold isCcfg; infer_instance + +omit [CInvG GF] in +/-- A separating conjunction over a list with a constant body depends only on the +list's length. -/ +theorem bigSepL_const_congr {α β : Type _} {P : IProp GF} {l1 : List α} {l2 : List β} + (h : l1.length = l2.length) : ([∗list] _x ∈ l1, P) ⊣⊢ ([∗list] _x ∈ l2, P) := by + refine (BigSepL.bigSepL_replicate (l := l1) (P := P)).symm.trans + (BiEntails.trans ?_ (BigSepL.bigSepL_replicate (l := l2) (P := P))) + rw [h]; exact .rfl + +/-- Split the cancelable-invariant fraction `own γ ⟨qc⟩` into `l.length + 1` equal +pieces: one for the current thread, plus one piece per forked thread in `l`. The +fraction type must support `n`-way division, hence the specialization to `Qp`. +Mirrors `fractional_divide_n` in `framework/thread_pool.v`. -/ +theorem own_divide_forks {α : Type _} (γ : GName) (qc : Qp) (l : List α) : + CancelableInvariant.own (GF := GF) γ qc ⊢ + CancelableInvariant.own γ (qc.divide_even (l.length + 1) (Nat.succ_pos _) : Qp) ∗ + ([∗list] _x ∈ l, + CancelableInvariant.own γ (qc.divide_even (l.length + 1) (Nat.succ_pos _) : Qp)) := by + have h := fractional_divide_equal + (Φ := fun p : Qp => CancelableInvariant.own (GF := GF) γ p) qc l.length + rw [List.replicate_succ'] at h + refine h.trans ((BigSepL.bigSepL_snoc (Φ := fun _ _ => CancelableInvariant.own (GF := GF) γ + ((qc.divide_even (l.length + 1) (Nat.succ_pos _)) : Qp))).1.trans + (sep_comm.1.trans (sep_mono_right (bigSepL_const_congr (by simp)).1))) + +/-- When there are no forks (`l = []`), dividing by `l.length + 1 = 1` is the +identity. This is the algebraic fact behind `f = doesNotFork → q = q'`. -/ +theorem qp_div_ofPNat_succ_nil {α : Type _} (qc : Qp) {l : List α} (h : l = []) : + qc.divide_even (l.length + 1) (Nat.succ_pos _) = qc := by + subst h + apply Subtype.ext + simp + grind + +theorem weakestpre_completeness + (Cini : List Expr × State) (f : Forking) (γ : GName) (q : Qp) + (n : Nat) (e : Expr) : + isCcfg (TI := TI) (wp := wp) Cini f γ -∗ + CancelableInvariant.own γ q -∗ + isThread (TI := TI) n (.own 1) e -∗ + wp ⊤ e (fun v => iprop% + isThread (TI := TI) n (.own 1) (ToVal.ofVal v) ∗ + ∃ q' : Qp, CancelableInvariant.own γ q' ∗ ⌜f = .doesNotFork → q = q'⌝) := by + iintro #Hinv + iloeb as IH generalizing %q %n %e + iintro Hq He + have Hn : nclose completenessN ⊆ ⊤ := fun _ _ => CoPset.mem_full + have Hn' : ⊤ \ nclose completenessN ⊆ ⊤ := Std.LawfulSet.diff_subset_left + iapply IAO.inv_open_maybe (E₂ := ⊤ \ nclose completenessN) _ _ _ Hn' + unfold isCcfg + imod CancelableInvariant.acc _ _ _ _ _ Hn $$ [$] [$] with ⟨>Hinv2, Hq, Hclose⟩ + unfold cfgInv + icases Hinv2 with ⟨%cfg, Hheap, HtpInv, %Hx⟩ + rcases Hx with ⟨Hsafe, Hreach⟩ + ihave %Hlu := tpInv_lookup $$ [$] [$] + have ⟨HnotStuck, Hforking⟩ := Hsafe .refl + rcases HnotStuck (List.mem_of_getElem? Hlu) with Hv|HnotStuck' + · replace ⟨v, Hv⟩ := Option.isSome_iff_exists.mp Hv + obtain rfl := (coe_of_toVal_eq_some Hv).symm; clear Hv + imodintro + ileft + -- TODO: Can iframe be improved to supply these directly? + have Hframe1 : Context (Expr := Expr) id := by infer_instance + have Hframe2 : (↑v : Expr) = id ↑v := rfl + have Hframe3 : Atomic Atomicity.WeaklyAtomic (↑v : Expr) := val_atomic + iexists id, v + iframe %Hframe1 %Hframe2 %Hframe3 + clear Hframe1 Hframe2 Hframe3 + simp only [id_eq] + iapply LWP.wp_value + imodintro + imod Hclose $$ [HtpInv Hheap] with - + · inext + iexists cfg + iframe Hheap HtpInv %Hreach %Hsafe + · imodintro + iapply LWP.wp_value + imodintro + iframe + iexists q + iframe + ipureintro + grind + · imod AbstractLangCompletenessGen.lang_completeness $$ %HnotStuck' He [Hheap HtpInv] + with (⟨%K, %e₁, %Hctx, %Heq, %Hval, %Hatom, H⟩|⟨Hheap, Htpinv, H⟩) + · have aux : cfgSafe (cfg.fst, cfg.snd) := cfgSafe_of_cfgSafeForking Hsafe + iframe %aux Hheap HtpInv + · imodintro + ileft + iexists K, e₁ + iframe %Hctx %Heq %Hatom + iapply H + iintro !> %κ %v₂ %σ₂' %Hefs %Hbase He HtpInv + -- Divide the fraction `q` among the current thread and the `length Hefs` forks. + icases own_divide_forks γ q Hefs $$ Hq with ⟨Hq, Hefsfrac⟩ + -- Register the forked threads and update the current thread to `K ↑v₂`. + imod (tpInv_update cfg.fst n e (K ↑v₂)) $$ HtpInv He with ⟨HtpInv, He⟩ + imod (tpInv_new_threads Hefs (cfg.fst.set n (K ↑v₂))) $$ HtpInv with ⟨HtpInv, Hefs_threads⟩ + imodintro + isplitl [Hclose Hq He HtpInv] + · -- Current thread: close the invariant at the new configuration, then recurse. + iintro Hheap + have Hprim : (e, cfg.snd) -<κ>-> (K ↑v₂, σ₂', Hefs) := Heq ▸ Context.primStep_fill Hbase + obtain ⟨Hsafe', Hnf⟩ := cfg_safeStep Hsafe Hlu Hprim + imod Hclose $$ [Hheap HtpInv] with - + · inext + iexists (cfg.fst.set n (K ↑v₂) ++ Hefs, σ₂') + iframe Hheap HtpInv + ipureintro + exact ⟨Hsafe', Hreach.tail ⟨κ, cfg_step Hlu Hprim⟩⟩ + imodintro + iapply LWP.wp_wand $$ [Hq He] + · iapply IH $$ Hq He + iintro %v ⟨Hthread, %q', Hq', %Hfork⟩ + iframe Hthread + iexists q' + iframe Hq' + ipureintro + intro hnf + rw [← Hfork hnf] + congr 1 + exact (qp_div_ofPNat_succ_nil q (Hnf hnf)).symm + · -- Forked threads: recurse on each, discarding the postcondition. + ihave Hcomb : iprop([∗list] k ↦ e' ∈ Hefs, + (((cfg.fst.set n (K ↑v₂)).length + k) ↪thread e') ∗ + CancelableInvariant.own γ + (q.divide_even (Hefs.length + 1) (Nat.succ_pos _) : Qp)) + $$ [Hefs_threads Hefsfrac] + · iapply (BigSepL.bigSepL_sep_eqv).2 + iframe Hefs_threads Hefsfrac + iapply BigSepL.bigSepL_impl $$ Hcomb + iintro !> %k %e' %_ ⟨He, Hq⟩ + iapply LWP.wp_wand $$ [Hq He] + · iapply IH $$ Hq He + iintro %v _ + ipureintro + trivial + · imodintro + iright + imod Hclose $$ [Hheap Htpinv] with - + · inext + iexists cfg + -- FIXME: needs a better proof of this + have Hframe : cfgSafeForking cfg f := @«inferInstanceAs» (cfgSafeForking cfg f) Hsafe + iframe Hheap Htpinv %Hreach %Hframe + imodintro + iapply H + inext + iintro %e₂ %efs H + imod CancelableInvariant.acc _ _ _ _ _ Hn $$ [$] [$] with ⟨>Hinv2, Hq, Hclose⟩ + icases Hinv2 with ⟨%cfg2, Hheap, Htpinv, %Hsafe2, %Hreach2⟩ + -- Use the step-producer `H` against the freshly-opened invariant content. + imod H $$ [Hheap Htpinv] with ⟨%κ, %σ1', %Hprim, He, Htpinv, Hhp⟩ + · iframe Hheap Htpinv + ipureintro + exact cfgSafe_of_cfgSafeForking Hsafe2 + -- Divide the fraction and register the new threads. + icases own_divide_forks γ q efs $$ Hq with ⟨Hq, Hefsfrac⟩ + ihave %Hlu2 := tpInv_lookup $$ Htpinv He + obtain ⟨Hsafe2', Hforking2⟩ := cfg_safeSteps Hsafe2 Hlu2 Hprim + imod (tpInv_update cfg2.fst n e e₂) $$ Htpinv He with ⟨Htpinv, He⟩ + imod (tpInv_new_threads efs (cfg2.fst.set n e₂)) $$ Htpinv with ⟨Htpinv, Hefs_threads⟩ + imod Hclose $$ [Hhp Htpinv] with - + · inext + iexists (cfg2.fst.set n e₂ ++ efs, σ1') + iframe Hhp Htpinv + ipureintro + exact ⟨Hsafe2', Hreach2.trans (cfg_steps Hlu2 Hprim)⟩ + imodintro + isplitl [Hq He] + · -- Current thread continues with `e₂`; recurse. + iapply LWP.wp_wand $$ [Hq He] + · iapply IH $$ Hq He + iintro %v ⟨Hthread, %q', Hq', %Hfork⟩ + iframe Hthread + iexists q' + iframe Hq' + ipureintro + intro hnf + rw [← Hfork hnf] + congr 1 + exact (qp_div_ofPNat_succ_nil q (Hforking2 hnf)).symm + · -- Forked threads: recurse on each, discarding the postcondition. + ihave Hcomb : iprop([∗list] k ↦ e' ∈ efs, + (((cfg2.fst.set n e₂).length + k) ↪thread e') ∗ + CancelableInvariant.own γ + (q.divide_even (efs.length + 1) (Nat.succ_pos _) : Qp)) + $$ [Hefs_threads Hefsfrac] + · iapply (BigSepL.bigSepL_sep_eqv).2 + iframe Hefs_threads Hefsfrac + iapply BigSepL.bigSepL_impl $$ Hcomb + iintro !> %k %e' %_ ⟨He, Hq⟩ + iapply LWP.wp_wand $$ [Hq He] + · iapply IH $$ Hq He + iintro %v _ + ipureintro + trivial + + +/-- **Top-level theorem**: `adequate` gives a WP with a pure postcondition. +This is the entry point consumed by the heap-lang case study. Stated on the +generic `AbstractLangCompletenessGen`, carrying `[InvOpenAbstractWP wp]` +(mirrors Rocq's `abstract_weakestpre_gen_magic` hypothesis). -/ +theorem weakestpre_sem_completeness + (e : Expr) (σ : State) (φ : Val → Prop) + (Hade : adequate .NotStuck e σ (fun v _ => φ v)) : + ⊢ tpInvIni (TI := TI) -∗ + ACG.heap_inv [e] σ -∗ + wp ⊤ e (fun v => iprop% ⌜φ v⌝) := by + have Hsafe0 : cfgSafeForking ([e], σ) .doesFork := + fun {C₂} hreach => + ⟨fun {e2} hmem => Hade.adequate_not_stuck _ _ e2 rfl hreach hmem, + fun hf => Forking.noConfusion hf⟩ + iintro Hini Hheap + iapply LWP.fupd_wp + imod (tpInv_set [e]) $$ Hini with ⟨Hauth, Hfrags⟩ + imod (CancelableInvariant.alloc ⊤ completenessN + (cfgInv (wp := wp) ([e], σ) .doesFork)) $$ [Hauth Hheap] with ⟨%γ, #Hinv, Hq⟩ + · inext + unfold cfgInv + iexists ([e], σ) + iframe Hheap Hauth %Hsafe0 + ipureintro + exact .refl + have Hn0 : (completenessN : CoPset) ⊆ ⊤ := fun _ _ => CoPset.mem_full + ihave He0 := (Iris.BI.BigSepL.bigSepL_singleton + (Φ := fun n e' => isThread (TI := TI) n (.own 1) e') (x := e)).1 $$ Hfrags + imodintro + iapply LWP.wp_fupd + ihave Hccfg : iprop(isCcfg (wp := wp) ([e], σ) .doesFork γ) $$ [Hinv] + · unfold isCcfg; iexact Hinv + ihave Hwp := weakestpre_completeness (wp := wp) ([e], σ) .doesFork γ (One.one : Qp) 0 e + $$ Hccfg Hq He0 + iapply LWP.wp_wand $$ Hwp + iintro %v ⟨Hv, %q', Hq', _⟩ + imod (CancelableInvariant.acc ⊤ completenessN γ q' + (cfgInv (wp := wp) ([e], σ) .doesFork) Hn0) $$ Hinv Hq' with ⟨>Hinv2, Hq', Hclose2⟩ + unfold cfgInv + icases Hinv2 with ⟨%cfg, Hheap, Htpinv, %Hsafe2, %Hreach2⟩ + ihave %Hlu := tpInv_lookup $$ Htpinv Hv + imod Hclose2 $$ [Hheap Htpinv] with - + · inext + iexists cfg + iframe Hheap Htpinv %Hsafe2 %Hreach2 + imodintro + ipureintro + obtain ⟨tp2, σ2⟩ := cfg + rcases tp2 with _ | ⟨hd, rest⟩ + · simp at Hlu + · simp only [List.getElem?_cons_zero, Option.some.injEq] at Hlu + subst Hlu + exact Hade.adequate_result rest σ2 v Hreach2 + +/-- Strong nofork variant. -/ +theorem weakestpre_sem_completeness_nofork_strong + (e : Expr) (σ : State) (φ : Val → State → Prop) + (Hade : AdequateNoFork .NotStuck e σ (fun v σ' => φ v σ')) : + ⊢ tpInvIni (TI := TI) -∗ + ACG.heap_inv [e] σ -∗ + wp ⊤ e (fun v => + iprop% ∃ σ' : State, + tpInv (TI := TI) [ToVal.ofVal v] ∗ + isThread (TI := TI) 0 (.own 1) (ToVal.ofVal v) ∗ + ACG.heap_inv [ToVal.ofVal v] σ' ∗ + ⌜φ v σ'⌝) := by + have Hsafe0 : cfgSafeForking ([e], σ) .doesNotFork := by + rintro ⟨tp2, σ2⟩ hreach + refine ⟨fun {e2} hmem => Hade.not_stuck rfl hreach hmem, ?_⟩ + intro _ e2 hmem e' σ' κ efs hstep + exact adequateNoFork_efs_nil Hade hreach hmem hstep + have Hn0 : (completenessN : CoPset) ⊆ ⊤ := fun _ _ => CoPset.mem_full + iintro Hini Hheap + iapply LWP.fupd_wp + imod (tpInv_set [e]) $$ Hini with ⟨Hauth, Hfrags⟩ + imod (CancelableInvariant.alloc ⊤ completenessN + (cfgInv (wp := wp) ([e], σ) .doesNotFork)) $$ [Hauth Hheap] with ⟨%γ, #Hinv, Hq⟩ + · inext + unfold cfgInv + iexists ([e], σ) + iframe Hheap Hauth %Hsafe0 + ipureintro + exact .refl + ihave He0 := (Iris.BI.BigSepL.bigSepL_singleton + (Φ := fun n e' => isThread (TI := TI) n (.own 1) e') (x := e)).1 $$ Hfrags + imodintro + iapply LWP.wp_fupd + ihave Hccfg : iprop(isCcfg (wp := wp) ([e], σ) .doesNotFork γ) $$ [Hinv] + · unfold isCcfg; iexact Hinv + ihave Hwp := weakestpre_completeness (wp := wp) ([e], σ) .doesNotFork γ (One.one : Qp) 0 e + $$ Hccfg Hq He0 + iapply LWP.wp_wand $$ Hwp + iintro %v ⟨Hv, %q', Hq', %His1⟩ + obtain rfl := His1 rfl + imod (CancelableInvariant.cancel ⊤ completenessN γ + (cfgInv (wp := wp) ([e], σ) .doesNotFork) Hn0) $$ Hinv Hq' with >Hinv2 + unfold cfgInv + icases Hinv2 with ⟨%cfg, Hheap, Htpinv, %Hsafe2, %Hreach2⟩ + ihave %Hlu := tpInv_lookup $$ Htpinv Hv + imodintro + obtain ⟨tp2, σ2⟩ := cfg + rcases tp2 with _ | ⟨hd, rest⟩ + · simp at Hlu + · simp only [List.getElem?_cons_zero, Option.some.injEq] at Hlu + subst Hlu + have hlen := Hade.no_fork Hreach2 + rw [List.length_cons] at hlen + obtain rfl := List.length_eq_zero_iff.mp (by omega : rest.length = 0) + iexists σ2 + iframe Htpinv Hv Hheap + ipureintro + exact Hade.result Hreach2 + +/-- User-facing nofork variant. -/ +theorem weakestpre_sem_completeness_nofork + (e : Expr) (σ : State) (φ : Val → State → Prop) + (Hade : AdequateNoFork .NotStuck e σ (fun v σ' => φ v σ')) : + ⊢ tpInvIni (TI := TI) -∗ + ACG.heap_inv [e] σ -∗ + wp ⊤ e (fun v => + iprop% ∃ σ' : State, ACG.heap_inv [ToVal.ofVal v] σ' ∗ ⌜φ v σ'⌝) := by + iintro Hini Hheap + ihave Hw := weakestpre_sem_completeness_nofork_strong (wp := wp) e σ φ Hade $$ Hini Hheap + iapply LWP.wp_wand $$ Hw + iintro %v ⟨%σ2, _, _, Hh, Hphi⟩ + iexists σ2 + iframe + +end Completeness + +end + +end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/Adequacy.lean b/Iris/Iris/ProgramLogic/Adequacy.lean index 9cd153298..19b451411 100644 --- a/Iris/Iris/ProgramLogic/Adequacy.lean +++ b/Iris/Iris/ProgramLogic/Adequacy.lean @@ -234,8 +234,7 @@ theorem wp_strong_adequacy_gen [InvGpreS GF] (s : Stuckness) (es : List Expr) ( abbrev wp_strong_adequacy := @wp_strong_adequacy_gen .hasLC @[rocq_alias adequate] -structure adequate (s : Stuckness) (e1 : Expr) (σ1 : State) - (φ : Val → State → Prop) : Prop where +structure adequate (s : Stuckness) (e1 : Expr) (σ1 : State) (φ : Val → State → Prop) : Prop where adequate_result : ∀ (t2 : List Expr) (σ2 : State) (v2 : Val), ([e1], σ1) -·->ₜₚ* (ToVal.ofVal v2 :: t2, σ2) → φ v2 σ2 @@ -243,6 +242,11 @@ structure adequate (s : Stuckness) (e1 : Expr) (σ1 : State) ∀ (t2 : List Expr) (σ2 : State) (e2 : Expr), s = .NotStuck → ([e1], σ1) -·->ₜₚ* (t2, σ2) → e2 ∈ t2 → NotStuck (e2, σ2) +structure AdequateNoFork (s : Stuckness) (e₁ : Expr) (σ₁ : State) (φ : Val → State → Prop) : Prop where + no_fork {t₂ σ₂} : ([e₁], σ₁) -·->ₜₚ* (t₂, σ₂) → t₂.length = 1 + result {t₂ σ₂ v₂} : ([e₁], σ₁) -·->ₜₚ* (ToVal.ofVal v₂ :: t₂, σ₂) → φ v₂ σ₂ + not_stuck {t₂ σ₂ e₂} : s = .NotStuck → ([e₁], σ₁) -·->ₜₚ* (t₂, σ₂) → e₂ ∈ t₂ → NotStuck ⟨e₂, σ₂⟩ + @[rocq_alias adequate_alt] theorem adequate_alt (s : Stuckness) (e1 : Expr) (σ1 : State) (φ : Val → State → Prop) : @@ -274,6 +278,25 @@ theorem adequate_tp_safe (e1 : Expr) (t2 : List Expr) (σ1 σ2 : State) obtain ⟨t2', t2'', rfl⟩ := List.append_of_mem hel exact .inr ⟨t2' ++ e3 :: t2'' ++ efs, σ3, obs, Language.Step.of_primStep hstep⟩ +theorem adequateNoFork_step {e₁ e₂ : Expr} {σ₁ σ₂ s Q} + (Hstep : ([e₁], σ₁) -·->ₜₚ* ([e₂], σ₂)) (H : AdequateNoFork s e₁ σ₁ Q) : + AdequateNoFork s e₂ σ₂ Q := + ⟨(H.no_fork <| Hstep.trans ·), (H.result <| Hstep.trans ·), (H.not_stuck · <| Hstep.trans ·)⟩ + +theorem adequateNoFork_primStep {e₁ e₂ : Expr} {κ σ₁ σ₂ s Q} + (Hstep : (e₁, σ₁) -<κ>-> (e₂, σ₂, [])) + (H : AdequateNoFork s e₁ σ₁ Q) : AdequateNoFork s e₂ σ₂ Q := + adequateNoFork_step (.tail .refl ⟨κ, .of_primStep Hstep (t₁ := []) (t₂ := [])⟩) H + +theorem adequateNoFork_efs_nil {e₁ : Expr} {σ₁ s φ} (H : AdequateNoFork s e₁ σ₁ φ) + {t₂ σ₂ e₂} (Hsteps : ([e₁], σ₁) -·->ₜₚ* (t₂, σ₂)) (Hmem : e₂ ∈ t₂) + {κ e' σ' efs} (Hstep : (e₂, σ₂) -<κ>-> (e', σ', efs)) : efs = [] := by + obtain ⟨t₂a, t₂b, rfl⟩ := List.append_of_mem Hmem + have Hlen := H.no_fork (Hsteps.tail ⟨κ, .atomic Hstep t₂a t₂b⟩) + refine List.length_eq_zero_iff.mp ?_ + simp [List.length_append] at Hlen + omega + omit iG in @[rocq_alias wp_adequacy_gen] theorem wp_adequacy_gen [InvGpreS GF] (s : Stuckness) (e : Expr) (σ : State) (φ : Val → Prop) diff --git a/Iris/Iris/ProgramLogic/ThreadPool.lean b/Iris/Iris/ProgramLogic/ThreadPool.lean new file mode 100644 index 000000000..4330c3630 --- /dev/null +++ b/Iris/Iris/ProgramLogic/ThreadPool.lean @@ -0,0 +1,282 @@ +/- +Copyright (c) 2026 Markus de Medeiros. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import Iris.ProgramLogic.Language +public import Iris.ProgramLogic.EctxLanguage +public import Iris.ProgramLogic.Adequacy +public import Iris.Instances.Lib.GhostMap +public import Iris.Std.FromMathlib +public import Batteries.Data.List.Lemmas + +namespace Iris.ProgramLogic + +open Iris.ProgramLogic.PrimStep +open Language Language.Notation Relation FromMathlib FromMathlib.Relation.TransGen + +@[expose] public section + +variable {Expr State Obs Val : Type _} [Λ : Language Expr State Obs Val] + +/-! ### Multi-step prim reduction on a single thread -/ + +/-- Transitive closure of `primStep` with accumulated observations and forks. -/ +inductive PrimSteps : Expr → State → List Obs → Expr → State → List Expr → Prop where + | once {e₁ σ₁ κ e₂ σ₂ efs} : + (e₁, σ₁) -<κ>-> (e₂, σ₂, efs) → PrimSteps e₁ σ₁ κ e₂ σ₂ efs + | next {e₁ σ₁ κ₁ e₂ σ₂ efs₁ κ₂ e₃ σ₃ efs₂} : + (e₁, σ₁) -<κ₁>-> (e₂, σ₂, efs₁) → + PrimSteps e₂ σ₂ κ₂ e₃ σ₃ efs₂ → + PrimSteps e₁ σ₁ (κ₁ ++ κ₂) e₃ σ₃ (efs₁ ++ efs₂) + +/-! ### Configuration safety -/ + +inductive Forking where + | doesFork + | doesNotFork + +/-- Every thread in the pool is not stuck at the current state. -/ +def cfgNotStuck (C : List Expr × State) : Prop := + ∀ {e}, e ∈ C.1 → NotStuck (e, C.2) + +/-- If we declared the configuration `DoesNotFork`, every primitive step +of every thread emits empty forks. -/ +def cfgForking (C : List Expr × State) (f : Forking) : Prop := + f = .doesNotFork → ∀ e ∈ C.1, ∀ {e' σ' κ efs}, (e, C.2) -<κ>-> (e', σ', efs) → efs = [] + +/-- The configuration is safe under the given forking discipline: +every reachable configuration is not stuck and respects the forking constraint. -/ +def cfgSafeForking (C : List Expr × State) (f : Forking) : Prop := + ∀ {C₂}, (C -·->ₜₚ* C₂) → cfgNotStuck C₂ ∧ cfgForking C₂ f + +/-- The configuration is safe: every reachable configuration is not stuck. -/ +def cfgSafe (C : List Expr × State) : Prop := + ∀ {C₂}, (C -·->ₜₚ* C₂) → cfgNotStuck C₂ + +theorem cfgSafe_of_cfgSafeForking {C : List Expr × State} {f : Forking} + (H : cfgSafeForking C f) : cfgSafe C := fun Hp _ => H Hp |>.1 + +theorem PrimSteps.fill {K : Expr → Expr} [Context K] {e₁ σ₁ κ e₂ σ₂ efs} + (Hs : PrimSteps e₁ σ₁ κ e₂ σ₂ efs) : PrimSteps (K e₁) σ₁ κ (K e₂) σ₂ efs := + match Hs with + | once hstep => .once <| Context.primStep_fill hstep + | next hstep hsteps => .next (Context.primStep_fill hstep) hsteps.fill + +theorem cfg_step {tp : List Expr} {σ : State} {n : Nat} {e : Expr} + {κ : List Obs} {e' : Expr} {σ' : State} {efs : List Expr} + (Hlu : tp[n]? = some e) (Hprim : (e, σ) -<κ>-> (e', σ', efs)) : + Step (tp, σ) κ (tp.set n e' ++ efs, σ') := by + obtain ⟨hlt, rfl⟩ := List.getElem?_eq_some_iff.mp Hlu + simpa only [List.getElem_cons_drop hlt, List.take_append_drop, + ← List.set_eq_take_cons_drop e' hlt] using + Step.of_primStep Hprim (t₁ := tp.take n) (t₂ := tp.drop (n+1)) + +theorem getElem?_set_append_self {tp : List Expr} {n : Nat} {a : Expr} {efs : List Expr} + (hlt : n < tp.length) : (tp.set n a ++ efs)[n]? = some a := by + rw [List.getElem?_append_left (by rwa [List.length_set]), List.getElem?_set_self hlt] + +theorem set_append_set_append {tp : List Expr} {n : Nat} {a b : Expr} + {efs₁ efs₂ : List Expr} (hlt : n < tp.length) : + (tp.set n a ++ efs₁).set n b ++ efs₂ = tp.set n b ++ (efs₁ ++ efs₂) := by + rw [List.set_append_left _ _ (by rwa [List.length_set]), List.set_set, List.append_assoc] + +theorem cfg_stepsTc {tp : List Expr} {σ : State} {n e κ e' σ' efs} + (Hlu : tp[n]? = some e) (Hprim : PrimSteps e σ κ e' σ' efs) : + Relation.TransGen ErasedStep (tp, σ) (tp.set n e' ++ efs, σ') := by + revert Hlu + induction Hprim generalizing tp with + | once hstep => exact fun Hlu => .single ⟨_, cfg_step Hlu hstep⟩ + | @next _ _ _ e₂ _ efs₁ _ _ _ _ hstep _ ih => + intro Hlu + have hlt : n < tp.length := (List.getElem?_eq_some_iff.mp Hlu).1 + have rest := ih (tp := tp.set n e₂ ++ efs₁) (getElem?_set_append_self hlt) + rw [set_append_set_append hlt] at rest + exact head ⟨_, cfg_step Hlu hstep⟩ rest + +theorem cfg_steps {tp : List Expr} {σ : State} {n e κ e' σ' efs} (Hlu : tp[n]? = some e) + (Hprim : PrimSteps e σ κ e' σ' efs) : (tp, σ) -·->ₜₚ* (tp.set n e' ++ efs, σ') := + to_reflTransGen (cfg_stepsTc Hlu Hprim) + +theorem cfg_safeStep {tp : List Expr} {σ : State} {f n e κ e' σ' efs} + (Hsafe : cfgSafeForking (tp, σ) f) (Hlu : tp[n]? = some e) + (Hprim : (e, σ) -<κ>-> (e', σ', efs)) : + cfgSafeForking (tp.set n e' ++ efs, σ') f ∧ (f = .doesNotFork → efs = []) := by + refine ⟨fun {C₂ Hrtc} => ?_, fun hf => ?_⟩ + · exact Hsafe (.head ⟨κ, cfg_step Hlu Hprim⟩ Hrtc) + · exact Hsafe .refl |>.2 hf e (List.mem_of_getElem? Hlu) Hprim + +theorem cfg_safeSteps {tp : List Expr} {σ : State} {f n e κ e' σ' efs} + (Hsafe : cfgSafeForking (tp, σ) f) (Hlu : tp[n]? = some e) + (Hprim : PrimSteps e σ κ e' σ' efs) : + cfgSafeForking (tp.set n e' ++ efs, σ') f ∧ + (f = .doesNotFork → efs = []) := by + revert Hsafe Hlu + induction Hprim generalizing tp with + | once hstep => exact fun Hsafe Hlu => cfg_safeStep Hsafe Hlu hstep + | @next _ _ _ e₂ _ efs₁ _ _ _ _ hstep _ ih => + intro Hsafe Hlu + have hlt := (List.getElem?_eq_some_iff.mp Hlu).1 + obtain ⟨Hsafe2, Hnf⟩ := cfg_safeStep Hsafe Hlu hstep + obtain ⟨Hsafe3, Hnf2⟩ := + ih (tp := tp.set n e₂ ++ efs₁) Hsafe2 (getElem?_set_append_self hlt) + rw [set_append_set_append hlt] at Hsafe3 + exact ⟨Hsafe3, fun hf => by simp [Hnf hf, Hnf2 hf]⟩ + +theorem nSteps_trans {n m : Nat} {ρ₁ ρ₂ ρ₃ : List Expr × State} {κa κb : List Obs} + (H1 : ρ₁ -<κa>->ₜₚ^[n] ρ₂) (H2 : ρ₂ -<κb>->ₜₚ^[m] ρ₃) : + ρ₁ -<(κa ++ κb)>->ₜₚ^[(n + m)] ρ₃ := by + induction H1 with + | refl ρ => simpa using H2 + | cons hstep _ ih => + rw [Nat.add_right_comm, List.append_assoc] + exact NSteps.cons hstep (ih H2) + +theorem nSteps_one {ρ₁ ρ₂ : List Expr × State} {κ : List Obs} + (H : ρ₁ -<κ>->ₜₚ ρ₂) : ρ₁ -<κ>->ₜₚ^[1] ρ₂ := by + simpa using NSteps.cons H (.refl _) + +theorem nSteps_r {n} {ρ₁ ρ₂ ρ₃ : List Expr × State} {κ κs : List Obs} + (H1 : ρ₁ -<κs>->ₜₚ^[n] ρ₂) (H2 : ρ₂ -<κ>->ₜₚ ρ₃) : ρ₁ -<(κs ++ κ)>->ₜₚ^[(n + 1)] ρ₃ := + nSteps_trans H1 (nSteps_one H2) + +theorem primSteps_atomic {e : Expr} {σ κ e₂ σ' efs} + (Hatom : Atomic .StronglyAtomic e) (Hsteps : PrimSteps e σ κ e₂ σ' efs) : + ((e, σ) -<κ>-> (e₂, σ', efs)) ∧ (ToVal.toVal e₂).isSome := by + cases Hsteps with + | once hstep => exact ⟨hstep, Hatom.atomic hstep⟩ + | next hstep hsteps2 => + have hv := Hatom.atomic hstep + cases hsteps2 with + | once h3 => simp [Language.val_stuck h3] at hv + | next h3 _ => simp [Language.val_stuck h3] at hv + +end + +/-! ### Thread-pool ghost-state invariant -/ + +section ghost +open Iris CMRA Std + +variable {GF : BundledGFunctors} +variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] +variable {Expr : Type _} + +/-- The ghost state needed to track a thread-pool invariant -/ +public class TpinvGS (GF : BundledGFunctors) (Expr : Type _) (H : outParam <| Type _ → Type _) + [LawfulFiniteMap H Nat] extends GhostMapG GF Nat Expr H where + tp_name : GName + +variable [TI : TpinvGS GF Expr H] + +/-- Thread `n` in the pool is the expression `e`. -/ +public def isThread (n : Nat) (dq : DFrac) (e : Expr) : IProp GF := + TI.tp_name ↪◯MAP[n]{dq} e + +notation k " ↪thread{" dq "} " v => isThread k dq v +notation k " ↪thread " v => isThread k (DFrac.own 1) v + +/-- The initial thread-pool authority (empty pool). -/ +public def tpInvIni : IProp GF := + TI.tp_name ↪●MAP (∅ : H Expr) + +/-- The thread-pool invariant: the auth-side `ghost_map` agrees pointwise with +the operational thread list `tp`. -/ +public def tpInv (tp : List Expr) : IProp GF := iprop% + ∃ m : H Expr, ⌜∀ n, PartialMap.get? m n = tp[n]?⌝ ∗ TI.tp_name ↪●MAP m + +/-- `tpInv` is timeless: the ghost-map authority is over a discrete camera, and +the rest is pure/existential. Needed to strip the later off invariant contents +after opening (e.g. via `CancelableInvariant.acc`). -/ +public instance tpInv_timeless (tp : List Expr) : Iris.BI.Timeless (tpInv (TI := TI) tp) := by + unfold tpInv; infer_instance + +public theorem tpInv_lookup (tp : List Expr) (n : Nat) (e₁ : Expr) (dq : DFrac) : + tpInv tp ⊢@{IProp GF} (n ↪thread{dq} e₁) -∗ ⌜tp[n]? = some e₁⌝ := by + unfold tpInv isThread + iintro ⟨%m, %He, Hauth⟩ Hfrag + ihave %Hlookup := ghost_map_lookup $$ Hauth Hfrag + ipureintro + rw [← Hlookup, He _] + +public theorem tpInv_update (tp : List Expr) (n : Nat) (e₁ e₂ : Expr) : + tpInv tp ⊢@{IProp GF} + (n ↪thread e₁) ==∗ tpInv (tp.set n e₂) ∗ (n ↪thread e₂) := by + iintro Hinv Hfrag + ihave %Hlookup := tpInv_lookup $$ Hinv Hfrag + unfold tpInv isThread + ihave ⟨%m, %He, Hauth⟩ := Hinv + imod ghost_map_update (w := e₂) $$ Hauth Hfrag with ⟨Hauth, Hfrag⟩ + imodintro + iframe + iexists (Std.insert m n e₂) + iframe; ipureintro; intro n + grind [LawfulPartialMap.get?_insert] + +public theorem tpInv_new_threads (efs tp : List Expr) : + ⊢@{IProp GF} tpInv tp ==∗ (tpInv (tp ++ efs) ∗ ([∗list] n ↦ e' ∈ efs, (tp.length + n) ↪thread e')) := by + unfold tpInv isThread + iintro ⟨%m, %He, Hauth⟩ + have Hdisj : PartialMap.disjoint (FiniteMap.map_seq (M := H) tp.length efs) m := by + rw [PartialMap.disjoint_iff] + intro k + rcases Nat.lt_or_ge k tp.length with h | h + · left; rw [LawfulFiniteMap.get?_map_seq, if_neg (by omega)] + · right; rw [He k, List.getElem?_eq_none h] + imod ghost_map_insert_big (FiniteMap.map_seq tp.length efs) Hdisj $$ Hauth + with ⟨Hauth, Hlist⟩ + imodintro + isplitl [Hauth] + · iexists (FiniteMap.map_seq tp.length efs ∪ m) + iframe + ipureintro + intro n + show get? (PartialMap.union (FiniteMap.map_seq tp.length efs) m) n = (tp ++ efs)[n]? + rw [LawfulPartialMap.get?_union, LawfulFiniteMap.get?_map_seq, He n] + rcases Nat.lt_or_ge n tp.length with h | h + · rw [if_neg (by omega), List.getElem?_append_left h]; rfl + · rw [if_pos h, List.getElem?_append_right h, List.getElem?_eq_none h] + cases efs[n - tp.length]? <;> rfl + · iapply (Iris.BI.BigSepM.bigSepM_map_seq).mp + iexact Hlist + +public theorem tpInv_set (C : List Expr) : + ⊢@{IProp GF} tpInvIni (Expr := Expr) ==∗ tpInv C ∗ ([∗list] n ↦ e ∈ C, n ↪thread e) := by + iintro Hauth + imod tpInv_new_threads C [] $$ [Hauth] with ⟨Hi, Hlist⟩ + · unfold tpInvIni tpInv + iexists ∅ + iframe + ipureintro + exact get?_empty + imodintro + simp + +end ghost + +/-! ### Allocation + +Allocates the empty thread-pool authority and exposes a `TpinvGS` instance +parameterized by the freshly-chosen ghost name. -/ + +section alloc +open Iris CMRA Std + +variable {GF : BundledGFunctors} +variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] +variable {Expr : Type _} [GhostMapG GF Nat Expr H] + +open Classical in +public theorem tpInv_alloc : + ⊢@{IProp GF} |==> ∃ γ, + tpInvIni (Expr := Expr) (TI := { toGhostMapG := inferInstance, tp_name := γ }) := by + imod @ghost_map_alloc_empty _ Nat Expr H with ⟨%γ, H⟩ + imodintro + iexists γ + unfold tpInvIni + iexact H + +end alloc + +end Iris.ProgramLogic From 77560c3033bbd85b3e1aa371337904264ac2e92b Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Tue, 7 Jul 2026 17:13:12 +0900 Subject: [PATCH 19/33] fix build --- Iris/Iris/ProgramLogic/AbstractLangCompleteness.lean | 8 ++++---- Iris/Iris/ProgramLogic/ThreadPool.lean | 3 ++- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/Iris/Iris/ProgramLogic/AbstractLangCompleteness.lean b/Iris/Iris/ProgramLogic/AbstractLangCompleteness.lean index 7a0ad9198..57d030907 100644 --- a/Iris/Iris/ProgramLogic/AbstractLangCompleteness.lean +++ b/Iris/Iris/ProgramLogic/AbstractLangCompleteness.lean @@ -151,7 +151,7 @@ theorem weakestpre_completeness have Hn' : ⊤ \ nclose completenessN ⊆ ⊤ := Std.LawfulSet.diff_subset_left iapply IAO.inv_open_maybe (E₂ := ⊤ \ nclose completenessN) _ _ _ Hn' unfold isCcfg - imod CancelableInvariant.acc _ _ _ _ _ Hn $$ [$] [$] with ⟨>Hinv2, Hq, Hclose⟩ + imod CancelableInvariant.acc Hn $$ [$] [$] with ⟨>Hinv2, Hq, Hclose⟩ unfold cfgInv icases Hinv2 with ⟨%cfg, Hheap, HtpInv, %Hx⟩ rcases Hx with ⟨Hsafe, Hreach⟩ @@ -250,7 +250,7 @@ theorem weakestpre_completeness iapply H inext iintro %e₂ %efs H - imod CancelableInvariant.acc _ _ _ _ _ Hn $$ [$] [$] with ⟨>Hinv2, Hq, Hclose⟩ + imod CancelableInvariant.acc Hn $$ [$] [$] with ⟨>Hinv2, Hq, Hclose⟩ icases Hinv2 with ⟨%cfg2, Hheap, Htpinv, %Hsafe2, %Hreach2⟩ -- Use the step-producer `H` against the freshly-opened invariant content. imod H $$ [Hheap Htpinv] with ⟨%κ, %σ1', %Hprim, He, Htpinv, Hhp⟩ @@ -336,8 +336,8 @@ theorem weakestpre_sem_completeness $$ Hccfg Hq He0 iapply LWP.wp_wand $$ Hwp iintro %v ⟨Hv, %q', Hq', _⟩ - imod (CancelableInvariant.acc ⊤ completenessN γ q' - (cfgInv (wp := wp) ([e], σ) .doesFork) Hn0) $$ Hinv Hq' with ⟨>Hinv2, Hq', Hclose2⟩ + imod (CancelableInvariant.acc (E := ⊤) (N := completenessN) (γ := γ) (p := q') + (P := cfgInv (wp := wp) ([e], σ) .doesFork) Hn0) $$ Hinv Hq' with ⟨>Hinv2, Hq', Hclose2⟩ unfold cfgInv icases Hinv2 with ⟨%cfg, Hheap, Htpinv, %Hsafe2, %Hreach2⟩ ihave %Hlu := tpInv_lookup $$ Htpinv Hv diff --git a/Iris/Iris/ProgramLogic/ThreadPool.lean b/Iris/Iris/ProgramLogic/ThreadPool.lean index 4330c3630..8ddef6005 100644 --- a/Iris/Iris/ProgramLogic/ThreadPool.lean +++ b/Iris/Iris/ProgramLogic/ThreadPool.lean @@ -232,7 +232,7 @@ public theorem tpInv_new_threads (efs tp : List Expr) : iframe ipureintro intro n - show get? (PartialMap.union (FiniteMap.map_seq tp.length efs) m) n = (tp ++ efs)[n]? + show get? (FiniteMap.map_seq tp.length efs ∪ m) n = (tp ++ efs)[n]? rw [LawfulPartialMap.get?_union, LawfulFiniteMap.get?_map_seq, He n] rcases Nat.lt_or_ge n tp.length with h | h · rw [if_neg (by omega), List.getElem?_append_left h]; rfl @@ -252,6 +252,7 @@ public theorem tpInv_set (C : List Expr) : exact get?_empty imodintro simp + iframe end ghost From 5cc7d433cd028489e143277d7b51ae66229e4449 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Wed, 8 Jul 2026 09:51:05 +0900 Subject: [PATCH 20/33] pass --- .../AbstractEctxLangCompleteness.lean | 47 ++++++++++--------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/Iris/Iris/ProgramLogic/AbstractEctxLangCompleteness.lean b/Iris/Iris/ProgramLogic/AbstractEctxLangCompleteness.lean index 958c00132..e23d3334e 100644 --- a/Iris/Iris/ProgramLogic/AbstractEctxLangCompleteness.lean +++ b/Iris/Iris/ProgramLogic/AbstractEctxLangCompleteness.lean @@ -35,15 +35,17 @@ variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] variable [TI : TpinvGS GF Expr H] /-- The body of the `ectx_lang_completeness` field of -`AbstractEctxLangCompletenessGen`; mirrors `ectx_lang_completeness` in -`framework/abstract/abstract_ectx_lang_completeness.v` lines 13–31. -/ -public def ectxLangCompletenessStmt [TI : TpinvGS GF Expr H] (wp : AbstractWP Expr Val GF) +`AbstractEctxLangCompletenessGen`: for a base-reducible redex `e₁` under an +evaluation context `K`, either `e₁` is weakly atomic and its post-step +obligation discharges the WP, or the configuration reduces and the WP follows by +binding under `K`. -/ +public def ectxLangCompletenessStmt (wp : AbstractWP Expr Val GF) (heap_inv : List Expr → State → IProp GF) (n : Nat) (C : List Expr) (e₁ : Expr) (σ : State) (K : Ectx) (E : CoPset) : IProp GF := iprop% ⌜BaseStep.Reducible (e₁, σ)⌝ -∗ (n ↪thread (EvContext.fill K e₁)) -∗ heap_inv C σ ∗ tpInv C ∗ ⌜cfgSafe (C, σ)⌝ ={E}=∗ - ((⌜Iris.ProgramLogic.Language.Atomic Atomicity.WeaklyAtomic e₁⌝ ∗ + ((⌜Atomic .WeaklyAtomic e₁⌝ ∗ (∀ Φ, (▷ ∀ κ v₂ σ' efs, ⌜PrimStep.primStep (e₁, σ) κ ((ToVal.ofVal v₂ : Expr), σ', efs)⌝ -∗ @@ -91,28 +93,26 @@ variable {GF : BundledGFunctors} {HLC : HasLC} [IrisGS_gen HLC Expr GF] variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] variable [TI : TpinvGS GF Expr H] variable {wp : AbstractWP Expr Val GF} -variable [BindAbstractWP wp] [InvOpenAbstractWP wp] +variable [BWP : BindAbstractWP wp] variable [AEC : AbstractEctxLangCompletenessGen wp] -variable [CInvG GF] - -omit [InvOpenAbstractWP wp] [CInvG GF] in -/-- Lift the ectx-level reduction soundness equation to a prim-level one. -Mirrors `weakestpre_ectx_to_prim_completeness` in -`framework/abstract/abstract_ectx_lang_completeness.v` lines 37–53. -/ -theorem weakestpre_ectx_to_prim_completeness : - ∀ (n : Nat) (C : List Expr) (e₁ : Expr) (σ : State) (E : CoPset), + +/-- Lift the ectx-level reduction soundness equation to a prim-level one: a prim +step decomposes as a base step under some evaluation context `K`, so the +ectx-level statement transfers to the prim level via `wp_bind`. -/ +theorem weakestpre_ectx_to_prim_completeness (n : Nat) (C : List Expr) (e₁ : Expr) + (σ : State) (E : CoPset) : ⊢ abstractECTXLangComplete (TI := TI) wp AEC.heap_inv n C e₁ σ E := by - iintro %n %C %e₁ %σ %E %Hred Htok ⟨Hheap, Htp, %Hsafe⟩ + iintro %Hred Htok ⟨Hheap, Htp, %Hsafe⟩ obtain ⟨κ, e', σ', efs, hstep⟩ := Hred - obtain ⟨Hbase⟩ := hstep - rename_i e₁' e₂' K + obtain @⟨e₁', e₂', K, Hbase⟩ := hstep have Hbred : BaseStep.Reducible (e₁', σ) := ⟨κ, e₂', σ', efs, Hbase⟩ - have key := AEC.ectx_lang_completeness (wp := wp) n C e₁' σ K E + have key := AEC.ectx_lang_completeness n C e₁' σ K E unfold ectxLangCompletenessStmt at key imod key $$ %Hbred Htok [Hheap Htp] with (⟨%Hatom, HH⟩ | ⟨Hheap, Htp, HH⟩) · iframe Hheap Htp - ipureintro; exact Hsafe + ipureintro + exact Hsafe · -- Atomic redex: package the context `fill K` and forward the magic premise. imodintro ileft @@ -128,7 +128,7 @@ theorem weakestpre_ectx_to_prim_completeness : iright iframe Hheap Htp iintro %Ψ Hc - iapply ((‹BindAbstractWP wp›).wp_bind (K := fill (Expr := Expr) K) (e := e₁') (Φ := Ψ)).1 + iapply (BWP.wp_bind (K := fill (Expr := Expr) K) (e := e₁') (Φ := Ψ)).1 iapply HH inext iintro %e₂ %efs H @@ -141,7 +141,8 @@ theorem weakestpre_ectx_to_prim_completeness : · iintro %σ₁ %C₁ ⟨Hi, Htp1, %Hs⟩ imod H $$ [Hi Htp1] with ⟨%κ', %σ₁', %Hps, Htok2, Htp1', Hhp⟩ · iframe Hi Htp1 - ipureintro; exact Hs + ipureintro + exact Hs imodintro iexists κ', σ₁' iframe Htok2 Htp1' Hhp @@ -150,7 +151,7 @@ theorem weakestpre_ectx_to_prim_completeness : imod Hc $$ Hprem with ⟨Hwp, Hlist⟩ imodintro isplitl [Hwp] - · iapply ((‹BindAbstractWP wp›).wp_bind (K := fill (Expr := Expr) K) (e := e₂) (Φ := Ψ)).2 $$ Hwp + · iapply (BWP.wp_bind (K := fill (Expr := Expr) K) (e := e₂) (Φ := Ψ)).2 $$ Hwp · iexact Hlist /-- Every `AbstractEctxLangCompletenessGen` gives an @@ -158,8 +159,8 @@ theorem weakestpre_ectx_to_prim_completeness : instance abstract_ectx_to_completeness : AbstractLangCompletenessGen wp where heap_inv := AEC.heap_inv - heap_inv_timeless C σ := AEC.heap_inv_timeless C σ - lang_completeness := weakestpre_ectx_to_prim_completeness _ _ _ _ _ + heap_inv_timeless := AEC.heap_inv_timeless + lang_completeness {n C e₁ σ E} := weakestpre_ectx_to_prim_completeness n C e₁ σ E end Lifting From c57768be25ddafd278a699374f1ae7ce8e79a6ff Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Thu, 18 Jun 2026 16:17:03 -0400 Subject: [PATCH 21/33] upload --- Iris/Iris/HeapLang/Completeness.lean | 868 +++++++++++++++++++++++++++ 1 file changed, 868 insertions(+) create mode 100644 Iris/Iris/HeapLang/Completeness.lean diff --git a/Iris/Iris/HeapLang/Completeness.lean b/Iris/Iris/HeapLang/Completeness.lean new file mode 100644 index 000000000..e7fb13376 --- /dev/null +++ b/Iris/Iris/HeapLang/Completeness.lean @@ -0,0 +1,868 @@ +/- +Copyright (c) 2026 Markus de Medeiros. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import Iris.HeapLang.PrimitiveLaws +public import Iris.BI.BigOp.BigSepSet +public import Iris.ProgramLogic.ThreadPool +public import Iris.ProgramLogic.AbstractWeakestPre +public import Iris.ProgramLogic.AbstractLangCompleteness +public import Iris.ProgramLogic.AbstractEctxLangCompleteness +public import Iris.Instances.Lib.CInvariants +public import Iris.Instances.Lib.GhostMap +public import Iris.ProofMode + +/-! # HeapLang completeness + +Ports `case_studies/heaplang/completeness_generic.v` and +`completeness_classical.v`. `heap_inv` carries Rocq's two conjuncts: per-cell +`heapCellPts ∗ meta_token` (mirroring `from_option (λ v, ℓ ↦ v) ⌜True⌝` — a live +cell owns its points-to, a freed `none` cell owns nothing), and +`∃ pvs, proph p pvs` for every prophecy id in `σ.usedProphId`. `stateInterp` +includes `prophMapInterp κs σ.usedProphId` alongside `genHeapInterp σ.heap`. + +Status of `wp_base_completeness` (the base-step case analysis): +* pure branches (`rec`/`pair`/`injL`/`injR`/`beta`/`unop`/`binop`/`if`/`fst`/ + `snd`/`case`) — via `wp_base_pure` + the `PureExec` instances/lemmas; +* atomic heap branches (`load`/`store`/`free`/`xchg`/`faa`/`cmpXchg`) — via + `wp_base_atomic`(`_nochange`) + the per-op determinism lemmas; +* `fork` — via the non-atomic disjunct and `wp_fork_fupd`; +* `alloc` — via `genHeap_alloc_big`, with location freshness from `meta_token_ne`; +* `newProph` — atomic lift, fresh `p` picked in `σ₁.usedProphId`, then + `ProphMap.new_proph` allocates a proph token; freshness in `σ` follows from + `proph_exclusive` against the proph conjunct of `heap_inv σ`; +* `resolve` — `sorry` body, but `wp_base_completeness` is now a well-founded + recursion on `e₁` (declared via `termination_by e₁`), so the resolveS branch + has the inductive hypothesis `IH : heap_inv σ ⊢ |={E}=> baseCompletenessGoal + e σ E` in scope for the inner expression `e`. What remains is the body that + combines `IH` with the outer Resolve wrapping (mirror of Rocq lines 127–159): + extract `proph p` from `heap_inv σ`'s proph conjunct via `bigSepS_elem_of_acc` + + `hp : p ∈ σ.usedProphId`, then either inline a `wp_resolve_strong`-style + argument or split on `IH`'s atomic/non-atomic disjunction and use + `ProphMap.resolve_proph` to consume the front observation `(p,(v,w))` of + `κs`. All other supporting infrastructure (`prophMapInterp`, `proph p pvs`, + `ProphMap.resolve_proph`, the proph conjunct of `heap_inv`, the recursion) + is in place. +-/ + +@[expose] public section +namespace Iris.HeapLang + +open Iris ProgramLogic Iris.BI Language Language.Notation Std + +variable {hlc : HasLC} {GF : BundledGFunctors} [HeapLangGS hlc GF] + +/-- Ownership of a single heap cell's points-to. Mirrors Rocq's +`from_option (λ v, ℓ ↦ v) ⌜True⌝`: a live cell `some v` contributes `l ↦ some v`, +while a freed cell `none` contributes no ownership (`emp`). Note iris-lean's +`l ↦ ·` is the raw `gen_heap` points-to over `Option Val`, unlike Rocq heap_lang's +sealed `↦` which always wraps `Some`; hence the explicit `match` here. -/ +@[reducible] def heapCellPts (l : Loc) (vo : Option Val) : IProp GF := + match vo with + | some _ => iprop(l ↦ vo) + | none => iprop(emp) + +instance heapCellPts_timeless (l : Loc) (vo : Option Val) : + Timeless (heapCellPts (GF := GF) l vo) := by + cases vo <;> (unfold heapCellPts; infer_instance) + +/-- The raw points-to entails the cell invariant: for a live cell it is the same +resource, for a freed cell the points-to is dropped (affinely). -/ +theorem pointsTo_heapCellPts (l : Loc) (vo : Option Val) : + (l ↦ vo) ⊢ heapCellPts (GF := GF) l vo := by + cases vo with + | some v => exact .rfl + | none => exact BI.Affine.affine + +/-- The heap-lang configuration invariant: ownership of every live heap cell's +points-to together with the `meta_token` of every cell (live or freed), and a +`proph` token for every used prophecy id. +Mirrors `heap_inv` in `case_studies/heaplang/completeness_generic.v`. -/ +@[reducible] def heap_inv (σ : State) : IProp GF := iprop( + (bigSepM (M := HeapF) (K := Loc) + (fun (l : Loc) (vo : Option Val) => iprop(heapCellPts l vo ∗ metaToken l ⊤)) σ.heap) ∗ + ([∗set] p ∈ σ.usedProphId, ∃ pvs : List (Val × Val), proph p pvs)) + +instance heap_inv_timeless (σ : State) : Timeless (heap_inv (GF := GF) σ) := by + unfold heap_inv; infer_instance + +/-- Common shape of the completeness equation for a single base step, packaged so +the per-branch proofs only have to supply the (atomic / non-atomic) disjunct. -/ +abbrev baseCompletenessGoal (e₁ : Exp) (σ : State) (E : CoPset) : IProp GF := iprop( + ((⌜Atomic Atomicity.StronglyAtomic e₁⌝ ∗ + ∀ (Φ : Val → IProp GF), + (▷ ∀ κ v₂ σ' efs, ⌜PrimStep.primStep (e₁, σ) κ ((ToVal.ofVal v₂ : Exp), σ', efs)⌝ ==∗ + ((heap_inv σ' -∗ Φ v₂) ∗ + [∗list] _i ↦ etp ∈ efs, WP etp @ Stuckness.NotStuck; ⊤ {{ _v, True }})) -∗ + WP e₁ @ Stuckness.NotStuck; E {{ v, Φ v }}) ∨ + (heap_inv σ ∗ + ∀ (Φ : Val → IProp GF) (E₂ : CoPset), + (▷ ∀ e₂ efs, (∀ σ₁, heap_inv σ₁ ={E}=∗ + ∃ κ σ₁', ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' efs⌝ ∗ heap_inv σ₁') ={E₂}=∗ + WP e₂ @ Stuckness.NotStuck; E₂ {{ v, Φ v }} ∗ + [∗list] _i ↦ etp ∈ efs, WP etp @ Stuckness.NotStuck; ⊤ {{ _v, True }}) -∗ + WP e₁ @ Stuckness.NotStuck; E₂ {{ v, Φ v }}))) + +/-- Pure-step branch of `wp_base_completeness`: a pure base step `e₁ → e₂` lands in +the non-atomic disjunct, stepping the WP with `PureExec` and witnessing the +trajectory with the (state-independent) base step. -/ +theorem wp_base_pure {e₁ e₂ : Exp} {φ : Prop} [hpe : Language.PureExec φ 1 e₁ e₂] (hφ : φ) + (σ : State) (E : CoPset) + (hbase : ∀ σ' : State, BaseStep e₁ σ' [] e₂ σ' []) : + heap_inv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by + iintro Hinv + unfold baseCompletenessGoal + imodintro + iright + iframe Hinv + iintro %Φ %E₂ H + iapply wp_pure_step_later (Hexec := hpe) (Hφ := hφ) + iintro !> _ + ihave Htraj : iprop(∀ σ₁, heap_inv σ₁ ={E}=∗ + ∃ κ σ₁', ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' []⌝ ∗ heap_inv σ₁') $$ [] + · iintro %σ₁ Hinv₁ + imodintro + iexists [], σ₁ + iframe Hinv₁ + ipureintro + exact PrimSteps.once (EctxLanguage.primStep_of_baseStep (hbase σ₁)) + iapply fupd_wp + imod H $$ Htraj with ⟨Hwp, _⟩ + imodintro + iexact Hwp + +/-- Atomic heap-step branch of `wp_base_completeness`: a deterministic heap +operation at a live location `l` (reading cell `some vlive`, writing `vnew`, +returning `v₂`) lands in the atomic disjunct. The WP's own step (via +`wp_lift_atomic_step`) exposes the later needed to strip the magic premise. -/ +theorem wp_base_atomic {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (vnew : Option Val) + (σ : State) (E : CoPset) + (hatom : Atomic Atomicity.StronglyAtomic e₁) + (hcell : get? (M := HeapF) σ.heap l = some (some vlive)) + (hbase : ∀ σ'' : State, get? (M := HeapF) σ''.heap l = some (some vlive) → + BaseStep e₁ σ'' [] (ToVal.ofVal v₂) (σ''.initHeap l 1 vnew) []) + (hdet : ∀ {σ'' : State} {obs e' σ''' efs}, + get? (M := HeapF) σ''.heap l = some (some vlive) → + BaseStep e₁ σ'' obs e' σ''' efs → + obs = [] ∧ e' = (ToVal.ofVal v₂ : Exp) ∧ σ''' = σ''.initHeap l 1 vnew ∧ efs = []) : + heap_inv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by + iintro ⟨Hmap, Hproph_inv⟩ + unfold baseCompletenessGoal + imodintro + ileft + iframe %hatom + iintro %Φ Hstep + -- For the live cell, `heapCellPts l (some vlive)` reduces to `l ↦ some vlive`. + icases (BigSepM.bigSepM_insert_acc (M := HeapF) + (Φ := fun (k : Loc) (vo : Option Val) => iprop(heapCellPts k vo ∗ metaToken k ⊤)) hcell) + $$ Hmap with ⟨⟨Hpt, Hmeta⟩, Hclose⟩ + iapply wp_lift_atomic_step (EctxLanguage.val_stuck (hbase σ hcell)) + iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ + ihave %hcell1 : ⌜get? (M := HeapF) σ₁.heap l = some (some vlive)⌝ $$ [Hσ Hpt] + · icases genHeap_valid $$ [$Hσ $Hpt] with >%hh + itrivial + isplitr + · ipureintro + simp only [Stuckness.MaybeReducible] + exact EctxLanguage.primStep_reducible_of_baseStep_reducible + ⟨[], _, _, [], hbase σ₁ hcell1⟩ + iintro !> %e₂ %σ₂ %eₜ %Hprim Hcr + obtain ⟨rfl, rfl, rfl, rfl⟩ := + hdet hcell1 (EctxLanguage.baseStep_of_primStep_of_baseStep_reducible ⟨[], _, _, [], hbase σ₁ hcell1⟩ Hprim) + imod genHeap_update (v₂ := vnew) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ + imod Hstep $$ [] with ⟨Hpost, _⟩ + · ipureintro + exact EctxLanguage.primStep_of_baseStep (hbase σ hcell) + imodintro + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + have hl0 : l + (0 : Int) = l := by cases l; simp only [HAdd.hAdd, Loc.mk.injEq]; grind + simp only [stateInterp, State.initHeap, Int.toNat_one, List.range_one, List.foldl_cons, + Int.cast_ofNat_Int, List.foldl_nil, hl0, + Algebra.BigOpL.bigOpL_nil] + iframe Hσ Hproph + isplitl [Hpost Hclose Hpt Hmeta Hproph_inv] + · iexists v₂ + isplit + · ipureintro; simp [toVal]; rfl + iapply Hpost + simp only [heap_inv] + isplitl [Hclose Hpt Hmeta] + · iapply Hclose + isplitl [Hpt] + -- Convert the raw points-to back into the cell invariant (`emp` if freed). + · iapply (pointsTo_heapCellPts l vnew); iexact Hpt + · iexact Hmeta + · iexact Hproph_inv + · itrivial + +/-- Atomic heap-step branch that leaves the heap unchanged (read-only ops: `load`, +failing `cmpXchg`). -/ +theorem wp_base_atomic_nochange {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) + (σ : State) (E : CoPset) + (hatom : Atomic Atomicity.StronglyAtomic e₁) + (hcell : get? (M := HeapF) σ.heap l = some (some vlive)) + (hbase : ∀ σ'' : State, get? (M := HeapF) σ''.heap l = some (some vlive) → + BaseStep e₁ σ'' [] (ToVal.ofVal v₂) σ'' []) + (hdet : ∀ {σ'' : State} {obs e' σ''' efs}, + get? (M := HeapF) σ''.heap l = some (some vlive) → + BaseStep e₁ σ'' obs e' σ''' efs → + obs = [] ∧ e' = (ToVal.ofVal v₂ : Exp) ∧ σ''' = σ'' ∧ efs = []) : + heap_inv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by + iintro ⟨Hmap, Hproph_inv⟩ + unfold baseCompletenessGoal + imodintro + ileft + iframe %hatom + iintro %Φ Hstep + iapply wp_lift_atomic_step (EctxLanguage.val_stuck (hbase σ hcell)) + iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ + ihave %hcell1 : ⌜get? (M := HeapF) σ₁.heap l = some (some vlive)⌝ $$ [Hσ Hmap] + · icases (BigSepM.bigSepM_lookup_acc (M := HeapF) + (Φ := fun (k : Loc) (vo : Option Val) => iprop(heapCellPts k vo ∗ metaToken k ⊤)) hcell).1 + $$ Hmap with ⟨⟨Hpt, _⟩, _⟩ + icases genHeap_valid $$ [$Hσ $Hpt] with >%hh + itrivial + isplitr + · ipureintro + simp only [Stuckness.MaybeReducible] + exact EctxLanguage.primStep_reducible_of_baseStep_reducible + ⟨[], _, _, [], hbase σ₁ hcell1⟩ + iintro !> %e₂ %σ₂ %eₜ %Hprim Hcr + obtain ⟨rfl, rfl, rfl, rfl⟩ := + hdet hcell1 (EctxLanguage.baseStep_of_primStep_of_baseStep_reducible + ⟨[], _, _, [], hbase σ₁ hcell1⟩ Hprim) + imod Hstep $$ [] with ⟨Hpost, _⟩ + · ipureintro + exact EctxLanguage.primStep_of_baseStep (hbase σ hcell) + imodintro + ihave Hproph := (prophMapInterp_nil_append obs' σ₂.usedProphId).mp $$ Hproph + simp only [stateInterp] + iframe Hσ Hproph + isplitl [Hpost Hmap Hproph_inv] + · iexists v₂ + isplit + · ipureintro; simp [toVal]; rfl + iapply Hpost + simp only [heap_inv] + iframe Hmap Hproph_inv + · itrivial + +/-! ### Per-operation determinism facts. + +These discharge the `hdet` argument of `wp_base_atomic`(`_nochange`): for a fixed +redex and a fixed value of the cell being acted on, the base step's output is +uniquely determined. In Rocq these are obtained for free by reasoning forward +with the concrete `wp_load`/`wp_store`/… rules; here the generic atomic helper +takes the determinism as an explicit side condition. Each is a one-constructor +`cases` followed by reading off the cell equation. -/ + +theorem loadS_det {l : Loc} {v : Val} {σ : State} {obs e' σ' efs} + (h : get? (M := HeapF) σ.heap l = some (some v)) + (hs : BaseStep (.load (.val (.lit (.loc l)))) σ obs e' σ' efs) : + obs = [] ∧ e' = (ToVal.ofVal v : Exp) ∧ σ' = σ ∧ efs = [] := by + cases hs with + | loadS _ v' _ h' => + simp only [State.get?] at h' + rw [h] at h' + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at h' + subst h' + refine ⟨rfl, rfl, rfl, rfl⟩ + +theorem storeS_det {l : Loc} {w : Val} {σ : State} {obs e' σ' efs} + (hs : BaseStep (.store (.val (.lit (.loc l))) (.val w)) σ obs e' σ' efs) : + obs = [] ∧ e' = (ToVal.ofVal (Val.lit .unit) : Exp) ∧ + σ' = σ.initHeap l 1 (some w) ∧ efs = [] := by + cases hs with + | storeS _ _ _ _ _ => refine ⟨rfl, rfl, rfl, rfl⟩ + +theorem freeS_det {l : Loc} {σ : State} {obs e' σ' efs} + (hs : BaseStep (.free (.val (.lit (.loc l)))) σ obs e' σ' efs) : + obs = [] ∧ e' = (ToVal.ofVal (Val.lit .unit) : Exp) ∧ + σ' = σ.initHeap l 1 none ∧ efs = [] := by + cases hs with + | freeS _ _ _ _ => refine ⟨rfl, rfl, rfl, rfl⟩ + +theorem xchgS_det {l : Loc} {v1 v2 : Val} {σ : State} {obs e' σ' efs} + (h : get? (M := HeapF) σ.heap l = some (some v1)) + (hs : BaseStep (.xchg (.val (.lit (.loc l))) (.val v2)) σ obs e' σ' efs) : + obs = [] ∧ e' = (ToVal.ofVal v1 : Exp) ∧ σ' = σ.initHeap l 1 (some v2) ∧ efs = [] := by + cases hs with + | xchgS _ v1' _ _ h' => + simp only [State.get?] at h' + rw [h] at h' + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at h' + subst h' + refine ⟨rfl, rfl, rfl, rfl⟩ + +theorem faaS_det {l : Loc} {i1 i2 : Int} {σ : State} {obs e' σ' efs} + (h : get? (M := HeapF) σ.heap l = some (some (Val.lit (.int i1)))) + (hs : BaseStep (.faa (.val (.lit (.loc l))) (.val (.lit (.int i2)))) σ obs e' σ' efs) : + obs = [] ∧ e' = (ToVal.ofVal (Val.lit (.int i1)) : Exp) ∧ + σ' = σ.initHeap l 1 (some (Val.lit (.int (i1 + i2)))) ∧ efs = [] := by + cases hs with + | faaS _ i1' _ _ h' => + simp only [State.get?] at h' + rw [h] at h' + simp only [Option.some.injEq, Val.lit.injEq, BaseLit.int.injEq] at h' + subst h' + refine ⟨rfl, rfl, rfl, rfl⟩ + +theorem cmpXchgS_det_true {l : Loc} {v1 v2 vl : Val} {σ : State} {obs e' σ' efs} + (h : get? (M := HeapF) σ.heap l = some (some vl)) (htrue : decide (vl = v1) = true) + (hs : BaseStep (.cmpXchg (.val (.lit (.loc l))) (.val v1) (.val v2)) σ obs e' σ' efs) : + obs = [] ∧ e' = (ToVal.ofVal (Val.pair vl (.lit (.bool true))) : Exp) ∧ + σ' = σ.initHeap l 1 (some v2) ∧ efs = [] := by + cases hs with + | cmpXchgS _ _ _ vl' _ b' h' hcs' hb' => + simp only [State.get?] at h' + rw [h] at h' + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at h' + subst h' + rw [htrue] at hb' + subst hb' + refine ⟨rfl, rfl, rfl, rfl⟩ + +theorem cmpXchgS_det_false {l : Loc} {v1 v2 vl : Val} {σ : State} {obs e' σ' efs} + (h : get? (M := HeapF) σ.heap l = some (some vl)) (hfalse : decide (vl = v1) = false) + (hs : BaseStep (.cmpXchg (.val (.lit (.loc l))) (.val v1) (.val v2)) σ obs e' σ' efs) : + obs = [] ∧ e' = (ToVal.ofVal (Val.pair vl (.lit (.bool false))) : Exp) ∧ + σ' = σ ∧ efs = [] := by + cases hs with + | cmpXchgS _ _ _ vl' _ b' h' hcs' hb' => + simp only [State.get?] at h' + rw [h] at h' + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at h' + subst h' + rw [hfalse] at hb' + subst hb' + refine ⟨rfl, rfl, rfl, rfl⟩ + +/-! ### Multi-cell allocation helpers (for the `allocN` branch). + +`allocN n v` writes `v` into `n` consecutive fresh locations. The state update +`State.initHeap` is a left-fold of single inserts; the lemmas below characterise +its heap pointwise and as a left-biased union with a freshly-built block +`allocCells`, which is what lets `genHeap_alloc_big` produce the new points-to and +meta tokens. -/ + +/-- A block of `n` cells all holding `v`, starting at `l` (`l, l+1, …, l+(n-1)`). +This is `(State.initHeap σ l n v).heap` with the existing heap `σ.heap` removed. -/ +def allocCells (l : Loc) (n : Nat) (v : Option Val) : HeapF (Option Val) := + (List.range n).foldl (fun h (i : Nat) => Std.insert (M := HeapF) h (l + (i : Int)) v) ∅ + +theorem get?_foldl_insert (l : Loc) (v : Option Val) (m : HeapF (Option Val)) (n : Nat) (k : Loc) : + get? (M := HeapF) ((List.range n).foldl + (fun h (i : Nat) => Std.insert (M := HeapF) h (l + (i : Int)) v) m) k + = if (∃ i, i < n ∧ k = l + (i : Int)) then some v else get? (M := HeapF) m k := by + induction n with + | zero => simp + | succ n ih => + rw [List.range_succ, List.foldl_append, List.foldl_cons, List.foldl_nil, + Iris.Std.LawfulPartialMap.get?_insert, ih] + by_cases hk : (l + (n : Int)) = k + · rw [if_pos hk, if_pos ⟨n, Nat.lt_succ_self n, hk.symm⟩] + · rw [if_neg hk] + by_cases hex : ∃ i, i < n ∧ k = l + (i : Int) + · obtain ⟨i, hi, hki⟩ := hex + rw [if_pos ⟨i, hi, hki⟩, if_pos ⟨i, Nat.lt_succ_of_lt hi, hki⟩] + · rw [if_neg hex, if_neg] + rintro ⟨i, hi, hki⟩ + rcases Nat.lt_succ_iff_lt_or_eq.mp hi with hi' | rfl + · exact hex ⟨i, hi', hki⟩ + · exact hk hki.symm + +theorem get?_allocCells {l : Loc} {n : Nat} {v : Option Val} {k : Loc} : + get? (M := HeapF) (allocCells l n v) k + = if (∃ i, i < n ∧ k = l + (i : Int)) then some v else none := by + rw [allocCells, get?_foldl_insert] + simp only [LawfulPartialMap.get?_empty] + +/-- `State.initHeap` is the left-biased union of the fresh block with the old heap. -/ +theorem initHeap_heap_eq {σ : State} {l : Loc} {n : Int} {v : Option Val} : + Iris.Std.PartialMap.equiv (M := HeapF) (σ.initHeap l n v).heap + (Iris.Std.PartialMap.union (allocCells l n.toNat v) σ.heap) := by + intro k + show get? (M := HeapF) ((List.range n.toNat).foldl + (fun h (i : Nat) => Std.insert (M := HeapF) h (l + (i : Int)) v) σ.heap) k = _ + rw [get?_foldl_insert, Iris.Std.LawfulPartialMap.get?_union, get?_allocCells] + by_cases hex : ∃ i, i < n.toNat ∧ k = l + (i : Int) + · simp only [if_pos hex, Option.orElse] + · simp only [if_neg hex, Option.orElse] + +theorem allocCells_disjoint {l : Loc} {n : Int} {v : Val} {m : HeapF (Option Val)} + (hf : ∀ i : Int, 0 ≤ i → i < n → get? (M := HeapF) m (l + i) = none) : + Std.PartialMap.disjoint (M := HeapF) (allocCells l n.toNat (some v)) m := by + intro k ⟨h1, h2⟩ + rw [get?_allocCells] at h1 + split at h1 <;> rename_i hcond + · obtain ⟨i, hi, hki⟩ := hcond + rw [hki, hf (i : Int) (Int.natCast_nonneg i) (by omega)] at h2 + simp at h2 + · simp at h1 + +private theorem mem_le_foldr_max (x : Int) (L : List Int) (h : x ∈ L) : + x ≤ L.foldr max 0 := by + induction L with + | nil => simp at h + | cons a L ih => + simp only [List.foldr_cons] + rcases List.mem_cons.mp h with rfl | h + · omega + · have := ih h; omega + +/-- Any heap has a fresh block of `n` consecutive locations: pick a base strictly +above every used location's address. This is the reducibility witness for the +`allocN` lift, replacing Rocq's built-in `fresh_locs`. -/ +theorem exists_fresh_block (m : HeapF (Option Val)) (n : Int) : + ∃ l : Loc, ∀ i : Int, 0 ≤ i → i < n → get? (M := HeapF) m (l + i) = none := by + refine ⟨Loc.mk ((m.keys.map Loc.n).foldr max 0 + 1), fun i hi0 hin => ?_⟩ + have hnotmem : (Loc.mk ((m.keys.map Loc.n).foldr max 0 + 1) + i) ∉ m.keys := by + intro hmem + have hle : (Loc.mk ((m.keys.map Loc.n).foldr max 0 + 1) + i).n + ≤ (m.keys.map Loc.n).foldr max 0 := + mem_le_foldr_max _ _ (List.mem_map_of_mem hmem) + simp only [loc_add_n] at hle + omega + simpa [get?, getElem?_eq_none_iff, ← Std.ExtTreeMap.mem_keys] using hnotmem + +private theorem coPset_top_ne_empty : (⊤ : CoPset) ≠ ∅ := by + intro h + have hm : Pos.xH ∈ (⊤ : CoPset) := CoPset.mem_full + rw [h] at hm + exact CoPset.mem_empty hm + +/-- The heap-only completeness equation: case analysis on the base step. Mirrors +`wp_base_completeness` in `case_studies/heaplang/completeness_generic.v`. -/ +theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) + (Hred : BaseStep.Reducible (e₁, σ)) : + heap_inv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by + iintro Hinv + obtain ⟨κ, e', σ', efs, Hstep⟩ := Hred + cases Hstep with + | recS f x e σ => + iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.recS f x e σ')) $$ Hinv + | pairS v1 v2 σ => + iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.pairS v1 v2 σ')) $$ Hinv + | injLS v σ => + iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.injLS v σ')) $$ Hinv + | injRS v σ => + iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.injRS v σ')) $$ Hinv + | betaS f x eb v2 e' σ h => + subst h + iapply (wp_base_pure trivial σ E + (fun σ' => BaseStep.betaS f x eb v2 _ σ' rfl)) $$ Hinv + | unOpS op v v' σ h => + iapply (wp_base_pure (hpe := instPureExecUnOp) h σ E + (fun σ' => BaseStep.unOpS op v v' σ' h)) $$ Hinv + | binOpS op v1 v2 v' σ h => + iapply (wp_base_pure (hpe := instPureExecBinOp) h σ E + (fun σ' => BaseStep.binOpS op v1 v2 v' σ' h)) $$ Hinv + | ifTrueS et ee σ => + iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.ifTrueS e' ee σ')) $$ Hinv + | ifFalseS et ee σ => + iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.ifFalseS et e' σ')) $$ Hinv + | fstS v1 v2 σ => + iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.fstS v1 v2 σ')) $$ Hinv + | sndS v1 v2 σ => + iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.sndS v1 v2 σ')) $$ Hinv + | caseLS v et ee σ => + iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.caseLS v et ee σ')) $$ Hinv + | caseRS v et ee σ => + iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.caseRS v et ee σ')) $$ Hinv + | loadS l v σ hl => + iapply (wp_base_atomic_nochange (v₂ := v) l v σ E + (base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.loadS l v σ hl)) hl + (fun σ'' h => BaseStep.loadS l v σ'' h) loadS_det) $$ Hinv + | storeS l v w σ hl => + iapply (wp_base_atomic (v₂ := .lit .unit) l v (some w) σ E + (base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.storeS l v w σ hl)) hl + (fun σ'' h => BaseStep.storeS l v w σ'' h) (fun _ hs => storeS_det hs)) $$ Hinv + | freeS l v σ hl => + iapply (wp_base_atomic (v₂ := .lit .unit) l v none σ E + (base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.freeS l v σ hl)) hl + (fun σ'' h => BaseStep.freeS l v σ'' h) (fun _ hs => freeS_det hs)) $$ Hinv + | xchgS l v1 v2 σ hl => + iapply (wp_base_atomic (v₂ := v1) l v1 (some v2) σ E + (base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.xchgS l v1 v2 σ hl)) hl + (fun σ'' h => BaseStep.xchgS l v1 v2 σ'' h) xchgS_det) $$ Hinv + | faaS l i1 i2 σ hl => + iapply (wp_base_atomic (v₂ := .lit (.int i1)) l (.lit (.int i1)) + (some (.lit (.int (i1 + i2)))) σ E + (base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.faaS l i1 i2 σ hl)) hl + (fun σ'' h => BaseStep.faaS l i1 i2 σ'' h) faaS_det) $$ Hinv + | cmpXchgS l v1 v2 vl σ b hl hcs hb => + cases hb1 : decide (vl = v1) with + | true => + iapply (wp_base_atomic (v₂ := .pair vl (.lit (.bool true))) l vl (some v2) σ E + (base_step_to_val_atomic Atomicity.StronglyAtomic + (BaseStep.cmpXchgS l v1 v2 vl σ true hl hcs (by rw [hb1]))) + hl + (fun σ'' h => by + have := BaseStep.cmpXchgS l v1 v2 vl σ'' true h hcs (by rw [hb1]) + simpa using this) + (fun h hs => cmpXchgS_det_true h hb1 hs)) $$ Hinv + | false => + iapply (wp_base_atomic_nochange (v₂ := .pair vl (.lit (.bool false))) l vl σ E + (base_step_to_val_atomic Atomicity.StronglyAtomic + (BaseStep.cmpXchgS l v1 v2 vl σ false hl hcs (by rw [hb1]))) + hl + (fun σ'' h => by + have := BaseStep.cmpXchgS l v1 v2 vl σ'' false h hcs (by rw [hb1]) + simpa using this) + (fun h hs => cmpXchgS_det_false h hb1 hs)) $$ Hinv + | forkS e σ => + -- Fork lands in the non-atomic disjunct: the forked thread `e` becomes the + -- single forked expression `efs = [e]`, and the parent steps to `#()`. + imodintro + iright + iframe Hinv + iintro %Φ %E₂ H + iapply wp_fork_fupd + iintro !> + ihave Htraj : iprop(∀ σ₁, heap_inv σ₁ ={E}=∗ + ∃ κ σ₁', ⌜PrimSteps (.fork e) σ₁ κ (.val (.lit .unit)) σ₁' [e]⌝ ∗ heap_inv σ₁') $$ [] + · iintro %σ₁ Hheap + imodintro + iexists [], σ₁ + iframe Hheap + ipureintro + exact PrimSteps.once (EctxLanguage.primStep_of_baseStep (BaseStep.forkS e σ₁)) + imod H $$ Htraj with ⟨HwpUnit, Hefs⟩ + isplitl [Hefs] + · iapply (BI.BigSepL.bigSepL_singleton (PROP := IProp GF)).1 $$ Hefs + · iapply (wp_value_fupd' (v := .lit .unit)).1 $$ HwpUnit + | allocNS n v σ l hn hfresh => + -- `allocN` is atomic and allocates a fresh block of `n` cells. + imodintro + ileft + have hatom : Atomic Atomicity.StronglyAtomic (Exp.allocN (.val (.lit (.int n))) (.val v)) := + base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.allocNS n v σ l hn hfresh) + iframe %hatom + iintro %Φ Hstep + iapply wp_lift_atomic_step + (EctxLanguage.val_stuck (BaseStep.allocNS n v σ l hn hfresh)) + iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ + -- Reducibility in `σ₁` from a fresh block. + obtain ⟨lf, hlf⟩ := exists_fresh_block σ₁.heap n + have Hred₁ : BaseStep.Reducible (Exp.allocN (.val (.lit (.int n))) (.val v), σ₁) := + ⟨[], _, _, [], BaseStep.allocNS n v σ₁ lf hn hlf⟩ + isplitr + · ipureintro + simp only [Stuckness.MaybeReducible] + exact EctxLanguage.primStep_reducible_of_baseStep_reducible Hred₁ + iintro !> %e₂ %σ₂ %eₜ %Hprim Hcr + cases EctxLanguage.baseStep_of_primStep_of_baseStep_reducible Hred₁ Hprim + rename_i l' Hpo Hi + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + -- Destructure `heap_inv σ` into its heap and prophecy conjuncts. + icases Hinv with ⟨Hmap, Hproph_inv⟩ + -- Allocate the new block in the state interpretation. + imod (genHeap_alloc_big (allocCells l' n.toNat (some v)) σ₁.heap (allocCells_disjoint Hi)) + $$ Hσ with ⟨Hσ', Hnewpts, Hnewmeta⟩ + -- Freshness of the block in `σ` (the `heap_inv` state), via `meta_token_ne`. + ihave %hfreshσ : ⌜∀ i : Int, 0 ≤ i → i < n → get? (M := HeapF) σ.heap (l' + i) = none⌝ + $$ [Hmap Hnewmeta] + · iintro %i %hi0 %hin + rcases hgc : get? (M := HeapF) σ.heap (l' + i) with _ | vo + · itrivial + · icases (BigSepM.bigSepM_lookup_acc (M := HeapF) + (Φ := fun (k : Loc) (vo : Option Val) => iprop(heapCellPts k vo ∗ metaToken k ⊤)) hgc).1 + $$ Hmap with ⟨⟨_, Hmeta1⟩, _⟩ + have hcell_new : get? (M := HeapF) (allocCells l' n.toNat (some v)) (l' + i) + = some (some v) := by + rw [get?_allocCells, if_pos ⟨i.toNat, by omega, by rw [Int.toNat_of_nonneg hi0]⟩] + icases (BigSepM.bigSepM_lookup_acc (M := HeapF) + (Φ := fun (k : Loc) (_vo : Option Val) => iprop(metaToken k ⊤)) hcell_new).1 + $$ Hnewmeta with ⟨Hmeta2, _⟩ + icases metaToken_ne coPset_top_ne_empty $$ Hmeta1 Hmeta2 with %hne + exact absurd rfl hne + -- Instantiate the magic premise with the base step from `σ` at `l'`. + imod Hstep $$ [] with ⟨Hpost, _⟩ + · ipureintro + exact EctxLanguage.primStep_of_baseStep (BaseStep.allocNS n v σ l' hn hfreshσ) + imodintro + isplitl [Hσ' Hproph] + · simp only [stateInterp] + isplitl [Hσ'] + · iapply genHeapInterp_eqv (Iris.Std.PartialMap.equiv.symm _ _ initHeap_heap_eq) + iexact Hσ' + · iexact Hproph + isplitl [Hpost Hmap Hproph_inv Hnewpts Hnewmeta] + · iexists (.lit (.loc l')) + isplit + · ipureintro; simp [toVal]; rfl + iapply Hpost + simp only [heap_inv] + isplitl [Hmap Hnewpts Hnewmeta] + · iapply (BigSepM.bigSepM_eqv_of_perm + (Φ := fun (k : Loc) (vo : Option Val) => iprop(heapCellPts k vo ∗ metaToken k ⊤)) + initHeap_heap_eq).2 + iapply (BigSepM.bigSepM_union + (Φ := fun (k : Loc) (vo : Option Val) => iprop(heapCellPts k vo ∗ metaToken k ⊤)) + (allocCells_disjoint hfreshσ)).2 + isplitl [Hnewpts Hnewmeta] + · iapply (Iris.BI.equiv_iff.mp (BigSepM.bigSepM_sep_eqv (M := HeapF) + (Φ := fun (k : Loc) (vo : Option Val) => heapCellPts k vo) + (Ψ := fun (k : Loc) (_vo : Option Val) => iprop(metaToken k ⊤)))).2 + -- Convert the raw points-tos of the freshly-allocated (live) cells + -- into cell invariants before framing. + ihave Hnewpts := (BigSepM.bigSepM_mono_of_forall + (fun {k vo} => pointsTo_heapCellPts k vo)) $$ Hnewpts + iframe Hnewpts Hnewmeta + · iexact Hmap + · iexact Hproph_inv + · itrivial + | newProphS σ p hp => + -- `newProph` is atomic and allocates a fresh prophecy variable. + imodintro + ileft + have hatom : Atomic Atomicity.StronglyAtomic (Exp.newProph : Exp) := + base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.newProphS σ p hp) + iframe %hatom + iintro %Φ Hstep + iapply wp_lift_atomic_step + (EctxLanguage.val_stuck (BaseStep.newProphS σ p hp)) + iintro %σ₁ %ns %obs %obs' %nt Hσ !> + icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ + -- Pick a prophecy id fresh in `σ₁.usedProphId`. + obtain ⟨pf, Hpf⟩ := Iris.Std.List.fresh σ₁.usedProphId.toList + have Hpf_contains : ¬ σ₁.usedProphId.contains pf := by + intro hc; exact Hpf (Std.ExtTreeSet.mem_toList.mpr hc) + have Hred₁ : BaseStep.Reducible (Exp.newProph, σ₁) := + ⟨[], _, _, [], BaseStep.newProphS σ₁ pf Hpf_contains⟩ + isplitr + · ipureintro + simp only [Stuckness.MaybeReducible] + exact EctxLanguage.primStep_reducible_of_baseStep_reducible Hred₁ + iintro !> %e₂ %σ₂ %eₜ %Hprim Hcr + cases EctxLanguage.baseStep_of_primStep_of_baseStep_reducible Hred₁ Hprim + rename_i p' Hp' + ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph + have Hp'_mem : p' ∉ σ₁.usedProphId := + fun hmem => Hp' (Std.ExtTreeSet.mem_iff_contains.symm.mp hmem) + imod (ProphMap.new_proph p' σ₁.usedProphId obs' Hp'_mem) $$ Hproph + with ⟨Hproph', Htok⟩ + -- Destructure `heap_inv σ` and derive that `p'` is fresh in `σ` via + -- `proph_exclusive` against `Hproph_inv`. + icases Hinv with ⟨Hmap, Hproph_inv⟩ + ihave %Hfresh_σ : ⌜p' ∉ σ.usedProphId⌝ $$ [Hproph_inv Htok] + · iintro %hmem + icases Iris.BI.BigSepS.bigSepS_elem_of_acc hmem $$ Hproph_inv with ⟨⟨%pvs', Htok'⟩, _⟩ + iapply proph_exclusive $$ Htok Htok' + have Hfresh_σ_contains : ¬ σ.usedProphId.contains p' := fun hc => + Hfresh_σ (Std.ExtTreeSet.mem_iff_contains.symm.mpr hc) + -- Instantiate the magic premise with the `newProph` step from `σ` at `p'`. + imod Hstep $$ [] with ⟨Hpost, _⟩ + · ipureintro + exact EctxLanguage.primStep_of_baseStep (BaseStep.newProphS σ p' Hfresh_σ_contains) + imodintro + isplitl [Hσ Hproph'] + · simp only [stateInterp] + iframe Hσ + rw [show ({p'} ∪ σ₁.usedProphId : Std.ExtTreeSet ProphId compare) + = σ₁.usedProphId.insert p' from usedProph_insert_eq.symm] + iexact Hproph' + isplitl [Hpost Hmap Hproph_inv Htok] + · iexists (.lit (.prophecy p')) + isplit + · ipureintro; simp [toVal]; rfl + iapply Hpost + simp only [heap_inv] + isplitl [Hmap] + · iexact Hmap + · -- goal: bigSepS (σ.usedProphId.insert p') (∃ pvs, proph) + rw [usedProph_insert_eq (ps := σ.usedProphId) (p := p')] + have hdisj : ({p'} : Std.ExtTreeSet ProphId compare) ## σ.usedProphId := by + intro x ⟨h1, h2⟩ + rw [Iris.Std.LawfulSet.mem_singleton] at h1 + subst h1 + exact Hfresh_σ h2 + iapply (Iris.BI.BigSepS.bigSepS_union hdisj).mpr + isplitl [Htok] + · iapply Iris.BI.BigSepS.bigSepS_singleton.mpr + iexists (prophListResolves obs' p') + iexact Htok + · iexact Hproph_inv + · itrivial + | resolveS p v e σ w σ' κs ts hbase hp => + -- Mirror of `completeness_generic.v:127–159`. Resolve is atomic since the + -- inner step `hbase` produces a value in one base step. We recurse on + -- `hbase` to get the completeness equation for `e`, then lift through + -- the `Resolve` wrapper via `wp_resolve_strong`. + have IH : heap_inv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e σ E) := + wp_base_completeness e σ E ⟨κs, _, _, _, hbase⟩ + have hatom : Atomic Atomicity.StronglyAtomic + (Exp.resolve e (.val (.lit (.prophecy p))) (.val w)) := + base_step_to_val_atomic Atomicity.StronglyAtomic + (BaseStep.resolveS p v e σ w σ' κs efs hbase hp) + have hatom_e : Atomic Atomicity.StronglyAtomic e := + base_step_to_val_atomic Atomicity.StronglyAtomic hbase + have hne_e : toVal e = none := EctxLanguage.val_stuck hbase + have hp_mem : p ∈ σ.usedProphId := Std.ExtTreeSet.mem_iff_contains.symm.mpr hp + imodintro + ileft + iframe %hatom + iintro %Φ Hstep + icases Hinv with ⟨Hmap, Hproph_inv⟩ + icases Iris.BI.BigSepS.bigSepS_elem_of_acc hp_mem $$ Hproph_inv + with ⟨⟨%pvs, Htok⟩, HcloseProph⟩ + iapply (wp_resolve_strong hatom_e hne_e) $$ Htok + iintro Hele + ihave Hinv_full : iprop(heap_inv σ) $$ [Hmap HcloseProph Hele] + · unfold heap_inv + iframe Hmap + iapply HcloseProph + iexists pvs; iexact Hele + ihave Hinner : iprop(|={E}=> baseCompletenessGoal e σ E) $$ [Hinv_full] + · iapply IH; iexact Hinv_full + iapply fupd_wp + imod Hinner with H + imodintro + icases H with (⟨_hatom_e', Hrst⟩ | ⟨Hinv_back, Hrst_nonatom⟩) + · -- Atomic disjunct: feed `Hrst` the resolve-strong post for `e`. + iapply Hrst + iintro !> %κ_e %v_e %σ_e %efs_e %Hprim_e + have Hbase_e : BaseStep e σ κ_e (.val v_e) σ_e efs_e := + primStep_val_baseStep Hprim_e + imod Hstep $$ %_ %_ %_ %_ %(prim_step_resolve_of_inner (w := w) Hbase_e hp) + with ⟨Hwp_outer, Hefs⟩ + imodintro + iframe Hefs + iintro ⟨Hmap_e, Hproph_inv_e⟩ + have hp_mem_e : p ∈ σ_e.usedProphId := + base_step_more_proph_ids Hbase_e p hp_mem + icases Iris.BI.BigSepS.bigSepS_elem_of_acc hp_mem_e $$ Hproph_inv_e + with ⟨⟨%pvs2, Hele2⟩, HcloseProph_e⟩ + iexists pvs2 + iframe Hele2 + iintro %pvs'' %heq Hele2' + subst heq + iapply Hwp_outer + unfold heap_inv + iframe Hmap_e + iapply HcloseProph_e + iexists pvs''; iexact Hele2' + · -- Non-atomic disjunct: symmetric to the atomic case, plus extracting + -- the single prim step from the trajectory via `primSteps_atomic`. + iapply Hrst_nonatom + iintro !> %e₂_e %efs_e Htraj_e + imod Htraj_e $$ %_ Hinv_back with ⟨%κ_e, %σ_e, %Hprims, ⟨Hmap_e, Hproph_inv_e⟩⟩ + obtain ⟨Hprim_e, hval_e⟩ := + ProgramLogic.primSteps_atomic (e := e) hatom_e Hprims + obtain ⟨v_e, rfl⟩ : ∃ v_e, e₂_e = Exp.val v_e := by + match e₂_e, hval_e with + | .val v_e, _ => exact ⟨v_e, rfl⟩ + have Hbase_e : BaseStep e σ κ_e (.val v_e) σ_e efs_e := + primStep_val_baseStep Hprim_e + imod Hstep $$ %_ %_ %_ %_ %(prim_step_resolve_of_inner (w := w) Hbase_e hp) + with ⟨Hwp_outer, Hefs⟩ + imodintro + have hp_mem_e : p ∈ σ_e.usedProphId := + base_step_more_proph_ids Hbase_e p hp_mem + icases Iris.BI.BigSepS.bigSepS_elem_of_acc hp_mem_e $$ Hproph_inv_e + with ⟨⟨%pvs2, Hele2⟩, HcloseProph_e⟩ + isplitl [Hele2 Hwp_outer Hmap_e HcloseProph_e] + · -- WP (Val v_e) {{ strong-post }} — apply wp_value', witness pvs2. + iapply wp_value' + iexists pvs2 + iframe Hele2 + iintro %pvs'' %heq Hele2' + subst heq + iapply Hwp_outer + unfold heap_inv + iframe Hmap_e + iapply HcloseProph_e + iexists pvs''; iexact Hele2' + · iexact Hefs +termination_by e₁ + +section Framework + +variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] [TI : TpinvGS GF Exp H] + +/-- The framework-facing heap-lang completeness equation: the `ectx`-level +soundness equation specialized to heap_lang's `heap_inv`. Mirrors +`wp_base_completeness_actual` in `case_studies/heaplang/completeness_generic.v`. -/ +theorem wp_base_completeness_actual + (n : Nat) (C : List Exp) (e₁ : Exp) (σ : State) (K : List ECtxItem) (E : CoPset) : + ⊢ ectxLangCompletenessStmt (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) + (fun (_ : List Exp) (σ : State) => heap_inv σ) n C e₁ σ K E := by + unfold ectxLangCompletenessStmt + iintro %Hred Htok ⟨Hheap, Htp, %Hsafe⟩ + imod (wp_base_completeness e₁ σ E Hred) $$ Hheap with (⟨%Hatom, H⟩ | ⟨Hheap, H⟩) + · -- Atomic redex. + imodintro + ileft + have Hwa : Atomic Atomicity.WeaklyAtomic e₁ := stronglyAtomic_atomic Hatom + iframe %Hwa + iintro %Φ Hx + iapply H + iintro !> %κ %v₂ %σ' %efs %Hprim + iapply Hx $$ [] Htok Htp + ipureintro; exact Hprim + · -- Non-atomic redex. + imodintro + iright + iframe Hheap Htp + iintro %Φ Hx + iapply H + iintro !> %e₂ %efs HH + iapply Hx + iintro %σ₁ %C₁ ⟨Hsi, Htp, %_Hs⟩ + imod HH $$ Hsi with ⟨%κ, %σ₁', %Hprims, Hhp⟩ + imodintro + iexists κ, σ₁' + iframe Htok Htp Hhp + ipureintro + exact Hprims + +/-- HeapLang is an instance of the abstract ectx-completeness theory. Mirrors +`heap_lang_completeness` in `case_studies/heaplang/completeness_generic.v`. -/ +instance heap_lang_completeness : + AbstractEctxLangCompletenessGen (Expr := Exp) (Ectx := List ECtxItem) + (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where + heap_inv _C σ := heap_inv σ + heap_inv_timeless _C σ := heap_inv_timeless σ + ectx_lang_completeness n _C e₁ σ K E := wp_base_completeness_actual n _C e₁ σ K E + +end Framework + +section Endpoint + +/-- **Top-level heap-lang completeness**: an adequate program admits a WP with the +adequacy postcondition. Mirrors `heap_lang_sem_completeness` in +`case_studies/heaplang/completeness_classical.v`. -/ +theorem heap_lang_sem_completeness {H : Type _ → Type _} [LawfulFiniteMap H Nat] + [GhostMapG GF Nat Exp H] [CInvG GF] + (e : Exp) (σ : State) (φ : Val → Prop) + (Hade : adequate Stuckness.NotStuck e σ (fun v _ => φ v)) : + ⊢ heap_inv (GF := GF) σ -∗ WP e @ Stuckness.NotStuck; ⊤ {{ v, ⌜φ v⌝ }} := by + iintro Hheap + imod (tpInv_alloc (GF := GF) (Expr := Exp) (H := H)) with ⟨%γ, Hini⟩ + letI TI : TpinvGS GF Exp H := { toGhostMapG := inferInstance, tp_name := γ } + ihave Hwp := weakestpre_sem_completeness + (wp := Wp.wp (PROP := IProp GF) Stuckness.NotStuck) e σ φ Hade $$ Hini Hheap + iexact Hwp + +/-- Nofork variant. Mirrors `heap_lang_sem_completeness_nofork`. -/ +theorem heap_lang_sem_completeness_nofork {H : Type _ → Type _} [LawfulFiniteMap H Nat] + [GhostMapG GF Nat Exp H] [CInvG GF] + (e : Exp) (σ : State) (φ : Val → State → Prop) + (Hade : AdequateNoFork Stuckness.NotStuck e σ (fun v σ' => φ v σ')) : + ⊢ heap_inv (GF := GF) σ -∗ + WP e @ Stuckness.NotStuck; ⊤ {{ v, ∃ σ' : State, heap_inv σ' ∗ ⌜φ v σ'⌝ }} := by + iintro Hheap + imod (tpInv_alloc (GF := GF) (Expr := Exp) (H := H)) with ⟨%γ, Hini⟩ + letI TI : TpinvGS GF Exp H := { toGhostMapG := inferInstance, tp_name := γ } + ihave Hwp := weakestpre_sem_completeness_nofork + (wp := Wp.wp (PROP := IProp GF) Stuckness.NotStuck) e σ φ Hade $$ Hini Hheap + iexact Hwp + +end Endpoint + +end Iris.HeapLang From 096e105cc4d07c6705bb0f178bb579c0fa3c2b47 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Wed, 8 Jul 2026 12:10:29 +0900 Subject: [PATCH 22/33] fix build --- Iris/Iris/HeapLang/Completeness.lean | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/Iris/Iris/HeapLang/Completeness.lean b/Iris/Iris/HeapLang/Completeness.lean index e7fb13376..254ac40c4 100644 --- a/Iris/Iris/HeapLang/Completeness.lean +++ b/Iris/Iris/HeapLang/Completeness.lean @@ -388,10 +388,11 @@ theorem initHeap_heap_eq {σ : State} {l : Loc} {n : Int} {v : Option Val} : intro k show get? (M := HeapF) ((List.range n.toNat).foldl (fun h (i : Nat) => Std.insert (M := HeapF) h (l + (i : Int)) v) σ.heap) k = _ - rw [get?_foldl_insert, Iris.Std.LawfulPartialMap.get?_union, get?_allocCells] + rw [get?_foldl_insert] + simp only [Iris.Std.PartialMap.union, Iris.Std.LawfulPartialMap.get?_merge, get?_allocCells] by_cases hex : ∃ i, i < n.toNat ∧ k = l + (i : Int) - · simp only [if_pos hex, Option.orElse] - · simp only [if_neg hex, Option.orElse] + · simp only [if_pos hex]; cases get? (M := HeapF) σ.heap k <;> rfl + · simp only [if_neg hex]; cases get? (M := HeapF) σ.heap k <;> rfl theorem allocCells_disjoint {l : Loc} {n : Int} {v : Val} {m : HeapF (Option Val)} (hf : ∀ i : Int, 0 ≤ i → i < n → get? (M := HeapF) m (l + i) = none) : @@ -435,6 +436,16 @@ private theorem coPset_top_ne_empty : (⊤ : CoPset) ≠ ∅ := by rw [h] at hm exact CoPset.mem_empty hm +/-- Inserting a prophecy id into the used-id set is the same as unioning in the +singleton, phrased for the native `ExtTreeSet.insert`. -/ +theorem usedProph_insert_eq {ps : Std.ExtTreeSet ProphId compare} {p : ProphId} : + ps.insert p = ({p} ∪ ps : Std.ExtTreeSet ProphId compare) := by + apply Std.ExtTreeSet.ext_mem + intro x + rw [Std.ExtTreeSet.mem_union_iff, Std.ExtTreeSet.mem_insert, + Iris.Std.mem_singleton_extTreeSet, Std.LawfulEqCmp.compare_eq_iff_eq] + exact ⟨fun h => h.imp Eq.symm id, fun h => h.imp Eq.symm id⟩ + /-- The heap-only completeness equation: case analysis on the base step. Mirrors `wp_base_completeness` in `case_studies/heaplang/completeness_generic.v`. -/ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) From 58597b2ac77cf1bba3be8ff9aca0f663de2e5b9a Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Sat, 18 Jul 2026 11:51:45 -0400 Subject: [PATCH 23/33] minor --- Iris/Iris/HeapLang/Completeness.lean | 259 +++++++++------------------ 1 file changed, 87 insertions(+), 172 deletions(-) diff --git a/Iris/Iris/HeapLang/Completeness.lean b/Iris/Iris/HeapLang/Completeness.lean index 254ac40c4..5dcadd525 100644 --- a/Iris/Iris/HeapLang/Completeness.lean +++ b/Iris/Iris/HeapLang/Completeness.lean @@ -14,38 +14,7 @@ public import Iris.Instances.Lib.CInvariants public import Iris.Instances.Lib.GhostMap public import Iris.ProofMode -/-! # HeapLang completeness - -Ports `case_studies/heaplang/completeness_generic.v` and -`completeness_classical.v`. `heap_inv` carries Rocq's two conjuncts: per-cell -`heapCellPts ∗ meta_token` (mirroring `from_option (λ v, ℓ ↦ v) ⌜True⌝` — a live -cell owns its points-to, a freed `none` cell owns nothing), and -`∃ pvs, proph p pvs` for every prophecy id in `σ.usedProphId`. `stateInterp` -includes `prophMapInterp κs σ.usedProphId` alongside `genHeapInterp σ.heap`. - -Status of `wp_base_completeness` (the base-step case analysis): -* pure branches (`rec`/`pair`/`injL`/`injR`/`beta`/`unop`/`binop`/`if`/`fst`/ - `snd`/`case`) — via `wp_base_pure` + the `PureExec` instances/lemmas; -* atomic heap branches (`load`/`store`/`free`/`xchg`/`faa`/`cmpXchg`) — via - `wp_base_atomic`(`_nochange`) + the per-op determinism lemmas; -* `fork` — via the non-atomic disjunct and `wp_fork_fupd`; -* `alloc` — via `genHeap_alloc_big`, with location freshness from `meta_token_ne`; -* `newProph` — atomic lift, fresh `p` picked in `σ₁.usedProphId`, then - `ProphMap.new_proph` allocates a proph token; freshness in `σ` follows from - `proph_exclusive` against the proph conjunct of `heap_inv σ`; -* `resolve` — `sorry` body, but `wp_base_completeness` is now a well-founded - recursion on `e₁` (declared via `termination_by e₁`), so the resolveS branch - has the inductive hypothesis `IH : heap_inv σ ⊢ |={E}=> baseCompletenessGoal - e σ E` in scope for the inner expression `e`. What remains is the body that - combines `IH` with the outer Resolve wrapping (mirror of Rocq lines 127–159): - extract `proph p` from `heap_inv σ`'s proph conjunct via `bigSepS_elem_of_acc` - + `hp : p ∈ σ.usedProphId`, then either inline a `wp_resolve_strong`-style - argument or split on `IH`'s atomic/non-atomic disjunction and use - `ProphMap.resolve_proph` to consume the front observation `(p,(v,w))` of - `κs`. All other supporting infrastructure (`prophMapInterp`, `proph p pvs`, - `ProphMap.resolve_proph`, the proph conjunct of `heap_inv`, the recursion) - is in place. --/ +/-! # HeapLang completeness -/ @[expose] public section namespace Iris.HeapLang @@ -54,64 +23,50 @@ open Iris ProgramLogic Iris.BI Language Language.Notation Std variable {hlc : HasLC} {GF : BundledGFunctors} [HeapLangGS hlc GF] -/-- Ownership of a single heap cell's points-to. Mirrors Rocq's -`from_option (λ v, ℓ ↦ v) ⌜True⌝`: a live cell `some v` contributes `l ↦ some v`, -while a freed cell `none` contributes no ownership (`emp`). Note iris-lean's -`l ↦ ·` is the raw `gen_heap` points-to over `Option Val`, unlike Rocq heap_lang's -sealed `↦` which always wraps `Some`; hence the explicit `match` here. -/ @[reducible] def heapCellPts (l : Loc) (vo : Option Val) : IProp GF := match vo with | some _ => iprop(l ↦ vo) | none => iprop(emp) -instance heapCellPts_timeless (l : Loc) (vo : Option Val) : +instance instTimeless_heapCellPts (l : Loc) (vo : Option Val) : Timeless (heapCellPts (GF := GF) l vo) := by cases vo <;> (unfold heapCellPts; infer_instance) -/-- The raw points-to entails the cell invariant: for a live cell it is the same -resource, for a freed cell the points-to is dropped (affinely). -/ +@[reducible] def cellInv (k : Loc) (vo : Option Val) : IProp GF := + iprop(heapCellPts k vo ∗ metaToken k ⊤) + theorem pointsTo_heapCellPts (l : Loc) (vo : Option Val) : (l ↦ vo) ⊢ heapCellPts (GF := GF) l vo := by cases vo with | some v => exact .rfl - | none => exact BI.Affine.affine - -/-- The heap-lang configuration invariant: ownership of every live heap cell's -points-to together with the `meta_token` of every cell (live or freed), and a -`proph` token for every used prophecy id. -Mirrors `heap_inv` in `case_studies/heaplang/completeness_generic.v`. -/ -@[reducible] def heap_inv (σ : State) : IProp GF := iprop( - (bigSepM (M := HeapF) (K := Loc) - (fun (l : Loc) (vo : Option Val) => iprop(heapCellPts l vo ∗ metaToken l ⊤)) σ.heap) ∗ - ([∗set] p ∈ σ.usedProphId, ∃ pvs : List (Val × Val), proph p pvs)) - -instance heap_inv_timeless (σ : State) : Timeless (heap_inv (GF := GF) σ) := by - unfold heap_inv; infer_instance - -/-- Common shape of the completeness equation for a single base step, packaged so -the per-branch proofs only have to supply the (atomic / non-atomic) disjunct. -/ + | none => exact Affine.affine + +@[reducible] def heapInv (σ : State) : IProp GF := iprop% + (bigSepM (M := HeapF) (fun l vo => iprop% heapCellPts l vo ∗ metaToken l ⊤) σ.heap) ∗ + ([∗set] p ∈ σ.usedProphId, ∃ pvs, proph p pvs) + +instance instTimeless_heapInv (σ : State) : Timeless (heapInv (GF := GF) σ) := by + unfold heapInv; infer_instance + abbrev baseCompletenessGoal (e₁ : Exp) (σ : State) (E : CoPset) : IProp GF := iprop( ((⌜Atomic Atomicity.StronglyAtomic e₁⌝ ∗ ∀ (Φ : Val → IProp GF), (▷ ∀ κ v₂ σ' efs, ⌜PrimStep.primStep (e₁, σ) κ ((ToVal.ofVal v₂ : Exp), σ', efs)⌝ ==∗ - ((heap_inv σ' -∗ Φ v₂) ∗ + ((heapInv σ' -∗ Φ v₂) ∗ [∗list] _i ↦ etp ∈ efs, WP etp @ Stuckness.NotStuck; ⊤ {{ _v, True }})) -∗ WP e₁ @ Stuckness.NotStuck; E {{ v, Φ v }}) ∨ - (heap_inv σ ∗ + (heapInv σ ∗ ∀ (Φ : Val → IProp GF) (E₂ : CoPset), - (▷ ∀ e₂ efs, (∀ σ₁, heap_inv σ₁ ={E}=∗ - ∃ κ σ₁', ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' efs⌝ ∗ heap_inv σ₁') ={E₂}=∗ + (▷ ∀ e₂ efs, (∀ σ₁, heapInv σ₁ ={E}=∗ + ∃ κ σ₁', ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' efs⌝ ∗ heapInv σ₁') ={E₂}=∗ WP e₂ @ Stuckness.NotStuck; E₂ {{ v, Φ v }} ∗ [∗list] _i ↦ etp ∈ efs, WP etp @ Stuckness.NotStuck; ⊤ {{ _v, True }}) -∗ WP e₁ @ Stuckness.NotStuck; E₂ {{ v, Φ v }}))) -/-- Pure-step branch of `wp_base_completeness`: a pure base step `e₁ → e₂` lands in -the non-atomic disjunct, stepping the WP with `PureExec` and witnessing the -trajectory with the (state-independent) base step. -/ theorem wp_base_pure {e₁ e₂ : Exp} {φ : Prop} [hpe : Language.PureExec φ 1 e₁ e₂] (hφ : φ) (σ : State) (E : CoPset) (hbase : ∀ σ' : State, BaseStep e₁ σ' [] e₂ σ' []) : - heap_inv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by + heapInv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by iintro Hinv unfold baseCompletenessGoal imodintro @@ -120,8 +75,8 @@ theorem wp_base_pure {e₁ e₂ : Exp} {φ : Prop} [hpe : Language.PureExec φ 1 iintro %Φ %E₂ H iapply wp_pure_step_later (Hexec := hpe) (Hφ := hφ) iintro !> _ - ihave Htraj : iprop(∀ σ₁, heap_inv σ₁ ={E}=∗ - ∃ κ σ₁', ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' []⌝ ∗ heap_inv σ₁') $$ [] + ihave Htraj : iprop(∀ σ₁, heapInv σ₁ ={E}=∗ + ∃ κ σ₁', ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' []⌝ ∗ heapInv σ₁') $$ [] · iintro %σ₁ Hinv₁ imodintro iexists [], σ₁ @@ -133,10 +88,6 @@ theorem wp_base_pure {e₁ e₂ : Exp} {φ : Prop} [hpe : Language.PureExec φ 1 imodintro iexact Hwp -/-- Atomic heap-step branch of `wp_base_completeness`: a deterministic heap -operation at a live location `l` (reading cell `some vlive`, writing `vnew`, -returning `v₂`) lands in the atomic disjunct. The WP's own step (via -`wp_lift_atomic_step`) exposes the later needed to strip the magic premise. -/ theorem wp_base_atomic {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (vnew : Option Val) (σ : State) (E : CoPset) (hatom : Atomic Atomicity.StronglyAtomic e₁) @@ -147,7 +98,7 @@ theorem wp_base_atomic {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (vnew : get? (M := HeapF) σ''.heap l = some (some vlive) → BaseStep e₁ σ'' obs e' σ''' efs → obs = [] ∧ e' = (ToVal.ofVal v₂ : Exp) ∧ σ''' = σ''.initHeap l 1 vnew ∧ efs = []) : - heap_inv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by + heapInv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by iintro ⟨Hmap, Hproph_inv⟩ unfold baseCompletenessGoal imodintro @@ -156,7 +107,7 @@ theorem wp_base_atomic {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (vnew : iintro %Φ Hstep -- For the live cell, `heapCellPts l (some vlive)` reduces to `l ↦ some vlive`. icases (BigSepM.bigSepM_insert_acc (M := HeapF) - (Φ := fun (k : Loc) (vo : Option Val) => iprop(heapCellPts k vo ∗ metaToken k ⊤)) hcell) + (Φ := cellInv) hcell) $$ Hmap with ⟨⟨Hpt, Hmeta⟩, Hclose⟩ iapply wp_lift_atomic_step (EctxLanguage.val_stuck (hbase σ hcell)) iintro %σ₁ %ns %obs %obs' %nt Hσ !> @@ -178,7 +129,10 @@ theorem wp_base_atomic {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (vnew : exact EctxLanguage.primStep_of_baseStep (hbase σ hcell) imodintro ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph - have hl0 : l + (0 : Int) = l := by cases l; simp only [HAdd.hAdd, Loc.mk.injEq]; grind + have hl0 : l + (0 : Int) = l := by + cases l + simp only [HAdd.hAdd, Loc.mk.injEq] + grind simp only [stateInterp, State.initHeap, Int.toNat_one, List.range_one, List.foldl_cons, Int.cast_ofNat_Int, List.foldl_nil, hl0, Algebra.BigOpL.bigOpL_nil] @@ -188,7 +142,7 @@ theorem wp_base_atomic {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (vnew : isplit · ipureintro; simp [toVal]; rfl iapply Hpost - simp only [heap_inv] + simp only [heapInv] isplitl [Hclose Hpt Hmeta] · iapply Hclose isplitl [Hpt] @@ -198,8 +152,6 @@ theorem wp_base_atomic {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (vnew : · iexact Hproph_inv · itrivial -/-- Atomic heap-step branch that leaves the heap unchanged (read-only ops: `load`, -failing `cmpXchg`). -/ theorem wp_base_atomic_nochange {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (σ : State) (E : CoPset) (hatom : Atomic Atomicity.StronglyAtomic e₁) @@ -210,7 +162,7 @@ theorem wp_base_atomic_nochange {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val get? (M := HeapF) σ''.heap l = some (some vlive) → BaseStep e₁ σ'' obs e' σ''' efs → obs = [] ∧ e' = (ToVal.ofVal v₂ : Exp) ∧ σ''' = σ'' ∧ efs = []) : - heap_inv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by + heapInv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by iintro ⟨Hmap, Hproph_inv⟩ unfold baseCompletenessGoal imodintro @@ -222,7 +174,7 @@ theorem wp_base_atomic_nochange {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ ihave %hcell1 : ⌜get? (M := HeapF) σ₁.heap l = some (some vlive)⌝ $$ [Hσ Hmap] · icases (BigSepM.bigSepM_lookup_acc (M := HeapF) - (Φ := fun (k : Loc) (vo : Option Val) => iprop(heapCellPts k vo ∗ metaToken k ⊤)) hcell).1 + (Φ := cellInv) hcell).1 $$ Hmap with ⟨⟨Hpt, _⟩, _⟩ icases genHeap_valid $$ [$Hσ $Hpt] with >%hh itrivial @@ -247,18 +199,11 @@ theorem wp_base_atomic_nochange {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val isplit · ipureintro; simp [toVal]; rfl iapply Hpost - simp only [heap_inv] + simp only [heapInv] iframe Hmap Hproph_inv · itrivial -/-! ### Per-operation determinism facts. - -These discharge the `hdet` argument of `wp_base_atomic`(`_nochange`): for a fixed -redex and a fixed value of the cell being acted on, the base step's output is -uniquely determined. In Rocq these are obtained for free by reasoning forward -with the concrete `wp_load`/`wp_store`/… rules; here the generic atomic helper -takes the determinism as an explicit side condition. Each is a one-constructor -`cases` followed by reading off the cell equation. -/ +/-! ### Per-operation determinism facts -/ theorem loadS_det {l : Loc} {v : Val} {σ : State} {obs e' σ' efs} (h : get? (M := HeapF) σ.heap l = some (some v)) @@ -341,16 +286,8 @@ theorem cmpXchgS_det_false {l : Loc} {v1 v2 vl : Val} {σ : State} {obs e' σ' e subst hb' refine ⟨rfl, rfl, rfl, rfl⟩ -/-! ### Multi-cell allocation helpers (for the `allocN` branch). +/-! ### Multi-cell allocation helpers -/ -`allocN n v` writes `v` into `n` consecutive fresh locations. The state update -`State.initHeap` is a left-fold of single inserts; the lemmas below characterise -its heap pointwise and as a left-biased union with a freshly-built block -`allocCells`, which is what lets `genHeap_alloc_big` produce the new points-to and -meta tokens. -/ - -/-- A block of `n` cells all holding `v`, starting at `l` (`l, l+1, …, l+(n-1)`). -This is `(State.initHeap σ l n v).heap` with the existing heap `σ.heap` removed. -/ def allocCells (l : Loc) (n : Nat) (v : Option Val) : HeapF (Option Val) := (List.range n).foldl (fun h (i : Nat) => Std.insert (M := HeapF) h (l + (i : Int)) v) ∅ @@ -362,7 +299,7 @@ theorem get?_foldl_insert (l : Loc) (v : Option Val) (m : HeapF (Option Val)) (n | zero => simp | succ n ih => rw [List.range_succ, List.foldl_append, List.foldl_cons, List.foldl_nil, - Iris.Std.LawfulPartialMap.get?_insert, ih] + Std.LawfulPartialMap.get?_insert, ih] by_cases hk : (l + (n : Int)) = k · rw [if_pos hk, if_pos ⟨n, Nat.lt_succ_self n, hk.symm⟩] · rw [if_neg hk] @@ -371,7 +308,7 @@ theorem get?_foldl_insert (l : Loc) (v : Option Val) (m : HeapF (Option Val)) (n rw [if_pos ⟨i, hi, hki⟩, if_pos ⟨i, Nat.lt_succ_of_lt hi, hki⟩] · rw [if_neg hex, if_neg] rintro ⟨i, hi, hki⟩ - rcases Nat.lt_succ_iff_lt_or_eq.mp hi with hi' | rfl + obtain hi' | rfl := Nat.lt_succ_iff_lt_or_eq.mp hi · exact hex ⟨i, hi', hki⟩ · exact hk hki.symm @@ -381,15 +318,14 @@ theorem get?_allocCells {l : Loc} {n : Nat} {v : Option Val} {k : Loc} : rw [allocCells, get?_foldl_insert] simp only [LawfulPartialMap.get?_empty] -/-- `State.initHeap` is the left-biased union of the fresh block with the old heap. -/ theorem initHeap_heap_eq {σ : State} {l : Loc} {n : Int} {v : Option Val} : - Iris.Std.PartialMap.equiv (M := HeapF) (σ.initHeap l n v).heap - (Iris.Std.PartialMap.union (allocCells l n.toNat v) σ.heap) := by + Std.PartialMap.equiv (M := HeapF) (σ.initHeap l n v).heap + (Std.PartialMap.union (allocCells l n.toNat v) σ.heap) := by intro k show get? (M := HeapF) ((List.range n.toNat).foldl (fun h (i : Nat) => Std.insert (M := HeapF) h (l + (i : Int)) v) σ.heap) k = _ rw [get?_foldl_insert] - simp only [Iris.Std.PartialMap.union, Iris.Std.LawfulPartialMap.get?_merge, get?_allocCells] + simp only [Std.PartialMap.union, Std.LawfulPartialMap.get?_merge, get?_allocCells] by_cases hex : ∃ i, i < n.toNat ∧ k = l + (i : Int) · simp only [if_pos hex]; cases get? (M := HeapF) σ.heap k <;> rfl · simp only [if_neg hex]; cases get? (M := HeapF) σ.heap k <;> rfl @@ -405,19 +341,16 @@ theorem allocCells_disjoint {l : Loc} {n : Int} {v : Val} {m : HeapF (Option Val simp at h2 · simp at h1 -private theorem mem_le_foldr_max (x : Int) (L : List Int) (h : x ∈ L) : +theorem mem_le_foldr_max (x : Int) (L : List Int) (h : x ∈ L) : x ≤ L.foldr max 0 := by induction L with | nil => simp at h | cons a L ih => simp only [List.foldr_cons] - rcases List.mem_cons.mp h with rfl | h + obtain rfl | h := List.mem_cons.mp h · omega - · have := ih h; omega + · have hih := ih h; omega -/-- Any heap has a fresh block of `n` consecutive locations: pick a base strictly -above every used location's address. This is the reducibility witness for the -`allocN` lift, replacing Rocq's built-in `fresh_locs`. -/ theorem exists_fresh_block (m : HeapF (Option Val)) (n : Int) : ∃ l : Loc, ∀ i : Int, 0 ≤ i → i < n → get? (M := HeapF) m (l + i) = none := by refine ⟨Loc.mk ((m.keys.map Loc.n).foldr max 0 + 1), fun i hi0 hin => ?_⟩ @@ -430,27 +363,23 @@ theorem exists_fresh_block (m : HeapF (Option Val)) (n : Int) : omega simpa [get?, getElem?_eq_none_iff, ← Std.ExtTreeMap.mem_keys] using hnotmem -private theorem coPset_top_ne_empty : (⊤ : CoPset) ≠ ∅ := by +theorem coPset_top_ne_empty : (⊤ : CoPset) ≠ ∅ := by intro h have hm : Pos.xH ∈ (⊤ : CoPset) := CoPset.mem_full rw [h] at hm exact CoPset.mem_empty hm -/-- Inserting a prophecy id into the used-id set is the same as unioning in the -singleton, phrased for the native `ExtTreeSet.insert`. -/ theorem usedProph_insert_eq {ps : Std.ExtTreeSet ProphId compare} {p : ProphId} : ps.insert p = ({p} ∪ ps : Std.ExtTreeSet ProphId compare) := by apply Std.ExtTreeSet.ext_mem intro x rw [Std.ExtTreeSet.mem_union_iff, Std.ExtTreeSet.mem_insert, - Iris.Std.mem_singleton_extTreeSet, Std.LawfulEqCmp.compare_eq_iff_eq] + Std.mem_singleton_extTreeSet, Std.LawfulEqCmp.compare_eq_iff_eq] exact ⟨fun h => h.imp Eq.symm id, fun h => h.imp Eq.symm id⟩ -/-- The heap-only completeness equation: case analysis on the base step. Mirrors -`wp_base_completeness` in `case_studies/heaplang/completeness_generic.v`. -/ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) (Hred : BaseStep.Reducible (e₁, σ)) : - heap_inv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by + heapInv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by iintro Hinv obtain ⟨κ, e', σ', efs, Hstep⟩ := Hred cases Hstep with @@ -513,8 +442,7 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) (BaseStep.cmpXchgS l v1 v2 vl σ true hl hcs (by rw [hb1]))) hl (fun σ'' h => by - have := BaseStep.cmpXchgS l v1 v2 vl σ'' true h hcs (by rw [hb1]) - simpa using this) + simpa using BaseStep.cmpXchgS l v1 v2 vl σ'' true h hcs (by rw [hb1])) (fun h hs => cmpXchgS_det_true h hb1 hs)) $$ Hinv | false => iapply (wp_base_atomic_nochange (v₂ := .pair vl (.lit (.bool false))) l vl σ E @@ -522,8 +450,7 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) (BaseStep.cmpXchgS l v1 v2 vl σ false hl hcs (by rw [hb1]))) hl (fun σ'' h => by - have := BaseStep.cmpXchgS l v1 v2 vl σ'' false h hcs (by rw [hb1]) - simpa using this) + simpa using BaseStep.cmpXchgS l v1 v2 vl σ'' false h hcs (by rw [hb1])) (fun h hs => cmpXchgS_det_false h hb1 hs)) $$ Hinv | forkS e σ => -- Fork lands in the non-atomic disjunct: the forked thread `e` becomes the @@ -534,8 +461,8 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) iintro %Φ %E₂ H iapply wp_fork_fupd iintro !> - ihave Htraj : iprop(∀ σ₁, heap_inv σ₁ ={E}=∗ - ∃ κ σ₁', ⌜PrimSteps (.fork e) σ₁ κ (.val (.lit .unit)) σ₁' [e]⌝ ∗ heap_inv σ₁') $$ [] + ihave Htraj : iprop(∀ σ₁, heapInv σ₁ ={E}=∗ + ∃ κ σ₁', ⌜PrimSteps (.fork e) σ₁ κ (.val (.lit .unit)) σ₁' [e]⌝ ∗ heapInv σ₁') $$ [] · iintro %σ₁ Hheap imodintro iexists [], σ₁ @@ -544,7 +471,7 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) exact PrimSteps.once (EctxLanguage.primStep_of_baseStep (BaseStep.forkS e σ₁)) imod H $$ Htraj with ⟨HwpUnit, Hefs⟩ isplitl [Hefs] - · iapply (BI.BigSepL.bigSepL_singleton (PROP := IProp GF)).1 $$ Hefs + · iapply (BigSepL.bigSepL_singleton (PROP := IProp GF)).1 $$ Hefs · iapply (wp_value_fupd' (v := .lit .unit)).1 $$ HwpUnit | allocNS n v σ l hn hfresh => -- `allocN` is atomic and allocates a fresh block of `n` cells. @@ -570,19 +497,19 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) cases EctxLanguage.baseStep_of_primStep_of_baseStep_reducible Hred₁ Hprim rename_i l' Hpo Hi ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph - -- Destructure `heap_inv σ` into its heap and prophecy conjuncts. + -- Destructure `heapInv σ` into its heap and prophecy conjuncts. icases Hinv with ⟨Hmap, Hproph_inv⟩ -- Allocate the new block in the state interpretation. imod (genHeap_alloc_big (allocCells l' n.toNat (some v)) σ₁.heap (allocCells_disjoint Hi)) $$ Hσ with ⟨Hσ', Hnewpts, Hnewmeta⟩ - -- Freshness of the block in `σ` (the `heap_inv` state), via `meta_token_ne`. + -- Freshness of the block in `σ` (the `heapInv` state), via `meta_token_ne`. ihave %hfreshσ : ⌜∀ i : Int, 0 ≤ i → i < n → get? (M := HeapF) σ.heap (l' + i) = none⌝ $$ [Hmap Hnewmeta] · iintro %i %hi0 %hin rcases hgc : get? (M := HeapF) σ.heap (l' + i) with _ | vo · itrivial · icases (BigSepM.bigSepM_lookup_acc (M := HeapF) - (Φ := fun (k : Loc) (vo : Option Val) => iprop(heapCellPts k vo ∗ metaToken k ⊤)) hgc).1 + (Φ := cellInv) hgc).1 $$ Hmap with ⟨⟨_, Hmeta1⟩, _⟩ have hcell_new : get? (M := HeapF) (allocCells l' n.toNat (some v)) (l' + i) = some (some v) := by @@ -600,7 +527,7 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) isplitl [Hσ' Hproph] · simp only [stateInterp] isplitl [Hσ'] - · iapply genHeapInterp_eqv (Iris.Std.PartialMap.equiv.symm _ _ initHeap_heap_eq) + · iapply genHeapInterp_eqv (Std.PartialMap.equiv.symm _ _ initHeap_heap_eq) iexact Hσ' · iexact Hproph isplitl [Hpost Hmap Hproph_inv Hnewpts Hnewmeta] @@ -608,16 +535,16 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) isplit · ipureintro; simp [toVal]; rfl iapply Hpost - simp only [heap_inv] + simp only [heapInv] isplitl [Hmap Hnewpts Hnewmeta] · iapply (BigSepM.bigSepM_eqv_of_perm - (Φ := fun (k : Loc) (vo : Option Val) => iprop(heapCellPts k vo ∗ metaToken k ⊤)) + (Φ := cellInv) initHeap_heap_eq).2 iapply (BigSepM.bigSepM_union - (Φ := fun (k : Loc) (vo : Option Val) => iprop(heapCellPts k vo ∗ metaToken k ⊤)) + (Φ := cellInv) (allocCells_disjoint hfreshσ)).2 isplitl [Hnewpts Hnewmeta] - · iapply (Iris.BI.equiv_iff.mp (BigSepM.bigSepM_sep_eqv (M := HeapF) + · iapply (equiv_iff.mp (BigSepM.bigSepM_sep_eqv (M := HeapF) (Φ := fun (k : Loc) (vo : Option Val) => heapCellPts k vo) (Ψ := fun (k : Loc) (_vo : Option Val) => iprop(metaToken k ⊤)))).2 -- Convert the raw points-tos of the freshly-allocated (live) cells @@ -641,7 +568,7 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) iintro %σ₁ %ns %obs %obs' %nt Hσ !> icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ -- Pick a prophecy id fresh in `σ₁.usedProphId`. - obtain ⟨pf, Hpf⟩ := Iris.Std.List.fresh σ₁.usedProphId.toList + obtain ⟨pf, Hpf⟩ := Std.List.fresh σ₁.usedProphId.toList have Hpf_contains : ¬ σ₁.usedProphId.contains pf := by intro hc; exact Hpf (Std.ExtTreeSet.mem_toList.mpr hc) have Hred₁ : BaseStep.Reducible (Exp.newProph, σ₁) := @@ -658,12 +585,12 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) fun hmem => Hp' (Std.ExtTreeSet.mem_iff_contains.symm.mp hmem) imod (ProphMap.new_proph p' σ₁.usedProphId obs' Hp'_mem) $$ Hproph with ⟨Hproph', Htok⟩ - -- Destructure `heap_inv σ` and derive that `p'` is fresh in `σ` via + -- Destructure `heapInv σ` and derive that `p'` is fresh in `σ` via -- `proph_exclusive` against `Hproph_inv`. icases Hinv with ⟨Hmap, Hproph_inv⟩ ihave %Hfresh_σ : ⌜p' ∉ σ.usedProphId⌝ $$ [Hproph_inv Htok] · iintro %hmem - icases Iris.BI.BigSepS.bigSepS_elem_of_acc hmem $$ Hproph_inv with ⟨⟨%pvs', Htok'⟩, _⟩ + icases BigSepS.bigSepS_elem_of_acc hmem $$ Hproph_inv with ⟨⟨%pvs', Htok'⟩, _⟩ iapply proph_exclusive $$ Htok Htok' have Hfresh_σ_contains : ¬ σ.usedProphId.contains p' := fun hc => Hfresh_σ (Std.ExtTreeSet.mem_iff_contains.symm.mpr hc) @@ -683,29 +610,25 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) isplit · ipureintro; simp [toVal]; rfl iapply Hpost - simp only [heap_inv] + simp only [heapInv] isplitl [Hmap] · iexact Hmap - · -- goal: bigSepS (σ.usedProphId.insert p') (∃ pvs, proph) - rw [usedProph_insert_eq (ps := σ.usedProphId) (p := p')] + · rw [usedProph_insert_eq (ps := σ.usedProphId) (p := p')] have hdisj : ({p'} : Std.ExtTreeSet ProphId compare) ## σ.usedProphId := by intro x ⟨h1, h2⟩ - rw [Iris.Std.LawfulSet.mem_singleton] at h1 + rw [Std.LawfulSet.mem_singleton] at h1 subst h1 exact Hfresh_σ h2 - iapply (Iris.BI.BigSepS.bigSepS_union hdisj).mpr + iapply (BigSepS.bigSepS_union hdisj).mpr isplitl [Htok] - · iapply Iris.BI.BigSepS.bigSepS_singleton.mpr + · iapply BigSepS.bigSepS_singleton.mpr iexists (prophListResolves obs' p') iexact Htok · iexact Hproph_inv · itrivial | resolveS p v e σ w σ' κs ts hbase hp => - -- Mirror of `completeness_generic.v:127–159`. Resolve is atomic since the - -- inner step `hbase` produces a value in one base step. We recurse on - -- `hbase` to get the completeness equation for `e`, then lift through - -- the `Resolve` wrapper via `wp_resolve_strong`. - have IH : heap_inv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e σ E) := + -- Recurse on `hbase` for `e`, then lift through the `Resolve` wrapper. + have IH : heapInv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e σ E) := wp_base_completeness e σ E ⟨κs, _, _, _, hbase⟩ have hatom : Atomic Atomicity.StronglyAtomic (Exp.resolve e (.val (.lit (.prophecy p))) (.val w)) := @@ -720,12 +643,12 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) iframe %hatom iintro %Φ Hstep icases Hinv with ⟨Hmap, Hproph_inv⟩ - icases Iris.BI.BigSepS.bigSepS_elem_of_acc hp_mem $$ Hproph_inv + icases BigSepS.bigSepS_elem_of_acc hp_mem $$ Hproph_inv with ⟨⟨%pvs, Htok⟩, HcloseProph⟩ iapply (wp_resolve_strong hatom_e hne_e) $$ Htok iintro Hele - ihave Hinv_full : iprop(heap_inv σ) $$ [Hmap HcloseProph Hele] - · unfold heap_inv + ihave Hinv_full : iprop(heapInv σ) $$ [Hmap HcloseProph Hele] + · unfold heapInv iframe Hmap iapply HcloseProph iexists pvs; iexact Hele @@ -747,14 +670,14 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) iintro ⟨Hmap_e, Hproph_inv_e⟩ have hp_mem_e : p ∈ σ_e.usedProphId := base_step_more_proph_ids Hbase_e p hp_mem - icases Iris.BI.BigSepS.bigSepS_elem_of_acc hp_mem_e $$ Hproph_inv_e + icases BigSepS.bigSepS_elem_of_acc hp_mem_e $$ Hproph_inv_e with ⟨⟨%pvs2, Hele2⟩, HcloseProph_e⟩ iexists pvs2 iframe Hele2 iintro %pvs'' %heq Hele2' subst heq iapply Hwp_outer - unfold heap_inv + unfold heapInv iframe Hmap_e iapply HcloseProph_e iexists pvs''; iexact Hele2' @@ -764,7 +687,7 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) iintro !> %e₂_e %efs_e Htraj_e imod Htraj_e $$ %_ Hinv_back with ⟨%κ_e, %σ_e, %Hprims, ⟨Hmap_e, Hproph_inv_e⟩⟩ obtain ⟨Hprim_e, hval_e⟩ := - ProgramLogic.primSteps_atomic (e := e) hatom_e Hprims + primSteps_atomic (e := e) hatom_e Hprims obtain ⟨v_e, rfl⟩ : ∃ v_e, e₂_e = Exp.val v_e := by match e₂_e, hval_e with | .val v_e, _ => exact ⟨v_e, rfl⟩ @@ -775,7 +698,7 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) imodintro have hp_mem_e : p ∈ σ_e.usedProphId := base_step_more_proph_ids Hbase_e p hp_mem - icases Iris.BI.BigSepS.bigSepS_elem_of_acc hp_mem_e $$ Hproph_inv_e + icases BigSepS.bigSepS_elem_of_acc hp_mem_e $$ Hproph_inv_e with ⟨⟨%pvs2, Hele2⟩, HcloseProph_e⟩ isplitl [Hele2 Hwp_outer Hmap_e HcloseProph_e] · -- WP (Val v_e) {{ strong-post }} — apply wp_value', witness pvs2. @@ -785,7 +708,7 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) iintro %pvs'' %heq Hele2' subst heq iapply Hwp_outer - unfold heap_inv + unfold heapInv iframe Hmap_e iapply HcloseProph_e iexists pvs''; iexact Hele2' @@ -794,15 +717,12 @@ termination_by e₁ section Framework -variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] [TI : TpinvGS GF Exp H] +variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] [TpinvGS GF Exp H] -/-- The framework-facing heap-lang completeness equation: the `ectx`-level -soundness equation specialized to heap_lang's `heap_inv`. Mirrors -`wp_base_completeness_actual` in `case_studies/heaplang/completeness_generic.v`. -/ theorem wp_base_completeness_actual (n : Nat) (C : List Exp) (e₁ : Exp) (σ : State) (K : List ECtxItem) (E : CoPset) : ⊢ ectxLangCompletenessStmt (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) - (fun (_ : List Exp) (σ : State) => heap_inv σ) n C e₁ σ K E := by + (fun (_ : List Exp) (σ : State) => heapInv σ) n C e₁ σ K E := by unfold ectxLangCompletenessStmt iintro %Hred Htok ⟨Hheap, Htp, %Hsafe⟩ imod (wp_base_completeness e₁ σ E Hred) $$ Hheap with (⟨%Hatom, H⟩ | ⟨Hheap, H⟩) @@ -832,27 +752,24 @@ theorem wp_base_completeness_actual ipureintro exact Hprims -/-- HeapLang is an instance of the abstract ectx-completeness theory. Mirrors -`heap_lang_completeness` in `case_studies/heaplang/completeness_generic.v`. -/ instance heap_lang_completeness : AbstractEctxLangCompletenessGen (Expr := Exp) (Ectx := List ECtxItem) (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where - heap_inv _C σ := heap_inv σ - heap_inv_timeless _C σ := heap_inv_timeless σ + heap_inv _C σ := heapInv σ + heap_inv_timeless _C σ := instTimeless_heapInv σ ectx_lang_completeness n _C e₁ σ K E := wp_base_completeness_actual n _C e₁ σ K E end Framework section Endpoint -/-- **Top-level heap-lang completeness**: an adequate program admits a WP with the -adequacy postcondition. Mirrors `heap_lang_sem_completeness` in -`case_studies/heaplang/completeness_classical.v`. -/ -theorem heap_lang_sem_completeness {H : Type _ → Type _} [LawfulFiniteMap H Nat] - [GhostMapG GF Nat Exp H] [CInvG GF] +variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] [GhostMapG GF Nat Exp H] [CInvG GF] +include H + +theorem heap_lang_sem_completeness (e : Exp) (σ : State) (φ : Val → Prop) (Hade : adequate Stuckness.NotStuck e σ (fun v _ => φ v)) : - ⊢ heap_inv (GF := GF) σ -∗ WP e @ Stuckness.NotStuck; ⊤ {{ v, ⌜φ v⌝ }} := by + ⊢ heapInv (GF := GF) σ -∗ WP e @ Stuckness.NotStuck; ⊤ {{ v, ⌜φ v⌝ }} := by iintro Hheap imod (tpInv_alloc (GF := GF) (Expr := Exp) (H := H)) with ⟨%γ, Hini⟩ letI TI : TpinvGS GF Exp H := { toGhostMapG := inferInstance, tp_name := γ } @@ -860,13 +777,11 @@ theorem heap_lang_sem_completeness {H : Type _ → Type _} [LawfulFiniteMap H Na (wp := Wp.wp (PROP := IProp GF) Stuckness.NotStuck) e σ φ Hade $$ Hini Hheap iexact Hwp -/-- Nofork variant. Mirrors `heap_lang_sem_completeness_nofork`. -/ -theorem heap_lang_sem_completeness_nofork {H : Type _ → Type _} [LawfulFiniteMap H Nat] - [GhostMapG GF Nat Exp H] [CInvG GF] +theorem heap_lang_sem_completeness_nofork (e : Exp) (σ : State) (φ : Val → State → Prop) (Hade : AdequateNoFork Stuckness.NotStuck e σ (fun v σ' => φ v σ')) : - ⊢ heap_inv (GF := GF) σ -∗ - WP e @ Stuckness.NotStuck; ⊤ {{ v, ∃ σ' : State, heap_inv σ' ∗ ⌜φ v σ'⌝ }} := by + ⊢ heapInv (GF := GF) σ -∗ + WP e @ Stuckness.NotStuck; ⊤ {{ v, ∃ σ' : State, heapInv σ' ∗ ⌜φ v σ'⌝ }} := by iintro Hheap imod (tpInv_alloc (GF := GF) (Expr := Exp) (H := H)) with ⟨%γ, Hini⟩ letI TI : TpinvGS GF Exp H := { toGhostMapG := inferInstance, tp_name := γ } From 58f8abd7013436bf1d80c117199ca3ff05d1d432 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Sat, 18 Jul 2026 15:00:38 -0400 Subject: [PATCH 24/33] more cleanup --- Iris/Iris/HeapLang/Completeness.lean | 342 ++++++++++----------------- 1 file changed, 121 insertions(+), 221 deletions(-) diff --git a/Iris/Iris/HeapLang/Completeness.lean b/Iris/Iris/HeapLang/Completeness.lean index 5dcadd525..53067e26b 100644 --- a/Iris/Iris/HeapLang/Completeness.lean +++ b/Iris/Iris/HeapLang/Completeness.lean @@ -41,6 +41,7 @@ theorem pointsTo_heapCellPts (l : Loc) (vo : Option Val) : | some v => exact .rfl | none => exact Affine.affine +/-- Predicate which asserts ownership over a complete HeapLang state -/ @[reducible] def heapInv (σ : State) : IProp GF := iprop% (bigSepM (M := HeapF) (fun l vo => iprop% heapCellPts l vo ∗ metaToken l ⊤) σ.heap) ∗ ([∗set] p ∈ σ.usedProphId, ∃ pvs, proph p pvs) @@ -48,33 +49,32 @@ theorem pointsTo_heapCellPts (l : Loc) (vo : Option Val) : instance instTimeless_heapInv (σ : State) : Timeless (heapInv (GF := GF) σ) := by unfold heapInv; infer_instance -abbrev baseCompletenessGoal (e₁ : Exp) (σ : State) (E : CoPset) : IProp GF := iprop( - ((⌜Atomic Atomicity.StronglyAtomic e₁⌝ ∗ - ∀ (Φ : Val → IProp GF), - (▷ ∀ κ v₂ σ' efs, ⌜PrimStep.primStep (e₁, σ) κ ((ToVal.ofVal v₂ : Exp), σ', efs)⌝ ==∗ - ((heapInv σ' -∗ Φ v₂) ∗ - [∗list] _i ↦ etp ∈ efs, WP etp @ Stuckness.NotStuck; ⊤ {{ _v, True }})) -∗ - WP e₁ @ Stuckness.NotStuck; E {{ v, Φ v }}) ∨ - (heapInv σ ∗ - ∀ (Φ : Val → IProp GF) (E₂ : CoPset), - (▷ ∀ e₂ efs, (∀ σ₁, heapInv σ₁ ={E}=∗ - ∃ κ σ₁', ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' efs⌝ ∗ heapInv σ₁') ={E₂}=∗ - WP e₂ @ Stuckness.NotStuck; E₂ {{ v, Φ v }} ∗ - [∗list] _i ↦ etp ∈ efs, WP etp @ Stuckness.NotStuck; ⊤ {{ _v, True }}) -∗ - WP e₁ @ Stuckness.NotStuck; E₂ {{ v, Φ v }}))) +abbrev baseCompletenessGoal (e₁ : Exp) (σ : State) (E : CoPset) : IProp GF := iprop% + ((⌜Atomic Atomicity.StronglyAtomic e₁⌝ ∗ + ∀ (Φ : Val → IProp GF), + (▷ ∀ κ v₂ σ' efs, ⌜PrimStep.primStep (e₁, σ) κ (ToVal.ofVal v₂, σ', efs)⌝ ==∗ + ((heapInv σ' -∗ Φ v₂) ∗ + [∗list] _i ↦ etp ∈ efs, WP etp @ Stuckness.NotStuck; ⊤ {{ _v, True }})) -∗ + WP e₁ @ Stuckness.NotStuck; E {{ v, Φ v }}) ∨ + (heapInv σ ∗ + ∀ (Φ : Val → IProp GF) (E₂ : CoPset), + (▷ ∀ e₂ efs, (∀ σ₁, heapInv σ₁ ={E}=∗ + ∃ κ σ₁', ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' efs⌝ ∗ heapInv σ₁') ={E₂}=∗ + WP e₂ @ Stuckness.NotStuck; E₂ {{ v, Φ v }} ∗ + [∗list] _i ↦ etp ∈ efs, WP etp @ Stuckness.NotStuck; ⊤ {{ _v, True }}) -∗ + WP e₁ @ Stuckness.NotStuck; E₂ {{ v, Φ v }})) theorem wp_base_pure {e₁ e₂ : Exp} {φ : Prop} [hpe : Language.PureExec φ 1 e₁ e₂] (hφ : φ) (σ : State) (E : CoPset) (hbase : ∀ σ' : State, BaseStep e₁ σ' [] e₂ σ' []) : heapInv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by iintro Hinv - unfold baseCompletenessGoal imodintro iright iframe Hinv iintro %Φ %E₂ H iapply wp_pure_step_later (Hexec := hpe) (Hφ := hφ) - iintro !> _ + iintro !> - ihave Htraj : iprop(∀ σ₁, heapInv σ₁ ={E}=∗ ∃ κ σ₁', ⌜PrimSteps e₁ σ₁ κ e₂ σ₁' []⌝ ∗ heapInv σ₁') $$ [] · iintro %σ₁ Hinv₁ @@ -105,10 +105,8 @@ theorem wp_base_atomic {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (vnew : ileft iframe %hatom iintro %Φ Hstep - -- For the live cell, `heapCellPts l (some vlive)` reduces to `l ↦ some vlive`. - icases (BigSepM.bigSepM_insert_acc (M := HeapF) - (Φ := cellInv) hcell) - $$ Hmap with ⟨⟨Hpt, Hmeta⟩, Hclose⟩ + icases (BigSepM.bigSepM_insert_acc (M := HeapF) (Φ := cellInv) hcell) $$ Hmap + with ⟨⟨Hpt, Hmeta⟩, Hclose⟩ iapply wp_lift_atomic_step (EctxLanguage.val_stuck (hbase σ hcell)) iintro %σ₁ %ns %obs %obs' %nt Hσ !> icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ @@ -122,7 +120,8 @@ theorem wp_base_atomic {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (vnew : ⟨[], _, _, [], hbase σ₁ hcell1⟩ iintro !> %e₂ %σ₂ %eₜ %Hprim Hcr obtain ⟨rfl, rfl, rfl, rfl⟩ := - hdet hcell1 (EctxLanguage.baseStep_of_primStep_of_baseStep_reducible ⟨[], _, _, [], hbase σ₁ hcell1⟩ Hprim) + hdet hcell1 (EctxLanguage.baseStep_of_primStep_of_baseStep_reducible + ⟨[], _, _, [], hbase σ₁ hcell1⟩ Hprim) imod genHeap_update (v₂ := vnew) $$ [$Hσ $Hpt] with ⟨Hσ, Hpt⟩ imod Hstep $$ [] with ⟨Hpost, _⟩ · ipureintro @@ -136,21 +135,16 @@ theorem wp_base_atomic {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (vnew : simp only [stateInterp, State.initHeap, Int.toNat_one, List.range_one, List.foldl_cons, Int.cast_ofNat_Int, List.foldl_nil, hl0, Algebra.BigOpL.bigOpL_nil] - iframe Hσ Hproph - isplitl [Hpost Hclose Hpt Hmeta Hproph_inv] - · iexists v₂ - isplit - · ipureintro; simp [toVal]; rfl - iapply Hpost - simp only [heapInv] - isplitl [Hclose Hpt Hmeta] - · iapply Hclose - isplitl [Hpt] - -- Convert the raw points-to back into the cell invariant (`emp` if freed). - · iapply (pointsTo_heapCellPts l vnew); iexact Hpt - · iexact Hmeta - · iexact Hproph_inv - · itrivial + iframe + iexists v₂ + isplit; ipureintro; simp [toVal]; rfl + iapply Hpost + simp only [heapInv] + iframe + iapply Hclose + unfold cellInv + iframe + iapply (pointsTo_heapCellPts l vnew); iexact Hpt theorem wp_base_atomic_nochange {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val) (σ : State) (E : CoPset) @@ -173,9 +167,8 @@ theorem wp_base_atomic_nochange {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val iintro %σ₁ %ns %obs %obs' %nt Hσ !> icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ ihave %hcell1 : ⌜get? (M := HeapF) σ₁.heap l = some (some vlive)⌝ $$ [Hσ Hmap] - · icases (BigSepM.bigSepM_lookup_acc (M := HeapF) - (Φ := cellInv) hcell).1 - $$ Hmap with ⟨⟨Hpt, _⟩, _⟩ + · icases (BigSepM.bigSepM_lookup_acc (M := HeapF) (Φ := cellInv) hcell).1 $$ Hmap + with ⟨⟨Hpt, _⟩, _⟩ icases genHeap_valid $$ [$Hσ $Hpt] with >%hh itrivial isplitr @@ -193,15 +186,12 @@ theorem wp_base_atomic_nochange {e₁ : Exp} {v₂ : Val} (l : Loc) (vlive : Val imodintro ihave Hproph := (prophMapInterp_nil_append obs' σ₂.usedProphId).mp $$ Hproph simp only [stateInterp] - iframe Hσ Hproph - isplitl [Hpost Hmap Hproph_inv] - · iexists v₂ - isplit - · ipureintro; simp [toVal]; rfl - iapply Hpost - simp only [heapInv] - iframe Hmap Hproph_inv - · itrivial + iframe + iexists v₂ + isplit; ipureintro; simp [toVal]; rfl + iapply Hpost + simp only [heapInv] + iframe /-! ### Per-operation determinism facts -/ @@ -209,82 +199,46 @@ theorem loadS_det {l : Loc} {v : Val} {σ : State} {obs e' σ' efs} (h : get? (M := HeapF) σ.heap l = some (some v)) (hs : BaseStep (.load (.val (.lit (.loc l)))) σ obs e' σ' efs) : obs = [] ∧ e' = (ToVal.ofVal v : Exp) ∧ σ' = σ ∧ efs = [] := by - cases hs with - | loadS _ v' _ h' => - simp only [State.get?] at h' - rw [h] at h' - simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at h' - subst h' - refine ⟨rfl, rfl, rfl, rfl⟩ + cases hs with | loadS => grind theorem storeS_det {l : Loc} {w : Val} {σ : State} {obs e' σ' efs} (hs : BaseStep (.store (.val (.lit (.loc l))) (.val w)) σ obs e' σ' efs) : obs = [] ∧ e' = (ToVal.ofVal (Val.lit .unit) : Exp) ∧ σ' = σ.initHeap l 1 (some w) ∧ efs = [] := by - cases hs with - | storeS _ _ _ _ _ => refine ⟨rfl, rfl, rfl, rfl⟩ + cases hs with | storeS => grind theorem freeS_det {l : Loc} {σ : State} {obs e' σ' efs} (hs : BaseStep (.free (.val (.lit (.loc l)))) σ obs e' σ' efs) : obs = [] ∧ e' = (ToVal.ofVal (Val.lit .unit) : Exp) ∧ σ' = σ.initHeap l 1 none ∧ efs = [] := by - cases hs with - | freeS _ _ _ _ => refine ⟨rfl, rfl, rfl, rfl⟩ + cases hs with | freeS => grind theorem xchgS_det {l : Loc} {v1 v2 : Val} {σ : State} {obs e' σ' efs} (h : get? (M := HeapF) σ.heap l = some (some v1)) (hs : BaseStep (.xchg (.val (.lit (.loc l))) (.val v2)) σ obs e' σ' efs) : obs = [] ∧ e' = (ToVal.ofVal v1 : Exp) ∧ σ' = σ.initHeap l 1 (some v2) ∧ efs = [] := by - cases hs with - | xchgS _ v1' _ _ h' => - simp only [State.get?] at h' - rw [h] at h' - simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at h' - subst h' - refine ⟨rfl, rfl, rfl, rfl⟩ + cases hs with | xchgS => grind theorem faaS_det {l : Loc} {i1 i2 : Int} {σ : State} {obs e' σ' efs} (h : get? (M := HeapF) σ.heap l = some (some (Val.lit (.int i1)))) (hs : BaseStep (.faa (.val (.lit (.loc l))) (.val (.lit (.int i2)))) σ obs e' σ' efs) : obs = [] ∧ e' = (ToVal.ofVal (Val.lit (.int i1)) : Exp) ∧ σ' = σ.initHeap l 1 (some (Val.lit (.int (i1 + i2)))) ∧ efs = [] := by - cases hs with - | faaS _ i1' _ _ h' => - simp only [State.get?] at h' - rw [h] at h' - simp only [Option.some.injEq, Val.lit.injEq, BaseLit.int.injEq] at h' - subst h' - refine ⟨rfl, rfl, rfl, rfl⟩ + cases hs with | faaS => grind theorem cmpXchgS_det_true {l : Loc} {v1 v2 vl : Val} {σ : State} {obs e' σ' efs} (h : get? (M := HeapF) σ.heap l = some (some vl)) (htrue : decide (vl = v1) = true) (hs : BaseStep (.cmpXchg (.val (.lit (.loc l))) (.val v1) (.val v2)) σ obs e' σ' efs) : obs = [] ∧ e' = (ToVal.ofVal (Val.pair vl (.lit (.bool true))) : Exp) ∧ σ' = σ.initHeap l 1 (some v2) ∧ efs = [] := by - cases hs with - | cmpXchgS _ _ _ vl' _ b' h' hcs' hb' => - simp only [State.get?] at h' - rw [h] at h' - simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at h' - subst h' - rw [htrue] at hb' - subst hb' - refine ⟨rfl, rfl, rfl, rfl⟩ + cases hs with | cmpXchgS => grind theorem cmpXchgS_det_false {l : Loc} {v1 v2 vl : Val} {σ : State} {obs e' σ' efs} (h : get? (M := HeapF) σ.heap l = some (some vl)) (hfalse : decide (vl = v1) = false) (hs : BaseStep (.cmpXchg (.val (.lit (.loc l))) (.val v1) (.val v2)) σ obs e' σ' efs) : obs = [] ∧ e' = (ToVal.ofVal (Val.pair vl (.lit (.bool false))) : Exp) ∧ σ' = σ ∧ efs = [] := by - cases hs with - | cmpXchgS _ _ _ vl' _ b' h' hcs' hb' => - simp only [State.get?] at h' - rw [h] at h' - simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_some, Option.some.injEq] at h' - subst h' - rw [hfalse] at hb' - subst hb' - refine ⟨rfl, rfl, rfl, rfl⟩ + cases hs with | cmpXchgS => grind /-! ### Multi-cell allocation helpers -/ @@ -306,17 +260,12 @@ theorem get?_foldl_insert (l : Loc) (v : Option Val) (m : HeapF (Option Val)) (n by_cases hex : ∃ i, i < n ∧ k = l + (i : Int) · obtain ⟨i, hi, hki⟩ := hex rw [if_pos ⟨i, hi, hki⟩, if_pos ⟨i, Nat.lt_succ_of_lt hi, hki⟩] - · rw [if_neg hex, if_neg] - rintro ⟨i, hi, hki⟩ - obtain hi' | rfl := Nat.lt_succ_iff_lt_or_eq.mp hi - · exact hex ⟨i, hi', hki⟩ - · exact hk hki.symm + · grind theorem get?_allocCells {l : Loc} {n : Nat} {v : Option Val} {k : Loc} : get? (M := HeapF) (allocCells l n v) k = if (∃ i, i < n ∧ k = l + (i : Int)) then some v else none := by - rw [allocCells, get?_foldl_insert] - simp only [LawfulPartialMap.get?_empty] + simp [allocCells, get?_foldl_insert, LawfulPartialMap.get?_empty] theorem initHeap_heap_eq {σ : State} {l : Loc} {n : Int} {v : Option Val} : Std.PartialMap.equiv (M := HeapF) (σ.initHeap l n v).heap @@ -324,8 +273,7 @@ theorem initHeap_heap_eq {σ : State} {l : Loc} {n : Int} {v : Option Val} : intro k show get? (M := HeapF) ((List.range n.toNat).foldl (fun h (i : Nat) => Std.insert (M := HeapF) h (l + (i : Int)) v) σ.heap) k = _ - rw [get?_foldl_insert] - simp only [Std.PartialMap.union, Std.LawfulPartialMap.get?_merge, get?_allocCells] + rw [get?_foldl_insert, Std.PartialMap.union, Std.LawfulPartialMap.get?_merge, get?_allocCells] by_cases hex : ∃ i, i < n.toNat ∧ k = l + (i : Int) · simp only [if_pos hex]; cases get? (M := HeapF) σ.heap k <;> rfl · simp only [if_neg hex]; cases get? (M := HeapF) σ.heap k <;> rfl @@ -342,40 +290,29 @@ theorem allocCells_disjoint {l : Loc} {n : Int} {v : Val} {m : HeapF (Option Val · simp at h1 theorem mem_le_foldr_max (x : Int) (L : List Int) (h : x ∈ L) : - x ≤ L.foldr max 0 := by - induction L with - | nil => simp at h - | cons a L ih => - simp only [List.foldr_cons] - obtain rfl | h := List.mem_cons.mp h - · omega - · have hih := ih h; omega + x ≤ L.foldr max 0 := by induction L <;> grind theorem exists_fresh_block (m : HeapF (Option Val)) (n : Int) : ∃ l : Loc, ∀ i : Int, 0 ≤ i → i < n → get? (M := HeapF) m (l + i) = none := by refine ⟨Loc.mk ((m.keys.map Loc.n).foldr max 0 + 1), fun i hi0 hin => ?_⟩ - have hnotmem : (Loc.mk ((m.keys.map Loc.n).foldr max 0 + 1) + i) ∉ m.keys := by - intro hmem - have hle : (Loc.mk ((m.keys.map Loc.n).foldr max 0 + 1) + i).n - ≤ (m.keys.map Loc.n).foldr max 0 := - mem_le_foldr_max _ _ (List.mem_map_of_mem hmem) - simp only [loc_add_n] at hle - omega - simpa [get?, getElem?_eq_none_iff, ← Std.ExtTreeMap.mem_keys] using hnotmem + simp only [get?, getElem?_eq_none_iff, ← Std.ExtTreeMap.mem_keys] + intro hmem + have hle : (Loc.mk ((m.keys.map Loc.n).foldr max 0 + 1) + i).n ≤ (m.keys.map Loc.n).foldr max 0 := + mem_le_foldr_max _ _ (List.mem_map_of_mem hmem) + simp only [loc_add_n] at hle + grind theorem coPset_top_ne_empty : (⊤ : CoPset) ≠ ∅ := by intro h - have hm : Pos.xH ∈ (⊤ : CoPset) := CoPset.mem_full - rw [h] at hm - exact CoPset.mem_empty hm + refine CoPset.mem_empty (p := Pos.xH) ?_ + cases h theorem usedProph_insert_eq {ps : Std.ExtTreeSet ProphId compare} {p : ProphId} : ps.insert p = ({p} ∪ ps : Std.ExtTreeSet ProphId compare) := by - apply Std.ExtTreeSet.ext_mem - intro x + refine Std.ExtTreeSet.ext_mem fun x => ?_ rw [Std.ExtTreeSet.mem_union_iff, Std.ExtTreeSet.mem_insert, Std.mem_singleton_extTreeSet, Std.LawfulEqCmp.compare_eq_iff_eq] - exact ⟨fun h => h.imp Eq.symm id, fun h => h.imp Eq.symm id⟩ + grind theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) (Hred : BaseStep.Reducible (e₁, σ)) : @@ -384,77 +321,65 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) obtain ⟨κ, e', σ', efs, Hstep⟩ := Hred cases Hstep with | recS f x e σ => - iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.recS f x e σ')) $$ Hinv + iapply (wp_base_pure trivial σ E (.recS f x e)) $$ Hinv | pairS v1 v2 σ => - iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.pairS v1 v2 σ')) $$ Hinv + iapply (wp_base_pure trivial σ E (.pairS v1 v2)) $$ Hinv | injLS v σ => - iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.injLS v σ')) $$ Hinv + iapply (wp_base_pure trivial σ E (.injLS v)) $$ Hinv | injRS v σ => - iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.injRS v σ')) $$ Hinv + iapply (wp_base_pure trivial σ E (.injRS v)) $$ Hinv | betaS f x eb v2 e' σ h => - subst h - iapply (wp_base_pure trivial σ E - (fun σ' => BaseStep.betaS f x eb v2 _ σ' rfl)) $$ Hinv + iapply (wp_base_pure trivial σ E (.betaS f x eb v2 _ · rfl)) $$ Hinv | unOpS op v v' σ h => - iapply (wp_base_pure (hpe := instPureExecUnOp) h σ E - (fun σ' => BaseStep.unOpS op v v' σ' h)) $$ Hinv + iapply (wp_base_pure (hpe := instPureExecUnOp) h σ E (.unOpS op v v' · h)) $$ Hinv | binOpS op v1 v2 v' σ h => - iapply (wp_base_pure (hpe := instPureExecBinOp) h σ E - (fun σ' => BaseStep.binOpS op v1 v2 v' σ' h)) $$ Hinv + iapply (wp_base_pure (hpe := instPureExecBinOp) h σ E (.binOpS op v1 v2 v' · h)) $$ Hinv | ifTrueS et ee σ => - iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.ifTrueS e' ee σ')) $$ Hinv + iapply (wp_base_pure trivial σ E (.ifTrueS e' ee)) $$ Hinv | ifFalseS et ee σ => - iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.ifFalseS et e' σ')) $$ Hinv + iapply (wp_base_pure trivial σ E (.ifFalseS et e')) $$ Hinv | fstS v1 v2 σ => - iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.fstS v1 v2 σ')) $$ Hinv + iapply (wp_base_pure trivial σ E (.fstS v1 v2)) $$ Hinv | sndS v1 v2 σ => - iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.sndS v1 v2 σ')) $$ Hinv + iapply (wp_base_pure trivial σ E (.sndS v1 v2)) $$ Hinv | caseLS v et ee σ => - iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.caseLS v et ee σ')) $$ Hinv + iapply (wp_base_pure trivial σ E (.caseLS v et ee)) $$ Hinv | caseRS v et ee σ => - iapply (wp_base_pure trivial σ E (fun σ' => BaseStep.caseRS v et ee σ')) $$ Hinv + iapply (wp_base_pure trivial σ E (.caseRS v et ee)) $$ Hinv | loadS l v σ hl => - iapply (wp_base_atomic_nochange (v₂ := v) l v σ E - (base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.loadS l v σ hl)) hl - (fun σ'' h => BaseStep.loadS l v σ'' h) loadS_det) $$ Hinv + iapply (wp_base_atomic_nochange l v σ E + (base_step_to_val_atomic .StronglyAtomic (.loadS l v σ hl)) hl + (.loadS l v) loadS_det) $$ Hinv | storeS l v w σ hl => - iapply (wp_base_atomic (v₂ := .lit .unit) l v (some w) σ E - (base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.storeS l v w σ hl)) hl - (fun σ'' h => BaseStep.storeS l v w σ'' h) (fun _ hs => storeS_det hs)) $$ Hinv + iapply (wp_base_atomic l v (some w) σ E + (base_step_to_val_atomic .StronglyAtomic (.storeS l v w σ hl)) hl + (.storeS l v w) (fun _ => storeS_det)) $$ Hinv | freeS l v σ hl => - iapply (wp_base_atomic (v₂ := .lit .unit) l v none σ E - (base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.freeS l v σ hl)) hl - (fun σ'' h => BaseStep.freeS l v σ'' h) (fun _ hs => freeS_det hs)) $$ Hinv + iapply (wp_base_atomic l v none σ E + (base_step_to_val_atomic .StronglyAtomic (.freeS l v σ hl)) hl + (.freeS l v) (fun _ => freeS_det)) $$ Hinv | xchgS l v1 v2 σ hl => - iapply (wp_base_atomic (v₂ := v1) l v1 (some v2) σ E - (base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.xchgS l v1 v2 σ hl)) hl - (fun σ'' h => BaseStep.xchgS l v1 v2 σ'' h) xchgS_det) $$ Hinv + iapply (wp_base_atomic l v1 (some v2) σ E + (base_step_to_val_atomic .StronglyAtomic (.xchgS l v1 v2 σ hl)) hl + (.xchgS l v1 v2) xchgS_det) $$ Hinv | faaS l i1 i2 σ hl => - iapply (wp_base_atomic (v₂ := .lit (.int i1)) l (.lit (.int i1)) + iapply (wp_base_atomic l (.lit (.int i1)) (some (.lit (.int (i1 + i2)))) σ E - (base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.faaS l i1 i2 σ hl)) hl - (fun σ'' h => BaseStep.faaS l i1 i2 σ'' h) faaS_det) $$ Hinv + (base_step_to_val_atomic .StronglyAtomic (.faaS l i1 i2 σ hl)) hl + (.faaS l i1 i2) faaS_det) $$ Hinv | cmpXchgS l v1 v2 vl σ b hl hcs hb => cases hb1 : decide (vl = v1) with | true => - iapply (wp_base_atomic (v₂ := .pair vl (.lit (.bool true))) l vl (some v2) σ E - (base_step_to_val_atomic Atomicity.StronglyAtomic - (BaseStep.cmpXchgS l v1 v2 vl σ true hl hcs (by rw [hb1]))) - hl - (fun σ'' h => by - simpa using BaseStep.cmpXchgS l v1 v2 vl σ'' true h hcs (by rw [hb1])) - (fun h hs => cmpXchgS_det_true h hb1 hs)) $$ Hinv + have Hx σ'' h := BaseStep.cmpXchgS l v1 v2 vl σ'' true h hcs (by rw [hb1]) + iapply (wp_base_atomic l vl (some v2) σ E + (base_step_to_val_atomic .StronglyAtomic (Hx σ hl)) + hl Hx (cmpXchgS_det_true · hb1)) $$ Hinv | false => - iapply (wp_base_atomic_nochange (v₂ := .pair vl (.lit (.bool false))) l vl σ E - (base_step_to_val_atomic Atomicity.StronglyAtomic - (BaseStep.cmpXchgS l v1 v2 vl σ false hl hcs (by rw [hb1]))) - hl - (fun σ'' h => by - simpa using BaseStep.cmpXchgS l v1 v2 vl σ'' false h hcs (by rw [hb1])) - (fun h hs => cmpXchgS_det_false h hb1 hs)) $$ Hinv + have Hx σ'' h := BaseStep.cmpXchgS l v1 v2 vl σ'' false h hcs (by rw [hb1]) + iapply (wp_base_atomic_nochange l vl σ E + (base_step_to_val_atomic Atomicity.StronglyAtomic (Hx σ hl)) + hl Hx (cmpXchgS_det_false · hb1)) $$ Hinv | forkS e σ => - -- Fork lands in the non-atomic disjunct: the forked thread `e` becomes the - -- single forked expression `efs = [e]`, and the parent steps to `#()`. imodintro iright iframe Hinv @@ -468,95 +393,71 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) iexists [], σ₁ iframe Hheap ipureintro - exact PrimSteps.once (EctxLanguage.primStep_of_baseStep (BaseStep.forkS e σ₁)) + exact .once (EctxLanguage.primStep_of_baseStep (.forkS e σ₁)) imod H $$ Htraj with ⟨HwpUnit, Hefs⟩ isplitl [Hefs] · iapply (BigSepL.bigSepL_singleton (PROP := IProp GF)).1 $$ Hefs · iapply (wp_value_fupd' (v := .lit .unit)).1 $$ HwpUnit | allocNS n v σ l hn hfresh => - -- `allocN` is atomic and allocates a fresh block of `n` cells. imodintro ileft - have hatom : Atomic Atomicity.StronglyAtomic (Exp.allocN (.val (.lit (.int n))) (.val v)) := + have hatom : Atomic .StronglyAtomic (Exp.allocN (.val (.lit (.int n))) (.val v)) := base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.allocNS n v σ l hn hfresh) iframe %hatom iintro %Φ Hstep - iapply wp_lift_atomic_step - (EctxLanguage.val_stuck (BaseStep.allocNS n v σ l hn hfresh)) + iapply wp_lift_atomic_step (EctxLanguage.val_stuck (BaseStep.allocNS n v σ l hn hfresh)) iintro %σ₁ %ns %obs %obs' %nt Hσ !> icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ - -- Reducibility in `σ₁` from a fresh block. obtain ⟨lf, hlf⟩ := exists_fresh_block σ₁.heap n have Hred₁ : BaseStep.Reducible (Exp.allocN (.val (.lit (.int n))) (.val v), σ₁) := ⟨[], _, _, [], BaseStep.allocNS n v σ₁ lf hn hlf⟩ - isplitr + isplit · ipureintro simp only [Stuckness.MaybeReducible] exact EctxLanguage.primStep_reducible_of_baseStep_reducible Hred₁ iintro !> %e₂ %σ₂ %eₜ %Hprim Hcr - cases EctxLanguage.baseStep_of_primStep_of_baseStep_reducible Hred₁ Hprim + rcases EctxLanguage.baseStep_of_primStep_of_baseStep_reducible Hred₁ Hprim rename_i l' Hpo Hi ihave Hproph := (prophMapInterp_nil_append obs' σ₁.usedProphId).mp $$ Hproph - -- Destructure `heapInv σ` into its heap and prophecy conjuncts. icases Hinv with ⟨Hmap, Hproph_inv⟩ - -- Allocate the new block in the state interpretation. imod (genHeap_alloc_big (allocCells l' n.toNat (some v)) σ₁.heap (allocCells_disjoint Hi)) $$ Hσ with ⟨Hσ', Hnewpts, Hnewmeta⟩ - -- Freshness of the block in `σ` (the `heapInv` state), via `meta_token_ne`. ihave %hfreshσ : ⌜∀ i : Int, 0 ≤ i → i < n → get? (M := HeapF) σ.heap (l' + i) = none⌝ $$ [Hmap Hnewmeta] · iintro %i %hi0 %hin rcases hgc : get? (M := HeapF) σ.heap (l' + i) with _ | vo · itrivial - · icases (BigSepM.bigSepM_lookup_acc (M := HeapF) - (Φ := cellInv) hgc).1 - $$ Hmap with ⟨⟨_, Hmeta1⟩, _⟩ - have hcell_new : get? (M := HeapF) (allocCells l' n.toNat (some v)) (l' + i) - = some (some v) := by + · icases (BigSepM.bigSepM_lookup_acc hgc).1 $$ Hmap with ⟨⟨_, Hmeta1⟩, _⟩ + have hcell_new : get? (allocCells l' n.toNat (some v)) (l' + i) = some (some v) := by rw [get?_allocCells, if_pos ⟨i.toNat, by omega, by rw [Int.toNat_of_nonneg hi0]⟩] - icases (BigSepM.bigSepM_lookup_acc (M := HeapF) - (Φ := fun (k : Loc) (_vo : Option Val) => iprop(metaToken k ⊤)) hcell_new).1 - $$ Hnewmeta with ⟨Hmeta2, _⟩ + icases (BigSepM.bigSepM_lookup_acc hcell_new).1 $$ Hnewmeta with ⟨Hmeta2, _⟩ icases metaToken_ne coPset_top_ne_empty $$ Hmeta1 Hmeta2 with %hne exact absurd rfl hne - -- Instantiate the magic premise with the base step from `σ` at `l'`. imod Hstep $$ [] with ⟨Hpost, _⟩ · ipureintro exact EctxLanguage.primStep_of_baseStep (BaseStep.allocNS n v σ l' hn hfreshσ) imodintro + iframe isplitl [Hσ' Hproph] · simp only [stateInterp] - isplitl [Hσ'] - · iapply genHeapInterp_eqv (Std.PartialMap.equiv.symm _ _ initHeap_heap_eq) - iexact Hσ' - · iexact Hproph - isplitl [Hpost Hmap Hproph_inv Hnewpts Hnewmeta] - · iexists (.lit (.loc l')) - isplit - · ipureintro; simp [toVal]; rfl - iapply Hpost - simp only [heapInv] - isplitl [Hmap Hnewpts Hnewmeta] - · iapply (BigSepM.bigSepM_eqv_of_perm - (Φ := cellInv) - initHeap_heap_eq).2 - iapply (BigSepM.bigSepM_union - (Φ := cellInv) - (allocCells_disjoint hfreshσ)).2 - isplitl [Hnewpts Hnewmeta] - · iapply (equiv_iff.mp (BigSepM.bigSepM_sep_eqv (M := HeapF) - (Φ := fun (k : Loc) (vo : Option Val) => heapCellPts k vo) - (Ψ := fun (k : Loc) (_vo : Option Val) => iprop(metaToken k ⊤)))).2 - -- Convert the raw points-tos of the freshly-allocated (live) cells - -- into cell invariants before framing. - ihave Hnewpts := (BigSepM.bigSepM_mono_of_forall - (fun {k vo} => pointsTo_heapCellPts k vo)) $$ Hnewpts - iframe Hnewpts Hnewmeta - · iexact Hmap - · iexact Hproph_inv - · itrivial + iframe + iapply genHeapInterp_eqv (Std.PartialMap.equiv.symm _ _ initHeap_heap_eq) + iexact Hσ' + iexists (.lit (.loc l')) + isplit; ipureintro; simp [toVal]; rfl + iapply Hpost + simp only [heapInv] + iframe + iapply (BigSepM.bigSepM_eqv_of_perm initHeap_heap_eq).2 + iapply (BigSepM.bigSepM_union (allocCells_disjoint hfreshσ)).2 + iframe + iapply (equiv_iff.mp BigSepM.bigSepM_sep_eqv).2 + iframe + iapply (BigSepM.bigSepM_mono_of_forall (fun {k vo} => pointsTo_heapCellPts k vo)) $$ Hnewpts + + -- HERE + | newProphS σ p hp => - -- `newProph` is atomic and allocates a fresh prophecy variable. imodintro ileft have hatom : Atomic Atomicity.StronglyAtomic (Exp.newProph : Exp) := @@ -567,7 +468,6 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) (EctxLanguage.val_stuck (BaseStep.newProphS σ p hp)) iintro %σ₁ %ns %obs %obs' %nt Hσ !> icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ - -- Pick a prophecy id fresh in `σ₁.usedProphId`. obtain ⟨pf, Hpf⟩ := Std.List.fresh σ₁.usedProphId.toList have Hpf_contains : ¬ σ₁.usedProphId.contains pf := by intro hc; exact Hpf (Std.ExtTreeSet.mem_toList.mpr hc) From 79df6aac77d154293bafb733997fedcce34f4ef0 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Sat, 18 Jul 2026 17:37:14 -0400 Subject: [PATCH 25/33] cleanup --- Iris/Iris/HeapLang/Completeness.lean | 140 +++++++++++---------------- 1 file changed, 57 insertions(+), 83 deletions(-) diff --git a/Iris/Iris/HeapLang/Completeness.lean b/Iris/Iris/HeapLang/Completeness.lean index 53067e26b..7bac3ec41 100644 --- a/Iris/Iris/HeapLang/Completeness.lean +++ b/Iris/Iris/HeapLang/Completeness.lean @@ -314,7 +314,7 @@ theorem usedProph_insert_eq {ps : Std.ExtTreeSet ProphId compare} {p : ProphId} Std.mem_singleton_extTreeSet, Std.LawfulEqCmp.compare_eq_iff_eq] grind -theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) +theorem wp_baseCompletenessGoal (e₁ : Exp) (σ : State) (E : CoPset) (Hred : BaseStep.Reducible (e₁, σ)) : heapInv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e₁ σ E) := by iintro Hinv @@ -454,18 +454,14 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) iapply (equiv_iff.mp BigSepM.bigSepM_sep_eqv).2 iframe iapply (BigSepM.bigSepM_mono_of_forall (fun {k vo} => pointsTo_heapCellPts k vo)) $$ Hnewpts - - -- HERE - | newProphS σ p hp => imodintro ileft - have hatom : Atomic Atomicity.StronglyAtomic (Exp.newProph : Exp) := - base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.newProphS σ p hp) - iframe %hatom + isplit + · ipureintro + exact base_step_to_val_atomic Atomicity.StronglyAtomic (BaseStep.newProphS σ p hp) iintro %Φ Hstep - iapply wp_lift_atomic_step - (EctxLanguage.val_stuck (BaseStep.newProphS σ p hp)) + iapply wp_lift_atomic_step (EctxLanguage.val_stuck (BaseStep.newProphS σ p hp)) iintro %σ₁ %ns %obs %obs' %nt Hσ !> icases (stateInterp_split σ₁ ns (obs ++ obs') nt).mp $$ Hσ with ⟨Hσ, Hproph⟩ obtain ⟨pf, Hpf⟩ := Std.List.fresh σ₁.usedProphId.toList @@ -485,8 +481,6 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) fun hmem => Hp' (Std.ExtTreeSet.mem_iff_contains.symm.mp hmem) imod (ProphMap.new_proph p' σ₁.usedProphId obs' Hp'_mem) $$ Hproph with ⟨Hproph', Htok⟩ - -- Destructure `heapInv σ` and derive that `p'` is fresh in `σ` via - -- `proph_exclusive` against `Hproph_inv`. icases Hinv with ⟨Hmap, Hproph_inv⟩ ihave %Hfresh_σ : ⌜p' ∉ σ.usedProphId⌝ $$ [Hproph_inv Htok] · iintro %hmem @@ -494,7 +488,6 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) iapply proph_exclusive $$ Htok Htok' have Hfresh_σ_contains : ¬ σ.usedProphId.contains p' := fun hc => Hfresh_σ (Std.ExtTreeSet.mem_iff_contains.symm.mpr hc) - -- Instantiate the magic premise with the `newProph` step from `σ` at `p'`. imod Hstep $$ [] with ⟨Hpost, _⟩ · ipureintro exact EctxLanguage.primStep_of_baseStep (BaseStep.newProphS σ p' Hfresh_σ_contains) @@ -505,31 +498,26 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) rw [show ({p'} ∪ σ₁.usedProphId : Std.ExtTreeSet ProphId compare) = σ₁.usedProphId.insert p' from usedProph_insert_eq.symm] iexact Hproph' - isplitl [Hpost Hmap Hproph_inv Htok] - · iexists (.lit (.prophecy p')) - isplit - · ipureintro; simp [toVal]; rfl - iapply Hpost - simp only [heapInv] - isplitl [Hmap] - · iexact Hmap - · rw [usedProph_insert_eq (ps := σ.usedProphId) (p := p')] - have hdisj : ({p'} : Std.ExtTreeSet ProphId compare) ## σ.usedProphId := by - intro x ⟨h1, h2⟩ - rw [Std.LawfulSet.mem_singleton] at h1 - subst h1 - exact Hfresh_σ h2 - iapply (BigSepS.bigSepS_union hdisj).mpr - isplitl [Htok] - · iapply BigSepS.bigSepS_singleton.mpr - iexists (prophListResolves obs' p') - iexact Htok - · iexact Hproph_inv - · itrivial + iframe + iexists (.lit (.prophecy p')) + isplit; ipureintro; simp [toVal]; rfl + iapply Hpost + simp only [heapInv] + iframe + rw [usedProph_insert_eq (ps := σ.usedProphId) (p := p')] + have hdisj : ({p'} : Std.ExtTreeSet ProphId compare) ## σ.usedProphId := by + intro x ⟨h1, h2⟩ + rw [Std.LawfulSet.mem_singleton] at h1 + subst h1 + exact Hfresh_σ h2 + iapply (BigSepS.bigSepS_union hdisj).mpr + iframe + iapply BigSepS.bigSepS_singleton.mpr + iexists (prophListResolves obs' p') + iexact Htok | resolveS p v e σ w σ' κs ts hbase hp => - -- Recurse on `hbase` for `e`, then lift through the `Resolve` wrapper. have IH : heapInv (GF := GF) σ ⊢ iprop(|={E}=> baseCompletenessGoal e σ E) := - wp_base_completeness e σ E ⟨κs, _, _, _, hbase⟩ + wp_baseCompletenessGoal e σ E ⟨κs, _, _, _, hbase⟩ have hatom : Atomic Atomicity.StronglyAtomic (Exp.resolve e (.val (.lit (.prophecy p))) (.val w)) := base_step_to_val_atomic Atomicity.StronglyAtomic @@ -540,36 +528,32 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) have hp_mem : p ∈ σ.usedProphId := Std.ExtTreeSet.mem_iff_contains.symm.mpr hp imodintro ileft - iframe %hatom + iframe %hatom; clear hatom iintro %Φ Hstep icases Hinv with ⟨Hmap, Hproph_inv⟩ - icases BigSepS.bigSepS_elem_of_acc hp_mem $$ Hproph_inv - with ⟨⟨%pvs, Htok⟩, HcloseProph⟩ + icases BigSepS.bigSepS_elem_of_acc hp_mem $$ Hproph_inv with ⟨⟨%pvs, Htok⟩, HcloseProph⟩ iapply (wp_resolve_strong hatom_e hne_e) $$ Htok iintro Hele - ihave Hinv_full : iprop(heapInv σ) $$ [Hmap HcloseProph Hele] + ihave Hinv_full : heapInv σ $$ [Hmap HcloseProph Hele] · unfold heapInv - iframe Hmap + iframe iapply HcloseProph iexists pvs; iexact Hele ihave Hinner : iprop(|={E}=> baseCompletenessGoal e σ E) $$ [Hinv_full] - · iapply IH; iexact Hinv_full + · iapply IH $$ [$] iapply fupd_wp imod Hinner with H imodintro - icases H with (⟨_hatom_e', Hrst⟩ | ⟨Hinv_back, Hrst_nonatom⟩) - · -- Atomic disjunct: feed `Hrst` the resolve-strong post for `e`. - iapply Hrst + icases H with (⟨-, Hrst⟩ | ⟨Hinv_back, Hrst_nonatom⟩) + · iapply Hrst iintro !> %κ_e %v_e %σ_e %efs_e %Hprim_e - have Hbase_e : BaseStep e σ κ_e (.val v_e) σ_e efs_e := - primStep_val_baseStep Hprim_e + have Hbase_e : BaseStep e σ κ_e (.val v_e) σ_e efs_e := primStep_val_baseStep Hprim_e imod Hstep $$ %_ %_ %_ %_ %(prim_step_resolve_of_inner (w := w) Hbase_e hp) with ⟨Hwp_outer, Hefs⟩ imodintro iframe Hefs iintro ⟨Hmap_e, Hproph_inv_e⟩ - have hp_mem_e : p ∈ σ_e.usedProphId := - base_step_more_proph_ids Hbase_e p hp_mem + have hp_mem_e : p ∈ σ_e.usedProphId := base_step_more_proph_ids Hbase_e p hp_mem icases BigSepS.bigSepS_elem_of_acc hp_mem_e $$ Hproph_inv_e with ⟨⟨%pvs2, Hele2⟩, HcloseProph_e⟩ iexists pvs2 @@ -581,51 +565,43 @@ theorem wp_base_completeness (e₁ : Exp) (σ : State) (E : CoPset) iframe Hmap_e iapply HcloseProph_e iexists pvs''; iexact Hele2' - · -- Non-atomic disjunct: symmetric to the atomic case, plus extracting - -- the single prim step from the trajectory via `primSteps_atomic`. - iapply Hrst_nonatom + · iapply Hrst_nonatom iintro !> %e₂_e %efs_e Htraj_e imod Htraj_e $$ %_ Hinv_back with ⟨%κ_e, %σ_e, %Hprims, ⟨Hmap_e, Hproph_inv_e⟩⟩ - obtain ⟨Hprim_e, hval_e⟩ := - primSteps_atomic (e := e) hatom_e Hprims + obtain ⟨Hprim_e, hval_e⟩ := primSteps_atomic (e := e) hatom_e Hprims obtain ⟨v_e, rfl⟩ : ∃ v_e, e₂_e = Exp.val v_e := by - match e₂_e, hval_e with - | .val v_e, _ => exact ⟨v_e, rfl⟩ - have Hbase_e : BaseStep e σ κ_e (.val v_e) σ_e efs_e := - primStep_val_baseStep Hprim_e + match e₂_e, hval_e with | .val v_e, _ => exact ⟨v_e, rfl⟩ + have Hbase_e : BaseStep e σ κ_e (.val v_e) σ_e efs_e := primStep_val_baseStep Hprim_e imod Hstep $$ %_ %_ %_ %_ %(prim_step_resolve_of_inner (w := w) Hbase_e hp) with ⟨Hwp_outer, Hefs⟩ imodintro - have hp_mem_e : p ∈ σ_e.usedProphId := - base_step_more_proph_ids Hbase_e p hp_mem + have hp_mem_e : p ∈ σ_e.usedProphId := base_step_more_proph_ids Hbase_e p hp_mem icases BigSepS.bigSepS_elem_of_acc hp_mem_e $$ Hproph_inv_e with ⟨⟨%pvs2, Hele2⟩, HcloseProph_e⟩ - isplitl [Hele2 Hwp_outer Hmap_e HcloseProph_e] - · -- WP (Val v_e) {{ strong-post }} — apply wp_value', witness pvs2. - iapply wp_value' - iexists pvs2 - iframe Hele2 - iintro %pvs'' %heq Hele2' - subst heq - iapply Hwp_outer - unfold heapInv - iframe Hmap_e - iapply HcloseProph_e - iexists pvs''; iexact Hele2' - · iexact Hefs + iframe + iapply wp_value' + iexists pvs2 + iframe Hele2 + iintro %pvs'' %heq Hele2' + subst heq + iapply Hwp_outer + unfold heapInv + iframe Hmap_e + iapply HcloseProph_e + iexists pvs'' + iexact Hele2' termination_by e₁ section Framework variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] [TpinvGS GF Exp H] -theorem wp_base_completeness_actual - (n : Nat) (C : List Exp) (e₁ : Exp) (σ : State) (K : List ECtxItem) (E : CoPset) : - ⊢ ectxLangCompletenessStmt (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) +theorem wp_base_completeness {n C e₁ σ K E} : + ⊢@{IProp GF} ectxLangCompletenessStmt (Wp.wp Stuckness.NotStuck) (fun (_ : List Exp) (σ : State) => heapInv σ) n C e₁ σ K E := by unfold ectxLangCompletenessStmt iintro %Hred Htok ⟨Hheap, Htp, %Hsafe⟩ - imod (wp_base_completeness e₁ σ E Hred) $$ Hheap with (⟨%Hatom, H⟩ | ⟨Hheap, H⟩) + imod (wp_baseCompletenessGoal e₁ σ E Hred) $$ Hheap with (⟨%Hatom, H⟩ | ⟨Hheap, H⟩) · -- Atomic redex. imodintro ileft @@ -655,9 +631,9 @@ theorem wp_base_completeness_actual instance heap_lang_completeness : AbstractEctxLangCompletenessGen (Expr := Exp) (Ectx := List ECtxItem) (Wp.wp (PROP := IProp GF) Stuckness.NotStuck) where - heap_inv _C σ := heapInv σ - heap_inv_timeless _C σ := instTimeless_heapInv σ - ectx_lang_completeness n _C e₁ σ K E := wp_base_completeness_actual n _C e₁ σ K E + heap_inv _ := heapInv + heap_inv_timeless _ := instTimeless_heapInv + ectx_lang_completeness _ _ _ _ _ _ := wp_base_completeness end Framework @@ -666,8 +642,7 @@ section Endpoint variable {H : Type _ → Type _} [LawfulFiniteMap H Nat] [GhostMapG GF Nat Exp H] [CInvG GF] include H -theorem heap_lang_sem_completeness - (e : Exp) (σ : State) (φ : Val → Prop) +theorem heap_lang_sem_completeness (e : Exp) (σ : State) (φ : Val → Prop) (Hade : adequate Stuckness.NotStuck e σ (fun v _ => φ v)) : ⊢ heapInv (GF := GF) σ -∗ WP e @ Stuckness.NotStuck; ⊤ {{ v, ⌜φ v⌝ }} := by iintro Hheap @@ -677,8 +652,7 @@ theorem heap_lang_sem_completeness (wp := Wp.wp (PROP := IProp GF) Stuckness.NotStuck) e σ φ Hade $$ Hini Hheap iexact Hwp -theorem heap_lang_sem_completeness_nofork - (e : Exp) (σ : State) (φ : Val → State → Prop) +theorem heap_lang_sem_completeness_nofork (e : Exp) (σ : State) (φ : Val → State → Prop) (Hade : AdequateNoFork Stuckness.NotStuck e σ (fun v σ' => φ v σ')) : ⊢ heapInv (GF := GF) σ -∗ WP e @ Stuckness.NotStuck; ⊤ {{ v, ∃ σ' : State, heapInv σ' ∗ ⌜φ v σ'⌝ }} := by From c8322ffa193d056c716f7fe5c42ac986bfca4db2 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Thu, 18 Jun 2026 16:23:48 -0400 Subject: [PATCH 26/33] upload --- Iris/Iris/HeapLang/Do.lean | 177 +++++++++++ Iris/Iris/HeapLang/Omni.lean | 559 +++++++++++++++++++++++++++++++++++ 2 files changed, 736 insertions(+) create mode 100644 Iris/Iris/HeapLang/Do.lean create mode 100644 Iris/Iris/HeapLang/Omni.lean diff --git a/Iris/Iris/HeapLang/Do.lean b/Iris/Iris/HeapLang/Do.lean new file mode 100644 index 000000000..7966f7369 --- /dev/null +++ b/Iris/Iris/HeapLang/Do.lean @@ -0,0 +1,177 @@ +-- This code is temporarily being vendored from the Lean 4.31 release candidates +module + +@[expose] public section + +open Lean.Order + +universe u v w z + +structure PredTrans (Pred : Type u) (EPred : Type v) (α : Type w) where + /-- Apply the predicate transformer to a postcondition and exception postcondition. -/ + apply : (α → Pred) → EPred → Pred + +/-- Extensionality for predicate transformers. -/ +@[ext] theorem PredTrans.ext {x y : PredTrans Pred EPred α} + (h : ∀ post epost, x.apply post epost = y.apply post epost) : x = y := by + cases x; cases y; congr; funext post epost; exact h post epost + +/-- Partial order on predicate transformers, inherited from the function space. -/ +instance [PartialOrder Pred] : PartialOrder (PredTrans Pred EPred α) where + rel x y := x.apply ⊑ y.apply + rel_refl := PartialOrder.rel_refl + rel_trans h1 h2 := PartialOrder.rel_trans h1 h2 + rel_antisymm h1 h2 := PredTrans.ext fun post epost => + PartialOrder.rel_antisymm (h1 post epost) (h2 post epost) + +/-- Chain-complete partial order on predicate transformers, for fixed-point reasoning. -/ +instance [CCPO Pred] : CCPO (PredTrans Pred EPred α) where + has_csup {c} hc := by + let c' : ((α → Pred) → EPred → Pred) → Prop := fun f => ∃ pt, c pt ∧ pt.apply = f + have hc' : chain c' := by + intro _ _ ⟨pf, hpf, hpf_eq⟩ ⟨pg, hpg, hpg_eq⟩ + subst hpf_eq; subst hpg_eq + exact hc pf pg hpf hpg + obtain ⟨sup, hsup⟩ := CCPO.has_csup hc' + refine ⟨⟨sup⟩, fun q => ?_⟩ + constructor + · intro h pt hpt + exact (hsup q.apply).mp h pt.apply ⟨pt, hpt, rfl⟩ + · intro h + exact (hsup q.apply).mpr fun f ⟨pf, hpf, hpf_eq⟩ => by subst hpf_eq; exact h pf hpf + +/-- `Monad` instance for `PredTrans`: `pure` returns the postcondition applied to the value, +and `bind` threads the postcondition through the continuation. -/ +instance instMonadPredTrans (Pred : Type u) (EPred : Type v) : Monad (PredTrans Pred EPred) where + pure x := ⟨fun post _epost => post x⟩ + bind x f := ⟨fun post epost => x.apply (fun a => (f a).apply post epost) epost⟩ + +/-- `PredTrans` is a lawful monad: all monad laws hold definitionally. -/ +instance instLawfulMonadPredTrans (Pred : Type u) (EPred : Type v) : + LawfulMonad (PredTrans Pred EPred) where + map_const := funext fun _ => funext fun _ => PredTrans.ext fun _ _ => rfl + id_map _ := PredTrans.ext fun _ _ => rfl + seqLeft_eq _ _ := PredTrans.ext fun _ _ => rfl + seqRight_eq _ _ := PredTrans.ext fun _ _ => rfl + pure_seq _ _ := PredTrans.ext fun _ _ => rfl + bind_pure_comp _ _ := PredTrans.ext fun _ _ => rfl + bind_map _ _ := PredTrans.ext fun _ _ => rfl + pure_bind _ _ := PredTrans.ext fun _ _ => rfl + bind_assoc _ _ _ := PredTrans.ext fun _ _ => rfl + +/-- Monotonicity property for a predicate transformer: if both `post` and `epost` grow, +then the resulting precondition grows. -/ +def PredTrans.monotone [PartialOrder Pred] [PartialOrder EPred] (pt : PredTrans Pred EPred α) := + ∀ post post' epost epost', epost ⊑ epost' → post ⊑ post' → + pt.apply post epost ⊑ pt.apply post' epost' + +class abbrev Assertion (α : Type w) := CompleteLattice α + +instance [Assertion EPred] : CCPO EPred where + has_csup {c} _ := CompleteLattice.has_sup c + +class WPPre (α : Type u) (ρ : outParam (Type v)) (Pred : outParam (Type w)) + (EPred : outParam (Type w')) [Assertion Pred] [Assertion EPred] where + /-- The weakest precondition transformer for a monadic program. -/ + wpTrans : α → PredTrans Pred EPred ρ + /-- Monotonicity: weaker postconditions yield weaker preconditions. -/ + wp_trans_monotone (x : α) : wpTrans x |>.monotone + +class WPMonad (m : Type u → Type v) (Pred : outParam (Type w)) (EPred : outParam (Type w')) + [Monad m] [Assertion Pred] [Assertion EPred] [∀ α, WPPre (m α) α Pred EPred] + extends LawfulMonad m where + /-- Soundness of `bind`: composing WPs is at least as strong as the WPMonad of `>>=`. -/ + wp_trans_bind (x : m α) (f : α → m β) : + WPPre.wpTrans x >>= (WPPre.wpTrans <| f ·) ⊑ WPPre.wpTrans (x >>= f) + /-- Monotonicity: weaker postconditions yield weaker preconditions. -/ + wp_trans_monotone (x : m α) : WPPre.wpTrans x |>.monotone + +/- Example: + +-- The simplest IMP + omni-semantics + +abbrev Var := String +abbrev State := Var → Nat + +def State.update (s : State) (x : Var) (v : Nat) : State := + fun y => if y = x then v else s y + +@[simp] theorem State.update_same (s : State) (x : Var) (v : Nat) : + (s.update x v) x = v := by simp [State.update] + +@[simp] theorem State.update_other (s : State) (x y : Var) (v : Nat) (h : y ≠ x) : + (s.update x v) y = s y := by simp [State.update, h] + +-- Expressions (arithmetic; conditions via ≠ 0) +inductive Expr + | lit (n : Nat) + | var (x : Var) + | add (e₁ e₂ : Expr) + +@[simp] def Expr.eval (s : State) : Expr → Nat + | .lit n => n + | .var x => s x + | .add e₁ e₂ => e₁.eval s + e₂.eval s + +-- Commands +inductive Cmd + | skip + | assign (x : Var) (e : Expr) + | seq (c₁ c₂ : Cmd) + | ite (cond : Expr) (c₁ c₂ : Cmd) + | while (cond : Expr) (body : Cmd) + +-- Omni-semantics as WP (structurally recursive on Cmd) +def wp : Cmd → (State → Prop) → State → Prop + | .skip, Q, s => Q s + | .assign x e, Q, s => Q (s.update x (e.eval s)) + | .seq c₁ c₂, Q, s => wp c₁ (fun s' => wp c₂ Q s') s + | .ite cond c₁ c₂, Q, s => + if cond.eval s ≠ 0 then wp c₁ Q s else wp c₂ Q s + | .while cond body, Q, s => + ∃ I : State → Prop, + I s ∧ + (∀ s', I s' → cond.eval s' ≠ 0 → wp body I s') ∧ + (∀ s', I s' → cond.eval s' = 0 → Q s') + +instance : PartialOrder Prop where + rel p q := p → q + rel_refl := id + rel_trans := fun h1 h2 x => h2 (h1 x) + rel_antisymm := fun h1 h2 => propext ⟨h1, h2⟩ + +/-- Supremum for Prop: true iff some element of the set is true -/ +def propSup (c : Prop → Prop) : Prop := ∃ p, c p ∧ p + +theorem propSup_is_sup (c : Prop → Prop) : is_sup c (propSup c) := by + intro y + constructor + · intro hsup z hcz hz + apply hsup + exact Exists.intro z (And.intro hcz hz) + · intro h ⟨z, hcz, hz⟩ + exact h z hcz hz + +instance : CompleteLattice Prop where + has_sup c := ⟨propSup c, propSup_is_sup c⟩ + +-/ + +/-- The empty exception postcondition type, used when a monad has no exception layers. -/ +structure EPost.nil : Type + +instance : PartialOrder EPost.nil where + rel _ _ := True + rel_refl := trivial + rel_trans _ _ := trivial + rel_antisymm := fun {p q} _ _ => by cases p; cases q; rfl + +instance : CompleteLattice EPost.nil where + has_sup _ := ⟨EPost.nil.mk, fun _ => ⟨fun _ _ _ => trivial, fun _ => trivial⟩⟩ + +/- Example (continued): + +instance : WPPre Cmd Unit (State → Prop) EPost.nil where + wpTrans cmd := PredTrans.mk fun Q _ s => wp cmd (Q ()) s + wp_trans_monotone := sorry +-/ diff --git a/Iris/Iris/HeapLang/Omni.lean b/Iris/Iris/HeapLang/Omni.lean new file mode 100644 index 000000000..bb6b0ae89 --- /dev/null +++ b/Iris/Iris/HeapLang/Omni.lean @@ -0,0 +1,559 @@ +/- +An omnisemantics (omni-WP) for a fragment of HeapLang, built as the greatest +fixpoint of the safety functional over the language's `primStep`, and a bridge +showing it produces an `adequate` (partial-correctness) predicate. +-/ +module + +public import Iris.HeapLang.Instances +public import Iris.ProgramLogic.Adequacy +public import Iris.HeapLang.Do + +@[expose] public section +namespace Iris.HeapLang + +open ProgramLogic PrimStep Language Language.Notation Lean.Order + +/-! ## `Prop` as a complete lattice (for the predicate-transformer order) -/ + +instance : Lean.Order.PartialOrder Prop where + rel p q := p → q + rel_refl := id + rel_trans h1 h2 x := h2 (h1 x) + rel_antisymm h1 h2 := propext ⟨h1, h2⟩ + +instance : Lean.Order.CompleteLattice Prop where + has_sup c := ⟨∃ p, c p ∧ p, by + intro x; constructor + · intro hsup z hcz hz; exact hsup ⟨z, hcz, hz⟩ + · rintro h ⟨z, hcz, hz⟩; exact h z hcz hz⟩ + +/-! ## Greatest fixpoint (dual of `Lean.Order.lfp`) -/ + +section gfp +open Lean.Order.PartialOrder Lean.Order.CompleteLattice +variable {α : Sort u} [Lean.Order.CompleteLattice α] + +/-- Greatest fixpoint: the largest post-fixed point `x ⊑ f x`. -/ +noncomputable def gfp (f : α → α) : α := sup (fun x => x ⊑ f x) + +/-- Coinduction: any post-fixed point is below `gfp f`. -/ +theorem le_gfp {f : α → α} {x : α} (h : x ⊑ f x) : x ⊑ gfp f := le_sup _ h + +theorem gfp_postfixed {f : α → α} (hm : monotone f) : gfp f ⊑ f (gfp f) := by + apply sup_le; intro y hy + exact rel_trans hy (hm _ _ (le_sup _ hy)) + +theorem gfp_prefixed {f : α → α} (hm : monotone f) : f (gfp f) ⊑ gfp f := + le_gfp (hm _ _ (gfp_postfixed hm)) + +theorem gfp_fix {f : α → α} (hm : monotone f) : gfp f = f (gfp f) := + rel_antisymm (gfp_postfixed hm) (gfp_prefixed hm) + +end gfp + +/-! ## The omni-WP for HeapLang + +`WPArg := State → (Val → State → Prop) → Prop`, ordered pointwise (so it is a +`CompleteLattice` via the `Prop` instance and pi-lifting), and `wp` is the gfp +of the safety functional `wpF`. -/ + +abbrev WPArg := Exp → State → (Val → State → Prop) → Prop + +/-- One unfolding of the (sequential) safety predicate: either a value +satisfying the post, or reducible and every successor is again safe. Forks are +forbidden — this is the fork-free fragment, so every step has `efs = []`. -/ +def wpF (r : WPArg) : WPArg := fun e σ Q => + (∃ v, ToVal.toVal e = some v ∧ Q v σ) ∨ + (Reducible (e, σ) ∧ + ∀ κ e' σ' efs, (e, σ) -<κ>-> (e', σ', efs) → efs = [] ∧ r e' σ' Q) + +noncomputable def wp : WPArg := gfp wpF + +theorem wpF_monotone : monotone wpF := by + intro r1 r2 h e σ Q hr + rcases hr with hv | ⟨hred, hstep⟩ + · exact .inl hv + · refine .inr ⟨hred, fun κ e' σ' efs hs => ?_⟩ + obtain ⟨hnil, h1⟩ := hstep κ e' σ' efs hs + exact ⟨hnil, h e' σ' Q h1⟩ + +/-- The defining fixpoint equation for `wp`. -/ +theorem wp_unfold : wp = wpF wp := gfp_fix wpF_monotone + +theorem wp_unfold_apply {e σ Q} : wp e σ Q ↔ wpF wp e σ Q := by rw [← wp_unfold] + +/-- Coinduction principle: an invariant closed under `wpF` is below `wp`. -/ +theorem wp_coind (I : WPArg) (h : ∀ e σ Q, I e σ Q → wpF I e σ Q) : + ∀ e σ Q, I e σ Q → wp e σ Q := + le_gfp (f := wpF) (x := I) h + +/-! ## Adequacy bridge (fork-free fragment) + +Since `wpF` forbids forks, a `wp`-safe singleton pool steps only to `wp`-safe +singleton pools. Lifting this invariant along `-·->ₜₚ*` discharges the three +`AdequateNoFork` obligations. -/ + +/-- A `wp`-safe thread that steps stays `wp`-safe (and the step produces no +forks). The new state `σ'` is the successor's state, so there is no +interference to reason about. -/ +theorem wp_primStep {e σ Q κ e' σ' efs} + (hwp : wp e σ Q) (hstep : (e, σ) -<κ>-> (e', σ', efs)) : + efs = [] ∧ wp e' σ' Q := by + rw [wp_unfold_apply] at hwp + rcases hwp with ⟨v, hv, _⟩ | ⟨_, hk⟩ + · exact absurd (Language.val_stuck hstep) (by rw [hv]; exact Option.some_ne_none v) + · exact hk κ e' σ' efs hstep + +/-- A `wp`-safe thread is not stuck. -/ +theorem wp_notStuck {e σ Q} (hwp : wp e σ Q) : NotStuck (e, σ) := by + rw [wp_unfold_apply] at hwp + rcases hwp with ⟨v, hv, _⟩ | ⟨hred, _⟩ + · exact .inl (by rw [hv]; exact rfl) + · exact .inr hred + +/-- One pool step out of a `wp`-safe singleton lands on a `wp`-safe singleton. -/ +theorem wp_erasedStep {e σ Q t' σ'} (hwp : wp e σ Q) + (hstep : ([e], σ) -·->ₜₚ (t', σ')) : ∃ e', t' = [e'] ∧ wp e' σ' Q := by + obtain ⟨κ, hstep⟩ := hstep + generalize hsrc : ([e], σ) = src at hstep + cases hstep with + | @atomic e₀ _ _ e' _ efs hbase t₁ t₂ => + obtain ⟨hpool, rfl⟩ := Prod.mk.injEq .. ▸ hsrc + -- [e] = t₁ ++ e₀ :: t₂ forces t₁ = t₂ = [] and e₀ = e + rcases List.append_eq_cons_iff.mp hpool.symm with ⟨rfl, heq⟩ | ⟨a, _, hcontra⟩ + · obtain ⟨rfl, rfl⟩ := List.cons_eq_cons.mp heq + obtain ⟨rfl, hwp'⟩ := wp_primStep hwp hbase + exact ⟨e', by simp, hwp'⟩ + · exact absurd hcontra (by simp) + +/-- Reaching any pool from a `wp`-safe singleton keeps it a `wp`-safe singleton. -/ +theorem wp_reach {e σ Q} (hwp : wp e σ Q) : + ∀ {p : List Exp × State}, ([e], σ) -·->ₜₚ* p → ∃ e', p.1 = [e'] ∧ wp e' p.2 Q := by + intro p hreach + induction hreach with + | refl => exact ⟨e, rfl, hwp⟩ + | @tail q r _ hstep ih => + obtain ⟨e₁, hq, hwp₁⟩ := ih + obtain ⟨tq, σq⟩ := q; subst hq + obtain ⟨tr, σr⟩ := r + obtain ⟨e₂, rfl, hwp₂⟩ := wp_erasedStep hwp₁ hstep + exact ⟨e₂, rfl, hwp₂⟩ + +/-- **Adequacy for the fork-free fragment**: the omni-`wp` yields an +`AdequateNoFork` partial-correctness predicate. -/ +theorem wp_adequateNoFork (e : Exp) (σ : State) (Q : Val → State → Prop) + (hwp : wp e σ Q) : AdequateNoFork .NotStuck e σ Q where + no_fork hreach := by + obtain ⟨e', hq, _⟩ := wp_reach hwp hreach; simp only at hq; rw [hq]; rfl + result hreach := by + obtain ⟨e', hq, hwp'⟩ := wp_reach hwp hreach; simp only at hq hwp' + -- hq : ofVal v :: t₂ = [e'], so the pool is exactly [ofVal v] and e' = ofVal v + obtain ⟨rfl, -⟩ := List.cons_eq_cons.mp hq + rw [wp_unfold_apply] at hwp' + rcases hwp' with ⟨v', hv', hQ⟩ | ⟨hred, _⟩ + · rw [ToVal.toVal_coe] at hv'; cases hv'; exact hQ + · exact absurd (toVal_none_of_reducible hred) (by rw [ToVal.toVal_coe]; simp) + not_stuck _ hreach hmem := by + obtain ⟨e', hq, hwp'⟩ := wp_reach hwp hreach; simp only at hq hwp' + rw [hq, List.mem_singleton] at hmem; subst hmem + exact wp_notStuck hwp' + +/-! ## `WPPre` instance (wiring into the `Do.lean` framework) + +The omni-`wp` is the predicate transformer of the `WPPre` framework, with +result type `Val`, precondition lattice `State → Prop`, and the trivial +exceptional postcondition `EPost.nil` (the fragment is exception-free). -/ + +/-- `wp` is monotone in its postcondition. -/ +theorem wp_mono {e σ} {Q Q' : Val → State → Prop} + (hQ : ∀ v σ, Q v σ → Q' v σ) (hwp : wp e σ Q) : wp e σ Q' := by + -- Coinduction: `fun e σ R => ∃ Q, (∀ v σ, Q v σ → R v σ) ∧ wp e σ Q` is `wpF`-closed. + refine wp_coind (fun e σ R => ∃ Q, (∀ v σ, Q v σ → R v σ) ∧ wp e σ Q) + (fun e σ R ⟨Q, hQR, hwpQ⟩ => ?_) e σ Q' ⟨Q, hQ, hwp⟩ + rw [wp_unfold_apply] at hwpQ + rcases hwpQ with ⟨v, hv, hQv⟩ | ⟨hred, hstep⟩ + · exact .inl ⟨v, hv, hQR v σ hQv⟩ + · refine .inr ⟨hred, fun κ e' σ' efs hs => ?_⟩ + obtain ⟨hnil, hwp'⟩ := hstep κ e' σ' efs hs + exact ⟨hnil, Q, hQR, hwp'⟩ + +/-! ## Bind / evaluation-context rule + +`wp_bind` decomposes the wp of an expression sitting in an evaluation context: +evaluate the focus `e` to a value `v`, then continue with `K (ofVal v)`. Stated +for any `Language.Context K` (HeapLang provides `instContextFill` for +`fill K`). -/ + +theorem wp_bind {K : Exp → Exp} [Language.Context K] {e σ Q} + (hwp : wp e σ (fun v σ' => wp (K (Exp.ofVal v)) σ' Q)) : wp (K e) σ Q := by + -- Coinduct on: "already wp, or of the form `K e` with `e` running toward the + -- continuation". The left disjunct lets the invariant absorb `wp`. + refine wp_coind + (fun a σ Q => wp a σ Q ∨ + ∃ e, a = K e ∧ wp e σ (fun v σ' => wp (K (Exp.ofVal v)) σ' Q)) + (fun a σ Q hI => ?_) (K e) σ Q (.inr ⟨e, rfl, hwp⟩) + rcases hI with hwp | ⟨e, rfl, hwp⟩ + · -- already `wp a σ Q`: unfold and weaken each recursive position into the invariant + rw [wp_unfold_apply] at hwp + rcases hwp with hv | ⟨hred, hstep⟩ + · exact .inl hv + · exact .inr ⟨hred, fun κ e' σ' efs hs => + (hstep κ e' σ' efs hs).imp id (.inl ·)⟩ + · -- `a = K e`: case on whether the focus `e` is already a value + rw [wp_unfold_apply] at hwp + rcases hwp with ⟨v, hv, hcont⟩ | ⟨hred, hstep⟩ + · -- focus is `ofVal v`: `K e = K (ofVal v)`, continue with `wp (K (ofVal v))` + have : e = Exp.ofVal v := (ToVal.coe_of_toVal_eq_some hv).symm + subst this + -- `hcont : wp (K (ofVal v)) σ Q`; fold into the invariant via the left disjunct + rw [wp_unfold_apply] at hcont + exact hcont.imp id (fun ⟨hr, hs⟩ => ⟨hr, fun κ e' σ' efs hst => + (hs κ e' σ' efs hst).imp id (.inl ·)⟩) + · -- focus reduces: `K e` is reducible, and successors stay in the invariant + have hKred : Reducible (K e, σ) := + let ⟨obs, e', σ', eₜ, hst⟩ := hred + ⟨obs, K e', σ', eₜ, Language.Context.primStep_fill hst⟩ + refine .inr ⟨hKred, fun κ Ke' σ' efs hs => ?_⟩ + have hnv : ToVal.toVal e = none := toVal_none_of_reducible hred + obtain ⟨e', rfl, hes⟩ := Language.Context.primStep_fill_inv hnv hs + obtain ⟨hnil, hwp'⟩ := hstep κ e' σ' efs hes + exact ⟨hnil, .inr ⟨e', rfl, hwp'⟩⟩ + +/-- HeapLang specialization: bind over an evaluation context `fill K`. -/ +theorem wp_bind_fill (K : List ECtxItem) {e σ Q} + (hwp : wp e σ (fun v σ' => wp (ProgramLogic.fill K (Exp.ofVal v)) σ' Q)) : + wp (ProgramLogic.fill K e) σ Q := + wp_bind (K := ProgramLogic.fill K) hwp + +/-! ## Lifting base steps to `wp` + +Generic backward rule: to prove `wp e σ Q` it suffices that `e` is reducible and +every (fork-free) successor is already `wp`-safe. Every primitive rule below is +an instance of this with the relevant `BaseStep` inverted. -/ + +/-- Backward step rule (the right disjunct of `wp_unfold`). -/ +theorem wp_lift_step {e σ Q} (hred : Reducible (e, σ)) + (hcont : ∀ κ e' σ' efs, (e, σ) -<κ>-> (e', σ', efs) → efs = [] ∧ wp e' σ' Q) : + wp e σ Q := by + rw [wp_unfold_apply]; exact .inr ⟨hred, hcont⟩ + +open ProgramLogic EctxLanguage in +/-- A `load` of a bound location reduces to the stored value, leaving the state +unchanged. -/ +theorem wp_load {l : Loc} {v : Val} {σ Q} + (hl : σ.get? l = some (some v)) (hQ : Q v σ) : + wp (.load (.ofVal (.lit (.loc l)))) σ Q := by + have hbred : BaseStep.Reducible (Exp.load (.ofVal (.lit (.loc l))), σ) := + ⟨[], _, _, _, BaseStep.loadS l v σ hl⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + -- the only base step of `load (loc l)` is `loadS`, giving `(ofVal v, σ, [])` + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | loadS _ v' _ hl' => + rw [hl'] at hl; cases hl + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨v, ToVal.toVal_coe v, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- A `store` to a bound location updates it and returns unit. -/ +theorem wp_store {l : Loc} {v w : Val} {σ Q} + (hl : σ.get? l = some (some v)) (hQ : Q (.lit .unit) (σ.initHeap l 1 (some w))) : + wp (.store (.ofVal (.lit (.loc l))) (.ofVal w)) σ Q := by + have hbred : BaseStep.Reducible (Exp.store (.ofVal (.lit (.loc l))) (.ofVal w), σ) := + ⟨[], _, _, _, BaseStep.storeS l v w σ hl⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | storeS _ v' _ _ hl' => + exact ⟨rfl, by rw [wp_unfold_apply] + exact .inl ⟨.lit .unit, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- `if #true then e₁ else e₂` reduces to `e₁`. -/ +theorem wp_if_true {e₁ e₂ σ Q} (hQ : wp e₁ σ Q) : + wp (.if (.ofVal (.lit (.bool true))) e₁ e₂) σ Q := by + have hbred : BaseStep.Reducible (Exp.if (.ofVal (.lit (.bool true))) e₁ e₂, σ) := + ⟨[], _, _, _, BaseStep.ifTrueS e₁ e₂ σ⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with | ifTrueS => exact ⟨rfl, hQ⟩ + +open ProgramLogic EctxLanguage in +/-- `if #false then e₁ else e₂` reduces to `e₂`. -/ +theorem wp_if_false {e₁ e₂ σ Q} (hQ : wp e₂ σ Q) : + wp (.if (.ofVal (.lit (.bool false))) e₁ e₂) σ Q := by + have hbred : BaseStep.Reducible (Exp.if (.ofVal (.lit (.bool false))) e₁ e₂, σ) := + ⟨[], _, _, _, BaseStep.ifFalseS e₁ e₂ σ⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with | ifFalseS => exact ⟨rfl, hQ⟩ + +open ProgramLogic EctxLanguage in +/-- `free` of a bound location deallocates it and returns unit. -/ +theorem wp_free {l : Loc} {v : Val} {σ Q} + (hl : σ.get? l = some (some v)) (hQ : Q (.lit .unit) (σ.initHeap l 1 none)) : + wp (.free (.ofVal (.lit (.loc l)))) σ Q := by + have hbred : BaseStep.Reducible (Exp.free (.ofVal (.lit (.loc l))), σ) := + ⟨[], _, _, _, BaseStep.freeS l v σ hl⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | freeS _ _ _ _ => + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨.lit .unit, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- Atomic exchange `xchg l v2`: returns the old value, stores `v2`. -/ +theorem wp_xchg {l : Loc} {v1 v2 : Val} {σ Q} + (hl : σ.get? l = some (some v1)) (hQ : Q v1 (σ.initHeap l 1 (some v2))) : + wp (.xchg (.ofVal (.lit (.loc l))) (.ofVal v2)) σ Q := by + have hbred : BaseStep.Reducible (Exp.xchg (.ofVal (.lit (.loc l))) (.ofVal v2), σ) := + ⟨[], _, _, _, BaseStep.xchgS l v1 v2 σ hl⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | xchgS _ v1' _ _ hl' => + rw [hl'] at hl; cases hl + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨v1, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- Compare-and-exchange. The stored value `vl` must be comparable to `v1`; the +boolean result `b = (vl == v1)` decides whether the store happens. The +continuation must cover both outcomes. -/ +theorem wp_cmpXchg {l : Loc} {v1 v2 vl : Val} {σ Q} + (hl : σ.get? l = some (some vl)) (hcmp : vl.compareSafe v1) + (hQ : ∀ b : Bool, decide (vl = v1) = b → + Q (.pair vl (.lit (.bool b))) (if b then σ.initHeap l 1 (some v2) else σ)) : + wp (.cmpXchg (.ofVal (.lit (.loc l))) (.ofVal v1) (.ofVal v2)) σ Q := by + have hbred : BaseStep.Reducible + (Exp.cmpXchg (.ofVal (.lit (.loc l))) (.ofVal v1) (.ofVal v2), σ) := + ⟨[], _, _, _, BaseStep.cmpXchgS l v1 v2 vl σ _ hl hcmp rfl⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | cmpXchgS _ _ _ vl' _ b hl' _ hb => + rw [hl'] at hl; cases hl + exact ⟨rfl, by rw [wp_unfold_apply] + exact .inl ⟨_, ToVal.toVal_coe _, hQ b hb⟩⟩ + +open ProgramLogic EctxLanguage in +/-- Fetch-and-add: atomically adds `i2` to the integer stored at `l`, returning +the old value. -/ +theorem wp_faa {l : Loc} {i1 i2 : Int} {σ Q} + (hl : σ.get? l = some (some (.lit (.int i1)))) + (hQ : Q (.lit (.int i1)) (σ.initHeap l 1 (some (.lit (.int (i1 + i2)))))) : + wp (.faa (.ofVal (.lit (.loc l))) (.ofVal (.lit (.int i2)))) σ Q := by + have hbred : BaseStep.Reducible + (Exp.faa (.ofVal (.lit (.loc l))) (.ofVal (.lit (.int i2))), σ) := + ⟨[], _, _, _, BaseStep.faaS l i1 i2 σ hl⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | faaS _ i1' _ _ hl' => + rw [hl'] at hl; cases hl + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨_, ToVal.toVal_coe _, hQ⟩⟩ + +open Std Iris.Std FromMathlib in +/-- Heap finiteness + `Loc` infinitude: every state has a location absent from +the heap. (Single cell; matches the freshness used by Iris's `wp_alloc`.) -/ +theorem State.exists_fresh (σ : State) : ∃ l : Loc, σ.get? l = none := by + refine ⟨(List.fresh σ.heap.keys).choose, ?_⟩ + have h := (List.fresh σ.heap.keys).choose_spec + show σ.heap[_]? = none + exact Std.ExtTreeMap.getElem?_eq_none (fun hm => h (Std.ExtTreeMap.mem_keys.mpr hm)) + +open ProgramLogic EctxLanguage in +/-- `allocN n v` with `0 < n` allocates a fresh array. Allocation is +nondeterministic in the base location, so the continuation must hold for **every** +valid fresh `l`; the `hfresh` premise witnesses that at least one exists (needed +for reducibility — discharge it from heap finiteness at the call site). -/ +theorem wp_allocN {n : Int} {v : Val} {σ Q} (hn : 0 < n) + (hfresh : ∃ l : Loc, ∀ i : Int, 0 ≤ i → i < n → σ.get? (l + i) = none) + (hQ : ∀ l : Loc, (∀ i : Int, 0 ≤ i → i < n → σ.get? (l + i) = none) → + Q (.lit (.loc l)) (σ.initHeap l n v)) : + wp (.allocN (.ofVal (.lit (.int n))) (.ofVal v)) σ Q := by + obtain ⟨l₀, hl₀⟩ := hfresh + have hbred : BaseStep.Reducible (Exp.allocN (.ofVal (.lit (.int n))) (.ofVal v), σ) := + ⟨[], _, _, _, BaseStep.allocNS n v σ l₀ hn hl₀⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | allocNS _ _ _ l _ hfr => + exact ⟨rfl, by rw [wp_unfold_apply] + exact .inl ⟨.lit (.loc l), ToVal.toVal_coe _, hQ l hfr⟩⟩ + +/-- Single-cell allocation `ref v` (= `allocN 1 v`): premise-free, since a fresh +location always exists. The result location is universally quantified. -/ +theorem wp_alloc {v : Val} {σ Q} + (hQ : ∀ l : Loc, σ.get? l = none → Q (.lit (.loc l)) (σ.initHeap l 1 v)) : + wp (.allocN (.ofVal (.lit (.int 1))) (.ofVal v)) σ Q := by + have hl0 : ∀ l : Loc, l + (0 : Int) = l := fun l => by ext; simp + refine wp_allocN (by decide) ?_ (fun l hfr => hQ l ?_) + · obtain ⟨l, hl⟩ := σ.exists_fresh + exact ⟨l, fun i _ h1 => by rw [show i = 0 by omega, hl0]; exact hl⟩ + · rw [← hl0 l]; exact hfr 0 (by decide) (by decide) + +open ProgramLogic EctxLanguage in +/-- β-reduction: applying a recursive closure substitutes both binders. -/ +theorem wp_beta {f x : Binder} {e1 : Exp} {v2 : Val} {σ Q} + (hQ : wp ((e1.subst f (.rec_ f x e1)).subst x v2) σ Q) : + wp (.app (.ofVal (.rec_ f x e1)) (.ofVal v2)) σ Q := by + have hbred : BaseStep.Reducible (Exp.app (.ofVal (.rec_ f x e1)) (.ofVal v2), σ) := + ⟨[], _, _, _, BaseStep.betaS f x e1 v2 _ σ rfl⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with | betaS _ _ _ _ _ _ heq => subst heq; exact ⟨rfl, hQ⟩ + +open ProgramLogic EctxLanguage in +/-- Recursive closures evaluate to themselves as values. -/ +theorem wp_rec {f x : Binder} {e : Exp} {σ Q} + (hQ : Q (.rec_ f x e) σ) : wp (.rec_ f x e) σ Q := by + have hbred : BaseStep.Reducible (Exp.rec_ f x e, σ) := ⟨[], _, _, _, BaseStep.recS f x e σ⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | recS _ _ _ _ => + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨_, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- Unary operator evaluation. -/ +theorem wp_unop {op : UnOp} {v v' : Val} {σ Q} + (hop : op.eval v = some v') (hQ : Q v' σ) : + wp (.unop op (.ofVal v)) σ Q := by + have hbred : BaseStep.Reducible (Exp.unop op (.ofVal v), σ) := + ⟨[], _, _, _, BaseStep.unOpS op v v' σ hop⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | unOpS _ _ v'' _ hop' => + rw [hop'] at hop; cases hop + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨_, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- Binary operator evaluation. -/ +theorem wp_binop {op : BinOp} {v1 v2 v' : Val} {σ Q} + (hop : op.eval v1 v2 = some v') (hQ : Q v' σ) : + wp (.binop op (.ofVal v1) (.ofVal v2)) σ Q := by + have hbred : BaseStep.Reducible (Exp.binop op (.ofVal v1) (.ofVal v2), σ) := + ⟨[], _, _, _, BaseStep.binOpS op v1 v2 v' σ hop⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | binOpS _ _ _ v'' _ hop' => + rw [hop'] at hop; cases hop + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨_, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- Pairing two values. -/ +theorem wp_pair {v1 v2 : Val} {σ Q} (hQ : Q (.pair v1 v2) σ) : + wp (.pair (.ofVal v1) (.ofVal v2)) σ Q := by + have hbred : BaseStep.Reducible (Exp.pair (.ofVal v1) (.ofVal v2), σ) := + ⟨[], _, _, _, BaseStep.pairS v1 v2 σ⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | pairS _ _ _ => + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨_, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- First projection. -/ +theorem wp_fst {v1 v2 : Val} {σ Q} (hQ : Q v1 σ) : + wp (.fst (.ofVal (.pair v1 v2))) σ Q := by + have hbred : BaseStep.Reducible (Exp.fst (.ofVal (.pair v1 v2)), σ) := + ⟨[], _, _, _, BaseStep.fstS v1 v2 σ⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | fstS _ _ _ => + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨_, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- Second projection. -/ +theorem wp_snd {v1 v2 : Val} {σ Q} (hQ : Q v2 σ) : + wp (.snd (.ofVal (.pair v1 v2))) σ Q := by + have hbred : BaseStep.Reducible (Exp.snd (.ofVal (.pair v1 v2)), σ) := + ⟨[], _, _, _, BaseStep.sndS v1 v2 σ⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | sndS _ _ _ => + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨_, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- Left injection. -/ +theorem wp_injL {v : Val} {σ Q} (hQ : Q (.injL v) σ) : + wp (.injL (.ofVal v)) σ Q := by + have hbred : BaseStep.Reducible (Exp.injL (.ofVal v), σ) := ⟨[], _, _, _, BaseStep.injLS v σ⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | injLS _ _ => + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨_, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- Right injection. -/ +theorem wp_injR {v : Val} {σ Q} (hQ : Q (.injR v) σ) : + wp (.injR (.ofVal v)) σ Q := by + have hbred : BaseStep.Reducible (Exp.injR (.ofVal v), σ) := ⟨[], _, _, _, BaseStep.injRS v σ⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with + | injRS _ _ => + exact ⟨rfl, by rw [wp_unfold_apply]; exact .inl ⟨_, ToVal.toVal_coe _, hQ⟩⟩ + +open ProgramLogic EctxLanguage in +/-- `case` on a left injection takes the left branch (applied to the payload). -/ +theorem wp_case_injL {v : Val} {e1 e2 σ Q} (hQ : wp (.app e1 (.ofVal v)) σ Q) : + wp (.case (.ofVal (.injL v)) e1 e2) σ Q := by + have hbred : BaseStep.Reducible (Exp.case (.ofVal (.injL v)) e1 e2, σ) := + ⟨[], _, _, _, BaseStep.caseLS v e1 e2 σ⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with | caseLS _ _ _ _ => exact ⟨rfl, hQ⟩ + +open ProgramLogic EctxLanguage in +/-- `case` on a right injection takes the right branch (applied to the payload). -/ +theorem wp_case_injR {v : Val} {e1 e2 σ Q} (hQ : wp (.app e2 (.ofVal v)) σ Q) : + wp (.case (.ofVal (.injR v)) e1 e2) σ Q := by + have hbred : BaseStep.Reducible (Exp.case (.ofVal (.injR v)) e1 e2, σ) := + ⟨[], _, _, _, BaseStep.caseRS v e1 e2 σ⟩ + refine wp_lift_step (primStep_reducible_of_baseStep_reducible hbred) + (fun κ e' σ' efs hs => ?_) + have hb := baseStep_of_primStep_of_baseStep_reducible hbred hs + cases hb with | caseRS _ _ _ _ => exact ⟨rfl, hQ⟩ + +/-- The value rule: `wp (ofVal v) σ Q ↔ Q v σ`. -/ +@[simp] theorem wp_val {v : Val} {σ Q} : wp (.ofVal v) σ Q ↔ Q v σ := by + rw [wp_unfold_apply] + constructor + · rintro (⟨v', hv', hQ⟩ | ⟨hred, _⟩) + · rw [ToVal.toVal_coe] at hv'; cases hv'; exact hQ + · exact absurd (toVal_none_of_reducible hred) (by rw [ToVal.toVal_coe]; simp) + · exact fun hQ => .inl ⟨v, ToVal.toVal_coe v, hQ⟩ + +open Lean.Order in +instance instWPPreExp : WPPre Exp Val (State → Prop) _root_.EPost.nil where + wpTrans e := ⟨fun Q _ σ => wp e σ Q⟩ + wp_trans_monotone e := by + intro post post' _ _ _ hpost + exact fun σ h => wp_mono (fun v s => hpost v s) h + +end Iris.HeapLang From 9a3692be8a93c3e1872ec977fd804037c6fb27ea Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Sat, 18 Jul 2026 18:02:24 -0400 Subject: [PATCH 27/33] update to 4.33.0-rc1 --- Iris/Iris/Algebra/COFESolver.lean | 6 ++++-- Iris/Iris/Instances/IProp/Instance.lean | 6 ++++-- Iris/lake-manifest.json | 8 ++++---- Iris/lakefile.toml | 4 ++-- Iris/lean-toolchain | 2 +- 5 files changed, 15 insertions(+), 11 deletions(-) diff --git a/Iris/Iris/Algebra/COFESolver.lean b/Iris/Iris/Algebra/COFESolver.lean index 4a3517f8f..726d99df1 100644 --- a/Iris/Iris/Algebra/COFESolver.lean +++ b/Iris/Iris/Algebra/COFESolver.lean @@ -276,11 +276,13 @@ def Tower.isoAux : OFE.Iso (F (Tower F) (Tower F)) (Tower F) where refine ((map_comp _ _ _ _ _).trans <| (map ..).ne.eqv (map_comp _ _ _ _ _)).symm.trans ?_ refine .trans (y := map (upN F n) (downN F n) (X (k+n+1))) ?_ ?_ · refine fun m => map_ne.eqv (fun m' Y => ?_) (fun m' Y => ?_) m _ - · simp [Hom.comp, Tower.embed, Tower.proj, embed, (by omega : k ≤ k+n+1)] + · show (down F (k+n)).f ((embed : A F k -n> A F (k+n+1)).f Y) ≡{m'}≡ (upN F n).f Y + simp only [embed, dif_pos (show k ≤ k+n+1 by omega), Hom.comp] have {a e} : down F (k + n) (eqToHom e (upN F a Y)) ≡ upN F n Y := by cases Nat.add_left_cancel (k := n+1) e; exact (down_up _) exact this.dist - · simp [Hom.comp, Tower.embed, Tower.proj, embed, show ¬k+n+1 ≤ k by omega] + · show (embed : A F (k+n+1) -n> A F k).f ((up F (k+n)).f Y) ≡{m'}≡ (downN F n).f Y + simp only [embed, dif_neg (show ¬k+n+1 ≤ k by omega), Hom.comp, Function.comp_apply] have {a e} : downN F a (eqToHom e (up F (k + n) Y)) ≡ downN F n Y := by cases Nat.add_left_cancel (m := n+1) e; exact (downN ..).ne.eqv (down_up _) exact this.dist diff --git a/Iris/Iris/Instances/IProp/Instance.lean b/Iris/Iris/Instances/IProp/Instance.lean index 84506015a..5c9ba4831 100644 --- a/Iris/Iris/Instances/IProp/Instance.lean +++ b/Iris/Iris/Instances/IProp/Instance.lean @@ -174,14 +174,16 @@ theorem IProp.unfoldi_foldi (x : FF.api τ (IPre FF)) : unfoldi (foldi x) ≡ x refine OFE.equiv_dist.mpr fun n => ?_ refine .trans (OFunctor.map_comp (F := FF τ |>.fst) ..).symm ?_ refine .trans ?_ (OFunctor.map_id (F := FF τ |>.fst) x).dist - apply OFunctor.map_ne.ne <;> intro _ <;> simp [IProp.unfold, IProp.fold] + apply OFunctor.map_ne.ne <;> intro _ <;> simp only [IProp.unfold, IProp.fold] <;> + first | exact OFunctor.Fix.iso.hom_inv.dist | exact OFunctor.Fix.iso.inv_hom.dist @[rocq_alias inG_fold_unfold] theorem IProp.foldi_unfoldi (x : FF.api τ (IProp FF)) : foldi (unfoldi x) ≡ x := by refine OFE.equiv_dist.mpr fun n => ?_ refine .trans (OFunctor.map_comp (F := FF τ |>.fst) ..).symm ?_ refine .trans ?_ (OFunctor.map_id (F := FF τ |>.fst) x).dist - apply OFunctor.map_ne.ne <;> intro _ <;> simp [IProp.unfold, IProp.fold] + apply OFunctor.map_ne.ne <;> intro _ <;> simp only [IProp.unfold, IProp.fold] <;> + first | exact OFunctor.Fix.iso.hom_inv.dist | exact OFunctor.Fix.iso.inv_hom.dist theorem IProp.unfoldi_discreteE {v : FF.api τ (IProp FF)} (hv : OFE.DiscreteE v) : OFE.DiscreteE (unfoldi.f v) where diff --git a/Iris/lake-manifest.json b/Iris/lake-manifest.json index 8f17b358d..859755111 100644 --- a/Iris/lake-manifest.json +++ b/Iris/lake-manifest.json @@ -5,20 +5,20 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "023ce7d62a0531e22a5331e20b587817a80d49ff", + "rev": "31a49105f960721073a9adfc82b261f5d0f2ce1e", "name": "batteries", "manifestFile": "lake-manifest.json", - "inputRev": "v4.32.0", + "inputRev": "v4.33.0-rc1", "inherited": false, "configFile": "lakefile.toml"}, {"url": "https://github.com/leanprover-community/quote4", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "38d591e778f100aec9762bb582f9c7f55f50e9dc", + "rev": "ee41917ae11d38479fb8fb24745f7ca4bf0a784d", "name": "Qq", "manifestFile": "lake-manifest.json", - "inputRev": "v4.32.0", + "inputRev": "v4.33.0-rc1", "inherited": false, "configFile": "lakefile.toml"}], "name": "iris", diff --git a/Iris/lakefile.toml b/Iris/lakefile.toml index 62ceb86ea..37d7e684e 100644 --- a/Iris/lakefile.toml +++ b/Iris/lakefile.toml @@ -4,12 +4,12 @@ defaultTargets = ["Iris", "IrisTest"] [[require]] name = "Qq" scope = "leanprover-community" -rev = "v4.32.0" +rev = "v4.33.0-rc1" [[require]] name = "batteries" scope = "leanprover-community" -rev = "v4.32.0" +rev = "v4.33.0-rc1" [[lean_lib]] name = "Iris" diff --git a/Iris/lean-toolchain b/Iris/lean-toolchain index 2544c30c5..fd85b262b 100644 --- a/Iris/lean-toolchain +++ b/Iris/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.32.0 \ No newline at end of file +leanprover/lean4:v4.33.0-rc1 From fe1ee17aa1fd94aefd9b0d4ce20e72dd7240fea9 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Sat, 18 Jul 2026 18:11:16 -0400 Subject: [PATCH 28/33] remove vendored code in favour of the real Std.Do --- Iris/Iris/HeapLang/Do.lean | 177 ----------------------------------- Iris/Iris/HeapLang/Omni.lean | 18 +--- 2 files changed, 2 insertions(+), 193 deletions(-) delete mode 100644 Iris/Iris/HeapLang/Do.lean diff --git a/Iris/Iris/HeapLang/Do.lean b/Iris/Iris/HeapLang/Do.lean deleted file mode 100644 index 7966f7369..000000000 --- a/Iris/Iris/HeapLang/Do.lean +++ /dev/null @@ -1,177 +0,0 @@ --- This code is temporarily being vendored from the Lean 4.31 release candidates -module - -@[expose] public section - -open Lean.Order - -universe u v w z - -structure PredTrans (Pred : Type u) (EPred : Type v) (α : Type w) where - /-- Apply the predicate transformer to a postcondition and exception postcondition. -/ - apply : (α → Pred) → EPred → Pred - -/-- Extensionality for predicate transformers. -/ -@[ext] theorem PredTrans.ext {x y : PredTrans Pred EPred α} - (h : ∀ post epost, x.apply post epost = y.apply post epost) : x = y := by - cases x; cases y; congr; funext post epost; exact h post epost - -/-- Partial order on predicate transformers, inherited from the function space. -/ -instance [PartialOrder Pred] : PartialOrder (PredTrans Pred EPred α) where - rel x y := x.apply ⊑ y.apply - rel_refl := PartialOrder.rel_refl - rel_trans h1 h2 := PartialOrder.rel_trans h1 h2 - rel_antisymm h1 h2 := PredTrans.ext fun post epost => - PartialOrder.rel_antisymm (h1 post epost) (h2 post epost) - -/-- Chain-complete partial order on predicate transformers, for fixed-point reasoning. -/ -instance [CCPO Pred] : CCPO (PredTrans Pred EPred α) where - has_csup {c} hc := by - let c' : ((α → Pred) → EPred → Pred) → Prop := fun f => ∃ pt, c pt ∧ pt.apply = f - have hc' : chain c' := by - intro _ _ ⟨pf, hpf, hpf_eq⟩ ⟨pg, hpg, hpg_eq⟩ - subst hpf_eq; subst hpg_eq - exact hc pf pg hpf hpg - obtain ⟨sup, hsup⟩ := CCPO.has_csup hc' - refine ⟨⟨sup⟩, fun q => ?_⟩ - constructor - · intro h pt hpt - exact (hsup q.apply).mp h pt.apply ⟨pt, hpt, rfl⟩ - · intro h - exact (hsup q.apply).mpr fun f ⟨pf, hpf, hpf_eq⟩ => by subst hpf_eq; exact h pf hpf - -/-- `Monad` instance for `PredTrans`: `pure` returns the postcondition applied to the value, -and `bind` threads the postcondition through the continuation. -/ -instance instMonadPredTrans (Pred : Type u) (EPred : Type v) : Monad (PredTrans Pred EPred) where - pure x := ⟨fun post _epost => post x⟩ - bind x f := ⟨fun post epost => x.apply (fun a => (f a).apply post epost) epost⟩ - -/-- `PredTrans` is a lawful monad: all monad laws hold definitionally. -/ -instance instLawfulMonadPredTrans (Pred : Type u) (EPred : Type v) : - LawfulMonad (PredTrans Pred EPred) where - map_const := funext fun _ => funext fun _ => PredTrans.ext fun _ _ => rfl - id_map _ := PredTrans.ext fun _ _ => rfl - seqLeft_eq _ _ := PredTrans.ext fun _ _ => rfl - seqRight_eq _ _ := PredTrans.ext fun _ _ => rfl - pure_seq _ _ := PredTrans.ext fun _ _ => rfl - bind_pure_comp _ _ := PredTrans.ext fun _ _ => rfl - bind_map _ _ := PredTrans.ext fun _ _ => rfl - pure_bind _ _ := PredTrans.ext fun _ _ => rfl - bind_assoc _ _ _ := PredTrans.ext fun _ _ => rfl - -/-- Monotonicity property for a predicate transformer: if both `post` and `epost` grow, -then the resulting precondition grows. -/ -def PredTrans.monotone [PartialOrder Pred] [PartialOrder EPred] (pt : PredTrans Pred EPred α) := - ∀ post post' epost epost', epost ⊑ epost' → post ⊑ post' → - pt.apply post epost ⊑ pt.apply post' epost' - -class abbrev Assertion (α : Type w) := CompleteLattice α - -instance [Assertion EPred] : CCPO EPred where - has_csup {c} _ := CompleteLattice.has_sup c - -class WPPre (α : Type u) (ρ : outParam (Type v)) (Pred : outParam (Type w)) - (EPred : outParam (Type w')) [Assertion Pred] [Assertion EPred] where - /-- The weakest precondition transformer for a monadic program. -/ - wpTrans : α → PredTrans Pred EPred ρ - /-- Monotonicity: weaker postconditions yield weaker preconditions. -/ - wp_trans_monotone (x : α) : wpTrans x |>.monotone - -class WPMonad (m : Type u → Type v) (Pred : outParam (Type w)) (EPred : outParam (Type w')) - [Monad m] [Assertion Pred] [Assertion EPred] [∀ α, WPPre (m α) α Pred EPred] - extends LawfulMonad m where - /-- Soundness of `bind`: composing WPs is at least as strong as the WPMonad of `>>=`. -/ - wp_trans_bind (x : m α) (f : α → m β) : - WPPre.wpTrans x >>= (WPPre.wpTrans <| f ·) ⊑ WPPre.wpTrans (x >>= f) - /-- Monotonicity: weaker postconditions yield weaker preconditions. -/ - wp_trans_monotone (x : m α) : WPPre.wpTrans x |>.monotone - -/- Example: - --- The simplest IMP + omni-semantics - -abbrev Var := String -abbrev State := Var → Nat - -def State.update (s : State) (x : Var) (v : Nat) : State := - fun y => if y = x then v else s y - -@[simp] theorem State.update_same (s : State) (x : Var) (v : Nat) : - (s.update x v) x = v := by simp [State.update] - -@[simp] theorem State.update_other (s : State) (x y : Var) (v : Nat) (h : y ≠ x) : - (s.update x v) y = s y := by simp [State.update, h] - --- Expressions (arithmetic; conditions via ≠ 0) -inductive Expr - | lit (n : Nat) - | var (x : Var) - | add (e₁ e₂ : Expr) - -@[simp] def Expr.eval (s : State) : Expr → Nat - | .lit n => n - | .var x => s x - | .add e₁ e₂ => e₁.eval s + e₂.eval s - --- Commands -inductive Cmd - | skip - | assign (x : Var) (e : Expr) - | seq (c₁ c₂ : Cmd) - | ite (cond : Expr) (c₁ c₂ : Cmd) - | while (cond : Expr) (body : Cmd) - --- Omni-semantics as WP (structurally recursive on Cmd) -def wp : Cmd → (State → Prop) → State → Prop - | .skip, Q, s => Q s - | .assign x e, Q, s => Q (s.update x (e.eval s)) - | .seq c₁ c₂, Q, s => wp c₁ (fun s' => wp c₂ Q s') s - | .ite cond c₁ c₂, Q, s => - if cond.eval s ≠ 0 then wp c₁ Q s else wp c₂ Q s - | .while cond body, Q, s => - ∃ I : State → Prop, - I s ∧ - (∀ s', I s' → cond.eval s' ≠ 0 → wp body I s') ∧ - (∀ s', I s' → cond.eval s' = 0 → Q s') - -instance : PartialOrder Prop where - rel p q := p → q - rel_refl := id - rel_trans := fun h1 h2 x => h2 (h1 x) - rel_antisymm := fun h1 h2 => propext ⟨h1, h2⟩ - -/-- Supremum for Prop: true iff some element of the set is true -/ -def propSup (c : Prop → Prop) : Prop := ∃ p, c p ∧ p - -theorem propSup_is_sup (c : Prop → Prop) : is_sup c (propSup c) := by - intro y - constructor - · intro hsup z hcz hz - apply hsup - exact Exists.intro z (And.intro hcz hz) - · intro h ⟨z, hcz, hz⟩ - exact h z hcz hz - -instance : CompleteLattice Prop where - has_sup c := ⟨propSup c, propSup_is_sup c⟩ - --/ - -/-- The empty exception postcondition type, used when a monad has no exception layers. -/ -structure EPost.nil : Type - -instance : PartialOrder EPost.nil where - rel _ _ := True - rel_refl := trivial - rel_trans _ _ := trivial - rel_antisymm := fun {p q} _ _ => by cases p; cases q; rfl - -instance : CompleteLattice EPost.nil where - has_sup _ := ⟨EPost.nil.mk, fun _ => ⟨fun _ _ _ => trivial, fun _ => trivial⟩⟩ - -/- Example (continued): - -instance : WPPre Cmd Unit (State → Prop) EPost.nil where - wpTrans cmd := PredTrans.mk fun Q _ s => wp cmd (Q ()) s - wp_trans_monotone := sorry --/ diff --git a/Iris/Iris/HeapLang/Omni.lean b/Iris/Iris/HeapLang/Omni.lean index bb6b0ae89..dd8ba5330 100644 --- a/Iris/Iris/HeapLang/Omni.lean +++ b/Iris/Iris/HeapLang/Omni.lean @@ -7,27 +7,13 @@ module public import Iris.HeapLang.Instances public import Iris.ProgramLogic.Adequacy -public import Iris.HeapLang.Do +public import Std.Internal.Do.WP.Basic @[expose] public section namespace Iris.HeapLang open ProgramLogic PrimStep Language Language.Notation Lean.Order -/-! ## `Prop` as a complete lattice (for the predicate-transformer order) -/ - -instance : Lean.Order.PartialOrder Prop where - rel p q := p → q - rel_refl := id - rel_trans h1 h2 x := h2 (h1 x) - rel_antisymm h1 h2 := propext ⟨h1, h2⟩ - -instance : Lean.Order.CompleteLattice Prop where - has_sup c := ⟨∃ p, c p ∧ p, by - intro x; constructor - · intro hsup z hcz hz; exact hsup ⟨z, hcz, hz⟩ - · rintro h ⟨z, hcz, hz⟩; exact h z hcz hz⟩ - /-! ## Greatest fixpoint (dual of `Lean.Order.lfp`) -/ section gfp @@ -550,7 +536,7 @@ theorem wp_case_injR {v : Val} {e1 e2 σ Q} (hQ : wp (.app e2 (.ofVal v)) σ Q) · exact fun hQ => .inl ⟨v, ToVal.toVal_coe v, hQ⟩ open Lean.Order in -instance instWPPreExp : WPPre Exp Val (State → Prop) _root_.EPost.nil where +instance instWPPreExp : Std.Internal.Do.WP Exp Val (State → Prop) Std.Internal.Do.EPost.Nil where wpTrans e := ⟨fun Q _ σ => wp e σ Q⟩ wp_trans_monotone e := by intro post post' _ _ _ hpost From ee63de803221662ce33f5edcf5c1fe4e09575fba Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Sat, 18 Jul 2026 18:30:23 -0400 Subject: [PATCH 29/33] compute ((1+2)+(3+4)) --- Iris/Iris/HeapLang/VcgenSmokeTest.lean | 51 ++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) create mode 100644 Iris/Iris/HeapLang/VcgenSmokeTest.lean diff --git a/Iris/Iris/HeapLang/VcgenSmokeTest.lean b/Iris/Iris/HeapLang/VcgenSmokeTest.lean new file mode 100644 index 000000000..94219dfbc --- /dev/null +++ b/Iris/Iris/HeapLang/VcgenSmokeTest.lean @@ -0,0 +1,51 @@ +module + +import Iris.HeapLang.Omni +import Std.Tactic.Do + +open Iris.HeapLang Lean.Order Std.Internal.Do + +namespace Iris.HeapLang.VcgenSmoke + +/-! ## Approach-1 smoke test: spec-driven evaluation-order for `binop`. + +Four `@[spec]` lemmas, all in the internal engine's `pre ⊑ wp` shape: +value, head-redex, right-focus, left-focus. Priorities make the most-evaluated +pattern win, so a nested `binop` tree is walked right-to-left down to leaves. -/ + +/-- Value form. -/ +@[spec high] theorem val_spec (v : Val) (post : Val → State → Prop) (epost : EPost.Nil) : + post v ⊑ Std.Internal.Do.wp ((.ofVal v : Exp)) post epost := by + intro σ h; exact wp_val.mpr h + +/-- Head redex: both operands are values. -/ +@[spec high] theorem binop_redex_spec {op : BinOp} {v1 v2 v' : Val} + (hop : op.eval v1 v2 = some v') (post : Val → State → Prop) (epost : EPost.Nil) : + post v' ⊑ Std.Internal.Do.wp (Exp.binop op (.ofVal v1) (.ofVal v2)) post epost := by + intro σ h; exact wp_binop hop h + +/-- Left-focus: right operand already a value, evaluate the left. -/ +@[spec] theorem binop_focusL_spec {op : BinOp} {e1 : Exp} {v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e1 (fun v1 => Std.Internal.Do.wp (Exp.binop op (.ofVal v1) (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.binop op e1 (.ofVal v2)) post epost := by + intro σ h; exact wp_bind_fill [.binOpL op v2] h + +/-- Right-focus: evaluate the right operand first (HeapLang is right-to-left). -/ +@[spec low] theorem binop_focusR_spec {op : BinOp} {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e2 (fun v2 => Std.Internal.Do.wp (Exp.binop op e1 (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.binop op e1 e2) post epost := by + intro σ h; exact wp_bind_fill [.binOpR op e1] h + +/-! ## The program `(1 + 2) + (3 + 4)`. -/ + +/-- `vcgen` executes the nested tree and reduces the goal to the arithmetic VCs. -/ +example : (fun _ => True) ⊑ Std.Internal.Do.wp hl((#1 + #2) + (#3 + #4)) (fun r _ => r = .lit (.int 10)) EPost.Nil.mk := by + vcgen + -- Order matters here, atm + case vc3 => rfl + case vc5 => rfl + case vc1 => rfl + +end Iris.HeapLang.VcgenSmoke From 2ccfcab80cd5fbd3df6a0f3f94c902b7e88bd4af Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Wed, 22 Jul 2026 12:30:51 +0100 Subject: [PATCH 30/33] checkpoint --- Iris/Iris/HeapLang/Omni.lean | 32 +- Iris/Iris/HeapLang/VcgenSmokeTest.lean | 393 +++++++++++++++++++++++-- 2 files changed, 378 insertions(+), 47 deletions(-) diff --git a/Iris/Iris/HeapLang/Omni.lean b/Iris/Iris/HeapLang/Omni.lean index dd8ba5330..9c205ddb7 100644 --- a/Iris/Iris/HeapLang/Omni.lean +++ b/Iris/Iris/HeapLang/Omni.lean @@ -1,8 +1,3 @@ -/- -An omnisemantics (omni-WP) for a fragment of HeapLang, built as the greatest -fixpoint of the safety functional over the language's `primStep`, and a bridge -showing it produces an `adequate` (partial-correctness) predicate. --/ module public import Iris.HeapLang.Instances @@ -38,17 +33,12 @@ theorem gfp_fix {f : α → α} (hm : monotone f) : gfp f = f (gfp f) := end gfp -/-! ## The omni-WP for HeapLang - -`WPArg := State → (Val → State → Prop) → Prop`, ordered pointwise (so it is a -`CompleteLattice` via the `Prop` instance and pi-lifting), and `wp` is the gfp -of the safety functional `wpF`. -/ +/-! ## The omni-WP for HeapLang -/ abbrev WPArg := Exp → State → (Val → State → Prop) → Prop -/-- One unfolding of the (sequential) safety predicate: either a value -satisfying the post, or reducible and every successor is again safe. Forks are -forbidden — this is the fork-free fragment, so every step has `efs = []`. -/ +/-- Weakest precondition functor +This wp forbids forks. -/ def wpF (r : WPArg) : WPArg := fun e σ Q => (∃ v, ToVal.toVal e = some v ∧ Q v σ) ∨ (Reducible (e, σ) ∧ @@ -71,18 +61,10 @@ theorem wp_unfold_apply {e σ Q} : wp e σ Q ↔ wpF wp e σ Q := by rw [← wp_ /-- Coinduction principle: an invariant closed under `wpF` is below `wp`. -/ theorem wp_coind (I : WPArg) (h : ∀ e σ Q, I e σ Q → wpF I e σ Q) : - ∀ e σ Q, I e σ Q → wp e σ Q := - le_gfp (f := wpF) (x := I) h - -/-! ## Adequacy bridge (fork-free fragment) + ∀ e σ Q, I e σ Q → wp e σ Q := le_gfp (x := I) h -Since `wpF` forbids forks, a `wp`-safe singleton pool steps only to `wp`-safe -singleton pools. Lifting this invariant along `-·->ₜₚ*` discharges the three -`AdequateNoFork` obligations. -/ +/-! ## Adequacy (fork-free fragment) -/ -/-- A `wp`-safe thread that steps stays `wp`-safe (and the step produces no -forks). The new state `σ'` is the successor's state, so there is no -interference to reason about. -/ theorem wp_primStep {e σ Q κ e' σ' efs} (hwp : wp e σ Q) (hstep : (e, σ) -<κ>-> (e', σ', efs)) : efs = [] ∧ wp e' σ' Q := by @@ -91,14 +73,12 @@ theorem wp_primStep {e σ Q κ e' σ' efs} · exact absurd (Language.val_stuck hstep) (by rw [hv]; exact Option.some_ne_none v) · exact hk κ e' σ' efs hstep -/-- A `wp`-safe thread is not stuck. -/ theorem wp_notStuck {e σ Q} (hwp : wp e σ Q) : NotStuck (e, σ) := by rw [wp_unfold_apply] at hwp rcases hwp with ⟨v, hv, _⟩ | ⟨hred, _⟩ · exact .inl (by rw [hv]; exact rfl) · exact .inr hred -/-- One pool step out of a `wp`-safe singleton lands on a `wp`-safe singleton. -/ theorem wp_erasedStep {e σ Q t' σ'} (hwp : wp e σ Q) (hstep : ([e], σ) -·->ₜₚ (t', σ')) : ∃ e', t' = [e'] ∧ wp e' σ' Q := by obtain ⟨κ, hstep⟩ := hstep @@ -106,14 +86,12 @@ theorem wp_erasedStep {e σ Q t' σ'} (hwp : wp e σ Q) cases hstep with | @atomic e₀ _ _ e' _ efs hbase t₁ t₂ => obtain ⟨hpool, rfl⟩ := Prod.mk.injEq .. ▸ hsrc - -- [e] = t₁ ++ e₀ :: t₂ forces t₁ = t₂ = [] and e₀ = e rcases List.append_eq_cons_iff.mp hpool.symm with ⟨rfl, heq⟩ | ⟨a, _, hcontra⟩ · obtain ⟨rfl, rfl⟩ := List.cons_eq_cons.mp heq obtain ⟨rfl, hwp'⟩ := wp_primStep hwp hbase exact ⟨e', by simp, hwp'⟩ · exact absurd hcontra (by simp) -/-- Reaching any pool from a `wp`-safe singleton keeps it a `wp`-safe singleton. -/ theorem wp_reach {e σ Q} (hwp : wp e σ Q) : ∀ {p : List Exp × State}, ([e], σ) -·->ₜₚ* p → ∃ e', p.1 = [e'] ∧ wp e' p.2 Q := by intro p hreach diff --git a/Iris/Iris/HeapLang/VcgenSmokeTest.lean b/Iris/Iris/HeapLang/VcgenSmokeTest.lean index 94219dfbc..c7239e198 100644 --- a/Iris/Iris/HeapLang/VcgenSmokeTest.lean +++ b/Iris/Iris/HeapLang/VcgenSmokeTest.lean @@ -1,51 +1,404 @@ module import Iris.HeapLang.Omni +import Iris.HeapLang.Notation import Std.Tactic.Do +/-! +# `@[spec]` lemmas driving `vcgen` over the HeapLang omni-WP + +This wires the omni-WP `wp` step rules from `Omni.lean` into the (internal) +`Std.Internal.Do` verification-condition generator, following the +"approach 1" recipe: for every syntactic form, + +* a **redex** spec, keyed on the fully-evaluated head (operands `.ofVal _`), and +* one **focus** spec per sub-expression position, expressing HeapLang's + right-to-left evaluation order via `wp_bind_fill [ectxItem]`. + +All specs are in the engine's `pre ⊑ wp prog post epost` shape. + +**Priorities.** Redexes/values fire first (`high`); among the focus specs for a +constructor the one requiring the *most* already-evaluated positions gets the +higher priority (`L > M > R`), so `vcgen` never re-focuses a value and the tree +is walked deterministically. Termination: each focus spec strictly shrinks the +focused subterm; the value spec is the base case. +-/ + open Iris.HeapLang Lean.Order Std.Internal.Do namespace Iris.HeapLang.VcgenSmoke -/-! ## Approach-1 smoke test: spec-driven evaluation-order for `binop`. - -Four `@[spec]` lemmas, all in the internal engine's `pre ⊑ wp` shape: -value, head-redex, right-focus, left-focus. Priorities make the most-evaluated -pattern win, so a nested `binop` tree is walked right-to-left down to leaves. -/ +/-! ## Values -/ -/-- Value form. -/ @[spec high] theorem val_spec (v : Val) (post : Val → State → Prop) (epost : EPost.Nil) : post v ⊑ Std.Internal.Do.wp ((.ofVal v : Exp)) post epost := by intro σ h; exact wp_val.mpr h -/-- Head redex: both operands are values. -/ -@[spec high] theorem binop_redex_spec {op : BinOp} {v1 v2 v' : Val} - (hop : op.eval v1 v2 = some v') (post : Val → State → Prop) (epost : EPost.Nil) : +/-- Recursive closures are values. -/ +@[spec high] theorem rec_spec (f x : Binder) (e : Exp) (post : Val → State → Prop) (epost : EPost.Nil) : + post (.rec_ f x e) ⊑ Std.Internal.Do.wp (Exp.rec_ f x e) post epost := by + intro σ h; exact wp_rec h + +/-! ## Unary operator -/ + +@[spec high] theorem unop_redex_spec {op : UnOp} {v v' : Val} (hop : op.eval v = some v') + (post : Val → State → Prop) (epost : EPost.Nil) : + post v' ⊑ Std.Internal.Do.wp (Exp.unop op (.ofVal v)) post epost := by + intro σ h; exact wp_unop hop h + +@[spec 1000] theorem unop_focus_spec {op : UnOp} {e : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e (fun v => Std.Internal.Do.wp (Exp.unop op (.ofVal v)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.unop op e) post epost := by + intro σ h; exact wp_bind_fill [.unOp op] h + +/-! ## Binary operator -/ + +@[spec high] theorem binop_redex_spec {op : BinOp} {v1 v2 v' : Val} (hop : op.eval v1 v2 = some v') + (post : Val → State → Prop) (epost : EPost.Nil) : post v' ⊑ Std.Internal.Do.wp (Exp.binop op (.ofVal v1) (.ofVal v2)) post epost := by intro σ h; exact wp_binop hop h -/-- Left-focus: right operand already a value, evaluate the left. -/ -@[spec] theorem binop_focusL_spec {op : BinOp} {e1 : Exp} {v2 : Val} +@[spec 1200] theorem binop_focusL_spec {op : BinOp} {e1 : Exp} {v2 : Val} (post : Val → State → Prop) (epost : EPost.Nil) : Std.Internal.Do.wp e1 (fun v1 => Std.Internal.Do.wp (Exp.binop op (.ofVal v1) (.ofVal v2)) post epost) epost ⊑ Std.Internal.Do.wp (Exp.binop op e1 (.ofVal v2)) post epost := by intro σ h; exact wp_bind_fill [.binOpL op v2] h -/-- Right-focus: evaluate the right operand first (HeapLang is right-to-left). -/ -@[spec low] theorem binop_focusR_spec {op : BinOp} {e1 e2 : Exp} +@[spec 1000] theorem binop_focusR_spec {op : BinOp} {e1 e2 : Exp} (post : Val → State → Prop) (epost : EPost.Nil) : Std.Internal.Do.wp e2 (fun v2 => Std.Internal.Do.wp (Exp.binop op e1 (.ofVal v2)) post epost) epost ⊑ Std.Internal.Do.wp (Exp.binop op e1 e2) post epost := by intro σ h; exact wp_bind_fill [.binOpR op e1] h -/-! ## The program `(1 + 2) + (3 + 4)`. -/ +/-! ## Application (β-reduction) -/ + +@[spec high] theorem beta_redex_spec {f x : Binder} {e1 : Exp} {v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp ((e1.subst f (.rec_ f x e1)).subst x v2) post epost + ⊑ Std.Internal.Do.wp (Exp.app (.ofVal (.rec_ f x e1)) (.ofVal v2)) post epost := by + intro σ h; exact wp_beta h + +@[spec 1200] theorem app_focusL_spec {e1 : Exp} {v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e1 (fun v1 => Std.Internal.Do.wp (Exp.app (.ofVal v1) (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.app e1 (.ofVal v2)) post epost := by + intro σ h; exact wp_bind_fill [.appL v2] h + +@[spec 1000] theorem app_focusR_spec {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e2 (fun v2 => Std.Internal.Do.wp (Exp.app e1 (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.app e1 e2) post epost := by + intro σ h; exact wp_bind_fill [.appR e1] h + +/-! ## Pairs -/ + +@[spec high] theorem pair_redex_spec {v1 v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + post (.pair v1 v2) ⊑ Std.Internal.Do.wp (Exp.pair (.ofVal v1) (.ofVal v2)) post epost := by + intro σ h; exact wp_pair h + +@[spec 1200] theorem pair_focusL_spec {e1 : Exp} {v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e1 (fun v1 => Std.Internal.Do.wp (Exp.pair (.ofVal v1) (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.pair e1 (.ofVal v2)) post epost := by + intro σ h; exact wp_bind_fill [.pairL v2] h + +@[spec 1000] theorem pair_focusR_spec {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e2 (fun v2 => Std.Internal.Do.wp (Exp.pair e1 (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.pair e1 e2) post epost := by + intro σ h; exact wp_bind_fill [.pairR e1] h + +@[spec high] theorem fst_redex_spec {v1 v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + post v1 ⊑ Std.Internal.Do.wp (Exp.fst (.ofVal (.pair v1 v2))) post epost := by + intro σ h; exact wp_fst h + +@[spec 1000] theorem fst_focus_spec {e : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e (fun v => Std.Internal.Do.wp (Exp.fst (.ofVal v)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.fst e) post epost := by + intro σ h; exact wp_bind_fill [.fst] h + +@[spec high] theorem snd_redex_spec {v1 v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + post v2 ⊑ Std.Internal.Do.wp (Exp.snd (.ofVal (.pair v1 v2))) post epost := by + intro σ h; exact wp_snd h + +@[spec 1000] theorem snd_focus_spec {e : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e (fun v => Std.Internal.Do.wp (Exp.snd (.ofVal v)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.snd e) post epost := by + intro σ h; exact wp_bind_fill [.snd] h + +/-! ## Sum injections -/ + +@[spec high] theorem injL_redex_spec {v : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + post (.injL v) ⊑ Std.Internal.Do.wp (Exp.injL (.ofVal v)) post epost := by + intro σ h; exact wp_injL h + +@[spec 1000] theorem injL_focus_spec {e : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e (fun v => Std.Internal.Do.wp (Exp.injL (.ofVal v)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.injL e) post epost := by + intro σ h; exact wp_bind_fill [.injL] h + +@[spec high] theorem injR_redex_spec {v : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + post (.injR v) ⊑ Std.Internal.Do.wp (Exp.injR (.ofVal v)) post epost := by + intro σ h; exact wp_injR h + +@[spec 1000] theorem injR_focus_spec {e : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e (fun v => Std.Internal.Do.wp (Exp.injR (.ofVal v)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.injR e) post epost := by + intro σ h; exact wp_bind_fill [.injR] h + +/-! ## Conditional (only the scrutinee is evaluated) -/ + +@[spec high] theorem if_true_spec {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e1 post epost + ⊑ Std.Internal.Do.wp (Exp.if (.ofVal (.lit (.bool true))) e1 e2) post epost := by + intro σ h; exact wp_if_true h + +@[spec high] theorem if_false_spec {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e2 post epost + ⊑ Std.Internal.Do.wp (Exp.if (.ofVal (.lit (.bool false))) e1 e2) post epost := by + intro σ h; exact wp_if_false h + +@[spec 1000] theorem if_focus_spec {e e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e (fun v => Std.Internal.Do.wp (Exp.if (.ofVal v) e1 e2) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.if e e1 e2) post epost := by + intro σ h; exact wp_bind_fill [.if e1 e2] h + +/-! ## Case (only the scrutinee is evaluated) -/ + +@[spec high] theorem case_injL_spec {v : Val} {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp (Exp.app e1 (.ofVal v)) post epost + ⊑ Std.Internal.Do.wp (Exp.case (.ofVal (.injL v)) e1 e2) post epost := by + intro σ h; exact wp_case_injL h + +@[spec high] theorem case_injR_spec {v : Val} {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp (Exp.app e2 (.ofVal v)) post epost + ⊑ Std.Internal.Do.wp (Exp.case (.ofVal (.injR v)) e1 e2) post epost := by + intro σ h; exact wp_case_injR h + +@[spec 1000] theorem case_focus_spec {e e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e (fun v => Std.Internal.Do.wp (Exp.case (.ofVal v) e1 e2) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.case e e1 e2) post epost := by + intro σ h; exact wp_bind_fill [.case e1 e2] h + +/-! ## Heap: allocation + +`ref v` (`allocN 1`) is premise-free; general `allocN n` carries `0 < n` and a +freshness witness as VCs. -/ + +@[spec high] theorem alloc_spec {v : Val} (post : Val → State → Prop) (epost : EPost.Nil) : + (fun σ => ∀ l : Loc, σ.get? l = none → post (.lit (.loc l)) (σ.initHeap l 1 v)) + ⊑ Std.Internal.Do.wp (Exp.allocN (.ofVal (.lit (.int 1))) (.ofVal v)) post epost := by + intro σ h; exact wp_alloc h + +@[spec 1300] theorem allocN_spec {n : Int} {v : Val} (post : Val → State → Prop) (epost : EPost.Nil) : + (fun σ => 0 < n ∧ (∃ l : Loc, ∀ i : Int, 0 ≤ i → i < n → σ.get? (l + i) = none) ∧ + ∀ l : Loc, (∀ i : Int, 0 ≤ i → i < n → σ.get? (l + i) = none) → + post (.lit (.loc l)) (σ.initHeap l n v)) + ⊑ Std.Internal.Do.wp (Exp.allocN (.ofVal (.lit (.int n))) (.ofVal v)) post epost := by + intro σ h; obtain ⟨hn, hfresh, hQ⟩ := h; exact wp_allocN hn hfresh hQ + +@[spec 1200] theorem allocN_focusL_spec {e1 : Exp} {v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e1 (fun v1 => Std.Internal.Do.wp (Exp.allocN (.ofVal v1) (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.allocN e1 (.ofVal v2)) post epost := by + intro σ h; exact wp_bind_fill [.allocNL v2] h + +@[spec 1000] theorem allocN_focusR_spec {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e2 (fun v2 => Std.Internal.Do.wp (Exp.allocN e1 (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.allocN e1 e2) post epost := by + intro σ h; exact wp_bind_fill [.allocNR e1] h + +/-! ## Heap: load / free (unary) -/ + +@[spec high] theorem load_spec {l : Loc} (post : Val → State → Prop) (epost : EPost.Nil) : + (fun σ => ∃ v : Val, σ.get? l = some (some v) ∧ post v σ) + ⊑ Std.Internal.Do.wp (Exp.load (.ofVal (.lit (.loc l)))) post epost := by + intro σ h; obtain ⟨v, hl, hq⟩ := h; exact wp_load hl hq + +@[spec 1000] theorem load_focus_spec {e : Exp} (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e (fun v => Std.Internal.Do.wp (Exp.load (.ofVal v)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.load e) post epost := by + intro σ h; exact wp_bind_fill [.load] h + +@[spec high] theorem free_spec {l : Loc} (post : Val → State → Prop) (epost : EPost.Nil) : + (fun σ => ∃ v : Val, σ.get? l = some (some v) ∧ post (.lit .unit) (σ.initHeap l 1 none)) + ⊑ Std.Internal.Do.wp (Exp.free (.ofVal (.lit (.loc l)))) post epost := by + intro σ h; obtain ⟨v, hl, hq⟩ := h; exact wp_free hl hq + +@[spec 1000] theorem free_focus_spec {e : Exp} (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e (fun v => Std.Internal.Do.wp (Exp.free (.ofVal v)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.free e) post epost := by + intro σ h; exact wp_bind_fill [.free] h + +/-! ## Heap: store / xchg / faa (binary) -/ + +@[spec high] theorem store_spec {l : Loc} {w : Val} (post : Val → State → Prop) (epost : EPost.Nil) : + (fun σ => ∃ v : Val, σ.get? l = some (some v) ∧ post (.lit .unit) (σ.initHeap l 1 (some w))) + ⊑ Std.Internal.Do.wp (Exp.store (.ofVal (.lit (.loc l))) (.ofVal w)) post epost := by + intro σ h; obtain ⟨v, hl, hq⟩ := h; exact wp_store hl hq + +@[spec 1200] theorem store_focusL_spec {e1 : Exp} {v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e1 (fun v1 => Std.Internal.Do.wp (Exp.store (.ofVal v1) (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.store e1 (.ofVal v2)) post epost := by + intro σ h; exact wp_bind_fill [.storeL v2] h + +@[spec 1000] theorem store_focusR_spec {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e2 (fun v2 => Std.Internal.Do.wp (Exp.store e1 (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.store e1 e2) post epost := by + intro σ h; exact wp_bind_fill [.storeR e1] h + +@[spec high] theorem xchg_spec {l : Loc} {v2 : Val} (post : Val → State → Prop) (epost : EPost.Nil) : + (fun σ => ∃ v1 : Val, σ.get? l = some (some v1) ∧ post v1 (σ.initHeap l 1 (some v2))) + ⊑ Std.Internal.Do.wp (Exp.xchg (.ofVal (.lit (.loc l))) (.ofVal v2)) post epost := by + intro σ h; obtain ⟨v1, hl, hq⟩ := h; exact wp_xchg hl hq + +@[spec 1200] theorem xchg_focusL_spec {e1 : Exp} {v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e1 (fun v1 => Std.Internal.Do.wp (Exp.xchg (.ofVal v1) (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.xchg e1 (.ofVal v2)) post epost := by + intro σ h; exact wp_bind_fill [.xchgL v2] h + +@[spec 1000] theorem xchg_focusR_spec {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e2 (fun v2 => Std.Internal.Do.wp (Exp.xchg e1 (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.xchg e1 e2) post epost := by + intro σ h; exact wp_bind_fill [.xchgR e1] h + +@[spec high] theorem faa_spec {l : Loc} {i2 : Int} (post : Val → State → Prop) (epost : EPost.Nil) : + (fun σ => ∃ i1 : Int, σ.get? l = some (some (.lit (.int i1))) ∧ + post (.lit (.int i1)) (σ.initHeap l 1 (some (.lit (.int (i1 + i2)))))) + ⊑ Std.Internal.Do.wp (Exp.faa (.ofVal (.lit (.loc l))) (.ofVal (.lit (.int i2)))) post epost := by + intro σ h; obtain ⟨i1, hl, hq⟩ := h; exact wp_faa hl hq + +@[spec 1200] theorem faa_focusL_spec {e1 : Exp} {v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e1 (fun v1 => Std.Internal.Do.wp (Exp.faa (.ofVal v1) (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.faa e1 (.ofVal v2)) post epost := by + intro σ h; exact wp_bind_fill [.faaL v2] h + +@[spec 1000] theorem faa_focusR_spec {e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e2 (fun v2 => Std.Internal.Do.wp (Exp.faa e1 (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.faa e1 e2) post epost := by + intro σ h; exact wp_bind_fill [.faaR e1] h + +/-! ## Heap: compare-and-exchange (ternary) -/ + +@[spec high] theorem cmpXchg_spec {l : Loc} {v1 v2 : Val} (post : Val → State → Prop) (epost : EPost.Nil) : + (fun σ => ∃ vl : Val, σ.get? l = some (some vl) ∧ vl.compareSafe v1 ∧ + ∀ b : Bool, decide (vl = v1) = b → + post (.pair vl (.lit (.bool b))) (if b then σ.initHeap l 1 (some v2) else σ)) + ⊑ Std.Internal.Do.wp (Exp.cmpXchg (.ofVal (.lit (.loc l))) (.ofVal v1) (.ofVal v2)) post epost := by + intro σ h; obtain ⟨vl, hl, hcmp, hQ⟩ := h; exact wp_cmpXchg hl hcmp hQ + +@[spec 1200] theorem cmpXchg_focusL_spec {e0 : Exp} {v1 v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e0 (fun v0 => Std.Internal.Do.wp (Exp.cmpXchg (.ofVal v0) (.ofVal v1) (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.cmpXchg e0 (.ofVal v1) (.ofVal v2)) post epost := by + intro σ h; exact wp_bind_fill [.cmpXchgL v1 v2] h + +@[spec 1100] theorem cmpXchg_focusM_spec {e0 e1 : Exp} {v2 : Val} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e1 (fun v1 => Std.Internal.Do.wp (Exp.cmpXchg e0 (.ofVal v1) (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.cmpXchg e0 e1 (.ofVal v2)) post epost := by + intro σ h; exact wp_bind_fill [.cmpXchgM e0 v2] h + +@[spec 1000] theorem cmpXchg_focusR_spec {e0 e1 e2 : Exp} + (post : Val → State → Prop) (epost : EPost.Nil) : + Std.Internal.Do.wp e2 (fun v2 => Std.Internal.Do.wp (Exp.cmpXchg e0 e1 (.ofVal v2)) post epost) epost + ⊑ Std.Internal.Do.wp (Exp.cmpXchg e0 e1 e2) post epost := by + intro σ h; exact wp_bind_fill [.cmpXchgR e0 e1] h -/-- `vcgen` executes the nested tree and reduces the goal to the arithmetic VCs. -/ -example : (fun _ => True) ⊑ Std.Internal.Do.wp hl((#1 + #2) + (#3 + #4)) (fun r _ => r = .lit (.int 10)) EPost.Nil.mk := by +/-! ## Demos -/ + +private def lit (n : Int) : Exp := .ofVal (.lit (.int n)) +private def add (a b : Exp) : Exp := Exp.binop .plus a b + +/-- Pure arithmetic, nested redexes: `(1 + 2) + (3 + 4) = 10`. -/ +example : (fun _ => True) ⊑ + Std.Internal.Do.wp (add (add (lit 1) (lit 2)) (add (lit 3) (lit 4))) + (fun r _ => r = .lit (.int 10)) EPost.Nil.mk := by + unfold add lit + vcgen + -- Leftover VCs are the per-node `BinOp.eval` obligations. Each `rfl` also pins + -- the intermediate-value metavariable, so a couple of passes (inner nodes + -- before the outer one) discharge the whole chain regardless of goal order. + all_goals (try rfl) + all_goals (try rfl) + +/-- Mixing constructs: `fst ((1 + 2), (3 + 4)) = 3`, with a conditional wrapper. -/ +example : (fun _ => True) ⊑ + Std.Internal.Do.wp + (Exp.if (.ofVal (.lit (.bool true))) + (Exp.fst (Exp.pair (add (lit 1) (lit 2)) (add (lit 3) (lit 4)))) + (lit 0)) + (fun r _ => r = .lit (.int 3)) EPost.Nil.mk := by + unfold add lit vcgen - -- Order matters here, atm - case vc3 => rfl - case vc5 => rfl - case vc1 => rfl + all_goals (try rfl) + all_goals (try rfl) + +/-! ### Larger programs in HeapLang surface syntax + +Written with the `hl(…)` notation; `vcgen` symbolically executes the whole +expression, leaving only the primitive `BinOp.eval` obligations as VCs. -/ + +/-- Deeper arithmetic, mixed operators: `(10 - 3) * (2 + 2)` ⟶ `28`. -/ +private def arith : Exp := hl((#10 - #3) * (#2 + #2)) +example : (fun _ => True) ⊑ + Std.Internal.Do.wp arith (fun r _ => r = .lit (.int 28)) EPost.Nil.mk := by + unfold arith + vcgen + all_goals (try rfl) + all_goals (try rfl) + +/-- Build a nested tuple, then project into it (pairs/`fst`/`snd` bind nothing, so +`vcgen` handles them fully): `fst (snd (1, (2 * 3, 4 + 5)))` ⟶ `6`. -/ +private def project : Exp := hl(fst(snd((#1, (#2 * #3, #4 + #5))))) +example : (fun _ => True) ⊑ + Std.Internal.Do.wp project (fun r _ => r = .lit (.int 6)) EPost.Nil.mk := by + unfold project + vcgen + all_goals (try rfl) + all_goals (try rfl) + +/-! ### The frontier + +`vcgen` here drives *substitution-free* evaluation: arithmetic, pairs/projections, +injections, and control flow whose scrutinee is a **literal** (as in the `if true …` +demo above — the dead branch is discarded untouched). Three things are out of reach +with just these specs, all for the same underlying reason — a spec has to match the +program **syntactically**: + +* **Binding — `let`, `λ`-application, recursion.** β-reduction (`beta_redex_spec`) + produces a metalevel `Exp.subst …` term; `vcgen` has no spec for a raw `subst` + call, and feeding `Exp.subst` to its simp set makes the substitution's binder + handling panic. Needs a normalizing substitution operation `vcgen` can compute. +* **Control flow on a *computed* condition** (`if x < y then …`). The guard reduces + to `.lit (.bool (x < y))`, whose boolean does not syntactically match `if_true`'s + `true` / `if_false`'s `false`; `if_focus` then re-fires on the value scrutinee and + loops. Needs the comparison to normalize to a literal `true`/`false`. +* **Mutable state end-to-end.** `ref`/`load`/`store` each step, but the heap + side-conditions (`σ.get? l = some …`) are left as VCs — there is no separation-logic + frame in this plain `State → Prop` lattice to discharge them automatically. -/ end Iris.HeapLang.VcgenSmoke From 506fd6fb37bbd98c162019b3303f711ba29f31aa Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Thu, 23 Jul 2026 12:56:16 +0100 Subject: [PATCH 31/33] more --- Iris/Iris/HeapLang/AxSem.lean | 193 ++++++++++++++ Iris/lean-toolchain | 2 +- .../.github/workflows/lean_action_ci.yml | 14 + IrisDoNightly/.gitignore | 1 + IrisDoNightly/IrisDoNightly.lean | 1 + IrisDoNightly/IrisDoNightly/AxSem.lean | 199 ++++++++++++++ IrisDoNightly/IrisDoNightly/Prelude.lean | 169 ++++++++++++ IrisDoNightly/IrisDoNightly/Semantics.lean | 200 ++++++++++++++ IrisDoNightly/IrisDoNightly/Syntax.lean | 247 ++++++++++++++++++ IrisDoNightly/README.md | 1 + IrisDoNightly/lake-manifest.json | 6 + IrisDoNightly/lakefile.toml | 6 + IrisDoNightly/lean-toolchain | 1 + 13 files changed, 1039 insertions(+), 1 deletion(-) create mode 100644 Iris/Iris/HeapLang/AxSem.lean create mode 100644 IrisDoNightly/.github/workflows/lean_action_ci.yml create mode 100644 IrisDoNightly/.gitignore create mode 100644 IrisDoNightly/IrisDoNightly.lean create mode 100644 IrisDoNightly/IrisDoNightly/AxSem.lean create mode 100644 IrisDoNightly/IrisDoNightly/Prelude.lean create mode 100644 IrisDoNightly/IrisDoNightly/Semantics.lean create mode 100644 IrisDoNightly/IrisDoNightly/Syntax.lean create mode 100644 IrisDoNightly/README.md create mode 100644 IrisDoNightly/lake-manifest.json create mode 100644 IrisDoNightly/lakefile.toml create mode 100644 IrisDoNightly/lean-toolchain diff --git a/Iris/Iris/HeapLang/AxSem.lean b/Iris/Iris/HeapLang/AxSem.lean new file mode 100644 index 000000000..507647800 --- /dev/null +++ b/Iris/Iris/HeapLang/AxSem.lean @@ -0,0 +1,193 @@ +module + +import Iris.HeapLang.Semantics +import Std.Tactic.Do +import Std.Internal.Do + +/-! # Axiomatic Semantics for HeapLang -/ + +set_option mvcgen.warning false + +open Lean.Order + +namespace Iris.HeapLang.Ax + +/-- A predicate `wp` imbues a fragment of HeapLang with the correct axiomatic semantics. +In particular, `wp` admits proof rules that obey the evaluation order and effects of HeapLang. -/ +class HeapLangAxioms (wp : Exp → (Val → Prop) → Prop) where + wp_mono : (∀ v, Φ v → Ψ v) → wp e Φ → wp e Ψ + wp_val : Φ v → wp (Exp.ofVal v) Φ + wp_closure : Φ (.rec_ f x e) → wp (Exp.rec_ f x e) Φ + wp_app : + wp e₂ (fun v₂ => wp e₁ (fun vf => ∃ f x body, vf = Val.rec_ f x body ∧ + wp ((body.subst f (.rec_ f x body)).subst x v₂) Φ)) → + wp (Exp.app e₁ e₂) Φ + wp_unop : + wp e (fun v => ∃ v', op.eval v = some v' ∧ Φ v') → + wp (Exp.unop op e) Φ + wp_binop : + wp e₂ (fun v₂ => wp e₁ (fun v₁ => ∃ v', op.eval v₁ v₂ = some v' ∧ Φ v')) → + wp (Exp.binop op e₁ e₂) Φ + wp_cond : + wp e₀ (fun vc => ∃ b, vc = Val.lit (.bool b) ∧ wp (if b then e₁ else e₂) Φ) → + wp (Exp.if e₀ e₁ e₂) Φ + wp_pair : + wp e₂ (fun v₂ => wp e₁ (fun v₁ => Φ (Val.pair v₁ v₂))) → + wp (Exp.pair e₁ e₂) Φ + wp_fst : wp e (fun v => ∃ v₁ v₂, v = Val.pair v₁ v₂ ∧ Φ v₁) → wp (Exp.fst e) Φ + wp_snd : wp e (fun v => ∃ v₁ v₂, v = Val.pair v₁ v₂ ∧ Φ v₂) → wp (Exp.snd e) Φ + wp_injL : wp e (fun v => Φ (Val.injL v)) → wp (Exp.injL e) Φ + wp_injR : wp e (fun v => Φ (Val.injR v)) → wp (Exp.injR e) Φ + wp_case : + wp e₀ (fun vc => + (∃ v, vc = Val.injL v ∧ wp (Exp.app e₁ (Exp.ofVal v)) Φ) ∨ + (∃ v, vc = Val.injR v ∧ wp (Exp.app e₂ (Exp.ofVal v)) Φ)) → + wp (Exp.case e₀ e₁ e₂) Φ + +open HeapLangAxioms Std.Internal.Do + +/-- Local notation for a Std.Do weakest precondition. -/ +scoped syntax:max "wp⟦" term:min "⟧" ppSpace term:max : term +scoped macro_rules + | `(wp⟦ $e ⟧ $Φ) => `(Std.Internal.Do.wp $e $Φ Std.Internal.Do.EPost.Nil.mk) + +set_option synthInstance.checkSynthOrder false in +instance instWP_HeapLangAxioms {wp} [HeapLangAxioms wp] : + Std.Internal.Do.WP Exp Val Prop EPost.Nil where + wpTrans e := ⟨fun Φ _ => wp e Φ⟩ + wp_trans_monotone _ _ _ _ _ _ := wp_mono + +section laws + +variable {wp} [HeapLangAxioms wp] + +@[spec] theorem spec_val {v : Val} {Φ : Val → Prop} : + Φ v ⊑ wp⟦(Exp.ofVal v : Exp)⟧ Φ := by + intro h; exact wp_val h + +@[spec] theorem spec_rec {f x : Binder} {e : Exp} {Φ : Val → Prop} : + Φ (.rec_ f x e) ⊑ wp⟦Exp.rec_ f x e⟧ Φ := by + intro h; exact wp_closure h + +@[spec] theorem spec_app {e₁ e₂ : Exp} {Φ : Val → Prop} : + wp⟦e₂⟧ (fun v₂ => wp⟦e₁⟧ (fun vf => ∃ f x body, vf = Val.rec_ f x body ∧ + wp⟦(body.subst f (.rec_ f x body)).subst x v₂⟧ Φ)) + ⊑ wp⟦Exp.app e₁ e₂⟧ Φ := by + intro h; exact wp_app h + +@[spec] theorem spec_unop {op : UnOp} {e : Exp} {Φ : Val → Prop} : + wp⟦e⟧ (fun v => ∃ v', op.eval v = some v' ∧ Φ v') + ⊑ wp⟦Exp.unop op e⟧ Φ := by + intro h; exact wp_unop h + +@[spec] theorem spec_binop {op : BinOp} {e₁ e₂ : Exp} {Φ : Val → Prop} : + wp⟦e₂⟧ (fun v₂ => wp⟦e₁⟧ (fun v₁ => ∃ v', op.eval v₁ v₂ = some v' ∧ Φ v')) + ⊑ wp⟦Exp.binop op e₁ e₂⟧ Φ := by + intro h; exact wp_binop h + +@[spec] theorem spec_if {e₀ e₁ e₂ : Exp} {Φ : Val → Prop} : + wp⟦e₀⟧ (fun vc => ∃ b, vc = Val.lit (.bool b) ∧ wp⟦if b then e₁ else e₂⟧ Φ) + ⊑ wp⟦Exp.if e₀ e₁ e₂⟧ Φ := by + intro h; exact wp_cond h + +@[spec] theorem spec_pair {e₁ e₂ : Exp} {Φ : Val → Prop} : + wp⟦e₂⟧ (fun v₂ => wp⟦e₁⟧ (fun v₁ => Φ (Val.pair v₁ v₂))) + ⊑ wp⟦Exp.pair e₁ e₂⟧ Φ := by + intro h; exact wp_pair h + +@[spec] theorem spec_fst {e : Exp} {Φ : Val → Prop} : + wp⟦e⟧ (fun v => ∃ v₁ v₂, v = Val.pair v₁ v₂ ∧ Φ v₁) + ⊑ wp⟦Exp.fst e⟧ Φ := by + intro h; exact wp_fst h + +@[spec] theorem spec_snd {e : Exp} {Φ : Val → Prop} : + wp⟦e⟧ (fun v => ∃ v₁ v₂, v = Val.pair v₁ v₂ ∧ Φ v₂) + ⊑ wp⟦Exp.snd e⟧ Φ := by + intro h; exact wp_snd h + +@[spec] theorem spec_injL {e : Exp} {Φ : Val → Prop} : + wp⟦e⟧ (fun v => Φ (Val.injL v)) ⊑ wp⟦Exp.injL e⟧ Φ := by + intro h; exact wp_injL h + +@[spec] theorem spec_injR {e : Exp} {Φ : Val → Prop} : + wp⟦e⟧ (fun v => Φ (Val.injR v)) ⊑ wp⟦Exp.injR e⟧ Φ := by + intro h; exact wp_injR h + +@[spec] theorem spec_case {e₀ e₁ e₂ : Exp} {Φ : Val → Prop} : + wp⟦e₀⟧ (fun vc => + (∃ v, vc = Val.injL v ∧ wp⟦Exp.app e₁ (Exp.ofVal v)⟧ Φ) ∨ + (∃ v, vc = Val.injR v ∧ wp⟦Exp.app e₂ (Exp.ofVal v)⟧ Φ)) + ⊑ wp⟦Exp.case e₀ e₁ e₂⟧ Φ := by + intro h; exact wp_case h + +end laws + + +section demos + +variable {wp} [HeapLangAxioms wp] + +private def lit (n : Int) : Exp := .ofVal (.lit (.int n)) +private def bool (b : Bool) : Exp := .ofVal (.lit (.bool b)) +private def lam (x : String) (e : Exp) : Exp := .rec_ .anon (.named x) e +private def add (a b : Exp) : Exp := .binop .plus a b + +/-- Substituting into a value-expression is the identity. Needed because the +default simp set normalises `.val` to `.ofVal` (`val_to_ofVal`), so `substStr`'s +`.val` case cannot fire on a `.ofVal` leaf; this `rfl` lemma bridges the gap while +keeping the `vcgen`-friendly `.ofVal` form. -/ +@[local simp] private theorem substStr_ofVal (x : String) (v w : Val) : + Exp.substStr x v (Exp.ofVal w) = Exp.ofVal w := rfl + +/-! ### Values and pure arithmetic -/ + +example : True ⊑ wp⟦lit 0⟧ (fun _v => True) := by + unfold lit; vcgen + +example : True ⊑ wp⟦lit 0⟧ (fun v => v = Val.lit (.int 0)) := by + unfold lit; vcgen with finish + +/-- `(1 + 2) + (3 + 4) = 10`, nested redexes. -/ +example : True ⊑ wp⟦add (add (lit 1) (lit 2)) (add (lit 3) (lit 4))⟧ (fun v => v = Val.lit (.int 10)) := by + unfold add lit + vcgen <;> (try simp [BinOp.eval]) <;> (try vcgen) <;> (try simp [BinOp.eval]) + +/-! ### Computed conditions -/ + +/-- The guard is a comparison, not a literal: `if 1 < 2 then 1 else 2 = 1`. -/ +example : True ⊑ wp⟦Exp.if (.binop .lt (lit 1) (lit 2)) (lit 1) (lit 2)⟧ (fun v => v = Val.lit (.int 1)) := by + unfold lit + vcgen <;> (try simp [BinOp.eval]) <;> (try vcgen) <;> (try simp [BinOp.eval]) <;> + (try vcgen) <;> (try simp [BinOp.eval]) + +/-! ### Binders (β-reduction) + +The workflow: `vcgen until Exp.subst _ _ _` symbolically executes up to the +substitution redex, `simp [Exp.subst, Exp.substStr]` computes it, then `vcgen` +resumes on the concrete substituted program. -/ + +/-- Identity applied to a literal: `(λx. x) 0`. -/ +example : True ⊑ wp⟦Exp.app (lam "x" (.var "x")) (lit 0)⟧ (fun _v => True) := by + unfold lam lit + vcgen until Exp.subst _ _ _ + refine ⟨_, _, _, rfl, ?_⟩ + simp [Exp.subst, Exp.substStr] + vcgen + +/-- The bound variable is used in an arithmetic context: `(λx. x + 1) 5 = 6`. -/ +example : True ⊑ wp⟦Exp.app (lam "x" (add (.var "x") (lit 1))) (lit 5)⟧ (fun v => v = Val.lit (.int 6)) := by + unfold lam add lit + vcgen until Exp.subst _ _ _ + refine ⟨_, _, _, rfl, ?_⟩ + simp [Exp.subst, Exp.substStr] + vcgen <;> (try simp [BinOp.eval]) <;> (try vcgen) <;> (try simp [BinOp.eval]) + +/-! ### Products and sums -/ + +/-- `fst (1 + 2, 3 + 4) = 3`. -/ +example : True ⊑ wp⟦Exp.fst (Exp.pair (add (lit 1) (lit 2)) (add (lit 3) (lit 4)))⟧ (fun v => v = Val.lit (.int 3)) := by + unfold add lit + vcgen <;> (try simp [BinOp.eval]) <;> (try vcgen) <;> (try simp [BinOp.eval]) + +end demos +end Iris.HeapLang.Ax diff --git a/Iris/lean-toolchain b/Iris/lean-toolchain index fd85b262b..b9371ec41 100644 --- a/Iris/lean-toolchain +++ b/Iris/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.33.0-rc1 +leanprover/lean4:4.33.0-rc1 diff --git a/IrisDoNightly/.github/workflows/lean_action_ci.yml b/IrisDoNightly/.github/workflows/lean_action_ci.yml new file mode 100644 index 000000000..c48bd6829 --- /dev/null +++ b/IrisDoNightly/.github/workflows/lean_action_ci.yml @@ -0,0 +1,14 @@ +name: Lean Action CI + +on: + push: + pull_request: + workflow_dispatch: + +jobs: + build: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v5 + - uses: leanprover/lean-action@v1 diff --git a/IrisDoNightly/.gitignore b/IrisDoNightly/.gitignore new file mode 100644 index 000000000..bfb30ec8c --- /dev/null +++ b/IrisDoNightly/.gitignore @@ -0,0 +1 @@ +/.lake diff --git a/IrisDoNightly/IrisDoNightly.lean b/IrisDoNightly/IrisDoNightly.lean new file mode 100644 index 000000000..24c6ff66d --- /dev/null +++ b/IrisDoNightly/IrisDoNightly.lean @@ -0,0 +1 @@ +import IrisDoNightly.AxSem diff --git a/IrisDoNightly/IrisDoNightly/AxSem.lean b/IrisDoNightly/IrisDoNightly/AxSem.lean new file mode 100644 index 000000000..5e955515d --- /dev/null +++ b/IrisDoNightly/IrisDoNightly/AxSem.lean @@ -0,0 +1,199 @@ +module + +public import IrisDoNightly.Semantics +import Std.Tactic.Do +import Std.Internal.Do + +/-! # Axiomatic Semantics for HeapLang -/ + +set_option mvcgen.warning false + +open Lean.Order + +namespace Iris.HeapLang.Ax + +/-- A predicate `wp` imbues a fragment of HeapLang with the correct axiomatic semantics. +In particular, `wp` admits proof rules that obey the evaluation order and effects of HeapLang. -/ +class HeapLangAxioms (wp : Exp → (Val → Prop) → Prop) where + wp_mono : (∀ v, Φ v → Ψ v) → wp e Φ → wp e Ψ + wp_val : Φ v → wp (Exp.ofVal v) Φ + wp_closure : Φ (.rec_ f x e) → wp (Exp.rec_ f x e) Φ + wp_app : + wp e₂ (fun v₂ => wp e₁ (fun vf => ∃ f x body, vf = Val.rec_ f x body ∧ + wp ((body.subst f (.rec_ f x body)).subst x v₂) Φ)) → + wp (Exp.app e₁ e₂) Φ + wp_unop : + wp e (fun v => ∃ v', op.eval v = some v' ∧ Φ v') → + wp (Exp.unop op e) Φ + wp_binop : + wp e₂ (fun v₂ => wp e₁ (fun v₁ => ∃ v', op.eval v₁ v₂ = some v' ∧ Φ v')) → + wp (Exp.binop op e₁ e₂) Φ + wp_cond : + wp e₀ (fun vc => ∃ b, vc = Val.lit (.bool b) ∧ wp (if b then e₁ else e₂) Φ) → + wp (Exp.if e₀ e₁ e₂) Φ + wp_pair : + wp e₂ (fun v₂ => wp e₁ (fun v₁ => Φ (Val.pair v₁ v₂))) → + wp (Exp.pair e₁ e₂) Φ + wp_fst : wp e (fun v => ∃ v₁ v₂, v = Val.pair v₁ v₂ ∧ Φ v₁) → wp (Exp.fst e) Φ + wp_snd : wp e (fun v => ∃ v₁ v₂, v = Val.pair v₁ v₂ ∧ Φ v₂) → wp (Exp.snd e) Φ + wp_injL : wp e (fun v => Φ (Val.injL v)) → wp (Exp.injL e) Φ + wp_injR : wp e (fun v => Φ (Val.injR v)) → wp (Exp.injR e) Φ + wp_case : + wp e₀ (fun vc => + (∃ v, vc = Val.injL v ∧ wp (Exp.app e₁ (Exp.ofVal v)) Φ) ∨ + (∃ v, vc = Val.injR v ∧ wp (Exp.app e₂ (Exp.ofVal v)) Φ)) → + wp (Exp.case e₀ e₁ e₂) Φ + +open HeapLangAxioms Std.Internal.Do + +/-- Local notation for a Std.Do weakest precondition. -/ +scoped syntax:max "wp⟦" term:min "⟧" ppSpace term:max : term +scoped macro_rules + | `(wp⟦ $e ⟧ $Φ) => `(Std.Internal.Do.wp $e $Φ Std.Internal.Do.EPost.Nil.mk) + +set_option synthInstance.checkSynthOrder false in +instance instWP_HeapLangAxioms {wp} [HeapLangAxioms wp] : + Std.Internal.Do.WP Exp Val Prop EPost.Nil where + wpTrans e := ⟨fun Φ _ => wp e Φ⟩ + wp_trans_monotone _ _ _ _ _ _ := wp_mono + +section laws + +variable {wp} [HeapLangAxioms wp] + +@[spec] theorem spec_val {v : Val} {Φ : Val → Prop} : + Φ v ⊑ wp⟦(Exp.ofVal v : Exp)⟧ Φ := by + intro h; exact wp_val h + +@[spec] theorem spec_rec {f x : Binder} {e : Exp} {Φ : Val → Prop} : + Φ (.rec_ f x e) ⊑ wp⟦Exp.rec_ f x e⟧ Φ := by + intro h; exact wp_closure h + +@[spec] theorem spec_app {e₁ e₂ : Exp} {Φ : Val → Prop} : + wp⟦e₂⟧ (fun v₂ => wp⟦e₁⟧ (fun vf => ∃ f x body, vf = Val.rec_ f x body ∧ + wp⟦(body.subst f (.rec_ f x body)).subst x v₂⟧ Φ)) + ⊑ wp⟦Exp.app e₁ e₂⟧ Φ := by + intro h; exact wp_app h + +@[spec] theorem spec_unop {op : UnOp} {e : Exp} {Φ : Val → Prop} : + wp⟦e⟧ (fun v => ∃ v', op.eval v = some v' ∧ Φ v') + ⊑ wp⟦Exp.unop op e⟧ Φ := by + intro h; exact wp_unop h + +@[spec] theorem spec_binop {op : BinOp} {e₁ e₂ : Exp} {Φ : Val → Prop} : + wp⟦e₂⟧ (fun v₂ => wp⟦e₁⟧ (fun v₁ => ∃ v', op.eval v₁ v₂ = some v' ∧ Φ v')) + ⊑ wp⟦Exp.binop op e₁ e₂⟧ Φ := by + intro h; exact wp_binop h + +@[spec] theorem spec_if {e₀ e₁ e₂ : Exp} {Φ : Val → Prop} : + wp⟦e₀⟧ (fun vc => ∃ b, vc = Val.lit (.bool b) ∧ wp⟦if b then e₁ else e₂⟧ Φ) + ⊑ wp⟦Exp.if e₀ e₁ e₂⟧ Φ := by + intro h; exact wp_cond h + +@[spec] theorem spec_pair {e₁ e₂ : Exp} {Φ : Val → Prop} : + wp⟦e₂⟧ (fun v₂ => wp⟦e₁⟧ (fun v₁ => Φ (Val.pair v₁ v₂))) + ⊑ wp⟦Exp.pair e₁ e₂⟧ Φ := by + intro h; exact wp_pair h + +@[spec] theorem spec_fst {e : Exp} {Φ : Val → Prop} : + wp⟦e⟧ (fun v => ∃ v₁ v₂, v = Val.pair v₁ v₂ ∧ Φ v₁) + ⊑ wp⟦Exp.fst e⟧ Φ := by + intro h; exact wp_fst h + +@[spec] theorem spec_snd {e : Exp} {Φ : Val → Prop} : + wp⟦e⟧ (fun v => ∃ v₁ v₂, v = Val.pair v₁ v₂ ∧ Φ v₂) + ⊑ wp⟦Exp.snd e⟧ Φ := by + intro h; exact wp_snd h + +@[spec] theorem spec_injL {e : Exp} {Φ : Val → Prop} : + wp⟦e⟧ (fun v => Φ (Val.injL v)) ⊑ wp⟦Exp.injL e⟧ Φ := by + intro h; exact wp_injL h + +@[spec] theorem spec_injR {e : Exp} {Φ : Val → Prop} : + wp⟦e⟧ (fun v => Φ (Val.injR v)) ⊑ wp⟦Exp.injR e⟧ Φ := by + intro h; exact wp_injR h + +@[spec] theorem spec_case {e₀ e₁ e₂ : Exp} {Φ : Val → Prop} : + wp⟦e₀⟧ (fun vc => + (∃ v, vc = Val.injL v ∧ wp⟦Exp.app e₁ (Exp.ofVal v)⟧ Φ) ∨ + (∃ v, vc = Val.injR v ∧ wp⟦Exp.app e₂ (Exp.ofVal v)⟧ Φ)) + ⊑ wp⟦Exp.case e₀ e₁ e₂⟧ Φ := by + intro h; exact wp_case h + +end laws + + +section demos + +variable {wp} [HeapLangAxioms wp] + +private def lit (n : Int) : Exp := .ofVal (.lit (.int n)) +private def bool (b : Bool) : Exp := .ofVal (.lit (.bool b)) +private def lam (x : String) (e : Exp) : Exp := .rec_ .anon (.named x) e +private def add (a b : Exp) : Exp := .binop .plus a b + +/-- Substituting into a value-expression is the identity. Needed because the +default simp set normalises `.val` to `.ofVal` (`val_to_ofVal`), so `substStr`'s +`.val` case cannot fire on a `.ofVal` leaf; this `rfl` lemma bridges the gap while +keeping the `vcgen`-friendly `.ofVal` form. -/ +@[local simp] private theorem substStr_ofVal (x : String) (v w : Val) : + Exp.substStr x v (Exp.ofVal w) = Exp.ofVal w := rfl + +/-! ### Values and pure arithmetic -/ + +example : True ⊑ wp⟦lit 0⟧ (fun _v => True) := by + unfold lit; vcgen + +example : True ⊑ wp⟦lit 0⟧ (fun v => v = Val.lit (.int 0)) := by + unfold lit; vcgen with finish + +attribute [simp] BinOp.eval + +/-- `(1 + 2) + (3 + 4) = 10`, nested redexes. -/ +example : True ⊑ wp⟦add (add (lit 1) (lit 2)) (add (lit 3) (lit 4))⟧ (fun v => v = Val.lit (.int 10)) := by + simp only [add, lit] + vcgen + simp [BinOp.eval] + vcgen + simp + +/-! ### Computed conditions -/ + +/-- The guard is a comparison, not a literal: `if 1 < 2 then 1 else 2 = 1`. -/ +example : True ⊑ wp⟦Exp.if (.binop .lt (lit 1) (lit 2)) (lit 1) (lit 2)⟧ (fun v => v = Val.lit (.int 1)) := by + unfold lit + vcgen + simp [BinOp.eval] + vcgen + +/-! ### Binders (β-reduction) + +The workflow: `vcgen until Exp.subst _ _ _` symbolically executes up to the +substitution redex, `simp [Exp.subst, Exp.substStr]` computes it, then `vcgen` +resumes on the concrete substituted program. -/ + +/-- Identity applied to a literal: `(λx. x) 0`. -/ +example : True ⊑ wp⟦Exp.app (lam "x" (.var "x")) (lit 0)⟧ (fun _v => True) := by + simp only [lam, lit] + vcgen until Exp.subst _ _ _ + refine ⟨_, _, _, rfl, ?_⟩ + simp [Exp.subst, Exp.substStr] + vcgen + +/-- The bound variable is used in an arithmetic context: `(λx. x + 1) 5 = 6`. -/ +example : True ⊑ wp⟦Exp.app (lam "x" (add (.var "x") (lit 1))) (lit 5)⟧ (fun v => v = Val.lit (.int 6)) := by + unfold lam add lit + vcgen until Exp.subst _ _ _ + refine ⟨_, _, _, rfl, ?_⟩ + simp [Exp.subst, Exp.substStr] + vcgen <;> (try simp [BinOp.eval]) <;> (try vcgen) <;> (try simp [BinOp.eval]) + +/-! ### Products and sums -/ + +/-- `fst (1 + 2, 3 + 4) = 3`. -/ +example : True ⊑ wp⟦Exp.fst (Exp.pair (add (lit 1) (lit 2)) (add (lit 3) (lit 4)))⟧ (fun v => v = Val.lit (.int 3)) := by + unfold add lit + vcgen <;> (try simp [BinOp.eval]) <;> (try vcgen) <;> (try simp [BinOp.eval]) + +end demos +end Iris.HeapLang.Ax diff --git a/IrisDoNightly/IrisDoNightly/Prelude.lean b/IrisDoNightly/IrisDoNightly/Prelude.lean new file mode 100644 index 000000000..2276dc941 --- /dev/null +++ b/IrisDoNightly/IrisDoNightly/Prelude.lean @@ -0,0 +1,169 @@ +module + +public import Std.Data.ExtTreeMap +public import Std.Data.ExtTreeSet + +/-! +# Prelude shims for `IrisDoNightly` + +This experimental project ports the HeapLang syntax and operational semantics onto a +bleeding-edge Lean nightly so that we can play with the `Std.Do` weakest-precondition +machinery, *without* dragging in the whole Iris algebra/BI stack (which is pinned to an +older stable toolchain). + +Rather than importing `Iris.ProgramLogic.Language`, `Iris.Std.BitOp`, +`Iris.Std.Infinite`, `Iris.Std.PartialMap`, `Iris.Std.HeapInstances`, … (which transitively +pull in the entire library), we reproduce here the *small* pieces those files provide that +the syntax and semantics actually depend on: + +* the `Int` bit-wise / shift instances (from `Iris.Std.BitOp`, originally copied from Mathlib); +* the `InfiniteType` class (from `Iris.Std.Infinite`); +* the `ToVal` class (from `Iris.ProgramLogic.Language`); +* a minimal `PartialMap` class together with the `Std.ExtTreeMap` instance + (from `Iris.Std.PartialMap` / `Iris.Std.HeapInstances`). +-/ + +@[expose] public section + +/-! ## Integer bit-wise operations + +Copied from `Iris.Std.BitOp` (itself copied from Mathlib). Lean core does not provide +`AndOp`/`OrOp`/`XorOp`/`ShiftLeft`/`ShiftRight` instances for `Int`, so `BinOp.eval` needs +them. -/ + +namespace IrisDoNightly.BitOp + +namespace Nat + +/-- `ldiff` computes the bitwise "and not" of two natural numbers. -/ +def ldiff : Nat → Nat → Nat := + Nat.bitwise fun a b => a && not b + +/-- `bit b` appends the digit `b` to the little end of the binary representation of `n`. -/ +def bit (b : Bool) (n : Nat) : Nat := + cond b (2 * n + 1) (2 * n) + +/-- `shiftLeft' b m n` left-shifts `m` `n` times, inserting bit `b` each step. -/ +def shiftLeft' (b : Bool) (m : Nat) : Nat → Nat + | 0 => m + | n + 1 => bit b (shiftLeft' b m n) + +end Nat + +namespace Int + +open _root_.IrisDoNightly.BitOp.Nat _root_.Int + +/-- Bitwise `or` on integers. -/ +def lor : Int → Int → Int + | (m : Nat), (n : Nat) => m ||| n + | (m : Nat), -[n+1] => -[ldiff n m+1] + | -[m+1], (n : Nat) => -[ldiff m n+1] + | -[m+1], -[n+1] => -[m &&& n+1] + +instance : OrOp Int := ⟨lor⟩ + +/-- Bitwise `and` on integers. -/ +def land : Int → Int → Int + | (m : Nat), (n : Nat) => m &&& n + | (m : Nat), -[n+1] => ldiff m n + | -[m+1], (n : Nat) => ldiff n m + | -[m+1], -[n+1] => -[m ||| n+1] + +instance : AndOp Int := ⟨land⟩ + +/-- Bitwise `xor` on integers. -/ +def xor : Int → Int → Int + | (m : Nat), (n : Nat) => (m ^^^ n) + | (m : Nat), -[n+1] => -[(m ^^^ n)+1] + | -[m+1], (n : Nat) => -[(m ^^^ n)+1] + | -[m+1], -[n+1] => (m ^^^ n) + +instance : XorOp Int := ⟨xor⟩ + +/-- Left shift on integers. -/ +instance : ShiftLeft Int where + shiftLeft + | (m : Nat), (n : Nat) => Nat.shiftLeft' false m n + | (m : Nat), -[n+1] => m >>> (Nat.succ n) + | -[m+1], (n : Nat) => -[Nat.shiftLeft' true m n+1] + | -[m+1], -[n+1] => -[m >>> (Nat.succ n)+1] + +/-- Right shift on integers. -/ +instance : ShiftRight Int where + shiftRight m n := m <<< (-n) + +end Int + +end IrisDoNightly.BitOp + +-- Bring the `Int` instances into scope everywhere. +open IrisDoNightly.BitOp.Int + +/-! ## Infinite types + +Copied from `Iris.Std.Infinite`. -/ + +/-- A type is *infinite* if there is an injection `Nat → T`. -/ +class InfiniteType (T : Type _) where + enum : Nat → T + enum_inj : ∀ n m : Nat, enum n = enum m → n = m + +instance : InfiniteType Nat where + enum := id + enum_inj _ _ H := H + +/-! ## `ToVal` + +Copied from `Iris.ProgramLogic.Language`, minus the `rocq_alias` bookkeeping. -/ + +namespace Iris.ProgramLogic + +class ToVal (Expr : Type _) (Val : outParam (Type _)) where + toVal : Expr → Option Val + ofVal : Val → Expr + /-- If `toVal` is defined for an expression, `ofVal` is its inverse. -/ + coe_of_toVal_eq_some {e : Expr} {v : Val} : toVal e = some v → ofVal v = e + /-- `toVal` is the inverse of `ofVal`. -/ + toVal_coe (v : Val) : toVal (ofVal v) = some v +export ToVal (toVal coe_of_toVal_eq_some toVal_coe) + +attribute [simp, grind =] ToVal.toVal_coe +attribute [coe] ToVal.ofVal + +namespace ToVal + +variable {Expr Val : Type _} [ι : ToVal Expr Val] + +instance : Coe Val Expr where coe := ofVal + +@[grind! .] +theorem toVal_eq_iff_coe (e : Expr) (v : Val) : v = e ↔ toVal e = some v := + ⟨(· ▸ toVal_coe v), coe_of_toVal_eq_some⟩ + +theorem ofVal_inj : ι.ofVal.Injective := by + intro x y h + simpa [toVal_coe] using congrArg (toVal) h + +end ToVal +end Iris.ProgramLogic + +/-! ## Partial maps + +A minimal version of `Iris.Std.PartialMap` providing just the `get?`/`insert` operations, +together with the `Std.ExtTreeMap` instance from `Iris.Std.HeapInstances`, which is all the +HeapLang semantics needs to model its heap. -/ + +namespace Iris.Std + +class PartialMap (M : Type _ → Type _) (K : outParam (Type _)) where + get? : M V → K → Option V + insert : M V → K → V → M V +export PartialMap (get? insert) + +instance {K : Type _} [Ord K] [Std.TransOrd K] [Std.LawfulEqOrd K] : + PartialMap (Std.ExtTreeMap K · compare) K where + get? t k := t[k]? + insert t k v := t.alter k (fun _ => some v) + +end Iris.Std diff --git a/IrisDoNightly/IrisDoNightly/Semantics.lean b/IrisDoNightly/IrisDoNightly/Semantics.lean new file mode 100644 index 000000000..dd39d55ad --- /dev/null +++ b/IrisDoNightly/IrisDoNightly/Semantics.lean @@ -0,0 +1,200 @@ +/- +Copyright (c) 2026 Sergei Stepanenko. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import IrisDoNightly.Syntax +public import Std.Data.ExtTreeMap +public import Std.Data.ExtTreeSet + +@[expose] public section +namespace Iris.HeapLang + +open _root_.Std Iris.Std + +inductive ECtxItem where + | appL (v2 : Val) + | appR (e1 : Exp) + | unOp (op : UnOp) + | binOpL (op : BinOp) (v2 : Val) + | binOpR (op : BinOp) (e1 : Exp) + | if (e1 e2 : Exp) + | pairL (v2 : Val) + | pairR (e1 : Exp) + | fst + | snd + | injL + | injR + | case (e1 e2 : Exp) + | allocNL (v2 : Val) + | allocNR (e1 : Exp) + | free + | load + | storeL (v2 : Val) + | storeR (e1 : Exp) + | xchgL (v2 : Val) + | xchgR (e1 : Exp) + | cmpXchgL (v1 v2 : Val) + | cmpXchgM (e0 : Exp) (v2 : Val) + | cmpXchgR (e0 e1 : Exp) + | faaL (v2 : Val) + | faaR (e1 : Exp) + | resolveL (ctx : ECtxItem) (v1 v2 : Val) + | resolveM (e0 : Exp) (v2 : Val) + | resolveR (e0 e1 : Exp) + deriving Inhabited, Repr, DecidableEq + +def ECtxItem.fill (Ki : ECtxItem) (e : Exp) : Exp := + match Ki with + | .appL v2 => .app e (.ofVal v2) + | .appR e1 => .app e1 e + | .unOp op => .unop op e + | .binOpL op v2 => .binop op e (.ofVal v2) + | .binOpR op e1 => .binop op e1 e + | .if e1 e2 => .if e e1 e2 + | .pairL v2 => .pair e (.ofVal v2) + | .pairR e1 => .pair e1 e + | .fst => .fst e + | .snd => .snd e + | .injL => .injL e + | .injR => .injR e + | .case e1 e2 => .case e e1 e2 + | .allocNL v2 => .allocN e (.ofVal v2) + | .allocNR e1 => .allocN e1 e + | .free => .free e + | .load => .load e + | .storeL v2 => .store e (.ofVal v2) + | .storeR e1 => .store e1 e + | .xchgL v2 => .xchg e (.ofVal v2) + | .xchgR e1 => .xchg e1 e + | .cmpXchgL v1 v2 => .cmpXchg e (.ofVal v1) (.ofVal v2) + | .cmpXchgM e0 v2 => .cmpXchg e0 e (.ofVal v2) + | .cmpXchgR e0 e1 => .cmpXchg e0 e1 e + | .faaL v2 => .faa e (.ofVal v2) + | .faaR e1 => .faa e1 e + | .resolveL K v1 v2 => .resolve (K.fill e) (.ofVal v1) (.ofVal v2) + | .resolveM e0 v2 => .resolve e0 e (.ofVal v2) + | .resolveR e0 e1 => .resolve e0 e1 e + +structure State where + heap : Std.ExtTreeMap Loc (Option Val) + usedProphId : Std.ExtTreeSet ProphId + +instance : Inhabited State := ⟨.empty, .empty⟩ + +abbrev Observation := ProphId × (Val × Val) + +def UnOp.eval : UnOp → Val → Option Val + | .neg, .lit (.bool b) => some (.lit (.bool (!b))) + | .minus, .lit (.int n) => some (.lit (.int (-n))) + | _, _ => none + +def BinOp.eval : BinOp → Val → Val → Option Val + | .plus, .lit (.int n1), .lit (.int n2) => some (.lit (.int (n1 + n2))) + | .minus, .lit (.int n1), .lit (.int n2) => some (.lit (.int (n1 - n2))) + | .mult, .lit (.int n1), .lit (.int n2) => some (.lit (.int (n1 * n2))) + | .tdiv, .lit (.int n1), .lit (.int n2) => some (.lit (.int (n1.tdiv n2))) + | .tmod, .lit (.int n1), .lit (.int n2) => some (.lit (.int (n1.tmod n2))) + | .and, .lit (.int n1), .lit (.int n2) => some (.lit (.int (n1 &&& n2))) + | .or, .lit (.int n1), .lit (.int n2) => some (.lit (.int (n1 ||| n2))) + | .xor, .lit (.int n1), .lit (.int n2) => some (.lit (.int (n1 ^^^ n2))) + | .and, .lit (.bool b1), .lit (.bool b2) => some (.lit (.bool (b1 && b2))) + | .or, .lit (.bool b1), .lit (.bool b2) => some (.lit (.bool (b1 || b2))) + | .xor, .lit (.bool b1), .lit (.bool b2) => some (.lit (.bool (b1 ^^ b2))) + | .shiftl, .lit (.int n1), .lit (.int n2) => some (.lit (.int (n1 <<< n2))) + | .shiftr, .lit (.int n1), .lit (.int n2) => some (.lit (.int (n1 >>> n2))) + | .le, .lit (.int n1), .lit (.int n2) => some (.lit (.bool (n1 ≤ n2))) + | .lt, .lit (.int n1), .lit (.int n2) => some (.lit (.bool (n1 < n2))) + | .eq, v1, v2 => + if v1.compareSafe v2 then some (.lit (.bool (v1 == v2))) else none + | .offset, .lit (.loc l), .lit (.int n) => some (.lit (.loc (l + n))) + | _, _, _ => none + +abbrev State.initHeap (σ : State) (l : Loc) (n : Int) (v : Option Val) : State := + { σ with heap := (List.range n.toNat).foldl + (fun h (i : Nat) => Std.insert + (M := fun V => Std.ExtTreeMap Loc V compare) + h (l + (i : Int)) v) σ.heap } + +abbrev State.get? (σ : State) (l : Loc) : Option (Option Val) := + PartialMap.get? (M := fun V => Std.ExtTreeMap Loc V compare) σ.heap l + +inductive BaseStep : Exp → State → List Observation → Exp → State → List Exp → Prop where + | recS (f x : Binder) (e : Exp) (σ : State) : + BaseStep (.rec_ f x e) σ [] (.ofVal (.rec_ f x e)) σ [] + | pairS (v1 v2 : Val) (σ : State) : + BaseStep (.pair (.ofVal v1) (.ofVal v2)) σ [] (.ofVal (.pair v1 v2)) σ [] + | injLS (v : Val) (σ : State) : + BaseStep (.injL (.ofVal v)) σ [] (.ofVal (.injL v)) σ [] + | injRS (v : Val) (σ : State) : + BaseStep (.injR (.ofVal v)) σ [] (.ofVal (.injR v)) σ [] + | betaS (f x : Binder) (e1 : Exp) (v2 : Val) (e' : Exp) (σ : State) : + e' = (e1.subst f (.rec_ f x e1)).subst x v2 → + BaseStep (.app (.ofVal (.rec_ f x e1)) (.ofVal v2)) σ [] e' σ [] + | unOpS (op : UnOp) (v v' : Val) (σ : State) : + op.eval v = some v' → + BaseStep (.unop op (.ofVal v)) σ [] (.ofVal v') σ [] + | binOpS (op : BinOp) (v1 v2 v' : Val) (σ : State) : + op.eval v1 v2 = some v' → + BaseStep (.binop op (.ofVal v1) (.ofVal v2)) σ [] (.ofVal v') σ [] + | ifTrueS (e1 e2 : Exp) (σ : State) : + BaseStep (.if (.ofVal (.lit (.bool true))) e1 e2) σ [] e1 σ [] + | ifFalseS (e1 e2 : Exp) (σ : State) : + BaseStep (.if (.ofVal (.lit (.bool false))) e1 e2) σ [] e2 σ [] + | fstS (v1 v2 : Val) (σ : State) : + BaseStep (.fst (.ofVal (Val.pair v1 v2))) σ [] (.ofVal v1) σ [] + | sndS (v1 v2 : Val) (σ : State) : + BaseStep (.snd (.ofVal (Val.pair v1 v2))) σ [] (.ofVal v2) σ [] + | caseLS (v : Val) (e1 e2 : Exp) (σ : State) : + BaseStep (.case (.ofVal (.injL v)) e1 e2) σ [] (.app e1 (.ofVal v)) σ [] + | caseRS (v : Val) (e1 e2 : Exp) (σ : State) : + BaseStep (.case (.ofVal (.injR v)) e1 e2) σ [] (.app e2 (.ofVal v)) σ [] + | allocNS (n : Int) (v : Val) (σ : State) (l : Loc) : + 0 < n → + (∀ i : Int, 0 ≤ i → i < n → σ.get? (l + i) = none) → + BaseStep (.allocN (.ofVal (.lit (.int n))) (.ofVal v)) σ + [] (.ofVal (.lit (.loc l))) (σ.initHeap l n v) [] + | freeS (l : Loc) (v : Val) (σ : State) : + σ.get? l = some v → + BaseStep (.free (.ofVal (.lit (.loc l)))) σ + [] (.ofVal (.lit .unit)) (σ.initHeap l 1 none) [] + | loadS (l : Loc) (v : Val) (σ : State) : + σ.get? l = some v → + BaseStep (.load (.ofVal (.lit (.loc l)))) σ [] (.ofVal v) σ [] + | storeS (l : Loc) (v w : Val) (σ : State) : + σ.get? l = some v → + BaseStep (.store (.ofVal (.lit (.loc l))) (.ofVal w)) σ + [] (.ofVal (.lit .unit)) (σ.initHeap l 1 w) [] + | xchgS (l : Loc) (v1 v2 : Val) (σ : State) : + σ.get? l = some v1 → + BaseStep (.xchg (.ofVal (.lit (.loc l))) (.ofVal v2)) σ + [] (.ofVal v1) (σ.initHeap l 1 v2) [] + | cmpXchgS (l : Loc) (v1 v2 vl : Val) (σ : State) (b : Bool) : + σ.get? l = some vl → + vl.compareSafe v1 → + decide (vl = v1) = b → + BaseStep (.cmpXchg (.ofVal (.lit (.loc l))) (.ofVal v1) (.ofVal v2)) σ + [] + (.ofVal (.pair vl (.lit (.bool b)))) + (if b then (σ.initHeap l 1 v2) else σ) [] + | faaS (l : Loc) (i1 i2 : Int) (σ : State) : + σ.get? l = some (some (.lit (.int i1))) → + BaseStep (.faa (.ofVal (.lit (.loc l))) (.ofVal (.lit (.int i2)))) σ + [] (.ofVal (.lit (.int i1))) + (σ.initHeap l 1 (some (.lit (.int (i1 + i2))))) [] + | forkS (e : Exp) (σ : State) : + BaseStep (.fork e) σ [] (.ofVal (.lit .unit)) σ [e] + | newProphS (σ : State) (p : ProphId) : + ¬ σ.usedProphId.contains p → + BaseStep .newProph σ + [] (.ofVal (.lit (.prophecy p))) + { σ with usedProphId := σ.usedProphId.insert p } [] + | resolveS (p : ProphId) (v : Val) (e : Exp) (σ : State) (w : Val) (σ' : State) + (κs : List Observation) (ts : List Exp) : + BaseStep e σ κs (.ofVal v) σ' ts → + σ.usedProphId.contains p → + BaseStep (.resolve e (.ofVal (.lit (.prophecy p))) (.ofVal w)) σ + (κs ++ [(p, (v, w))]) (.ofVal v) σ' ts + +end Iris.HeapLang diff --git a/IrisDoNightly/IrisDoNightly/Syntax.lean b/IrisDoNightly/IrisDoNightly/Syntax.lean new file mode 100644 index 000000000..169427fd7 --- /dev/null +++ b/IrisDoNightly/IrisDoNightly/Syntax.lean @@ -0,0 +1,247 @@ +/- +Copyright (c) 2026 Michael Sammler. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Michael Sammler +-/ +module + +public import IrisDoNightly.Prelude + +@[expose] public section +namespace Iris.HeapLang + +@[ext] +structure Loc where + mk :: + n : Int +deriving Inhabited, Repr, DecidableEq + +instance : InfiniteType Loc where + enum n := .mk n + enum_inj n m := by grind + +instance : Ord Loc where + compare l₁ l₂ := compare l₁.n l₂.n + +instance : Std.TransOrd Loc where + eq_swap := by + intros l₁ l₂; unfold compare; unfold instOrdLoc; simp; + apply Int.instTransOrd.eq_swap + isLE_trans := by + intros l₁ l₂ l₃; unfold compare; unfold instOrdLoc; simp; + apply Int.instTransOrd.isLE_trans + +instance : Std.LawfulEqOrd Loc where + eq_of_compare := by + intros l₁ l₂; unfold compare; unfold instOrdLoc; simp; + intros h; ext; assumption + +instance : HAdd Loc Int Loc where + hAdd l i := ⟨l.n + i⟩ + +instance : Zero Loc where + zero := ⟨0⟩ + +@[simp] +theorem loc_add_n (l : Loc) n : + (l + n).n = l.n + n := by simp [HAdd.hAdd] + +@[ext] +structure ProphId where + mk :: + n : Nat +deriving Inhabited, Repr, DecidableEq + +instance : Ord ProphId where + compare l₁ l₂ := compare l₁.n l₂.n + +instance : Std.TransOrd ProphId where + eq_swap := by + intros l₁ l₂; unfold compare; unfold instOrdProphId; simp; + apply Nat.instTransOrd.eq_swap + isLE_trans := by + intros l₁ l₂ l₃; unfold compare; unfold instOrdProphId; simp; + apply Nat.instTransOrd.isLE_trans + +instance : Std.LawfulEqOrd ProphId where + eq_of_compare := by + intros l₁ l₂; unfold compare; unfold instOrdProphId; simp; + intros h; ext; assumption + +instance : InfiniteType ProphId where + enum n := .mk n + enum_inj n m := by grind + +inductive Binder where + | anon + | named (name : String) +deriving Inhabited, Repr, DecidableEq + +inductive BaseLit where + | int (n : Int) + | bool (b : Bool) + | unit + | poison + | loc (l : Loc) + | prophecy (p : ProphId) +deriving Inhabited, Repr, DecidableEq + +inductive UnOp where + | neg + | minus +deriving Inhabited, Repr, DecidableEq + +inductive BinOp where + /- We use "tdiv" and "tmod" instead of "div" and "mod" to + better match the behavior of 'real' languages: + e.g., in Rust, -30 / -4 == 7. ("div" would return 8.) -/ + | plus | minus | mult | tdiv | tmod /- arithmetic -/ + | and | or | xor /- bitwise -/ + | shiftl | shiftr /- shifts -/ + | le | lt | eq /- relations -/ + | offset /- pointer offset -/ +deriving Inhabited, Repr, DecidableEq + +mutual + inductive Exp : Type where + /- values -/ + -- This constructor should not be used directly. Use Exp.ofVal instead. + | val (v : Val) + /- Base lambda calculus -/ + | var (x : String) + | rec_ (f x : Binder) (e : Exp) + | app (e₁ e₂ : Exp) + /- Base types and their operations -/ + | unop (op : UnOp) (e : Exp) + | binop (op : BinOp) (e₁ e₂ : Exp) + | if (e₀ e₁ e₂ : Exp) + /- Products -/ + | pair (e₁ e₂ : Exp) + | fst (e : Exp) + | snd (e : Exp) + /- Sums -/ + | injL (e : Exp) + | injR (e : Exp) + | case (e₀ e₁ e₂ : Exp) + /- Heap -/ + | allocN (e₁ e₂ : Exp) /- array length, initial value -/ + | free (e : Exp) + | load (e : Exp) + | store (e₁ e₂ : Exp) + | cmpXchg (e₀ e₁ e₂ : Exp) /- compare exchange -/ + | xchg (e₁ e₂ : Exp) /- exchange -/ + | faa (e₁ e₂ : Exp) /- fetch and add -/ + /- Concurrency -/ + | fork (e : Exp) + /- Prophecy -/ + | newProph + | resolve (e₀ e₁ e₂ : Exp) + deriving Inhabited, Repr, DecidableEq + inductive Val : Type where + | lit (l : BaseLit) + | rec_ (f x : Binder) (e : Exp) + | pair (v₁ v₂ : Val) + | injL (v : Val) + | injR (v : Val) + deriving Inhabited, Repr, DecidableEq +end + +def Exp.isVal : Exp → Bool + | .val _ => true + | _ => false + +instance instToVal : ProgramLogic.ToVal Exp Val where + toVal + | .val v => some v + | _ => none + ofVal := .val + coe_of_toVal_eq_some {e v} h := by + cases e <;> simp_all + toVal_coe _ := rfl + +namespace Exp +export ProgramLogic.ToVal (ofVal) +end Exp + +@[simp] +theorem val_to_ofVal : Exp.val = Exp.ofVal := rfl + +instance : Coe Nat BaseLit where + coe n := .int n + +instance : Coe Int BaseLit where + coe n := .int n + +instance : Coe Bool BaseLit where + coe b := .bool b + +instance : Coe Loc BaseLit where + coe l := .loc l + +instance : Coe ProphId BaseLit where + coe p := .prophecy p + +instance : Coe Unit BaseLit where + coe _ := .unit + +attribute [coe] BaseLit.int BaseLit.bool BaseLit.loc BaseLit.prophecy + +def Exp.substStr (x : String) (v : Val) (e : Exp) : Exp := + match e with + | .val _ => e + | .var x' => if x == x' then .val v else e + | .rec_ f x' e => .rec_ f x' $ if .named x != f && .named x != x' then e.substStr x v else e + | .app e₁ e₂ => .app (e₁.substStr x v) (e₂.substStr x v) + | .unop op e' => .unop op (e'.substStr x v) + | .binop op e₁ e₂ => .binop op (e₁.substStr x v) (e₂.substStr x v) + | .if e₀ e₁ e₂ => .if (e₀.substStr x v) (e₁.substStr x v) (e₂.substStr x v) + | .pair e₁ e₂ => .pair (e₁.substStr x v) (e₂.substStr x v) + | .fst e' => .fst (e'.substStr x v) + | .snd e' => .snd (e'.substStr x v) + | .injL e' => .injL (e'.substStr x v) + | .injR e' => .injR (e'.substStr x v) + | .case e₀ e₁ e₂ => .case (e₀.substStr x v) (e₁.substStr x v) (e₂.substStr x v) + | .allocN e₁ e₂ => .allocN (e₁.substStr x v) (e₂.substStr x v) + | .free e' => .free (e'.substStr x v) + | .load e' => .load (e'.substStr x v) + | .store e₁ e₂ => .store (e₁.substStr x v) (e₂.substStr x v) + | .cmpXchg e₀ e₁ e₂ => .cmpXchg (e₀.substStr x v) (e₁.substStr x v) (e₂.substStr x v) + | .xchg e₁ e₂ => .xchg (e₁.substStr x v) (e₂.substStr x v) + | .faa e₁ e₂ => .faa (e₁.substStr x v) (e₂.substStr x v) + | .fork e' => .fork (e'.substStr x v) + | .newProph => .newProph + | .resolve e₀ e₁ e₂ => .resolve (e₀.substStr x v) (e₁.substStr x v) (e₂.substStr x v) + +def Exp.subst (x : Binder) (v : Val) (e : Exp) : Exp := + if let .named x := x then Exp.substStr x v e else e + +def BaseLit.isUnboxed : BaseLit → Bool + | .prophecy _ | .poison => false + | _ => true + +def Val.isUnboxed : Val → Bool + | .lit l => l.isUnboxed + | .injL (.lit l) => l.isUnboxed + | .injR (.lit l) => l.isUnboxed + | _ => false + +def Val.compareSafe (v1 v2 : Val) : Bool := + v1.isUnboxed || v2.isUnboxed + +section Derived +def Exp.stuck : Exp := Exp.app (.ofVal $ .lit $ .int 0) (.ofVal $ .lit $ .int 0) + +@[simp] +theorem Exp.stuck_subst {x v} : Exp.substStr x v Exp.stuck = Exp.stuck := by + simp [Exp.stuck, Exp.substStr] + simp only [substStr, ofVal] + +def Exp.assert (e : Exp) := Exp.if e (.ofVal $ .lit .unit) Exp.stuck + +@[simp] +theorem Exp.assert_subst {x v} e : + Exp.substStr x v (Exp.assert e) = Exp.assert (Exp.substStr x v e) := by + simp [Exp.assert, Exp.substStr] + simp only [substStr, ofVal] + +end Derived diff --git a/IrisDoNightly/README.md b/IrisDoNightly/README.md new file mode 100644 index 000000000..8027cc63d --- /dev/null +++ b/IrisDoNightly/README.md @@ -0,0 +1 @@ +# IrisDoNightly \ No newline at end of file diff --git a/IrisDoNightly/lake-manifest.json b/IrisDoNightly/lake-manifest.json new file mode 100644 index 000000000..7b20bee1c --- /dev/null +++ b/IrisDoNightly/lake-manifest.json @@ -0,0 +1,6 @@ +{"version": "1.2.0", + "packagesDir": ".lake/packages", + "packages": [], + "name": "IrisDoNightly", + "lakeDir": ".lake", + "fixedToolchain": false} diff --git a/IrisDoNightly/lakefile.toml b/IrisDoNightly/lakefile.toml new file mode 100644 index 000000000..ad6096e75 --- /dev/null +++ b/IrisDoNightly/lakefile.toml @@ -0,0 +1,6 @@ +name = "IrisDoNightly" +version = "0.1.0" +defaultTargets = ["IrisDoNightly"] + +[[lean_lib]] +name = "IrisDoNightly" diff --git a/IrisDoNightly/lean-toolchain b/IrisDoNightly/lean-toolchain new file mode 100644 index 000000000..728ce7a44 --- /dev/null +++ b/IrisDoNightly/lean-toolchain @@ -0,0 +1 @@ +leanprover/lean4:nightly-2026-07-22 From 8a7547ac56b3dc68b632f3282720e19c7ab0b5c5 Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Fri, 24 Jul 2026 11:23:34 +0100 Subject: [PATCH 32/33] blah --- IrisDoNightly/IrisDoNightly/HeapAxioms.lean | 159 ++++++++++++++++++++ IrisDoNightly/IrisDoNightly/SLFrame.lean | 124 +++++++++++++++ IrisDoNightly/IrisDoNightly/SepAlgebra.lean | 97 ++++++++++++ IrisDoNightly/IrisDoNightly/SepLogic.lean | 101 +++++++++++++ 4 files changed, 481 insertions(+) create mode 100644 IrisDoNightly/IrisDoNightly/HeapAxioms.lean create mode 100644 IrisDoNightly/IrisDoNightly/SLFrame.lean create mode 100644 IrisDoNightly/IrisDoNightly/SepAlgebra.lean create mode 100644 IrisDoNightly/IrisDoNightly/SepLogic.lean diff --git a/IrisDoNightly/IrisDoNightly/HeapAxioms.lean b/IrisDoNightly/IrisDoNightly/HeapAxioms.lean new file mode 100644 index 000000000..3a47edd62 --- /dev/null +++ b/IrisDoNightly/IrisDoNightly/HeapAxioms.lean @@ -0,0 +1,159 @@ +module + +public import IrisDoNightly.SepLogic +public import Std.Internal +public import Std.Tactic.Do + +set_option mvcgen.warning false + +open Lean.Order +open Iris.HeapLang + +@[expose] public section + +namespace Iris.HeapLang.SL + +def hpure (φ : Prop) : HProp := fun _ => φ +def hand (P Q : HProp) : HProp := fun σ => P σ ∧ Q σ +def hexists {α : Sort _} (P : α → HProp) : HProp := fun σ => ∃ a, P a σ +def hor (P Q : HProp) : HProp := fun σ => P σ ∨ Q σ + +/-! ## The axiomatic interface -/ + +/-- A predicate `wp` imbues a fragment of HeapLang with the correct separation-logic axiomatic +semantics. The pure structural fields are `AxSem.HeapLangAxioms` with `→` replaced by `⊑`; the heap +fields are the small-footprint rules over `↦`. -/ +class HeapLangAxioms (wp : Exp → (Val → HProp) → HProp) where + wp_mono : Φ ⊑ Ψ → wp e Φ ⊑ wp e Ψ + wp_val : Φ v ⊑ wp (Exp.ofVal v) Φ + wp_closure : Φ (.rec_ f x e) ⊑ wp (Exp.rec_ f x e) Φ + wp_app : + wp e₂ (fun v₂ => wp e₁ (fun vf => hexists fun (f : Binder) => hexists fun (x : Binder) => + hexists fun (body : Exp) => hand (hpure (vf = Val.rec_ f x body)) + (wp ((body.subst f (.rec_ f x body)).subst x v₂) Φ))) + ⊑ wp (Exp.app e₁ e₂) Φ + wp_unop : + wp e (fun v => hexists fun v' => hand (hpure (op.eval v = some v')) (Φ v')) + ⊑ wp (Exp.unop op e) Φ + wp_binop : + wp e₂ (fun v₂ => wp e₁ (fun v₁ => hexists fun v' => hand (hpure (op.eval v₁ v₂ = some v')) (Φ v'))) + ⊑ wp (Exp.binop op e₁ e₂) Φ + wp_cond : + wp e₀ (fun vc => hexists fun b => hand (hpure (vc = Val.lit (.bool b))) (wp (if b then e₁ else e₂) Φ)) + ⊑ wp (Exp.if e₀ e₁ e₂) Φ + wp_pair : + wp e₂ (fun v₂ => wp e₁ (fun v₁ => Φ (Val.pair v₁ v₂))) + ⊑ wp (Exp.pair e₁ e₂) Φ + wp_fst : + wp e (fun v => hexists fun v₁ => hexists fun v₂ => hand (hpure (v = Val.pair v₁ v₂)) (Φ v₁)) + ⊑ wp (Exp.fst e) Φ + wp_snd : + wp e (fun v => hexists fun v₁ => hexists fun v₂ => hand (hpure (v = Val.pair v₁ v₂)) (Φ v₂)) + ⊑ wp (Exp.snd e) Φ + wp_injL : wp e (fun v => Φ (Val.injL v)) ⊑ wp (Exp.injL e) Φ + wp_injR : wp e (fun v => Φ (Val.injR v)) ⊑ wp (Exp.injR e) Φ + wp_case : + wp e₀ (fun vc => + hor (hexists fun v => hand (hpure (vc = Val.injL v)) (wp (Exp.app e₁ (Exp.ofVal v)) Φ)) + (hexists fun v => hand (hpure (vc = Val.injR v)) (wp (Exp.app e₂ (Exp.ofVal v)) Φ))) + ⊑ wp (Exp.case e₀ e₁ e₂) Φ + wp_load (l : Loc) (w : Val) : + pointsTo l w ⊑ wp (Exp.load (Exp.ofVal (Val.lit (.loc l)))) + (fun v => hand (hpure (v = w)) (pointsTo l w)) + wp_store (l : Loc) (v w : Val) : + pointsTo l v ⊑ wp (Exp.store (Exp.ofVal (Val.lit (.loc l))) (Exp.ofVal w)) + (fun _ => pointsTo l w) + wp_alloc (w : Val) : + emp ⊑ wp (Exp.allocN (Exp.ofVal (Val.lit (.int 1))) (Exp.ofVal w)) + (fun v => hexists fun l => hand (hpure (v = Val.lit (.loc l))) (pointsTo l w)) + wp_free (l : Loc) (w : Val) : + pointsTo l w ⊑ wp (Exp.free (Exp.ofVal (Val.lit (.loc l)))) (fun _ => emp) + +open Std.Internal.Do HeapLangAxioms + +/-! ## The `Std.Do` `WP` instance -/ + +set_option synthInstance.checkSynthOrder false in +instance instWP_SL {wp} [HeapLangAxioms wp] : WP Exp Val HProp EPost.Nil where + wpTrans e := ⟨fun Φ _ => wp e Φ⟩ + wp_trans_monotone _ _ _ _ _ _ hp := wp_mono hp + +/-- Local notation for a `Std.Do` weakest precondition. -/ +scoped syntax:max "wp⟦" term:min "⟧" ppSpace term:max : term +scoped macro_rules + | `(wp⟦ $e ⟧ $Φ) => `(Std.Internal.Do.wp $e $Φ Std.Internal.Do.EPost.Nil.mk) + +@[grind .] theorem sl_frames {wp} [HeapLangAxioms wp] (e : Exp) (F : HProp) : + WP.Frames sepConj e F where + conj_wp_le_wp_conj := by sorry + +/-! ## The `@[spec]` laws -/ + +section laws +variable {wp} [HeapLangAxioms wp] + +@[spec] theorem spec_val {v : Val} {Φ : Val → HProp} : + Φ v ⊑ wp⟦(Exp.ofVal v : Exp)⟧ Φ := wp_val + +@[spec] theorem spec_rec {f x : Binder} {e : Exp} {Φ : Val → HProp} : + Φ (.rec_ f x e) ⊑ wp⟦Exp.rec_ f x e⟧ Φ := wp_closure + +@[spec] theorem spec_app {e₁ e₂ : Exp} {Φ : Val → HProp} : + wp⟦e₂⟧ (fun v₂ => wp⟦e₁⟧ (fun vf => hexists fun (f : Binder) => hexists fun (x : Binder) => + hexists fun (body : Exp) => hand (hpure (vf = Val.rec_ f x body)) + (wp⟦(body.subst f (.rec_ f x body)).subst x v₂⟧ Φ))) + ⊑ wp⟦Exp.app e₁ e₂⟧ Φ := wp_app + +@[spec] theorem spec_unop {op : UnOp} {e : Exp} {Φ : Val → HProp} : + wp⟦e⟧ (fun v => hexists fun v' => hand (hpure (op.eval v = some v')) (Φ v')) + ⊑ wp⟦Exp.unop op e⟧ Φ := wp_unop + +@[spec] theorem spec_binop {op : BinOp} {e₁ e₂ : Exp} {Φ : Val → HProp} : + wp⟦e₂⟧ (fun v₂ => wp⟦e₁⟧ (fun v₁ => hexists fun v' => hand (hpure (op.eval v₁ v₂ = some v')) (Φ v'))) + ⊑ wp⟦Exp.binop op e₁ e₂⟧ Φ := wp_binop + +@[spec] theorem spec_if {e₀ e₁ e₂ : Exp} {Φ : Val → HProp} : + wp⟦e₀⟧ (fun vc => hexists fun b => hand (hpure (vc = Val.lit (.bool b))) (wp⟦if b then e₁ else e₂⟧ Φ)) + ⊑ wp⟦Exp.if e₀ e₁ e₂⟧ Φ := wp_cond + +@[spec] theorem spec_pair {e₁ e₂ : Exp} {Φ : Val → HProp} : + wp⟦e₂⟧ (fun v₂ => wp⟦e₁⟧ (fun v₁ => Φ (Val.pair v₁ v₂))) + ⊑ wp⟦Exp.pair e₁ e₂⟧ Φ := wp_pair + +@[spec] theorem spec_fst {e : Exp} {Φ : Val → HProp} : + wp⟦e⟧ (fun v => hexists fun v₁ => hexists fun v₂ => hand (hpure (v = Val.pair v₁ v₂)) (Φ v₁)) + ⊑ wp⟦Exp.fst e⟧ Φ := wp_fst + +@[spec] theorem spec_snd {e : Exp} {Φ : Val → HProp} : + wp⟦e⟧ (fun v => hexists fun v₁ => hexists fun v₂ => hand (hpure (v = Val.pair v₁ v₂)) (Φ v₂)) + ⊑ wp⟦Exp.snd e⟧ Φ := wp_snd + +@[spec] theorem spec_injL {e : Exp} {Φ : Val → HProp} : + wp⟦e⟧ (fun v => Φ (Val.injL v)) ⊑ wp⟦Exp.injL e⟧ Φ := wp_injL + +@[spec] theorem spec_injR {e : Exp} {Φ : Val → HProp} : + wp⟦e⟧ (fun v => Φ (Val.injR v)) ⊑ wp⟦Exp.injR e⟧ Φ := wp_injR + +@[spec] theorem spec_case {e₀ e₁ e₂ : Exp} {Φ : Val → HProp} : + wp⟦e₀⟧ (fun vc => + hor (hexists fun v => hand (hpure (vc = Val.injL v)) (wp⟦Exp.app e₁ (Exp.ofVal v)⟧ Φ)) + (hexists fun v => hand (hpure (vc = Val.injR v)) (wp⟦Exp.app e₂ (Exp.ofVal v)⟧ Φ))) + ⊑ wp⟦Exp.case e₀ e₁ e₂⟧ Φ := wp_case + +@[spec] theorem spec_load (l : Loc) (w : Val) : + pointsTo l w ⊑ wp⟦Exp.load (Exp.ofVal (Val.lit (.loc l)))⟧ + (fun v => hand (hpure (v = w)) (pointsTo l w)) := wp_load l w + +@[spec] theorem spec_store (l : Loc) (v w : Val) : + pointsTo l v ⊑ wp⟦Exp.store (Exp.ofVal (Val.lit (.loc l))) (Exp.ofVal w)⟧ + (fun _ => pointsTo l w) := wp_store l v w + +@[spec] theorem spec_alloc (w : Val) : + emp ⊑ wp⟦Exp.allocN (Exp.ofVal (Val.lit (.int 1))) (Exp.ofVal w)⟧ + (fun v => hexists fun l => hand (hpure (v = Val.lit (.loc l))) (pointsTo l w)) := wp_alloc w + +@[spec] theorem spec_free (l : Loc) (w : Val) : + pointsTo l w ⊑ wp⟦Exp.free (Exp.ofVal (Val.lit (.loc l)))⟧ (fun _ => emp) := wp_free l w + +end laws +end Iris.HeapLang.SL diff --git a/IrisDoNightly/IrisDoNightly/SLFrame.lean b/IrisDoNightly/IrisDoNightly/SLFrame.lean new file mode 100644 index 000000000..70006ca8a --- /dev/null +++ b/IrisDoNightly/IrisDoNightly/SLFrame.lean @@ -0,0 +1,124 @@ +module + +public import IrisDoNightly.HeapAxioms +import Lean +import Std.Internal +import Std.Tactic.Do +public meta import Lean.Elab.Tactic.Do.Internal.VCGen.FrameProc +public meta import Lean.Meta.Sym.Pattern + +/-! +# Phase 4 — Frame-inference metaprogramming for `∗` (+ Phase 5 front-end demos) + +Per `SEPLOGIC_PORT.md` §7 Phases 4–5. This is `Phase0Spike.lean`'s frameproc machinery retargeted +onto the real `Iris.HeapLang.HProp`/`sepConj` (Phase 2) and the `HeapLangAxioms` spec laws (Phase 3): +the separation-logic structural lemmas `sepConj_mono_r`/`sepConj_frame_r`, the `∗`-atom flattener +`sepAtoms`, the domain-difference frame inference `sepConjFrameProc`, and the `@[frameproc] heapFP` +keyed on `prog := ``Iris.HeapLang.Exp`. Phase 0 already proved this path fires on the non-monadic +`Exp` WP, so the only change from the spike is the target constants. + +The demos at the bottom (Phase 5) drive `vcgen` over the real SL: auto-framed and explicitly-framed +`store`, and a mixed `alloc`/`store`/`load` program. +-/ + +set_option mvcgen.warning false +set_option grind.warning false + +open Lean Meta Sym Std Std.Internal.Do Lean.Order +open Iris.HeapLang Iris.HeapLang.SL + +@[expose] public section + +namespace Iris.HeapLang.SL + +/-! ## Separation-logic structural lemmas for the frame split -/ + +theorem sepConj_mono_r {a b b' : HProp} (h : b ⊑ b') : (sepConj a b) ⊑ (sepConj a b') := by + rintro σ ⟨σ₁, σ₂, hd, rfl, ha, hb⟩; exact ⟨σ₁, σ₂, hd, rfl, ha, h _ hb⟩ + +theorem sepConj_frame_r {pre₀ F R : HProp} (h : pre₀ ⊑ R) : (sepConj pre₀ F) ⊑ (sepConj F R) := + PartialOrder.rel_trans (PartialOrder.rel_of_eq (sepConj_comm pre₀ F)) (sepConj_mono_r h) + +@[grind ←] theorem sepConj_comm_le (a b : HProp) : (sepConj a b) ⊑ (sepConj b a) := + PartialOrder.rel_of_eq (sepConj_comm a b) + +/-! ## The registered frame procedure for `∗` -/ + +open Lean.Elab.Tactic.Do.Internal Lean.Elab.Tactic.Do.Internal.VCGen + +public meta partial def sepAtoms (e : Expr) : Array Expr := + if e.isAppOf ``sepConj then sepAtoms e.appFn!.appArg! ++ sepAtoms e.appArg! + else #[e] + +public meta def sepConjFrameProc : FrameInferenceProc := fun _R pre _info specPre => do + let mut rest := sepAtoms pre + for atom in sepAtoms specPre do + let some i ← rest.findIdxM? (isDefEqS atom ·) | return none + rest := rest.eraseIdxIfInBounds i + if rest.isEmpty then return none + return some (rest.pop.foldr (fun a acc => mkApp2 (mkConst ``sepConj) a acc) rest.back!) + +@[frameproc] public meta def heapFP : FrameProc where + prog := ``Iris.HeapLang.Exp + mkOpAppM := fun _ => pure (mkConst ``sepConj) + resourceTy := fun _ => pure (mkConst ``HProp) + op := { head := ``sepConj, numConst := 0, terminal? := ``sepConj_frame_r } + proc := some sepConjFrameProc + +theorem le_hexists {α : Sort _} {P : HProp} (Q : α → HProp) (a : α) (h : P ⊑ Q a) : + P ⊑ hexists Q := fun σ hσ => ⟨a, h σ hσ⟩ + +theorem le_hand_pure {P R : HProp} {φ : Prop} (hφ : φ) (h : P ⊑ R) : + P ⊑ hand (hpure φ) R := fun σ hσ => ⟨hφ, h σ hσ⟩ + +section demos +variable {wp} [HeapLangAxioms wp] + +example (l1 l2 : Loc) (a b x : Val) : + (l1 ↦ a ∗ l2 ↦ b) + ⊑ wp⟦Exp.store (Exp.ofVal (Val.lit (.loc l1))) (Exp.ofVal x)⟧ + (fun _ => l1 ↦ x ∗ l2 ↦ b) := by + vcgen [spec_store] with finish + +/-- The same goal with the frame supplied explicitly via the `frames` clause. -/ +example (l1 l2 : Loc) (a b x : Val) : + (l1 ↦ a ∗ l2 ↦ b) + ⊑ wp⟦Exp.store (Exp.ofVal (Val.lit (.loc l1))) (Exp.ofVal x)⟧ + (fun _ => l1 ↦ x ∗ l2 ↦ b) := by + vcgen [spec_store] + frames | Exp.store _ _ => (pointsTo l2 b) + with finish + +/-- `alloc` yields a fresh cell holding `v`. -/ +example (v : Val) : + emp ⊑ wp⟦Exp.allocN (Exp.ofVal (Val.lit (.int 1))) (Exp.ofVal v)⟧ + (fun r => hexists fun l => hand (hpure (r = Val.lit (.loc l))) (pointsTo l v)) := by + vcgen [spec_alloc] with finish + +/-- `load` returns the stored value and keeps the cell. -/ +example (l : Loc) (w : Val) : + (l ↦ w) ⊑ wp⟦Exp.load (Exp.ofVal (Val.lit (.loc l)))⟧ + (fun v => hand (hpure (v = w)) (l ↦ w)) := by + vcgen [spec_load] with finish + +/-- A mixed program that `vcgen` drives end to end: `(λ_. ()) (l := b)` — store `b` into `l`, then +return unit — carrying the disjoint cell `k ↦ c` untouched across the (framed) store, then a pure +step. The heap spec is sequenced with a pure value through the application rule; `vcgen` applies the +frame for the store and reduces the pure tail, leaving only a `∗`-commutativity residual that +`finish` closes. -/ +example (l k : Loc) (a b c : Val) : + ((l ↦ a) ∗ (k ↦ c)) + ⊑ wp⟦Exp.app (Exp.rec_ .anon .anon (Exp.ofVal (Val.lit .unit))) + (Exp.store (Exp.ofVal (Val.lit (.loc l))) (Exp.ofVal b))⟧ + (fun _ => (l ↦ b) ∗ (k ↦ c)) := by + vcgen [spec_store] + case vc1 => + refine le_hexists _ .anon (le_hexists _ .anon + (le_hexists _ (Exp.ofVal (Val.lit .unit)) (le_hand_pure rfl ?_))) + simp only [Exp.subst] + vcgen with finish + all_goals grind + +end demos + +end Iris.HeapLang.SL diff --git a/IrisDoNightly/IrisDoNightly/SepAlgebra.lean b/IrisDoNightly/IrisDoNightly/SepAlgebra.lean new file mode 100644 index 000000000..ed2846020 --- /dev/null +++ b/IrisDoNightly/IrisDoNightly/SepAlgebra.lean @@ -0,0 +1,97 @@ +module + +public import IrisDoNightly.Semantics +public import Std.Data.ExtTreeMap +public import Std.Data.ExtTreeSet + +@[expose] public section +namespace Iris.HeapLang + +open _root_.Std Iris.Std + +/-! ## The separation algebra operations -/ + +def State.disjoint (σ₁ σ₂ : State) : Prop := + ∀ l, σ₁.get? l = none ∨ σ₂.get? l = none + +def State.union (σ₁ σ₂ : State) : State where + heap := σ₁.heap ∪ σ₂.heap + usedProphId := σ₁.usedProphId ∪ σ₂.usedProphId + +def State.emp : State := ⟨∅, ∅⟩ + +def State.single (l : Loc) (v : Option Val) : State := + ⟨(∅ : ExtTreeMap Loc (Option Val) compare).insert l v, ∅⟩ + +scoped infixl:70 " #ₕ " => State.disjoint +scoped infixl:65 " ⊎ₕ " => State.union + +theorem State.ext' {σ₁ σ₂ : State} + (hh : σ₁.heap = σ₂.heap) (hu : σ₁.usedProphId = σ₂.usedProphId) : σ₁ = σ₂ := by + cases σ₁; cases σ₂; subst hh; subst hu; rfl + +theorem State.get?_eq (σ : State) (l : Loc) : σ.get? l = σ.heap[l]? := rfl + +@[simp] theorem State.get?_union (σ₁ σ₂ : State) (l : Loc) : + (σ₁ ⊎ₕ σ₂).get? l = (σ₂.get? l).or (σ₁.get? l) := by + simp only [State.get?_eq, State.union] + exact ExtTreeMap.getElem?_union + +@[simp] theorem State.get?_emp (l : Loc) : State.emp.get? l = none := by + simp only [State.get?_eq, State.emp] + exact ExtTreeMap.getElem?_empty + +theorem State.get?_single (l l' : Loc) (v : Option Val) : + (State.single l v).get? l' = if l' = l then some v else none := by + simp only [State.get?_eq, State.single] + rw [ExtTreeMap.getElem?_insert, ExtTreeMap.getElem?_empty] + by_cases h : l = l' + · subst h; simp [compare_self] + · rw [if_neg (by simpa [compare_eq_iff_eq] using h), if_neg (fun hc => h hc.symm)] + +theorem State.union_none_iff (σ₁ σ₂ : State) (l : Loc) : + (σ₁ ⊎ₕ σ₂).get? l = none ↔ σ₁.get? l = none ∧ σ₂.get? l = none := by + simp only [State.get?_union, Option.or_eq_none_iff] + exact And.comm + +theorem State.disjoint_comm {σ₁ σ₂ : State} (h : σ₁ #ₕ σ₂) : σ₂ #ₕ σ₁ := + fun l => (h l).symm + +theorem State.union_comm {σ₁ σ₂ : State} (h : σ₁ #ₕ σ₂) : σ₁ ⊎ₕ σ₂ = σ₂ ⊎ₕ σ₁ := by + apply State.ext' + · ext l + simp only [State.union, ExtTreeMap.getElem?_union] + rcases h l with hl | hl <;> simp only [State.get?_eq] at hl <;> simp [hl] + · show σ₁.usedProphId ∪ σ₂.usedProphId = σ₂.usedProphId ∪ σ₁.usedProphId + ext k; simp only [ExtTreeSet.mem_union_iff]; exact Or.comm + +theorem State.union_assoc (σ₁ σ₂ σ₃ : State) : + (σ₁ ⊎ₕ σ₂) ⊎ₕ σ₃ = σ₁ ⊎ₕ (σ₂ ⊎ₕ σ₃) := by + apply State.ext' + · ext l; simp only [State.union, ExtTreeMap.getElem?_union, Option.or_assoc] + · show (σ₁.usedProphId ∪ σ₂.usedProphId) ∪ σ₃.usedProphId + = σ₁.usedProphId ∪ (σ₂.usedProphId ∪ σ₃.usedProphId) + ext k; simp only [ExtTreeSet.mem_union_iff]; exact or_assoc + +theorem State.disjoint_union_left {σ₁ σ₂ σ₃ : State} : + (σ₁ ⊎ₕ σ₂) #ₕ σ₃ ↔ σ₁ #ₕ σ₃ ∧ σ₂ #ₕ σ₃ := by + simp only [State.disjoint, State.union_none_iff] + grind + +theorem State.disjoint_union_right {σ₁ σ₂ σ₃ : State} : + σ₁ #ₕ (σ₂ ⊎ₕ σ₃) ↔ σ₁ #ₕ σ₂ ∧ σ₁ #ₕ σ₃ := by + simp only [State.disjoint, State.union_none_iff] + grind + +theorem State.emp_disjoint (σ : State) : State.emp #ₕ σ := + fun l => Or.inl (State.get?_emp l) + +theorem State.emp_union (σ : State) : State.emp ⊎ₕ σ = σ := by + apply State.ext' + · ext l + simp only [State.union, State.emp, ExtTreeMap.getElem?_union, ExtTreeMap.getElem?_empty, + Option.or_none] + · show State.emp.usedProphId ∪ σ.usedProphId = σ.usedProphId + ext k; simp only [State.emp, ExtTreeSet.mem_union_iff, ExtTreeSet.not_mem_empty, false_or] + +end Iris.HeapLang diff --git a/IrisDoNightly/IrisDoNightly/SepLogic.lean b/IrisDoNightly/IrisDoNightly/SepLogic.lean new file mode 100644 index 000000000..c76b0a904 --- /dev/null +++ b/IrisDoNightly/IrisDoNightly/SepLogic.lean @@ -0,0 +1,101 @@ +module + +public import IrisDoNightly.SepAlgebra +public import Std.Internal +public import Std.Tactic.Do + +@[expose] public section + +open Lean.Order Std Std.Internal.Do Std.Internal.Do.CompleteLattice +open Iris.HeapLang + +namespace Iris.HeapLang + +/-! ## Heap assertions -/ + +def HProp : Type := State → Prop + +instance : CompleteLattice HProp := inferInstanceAs (CompleteLattice (State → Prop)) + +/-! ## The separation-logic connectives -/ + +def emp : HProp := fun σ => σ = State.emp +def pointsTo (l : Loc) (w : Val) : HProp := fun σ => σ = State.single l (some w) +def sepConj (P Q : HProp) : HProp := + fun σ => ∃ σ₁ σ₂, σ₁ #ₕ σ₂ ∧ σ = σ₁ ⊎ₕ σ₂ ∧ P σ₁ ∧ Q σ₂ +def wand (P Q : HProp) : HProp := + fun σ => ∀ σ', σ #ₕ σ' → P σ' → Q (σ ⊎ₕ σ') + +scoped notation:70 l:max " ↦ " v:max => pointsTo l v +scoped infixr:65 " ∗ " => sepConj +scoped infixr:60 " -∗ " => wand + +theorem emp_sepConj (a : HProp) : (sepConj emp a) = a := by + funext σ + apply propext + constructor + · rintro ⟨σ₁, σ₂, _, rfl, rfl, ha⟩ + rwa [State.emp_union] + · intro ha + exact ⟨State.emp, σ, State.emp_disjoint σ, (State.emp_union σ).symm, rfl, ha⟩ + +theorem sepConj_assoc (a b c : HProp) : + (sepConj (sepConj a b) c) = (sepConj a (sepConj b c)) := by + funext σ + apply propext + constructor + · rintro ⟨_, σ₃, hd, rfl, ⟨σ₁, σ₂, hd12, rfl, ha, hb⟩, hc⟩ + obtain ⟨hd13, hd23⟩ := State.disjoint_union_left.mp hd + exact ⟨σ₁, σ₂ ⊎ₕ σ₃, State.disjoint_union_right.mpr ⟨hd12, hd13⟩, + State.union_assoc σ₁ σ₂ σ₃, ha, σ₂, σ₃, hd23, rfl, hb, hc⟩ + · rintro ⟨σ₁, _, hd, rfl, ha, ⟨σ₂, σ₃, hd23, rfl, hb, hc⟩⟩ + obtain ⟨hd12, hd13⟩ := State.disjoint_union_right.mp hd + exact ⟨σ₁ ⊎ₕ σ₂, σ₃, State.disjoint_union_left.mpr ⟨hd13, hd23⟩, + (State.union_assoc σ₁ σ₂ σ₃).symm, ⟨σ₁, σ₂, hd12, rfl, ha, hb⟩, hc⟩ + +theorem sepConj_comm (a b : HProp) : (sepConj a b) = (sepConj b a) := by + funext σ; apply propext + constructor <;> + · rintro ⟨σ₁, σ₂, hd, rfl, hp, hq⟩ + exact ⟨σ₂, σ₁, State.disjoint_comm hd, State.union_comm hd, hq, hp⟩ + +/-! ## `∗` preserves sups and its upper adjoint is the wand -/ + +/-- Pointwise characterization of the sup on `HProp`. -/ +theorem hprop_sup_apply (s : HProp → Prop) (σ : State) : + CompleteLattice.sup s σ = ∃ f, s f ∧ f σ := by + apply propext + constructor + · exact fun hh => sup_le s (x := fun σ => ∃ f, s f ∧ f σ) + (fun f hf σ' hfσ' => ⟨f, hf, hfσ'⟩) σ hh + · rintro ⟨f, hf, hfσ⟩; exact le_sup (c := s) hf σ hfσ + +instance (F : HProp) : PreservesSup (sepConj F) where + map_sup s := by + funext σ + apply propext + simp only [sepConj, hprop_sup_apply] + constructor + · rintro ⟨σ₁, σ₂, hd, rfl, hF, x, hx, hxσ₂⟩ + exact ⟨sepConj F x, ⟨x, hx, rfl⟩, σ₁, σ₂, hd, rfl, hF, hxσ₂⟩ + · rintro ⟨f, ⟨x, hx, rfl⟩, σ₁, σ₂, hd, rfl, hF, hxσ₂⟩ + exact ⟨σ₁, σ₂, hd, rfl, hF, x, hx, hxσ₂⟩ + +/-- The counit of the adjunction `F ∗ · ⊣ F -∗ ·`. -/ +theorem sepConj_wand_le (F b : HProp) : (sepConj F (wand F b)) ⊑ b := by + rintro σ ⟨σ₁, σ₂, hd, rfl, hF, hw⟩ + have := hw σ₁ (State.disjoint_comm hd) hF + rwa [State.union_comm (State.disjoint_comm hd)] at this + +/-- The upper adjoint of `F ∗ ·` is the magic wand `F -∗ ·`. -/ +theorem sepConj_upperAdjoint (F b : HProp) : + PreservesSup.upperAdjoint (sepConj F) b = (wand F b) := by + apply PartialOrder.rel_antisymm + · unfold PreservesSup.upperAdjoint + apply sup_le + intro x hx σ hxσ σ' hdisj hF + apply hx (σ ⊎ₕ σ') + exact ⟨σ', σ, State.disjoint_comm hdisj, State.union_comm hdisj, hF, hxσ⟩ + · exact PreservesSup.le_upperAdjoint (sepConj F) (sepConj_wand_le F b) + +end Iris.HeapLang From 8b7f0b07bd981f34133cf842b2a913d7dcdd952f Mon Sep 17 00:00:00 2001 From: Markus de Medeiros Date: Sat, 25 Jul 2026 08:58:27 +0100 Subject: [PATCH 33/33] misc --- IrisDoNightly/IrisDoNightly/SLFrame.lean | 14 -------------- IrisDoNightly/lean-toolchain | 2 +- 2 files changed, 1 insertion(+), 15 deletions(-) diff --git a/IrisDoNightly/IrisDoNightly/SLFrame.lean b/IrisDoNightly/IrisDoNightly/SLFrame.lean index 70006ca8a..eee3cdcdd 100644 --- a/IrisDoNightly/IrisDoNightly/SLFrame.lean +++ b/IrisDoNightly/IrisDoNightly/SLFrame.lean @@ -7,20 +7,6 @@ import Std.Tactic.Do public meta import Lean.Elab.Tactic.Do.Internal.VCGen.FrameProc public meta import Lean.Meta.Sym.Pattern -/-! -# Phase 4 — Frame-inference metaprogramming for `∗` (+ Phase 5 front-end demos) - -Per `SEPLOGIC_PORT.md` §7 Phases 4–5. This is `Phase0Spike.lean`'s frameproc machinery retargeted -onto the real `Iris.HeapLang.HProp`/`sepConj` (Phase 2) and the `HeapLangAxioms` spec laws (Phase 3): -the separation-logic structural lemmas `sepConj_mono_r`/`sepConj_frame_r`, the `∗`-atom flattener -`sepAtoms`, the domain-difference frame inference `sepConjFrameProc`, and the `@[frameproc] heapFP` -keyed on `prog := ``Iris.HeapLang.Exp`. Phase 0 already proved this path fires on the non-monadic -`Exp` WP, so the only change from the spike is the target constants. - -The demos at the bottom (Phase 5) drive `vcgen` over the real SL: auto-framed and explicitly-framed -`store`, and a mixed `alloc`/`store`/`load` program. --/ - set_option mvcgen.warning false set_option grind.warning false diff --git a/IrisDoNightly/lean-toolchain b/IrisDoNightly/lean-toolchain index 728ce7a44..592d7440f 100644 --- a/IrisDoNightly/lean-toolchain +++ b/IrisDoNightly/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:nightly-2026-07-22 +leanprover/lean4:nightly-2026-07-24