From 290b8b6ee7d20745e1b49bf92c51cb336eae59d4 Mon Sep 17 00:00:00 2001 From: Marcelo Fornet Date: Fri, 24 Jul 2026 14:59:52 +0200 Subject: [PATCH 1/9] Add total weakest preconditions --- Iris/Iris.lean | 2 + Iris/Iris/BI/WeakestPre.lean | 29 + Iris/Iris/ProgramLogic/TotalAdequacy.lean | 78 +++ Iris/Iris/ProgramLogic/TotalEctxLifting.lean | 71 +++ Iris/Iris/ProgramLogic/TotalLifting.lean | 150 +++++ Iris/Iris/ProgramLogic/TotalWeakestPre.lean | 566 +++++++++++++++++++ Iris/Iris/Tests/WeakestPre.lean | 16 + 7 files changed, 912 insertions(+) create mode 100644 Iris/Iris/ProgramLogic/TotalAdequacy.lean create mode 100644 Iris/Iris/ProgramLogic/TotalEctxLifting.lean create mode 100644 Iris/Iris/ProgramLogic/TotalLifting.lean create mode 100644 Iris/Iris/ProgramLogic/TotalWeakestPre.lean diff --git a/Iris/Iris.lean b/Iris/Iris.lean index 0b6587ede..e85e7fe0a 100644 --- a/Iris/Iris.lean +++ b/Iris/Iris.lean @@ -6,5 +6,7 @@ public import Iris.Examples public import Iris.HeapLang public import Iris.Instances public import Iris.ProofMode +public import Iris.ProgramLogic.TotalAdequacy +public import Iris.ProgramLogic.TotalEctxLifting public import Iris.Std public import Iris.Tests diff --git a/Iris/Iris/BI/WeakestPre.lean b/Iris/Iris/BI/WeakestPre.lean index 10bef1426..a513e12ba 100644 --- a/Iris/Iris/BI/WeakestPre.lean +++ b/Iris/Iris/BI/WeakestPre.lean @@ -76,6 +76,13 @@ syntax " {" noWs "{ " term:min " }" noWs "} " : texanPrecond syntax (name := texanTriple) texanPrecond wpExpr texanPostcond : term +/- Total Texan triples deliberately have no later in front of the postcondition +continuation. The doubled square brackets follow Iris-Rocq's TWP notation. -/ +syntax (name := totalTexanTriple) + "[[{" term:min "}]]" wpExpr + "[[{" ((ppSpace (binderIdent <|> bracketedBinder))+ ", ")? + "RET " term:min "; " term:min "}]]" : term + open Lean in meta def parseWpExpr : Lean.TSyntax ``wpExpr → Lean.MacroM (TSyntax `term × TSyntax `term × TSyntax `term) := fun | `(wpExpr| $e @ $s ; $E) => @@ -136,6 +143,28 @@ meta def wpTexanTriple : Lean.Macro `(iprop(∀ Φ, $P -∗ ▷ $k -∗ (WP $wpExpr {{ Φ }}))) | _ => Lean.Macro.throwUnsupported +@[macro totalTexanTriple] +meta def totalWpTexanTriple : Lean.Macro + | `([[{ $P:term }]] $wpExpr + [[{ $[$[$xs]* ,]? RET $pat ; $Q:term }]]) => do + let transform + (xs : Array (TSyntax [`Lean.binderIdent, `Lean.Parser.Term.bracketedBinder])) : + MacroM <| TSyntaxArray [`ident, `Lean.Parser.Term.hole, + `Lean.Parser.Term.bracketedBinder] := + xs.mapM fun + | `(binderIdent|_) => `(hole|_) + | `(binderIdent|$i:ident) => `(ident|$i) + | `(bracketedBinder|$x) => `(bracketedBinder|$x) + let k ← match xs with + | some xs => + let xs ← transform xs + `(iprop(∀ $xs*, $Q:term -∗ Φ $pat)) + | none => `($Q:term -∗ Φ $pat) + let (e, s, E) ← parseWpExpr wpExpr + `(iprop(∀ Φ, $P -∗ $k -∗ + TotalWp.totalWp $s $E $e Φ)) + | _ => Lean.Macro.throwUnsupported + meta def unexpandWpPostcondInner : TSyntax `term → PrettyPrinter.UnexpandM (TSyntax `wpPostcondInner) | `(fun $v:ident => iprop($Φ:term)) => `(wpPostcondInner|$v:ident, $Φ:term) | `(iprop($Φ:term)) => `(wpPostcondInner| $Φ:term) diff --git a/Iris/Iris/ProgramLogic/TotalAdequacy.lean b/Iris/Iris/ProgramLogic/TotalAdequacy.lean new file mode 100644 index 000000000..0704833d7 --- /dev/null +++ b/Iris/Iris/ProgramLogic/TotalAdequacy.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Fernando Leal. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import Iris.ProgramLogic.TotalWeakestPre +public import Iris.ProgramLogic.Adequacy + +namespace Iris.ProgramLogic + +open Iris OFE COFE BI Iris.BI Iris.Algebra Std FromMathlib LawfulSet +open Language Language.Notation + +@[expose] public section + +/-! ## Operational termination predicates + +`Acc` takes the next configuration as its left argument, so the operational +relation is flipped. This definition is constructive and means that every +reduction tree rooted at the configuration is finite (strong normalization), +not merely that some execution terminates. +-/ + +def StronglyNormalizing {α : Type _} (step : α → α → Prop) (x : α) : Prop := + Acc (flip step) x + +namespace StronglyNormalizing + +theorem intro {α : Type _} {step : α → α → Prop} {x : α} + (H : ∀ y, step x y → StronglyNormalizing step y) : + StronglyNormalizing step x := + Acc.intro x H + +theorem of_irreducible {α : Type _} {step : α → α → Prop} {x : α} + (H : ∀ y, ¬ step x y) : StronglyNormalizing step x := + .intro fun y Hxy => (H y Hxy).elim + +theorem tail {α : Type _} {step : α → α → Prop} {x y : α} + (H : StronglyNormalizing step x) (Hxy : step x y) : + StronglyNormalizing step y := + H.inv Hxy + +end StronglyNormalizing + +variable {Expr State Obs Val : Type _} [Λ : Language Expr State Obs Val] + +/-- Erased single-thread reduction. Forked expressions remain visible in the +step witness; clients can rule them out with `LanguageNoFork`. -/ +def ExprErasedStep : Expr × State → Expr × State → Prop + | (e₁, σ₁), (e₂, σ₂) => + ∃ (κ : List Obs) (efs : List Expr), (e₁, σ₁) -<κ>-> (e₂, σ₂, efs) + +/-- The single-threaded language contract used by the Wasm-facing adequacy +corollaries. -/ +class LanguageNoFork (Expr State Obs Val : Type _) + [Language Expr State Obs Val] : Prop where + no_fork {e₁ e₂ : Expr} {σ₁ σ₂ : State} {κ : List Obs} {efs : List Expr} : + (e₁, σ₁) -<κ>-> (e₂, σ₂, efs) → efs = [] + +theorem exprErasedStep_noFork [LanguageNoFork Expr State Obs Val] {e₁ σ₁ e₂ σ₂} + (H : ExprErasedStep (Expr := Expr) (State := State) (Obs := Obs) + (e₁, σ₁) (e₂, σ₂)) : + ∃ κ, (e₁, σ₁) -<κ>-> (e₂, σ₂, []) := by + obtain ⟨κ, efs, Hstep⟩ := H + have := LanguageNoFork.no_fork Hstep + subst efs + exact ⟨κ, Hstep⟩ + +theorem value_stronglyNormalizing (v : Val) (σ : State) : + StronglyNormalizing (ExprErasedStep (Expr := Expr) (Obs := Obs)) + ((v : Expr), σ) := by + apply StronglyNormalizing.of_irreducible + rintro ⟨e₂, σ₂⟩ ⟨κ, efs, Hstep⟩ + exact Language.prim_val_stuck Hstep + +end +end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/TotalEctxLifting.lean b/Iris/Iris/ProgramLogic/TotalEctxLifting.lean new file mode 100644 index 000000000..d429c5b96 --- /dev/null +++ b/Iris/Iris/ProgramLogic/TotalEctxLifting.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 Fernando Leal. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import Iris.ProgramLogic.TotalLifting +public import Iris.ProgramLogic.EctxLifting + +namespace Iris.ProgramLogic + +open Iris Language.Notation EctxLanguage EctxLanguage.Notation + +@[expose] public section + +/-! +Total base-step rules for evaluation-context languages. We intentionally stop +at the generic deterministic/no-fork interface needed by a Wasm language. +HeapLang primitive laws and concurrent convenience rules are not duplicated: +they add no capability for the initial single-threaded Wasm consumer. +-/ + +variable {hlc : outParam HasLC} {Expr Ectx State Obs Val} +variable [Λ : EctxLanguage Expr Ectx State Obs Val] +variable {GF : BundledGFunctors} [ι : IrisGS_gen hlc Expr GF] +variable {s : Stuckness} {E : CoPset} {e₁ e₂ : Expr} +variable {Φ : Val → IProp GF} + +theorem twp_lift_base_step_no_fork (h : toVal e₁ = none) : + (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E,∅}=∗ + ⌜BaseStep.Reducible (e₁, σ₁)⌝ ∗ + ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>->ᵇ (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ + ⌜κ = []⌝ ∗ ⌜eₜ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs nt ∗ + WP e₂ @ s; E [{ Φ }]) + ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro H + iapply twp_lift_step_no_fork h + iintro %σ₁ %ns %obs %nt Hσ + imod H $$ Hσ with ⟨%Hred, H⟩ + imodintro + isplit + · ipureintro + cases s + · exact EctxLanguage.primStep_reducible_of_baseStep_reducible Hred + · trivial + · iintro %κ %e₂ %σ₂ %eₜ %Hstep + have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible Hred Hstep + iapply H $$ %κ %e₂ %σ₂ %eₜ %Hb + +theorem twp_lift_pure_det_base_step_no_fork [Inhabited State] + (h : toVal e₁ = none) + (Hred : ∀ σ, BaseStep.Reducible (e₁, σ)) + (Hpure : ∀ σ κ e₂' σ₂ eₜ, + (e₁, σ) -<κ>->ᵇ (e₂', σ₂, eₜ) → + κ = [] ∧ σ₂ = σ ∧ e₂' = e₂ ∧ eₜ = []) : + WP e₂ @ s; E [{ Φ }] ⊢ WP e₁ @ s; E [{ Φ }] := by + apply twp_lift_pure_det_step_no_fork + · intro σ + cases s + · obtain ⟨κ, e', σ', efs, Hb⟩ := Hred σ + have ⟨hκ, _, _, _⟩ := Hpure σ κ e' σ' efs Hb + subst hκ + exact ⟨e', σ', efs, EctxLanguage.primStep_of_baseStep Hb⟩ + · exact h + · intro σ κ e₂' σ₂ eₜ Hstep + exact Hpure _ _ _ _ _ + (EctxLanguage.baseStep_of_primStep_of_baseStep_reducible (Hred σ) Hstep) + +end +end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/TotalLifting.lean b/Iris/Iris/ProgramLogic/TotalLifting.lean new file mode 100644 index 000000000..276a52229 --- /dev/null +++ b/Iris/Iris/ProgramLogic/TotalLifting.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Fernando Leal. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import Iris.ProgramLogic.TotalWeakestPre +public import Iris.ProgramLogic.Lifting + +namespace Iris.ProgramLogic + +open Iris Language Language.Notation BI + +@[expose] public section + +/-! +The no-fork rules in this file are the intended entry point for Wasm. They +make the single-threaded contract explicit (`eₜ = []`) while the underlying +TWP remains faithful to Iris and can account for forks. + +All total rules require the operational observation to be empty. This is a +semantic requirement of Iris TWP, not proof bookkeeping. +-/ + +variable {hlc : outParam HasLC} {Expr State Obs Val} +variable [Λ : Language Expr State Obs Val] +variable {GF : BundledGFunctors} [ι : IrisGS_gen hlc Expr GF] +variable {s : Stuckness} {E E₁ E₂ : CoPset} +variable {e e₁ e₂ : Expr} {Φ : Val → IProp GF} + +@[rocq_alias twp_lift_step] +theorem twp_lift_step (h : toVal e₁ = none) : + (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E,∅}=∗ + ⌜s.MaybeReducible (e₁, σ₁)⌝ ∗ + ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ + ⌜κ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ + WP e₂ @ s; E [{ Φ }] ∗ + [∗list] ef ∈ eₜ, WP ef @ s; ⊤ [{ ι.forkPost }]) + ⊢ WP e₁ @ s; E [{ Φ }] := by + rw [twp.unfold.to_eq] + simp only [twp.pre, h] + exact .rfl + +theorem twp_lift_step_no_fork (h : toVal e₁ = none) : + (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E,∅}=∗ + ⌜s.MaybeReducible (e₁, σ₁)⌝ ∗ + ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ + ⌜κ = []⌝ ∗ ⌜eₜ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs nt ∗ + WP e₂ @ s; E [{ Φ }]) + ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro H + iapply twp_lift_step h + iintro %σ₁ %ns %obs %nt Hσ + imod H $$ Hσ with ⟨%Hred, H⟩ + imodintro + iframe %Hred + iintro %κ %e₂ %σ₂ %eₜ %Hstep + imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with ⟨%hκ, %heₜ, Hσ, Hwp⟩ + subst heₜ + imodintro + simp only [List.length_nil, Nat.add_zero, Algebra.BigOpL.bigOpL_nil] + iframe %hκ Hσ Hwp + +@[rocq_alias twp_lift_atomic_step] +theorem twp_lift_atomic_step (h : toVal e₁ = none) : + (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E}=∗ + ⌜s.MaybeReducible (e₁, σ₁)⌝ ∗ + ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={E}=∗ + ⌜κ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ + (∃ v, ⌜toVal e₂ = some v⌝ ∧ Φ v) ∗ + [∗list] ef ∈ eₜ, WP ef @ s; ⊤ [{ ι.forkPost }]) + ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro H + iapply twp_lift_step h + iintro %σ₁ %ns %obs %nt Hσ + imod H $$ Hσ with ⟨%Hred, H⟩ + iapply fupd_mask_intro Std.LawfulSet.empty_subset + iintro Hclose + isplit + · ipureintro + exact Hred + · iintro %κ %e₂ %σ₂ %eₜ %Hstep + imod Hclose with - + imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with + ⟨%hκ, Hσ, ⟨%v, %hval, HΦ⟩, Hefs⟩ + imodintro + iframe %hκ Hσ Hefs + iapply twp.value (ToVal.coe_of_toVal_eq_some hval).symm + iexact HΦ + +theorem twp_lift_atomic_step_no_fork (h : toVal e₁ = none) : + (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E}=∗ + ⌜s.MaybeReducible (e₁, σ₁)⌝ ∗ + ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={E}=∗ + ⌜κ = []⌝ ∗ ⌜eₜ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs nt ∗ + ∃ v, ⌜toVal e₂ = some v⌝ ∧ Φ v) + ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro H + iapply twp_lift_atomic_step h + iintro %σ₁ %ns %obs %nt Hσ + imod H $$ Hσ with ⟨%Hred, H⟩ + imodintro + iframe %Hred + iintro %κ %e₂ %σ₂ %eₜ %Hstep + imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with + ⟨%hκ, %heₜ, Hσ, Hval⟩ + subst heₜ + imodintro + simp only [List.length_nil, Nat.add_zero, Algebra.BigOpL.bigOpL_nil] + iframe %hκ Hσ Hval + +theorem twp_lift_pure_det_step_no_fork [Inhabited State] + (Hsafe : ∀ σ₁, match s with + | .NotStuck => PrimStep.ReducibleNoObs (e₁, σ₁) + | .MaybeStuck => toVal e₁ = none) + (Hpure : ∀ σ₁ κ e₂' σ₂ eₜ, + (e₁, σ₁) -<κ>-> (e₂', σ₂, eₜ) → + κ = [] ∧ σ₂ = σ₁ ∧ e₂' = e₂ ∧ eₜ = []) : + WP e₂ @ s; E [{ Φ }] ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro Hwp + have hnone : toVal e₁ = none := by + cases s + · exact Language.toVal_none_of_reducible + (Language.reducible_of_reducibleNoObs (Hsafe default)) + · exact Hsafe default + iapply twp_lift_step_no_fork hnone + iintro %σ₁ %ns %obs %nt Hσ + iapply fupd_mask_intro Std.LawfulSet.empty_subset + iintro Hclose + isplit + · ipureintro + cases s + · exact Language.reducible_of_reducibleNoObs (Hsafe σ₁) + · trivial + · iintro %κ %e₂' %σ₂ %eₜ %Hstep + obtain ⟨rfl, rfl, rfl, rfl⟩ := Hpure _ _ _ _ _ Hstep + imod Hclose + ihave Hmono := ι.stateInterp_mono σ₂ ns obs nt $$ Hσ + imod fupd_mask_mono Std.LawfulSet.empty_subset $$ Hmono with Hσ + imodintro + iframe Hσ Hwp + ipureintro + exact ⟨rfl, rfl⟩ + +end +end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean new file mode 100644 index 000000000..29d1ea5f7 --- /dev/null +++ b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean @@ -0,0 +1,566 @@ +/- +Copyright (c) 2026 Fernando Leal. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import Iris.BI.Lib.Fixpoint +public import Iris.ProgramLogic.WeakestPre +public import Iris.ProofMode + +namespace Iris + +open ProgramLogic Language.Notation Std OFE + +@[expose] public section + +/-! +# Total weakest preconditions + +This is the least-fixed-point total weakest precondition from Iris-Rocq. In +contrast to ordinary WP, recursive occurrences are not guarded by a later. +Consequently, membership in TWP is a finite derivation and adequacy can turn it +into strong normalization. + +The definition remains fork-aware to stay compatible with Iris. Wasm clients +are expected to use the no-fork lifting rules in `TotalLifting`: the initial +target is single-threaded Wasm, so concurrency-specific derived libraries are +deliberately not duplicated here. + +As in Iris-Rocq, TWP only accepts silent operational steps. A language with +observable reductions must expose a silent administrative semantics or provide +a future trace-sensitive generalization instead of discarding observations. +-/ + +variable {hlc : outParam HasLC} {Expr State Obs Val} +variable [Λ : Language Expr State Obs Val] +variable {GF : BundledGFunctors} [ι : IrisGS_gen hlc Expr GF] + +namespace twp + +local instance : OFE CoPset := OFE.ofDiscrete _ +local instance : OFE Expr := OFE.ofDiscrete _ +local instance : OFE Val := OFE.ofDiscrete _ + +abbrev Args (Expr Val : Type _) (GF : BundledGFunctors) := + (CoPset × Expr) × (Val → IProp GF) + +def pre (s : Stuckness) + (twp : CoPset → Expr → (Val → IProp GF) → IProp GF) + (E : CoPset) (e₁ : Expr) (Φ : Val → IProp GF) : IProp GF := + match toVal e₁ with + | some v => iprop(|={E}=> Φ v) + | none => iprop(∀ (σ₁ : State) (ns : Nat) (obs : List Obs) (nt : Nat), + stateInterp σ₁ ns obs nt ={E,∅}=∗ + ⌜s.MaybeReducible (e₁, σ₁)⌝ ∗ + ∀ (κ : List Obs) e₂ σ₂ eₜ, + ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ + ⌜κ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ + twp E e₂ Φ ∗ + [∗list] e' ∈ eₜ, twp ⊤ e' ι.forkPost) + +def pre' (s : Stuckness) + (X : Args Expr Val GF → IProp GF) : Args Expr Val GF → IProp GF + | ((E, e), Φ) => pre s (fun E e Φ => X ((E, e), Φ)) E e Φ + +instance pre'_mono (s : Stuckness) : BIMonoPred (pre' (ι := ι) s) where + mono_pred := by + intro X Y _ _ + iintro #HXY %x + rcases x with ⟨⟨E, e⟩, Φ⟩ + simp only [pre', pre] + iintro HX + cases toVal e + case some => iexact HX + case none => + iintro %σ₁ %ns %obs %nt Hσ + imod HX $$ Hσ with ⟨%Hred, H⟩ + imodintro + isplit + · ipureintro + exact Hred + · iintro %κ %e₂ %σ₂ %eₜ %Hstep + imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with ⟨%hκ, Hσ, He, Hefs⟩ + imodintro + iframe %hκ Hσ + isplitl [He] + · iapply HXY $$ %((E, e₂), Φ) He + · iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef Hef + iapply HXY $$ %((⊤, ef), ι.forkPost) Hef + mono_pred_ne.ne {X} a b h := by + rcases a with ⟨⟨E₁, e₁⟩, Φ₁⟩ + rcases b with ⟨⟨E₂, e₂⟩, Φ₂⟩ + rcases h with ⟨⟨hE, he⟩, hΦ⟩ + change E₁ = E₂ at hE + change e₁ = e₂ at he + subst E₂ + subst e₂ + simp only [pre', pre] + match toVal e₁ with + | some v => exact BIFUpdate.ne.ne (hΦ v) + | none => + refine BI.forall_ne fun _ => ?_ + refine BI.forall_ne fun _ => ?_ + refine BI.forall_ne fun _ => ?_ + refine BI.forall_ne fun _ => ?_ + refine BI.wand_ne.ne .rfl ?_ + refine BIFUpdate.ne.ne ?_ + refine BI.sep_ne.ne .rfl ?_ + refine BI.forall_ne fun _ => ?_ + refine BI.forall_ne fun _ => ?_ + refine BI.forall_ne fun _ => ?_ + refine BI.forall_ne fun _ => ?_ + refine BI.wand_ne.ne .rfl ?_ + refine BIFUpdate.ne.ne ?_ + refine BI.sep_ne.ne .rfl ?_ + refine BI.sep_ne.ne .rfl ?_ + refine BI.sep_ne.ne ?_ ?_ + · apply NonExpansive.ne + exact ⟨⟨.rfl, .rfl⟩, hΦ⟩ + · exact .rfl + +def get (s : Stuckness) (E : CoPset) (e : Expr) (Φ : Val → IProp GF) : IProp GF := + letI : OFE CoPset := OFE.ofDiscrete _ + letI : OFE Expr := OFE.ofDiscrete _ + letI : OFE Val := OFE.ofDiscrete _ + bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ) + +instance instTotalWp : TotalWp (IProp GF) Expr Val Stuckness where + totalWp := get + +section Rules + +local instance : OFE CoPset := OFE.ofDiscrete _ +local instance : OFE Expr := OFE.ofDiscrete _ +local instance : OFE Val := OFE.ofDiscrete _ + +@[rocq_alias twp_unfold] +theorem unfold {s E} {e : Expr} {Φ : Val → IProp GF} : + WP e @ s ; E [{ Φ }] ⊣⊢ pre s (TotalWp.totalWp (PROP := IProp GF) s) E e Φ := by + change bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ) ⊣⊢ _ + exact BI.equiv_iff.1 (least_fixpoint_unfold (pre' (ι := ι) s)) + +@[rocq_alias twp_ind] +theorem induction (s : Stuckness) + (Ψ : CoPset → Expr → (Val → IProp GF) → IProp GF) + [HΨ : NonExpansive (fun x : Args Expr Val GF => Ψ x.1.1 x.1.2 x.2)] : + (⊢ □ (∀ E e Φ, + pre s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) E e Φ -∗ + Ψ E e Φ)) → + ⊢ ∀ E e Φ, WP e @ s ; E [{ Φ }] -∗ Ψ E e Φ := by + intro H + have H' : ⊢ □ (∀ E e Φ, + pre s (fun E e Φ => + iprop(Ψ E e Φ ∧ bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ))) + E e Φ -∗ Ψ E e Φ) := by + simpa only [TotalWp.totalWp, instTotalWp, get] using H + iintro %E %e %Φ + change ⊢ bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ) -∗ Ψ E e Φ + iintro Htwp + iapply least_fixpoint_ind (F := pre' (ι := ι) s) + (Φ := fun x => Ψ x.1.1 x.1.2 x.2) $$ [] Htwp + iintro !> %x + rcases x with ⟨⟨E, e⟩, Φ⟩ + simp only [pre'] + iintro Hx + iapply H' + iexact Hx + +@[rocq_alias twp_ne] +instance ne {s : Stuckness} {E} {e : Expr} : + NonExpansive (TotalWp.totalWp (PROP := IProp GF) s E e) where + ne {n Φ₁ Φ₂} HΦ := by + change bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ₁) ≡{n}≡ + bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ₂) + apply NonExpansive.ne + exact ⟨⟨.rfl, .rfl⟩, fun v => HΦ v⟩ + +@[rocq_alias twp_value_fupd'] +theorem value_fupd' {s : Stuckness} {E} {Φ : Val → IProp GF} {v : Val} : + WP (v : Expr) @ s ; E [{ Φ }] ⊣⊢ |={E}=> Φ v := by + simp [unfold.to_eq, pre, toVal_coe, BI.BIBase.BiEntails.rfl] + +@[rocq_alias twp_strong_mono] +theorem strong_mono {s₁ s₂ : Stuckness} {E₁ E₂} {e : Expr} + {Φ Ψ : Val → IProp GF} (hs : s₁ ≤ s₂) (hE : E₁ ⊆ E₂) : + ⊢ WP e @ s₁ ; E₁ [{ Φ }] -∗ + (∀ v, Φ v ={E₂}=∗ Ψ v) -∗ WP e @ s₂ ; E₂ [{ Ψ }] := by + let Pred := fun (E : CoPset) (e : Expr) (Φ : Val → IProp GF) => iprop( + ∀ E₂ Ψ, ⌜E ⊆ E₂⌝ -∗ (∀ v, Φ v ={E₂}=∗ Ψ v) -∗ + WP e @ s₂ ; E₂ [{ Ψ }]) + have hPred : NonExpansive + (fun x : Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by + constructor + intro n x y h + rcases x with ⟨⟨EX, eX⟩, ΦX⟩ + rcases y with ⟨⟨EY, eY⟩, ΦY⟩ + rcases h with ⟨⟨hE', he'⟩, hΦ⟩ + change EX = EY at hE' + change eX = eY at he' + subst EY + subst eY + refine BI.forall_ne fun _ => ?_ + refine BI.forall_ne fun _ => ?_ + refine BI.wand_ne.ne .rfl ?_ + refine BI.wand_ne.ne ?_ .rfl + refine BI.forall_ne fun v => ?_ + exact BI.wand_ne.ne (hΦ v) .rfl + letI := hPred + iintro H HΦ + iapply induction s₁ Pred (ι := ι) ?_ $$ H + · iintro !> %E %e₁ %Φ₁ IH %E' %Ψ' %hE' + rw [unfold.to_eq] + unfold pre + cases hval : toVal e₁ with + | some v => + dsimp only + iintro HpostSome + imod fupd_mask_mono hE' $$ IH with HΦv + iapply HpostSome $$ HΦv + | none => + dsimp only + iintro HpostNone + iintro %σ₁ %ns %obs %nt Hσ + imod fupd_mask_subseteq hE' with Hclose + imod IH $$ Hσ with ⟨%Hred, Hstep⟩ + imodintro + isplit + · ipureintro + simp only [LE.le] at hs + grind [cases Stuckness] + · iintro %κ %e₂ %σ₂ %eₜ %Hprim + imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with + ⟨%hκ, Hσ, He₂, Hefs⟩ + imod Hclose + imodintro + iframe %hκ Hσ + isplitl [He₂ HpostNone] + · icases He₂ with ⟨IH₂, -⟩ + iapply IH₂ $$ %E' %Ψ' %hE' HpostNone + · iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef Hef + icases Hef with ⟨IHef, -⟩ + iapply IHef $$ %⊤ %ι.forkPost %LawfulSet.subset_refl + iintro %v Hv + imodintro + iexact Hv + · ipureintro + exact hE + · iexact HΦ + +@[rocq_alias fupd_twp] +theorem fupd_twp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : + (|={E}=> WP e @ s ; E [{ Φ }]) ⊢ WP e @ s ; E [{ Φ }] := by + rw [unfold.to_eq] + iintro H + unfold pre + cases toVal e + · iintro %σ %ns %obs %nt Hσ + imod H with H + iapply H $$ Hσ + · imod H + iassumption + +@[rocq_alias twp_fupd] +theorem twp_fupd {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : + WP e @ s ; E [{ v, |={E}=> Φ v }] ⊢ WP e @ s ; E [{ Φ }] := by + iintro H + iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ H + iintro %v Hv + iexact Hv + +@[rocq_alias twp_atomic] +theorem atomic {s : Stuckness} {E₁ E₂ : CoPset} {e : Expr} + {Φ : Val → IProp GF} [hatom : Language.Atomic ↑s e] : + (|={E₁,E₂}=> WP e @ s ; E₂ [{ v, |={E₂,E₁}=> Φ v }]) + ⊢ WP e @ s ; E₁ [{ Φ }] := by + rw [unfold.to_eq, unfold.to_eq] + iintro H + unfold pre + cases he : toVal e with + | some v => + dsimp only + imod H + imod H + iassumption + | none => + dsimp only + iintro %σ₁ %ns %obs %nt Hσ + imod H + imod H $$ Hσ with ⟨%Hred, Hstep⟩ + imodintro + iframe %Hred + cases s + · iintro %κ %e₂ %σ₂ %eₜ %Hprim + imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with + ⟨%hκ, Hσ, He₂, Hefs⟩ + cases he₂ : toVal e₂ with + | some v₂ => + icases unfold $$ He₂ with He₂ + simp only [pre, he₂] + imod He₂ + imod He₂ + imodintro + iframe %hκ Hσ Hefs + rw [unfold.to_eq] + simp only [pre, he₂] + imodintro + iexact He₂ + | none => + icases unfold $$ He₂ with He₂ + simp only [pre, he₂] + imod He₂ $$ %σ₂ %(ns + 1) %obs %(nt + eₜ.length) Hσ with + ⟨%Hred₂, _⟩ + exact (Language.not_reducible_iff_irreducible.mpr + (hatom.atomic Hprim)) Hred₂ |>.elim + · iintro %κ %e₂ %σ₂ %eₜ %Hprim + imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with + ⟨%hκ, Hσ, He₂, Hefs⟩ + have ⟨v₂, hv₂⟩ := Option.isSome_iff_exists.mp (hatom.atomic Hprim) + icases unfold $$ He₂ with He₂ + simp only [pre, hv₂] + imod He₂ + imod He₂ + imodintro + iframe %hκ Hσ Hefs + rw [unfold.to_eq] + simp only [pre, hv₂] + imodintro + iexact He₂ + +@[rocq_alias twp_bind] +theorem bind (K : Expr → Expr) [ctx : Language.Context K] + {s : Stuckness} {E : CoPset} {e : Expr} {Φ : Val → IProp GF} : + TotalWp.totalWp s E e + (fun v : Val => iprop(WP (K (v : Expr)) @ s ; E [{ Φ }])) + ⊢ WP (K e) @ s ; E [{ Φ }] := by + let Pred := fun (E : CoPset) (e : Expr) (Ψ : Val → IProp GF) => iprop( + ∀ Φ, (∀ v, Ψ v -∗ WP (K (v : Expr)) @ s ; E [{ Φ }]) -∗ + WP (K e) @ s ; E [{ Φ }]) + have hPred : NonExpansive + (fun x : Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by + constructor + intro n x y hxy + rcases x with ⟨⟨EX, eX⟩, ΨX⟩ + rcases y with ⟨⟨EY, eY⟩, ΨY⟩ + rcases hxy with ⟨⟨hE, he⟩, hΨ⟩ + change EX = EY at hE + change eX = eY at he + subst EY + subst eY + refine BI.forall_ne fun _ => ?_ + refine BI.wand_ne.ne ?_ .rfl + refine BI.forall_ne fun v => ?_ + exact BI.wand_ne.ne (hΨ v) .rfl + letI := hPred + iintro H + iapply induction s Pred (ι := ι) ?_ $$ H + · iintro !> %E %e %Ψ + cases he : toVal e with + | some v => + simp only [pre, he] + iintro Hpre %Φ Hcont + have heq := ToVal.coe_of_toVal_eq_some he + rw [← heq] + ispecialize Hcont $$ %v + iapply fupd_twp + iapply (fupd_wand_left (P := Ψ v)) + iframe + | none => + simp only [pre, he] + iintro Hpre %Φ Hcont + rw [unfold.to_eq] + unfold pre + simp only [ctx.toVal_eq_none_fill he] + iintro %σ₁ %ns %obs %nt Hσ + imod Hpre $$ Hσ with ⟨%Hred, Hstep⟩ + imodintro + isplit + · ipureintro + cases s + · exact Language.Context.reducible_fill (K := K) Hred + · trivial + · iintro %κ %e₂ %σ₂ %eₜ %HKstep + obtain ⟨e₂', rfl, Hprim⟩ := ctx.primStep_fill_inv he HKstep + imod Hstep $$ %κ %e₂' %σ₂ %eₜ %Hprim with + ⟨%hκ, Hσ, He₂, Hefs⟩ + imodintro + iframe %hκ Hσ + isplitl [He₂ Hcont] + icases He₂ with ⟨IH, -⟩ + iapply IH $$ %Φ Hcont + iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef Hef + icases Hef with ⟨-, Hef⟩ + iexact Hef + · iintro %v Hv + iexact Hv + +@[rocq_alias twp_mono] +theorem mono {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} + (H : ∀ v, Φ v ⊢ Ψ v) : + WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E [{ Ψ }] := by + iintro Hwp + iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ Hwp + iintro %v Hv + imodintro + iapply H v + iexact Hv + +@[rocq_alias twp_stuck_mono] +theorem stuck_mono {s₁ s₂ : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} + (H : s₁ ≤ s₂) : + WP e @ s₁ ; E [{ Φ }] ⊢ WP e @ s₂ ; E [{ Φ }] := by + iintro Hwp + iapply strong_mono H LawfulSet.subset_refl $$ Hwp + iintro %v Hv + imodintro + iexact Hv + +@[rocq_alias twp_stuck_weaken] +theorem stuck_weaken {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : + WP e @ s ; E [{ Φ }] ⊢ WP e @ E ? [{ Φ }] := + stuck_mono Stuckness.le_MaybeStuck + +@[rocq_alias twp_mask_mono] +theorem mask_mono {s : Stuckness} {E₁ E₂} {e : Expr} {Φ : Val → IProp GF} + (H : E₁ ⊆ E₂) : + WP e @ s ; E₁ [{ Φ }] ⊢ WP e @ s ; E₂ [{ Φ }] := by + iintro Hwp + iapply strong_mono (Std.IsPreorder.le_refl _) H $$ Hwp + iintro %v Hv + imodintro + iexact Hv + +@[rocq_alias twp_value_fupd] +theorem value_fupd {s : Stuckness} {E} {e : Expr} {v : Val} + {Φ : Val → IProp GF} (h : e = (v : Expr)) : + WP e @ s ; E [{ Φ }] ⊣⊢ |={E}=> Φ v := by + subst e + exact value_fupd' + +@[rocq_alias twp_value'] +theorem value' {s : Stuckness} {E} {v : Val} {Φ : Val → IProp GF} : + Φ v ⊢ WP (v : Expr) @ s ; E [{ Φ }] := by + rw [value_fupd'.to_eq] + exact fupd_intro + +@[rocq_alias twp_value] +theorem value {s : Stuckness} {E} {e : Expr} {v : Val} {Φ : Val → IProp GF} + (h : e = (v : Expr)) : Φ v ⊢ WP e @ s ; E [{ Φ }] := by + subst e + exact value' + +@[rocq_alias twp_frame_l] +theorem frame_l {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} + {R : IProp GF} : + R ∗ WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E [{ v, R ∗ Φ v }] := by + iintro ⟨HR, Hwp⟩ + iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ Hwp + iintro %v HΦ + imodintro + iframe + +@[rocq_alias twp_frame_r] +theorem frame_r {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} + {R : IProp GF} : + WP e @ s ; E [{ Φ }] ∗ R ⊢ WP e @ s ; E [{ v, Φ v ∗ R }] := by + rw [(BI.sep_comm (P := WP e @ s ; E [{ Φ }]) (Q := R)).to_eq] + refine frame_l.trans ?_ + apply mono + intro v + exact BI.sep_comm.mp + +@[rocq_alias twp_wand] +theorem wand {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : + WP e @ s ; E [{ Φ }] ⊢ + (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s ; E [{ Ψ }] := by + iintro Hwp H + iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ Hwp + iintro %v Hv + imodintro + iapply H $$ Hv + +@[rocq_alias twp_wp] +theorem to_wp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : + WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E {{ Φ }} := by + iloeb as IH generalizing %E %e %Φ + rw [wp_unfold.to_eq, unfold.to_eq] + unfold wp.pre pre + cases hval : toVal e + case some v => + iintro H + iexact H + case none => + iintro H %σ %ns %κ %κs %nt Hσ + imod H $$ Hσ with ⟨%Hred, H⟩ + imodintro + isplit + · ipureintro + cases s <;> simp_all [Stuckness.MaybeReducible] + · iintro %e₂ %σ₂ %eₜ %Hstep _ + ihave Hnext := H $$ %κ %e₂ %σ₂ %eₜ %Hstep + iapply step_fupdN_intro Std.LawfulSet.empty_subset + rw [(BI.later_laterN _).to_eq] + iintro !> + iapply BI.laterN_intro + imod Hnext with ⟨%hκ, Hσ, He₂, Hefs⟩ + subst hκ + simp only [List.nil_append] + imodintro + iframe Hσ + isplitl [He₂] + · iapply IH $$ He₂ + · iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef Hef + iapply IH $$ Hef + +section ProofMode + +open ProofMode + +variable {s : Stuckness} {E : CoPset} {e : Expr} +variable {Φ Ψ : Val → IProp GF} {P R : IProp GF} + +instance frameTwp {p : Bool} [H : ∀ v, Frame p R (Φ v) (Ψ v)] : + Frame p R (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Ψ }]) where + frame := by + refine frame_l.trans ?_ + apply mono + exact fun v => (H v).frame + +instance isExcept0Twp : IsExcept0 (WP e @ s ; E [{ Φ }]) where + is_except0 := + calc iprop(◇ _) + _ ⊢ ◇ |={E}=> _ := BI.except0_mono fupd_intro + _ ⊢ |={E}=> _ := BIFUpdate.except0 + _ ⊢ WP e @ s ; E [{ Φ }] := fupd_twp + +instance (priority := default + 10) elimModalFupdTwp p : + ElimModal True p false iprop(|={E}=> P) P + (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where + elim_modal := by + iintro %_ ⟨H, G⟩ + icases BI.intuitionisticallyIf_elim $$ H with H + iapply fupd_twp + imod H + imodintro + iapply G $$ H + +instance elimModalBupdTwp p : + ElimModal True p false iprop(|==> P) P + (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where + elim_modal := by + rintro ⟨⟩ + refine BI.sep_mono (BI.intuitionisticallyIf_mono + (BIUpdateFUpdate.fupd_of_bupd (E := E))) .rfl |>.trans ?_ + apply elimModalFupdTwp _ |>.elim_modal ⟨⟩ + +end ProofMode + +end Rules +end twp +end +end Iris diff --git a/Iris/Iris/Tests/WeakestPre.lean b/Iris/Iris/Tests/WeakestPre.lean index 71874d0b1..d852ae773 100644 --- a/Iris/Iris/Tests/WeakestPre.lean +++ b/Iris/Iris/Tests/WeakestPre.lean @@ -118,6 +118,22 @@ variable (Φ : Val → PROP) end TestWP +section TestTotalTexanTriple + +set_option linter.unusedVariables false + +variable (PROP Expr Val : Type _) [BI PROP] +variable [TotalWp PROP Expr Val Stuckness] +variable (e : Expr) (P Q : PROP) (v : Val) + +/-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e [{ Φ }] ) : PROP -/ +#guard_msgs in #check [[{ P }]] e [[{ RET v; Q }]] + +/-- info: iprop(∀ Φ, P -∗ (∀ x, Q -∗ Φ x) -∗ WP e [{ Φ }] ) : PROP -/ +#guard_msgs in #check [[{ P }]] e [[{ x, RET x; Q }]] + +end TestTotalTexanTriple + section TestTexanTriple set_option linter.unusedVariables false From 9353174df725c89e440bf26a843ca614bf21b24a Mon Sep 17 00:00:00 2001 From: Marcelo Fornet Date: Sat, 25 Jul 2026 17:09:25 +0200 Subject: [PATCH 2/9] Align total weakest preconditions with Iris-Coq --- Iris/Iris/ProgramLogic/TotalAdequacy.lean | 448 +++++++++++++++++++ Iris/Iris/ProgramLogic/TotalEctxLifting.lean | 133 +++++- Iris/Iris/ProgramLogic/TotalLifting.lean | 90 +++- Iris/Iris/ProgramLogic/TotalWeakestPre.lean | 246 +++++++++- Iris/Iris/Tests.lean | 1 + Iris/Iris/Tests/TotalWeakestPre.lean | 375 ++++++++++++++++ 6 files changed, 1252 insertions(+), 41 deletions(-) create mode 100644 Iris/Iris/Tests/TotalWeakestPre.lean diff --git a/Iris/Iris/ProgramLogic/TotalAdequacy.lean b/Iris/Iris/ProgramLogic/TotalAdequacy.lean index 0704833d7..930a3ef03 100644 --- a/Iris/Iris/ProgramLogic/TotalAdequacy.lean +++ b/Iris/Iris/ProgramLogic/TotalAdequacy.lean @@ -20,8 +20,15 @@ open Language Language.Notation relation is flipped. This definition is constructive and means that every reduction tree rooted at the configuration is finite (strong normalization), not merely that some execution terminates. + +The fork-aware thread-pool predicate below is kept because it is part of the +Iris-Rocq adequacy argument. Thread-pool ghost-state convenience APIs are not +ported: they are unrelated to establishing total-WP termination for the +initial single-threaded Wasm client. Fair termination, trace-sensitive +liveness, and coinductive progress are intentionally outside this layer. -/ +@[rocq_alias sn] def StronglyNormalizing {α : Type _} (step : α → α → Prop) (x : α) : Prop := Acc (flip step) x @@ -41,10 +48,435 @@ theorem tail {α : Type _} {step : α → α → Prop} {x y : α} StronglyNormalizing step y := H.inv Hxy +theorem map {α β : Type _} {stepα : α → α → Prop} + {stepβ : β → β → Prop} (f : β → α) + (Hlift : ∀ x y, stepβ x y → stepα (f x) (f y)) + {x : β} (H : StronglyNormalizing stepα (f x)) : + StronglyNormalizing stepβ x := by + unfold StronglyNormalizing at H ⊢ + generalize hx : f x = z at H + induction H generalizing x with + | intro z Hz IH => + subst z + apply Acc.intro + intro y Hy + exact IH (f y) (Hlift x y Hy) rfl + end StronglyNormalizing variable {Expr State Obs Val : Type _} [Λ : Language Expr State Obs Val] +section ThreadPool + +variable {hlc : HasLC} {GF : BundledGFunctors} +variable [ι : IrisGS_gen hlc Expr GF] + +namespace twptp + +local instance : OFE CoPset := OFE.ofDiscrete _ +local instance : OFE Expr := OFE.ofDiscrete _ +local instance : OFE Val := OFE.ofDiscrete _ + +private theorem step_append_inv (r₁ r₂ t' : List Expr) (σ₁ σ₂ : State) + (κ : List Obs) : + (r₁ ++ r₂, σ₁) -<κ>->ₜₚ (t', σ₂) → + (∃ r₁', (r₁, σ₁) -<κ>->ₜₚ (r₁', σ₂) ∧ + t'.Perm (r₁' ++ r₂)) ∨ + (∃ r₂', (r₂, σ₁) -<κ>->ₜₚ (r₂', σ₂) ∧ + t'.Perm (r₁ ++ r₂')) := by + intro H + generalize hsrc : r₁ ++ r₂ = src at H + generalize hdst : t' = dst at H + cases H with + | @atomic e σ obs e' σ' efs Hprim p q => + rcases List.append_eq_append_iff.mp hsrc.symm with + (⟨mid, hr₁, heq⟩ | ⟨bs, hp, hr₂⟩) + · cases mid with + | nil => + simp only [List.append_nil] at hr₁ + simp only [List.nil_append] at heq + subst r₁ + subst r₂ + exact .inr ⟨e' :: q ++ efs, .atomic Hprim [] q, by simp⟩ + | cons a tail => + simp only [List.cons_append, List.cons.injEq] at heq + obtain ⟨rfl, hq⟩ := heq + subst r₁ + subst q + refine .inl ⟨p ++ e' :: tail ++ efs, .atomic Hprim p tail, ?_⟩ + have hp := List.Perm.append_left (p ++ [e']) + (List.Perm.append_left tail + (List.perm_append_comm : + (r₂ ++ efs).Perm (efs ++ r₂))) + simpa only [List.append_assoc, List.singleton_append, + List.cons_append, List.nil_append] using hp + · subst p + subst r₂ + refine .inr ⟨bs ++ e' :: q ++ efs, .atomic Hprim bs q, ?_⟩ + simp only [List.append_assoc] + exact .refl _ + +local instance : OFE (List Expr) := OFE.ofDiscrete _ + +/-- One unfolding of the total thread-pool predicate. Every possible pool step +must be silent, preserve the state interpretation, and recursively establish +the predicate for the complete successor pool. -/ +@[rocq_alias twptp_pre] +def pre (X : List Expr → IProp GF) (t₁ : List Expr) : IProp GF := iprop( + ∀ (t₂ : List Expr) (σ₁ : State) (ns : Nat) (κ κs : List Obs) + (σ₂ : State) (nt : Nat), + ⌜(t₁, σ₁) -<κ>->ₜₚ (t₂, σ₂)⌝ -∗ + stateInterp σ₁ ns κs nt ={⊤}=∗ + ∃ nt', ⌜κ = []⌝ ∗ stateInterp σ₂ (ns + 1) κs nt' ∗ X t₂) + +instance pre_mono_inst : BIMonoPred (pre (ι := ι)) where + mono_pred := by + intro X Y _ _ + iintro #HXY %t₁ Hpre + unfold pre + iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep Hσ + imod Hpre $$ %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep Hσ with + ⟨%nt', %hκ, Hσ, HX⟩ + imodintro + iexists nt' + iframe %hκ Hσ + iapply HXY $$ %t₂ HX + mono_pred_ne.ne {X} t₁ t₂ ht := by + change t₁ = t₂ at ht + subst t₂ + rfl + +@[rocq_alias twptp_pre_mono] +theorem pre_mono (X Y : List Expr → IProp GF) + [NonExpansive X] [NonExpansive Y] : + ⊢ □ (∀ t, X t -∗ Y t) -∗ + ∀ t, pre (ι := ι) X t -∗ pre (ι := ι) Y t := + mono_pred (F := pre (ι := ι)) + +/-- Least-fixed-point predicate governing all future reductions of a thread +pool. This is the direct Lean counterpart of Iris-Coq's `twptp`. -/ +@[rocq_alias twptp] +def get (t : List Expr) : IProp GF := + bi_least_fixpoint (pre (ι := ι)) t + +instance get_ne : NonExpansive (get (ι := ι)) := by + constructor + intro n x y hxy + change x = y at hxy + subst y + rfl + +@[rocq_alias twptp_unfold] +theorem unfold (t : List Expr) : + get (ι := ι) t ⊣⊢ pre (ι := ι) (get (ι := ι)) t := by + exact BI.equiv_iff.1 (least_fixpoint_unfold (pre (ι := ι))) + +@[rocq_alias twptp_ind] +theorem induction (Ψ : List Expr → IProp GF) [NonExpansive Ψ] : + (⊢ □ ∀ t, pre (ι := ι) (fun t => iprop(Ψ t ∧ get (ι := ι) t)) t -∗ Ψ t) → + ⊢ ∀ t, get (ι := ι) t -∗ Ψ t := by + intro H + have H' : ⊢ □ ∀ t, + pre (ι := ι) (fun t => iprop(Ψ t ∧ + bi_least_fixpoint (pre (ι := ι)) t)) t -∗ Ψ t := by + simpa only [get] using H + iintro %t + change ⊢ bi_least_fixpoint (pre (ι := ι)) t -∗ Ψ t + iintro Ht + iapply least_fixpoint_ind (F := pre (ι := ι)) (Φ := Ψ) $$ [] Ht + iintro !> %t' Hpre + iapply H' $$ %t' Hpre + +private theorem fold_right (Ψ : List Expr → IProp GF) [NonExpansive Ψ] + (t : List Expr) : + pre (ι := ι) (fun t => iprop(Ψ t ∧ get (ι := ι) t)) t ⊢ + get (ι := ι) t := by + letI : NonExpansive + (fun t => iprop(Ψ t ∧ get (ι := ι) t)) := by + constructor + intro n x y hxy + change x = y at hxy + subst y + rfl + rw [(twptp.unfold (ι := ι) t).to_eq] + iintro Hpre + iapply mono_pred (F := pre (ι := ι)) $$ [] %t Hpre + iintro !> %u Hu + icases Hu with ⟨-, Hu⟩ + iexact Hu + +@[rocq_alias twptp_Permutation] +theorem permutation {t₁ t₁' : List Expr} (Hp : t₁.Perm t₁') : + get (ι := ι) t₁ ⊢ get (ι := ι) t₁' := by + let Ψ := fun t : List Expr => iprop( + ∀ t', ⌜t.Perm t'⌝ -∗ get (ι := ι) t') + have hΨ : NonExpansive Ψ := by + constructor + intro n x y hxy + change x = y at hxy + subst y + rfl + letI := hΨ + iintro Ht + iapply induction Ψ (ι := ι) ?_ $$ %t₁ Ht %t₁' %Hp + iintro !> %t Hpre %t' %Htt' + rw [(twptp.unfold (ι := ι) t').to_eq] + unfold pre + iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep Hσ + obtain ⟨t₂', H₂perm, Hstep'⟩ := + Language.perm_of_step (t₁ := t') (t₁' := t) Htt'.symm Hstep + imod Hpre $$ %t₂' %σ₁ %ns %κ %κs %σ₂ %nt %Hstep' Hσ with + ⟨%nt', %hκ, Hσ, HIH⟩ + icases HIH with ⟨HIH, -⟩ + imodintro + iexists nt' + iframe %hκ Hσ + iapply HIH $$ %t₂ %H₂perm.symm + +@[rocq_alias twptp_app] +theorem app (t₁ t₂ : List Expr) : + get (ι := ι) t₁ -∗ get (ι := ι) t₂ -∗ get (ι := ι) (t₁ ++ t₂) := by + let Ψ₁ := fun t₁ : List Expr => iprop( + ∀ t₂, get (ι := ι) t₂ -∗ get (ι := ι) (t₁ ++ t₂)) + have hΨ₁ : NonExpansive Ψ₁ := by + constructor + intro n x y hxy + change x = y at hxy + subst y + rfl + letI := hΨ₁ + iintro H₁ + iapply induction Ψ₁ (ι := ι) ?_ $$ %t₁ H₁ %t₂ + let Ψ₂ := fun t₂ : List Expr => iprop( + ∀ t₁, pre (ι := ι) + (fun t => iprop(Ψ₁ t ∧ get (ι := ι) t)) t₁ -∗ + get (ι := ι) (t₁ ++ t₂)) + have hΨ₂ : NonExpansive Ψ₂ := by + constructor + intro n x y hxy + change x = y at hxy + subst y + rfl + letI := hΨ₂ + iintro !> %u₁ Hu₁ %u₂ Hu₂ + iapply induction Ψ₂ (ι := ι) ?_ $$ %u₂ Hu₂ %u₁ Hu₁ + iintro !> %r₂ Hr₂ %r₁ Hr₁ + rw [(twptp.unfold (ι := ι) (r₁ ++ r₂)).to_eq] + unfold pre + iintro %t' %σ₁ %ns %κ %κs %σ₂ %nt %Hstep Hσ + rcases step_append_inv r₁ r₂ t' σ₁ σ₂ κ Hstep with + (⟨r₁', Hstep₁, Hperm⟩ | ⟨r₂', Hstep₂, Hperm⟩) + · imod Hr₁ $$ %r₁' %σ₁ %ns %κ %κs %σ₂ %nt %Hstep₁ Hσ with + ⟨%nt', %hκ, Hσ, Hr₁'⟩ + icases Hr₁' with ⟨IH₁, -⟩ + imodintro + iexists nt' + iframe %hκ Hσ + iapply permutation Hperm.symm + iapply IH₁ $$ %r₂ + iapply fold_right Ψ₂ r₂ (ι := ι) + unfold pre + iexact Hr₂ + · imod Hr₂ $$ %r₂' %σ₁ %ns %κ %κs %σ₂ %nt %Hstep₂ Hσ with + ⟨%nt', %hκ, Hσ, Hr₂'⟩ + icases Hr₂' with ⟨IH₂, -⟩ + imodintro + iexists nt' + iframe %hκ Hσ + iapply permutation Hperm.symm + iapply IH₂ $$ %r₁ + unfold pre + iexact Hr₁ + +private theorem cons (e : Expr) (es : List Expr) : + get (ι := ι) [e] -∗ get (ι := ι) es -∗ get (ι := ι) (e :: es) := by + simpa only [List.singleton_append] using app [e] es (ι := ι) + +private theorem cons_sep (e : Expr) (es : List Expr) : + get (ι := ι) [e] ∗ get (ι := ι) es ⊢ get (ι := ι) (e :: es) := by + iintro H + icases H with ⟨He, Hes⟩ + iapply cons e es (ι := ι) $$ He Hes + +@[rocq_alias twptp_nil] +theorem nil : ⊢ get (ι := ι) ([] : List Expr) := by + rw [(twptp.unfold (ι := ι) []).to_eq] + unfold pre + iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep + exfalso + generalize hsrc : ([] : List Expr) = src at Hstep + cases Hstep with + | @atomic e σ obs e' σ' efs Hprim p q => + simp at hsrc + +private theorem step_singleton_inv (e : Expr) (t₂ : List Expr) + (σ₁ σ₂ : State) (κ : List Obs) : + ([e], σ₁) -<κ>->ₜₚ (t₂, σ₂) → + ∃ e₂ efs, (e, σ₁) -<κ>-> (e₂, σ₂, efs) ∧ t₂ = e₂ :: efs := by + intro H + generalize hsrc : [e] = src at H + generalize hdst : t₂ = dst at H + cases H with + | @atomic red σ obs red' σ' efs Hprim p q => + have hpq : p = [] ∧ red = e ∧ q = [] := by + rcases List.append_eq_singleton_iff.mp hsrc.symm with + (⟨hp, hrest⟩ | ⟨hp, hrest⟩) + · subst p + simp only [List.cons.injEq] at hrest + exact ⟨rfl, hrest.1, hrest.2⟩ + · simp at hrest + obtain ⟨rfl, rfl, rfl⟩ := hpq + exact ⟨red', efs, Hprim, by simp_all⟩ + +private theorem singleton_list (es : List Expr) : + ([∗list] e ∈ es, get (ι := ι) [e]) ⊢ get (ι := ι) es := by + induction es with + | nil => + simp only [Algebra.BigOpL.bigOpL_nil] + iintro _ + exact nil (ι := ι) + | cons e es IH => + simp only [Algebra.BigOpL.bigOpL_cons] + iintro Hes + icases Hes with ⟨He, Hes⟩ + rw [show e :: es = [e] ++ es by simp] + iapply app [e] es (ι := ι) $$ He + iapply IH + iexact Hes + +@[rocq_alias twp_twptp] +theorem of_twp (s : Stuckness) (e : Expr) (Φ : Val → IProp GF) : + WP e @ s ; ⊤ [{ Φ }] ⊢ get (ι := ι) [e] := by + let Ψ := fun (E : CoPset) (e : Expr) (_ : Val → IProp GF) => iprop( + ⌜E = ⊤⌝ -∗ get (ι := ι) [e]) + have hΨ : NonExpansive + (fun x : twp.Args Expr Val GF => Ψ x.1.1 x.1.2 x.2) := by + constructor + intro n x y hxy + rcases x with ⟨⟨EX, eX⟩, ΦX⟩ + rcases y with ⟨⟨EY, eY⟩, ΦY⟩ + rcases hxy with ⟨⟨hE, he⟩, _⟩ + change EX = EY at hE + change eX = eY at he + subst EY + subst eY + rfl + letI := hΨ + iintro He + iapply twp.induction s Ψ (ι := ι) ?_ $$ He %rfl + iintro !> %E %e %Φ + cases he : toVal e with + | some v => + simp only [twp.pre, he] + iintro _ %hE + subst E + rw [(twptp.unfold (ι := ι) [e]).to_eq] + unfold pre + iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep + obtain ⟨e₂, efs, Hprim, rfl⟩ := + step_singleton_inv e t₂ σ₁ σ₂ κ Hstep + have hnone := Language.val_stuck Hprim + rw [he] at hnone + cases hnone + | none => + simp only [twp.pre, he] + iintro Hpre %hE + subst E + rw [(twptp.unfold (ι := ι) [e]).to_eq] + unfold pre + iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep Hσ + obtain ⟨e₂, efs, Hprim, rfl⟩ := + step_singleton_inv e t₂ σ₁ σ₂ κ Hstep + imod Hpre $$ %σ₁ %ns %κs %nt Hσ with ⟨%_, Hpre⟩ + imod Hpre $$ %κ %e₂ %σ₂ %efs %Hprim with + ⟨%hκ, Hσ, He₂, Hefs⟩ + icases He₂ with ⟨IH₂, -⟩ + imodintro + iexists (nt + efs.length) + iframe %hκ Hσ + iapply cons_sep e₂ efs (ι := ι) + isplitl [IH₂] + · iapply IH₂ $$ %rfl + · iapply singleton_list efs (ι := ι) + iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef Hef + icases Hef with ⟨IHef, -⟩ + iapply IHef $$ %rfl + +end twptp + +local instance : OFE (List Expr) := OFE.ofDiscrete _ + +@[rocq_alias twptp_total] +theorem twptp_total (t : List Expr) (σ : State) (ns nt : Nat) : + stateInterp σ ns ([] : List Obs) nt -∗ twptp.get (ι := ι) t + ={⊤|}=∗ ⌜StronglyNormalizing + (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) + (t, σ)⌝ := by + let Ψ := fun t : List Expr => iprop( + ∀ (σ : State) (ns nt : Nat), + StateInterp.stateInterp (GF := GF) σ ns ([] : List Obs) nt -∗ + |={⊤|}=> ⌜StronglyNormalizing + (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) + (t, σ)⌝) + have hΨ : NonExpansive Ψ := by + constructor + intro n x y hxy + change x = y at hxy + subst y + rfl + letI := hΨ + iintro Hσ Ht + iapply twptp.induction Ψ (ι := ι) ?_ $$ %t Ht %σ %ns %nt Hσ + iintro !> %t + unfold twptp.pre + iintro Hpre %σ %ns %nt Hσ + iapply fupd_finally_mono (pure_mono StronglyNormalizing.intro) + iintro %cfg₂ %Hstep + rcases cfg₂ with ⟨t₂, σ₂⟩ + obtain ⟨κ, Hstep⟩ := Hstep + imod Hpre $$ %t₂ %σ %ns %κ %([] : List Obs) %σ₂ %nt %Hstep Hσ with + ⟨%nt', %hκ, Hσ, Ht₂⟩ + icases Ht₂ with ⟨IH, -⟩ + iapply IH $$ %σ₂ %(ns + 1) %nt' Hσ + +end ThreadPool + +omit Λ in +/-- General total adequacy. An initialized state interpretation together with +a total weakest precondition entails strong normalization of the complete +fork-aware language configuration. As in Iris-Coq, the chosen +`numLatersPerStep` is abstract because TWP itself does not inspect it. -/ +@[rocq_alias twp_total] +theorem twp_total {hlc : HasLC} {GF : BundledGFunctors} + [InvGpreS GF] [Language Expr State Obs Val] + (s : Stuckness) (e : Expr) (σ : State) + (Φ : Val → IProp GF) (n m : Nat) + (Hwp : ∀ [InvGS_gen hlc GF], + ⊢ |={⊤}=> + ∃ (stateI : State → Nat → List Obs → Nat → IProp GF) + (numLatersPerStep : Nat → Nat) + (forkPost : Val → IProp GF) + (mono : ∀ σ ns obs nt, + stateI σ ns obs nt ⊢ |={∅}=> stateI σ (ns + 1) obs nt), + let _ : IrisGS_gen hlc Expr GF := + .mk (toStateInterp := ⟨stateI⟩) numLatersPerStep forkPost mono + iprop(stateI σ n [] 0 ∗ + (£ m -∗ WP e @ s ; ⊤ [{ Φ }]))) : + StronglyNormalizing + (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) + ([e], σ) := by + apply pure_soundness (PROP := IProp GF) + apply fupd_finally_soundness hlc m ⊤ + iintro %Hinv Hcred + imod Hwp with + ⟨%stateI, %numLatersPerStep, %forkPost, %mono, Hσ, Htwp⟩ + letI iG : IrisGS_gen hlc Expr GF := + .mk (toStateInterp := ⟨stateI⟩) numLatersPerStep forkPost mono + iapply twptp_total [e] σ n 0 (ι := iG) $$ Hσ + iapply twptp.of_twp s e Φ (ι := iG) + iapply Htwp $$ Hcred + /-- Erased single-thread reduction. Forked expressions remain visible in the step witness; clients can rule them out with `LanguageNoFork`. -/ def ExprErasedStep : Expr × State → Expr × State → Prop @@ -67,6 +499,22 @@ theorem exprErasedStep_noFork [LanguageNoFork Expr State Obs Val] {e₁ σ₁ e subst efs exact ⟨κ, Hstep⟩ +/-- A fork-aware total-adequacy result specializes to the single-expression +machine when the language proves that primitive steps never fork. -/ +theorem stronglyNormalizing_expr_of_threadPool + [LanguageNoFork Expr State Obs Val] {e : Expr} {σ : State} + (H : StronglyNormalizing + (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) + ([e], σ)) : + StronglyNormalizing + (ExprErasedStep (Expr := Expr) (State := State) (Obs := Obs)) + (e, σ) := by + apply StronglyNormalizing.map (fun ρ : Expr × State => ([ρ.1], ρ.2)) ?_ H + rintro ⟨e₁, σ₁⟩ ⟨e₂, σ₂⟩ ⟨κ, efs, Hstep⟩ + have hefs : efs = [] := LanguageNoFork.no_fork Hstep + subst efs + exact ⟨κ, .atomic Hstep [] []⟩ + theorem value_stronglyNormalizing (v : Val) (σ : State) : StronglyNormalizing (ExprErasedStep (Expr := Expr) (Obs := Obs)) ((v : Expr), σ) := by diff --git a/Iris/Iris/ProgramLogic/TotalEctxLifting.lean b/Iris/Iris/ProgramLogic/TotalEctxLifting.lean index d429c5b96..fd4d032c8 100644 --- a/Iris/Iris/ProgramLogic/TotalEctxLifting.lean +++ b/Iris/Iris/ProgramLogic/TotalEctxLifting.lean @@ -26,9 +26,35 @@ variable {GF : BundledGFunctors} [ι : IrisGS_gen hlc Expr GF] variable {s : Stuckness} {E : CoPset} {e₁ e₂ : Expr} variable {Φ : Val → IProp GF} +@[rocq_alias twp_lift_base_step] +theorem twp_lift_base_step (h : toVal e₁ = none) : + (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E,∅}=∗ + ⌜BaseStep.ReducibleNoObs (e₁, σ₁)⌝ ∗ + ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>->ᵇ (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ + ⌜κ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ + WP e₂ @ s; E [{ Φ }] ∗ + [∗list] ef ∈ eₜ, WP ef @ s; ⊤ [{ ι.forkPost }]) + ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro H + iapply twp_lift_step h + iintro %σ₁ %ns %obs %nt Hσ + imod H $$ Hσ with ⟨%Hred, H⟩ + imodintro + isplit + · ipureintro + cases s + · exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs + Hred + · trivial + · iintro %κ %e₂ %σ₂ %eₜ %Hstep + have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible + (BaseStep.reducible_of_reducibleNoObs Hred) Hstep + iapply H $$ %κ %e₂ %σ₂ %eₜ %Hb + theorem twp_lift_base_step_no_fork (h : toVal e₁ = none) : (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E,∅}=∗ - ⌜BaseStep.Reducible (e₁, σ₁)⌝ ∗ + ⌜BaseStep.ReducibleNoObs (e₁, σ₁)⌝ ∗ ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>->ᵇ (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ ⌜κ = []⌝ ∗ ⌜eₜ = []⌝ ∗ stateInterp σ₂ (ns + 1) obs nt ∗ @@ -42,30 +68,111 @@ theorem twp_lift_base_step_no_fork (h : toVal e₁ = none) : isplit · ipureintro cases s - · exact EctxLanguage.primStep_reducible_of_baseStep_reducible Hred + · exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs Hred + · trivial + · iintro %κ %e₂ %σ₂ %eₜ %Hstep + have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible + (BaseStep.reducible_of_reducibleNoObs Hred) Hstep + iapply H $$ %κ %e₂ %σ₂ %eₜ %Hb + +@[rocq_alias twp_lift_pure_base_step_no_fork] +theorem twp_lift_pure_base_step_no_fork [Inhabited State] + (Hred : ∀ σ, BaseStep.ReducibleNoObs (e₁, σ)) + (Hpure : ∀ σ₁ κ e₂' σ₂ eₜ, + (e₁, σ₁) -<κ>->ᵇ (e₂', σ₂, eₜ) → + κ = [] ∧ σ₂ = σ₁ ∧ eₜ = []) : + (|={E}=> ∀ κ e₂' eₜ σ, + ⌜(e₁, σ) -<κ>->ᵇ (e₂', σ, eₜ)⌝ -∗ + WP e₂' @ s; E [{ Φ }]) + ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro H + iapply twp_lift_pure_step_no_fork + · intro σ + exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs + (Hred σ) + · intro σ₁ κ e₂' σ₂ eₜ Hstep + exact Hpure _ _ _ _ _ + (EctxLanguage.baseStep_of_primStep_of_baseStep_reducible + (BaseStep.reducible_of_reducibleNoObs (Hred σ₁)) Hstep) + · imod H with H + imodintro + iintro %κ %e₂' %eₜ %σ %Hstep + have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible + (BaseStep.reducible_of_reducibleNoObs (Hred σ)) Hstep + iapply H $$ %κ %e₂' %eₜ %σ %Hb + +@[rocq_alias twp_lift_atomic_base_step] +theorem twp_lift_atomic_base_step (h : toVal e₁ = none) : + (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E}=∗ + ⌜BaseStep.ReducibleNoObs (e₁, σ₁)⌝ ∗ + ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>->ᵇ (e₂, σ₂, eₜ)⌝ ={E}=∗ + ⌜κ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ + (∃ v, ⌜toVal e₂ = some v⌝ ∧ Φ v) ∗ + [∗list] ef ∈ eₜ, WP ef @ s; ⊤ [{ ι.forkPost }]) + ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro H + iapply twp_lift_atomic_step h + iintro %σ₁ %ns %obs %nt Hσ + imod H $$ Hσ with ⟨%Hred, H⟩ + imodintro + isplit + · ipureintro + cases s + · exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs + Hred · trivial · iintro %κ %e₂ %σ₂ %eₜ %Hstep - have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible Hred Hstep + have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible + (BaseStep.reducible_of_reducibleNoObs Hred) Hstep iapply H $$ %κ %e₂ %σ₂ %eₜ %Hb +@[rocq_alias twp_lift_atomic_base_step_no_fork] +theorem twp_lift_atomic_base_step_no_fork (h : toVal e₁ = none) : + (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E}=∗ + ⌜BaseStep.ReducibleNoObs (e₁, σ₁)⌝ ∗ + ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>->ᵇ (e₂, σ₂, eₜ)⌝ ={E}=∗ + ⌜κ = []⌝ ∗ ⌜eₜ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs nt ∗ + ∃ v, ⌜toVal e₂ = some v⌝ ∧ Φ v) + ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro H + iapply twp_lift_atomic_step_no_fork h + iintro %σ₁ %ns %obs %nt Hσ + imod H $$ Hσ with ⟨%Hred, H⟩ + imodintro + isplit + · ipureintro + cases s + · exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs + Hred + · trivial + · iintro %κ %e₂ %σ₂ %eₜ %Hstep + have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible + (BaseStep.reducible_of_reducibleNoObs Hred) Hstep + iapply H $$ %κ %e₂ %σ₂ %eₜ %Hb + +/-- Deterministic pure base-step lifting. The explicit non-value premise is +retained to match Iris-Rocq's public theorem, although `Hred` also implies it. -/ +@[rocq_alias twp_lift_pure_det_base_step_no_fork] theorem twp_lift_pure_det_base_step_no_fork [Inhabited State] - (h : toVal e₁ = none) - (Hred : ∀ σ, BaseStep.Reducible (e₁, σ)) + (_h : toVal e₁ = none) + (Hred : ∀ σ, BaseStep.ReducibleNoObs (e₁, σ)) (Hpure : ∀ σ κ e₂' σ₂ eₜ, (e₁, σ) -<κ>->ᵇ (e₂', σ₂, eₜ) → κ = [] ∧ σ₂ = σ ∧ e₂' = e₂ ∧ eₜ = []) : WP e₂ @ s; E [{ Φ }] ⊢ WP e₁ @ s; E [{ Φ }] := by - apply twp_lift_pure_det_step_no_fork + iintro Hwp + iapply twp_lift_pure_det_step_no_fork · intro σ - cases s - · obtain ⟨κ, e', σ', efs, Hb⟩ := Hred σ - have ⟨hκ, _, _, _⟩ := Hpure σ κ e' σ' efs Hb - subst hκ - exact ⟨e', σ', efs, EctxLanguage.primStep_of_baseStep Hb⟩ - · exact h + exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs + (Hred σ) · intro σ κ e₂' σ₂ eₜ Hstep exact Hpure _ _ _ _ _ - (EctxLanguage.baseStep_of_primStep_of_baseStep_reducible (Hred σ) Hstep) + (EctxLanguage.baseStep_of_primStep_of_baseStep_reducible + (BaseStep.reducible_of_reducibleNoObs (Hred σ)) Hstep) + · imodintro + iexact Hwp end end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/TotalLifting.lean b/Iris/Iris/ProgramLogic/TotalLifting.lean index 276a52229..5c61d6fc2 100644 --- a/Iris/Iris/ProgramLogic/TotalLifting.lean +++ b/Iris/Iris/ProgramLogic/TotalLifting.lean @@ -31,7 +31,7 @@ variable {e e₁ e₂ : Expr} {Φ : Val → IProp GF} @[rocq_alias twp_lift_step] theorem twp_lift_step (h : toVal e₁ = none) : (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E,∅}=∗ - ⌜s.MaybeReducible (e₁, σ₁)⌝ ∗ + ⌜s.MaybeReducibleNoObs (e₁, σ₁)⌝ ∗ ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ ⌜κ = []⌝ ∗ stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ @@ -44,7 +44,7 @@ theorem twp_lift_step (h : toVal e₁ = none) : theorem twp_lift_step_no_fork (h : toVal e₁ = none) : (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E,∅}=∗ - ⌜s.MaybeReducible (e₁, σ₁)⌝ ∗ + ⌜s.MaybeReducibleNoObs (e₁, σ₁)⌝ ∗ ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ ⌜κ = []⌝ ∗ ⌜eₜ = []⌝ ∗ stateInterp σ₂ (ns + 1) obs nt ∗ @@ -66,7 +66,7 @@ theorem twp_lift_step_no_fork (h : toVal e₁ = none) : @[rocq_alias twp_lift_atomic_step] theorem twp_lift_atomic_step (h : toVal e₁ = none) : (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E}=∗ - ⌜s.MaybeReducible (e₁, σ₁)⌝ ∗ + ⌜s.MaybeReducibleNoObs (e₁, σ₁)⌝ ∗ ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={E}=∗ ⌜κ = []⌝ ∗ stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ @@ -93,7 +93,7 @@ theorem twp_lift_atomic_step (h : toVal e₁ = none) : theorem twp_lift_atomic_step_no_fork (h : toVal e₁ = none) : (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E}=∗ - ⌜s.MaybeReducible (e₁, σ₁)⌝ ∗ + ⌜s.MaybeReducibleNoObs (e₁, σ₁)⌝ ∗ ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={E}=∗ ⌜κ = []⌝ ∗ ⌜eₜ = []⌝ ∗ stateInterp σ₂ (ns + 1) obs nt ∗ @@ -113,38 +113,82 @@ theorem twp_lift_atomic_step_no_fork (h : toVal e₁ = none) : simp only [List.length_nil, Nat.add_zero, Algebra.BigOpL.bigOpL_nil] iframe %hκ Hσ Hval -theorem twp_lift_pure_det_step_no_fork [Inhabited State] - (Hsafe : ∀ σ₁, match s with - | .NotStuck => PrimStep.ReducibleNoObs (e₁, σ₁) - | .MaybeStuck => toVal e₁ = none) +@[rocq_alias twp_lift_pure_step_no_fork] +theorem twp_lift_pure_step_no_fork [Inhabited State] + (Hsafe : ∀ σ₁, PrimStep.ReducibleNoObs (e₁, σ₁)) (Hpure : ∀ σ₁ κ e₂' σ₂ eₜ, (e₁, σ₁) -<κ>-> (e₂', σ₂, eₜ) → - κ = [] ∧ σ₂ = σ₁ ∧ e₂' = e₂ ∧ eₜ = []) : - WP e₂ @ s; E [{ Φ }] ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro Hwp - have hnone : toVal e₁ = none := by - cases s - · exact Language.toVal_none_of_reducible - (Language.reducible_of_reducibleNoObs (Hsafe default)) - · exact Hsafe default + κ = [] ∧ σ₂ = σ₁ ∧ eₜ = []) : + (|={E}=> ∀ κ e₂' eₜ σ, + ⌜(e₁, σ) -<κ>-> (e₂', σ, eₜ)⌝ -∗ + WP e₂' @ s; E [{ Φ }]) + ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro H + have hnone : toVal e₁ = none := + Language.toVal_none_of_reducible + (Language.reducible_of_reducibleNoObs (Hsafe default)) iapply twp_lift_step_no_fork hnone iintro %σ₁ %ns %obs %nt Hσ + imod H with H iapply fupd_mask_intro Std.LawfulSet.empty_subset iintro Hclose isplit · ipureintro cases s - · exact Language.reducible_of_reducibleNoObs (Hsafe σ₁) + · exact Hsafe σ₁ · trivial · iintro %κ %e₂' %σ₂ %eₜ %Hstep - obtain ⟨rfl, rfl, rfl, rfl⟩ := Hpure _ _ _ _ _ Hstep + obtain ⟨rfl, rfl, rfl⟩ := Hpure _ _ _ _ _ Hstep + imod ι.stateInterp_mono σ₂ ns obs nt $$ Hσ with Hσ imod Hclose - ihave Hmono := ι.stateInterp_mono σ₂ ns obs nt $$ Hσ - imod fupd_mask_mono Std.LawfulSet.empty_subset $$ Hmono with Hσ imodintro - iframe Hσ Hwp - ipureintro - exact ⟨rfl, rfl⟩ + iframe Hσ + isplit + · ipureintro + exact rfl + · isplit + · ipureintro + exact rfl + · iapply H $$ %([] : List Obs) %e₂' %([] : List Expr) %σ₂ %Hstep + +@[rocq_alias twp_lift_pure_det_step_no_fork] +theorem twp_lift_pure_det_step_no_fork [Inhabited State] + (Hsafe : ∀ σ₁, PrimStep.ReducibleNoObs (e₁, σ₁)) + (Hpure : ∀ σ₁ κ e₂' σ₂ eₜ, + (e₁, σ₁) -<κ>-> (e₂', σ₂, eₜ) → + κ = [] ∧ σ₂ = σ₁ ∧ e₂' = e₂ ∧ eₜ = []) : + (|={E}=> WP e₂ @ s; E [{ Φ }]) ⊢ WP e₁ @ s; E [{ Φ }] := by + iintro Hwp + iapply twp_lift_pure_step_no_fork Hsafe ?_ + · intro σ₁ κ e₂' σ₂ eₜ Hstep + obtain ⟨hκ, hσ, _, heₜ⟩ := Hpure _ _ _ _ _ Hstep + exact ⟨hκ, hσ, heₜ⟩ + · imod Hwp with Hwp + imodintro + iintro %κ %e₂' %eₜ %σ %Hstep + obtain ⟨_, _, he₂, _⟩ := Hpure _ _ _ _ _ Hstep + subst e₂' + iexact Hwp + +@[rocq_alias twp_pure_step] +theorem twp_pure_step [Inhabited State] + (Hexec : PureExec φ n e₁ e₂) (Hφ : φ) : + WP e₂ @ s; E [{ Φ }] ⊢ WP e₁ @ s; E [{ Φ }] := by + replace Hexec := Hexec.pureExec Hφ + iinduction Hexec using Relation.Iterate.head_induction_on with + | rfl => + iintro Hwp + iexact Hwp + | @head n e₁ e₃ _ _ IH => + iintro Hwp + obtain ⟨Hsafe, Hdet⟩ := ‹e₁ -ᵖ-> e₃› + iapply twp_lift_pure_det_step_no_fork Hsafe ?_ + · intro σ₁ κ e₂' σ₂ eₜ Hstep + obtain ⟨hκ, hσ, he, heₜ⟩ := Hdet Hstep + exact ⟨hκ, hσ.symm, he.symm, heₜ⟩ + · imodintro + iapply IH + iexact Hwp end end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean index 29d1ea5f7..6c5aef8f2 100644 --- a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean +++ b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean @@ -30,12 +30,28 @@ deliberately not duplicated here. As in Iris-Rocq, TWP only accepts silent operational steps. A language with observable reductions must expose a silent administrative semantics or provide a future trace-sensitive generalization instead of discarding observations. + +For Wasm, traps must therefore be represented deliberately: either as values +in the language's result type, or as non-values excluded by the reducibility +obligation. TWP does not silently reinterpret a stuck trap as successful +termination. -/ variable {hlc : outParam HasLC} {Expr State Obs Val} variable [Λ : Language Expr State Obs Val] variable {GF : BundledGFunctors} [ι : IrisGS_gen hlc Expr GF] +/-- The stuckness-dependent reducibility condition used by total WP. + +Unlike partial WP's `Stuckness.MaybeReducible`, the `NotStuck` case requires +the existence of a *silent* primitive step. This matches Iris-Rocq's +`reducible_no_obs` premise and prevents an observable transition from being +used to justify TWP only to be rejected by the step clause immediately +afterwards. -/ +abbrev Stuckness.MaybeReducibleNoObs : Stuckness → Expr × State → Prop + | .NotStuck, ρ => PrimStep.ReducibleNoObs ρ + | .MaybeStuck, _ => True + namespace twp local instance : OFE CoPset := OFE.ofDiscrete _ @@ -45,6 +61,7 @@ local instance : OFE Val := OFE.ofDiscrete _ abbrev Args (Expr Val : Type _) (GF : BundledGFunctors) := (CoPset × Expr) × (Val → IProp GF) +@[rocq_alias twp_pre] def pre (s : Stuckness) (twp : CoPset → Expr → (Val → IProp GF) → IProp GF) (E : CoPset) (e₁ : Expr) (Φ : Val → IProp GF) : IProp GF := @@ -52,7 +69,7 @@ def pre (s : Stuckness) | some v => iprop(|={E}=> Φ v) | none => iprop(∀ (σ₁ : State) (ns : Nat) (obs : List Obs) (nt : Nat), stateInterp σ₁ ns obs nt ={E,∅}=∗ - ⌜s.MaybeReducible (e₁, σ₁)⌝ ∗ + ⌜s.MaybeReducibleNoObs (e₁, σ₁)⌝ ∗ ∀ (κ : List Obs) e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ ⌜κ = []⌝ ∗ @@ -121,6 +138,36 @@ instance pre'_mono (s : Stuckness) : BIMonoPred (pre' (ι := ι) s) where exact ⟨⟨.rfl, .rfl⟩, hΦ⟩ · exact .rfl +@[rocq_alias twp_pre_mono] +theorem pre_mono (s : Stuckness) + (X Y : CoPset → Expr → (Val → IProp GF) → IProp GF) + [NonExpansive (fun x : Args Expr Val GF => X x.1.1 x.1.2 x.2)] + [NonExpansive (fun x : Args Expr Val GF => Y x.1.1 x.1.2 x.2)] : + ⊢ □ (∀ E e Φ, X E e Φ -∗ Y E e Φ) -∗ + ∀ E e Φ, pre s X E e Φ -∗ pre s Y E e Φ := by + iintro #H %E %e %Φ Hpre + unfold pre + cases hval : toVal e with + | some v => + imod Hpre with Hpre + imodintro + iexact Hpre + | none => + iintro %σ₁ %ns %obs %nt Hσ + imod Hpre $$ Hσ with ⟨%Hred, Hstep⟩ + imodintro + iframe %Hred + iintro %κ %e₂ %σ₂ %eₜ %Hprim + imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with + ⟨%hκ, Hσ, He₂, Hefs⟩ + imodintro + iframe %hκ Hσ + isplitl [He₂] + · iapply H $$ %E %e₂ %Φ He₂ + · iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef Hef + iapply H $$ %⊤ %ef %ι.forkPost Hef + def get (s : Stuckness) (E : CoPset) (e : Expr) (Φ : Val → IProp GF) : IProp GF := letI : OFE CoPset := OFE.ofDiscrete _ letI : OFE Expr := OFE.ofDiscrete _ @@ -314,7 +361,8 @@ theorem atomic {s : Stuckness} {E₁ E₂ : CoPset} {e : Expr} imod He₂ $$ %σ₂ %(ns + 1) %obs %(nt + eₜ.length) Hσ with ⟨%Hred₂, _⟩ exact (Language.not_reducible_iff_irreducible.mpr - (hatom.atomic Hprim)) Hred₂ |>.elim + (hatom.atomic Hprim)) + (Language.reducible_of_reducibleNoObs Hred₂) |>.elim · iintro %κ %e₂ %σ₂ %eₜ %Hprim imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with ⟨%hκ, Hσ, He₂, Hefs⟩ @@ -380,7 +428,7 @@ theorem bind (K : Expr → Expr) [ctx : Language.Context K] isplit · ipureintro cases s - · exact Language.Context.reducible_fill (K := K) Hred + · exact Language.Context.reducibleNoObs_fill (K := K) Hred · trivial · iintro %κ %e₂ %σ₂ %eₜ %HKstep obtain ⟨e₂', rfl, Hprim⟩ := ctx.primStep_fill_inv he HKstep @@ -398,6 +446,131 @@ theorem bind (K : Expr → Expr) [ctx : Language.Context K] · iintro %v Hv iexact Hv +private theorem fold_induction_right + (Ψ : CoPset → Expr → (Val → IProp GF) → IProp GF) + (s : Stuckness) (E : CoPset) (e : Expr) (Φ : Val → IProp GF) : + (match toVal e with + | some v => iprop(|={E}=> Φ v) + | none => iprop( + ∀ (σ₁ : State) (ns : Nat) (obs : List Obs) (nt : Nat), + stateInterp σ₁ ns obs nt ={E,∅}=∗ + ⌜s.MaybeReducibleNoObs (e, σ₁)⌝ ∗ + ∀ (κ : List Obs) e₂ σ₂ eₜ, + ⌜(e, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ + ⌜κ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ + (Ψ E e₂ Φ ∧ WP e₂ @ s ; E [{ Φ }]) ∗ + [∗list] e' ∈ eₜ, + (Ψ ⊤ e' ι.forkPost ∧ + WP e' @ s ; ⊤ [{ ι.forkPost }]))) ⊢ + WP e @ s ; E [{ Φ }] := by + rw [unfold.to_eq] + unfold pre + cases hval : toVal e with + | some => + exact .rfl + | none => + iintro H + iintro %σ₁ %ns %obs %nt Hσ + imod H $$ Hσ with ⟨%Hred, Hstep⟩ + imodintro + iframe %Hred + iintro %κ %e₂ %σ₂ %eₜ %Hprim + imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with + ⟨%hκ, Hσ, He₂, Hefs⟩ + imodintro + iframe %hκ Hσ + isplitl [He₂] + · icases He₂ with ⟨-, He₂⟩ + iexact He₂ + · iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef Hef + icases Hef with ⟨-, Hef⟩ + iexact Hef + +@[rocq_alias twp_bind_inv] +theorem bind_inv (K : Expr → Expr) [ctx : Language.Context K] + {s : Stuckness} {E : CoPset} {e : Expr} {Φ : Val → IProp GF} : + WP (K e) @ s ; E [{ Φ }] ⊢ + TotalWp.totalWp s E e + (fun v : Val => iprop(WP (K (v : Expr)) @ s ; E [{ Φ }])) := by + let Pred := fun (E : CoPset) (e' : Expr) (Φ : Val → IProp GF) => iprop( + ∀ e, ⌜e' = K e⌝ -∗ + TotalWp.totalWp s E e + (fun v : Val => iprop(WP (K (v : Expr)) @ s ; E [{ Φ }]))) + have hPred : NonExpansive + (fun x : Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by + constructor + intro n x y hxy + rcases x with ⟨⟨EX, eX⟩, ΦX⟩ + rcases y with ⟨⟨EY, eY⟩, ΦY⟩ + rcases hxy with ⟨⟨hE, he⟩, hΦ⟩ + change EX = EY at hE + change eX = eY at he + subst EY + subst eY + refine BI.forall_ne fun _ => ?_ + refine BI.wand_ne.ne .rfl ?_ + apply NonExpansive.ne + exact fun _ => NonExpansive.ne hΦ + letI := hPred + iintro H + iapply induction s Pred (ι := ι) ?_ $$ H %e %rfl + iintro !> %E %e' %Φ IH %e %heq + subst e' + rw [unfold.to_eq] + unfold pre + cases he : toVal e with + | some v => + dsimp only + have heq := ToVal.coe_of_toVal_eq_some he + subst e + imodintro + iapply fold_induction_right Pred s E (K (v : Expr)) Φ + iexact IH + | none => + dsimp only + have hK : toVal (K e) = none := ctx.toVal_eq_none_fill he + let unfolded := iprop( + ∀ (σ₁ : State) (ns : Nat) (obs : List Obs) (nt : Nat), + stateInterp σ₁ ns obs nt ={E,∅}=∗ + ⌜s.MaybeReducibleNoObs (K e, σ₁)⌝ ∗ + ∀ (κ : List Obs) e₂ σ₂ eₜ, + ⌜(K e, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ + ⌜κ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ + (Pred E e₂ Φ ∧ WP e₂ @ s ; E [{ Φ }]) ∗ + [∗list] e' ∈ eₜ, + (Pred ⊤ e' ι.forkPost ∧ + WP e' @ s ; ⊤ [{ ι.forkPost }])) + have hIH : + (match toVal (K e) with + | some v => iprop(|={E}=> Φ v) + | none => unfolded) ⊢ unfolded := by + simp only [hK] + exact .rfl + icases hIH $$ IH with IH + iintro %σ₁ %ns %obs %nt Hσ + imod IH $$ Hσ with ⟨%Hred, Hstep⟩ + imodintro + isplit + · ipureintro + cases s + · exact Language.Context.reducibleNoObs_fill_inv (K := K) he Hred + · trivial + · iintro %κ %e₂ %σ₂ %eₜ %Hprim + imod Hstep $$ %κ %(K e₂) %σ₂ %eₜ + %(ctx.primStep_fill Hprim) with ⟨%hκ, Hσ, He₂, Hefs⟩ + imodintro + iframe %hκ Hσ + isplitl [He₂] + · icases He₂ with ⟨IH₂, -⟩ + iapply IH₂ $$ %e₂ %rfl + · iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef Hef + icases Hef with ⟨-, Hef⟩ + iexact Hef + @[rocq_alias twp_mono] theorem mono {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} (H : ∀ v, Φ v ⊢ Ψ v) : @@ -483,6 +656,30 @@ theorem wand {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : imodintro iapply H $$ Hv +@[rocq_alias twp_wand_l] +theorem wand_l {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : + (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s ; E [{ Φ }] ⊢ + WP e @ s ; E [{ Ψ }] := by + iintro ⟨H, Hwp⟩ + iapply wand $$ Hwp H + +@[rocq_alias twp_wand_r] +theorem wand_r {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : + WP e @ s ; E [{ Φ }] ∗ (∀ v, Φ v -∗ Ψ v) ⊢ + WP e @ s ; E [{ Ψ }] := by + iintro ⟨Hwp, H⟩ + iapply wand $$ Hwp H + +@[rocq_alias twp_frame_wand] +theorem frame_wand {s : Stuckness} {E} {e : Expr} + {Φ : Val → IProp GF} {R : IProp GF} : + R ⊢ (WP e @ s ; E [{ v, R -∗ Φ v }]) -∗ + WP e @ s ; E [{ Φ }] := by + iintro HR Hwp + iapply wand $$ Hwp + iintro %v HΦ + iapply HΦ $$ HR + @[rocq_alias twp_wp] theorem to_wp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E {{ Φ }} := by @@ -499,7 +696,9 @@ theorem to_wp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : imodintro isplit · ipureintro - cases s <;> simp_all [Stuckness.MaybeReducible] + cases s + · exact Language.reducible_of_reducibleNoObs Hred + · trivial · iintro %e₂ %σ₂ %eₜ %Hstep _ ihave Hnext := H $$ %κ %e₂ %σ₂ %eₜ %Hstep iapply step_fupdN_intro Std.LawfulSet.empty_subset @@ -521,9 +720,10 @@ section ProofMode open ProofMode -variable {s : Stuckness} {E : CoPset} {e : Expr} +variable {s : Stuckness} {E E₁ E₂ : CoPset} {e : Expr} variable {Φ Ψ : Val → IProp GF} {P R : IProp GF} +@[rocq_alias frame_twp] instance frameTwp {p : Bool} [H : ∀ v, Frame p R (Φ v) (Ψ v)] : Frame p R (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Ψ }]) where frame := by @@ -531,6 +731,8 @@ instance frameTwp {p : Bool} [H : ∀ v, Frame p R (Φ v) (Ψ v)] : apply mono exact fun v => (H v).frame +-- Iris-Rocq reuses the module-qualified name `is_except_0_wp` here; that alias +-- is already assigned to partial WP in Lean, so this instance is left unaliased. instance isExcept0Twp : IsExcept0 (WP e @ s ; E [{ Φ }]) where is_except0 := calc iprop(◇ _) @@ -538,6 +740,7 @@ instance isExcept0Twp : IsExcept0 (WP e @ s ; E [{ Φ }]) where _ ⊢ |={E}=> _ := BIFUpdate.except0 _ ⊢ WP e @ s ; E [{ Φ }] := fupd_twp +@[rocq_alias elim_modal_fupd_twp] instance (priority := default + 10) elimModalFupdTwp p : ElimModal True p false iprop(|={E}=> P) P (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where @@ -549,6 +752,7 @@ instance (priority := default + 10) elimModalFupdTwp p : imodintro iapply G $$ H +@[rocq_alias elim_modal_bupd_twp] instance elimModalBupdTwp p : ElimModal True p false iprop(|==> P) P (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where @@ -558,6 +762,38 @@ instance elimModalBupdTwp p : (BIUpdateFUpdate.fupd_of_bupd (E := E))) .rfl |>.trans ?_ apply elimModalFupdTwp _ |>.elim_modal ⟨⟩ +/-- The same diagnostic as partial WP: changing masks through a non-atomic +TWP goal requires an explicit leading update. -/ +@[rocq_alias elim_modal_fupd_twp_wrong_mask] +instance elimModalFupdTwp_wrongMask : + ElimModal (PMError "Goal and eliminated modality must have the same mask. + Use `iapply twp.fupd_twp; imod (fupd_mask_subseteq E₂)` to adjust the mask of your goal to `E₂`") + p false iprop(|={E₂}=> P) iprop(False) + (WP e @ s ; E₁ [{ Φ }]) iprop(False) where + elim_modal := nofun + +@[rocq_alias elim_modal_fupd_twp_atomic] +instance elimModalFupdTwpAtomic : + ElimModal (Language.Atomic ↑s e) p false iprop(|={E₁,E₂}=> P) P + (WP e @ s ; E₁ [{ Φ }]) + (WP e @ s ; E₂ [{ v, |={E₂,E₁}=> Φ v }]) where + elim_modal := by + rintro hatomic + iintro ⟨H, G⟩ + icases BI.intuitionisticallyIf_elim $$ H with H + iapply atomic + imod H + imodintro + iapply G $$ H + +@[rocq_alias elim_modal_fupd_twp_atomic_wrong_mask] +instance elimModalFupdTwpAtomic_wrongMask : + ElimModal (PMError "Goal and eliminated modality must have the same mask. + Use `iapply twp.fupd_twp; imod (fupd_mask_subseteq E₂)` to adjust the mask of your goal to `E₂`") + p false iprop(|={E₁,E₂}=> P) iprop(False) + (WP e @ s ; E₁ [{ Φ }]) iprop(False) where + elim_modal := nofun + end ProofMode end Rules diff --git a/Iris/Iris/Tests.lean b/Iris/Iris/Tests.lean index 9c46a845a..9fdd26d27 100644 --- a/Iris/Iris/Tests.lean +++ b/Iris/Iris/Tests.lean @@ -6,4 +6,5 @@ public import Iris.Tests.Notation public import Iris.Tests.Tactics public import Iris.Tests.HeapLang public import Iris.Tests.Language +public import Iris.Tests.TotalWeakestPre public import Iris.Tests.WeakestPre diff --git a/Iris/Iris/Tests/TotalWeakestPre.lean b/Iris/Iris/Tests/TotalWeakestPre.lean new file mode 100644 index 000000000..f951e022e --- /dev/null +++ b/Iris/Iris/Tests/TotalWeakestPre.lean @@ -0,0 +1,375 @@ +/- +Copyright (c) 2026 Fernando Leal. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +-/ +module + +public import Iris.ProgramLogic.TotalAdequacy +public import Iris.ProgramLogic.TotalLifting +public import Iris.Examples.ClosedProofs +public import Iris.HeapLang.Instances + +namespace Iris.Tests.TotalWeakestPre + +open Iris BI ProgramLogic ProgramLogic.Language ProgramLogic.Language.Notation +open Std LawfulSet + +/-! +An intentionally small total-correctness test language. It is deterministic +except for `branch`: both branch successors decrease the same structural +measure, which checks that TWP proves termination of *all* successors rather +than merely finding a terminating execution. + +`put` changes the machine state, `stuck` has no successor, steps never fork, +and all genuine reductions are silent. The latter two properties model the +initial Wasm integration contract. +-/ + +inductive Expr where + | val : Nat → Expr + | tick : Nat → Expr + | put : Nat → Expr + | branch : Nat → Expr + | observe : Expr + | stuck : Expr +deriving DecidableEq, Repr + +abbrev Val := Nat +abbrev State := Nat +abbrev Obs := Unit + +instance : ToVal Expr Val where + toVal + | .val n => some n + | _ => none + ofVal := .val + coe_of_toVal_eq_some := by + intro e v h + cases e <;> simp_all + toVal_coe := by simp + +inductive Step : Expr → State → List Obs → Expr → State → List Expr → Prop + | tickSucc (n σ) : Step (.tick (n + 1)) σ [] (.tick n) σ [] + | tickZero (σ) : Step (.tick 0) σ [] (.val 0) σ [] + | put (n σ) : Step (.put n) σ [] (.val n) n [] + | branchLeft (n σ) : Step (.branch (n + 1)) σ [] (.branch n) σ [] + | branchRight (n σ) : Step (.branch (n + 1)) σ [] (.tick n) σ [] + | branchZero (σ) : Step (.branch 0) σ [] (.val 0) σ [] + | observe (σ) : Step .observe σ [()] (.val 0) σ [] + +instance : PrimStep Expr State (List Obs) where + primStep + | (e₁, σ₁), κ, (e₂, σ₂, efs) => Step e₁ σ₁ κ e₂ σ₂ efs + +instance : Language Expr State Obs Val where + val_stuck := by + intro e σ κ e' σ' efs H + cases H <;> rfl + +instance : LanguageNoFork Expr State Obs Val where + no_fork H := by cases H <;> rfl + +theorem step_noFork {e₁ e₂ : Expr} {σ₁ σ₂ : State} + {κ : List Obs} {efs : List Expr} + (H : (e₁, σ₁) -<κ>-> (e₂, σ₂, efs)) : efs = [] := by + cases H <;> rfl + +section Proofs + +noncomputable abbrev GF := Iris.Examples.ClosedProofs.GF + +variable [InvGS_gen .hasNoLC GF] + +noncomputable local instance testIrisGS : IrisGS_gen .hasNoLC Expr GF where + toStateInterp := ⟨fun _ _ _ _ => iprop(True)⟩ + numLatersPerStep := fun _ => 0 + forkPost := fun _ => iprop(True) + stateInterp_mono := by + intro σ ns obs nt + iintro _ + imodintro + itrivial + +theorem tick_twp (n : Nat) : + ⊢ WP (Expr.tick n) @ Stuckness.NotStuck ; ⊤ [{ + fun v : Val => (iprop(⌜v = 0⌝) : IProp GF) }] := by + induction n with + | zero => + iapply twp_lift_pure_det_step_no_fork + (e₂ := Expr.val 0) + · intro σ + exact ⟨.val 0, σ, [], Step.tickZero σ⟩ + · intro σ₁ κ e₂' σ₂ efs H + cases H + exact ⟨rfl, rfl, rfl, rfl⟩ + · imodintro + iapply twp.value rfl + ipureintro + rfl + | succ n IH => + iapply twp_lift_pure_det_step_no_fork + (e₂ := Expr.tick n) + · intro σ + exact ⟨.tick n, σ, [], Step.tickSucc n σ⟩ + · intro σ₁ κ e₂' σ₂ efs H + cases H + exact ⟨rfl, rfl, rfl, rfl⟩ + · imodintro + iapply IH + +omit [InvGS_gen .hasNoLC GF] in +theorem tick_purePrimStep_succ (n : Nat) : + Expr.tick (n + 1) -ᵖ-> Expr.tick n where + safe σ := ⟨.tick n, σ, [], Step.tickSucc n σ⟩ + deterministic H := by + cases H + exact ⟨rfl, rfl, rfl, rfl⟩ + +omit [InvGS_gen .hasNoLC GF] in +theorem tick_purePrimStep_zero : + Expr.tick 0 -ᵖ-> Expr.val 0 where + safe σ := ⟨.val 0, σ, [], Step.tickZero σ⟩ + deterministic H := by + cases H + exact ⟨rfl, rfl, rfl, rfl⟩ + +omit [InvGS_gen .hasNoLC GF] in +theorem tick_pureExec (n : Nat) : + PureExec True (n + 1) (Expr.tick n) (Expr.val 0) where + pureExec _ := by + induction n with + | zero => + exact .once tick_purePrimStep_zero + | succ n IH => + exact .head (tick_purePrimStep_succ n) IH + +/-- Checks the no-credit multi-step `PureExec` rule independently of the +structural proof above. -/ +theorem tick_twp_via_pureExec (n : Nat) : + ⊢ WP (Expr.tick n) @ Stuckness.NotStuck ; ⊤ [{ + fun v : Val => (iprop(⌜v = 0⌝) : IProp GF) }] := by + iapply twp_pure_step (tick_pureExec n) trivial + iapply twp.value rfl + ipureintro + rfl + +theorem put_twp (n : Nat) : + ⊢ WP (Expr.put n) @ Stuckness.NotStuck ; ⊤ [{ + fun v : Val => (iprop(⌜v = n⌝) : IProp GF) }] := by + iapply twp_lift_atomic_step_no_fork (e₁ := Expr.put n) rfl + iintro %σ %ns %obs %nt _ + imodintro + isplit + · ipureintro + exact ⟨.val n, n, [], Step.put n σ⟩ + · iintro %κ %e₂ %σ₂ %efs %Hstep + cases Hstep + imodintro + isplit + · ipureintro + rfl + · isplit + · ipureintro + rfl + · isplit + · itrivial + · iexists n + isplit + · ipureintro + rfl + · ipureintro + rfl + +theorem branch_twp (n : Nat) : + ⊢ WP (Expr.branch n) @ Stuckness.NotStuck ; ⊤ [{ + fun v : Val => (iprop(⌜v = 0⌝) : IProp GF) }] := by + induction n with + | zero => + iapply twp_lift_pure_det_step_no_fork + (e₂ := Expr.val 0) + · intro σ + exact ⟨.val 0, σ, [], Step.branchZero σ⟩ + · intro σ₁ κ e₂' σ₂ efs H + cases H + exact ⟨rfl, rfl, rfl, rfl⟩ + · imodintro + iapply twp.value rfl + ipureintro + rfl + | succ n IH => + iapply twp_lift_step_no_fork (e₁ := Expr.branch (n + 1)) rfl + iintro %σ %ns %obs %nt _ + iapply fupd_mask_intro empty_subset + iintro Hclose + isplit + · ipureintro + exact ⟨.branch n, σ, [], Step.branchLeft n σ⟩ + · iintro %κ %e₂ %σ₂ %efs %Hstep + cases Hstep + · imod Hclose + imodintro + isplit + · ipureintro + rfl + · isplit + · ipureintro + rfl + · isplitl [] + · change ⊢ iprop(True) + itrivial + · iapply IH + · imod Hclose + imodintro + isplit + · ipureintro + rfl + · isplit + · ipureintro + rfl + · isplitl [] + · change ⊢ iprop(True) + itrivial + · iapply tick_twp n + +end Proofs + +section CoreRuleChecks + +variable {e : Expr} {Φ : Val → IProp GF} {P : IProp GF} +variable [InvGS_gen .hasNoLC GF] +noncomputable local instance : IrisGS_gen .hasNoLC Expr GF := testIrisGS + +example : + WP e @ Stuckness.NotStuck ; ⊤ [{ Φ }] ⊢ + WP e @ Stuckness.NotStuck ; ⊤ {{ Φ }} := + twp.to_wp + +example : + P ∗ WP e @ Stuckness.NotStuck ; ⊤ [{ Φ }] ⊢ + WP e @ Stuckness.NotStuck ; ⊤ [{ v, P ∗ Φ v }] := + twp.frame_l + +example : + WP (id e) @ Stuckness.NotStuck ; ⊤ [{ Φ }] ⊢ + TotalWp.totalWp Stuckness.NotStuck ⊤ e + (fun v : Val => iprop( + WP (id (v : Expr)) @ Stuckness.NotStuck ; ⊤ [{ Φ }])) := + twp.bind_inv id + +example : + TotalWp.totalWp Stuckness.NotStuck ⊤ e + (fun v : Val => iprop( + WP (id (v : Expr)) @ Stuckness.NotStuck ; ⊤ [{ Φ }])) ⊢ + WP (id e) @ Stuckness.NotStuck ; ⊤ [{ Φ }] := + twp.bind id + +end CoreRuleChecks + +section HeapLangPureSmoke + +open Iris.HeapLang + +variable [InvGS_gen .hasNoLC GF] + +noncomputable local instance heapIrisGS : + IrisGS_gen .hasNoLC Iris.HeapLang.Exp GF where + toStateInterp := ⟨fun _ _ _ _ => iprop(True)⟩ + numLatersPerStep := fun _ => 0 + forkPost := fun _ => iprop(True) + stateInterp_mono := by + intro σ ns obs nt + iintro _ + imodintro + itrivial + +/-- Existing HeapLang `PureExec` instances are immediately reusable by TWP; +HeapLang-specific stateful primitive laws remain intentionally out of scope. -/ +theorem heapLang_add_twp : + ⊢ WP hl(#1 + #2) @ Stuckness.NotStuck ; ⊤ [{ + fun v : Iris.HeapLang.Val => + (iprop(⌜v = hl_val(#3)⌝) : IProp GF) }] := by + iapply twp_pure_step + (instPureExecBinOp (op := .plus) + (v1 := hl_val(#1)) (v2 := hl_val(#2)) (v' := hl_val(#3))) + (by rfl) + iapply twp.value rfl + ipureintro + rfl + +end HeapLangPureSmoke + +theorem branch_stronglyNormalizing (n initialState : Nat) : + StronglyNormalizing + (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) + ([Expr.branch n], initialState) := by + apply twp_total (hlc := .hasNoLC) (GF := GF) + Stuckness.NotStuck (Expr.branch n) initialState + (fun v : Val => (iprop(⌜v = 0⌝) : IProp GF)) 0 0 + iintro %Hinv + imodintro + iexists + (fun (_ : State) (_ : Nat) (_ : List Obs) (_ : Nat) => + (iprop(True) : IProp GF)), + (fun _ => 0), + (fun _ : Val => (iprop(True) : IProp GF)), + (fun _ _ _ _ => by + iintro _ + imodintro + itrivial) + dsimp only + isplitl [] + · itrivial + · iintro _ + iapply branch_twp n + +theorem branch_singleMachine_stronglyNormalizing (n initialState : Nat) : + StronglyNormalizing + (ExprErasedStep (Expr := Expr) (State := State) (Obs := Obs)) + (Expr.branch n, initialState) := + stronglyNormalizing_expr_of_threadPool + (branch_stronglyNormalizing n initialState) + +theorem put_stronglyNormalizing (n initialState : Nat) : + StronglyNormalizing + (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) + ([Expr.put n], initialState) := by + apply twp_total (hlc := .hasNoLC) (GF := GF) + Stuckness.NotStuck (Expr.put n) initialState + (fun v : Val => (iprop(⌜v = n⌝) : IProp GF)) 0 0 + iintro %Hinv + imodintro + iexists + (fun (_ : State) (_ : Nat) (_ : List Obs) (_ : Nat) => + (iprop(True) : IProp GF)), + (fun _ => 0), + (fun _ : Val => (iprop(True) : IProp GF)), + (fun _ _ _ _ => by + iintro _ + imodintro + itrivial) + dsimp only + isplitl [] + · itrivial + · iintro _ + iapply put_twp n + +/-! Negative semantic boundary checks. `stuck` is a non-value without a +successor, and `observe` has only a non-silent successor. Consequently neither +can satisfy the `.NotStuck` reducibility premise of TWP. The no-fork lifting +API separately exposes `eₜ = []` as a proof obligation, so a forking rule +cannot be passed to it. -/ + +example : toVal Expr.stuck = (none : Option Val) := rfl + +example (σ : State) : PrimStep.Irreducible (Expr.stuck, σ) := by + intro κ e₂ σ₂ efs H + cases H + +example (σ : State) : PrimStep.Reducible (Expr.observe, σ) := + ⟨[()], .val 0, σ, [], Step.observe σ⟩ + +example (σ : State) : ¬ PrimStep.ReducibleNoObs (Expr.observe, σ) := by + rintro ⟨e₂, σ₂, efs, H⟩ + cases H + +end Iris.Tests.TotalWeakestPre From 3d9ecf13c89946a877fceb048a389e1596808157 Mon Sep 17 00:00:00 2001 From: Marcelo Fornet Date: Thu, 30 Jul 2026 12:51:14 +0200 Subject: [PATCH 3/9] Adapt TWP proof-mode instances to InOut --- Iris/Iris/ProgramLogic/TotalWeakestPre.lean | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean index 6c5aef8f2..7c17b2b40 100644 --- a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean +++ b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean @@ -742,7 +742,7 @@ instance isExcept0Twp : IsExcept0 (WP e @ s ; E [{ Φ }]) where @[rocq_alias elim_modal_fupd_twp] instance (priority := default + 10) elimModalFupdTwp p : - ElimModal True p false iprop(|={E}=> P) P + ElimModal True p io false iprop(|={E}=> P) P (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where elim_modal := by iintro %_ ⟨H, G⟩ @@ -754,13 +754,13 @@ instance (priority := default + 10) elimModalFupdTwp p : @[rocq_alias elim_modal_bupd_twp] instance elimModalBupdTwp p : - ElimModal True p false iprop(|==> P) P + ElimModal True p io false iprop(|==> P) P (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where elim_modal := by rintro ⟨⟩ refine BI.sep_mono (BI.intuitionisticallyIf_mono (BIUpdateFUpdate.fupd_of_bupd (E := E))) .rfl |>.trans ?_ - apply elimModalFupdTwp _ |>.elim_modal ⟨⟩ + apply elimModalFupdTwp _ |>.elim_modal ⟨⟩ (io := io) /-- The same diagnostic as partial WP: changing masks through a non-atomic TWP goal requires an explicit leading update. -/ @@ -768,13 +768,13 @@ TWP goal requires an explicit leading update. -/ instance elimModalFupdTwp_wrongMask : ElimModal (PMError "Goal and eliminated modality must have the same mask. Use `iapply twp.fupd_twp; imod (fupd_mask_subseteq E₂)` to adjust the mask of your goal to `E₂`") - p false iprop(|={E₂}=> P) iprop(False) + p io false iprop(|={E₂}=> P) iprop(False) (WP e @ s ; E₁ [{ Φ }]) iprop(False) where elim_modal := nofun @[rocq_alias elim_modal_fupd_twp_atomic] instance elimModalFupdTwpAtomic : - ElimModal (Language.Atomic ↑s e) p false iprop(|={E₁,E₂}=> P) P + ElimModal (Language.Atomic ↑s e) p io false iprop(|={E₁,E₂}=> P) P (WP e @ s ; E₁ [{ Φ }]) (WP e @ s ; E₂ [{ v, |={E₂,E₁}=> Φ v }]) where elim_modal := by @@ -790,7 +790,7 @@ instance elimModalFupdTwpAtomic : instance elimModalFupdTwpAtomic_wrongMask : ElimModal (PMError "Goal and eliminated modality must have the same mask. Use `iapply twp.fupd_twp; imod (fupd_mask_subseteq E₂)` to adjust the mask of your goal to `E₂`") - p false iprop(|={E₁,E₂}=> P) iprop(False) + p io false iprop(|={E₁,E₂}=> P) iprop(False) (WP e @ s ; E₁ [{ Φ }]) iprop(False) where elim_modal := nofun From 035bf1029d1fe26d7dd04a4cf509f56ad2825a52 Mon Sep 17 00:00:00 2001 From: Marcelo Fornet Date: Tue, 4 Aug 2026 21:14:15 +0200 Subject: [PATCH 4/9] Address total WP review feedback --- Iris/Iris/ProgramLogic/TotalAdequacy.lean | 10 +++++----- Iris/Iris/ProgramLogic/TotalEctxLifting.lean | 9 ++++----- Iris/Iris/ProgramLogic/TotalLifting.lean | 8 ++++---- Iris/Iris/ProgramLogic/TotalWeakestPre.lean | 13 ++++++------- Iris/Iris/Tests/TotalWeakestPre.lean | 6 +++--- 5 files changed, 22 insertions(+), 24 deletions(-) diff --git a/Iris/Iris/ProgramLogic/TotalAdequacy.lean b/Iris/Iris/ProgramLogic/TotalAdequacy.lean index 930a3ef03..06e2e6762 100644 --- a/Iris/Iris/ProgramLogic/TotalAdequacy.lean +++ b/Iris/Iris/ProgramLogic/TotalAdequacy.lean @@ -1,5 +1,5 @@ /- -Copyright (c) 2026 Fernando Leal. All rights reserved. +Copyright (c) 2026 Marcelo Fornet. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -/ module @@ -23,9 +23,9 @@ not merely that some execution terminates. The fork-aware thread-pool predicate below is kept because it is part of the Iris-Rocq adequacy argument. Thread-pool ghost-state convenience APIs are not -ported: they are unrelated to establishing total-WP termination for the -initial single-threaded Wasm client. Fair termination, trace-sensitive -liveness, and coinductive progress are intentionally outside this layer. +ported because they are unrelated to the core total-WP adequacy result. Fair +termination, trace-sensitive liveness, and coinductive progress are +intentionally outside this layer. -/ @[rocq_alias sn] @@ -483,7 +483,7 @@ def ExprErasedStep : Expr × State → Expr × State → Prop | (e₁, σ₁), (e₂, σ₂) => ∃ (κ : List Obs) (efs : List Expr), (e₁, σ₁) -<κ>-> (e₂, σ₂, efs) -/-- The single-threaded language contract used by the Wasm-facing adequacy +/-- The single-threaded language contract used by the no-fork adequacy corollaries. -/ class LanguageNoFork (Expr State Obs Val : Type _) [Language Expr State Obs Val] : Prop where diff --git a/Iris/Iris/ProgramLogic/TotalEctxLifting.lean b/Iris/Iris/ProgramLogic/TotalEctxLifting.lean index fd4d032c8..cde6df973 100644 --- a/Iris/Iris/ProgramLogic/TotalEctxLifting.lean +++ b/Iris/Iris/ProgramLogic/TotalEctxLifting.lean @@ -1,5 +1,5 @@ /- -Copyright (c) 2026 Fernando Leal. All rights reserved. +Copyright (c) 2026 Marcelo Fornet. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -/ module @@ -14,10 +14,9 @@ open Iris Language.Notation EctxLanguage EctxLanguage.Notation @[expose] public section /-! -Total base-step rules for evaluation-context languages. We intentionally stop -at the generic deterministic/no-fork interface needed by a Wasm language. -HeapLang primitive laws and concurrent convenience rules are not duplicated: -they add no capability for the initial single-threaded Wasm consumer. +Total base-step rules for evaluation-context languages. We intentionally stop +at the generic deterministic/no-fork interface. HeapLang primitive laws and +concurrent convenience rules are outside the scope of these generic rules. -/ variable {hlc : outParam HasLC} {Expr Ectx State Obs Val} diff --git a/Iris/Iris/ProgramLogic/TotalLifting.lean b/Iris/Iris/ProgramLogic/TotalLifting.lean index 5c61d6fc2..f317478e8 100644 --- a/Iris/Iris/ProgramLogic/TotalLifting.lean +++ b/Iris/Iris/ProgramLogic/TotalLifting.lean @@ -1,5 +1,5 @@ /- -Copyright (c) 2026 Fernando Leal. All rights reserved. +Copyright (c) 2026 Marcelo Fornet. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -/ module @@ -14,9 +14,9 @@ open Iris Language Language.Notation BI @[expose] public section /-! -The no-fork rules in this file are the intended entry point for Wasm. They -make the single-threaded contract explicit (`eₜ = []`) while the underlying -TWP remains faithful to Iris and can account for forks. +The no-fork rules in this file make the single-threaded contract explicit +(`eₜ = []`) while the underlying TWP remains faithful to Iris and can account +for forks. All total rules require the operational observation to be empty. This is a semantic requirement of Iris TWP, not proof bookkeeping. diff --git a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean index 7c17b2b40..e77d88eb9 100644 --- a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean +++ b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean @@ -1,5 +1,5 @@ /- -Copyright (c) 2026 Fernando Leal. All rights reserved. +Copyright (c) 2026 Marcelo Fornet. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -/ module @@ -22,17 +22,16 @@ contrast to ordinary WP, recursive occurrences are not guarded by a later. Consequently, membership in TWP is a finite derivation and adequacy can turn it into strong normalization. -The definition remains fork-aware to stay compatible with Iris. Wasm clients -are expected to use the no-fork lifting rules in `TotalLifting`: the initial -target is single-threaded Wasm, so concurrency-specific derived libraries are -deliberately not duplicated here. +The definition remains fork-aware to stay compatible with Iris. Clients with +single-threaded semantics can use the no-fork lifting rules in `TotalLifting`; +concurrency-specific derived libraries are deliberately not duplicated here. As in Iris-Rocq, TWP only accepts silent operational steps. A language with observable reductions must expose a silent administrative semantics or provide a future trace-sensitive generalization instead of discarding observations. -For Wasm, traps must therefore be represented deliberately: either as values -in the language's result type, or as non-values excluded by the reducibility +Traps must therefore be represented deliberately: either as values in the +language's result type, or as non-values excluded by the reducibility obligation. TWP does not silently reinterpret a stuck trap as successful termination. -/ diff --git a/Iris/Iris/Tests/TotalWeakestPre.lean b/Iris/Iris/Tests/TotalWeakestPre.lean index f951e022e..b0a86c323 100644 --- a/Iris/Iris/Tests/TotalWeakestPre.lean +++ b/Iris/Iris/Tests/TotalWeakestPre.lean @@ -1,5 +1,5 @@ /- -Copyright (c) 2026 Fernando Leal. All rights reserved. +Copyright (c) 2026 Marcelo Fornet. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -/ module @@ -21,8 +21,8 @@ measure, which checks that TWP proves termination of *all* successors rather than merely finding a terminating execution. `put` changes the machine state, `stuck` has no successor, steps never fork, -and all genuine reductions are silent. The latter two properties model the -initial Wasm integration contract. +and all genuine reductions are silent. The latter two properties exercise the +single-threaded, no-observation lifting rules. -/ inductive Expr where From 7ef5afab7a0a09f315361db991633a4181b673f0 Mon Sep 17 00:00:00 2001 From: Marcelo Fornet Date: Wed, 5 Aug 2026 15:17:33 +0200 Subject: [PATCH 5/9] Address total WP review findings --- Iris/Iris/ProgramLogic/TotalAdequacy.lean | 67 +----- Iris/Iris/ProgramLogic/TotalEctxLifting.lean | 10 +- Iris/Iris/ProgramLogic/TotalLifting.lean | 10 +- Iris/Iris/ProgramLogic/TotalWeakestPre.lean | 216 +++++++------------ Iris/Iris/Tests/TotalWeakestPre.lean | 89 +++++--- Iris/Iris/Tests/WeakestPre.lean | 23 +- 6 files changed, 169 insertions(+), 246 deletions(-) diff --git a/Iris/Iris/ProgramLogic/TotalAdequacy.lean b/Iris/Iris/ProgramLogic/TotalAdequacy.lean index 06e2e6762..737a5b06f 100644 --- a/Iris/Iris/ProgramLogic/TotalAdequacy.lean +++ b/Iris/Iris/ProgramLogic/TotalAdequacy.lean @@ -14,21 +14,9 @@ open Language Language.Notation @[expose] public section -/-! ## Operational termination predicates - -`Acc` takes the next configuration as its left argument, so the operational -relation is flipped. This definition is constructive and means that every -reduction tree rooted at the configuration is finite (strong normalization), -not merely that some execution terminates. - -The fork-aware thread-pool predicate below is kept because it is part of the -Iris-Rocq adequacy argument. Thread-pool ghost-state convenience APIs are not -ported because they are unrelated to the core total-WP adequacy result. Fair -termination, trace-sensitive liveness, and coinductive progress are -intentionally outside this layer. --/ +/-! ## Total adequacy -/ -@[rocq_alias sn] +/-- Strong normalization for `step`. -/ def StronglyNormalizing {α : Type _} (step : α → α → Prop) (x : α) : Prop := Acc (flip step) x @@ -39,15 +27,6 @@ theorem intro {α : Type _} {step : α → α → Prop} {x : α} StronglyNormalizing step x := Acc.intro x H -theorem of_irreducible {α : Type _} {step : α → α → Prop} {x : α} - (H : ∀ y, ¬ step x y) : StronglyNormalizing step x := - .intro fun y Hxy => (H y Hxy).elim - -theorem tail {α : Type _} {step : α → α → Prop} {x y : α} - (H : StronglyNormalizing step x) (Hxy : step x y) : - StronglyNormalizing step y := - H.inv Hxy - theorem map {α β : Type _} {stepα : α → α → Prop} {stepβ : β → β → Prop} (f : β → α) (Hlift : ∀ x y, stepβ x y → stepα (f x) (f y)) @@ -118,9 +97,7 @@ private theorem step_append_inv (r₁ r₂ t' : List Expr) (σ₁ σ₂ : State) local instance : OFE (List Expr) := OFE.ofDiscrete _ -/-- One unfolding of the total thread-pool predicate. Every possible pool step -must be silent, preserve the state interpretation, and recursively establish -the predicate for the complete successor pool. -/ +/-- One unfolding of the total thread-pool predicate. -/ @[rocq_alias twptp_pre] def pre (X : List Expr → IProp GF) (t₁ : List Expr) : IProp GF := iprop( ∀ (t₂ : List Expr) (σ₁ : State) (ns : Nat) (κ κs : List Obs) @@ -153,8 +130,7 @@ theorem pre_mono (X Y : List Expr → IProp GF) ∀ t, pre (ι := ι) X t -∗ pre (ι := ι) Y t := mono_pred (F := pre (ι := ι)) -/-- Least-fixed-point predicate governing all future reductions of a thread -pool. This is the direct Lean counterpart of Iris-Coq's `twptp`. -/ +/-- Total weakest precondition for a thread pool. -/ @[rocq_alias twptp] def get (t : List Expr) : IProp GF := bi_least_fixpoint (pre (ι := ι)) t @@ -298,8 +274,7 @@ private theorem cons_sep (e : Expr) (es : List Expr) : icases H with ⟨He, Hes⟩ iapply cons e es (ι := ι) $$ He Hes -@[rocq_alias twptp_nil] -theorem nil : ⊢ get (ι := ι) ([] : List Expr) := by +private theorem nil : ⊢ get (ι := ι) ([] : List Expr) := by rw [(twptp.unfold (ι := ι) []).to_eq] unfold pre iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep @@ -350,7 +325,7 @@ theorem of_twp (s : Stuckness) (e : Expr) (Φ : Val → IProp GF) : let Ψ := fun (E : CoPset) (e : Expr) (_ : Val → IProp GF) => iprop( ⌜E = ⊤⌝ -∗ get (ι := ι) [e]) have hΨ : NonExpansive - (fun x : twp.Args Expr Val GF => Ψ x.1.1 x.1.2 x.2) := by + (fun x : twp.Internal.Args Expr Val GF => Ψ x.1.1 x.1.2 x.2) := by constructor intro n x y hxy rcases x with ⟨⟨EX, eX⟩, ΦX⟩ @@ -443,10 +418,7 @@ theorem twptp_total (t : List Expr) (σ : State) (ns nt : Nat) : end ThreadPool omit Λ in -/-- General total adequacy. An initialized state interpretation together with -a total weakest precondition entails strong normalization of the complete -fork-aware language configuration. As in Iris-Coq, the chosen -`numLatersPerStep` is abstract because TWP itself does not inspect it. -/ +/-- Total adequacy for thread-pool reduction. -/ @[rocq_alias twp_total] theorem twp_total {hlc : HasLC} {GF : BundledGFunctors} [InvGpreS GF] [Language Expr State Obs Val] @@ -477,30 +449,18 @@ theorem twp_total {hlc : HasLC} {GF : BundledGFunctors} iapply twptp.of_twp s e Φ (ι := iG) iapply Htwp $$ Hcred -/-- Erased single-thread reduction. Forked expressions remain visible in the -step witness; clients can rule them out with `LanguageNoFork`. -/ +/-- Erased single-expression reduction. -/ def ExprErasedStep : Expr × State → Expr × State → Prop | (e₁, σ₁), (e₂, σ₂) => ∃ (κ : List Obs) (efs : List Expr), (e₁, σ₁) -<κ>-> (e₂, σ₂, efs) -/-- The single-threaded language contract used by the no-fork adequacy -corollaries. -/ +/-- A language whose primitive steps do not fork. -/ class LanguageNoFork (Expr State Obs Val : Type _) [Language Expr State Obs Val] : Prop where no_fork {e₁ e₂ : Expr} {σ₁ σ₂ : State} {κ : List Obs} {efs : List Expr} : (e₁, σ₁) -<κ>-> (e₂, σ₂, efs) → efs = [] -theorem exprErasedStep_noFork [LanguageNoFork Expr State Obs Val] {e₁ σ₁ e₂ σ₂} - (H : ExprErasedStep (Expr := Expr) (State := State) (Obs := Obs) - (e₁, σ₁) (e₂, σ₂)) : - ∃ κ, (e₁, σ₁) -<κ>-> (e₂, σ₂, []) := by - obtain ⟨κ, efs, Hstep⟩ := H - have := LanguageNoFork.no_fork Hstep - subst efs - exact ⟨κ, Hstep⟩ - -/-- A fork-aware total-adequacy result specializes to the single-expression -machine when the language proves that primitive steps never fork. -/ +/-- Derive single-expression normalization from thread-pool normalization. -/ theorem stronglyNormalizing_expr_of_threadPool [LanguageNoFork Expr State Obs Val] {e : Expr} {σ : State} (H : StronglyNormalizing @@ -515,12 +475,5 @@ theorem stronglyNormalizing_expr_of_threadPool subst efs exact ⟨κ, .atomic Hstep [] []⟩ -theorem value_stronglyNormalizing (v : Val) (σ : State) : - StronglyNormalizing (ExprErasedStep (Expr := Expr) (Obs := Obs)) - ((v : Expr), σ) := by - apply StronglyNormalizing.of_irreducible - rintro ⟨e₂, σ₂⟩ ⟨κ, efs, Hstep⟩ - exact Language.prim_val_stuck Hstep - end end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/TotalEctxLifting.lean b/Iris/Iris/ProgramLogic/TotalEctxLifting.lean index cde6df973..568cbaa34 100644 --- a/Iris/Iris/ProgramLogic/TotalEctxLifting.lean +++ b/Iris/Iris/ProgramLogic/TotalEctxLifting.lean @@ -5,7 +5,7 @@ Released under Apache 2.0 license as described in the file LICENSE. module public import Iris.ProgramLogic.TotalLifting -public import Iris.ProgramLogic.EctxLifting +public import Iris.ProgramLogic.EctxiLanguage namespace Iris.ProgramLogic @@ -13,11 +13,7 @@ open Iris Language.Notation EctxLanguage EctxLanguage.Notation @[expose] public section -/-! -Total base-step rules for evaluation-context languages. We intentionally stop -at the generic deterministic/no-fork interface. HeapLang primitive laws and -concurrent convenience rules are outside the scope of these generic rules. --/ +/-! ## Total lifting rules for evaluation-context languages -/ variable {hlc : outParam HasLC} {Expr Ectx State Obs Val} variable [Λ : EctxLanguage Expr Ectx State Obs Val] @@ -151,8 +147,6 @@ theorem twp_lift_atomic_base_step_no_fork (h : toVal e₁ = none) : (BaseStep.reducible_of_reducibleNoObs Hred) Hstep iapply H $$ %κ %e₂ %σ₂ %eₜ %Hb -/-- Deterministic pure base-step lifting. The explicit non-value premise is -retained to match Iris-Rocq's public theorem, although `Hred` also implies it. -/ @[rocq_alias twp_lift_pure_det_base_step_no_fork] theorem twp_lift_pure_det_base_step_no_fork [Inhabited State] (_h : toVal e₁ = none) diff --git a/Iris/Iris/ProgramLogic/TotalLifting.lean b/Iris/Iris/ProgramLogic/TotalLifting.lean index f317478e8..8c9b71c61 100644 --- a/Iris/Iris/ProgramLogic/TotalLifting.lean +++ b/Iris/Iris/ProgramLogic/TotalLifting.lean @@ -5,7 +5,6 @@ Released under Apache 2.0 license as described in the file LICENSE. module public import Iris.ProgramLogic.TotalWeakestPre -public import Iris.ProgramLogic.Lifting namespace Iris.ProgramLogic @@ -13,14 +12,7 @@ open Iris Language Language.Notation BI @[expose] public section -/-! -The no-fork rules in this file make the single-threaded contract explicit -(`eₜ = []`) while the underlying TWP remains faithful to Iris and can account -for forks. - -All total rules require the operational observation to be empty. This is a -semantic requirement of Iris TWP, not proof bookkeeping. --/ +/-! ## Total lifting rules -/ variable {hlc : outParam HasLC} {Expr State Obs Val} variable [Λ : Language Expr State Obs Val] diff --git a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean index e77d88eb9..65476cbb7 100644 --- a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean +++ b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean @@ -17,36 +17,14 @@ open ProgramLogic Language.Notation Std OFE /-! # Total weakest preconditions -This is the least-fixed-point total weakest precondition from Iris-Rocq. In -contrast to ordinary WP, recursive occurrences are not guarded by a later. -Consequently, membership in TWP is a finite derivation and adequacy can turn it -into strong normalization. - -The definition remains fork-aware to stay compatible with Iris. Clients with -single-threaded semantics can use the no-fork lifting rules in `TotalLifting`; -concurrency-specific derived libraries are deliberately not duplicated here. - -As in Iris-Rocq, TWP only accepts silent operational steps. A language with -observable reductions must expose a silent administrative semantics or provide -a future trace-sensitive generalization instead of discarding observations. - -Traps must therefore be represented deliberately: either as values in the -language's result type, or as non-values excluded by the reducibility -obligation. TWP does not silently reinterpret a stuck trap as successful -termination. +The total weakest precondition is the least fixed point of `twp.pre`. -/ variable {hlc : outParam HasLC} {Expr State Obs Val} variable [Λ : Language Expr State Obs Val] variable {GF : BundledGFunctors} [ι : IrisGS_gen hlc Expr GF] -/-- The stuckness-dependent reducibility condition used by total WP. - -Unlike partial WP's `Stuckness.MaybeReducible`, the `NotStuck` case requires -the existence of a *silent* primitive step. This matches Iris-Rocq's -`reducible_no_obs` premise and prevents an observable transition from being -used to justify TWP only to be rejected by the step clause immediately -afterwards. -/ +/-- The stuckness-dependent reducibility condition for total WP. -/ abbrev Stuckness.MaybeReducibleNoObs : Stuckness → Expr × State → Prop | .NotStuck, ρ => PrimStep.ReducibleNoObs ρ | .MaybeStuck, _ => True @@ -57,9 +35,13 @@ local instance : OFE CoPset := OFE.ofDiscrete _ local instance : OFE Expr := OFE.ofDiscrete _ local instance : OFE Val := OFE.ofDiscrete _ +namespace Internal + abbrev Args (Expr Val : Type _) (GF : BundledGFunctors) := (CoPset × Expr) × (Val → IProp GF) +end Internal + @[rocq_alias twp_pre] def pre (s : Stuckness) (twp : CoPset → Expr → (Val → IProp GF) → IProp GF) @@ -76,35 +58,54 @@ def pre (s : Stuckness) twp E e₂ Φ ∗ [∗list] e' ∈ eₜ, twp ⊤ e' ι.forkPost) +namespace Internal + def pre' (s : Stuckness) (X : Args Expr Val GF → IProp GF) : Args Expr Val GF → IProp GF | ((E, e), Φ) => pre s (fun E e Φ => X ((E, e), Φ)) E e Φ +end Internal + +@[rocq_alias twp_pre_mono] +theorem pre_mono (s : Stuckness) + (X Y : CoPset → Expr → (Val → IProp GF) → IProp GF) : + ⊢ □ (∀ E e Φ, X E e Φ -∗ Y E e Φ) -∗ + ∀ E e Φ, pre s X E e Φ -∗ pre s Y E e Φ := by + iintro #H %E %e %Φ Hpre + unfold pre + cases toVal e with + | some => + imod Hpre with Hpre + imodintro + iexact Hpre + | none => + iintro %σ₁ %ns %obs %nt Hσ + imod Hpre $$ Hσ with ⟨%Hred, Hstep⟩ + imodintro + iframe %Hred + iintro %κ %e₂ %σ₂ %eₜ %Hprim + imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with + ⟨%hκ, Hσ, He₂, Hefs⟩ + imodintro + iframe %hκ Hσ + isplitl [He₂] + · iapply H $$ %E %e₂ %Φ He₂ + · iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef Hef + iapply H $$ %⊤ %ef %ι.forkPost Hef + +namespace Internal + instance pre'_mono (s : Stuckness) : BIMonoPred (pre' (ι := ι) s) where mono_pred := by intro X Y _ _ - iintro #HXY %x + iintro #HXY %x HX rcases x with ⟨⟨E, e⟩, Φ⟩ - simp only [pre', pre] - iintro HX - cases toVal e - case some => iexact HX - case none => - iintro %σ₁ %ns %obs %nt Hσ - imod HX $$ Hσ with ⟨%Hred, H⟩ - imodintro - isplit - · ipureintro - exact Hred - · iintro %κ %e₂ %σ₂ %eₜ %Hstep - imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with ⟨%hκ, Hσ, He, Hefs⟩ - imodintro - iframe %hκ Hσ - isplitl [He] - · iapply HXY $$ %((E, e₂), Φ) He - · iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef Hef - iapply HXY $$ %((⊤, ef), ι.forkPost) Hef + simp only [pre'] + iapply pre_mono s (fun E e Φ => X ((E, e), Φ)) + (fun E e Φ => Y ((E, e), Φ)) $$ [] %E %e %Φ HX + iintro !> %E %e %Φ H + iapply HXY $$ %((E, e), Φ) H mono_pred_ne.ne {X} a b h := by rcases a with ⟨⟨E₁, e₁⟩, Φ₁⟩ rcases b with ⟨⟨E₂, e₂⟩, Φ₂⟩ @@ -137,44 +138,17 @@ instance pre'_mono (s : Stuckness) : BIMonoPred (pre' (ι := ι) s) where exact ⟨⟨.rfl, .rfl⟩, hΦ⟩ · exact .rfl -@[rocq_alias twp_pre_mono] -theorem pre_mono (s : Stuckness) - (X Y : CoPset → Expr → (Val → IProp GF) → IProp GF) - [NonExpansive (fun x : Args Expr Val GF => X x.1.1 x.1.2 x.2)] - [NonExpansive (fun x : Args Expr Val GF => Y x.1.1 x.1.2 x.2)] : - ⊢ □ (∀ E e Φ, X E e Φ -∗ Y E e Φ) -∗ - ∀ E e Φ, pre s X E e Φ -∗ pre s Y E e Φ := by - iintro #H %E %e %Φ Hpre - unfold pre - cases hval : toVal e with - | some v => - imod Hpre with Hpre - imodintro - iexact Hpre - | none => - iintro %σ₁ %ns %obs %nt Hσ - imod Hpre $$ Hσ with ⟨%Hred, Hstep⟩ - imodintro - iframe %Hred - iintro %κ %e₂ %σ₂ %eₜ %Hprim - imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with - ⟨%hκ, Hσ, He₂, Hefs⟩ - imodintro - iframe %hκ Hσ - isplitl [He₂] - · iapply H $$ %E %e₂ %Φ He₂ - · iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef Hef - iapply H $$ %⊤ %ef %ι.forkPost Hef - -def get (s : Stuckness) (E : CoPset) (e : Expr) (Φ : Val → IProp GF) : IProp GF := +def get (s : Stuckness) (E : CoPset) (e : Expr) + (Φ : Val → IProp GF) : IProp GF := letI : OFE CoPset := OFE.ofDiscrete _ letI : OFE Expr := OFE.ofDiscrete _ letI : OFE Val := OFE.ofDiscrete _ bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ) +end Internal + instance instTotalWp : TotalWp (IProp GF) Expr Val Stuckness where - totalWp := get + totalWp := Internal.get section Rules @@ -185,13 +159,14 @@ local instance : OFE Val := OFE.ofDiscrete _ @[rocq_alias twp_unfold] theorem unfold {s E} {e : Expr} {Φ : Val → IProp GF} : WP e @ s ; E [{ Φ }] ⊣⊢ pre s (TotalWp.totalWp (PROP := IProp GF) s) E e Φ := by - change bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ) ⊣⊢ _ - exact BI.equiv_iff.1 (least_fixpoint_unfold (pre' (ι := ι) s)) + change bi_least_fixpoint (Internal.pre' (ι := ι) s) ((E, e), Φ) ⊣⊢ _ + exact BI.equiv_iff.1 (least_fixpoint_unfold (Internal.pre' (ι := ι) s)) @[rocq_alias twp_ind] theorem induction (s : Stuckness) (Ψ : CoPset → Expr → (Val → IProp GF) → IProp GF) - [HΨ : NonExpansive (fun x : Args Expr Val GF => Ψ x.1.1 x.1.2 x.2)] : + [HΨ : NonExpansive + (fun x : Internal.Args Expr Val GF => Ψ x.1.1 x.1.2 x.2)] : (⊢ □ (∀ E e Φ, pre s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) E e Φ -∗ Ψ E e Φ)) → @@ -199,17 +174,18 @@ theorem induction (s : Stuckness) intro H have H' : ⊢ □ (∀ E e Φ, pre s (fun E e Φ => - iprop(Ψ E e Φ ∧ bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ))) + iprop(Ψ E e Φ ∧ + bi_least_fixpoint (Internal.pre' (ι := ι) s) ((E, e), Φ))) E e Φ -∗ Ψ E e Φ) := by - simpa only [TotalWp.totalWp, instTotalWp, get] using H + simpa only [TotalWp.totalWp, instTotalWp, Internal.get] using H iintro %E %e %Φ - change ⊢ bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ) -∗ Ψ E e Φ + change ⊢ bi_least_fixpoint (Internal.pre' (ι := ι) s) ((E, e), Φ) -∗ Ψ E e Φ iintro Htwp - iapply least_fixpoint_ind (F := pre' (ι := ι) s) + iapply least_fixpoint_ind (F := Internal.pre' (ι := ι) s) (Φ := fun x => Ψ x.1.1 x.1.2 x.2) $$ [] Htwp iintro !> %x rcases x with ⟨⟨E, e⟩, Φ⟩ - simp only [pre'] + simp only [Internal.pre'] iintro Hx iapply H' iexact Hx @@ -218,8 +194,8 @@ theorem induction (s : Stuckness) instance ne {s : Stuckness} {E} {e : Expr} : NonExpansive (TotalWp.totalWp (PROP := IProp GF) s E e) where ne {n Φ₁ Φ₂} HΦ := by - change bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ₁) ≡{n}≡ - bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ₂) + change bi_least_fixpoint (Internal.pre' (ι := ι) s) ((E, e), Φ₁) ≡{n}≡ + bi_least_fixpoint (Internal.pre' (ι := ι) s) ((E, e), Φ₂) apply NonExpansive.ne exact ⟨⟨.rfl, .rfl⟩, fun v => HΦ v⟩ @@ -237,7 +213,7 @@ theorem strong_mono {s₁ s₂ : Stuckness} {E₁ E₂} {e : Expr} ∀ E₂ Ψ, ⌜E ⊆ E₂⌝ -∗ (∀ v, Φ v ={E₂}=∗ Ψ v) -∗ WP e @ s₂ ; E₂ [{ Ψ }]) have hPred : NonExpansive - (fun x : Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by + (fun x : Internal.Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by constructor intro n x y h rcases x with ⟨⟨EX, eX⟩, ΦX⟩ @@ -387,7 +363,7 @@ theorem bind (K : Expr → Expr) [ctx : Language.Context K] ∀ Φ, (∀ v, Ψ v -∗ WP (K (v : Expr)) @ s ; E [{ Φ }]) -∗ WP (K e) @ s ; E [{ Φ }]) have hPred : NonExpansive - (fun x : Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by + (fun x : Internal.Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by constructor intro n x y hxy rcases x with ⟨⟨EX, eX⟩, ΨX⟩ @@ -448,44 +424,16 @@ theorem bind (K : Expr → Expr) [ctx : Language.Context K] private theorem fold_induction_right (Ψ : CoPset → Expr → (Val → IProp GF) → IProp GF) (s : Stuckness) (E : CoPset) (e : Expr) (Φ : Val → IProp GF) : - (match toVal e with - | some v => iprop(|={E}=> Φ v) - | none => iprop( - ∀ (σ₁ : State) (ns : Nat) (obs : List Obs) (nt : Nat), - stateInterp σ₁ ns obs nt ={E,∅}=∗ - ⌜s.MaybeReducibleNoObs (e, σ₁)⌝ ∗ - ∀ (κ : List Obs) e₂ σ₂ eₜ, - ⌜(e, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ - ⌜κ = []⌝ ∗ - stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ - (Ψ E e₂ Φ ∧ WP e₂ @ s ; E [{ Φ }]) ∗ - [∗list] e' ∈ eₜ, - (Ψ ⊤ e' ι.forkPost ∧ - WP e' @ s ; ⊤ [{ ι.forkPost }]))) ⊢ - WP e @ s ; E [{ Φ }] := by + pre s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) + E e Φ ⊢ WP e @ s ; E [{ Φ }] := by rw [unfold.to_eq] - unfold pre - cases hval : toVal e with - | some => - exact .rfl - | none => - iintro H - iintro %σ₁ %ns %obs %nt Hσ - imod H $$ Hσ with ⟨%Hred, Hstep⟩ - imodintro - iframe %Hred - iintro %κ %e₂ %σ₂ %eₜ %Hprim - imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with - ⟨%hκ, Hσ, He₂, Hefs⟩ - imodintro - iframe %hκ Hσ - isplitl [He₂] - · icases He₂ with ⟨-, He₂⟩ - iexact He₂ - · iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef Hef - icases Hef with ⟨-, Hef⟩ - iexact Hef + iintro Hpre + iapply (pre_mono s + (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) + (TotalWp.totalWp s)) $$ [] %E %e %Φ Hpre + iintro !> %E %e %Φ H + icases H with ⟨-, H⟩ + iexact H @[rocq_alias twp_bind_inv] theorem bind_inv (K : Expr → Expr) [ctx : Language.Context K] @@ -498,7 +446,7 @@ theorem bind_inv (K : Expr → Expr) [ctx : Language.Context K] TotalWp.totalWp s E e (fun v : Val => iprop(WP (K (v : Expr)) @ s ; E [{ Φ }]))) have hPred : NonExpansive - (fun x : Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by + (fun x : Internal.Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by constructor intro n x y hxy rcases x with ⟨⟨EX, eX⟩, ΦX⟩ @@ -518,17 +466,16 @@ theorem bind_inv (K : Expr → Expr) [ctx : Language.Context K] iintro !> %E %e' %Φ IH %e %heq subst e' rw [unfold.to_eq] - unfold pre cases he : toVal e with | some v => - dsimp only + ihave IHfold := fold_induction_right Pred s E (K e) Φ (ι := ι) $$ IH + simp only [pre, he] have heq := ToVal.coe_of_toVal_eq_some he subst e imodintro - iapply fold_induction_right Pred s E (K (v : Expr)) Φ - iexact IH + iexact IHfold | none => - dsimp only + simp only [pre, he] have hK : toVal (K e) = none := ctx.toVal_eq_none_fill he let unfolded := iprop( ∀ (σ₁ : State) (ns : Nat) (obs : List Obs) (nt : Nat), @@ -723,12 +670,13 @@ variable {s : Stuckness} {E E₁ E₂ : CoPset} {e : Expr} variable {Φ Ψ : Val → IProp GF} {P R : IProp GF} @[rocq_alias frame_twp] -instance frameTwp {p : Bool} [H : ∀ v, Frame p R (Φ v) (Ψ v)] : +instance frameTwp {p : Bool} + [H : ∀ v, FrameInstantiateExistDisabled p R (Φ v) (Ψ v)] : Frame p R (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Ψ }]) where frame := by refine frame_l.trans ?_ apply mono - exact fun v => (H v).frame + exact fun v => (H v).frame_instantiatiate_exist_disabled.frame -- Iris-Rocq reuses the module-qualified name `is_except_0_wp` here; that alias -- is already assigned to partial WP in Lean, so this instance is left unaliased. diff --git a/Iris/Iris/Tests/TotalWeakestPre.lean b/Iris/Iris/Tests/TotalWeakestPre.lean index b0a86c323..836c0ac82 100644 --- a/Iris/Iris/Tests/TotalWeakestPre.lean +++ b/Iris/Iris/Tests/TotalWeakestPre.lean @@ -5,6 +5,7 @@ Released under Apache 2.0 license as described in the file LICENSE. module public import Iris.ProgramLogic.TotalAdequacy +public import Iris.ProgramLogic.TotalEctxLifting public import Iris.ProgramLogic.TotalLifting public import Iris.Examples.ClosedProofs public import Iris.HeapLang.Instances @@ -14,16 +15,7 @@ namespace Iris.Tests.TotalWeakestPre open Iris BI ProgramLogic ProgramLogic.Language ProgramLogic.Language.Notation open Std LawfulSet -/-! -An intentionally small total-correctness test language. It is deterministic -except for `branch`: both branch successors decrease the same structural -measure, which checks that TWP proves termination of *all* successors rather -than merely finding a terminating execution. - -`put` changes the machine state, `stuck` has no successor, steps never fork, -and all genuine reductions are silent. The latter two properties exercise the -single-threaded, no-observation lifting rules. --/ +/-! A small language for total-correctness tests. -/ inductive Expr where | val : Nat → Expr @@ -69,11 +61,6 @@ instance : Language Expr State Obs Val where instance : LanguageNoFork Expr State Obs Val where no_fork H := by cases H <;> rfl -theorem step_noFork {e₁ e₂ : Expr} {σ₁ σ₂ : State} - {κ : List Obs} {efs : List Expr} - (H : (e₁, σ₁) -<κ>-> (e₂, σ₂, efs)) : efs = [] := by - cases H <;> rfl - section Proofs noncomputable abbrev GF := Iris.Examples.ClosedProofs.GF @@ -143,8 +130,6 @@ theorem tick_pureExec (n : Nat) : | succ n IH => exact .head (tick_purePrimStep_succ n) IH -/-- Checks the no-credit multi-step `PureExec` rule independently of the -structural proof above. -/ theorem tick_twp_via_pureExec (n : Nat) : ⊢ WP (Expr.tick n) @ Stuckness.NotStuck ; ⊤ [{ fun v : Val => (iprop(⌜v = 0⌝) : IProp GF) }] := by @@ -235,9 +220,9 @@ end Proofs section CoreRuleChecks -variable {e : Expr} {Φ : Val → IProp GF} {P : IProp GF} -variable [InvGS_gen .hasNoLC GF] -noncomputable local instance : IrisGS_gen .hasNoLC Expr GF := testIrisGS +variable {E : CoPset} {e : Expr} {v : Val} +variable {Φ : Val → IProp GF} {P Q : IProp GF} +variable [IrisGS_gen .hasNoLC Expr GF] example : WP e @ Stuckness.NotStuck ; ⊤ [{ Φ }] ⊢ @@ -263,8 +248,48 @@ example : WP (id e) @ Stuckness.NotStuck ; ⊤ [{ Φ }] := twp.bind id +example [inst : Language.IntoVal e v] : + P ∗ Φ v ⊢ WP e @ Stuckness.NotStuck ; ⊤ [{ w, P ∗ Φ w }] := by + iintro ⟨HP, HΦ⟩ + iframe HP + iapply twp.value $$ HΦ + exact inst.into_val.symm + +/-- error: iframe: cannot frame R 0 -/ +#guard_msgs in +example (R : Nat → IProp GF) : + R 0 ∗ WP e @ Stuckness.NotStuck ; E [{ fun _ => emp }] ⊢ + WP e @ Stuckness.NotStuck ; E [{ fun _ => iprop(∃ n, R n) }] := by + iintro ⟨HR, Hwp⟩ + iframe HR + +example : + (|={E}=> P) ∗ (P -∗ WP e @ Stuckness.NotStuck ; E [{ Φ }]) ⊢ + WP e @ Stuckness.NotStuck ; E [{ Φ }] := by + iintro ⟨HP, Hwp⟩ + imod HP + iapply Hwp $$ HP + +example : + (|==> Q) ∗ (Q -∗ WP e @ Stuckness.NotStuck ; E [{ Φ }]) ⊢ + WP e @ Stuckness.NotStuck ; E [{ Φ }] := by + iintro ⟨HQ, Hwp⟩ + imod HQ + iapply Hwp $$ HQ + end CoreRuleChecks +section TotalEctxRuleChecks + +example := @twp_lift_base_step +example := @twp_lift_base_step_no_fork +example := @twp_lift_pure_base_step_no_fork +example := @twp_lift_atomic_base_step +example := @twp_lift_atomic_base_step_no_fork +example := @twp_lift_pure_det_base_step_no_fork + +end TotalEctxRuleChecks + section HeapLangPureSmoke open Iris.HeapLang @@ -282,19 +307,19 @@ noncomputable local instance heapIrisGS : imodintro itrivial -/-- Existing HeapLang `PureExec` instances are immediately reusable by TWP; -HeapLang-specific stateful primitive laws remain intentionally out of scope. -/ theorem heapLang_add_twp : ⊢ WP hl(#1 + #2) @ Stuckness.NotStuck ; ⊤ [{ fun v : Iris.HeapLang.Val => (iprop(⌜v = hl_val(#3)⌝) : IProp GF) }] := by - iapply twp_pure_step - (instPureExecBinOp (op := .plus) - (v1 := hl_val(#1)) (v2 := hl_val(#2)) (v' := hl_val(#3))) - (by rfl) - iapply twp.value rfl - ipureintro - rfl + iapply twp_lift_pure_det_base_step_no_fork (e₂ := hl(#3)) rfl + · intro σ + refine ⟨hl(#3), σ, [], ?_⟩ + constructor <;> rfl + · intro σ κ e₂' σ₂ eₜ Hstep + cases Hstep <;> simp_all [Iris.HeapLang.BinOp.eval] + · iapply twp.value rfl + ipureintro + rfl end HeapLangPureSmoke @@ -353,11 +378,7 @@ theorem put_stronglyNormalizing (n initialState : Nat) : · iintro _ iapply put_twp n -/-! Negative semantic boundary checks. `stuck` is a non-value without a -successor, and `observe` has only a non-silent successor. Consequently neither -can satisfy the `.NotStuck` reducibility premise of TWP. The no-fork lifting -API separately exposes `eₜ = []` as a proof obligation, so a forking rule -cannot be passed to it. -/ +/-! Negative semantic boundary checks. -/ example : toVal Expr.stuck = (none : Option Val) := rfl diff --git a/Iris/Iris/Tests/WeakestPre.lean b/Iris/Iris/Tests/WeakestPre.lean index d852ae773..3489ea1eb 100644 --- a/Iris/Iris/Tests/WeakestPre.lean +++ b/Iris/Iris/Tests/WeakestPre.lean @@ -122,15 +122,30 @@ section TestTotalTexanTriple set_option linter.unusedVariables false -variable (PROP Expr Val : Type _) [BI PROP] -variable [TotalWp PROP Expr Val Stuckness] -variable (e : Expr) (P Q : PROP) (v : Val) +variable (PROP Expr Val A : Type _) [BI PROP] +variable [TotalWp PROP Expr Val A] [TotalWp PROP Expr Val Stuckness] +variable (e : Expr) (s : A) (E : CoPset) (P Q : PROP) (v : Val) + +/-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ s ; E [{ Φ }] ) : PROP -/ +#guard_msgs in #check [[{ P }]] e @ s ; E [[{ RET v; Q }]] + +/-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ E [{ Φ }] ) : PROP -/ +#guard_msgs in #check [[{ P }]] e @ E [[{ RET v; Q }]] + +/-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ E ? [{ Φ }] ) : PROP -/ +#guard_msgs in #check [[{ P }]] e @ E ? [[{ RET v; Q }]] /-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e [{ Φ }] ) : PROP -/ #guard_msgs in #check [[{ P }]] e [[{ RET v; Q }]] +/-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e ? [{ Φ }] ) : PROP -/ +#guard_msgs in #check [[{ P }]] e ? [[{ RET v; Q }]] + /-- info: iprop(∀ Φ, P -∗ (∀ x, Q -∗ Φ x) -∗ WP e [{ Φ }] ) : PROP -/ -#guard_msgs in #check [[{ P }]] e [[{ x, RET x; Q }]] +#guard_msgs in #check [[{ P }]] e [[{ (x : Val), RET x; Q }]] + +/-- info: iprop(∀ Φ, P -∗ (∀ x, Q -∗ Φ v) -∗ WP e [{ Φ }] ) : PROP -/ +#guard_msgs in #check [[{ P }]] e [[{ _, RET v; Q }]] end TestTotalTexanTriple From 0e593d69fd1f2e2f189a7d49f163ea4d9f3253a3 Mon Sep 17 00:00:00 2001 From: Marcelo Fornet Date: Wed, 5 Aug 2026 15:50:43 +0200 Subject: [PATCH 6/9] Tighten total WP port and adequacy tests --- Iris/Iris/BI/WeakestPre.lean | 31 ++--- Iris/Iris/ProgramLogic/TotalAdequacy.lean | 88 ++++--------- Iris/Iris/ProgramLogic/TotalWeakestPre.lean | 4 +- Iris/Iris/Tests/TotalWeakestPre.lean | 134 ++++++++++++++++---- 4 files changed, 148 insertions(+), 109 deletions(-) diff --git a/Iris/Iris/BI/WeakestPre.lean b/Iris/Iris/BI/WeakestPre.lean index caefaf0a9..1eb382357 100644 --- a/Iris/Iris/BI/WeakestPre.lean +++ b/Iris/Iris/BI/WeakestPre.lean @@ -62,8 +62,6 @@ syntax " {" noWs "{ " term:min " }" noWs "} " : texanPrecond syntax (name := texanTriple) texanPrecond wpExpr texanPostcond : term -/- Total Texan triples deliberately have no later in front of the postcondition -continuation. The doubled square brackets follow Iris-Rocq's TWP notation. -/ syntax (name := totalTexanTriple) "[[{" term:min "}]]" wpExpr "[[{" ((ppSpace (binderIdent <|> bracketedBinder))+ ", ")? @@ -99,6 +97,16 @@ meta def parseWpPostcond (stx : TSyntax `wpPostcond) : MacroM (TSyntax `term × return (←parseWpPostcondInner inner, true) | _ => Macro.throwUnsupported (α := TSyntax `term × Bool) +open Lean in +private meta def transformTexanBinders + (xs : Array (TSyntax [`Lean.binderIdent, `Lean.Parser.Term.bracketedBinder])) : + MacroM <| TSyntaxArray [`ident, `Lean.Parser.Term.hole, + `Lean.Parser.Term.bracketedBinder] := + xs.mapM fun + | `(binderIdent|_) => `(hole|_) + | `(binderIdent|$i:ident) => `(ident|$i) + | `(bracketedBinder|$x) => `(bracketedBinder|$x) + @[macro wp] meta def wpMacro : Lean.Macro := fun stx => do match stx with @@ -114,16 +122,9 @@ meta def wpMacro : Lean.Macro := fun stx => do @[macro texanTriple] meta def wpTexanTriple : Lean.Macro | `({{ $P:term }} $wpExpr {{ $[$[$xs]* ,]? RET $pat ; $Q:term }}) => do - - let transform (xs : Array (TSyntax [`Lean.binderIdent, `Lean.Parser.Term.bracketedBinder])) : MacroM <| TSyntaxArray [`ident, `Lean.Parser.Term.hole, `Lean.Parser.Term.bracketedBinder] := - xs.mapM fun - | `(binderIdent|_) => `(hole|_) - | `(binderIdent|$i:ident) => `(ident|$i) - | `(bracketedBinder|$x) => `(bracketedBinder|$x) - let k ← match xs with | some xs => - let xs ← transform xs -- TSyntax cast + let xs ← transformTexanBinders xs `(iprop(∀ $xs*, $Q:term -∗ Φ $pat)) | none => `($Q:term -∗ Φ $pat) `(iprop(∀ Φ, $P -∗ ▷ $k -∗ (WP $wpExpr {{ Φ }}))) @@ -133,17 +134,9 @@ meta def wpTexanTriple : Lean.Macro meta def totalWpTexanTriple : Lean.Macro | `([[{ $P:term }]] $wpExpr [[{ $[$[$xs]* ,]? RET $pat ; $Q:term }]]) => do - let transform - (xs : Array (TSyntax [`Lean.binderIdent, `Lean.Parser.Term.bracketedBinder])) : - MacroM <| TSyntaxArray [`ident, `Lean.Parser.Term.hole, - `Lean.Parser.Term.bracketedBinder] := - xs.mapM fun - | `(binderIdent|_) => `(hole|_) - | `(binderIdent|$i:ident) => `(ident|$i) - | `(bracketedBinder|$x) => `(bracketedBinder|$x) let k ← match xs with | some xs => - let xs ← transform xs + let xs ← transformTexanBinders xs `(iprop(∀ $xs*, $Q:term -∗ Φ $pat)) | none => `($Q:term -∗ Φ $pat) let (e, s, E) ← parseWpExpr wpExpr diff --git a/Iris/Iris/ProgramLogic/TotalAdequacy.lean b/Iris/Iris/ProgramLogic/TotalAdequacy.lean index 737a5b06f..91d5d9ec3 100644 --- a/Iris/Iris/ProgramLogic/TotalAdequacy.lean +++ b/Iris/Iris/ProgramLogic/TotalAdequacy.lean @@ -50,6 +50,15 @@ section ThreadPool variable {hlc : HasLC} {GF : BundledGFunctors} variable [ι : IrisGS_gen hlc Expr GF] +local instance : OFE (List Expr) := OFE.ofDiscrete _ + +private theorem list_nonexpansive (Ψ : List Expr → IProp GF) : NonExpansive Ψ := by + constructor + intro n x y hxy + change x = y at hxy + subst y + rfl + namespace twptp local instance : OFE CoPset := OFE.ofDiscrete _ @@ -95,8 +104,6 @@ private theorem step_append_inv (r₁ r₂ t' : List Expr) (σ₁ σ₂ : State) simp only [List.append_assoc] exact .refl _ -local instance : OFE (List Expr) := OFE.ofDiscrete _ - /-- One unfolding of the total thread-pool predicate. -/ @[rocq_alias twptp_pre] def pre (X : List Expr → IProp GF) (t₁ : List Expr) : IProp GF := iprop( @@ -135,12 +142,8 @@ theorem pre_mono (X Y : List Expr → IProp GF) def get (t : List Expr) : IProp GF := bi_least_fixpoint (pre (ι := ι)) t -instance get_ne : NonExpansive (get (ι := ι)) := by - constructor - intro n x y hxy - change x = y at hxy - subst y - rfl +instance get_ne : NonExpansive (get (ι := ι)) := + list_nonexpansive _ @[rocq_alias twptp_unfold] theorem unfold (t : List Expr) : @@ -163,17 +166,12 @@ theorem induction (Ψ : List Expr → IProp GF) [NonExpansive Ψ] : iintro !> %t' Hpre iapply H' $$ %t' Hpre -private theorem fold_right (Ψ : List Expr → IProp GF) [NonExpansive Ψ] +private theorem pre_and_get (Ψ : List Expr → IProp GF) [NonExpansive Ψ] (t : List Expr) : pre (ι := ι) (fun t => iprop(Ψ t ∧ get (ι := ι) t)) t ⊢ get (ι := ι) t := by - letI : NonExpansive - (fun t => iprop(Ψ t ∧ get (ι := ι) t)) := by - constructor - intro n x y hxy - change x = y at hxy - subst y - rfl + letI := list_nonexpansive + (fun t => iprop(Ψ t ∧ get (ι := ι) t)) rw [(twptp.unfold (ι := ι) t).to_eq] iintro Hpre iapply mono_pred (F := pre (ι := ι)) $$ [] %t Hpre @@ -186,13 +184,7 @@ theorem permutation {t₁ t₁' : List Expr} (Hp : t₁.Perm t₁') : get (ι := ι) t₁ ⊢ get (ι := ι) t₁' := by let Ψ := fun t : List Expr => iprop( ∀ t', ⌜t.Perm t'⌝ -∗ get (ι := ι) t') - have hΨ : NonExpansive Ψ := by - constructor - intro n x y hxy - change x = y at hxy - subst y - rfl - letI := hΨ + letI := list_nonexpansive Ψ iintro Ht iapply induction Ψ (ι := ι) ?_ $$ %t₁ Ht %t₁' %Hp iintro !> %t Hpre %t' %Htt' @@ -214,26 +206,14 @@ theorem app (t₁ t₂ : List Expr) : get (ι := ι) t₁ -∗ get (ι := ι) t₂ -∗ get (ι := ι) (t₁ ++ t₂) := by let Ψ₁ := fun t₁ : List Expr => iprop( ∀ t₂, get (ι := ι) t₂ -∗ get (ι := ι) (t₁ ++ t₂)) - have hΨ₁ : NonExpansive Ψ₁ := by - constructor - intro n x y hxy - change x = y at hxy - subst y - rfl - letI := hΨ₁ + letI := list_nonexpansive Ψ₁ iintro H₁ iapply induction Ψ₁ (ι := ι) ?_ $$ %t₁ H₁ %t₂ let Ψ₂ := fun t₂ : List Expr => iprop( ∀ t₁, pre (ι := ι) (fun t => iprop(Ψ₁ t ∧ get (ι := ι) t)) t₁ -∗ get (ι := ι) (t₁ ++ t₂)) - have hΨ₂ : NonExpansive Ψ₂ := by - constructor - intro n x y hxy - change x = y at hxy - subst y - rfl - letI := hΨ₂ + letI := list_nonexpansive Ψ₂ iintro !> %u₁ Hu₁ %u₂ Hu₂ iapply induction Ψ₂ (ι := ι) ?_ $$ %u₂ Hu₂ %u₁ Hu₁ iintro !> %r₂ Hr₂ %r₁ Hr₁ @@ -250,7 +230,7 @@ theorem app (t₁ t₂ : List Expr) : iframe %hκ Hσ iapply permutation Hperm.symm iapply IH₁ $$ %r₂ - iapply fold_right Ψ₂ r₂ (ι := ι) + iapply pre_and_get Ψ₂ r₂ (ι := ι) unfold pre iexact Hr₂ · imod Hr₂ $$ %r₂' %σ₁ %ns %κ %κs %σ₂ %nt %Hstep₂ Hσ with @@ -264,17 +244,7 @@ theorem app (t₁ t₂ : List Expr) : unfold pre iexact Hr₁ -private theorem cons (e : Expr) (es : List Expr) : - get (ι := ι) [e] -∗ get (ι := ι) es -∗ get (ι := ι) (e :: es) := by - simpa only [List.singleton_append] using app [e] es (ι := ι) - -private theorem cons_sep (e : Expr) (es : List Expr) : - get (ι := ι) [e] ∗ get (ι := ι) es ⊢ get (ι := ι) (e :: es) := by - iintro H - icases H with ⟨He, Hes⟩ - iapply cons e es (ι := ι) $$ He Hes - -private theorem nil : ⊢ get (ι := ι) ([] : List Expr) := by +private theorem get_nil : ⊢ get (ι := ι) ([] : List Expr) := by rw [(twptp.unfold (ι := ι) []).to_eq] unfold pre iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep @@ -303,13 +273,13 @@ private theorem step_singleton_inv (e : Expr) (t₂ : List Expr) obtain ⟨rfl, rfl, rfl⟩ := hpq exact ⟨red', efs, Hprim, by simp_all⟩ -private theorem singleton_list (es : List Expr) : +private theorem bigSepL_get_singleton (es : List Expr) : ([∗list] e ∈ es, get (ι := ι) [e]) ⊢ get (ι := ι) es := by induction es with | nil => simp only [Algebra.BigOpL.bigOpL_nil] iintro _ - exact nil (ι := ι) + exact get_nil (ι := ι) | cons e es IH => simp only [Algebra.BigOpL.bigOpL_cons] iintro Hes @@ -369,10 +339,10 @@ theorem of_twp (s : Stuckness) (e : Expr) (Φ : Val → IProp GF) : imodintro iexists (nt + efs.length) iframe %hκ Hσ - iapply cons_sep e₂ efs (ι := ι) - isplitl [IH₂] + rw [show e₂ :: efs = [e₂] ++ efs by simp] + iapply app [e₂] efs (ι := ι) $$ [IH₂] · iapply IH₂ $$ %rfl - · iapply singleton_list efs (ι := ι) + · iapply bigSepL_get_singleton efs (ι := ι) iapply BI.BigSepL.bigSepL_impl $$ Hefs iintro !> %k %ef %Hef Hef icases Hef with ⟨IHef, -⟩ @@ -380,8 +350,6 @@ theorem of_twp (s : Stuckness) (e : Expr) (Φ : Val → IProp GF) : end twptp -local instance : OFE (List Expr) := OFE.ofDiscrete _ - @[rocq_alias twptp_total] theorem twptp_total (t : List Expr) (σ : State) (ns nt : Nat) : stateInterp σ ns ([] : List Obs) nt -∗ twptp.get (ι := ι) t @@ -394,13 +362,7 @@ theorem twptp_total (t : List Expr) (σ : State) (ns nt : Nat) : |={⊤|}=> ⌜StronglyNormalizing (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) (t, σ)⌝) - have hΨ : NonExpansive Ψ := by - constructor - intro n x y hxy - change x = y at hxy - subst y - rfl - letI := hΨ + letI := list_nonexpansive Ψ iintro Hσ Ht iapply twptp.induction Ψ (ι := ι) ?_ $$ %t Ht %σ %ns %nt Hσ iintro !> %t diff --git a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean index 65476cbb7..0d04bb28e 100644 --- a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean +++ b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean @@ -17,7 +17,9 @@ open ProgramLogic Language.Notation Std OFE /-! # Total weakest preconditions -The total weakest precondition is the least fixed point of `twp.pre`. +This file provides the core definition and selected rules for total WP. Total WP +uses a least fixed point without a later modality and permits only +observation-free reductions. Further Iris-Rocq rules can be ported separately. -/ variable {hlc : outParam HasLC} {Expr State Obs Val} diff --git a/Iris/Iris/Tests/TotalWeakestPre.lean b/Iris/Iris/Tests/TotalWeakestPre.lean index 836c0ac82..fd55e7d24 100644 --- a/Iris/Iris/Tests/TotalWeakestPre.lean +++ b/Iris/Iris/Tests/TotalWeakestPre.lean @@ -279,17 +279,6 @@ example : end CoreRuleChecks -section TotalEctxRuleChecks - -example := @twp_lift_base_step -example := @twp_lift_base_step_no_fork -example := @twp_lift_pure_base_step_no_fork -example := @twp_lift_atomic_base_step -example := @twp_lift_atomic_base_step_no_fork -example := @twp_lift_pure_det_base_step_no_fork - -end TotalEctxRuleChecks - section HeapLangPureSmoke open Iris.HeapLang @@ -323,6 +312,114 @@ theorem heapLang_add_twp : end HeapLangPureSmoke +namespace Forking + +inductive Expr where + | done + | fork + +abbrev Val := Unit +abbrev State := Unit +abbrev Obs := Unit + +instance : ToVal Expr Val where + toVal + | .done => some () + | .fork => none + ofVal _ := .done + coe_of_toVal_eq_some := by + intro e v h + cases e <;> simp_all + toVal_coe := by simp + +inductive Step : Expr → State → List Obs → Expr → State → List Expr → Prop + | fork : Step .fork () [] .done () [.done] + +instance : PrimStep Expr State (List Obs) where + primStep + | (e₁, σ₁), κ, (e₂, σ₂, efs) => Step e₁ σ₁ κ e₂ σ₂ efs + +instance : Language Expr State Obs Val where + val_stuck := by + intro e σ κ e' σ' efs H + cases H + rfl + +section + +variable [InvGS_gen .hasNoLC GF] + +noncomputable local instance forkIrisGS : IrisGS_gen .hasNoLC Expr GF where + toStateInterp := ⟨fun _ _ _ _ => iprop(True)⟩ + numLatersPerStep := fun _ => 0 + forkPost := fun _ => iprop(True) + stateInterp_mono := by + intro σ ns obs nt + iintro _ + imodintro + itrivial + +theorem fork_twp : + ⊢ WP Expr.fork @ Stuckness.NotStuck ; ⊤ [{ + fun _ : Val => (iprop(True) : IProp GF) }] := by + iapply twp_lift_atomic_step (e₁ := Expr.fork) rfl + iintro %σ %ns %obs %nt _ + imodintro + isplit + · ipureintro + cases σ + exact ⟨.done, (), [.done], Step.fork⟩ + · iintro %κ %e₂ %σ₂ %efs %Hstep + cases Hstep + imodintro + isplit + · ipureintro + rfl + · isplitl [] + · change ⊢ iprop(True) + itrivial + · isplitl [] + · iexists () + isplit + · ipureintro + rfl + · itrivial + · simp only [Algebra.BigOpL.bigOpL_cons, + Algebra.BigOpL.bigOpL_nil] + isplit + · iapply twp.value (v := ()) rfl + change ⊢ iprop(True) + itrivial + · itrivial + +end + +theorem fork_stronglyNormalizing : + StronglyNormalizing + (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) + ([Expr.fork], ()) := by + apply twp_total (hlc := .hasNoLC) (GF := GF) + Stuckness.NotStuck Expr.fork () + (fun _ : Val => (iprop(True) : IProp GF)) 0 0 + iintro %Hinv + imodintro + iexists + (fun (_ : State) (_ : Nat) (_ : List Obs) (_ : Nat) => + (iprop(True) : IProp GF)), + (fun _ => 0), + (fun _ : Val => (iprop(True) : IProp GF)), + (fun _ _ _ _ => by + iintro _ + imodintro + itrivial) + dsimp only + isplitl [] + · itrivial + · iintro _ + iapply fork_twp + +end Forking + theorem branch_stronglyNormalizing (n initialState : Nat) : StronglyNormalizing (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) @@ -378,19 +475,4 @@ theorem put_stronglyNormalizing (n initialState : Nat) : · iintro _ iapply put_twp n -/-! Negative semantic boundary checks. -/ - -example : toVal Expr.stuck = (none : Option Val) := rfl - -example (σ : State) : PrimStep.Irreducible (Expr.stuck, σ) := by - intro κ e₂ σ₂ efs H - cases H - -example (σ : State) : PrimStep.Reducible (Expr.observe, σ) := - ⟨[()], .val 0, σ, [], Step.observe σ⟩ - -example (σ : State) : ¬ PrimStep.ReducibleNoObs (Expr.observe, σ) := by - rintro ⟨e₂, σ₂, efs, H⟩ - cases H - end Iris.Tests.TotalWeakestPre From aace5112e9a22829d1adf0ecad7766bcda798838 Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Sat, 8 Aug 2026 00:28:03 +0200 Subject: [PATCH 7/9] Pass WIP --- Iris/Iris/BI/WeakestPre.lean | 35 +- Iris/Iris/ProgramLogic/TotalWeakestPre.lean | 411 ++++++-------------- Iris/Iris/Tests/WeakestPre.lean | 82 ++-- 3 files changed, 194 insertions(+), 334 deletions(-) diff --git a/Iris/Iris/BI/WeakestPre.lean b/Iris/Iris/BI/WeakestPre.lean index 2090b5cf7..aef4d25a5 100644 --- a/Iris/Iris/BI/WeakestPre.lean +++ b/Iris/Iris/BI/WeakestPre.lean @@ -55,6 +55,7 @@ syntax " [" noWs "{ " wpPostcondInner " }" noWs "] " : wpPostcond syntax (name := wp) "WP " wpExpr wpPostcond : term syntax texanPostcondInner := ((ppSpace (binderIdent <|> bracketedBinder))+ ", ")? " RET " term:min "; " term:min + declare_syntax_cat texanPostcond syntax " {" noWs "{ " texanPostcondInner " }" noWs "} " : texanPostcond declare_syntax_cat texanPrecond @@ -62,10 +63,13 @@ syntax " {" noWs "{ " term:min " }" noWs "} " : texanPrecond syntax (name := texanTriple) texanPrecond wpExpr texanPostcond : term -syntax (name := totalTexanTriple) - "[[{" term:min "}]]" wpExpr - "[[{" ((ppSpace (binderIdent <|> bracketedBinder))+ ", ")? - "RET " term:min "; " term:min "}]]" : term + +declare_syntax_cat totalTexanPostcond +syntax " [" noWs "{ " texanPostcondInner " }" noWs "] " : totalTexanPostcond +declare_syntax_cat totalTexanPrecond +syntax " [" noWs "{ " term:min " }" noWs "] " : totalTexanPrecond + +syntax (name := totalTexanTriple) totalTexanPrecond wpExpr totalTexanPostcond : term open Lean in meta def parseWpExpr : Lean.TSyntax ``wpExpr → Lean.MacroM (TSyntax `term × TSyntax `term × TSyntax `term) := fun @@ -127,6 +131,13 @@ meta def parseTexanTriple : Syntax → MacroM Term `(iprop(∀ $xs*, $Q:term -∗ Φ $pat)) | none => `($Q:term -∗ Φ $pat) `(∀ Φ, $P -∗ ▷ $k -∗ (WP $wpExpr {{ Φ }})) + | `([{ $P:term }] $wpExpr [{ $[$[$xs]* ,]? RET $pat ; $Q:term }]) => do + let k ← match xs with + | some xs => + let xs ← transformTexanBinders xs + `(iprop(∀ $xs*, $Q:term -∗ Φ $pat)) + | none => `($Q:term -∗ Φ $pat) + `(∀ Φ, $P -∗ $k -∗ (WP $wpExpr [{ Φ }])) | _ => Lean.Macro.throwUnsupported @[macro Iris.BI.iprop] @@ -134,21 +145,7 @@ meta def wpTexanTriple : Lean.Macro | `(iprop($P)) => do `(iprop(□ $(← parseTexanTriple P))) | _ => Lean.Macro.throwUnsupported -@[macro totalTexanTriple] -meta def totalWpTexanTriple : Lean.Macro - | `([[{ $P:term }]] $wpExpr - [[{ $[$[$xs]* ,]? RET $pat ; $Q:term }]]) => do - let k ← match xs with - | some xs => - let xs ← transformTexanBinders xs - `(iprop(∀ $xs*, $Q:term -∗ Φ $pat)) - | none => `($Q:term -∗ Φ $pat) - let (e, s, E) ← parseWpExpr wpExpr - `(iprop(∀ Φ, $P -∗ $k -∗ - TotalWp.totalWp $s $E $e Φ)) - | _ => Lean.Macro.throwUnsupported - -@[macro texanTriple] +@[macro texanTriple, macro totalTexanTriple] meta def wpTexanTripleTerm : Lean.Macro | P => do `(⊢ $(← parseTexanTriple P)) diff --git a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean index 0d04bb28e..0c471edf1 100644 --- a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean +++ b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean @@ -40,61 +40,53 @@ local instance : OFE Val := OFE.ofDiscrete _ namespace Internal abbrev Args (Expr Val : Type _) (GF : BundledGFunctors) := - (CoPset × Expr) × (Val → IProp GF) + CoPset × Expr × (Val → IProp GF) end Internal @[rocq_alias twp_pre] -def pre (s : Stuckness) - (twp : CoPset → Expr → (Val → IProp GF) → IProp GF) - (E : CoPset) (e₁ : Expr) (Φ : Val → IProp GF) : IProp GF := +def pre (s : Stuckness) (twp : CoPset → Expr → (Val → IProp GF) → IProp GF) (E : CoPset) + (e₁ : Expr) (Φ : Val → IProp GF) : IProp GF := match toVal e₁ with - | some v => iprop(|={E}=> Φ v) - | none => iprop(∀ (σ₁ : State) (ns : Nat) (obs : List Obs) (nt : Nat), - stateInterp σ₁ ns obs nt ={E,∅}=∗ - ⌜s.MaybeReducibleNoObs (e₁, σ₁)⌝ ∗ - ∀ (κ : List Obs) e₂ σ₂ eₜ, - ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ - ⌜κ = []⌝ ∗ - stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ - twp E e₂ Φ ∗ - [∗list] e' ∈ eₜ, twp ⊤ e' ι.forkPost) + | some v => iprop% |={E}=> Φ v + | none => iprop% ∀ (σ₁ : State) (ns : Nat) (obs : List Obs) (nt : Nat), + stateInterp σ₁ ns obs nt ={E,∅}=∗ + ⌜s.MaybeReducibleNoObs (e₁, σ₁)⌝ ∗ + ∀ (κ : List Obs) e₂ σ₂ eₜ, + ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ + ⌜κ = []⌝ ∗ + stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ + twp E e₂ Φ ∗ + [∗list] e' ∈ eₜ, twp ⊤ e' ι.forkPost namespace Internal -def pre' (s : Stuckness) - (X : Args Expr Val GF → IProp GF) : Args Expr Val GF → IProp GF - | ((E, e), Φ) => pre s (fun E e Φ => X ((E, e), Φ)) E e Φ +def pre' (s : Stuckness) (X : Args Expr Val GF → IProp GF) : Args Expr Val GF → IProp GF + | (E, e, Φ) => pre s (fun E e Φ => X (E, e, Φ)) E e Φ end Internal @[rocq_alias twp_pre_mono] -theorem pre_mono (s : Stuckness) - (X Y : CoPset → Expr → (Val → IProp GF) → IProp GF) : +theorem pre_mono (s : Stuckness) (X Y : CoPset → Expr → (Val → IProp GF) → IProp GF) : ⊢ □ (∀ E e Φ, X E e Φ -∗ Y E e Φ) -∗ ∀ E e Φ, pre s X E e Φ -∗ pre s Y E e Φ := by iintro #H %E %e %Φ Hpre unfold pre cases toVal e with - | some => - imod Hpre with Hpre - imodintro - iexact Hpre + | some => itrivial | none => iintro %σ₁ %ns %obs %nt Hσ imod Hpre $$ Hσ with ⟨%Hred, Hstep⟩ - imodintro iframe %Hred - iintro %κ %e₂ %σ₂ %eₜ %Hprim - imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with - ⟨%hκ, Hσ, He₂, Hefs⟩ + iintro !> %κ %e₂ %σ₂ %eₜ Hprim + imod Hstep $$ Hprim with ⟨%hκ, Hσ, He₂, Hefs⟩ imodintro iframe %hκ Hσ isplitl [He₂] - · iapply H $$ %E %e₂ %Φ He₂ + · iapply H $$ He₂ · iapply BI.BigSepL.bigSepL_impl $$ Hefs iintro !> %k %ef %Hef Hef - iapply H $$ %⊤ %ef %ι.forkPost Hef + iapply H $$ Hef namespace Internal @@ -102,16 +94,12 @@ instance pre'_mono (s : Stuckness) : BIMonoPred (pre' (ι := ι) s) where mono_pred := by intro X Y _ _ iintro #HXY %x HX - rcases x with ⟨⟨E, e⟩, Φ⟩ - simp only [pre'] - iapply pre_mono s (fun E e Φ => X ((E, e), Φ)) - (fun E e Φ => Y ((E, e), Φ)) $$ [] %E %e %Φ HX + rcases x with ⟨E, e, Φ⟩ + unfold pre' + iapply pre_mono s (fun E e Φ => X (E, e, Φ)) (fun E e Φ => Y (E, e, Φ)) $$ [] [$] iintro !> %E %e %Φ H - iapply HXY $$ %((E, e), Φ) H - mono_pred_ne.ne {X} a b h := by - rcases a with ⟨⟨E₁, e₁⟩, Φ₁⟩ - rcases b with ⟨⟨E₂, e₂⟩, Φ₂⟩ - rcases h with ⟨⟨hE, he⟩, hΦ⟩ + iapply HXY $$ H + mono_pred_ne.ne {n} := fun ⟨E₁, e₁, Φ₁⟩ ⟨E₂, e₂, Φ₂⟩ ⟨hE, he, hΦ⟩ => by change E₁ = E₂ at hE change e₁ = e₂ at he subst E₂ @@ -137,15 +125,11 @@ instance pre'_mono (s : Stuckness) : BIMonoPred (pre' (ι := ι) s) where refine BI.sep_ne.ne .rfl ?_ refine BI.sep_ne.ne ?_ ?_ · apply NonExpansive.ne - exact ⟨⟨.rfl, .rfl⟩, hΦ⟩ - · exact .rfl + exact ⟨.rfl, .rfl, hΦ⟩ + · rfl -def get (s : Stuckness) (E : CoPset) (e : Expr) - (Φ : Val → IProp GF) : IProp GF := - letI : OFE CoPset := OFE.ofDiscrete _ - letI : OFE Expr := OFE.ofDiscrete _ - letI : OFE Val := OFE.ofDiscrete _ - bi_least_fixpoint (pre' (ι := ι) s) ((E, e), Φ) +def get (s : Stuckness) (E : CoPset) (e : Expr) (Φ : Val → IProp GF) : IProp GF := + bi_least_fixpoint (pre' s) (E, e, Φ) end Internal @@ -154,73 +138,49 @@ instance instTotalWp : TotalWp (IProp GF) Expr Val Stuckness where section Rules -local instance : OFE CoPset := OFE.ofDiscrete _ -local instance : OFE Expr := OFE.ofDiscrete _ -local instance : OFE Val := OFE.ofDiscrete _ - @[rocq_alias twp_unfold] theorem unfold {s E} {e : Expr} {Φ : Val → IProp GF} : - WP e @ s ; E [{ Φ }] ⊣⊢ pre s (TotalWp.totalWp (PROP := IProp GF) s) E e Φ := by - change bi_least_fixpoint (Internal.pre' (ι := ι) s) ((E, e), Φ) ⊣⊢ _ - exact BI.equiv_iff.1 (least_fixpoint_unfold (Internal.pre' (ι := ι) s)) + WP e @ s ; E [{ Φ }] ⊣⊢ pre s (TotalWp.totalWp s) E e Φ := + BI.equiv_iff.1 (least_fixpoint_unfold (Internal.pre' s)) @[rocq_alias twp_ind] -theorem induction (s : Stuckness) - (Ψ : CoPset → Expr → (Val → IProp GF) → IProp GF) - [HΨ : NonExpansive - (fun x : Internal.Args Expr Val GF => Ψ x.1.1 x.1.2 x.2)] : - (⊢ □ (∀ E e Φ, - pre s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) E e Φ -∗ - Ψ E e Φ)) → +theorem induction (s : Stuckness) (Ψ : CoPset → Expr → (Val → IProp GF) → IProp GF) + [HΨ : NonExpansive (fun x : Internal.Args Expr Val GF => Ψ x.1 x.2.1 x.2.2)] : + (⊢ □ (∀ E e Φ, pre s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) E e Φ -∗ Ψ E e Φ)) → ⊢ ∀ E e Φ, WP e @ s ; E [{ Φ }] -∗ Ψ E e Φ := by intro H - have H' : ⊢ □ (∀ E e Φ, - pre s (fun E e Φ => - iprop(Ψ E e Φ ∧ - bi_least_fixpoint (Internal.pre' (ι := ι) s) ((E, e), Φ))) - E e Φ -∗ Ψ E e Φ) := by - simpa only [TotalWp.totalWp, instTotalWp, Internal.get] using H iintro %E %e %Φ - change ⊢ bi_least_fixpoint (Internal.pre' (ι := ι) s) ((E, e), Φ) -∗ Ψ E e Φ + change ⊢ bi_least_fixpoint (Internal.pre' s) (E, e, Φ) -∗ Ψ E e Φ iintro Htwp - iapply least_fixpoint_ind (F := Internal.pre' (ι := ι) s) - (Φ := fun x => Ψ x.1.1 x.1.2 x.2) $$ [] Htwp - iintro !> %x - rcases x with ⟨⟨E, e⟩, Φ⟩ + iapply least_fixpoint_ind (F := Internal.pre' s) (Φ := fun x => Ψ x.1 x.2.1 x.2.2) $$ [] Htwp + iintro !> %⟨E, e, Φ⟩ simp only [Internal.pre'] - iintro Hx - iapply H' - iexact Hx + simp only [TotalWp.totalWp, Internal.get] at H + iapply H @[rocq_alias twp_ne] instance ne {s : Stuckness} {E} {e : Expr} : NonExpansive (TotalWp.totalWp (PROP := IProp GF) s E e) where ne {n Φ₁ Φ₂} HΦ := by - change bi_least_fixpoint (Internal.pre' (ι := ι) s) ((E, e), Φ₁) ≡{n}≡ - bi_least_fixpoint (Internal.pre' (ι := ι) s) ((E, e), Φ₂) + change bi_least_fixpoint (Internal.pre' s) (E, e, Φ₁) ≡{n}≡ _ apply NonExpansive.ne - exact ⟨⟨.rfl, .rfl⟩, fun v => HΦ v⟩ + exact ⟨.rfl, .rfl, HΦ⟩ @[rocq_alias twp_value_fupd'] theorem value_fupd' {s : Stuckness} {E} {Φ : Val → IProp GF} {v : Val} : WP (v : Expr) @ s ; E [{ Φ }] ⊣⊢ |={E}=> Φ v := by - simp [unfold.to_eq, pre, toVal_coe, BI.BIBase.BiEntails.rfl] + simp [unfold.to_eq, pre, toVal_coe] @[rocq_alias twp_strong_mono] theorem strong_mono {s₁ s₂ : Stuckness} {E₁ E₂} {e : Expr} {Φ Ψ : Val → IProp GF} (hs : s₁ ≤ s₂) (hE : E₁ ⊆ E₂) : ⊢ WP e @ s₁ ; E₁ [{ Φ }] -∗ (∀ v, Φ v ={E₂}=∗ Ψ v) -∗ WP e @ s₂ ; E₂ [{ Ψ }] := by - let Pred := fun (E : CoPset) (e : Expr) (Φ : Val → IProp GF) => iprop( - ∀ E₂ Ψ, ⌜E ⊆ E₂⌝ -∗ (∀ v, Φ v ={E₂}=∗ Ψ v) -∗ - WP e @ s₂ ; E₂ [{ Ψ }]) - have hPred : NonExpansive - (fun x : Internal.Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by + let Pred := fun (E : CoPset) (e : Expr) (Φ : Val → IProp GF) => iprop% + ∀ E₂ Ψ, ⌜E ⊆ E₂⌝ -∗ (∀ v, Φ v ={E₂}=∗ Ψ v) -∗ WP e @ s₂ ; E₂ [{ Ψ }] + have hPred : NonExpansive (fun x : Internal.Args Expr Val GF => Pred x.1 x.2.1 x.2.2) := by constructor - intro n x y h - rcases x with ⟨⟨EX, eX⟩, ΦX⟩ - rcases y with ⟨⟨EY, eY⟩, ΦY⟩ - rcases h with ⟨⟨hE', he'⟩, hΦ⟩ + intro n ⟨EX, eX, ΦX⟩ ⟨EY, eY, ΦY⟩ ⟨hE', he', hΦ⟩ change EX = EY at hE' change eX = eY at he' subst EY @@ -231,20 +191,17 @@ theorem strong_mono {s₁ s₂ : Stuckness} {E₁ E₂} {e : Expr} refine BI.wand_ne.ne ?_ .rfl refine BI.forall_ne fun v => ?_ exact BI.wand_ne.ne (hΦ v) .rfl - letI := hPred iintro H HΦ - iapply induction s₁ Pred (ι := ι) ?_ $$ H + iapply induction s₁ Pred $$ H [//] [$] · iintro !> %E %e₁ %Φ₁ IH %E' %Ψ' %hE' rw [unfold.to_eq] unfold pre cases hval : toVal e₁ with | some v => - dsimp only iintro HpostSome imod fupd_mask_mono hE' $$ IH with HΦv iapply HpostSome $$ HΦv | none => - dsimp only iintro HpostNone iintro %σ₁ %ns %obs %nt Hσ imod fupd_mask_subseteq hE' with Hclose @@ -254,25 +211,20 @@ theorem strong_mono {s₁ s₂ : Stuckness} {E₁ E₂} {e : Expr} · ipureintro simp only [LE.le] at hs grind [cases Stuckness] - · iintro %κ %e₂ %σ₂ %eₜ %Hprim - imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with - ⟨%hκ, Hσ, He₂, Hefs⟩ + · iintro %κ %e₂ %σ₂ %eₜ Hprim + imod Hstep $$ Hprim with ⟨%hκ, Hσ, He₂, Hefs⟩ imod Hclose imodintro iframe %hκ Hσ isplitl [He₂ HpostNone] · icases He₂ with ⟨IH₂, -⟩ - iapply IH₂ $$ %E' %Ψ' %hE' HpostNone + iapply IH₂ $$ [//] HpostNone · iapply BI.BigSepL.bigSepL_impl $$ Hefs iintro !> %k %ef %Hef Hef icases Hef with ⟨IHef, -⟩ iapply IHef $$ %⊤ %ι.forkPost %LawfulSet.subset_refl iintro %v Hv - imodintro - iexact Hv - · ipureintro - exact hE - · iexact HΦ + itrivial @[rocq_alias fupd_twp] theorem fupd_twp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : @@ -282,95 +234,67 @@ theorem fupd_twp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : unfold pre cases toVal e · iintro %σ %ns %obs %nt Hσ - imod H with H - iapply H $$ Hσ - · imod H - iassumption + imod H $$ Hσ with $ + · imod H with $ @[rocq_alias twp_fupd] theorem twp_fupd {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : WP e @ s ; E [{ v, |={E}=> Φ v }] ⊢ WP e @ s ; E [{ Φ }] := by iintro H iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ H - iintro %v Hv - iexact Hv + iintro %v $ @[rocq_alias twp_atomic] theorem atomic {s : Stuckness} {E₁ E₂ : CoPset} {e : Expr} {Φ : Val → IProp GF} [hatom : Language.Atomic ↑s e] : - (|={E₁,E₂}=> WP e @ s ; E₂ [{ v, |={E₂,E₁}=> Φ v }]) - ⊢ WP e @ s ; E₁ [{ Φ }] := by + (|={E₁,E₂}=> WP e @ s ; E₂ [{ v, |={E₂,E₁}=> Φ v }]) ⊢ WP e @ s ; E₁ [{ Φ }] := by rw [unfold.to_eq, unfold.to_eq] iintro H unfold pre cases he : toVal e with - | some v => - dsimp only - imod H - imod H - iassumption + | some v => icases H with > >$ | none => - dsimp only iintro %σ₁ %ns %obs %nt Hσ - imod H - imod H $$ Hσ with ⟨%Hred, Hstep⟩ + imod H $$ Hσ with >⟨$, Hstep⟩ imodintro - iframe %Hred cases s · iintro %κ %e₂ %σ₂ %eₜ %Hprim - imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with - ⟨%hκ, Hσ, He₂, Hefs⟩ + imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with ⟨%hκ, Hσ, He₂, Hefs⟩ cases he₂ : toVal e₂ with | some v₂ => - icases unfold $$ He₂ with He₂ - simp only [pre, he₂] - imod He₂ - imod He₂ - imodintro - iframe %hκ Hσ Hefs rw [unfold.to_eq] simp only [pre, he₂] - imodintro - iexact He₂ + icases He₂ with > >He₂ + iframe %hκ Hσ Hefs + simp only [unfold.to_eq, pre, he₂] + itrivial | none => - icases unfold $$ He₂ with He₂ + rw [unfold.to_eq] simp only [pre, he₂] - imod He₂ $$ %σ₂ %(ns + 1) %obs %(nt + eₜ.length) Hσ with - ⟨%Hred₂, _⟩ - exact (Language.not_reducible_iff_irreducible.mpr - (hatom.atomic Hprim)) + imod He₂ $$ %σ₂ %(ns + 1) %obs %(nt + eₜ.length) Hσ with ⟨%Hred₂, _⟩ + exact (Language.not_reducible_iff_irreducible.mpr (hatom.atomic Hprim)) (Language.reducible_of_reducibleNoObs Hred₂) |>.elim · iintro %κ %e₂ %σ₂ %eₜ %Hprim - imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with - ⟨%hκ, Hσ, He₂, Hefs⟩ + imod Hstep $$ [//] with ⟨%hκ, Hσ, He₂, Hefs⟩ have ⟨v₂, hv₂⟩ := Option.isSome_iff_exists.mp (hatom.atomic Hprim) - icases unfold $$ He₂ with He₂ - simp only [pre, hv₂] - imod He₂ - imod He₂ - imodintro - iframe %hκ Hσ Hefs rw [unfold.to_eq] simp only [pre, hv₂] - imodintro - iexact He₂ + imod He₂ with >He₂ + iframe %hκ Hσ Hefs + simp only [unfold.to_eq, pre, hv₂] + itrivial @[rocq_alias twp_bind] theorem bind (K : Expr → Expr) [ctx : Language.Context K] {s : Stuckness} {E : CoPset} {e : Expr} {Φ : Val → IProp GF} : TotalWp.totalWp s E e - (fun v : Val => iprop(WP (K (v : Expr)) @ s ; E [{ Φ }])) - ⊢ WP (K e) @ s ; E [{ Φ }] := by - let Pred := fun (E : CoPset) (e : Expr) (Ψ : Val → IProp GF) => iprop( - ∀ Φ, (∀ v, Ψ v -∗ WP (K (v : Expr)) @ s ; E [{ Φ }]) -∗ - WP (K e) @ s ; E [{ Φ }]) - have hPred : NonExpansive - (fun x : Internal.Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by + (fun v : Val => iprop(WP (K v) @ s ; E [{ Φ }])) ⊢ WP (K e) @ s ; E [{ Φ }] := by + let Pred := fun (E : CoPset) (e : Expr) (Ψ : Val → IProp GF) => iprop% + ∀ Φ, (∀ v, Ψ v -∗ WP (K v) @ s ; E [{ Φ }]) -∗ + WP (K e) @ s ; E [{ Φ }] + letI : NonExpansive (fun x : Internal.Args Expr Val GF => Pred x.1 x.2.1 x.2.2) := by constructor - intro n x y hxy - rcases x with ⟨⟨EX, eX⟩, ΨX⟩ - rcases y with ⟨⟨EY, eY⟩, ΨY⟩ - rcases hxy with ⟨⟨hE, he⟩, hΨ⟩ + intro n ⟨EX, eX, ΨX⟩ ⟨EY, eY, ΨY⟩ ⟨hE, he, hΨ⟩ change EX = EY at hE change eX = eY at he subst EY @@ -379,16 +303,14 @@ theorem bind (K : Expr → Expr) [ctx : Language.Context K] refine BI.wand_ne.ne ?_ .rfl refine BI.forall_ne fun v => ?_ exact BI.wand_ne.ne (hΨ v) .rfl - letI := hPred iintro H - iapply induction s Pred (ι := ι) ?_ $$ H + iapply induction s Pred $$ H · iintro !> %E %e %Ψ cases he : toVal e with | some v => simp only [pre, he] iintro Hpre %Φ Hcont - have heq := ToVal.coe_of_toVal_eq_some he - rw [← heq] + rw [← (ToVal.coe_of_toVal_eq_some he)] ispecialize Hcont $$ %v iapply fupd_twp iapply (fupd_wand_left (P := Ψ v)) @@ -409,51 +331,35 @@ theorem bind (K : Expr → Expr) [ctx : Language.Context K] · trivial · iintro %κ %e₂ %σ₂ %eₜ %HKstep obtain ⟨e₂', rfl, Hprim⟩ := ctx.primStep_fill_inv he HKstep - imod Hstep $$ %κ %e₂' %σ₂ %eₜ %Hprim with - ⟨%hκ, Hσ, He₂, Hefs⟩ - imodintro + imod Hstep $$ [//] with ⟨%hκ, Hσ, He₂, Hefs⟩ iframe %hκ Hσ isplitl [He₂ Hcont] - icases He₂ with ⟨IH, -⟩ - iapply IH $$ %Φ Hcont - iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef Hef - icases Hef with ⟨-, Hef⟩ - iexact Hef - · iintro %v Hv - iexact Hv + · icases He₂ with ⟨IH, -⟩ + iapply IH $$ Hcont + · iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef !>⟨-, $⟩ + · iintro %_ $ private theorem fold_induction_right (Ψ : CoPset → Expr → (Val → IProp GF) → IProp GF) (s : Stuckness) (E : CoPset) (e : Expr) (Φ : Val → IProp GF) : - pre s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) - E e Φ ⊢ WP e @ s ; E [{ Φ }] := by + pre s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) E e Φ ⊢ WP e @ s ; E [{ Φ }] := by rw [unfold.to_eq] iintro Hpre - iapply (pre_mono s - (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) - (TotalWp.totalWp s)) $$ [] %E %e %Φ Hpre - iintro !> %E %e %Φ H - icases H with ⟨-, H⟩ - iexact H + iapply pre_mono s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) $$ [] %E %e %Φ Hpre + iintro !> %E %e %Φ ⟨-, $⟩ @[rocq_alias twp_bind_inv] theorem bind_inv (K : Expr → Expr) [ctx : Language.Context K] {s : Stuckness} {E : CoPset} {e : Expr} {Φ : Val → IProp GF} : WP (K e) @ s ; E [{ Φ }] ⊢ - TotalWp.totalWp s E e - (fun v : Val => iprop(WP (K (v : Expr)) @ s ; E [{ Φ }])) := by - let Pred := fun (E : CoPset) (e' : Expr) (Φ : Val → IProp GF) => iprop( + TotalWp.totalWp s E e (fun v : Val => iprop(WP (K v) @ s ; E [{ Φ }])) := by + let Pred := fun (E : CoPset) (e' : Expr) (Φ : Val → IProp GF) => iprop% ∀ e, ⌜e' = K e⌝ -∗ - TotalWp.totalWp s E e - (fun v : Val => iprop(WP (K (v : Expr)) @ s ; E [{ Φ }]))) - have hPred : NonExpansive - (fun x : Internal.Args Expr Val GF => Pred x.1.1 x.1.2 x.2) := by + TotalWp.totalWp s E e (fun v : Val => iprop(WP (K v) @ s ; E [{ Φ }])) + letI : NonExpansive (fun x : Internal.Args Expr Val GF => Pred x.1 x.2.1 x.2.2) := by constructor - intro n x y hxy - rcases x with ⟨⟨EX, eX⟩, ΦX⟩ - rcases y with ⟨⟨EY, eY⟩, ΦY⟩ - rcases hxy with ⟨⟨hE, he⟩, hΦ⟩ + intro n ⟨EX, eX, ΦX⟩ ⟨EY, eY, ΦY⟩ ⟨hE, he, hΦ⟩ change EX = EY at hE change eX = eY at he subst EY @@ -462,42 +368,19 @@ theorem bind_inv (K : Expr → Expr) [ctx : Language.Context K] refine BI.wand_ne.ne .rfl ?_ apply NonExpansive.ne exact fun _ => NonExpansive.ne hΦ - letI := hPred iintro H - iapply induction s Pred (ι := ι) ?_ $$ H %e %rfl + iapply induction s Pred $$ H %e %rfl iintro !> %E %e' %Φ IH %e %heq subst e' rw [unfold.to_eq] cases he : toVal e with | some v => - ihave IHfold := fold_induction_right Pred s E (K e) Φ (ι := ι) $$ IH + ihave IHfold := fold_induction_right $$ IH simp only [pre, he] - have heq := ToVal.coe_of_toVal_eq_some he - subst e - imodintro - iexact IHfold + rw [← (ToVal.coe_of_toVal_eq_some he)] + itrivial | none => - simp only [pre, he] - have hK : toVal (K e) = none := ctx.toVal_eq_none_fill he - let unfolded := iprop( - ∀ (σ₁ : State) (ns : Nat) (obs : List Obs) (nt : Nat), - stateInterp σ₁ ns obs nt ={E,∅}=∗ - ⌜s.MaybeReducibleNoObs (K e, σ₁)⌝ ∗ - ∀ (κ : List Obs) e₂ σ₂ eₜ, - ⌜(K e, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={∅,E}=∗ - ⌜κ = []⌝ ∗ - stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ - (Pred E e₂ Φ ∧ WP e₂ @ s ; E [{ Φ }]) ∗ - [∗list] e' ∈ eₜ, - (Pred ⊤ e' ι.forkPost ∧ - WP e' @ s ; ⊤ [{ ι.forkPost }])) - have hIH : - (match toVal (K e) with - | some v => iprop(|={E}=> Φ v) - | none => unfolded) ⊢ unfolded := by - simp only [hK] - exact .rfl - icases hIH $$ IH with IH + simp only [pre, he, ctx.toVal_eq_none_fill he] iintro %σ₁ %ns %obs %nt Hσ imod IH $$ Hσ with ⟨%Hred, Hstep⟩ imodintro @@ -507,17 +390,13 @@ theorem bind_inv (K : Expr → Expr) [ctx : Language.Context K] · exact Language.Context.reducibleNoObs_fill_inv (K := K) he Hred · trivial · iintro %κ %e₂ %σ₂ %eₜ %Hprim - imod Hstep $$ %κ %(K e₂) %σ₂ %eₜ - %(ctx.primStep_fill Hprim) with ⟨%hκ, Hσ, He₂, Hefs⟩ + imod Hstep $$ %_ %_ %_ %_ %(ctx.primStep_fill Hprim) with ⟨$, $, He₂, Hefs⟩ imodintro - iframe %hκ Hσ isplitl [He₂] · icases He₂ with ⟨IH₂, -⟩ iapply IH₂ $$ %e₂ %rfl · iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef Hef - icases Hef with ⟨-, Hef⟩ - iexact Hef + iintro !> %k %ef %Hef ⟨-, $⟩ @[rocq_alias twp_mono] theorem mono {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} @@ -526,19 +405,14 @@ theorem mono {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} iintro Hwp iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ Hwp iintro %v Hv - imodintro - iapply H v - iexact Hv + iapply H $$ [$] @[rocq_alias twp_stuck_mono] -theorem stuck_mono {s₁ s₂ : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} - (H : s₁ ≤ s₂) : +theorem stuck_mono {s₁ s₂ : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} (H : s₁ ≤ s₂) : WP e @ s₁ ; E [{ Φ }] ⊢ WP e @ s₂ ; E [{ Φ }] := by iintro Hwp iapply strong_mono H LawfulSet.subset_refl $$ Hwp - iintro %v Hv - imodintro - iexact Hv + iintro %v $ @[rocq_alias twp_stuck_weaken] theorem stuck_weaken {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : @@ -551,28 +425,22 @@ theorem mask_mono {s : Stuckness} {E₁ E₂} {e : Expr} {Φ : Val → IProp GF} WP e @ s ; E₁ [{ Φ }] ⊢ WP e @ s ; E₂ [{ Φ }] := by iintro Hwp iapply strong_mono (Std.IsPreorder.le_refl _) H $$ Hwp - iintro %v Hv - imodintro - iexact Hv + iintro %v $ @[rocq_alias twp_value_fupd] -theorem value_fupd {s : Stuckness} {E} {e : Expr} {v : Val} - {Φ : Val → IProp GF} (h : e = (v : Expr)) : +theorem value_fupd {s : Stuckness} {E} {e : Expr} {v : Val} {Φ : Val → IProp GF} (h : e = v) : WP e @ s ; E [{ Φ }] ⊣⊢ |={E}=> Φ v := by - subst e - exact value_fupd' + simp [h, value_fupd'] @[rocq_alias twp_value'] theorem value' {s : Stuckness} {E} {v : Val} {Φ : Val → IProp GF} : Φ v ⊢ WP (v : Expr) @ s ; E [{ Φ }] := by - rw [value_fupd'.to_eq] - exact fupd_intro + simp [value_fupd'.to_eq, fupd_intro] @[rocq_alias twp_value] -theorem value {s : Stuckness} {E} {e : Expr} {v : Val} {Φ : Val → IProp GF} - (h : e = (v : Expr)) : Φ v ⊢ WP e @ s ; E [{ Φ }] := by - subst e - exact value' +theorem value {s : Stuckness} {E} {e : Expr} {v : Val} {Φ : Val → IProp GF} (h : e = v) : + Φ v ⊢ WP e @ s ; E [{ Φ }] := by + simp [h, value'] @[rocq_alias twp_frame_l] theorem frame_l {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} @@ -580,19 +448,13 @@ theorem frame_l {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} R ∗ WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E [{ v, R ∗ Φ v }] := by iintro ⟨HR, Hwp⟩ iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ Hwp - iintro %v HΦ - imodintro - iframe + iintro %v $ // @[rocq_alias twp_frame_r] -theorem frame_r {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} - {R : IProp GF} : +theorem frame_r {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} {R : IProp GF} : WP e @ s ; E [{ Φ }] ∗ R ⊢ WP e @ s ; E [{ v, Φ v ∗ R }] := by - rw [(BI.sep_comm (P := WP e @ s ; E [{ Φ }]) (Q := R)).to_eq] - refine frame_l.trans ?_ - apply mono - intro v - exact BI.sep_comm.mp + rw [BI.sep_comm.to_eq] + refine frame_l.trans (mono fun v => BI.sep_comm.mp) @[rocq_alias twp_wand] theorem wand {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : @@ -606,23 +468,19 @@ theorem wand {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : @[rocq_alias twp_wand_l] theorem wand_l {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : - (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s ; E [{ Φ }] ⊢ - WP e @ s ; E [{ Ψ }] := by + (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E [{ Ψ }] := by iintro ⟨H, Hwp⟩ iapply wand $$ Hwp H @[rocq_alias twp_wand_r] theorem wand_r {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : - WP e @ s ; E [{ Φ }] ∗ (∀ v, Φ v -∗ Ψ v) ⊢ - WP e @ s ; E [{ Ψ }] := by + WP e @ s ; E [{ Φ }] ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WP e @ s ; E [{ Ψ }] := by iintro ⟨Hwp, H⟩ iapply wand $$ Hwp H @[rocq_alias twp_frame_wand] -theorem frame_wand {s : Stuckness} {E} {e : Expr} - {Φ : Val → IProp GF} {R : IProp GF} : - R ⊢ (WP e @ s ; E [{ v, R -∗ Φ v }]) -∗ - WP e @ s ; E [{ Φ }] := by +theorem frame_wand {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} {R : IProp GF} : + R ⊢ (WP e @ s ; E [{ v, R -∗ Φ v }]) -∗ WP e @ s ; E [{ Φ }] := by iintro HR Hwp iapply wand $$ Hwp iintro %v HΦ @@ -635,9 +493,7 @@ theorem to_wp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : rw [wp_unfold.to_eq, unfold.to_eq] unfold wp.pre pre cases hval : toVal e - case some v => - iintro H - iexact H + case some v => iintro $ case none => iintro H %σ %ns %κ %κs %nt Hσ imod H $$ Hσ with ⟨%Hred, H⟩ @@ -648,20 +504,16 @@ theorem to_wp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : · exact Language.reducible_of_reducibleNoObs Hred · trivial · iintro %e₂ %σ₂ %eₜ %Hstep _ - ihave Hnext := H $$ %κ %e₂ %σ₂ %eₜ %Hstep iapply step_fupdN_intro Std.LawfulSet.empty_subset rw [(BI.later_laterN _).to_eq] - iintro !> - iapply BI.laterN_intro - imod Hnext with ⟨%hκ, Hσ, He₂, Hefs⟩ - subst hκ + iintro !> !> + imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with ⟨%⟨⟩, Hσ, He₂, Hefs⟩ simp only [List.nil_append] - imodintro iframe Hσ isplitl [He₂] · iapply IH $$ He₂ · iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef Hef + iintro !> %k %ef %Hef !>Hef iapply IH $$ Hef section ProofMode @@ -672,13 +524,11 @@ variable {s : Stuckness} {E E₁ E₂ : CoPset} {e : Expr} variable {Φ Ψ : Val → IProp GF} {P R : IProp GF} @[rocq_alias frame_twp] -instance frameTwp {p : Bool} - [H : ∀ v, FrameInstantiateExistDisabled p R (Φ v) (Ψ v)] : +instance frameTwp {p : Bool} [H : ∀ v, FrameInstantiateExistDisabled p R (Φ v) (Ψ v)] : Frame p R (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Ψ }]) where frame := by - refine frame_l.trans ?_ - apply mono - exact fun v => (H v).frame_instantiatiate_exist_disabled.frame + refine frame_l.trans (mono fun v => ?_) + exact (H v).frame_instantiatiate_exist_disabled.frame -- Iris-Rocq reuses the module-qualified name `is_except_0_wp` here; that alias -- is already assigned to partial WP in Lean, so this instance is left unaliased. @@ -691,20 +541,17 @@ instance isExcept0Twp : IsExcept0 (WP e @ s ; E [{ Φ }]) where @[rocq_alias elim_modal_fupd_twp] instance (priority := default + 10) elimModalFupdTwp p : - ElimModal True p io false iprop(|={E}=> P) P - (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where + ElimModal True p io false iprop(|={E}=> P) P (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where elim_modal := by iintro %_ ⟨H, G⟩ icases BI.intuitionisticallyIf_elim $$ H with H iapply fupd_twp imod H - imodintro iapply G $$ H @[rocq_alias elim_modal_bupd_twp] instance elimModalBupdTwp p : - ElimModal True p io false iprop(|==> P) P - (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where + ElimModal True p io false iprop(|==> P) P (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where elim_modal := by rintro ⟨⟩ refine BI.sep_mono (BI.intuitionisticallyIf_mono @@ -724,15 +571,13 @@ instance elimModalFupdTwp_wrongMask : @[rocq_alias elim_modal_fupd_twp_atomic] instance elimModalFupdTwpAtomic : ElimModal (Language.Atomic ↑s e) p io false iprop(|={E₁,E₂}=> P) P - (WP e @ s ; E₁ [{ Φ }]) - (WP e @ s ; E₂ [{ v, |={E₂,E₁}=> Φ v }]) where + (WP e @ s ; E₁ [{ Φ }]) (WP e @ s ; E₂ [{ v, |={E₂,E₁}=> Φ v }]) where elim_modal := by rintro hatomic iintro ⟨H, G⟩ icases BI.intuitionisticallyIf_elim $$ H with H iapply atomic imod H - imodintro iapply G $$ H @[rocq_alias elim_modal_fupd_twp_atomic_wrong_mask] diff --git a/Iris/Iris/Tests/WeakestPre.lean b/Iris/Iris/Tests/WeakestPre.lean index 55687bf21..71003436c 100644 --- a/Iris/Iris/Tests/WeakestPre.lean +++ b/Iris/Iris/Tests/WeakestPre.lean @@ -118,37 +118,6 @@ variable (Φ : Val → PROP) end TestWP -section TestTotalTexanTriple - -set_option linter.unusedVariables false - -variable (PROP Expr Val A : Type _) [BI PROP] -variable [TotalWp PROP Expr Val A] [TotalWp PROP Expr Val Stuckness] -variable (e : Expr) (s : A) (E : CoPset) (P Q : PROP) (v : Val) - -/-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ s ; E [{ Φ }] ) : PROP -/ -#guard_msgs in #check [[{ P }]] e @ s ; E [[{ RET v; Q }]] - -/-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ E [{ Φ }] ) : PROP -/ -#guard_msgs in #check [[{ P }]] e @ E [[{ RET v; Q }]] - -/-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ E ? [{ Φ }] ) : PROP -/ -#guard_msgs in #check [[{ P }]] e @ E ? [[{ RET v; Q }]] - -/-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e [{ Φ }] ) : PROP -/ -#guard_msgs in #check [[{ P }]] e [[{ RET v; Q }]] - -/-- info: iprop(∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e ? [{ Φ }] ) : PROP -/ -#guard_msgs in #check [[{ P }]] e ? [[{ RET v; Q }]] - -/-- info: iprop(∀ Φ, P -∗ (∀ x, Q -∗ Φ x) -∗ WP e [{ Φ }] ) : PROP -/ -#guard_msgs in #check [[{ P }]] e [[{ (x : Val), RET x; Q }]] - -/-- info: iprop(∀ Φ, P -∗ (∀ x, Q -∗ Φ v) -∗ WP e [{ Φ }] ) : PROP -/ -#guard_msgs in #check [[{ P }]] e [[{ _, RET v; Q }]] - -end TestTotalTexanTriple - section TestTexanTriple set_option linter.unusedVariables false @@ -223,6 +192,56 @@ variable (P Q : PROP) end TestTexanTriple +section TestTotalTexanTriple + +variable (PROP Expr Val A : Type _) [BI PROP] +variable [TotalWp PROP Expr Val A] [TotalWp PROP Expr Val Stuckness] +variable (e : Expr) (s : A) (E : CoPset) (P Q : PROP) (v : Val) + +/-- info: ⊢ ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ s ; E [{ Φ }] : Prop -/ +#guard_msgs in #check [{ P }] e @ s ; E [{ RET v; Q }] + +/-- info: ⊢ ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ E [{ Φ }] : Prop -/ +#guard_msgs in #check [{ P }] e @ E [{ RET v; Q }] + +/-- info: ⊢ ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ E ? [{ Φ }] : Prop -/ +#guard_msgs in #check [{ P }] e @ E ? [{ RET v; Q }] + +/-- info: ⊢ ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e [{ Φ }] : Prop -/ +#guard_msgs in #check [{ P }] e [{ RET v; Q }] + +/-- info: ⊢ ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e ? [{ Φ }] : Prop -/ +#guard_msgs in #check [{ P }] e ? [{ RET v; Q }] + +/-- info: ⊢ ∀ Φ, P -∗ (∀ x, Q -∗ Φ x) -∗ WP e [{ Φ }] : Prop -/ +#guard_msgs in #check [{ P }] e [{ (x : Val), RET x; Q }] + +/-- info: ⊢ ∀ Φ, P -∗ (∀ x, Q -∗ Φ v) -∗ WP e [{ Φ }] : Prop -/ +#guard_msgs in #check [{ P }] e [{ _, RET v; Q }] + +/-- info: iprop(□ ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ s ; E [{ Φ }] ) : PROP -/ +#guard_msgs in #check iprop([{ P }] e @ s ; E [{ RET v; Q }]) + +/-- info: iprop(□ ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ E [{ Φ }] ) : PROP -/ +#guard_msgs in #check iprop([{ P }] e @ E [{ RET v; Q }]) + +/-- info: iprop(□ ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e @ E ? [{ Φ }] ) : PROP -/ +#guard_msgs in #check iprop([{ P }] e @ E ? [{ RET v; Q }]) + +/-- info: iprop(□ ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e [{ Φ }] ) : PROP -/ +#guard_msgs in #check iprop([{ P }] e [{ RET v; Q }]) + +/-- info: iprop(□ ∀ Φ, P -∗ (Q -∗ Φ v) -∗ WP e ? [{ Φ }] ) : PROP -/ +#guard_msgs in #check iprop([{ P }] e ? [{ RET v; Q }]) + +/-- info: iprop(□ ∀ Φ, P -∗ (∀ x, Q -∗ Φ x) -∗ WP e [{ Φ }] ) : PROP -/ +#guard_msgs in #check iprop([{ P }] e [{ (x : Val), RET x; Q }]) + +/-- info: iprop(□ ∀ Φ, P -∗ (∀ x, Q -∗ Φ v) -∗ WP e [{ Φ }] ) : PROP -/ +#guard_msgs in #check iprop([{ P }] e [{ _, RET v; Q }]) + +end TestTotalTexanTriple + section HeapLangTestWP set_option linter.unusedVariables false @@ -318,4 +337,3 @@ info: iprop(□ ∀ Φ, P -∗ (▷ ∀ x, Q -∗ Φ x) -∗ WP hl(if (#1 < #2) #guard_msgs in #check iprop({{ P }} hl(#1) {{ v, RET v; ⌜v = hl_val(#1)⌝ }} : PROP) end HeapLangTestTexanTriple - From 27f05563f6f65993056c44da95be8a474dc9e57f Mon Sep 17 00:00:00 2001 From: Marcelo Fornet Date: Tue, 11 Aug 2026 09:41:13 +0200 Subject: [PATCH 8/9] Fix total adequacy after Args tuple change --- Iris/Iris/ProgramLogic/TotalAdequacy.lean | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Iris/Iris/ProgramLogic/TotalAdequacy.lean b/Iris/Iris/ProgramLogic/TotalAdequacy.lean index 91d5d9ec3..8b4f6a04d 100644 --- a/Iris/Iris/ProgramLogic/TotalAdequacy.lean +++ b/Iris/Iris/ProgramLogic/TotalAdequacy.lean @@ -295,12 +295,12 @@ theorem of_twp (s : Stuckness) (e : Expr) (Φ : Val → IProp GF) : let Ψ := fun (E : CoPset) (e : Expr) (_ : Val → IProp GF) => iprop( ⌜E = ⊤⌝ -∗ get (ι := ι) [e]) have hΨ : NonExpansive - (fun x : twp.Internal.Args Expr Val GF => Ψ x.1.1 x.1.2 x.2) := by + (fun x : twp.Internal.Args Expr Val GF => Ψ x.1 x.2.1 x.2.2) := by constructor intro n x y hxy - rcases x with ⟨⟨EX, eX⟩, ΦX⟩ - rcases y with ⟨⟨EY, eY⟩, ΦY⟩ - rcases hxy with ⟨⟨hE, he⟩, _⟩ + rcases x with ⟨EX, eX, ΦX⟩ + rcases y with ⟨EY, eY, ΦY⟩ + rcases hxy with ⟨hE, he, _⟩ change EX = EY at hE change eX = eY at he subst EY From 98653eb95208738d43b678c982523e949c14f729 Mon Sep 17 00:00:00 2001 From: Marcelo Fornet Date: Tue, 11 Aug 2026 18:43:33 +0200 Subject: [PATCH 9/9] Golf total weakest-precondition proofs --- Iris/Iris/Algebra/COFESolver.lean | 2 +- Iris/Iris/Algebra/IProp.lean | 8 +- Iris/Iris/Instances/IProp/Instance.lean | 16 +- Iris/Iris/ProgramLogic/TotalAdequacy.lean | 302 ++++---------- Iris/Iris/ProgramLogic/TotalEctxLifting.lean | 129 ++---- Iris/Iris/ProgramLogic/TotalLifting.lean | 119 ++---- Iris/Iris/ProgramLogic/TotalWeakestPre.lean | 412 ++++++------------- Iris/Iris/Tests/TotalWeakestPre.lean | 371 ++++------------- 8 files changed, 379 insertions(+), 980 deletions(-) diff --git a/Iris/Iris/Algebra/COFESolver.lean b/Iris/Iris/Algebra/COFESolver.lean index 937c630a9..6a607e591 100644 --- a/Iris/Iris/Algebra/COFESolver.lean +++ b/Iris/Iris/Algebra/COFESolver.lean @@ -28,7 +28,7 @@ def A' : Nat → Σ α : Type u, COFE α | n+1 => let ⟨A, _⟩ := A' n; ⟨F A A, inferInstance⟩ variable (F) in -def A (n : Nat) : Type u := (A' F n).1 +abbrev A (n : Nat) : Type u := (A' F n).1 instance instA' (n) : COFE (A' F n).1 := (A' F n).2 instance instA (n) : COFE (A F n) := (A' F n).2 diff --git a/Iris/Iris/Algebra/IProp.lean b/Iris/Iris/Algebra/IProp.lean index 9b79432a5..8cf998ac0 100644 --- a/Iris/Iris/Algebra/IProp.lean +++ b/Iris/Iris/Algebra/IProp.lean @@ -85,12 +85,12 @@ def IProp.fold : IPre GF -n> IProp GF := OFE.Iso.inv <| OFunctor.Fix.iso (F := (UPredOF (IResF GF))) @[rocq_alias iProp_solution.iProp_fold_unfold] -theorem IProp.fold_unfold (P : IProp GF) : IProp.fold GF (IProp.unfold GF P) = P := by - simp only [IProp.fold, IProp.unfold, OFE.Iso.inv_hom] +theorem IProp.fold_unfold (P : IProp GF) : IProp.fold GF (IProp.unfold GF P) = P := + OFunctor.Fix.iso (F := UPredOF (IResF GF)) |>.inv_hom @[rocq_alias iProp_solution.iProp_unfold_fold] -theorem IProp.unfold_fold (P : IPre GF) : IProp.unfold GF (IProp.fold GF P) = P := by - simp only [IProp.unfold, IProp.fold, OFE.Iso.hom_inv] +theorem IProp.unfold_fold (P : IPre GF) : IProp.unfold GF (IProp.fold GF P) = P := + OFunctor.Fix.iso (F := UPredOF (IResF GF)) |>.hom_inv end IProp diff --git a/Iris/Iris/Instances/IProp/Instance.lean b/Iris/Iris/Instances/IProp/Instance.lean index 1039ca5cb..dc98695e0 100644 --- a/Iris/Iris/Instances/IProp/Instance.lean +++ b/Iris/Iris/Instances/IProp/Instance.lean @@ -170,25 +170,19 @@ def IProp.foldi : FF.api τ (IPre FF) -n> FF.api τ (IProp FF) := @[rocq_alias inG_unfold_fold] theorem IProp.unfoldi_foldi (x : FF.api τ (IPre FF)) : unfoldi (foldi x) = x := by - refine OFE.eq_dist.mpr fun n => ?_ - refine .trans (OFunctor.map_comp (F := FF τ |>.fst) ..).symm.dist ?_ - refine .trans ?_ (OFunctor.map_id (F := FF τ |>.fst) x).dist - apply OFunctor.map_ne.ne <;> intro _ <;> simp [IProp.unfold, IProp.fold] + have h : (IProp.unfold FF).comp (IProp.fold FF) = OFE.Hom.id := OFE.Hom.ext <| funext (IProp.unfold_fold FF) + rw [unfoldi, foldi, ← OFunctor.map_comp, h, OFunctor.map_id] @[rocq_alias inG_fold_unfold] theorem IProp.foldi_unfoldi (x : FF.api τ (IProp FF)) : foldi (unfoldi x) = x := by - refine OFE.eq_dist.mpr fun n => ?_ - refine .trans (OFunctor.map_comp (F := FF τ |>.fst) ..).symm.dist ?_ - refine .trans ?_ (OFunctor.map_id (F := FF τ |>.fst) x).dist - apply OFunctor.map_ne.ne <;> intro _ <;> simp [IProp.unfold, IProp.fold] + have h : (IProp.fold FF).comp (IProp.unfold FF) = OFE.Hom.id := OFE.Hom.ext <| funext (IProp.fold_unfold FF) + rw [unfoldi, foldi, ← OFunctor.map_comp, h, OFunctor.map_id] @[rocq_alias iProp_unfold_equivI] theorem IProp.unfold_equivI (P Q : IProp FF) : (IProp.unfold FF P ≡ IProp.unfold FF Q) ⊢@{IProp FF} P ≡ Q := by - have h := BI.internalEq.of_internalEquiv_ne (PROP := IProp FF) (IProp.fold FF) + simpa only [IProp.fold_unfold] using BI.internalEq.of_internalEquiv_ne (PROP := IProp FF) (IProp.fold FF) (x := IProp.unfold FF P) (y := IProp.unfold FF Q) - rw [IProp.fold_unfold, IProp.fold_unfold] at h - exact h theorem IProp.unfoldi_discreteE {v : FF.api τ (IProp FF)} (hv : OFE.DiscreteE v) : OFE.DiscreteE (unfoldi.f v) where diff --git a/Iris/Iris/ProgramLogic/TotalAdequacy.lean b/Iris/Iris/ProgramLogic/TotalAdequacy.lean index 8b4f6a04d..6661f81d5 100644 --- a/Iris/Iris/ProgramLogic/TotalAdequacy.lean +++ b/Iris/Iris/ProgramLogic/TotalAdequacy.lean @@ -24,22 +24,14 @@ namespace StronglyNormalizing theorem intro {α : Type _} {step : α → α → Prop} {x : α} (H : ∀ y, step x y → StronglyNormalizing step y) : - StronglyNormalizing step x := - Acc.intro x H + StronglyNormalizing step x := Acc.intro x H theorem map {α β : Type _} {stepα : α → α → Prop} {stepβ : β → β → Prop} (f : β → α) (Hlift : ∀ x y, stepβ x y → stepα (f x) (f y)) {x : β} (H : StronglyNormalizing stepα (f x)) : - StronglyNormalizing stepβ x := by - unfold StronglyNormalizing at H ⊢ - generalize hx : f x = z at H - induction H generalizing x with - | intro z Hz IH => - subst z - apply Acc.intro - intro y Hy - exact IH (f y) (Hlift x y Hy) rfl + StronglyNormalizing stepβ x := + Subrelation.accessible (fun h => Hlift _ _ h) (InvImage.accessible f H) end StronglyNormalizing @@ -52,12 +44,8 @@ variable [ι : IrisGS_gen hlc Expr GF] local instance : OFE (List Expr) := OFE.ofDiscrete _ -private theorem list_nonexpansive (Ψ : List Expr → IProp GF) : NonExpansive Ψ := by - constructor - intro n x y hxy - change x = y at hxy - subst y - rfl +local instance list_nonexpansive (Ψ : List Expr → IProp GF) : NonExpansive Ψ := + ⟨fun _ _ _ hxy => hxy ▸ .rfl⟩ namespace twptp @@ -65,44 +53,20 @@ local instance : OFE CoPset := OFE.ofDiscrete _ local instance : OFE Expr := OFE.ofDiscrete _ local instance : OFE Val := OFE.ofDiscrete _ -private theorem step_append_inv (r₁ r₂ t' : List Expr) (σ₁ σ₂ : State) - (κ : List Obs) : +private theorem step_append_inv (r₁ r₂ : List Expr) {t' : List Expr} {σ₁ σ₂ : State} {κ : List Obs} : (r₁ ++ r₂, σ₁) -<κ>->ₜₚ (t', σ₂) → (∃ r₁', (r₁, σ₁) -<κ>->ₜₚ (r₁', σ₂) ∧ t'.Perm (r₁' ++ r₂)) ∨ (∃ r₂', (r₂, σ₁) -<κ>->ₜₚ (r₂', σ₂) ∧ - t'.Perm (r₁ ++ r₂')) := by - intro H + t'.Perm (r₁ ++ r₂')) := fun H => by generalize hsrc : r₁ ++ r₂ = src at H - generalize hdst : t' = dst at H - cases H with - | @atomic e σ obs e' σ' efs Hprim p q => - rcases List.append_eq_append_iff.mp hsrc.symm with - (⟨mid, hr₁, heq⟩ | ⟨bs, hp, hr₂⟩) - · cases mid with - | nil => - simp only [List.append_nil] at hr₁ - simp only [List.nil_append] at heq - subst r₁ - subst r₂ - exact .inr ⟨e' :: q ++ efs, .atomic Hprim [] q, by simp⟩ - | cons a tail => - simp only [List.cons_append, List.cons.injEq] at heq - obtain ⟨rfl, hq⟩ := heq - subst r₁ - subst q - refine .inl ⟨p ++ e' :: tail ++ efs, .atomic Hprim p tail, ?_⟩ - have hp := List.Perm.append_left (p ++ [e']) - (List.Perm.append_left tail - (List.perm_append_comm : - (r₂ ++ efs).Perm (efs ++ r₂))) - simpa only [List.append_assoc, List.singleton_append, - List.cons_append, List.nil_append] using hp - · subst p - subst r₂ - refine .inr ⟨bs ++ e' :: q ++ efs, .atomic Hprim bs q, ?_⟩ - simp only [List.append_assoc] - exact .refl _ + rcases H with @⟨e, _, _, e', _, efs, Hprim, p, q⟩ + rcases List.append_eq_append_iff.mp hsrc.symm with (⟨(_ | ⟨a, tail⟩), hr₁, heq⟩ | ⟨bs, hp, hr₂⟩) + · exact .inr ⟨e' :: q ++ efs, (heq.trans (List.nil_append r₂)) ▸ .atomic Hprim [] q, by simp [hr₁]⟩ + · simp_all only [List.cons_append, List.cons.injEq] + refine .inl ⟨p ++ e' :: tail ++ efs, .atomic Hprim p tail, ?_⟩ + simpa [List.append_assoc] using List.perm_append_comm.append_left (p ++ e' :: tail) + · exact .inr ⟨bs ++ e' :: q ++ efs, hr₂ ▸ .atomic Hprim bs q, by simp [hp, List.append_assoc]⟩ /-- One unfolding of the total thread-pool predicate. -/ @[rocq_alias twptp_pre] @@ -119,20 +83,13 @@ instance pre_mono_inst : BIMonoPred (pre (ι := ι)) where iintro #HXY %t₁ Hpre unfold pre iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep Hσ - imod Hpre $$ %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep Hσ with - ⟨%nt', %hκ, Hσ, HX⟩ - imodintro - iexists nt' + imod Hpre $$ %_ %_ %_ %_ %_ %_ %_ %Hstep Hσ with ⟨%nt', %hκ, Hσ, HX⟩ iframe %hκ Hσ - iapply HXY $$ %t₂ HX - mono_pred_ne.ne {X} t₁ t₂ ht := by - change t₁ = t₂ at ht - subst t₂ - rfl + iapply HXY $$ HX + mono_pred_ne.ne {X} _ _ ht := ht ▸ .rfl @[rocq_alias twptp_pre_mono] -theorem pre_mono (X Y : List Expr → IProp GF) - [NonExpansive X] [NonExpansive Y] : +theorem pre_mono (X Y : List Expr → IProp GF) : ⊢ □ (∀ t, X t -∗ Y t) -∗ ∀ t, pre (ι := ι) X t -∗ pre (ι := ι) Y t := mono_pred (F := pre (ι := ι)) @@ -147,57 +104,26 @@ instance get_ne : NonExpansive (get (ι := ι)) := @[rocq_alias twptp_unfold] theorem unfold (t : List Expr) : - get (ι := ι) t ⊣⊢ pre (ι := ι) (get (ι := ι)) t := by - exact BI.equiv_iff.1 (least_fixpoint_unfold (pre (ι := ι))) + get (ι := ι) t ⊣⊢ pre (ι := ι) (get (ι := ι)) t := + BI.equiv_iff.1 (least_fixpoint_unfold (pre (ι := ι))) @[rocq_alias twptp_ind] -theorem induction (Ψ : List Expr → IProp GF) [NonExpansive Ψ] : +theorem induction (Ψ : List Expr → IProp GF) : (⊢ □ ∀ t, pre (ι := ι) (fun t => iprop(Ψ t ∧ get (ι := ι) t)) t -∗ Ψ t) → - ⊢ ∀ t, get (ι := ι) t -∗ Ψ t := by - intro H - have H' : ⊢ □ ∀ t, - pre (ι := ι) (fun t => iprop(Ψ t ∧ - bi_least_fixpoint (pre (ι := ι)) t)) t -∗ Ψ t := by - simpa only [get] using H - iintro %t - change ⊢ bi_least_fixpoint (pre (ι := ι)) t -∗ Ψ t - iintro Ht - iapply least_fixpoint_ind (F := pre (ι := ι)) (Φ := Ψ) $$ [] Ht - iintro !> %t' Hpre - iapply H' $$ %t' Hpre - -private theorem pre_and_get (Ψ : List Expr → IProp GF) [NonExpansive Ψ] - (t : List Expr) : - pre (ι := ι) (fun t => iprop(Ψ t ∧ get (ι := ι) t)) t ⊢ - get (ι := ι) t := by - letI := list_nonexpansive - (fun t => iprop(Ψ t ∧ get (ι := ι) t)) - rw [(twptp.unfold (ι := ι) t).to_eq] - iintro Hpre - iapply mono_pred (F := pre (ι := ι)) $$ [] %t Hpre - iintro !> %u Hu - icases Hu with ⟨-, Hu⟩ - iexact Hu + ⊢ ∀ t, get (ι := ι) t -∗ Ψ t := fun H => by + simpa [get, BIBase.EmpValid] using H.trans (BI.wand_entails (least_fixpoint_ind (F := pre (ι := ι)) (Φ := Ψ))) @[rocq_alias twptp_Permutation] theorem permutation {t₁ t₁' : List Expr} (Hp : t₁.Perm t₁') : get (ι := ι) t₁ ⊢ get (ι := ι) t₁' := by - let Ψ := fun t : List Expr => iprop( - ∀ t', ⌜t.Perm t'⌝ -∗ get (ι := ι) t') - letI := list_nonexpansive Ψ iintro Ht - iapply induction Ψ (ι := ι) ?_ $$ %t₁ Ht %t₁' %Hp + iapply induction (fun t : List Expr => iprop(∀ t', ⌜t.Perm t'⌝ -∗ get (ι := ι) t')) + (ι := ι) ?_ $$ %t₁ Ht %t₁' %Hp iintro !> %t Hpre %t' %Htt' - rw [(twptp.unfold (ι := ι) t').to_eq] - unfold pre + simp only [(twptp.unfold (ι := ι) t').to_eq, pre] iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep Hσ - obtain ⟨t₂', H₂perm, Hstep'⟩ := - Language.perm_of_step (t₁ := t') (t₁' := t) Htt'.symm Hstep - imod Hpre $$ %t₂' %σ₁ %ns %κ %κs %σ₂ %nt %Hstep' Hσ with - ⟨%nt', %hκ, Hσ, HIH⟩ - icases HIH with ⟨HIH, -⟩ - imodintro - iexists nt' + obtain ⟨t₂', H₂perm, Hstep'⟩ := Language.perm_of_step Htt'.symm Hstep + imod Hpre $$ %_ %_ %_ %_ %_ %_ %_ %Hstep' Hσ with ⟨%nt', %hκ, Hσ, ⟨HIH, -⟩⟩ iframe %hκ Hσ iapply HIH $$ %t₂ %H₂perm.symm @@ -206,147 +132,73 @@ theorem app (t₁ t₂ : List Expr) : get (ι := ι) t₁ -∗ get (ι := ι) t₂ -∗ get (ι := ι) (t₁ ++ t₂) := by let Ψ₁ := fun t₁ : List Expr => iprop( ∀ t₂, get (ι := ι) t₂ -∗ get (ι := ι) (t₁ ++ t₂)) - letI := list_nonexpansive Ψ₁ iintro H₁ iapply induction Ψ₁ (ι := ι) ?_ $$ %t₁ H₁ %t₂ let Ψ₂ := fun t₂ : List Expr => iprop( ∀ t₁, pre (ι := ι) (fun t => iprop(Ψ₁ t ∧ get (ι := ι) t)) t₁ -∗ get (ι := ι) (t₁ ++ t₂)) - letI := list_nonexpansive Ψ₂ iintro !> %u₁ Hu₁ %u₂ Hu₂ iapply induction Ψ₂ (ι := ι) ?_ $$ %u₂ Hu₂ %u₁ Hu₁ iintro !> %r₂ Hr₂ %r₁ Hr₁ - rw [(twptp.unfold (ι := ι) (r₁ ++ r₂)).to_eq] - unfold pre + simp only [(twptp.unfold (ι := ι) (r₁ ++ r₂)).to_eq, pre] iintro %t' %σ₁ %ns %κ %κs %σ₂ %nt %Hstep Hσ - rcases step_append_inv r₁ r₂ t' σ₁ σ₂ κ Hstep with - (⟨r₁', Hstep₁, Hperm⟩ | ⟨r₂', Hstep₂, Hperm⟩) - · imod Hr₁ $$ %r₁' %σ₁ %ns %κ %κs %σ₂ %nt %Hstep₁ Hσ with - ⟨%nt', %hκ, Hσ, Hr₁'⟩ - icases Hr₁' with ⟨IH₁, -⟩ + rcases step_append_inv r₁ r₂ Hstep with (⟨r₁', Hstep₁, Hperm⟩ | ⟨r₂', Hstep₂, Hperm⟩) + · imod Hr₁ $$ %_ %_ %_ %_ %_ %_ %_ %Hstep₁ Hσ with ⟨%nt', %hκ, Hσ, ⟨IH₁, -⟩⟩ imodintro - iexists nt' iframe %hκ Hσ iapply permutation Hperm.symm iapply IH₁ $$ %r₂ - iapply pre_and_get Ψ₂ r₂ (ι := ι) + rw [(twptp.unfold (ι := ι) r₂).to_eq] + iapply pre_mono (fun t => iprop(Ψ₂ t ∧ get (ι := ι) t)) _ $$ [] %r₂ + iintro !> %u ⟨-, $⟩ unfold pre - iexact Hr₂ - · imod Hr₂ $$ %r₂' %σ₁ %ns %κ %κs %σ₂ %nt %Hstep₂ Hσ with - ⟨%nt', %hκ, Hσ, Hr₂'⟩ - icases Hr₂' with ⟨IH₂, -⟩ - imodintro - iexists nt' + iassumption + · imod Hr₂ $$ %_ %_ %_ %_ %_ %_ %_ %Hstep₂ Hσ with ⟨%nt', %hκ, Hσ, ⟨IH₂, -⟩⟩ iframe %hκ Hσ - iapply permutation Hperm.symm - iapply IH₂ $$ %r₁ - unfold pre - iexact Hr₁ + iunfold Ψ₂, pre at IH₂ + iapply permutation Hperm.symm $$ (IH₂ $$ %r₁ Hr₁) private theorem get_nil : ⊢ get (ι := ι) ([] : List Expr) := by - rw [(twptp.unfold (ι := ι) []).to_eq] - unfold pre + simp only [(twptp.unfold (ι := ι) []).to_eq, pre] iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep - exfalso - generalize hsrc : ([] : List Expr) = src at Hstep - cases Hstep with - | @atomic e σ obs e' σ' efs Hprim p q => - simp at hsrc - -private theorem step_singleton_inv (e : Expr) (t₂ : List Expr) - (σ₁ σ₂ : State) (κ : List Obs) : - ([e], σ₁) -<κ>->ₜₚ (t₂, σ₂) → - ∃ e₂ efs, (e, σ₁) -<κ>-> (e₂, σ₂, efs) ∧ t₂ = e₂ :: efs := by - intro H - generalize hsrc : [e] = src at H - generalize hdst : t₂ = dst at H - cases H with - | @atomic red σ obs red' σ' efs Hprim p q => - have hpq : p = [] ∧ red = e ∧ q = [] := by - rcases List.append_eq_singleton_iff.mp hsrc.symm with - (⟨hp, hrest⟩ | ⟨hp, hrest⟩) - · subst p - simp only [List.cons.injEq] at hrest - exact ⟨rfl, hrest.1, hrest.2⟩ - · simp at hrest - obtain ⟨rfl, rfl, rfl⟩ := hpq - exact ⟨red', efs, Hprim, by simp_all⟩ + grind [List.append_eq_nil_iff] private theorem bigSepL_get_singleton (es : List Expr) : - ([∗list] e ∈ es, get (ι := ι) [e]) ⊢ get (ι := ι) es := by - induction es with - | nil => - simp only [Algebra.BigOpL.bigOpL_nil] - iintro _ - exact get_nil (ι := ι) - | cons e es IH => - simp only [Algebra.BigOpL.bigOpL_cons] - iintro Hes - icases Hes with ⟨He, Hes⟩ - rw [show e :: es = [e] ++ es by simp] - iapply app [e] es (ι := ι) $$ He - iapply IH - iexact Hes + ([∗list] e ∈ es, get (ι := ι) [e]) ⊢ get (ι := ι) es := + List.rec (get_nil (ι := ι)) (fun e es IH => + (BI.sep_mono_right IH).trans (BI.wand_elim (BI.wand_entails (app [e] es (ι := ι))))) es @[rocq_alias twp_twptp] theorem of_twp (s : Stuckness) (e : Expr) (Φ : Val → IProp GF) : WP e @ s ; ⊤ [{ Φ }] ⊢ get (ι := ι) [e] := by let Ψ := fun (E : CoPset) (e : Expr) (_ : Val → IProp GF) => iprop( ⌜E = ⊤⌝ -∗ get (ι := ι) [e]) - have hΨ : NonExpansive - (fun x : twp.Internal.Args Expr Val GF => Ψ x.1 x.2.1 x.2.2) := by - constructor - intro n x y hxy - rcases x with ⟨EX, eX, ΦX⟩ - rcases y with ⟨EY, eY, ΦY⟩ - rcases hxy with ⟨hE, he, _⟩ - change EX = EY at hE - change eX = eY at he - subst EY - subst eY - rfl - letI := hΨ + letI : NonExpansive + (fun x : twp.Internal.Args Expr Val GF => Ψ x.1 x.2.1 x.2.2) := + ⟨fun _ _ _ ⟨hE, he, _⟩ => hE ▸ he ▸ .rfl⟩ iintro He iapply twp.induction s Ψ (ι := ι) ?_ $$ He %rfl iintro !> %E %e %Φ - cases he : toVal e with - | some v => - simp only [twp.pre, he] - iintro _ %hE - subst E - rw [(twptp.unfold (ι := ι) [e]).to_eq] - unfold pre - iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep - obtain ⟨e₂, efs, Hprim, rfl⟩ := - step_singleton_inv e t₂ σ₁ σ₂ κ Hstep - have hnone := Language.val_stuck Hprim - rw [he] at hnone - cases hnone - | none => - simp only [twp.pre, he] - iintro Hpre %hE - subst E - rw [(twptp.unfold (ι := ι) [e]).to_eq] - unfold pre - iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep Hσ - obtain ⟨e₂, efs, Hprim, rfl⟩ := - step_singleton_inv e t₂ σ₁ σ₂ κ Hstep - imod Hpre $$ %σ₁ %ns %κs %nt Hσ with ⟨%_, Hpre⟩ - imod Hpre $$ %κ %e₂ %σ₂ %efs %Hprim with - ⟨%hκ, Hσ, He₂, Hefs⟩ - icases He₂ with ⟨IH₂, -⟩ - imodintro - iexists (nt + efs.length) - iframe %hκ Hσ - rw [show e₂ :: efs = [e₂] ++ efs by simp] - iapply app [e₂] efs (ι := ι) $$ [IH₂] - · iapply IH₂ $$ %rfl - · iapply bigSepL_get_singleton efs (ι := ι) - iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef Hef - icases Hef with ⟨IHef, -⟩ - iapply IHef $$ %rfl + cases he : toVal e + all_goals + simp only [twp.pre, he] + iintro Hpre %hE + simp only [hE, (twptp.unfold (ι := ι) [e]).to_eq, pre] + iintro %t₂ %σ₁ %ns %κ %κs %σ₂ %nt %Hstep + obtain ⟨e₂, efs, Hprim, rfl⟩ : + ∃ e₂ efs, (e, σ₁) -<κ>-> (e₂, σ₂, efs) ∧ t₂ = e₂ :: efs := by + grind [List.append_eq_singleton_iff] + next => + iintro Hσ + imod Hpre $$ Hσ with ⟨%_, Hpre⟩ + imod Hpre $$ %κ %e₂ %σ₂ %efs %Hprim with ⟨%hκ, Hσ, ⟨IH₂, -⟩, Hefs⟩ + iframe %hκ Hσ + rw [show e₂ :: efs = [e₂] ++ efs by simp] + iapply app [e₂] efs (ι := ι) $$ (IH₂ $$ %rfl) + iapply (BigSepL.bigSepL_mono_of_forall ((sep_intro_emp_valid_left (pure_intro rfl) and_elim_l).trans + (wand_elim_swap .rfl))).trans (bigSepL_get_singleton efs (ι := ι)) $$ Hefs + next => simpa [he] using Language.val_stuck Hprim end twptp @@ -362,19 +214,14 @@ theorem twptp_total (t : List Expr) (σ : State) (ns nt : Nat) : |={⊤|}=> ⌜StronglyNormalizing (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) (t, σ)⌝) - letI := list_nonexpansive Ψ iintro Hσ Ht iapply twptp.induction Ψ (ι := ι) ?_ $$ %t Ht %σ %ns %nt Hσ iintro !> %t unfold twptp.pre iintro Hpre %σ %ns %nt Hσ iapply fupd_finally_mono (pure_mono StronglyNormalizing.intro) - iintro %cfg₂ %Hstep - rcases cfg₂ with ⟨t₂, σ₂⟩ - obtain ⟨κ, Hstep⟩ := Hstep - imod Hpre $$ %t₂ %σ %ns %κ %([] : List Obs) %σ₂ %nt %Hstep Hσ with - ⟨%nt', %hκ, Hσ, Ht₂⟩ - icases Ht₂ with ⟨IH, -⟩ + iintro %⟨t₂, σ₂⟩ %⟨κ, Hstep⟩ + imod Hpre $$ %_ %_ %_ %_ %_ %_ %_ %Hstep Hσ with ⟨%nt', %hκ, Hσ, ⟨IH, -⟩⟩ iapply IH $$ %σ₂ %(ns + 1) %nt' Hσ end ThreadPool @@ -400,16 +247,14 @@ theorem twp_total {hlc : HasLC} {GF : BundledGFunctors} StronglyNormalizing (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) ([e], σ) := by - apply pure_soundness (PROP := IProp GF) - apply fupd_finally_soundness hlc m ⊤ + refine pure_soundness (PROP := IProp GF) (fupd_finally_soundness hlc m ⊤ _ ?_) iintro %Hinv Hcred imod Hwp with ⟨%stateI, %numLatersPerStep, %forkPost, %mono, Hσ, Htwp⟩ letI iG : IrisGS_gen hlc Expr GF := .mk (toStateInterp := ⟨stateI⟩) numLatersPerStep forkPost mono iapply twptp_total [e] σ n 0 (ι := iG) $$ Hσ - iapply twptp.of_twp s e Φ (ι := iG) - iapply Htwp $$ Hcred + iapply twptp.of_twp s e Φ (ι := iG) $$ (Htwp $$ Hcred) /-- Erased single-expression reduction. -/ def ExprErasedStep : Expr × State → Expr × State → Prop @@ -430,12 +275,9 @@ theorem stronglyNormalizing_expr_of_threadPool ([e], σ)) : StronglyNormalizing (ExprErasedStep (Expr := Expr) (State := State) (Obs := Obs)) - (e, σ) := by - apply StronglyNormalizing.map (fun ρ : Expr × State => ([ρ.1], ρ.2)) ?_ H - rintro ⟨e₁, σ₁⟩ ⟨e₂, σ₂⟩ ⟨κ, efs, Hstep⟩ - have hefs : efs = [] := LanguageNoFork.no_fork Hstep - subst efs - exact ⟨κ, .atomic Hstep [] []⟩ + (e, σ) := + StronglyNormalizing.map (fun ρ : Expr × State => ([ρ.1], ρ.2)) + (fun _ _ ⟨κ, efs, Hstep⟩ => ⟨κ, by simpa [LanguageNoFork.no_fork Hstep] using Step.atomic Hstep [] []⟩) H end end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/TotalEctxLifting.lean b/Iris/Iris/ProgramLogic/TotalEctxLifting.lean index 568cbaa34..c62fa9cb5 100644 --- a/Iris/Iris/ProgramLogic/TotalEctxLifting.lean +++ b/Iris/Iris/ProgramLogic/TotalEctxLifting.lean @@ -9,7 +9,7 @@ public import Iris.ProgramLogic.EctxiLanguage namespace Iris.ProgramLogic -open Iris Language.Notation EctxLanguage EctxLanguage.Notation +open Iris BI Language.Notation EctxLanguage EctxLanguage.Notation @[expose] public section @@ -21,6 +21,29 @@ variable {GF : BundledGFunctors} [ι : IrisGS_gen hlc Expr GF] variable {s : Stuckness} {E : CoPset} {e₁ e₂ : Expr} variable {Φ : Val → IProp GF} +private theorem baseStep_of_primStep {e₂' σ₁ σ₂ κ eₜ} + (Hred : BaseStep.ReducibleNoObs (e₁, σ₁)) + (Hstep : (e₁, σ₁) -<κ>-> (e₂', σ₂, eₜ)) : + (e₁, σ₁) -<κ>->ᵇ (e₂', σ₂, eₜ) := + baseStep_of_primStep_of_baseStep_reducible (BaseStep.reducible_of_reducibleNoObs Hred) Hstep + +private theorem baseStep_mono {E₁ E₂ : CoPset} + {Q : Nat → List Obs → Nat → List Obs → Expr → State → List Expr → IProp GF} : + (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E₁,E₂}=∗ + ⌜BaseStep.ReducibleNoObs (e₁, σ₁)⌝ ∗ + ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>->ᵇ (e₂, σ₂, eₜ)⌝ ={E₂,E₁}=∗ + Q ns obs nt κ e₂ σ₂ eₜ) ⊢ + ∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E₁,E₂}=∗ + ⌜s.MaybeReducibleNoObs (e₁, σ₁)⌝ ∗ + ∀ κ e₂ σ₂ eₜ, ⌜(e₁, σ₁) -<κ>-> (e₂, σ₂, eₜ)⌝ ={E₂,E₁}=∗ + Q ns obs nt κ e₂ σ₂ eₜ := by + iintro H %σ₁ %ns %obs %nt Hσ + imod H $$ Hσ with ⟨%Hred, H⟩ + have Hred' : s.MaybeReducibleNoObs (e₁, σ₁) := by grind [primStep_reducibleNoObs_of_baseStep_reducibleNoObs] + iframe %Hred' + iintro !> %κ %e₂ %σ₂ %eₜ %Hstep + iapply H $$ %κ %e₂ %σ₂ %eₜ %(baseStep_of_primStep Hred Hstep) + @[rocq_alias twp_lift_base_step] theorem twp_lift_base_step (h : toVal e₁ = none) : (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E,∅}=∗ @@ -30,22 +53,8 @@ theorem twp_lift_base_step (h : toVal e₁ = none) : stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ WP e₂ @ s; E [{ Φ }] ∗ [∗list] ef ∈ eₜ, WP ef @ s; ⊤ [{ ι.forkPost }]) - ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro H - iapply twp_lift_step h - iintro %σ₁ %ns %obs %nt Hσ - imod H $$ Hσ with ⟨%Hred, H⟩ - imodintro - isplit - · ipureintro - cases s - · exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs - Hred - · trivial - · iintro %κ %e₂ %σ₂ %eₜ %Hstep - have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible - (BaseStep.reducible_of_reducibleNoObs Hred) Hstep - iapply H $$ %κ %e₂ %σ₂ %eₜ %Hb + ⊢ WP e₁ @ s; E [{ Φ }] := + baseStep_mono.trans (twp_lift_step h) theorem twp_lift_base_step_no_fork (h : toVal e₁ = none) : (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E,∅}=∗ @@ -54,21 +63,8 @@ theorem twp_lift_base_step_no_fork (h : toVal e₁ = none) : ⌜κ = []⌝ ∗ ⌜eₜ = []⌝ ∗ stateInterp σ₂ (ns + 1) obs nt ∗ WP e₂ @ s; E [{ Φ }]) - ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro H - iapply twp_lift_step_no_fork h - iintro %σ₁ %ns %obs %nt Hσ - imod H $$ Hσ with ⟨%Hred, H⟩ - imodintro - isplit - · ipureintro - cases s - · exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs Hred - · trivial - · iintro %κ %e₂ %σ₂ %eₜ %Hstep - have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible - (BaseStep.reducible_of_reducibleNoObs Hred) Hstep - iapply H $$ %κ %e₂ %σ₂ %eₜ %Hb + ⊢ WP e₁ @ s; E [{ Φ }] := + baseStep_mono.trans (twp_lift_step_no_fork h) @[rocq_alias twp_lift_pure_base_step_no_fork] theorem twp_lift_pure_base_step_no_fork [Inhabited State] @@ -80,21 +76,9 @@ theorem twp_lift_pure_base_step_no_fork [Inhabited State] ⌜(e₁, σ) -<κ>->ᵇ (e₂', σ, eₜ)⌝ -∗ WP e₂' @ s; E [{ Φ }]) ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro H - iapply twp_lift_pure_step_no_fork - · intro σ - exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs - (Hred σ) - · intro σ₁ κ e₂' σ₂ eₜ Hstep - exact Hpure _ _ _ _ _ - (EctxLanguage.baseStep_of_primStep_of_baseStep_reducible - (BaseStep.reducible_of_reducibleNoObs (Hred σ₁)) Hstep) - · imod H with H - imodintro - iintro %κ %e₂' %eₜ %σ %Hstep - have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible - (BaseStep.reducible_of_reducibleNoObs (Hred σ)) Hstep - iapply H $$ %κ %e₂' %eₜ %σ %Hb + refine (BIFUpdate.mono (forall_mono fun _ => forall_mono fun _ => forall_mono fun _ => forall_mono fun σ => + wand_mono_left <| pure_mono fun Hstep => baseStep_of_primStep (Hred σ) Hstep)).trans <| twp_lift_pure_step_no_fork + (by grind [primStep_reducibleNoObs_of_baseStep_reducibleNoObs]) (by grind only [→ baseStep_of_primStep]) @[rocq_alias twp_lift_atomic_base_step] theorem twp_lift_atomic_base_step (h : toVal e₁ = none) : @@ -105,22 +89,8 @@ theorem twp_lift_atomic_base_step (h : toVal e₁ = none) : stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ (∃ v, ⌜toVal e₂ = some v⌝ ∧ Φ v) ∗ [∗list] ef ∈ eₜ, WP ef @ s; ⊤ [{ ι.forkPost }]) - ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro H - iapply twp_lift_atomic_step h - iintro %σ₁ %ns %obs %nt Hσ - imod H $$ Hσ with ⟨%Hred, H⟩ - imodintro - isplit - · ipureintro - cases s - · exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs - Hred - · trivial - · iintro %κ %e₂ %σ₂ %eₜ %Hstep - have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible - (BaseStep.reducible_of_reducibleNoObs Hred) Hstep - iapply H $$ %κ %e₂ %σ₂ %eₜ %Hb + ⊢ WP e₁ @ s; E [{ Φ }] := + baseStep_mono.trans (twp_lift_atomic_step h) @[rocq_alias twp_lift_atomic_base_step_no_fork] theorem twp_lift_atomic_base_step_no_fork (h : toVal e₁ = none) : @@ -130,22 +100,8 @@ theorem twp_lift_atomic_base_step_no_fork (h : toVal e₁ = none) : ⌜κ = []⌝ ∗ ⌜eₜ = []⌝ ∗ stateInterp σ₂ (ns + 1) obs nt ∗ ∃ v, ⌜toVal e₂ = some v⌝ ∧ Φ v) - ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro H - iapply twp_lift_atomic_step_no_fork h - iintro %σ₁ %ns %obs %nt Hσ - imod H $$ Hσ with ⟨%Hred, H⟩ - imodintro - isplit - · ipureintro - cases s - · exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs - Hred - · trivial - · iintro %κ %e₂ %σ₂ %eₜ %Hstep - have Hb := EctxLanguage.baseStep_of_primStep_of_baseStep_reducible - (BaseStep.reducible_of_reducibleNoObs Hred) Hstep - iapply H $$ %κ %e₂ %σ₂ %eₜ %Hb + ⊢ WP e₁ @ s; E [{ Φ }] := + baseStep_mono.trans (twp_lift_atomic_step_no_fork h) @[rocq_alias twp_lift_pure_det_base_step_no_fork] theorem twp_lift_pure_det_base_step_no_fork [Inhabited State] @@ -154,18 +110,9 @@ theorem twp_lift_pure_det_base_step_no_fork [Inhabited State] (Hpure : ∀ σ κ e₂' σ₂ eₜ, (e₁, σ) -<κ>->ᵇ (e₂', σ₂, eₜ) → κ = [] ∧ σ₂ = σ ∧ e₂' = e₂ ∧ eₜ = []) : - WP e₂ @ s; E [{ Φ }] ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro Hwp - iapply twp_lift_pure_det_step_no_fork - · intro σ - exact EctxLanguage.primStep_reducibleNoObs_of_baseStep_reducibleNoObs - (Hred σ) - · intro σ κ e₂' σ₂ eₜ Hstep - exact Hpure _ _ _ _ _ - (EctxLanguage.baseStep_of_primStep_of_baseStep_reducible - (BaseStep.reducible_of_reducibleNoObs (Hred σ)) Hstep) - · imodintro - iexact Hwp + WP e₂ @ s; E [{ Φ }] ⊢ WP e₁ @ s; E [{ Φ }] := + fupd_intro.trans <| twp_lift_pure_det_step_no_fork (e₂ := e₂) + (by grind [primStep_reducibleNoObs_of_baseStep_reducibleNoObs]) (by grind only [→ baseStep_of_primStep]) end end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/TotalLifting.lean b/Iris/Iris/ProgramLogic/TotalLifting.lean index 8c9b71c61..be76b4757 100644 --- a/Iris/Iris/ProgramLogic/TotalLifting.lean +++ b/Iris/Iris/ProgramLogic/TotalLifting.lean @@ -29,10 +29,7 @@ theorem twp_lift_step (h : toVal e₁ = none) : stateInterp σ₂ (ns + 1) obs (nt + eₜ.length) ∗ WP e₂ @ s; E [{ Φ }] ∗ [∗list] ef ∈ eₜ, WP ef @ s; ⊤ [{ ι.forkPost }]) - ⊢ WP e₁ @ s; E [{ Φ }] := by - rw [twp.unfold.to_eq] - simp only [twp.pre, h] - exact .rfl + ⊢ WP e₁ @ s; E [{ Φ }] := by rw [twp.unfold.to_eq, twp.pre, h] theorem twp_lift_step_no_fork (h : toVal e₁ = none) : (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E,∅}=∗ @@ -42,17 +39,13 @@ theorem twp_lift_step_no_fork (h : toVal e₁ = none) : stateInterp σ₂ (ns + 1) obs nt ∗ WP e₂ @ s; E [{ Φ }]) ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro H - iapply twp_lift_step h - iintro %σ₁ %ns %obs %nt Hσ + refine .trans ?_ <| twp_lift_step h + iintro H %σ₁ %ns %obs %nt Hσ imod H $$ Hσ with ⟨%Hred, H⟩ - imodintro iframe %Hred - iintro %κ %e₂ %σ₂ %eₜ %Hstep - imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with ⟨%hκ, %heₜ, Hσ, Hwp⟩ - subst heₜ - imodintro - simp only [List.length_nil, Nat.add_zero, Algebra.BigOpL.bigOpL_nil] + iintro !> %κ %e₂ %σ₂ %eₜ Hstep + imod H $$ Hstep with ⟨%hκ, %heₜ, Hσ, Hwp⟩ + simp only [heₜ, List.length_nil, Nat.add_zero, Algebra.BigOpL.bigOpL_nil, BI.sep_emp.to_eq] iframe %hκ Hσ Hwp @[rocq_alias twp_lift_atomic_step] @@ -65,23 +58,17 @@ theorem twp_lift_atomic_step (h : toVal e₁ = none) : (∃ v, ⌜toVal e₂ = some v⌝ ∧ Φ v) ∗ [∗list] ef ∈ eₜ, WP ef @ s; ⊤ [{ ι.forkPost }]) ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro H - iapply twp_lift_step h - iintro %σ₁ %ns %obs %nt Hσ + refine .trans ?_ <| twp_lift_step h + iintro H %σ₁ %ns %obs %nt Hσ imod H $$ Hσ with ⟨%Hred, H⟩ iapply fupd_mask_intro Std.LawfulSet.empty_subset iintro Hclose - isplit - · ipureintro - exact Hred - · iintro %κ %e₂ %σ₂ %eₜ %Hstep - imod Hclose with - - imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with - ⟨%hκ, Hσ, ⟨%v, %hval, HΦ⟩, Hefs⟩ - imodintro - iframe %hκ Hσ Hefs - iapply twp.value (ToVal.coe_of_toVal_eq_some hval).symm - iexact HΦ + iframe %Hred + iintro %κ %e₂ %σ₂ %eₜ Hstep + imod Hclose with - + imod H $$ Hstep with ⟨%hκ, Hσ, ⟨%v, %hval, HΦ⟩, Hefs⟩ + iframe %hκ Hσ Hefs + iapply twp.value (ToVal.coe_of_toVal_eq_some hval).symm $$ HΦ theorem twp_lift_atomic_step_no_fork (h : toVal e₁ = none) : (∀ σ₁ ns obs nt, stateInterp σ₁ ns obs nt ={E}=∗ @@ -91,18 +78,13 @@ theorem twp_lift_atomic_step_no_fork (h : toVal e₁ = none) : stateInterp σ₂ (ns + 1) obs nt ∗ ∃ v, ⌜toVal e₂ = some v⌝ ∧ Φ v) ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro H - iapply twp_lift_atomic_step h - iintro %σ₁ %ns %obs %nt Hσ + refine .trans ?_ <| twp_lift_atomic_step h + iintro H %σ₁ %ns %obs %nt Hσ imod H $$ Hσ with ⟨%Hred, H⟩ - imodintro iframe %Hred - iintro %κ %e₂ %σ₂ %eₜ %Hstep - imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with - ⟨%hκ, %heₜ, Hσ, Hval⟩ - subst heₜ - imodintro - simp only [List.length_nil, Nat.add_zero, Algebra.BigOpL.bigOpL_nil] + iintro !> %κ %e₂ %σ₂ %eₜ Hstep + imod H $$ Hstep with ⟨%hκ, %heₜ, Hσ, Hval⟩ + simp only [heₜ, List.length_nil, Nat.add_zero, Algebra.BigOpL.bigOpL_nil, BI.sep_emp.to_eq] iframe %hκ Hσ Hval @[rocq_alias twp_lift_pure_step_no_fork] @@ -115,33 +97,19 @@ theorem twp_lift_pure_step_no_fork [Inhabited State] ⌜(e₁, σ) -<κ>-> (e₂', σ, eₜ)⌝ -∗ WP e₂' @ s; E [{ Φ }]) ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro H - have hnone : toVal e₁ = none := - Language.toVal_none_of_reducible - (Language.reducible_of_reducibleNoObs (Hsafe default)) - iapply twp_lift_step_no_fork hnone - iintro %σ₁ %ns %obs %nt Hσ - imod H with H + refine .trans ?_ <| twp_lift_step_no_fork (toVal_none_of_reducible <| reducible_of_reducibleNoObs (Hsafe default)) + iintro H %σ₁ %ns %obs %nt Hσ + imod H iapply fupd_mask_intro Std.LawfulSet.empty_subset iintro Hclose - isplit - · ipureintro - cases s - · exact Hsafe σ₁ - · trivial + isplitr + · exact BI.pure_intro (by grind [cases Stuckness]) · iintro %κ %e₂' %σ₂ %eₜ %Hstep - obtain ⟨rfl, rfl, rfl⟩ := Hpure _ _ _ _ _ Hstep + obtain ⟨hκ, rfl, heₜ⟩ := Hpure _ _ _ _ _ Hstep imod ι.stateInterp_mono σ₂ ns obs nt $$ Hσ with Hσ imod Hclose - imodintro - iframe Hσ - isplit - · ipureintro - exact rfl - · isplit - · ipureintro - exact rfl - · iapply H $$ %([] : List Obs) %e₂' %([] : List Expr) %σ₂ %Hstep + iframe %hκ %heₜ Hσ + iapply H $$ %κ %e₂' %eₜ %σ₂ %Hstep @[rocq_alias twp_lift_pure_det_step_no_fork] theorem twp_lift_pure_det_step_no_fork [Inhabited State] @@ -150,37 +118,16 @@ theorem twp_lift_pure_det_step_no_fork [Inhabited State] (e₁, σ₁) -<κ>-> (e₂', σ₂, eₜ) → κ = [] ∧ σ₂ = σ₁ ∧ e₂' = e₂ ∧ eₜ = []) : (|={E}=> WP e₂ @ s; E [{ Φ }]) ⊢ WP e₁ @ s; E [{ Φ }] := by - iintro Hwp - iapply twp_lift_pure_step_no_fork Hsafe ?_ - · intro σ₁ κ e₂' σ₂ eₜ Hstep - obtain ⟨hκ, hσ, _, heₜ⟩ := Hpure _ _ _ _ _ Hstep - exact ⟨hκ, hσ, heₜ⟩ - · imod Hwp with Hwp - imodintro - iintro %κ %e₂' %eₜ %σ %Hstep - obtain ⟨_, _, he₂, _⟩ := Hpure _ _ _ _ _ Hstep - subst e₂' - iexact Hwp + refine (BIFUpdate.mono ?_).trans <| twp_lift_pure_step_no_fork Hsafe (by grind only) + iintro Hwp %κ %e₂' %eₜ %σ %Hstep + exact (Hpure _ _ _ _ _ Hstep).2.2.1 ▸ .rfl @[rocq_alias twp_pure_step] theorem twp_pure_step [Inhabited State] (Hexec : PureExec φ n e₁ e₂) (Hφ : φ) : - WP e₂ @ s; E [{ Φ }] ⊢ WP e₁ @ s; E [{ Φ }] := by - replace Hexec := Hexec.pureExec Hφ - iinduction Hexec using Relation.Iterate.head_induction_on with - | rfl => - iintro Hwp - iexact Hwp - | @head n e₁ e₃ _ _ IH => - iintro Hwp - obtain ⟨Hsafe, Hdet⟩ := ‹e₁ -ᵖ-> e₃› - iapply twp_lift_pure_det_step_no_fork Hsafe ?_ - · intro σ₁ κ e₂' σ₂ eₜ Hstep - obtain ⟨hκ, hσ, he, heₜ⟩ := Hdet Hstep - exact ⟨hκ, hσ.symm, he.symm, heₜ⟩ - · imodintro - iapply IH - iexact Hwp + WP e₂ @ s; E [{ Φ }] ⊢ WP e₁ @ s; E [{ Φ }] := (Hexec.pureExec Hφ).head_induction_on + (motive := fun _ e _ => WP e₂ @ s; E [{ Φ }] ⊢ WP e @ s; E [{ Φ }]) .rfl fun e₃ Hstep _ IH => + (IH.trans fupd_intro).trans <| twp_lift_pure_det_step_no_fork (e₂ := e₃) Hstep.1 (by grind only [Hstep.2]) end end Iris.ProgramLogic diff --git a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean index 0c471edf1..28c034946 100644 --- a/Iris/Iris/ProgramLogic/TotalWeakestPre.lean +++ b/Iris/Iris/ProgramLogic/TotalWeakestPre.lean @@ -10,7 +10,7 @@ public import Iris.ProofMode namespace Iris -open ProgramLogic Language.Notation Std OFE +open ProgramLogic Language Language.Notation Std OFE BI @[expose] public section @@ -80,12 +80,11 @@ theorem pre_mono (s : Stuckness) (X Y : CoPset → Expr → (Val → IProp GF) iframe %Hred iintro !> %κ %e₂ %σ₂ %eₜ Hprim imod Hstep $$ Hprim with ⟨%hκ, Hσ, He₂, Hefs⟩ - imodintro iframe %hκ Hσ isplitl [He₂] · iapply H $$ He₂ · iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef Hef + iintro !> !> %k %ef %Hef Hef iapply H $$ Hef namespace Internal @@ -93,40 +92,22 @@ namespace Internal instance pre'_mono (s : Stuckness) : BIMonoPred (pre' (ι := ι) s) where mono_pred := by intro X Y _ _ - iintro #HXY %x HX - rcases x with ⟨E, e, Φ⟩ + iintro #HXY %⟨E, e, Φ⟩ HX unfold pre' iapply pre_mono s (fun E e Φ => X (E, e, Φ)) (fun E e Φ => Y (E, e, Φ)) $$ [] [$] iintro !> %E %e %Φ H iapply HXY $$ H - mono_pred_ne.ne {n} := fun ⟨E₁, e₁, Φ₁⟩ ⟨E₂, e₂, Φ₂⟩ ⟨hE, he, hΦ⟩ => by - change E₁ = E₂ at hE - change e₁ = e₂ at he - subst E₂ - subst e₂ + mono_pred_ne.ne {n} := fun ⟨E₁, e₁, Φ₁⟩ ⟨E₂, e₂, Φ₂⟩ ⟨hE, he, hΦ⟩ => + (show E₁ = E₂ from hE) ▸ (show e₁ = e₂ from he) ▸ by simp only [pre', pre] match toVal e₁ with | some v => exact BIFUpdate.ne.ne (hΦ v) | none => - refine BI.forall_ne fun _ => ?_ - refine BI.forall_ne fun _ => ?_ - refine BI.forall_ne fun _ => ?_ - refine BI.forall_ne fun _ => ?_ - refine BI.wand_ne.ne .rfl ?_ - refine BIFUpdate.ne.ne ?_ - refine BI.sep_ne.ne .rfl ?_ - refine BI.forall_ne fun _ => ?_ - refine BI.forall_ne fun _ => ?_ - refine BI.forall_ne fun _ => ?_ - refine BI.forall_ne fun _ => ?_ - refine BI.wand_ne.ne .rfl ?_ - refine BIFUpdate.ne.ne ?_ - refine BI.sep_ne.ne .rfl ?_ - refine BI.sep_ne.ne .rfl ?_ - refine BI.sep_ne.ne ?_ ?_ - · apply NonExpansive.ne - exact ⟨.rfl, .rfl, hΦ⟩ - · rfl + refine forall_ne fun _ => forall_ne fun _ => forall_ne fun _ => forall_ne fun _ => + wand_ne.ne .rfl <| BIFUpdate.ne.ne <| sep_ne.ne .rfl <| forall_ne fun _ => forall_ne fun e => + forall_ne fun _ => forall_ne fun _ => wand_ne.ne .rfl <| BIFUpdate.ne.ne <| + sep_ne.ne .rfl <| sep_ne.ne .rfl <| sep_ne.ne ?_ .rfl + exact NonExpansive.ne (show (E₁, e, Φ₁) ≡{n}≡ (E₁, e, Φ₂) from ⟨.rfl, .rfl, hΦ⟩) def get (s : Stuckness) (E : CoPset) (e : Expr) (Φ : Val → IProp GF) : IProp GF := bi_least_fixpoint (pre' s) (E, e, Φ) @@ -147,30 +128,29 @@ theorem unfold {s E} {e : Expr} {Φ : Val → IProp GF} : theorem induction (s : Stuckness) (Ψ : CoPset → Expr → (Val → IProp GF) → IProp GF) [HΨ : NonExpansive (fun x : Internal.Args Expr Val GF => Ψ x.1 x.2.1 x.2.2)] : (⊢ □ (∀ E e Φ, pre s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) E e Φ -∗ Ψ E e Φ)) → - ⊢ ∀ E e Φ, WP e @ s ; E [{ Φ }] -∗ Ψ E e Φ := by - intro H + ⊢ ∀ E e Φ, WP e @ s ; E [{ Φ }] -∗ Ψ E e Φ := fun H => by iintro %E %e %Φ change ⊢ bi_least_fixpoint (Internal.pre' s) (E, e, Φ) -∗ Ψ E e Φ - iintro Htwp - iapply least_fixpoint_ind (F := Internal.pre' s) (Φ := fun x => Ψ x.1 x.2.1 x.2.2) $$ [] Htwp + iapply least_fixpoint_ind (F := Internal.pre' s) (Φ := fun x => Ψ x.1 x.2.1 x.2.2) $$ [] iintro !> %⟨E, e, Φ⟩ - simp only [Internal.pre'] - simp only [TotalWp.totalWp, Internal.get] at H + simp only [Internal.pre', TotalWp.totalWp, Internal.get] at H ⊢ iapply H @[rocq_alias twp_ne] instance ne {s : Stuckness} {E} {e : Expr} : NonExpansive (TotalWp.totalWp (PROP := IProp GF) s E e) where - ne {n Φ₁ Φ₂} HΦ := by - change bi_least_fixpoint (Internal.pre' s) (E, e, Φ₁) ≡{n}≡ _ - apply NonExpansive.ne - exact ⟨.rfl, .rfl, HΦ⟩ + ne {n Φ₁ Φ₂} HΦ := NonExpansive.ne (f := bi_least_fixpoint (Internal.pre' s)) + (show (E, e, Φ₁) ≡{n}≡ (E, e, Φ₂) from ⟨.rfl, .rfl, HΦ⟩) @[rocq_alias twp_value_fupd'] theorem value_fupd' {s : Stuckness} {E} {Φ : Val → IProp GF} {v : Val} : WP (v : Expr) @ s ; E [{ Φ }] ⊣⊢ |={E}=> Φ v := by simp [unfold.to_eq, pre, toVal_coe] +@[rocq_alias twp_value_fupd] +theorem value_fupd {s : Stuckness} {E} {e : Expr} {v : Val} {Φ : Val → IProp GF} (h : e = v) : + WP e @ s ; E [{ Φ }] ⊣⊢ |={E}=> Φ v := h ▸ value_fupd' + @[rocq_alias twp_strong_mono] theorem strong_mono {s₁ s₂ : Stuckness} {E₁ E₂} {e : Expr} {Φ Ψ : Val → IProp GF} (hs : s₁ ≤ s₂) (hE : E₁ ⊆ E₂) : @@ -178,60 +158,47 @@ theorem strong_mono {s₁ s₂ : Stuckness} {E₁ E₂} {e : Expr} (∀ v, Φ v ={E₂}=∗ Ψ v) -∗ WP e @ s₂ ; E₂ [{ Ψ }] := by let Pred := fun (E : CoPset) (e : Expr) (Φ : Val → IProp GF) => iprop% ∀ E₂ Ψ, ⌜E ⊆ E₂⌝ -∗ (∀ v, Φ v ={E₂}=∗ Ψ v) -∗ WP e @ s₂ ; E₂ [{ Ψ }] - have hPred : NonExpansive (fun x : Internal.Args Expr Val GF => Pred x.1 x.2.1 x.2.2) := by - constructor - intro n ⟨EX, eX, ΦX⟩ ⟨EY, eY, ΦY⟩ ⟨hE', he', hΦ⟩ - change EX = EY at hE' - change eX = eY at he' - subst EY - subst eY - refine BI.forall_ne fun _ => ?_ - refine BI.forall_ne fun _ => ?_ - refine BI.wand_ne.ne .rfl ?_ - refine BI.wand_ne.ne ?_ .rfl - refine BI.forall_ne fun v => ?_ - exact BI.wand_ne.ne (hΦ v) .rfl + have hPred : NonExpansive (fun x : Internal.Args Expr Val GF => Pred x.1 x.2.1 x.2.2) := + ⟨fun _ _ _ ⟨hE, he, hΦ⟩ => hE ▸ he ▸ forall_ne fun _ => forall_ne fun _ => wand_ne.ne .rfl <| + wand_ne.ne (forall_ne fun v => wand_ne.ne (hΦ v) .rfl) .rfl⟩ iintro H HΦ iapply induction s₁ Pred $$ H [//] [$] · iintro !> %E %e₁ %Φ₁ IH %E' %Ψ' %hE' - rw [unfold.to_eq] - unfold pre - cases hval : toVal e₁ with - | some v => - iintro HpostSome - imod fupd_mask_mono hE' $$ IH with HΦv - iapply HpostSome $$ HΦv - | none => - iintro HpostNone + simp only [(unfold (s := s₂) (E := E') (e := e₁) (Φ := Ψ')).to_eq, pre] + cases hval : toVal e₁ + all_goals iintro Hpost + next => iintro %σ₁ %ns %obs %nt Hσ imod fupd_mask_subseteq hE' with Hclose imod IH $$ Hσ with ⟨%Hred, Hstep⟩ - imodintro - isplit - · ipureintro + have Hred' : s₂.MaybeReducibleNoObs (e₁, σ₁) := by simp only [LE.le] at hs grind [cases Stuckness] - · iintro %κ %e₂ %σ₂ %eₜ Hprim - imod Hstep $$ Hprim with ⟨%hκ, Hσ, He₂, Hefs⟩ - imod Hclose - imodintro - iframe %hκ Hσ - isplitl [He₂ HpostNone] - · icases He₂ with ⟨IH₂, -⟩ - iapply IH₂ $$ [//] HpostNone - · iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef Hef - icases Hef with ⟨IHef, -⟩ - iapply IHef $$ %⊤ %ι.forkPost %LawfulSet.subset_refl - iintro %v Hv - itrivial + iframe %Hred' + iintro !> %κ %e₂ %σ₂ %eₜ Hprim + imod Hstep $$ Hprim with ⟨%hκ, Hσ, ⟨IH₂, -⟩, Hefs⟩ + imod Hclose + iframe %hκ Hσ + isplitl [IH₂ Hpost] + · iapply IH₂ $$ [//] Hpost + · iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> !> %k %ef %Hef ⟨IHef, -⟩ + iapply IHef $$ %⊤ %ι.forkPost %LawfulSet.subset_refl + iintro %v $ + next => + imod fupd_mask_mono hE' $$ IH with HΦv + iapply Hpost $$ HΦv + +private theorem strong_mono_with {s₁ s₂ : Stuckness} {E₁ E₂} {e : Expr} {Φ Ψ : Val → IProp GF} + (hs : s₁ ≤ s₂) (hE : E₁ ⊆ E₂) (H : ∀ v, ⊢ Φ v ={E₂}=∗ Ψ v) : + WP e @ s₁ ; E₁ [{ Φ }] ⊢ WP e @ s₂ ; E₂ [{ Ψ }] := + sep_elim_emp_valid_right (forall_intro H) (wand_elim (wand_entails (strong_mono hs hE))) @[rocq_alias fupd_twp] theorem fupd_twp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : (|={E}=> WP e @ s ; E [{ Φ }]) ⊢ WP e @ s ; E [{ Φ }] := by - rw [unfold.to_eq] + simp only [(unfold (e := e)).to_eq, pre] iintro H - unfold pre cases toVal e · iintro %σ %ns %obs %nt Hσ imod H $$ Hσ with $ @@ -239,50 +206,37 @@ theorem fupd_twp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : @[rocq_alias twp_fupd] theorem twp_fupd {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : - WP e @ s ; E [{ v, |={E}=> Φ v }] ⊢ WP e @ s ; E [{ Φ }] := by - iintro H - iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ H - iintro %v $ + WP e @ s ; E [{ v, |={E}=> Φ v }] ⊢ WP e @ s ; E [{ Φ }] := + strong_mono_with (Std.IsPreorder.le_refl _) LawfulSet.subset_refl fun _ => BI.wand_rfl @[rocq_alias twp_atomic] theorem atomic {s : Stuckness} {E₁ E₂ : CoPset} {e : Expr} {Φ : Val → IProp GF} [hatom : Language.Atomic ↑s e] : (|={E₁,E₂}=> WP e @ s ; E₂ [{ v, |={E₂,E₁}=> Φ v }]) ⊢ WP e @ s ; E₁ [{ Φ }] := by - rw [unfold.to_eq, unfold.to_eq] + simp only [(unfold (e := e)).to_eq, pre] iintro H - unfold pre cases he : toVal e with | some v => icases H with > >$ | none => iintro %σ₁ %ns %obs %nt Hσ imod H $$ Hσ with >⟨$, Hstep⟩ - imodintro + iintro !> %κ %e₂ %σ₂ %eₜ %Hprim cases s - · iintro %κ %e₂ %σ₂ %eₜ %Hprim - imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with ⟨%hκ, Hσ, He₂, Hefs⟩ + · imod Hstep $$ %κ %e₂ %σ₂ %eₜ %Hprim with ⟨%hκ, Hσ, He₂, Hefs⟩ cases he₂ : toVal e₂ with | some v₂ => - rw [unfold.to_eq] - simp only [pre, he₂] - icases He₂ with > >He₂ + imod (value_fupd (ToVal.coe_of_toVal_eq_some he₂).symm).mp $$ He₂ with >He₂ iframe %hκ Hσ Hefs - simp only [unfold.to_eq, pre, he₂] - itrivial + iapply (value_fupd (ToVal.coe_of_toVal_eq_some he₂).symm).mpr $$ He₂ | none => - rw [unfold.to_eq] - simp only [pre, he₂] + simp only [(unfold (e := e₂)).to_eq, pre, he₂] imod He₂ $$ %σ₂ %(ns + 1) %obs %(nt + eₜ.length) Hσ with ⟨%Hred₂, _⟩ - exact (Language.not_reducible_iff_irreducible.mpr (hatom.atomic Hprim)) - (Language.reducible_of_reducibleNoObs Hred₂) |>.elim - · iintro %κ %e₂ %σ₂ %eₜ %Hprim - imod Hstep $$ [//] with ⟨%hκ, Hσ, He₂, Hefs⟩ + exact ((not_reducible_iff_irreducible.mpr (hatom.atomic Hprim)) (reducible_of_reducibleNoObs Hred₂)).elim + · imod Hstep $$ [//] with ⟨%hκ, Hσ, He₂, Hefs⟩ have ⟨v₂, hv₂⟩ := Option.isSome_iff_exists.mp (hatom.atomic Hprim) - rw [unfold.to_eq] - simp only [pre, hv₂] - imod He₂ with >He₂ + imod (value_fupd (ToVal.coe_of_toVal_eq_some hv₂).symm).mp $$ He₂ with >He₂ iframe %hκ Hσ Hefs - simp only [unfold.to_eq, pre, hv₂] - itrivial + iapply (value_fupd (ToVal.coe_of_toVal_eq_some hv₂).symm).mpr $$ He₂ @[rocq_alias twp_bind] theorem bind (K : Expr → Expr) [ctx : Language.Context K] @@ -292,63 +246,35 @@ theorem bind (K : Expr → Expr) [ctx : Language.Context K] let Pred := fun (E : CoPset) (e : Expr) (Ψ : Val → IProp GF) => iprop% ∀ Φ, (∀ v, Ψ v -∗ WP (K v) @ s ; E [{ Φ }]) -∗ WP (K e) @ s ; E [{ Φ }] - letI : NonExpansive (fun x : Internal.Args Expr Val GF => Pred x.1 x.2.1 x.2.2) := by - constructor - intro n ⟨EX, eX, ΨX⟩ ⟨EY, eY, ΨY⟩ ⟨hE, he, hΨ⟩ - change EX = EY at hE - change eX = eY at he - subst EY - subst eY - refine BI.forall_ne fun _ => ?_ - refine BI.wand_ne.ne ?_ .rfl - refine BI.forall_ne fun v => ?_ - exact BI.wand_ne.ne (hΨ v) .rfl + letI : NonExpansive (fun x : Internal.Args Expr Val GF => Pred x.1 x.2.1 x.2.2) := + ⟨fun _ _ _ ⟨hE, he, hΨ⟩ => hE ▸ he ▸ BI.forall_ne fun _ => + BI.wand_ne.ne (BI.forall_ne fun v => BI.wand_ne.ne (hΨ v) .rfl) .rfl⟩ iintro H iapply induction s Pred $$ H · iintro !> %E %e %Ψ - cases he : toVal e with - | some v => - simp only [pre, he] - iintro Hpre %Φ Hcont - rw [← (ToVal.coe_of_toVal_eq_some he)] - ispecialize Hcont $$ %v - iapply fupd_twp - iapply (fupd_wand_left (P := Ψ v)) - iframe - | none => + cases he : toVal e + all_goals simp only [pre, he] iintro Hpre %Φ Hcont - rw [unfold.to_eq] - unfold pre - simp only [ctx.toVal_eq_none_fill he] + next => + simp only [(unfold (e := K e)).to_eq, pre, ctx.toVal_eq_none_fill he] iintro %σ₁ %ns %obs %nt Hσ imod Hpre $$ Hσ with ⟨%Hred, Hstep⟩ - imodintro - isplit - · ipureintro - cases s - · exact Language.Context.reducibleNoObs_fill (K := K) Hred - · trivial - · iintro %κ %e₂ %σ₂ %eₜ %HKstep - obtain ⟨e₂', rfl, Hprim⟩ := ctx.primStep_fill_inv he HKstep - imod Hstep $$ [//] with ⟨%hκ, Hσ, He₂, Hefs⟩ - iframe %hκ Hσ - isplitl [He₂ Hcont] - · icases He₂ with ⟨IH, -⟩ - iapply IH $$ Hcont - · iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef !>⟨-, $⟩ + have Hred' : s.MaybeReducibleNoObs (K e, σ₁) := by grind [Language.Context.reducibleNoObs_fill] + iframe %Hred' + iintro !> %κ %e₂ %σ₂ %eₜ %HKstep + obtain ⟨e₂', rfl, Hprim⟩ := ctx.primStep_fill_inv he HKstep + imod Hstep $$ [//] with ⟨%hκ, Hσ, ⟨IH, -⟩, Hefs⟩ + iframe %hκ Hσ + isplitl [IH Hcont] + · iapply IH $$ Hcont + · iapply BI.BigSepL.bigSepL_mono_of_forall BI.and_elim_r $$ Hefs + next v => + rw [← (ToVal.coe_of_toVal_eq_some he)] + ispecialize Hcont $$ %v + iapply (fupd_wand_left (P := Ψ v)).trans fupd_twp $$ [$] · iintro %_ $ -private theorem fold_induction_right - (Ψ : CoPset → Expr → (Val → IProp GF) → IProp GF) - (s : Stuckness) (E : CoPset) (e : Expr) (Φ : Val → IProp GF) : - pre s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) E e Φ ⊢ WP e @ s ; E [{ Φ }] := by - rw [unfold.to_eq] - iintro Hpre - iapply pre_mono s (fun E e Φ => iprop(Ψ E e Φ ∧ WP e @ s ; E [{ Φ }])) $$ [] %E %e %Φ Hpre - iintro !> %E %e %Φ ⟨-, $⟩ - @[rocq_alias twp_bind_inv] theorem bind_inv (K : Expr → Expr) [ctx : Language.Context K] {s : Stuckness} {E : CoPset} {e : Expr} {Φ : Val → IProp GF} : @@ -357,62 +283,43 @@ theorem bind_inv (K : Expr → Expr) [ctx : Language.Context K] let Pred := fun (E : CoPset) (e' : Expr) (Φ : Val → IProp GF) => iprop% ∀ e, ⌜e' = K e⌝ -∗ TotalWp.totalWp s E e (fun v : Val => iprop(WP (K v) @ s ; E [{ Φ }])) - letI : NonExpansive (fun x : Internal.Args Expr Val GF => Pred x.1 x.2.1 x.2.2) := by - constructor - intro n ⟨EX, eX, ΦX⟩ ⟨EY, eY, ΦY⟩ ⟨hE, he, hΦ⟩ - change EX = EY at hE - change eX = eY at he - subst EY - subst eY - refine BI.forall_ne fun _ => ?_ - refine BI.wand_ne.ne .rfl ?_ - apply NonExpansive.ne - exact fun _ => NonExpansive.ne hΦ + letI : NonExpansive (fun x : Internal.Args Expr Val GF => Pred x.1 x.2.1 x.2.2) := + ⟨fun _ _ _ ⟨hE, he, hΦ⟩ => hE ▸ he ▸ BI.forall_ne fun _ => + BI.wand_ne.ne .rfl (NonExpansive.ne fun _ => NonExpansive.ne hΦ)⟩ iintro H iapply induction s Pred $$ H %e %rfl iintro !> %E %e' %Φ IH %e %heq - subst e' - rw [unfold.to_eq] + rw [heq, unfold.to_eq] cases he : toVal e with | some v => - ihave IHfold := fold_induction_right $$ IH - simp only [pre, he] - rw [← (ToVal.coe_of_toVal_eq_some he)] + ihave IHfold : iprop(WP (K e) @ s ; E [{ Φ }]) $$ [IH] + · rw [unfold.to_eq] + iapply pre_mono s (fun E e Φ => iprop(Pred E e Φ ∧ WP e @ s ; E [{ Φ }])) $$ [] %E %(K e) %Φ IH + iintro !> %E %e %Φ ⟨-, $⟩ + simp only [pre, ← ToVal.coe_of_toVal_eq_some he, toVal_coe] itrivial | none => simp only [pre, he, ctx.toVal_eq_none_fill he] iintro %σ₁ %ns %obs %nt Hσ imod IH $$ Hσ with ⟨%Hred, Hstep⟩ - imodintro - isplit - · ipureintro - cases s - · exact Language.Context.reducibleNoObs_fill_inv (K := K) he Hred - · trivial - · iintro %κ %e₂ %σ₂ %eₜ %Hprim - imod Hstep $$ %_ %_ %_ %_ %(ctx.primStep_fill Hprim) with ⟨$, $, He₂, Hefs⟩ - imodintro - isplitl [He₂] - · icases He₂ with ⟨IH₂, -⟩ - iapply IH₂ $$ %e₂ %rfl - · iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef ⟨-, $⟩ + have Hred' : s.MaybeReducibleNoObs (e, σ₁) := by grind [Language.Context.reducibleNoObs_fill_inv] + iframe %Hred' + iintro !> %κ %e₂ %σ₂ %eₜ %Hprim + imod Hstep $$ %_ %_ %_ %_ %(ctx.primStep_fill Hprim) with ⟨$, $, ⟨IH₂, -⟩, Hefs⟩ + isplitl [IH₂] + · iapply IH₂ $$ %e₂ %rfl + · iapply BI.BigSepL.bigSepL_mono_of_forall BI.and_elim_r $$ Hefs @[rocq_alias twp_mono] theorem mono {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} (H : ∀ v, Φ v ⊢ Ψ v) : - WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E [{ Ψ }] := by - iintro Hwp - iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ Hwp - iintro %v Hv - iapply H $$ [$] + WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E [{ Ψ }] := + strong_mono_with (Std.IsPreorder.le_refl _) LawfulSet.subset_refl fun v => entails_wand ((H v).trans fupd_intro) @[rocq_alias twp_stuck_mono] theorem stuck_mono {s₁ s₂ : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} (H : s₁ ≤ s₂) : - WP e @ s₁ ; E [{ Φ }] ⊢ WP e @ s₂ ; E [{ Φ }] := by - iintro Hwp - iapply strong_mono H LawfulSet.subset_refl $$ Hwp - iintro %v $ + WP e @ s₁ ; E [{ Φ }] ⊢ WP e @ s₂ ; E [{ Φ }] := + strong_mono_with H LawfulSet.subset_refl fun _ => BI.entails_wand fupd_intro @[rocq_alias twp_stuck_weaken] theorem stuck_weaken {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : @@ -422,99 +329,73 @@ theorem stuck_weaken {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : @[rocq_alias twp_mask_mono] theorem mask_mono {s : Stuckness} {E₁ E₂} {e : Expr} {Φ : Val → IProp GF} (H : E₁ ⊆ E₂) : - WP e @ s ; E₁ [{ Φ }] ⊢ WP e @ s ; E₂ [{ Φ }] := by - iintro Hwp - iapply strong_mono (Std.IsPreorder.le_refl _) H $$ Hwp - iintro %v $ - -@[rocq_alias twp_value_fupd] -theorem value_fupd {s : Stuckness} {E} {e : Expr} {v : Val} {Φ : Val → IProp GF} (h : e = v) : - WP e @ s ; E [{ Φ }] ⊣⊢ |={E}=> Φ v := by - simp [h, value_fupd'] + WP e @ s ; E₁ [{ Φ }] ⊢ WP e @ s ; E₂ [{ Φ }] := + strong_mono_with (Std.IsPreorder.le_refl _) H fun _ => BI.entails_wand fupd_intro @[rocq_alias twp_value'] theorem value' {s : Stuckness} {E} {v : Val} {Φ : Val → IProp GF} : - Φ v ⊢ WP (v : Expr) @ s ; E [{ Φ }] := by - simp [value_fupd'.to_eq, fupd_intro] + Φ v ⊢ WP (v : Expr) @ s ; E [{ Φ }] := fupd_intro.trans value_fupd'.mpr @[rocq_alias twp_value] theorem value {s : Stuckness} {E} {e : Expr} {v : Val} {Φ : Val → IProp GF} (h : e = v) : - Φ v ⊢ WP e @ s ; E [{ Φ }] := by - simp [h, value'] + Φ v ⊢ WP e @ s ; E [{ Φ }] := h ▸ value' @[rocq_alias twp_frame_l] theorem frame_l {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} {R : IProp GF} : - R ∗ WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E [{ v, R ∗ Φ v }] := by - iintro ⟨HR, Hwp⟩ - iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ Hwp - iintro %v $ // + R ∗ WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E [{ v, R ∗ Φ v }] := + (BI.sep_mono_left (BI.forall_intro fun _ => BI.wand_intro fupd_intro)).trans <| + BI.wand_elim_swap (BI.wand_entails (strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl)) @[rocq_alias twp_frame_r] theorem frame_r {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} {R : IProp GF} : - WP e @ s ; E [{ Φ }] ∗ R ⊢ WP e @ s ; E [{ v, Φ v ∗ R }] := by - rw [BI.sep_comm.to_eq] - refine frame_l.trans (mono fun v => BI.sep_comm.mp) + WP e @ s ; E [{ Φ }] ∗ R ⊢ WP e @ s ; E [{ v, Φ v ∗ R }] := + BI.sep_comm.mp.trans (frame_l.trans (mono fun _ => BI.sep_comm.mp)) @[rocq_alias twp_wand] theorem wand {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : WP e @ s ; E [{ Φ }] ⊢ - (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s ; E [{ Ψ }] := by - iintro Hwp H - iapply strong_mono (Std.IsPreorder.le_refl _) LawfulSet.subset_refl $$ Hwp - iintro %v Hv - imodintro - iapply H $$ Hv + (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s ; E [{ Ψ }] := + BI.wand_intro <| frame_r.trans <| mono fun v => (BI.sep_mono_right (BI.forall_elim v)).trans BI.wand_elim_right @[rocq_alias twp_wand_l] theorem wand_l {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : - (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E [{ Ψ }] := by - iintro ⟨H, Hwp⟩ - iapply wand $$ Hwp H + (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E [{ Ψ }] := + BI.wand_elim_swap wand @[rocq_alias twp_wand_r] theorem wand_r {s : Stuckness} {E} {e : Expr} {Φ Ψ : Val → IProp GF} : - WP e @ s ; E [{ Φ }] ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WP e @ s ; E [{ Ψ }] := by - iintro ⟨Hwp, H⟩ - iapply wand $$ Hwp H + WP e @ s ; E [{ Φ }] ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WP e @ s ; E [{ Ψ }] := + BI.wand_elim wand @[rocq_alias twp_frame_wand] theorem frame_wand {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} {R : IProp GF} : - R ⊢ (WP e @ s ; E [{ v, R -∗ Φ v }]) -∗ WP e @ s ; E [{ Φ }] := by - iintro HR Hwp - iapply wand $$ Hwp - iintro %v HΦ - iapply HΦ $$ HR + R ⊢ (WP e @ s ; E [{ v, R -∗ Φ v }]) -∗ WP e @ s ; E [{ Φ }] := + BI.wand_intro_left (frame_r.trans (mono fun _ => BI.wand_elim_left)) @[rocq_alias twp_wp] theorem to_wp {s : Stuckness} {E} {e : Expr} {Φ : Val → IProp GF} : WP e @ s ; E [{ Φ }] ⊢ WP e @ s ; E {{ Φ }} := by iloeb as IH generalizing %E %e %Φ - rw [wp_unfold.to_eq, unfold.to_eq] - unfold wp.pre pre + simp only [(wp_unfold (e := e)).to_eq, (unfold (e := e)).to_eq, wp.pre, pre] cases hval : toVal e case some v => iintro $ case none => iintro H %σ %ns %κ %κs %nt Hσ imod H $$ Hσ with ⟨%Hred, H⟩ - imodintro - isplit - · ipureintro - cases s - · exact Language.reducible_of_reducibleNoObs Hred - · trivial - · iintro %e₂ %σ₂ %eₜ %Hstep _ - iapply step_fupdN_intro Std.LawfulSet.empty_subset - rw [(BI.later_laterN _).to_eq] - iintro !> !> - imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with ⟨%⟨⟩, Hσ, He₂, Hefs⟩ - simp only [List.nil_append] - iframe Hσ - isplitl [He₂] - · iapply IH $$ He₂ - · iapply BI.BigSepL.bigSepL_impl $$ Hefs - iintro !> %k %ef %Hef !>Hef - iapply IH $$ Hef + have Hred' : s.MaybeReducible (e, σ) := by grind + iframe %Hred' + iintro !> %e₂ %σ₂ %eₜ %Hstep _ + iapply step_fupdN_intro Std.LawfulSet.empty_subset + iintro !> + imod H $$ %κ %e₂ %σ₂ %eₜ %Hstep with ⟨%⟨⟩, Hσ, He₂, Hefs⟩ + simp only [List.nil_append] + iframe Hσ + isplitl [He₂] + · iapply IH $$ He₂ + · iapply BI.BigSepL.bigSepL_impl $$ Hefs + iintro !> %k %ef %Hef !>Hef + iapply IH $$ Hef section ProofMode @@ -526,37 +407,24 @@ variable {Φ Ψ : Val → IProp GF} {P R : IProp GF} @[rocq_alias frame_twp] instance frameTwp {p : Bool} [H : ∀ v, FrameInstantiateExistDisabled p R (Φ v) (Ψ v)] : Frame p R (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Ψ }]) where - frame := by - refine frame_l.trans (mono fun v => ?_) - exact (H v).frame_instantiatiate_exist_disabled.frame + frame := frame_l.trans (mono fun v => (H v).frame_instantiatiate_exist_disabled.frame) -- Iris-Rocq reuses the module-qualified name `is_except_0_wp` here; that alias -- is already assigned to partial WP in Lean, so this instance is left unaliased. instance isExcept0Twp : IsExcept0 (WP e @ s ; E [{ Φ }]) where - is_except0 := - calc iprop(◇ _) - _ ⊢ ◇ |={E}=> _ := BI.except0_mono fupd_intro - _ ⊢ |={E}=> _ := BIFUpdate.except0 - _ ⊢ WP e @ s ; E [{ Φ }] := fupd_twp + is_except0 := (BI.except0_mono fupd_intro).trans (BIFUpdate.except0.trans fupd_twp) @[rocq_alias elim_modal_fupd_twp] instance (priority := default + 10) elimModalFupdTwp p : ElimModal True p io false iprop(|={E}=> P) P (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where - elim_modal := by - iintro %_ ⟨H, G⟩ - icases BI.intuitionisticallyIf_elim $$ H with H - iapply fupd_twp - imod H - iapply G $$ H + elim_modal _ := (sep_mono_left intuitionisticallyIf_elim).trans (fupd_wand_right.trans fupd_twp) @[rocq_alias elim_modal_bupd_twp] instance elimModalBupdTwp p : ElimModal True p io false iprop(|==> P) P (WP e @ s ; E [{ Φ }]) (WP e @ s ; E [{ Φ }]) where - elim_modal := by - rintro ⟨⟩ - refine BI.sep_mono (BI.intuitionisticallyIf_mono - (BIUpdateFUpdate.fupd_of_bupd (E := E))) .rfl |>.trans ?_ - apply elimModalFupdTwp _ |>.elim_modal ⟨⟩ (io := io) + elim_modal := fun ⟨⟩ => + (BI.sep_mono_left (BI.intuitionisticallyIf_mono (BIUpdateFUpdate.fupd_of_bupd (E := E)))).trans + (elimModalFupdTwp _ |>.elim_modal ⟨⟩ (io := io)) /-- The same diagnostic as partial WP: changing masks through a non-atomic TWP goal requires an explicit leading update. -/ @@ -572,13 +440,7 @@ instance elimModalFupdTwp_wrongMask : instance elimModalFupdTwpAtomic : ElimModal (Language.Atomic ↑s e) p io false iprop(|={E₁,E₂}=> P) P (WP e @ s ; E₁ [{ Φ }]) (WP e @ s ; E₂ [{ v, |={E₂,E₁}=> Φ v }]) where - elim_modal := by - rintro hatomic - iintro ⟨H, G⟩ - icases BI.intuitionisticallyIf_elim $$ H with H - iapply atomic - imod H - iapply G $$ H + elim_modal _ := (sep_mono_left intuitionisticallyIf_elim).trans (fupd_wand_right.trans atomic) @[rocq_alias elim_modal_fupd_twp_atomic_wrong_mask] instance elimModalFupdTwpAtomic_wrongMask : diff --git a/Iris/Iris/Tests/TotalWeakestPre.lean b/Iris/Iris/Tests/TotalWeakestPre.lean index fd55e7d24..25cd8710f 100644 --- a/Iris/Iris/Tests/TotalWeakestPre.lean +++ b/Iris/Iris/Tests/TotalWeakestPre.lean @@ -35,9 +35,7 @@ instance : ToVal Expr Val where | .val n => some n | _ => none ofVal := .val - coe_of_toVal_eq_some := by - intro e v h - cases e <;> simp_all + coe_of_toVal_eq_some := by grind toVal_coe := by simp inductive Step : Expr → State → List Obs → Expr → State → List Expr → Prop @@ -54,167 +52,86 @@ instance : PrimStep Expr State (List Obs) where | (e₁, σ₁), κ, (e₂, σ₂, efs) => Step e₁ σ₁ κ e₂ σ₂ efs instance : Language Expr State Obs Val where - val_stuck := by - intro e σ κ e' σ' efs H + val_stuck H := by cases H <;> rfl instance : LanguageNoFork Expr State Obs Val where - no_fork H := by cases H <;> rfl + no_fork H := by + cases H <;> rfl section Proofs noncomputable abbrev GF := Iris.Examples.ClosedProofs.GF -variable [InvGS_gen .hasNoLC GF] - -noncomputable local instance testIrisGS : IrisGS_gen .hasNoLC Expr GF where +noncomputable abbrev trivialIrisGS {Expr State Obs Val} + [Language Expr State Obs Val] [InvGS_gen .hasNoLC GF] : IrisGS_gen .hasNoLC Expr GF where toStateInterp := ⟨fun _ _ _ _ => iprop(True)⟩ numLatersPerStep := fun _ => 0 forkPost := fun _ => iprop(True) - stateInterp_mono := by - intro σ ns obs nt - iintro _ - imodintro - itrivial - -theorem tick_twp (n : Nat) : - ⊢ WP (Expr.tick n) @ Stuckness.NotStuck ; ⊤ [{ - fun v : Val => (iprop(⌜v = 0⌝) : IProp GF) }] := by - induction n with - | zero => - iapply twp_lift_pure_det_step_no_fork - (e₂ := Expr.val 0) - · intro σ - exact ⟨.val 0, σ, [], Step.tickZero σ⟩ - · intro σ₁ κ e₂' σ₂ efs H - cases H - exact ⟨rfl, rfl, rfl, rfl⟩ - · imodintro - iapply twp.value rfl - ipureintro - rfl - | succ n IH => - iapply twp_lift_pure_det_step_no_fork - (e₂ := Expr.tick n) - · intro σ - exact ⟨.tick n, σ, [], Step.tickSucc n σ⟩ - · intro σ₁ κ e₂' σ₂ efs H - cases H - exact ⟨rfl, rfl, rfl, rfl⟩ - · imodintro - iapply IH - -omit [InvGS_gen .hasNoLC GF] in -theorem tick_purePrimStep_succ (n : Nat) : - Expr.tick (n + 1) -ᵖ-> Expr.tick n where - safe σ := ⟨.tick n, σ, [], Step.tickSucc n σ⟩ - deterministic H := by - cases H - exact ⟨rfl, rfl, rfl, rfl⟩ + stateInterp_mono := fun _ _ _ _ => fupd_intro -omit [InvGS_gen .hasNoLC GF] in -theorem tick_purePrimStep_zero : - Expr.tick 0 -ᵖ-> Expr.val 0 where - safe σ := ⟨.val 0, σ, [], Step.tickZero σ⟩ - deterministic H := by - cases H - exact ⟨rfl, rfl, rfl, rfl⟩ - -omit [InvGS_gen .hasNoLC GF] in theorem tick_pureExec (n : Nat) : PureExec True (n + 1) (Expr.tick n) (Expr.val 0) where - pureExec _ := by - induction n with - | zero => - exact .once tick_purePrimStep_zero - | succ n IH => - exact .head (tick_purePrimStep_succ n) IH - -theorem tick_twp_via_pureExec (n : Nat) : - ⊢ WP (Expr.tick n) @ Stuckness.NotStuck ; ⊤ [{ - fun v : Val => (iprop(⌜v = 0⌝) : IProp GF) }] := by - iapply twp_pure_step (tick_pureExec n) trivial - iapply twp.value rfl - ipureintro - rfl - -theorem put_twp (n : Nat) : - ⊢ WP (Expr.put n) @ Stuckness.NotStuck ; ⊤ [{ - fun v : Val => (iprop(⌜v = n⌝) : IProp GF) }] := by + pureExec _ := Nat.rec (.once { + safe σ := ⟨.val 0, σ, [], Step.tickZero σ⟩ + deterministic | .tickZero _ => ⟨rfl, rfl, rfl, rfl⟩ }) + (fun n IH => .head { + safe σ := ⟨.tick n, σ, [], Step.tickSucc n σ⟩ + deterministic | .tickSucc _ _ => ⟨rfl, rfl, rfl, rfl⟩ } IH) n + +variable [InvGS_gen .hasNoLC GF] + +noncomputable local instance testIrisGS : IrisGS_gen .hasNoLC Expr GF := + trivialIrisGS (State := State) (Obs := Obs) (Val := Val) + +private noncomputable abbrev eqPost (n : Nat) : Val → IProp GF := fun v => iprop(⌜v = n⌝) +private abbrev zeroTwpSpec (e : Expr) : Prop := ⊢ WP e @ Stuckness.NotStuck ; ⊤ [{ eqPost 0 }] + +theorem tick_twp (n : Nat) : zeroTwpSpec (.tick n) := + (pure_intro rfl).trans (twp.value' (v := 0) (Φ := eqPost 0)) |>.trans (twp_pure_step (tick_pureExec n) trivial) + +theorem put_twp (n : Nat) : ⊢ WP (Expr.put n) @ Stuckness.NotStuck ; ⊤ [{ eqPost n }] := by iapply twp_lift_atomic_step_no_fork (e₁ := Expr.put n) rfl - iintro %σ %ns %obs %nt _ - imodintro + iintro %σ %ns %obs %nt _ !> isplit - · ipureintro - exact ⟨.val n, n, [], Step.put n σ⟩ - · iintro %κ %e₂ %σ₂ %efs %Hstep - cases Hstep - imodintro - isplit - · ipureintro - rfl - · isplit - · ipureintro - rfl - · isplit - · itrivial - · iexists n - isplit - · ipureintro - rfl - · ipureintro - rfl - -theorem branch_twp (n : Nat) : - ⊢ WP (Expr.branch n) @ Stuckness.NotStuck ; ⊤ [{ - fun v : Val => (iprop(⌜v = 0⌝) : IProp GF) }] := by + · exact BI.pure_intro ⟨.val n, n, [], Step.put n σ⟩ + · iintro %κ %e₂ %σ₂ %efs %⟨⟩ + exact (sep_intro_emp_valid_left (by itrivial) <| sep_intro_emp_valid_left (by itrivial) <| sep_intro_emp_valid_right + .rfl (exists_intro_trans n <| (pure_intro ⟨rfl, rfl⟩).trans pure_and.2)).trans fupd_intro + +theorem branch_twp (n : Nat) : zeroTwpSpec (.branch n) := by induction n with | zero => - iapply twp_lift_pure_det_step_no_fork - (e₂ := Expr.val 0) - · intro σ - exact ⟨.val 0, σ, [], Step.branchZero σ⟩ - · intro σ₁ κ e₂' σ₂ efs H - cases H - exact ⟨rfl, rfl, rfl, rfl⟩ - · imodintro - iapply twp.value rfl - ipureintro - rfl + exact (pure_intro rfl).trans (twp.value (Φ := eqPost 0) rfl) |>.trans fupd_intro |>.trans <| + twp_lift_pure_det_step_no_fork (e₂ := Expr.val 0) (fun σ => ⟨.val 0, σ, [], Step.branchZero σ⟩) + (fun _ _ _ _ _ (.branchZero _) => ⟨rfl, rfl, rfl, rfl⟩) | succ n IH => iapply twp_lift_step_no_fork (e₁ := Expr.branch (n + 1)) rfl iintro %σ %ns %obs %nt _ iapply fupd_mask_intro empty_subset iintro Hclose isplit - · ipureintro - exact ⟨.branch n, σ, [], Step.branchLeft n σ⟩ - · iintro %κ %e₂ %σ₂ %efs %Hstep - cases Hstep - · imod Hclose - imodintro - isplit - · ipureintro - rfl - · isplit - · ipureintro - rfl - · isplitl [] - · change ⊢ iprop(True) - itrivial - · iapply IH - · imod Hclose - imodintro - isplit - · ipureintro - rfl - · isplit - · ipureintro - rfl - · isplitl [] - · change ⊢ iprop(True) - itrivial - · iapply tick_twp n + · exact BI.pure_intro ⟨.branch n, σ, [], Step.branchLeft n σ⟩ + · iintro %κ %e₂ %σ₂ %efs %⟨⟩ + all_goals + imod Hclose with - + exact (BI.sep_intro_emp_valid_left (BI.pure_intro rfl) <| BI.sep_intro_emp_valid_left (BI.pure_intro rfl) <| + BI.sep_intro_emp_valid_right .rfl (by first | exact IH | exact tick_twp n)).trans fupd_intro + +omit [InvGS_gen .hasNoLC GF] in +private theorem stronglyNormalizing_of_twp {Expr State Obs Val} + [Language Expr State Obs Val] {e : Expr} {initialState : State} {Φ : Val → IProp GF} + (Hwp : ∀ [InvGS_gen .hasNoLC GF], + let _ : IrisGS_gen .hasNoLC Expr GF := + trivialIrisGS (State := State) (Obs := Obs) (Val := Val); + ⊢ WP e @ Stuckness.NotStuck ; ⊤ [{ Φ }]) : + StronglyNormalizing + (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) + ([e], initialState) := by + apply twp_total (hlc := .hasNoLC) (GF := GF) Stuckness.NotStuck e initialState Φ 0 0 + iintro %Hinv !> + iexists (fun _ _ _ _ => iprop(True)), (fun _ => 0), (fun _ => iprop(True)), fun _ _ _ _ => fupd_intro + exact BI.sep_intro_emp_valid_left BI.true_intro <| BI.wand_intro_left (BI.true_intro.trans Hwp) end Proofs @@ -249,11 +166,8 @@ example : twp.bind id example [inst : Language.IntoVal e v] : - P ∗ Φ v ⊢ WP e @ Stuckness.NotStuck ; ⊤ [{ w, P ∗ Φ w }] := by - iintro ⟨HP, HΦ⟩ - iframe HP - iapply twp.value $$ HΦ - exact inst.into_val.symm + P ∗ Φ v ⊢ WP e @ Stuckness.NotStuck ; ⊤ [{ w, P ∗ Φ w }] := + twp.value (Φ := fun w => iprop(P ∗ Φ w)) inst.into_val.symm /-- error: iframe: cannot frame R 0 -/ #guard_msgs in @@ -265,17 +179,13 @@ example (R : Nat → IProp GF) : example : (|={E}=> P) ∗ (P -∗ WP e @ Stuckness.NotStuck ; E [{ Φ }]) ⊢ - WP e @ Stuckness.NotStuck ; E [{ Φ }] := by - iintro ⟨HP, Hwp⟩ - imod HP - iapply Hwp $$ HP + WP e @ Stuckness.NotStuck ; E [{ Φ }] := + fupd_wand_right.trans twp.fupd_twp example : (|==> Q) ∗ (Q -∗ WP e @ Stuckness.NotStuck ; E [{ Φ }]) ⊢ - WP e @ Stuckness.NotStuck ; E [{ Φ }] := by - iintro ⟨HQ, Hwp⟩ - imod HQ - iapply Hwp $$ HQ + WP e @ Stuckness.NotStuck ; E [{ Φ }] := + bupd_wand_right.trans (BIUpdateFUpdate.fupd_of_bupd.trans twp.fupd_twp) end CoreRuleChecks @@ -285,30 +195,15 @@ open Iris.HeapLang variable [InvGS_gen .hasNoLC GF] -noncomputable local instance heapIrisGS : - IrisGS_gen .hasNoLC Iris.HeapLang.Exp GF where - toStateInterp := ⟨fun _ _ _ _ => iprop(True)⟩ - numLatersPerStep := fun _ => 0 - forkPost := fun _ => iprop(True) - stateInterp_mono := by - intro σ ns obs nt - iintro _ - imodintro - itrivial - -theorem heapLang_add_twp : - ⊢ WP hl(#1 + #2) @ Stuckness.NotStuck ; ⊤ [{ - fun v : Iris.HeapLang.Val => - (iprop(⌜v = hl_val(#3)⌝) : IProp GF) }] := by - iapply twp_lift_pure_det_base_step_no_fork (e₂ := hl(#3)) rfl - · intro σ - refine ⟨hl(#3), σ, [], ?_⟩ - constructor <;> rfl - · intro σ κ e₂' σ₂ eₜ Hstep - cases Hstep <;> simp_all [Iris.HeapLang.BinOp.eval] - · iapply twp.value rfl - ipureintro - rfl +noncomputable local instance heapIrisGS : IrisGS_gen .hasNoLC Iris.HeapLang.Exp GF := + trivialIrisGS (State := Iris.HeapLang.State) (Obs := Iris.HeapLang.Observation) + (Val := Iris.HeapLang.Val) + +private noncomputable abbrev addPost : Iris.HeapLang.Val → IProp GF := fun v => iprop(⌜v = hl_val(#3)⌝) + +theorem heapLang_add_twp : ⊢ WP hl(#1 + #2) @ Stuckness.NotStuck ; ⊤ [{ addPost }] := + (pure_intro rfl).trans (twp.value' (v := hl_val(#3)) (Φ := addPost)) |>.trans + (twp_pure_step Iris.HeapLang.instPureExecBinOp rfl) end HeapLangPureSmoke @@ -327,9 +222,7 @@ instance : ToVal Expr Val where | .done => some () | .fork => none ofVal _ := .done - coe_of_toVal_eq_some := by - intro e v h - cases e <;> simp_all + coe_of_toVal_eq_some := by grind toVal_coe := by simp inductive Step : Expr → State → List Obs → Expr → State → List Expr → Prop @@ -340,139 +233,53 @@ instance : PrimStep Expr State (List Obs) where | (e₁, σ₁), κ, (e₂, σ₂, efs) => Step e₁ σ₁ κ e₂ σ₂ efs instance : Language Expr State Obs Val where - val_stuck := by - intro e σ κ e' σ' efs H - cases H - rfl + val_stuck | .fork => rfl section variable [InvGS_gen .hasNoLC GF] -noncomputable local instance forkIrisGS : IrisGS_gen .hasNoLC Expr GF where - toStateInterp := ⟨fun _ _ _ _ => iprop(True)⟩ - numLatersPerStep := fun _ => 0 - forkPost := fun _ => iprop(True) - stateInterp_mono := by - intro σ ns obs nt - iintro _ - imodintro - itrivial +noncomputable local instance forkIrisGS : IrisGS_gen .hasNoLC Expr GF := + trivialIrisGS (State := State) (Obs := Obs) (Val := Val) theorem fork_twp : ⊢ WP Expr.fork @ Stuckness.NotStuck ; ⊤ [{ fun _ : Val => (iprop(True) : IProp GF) }] := by iapply twp_lift_atomic_step (e₁ := Expr.fork) rfl - iintro %σ %ns %obs %nt _ - imodintro + iintro %⟨⟩ %ns %obs %nt _ !> isplit - · ipureintro - cases σ - exact ⟨.done, (), [.done], Step.fork⟩ - · iintro %κ %e₂ %σ₂ %efs %Hstep - cases Hstep - imodintro - isplit - · ipureintro - rfl - · isplitl [] - · change ⊢ iprop(True) - itrivial - · isplitl [] - · iexists () - isplit - · ipureintro - rfl - · itrivial - · simp only [Algebra.BigOpL.bigOpL_cons, - Algebra.BigOpL.bigOpL_nil] - isplit - · iapply twp.value (v := ()) rfl - change ⊢ iprop(True) - itrivial - · itrivial + · exact BI.pure_intro ⟨.done, (), [.done], Step.fork⟩ + · iintro %κ %e₂ %σ₂ %efs %⟨⟩ + exact (sep_intro_emp_valid_left (PROP := IProp GF) (pure_intro rfl) <| sep_intro_emp_valid_right .rfl <| + sep_intro_emp_valid_left (exists_intro_trans () <| and_intro (pure_intro rfl) true_intro) + ((true_intro.trans (twp.value' (v := ()) (Φ := fun _ => iprop(True)))).trans sep_emp.mpr)).trans fupd_intro end theorem fork_stronglyNormalizing : StronglyNormalizing (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) - ([Expr.fork], ()) := by - apply twp_total (hlc := .hasNoLC) (GF := GF) - Stuckness.NotStuck Expr.fork () - (fun _ : Val => (iprop(True) : IProp GF)) 0 0 - iintro %Hinv - imodintro - iexists - (fun (_ : State) (_ : Nat) (_ : List Obs) (_ : Nat) => - (iprop(True) : IProp GF)), - (fun _ => 0), - (fun _ : Val => (iprop(True) : IProp GF)), - (fun _ _ _ _ => by - iintro _ - imodintro - itrivial) - dsimp only - isplitl [] - · itrivial - · iintro _ - iapply fork_twp + ([Expr.fork], ()) := + stronglyNormalizing_of_twp (fun [_] => fork_twp) end Forking theorem branch_stronglyNormalizing (n initialState : Nat) : StronglyNormalizing (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) - ([Expr.branch n], initialState) := by - apply twp_total (hlc := .hasNoLC) (GF := GF) - Stuckness.NotStuck (Expr.branch n) initialState - (fun v : Val => (iprop(⌜v = 0⌝) : IProp GF)) 0 0 - iintro %Hinv - imodintro - iexists - (fun (_ : State) (_ : Nat) (_ : List Obs) (_ : Nat) => - (iprop(True) : IProp GF)), - (fun _ => 0), - (fun _ : Val => (iprop(True) : IProp GF)), - (fun _ _ _ _ => by - iintro _ - imodintro - itrivial) - dsimp only - isplitl [] - · itrivial - · iintro _ - iapply branch_twp n + ([Expr.branch n], initialState) := + stronglyNormalizing_of_twp (fun [_] => branch_twp n) theorem branch_singleMachine_stronglyNormalizing (n initialState : Nat) : StronglyNormalizing (ExprErasedStep (Expr := Expr) (State := State) (Obs := Obs)) (Expr.branch n, initialState) := - stronglyNormalizing_expr_of_threadPool - (branch_stronglyNormalizing n initialState) + stronglyNormalizing_expr_of_threadPool (branch_stronglyNormalizing n initialState) theorem put_stronglyNormalizing (n initialState : Nat) : StronglyNormalizing (Language.ErasedStep (Expr := Expr) (State := State) (Obs := Obs)) - ([Expr.put n], initialState) := by - apply twp_total (hlc := .hasNoLC) (GF := GF) - Stuckness.NotStuck (Expr.put n) initialState - (fun v : Val => (iprop(⌜v = n⌝) : IProp GF)) 0 0 - iintro %Hinv - imodintro - iexists - (fun (_ : State) (_ : Nat) (_ : List Obs) (_ : Nat) => - (iprop(True) : IProp GF)), - (fun _ => 0), - (fun _ : Val => (iprop(True) : IProp GF)), - (fun _ _ _ _ => by - iintro _ - imodintro - itrivial) - dsimp only - isplitl [] - · itrivial - · iintro _ - iapply put_twp n + ([Expr.put n], initialState) := + stronglyNormalizing_of_twp (fun [_] => put_twp n) end Iris.Tests.TotalWeakestPre