From 286c6ce3669ec95403a90de1b7df8a6037599421 Mon Sep 17 00:00:00 2001 From: David Deng Date: Fri, 29 May 2026 14:37:00 -0700 Subject: [PATCH 01/12] CallElimCorrect: rewrite using small-step semantics Replaces the deprecated big-step `CallElimCorrect` proof with a small-step version, plus reusable infrastructure (`SubstSemantics`, `CoreTransformSemantics`) and shared-file helpers. The previous file carried a `DEPRECATED` notice flagging it for a small-step rewrite; this is that rewrite. ## Summary - `Strata/Transform/CallElimCorrect.lean`: 4597 -> 3814 LoC (-17%). Same top-level theorem name (`callElimStatementCorrect`); 6 public declarations preserved. - New `Strata/Transform/SubstSemantics.lean` (1721 LoC): generic substitution-semantics infrastructure (used by CallElim; reusable by future transforms). - New `Strata/Transform/CoreTransformSemantics.lean` (1151 LoC): reusable helpers for the Core small-step layer (`singleCmdToStmts`, `H_havocs`, `H_init`, `H_inits`, `genIdent*` correctness, fresh-name predicates, etc.). Net repository delta: +2,345 LoC (6,916 insertions / 4,571 deletions across 13 files), with the bulk being reusable infrastructure rather than CallElim-specific. Compared to the original 14,972-LoC big-step proof, this represents a -8,056 LoC reduction overall. ## Changes to shared files - `Strata/Languages/Core/StatementSemanticsProps.lean` (+159 LoC): 8 new helpers (`updatedStates_get_notin`, `readValues_get`, `evalExpressions_get`, `readValues_updatedStatesSame`, `evalExpressions_isDefined_flatMap`, `initStates_get_notin`, plus 2-/3-layer fall-through variants). - `Strata/DL/Util/ListUtils.lean` (+60 LoC net): adds `notin_append4`, `unzip_snd_length`, `disjoint_of_nodup_append_three`, `nodup_append_three_disjoint`; promotes existing helpers to `public`. - `@[expose]` attributes added where needed by the new module-system reductions: - `Strata/DL/Imperative/CmdSemantics.lean`: `isNotDefined`, `substStores`, `substDefined`, `substNodup`, `invStores`, `substSwap`, `WellFormedSemanticEvalVal`. - `Strata/DL/Lambda/LExprWF.lean`: `substFvar`, `substFvars`. - `Strata/DL/Util/StringGen.lean`: `StringGenState.gen`. - `Strata/Languages/Core/CoreGen.lean`: `CoreGenState.WF`, `CoreGenState.gen`. - `Strata/Languages/Core/Procedure.lean`: `Procedure.Spec.getCheckExprs`, `Procedure.Spec.updateCheckExprs`. - `Strata/Languages/Core/StatementSemantics.lean`: `updatedState`, `updatedStates'`, `updatedStates`, `WellFormedCoreEvalTwoState`. - `Strata/Transform/CoreTransform.lean`: ~17 generator/transform defs. - `Strata/Transform/CallElim.lean`: `callElimCmd`, plus an extracted `oldTyLookupCallElim` helper required for the proof to share auxiliary `match` definitions across two `do`-blocks. ## Testing Full repo build green (602 jobs); StrataTest green (617 jobs); zero warnings. --- Strata/DL/Imperative/CmdSemantics.lean | 14 +- Strata/DL/Lambda/LExprWF.lean | 4 +- Strata/DL/Util/ListUtils.lean | 71 +- Strata/DL/Util/StringGen.lean | 1 + Strata/Languages/Core/CoreGen.lean | 2 + Strata/Languages/Core/Procedure.lean | 2 + Strata/Languages/Core/StatementSemantics.lean | 4 + .../Core/StatementSemanticsProps.lean | 159 + Strata/Transform/CallElim.lean | 25 +- Strata/Transform/CallElimCorrect.lean | 8311 ++++++++--------- Strata/Transform/CoreTransform.lean | 22 + Strata/Transform/CoreTransformSemantics.lean | 1151 +++ Strata/Transform/SubstSemantics.lean | 1721 ++++ 13 files changed, 6916 insertions(+), 4571 deletions(-) create mode 100644 Strata/Transform/CoreTransformSemantics.lean create mode 100644 Strata/Transform/SubstSemantics.lean diff --git a/Strata/DL/Imperative/CmdSemantics.lean b/Strata/DL/Imperative/CmdSemantics.lean index a2da7a8607..2def6fd29f 100644 --- a/Strata/DL/Imperative/CmdSemantics.lean +++ b/Strata/DL/Imperative/CmdSemantics.lean @@ -47,7 +47,7 @@ when the command signals a failure. @[expose] def isDefined {P : PureExpr} (σ : SemanticStore P) (vs : List P.Ident) : Prop := ∀ v, v ∈ vs → (σ v).isSome = true -def isNotDefined {P : PureExpr} (σ : SemanticStore P) (vs : List P.Ident) : Prop := +@[expose] def isNotDefined {P : PureExpr} (σ : SemanticStore P) (vs : List P.Ident) : Prop := ∀ v, v ∈ vs → σ v = none -- Can make this more generic by supplying a predicate function @@ -138,26 +138,26 @@ theorem isNotDefinedApp' : /-! ### Store Substitution -/ /-- Substitution relation between stores. -/ -def substStores {P : PureExpr} (σ₁ σ₂ : SemanticStore P) (substs : List (P.Ident × P.Ident)) +@[expose] def substStores {P : PureExpr} (σ₁ σ₂ : SemanticStore P) (substs : List (P.Ident × P.Ident)) : Prop := ∀ k1 k2, (k1, k2) ∈ substs → σ₁ k1 = σ₂ k2 -def substDefined {P : PureExpr} (σ₁ σ₂ : SemanticStore P) (substs : List (P.Ident × P.Ident)) +@[expose] def substDefined {P : PureExpr} (σ₁ σ₂ : SemanticStore P) (substs : List (P.Ident × P.Ident)) : Prop := ∀ k1 k2, (k1, k2) ∈ substs → (σ₁ k1).isSome = true ∧ (σ₂ k2).isSome = true -def substNodup {P : PureExpr} (substs : List (P.Ident × P.Ident)) +@[expose] def substNodup {P : PureExpr} (substs : List (P.Ident × P.Ident)) : Prop := (substs.unzip.1 ++ substs.unzip.2).Nodup /-- a specialization of substitution, where the keys are the same -/ -def invStores {P : PureExpr} (σ₁ σ₂ : SemanticStore P) (vs : List P.Ident) +@[expose] def invStores {P : PureExpr} (σ₁ σ₂ : SemanticStore P) (vs : List P.Ident) : Prop := substStores σ₁ σ₂ $ vs.zip vs def invStoresExcept {P : PureExpr} (σ₁ σ₂ : SemanticStore P) (vs : List P.Ident) : Prop := ∀ (vs' : List P.Ident), vs'.Disjoint vs → invStores σ₁ σ₂ vs' -def substSwap {P : PureExpr} (substs : List (P.Ident × P.Ident)) +@[expose] def substSwap {P : PureExpr} (substs : List (P.Ident × P.Ident)) : List (P.Ident × P.Ident) := substs.map Prod.swap theorem substSwapId (substs : List (P.Ident × P.Ident)) : @@ -229,7 +229,7 @@ def WellFormedSemanticEvalBool {P : PureExpr} [HasBool P] [HasNot P] (δ σ e = some Imperative.HasBool.tt ↔ δ σ (Imperative.HasNot.not e) = (some HasBool.ff)) ∧ (δ σ e = some Imperative.HasBool.ff ↔ δ σ (Imperative.HasNot.not e) = (some HasBool.tt)) -def WellFormedSemanticEvalVal {P : PureExpr} [HasVal P] +@[expose] def WellFormedSemanticEvalVal {P : PureExpr} [HasVal P] (δ : SemanticEval P) : Prop := -- evaluator only evaluates to values (∀ v v' σ, δ σ v = some v' → HasVal.value v') ∧ diff --git a/Strata/DL/Lambda/LExprWF.lean b/Strata/DL/Lambda/LExprWF.lean index 8a8232b7f7..2c2c1f051c 100644 --- a/Strata/DL/Lambda/LExprWF.lean +++ b/Strata/DL/Lambda/LExprWF.lean @@ -326,7 +326,7 @@ Substitute `(.fvar x _)` in `e` with `to`. Does NOT lift de Bruijn indices in `t when going under binders - safe when `to` contains no bvars (e.g., substituting fvar→fvar). Use `substFvarLifting` when `to` contains bvars. -/ -def substFvar [BEq T.IDMeta] (e : LExpr ⟨T, GenericTy⟩) (fr : T.Identifier) (to : LExpr ⟨T, GenericTy⟩) +@[expose] def substFvar [BEq T.IDMeta] (e : LExpr ⟨T, GenericTy⟩) (fr : T.Identifier) (to : LExpr ⟨T, GenericTy⟩) : (LExpr ⟨T, GenericTy⟩) := match e with | .const _ _ => e | .bvar _ _ => e | .op _ _ _ => e @@ -367,7 +367,7 @@ in a single pass, avoiding variable capture between substitutions. Does NOT lift de Bruijn indices when going under binders. Safe only when all replacement expressions contain no bvars. -/ -def substFvars [BEq T.IDMeta] (e : LExpr ⟨T, GenericTy⟩) (sm : Map T.Identifier (LExpr ⟨T, GenericTy⟩)) +@[expose] def substFvars [BEq T.IDMeta] (e : LExpr ⟨T, GenericTy⟩) (sm : Map T.Identifier (LExpr ⟨T, GenericTy⟩)) : LExpr ⟨T, GenericTy⟩ := if sm.isEmpty then e else substFvarsAux e sm where diff --git a/Strata/DL/Util/ListUtils.lean b/Strata/DL/Util/ListUtils.lean index ae43c60aeb..0d74bf1d1a 100644 --- a/Strata/DL/Util/ListUtils.lean +++ b/Strata/DL/Util/ListUtils.lean @@ -91,7 +91,7 @@ theorem List.Forall_append : Forall P (a ++ b) ↔ Forall P a ∧ Forall P b := * `replace [1, 4, 2, 3, 3, 7] 5 6 = [1, 4, 2, 3, 3, 7]` Adapted from List.replace -/ -def List.replaceAll [BEq α] : List α → α → α → List α +@[expose] def List.replaceAll [BEq α] : List α → α → α → List α | [], _, _ => [] | a::as, b, c => match b == a with | true => c :: replaceAll as b c @@ -260,7 +260,7 @@ theorem List.Subset.subset_app_of_or_4 {l: List α}: l ⊆ l1 ∨ l ⊆ l2 ∨ l theorem List.Subset.assoc {l: List α}: l ⊆ l1 ++ l2 ++ l3 ↔ l ⊆ l1 ++ (l2 ++ l3) := by simp [Subset, List.Subset] -theorem List.replaceAll_app {α : Type} [DecidableEq α] {h h' : α} {as bs : List α}: +public theorem List.replaceAll_app {α : Type} [DecidableEq α] {h h' : α} {as bs : List α}: List.replaceAll as h h' ++ List.replaceAll bs h h' = List.replaceAll (as ++ bs) h h' := by induction as generalizing bs case nil => simp [List.replaceAll] @@ -278,7 +278,7 @@ theorem cons_removeAll [BEq α] {x : α} {xs ys : List α} : xs.removeAll ys := by simp [List.removeAll, List.filter_cons] -theorem List.app_removeAll {α : Type} [BEq α] {xs₁ xs₂ ys : List α}: +public theorem List.app_removeAll {α : Type} [BEq α] {xs₁ xs₂ ys : List α}: (xs₁ ++ xs₂).removeAll ys = (xs₁.removeAll ys) ++ (xs₂.removeAll ys) := by induction xs₁ <;> simp_all @@ -325,13 +325,13 @@ theorem List.removeAll_comm {α : Type} [BEq α] {xs₁ xs₂ ys : List α}: /-- From Mathlib4 https://github.com/leanprover-community/mathlib4/blob/e70dc4ede17dd5fcda9926c84268e0f270147cba/Mathlib/Data/List/Zip.lean#L32-L37 -/ @[simp] -theorem zip_swap : ∀ (l₁ : List α) (l₂ : List β), (List.zip l₁ l₂).map Prod.swap = List.zip l₂ l₁ +public theorem zip_swap : ∀ (l₁ : List α) (l₂ : List β), (List.zip l₁ l₂).map Prod.swap = List.zip l₂ l₁ | [], _ => List.zip_nil_right.symm | l₁, [] => by rw [List.zip_nil_right]; rfl | a :: l₁, b :: l₂ => by simp only [List.zip_cons_cons, List.map_cons, zip_swap l₁ l₂, Prod.swap_prod_mk] -theorem replaceAll_mem {α : Type u} [BEq α] [LawfulBEq α] {h h' k : α} {t: List α}: +public theorem replaceAll_mem {α : Type u} [BEq α] [LawfulBEq α] {h h' k : α} {t: List α}: k ∈ (t.replaceAll h h') → k ∈ t ∨ k = h' := by intros Hr induction t generalizing k h h' <;> simp [List.replaceAll] at * @@ -348,21 +348,21 @@ theorem replaceAll_mem {α : Type u} [BEq α] [LawfulBEq α] {h h' k : α} {t: L specialize ih hin cases ih <;> simp_all -theorem zip_self_eq : +public theorem zip_self_eq : (k1, k2) ∈ List.zip ks ks → k1 = k2 := by intros Hin induction ks <;> simp_all case cons h t ih => cases Hin <;> simp_all -theorem zip_self_eq' : +public theorem zip_self_eq' : k ∈ ks → (k, k) ∈ List.zip ks ks := by intros Hin induction ks <;> simp_all case cons h t ih => cases Hin <;> simp_all -theorem in_replaceAll_removeAll {α : Type u} [BEq α] [LawfulBEq α] {h h' k2 : α} {vs t: List α}: +public theorem in_replaceAll_removeAll {α : Type u} [BEq α] [LawfulBEq α] {h h' k2 : α} {vs t: List α}: k2 ∈ (vs.replaceAll h h').removeAll t → k2 = h' ∨ k2 ∈ vs.removeAll t := by intros H induction vs generalizing k2 <;> simp [List.removeAll, List.replaceAll] at * @@ -380,7 +380,7 @@ theorem in_replaceAll_removeAll {α : Type u} [BEq α] [LawfulBEq α] {h h' k2 : have Hor := replaceAll_mem Hin cases Hor <;> simp_all -theorem removeAll_cons {α : Type u} [BEq α] [LawfulBEq α] {k h : α} {vs t : List α} : +public theorem removeAll_cons {α : Type u} [BEq α] [LawfulBEq α] {k h : α} {vs t : List α} : k ≠ h → k ∈ List.removeAll vs t → k ∈ List.removeAll vs (h :: t) := by @@ -389,11 +389,11 @@ theorem removeAll_cons {α : Type u} [BEq α] [LawfulBEq α] {k h : α} {vs t : case cons h' t' ih => simp_all -theorem removeAll_sublist {α : Type u} [BEq α] [LawfulBEq α] (as bs : List α): +public theorem removeAll_sublist {α : Type u} [BEq α] [LawfulBEq α] (as bs : List α): (List.removeAll as bs).Sublist as := by induction as <;> simp [List.removeAll] -theorem replaceAll_not_mem {α : Type u} [BEq α] [LawfulBEq α] {h h' : α} {vs : List α}: +public theorem replaceAll_not_mem {α : Type u} [BEq α] [LawfulBEq α] {h h' : α} {vs : List α}: h ≠ h' → ¬ h ∈ (vs.replaceAll h h') := by intros Hne Hin @@ -507,3 +507,52 @@ theorem List.Forall_flatMap : intros Hfa have Hfa := List.Forall_append.mp Hfa exact ⟨Hfa.1, ih Hfa.2⟩ + +/-- Decompose a non-membership fact over a balanced 4-way append + `a ∉ (l₁ ++ l₂) ++ (l₃ ++ l₄)` into four leaf-level non-membership + facts. Used at the L4 (preVars) and L6 (postVars) `Hinv` sites in + `callElimStatementCorrect` to flatten the per-`removeAll` decomposition + cascades. -/ +public theorem List.notin_append4 + {α} {a : α} {l₁ l₂ l₃ l₄ : List α} + (Hnin : a ∉ (l₁ ++ l₂) ++ (l₃ ++ l₄)) : + a ∉ l₁ ∧ a ∉ l₂ ∧ a ∉ l₃ ∧ a ∉ l₄ := + ⟨fun h => Hnin (List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inl h)))), + fun h => Hnin (List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inr h)))), + fun h => Hnin (List.mem_append.mpr (Or.inr (List.mem_append.mpr (Or.inl h)))), + fun h => Hnin (List.mem_append.mpr (Or.inr (List.mem_append.mpr (Or.inr h))))⟩ + +/-- The length of `trips.unzip.snd` matches `trips.length`. Convenient + one-liner used to bridge `genXxxExprIdentsTrip_snd` shape facts to a + `triplen` length equation, instead of inlining the `simp + [List.unzip_eq_map]` rewrite at every length proof. -/ +public theorem List.unzip_snd_length {α β : Type _} (trips : List (α × β)) : + trips.unzip.snd.length = trips.length := by + simp [List.unzip_eq_map] + +/-- Pairwise disjointness between three concatenated lists, extracted + from `(a ++ b ++ c).Nodup`. Convenience re-packaging used downstream + to peel `cs'.generated`'s Nodup into per-segment disjointness. -/ +public theorem List.disjoint_of_nodup_append_three + {α} {a b c : List α} + (Hnd : (a ++ b ++ c).Nodup) : + a.Disjoint b ∧ a.Disjoint c ∧ b.Disjoint c := by + rw [List.append_assoc] at Hnd + have Hnd' := List.nodup_append.mp Hnd + have Hbc := List.nodup_append.mp Hnd'.2.1 + refine ⟨?_, ?_, ?_⟩ + · intro x hxa hxb + exact Hnd'.2.2 x hxa x (List.mem_append_left c hxb) rfl + · intro x hxa hxc + exact Hnd'.2.2 x hxa x (List.mem_append_right b hxc) rfl + · intro x hxb hxc + exact Hbc.2.2 x hxb x hxc rfl + +/-- Specialization of `disjoint_of_nodup_append_three` to extract the + three pairwise disjointness facts as a Forall-friendly tuple. -/ +public theorem List.nodup_append_three_disjoint + {α} {a b c : List α} + (Hnd : (a ++ b ++ c).Nodup) : + a.Disjoint b ∧ b.Disjoint c ∧ a.Disjoint c := + let ⟨h1, h2, h3⟩ := List.disjoint_of_nodup_append_three Hnd + ⟨h1, h3, h2⟩ diff --git a/Strata/DL/Util/StringGen.lean b/Strata/DL/Util/StringGen.lean index 214244eee1..697cac13a5 100644 --- a/Strata/DL/Util/StringGen.lean +++ b/Strata/DL/Util/StringGen.lean @@ -42,6 +42,7 @@ def StringGenState.emp : StringGenState := { cs := .emp, generated := [] } followed by an underscore (`_`), followed by a unique number given by its underlying counter `σ.cs`. -/ +@[expose] def StringGenState.gen (pf : String) (σ : StringGenState) : String × StringGenState := let (counter, cs) := Counter.genCounter σ.cs let newString : String := (pf ++ "_" ++ toString counter) diff --git a/Strata/Languages/Core/CoreGen.lean b/Strata/Languages/Core/CoreGen.lean index 5c0ce72381..1fd62d8bc6 100644 --- a/Strata/Languages/Core/CoreGen.lean +++ b/Strata/Languages/Core/CoreGen.lean @@ -28,6 +28,7 @@ structure CoreGenState where cs : StringGenState generated : List CoreIdent := [] +@[expose] def CoreGenState.WF (σ : CoreGenState) := StringGenState.WF σ.cs ∧ List.map (fun s => (⟨s, ()⟩ : CoreIdent)) σ.cs.generated.unzip.snd = σ.generated ∧ @@ -43,6 +44,7 @@ def CoreGenState.emp : CoreGenState := { cs := .emp, generated := [] } NOTE: we need to wrap the prefix into a CoreIdent in order to conform with the interface of UniqueLabelGen.gen TODO: Maybe use genIdent or genIdents? -/ +@[expose] def CoreGenState.gen (pf : CoreIdent) (σ : CoreGenState) : CoreIdent × CoreGenState := let (s, cs') := StringGenState.gen pf.name σ.cs diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 90b00cce92..01f4bc0032 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -262,11 +262,13 @@ def Procedure.Spec.eraseTypes (s : Procedure.Spec) : Procedure.Spec := postconditions := s.postconditions.map (fun (l, c) => (l, c.eraseTypes)) } +@[expose] def Procedure.Spec.getCheckExprs (conds : ListMap CoreLabel Procedure.Check) : List Expression.Expr := let checks := conds.values checks.map (fun c => c.expr) +@[expose] def Procedure.Spec.updateCheckExprs (es : List Expression.Expr) (conds : ListMap CoreLabel Procedure.Check) : ListMap CoreLabel Procedure.Check := diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 233cffd42d..4b9840dfce 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -163,6 +163,7 @@ inductive TouchVars : SemanticStore P → List P.Ident → SemanticStore P → P inductive Inits : SemanticStore P → SemanticStore P → Prop where | init : InitVars σ xs σ' → Inits σ σ' +@[expose] def updatedState (σ : SemanticStore P) (ident : P.Ident) @@ -172,6 +173,7 @@ def updatedState then some val else (σ k) +@[expose] def updatedStates' (σ : SemanticStore P) (idvals : List (P.Ident × P.Expr)) @@ -180,6 +182,7 @@ def updatedStates' | [] => σ | (ident, val) :: rest => updatedStates' (updatedState σ ident val) rest +@[expose] def updatedStates (σ : SemanticStore P) (idents : List P.Ident) @@ -193,6 +196,7 @@ def updatedStates -- https://dafny.org/latest/DafnyRef/DafnyRef#sec-two-state -- where this condition will be asserted at procedures utilizing those two-state functions -/ +@[expose] def WellFormedCoreEvalTwoState (δ : CoreEval) (σ₀ σ : CoreStore) : Prop := (∃ vs vs' σ₁, HavocVars σ₀ vs σ₁ ∧ InitVars σ₁ vs' σ) ∧ (∀ vs vs' σ₀ σ₁ σ, diff --git a/Strata/Languages/Core/StatementSemanticsProps.lean b/Strata/Languages/Core/StatementSemanticsProps.lean index 273ad23d60..23f372880b 100644 --- a/Strata/Languages/Core/StatementSemanticsProps.lean +++ b/Strata/Languages/Core/StatementSemanticsProps.lean @@ -1976,6 +1976,165 @@ theorem UpdatedStatesNotinSame : have HH := List.of_mem_zip Hin simp_all +/-- Helper: lookup of an unrelated key through `updatedStates` falls + through. -/ +theorem updatedStates_get_notin + {σ : CoreStore} {ks : List Expression.Ident} + {vs : List Expression.Expr} {k : Expression.Ident} + (Hkn : ¬ k ∈ ks) : + (updatedStates σ ks vs) k = σ k := by + induction ks generalizing σ vs with + | nil => + cases vs <;> simp [updatedStates, updatedStates'] + | cons t ts ih => + cases vs with + | nil => simp [updatedStates, updatedStates', List.zip] + | cons w ws => + have Hkt : k ≠ t := fun h => Hkn (h ▸ List.mem_cons_self) + have Hkts : ¬ k ∈ ts := fun h => Hkn (List.mem_cons_of_mem _ h) + have Hunfold : + updatedStates σ (t :: ts) (w :: ws) = + updatedStates (updatedState σ t w) ts ws := by + simp [updatedStates, updatedStates', List.zip, List.zipWith] + rw [Hunfold] + rw [ih (σ := updatedState σ t w) (vs := ws) Hkts] + simp [updatedState, Hkt] + +/-- 2-layer fall-through of `updatedStates_get_notin`. -/ +theorem updatedStates_2layer_get_notin + {σ : CoreStore} {ks₁ ks₂ : List Expression.Ident} + {vs₁ vs₂ : List Expression.Expr} {k : Expression.Ident} + (Hk1 : ¬ k ∈ ks₁) (Hk2 : ¬ k ∈ ks₂) : + (updatedStates (updatedStates σ ks₁ vs₁) ks₂ vs₂) k = σ k := by + rw [updatedStates_get_notin Hk2, updatedStates_get_notin Hk1] + +/-- 3-layer fall-through of `updatedStates_get_notin`. -/ +theorem updatedStates_3layer_get_notin + {σ : CoreStore} {ks₁ ks₂ ks₃ : List Expression.Ident} + {vs₁ vs₂ vs₃ : List Expression.Expr} {k : Expression.Ident} + (Hk1 : ¬ k ∈ ks₁) (Hk2 : ¬ k ∈ ks₂) (Hk3 : ¬ k ∈ ks₃) : + (updatedStates + (updatedStates + (updatedStates σ ks₁ vs₁) ks₂ vs₂) ks₃ vs₃) k = σ k := by + rw [updatedStates_get_notin Hk3, updatedStates_get_notin Hk2, + updatedStates_get_notin Hk1] + +/-- Positional projection of `ReadValues`: when `ReadValues σ ks vs` + holds and `i < ks.length` (= `vs.length`), `σ ks[i] = some vs[i]`. -/ +theorem readValues_get + {σ : CoreStore} {ks : List Expression.Ident} + {vs : List Expression.Expr} + (Hrd : ReadValues σ ks vs) {i : Nat} + {hi : i < ks.length} {hi' : i < vs.length} : + σ (ks[i]'hi) = some (vs[i]'hi') := by + induction Hrd generalizing i with + | read_none => + exact absurd hi (by simp) + | read_some Hsome Hrest ih => + cases i with + | zero => + simp only [List.getElem_cons_zero] + exact Hsome + | succ n => + simp only [List.getElem_cons_succ] + have hi_n : n < _ := Nat.lt_of_succ_lt_succ hi + have hi'_n : n < _ := Nat.lt_of_succ_lt_succ hi' + exact ih (hi := hi_n) (hi' := hi'_n) + +/-- Positional projection of `EvalExpressions`. -/ +theorem evalExpressions_get + {δ : CoreEval} {σ : CoreStore} + {es : List Expression.Expr} {vs : List Expression.Expr} + (Heval : EvalExpressions (P:=Expression) δ σ es vs) {i : Nat} + (hi : i < es.length) (hi' : i < vs.length) : + δ σ (List.get es ⟨i, hi⟩) = some (List.get vs ⟨i, hi'⟩) := by + induction Heval generalizing i with + | eval_none => + exact absurd hi (by simp) + | eval_some _ Hsome _ ih => + cases i with + | zero => + simp only [List.get] + exact Hsome + | succ n => + simp only [List.get] + have hi_n : n < _ := Nat.lt_of_succ_lt_succ hi + have hi'_n : n < _ := Nat.lt_of_succ_lt_succ hi' + exact ih hi_n hi'_n + +/-- `ReadValues (updatedStates σ ks vs) ks vs` whenever `ks.Nodup` and + lengths agree. -/ +theorem readValues_updatedStatesSame + {σ : CoreStore} {ks : List Expression.Ident} + {vs : List Expression.Expr} + (Hlen : ks.length = vs.length) + (Hnd : ks.Nodup) : + ReadValues (updatedStates σ ks vs) ks vs := by + induction ks generalizing σ vs with + | nil => + cases vs <;> simp_all + exact ReadValues.read_none + | cons k ks' ih => + cases vs with + | nil => simp at Hlen + | cons v vs' => + simp only [updatedStates, List.zip_cons_cons, updatedStates'] + have Hk_notin : ¬ k ∈ ks' := (List.nodup_cons.mp Hnd).1 + have Hnd' : ks'.Nodup := (List.nodup_cons.mp Hnd).2 + have Hlen' : ks'.length = vs'.length := by + simp at Hlen; exact Hlen + have Hk_lookup : (updatedStates' (updatedState σ k v) (ks'.zip vs')) k = some v := by + have Hfall : (updatedStates (updatedState σ k v) ks' vs') k = (updatedState σ k v) k := + updatedStates_get_notin (σ:=updatedState σ k v) (vs:=vs') Hk_notin + unfold updatedStates at Hfall + rw [Hfall] + simp [updatedState] + apply ReadValues.read_some Hk_lookup + have Hih := ih (σ := updatedState σ k v) Hlen' Hnd' + simp only [updatedStates] at Hih + exact Hih + +/-- Pointwise σ-definedness for the `flatMap getVars` of a list of + expressions, derived from `EvalExpressions.eval_some`. -/ +theorem evalExpressions_isDefined_flatMap + {δ : CoreEval} {σ : CoreStore} + {es : List Expression.Expr} {vs : List Expression.Expr} + (Heval : EvalExpressions (P:=Core.Expression) δ σ es vs) : + Imperative.isDefined σ + (List.flatMap (Imperative.HasVarsPure.getVars (P:=Expression)) es) := by + induction Heval with + | eval_none => + intro v Hv + simp at Hv + | eval_some Hdef _ _ Hrec_isdef => + intro v Hv + rw [List.flatMap_cons] at Hv + rcases List.mem_append.mp Hv with Hin | Hin + · exact Hdef v Hin + · exact Hrec_isdef v Hin + +/-- For any `v ∉ ks`, `InitStates σ ks vs σ'` leaves `σ' v = σ v`. -/ +theorem initStates_get_notin + {P : Imperative.PureExpr} + {σ σ' : Imperative.SemanticStore P} + {ks : List P.Ident} {vs : List P.Expr} {v : P.Ident} + (Hinit : InitStates σ ks vs σ') + (Hnin : v ∉ ks) : + σ' v = σ v := by + induction Hinit with + | init_none => rfl + | @init_some σ x e σ_step xs ys σ'' Hstep Hinits ih => + have Hvx : x ≠ v := fun heq => + Hnin (heq ▸ List.mem_cons_self) + have Hnin_tail : v ∉ xs := fun hin => + Hnin (List.mem_cons_of_mem _ hin) + have Hstep_eq : σ_step v = σ v := by + cases Hstep with + | init _ _ Heq => + exact Heq v Hvx + have Hih := ih Hnin_tail + rw [Hih, Hstep_eq] + theorem InvStoresExceptUpdatedSame : invStoresExcept σ σ' ks → ks'.length = vs'.length → diff --git a/Strata/Transform/CallElim.lean b/Strata/Transform/CallElim.lean index 8eb3a07262..d2514b0003 100644 --- a/Strata/Transform/CallElim.lean +++ b/Strata/Transform/CallElim.lean @@ -29,10 +29,30 @@ def callElimAssertPrefix : String := "callElimAssert_" /-- Label prefix for call-elimination assume statements. -/ def callElimAssumePrefix : String := "callElimAssume_" +/-- The lookup body used inside `callElimCmd` to convert each `oldVar` + identifier to its (forall-closed) type via + `proc.header.inputs.find?`. + + Factoring this lookup out as a named definition is what makes the + correctness proof in `CallElimCorrect.callElimCmd_call_eq` go through: + when the inner `match` is inlined into two distinct `do`-blocks, + Lean compiles each occurrence to a *different* private auxiliary + (e.g., `match_1` vs `match_3`), and the resulting terms are no + longer syntactically rewriteable. Sharing the same definition here + keeps both occurrences alpha-equivalent. -/ +@[expose] +def oldTyLookupCallElim (proc : Procedure) (id : Expression.Ident) + : CoreTransformM Lambda.LTy := do + match proc.header.inputs.find? id with + | some ty => pure (Lambda.LTy.forAll [] ty) + | none => throw (Strata.DiagnosticModel.fromFormat + f!"failed to find type for {Std.format id}") + /-- The main call elimination transformation algorithm on a single command. The returned result is a sequence of statements -/ +@[expose] def callElimCmd (cmd: Command) : CoreTransformM (Option (List Statement)) := do match cmd with @@ -68,10 +88,7 @@ def callElimCmd (cmd: Command) -- Generate fresh variables for "old g" (one per modified variable in lhs). -- For input/output parameters, look up types from the callee's inputs. let genOldIdents ← genOldExprIdents oldVars - let oldTys ← oldVars.mapM fun id => do - match proc.header.inputs.find? id with - | some ty => pure (Lambda.LTy.forAll [] ty) - | none => throw (Strata.DiagnosticModel.fromFormat f!"failed to find type for {Std.format id}") + let oldTys ← oldVars.mapM (oldTyLookupCallElim proc) let oldTripsRaw := (genOldIdents.zip oldTys).zip oldVars let oldGVars := oldVars.map (fun g => CoreIdent.mkOld g.name) let oldTrips := oldTripsRaw.zip oldGVars |>.map fun (((fresh, ty), _orig), oldG) => diff --git a/Strata/Transform/CallElimCorrect.lean b/Strata/Transform/CallElimCorrect.lean index 5b7c165ca7..7266890cb4 100644 --- a/Strata/Transform/CallElimCorrect.lean +++ b/Strata/Transform/CallElimCorrect.lean @@ -18,18 +18,16 @@ public import Strata.Transform.CallElim public import Strata.DL.Imperative.CmdSemantics public import Strata.Languages.Core.StatementSemantics import Strata.Languages.Core.StatementSemanticsProps +public import Strata.Transform.SubstSemantics +import Strata.Transform.CoreTransformSemantics import Strata.DL.Util.ListUtils +public import Strata.DL.Util.String -/-! # Call Elimination Correctness Proof (DEPRECATED) - - We are deprecating this proof because it relies on the old big-step semantics for - `Stmt`. This proof will be re-done with a new small-step semantics in the near - future. +/-! # Call Elimination Correctness Proof This file contains the main proof that the call elimination transformation is - semantics preserving (see `callElimStatementCorrect`). - Additionally, `callElimBlockNoExcept` shows that the call elimination - transformation always succeeds on well-formed statements. + semantics preserving (see `callElimStatementCorrect`), formulated against the + small-step `Stmt` semantics in `Strata.Languages.Core.StatementSemanticsProps`. -/ namespace CallElimCorrect @@ -39,4558 +37,3777 @@ public section -- inidividual lemmas -theorem createHavocsApp : -createHavocs (a ++ b) md = createHavocs a md ++ createHavocs b md := by -simp [createHavocs] - -theorem createFvarsApp : +private theorem createFvarsApp : createFvars (a ++ b) = createFvars a ++ createFvars b := by simp [createFvars] -theorem createFvarsLength : +private theorem createFvarsLength : (createFvars ls).length = ls.length := by induction ls <;> simp [createFvars] -/- --- Step 1. A theorem stating that given a well-formed program, call-elim will return no exception -theorem callElimBlockNoExcept : - ∀ (st : Core.Statement) - (p : Core.Program), - WF.WFStatementsProp p [st] → - ∃ sts, Except.ok sts = ((run [st] (CallElim.callElimStmts · p))) - -- NOTE: the generated variables will not be local, but temp. So it will not be well-formed - -- ∧ WF.WFStatementsProp p sts - := by - intros st p wf - simp [Transform.run, runStmts, CallElim.callElimStmts, CallElim.callElimCmd] - cases st with - | block l b md => exists [.block l b md] - | ite cd tb eb md => exists [.ite cd tb eb md] - | exit l b => exists [.exit l b] - | loop g m i b md => exists [.loop g m i b md] - | funcDecl f md => exists [.funcDecl f md] - | cmd c => - cases c with - | cmd c' => exists [Imperative.Stmt.cmd (CmdExt.cmd c')] - | call lhs procName args md => - split - . -- call case - next heq => - cases heq - next st => - sorry - /- - simp only [] -- reduce match - split <;> - simp only [StateT.run, bind, ExceptT.bind, ExceptT.mk, StateT.bind, genArgExprIdentsTrip, ne_eq, liftM, - monadLift, MonadLift.monadLift, ExceptT.lift, Functor.map, List.unzip_snd, ite_not, ExceptT.bindCont, ExceptT.map, - genOldExprIdentsTrip] - . split - next res a s heq1 => - split - . -- succeeded, prove it is well-formed - simp [StateT.bind, pure, Functor.map, ExceptT.mk, genOutExprIdentsTrip, liftM, monadLift, - MonadLift.monadLift, ExceptT.lift, bind, ExceptT.bind, ExceptT.bindCont, StateT.bind] - split at heq1 <;> try cases heq1 - . next res' a' s' heq2 => - split - split <;> simp only [bind, StateT.bind, StateT.pure] - . split - sorry - /- - split <;> simp [pure, StateT.pure, Except.ok.injEq] - -- old expression returns error, contradiction by well-formedness - next ss _ _ _ _ s x e heq1 => - split at heq1 <;> simp_all - next a' s' hif heq' => - cases heq' <;> simp_all - simp [bind, ExceptT.bindCont, StateT.bind] at heq1 - split at heq1 <;> simp_all - split at heq1 - . simp [ExceptT.pure, pure, ExceptT.mk, StateT.pure] at heq1 - cases heq1 - . next s x e heq => - generalize Heq : (List.filter (isGlobalVar p) - (List.flatMap OldExpressions.extractOldExprVars - (OldExpressions.normalizeOldExprs - (List.map Procedure.Check.expr res'.spec.postconditions.values))).eraseDups) - = eq at * - have Hgen := @getIdentTys!_no_throw p eq (List.mapM.loop genOldExprIdent eq [] ss).snd ?_ - simp [runWith, StateT.run] at Hgen - . cases Hgen with - | intro tys Hgen => - simp_all - . simp [← Heq, isGlobalVar] at * - -/ - . -- output length not equal, contradiction - next x e heq1 => - split at heq1 - . next x e heq1' => - simp [StateT.bind, StateT.map, pure, ExceptT.pure, ExceptT.bindCont, ExceptT.mk] at heq1 - cases heq1 - . -- lhs length not equal to outputs length - next Hne => - cases wf with - | mk df al ol => - exfalso - apply Hne - simp [Option.isSome] at df - unfold CoreIdent.unres at * - split at df <;> simp_all - apply Hne - simp [← ol, Lambda.LMonoTySignature.toTrivialLTy] - . -- failed to get type for arguments, contradiction - split at heq1 - . next x e heq1' => - simp [StateT.bind, StateT.map, pure, ExceptT.pure, ExceptT.bindCont, ExceptT.mk] at heq1 - cases heq1 - . -- arg length not equal to inputs length - next Hne => - cases wf with - | mk df al ol => - exfalso - apply Hne - simp [Option.isSome] at df - unfold CoreIdent.unres at * - split at df <;> simp_all - apply Hne - simp [← al, Lambda.LMonoTySignature.toTrivialLTy] - . exfalso - next proc Hfalse => - simp [Program.Procedure.find?] at Hfalse - split at Hfalse <;> simp_all - next heq' => - cases wf with - | intro wf => - cases wf with - | mk wf => - simp [Program.Procedure.find?] at wf - unfold CoreIdent.unres at * - split at wf <;> simp_all - -/ - . -- other case - grind - -theorem postconditions_subst_unwrap : - substPost ∈ - OldExpressions.substsOldExprs (createOldVarsSubst oldTrips) - (OldExpressions.normalizeOldExprs ps) → - ∃ post, post ∈ ps ∧ substPost = (OldExpressions.substsOldExpr (createOldVarsSubst oldTrips) - (OldExpressions.normalizeOldExpr post)) := by - intros H - induction ps - case nil => - simp [OldExpressions.normalizeOldExprs, OldExpressions.substsOldExprs] at H - case cons h t ih => - simp [OldExpressions.normalizeOldExprs, OldExpressions.substsOldExprs] at H - cases H with - | inl Hin => - simp_all - | inr Hin => - simp - cases Hin with - | intro x Hin => - right - refine ⟨x, Hin.1, ?_⟩ - symm - exact Hin.2 - -theorem prepostconditions_unwrap {ps : List (CoreLabel × Procedure.Check)} : -post ∈ List.map Procedure.Check.expr (ListMap.values ps) → -∃ label attr md, (label, { expr := post, attr := attr, md := md : Procedure.Check }) ∈ ps := by - intros H - induction ps - case nil => - cases H - case cons h t ih => - simp at H - cases H with - | intro c Hc - simp [ListMap.values] at Hc - cases Hc.1 with - | inl Hin => - simp_all - refine ⟨h.1, c.attr, c.md, ?_⟩ - left - simp [← Hc, Hin] - | inr Hin => - simp - specialize ih ?_ - . simp [← Hc.2] - refine ⟨c, ⟨Hin, rfl⟩⟩ - . cases ih with - | intro label ih => grind - -theorem updatedStateIsDefinedMono : - (σ k').isSome = true → - (updatedState σ k v k').isSome = true := by - intros Hsome - simp [updatedState] - by_cases Heq : (k' = k) <;> simp [Heq] - case neg => assumption - -theorem EvalExpressionUpdatedState {δ : CoreEval}: -Imperative.WellFormedSemanticEvalVar δ → -Core.WellFormedCoreEvalCong δ → -Imperative.WellFormedSemanticEvalVal δ → -¬ k ∈ (Imperative.HasVarsPure.getVars e) → -δ σ e = some v' → -δ (updatedState σ k v) e = some v' := by - intros Hwfv Hwfc Hwfvl Hnin Hsome - simp [Imperative.WellFormedSemanticEvalVar, Imperative.HasFvar.getFvar] at Hwfv - simp [Imperative.WellFormedSemanticEvalVal] at Hwfvl - have Hval := Hwfvl.2 - simp [← Hsome] at * - induction e <;> simp [Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - case const c | op o ty | bvar b => - rw [Hval]; rw [Hval]; constructor; constructor - case fvar m n ty => - simp [Hwfv] - simp [updatedState] - grind - case abs m ty e ih => - apply ((Hwfc.1 (updatedState σ k v) σ)) - grind - case quant m kk ty tr e trih eih => - apply Hwfc.quantcongr <;> grind - case app m fn e fnih eih => - apply Hwfc.appcongr <;> grind - case ite m c t e cih tih eih => - apply Hwfc.itecongr <;> grind - case eq m e1 e2 e1ih e2ih => - apply Hwfc.eqcongr <;> grind - -theorem EvalExpressionsUpdatedState {δ : CoreEval} : - Imperative.WellFormedSemanticEvalVar δ → - Core.WellFormedCoreEvalCong δ → - Imperative.WellFormedSemanticEvalVal δ → - ¬ k ∈ es.flatMap Imperative.HasVarsPure.getVars → - EvalExpressions (P:=Core.Expression) δ σ es vs → - EvalExpressions (P:=Core.Expression) δ (updatedState σ k v) es vs := by - intros Hwfv Hwfc Hwfvl Hnin Heval - have Hlen := EvalExpressionsLength Heval - induction es generalizing vs σ - case nil => - have Hnil := List.eq_nil_of_length_eq_zero (Eq.symm Hlen) - simp [Hnil] - constructor - case cons h t ih => - cases vs - . cases Heval - . case cons h' t' => - rcases Heval - case eval_some Hdef Heval Hevals => - constructor - . exact updatedStateDefMonotone Hdef - . apply EvalExpressionUpdatedState <;> simp_all - . apply ih <;> simp_all - -theorem EvalExpressionUpdatedStates {δ : CoreEval} : - Imperative.WellFormedSemanticEvalVar δ → - Core.WellFormedCoreEvalCong δ → - Imperative.WellFormedSemanticEvalVal δ → - ks'.length = vs'.length → - ks'.Nodup → - ks'.Disjoint (Imperative.HasVarsPure.getVars e) → - δ σ e = some v → - δ (updatedStates σ ks' vs') e = some v := by - intros Hwfv Hwfc Hwfvl Hlen Hnd Hnin Heval - induction ks' generalizing vs' σ - case nil => - have Hnil := List.eq_nil_of_length_eq_zero (Eq.symm Hlen) - simp [Hnil] - simp [updatedStates, updatedStates'] - assumption - case cons h t ih => - cases vs' - . simp_all - . case cons h' t' => - simp [updatedStates, updatedStates'] - rw [← updatedStateComm'] - apply EvalExpressionUpdatedState <;> try assumption - . intros Hin - apply Hnin _ Hin - simp_all - . apply ih <;> simp_all - apply List.Disjoint.mono_left _ Hnin - simp_all - . rw [List.unzip_zip] <;> grind - -theorem EvalExpressionsUpdatedStates {δ : CoreEval} : - Imperative.WellFormedSemanticEvalVar δ → - Core.WellFormedCoreEvalCong δ → - Imperative.WellFormedSemanticEvalVal δ → - ks'.length = vs'.length → - ks'.Nodup → - ks'.Disjoint (es.flatMap Imperative.HasVarsPure.getVars) → - EvalExpressions (P:=Core.Expression) δ σ es vs → - EvalExpressions (P:=Core.Expression) δ (updatedStates σ ks' vs') es vs := by - intros Hwfv Hwfc Hwfvl Hlen Hnd Hnin Heval - have Hlen := EvalExpressionsLength Heval - induction ks' generalizing vs' σ - case nil => - have Hnil := List.eq_nil_of_length_eq_zero (Eq.symm Hlen) - simp [Hnil] - simp [updatedStates, updatedStates'] - assumption - case cons h t ih => - cases vs' - . simp_all - . case cons h' t' => - simp [updatedStates, updatedStates'] - rw [← updatedStateComm'] - apply EvalExpressionsUpdatedState <;> try assumption - . intros Hin - apply Hnin _ Hin - simp_all - . apply ih <;> simp_all - apply List.Disjoint.mono_left _ Hnin - simp_all - . rw [List.unzip_zip] <;> grind - -theorem ReadValueUpdatedState : - x ≠ k → - σ x = some v' → - updatedState σ k v x = some v' := by - intros Hne Hsome - simp [updatedState, Hne] <;> simp_all - -theorem ReadValueUpdatedStates : - ¬ x ∈ ks → - σ x = some v' → - ks.length = vs.length → - updatedStates σ ks vs x = some v' := by - intros Hne Hsome Hlen - induction ks generalizing σ vs - case nil => - cases vs <;> simp_all - simp [updatedStates, updatedStates'] - assumption - case cons h t ih => - cases vs - case nil => simp_all - case cons h' t' => - simp [updatedStates, updatedStates'] - apply ih <;> simp_all - simp [updatedState] - simp_all - -theorem ReadValuesUpdatedState : - ¬ k ∈ ks → - ReadValues σ ks vs → - ReadValues (updatedState σ k v) ks vs := by - intros Hin Hrd - induction Hrd - case read_none => - apply ReadValues.read_none - case read_some xs' vs' x v' Hsome Hrd Hrd2 => - constructor <;> try assumption - apply ReadValueUpdatedState <;> simp_all - apply Ne.symm Hin.1 - apply Hrd2 <;> simp_all - -theorem ReadValuesUpdatedStates : - ks'.length = vs'.length → - ks'.Disjoint ks → - ReadValues σ ks vs → - ReadValues (updatedStates σ ks' vs') ks vs := by - intros Hlen Hin Hrd - induction ks generalizing vs - case nil => - cases Hrd - constructor - case cons h t ih => - cases vs with +/-- Contradiction: `σ k` cannot simultaneously be `isSome` and `none`. -/ +private theorem σ_some_contradiction {α β} {σ : β → Option α} {k : β} + (Hsome : (σ k).isSome) (Hnone : σ k = none) : False := by + rw [Hnone] at Hsome; simp at Hsome + +/-- A defined key cannot lie in an `isNotDefined` list. -/ +private theorem notin_of_isSome_isNotDefined {P : Imperative.PureExpr} + {σ : Imperative.SemanticStore P} {k : P.Ident} {ks : List P.Ident} + (Hsome : (σ k).isSome) (Hndef : Imperative.isNotDefined σ ks) : k ∉ ks := + fun h => σ_some_contradiction Hsome (Hndef k h) + +/-- Build `substDefined σ σ' ((a₁ ++ b₁).zip (a₂ ++ b₂))` from per-half + `isDefined` facts. -/ +private theorem substDefined_of_app + {σ σ' : CoreStore} {a₁ b₁ a₂ b₂ : List Expression.Ident} + (Hσ_a : Imperative.isDefined σ a₁) (Hσ_b : Imperative.isDefined σ b₁) + (Hσ'_a : Imperative.isDefined σ' a₂) (Hσ'_b : Imperative.isDefined σ' b₂) : + Imperative.substDefined σ σ' ((a₁ ++ b₁).zip (a₂ ++ b₂)) := by + intro k1 k2 Hkin + have Hmem := List.of_mem_zip Hkin + exact ⟨(List.mem_append.mp Hmem.1).elim (Hσ_a _) (Hσ_b _), + (List.mem_append.mp Hmem.2).elim (Hσ'_a _) (Hσ'_b _)⟩ + +/-- Decompose `(ks.zip ks').get n = (k1, k2)` into per-component equalities, + given explicit bounds for each list. -/ +private theorem zip_pair_split {α β} {ks : List α} {ks' : List β} + {n : Fin (ks.zip ks').length} {k1 : α} {k2 : β} + (hn : n.val < ks.length) (hn' : n.val < ks'.length) + (heq : (ks.zip ks').get n = (k1, k2)) : + k1 = ks[n.val]'hn ∧ k2 = ks'[n.val]'hn' := by + rw [show (ks.zip ks').get n = (ks.zip ks')[n.val]'n.isLt from rfl, + List.getElem_zip] at heq + exact ⟨((Prod.mk.injEq _ _ _ _).mp heq.symm).1, + ((Prod.mk.injEq _ _ _ _).mp heq.symm).2⟩ + +/-- Decompose `(a ++ b ++ c).Nodup` into its three component-Nodups and three + pairwise disjointnesses (in the local `List.Disjoint` form: `a → b → False`). + Repackages `List.nodup_append` and `List.disjoint_of_nodup_append_three`. -/ +private theorem nodup_3_decompose {α} {a b c : List α} + (Hnd : (a ++ b ++ c).Nodup) : + a.Nodup ∧ b.Nodup ∧ c.Nodup ∧ + a.Disjoint b ∧ a.Disjoint c ∧ b.Disjoint c := + let Hsplit := List.nodup_append.mp Hnd + let Hab := List.nodup_append.mp Hsplit.1 + let ⟨Hd_ab, Hd_ac, Hd_bc⟩ := List.disjoint_of_nodup_append_three Hnd + ⟨Hab.1, Hab.2.1, Hsplit.2.1, Hd_ab, Hd_ac, Hd_bc⟩ + +/-- Build `x ∉ a ++ b ++ c` from per-list non-membership. -/ +private theorem notin_3_append_of {α} [DecidableEq α] {a b c : List α} {x : α} + (h₁ : x ∉ a) (h₂ : x ∉ b) (h₃ : x ∉ c) : x ∉ a ++ b ++ c := by + simp only [List.mem_append, not_or]; exact ⟨⟨h₁, h₂⟩, h₃⟩ + +/-- `Map.find?_append` "some" branch packaged: if a key resolves to `some v` + in `l₁` and to `some w` in `l₁ ++ l₂`, then `v = w`. -/ +private theorem find?_append_some_eq {α β} [DecidableEq α] + {l₁ l₂ : List (α × β)} {k : α} {v w : β} + (hfind : Map.find? l₁ k = some v) + (Hf : Map.find? (l₁ ++ l₂) k = some w) : v = w := by + have HH := Map.find?_append l₁ l₂ k + rw [hfind] at HH + exact Option.some_inj.mp (HH.symm.trans Hf) + +/-- `Map.find?_append` "none" branch packaged: if a key misses in `l₁` but + `Map.find? (l₁ ++ l₂) k = some w`, then `Map.find? l₂ k = some w`. -/ +private theorem find?_append_none_elim {α β} [DecidableEq α] + {l₁ l₂ : List (α × β)} {k : α} {w : β} + (hfind : Map.find? l₁ k = none) + (Hf : Map.find? (l₁ ++ l₂) k = some w) : Map.find? l₂ k = some w := by + have HH := Map.find?_append l₁ l₂ k + rw [hfind] at HH + exact HH.symm.trans Hf + +/-- Shared `oldVars` filter used at multiple sites in `callElimCmd_call_eq` + and `callElimStatementCorrect`: those `CallArg.getLhs args` parameters + that (i) appear in both `proc.header.inputs` and `proc.header.outputs`, + and (ii) are referenced as `old _` in `proc.spec.postconditions`. + Marked `@[reducible]` so generalize/simp can match the inline form. -/ +@[reducible] private def callElim_oldVars (proc : Procedure) + (args : List (CallArg Expression)) : List Expression.Ident := + List.filter + (fun g => + (ListMap.keys proc.header.inputs).contains g && + (ListMap.keys proc.header.outputs).contains g && + (List.map Procedure.Check.expr proc.spec.postconditions.values).any fun e => + List.any e.freeVars fun x => x.fst == CoreIdent.mkOld g.name) + (CallArg.getLhs args) + +/-- Shared `inputOnlyOldSubst` map: input-only parameters referenced as `old _` + in postconditions, mapped to the corresponding caller-side argument. -/ +@[reducible] private def callElim_inputOnlyOldSubst (proc : Procedure) + (args : List (CallArg Expression)) : + Map Expression.Ident Expression.Expr := + (proc.header.inputs.keys.zip (CallArg.getInputExprs args)).filterMap fun (paramId, argExpr) => + let oldVar := CoreIdent.mkOld paramId.name + if !(ListMap.keys proc.header.outputs).contains paramId && + (proc.spec.postconditions.values.map Procedure.Check.expr).any + (fun e => Lambda.LExpr.freeVars e |>.any (fun (id, _) => id == oldVar)) + then some (oldVar, argExpr) + else none + +/-! ### Top-level call-elimination correctness theorem -/ + +/-- Returns the call-elim transformation result of a single command: + either the rewritten statement list (for a `.call`) or `[s]` + unchanged (for a non-call statement). -/ +@[expose] +def callElimStmt (s : Statement) (p : Program) + : CoreTransformM (List Statement) := do + modify (fun σ => { σ with currentProgram := .some p }) + match s with + | .cmd (CmdExt.call procName args md) => do + match (← CallElim.callElimCmd (CmdExt.call procName args md)) with + | .none => return [s] + | .some s' => return s' + | _ => return [s] + +/-- An inline analogue of the inner-`go` walk inside + `Procedure.Spec.updateCheckExprs`: given a substituted-expression + list and an original-checks list, produce the per-entry checks with + the new expression. This mirrors the `where go` clause of + `Procedure.Spec.updateCheckExprs` so we can reason about its result + without referring to the where-private constant. -/ +private def updateCheckExprs_walk + (es : List Expression.Expr) (checks : List Procedure.Check) : + List Procedure.Check := + match es, checks with + | [], _ => checks + | _, [] => checks + | e :: erest, c :: crest => + { c with expr := e } :: updateCheckExprs_walk erest crest + +/-- The walk preserves length when `es = checks.map f`. -/ +private theorem updateCheckExprs_walk_length_map + (vs : List Procedure.Check) + (f : Procedure.Check → Expression.Expr) : + (updateCheckExprs_walk (vs.map f) vs).length = vs.length := by + induction vs with + | nil => simp [updateCheckExprs_walk] + | cons hd tl ih => + simp only [List.map_cons, updateCheckExprs_walk, + List.length_cons] + exact congrArg (· + 1) ih + +/-- Positional access into `updateCheckExprs_walk (vs.map (substFvars ·.expr sm)) vs`. -/ +private theorem updateCheckExprs_walk_getElem_substFvars + {sm : Map Expression.Ident Expression.Expr} + (vs : List Procedure.Check) + (i : Nat) + (Hi : i < vs.length) + (Hi' : i < (updateCheckExprs_walk + (vs.map (fun c => + Lambda.LExpr.substFvars c.expr sm)) + vs).length) : + ((updateCheckExprs_walk + (vs.map (fun c => Lambda.LExpr.substFvars c.expr sm)) + vs)[i]'Hi').expr = + Lambda.LExpr.substFvars (vs[i]'Hi).expr sm := by + induction vs generalizing i with + | nil => + exact absurd Hi (by simp) + | cons hd tl ih => + cases i with + | zero => + simp only [List.map_cons, updateCheckExprs_walk, + List.getElem_cons_zero] + | succ k => + have Hk : k < tl.length := by + simp only [List.length_cons] at Hi; omega + have Hk' : k < (updateCheckExprs_walk + (tl.map (fun c => + Lambda.LExpr.substFvars c.expr sm)) + tl).length := by + simp only [List.map_cons, updateCheckExprs_walk, + List.length_cons] at Hi' + omega + have HiH := ih k Hk Hk' + simp only [List.map_cons, updateCheckExprs_walk, + List.getElem_cons_succ] + exact HiH + +/-- The local `updateCheckExprs_walk` mirror agrees pointwise with the + where-private `Procedure.Spec.updateCheckExprs.go`. Both walk the two + lists in parallel and return the original `checks` list when either + argument is exhausted; the equality holds for all input shapes. -/ +private theorem updateCheckExprs_walk_eq_go : + ∀ (es : List Expression.Expr) (cs : List Procedure.Check), + updateCheckExprs_walk es cs = + Procedure.Spec.updateCheckExprs.go es cs := by + intro es cs + induction es generalizing cs with + | nil => + cases cs with | nil => - cases Hrd - | cons h t => - cases Hrd with - | read_some Hh Ht => - constructor - . refine ReadValueUpdatedStates ?_ Hh Hlen - . intros Hin' - exact Hin Hin' List.mem_cons_self - . apply ih ?_ Ht - apply List.Disjoint.mono_right _ Hin - simp_all - -theorem ReadValueUpdatedState' : - x ≠ k → - updatedState σ k v x = some v' → - σ x = some v' := by - intros Hne Hsome - simp [updatedState, Hne] at Hsome <;> simp_all - -theorem ReadValueUpdatedStates' : - ¬ x ∈ ks → - updatedStates σ ks vs x = some v' → - ks.length = vs.length → - σ x = some v' := by - intros Hne Hsome Hlen - induction ks generalizing σ vs - case nil => - cases vs <;> simp_all - simp [updatedStates, updatedStates'] at Hsome - assumption - case cons h t ih => - cases vs - case nil => simp_all - case cons h' t' => - simp [updatedStates, updatedStates'] at * - specialize ih Hne.2 Hsome Hlen - exact ReadValueUpdatedState' Hne.1 ih - -theorem ReadValuesUpdatedState' : - ¬ k ∈ ks → - ReadValues (updatedState σ k v) ks vs → - ReadValues σ ks vs := by - intros Hin Hrd - induction Hrd - case read_none => - apply ReadValues.read_none - case read_some xs' vs' x v' Hsome Hrd Hrd2 => - constructor <;> try assumption - apply ReadValueUpdatedState' (k:=k) (v:=v) _ Hsome - . exact Ne.symm (List.ne_of_not_mem_cons Hin) - . apply Hrd2 - exact List.not_mem_of_not_mem_cons Hin - -theorem ReadValuesUpdatedStates' : - ks'.length = vs'.length → - ks'.Disjoint ks → - ReadValues (updatedStates σ ks' vs') ks vs → - ReadValues σ ks vs := by - intros Hlen Hin Hrd - induction ks generalizing vs - case nil => - cases Hrd - constructor - case cons h t ih => - cases vs with + simp [updateCheckExprs_walk, + Procedure.Spec.updateCheckExprs.go] + | cons hd tl => + simp [updateCheckExprs_walk, + Procedure.Spec.updateCheckExprs.go] + | cons e es' ih => + cases cs with | nil => - cases Hrd - | cons h t => - cases Hrd with - | read_some Hh Ht => - constructor - . refine ReadValueUpdatedStates' ?_ Hh Hlen - . intros Hin' - exact Hin Hin' List.mem_cons_self - . apply ih ?_ Ht - apply List.Disjoint.mono_right _ Hin - simp_all - -theorem ReadValuesUpdatedStatesSame : - ks.length = vs.length → - ks.Nodup → - ReadValues (updatedStates σ ks vs) ks vs := by - intros Hlen Hnd - induction ks generalizing σ vs - case nil => - cases vs <;> simp_all - constructor - case cons h t ih => - cases vs - . simp_all - . simp [updatedStates, updatedStates'] - rw [← updatedStateComm'] - constructor <;> simp_all - simp [updatedState] - rw [updatedStateComm'] - apply ih <;> simp_all - rw [List.unzip_zip] <;> simp_all - rw [List.unzip_zip] <;> simp_all - -theorem EvalStatementContractInitVar : - Imperative.WellFormedSemanticEvalVar δ → - σ v = some vv → - σ v' = none → - EvalStatementContract π φ δ σ - (createInitVar ((v', ty), v)) - (updatedState σ v' vv) δ := by - intros Hwf Hsome Hnone - simp [createInitVar] - constructor - constructor - . apply Imperative.EvalCmd.eval_init <;> try assumption - have Hwfv := Hwf (Lambda.LExpr.fvar () v none) v σ - rw [Hwfv]; assumption - simp [Imperative.HasFvar.getFvar] - apply Imperative.InitState.init Hnone - simp [updatedState] - intros y Hne - simp [updatedState] - intros Heq - simp_all - . simp [Imperative.isDefinedOver, - Imperative.isDefined, - Imperative.HasVarsImp.modifiedVars, - Command.modifiedVars, - Imperative.Cmd.modifiedVars] - -theorem EvalStatementsContractInitVars : - Imperative.WellFormedSemanticEvalVar δ → - -- the generated old variable names shouldn't overlap with original variables - List.Nodup ((trips.unzip.fst.unzip.fst) ++ (trips.unzip.snd)) → - ReadValues σ (trips.unzip.snd) vvs → - Imperative.isNotDefined σ (trips.unzip.fst.unzip.fst) → - EvalStatementsContract π φ δ σ - (createInitVars trips) - (updatedStates σ - (trips.unzip.fst.unzip.fst) vvs) δ := by - intros Hwf Hndup Hdef Hndef - induction trips generalizing σ vvs with + simp [updateCheckExprs_walk, + Procedure.Spec.updateCheckExprs.go] + | cons hd tl => + simp [updateCheckExprs_walk, + Procedure.Spec.updateCheckExprs.go, + ih] + +/-- For each entry in `updateCheckExprs (conds.values.map (substFvars · sm)) + conds`, the entry's expression is exactly `substFvars c.expr sm` for some + `c ∈ conds.values`. This is the per-entry correspondence used by D2f + to lift `δ σO original_post = tt` (Hpost) to the substituted + postcondition form. + + Note: the proof relies on the `where`-clause `Procedure.Spec.updateCheckExprs.go` + walking the lists in parallel; we mirror this via `updateCheckExprs_walk` + and use definitional unfolding via `show`. -/ +private theorem updateCheckExprs_substFvars_mem + {sm : Map Expression.Ident Expression.Expr} + {conds : ListMap CoreLabel Procedure.Check} + {entry : CoreLabel × Procedure.Check} + (Hentry : entry ∈ + (conds.keys.zip + (updateCheckExprs_walk + (conds.values.map + (fun c => Lambda.LExpr.substFvars c.expr sm)) + conds.values))) : + ∃ c ∈ conds.values, + entry.snd.expr = Lambda.LExpr.substFvars c.expr sm := by + rcases List.mem_iff_get.mp Hentry with ⟨n, Hn⟩ + have Hn_lt_zip := n.isLt + have Hzip_len : + (conds.keys.zip + (updateCheckExprs_walk + (conds.values.map + (fun c => Lambda.LExpr.substFvars c.expr sm)) + conds.values)).length = + Nat.min conds.keys.length + (updateCheckExprs_walk + (conds.values.map + (fun c => Lambda.LExpr.substFvars c.expr sm)) + conds.values).length := List.length_zip + have Hwalk_len : + (updateCheckExprs_walk + (conds.values.map (fun c => + Lambda.LExpr.substFvars c.expr sm)) + conds.values).length = conds.values.length := + updateCheckExprs_walk_length_map _ _ + have Hn_lt_zip' : n.val < + Nat.min conds.keys.length + (updateCheckExprs_walk + (conds.values.map + (fun c => Lambda.LExpr.substFvars c.expr sm)) + conds.values).length := Hzip_len ▸ Hn_lt_zip + have Hn_lt_keys : n.val < conds.keys.length := + Nat.lt_of_lt_of_le Hn_lt_zip' (Nat.min_le_left _ _) + have Hn_lt_walk : + n.val < (updateCheckExprs_walk + (conds.values.map (fun c => + Lambda.LExpr.substFvars c.expr sm)) + conds.values).length := + Nat.lt_of_lt_of_le Hn_lt_zip' (Nat.min_le_right _ _) + have Hn_lt_vs : n.val < conds.values.length := Hwalk_len ▸ Hn_lt_walk + have HzipGet : + (conds.keys.zip + (updateCheckExprs_walk + (conds.values.map + (fun c => Lambda.LExpr.substFvars c.expr sm)) + conds.values))[n.val]'Hn_lt_zip = + (conds.keys[n.val]'Hn_lt_keys, + (updateCheckExprs_walk + (conds.values.map + (fun c => Lambda.LExpr.substFvars c.expr sm)) + conds.values)[n.val]'Hn_lt_walk) := + List.getElem_zip + have HhE_get : (conds.keys.zip _)[n.val]'Hn_lt_zip = entry := Hn + rw [HzipGet] at HhE_get + have Hsnd_eq : + entry.snd = + (updateCheckExprs_walk + (conds.values.map (fun c => + Lambda.LExpr.substFvars c.expr sm)) + conds.values)[n.val]'Hn_lt_walk := + ((Prod.mk.injEq _ _ _ _).mp HhE_get).2.symm + refine ⟨conds.values[n.val]'Hn_lt_vs, List.getElem_mem _, ?_⟩ + rw [Hsnd_eq] + exact updateCheckExprs_walk_getElem_substFvars + conds.values n.val Hn_lt_vs Hn_lt_walk + +/-! ## Call-case helper lemmas + +These helpers bridge the WF infrastructure to the disjointness/Nodup +obligations the L1–L6 wrappers need. Most consume a +`Forall isTempIdent`/`Forall isOldTempIdent` hypothesis rather than +producing one from `genIdent` semantics directly, since the producing +side requires reasoning through opaque `String.startsWith` / +`Slice`/`Pattern` infrastructure. -/ + +/-- Negation form of `List.Forall_mem_iff.mp`: if every element of `l` + satisfies `p` and `x` does *not* satisfy `p`, then `x ∉ l`. Used + repeatedly for `notTemp ⇒ k1 ∉ argTemps/outTemps/genOldIdents`. -/ +private theorem notMem_of_Forall_neg + {α : Type _} {l : List α} {p : α → Prop} {x : α} + (Hforall : Forall p l) (Hnotp : ¬ p x) : x ∉ l := fun h => + Hnotp ((List.Forall_mem_iff.mp Hforall) x h) + +/-- Positional decomposition for `(k1, k2) ∈ ks.zip ks'` under length + equality: produce a position `n` together with the bounds and the + pair-projection equalities `k1 = ks[n]` and `k2 = ks'[n]`. Absorbs the + `mem_iff_get` → `getElem_zip` → `Prod.mk.injEq` dance that recurs in + the `Hsubst` input-half and `Hinv` class-(a) chases. -/ +private theorem pair_in_zip_pos_decomp + {α β} {ks : List α} {ks' : List β} + (Hlen : ks.length = ks'.length) + {k1 : α} {k2 : β} (Hkin : (k1, k2) ∈ ks.zip ks') : + ∃ (n : Nat) (Hn_lt : n < ks.length) (Hn_lt' : n < ks'.length), + k1 = ks[n]'Hn_lt ∧ k2 = ks'[n]'Hn_lt' := by + rcases List.mem_iff_get.mp Hkin with ⟨n, Hn⟩ + have HzipLen : (ks.zip ks').length = ks.length := by + rw [List.length_zip, Hlen, Nat.min_self] + have Hn_lt : n.val < ks.length := HzipLen ▸ n.isLt + have Hn_lt' : n.val < ks'.length := Hlen ▸ Hn_lt + have Hget : (ks.zip ks')[n.val]'n.isLt = (ks[n.val]'Hn_lt, ks'[n.val]'Hn_lt') := + List.getElem_zip + have HEq : (k1, k2) = (ks[n.val]'Hn_lt, ks'[n.val]'Hn_lt') := Hget ▸ Hn.symm + exact ⟨n.val, Hn_lt, Hn_lt', + ((Prod.mk.injEq _ _ _ _).mp HEq).1, ((Prod.mk.injEq _ _ _ _).mp HEq).2⟩ + +/-- Reverse of `pair_in_zip_pos_decomp`: under matching position bounds, + the pair `(ks[n], ks'[n])` lies in `ks.zip ks'`. Used by the + `Hk1 ∉ inputs.keys` chase in `Hinv` class-(a). -/ +private theorem pair_in_zip_of_pos + {α β} {ks : List α} {ks' : List β} + {n : Nat} (Hn_lt : n < ks.length) (Hn_lt' : n < ks'.length) : + (ks[n]'Hn_lt, ks'[n]'Hn_lt') ∈ ks.zip ks' := + List.mem_iff_get.mpr + ⟨⟨n, by rw [List.length_zip]; omega⟩, List.getElem_zip⟩ + +/-- Bridge from the `tmp_` half of `Hwfgenst` to `isNotDefined` for a list + of fresh temp names: if a name is `isTempIdent` and is *not* in + `γ.generated`, then it must be undefined in σ (otherwise the iff in + `Hwfgentmp` would put it in `γ.generated`). + + Takes the dual-clause `tmp_` half: for every `v`, `v ∈ generated ∧ + isTempIdent v ↔ (σ v).isSome ∧ isTempIdent v`. -/ +private theorem fresh_temps_not_defined + {σ : CoreStore} {γ : CoreTransformState} + (Hwfgentmp : ∀ v, v ∈ γ.genState.generated ∧ isTempIdent v ↔ + ((σ v).isSome ∧ isTempIdent v)) + {newTemps : List Expression.Ident} + (Hnotgen : ∀ x ∈ newTemps, x ∉ γ.genState.generated) + (HtempPred : Forall (fun x => isTempIdent x) newTemps) : + Imperative.isNotDefined σ newTemps := by + intro v Hin + have Htemp : isTempIdent v := (List.Forall_mem_iff.mp HtempPred) v Hin + have Hnotin : v ∉ γ.genState.generated := Hnotgen v Hin + -- If σ v = some _ then `Hwfgentmp.mpr` would put v in `γ.generated`, + -- contradicting `Hnotin`. Case split on `σ v` directly. + match hσ : σ v with + | none => rfl + | some w => + exfalso + apply Hnotin + have Hbundle : (σ v).isSome ∧ isTempIdent v := by + refine ⟨?_, Htemp⟩ + simp [hσ] + exact ((Hwfgentmp v).mpr Hbundle).1 + +/-- Bridge from the `old_` half of `Hwfgenst` to `isNotDefined` for a list + of fresh `old_`-prefixed names: if every name is `isOldTempIdent`, then + each must be undefined in σ by the freshness clause. -/ +private theorem fresh_olds_not_defined + {σ : CoreStore} + (Hwfgenold : ∀ v, isOldTempIdent v → (σ v).isNone) + {newOlds : List Expression.Ident} + (HoldPred : Forall (fun x => isOldTempIdent x) newOlds) : + Imperative.isNotDefined σ newOlds := by + intro v Hin + have Hold : isOldTempIdent v := (List.Forall_mem_iff.mp HoldPred) v Hin + exact Option.isNone_iff_eq_none.mp (Hwfgenold v Hold) + +/-- Positional decomposition for `Map.find?` against the L6 canonical + `createOldVarsSubst` map. Given a hit + `Map.find? (createOldVarsSubst (...zip-form...)) k = some w`, extract + the positional witness `i < oldVars.length` together with the shape + facts `k = mkOld oldVars[i].name` and `w = createFvar genOldIdents[i]`. + + Absorbs the verbatim ~125-LoC `HCanonLen → Hni_lt → HtripGet → Htrip_shape → + HoldG_get → HgoEq → HkwEq → Hk_eq / Hw_eq` chain that recurs at three + `createOldVarsSubst`-flavoured sites in `callElimStatementCorrect` + (`HoldSubBridge`, `Hinv` class-(b1), `Hpred_disj` class-(b1)). -/ +private theorem createOldVarsSubst_pos_decomp + {genOldIdents : List Expression.Ident} + {oldTys : List Lambda.LTy} + {oldVars : List Expression.Ident} + (HgenOldLen : genOldIdents.length = oldVars.length) + (HoldTysLen : oldTys.length = oldVars.length) + {k : Expression.Ident} {w : Expression.Expr} + (Hf : Map.find? + (Core.Transform.createOldVarsSubst + ((((genOldIdents.zip oldTys).zip oldVars).zip + (oldVars.map (fun g => CoreIdent.mkOld g.name))).map + (fun (((fresh, ty), _orig), oldG) => + ((fresh, ty), oldG)))) k = some w) : + ∃ (i : Nat) (Hi : i < oldVars.length), + k = CoreIdent.mkOld (oldVars[i]'Hi).name ∧ + w = Core.Transform.createFvar + (genOldIdents[i]'(by rw [HgenOldLen]; exact Hi)) := by + -- Local abbreviations matching the call-site canonical names. + let oldGVars : List Expression.Ident := + oldVars.map (fun g => CoreIdent.mkOld g.name) + let oldTripsCanonical : + List ((Expression.Ident × Expression.Ty) × Expression.Ident) := + (((genOldIdents.zip oldTys).zip oldVars).zip oldGVars).map + (fun (((fresh, ty), _orig), oldG) => ((fresh, ty), oldG)) + -- (k, w) ∈ createOldVarsSubst oldTripsCanonical (as List). + have Hkw_mem_list : + List.Mem (k, w) + (Core.Transform.createOldVarsSubst oldTripsCanonical) := + Map.find?_mem _ k w Hf + -- createOldVarsSubst trips = trips.map go (definitional). + rcases List.mem_map.mp Hkw_mem_list with ⟨trip, Htrip_in, Htrip_eq⟩ + rcases List.mem_iff_get.mp Htrip_in with ⟨ni, Hni⟩ + -- Length facts. + have HoldGLen : oldGVars.length = oldVars.length := by + simp [oldGVars, List.length_map] + have Hni_lt_canon : ni.val < oldTripsCanonical.length := ni.isLt + have Hni_lt : ni.val < oldVars.length := by + have := ni.isLt + simp [oldTripsCanonical, List.length_map, List.length_zip, HgenOldLen, + HoldTysLen, HoldGLen] at this; exact this + have Hni_lt_genOld : ni.val < genOldIdents.length := by omega + have Hni_lt_oldTys : ni.val < oldTys.length := by omega + have Hni_lt_oldGVars : ni.val < oldGVars.length := HoldGLen ▸ Hni_lt + -- Project the canonical trip via zip-getElem reductions. + have HtripGet : + oldTripsCanonical[ni.val]'Hni_lt_canon = + ((genOldIdents[ni.val]'Hni_lt_genOld, + oldTys[ni.val]'Hni_lt_oldTys), + oldGVars[ni.val]'Hni_lt_oldGVars) := by + show (((((genOldIdents.zip oldTys).zip oldVars).zip + oldGVars).map _)[ni.val]'Hni_lt_canon) = _ + simp only [List.getElem_map, List.getElem_zip] + have Htrip_shape : + trip = ((genOldIdents[ni.val]'Hni_lt_genOld, + oldTys[ni.val]'Hni_lt_oldTys), + oldGVars[ni.val]'Hni_lt_oldGVars) := by + rw [← Hni]; exact HtripGet + have HoldG_get : + oldGVars[ni.val]'Hni_lt_oldGVars = + CoreIdent.mkOld (oldVars[ni.val]'Hni_lt).name := by + show (oldVars.map (fun g => CoreIdent.mkOld g.name))[ni.val]'_ = _ + rw [List.getElem_map] + have HkwEq : + (k, w) = (oldGVars[ni.val]'Hni_lt_oldGVars, + Core.Transform.createFvar + (genOldIdents[ni.val]'Hni_lt_genOld)) := by + rw [← Htrip_eq, Htrip_shape]; rfl + refine ⟨ni.val, Hni_lt, ?_, ((Prod.mk.injEq _ _ _ _).mp HkwEq).2⟩ + rw [((Prod.mk.injEq _ _ _ _).mp HkwEq).1, HoldG_get] + +/-- Positional decomposition for `Map.find?` against the L6 + `inputOnlyOldSubst` map. Given a hit + `Map.find? (inputOnlyOldSubst inputs inputArgs outputs posts) k = some w`, + extract the positional witness `ni < inputs.length` (with the + matching `ni < inputArgs.length`) together with the shape facts + `k = mkOld inputs[ni].name` and `w = inputArgs[ni]`, plus the + guard byproduct `inputs[ni] ∉ outputs`. + + Absorbs the verbatim ~80-LoC `List.mem_filterMap` + `by_cases Hg` + + positional `List.mem_iff_get` + `getElem_zip` chain that recurs at + three `inputOnlyOldSubst`-flavoured sites in `callElimStatementCorrect` + (`HinputSubBridge`, `Hinv` class-(b2), `Hpred_disj` class-(b2)). + + Mirror of `createOldVarsSubst_pos_decomp` for the input-only old + substitution map. -/ +private theorem inputOnlyOldSubst_pos_decomp + {inputs : List Expression.Ident} + {inputArgs : List Expression.Expr} + {outputs : List Expression.Ident} + {posts : List Expression.Expr} + {k : Expression.Ident} {w : Expression.Expr} + (Hf : Map.find? + ((inputs.zip inputArgs).filterMap + (fun (paramId, argExpr) => + let oldVar := CoreIdent.mkOld paramId.name + if !outputs.contains paramId && + posts.any (fun e => Lambda.LExpr.freeVars e |>.any + (fun (id, _) => id == oldVar)) + then some (oldVar, argExpr) + else none)) k = some w) : + ∃ (ni : Nat) (Hi : ni < inputs.length) + (Hi' : ni < inputArgs.length), + k = CoreIdent.mkOld (inputs[ni]'Hi).name ∧ + w = inputArgs[ni]'Hi' ∧ + (inputs[ni]'Hi) ∉ outputs := by + -- (k, w) ∈ inputOnlyOldSubst (as List). + have Hkw_mem_list : + List.Mem (k, w) + ((inputs.zip inputArgs).filterMap + (fun (paramId, argExpr) => + let oldVar := CoreIdent.mkOld paramId.name + if !outputs.contains paramId && + posts.any (fun e => Lambda.LExpr.freeVars e |>.any + (fun (id, _) => id == oldVar)) + then some (oldVar, argExpr) + else none)) := + Map.find?_mem _ k w Hf + -- Apply List.mem_filterMap to extract a witness pair. + rcases List.mem_filterMap.mp Hkw_mem_list with + ⟨pair, Hpair_in, Hpair_eq⟩ + -- Case-split on the guard. + by_cases Hg : + (!outputs.contains pair.fst && + posts.any + (fun e => Lambda.LExpr.freeVars e |>.any + (fun (id, _) => id == CoreIdent.mkOld pair.fst.name))) = true + · -- guard = true branch. + have Hpair_eq' : + (CoreIdent.mkOld pair.fst.name, pair.snd) = (k, w) := by + simp only [Hg, if_true] at Hpair_eq + exact Option.some_inj.mp Hpair_eq + have Hk_eq : k = CoreIdent.mkOld pair.fst.name := + ((Prod.mk.injEq _ _ _ _).mp Hpair_eq').1.symm + have Hw_eq : w = pair.snd := + ((Prod.mk.injEq _ _ _ _).mp Hpair_eq').2.symm + -- pair ∈ inputs.zip inputArgs. + rcases List.mem_iff_get.mp Hpair_in with ⟨ni, Hni⟩ + have Hni_lt_zip : ni.val < (inputs.zip inputArgs).length := ni.isLt + have Hni_lt_min : ni.val < min inputs.length inputArgs.length := + List.length_zip ▸ Hni_lt_zip + have Hni_lt_inputs : ni.val < inputs.length := by omega + have Hni_lt_inputArgs : ni.val < inputArgs.length := by omega + -- Project pair to its components positionally. + have Hpair_shape : + pair = (inputs[ni.val]'Hni_lt_inputs, + inputArgs[ni.val]'Hni_lt_inputArgs) := by + have HpairGet : + (inputs.zip inputArgs)[ni.val]'Hni_lt_zip = + (inputs[ni.val]'Hni_lt_inputs, + inputArgs[ni.val]'Hni_lt_inputArgs) := List.getElem_zip + rw [← Hni]; exact HpairGet + refine ⟨ni.val, Hni_lt_inputs, Hni_lt_inputArgs, ?_, ?_, ?_⟩ + · rw [Hk_eq, Hpair_shape] + · rw [Hw_eq, Hpair_shape] + · -- inputs[ni.val] ∉ outputs from guard. + have HgL : (!outputs.contains pair.fst) = true := + (Bool.and_eq_true _ _).mp Hg |>.1 + simp at HgL + rwa [Hpair_shape] at HgL + · -- guard = false: contradiction. + simp only [Hg] at Hpair_eq + exact absurd Hpair_eq (by simp) + +/-- Membership form: the entry's `.snd.expr` lies in `getCheckExprs conds`. -/ +private theorem filterCheck_mem_getCheckExprs + {conds : ListMap CoreLabel Procedure.Check} + {f : CoreLabel × Procedure.Check → Bool} + {entry : CoreLabel × Procedure.Check} + (Hentry : entry ∈ conds.filter f) : + entry.snd.expr ∈ Procedure.Spec.getCheckExprs conds := by + have Hin_full := (List.mem_filter.mp Hentry).1 + simp only [Procedure.Spec.getCheckExprs, List.mem_map] + refine ⟨entry.snd, ?_, rfl⟩ + rw [ListMap.values_eq_map_snd] + exact List.mem_map_of_mem Hin_full + +/-- `.contains` form of `filterCheck_mem_getCheckExprs`. Used at the + pre-filtered and post-filtered sites of `callElimStatementCorrect` to + bridge filter membership to the `.contains` argument expected by the + `Hpre`/`Hpost` hypotheses from `call_sem`. -/ +private theorem filterCheck_in_getCheckExprs [LawfulBEq Expression.Expr] + {conds : ListMap CoreLabel Procedure.Check} + {f : CoreLabel × Procedure.Check → Bool} + {entry : CoreLabel × Procedure.Check} + (Hentry : entry ∈ conds.filter f) : + (Procedure.Spec.getCheckExprs conds).contains entry.snd.expr := + List.contains_iff_mem.mpr (filterCheck_mem_getCheckExprs Hentry) + +/-- Store-agreement helper for `σ_R1`-style stacks (the σ_R1 layer + overlaying `genOldIdents ↦ oldVals` on σO, plus the σO ← σAO ← + σA ← σ chain from havoc + InitStates). + + For any identifier `v` not touched by any layer, all four stores + agree: `updatedStates σO genOldIds oldVals v = σ v`. Used at three + sites in `callElimStatementCorrect` (D2c "argExpr survives" branches + and the L6 `Hinv` derivations). -/ +private theorem σR1_eq_σ_for_notTouched + {σ σA σAO σO : CoreStore} + {ins outs genOldIds : List Expression.Ident} + {argVals oVals oldVals : List Expression.Expr} + (Hinitin : InitStates σ ins argVals σA) + (Hinitout : InitStates σA outs oVals σAO) + (Hhav : HavocVars σAO outs σO) + {v : Expression.Ident} + (HvNotIns : v ∉ ins) + (HvNotOuts : v ∉ outs) + (HvNotGen : v ∉ genOldIds) : + updatedStates σO genOldIds oldVals v = σ v := by + rw [updatedStates_get_notin HvNotGen] + rcases HavocVarsUpdateStates Hhav with ⟨ovh, Hup_havoc⟩ + have HσO_eq : σO = updatedStates σAO outs ovh := UpdateStatesUpdated Hup_havoc + rw [HσO_eq, updatedStates_get_notin HvNotOuts, + initStates_get_notin Hinitout HvNotOuts, + initStates_get_notin Hinitin HvNotIns] + +-- Q19-I bind-shell simp golf: shared simp sets used inside the +-- `callElim*_ok` no-throw lemmas and `callElimCmd_call_eq`. The +-- hypothesis name is captured as an `ident` and spliced into the +-- `simp ... at` location list. +local macro "bind_shell" "at" h:ident : tactic => `(tactic| + simp only [bind, StateT.bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk, + pure, ExceptT.pure, StateT.pure] at $h:ident) + +local macro "bind_shell_state" "at" h:ident : tactic => `(tactic| + simp only [bind, StateT.bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk, + pure, ExceptT.pure, StateT.pure, + get, getThe, MonadStateOf.get, MonadState.get, StateT.get, + set, MonadStateOf.set, StateT.set, + monadLift, MonadLift.monadLift, liftM, ExceptT.lift, + Functor.map, StateT.map, Except.mapError] at $h:ident) + +/-- No-throw fact for the `oldTys ← oldVars.mapM ...` step inside + `callElimCmd`. When every `g ∈ oldVars` is a key of + `proc.header.inputs`, the `find?` lookup never throws, so the + `mapM` reduces to `Except.ok oldTys` with `oldTys.length = + oldVars.length`. -/ +private theorem oldVars_oldTys_mapM_ok + {proc : Procedure} + {oldVars : List Expression.Ident} + {γ : CoreTransformState} + (Holdvars_in_inputs : + ∀ g ∈ oldVars, (ListMap.keys proc.header.inputs).contains g) : + ∃ (oldTys : List (Lambda.LTy)) (γ' : CoreTransformState), + (oldVars.mapM (m:=CoreTransformM) (oldTyLookupCallElim proc)) + γ + = (Except.ok oldTys, γ') ∧ + oldTys.length = oldVars.length := by + -- Bridge: `keys.contains g = true` gives `find? g = some _`. + -- Use the contrapositive of `ListMap.find?_of_not_mem_values`: + -- `find? = none → g ∉ keys`, so `g ∈ keys → find? ≠ none`. + have Hfind_some : + ∀ (m : ListMap Expression.Ident Lambda.LMonoTy) + (g : Expression.Ident), + (ListMap.keys m).contains g = true → + ∃ v, ListMap.find? m g = some v := by + intro m g Hcontains + have Hmem : g ∈ ListMap.keys m := List.contains_iff_mem.mp Hcontains + cases hf : ListMap.find? m g with + | none => + have := ListMap.find?_of_not_mem_values m hf + exact absurd Hmem this + | some v => exact ⟨v, rfl⟩ + -- Induct on `oldVars`; threading the state explicitly. + induction oldVars generalizing γ with | nil => - simp [createInitVars, updatedStates] - constructor - | cons h t ih => - cases Hdef - next vs vv Hsome Hrest => - cases h with - | mk pair v => - cases pair with - | mk v' ty => - apply Imperative.EvalBlock.stmts_some_sem - apply EvalStatementContractInitVar <;> try assumption - apply Hndef <;> simp_all - unfold updatedStates - apply ih - . simp_all - have HH := Hndup.2 - apply List.Sublist.nodup (by simp) HH - . refine ReadValuesUpdatedState ?_ Hrest - simp [List.Nodup] at Hndup - have Hin := Hndup.1 - apply List.forall_mem_ne.mp - intros x' ty' - simp_all - . simp [Imperative.isNotDefined] at Hndef ⊢ - intros v x x1 Hin - simp [updatedState] - split <;> simp_all - apply Hndef.2 - apply Hin - -theorem EvalStatementContractInit : - Imperative.WellFormedSemanticEvalVar δ → - δ σ e = some vv → - σ v' = none → - EvalStatementContract π φ δ σ - (createInit ((v', ty), e)) - (updatedState σ v' vv) δ := by - intros Hwf Hsome Hnone - simp [createInit] - constructor - constructor - . apply Imperative.EvalCmd.eval_init <;> try assumption - apply Imperative.InitState.init Hnone - simp [updatedState] - intros y Hne - simp [updatedState] - intros Heq - simp_all - . simp [Imperative.isDefinedOver, - Imperative.isDefined, - Command.modifiedVars, - Imperative.Cmd.modifiedVars, - Imperative.HasVarsImp.modifiedVars] - -theorem EvalStatementsContractInits : - Imperative.WellFormedSemanticEvalVar δ → - Imperative.WellFormedSemanticEvalVal δ → - WellFormedCoreEvalCong δ → - -- the generated old variable names shouldn't overlap with original variables - trips.unzip.1.unzip.1.Disjoint (List.flatMap (Imperative.HasVarsPure.getVars (P:=Expression)) trips.unzip.2) → - List.Nodup (trips.unzip.1.unzip.1) → - EvalExpressions (P:=Core.Expression) δ σ (trips.unzip.2) vvs → - -- ReadValues σ (trips.unzip.2) vvs → - Imperative.isNotDefined σ (trips.unzip.1.unzip.1) → - EvalStatementsContract π φ δ σ - (createInits trips) - (updatedStates σ - (trips.unzip.1.unzip.1) vvs) δ := by - intros Hwfvr Hwfvl Hwfc Hdisj Hndup Hdef Hndef - induction trips generalizing σ vvs with + refine ⟨[], γ, ?_, rfl⟩ + simp [List.mapM_nil, pure, ExceptT.pure, StateT.pure, ExceptT.mk] + | cons g rest ih => + -- Head: lookup succeeds via `Holdvars_in_inputs`. + have Hg_in : (ListMap.keys proc.header.inputs).contains g = true := by + exact Holdvars_in_inputs g (by simp) + obtain ⟨ty, Hty⟩ := Hfind_some proc.header.inputs g Hg_in + -- Tail: IH applies because `Holdvars_in_inputs` weakens. + have Hrest : ∀ g' ∈ rest, (ListMap.keys proc.header.inputs).contains g' = true := + fun g' Hin => Holdvars_in_inputs g' (List.mem_cons_of_mem _ Hin) + obtain ⟨tys', γ'', Heqtail, Hlen⟩ := ih Hrest (γ := γ) + refine ⟨Lambda.LTy.forAll [] ty :: tys', γ'', ?_, ?_⟩ + · -- Unfold mapM_cons and chain the head match through to the tail mapM. + -- Strategy: unfold the bind shell and `pure` in both the goal and + -- `Heqtail` so the inner-mapM call is in a matching form, then `rw`. + simp only [List.mapM_cons, oldTyLookupCallElim, + bind, ExceptT.bind, ExceptT.bindCont, + ExceptT.mk, StateT.bind, + pure, ExceptT.pure, StateT.pure, Hty] + rw [Heqtail] + rfl + · simp [Hlen] + +/-- No-throw fact for `Core.Transform.createAsserts`. Its inner + `mapM` only invokes `genIdent` (a pure non-throwing state mutation), + so the computation always reduces to `Except.ok asserts` with + `asserts.length = conds.length`. The `asserts_shape` conjunct + exposes the list as a `conds.zip labels`-shape that the + label-agnostic downstream consumer needs. -/ +private theorem createAsserts_ok + (conds : ListMap CoreLabel Procedure.Check) + (subst : Map Expression.Ident Expression.Expr) + (md : Imperative.MetaData Expression) + (labelPrefix : String) + (γ : CoreTransformState) : + ∃ (asserts : List Statement) (γ' : CoreTransformState), + Core.Transform.createAsserts conds subst md labelPrefix γ + = (Except.ok asserts, γ') ∧ + asserts.length = conds.length ∧ + ∃ (labels : List String), labels.length = conds.length ∧ + asserts = (conds.zip labels).map (fun (entry, lbl) => + Statement.assert lbl + (Lambda.LExpr.substFvars entry.snd.expr subst) + (entry.snd.md.setCallSiteFileRange md)) := by + unfold Core.Transform.createAsserts + -- `ListMap α β := List (α × β)`, so `conds.mapM` is `List.mapM` over + -- the underlying list. Induct on that list, threading the state. + induction conds generalizing γ with | nil => - simp [createInits, updatedStates] - constructor - | cons h t ih => - cases Hdef - next vs vv Hsome Hrest => - cases h with - | mk pair v => - cases pair with - | mk v' ty => - apply Imperative.EvalBlock.stmts_some_sem - apply EvalStatementContractInit <;> try assumption - apply Hndef <;> simp_all - unfold updatedStates - apply ih - . apply List.Disjoint.mono ?_ ?_ Hdisj <;> simp_all - . simp_all - . refine EvalExpressionsUpdatedState Hwfvr Hwfc Hwfvl ?_ Hrest - simp at Hdisj - have Hdisj' : - [v'].Disjoint (List.flatMap Imperative.HasVarsPure.getVars t.unzip.snd) := by - apply List.Disjoint.mono ?_ ?_ Hdisj <;> simp_all - intros Hin - exact Hdisj' (List.mem_singleton.mpr rfl) Hin - . simp [Imperative.isNotDefined] at Hndef ⊢ - intros v x x1 Hin - simp [updatedState] - split <;> simp_all - apply Hndef.2 - apply Hin - -theorem EvalStatementContractHavocUpdated : - ∀ vv, - Imperative.WellFormedSemanticEvalVar δ → - σ v = some vv' → - EvalStatementContract π φ δ σ - (createHavoc v) - (updatedState σ v vv) δ := by - intros vv Hwf Hsome - simp [createHavoc] - constructor - constructor - . constructor - . exact updatedStateUpdate Hsome - . assumption - . simp [Imperative.isDefinedOver, Imperative.isDefined, - Imperative.HasVarsImp.modifiedVars, - Command.modifiedVars, - Imperative.Cmd.modifiedVars, Option.isSome] - split <;> simp_all - -theorem ReadValuesSome : - Imperative.isDefined σ ks → - ∃ vs, ReadValues σ ks vs := by - intros H - induction ks - case nil => - exists [] - constructor - case cons h t ih => - have Hh := H h - have Ht := ih ?_ - . cases Ht with - | intro t' Hrd => - simp [Option.isSome] at Hh - split at Hh <;> simp_all - next x val heq => - exists val :: t' - constructor <;> simp_all - . simp [Imperative.isDefined] at * - intros v a - simp_all - -theorem idents2havocsApp : -createHavocs (vs₁ ++ vs₂) = -createHavocs vs₁ ++ createHavocs vs₂ := by -cases vs₁ <;> simp [createHavocs] - -theorem createFvarsSubstStores : - ks1.length = ks2.length → - Imperative.WellFormedSemanticEvalVar δ → - Imperative.substDefined σ σA (ks1.zip ks2) → - Imperative.substStores σ σA (ks1.zip ks2) → - ReadValues σA ks2 argVals → - EvalExpressions (P:=Core.Expression) δ σ (createFvars ks1) argVals := by - intros Hlen Hwfv Hdef Hsubst Hrd - simp [createFvars] - have Hlen2 := ReadValuesLength Hrd - induction Hrd generalizing ks1 - case read_none => simp_all; constructor - case read_some xs vs x v Hsome Hrds ih' => - induction ks1 generalizing ks2 vs v with - | nil => - simp_all - | cons h t ih => - simp - constructor - . simp [createFvar, - Imperative.HasVarsPure.getVars, - Lambda.LExpr.LExpr.getVars] - simp [Imperative.substDefined] at Hdef - intros hh Hin - apply (Hdef hh x ?_).1 - left - simp_all - . simp [createFvar] - simp [Imperative.WellFormedSemanticEvalVar] at Hwfv - simp [Imperative.HasFvar.getFvar] at Hwfv - simp [Hwfv] - rw [Hsubst] - exact Hsome - simp_all - . apply ih' <;> simp_all - . intros k1 k2 Hin - apply Hdef <;> simp_all - . simp [Imperative.substStores] at * - intros - apply Hsubst <;> simp_all - -theorem EvalStatementsContractHavocVars : - Imperative.WellFormedSemanticEvalVar δ → - Imperative.isDefined σ vs → - HavocVars σ vs σ' → - EvalStatementsContract π φ δ σ - (createHavocs vs) σ' δ := by - intros Hwfv Hdef Hhav - simp [createHavocs] - induction vs generalizing σ - case nil => - have Heq := HavocVarsEmpty Hhav - simp_all - exact Imperative.EvalBlock.stmts_none_sem - case cons h t ih => - simp [createHavoc] - cases Hhav with - | update_some Hup Hhav => - apply Imperative.EvalBlock.stmts_some_sem - apply EvalStmtRefinesContract - apply Imperative.EvalStmt.cmd_sem - apply EvalCommand.cmd_sem - apply Imperative.EvalCmd.eval_set_nondet <;> try assumption - . simp [Imperative.isDefinedOver, Command.modifiedVars,Imperative.Cmd.modifiedVars, - Imperative.HasVarsImp.modifiedVars] - simp [Imperative.isDefined] at Hdef ⊢ - apply Hdef.1 - . apply ih <;> try assumption - . apply UpdateStateDefMonotone (σ:=σ) (vs:=t) <;> try assumption - simp [Imperative.isDefined] at * <;> simp_all - -theorem updatedStateInv : -¬k = h → -updatedState σ h h' k = σ k := by -intros Hne -unfold updatedState -simp [Hne] <;> simp_all - -theorem updatedStatesInv : -¬k ∈ ks' → -updatedStates σ ks' vs' k = σ k := by -intros Hin -induction ks' generalizing vs' σ <;> simp_all -case nil => - simp [updatedStates, updatedStates'] -case cons h t ih => - cases vs' - case nil => - simp [updatedStates, updatedStates'] - case cons h' t' => - unfold updatedStates - have Hsome' : (updatedState σ h h') k = σ k := by - apply updatedStateInv <;> simp_all - simp [← Hsome'] - exact ih - -theorem UpdateStateUpdatedDists -{P : Imperative.PureExpr} -{σ σ' : Imperative.SemanticStore P} -{h : P.Ident} {v : P.Expr} {ks : List P.Ident} {vs : List P.Expr} : -¬ h ∈ ks → -Imperative.UpdateState P σ h v σ' → -Imperative.UpdateState P (updatedStates σ ks vs) h v (updatedStates σ' ks vs) := by -intros Hnin Hup -cases Hup with -| update Hsome HH => -simp [updatedStates] -generalize Hls : ks.zip vs = ls -induction ls generalizing ks vs σ σ' -case nil => - simp [updatedStates'] - simp_all - constructor <;> try simp_all - rfl -case cons h t ih H' => - simp [updatedStates'] - have Hzip := List.zip_eq_cons_iff.mp Hls - cases Hzip with | intro l1 Hzip => cases Hzip with | intro l2 Hzip => - apply ih ?_ (ks:=l1) (vs:=l2) <;> simp_all - . simp [updatedState] - split <;> simp_all - . intros y Hne - simp [updatedState] - split <;> simp_all - . cases h with - | mk l r => - simp [updatedState] at * - split <;> simp_all - -theorem InitStateUpdatedDists -{P : Imperative.PureExpr} -{σ σ' : Imperative.SemanticStore P} -{h : P.Ident} {v : P.Expr} {ks : List P.Ident} {vs : List P.Expr} : -¬ h ∈ ks → -Imperative.InitState P σ h v σ' → -Imperative.InitState P (updatedStates σ ks vs) h v (updatedStates σ' ks vs) := by -intros Hnin Hup -cases Hup with -| init Hsome HH => -simp [updatedStates] -generalize Hls : ks.zip vs = ls -induction ls generalizing ks vs σ σ' -case nil => - simp [updatedStates'] - simp_all - constructor <;> try simp_all -case cons h t ih H' => - simp [updatedStates'] - have Hzip := List.zip_eq_cons_iff.mp Hls - cases Hzip with | intro l1 Hzip => cases Hzip with | intro l2 Hzip => - apply ih ?_ (ks:=l1) (vs:=l2) <;> simp_all - . simp [updatedState] - split <;> simp_all - . intros y Hne - simp [updatedState] - split <;> simp_all - . cases h with - | mk l r => - simp [updatedState] at * - split <;> simp_all - -theorem UpdateStatesUpdatedDists -{P : Imperative.PureExpr} -{σ σ' : Imperative.SemanticStore P} -{ks ks': List P.Ident} {vs vs' : List P.Expr} : - ks.Disjoint ks' → - UpdateStates σ ks vs σ' → - UpdateStates (updatedStates σ ks' vs') ks vs (updatedStates σ' ks' vs') := by -intros Hnd Hup -induction Hup -case update_none => - exact UpdateStates.update_none -case update_some Hup Hups ih => - apply UpdateStates.update_some - . apply UpdateStateUpdatedDists <;> try assumption - simp [List.Disjoint] at Hnd - simp_all - . apply ih - simp [List.Disjoint] at * - simp_all - -theorem InitStatesUpdatedDists -{P : Imperative.PureExpr} -{σ σ' : Imperative.SemanticStore P} -{ks ks': List P.Ident} {vs vs' : List P.Expr} : - ks.Disjoint ks' → - InitStates σ ks vs σ' → - InitStates (updatedStates σ ks' vs') ks vs (updatedStates σ' ks' vs') := by -intros Hnd Hup -induction Hup -case init_none => - exact InitStates.init_none -case init_some Hup Hups ih => - apply InitStates.init_some - . apply InitStateUpdatedDists <;> try assumption - simp [List.Disjoint] at Hnd - simp_all - . apply ih - simp [List.Disjoint] at * - simp_all - -theorem UpdateStatesUpdatedDist -{P : Imperative.PureExpr} -{σ σ' : Imperative.SemanticStore P} -{ks : List P.Ident} {vs : List P.Expr} -{k : P.Ident} {v : P.Expr} : - ¬ k ∈ ks → - UpdateStates σ ks vs σ' → - UpdateStates (updatedState σ k v) ks vs (updatedState σ' k v) := by -intros Hnd Hup -have Hnd : ks.Disjoint [k] := by - intros a Hin1 Hin2 - apply Hnd - simp_all -have HH := UpdateStatesUpdatedDists (vs':=[v]) Hnd Hup -simp [updatedStates, updatedStates'] at HH -assumption - -theorem HavocVarsUpdatedDists : -ks.Disjoint ks' → -HavocVars σ ks σ' → -HavocVars (updatedStates σ ks' vs') ks - (updatedStates σ' ks' vs') := by -intros Hnd Hhav -induction ks generalizing σ -case nil => - have Heq := HavocVarsEmpty Hhav - simp_all - exact HavocVars.update_none -case cons h t ih => - cases Hhav - next v σ'' Hup Hhav2 => - apply HavocVars.update_some (v:=v) (σ':=(updatedStates σ'' ks' vs')) - . simp [List.Disjoint] at Hnd - apply UpdateStateUpdatedDists Hnd.1 Hup - . apply ih ?_ Hhav2 - apply List.Disjoint.mono_left ?_ Hnd - simp_all - -theorem InitVarsUpdatedDists : -ks.Disjoint ks' → -InitVars σ ks σ' → -InitVars (updatedStates σ ks' vs') ks - (updatedStates σ' ks' vs') := by -intros Hnd Hhav -induction ks generalizing σ -case nil => - have Heq := InitVarsEmpty Hhav - simp_all - exact InitVars.init_none -case cons h t ih => - cases Hhav - next v σ'' Hup Hhav2 => - apply InitVars.init_some (v:=v) (σ':=(updatedStates σ'' ks' vs')) - . simp [List.Disjoint] at Hnd - apply InitStateUpdatedDists Hnd.1 Hup - . apply ih ?_ Hhav2 - apply List.Disjoint.mono_left ?_ Hnd - simp_all - -theorem HavocVarsUpdatedDist : -¬ k ∈ ks → -HavocVars σ ks σ' → -HavocVars (updatedState σ k v) ks - (updatedState σ' k v) := by -intros Hnd Hhav -have Hnd : ks.Disjoint [k] := by - intros a Hin1 Hin2 - apply Hnd - simp_all -have HH := HavocVarsUpdatedDists (vs':=[v]) Hnd Hhav -simp [updatedStates, updatedStates'] at HH -assumption - -theorem InitVarsUpdatedDist : -¬ k ∈ ks → -InitVars σ ks σ' → -InitVars (updatedState σ k v) ks - (updatedState σ' k v) := by -intros Hnd Hhav -have Hnd : ks.Disjoint [k] := by - intros a Hin1 Hin2 - apply Hnd - simp_all -have HH := InitVarsUpdatedDists (vs':=[v]) Hnd Hhav -simp [updatedStates, updatedStates'] at HH -assumption - -theorem UpdatedStatesDisjNotDefMonotone : - ks.Disjoint ks' → - ks.length = vs.length → - Imperative.isNotDefined σ ks' → - Imperative.isNotDefined (updatedStates σ ks vs) ks' := by -intros Hdis Hlen Hndef -simp [Imperative.isNotDefined, updatedStates] at * -intros v Hin -induction ks generalizing vs σ <;> simp_all -case nil => - simp [updatedStates'] - exact Hndef v Hin -case cons h t ih => - induction vs generalizing h t σ <;> simp_all - case cons h' t' ih' => - simp [updatedStates'] - rw [ih] <;> try simp_all - . apply List.Disjoint.mono_left _ Hdis - simp_all - . intros v Hin - simp [updatedState] - split <;> simp_all - apply Hdis _ Hin - simp_all - -/-- We can't use arbitrary expressions for substitution, - because then we can't say anything about the stores - due to not knowing the exact form of the expressions -/ -theorem Lambda.LExpr.substFvarCorrect : - Core.WellFormedCoreEvalCong δ → - Imperative.WellFormedSemanticEvalVar (P:=Expression) δ → - Imperative.WellFormedSemanticEvalVal (P:=Expression) δ → - Imperative.substStores σ σ' [(fro, to)] → - -- NOTE: `to` shouldn't be referred to in the original expression as well, but it is not needed in this lemma. - Imperative.invStores σ σ' - ((@Imperative.HasVarsPure.getVars Expression _ _ e).removeAll [fro]) → - -- NOTE: the old store is irrelevant because we assume congruence on old expressions as well, - -- More relation between the old store would be needed if we remove old expression congruence from WellFormedSemanticEvalVal - δ σ e = δ σ' (e.substFvar fro (createFvar to)) := by - intros Hwfc Hwfvr Hwfvl Hsubst2 Hinv - induction e <;> simp [Lambda.LExpr.substFvar, createFvar] at * - case const c | op o ty | bvar x => - rw [Hwfvl.2] - rw [Hwfvl.2] - constructor - constructor - case fvar name ty => - simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr - split <;> try simp_all - . simp [Imperative.substStores] at Hsubst2 - rw [Hwfvr] - rw [Hwfvr] - exact Hsubst2 - simp [Imperative.HasFvar.getFvar] - simp [Imperative.HasFvar.getFvar] - . next Hne => - simp [Imperative.invStores, Imperative.substStores, - Imperative.HasVarsPure.getVars, - Lambda.LExpr.LExpr.getVars, List.removeAll, Hne] at Hinv - rw [Hwfvr] - rw [Hwfvr] - exact Hinv - simp [Imperative.HasFvar.getFvar] - simp [Imperative.HasFvar.getFvar] - case abs m ty e ih => - specialize ih Hinv - have e2 := (e.substFvar fro (Lambda.LExpr.fvar () to none)) - have Hwfc := Hwfc.1 σ σ' e ((e.substFvar fro (Lambda.LExpr.fvar () to none))) - grind - case quant m k ty tr e trih eih => - simp [Imperative.invStores, Imperative.substStores, - Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - simp [List.app_removeAll, List.zip_append] at * - specialize eih ?_ - · intros k1 k2 Hin - rw [Hinv] - right; - assumption - specialize trih ?_ - · intros k1 k2 Hin - rw [Hinv] - left; - assumption - apply Hwfc.quantcongr <;> grind - case app m c fn fih eih => - simp [Imperative.invStores, Imperative.substStores, - Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - simp [List.app_removeAll, List.zip_append] at * - specialize fih ?_ - . intros k1 k2 Hin - rw [Hinv] - left; assumption - specialize eih ?_ - . intros k1 k2 Hin - rw [Hinv] - right; assumption - apply Hwfc.appcongr <;> grind - case ite m c t e cih tih eih => - simp [Imperative.invStores, Imperative.substStores, - Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - simp [List.app_removeAll, List.zip_append] at * - specialize cih ?_ - . intros k1 k2 Hin - rw [Hinv] - left; assumption - specialize tih ?_ - . intros k1 k2 Hin - rw [Hinv] - right; left; assumption - specialize eih ?_ - . intros k1 k2 Hin - rw [Hinv] - right; right; assumption - apply Hwfc.itecongr <;> grind - case eq m e1 e2 e1ih e2ih => - simp [Imperative.invStores, Imperative.substStores, - Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - simp [List.app_removeAll, List.zip_append] at * - specialize e1ih ?_ - . intros k1 k2 Hin - rw [Hinv] - left; assumption - specialize e2ih ?_ - . intros k1 k2 Hin - rw [Hinv] - right; assumption - apply Hwfc.eqcongr <;> grind - -theorem Lambda.LExpr.substFvarsCorrectZero : - Core.WellFormedCoreEvalCong δ → - Imperative.WellFormedSemanticEvalVar δ → - Imperative.WellFormedSemanticEvalVal δ → - Imperative.invStores σ σ' (Imperative.HasVarsPure.getVars e) → - δ σ e = δ σ' e := by - intros Hwfc Hwfvr Hwfvl Hinv - induction e <;> simp at * - case const c | op o ty | bvar x => - rw [Hwfvl.2] - rw [Hwfvl.2] - constructor - constructor - case fvar m name ty => - simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr - specialize Hwfvr (Lambda.LExpr.fvar m name ty) name - rw [Hwfvr] - rw [Hwfvr] - rw [Hinv] - simp [Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] - simp [Imperative.HasFvar.getFvar] - simp [Imperative.HasFvar.getFvar] - case abs m ty e ih => - specialize ih Hinv - have Hwfc := Hwfc.abscongr σ σ' e e ih - apply Hwfc - case quant m k ty tr e trih eih => - simp [Imperative.invStores, Imperative.substStores, - Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - simp [List.zip_append] at * - specialize trih ?_ - . intros k1 k2 Hin - rw [Hinv] - left; assumption - specialize eih ?_ - . intros k1 k2 Hin - rw [Hinv] - right; assumption - apply Hwfc.quantcongr <;> grind - case app m fn e fih eih => - simp [Imperative.invStores, Imperative.substStores, - Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - simp [List.zip_append] at * - specialize fih ?_ - . intros k1 k2 Hin - rw [Hinv] - left; assumption - specialize eih ?_ - . intros k1 k2 Hin - rw [Hinv] - right; assumption - apply Hwfc.appcongr <;> grind - case ite m c t e cih tih eih => - simp [Imperative.invStores, Imperative.substStores, - Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - simp [List.zip_append] at * - specialize cih ?_ - . intros k1 k2 Hin - rw [Hinv] - left; assumption - specialize tih ?_ - . intros k1 k2 Hin - rw [Hinv] - right; left; assumption - specialize eih ?_ - . intros k1 k2 Hin - rw [Hinv] - right; right; assumption - apply Hwfc.itecongr <;> grind - case eq m e1 e2 e1ih e2ih => - simp [Imperative.invStores, Imperative.substStores, - Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - simp [List.zip_append] at * - specialize e1ih ?_ - . intros k1 k2 Hin - rw [Hinv] - left; assumption - specialize e2ih ?_ - . intros k1 k2 Hin - rw [Hinv] - right; assumption - apply Hwfc.eqcongr <;> grind - -theorem updatedStoresInvStores : - ¬ k ∈ ks → - Imperative.invStores σ (updatedState σ k v) ks := by - intros Hnin k1 k2 Hin - have Heq : k1 = k2 := zip_self_eq Hin - simp_all - have Hin := (List.of_mem_zip Hin).1 - have Hne : k2 ≠ k := by - exact ne_of_mem_of_not_mem Hin Hnin - simp [updatedState] - simp_all - -theorem invStoresSubstHead : - Imperative.substStores (P := Expression) σ (updatedState σ h' v₁) [(h, h')] → - ¬ h' ∈ vs → - Imperative.invStores σ (updatedState σ h' v₁) (List.removeAll vs [h]) := by -intros Hnin Hsubst k1 k2 -apply updatedStoresInvStores -simp [List.removeAll] -simp_all - -theorem invStoresEraseDups' : - Imperative.invStores (P:=Expression) σ σ' vs.eraseDups → - Imperative.invStores (P:=Expression) σ σ' vs := by - intros Hinv k1 k2 Hin - specialize Hinv k1 k2 - have Heq := zip_self_eq Hin - simp_all - apply Hinv - apply zip_self_eq' - refine eraseDupsBy.sound ?_ - have Hsub := eraseDupsBy.sound Hin - have Hmem := List.of_mem_zip Hin - exact Hmem.1 - -theorem invStoresSubstTail' [BEq P.Ident] [LawfulBEq P.Ident] {σ : Imperative.SemanticStore P}: - σ h = some v₁ → - Imperative.invStores (P:=P) σ₀ σ (List.removeAll vs (h :: t)) → - Imperative.invStores (updatedState σ₀ h v₁) σ (List.removeAll vs t) := by - intros Hsome Hinv k1 k2 Hin - have Heq := zip_self_eq Hin - simp_all - simp [Imperative.invStores, Imperative.substStores] at * - simp [updatedState] - split <;> simp_all - . next neq => - apply Hinv - apply zip_self_eq' - have Hin := (List.of_mem_zip Hin).1 - apply removeAll_cons <;> simp_all - -theorem invStoresSubstTail : - Imperative.substStores (P := Expression) σ σ' ((h, h') :: t.zip t') → - Imperative.substStores (P := Expression) (updatedState σ h' v₁) σ' (t.zip t') → - σ h = some v₁ → - h ≠ h' → - Imperative.invStores σ σ' (List.removeAll vs ((h :: t) ++ (h' :: t'))) → - Imperative.invStores (updatedState σ h' v₁) σ' - (List.removeAll (vs.replaceAll h h') (t ++ t')) := by - intros Hsubst1 Hsubst2 Hsome Hne Hinv k1 k2 Hin - have Heq := zip_self_eq Hin - simp_all - simp [Imperative.invStores, Imperative.substStores] at * - simp [updatedState] - split - . rw [← Hsubst1 h] <;> simp_all - . next neq => - apply Hinv - apply zip_self_eq' - have Hin := (List.of_mem_zip Hin).1 - have Hsub := removeAll_sublist (vs.replaceAll h h') (t ++ t') - have Hin' : k2 ∈ (vs.replaceAll h h') := List.Sublist.mem Hin Hsub - have Hor := in_replaceAll_removeAll Hin - cases Hor <;> simp_all - apply removeAll_cons - . intros Heq - simp_all - have Hnmem : ¬ h ∈ vs.replaceAll h h' := replaceAll_not_mem Hne - exact Hnmem Hin' - . simp [List.removeAll] at * - simp_all - -theorem subst_create_replace : -(Imperative.HasVarsPure.getVars (Lambda.LExpr.substFvar e h (createFvar h'))) = -(Imperative.HasVarsPure.getVars e).replaceAll h h' -:= by -induction e <;> simp [ - Imperative.HasVarsPure.getVars, - Lambda.LExpr.LExpr.getVars, - Lambda.LExpr.substFvar, - createFvar, - List.replaceAll, - ] at * <;> try assumption -case fvar name ty => - split <;> try simp_all - simp [Lambda.LExpr.LExpr.getVars] - split <;> simp_all - simp [Lambda.LExpr.LExpr.getVars] -case app fn e fn_ih e_ih => - rw [fn_ih, e_ih] - rw [List.replaceAll_app] -case quant k ty tr_ih e_ih => - rw [tr_ih, e_ih] - rw [List.replaceAll_app] -case ite c t e c_ih t_ih e_ih => - rw [c_ih, t_ih, e_ih] - rw [List.replaceAll_app] - rw [List.replaceAll_app] -case eq e1 e2 e1_ih e2_ih => - rw [e1_ih, e2_ih] - rw [List.replaceAll_app] - -theorem substDefined_tail : -Imperative.substDefined σ σ' (h :: t) → -Imperative.substDefined σ σ' t := by -intros Hsubst k1 k2 Hin -apply Hsubst -exact List.mem_cons_of_mem h Hin - -theorem substNodup_tail : -Imperative.substNodup (h :: t) → -Imperative.substNodup t := by -intros Hsubst -simp [Imperative.substNodup] at * -exact (List.nodup_cons.mp (nodup_middle Hsubst.right)).right - -theorem substDefined_updatedState : -Imperative.substDefined σ σ' ls → -Imperative.substDefined (updatedState σ k v) σ' ls := by -intros Hsubst k1 k2 Hin -apply And.intro -. apply updatedStateIsDefinedMono - exact (Hsubst k1 k2 Hin).1 -. exact (Hsubst k1 k2 Hin).2 - -theorem zip_notin_fst : - t.length = t'.length → - (∀ x, ¬(h, x) ∈ List.zip t t') → - ¬ h ∈ t := by -intros Hlen H -induction t generalizing t' h <;> simp_all -case cons h t ih => -induction t' <;> simp_all -case cons h' t' => -have HH := H h' -simp_all -exact ih rfl H - -theorem zip_notin_snd : - t.length = t'.length → - (∀ x, ¬(x, h) ∈ List.zip t t') → - ¬ h ∈ t' := by -intros Hlen H -induction t' generalizing t h <;> simp_all -case cons h t ih => -induction t <;> simp_all -case cons h' t' => -have HH := H h' -simp_all -exact ih Hlen H - -theorem substNodup_ht : - t.length = t'.length → - Imperative.substNodup ((h, h') :: List.zip t t') → - ¬ h ∈ t ∧ ¬ h' ∈ t' := by - intros Hlen Hsubst - simp [Imperative.substNodup] at Hsubst - apply And.intro - . intros Hin - exact zip_notin_fst Hlen Hsubst.1.1 Hin - . have Hnd := nodup_middle Hsubst.2 - simp at Hnd - have Hnd' := Hnd.1.2 - exact zip_notin_snd Hlen Hnd' - -theorem getVarsSubstCreateFvar : -v ∈ (Imperative.HasVarsPure.getVars (P:=Expression) (Lambda.LExpr.substFvar e h (createFvar h'))) → -v ∈ (Imperative.HasVarsPure.getVars e) ∨ v = h' := by -intros Hin -induction e <;> -simp [Lambda.LExpr.substFvar, - Imperative.HasVarsPure.getVars, - Lambda.LExpr.LExpr.getVars, - createFvar - ] at * <;> try simp_all -case fvar name ty => - split at Hin <;> simp [Lambda.LExpr.LExpr.getVars] at * <;> simp_all -case app fn e fn_ih e_ih => - cases Hin <;> simp_all - cases fn_ih <;> simp_all - cases e_ih <;> simp_all -case quant k ty tr_ih e_ih => - cases Hin <;> simp_all - cases tr_ih <;> simp_all - cases e_ih <;> simp_all -case ite c t e c_ih t_ih e_ih => - cases Hin with - | inl Hin => cases (c_ih Hin) <;> simp_all - | inr Hin => - cases Hin with - | inl Hin => cases (t_ih Hin) <;> simp_all - | inr Hin => cases (e_ih Hin) <;> simp_all -case eq fn e fn_ih e_ih => - cases Hin <;> simp_all - cases fn_ih <;> simp_all - cases e_ih <;> simp_all - -theorem Lambda.LExpr.substFvarsCorrect : - WellFormedCoreEvalCong δ → - Imperative.WellFormedSemanticEvalVar (P:=Expression) δ → - Imperative.WellFormedSemanticEvalVal (P:=Expression) δ → - fro.length = to.length → - Imperative.substDefined σ σ' (fro.zip to) → - Imperative.substNodup (fro.zip to) → - Imperative.substStores σ σ' (fro.zip to) → - to.Disjoint (@Imperative.HasVarsPure.getVars Expression _ _ e) → - Imperative.invStores σ σ' - ((@Imperative.HasVarsPure.getVars Expression _ _ e).removeAll (fro ++ to)) → - δ σ e = δ σ' (e.substFvars (fro.zip $ createFvars to)) := by - intros Hwfc Hwfvr Hwfvl Hlen Hdef Hnd Hsubst Hnin Hinv - induction fro generalizing to σ σ' e - case nil => - simp_all - have Hemp : to = [] := by - apply List.eq_nil_of_length_eq_zero (Eq.symm Hlen) - simp [Hemp] at * - simp [Lambda.LExpr.substFvars] - exact substFvarsCorrectZero Hwfc Hwfvr Hwfvl Hinv - case cons h t ih => - cases to with - | nil => simp_all - | cons h' t' => - simp [Lambda.LExpr.substFvars] at * - simp [createFvars] at * - have Hsubst1 := substStoresCons' Hnd Hdef Hsubst - cases Hsubst1 with - | intro σ₁ Hsubst1 => - cases Hsubst1 with - | intro v₁ Hsubst1 => - cases Hsubst1 with - | intro Hsome Hsubst1 => - cases Hsubst1 with - | intro Hstore Hsubst1 => - cases Hsubst1 with - | intro Hsubst' Hsubst1 => - -- the old store can stay unchanged since it is irrelevant - rw [substFvarCorrect (e := e) Hwfc Hwfvr Hwfvl Hsubst'] <;> simp_all - rw [ih] <;> try simp_all - . refine substDefined_updatedState ?_ - exact substDefined_tail Hdef - . simp [Imperative.substNodup] at Hnd ⊢ - have Hnd2 := nodup_middle Hnd.2 - simp_all - . -- Disjoint - intros a' Hin Hin2 - have Hor := getVarsSubstCreateFvar Hin2 - cases Hor <;> simp_all - next Hin3 => - apply @Hnin a' ?_ ?_ - exact List.mem_cons_of_mem h' Hin - exact Hin3 - next Heq => - apply @Hnin h' ?_ ?_ - simp_all - exfalso - have Hht := substNodup_ht Hlen Hnd - simp_all - . -- invStores from σ₁ to σ' - rw [subst_create_replace] - apply invStoresSubstTail Hsubst Hsubst1 Hsome ?_ Hinv - . simp [Imperative.substNodup] at Hnd - simp_all - . simp [List.Disjoint] at Hnin - exact invStoresSubstHead Hsubst' Hnin.1 - -/- -theorem createAssertsCorrect : - Imperative.WellFormedSemanticEvalBool δ → - Imperative.WellFormedSemanticEvalVar δ → - Imperative.WellFormedSemanticEvalVal δ → - -- TODO: remove congruence of old expressions, and require pre to contain no old expressions - Core.WellFormedCoreEvalCong δ → - ks.length = ks'.length → - Imperative.substNodup (ks.zip ks') → - Imperative.substDefined σA σ' (ks.zip ks') → - (∀ pre, pre ∈ pres → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) pre).removeAll (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) pre) ∧ - δ σA pre = some Imperative.HasBool.tt) → - EvalExpressions δ σ (createFvars ks') vals → - ReadValues σA ks vals → - Imperative.substStores σ' σA (ks'.zip ks) → - EvalStatementsContract π φ δ σ' (createAsserts pres (ks.zip (createFvars ks'))) σ' δ := by - intros Hwfb Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hpres Heval Hrd Hsubst2 - simp [createAsserts] - -- Make index parameter `i` explicit so that we can induct generalizing `i`. - suffices h : ∀ (i : Nat) (l : List Expression.Expr), - (∀ pre, pre ∈ l → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) pre).removeAll (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) pre) ∧ - δ σA pre = some Imperative.HasBool.tt) → - EvalStatementsContract π φ δ σ' - (List.mapIdx (fun j pred => Statement.assert s!"assert_{i + j}" - (Lambda.LExpr.substFvars pred (ks.zip (createFvars ks')))) l) σ' δ - by - have := @h 0 pres Hpres - simp at this; exact this - intros i l Hl - induction l generalizing i - case nil => - simp; constructor - case cons st sts ih => - simp; constructor; constructor; constructor; constructor - specialize Hl st (by simp) - . have Heq : δ σA st = δ σ' (Lambda.LExpr.substFvars st (ks.zip (createFvars ks'))) := by - apply Lambda.LExpr.substFvarsCorrect Hwfc Hwfvr Hwfvl Hlen Hdef Hnd ?_ Hl.2.1 Hl.1 - . apply Imperative.substStoresFlip' - simp [Imperative.substSwap, zip_swap] - assumption - simp [Imperative.WellFormedSemanticEvalBool] at Hwfb - rw [← Heq] - exact Hl.2.2 - . assumption - . simp [Imperative.isDefinedOver, Command.modifiedVars, - Imperative.Cmd.modifiedVars, - Imperative.HasVarsImp.modifiedVars, - Imperative.isDefined] - . have ih' := ih (i + 1) - ac_nf at ih' - apply ih' - intros pre Hin - simp_all - -theorem createAssumesCorrect : - Imperative.WellFormedSemanticEvalBool δ → - Imperative.WellFormedSemanticEvalVar δ → - Imperative.WellFormedSemanticEvalVal δ → - Core.WellFormedCoreEvalCong δ → - ks.length = ks'.length → - Imperative.substNodup (ks.zip ks') → - Imperative.substDefined σA σ' (ks.zip ks') → - (∀ post, post ∈ posts → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) post).removeAll (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) post) ∧ - δ σA post = some Imperative.HasBool.tt) → - Imperative.substStores σA σ' (ks.zip ks') → - EvalStatementsContract π φ δ σ' (createAssumes posts (ks.zip (createFvars ks'))) σ' δ := by - intros Hwfb Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hposts Hsubst2 - simp [createAssumes] - -- Make index parameter `i` explicit so that we can induct generalizing `i`. - suffices h : ∀ (i : Nat) (l : List Expression.Expr), - (∀ post, post ∈ l → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) post).removeAll (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) post) ∧ - δ σA post = some Imperative.HasBool.tt) → - EvalStatementsContract π φ δ σ' - (List.mapIdx (fun j pred => Statement.assume s!"assume_{i + j}" - (Lambda.LExpr.substFvars pred (ks.zip (createFvars ks')))) l) σ' δ - by - have := @h 0 posts Hposts - simp at this; exact this - intros i l Hl - induction l generalizing i - case nil => - simp; constructor - case cons st sts ih => - simp ; constructor ; constructor ; constructor ; constructor - specialize Hl st (by simp) - . have Heq : δ σA st = δ σ' (Lambda.LExpr.substFvars st (ks.zip (createFvars ks'))) := by - apply Lambda.LExpr.substFvarsCorrect Hwfc Hwfvr Hwfvl Hlen Hdef Hnd Hsubst2 Hl.2.1 Hl.1 - rw [← Heq] - exact Hl.2.2 - . assumption - . simp [Imperative.isDefinedOver, Command.modifiedVars, - Imperative.Cmd.modifiedVars, - Imperative.HasVarsImp.modifiedVars, - Imperative.isDefined] - . have ih' := ih (i + 1) - ac_nf at ih' - apply ih' - intros post Hin - simp_all - -theorem SubstPostsMem : - substPost ∈ OldExpressions.substsOldExprs (createOldVarsSubst oldTrips) - (OldExpressions.normalizeOldExprs vs) → - ∃ post, post ∈ vs ∧ - substPost = OldExpressions.substsOldExpr (createOldVarsSubst oldTrips) (OldExpressions.normalizeOldExpr post) - := by - intros Hin - generalize Heq : OldExpressions.substsOldExprs - (createOldVarsSubst oldTrips) - (OldExpressions.normalizeOldExprs vs) = l at * - cases vs <;> simp [OldExpressions.normalizeOldExprs, - OldExpressions.substsOldExprs] at * - case nil => simp_all - case cons h t => - simp [← Heq] at * - cases Hin with - | inl Hin => - left; assumption - | inr Hin => - right - cases Hin with - | intro id HH => exact ⟨id, HH.1, Eq.symm HH.2⟩ --/ - -/-- -Generate the substitution pairs needed for the body of the procedure --/ -def createOldStoreSubst - (trips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)) - : List (Expression.Ident × Expression.Ident) := - trips.map go where go - | ((v', _), v) => (v, v') - -theorem createOldStoreSubstEq : - createOldStoreSubst oldTrips = - oldTrips.unzip.2.zip oldTrips.unzip.1.unzip.1 := by - induction oldTrips <;> simp [createOldStoreSubst, createOldStoreSubst.go] at * - case cons h t ih => exact ih - -theorem substOldCorrect : - Imperative.WellFormedSemanticEvalVar δ → - Imperative.WellFormedSemanticEvalVal δ → - Core.WellFormedCoreEvalCong δ → - Core.WellFormedCoreEvalTwoState δ σ₀ σ → - OldExpressions.NormalizedOldExpr e → - --Imperative.invStores σ₀ σ - -- ((OldExpressions.extractOldExprVars e).removeAll [fro]) → - Imperative.substDefined σ₀ σ [(fro, to)] → - Imperative.substStores σ₀ σ [(fro, to)] → - -- substitute the store and the expression simultaneously - δ σ e = δ σ (OldExpressions.substOld fro (createFvar to) e) := by - intros Hwfvr Hwfvl Hwfc Hwf2 Hnorm Hdef Hsubst - induction e <;> simp [OldExpressions.substOld] at * - case abs m ty e ih => - cases Hnorm with - | abs Hnorm => - apply Hwfc.1 - apply ih Hnorm - case quant m k ty tr e trih eih => - cases Hnorm with - | quant Ht He => - specialize eih He - specialize trih Ht - apply Hwfc.quantcongr <;> grind - case app m c fn fih eih => - cases Hnorm with - | app Hc Hfn Hwf => - specialize fih Hc - specialize eih Hfn - split - . -- is an old var - split - . -- is an old var that is substituted - next x ty eq => - simp [eq] at * - simp [WellFormedCoreEvalTwoState] at Hwf2 - cases Hwf2.1 with - | intro vs Hwf2' => - cases Hwf2' with - | intro vs' Hwf2' => - cases Hwf2' with - | intro σ₁ Hwf2' => - by_cases Hin : fro ∈ vs - case pos => - -- old var is modified - have HH:= Hwf2.2.1 vs vs' σ₀ σ₁ σ Hwf2'.1 Hwf2'.2 fro - simp [OldExpressions.oldVar, - OldExpressions.oldExpr, - CoreIdent.unres, Hin] at HH - rw [HH] - simp [createFvar] - simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr - rw [Hwfvr (v:=to)] - apply Hsubst - exact List.mem_singleton.mpr rfl - simp [Imperative.HasFvar.getFvar] - case neg => - -- old var is not modified - have Hup := HavocVarsUpdateStates Hwf2'.1 - cases Hup with - | intro as Hup => - have Hinit := InitVarsInitStates Hwf2'.2 - cases Hinit with - | intro bs Hinit => - have Hsubst' := substStoresUpdatesInv' ?_ Hsubst Hup - have Hsubst'' := substStoresInitsInv' ?_ Hsubst' Hinit - . have HH:= Hwf2.2.1 vs vs' σ₀ σ₁ σ Hwf2'.1 Hwf2'.2 fro - simp [OldExpressions.oldVar, - OldExpressions.oldExpr, - CoreIdent.unres, Hin] at HH - simp [createFvar] - simp [HH] - simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr - rw [Hwfvr (v:=to)] - . simp [Imperative.substStores] at Hsubst'' - exact Hsubst'' - . simp [Imperative.HasFvar.getFvar] - . simp [Imperative.substDefined] at * - have Hdef' : Imperative.isDefined σ₀ [fro] := by - simp [Imperative.isDefined] - exact Hdef.1 - have Hdef'' := UpdateStatesDefMonotone Hdef' Hup - simp [Imperative.isDefined] at Hdef'' - refine ⟨Hdef'', Hdef.2⟩ - . simp [List.Disjoint] - intros a Hin Heq - simp [Heq] at * - contradiction - . -- is an old var that is not substituted, use congruence - rename_i e1 e2 mOp ty0 mVar x ty1 h - simp at m mOp ty0 mVar x ty1 - apply Hwfc.appcongr <;> grind - . -- is not an old var, use congruence - apply Hwfc.appcongr <;> grind - case ite m c t e cih tih eih => - cases Hnorm with - | ite Hc Ht He => - specialize cih Hc - specialize tih Ht - specialize eih He - apply Hwfc.itecongr <;> grind - case eq m e1 e2 e1ih e2ih => - cases Hnorm with - | eq He1 He2 => - specialize e2ih He2 - apply Hwfc.eqcongr <;> grind - - --- Needed from refinement theorem --- UpdateState P✝ σ id v✝ σ'✝ --- Ht : TouchVars σ'✝ l₂ σ'' --- ⊢ TouchVars σ l₂ σ'' - -theorem UpdateStatesUpdatedId : -k ∈ vs → -UpdateStates σ₀ vs vs' σ₁ → -UpdateStates (updatedState σ₀ k v) vs vs' σ₁ := by -intros Hin Hup -have Hlen := UpdateStatesLength Hup -induction vs generalizing vs' σ₀ σ₁ k v <;> simp_all -case cons h t ih => - cases vs' - case nil => simp_all - case cons h' t' => - cases Hup with - | update_some Hup Hups => - next σ'' => - cases Hin with - | inl Heq => - -- the head is overwritten - simp [Heq] at * - apply UpdateStates.update_some (σ':=σ'') ?_ Hups - constructor - . simp [updatedState] + exact ⟨[], γ, by simp [List.mapM_nil, pure, ExceptT.pure, StateT.pure, ExceptT.mk], + rfl, [], rfl, by simp⟩ + | cons head rest ih => + obtain ⟨l, check⟩ := head + -- Head: genIdent always succeeds, producing a label and updated state. + cases hgi : Core.Transform.genIdent l (fun s => s!"{labelPrefix}{s}") γ.genState with + | mk newLabel γgen' => + -- The post-genIdent CoreTransformState (genState updated, rest preserved). + let γhead : CoreTransformState := + { genState := γgen', + currentProgram := γ.currentProgram, + currentProcedureName := γ.currentProcedureName, + cachedAnalyses := γ.cachedAnalyses, + factory := γ.factory, + statistics := γ.statistics } + obtain ⟨asserts', γ'', Heqtail, Hlen, labelsTail, HlblsLen, Hshape⟩ := ih (γ := γhead) + refine ⟨Statement.assert newLabel.toPretty + (Lambda.LExpr.substFvars check.expr subst) + (check.md.setCallSiteFileRange md) :: asserts', γ'', ?_, ?_, ?_⟩ + · -- Reduce both sides to the same `List.mapM` core, then chain via Heqtail. + -- Apply the same simp set on both the goal and Heqtail so the inner-mapM + -- shape matches. + simp only [List.mapM_cons, bind, ExceptT.bind, ExceptT.bindCont, + ExceptT.mk, ExceptT.lift, ExceptT.pure, + StateT.bind, StateT.pure, pure, + monadLift, MonadLift.monadLift, liftM, + Functor.map, StateT.map, liftCoreGenM, hgi] + bind_shell_state at Heqtail + rw [Heqtail] rfl - . cases Hup - assumption - . intros y Hne - simp [updatedState] - cases Hup - split <;> simp_all - | inr Heq => - -- a part of the tail is overwritten - cases Hup with - | update Hsome Hall Hsome' => - next v' => - by_cases Heq : h = k - case pos => - -- both the tail and head are overwritten - simp [Heq] at * - apply UpdateStates.update_some (σ':=(updatedState σ'' k h')) - . constructor - . simp [updatedState] - rfl - . simp [updatedState] - . intros y Hne - simp [updatedState] - split <;> simp_all - . apply ih <;> simp_all - case neg => - -- only the tail is overwritten - apply UpdateStates.update_some (σ':=(updatedState σ'' k v)) - . constructor - . simp [updatedState] - simp_all - rfl - . simp [updatedState] - simp_all - . intros y Hne - simp [updatedState] - split <;> simp_all - . apply ih <;> simp_all - -theorem InitVarsRemoveAll {P: Imperative.PureExpr} [BEq P.Ident] [LawfulBEq P.Ident] - {σ σ' : Imperative.SemanticStore P} - {k : P.Ident} {v : P.Expr} {vs : List P.Ident} : - σ' k = some v → - InitVars σ vs σ' → - InitVars (updatedState (P:=P) σ k v) (List.removeAll vs [k]) σ' := by -intros Hsome Hinit -have HinitSt := InitVarsInitStates Hinit -cases HinitSt with -| intro mv HinitSt => -have Hnd := InitStatesNodup HinitSt -clear HinitSt -induction vs generalizing σ σ' k v -case nil => - simp_all - simp [InitVarsEmpty Hinit] at * - rw [updatedStateId] <;> simp_all -case cons h t ih => - cases Hinit with - | init_some Hinit Hinits - next vv σ₁ => - simp only [List.cons_removeAll] - split - -- the initialized variable h is not the same as the updated variable k - . next Hne => - simp_all - apply InitVars.init_some (σ':=(updatedState (updatedState σ k v) h vv)) - apply updatedStateInit - . simp [updatedState] - split <;> simp_all - cases Hinit - assumption - . rw [updatedStateComm] - apply ih Hsome - have Heq := InitStateUpdated Hinit <;> simp_all - exact fun a => Hne (Eq.symm a) - -- the initialized variable h *is* the same as the updated variable k - . next Heq => - -- assert that v = vv, since it has been initialized - have Heq' : σ₁ k = some v := by - have Hinitst := InitVarsInitStates Hinits - cases Hinitst - case intro t' Hinitst => - apply InitStatesSomeMonotone' ?_ Hsome - apply Hinitst - simp_all - have Heq'' : σ₁ k = some vv := by - have Hrd := InitStateReadValues Hinit - cases Hrd <;> simp_all - simp_all - have Heq''' : (updatedState σ k v) = (updatedState σ₁ k v) := by - funext x - simp [updatedState] - split <;> simp_all - next Hne => - cases Hinit with - | init Hnone Hsome Hall => - rw [Hall] - exact fun a => Hne (Eq.symm a) - simp_all - -theorem updatedStateOldWellFormedCoreEvalTwoState : - σ k = some v → - WellFormedCoreEvalTwoState δ σ₀ σ → - WellFormedCoreEvalTwoState δ (updatedState σ₀ k v) σ := by - intros Hsome Hwf2 - simp [WellFormedCoreEvalTwoState] at * - refine ⟨?_, Hwf2.2⟩ - cases Hwf2.1 with - | intro vs Hwf2 => - cases Hwf2 with - | intro vs' Hwf => - cases Hwf with - | intro σ₁ Hwf => - by_cases Hin : k ∈ vs - -- k is already in vs, use the mod/init lists as is - case pos => - refine ⟨vs,vs',σ₁,?_,Hwf.2⟩ - have Hup := HavocVarsUpdateStates Hwf.1 - cases Hup with - | intro vs' Hup => - apply UpdateStatesHavocVars (modvals:=vs') - exact UpdateStatesUpdatedId Hin Hup - -- k is not in vs, add k to vs - case neg => - by_cases Hin' : k ∈ vs' - -- k not in vs, but is in vs'. - -- This is the case that k is a newly created variable - -- Since we are updating/initializing k in σ₀, we remove k from vs' - case pos => - refine ⟨vs,vs'.removeAll [k],(updatedState σ₁ k v),?_,?_⟩ - . refine HavocVarsUpdatedDist Hin ?_ - exact Hwf.1 - . apply InitVarsRemoveAll <;> simp_all - -- k is not in vs' - case neg => - have Hup := HavocVarsUpdateStates Hwf.1 - cases Hup with - | intro es' Hup => - refine ⟨k :: vs,vs',σ₁,?_,Hwf.2⟩ - have Hdef1 : Imperative.isDefined σ₁ [k] := by - apply InitVarsDefMonotone' (σ':=σ) (vs':=vs') <;> simp_all - . simp_all [List.Disjoint] - . simp [Imperative.isDefined, Option.isSome] - split <;> simp_all - have Hdef0 : Imperative.isDefined σ₀ [k] := by - exact HavocVarsDefMonotone' (vs':=vs) Hdef1 Hwf.1 - simp [Imperative.isDefined, Option.isSome] at Hdef0 - split at Hdef0 <;> simp_all - next x val heq => - apply UpdateStatesHavocVars (modvals:=val :: es') - refine UpdateStatesUpdatedId ?_ ?_ - . exact List.mem_cons_self - . apply UpdateStates.update_some (σ':=updatedState σ₀ k val) - apply updatedStateUpdate <;> assumption - rw [updatedStateId] <;> simp_all - -open OldExpressions in -theorem substOld_create_replace : -NormalizedOldExpr e → -(extractOldExprVars (substOld h (createFvar h') e)) = -(extractOldExprVars e).removeAll [h] := by - intros Hnorm - induction Hnorm <;> simp [extractOldExprVars, createFvar, substOld] at * <;> try assumption - case app fn e m Hnfn Hne Hwf ih1 ih2 => - split - . -- is old var - next e1 e2 ty x ty => - split <;> simp [extractOldExprVars, List.removeAll] <;> simp_all - . -- is a normal expression (non-old) - next e1 e2 HH => - have Hnold : ¬ IsOldPred fn := by - intros Hold - specialize Hwf Hold - cases Hold - cases Hwf - simp_all - simp [CoreIdent.unres] at HH - rename_i md tyy id v - have HH2 := HH md tyy () id v - simp_all - have Hnold' : ¬ IsOldPred (substOld h (Lambda.LExpr.fvar () h' none) fn) := by - intros Hold - apply Hnold - apply substOldIsOldPred' ?_ Hold - intros Hold - cases Hold - unfold extractOldExprVars - simp - split <;> simp_all - . -- old var, contradiction - exfalso; apply Hnold'; constructor - . -- old expr, contradiction - exfalso; apply Hnold'; constructor - split - · rename_i x1 x2 x3 m1 id ty2 x7 - have hI: Lambda.LExpr.op x2 ⟨"old", Visibility.unres⟩ x3 = Lambda.LExpr.op x2 ⟨"old", Visibility.unres⟩ x3 := by rfl - have hI2: Lambda.LExpr.fvar m1 id ty2 = Lambda.LExpr.fvar m1 id ty2 := by rfl - have h2 := HH x2 x3 m1 id ty2 hI hI2 - exfalso - contradiction - . -- old expr, contradiction - exfalso; apply Hnold; constructor - . simp [List.app_removeAll] - case ite c t e cih tih eih => - rw [cih, tih, eih] - simp [List.app_removeAll] - case eq e1 e2 e1ih e2ih => - rw [e1ih, e2ih] - simp [List.app_removeAll] - case quant tr e trih eih => - rw [trih, eih] - simp [List.app_removeAll] - -theorem substOldExpr_cons: - Imperative.substNodup (createOldStoreSubst (h::t)) → - OldExpressions.substsOldExpr (createOldVarsSubst (h :: t)) e - = OldExpressions.substsOldExpr (createOldVarsSubst t) (OldExpressions.substOld h.snd (createFvar h.1.fst) e) :=by - intro Hnd - induction e - case app Hfn He => - simp [OldExpressions.substsOldExpr, createOldVarsSubst, Map.isEmpty, OldExpressions.substOld, createFvar] - split; split; split - simp [OldExpressions.substOld, createFvar,Map.find? , *, createOldVarsSubst.go] at * - rename_i H; simp [← H, OldExpressions.substsOldExpr] - simp_all [OldExpressions.substOld, createFvar,Map.find?, createOldVarsSubst.go] - rename_i H _; split at H <;> simp_all [OldExpressions.substsOldExpr] - intro; simp_all [Map.isEmpty]; rename_i H; split at H <;> simp_all [Map.find?] - split <;> (rename_i H _; simp [*, createOldVarsSubst.go, Map.find?] at H) - split at H; contradiction - unfold OldExpressions.substsOldExpr - split <;> simp [*] - simp_all [createOldVarsSubst, createFvar] - rename_i _ fn e _ _ H - generalize H1: (OldExpressions.substOld h.snd (Lambda.LExpr.fvar () h.fst.fst none) fn) = fn' - generalize H2: (OldExpressions.substOld h.snd (Lambda.LExpr.fvar () h.fst.fst none) e) = e' - rw (occs := [3]) [Core.OldExpressions.substsOldExpr.eq_def] - simp; split - simp_all [Map.isEmpty]; rename_i H; split at H <;> simp_all - rw[OldExpressions.substOldExpr_nil, OldExpressions.substOldExpr_nil]; simp - split; split - unfold OldExpressions.substOld at H1 - split at H1 <;> simp_all - unfold OldExpressions.substOld at H2 - split at H2 <;> simp_all; grind - split at H2; split at H2 - any_goals simp_all - simp [← H2.left] at * - have : Map.find? (List.map createOldVarsSubst.go t) h.fst.fst = none :=by - simp [Imperative.substNodup, createOldStoreSubst, createOldStoreSubst.go] at Hnd - have Hnd := Hnd.right - have : List.map (Prod.fst ∘ createOldStoreSubst.go) t = List.map (Prod.fst ∘ createOldVarsSubst.go) t := by - simp [createOldStoreSubst.go, createOldVarsSubst.go] - have : ¬ h.fst.fst ∈ List.map (Prod.fst ∘ createOldVarsSubst.go) t := by - rw[← this] - rw [List.nodup_append] at Hnd - false_or_by_contra - have Hnd := Hnd.right.right h.fst.fst (by assumption) h.fst.fst (by simp) - contradiction - apply Map.findNone_eq_notmem_mapfst.mp - simp only [List.map_map] - assumption - simp_all - split at H1 <;> try simp_all - split at H1 <;> try simp_all - simp [OldExpressions.substsOldExpr] - any_goals simp [OldExpressions.substsOldExpr, OldExpressions.substOld, createOldVarsSubst, Map.isEmpty] - any_goals (split <;> rename_i H; split at H) - any_goals (simp_all [createOldVarsSubst]; rw [OldExpressions.substOldExpr_nil]) - any_goals simp_all - any_goals (split at H <;> try contradiction) - any_goals simp_all [createOldVarsSubst] - any_goals rw [OldExpressions.substOldExpr_nil] - simp [createFvar]; rw [OldExpressions.substOldExpr_nil] - -theorem substsOldCorrect : - Imperative.WellFormedSemanticEvalVar δ → - Imperative.WellFormedSemanticEvalVal δ → - Core.WellFormedCoreEvalCong δ → - Core.WellFormedCoreEvalTwoState δ σ₀ σ → - OldExpressions.NormalizedOldExpr e → - Imperative.substStores σ₀ σ (createOldStoreSubst oldTrips) → - Imperative.substDefined σ₀ σ (createOldStoreSubst oldTrips) → - Imperative.substNodup (createOldStoreSubst oldTrips) → - oldTrips.unzip.1.unzip.1.Disjoint (OldExpressions.extractOldExprVars e) → - δ σ e = δ σ (OldExpressions.substsOldExpr (createOldVarsSubst oldTrips) e) := by - intros Hwfvr Hwfvl Hwfc Hwf2 Hnorm Hsubst Hdef Hnd Hdisj - induction oldTrips generalizing e - case nil => - simp [createOldVarsSubst] at *; rw[OldExpressions.substOldExpr_nil] - case cons h t ih => - have : OldExpressions.substsOldExpr (createOldVarsSubst (h :: t)) e - = OldExpressions.substsOldExpr (createOldVarsSubst t) (OldExpressions.substOld h.snd (createFvar h.1.fst) e) :=by - apply substOldExpr_cons Hnd - rw[this, ← ih] - apply substOldCorrect <;> try assumption - intro k1 k2 Hin - simp [Imperative.substDefined] at Hdef - apply Hdef; simp_all [createOldStoreSubst, createOldStoreSubst.go] - intro k1 k2 Hin - simp [Imperative.substStores] at Hsubst - apply Hsubst; simp_all [createOldStoreSubst, createOldStoreSubst.go] - apply OldExpressions.substOldNormalizedMono - intro H; cases H; assumption; - constructor - intro k1 k2 Hin - simp [Imperative.substStores] at Hsubst - apply Hsubst; simp_all [createOldStoreSubst, createOldStoreSubst.go] - exact substDefined_tail Hdef - simp [createOldStoreSubst] at * - exact substNodup_tail Hnd - simp at Hdisj - rw [substOld_create_replace] <;> try assumption - have H:= List.Disjoint.removeAll (zs:=[h.snd]) Hdisj - rw[← List.Disjoint_app] at H; - simp - exact List.Disjoint_cons_tail H.right - -theorem genArgExprIdent_len' : (List.mapM (fun _ => genArgExprIdent) t s).fst.length = t.length := by - induction t generalizing s <;> simp_all - case nil => - simp [pure, StateT.pure] - case cons h t ih => - simp [bind, StateT.bind, Functor.map] - split - simp [StateT.map, Functor.map] - apply ih - -theorem genArgExprIdent_len : List.mapM (fun _ => genArgExprIdent) t s = (a, s') → t.length = a.length := by - intros Hgen - generalize Heq : List.mapM (fun _ => genArgExprIdent) t s = res at Hgen - cases res with - | mk fst snd => - have Heq' : (List.mapM (fun _ => genArgExprIdent) t s).fst = fst := by simp [Heq] - cases Hgen - simp [← Heq'] - symm - exact genArgExprIdent_len' - -theorem genOutExprIdent_len' : (List.mapM genOutExprIdent t s).fst.length = t.length := by - induction t generalizing s <;> simp_all - case nil => - simp [pure, StateT.pure] - case cons h t ih => - simp [bind, StateT.bind, Functor.map] - split - simp [StateT.map, Functor.map] - apply ih - -theorem genOldExprIdent_len' : (List.mapM genOldExprIdent t s).fst.length = t.length := by - induction t generalizing s <;> simp_all - case nil => - simp [pure, StateT.pure] - case cons h t ih => - simp [bind, StateT.bind, Functor.map] - split - simp [StateT.map, Functor.map] - apply ih - -theorem getIdentTys!_len : - getIdentTys! p xs s = (Except.ok a,s') → - xs.length = a.length := by - intros H - induction xs generalizing s s' a <;> simp [getIdentTys!] at H - case nil => - cases H - rfl - case cons h t ih => - simp [bind, ExceptT.bind, StateT.bind, - ExceptT.bindCont, Functor.map, ExceptT.map, ExceptT.mk] at H - split at H - split at H - . simp [bind, StateT.bind] at H - split at H - split at H - . simp [pure, StateT.pure] at H - cases H - simp_all - apply ih - assumption - . cases H - . sorry - -- cases H -/- -theorem genOutExprIdent_len : List.mapM genOutExprIdent t s = (a, s') → t.length = a.length := by - intros Hgen - generalize Heq : List.mapM genOutExprIdent t s = res at Hgen - cases res with - | mk fst snd => - have Heq' : (List.mapM genOutExprIdent t s).fst = fst := by simp [Heq] - cases Hgen - simp [← Heq'] - symm - exact genOutExprIdent_len' - -theorem genArgExprIdentsTrip_snd : - genArgExprIdentsTrip tys args s = (Except.ok a, s') → - List.map Prod.snd a = args := by - intros Hgen - simp [genArgExprIdentsTrip] at Hgen - split at Hgen - . simp [Functor.map, liftM, monadLift, MonadLift.monadLift, ExceptT.lift, - ExceptT.mk, ExceptT.map, bind, StateT.bind] at Hgen - split at Hgen - split at Hgen <;> try cases Hgen - next x a heq => - simp [genArgExprIdents] at heq - induction args <;> simp_all - case cons h t ih => - simp [bind, List.replicate, StateT.bind, StateT.map] at heq - rw [List.map_snd_zip] - simp - split at heq - cases heq - next a' e' heq => - split at heq - split at heq - next a'' e'' heq'' => - cases heq - simp_all - have Hlen: t.length = (List.replicate t.length ()).length := by - solve | simp - rw [Hlen] - rw [genArgExprIdent_len (t:=List.replicate t.length ()) (a:=a'')] <;> try assumption - omega - . simp [throw, throwThe, MonadExceptOf.throw, ExceptT.mk, pure, StateT.pure] at Hgen - cases Hgen - -theorem genOutExprIdentsTrip_snd : - genOutExprIdentsTrip tys args s = (Except.ok a, s') → - List.map Prod.snd a = args := by - intros Hgen - simp [genOutExprIdentsTrip] at Hgen - split at Hgen - . simp [Functor.map, liftM, monadLift, MonadLift.monadLift, ExceptT.lift, - ExceptT.mk, ExceptT.map, bind, StateT.bind] at Hgen - split at Hgen - split at Hgen <;> try cases Hgen - next x a heq => - simp [genOutExprIdents] at heq - induction args <;> simp_all - case cons h t ih => - simp [bind, StateT.bind, Functor.map, StateT.map] at heq - rw [List.map_snd_zip] - simp - split at heq - cases heq - next a' e' heq => - split at heq - split at heq - next a'' e'' heq'' => - cases heq - simp_all - rw [genOutExprIdent_len (t:=t) (a:=a'')] <;> try assumption - simp_all - . simp [throw, throwThe, MonadExceptOf.throw, ExceptT.mk, pure, StateT.pure] at Hgen - cases Hgen - -theorem genOldExprIdentsTrip_snd : - genOldExprIdentsTrip p ids s = (Except.ok a, s') → - List.map Prod.snd a = ids := by - intros Hgen - simp [genOldExprIdentsTrip, Functor.map, liftM, monadLift, - MonadLift.monadLift, ExceptT.lift, ExceptT.mk, bind, pure, ExceptT.pure, ExceptT.bind, - StateT.bind, ExceptT.bindCont, StateT.map] at Hgen - split at Hgen - next heq => - split at Hgen - . simp [bind, StateT.bind, ExceptT.bindCont] at Hgen - split at Hgen - split at Hgen <;> try cases Hgen - next x a heq' => - split at heq <;> simp_all - next heq'' => - simp [genOldExprIdents] at heq'' - cases heq - have Hlen := genOldExprIdent_len' (t:=ids) (s:=s) - simp [heq''] at Hlen - rw [List.map_snd_zip] - simp [Hlen] - simp [getIdentTys!_len heq'] - . cases Hgen - -theorem Procedure.find.go_in_decls : - Program.find?.go DeclKind.proc name decls = some (Decl.proc proc md) → - Decl.proc proc md ∈ decls := by - intro Hsome - induction decls generalizing md <;> simp_all - case nil => cases Hsome - case cons h t ih => - simp [Program.find?.go] at Hsome - split at Hsome <;> simp_all - -theorem Procedure.find_in_decls : - Program.Procedure.find? p name = some proc → - ∃ md, .proc proc md ∈ p.decls := by - intros Hsome - simp only [Program.Procedure.find?] at Hsome - split at Hsome - case h_1 => - grind - case h_2 d heq => - simp only [Decl.getProc, Option.some.injEq] at Hsome - split at Hsome - case h_1 _ _ proc' md _ => - exists md - simp only [Hsome] at heq - exact find.go_in_decls heq - -theorem Program.find.go_decl_kind_match : - Program.find?.go d name decls = some decl → - decl.kind = d := by - intro Hsome - induction decls - case nil => cases Hsome - case cons h t ih => - simp [Program.find?.go] at Hsome - split at Hsome <;> simp_all - -theorem Program.find.go_decl_name_match : - Program.find?.go d name decls = some decl → - decl.name = name := by - intro Hsome - induction decls - case nil => cases Hsome - case cons h t ih => - simp [Program.find?.go] at Hsome - split at Hsome <;> simp_all - -theorem Program.find.go_var_in_decls : - Program.find?.go DeclKind.var name decls = some (Decl.var n ty e md) → - Decl.var n ty e md ∈ decls := by - intro Hsome - induction decls generalizing md <;> simp_all - case nil => cases Hsome - case cons h t ih => - simp [Program.find?.go] at Hsome - split at Hsome <;> simp_all - -theorem Program.find.var_in_decls : - Program.find? p DeclKind.var name = some decl → - ∃ ty e md, Decl.var name ty e md ∈ p.decls ∧ decl = Decl.var name ty e md := by - intros Hsome - cases decl - case var ty e md => - have H := go_decl_name_match Hsome - simp [Decl.name] at H - simp_all - refine ⟨ty,e,md,?_,?_⟩ - . apply go_var_in_decls (name:=name) - exact Hsome - . simp_all - case type | ax | distinct | proc | func => - simp [Program.find?] at Hsome - have HH := Program.find.go_decl_kind_match Hsome - simp [Decl.kind] at HH - -theorem WFProgGlob : - WF.WFDeclsProp p p.decls → - PredImplies (isGlobalVar p ·) (CoreIdent.isGlob ·) := by - intros Hwf x HH - simp [isGlobalVar, Option.isSome] at HH - split at HH <;> simp at HH - next x val heq => - have Hdecl := Program.find.var_in_decls heq - cases Hdecl with - | intro ty Hdecl => cases Hdecl with - | intro e Hdecl => cases Hdecl with - | intro md Hdecl => - have Hwfv := (List.Forall_mem_iff.mp Hwf) _ Hdecl.1 - exact Hwfv.1 - -theorem genOldExprIdentsEmpty : - genOldExprIdentsTrip p [] s = (Except.ok trips, cs') → trips = [] := by - intros Hgen - simp [genOldExprIdentsTrip, bind, pure, liftM, MonadLift.monadLift, ExceptT.lift, - ExceptT.bindCont, monadLift, ExceptT.bind, ExceptT.mk, StateT.bind, Functor.map] at Hgen - split at Hgen - split at Hgen - . simp [ExceptT.bindCont, ExceptT.pure, ExceptT.mk, pure, StateT.bind, bind] at Hgen - split at Hgen - split at Hgen <;> simp_all - . simp [StateT.pure,pure] at Hgen - cases Hgen - rfl - . simp [StateT.pure,pure] at Hgen - cases Hgen - . simp [StateT.pure,pure] at Hgen - cases Hgen - -theorem genOldExprIdentsFind : -(∀ l, l ∈ ls → (p.find? DeclKind.var l).isSome) → -genOldExprIdentsTrip p ls s_out = - (Except.ok oldTrips, cs) → -k ∈ oldTrips.unzip.snd → -(p.find? DeclKind.var k).isSome := by -intros Hfa Hgen Hin -induction ls generalizing oldTrips cs s_out <;> simp_all -case nil => - have Hempty := genOldExprIdentsEmpty Hgen - simp [Hempty] at * -case cons h t ih => - simp [genOldExprIdentsTrip, bind, pure, liftM, MonadLift.monadLift, ExceptT.lift, - ExceptT.bindCont, monadLift, ExceptT.bind, ExceptT.mk, StateT.bind, Functor.map] at Hgen - split at Hgen - split at Hgen - . next heq => - simp [ExceptT.bindCont, ExceptT.pure, ExceptT.mk, pure, StateT.bind, bind] at Hgen - split at Hgen - split at Hgen <;> simp_all - . simp [StateT.pure,pure] at Hgen - cases Hgen - cases Hin with - | intro a Hin => - cases Hin with - | intro b Hin => - have Hin := List.of_mem_zip Hin - simp at Hin - cases Hin.2 <;> simp_all - . simp [StateT.pure,pure] at Hgen - cases Hgen - . simp [StateT.pure,pure] at Hgen - cases Hgen - -/--! Theorems about well-formedness of CoreGen -/ - -theorem genArgExprIdentTemp : - genArgExprIdent s = (l, s') → CoreIdent.isTemp l := - fun Hgen => by exact genCoreIdentTemp Hgen - -theorem genOutExprIdentTemp : - genOutExprIdent e s = (l, s') → CoreIdent.isTemp l := - fun Hgen => genCoreIdentTemp Hgen - -theorem genCoreIdentGeneratedWF : - CoreGenState.gen pf s = (l, s') → s'.generated = l :: s.generated := by - intros Hgen - simp [CoreGenState.gen] at Hgen - rw [← Hgen.2] - simp_all - -theorem genIdentGeneratedWF : - genIdent ident pf s = (l, s') → s'.generated = l :: s.generated := - fun Hgen => genCoreIdentGeneratedWF Hgen - -theorem genArgExprIdentGeneratedWF : - genArgExprIdent s = (l, s') → s'.generated = l :: s.generated := - fun Hgen => genCoreIdentGeneratedWF Hgen - -theorem genArgExprIdentsGeneratedWF : - genArgExprIdents n s = (ls, s') → - ls.reverse ++ s.generated = s'.generated - := by - intros Hgen - simp [genArgExprIdents] at Hgen - induction n generalizing s ls s' - case zero => - rw [List.replicate_zero] at Hgen - simp [StateT.pure, pure] at Hgen - cases Hgen <;> simp_all - case succ n => - simp only [List.replicate] at Hgen - simp [bind, StateT.bind, pure] at Hgen - split at Hgen - next a s₁ heq => - split at Hgen - next a' s₂ heq' => - cases Hgen - have HH := genArgExprIdentGeneratedWF heq - grind - -theorem genArgExprIdentsTripGeneratedWF { s s' : CoreGenState } : - genArgExprIdentsTrip outs xs s = (Except.ok trips, s') → - trips.unzip.1.unzip.1.reverse ++ s.generated = s'.generated := by - intros Hgen - apply genArgExprIdentsGeneratedWF (n:=xs.length) - simp [genArgExprIdentsTrip] at * - split at Hgen - . simp [Functor.map, ExceptT.map, bind, - liftM, monadLift, MonadLift.monadLift, ExceptT.lift, - ExceptT.mk, StateT.bind] at Hgen - split at Hgen - split at Hgen - . next heq => - simp [pure, StateT.pure] at Hgen - cases Hgen - simp [StateT.map, Functor.map] at heq - cases heq - rw [← List.map_map] - rw [List.map_fst_zip] <;> try simp_all - rw [List.map_fst_zip] <;> try simp_all - . rfl - . simp [genArgExprIdents] - rw [genArgExprIdent_len'] <;> simp_all - . simp [genArgExprIdents] - rw [genArgExprIdent_len'] <;> simp_all - . simp [StateT.pure, pure] at Hgen - cases Hgen - . simp [throw, throwThe, MonadExceptOf.throw, - ExceptT.mk, StateT.pure, pure] at Hgen - cases Hgen - -theorem genArgExprIdentWFMono : - CoreGenState.WF s → - genArgExprIdent s = (l, s') → - CoreGenState.WF s' := - fun Hgen => CoreGenState.WFMono' Hgen - -theorem genArgExprIdentsWFMono : - CoreGenState.WF s → - genArgExprIdents n s = (ls, s') → - CoreGenState.WF s' := by - intros Hwf Hgen - simp [genArgExprIdents] at Hgen - induction n generalizing s ls s' - case zero => - simp [StateT.pure, pure] at Hgen - cases Hgen <;> simp_all - case succ n' => - simp only [List.replicate] at Hgen - simp [bind, StateT.bind, pure] at Hgen - split at Hgen - next a s₁ heq => - split at Hgen - next a' s₂ heq' => - cases Hgen - have HH := genArgExprIdentWFMono Hwf heq - grind - -theorem genArgExprIdentsTripWFMono : - CoreGenState.WF s → - genArgExprIdentsTrip outs xs s = (Except.ok trips, s') → - CoreGenState.WF s' := by - intros Hwf Hgen - simp [genArgExprIdentsTrip] at * - split at Hgen - . simp [Functor.map, ExceptT.map, bind, - liftM, monadLift, MonadLift.monadLift, ExceptT.lift, - ExceptT.mk, StateT.bind] at Hgen - split at Hgen - split at Hgen - . next a heq => - simp [pure, StateT.pure] at Hgen - cases Hgen - simp [StateT.map, Functor.map] at heq - generalize Hgen' : (genArgExprIdents xs.length s) = gen at heq - cases gen with - | mk fst snd => - simp at heq - cases heq - apply genArgExprIdentsWFMono Hwf Hgen' - . simp [StateT.pure, pure] at Hgen - cases Hgen - . simp [throw, throwThe, MonadExceptOf.throw, - ExceptT.mk, StateT.pure, pure] at Hgen - cases Hgen - -theorem genOutExprIdentGeneratedWF : - genOutExprIdent e s = (l, s') → s'.generated = l :: s.generated := - fun Hgen => genCoreIdentGeneratedWF Hgen - -theorem genOutExprIdentsGeneratedWF : - genOutExprIdents es s = (ls, s') → - ls.reverse ++ s.generated = s'.generated - := by - intros Hgen - simp [genOutExprIdents] at Hgen - induction es generalizing s ls s' <;> simp at Hgen - case nil => - simp [StateT.pure, pure] at Hgen - cases Hgen <;> simp_all - case cons h t ih => - simp [bind, StateT.bind, Functor.map, StateT.map, pure] at Hgen - split at Hgen - next a s₁ heq => - split at Hgen - next a' s₂ heq' => - cases Hgen - have HH := genOutExprIdentGeneratedWF heq - specialize ih heq' - simp [HH] at ih - simp_all - -theorem genOutExprIdentsTripGeneratedWF { s s' : CoreGenState } : - genOutExprIdentsTrip outs xs s = (Except.ok trips, s') → - trips.unzip.1.unzip.1.reverse ++ s.generated = s'.generated := by - intros Hgen - apply genOutExprIdentsGeneratedWF (es:=xs) - simp [genOutExprIdentsTrip] at * - split at Hgen - . simp [Functor.map, ExceptT.map, bind, - liftM, monadLift, MonadLift.monadLift, ExceptT.lift, - ExceptT.mk, StateT.bind] at Hgen - split at Hgen - split at Hgen - . next heq => - simp [pure, StateT.pure] at Hgen - cases Hgen - simp [StateT.map, Functor.map] at heq - cases heq - rw [← List.map_map] - rw [List.map_fst_zip] <;> try simp_all - rw [List.map_fst_zip] <;> try simp_all - . rfl - . simp [genOutExprIdents] - rw [genOutExprIdent_len'] <;> simp_all - . simp [genOutExprIdents] - rw [genOutExprIdent_len'] <;> simp_all - . simp [StateT.pure, pure] at Hgen - cases Hgen - . simp [throw, throwThe, MonadExceptOf.throw, - ExceptT.mk, StateT.pure, pure] at Hgen - cases Hgen - -theorem genOutExprIdentWFMono : - CoreGenState.WF s → - genOutExprIdent e s = (l, s') → - CoreGenState.WF s' := - fun Hgen => CoreGenState.WFMono' Hgen - -theorem genOutExprIdentsWFMono : - CoreGenState.WF s → - genOutExprIdents es s = (ls, s') → - CoreGenState.WF s' := by - intros Hwf Hgen - simp [genOutExprIdents] at Hgen - induction es generalizing s ls s' <;> simp at Hgen - case nil => - simp [StateT.pure, pure] at Hgen - cases Hgen <;> simp_all - case cons h t ih => - simp [bind, StateT.bind, Functor.map, StateT.map, pure] at Hgen - split at Hgen - next a s₁ heq => - split at Hgen - next a' s₂ heq' => - cases Hgen - have HH := genOutExprIdentWFMono Hwf heq - exact ih HH heq' - -theorem genOutExprIdentsTripWFMono : - CoreGenState.WF s → - genOutExprIdentsTrip outs xs s = (Except.ok trips, s') → - CoreGenState.WF s' := by - intros Hwf Hgen - simp [genOutExprIdentsTrip] at * - split at Hgen - . simp [Functor.map, ExceptT.map, bind, - liftM, monadLift, MonadLift.monadLift, ExceptT.lift, - ExceptT.mk, StateT.bind] at Hgen - split at Hgen - split at Hgen - . next a heq => - simp [pure, StateT.pure] at Hgen - cases Hgen - simp [StateT.map, Functor.map] at heq - generalize Hgen' : (genOutExprIdents xs s) = gen at heq - cases gen with - | mk fst snd => - simp at heq - cases heq - apply genOutExprIdentsWFMono Hwf Hgen' - . simp [StateT.pure, pure] at Hgen - cases Hgen - . simp [throw, throwThe, MonadExceptOf.throw, - ExceptT.mk, StateT.pure, pure] at Hgen - cases Hgen - -theorem genOldExprIdentGeneratedWF : - genOldExprIdent e s = (l, s') → s'.generated = l :: s.generated := - fun Hgen => genCoreIdentGeneratedWF Hgen - -theorem genOldExprIdentsGeneratedWF : - genOldExprIdents es s = (ls, s') → - ls.reverse ++ s.generated = s'.generated - := by - intros Hgen - simp [genOldExprIdents] at Hgen - induction es generalizing s ls s' <;> simp at Hgen - case nil => - simp [StateT.pure, pure] at Hgen - cases Hgen <;> simp_all - case cons h t ih => - simp [bind, StateT.bind, Functor.map, StateT.map, pure] at Hgen - split at Hgen - next a s₁ heq => - split at Hgen - next a' s₂ heq' => - cases Hgen - have HH := genOldExprIdentGeneratedWF heq - specialize ih heq' - simp [HH] at ih - simp_all - -theorem genOldExprIdentsTripGeneratedWF { s s' : CoreGenState } : - genOldExprIdentsTrip p xs s = (Except.ok trips, s') → - trips.unzip.1.unzip.1.reverse ++ s.generated = s'.generated := by - intros Hgen - apply genOldExprIdentsGeneratedWF (es:=xs) - simp [genOldExprIdentsTrip, bind, liftM,] at * - simp [Functor.map, ExceptT.bind, ExceptT.bindCont, bind, - monadLift, MonadLift.monadLift, ExceptT.lift, - ExceptT.mk, StateT.bind] at Hgen - split at Hgen - split at Hgen - . next heq => - simp [bind, StateT.bind] at Hgen - split at Hgen - next heq' => - simp [ExceptT.bindCont] at Hgen - split at Hgen - . cases Hgen - simp [StateT.map, Functor.map] at heq - cases heq - rw [← List.map_map] - rw [List.map_fst_zip] <;> try simp_all - rw [List.map_fst_zip] <;> try simp_all - rw [← getIdentTys!_store_same heq'] - congr - . simp [genOldExprIdents] - rw [← getIdentTys!_len heq'] - rw [genOldExprIdent_len'] <;> simp_all - . simp [genOldExprIdents] - rw [← getIdentTys!_len heq'] - rw [genOldExprIdent_len'] <;> simp_all - . cases Hgen - . cases Hgen - -theorem genOldExprIdentWFMono : - CoreGenState.WF s → - genOldExprIdent e s = (l, s') → - CoreGenState.WF s' := - fun Hgen => CoreGenState.WFMono' Hgen - -theorem genOldExprIdentsWFMono : - CoreGenState.WF s → - genOldExprIdents es s = (ls, s') → - CoreGenState.WF s' := by - intros Hwf Hgen - simp [genOldExprIdents] at Hgen - induction es generalizing s ls s' <;> simp at Hgen - case nil => - simp [StateT.pure, pure] at Hgen - cases Hgen <;> simp_all - case cons h t ih => - simp [bind, StateT.bind, Functor.map, StateT.map, pure] at Hgen - split at Hgen - next a s₁ heq => - split at Hgen - next a' s₂ heq' => - cases Hgen - have HH := genOldExprIdentWFMono Hwf heq - exact ih HH heq' - -theorem genOldExprIdentsTripWFMono : - CoreGenState.WF s → - genOldExprIdentsTrip outs xs s = (Except.ok trips, s') → - CoreGenState.WF s' := by - intros Hwf Hgen - simp [genOldExprIdentsTrip, bind, liftM,] at * - simp [Functor.map, ExceptT.bind, ExceptT.bindCont, bind, - monadLift, MonadLift.monadLift, ExceptT.lift, - ExceptT.mk, StateT.bind] at Hgen - split at Hgen - split at Hgen - . next heq => - simp [bind, StateT.bind] at Hgen - split at Hgen - next heq' => - simp [ExceptT.bindCont] at Hgen - split at Hgen - . cases Hgen - simp [StateT.map, Functor.map] at heq - cases heq - generalize Hgen' : (genOldExprIdents xs s) = gen at heq' - cases gen with - | mk fst snd => - rw [← getIdentTys!_store_same heq'] - exact genOldExprIdentsWFMono Hwf Hgen' - . cases Hgen - . cases Hgen - -private theorem List.Subset.trans : - List.Subset a b → b.Subset c → a.Subset c := fun H1 H2 _ Hin => H2 (H1 Hin) - -private theorem List.Subset.app : - List.Subset a c → b.Subset c → (a ++ b).Subset c := by - intros H1 H2 - intros x Hin - simp at Hin - cases Hin with - | inl Hin => - exact H1 Hin - | inr Hin => - exact H2 Hin - -open OldExpressions in -theorem extractedOldExprInVars : - NormalizedOldExpr post → - (extractOldExprVars post).Subset - (Imperative.HasVarsPure.getVars post) := by - intros Hnorm - induction post <;> - simp [Imperative.HasVarsPure.getVars, extractOldExprVars, - Lambda.LExpr.LExpr.getVars] at * <;> - try simp_all - case app fn e fn_ih e_ih => - unfold extractOldExprVars - split - . simp [Lambda.LExpr.LExpr.getVars] - intros x Hin - exact Hin - . next Hfalse => - cases Hnorm with - | app H1 H2 Hn => - exfalso - specialize Hn ?_ - constructor - cases Hn - apply Hfalse - rfl - . cases Hnorm with - | app H1 H2 Hn => - apply List.Subset.app - . apply List.Subset.trans - apply fn_ih - exact H1 - intros x Hin - simp_all - . apply List.Subset.trans - apply e_ih - exact H2 - intros x Hin - simp_all - case abs ih => - cases Hnorm - apply ih <;> assumption - case quant trih eih => - cases Hnorm - rename_i e_normalized - rename_i tr_normalized - rename_i tr e ty k - apply List.Subset.app - . apply List.Subset.trans - apply trih <;> assumption - intros x Hin - simp_all - . apply List.Subset.trans - apply eih <;> assumption - intros x Hin - simp_all - case ite cih tih eih => - cases Hnorm - apply List.Subset.app - . apply List.Subset.trans - apply cih <;> assumption - intros x Hin - simp_all - apply List.Subset.app - . apply List.Subset.trans - apply tih <;> assumption - intros x Hin - simp_all - . apply List.Subset.trans - apply eih <;> assumption - intros x Hin - simp_all - case eq ih1 ih2 => - cases Hnorm - apply List.Subset.app - . apply List.Subset.trans - apply ih1 <;> assumption - intros x Hin - simp_all - . apply List.Subset.trans - apply ih2 <;> assumption - intros x Hin - simp_all - -open OldExpressions in -theorem normalizeOldExprInVarsTrue: - (Lambda.LExpr.LExpr.getVars (normalizeOldExpr e true)).Subset - (Lambda.LExpr.LExpr.getVars (normalizeOldExpr e)) := by - induction e <;> - simp [normalizeOldExpr, Lambda.LExpr.LExpr.getVars] at * <;> - try simp_all - case app fn e fn_ih e_ih => - unfold normalizeOldExpr - split - split - split - . simp [Lambda.LExpr.LExpr.getVars] at * - intros x Hin - exact Hin - . intros x Hin - exact Hin - . simp [Lambda.LExpr.LExpr.getVars, normalizeOldExpr] at * - exact e_ih - . simp [Lambda.LExpr.LExpr.getVars] at * - apply List.Subset.app - . apply List.Subset.trans - apply fn_ih - intros x Hin - simp_all - . apply List.Subset.trans - apply e_ih - intros x Hin - simp_all - case fvar => intros x Hin; exact Hin - case ite cih tih eih => - apply List.Subset.app - . apply List.Subset.trans - apply cih <;> assumption - intros x Hin - simp_all - apply List.Subset.app - . apply List.Subset.trans - apply tih <;> assumption - intros x Hin - simp_all - . apply List.Subset.trans - apply eih <;> assumption - intros x Hin - simp_all - case quant k ty trih eih => - apply List.Subset.app - . apply List.Subset.trans - apply trih <;> assumption - intros x Hin - simp_all - . apply List.Subset.trans - apply eih <;> assumption - intros x Hin - simp_all - case eq ih1 ih2 => - apply List.Subset.app - . apply List.Subset.trans - apply ih1 <;> assumption - intros x Hin - simp_all - . apply List.Subset.trans - apply ih2 <;> assumption - intros x Hin - simp_all - -open OldExpressions in -theorem normalizeOldExprInVars : - (Imperative.HasVarsPure.getVars (P:=Expression) (normalizeOldExpr post)).Subset - (Imperative.HasVarsPure.getVars post) := by - induction post <;> - simp [normalizeOldExpr, - Imperative.HasVarsPure.getVars, - Lambda.LExpr.LExpr.getVars] at * <;> - try simp_all - case app fn e fn_ih e_ih => - unfold normalizeOldExpr - split - split - split - . simp [Lambda.LExpr.LExpr.getVars] at * - intros x Hin - exact Hin - . simp [Lambda.LExpr.LExpr.getVars] at * - apply List.Subset.trans - apply normalizeOldExprInVarsTrue - exact e_ih - . simp [Lambda.LExpr.LExpr.getVars, normalizeOldExpr] at * - exact e_ih - . simp [Lambda.LExpr.LExpr.getVars] at * - apply List.Subset.app - . apply List.Subset.trans - apply fn_ih - intros x Hin - simp_all - . apply List.Subset.trans - apply e_ih - intros x Hin - simp_all - case fvar => intros x Hin; exact Hin - case ite cih tih eih => - apply List.Subset.app - . apply List.Subset.trans - apply cih <;> assumption - intros x Hin - simp_all - apply List.Subset.app - . apply List.Subset.trans - apply tih <;> assumption - intros x Hin - simp_all - . apply List.Subset.trans - apply eih <;> assumption - intros x Hin - simp_all - case quant k ty trih eih => - apply List.Subset.app - . apply List.Subset.trans - apply trih <;> assumption - intros x Hin - simp_all - . apply List.Subset.trans - apply eih <;> assumption - intros x Hin - simp_all - case eq ih1 ih2 => - apply List.Subset.app - . apply List.Subset.trans - apply ih1 <;> assumption - intros x Hin - simp_all - . apply List.Subset.trans - apply ih2 <;> assumption - intros x Hin - simp_all - -open OldExpressions in -theorem extractedOldVarsInVars : - ValidExpression post → - (extractOldExprVars - (normalizeOldExpr post)).Subset - (Imperative.HasVarsPure.getVars post) := by - intros Hvalid - apply List.Subset.trans - . apply extractedOldExprInVars - exact normalizeOldExprSound Hvalid - . exact normalizeOldExprInVars - -open OldExpressions in -theorem substOldPostSubset: - (Imperative.HasVarsPure.getVars (P:=Expression) - (substOld h2 (Lambda.LExpr.fvar m h1 ty) post)).Subset - (Imperative.HasVarsPure.getVars (P:=Expression) post ++ [h1]) := by - induction post <;> simp [substOld] - case fvar => - intros x Hin - rename_i m name ty2 - simp at m - simp at name - simp at ty2 - - simp_all - case op => - intros x Hin - rename_i m name ty2 - simp at m - simp at name - simp at ty2 - simp_all - case const => - intros x Hin - rename_i m name - simp at m - simp_all - case bvar => - intros x Hin - rename_i m d - simp at m - simp_all - case abs ih => - exact ih - case ite cih tih eih => - simp [Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - apply List.Subset.app - . apply List.Subset.trans - apply cih <;> assumption - intros x Hin - simp_all - cases Hin <;> simp_all - apply List.Subset.app - . apply List.Subset.trans - apply tih <;> assumption - intros x Hin - simp_all - cases Hin <;> simp_all - . apply List.Subset.trans - apply eih <;> assumption - intros x Hin - simp_all - case app ih1 ih2 => - split - . split - . simp [Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - intros x Hin - simp_all - . simp [Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - intros x Hin - simp_all - . simp [Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - apply List.Subset.app - . apply List.Subset.trans - apply ih1 <;> assumption - intros x Hin - simp_all - cases Hin <;> simp_all - . apply List.Subset.trans - apply ih2 <;> assumption - intros x Hin - simp_all - case quant trih eih => - simp [Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - apply List.Subset.app - . apply List.Subset.trans - apply trih <;> assumption - intros x Hin - rename_i m1 k1 ty1 trigger1 e1 - have assoc := List.append_assoc (Lambda.LExpr.LExpr.getVars trigger1) (Lambda.LExpr.LExpr.getVars e1) [h1] - simp_all - cases Hin <;> simp_all - . apply List.Subset.trans - apply eih <;> assumption - intros x Hin - simp_all - case eq ih1 ih2 => - simp [Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * - apply List.Subset.app - . apply List.Subset.trans - apply ih1 <;> assumption - intros x Hin - simp_all - cases Hin <;> simp_all - . apply List.Subset.trans - apply ih2 <;> assumption - intros x Hin - simp_all - -theorem substOldExprPostSubset': - (Imperative.HasVarsPure.getVars (P:=Expression) - (OldExpressions.substsOldExpr [(h2, (Lambda.LExpr.fvar m h1 ty))] post)).Subset - (Imperative.HasVarsPure.getVars (P:=Expression) post ++ [h1]) := by - rw [OldExpressions.substsOldExpr_singleton] - apply substOldPostSubset - -theorem substOldExprPostSubset'': - (Imperative.HasVarsPure.getVars (P:=Expression) post ++ [h1]) ⊆ S → - (Imperative.HasVarsPure.getVars (P:=Expression) - (OldExpressions.substsOldExpr [(h2, (Lambda.LExpr.fvar m h1 ty))] post)) ⊆ S := by - have : (Imperative.HasVarsPure.getVars (P:=Expression) - (OldExpressions.substsOldExpr [(h2, (Lambda.LExpr.fvar m h1 ty))] post)).Subset - (Imperative.HasVarsPure.getVars (P:=Expression) post ++ [h1]) := substOldExprPostSubset' - apply List.Subset.trans this - -open OldExpressions in -theorem substOldExprPostSubset: - (Imperative.HasVarsPure.getVars (P:=Expression) - (substsOldExpr ((h2, (Lambda.LExpr.fvar m h1 ty))::t) post)).Subset - (Imperative.HasVarsPure.getVars (P:=Expression) (substsOldExpr t post) ++ [h1]) := by - induction post - any_goals (simp only [Imperative.HasVarsPure.getVars, substsOldExpr, Map.isEmpty, Bool.false_eq_true, ↓reduceIte, ite_self] at *; try apply List.subset_append_left) - any_goals (by_cases Hnil: t = [] <;> (simp only [Hnil]; simp only [Bool.false_eq_true, ↓reduceIte, Lambda.LExpr.LExpr.getVars]); try apply substOldExprPostSubset'; try assumption) - any_goals (try simp only [Hnil, List.append_assoc] at *; try rw [OldExpressions.substOldExpr_nil] at *) - any_goals (apply List.append_subset.mpr; constructor <;> try apply List.Subset.trans (by assumption); try apply List.append_subset.mpr; constructor) - any_goals (apply List.append_subset.mpr; constructor) - any_goals apply List.Subset.assoc.mp - any_goals (solve | apply List.Subset.subset_app_of_or_3; simp) - split <;> try split - any_goals (split <;> try split) - any_goals split - any_goals (simp [Map.find?] at *) - any_goals simp [Lambda.LExpr.LExpr.getVars] - any_goals (apply substOldExprPostSubset'') - any_goals (try apply List.Subset.trans (by assumption)) - any_goals (apply List.append_subset.mpr; constructor) - any_goals (repeat apply List.Subset.assoc.mp) - any_goals apply List.Subset.subset_app_of_or_4 - any_goals simp [Imperative.HasVarsPure.getVars] - rename_i H; simp [← H.right, Lambda.LExpr.LExpr.getVars] - constructor <;> (apply substOldExprPostSubset''; apply List.Subset.assoc.mp; apply List.append_subset.mpr; constructor <;> (apply List.Subset.subset_app_of_or_3; simp[Imperative.HasVarsPure.getVars])) - rename_i H _ _ _ - split at H <;> try contradiction - apply List.Subset.subset_app_of_or_2 - simp at H - simp [← H, Lambda.LExpr.LExpr.getVars] - simp_all - apply List.Subset.subset_app_of_or_2; simp - rename_i H _ _ - split at H <;> try contradiction - simp at H - simp [← H, Lambda.LExpr.LExpr.getVars, List.Subset] - simp_all - rename_i H _ _ _ - split at H <;> try contradiction - simp_all - unfold substsOldExpr; simp [Map.isEmpty, Lambda.LExpr.LExpr.getVars] - apply List.Subset.trans (by assumption) - any_goals (try apply List.Subset.trans (by assumption); apply List.append_subset.mpr <;> constructor) - apply List.append_subset.mpr; constructor - any_goals (try apply List.Subset.assoc.mp; apply List.Subset.subset_app_of_or_3; simp) - -open OldExpressions in -theorem substsOldPostSubset: - oldTrips.unzip.1.unzip.1.Disjoint oldTrips.unzip.2 → - (Imperative.HasVarsPure.getVars (substsOldExpr (createOldVarsSubst oldTrips) post)).Subset - (Imperative.HasVarsPure.getVars post ++ (oldTrips.unzip.1.unzip.1)) := by - intros Hdisj - induction oldTrips generalizing post <;> - simp [createFvar, createOldVarsSubst, createOldVarsSubst.go] at * - case nil => - intros x Hin - unfold substsOldExpr at Hin - simp [Map.isEmpty] at Hin - exact Hin - case cons h t ih => - have Hdisj: (List.map (Prod.fst ∘ Prod.fst) t).Disjoint (List.map Prod.snd t) := by - apply List.Disjoint_Subsets Hdisj <;> apply List.subset_cons_self - - have ih := @ih post Hdisj - have : (Imperative.HasVarsPure.getVars - (substsOldExpr ((h.snd, Lambda.LExpr.fvar () h.1.fst none) :: List.map createOldVarsSubst.go t) post)).Subset - ((Imperative.HasVarsPure.getVars (substsOldExpr (List.map createOldVarsSubst.go t) post)) ++ [h.1.fst]) := by - apply substOldExprPostSubset - apply List.Subset.trans this - apply List.Subset.app _ (by simp [List.Subset]) - apply List.Subset.trans ih - apply List.Subset.app - apply List.subset_append_left - apply List.subset_append_of_subset_right - apply List.subset_cons_self - + · simp [Hlen] + · refine ⟨newLabel.toPretty :: labelsTail, ?_, ?_⟩ + · simp [HlblsLen] + · simp only [List.zip_cons_cons, List.map_cons] + rw [Hshape] + +/-- No-throw fact for `Core.Transform.createAssumes`. Mirror of + `createAsserts_ok` for the assume case. Same `genIdent`-only + structure, same conclusion, same caveats about labels. -/ +private theorem createAssumes_ok + (conds : ListMap CoreLabel Procedure.Check) + (subst : Map Expression.Ident Expression.Expr) + (md : Imperative.MetaData Expression) + (labelPrefix : String) + (γ : CoreTransformState) : + ∃ (assumes : List Statement) (γ' : CoreTransformState), + Core.Transform.createAssumes conds subst md labelPrefix γ + = (Except.ok assumes, γ') ∧ + assumes.length = conds.length ∧ + ∃ (labels : List String), labels.length = conds.length ∧ + assumes = (conds.zip labels).map (fun (entry, lbl) => + Statement.assume lbl + (Lambda.LExpr.substFvars entry.snd.expr subst) + (entry.snd.md.setCallSiteFileRange md)) := by + unfold Core.Transform.createAssumes + induction conds generalizing γ with + | nil => + exact ⟨[], γ, by simp [List.mapM_nil, pure, ExceptT.pure, StateT.pure, ExceptT.mk], + rfl, [], rfl, by simp⟩ + | cons head rest ih => + obtain ⟨l, check⟩ := head + cases hgi : Core.Transform.genIdent l (fun s => s!"{labelPrefix}{s}") γ.genState with + | mk newLabel γgen' => + let γhead : CoreTransformState := + { genState := γgen', + currentProgram := γ.currentProgram, + currentProcedureName := γ.currentProcedureName, + cachedAnalyses := γ.cachedAnalyses, + factory := γ.factory, + statistics := γ.statistics } + obtain ⟨assumes', γ'', Heqtail, Hlen, labelsTail, HlblsLen, Hshape⟩ := ih (γ := γhead) + refine ⟨Statement.assume newLabel.toPretty + (Lambda.LExpr.substFvars check.expr subst) + (check.md.setCallSiteFileRange md) :: assumes', γ'', ?_, ?_, ?_⟩ + · -- Reduce both sides to the same `List.mapM` core, then chain via Heqtail. + simp only [List.mapM_cons, bind, ExceptT.bind, ExceptT.bindCont, + ExceptT.mk, ExceptT.lift, ExceptT.pure, + StateT.bind, StateT.pure, pure, + monadLift, MonadLift.monadLift, liftM, + Functor.map, StateT.map, liftCoreGenM, hgi] + bind_shell_state at Heqtail + rw [Heqtail] + rfl + · simp [Hlen] + · refine ⟨newLabel.toPretty :: labelsTail, ?_, ?_⟩ + · simp [HlblsLen] + · simp only [List.zip_cons_cons, List.map_cons] + rw [Hshape] + +/-- Internal-shape destructuring of a successful `callElimCmd` call. + + The B1 phase of `callElimStatementCorrect` needs to bind the + `argTrips`, `outTrips`, `genOldIdents`, `oldTys`, `asserts`, + `assumes` and intermediate gen states produced inside + `callElimCmd`'s `do` block, plus a procedure-lookup result and + the structural equation `sts' = argInit ++ outInit ++ oldInit ++ + asserts ++ havocs ++ assumes`. Because the inner + `bind`/`ExceptT.bindCont` envelope does not normalize + syntactically to a bare `match`, the destructuring is factored + through this helper so the call site stays clean. + + The input state is constrained to have `currentProgram := some p` + (which is the post-`modify` shape produced by `callElimStmt`'s + outer `runWith`). + + The helper exposes everything the call site needs to subst the + structural equation and continue with L1-L6 reasoning. Internal + state names `s_arg/s_out/s_old/s_postold/s_assert/s_assume` are + threaded through; only state-shape relevant downstream are retained. +-/ -set_option maxHeartbeats 500000 --- Second, the program/statement returned by callElim has the same semantics as the pre-transformation program/statement -theorem callElimStatementCorrect [LawfulBEq Expression.Expr] : - -- procedure lookup function is well-behaved - (∀ pname, π pname = (Program.Procedure.find? p (.unres pname))) → - -- all global variables in p exist in σ - (∀ gk, (p.find? .var gk).isSome → (σ gk).isSome) → - EvalStatementsContract π φ δ σ [st] σ' δ → - WellFormedCoreEvalCong δ → - WF.WFStatementsProp p [st] → - WF.WFProgramProp p → - CoreGenState.WF γ → - (∀ v, v ∈ γ.generated ↔ ((σ v).isSome ∧ CoreIdent.isTemp v)) → - (Except.ok sts, γ') = (runWith [st] (CallElim.callElimStmts · p) γ) → - -- NOTE: The theorem does not expect the same store due to inserting new temp variables - exists σ'', - Inits σ' σ'' ∧ - EvalStatementsContract π φ δ σ sts σ'' δ - := by - intros Hp Hgv Heval Hwfc Hwf Hwfp Hwfgen Hwfgenst Helim - cases st <;> - simp [Transform.runWith, StateT.run, callElimStmts, runStmts, callElimCmd, - pure, ExceptT.pure, ExceptT.mk, StateT.pure, - bind, ExceptT.bind, ExceptT.bindCont, StateT.bind, - ] at Helim - <;> try simp [Helim] - case block => exact ⟨σ', Inits.init InitVars.init_none, Heval⟩ - case ite => exact ⟨σ', Inits.init InitVars.init_none, Heval⟩ - case exit => exact ⟨σ', Inits.init InitVars.init_none, Heval⟩ - case loop => exact ⟨σ', Inits.init InitVars.init_none, Heval⟩ - case funcDecl => exact ⟨σ', Inits.init InitVars.init_none, Heval⟩ - case cmd c => - cases c with - | cmd c' => - exists σ' - refine ⟨?_, ?_⟩ - exact Inits.init InitVars.init_none - simp [StateT.pure, StateT.bind, ExceptT.bindCont, pure, bind] at Helim - simp_all - | call lhs procName args md => - split at Helim - next pair l cs' Helim' => - -- NOTE: the simplifier must be invoked in two stages in this case - -- in order to get to - -- Helim : sts = a✝ ∧ γ' = cs' - split at Helim - <;> simp only [StateT.bind, StateT.pure, ExceptT.bindCont, pure_bind, List.append_nil] at Helim - <;> simp [pure] at Helim - next res l => - simp [Helim] at * - simp only [Forall, and_true] at Hwf - cases Hwf with | mk Hwf => - simp [Option.isSome] at Hwf - split at Hwf <;> simp_all - next decl' proc Harglen Houtlen Hlhsdisj Hlhs Hwfargs Hfind => - cases Heval with | stmts_some_sem Heval Heval2 => - cases Heval with - | cmd_sem Heval Hdef => - cases Heval with - | call_sem lkup Hevalargs Hevalouts Hwfval Hwfvars Hwfb Hwf2 Hwf Hinitin Hinitout Hpre Hhav1 Hhav2 Hpost Hrd Hupdate => - next outVals argVals σA σAO σO σR p' modvals => - unfold CoreIdent.unres at Hfind - have Hsome : (Program.Procedure.find? p procName).isSome := by - grind - simp [Option.isSome] at Hsome - unfold CoreIdent.unres at * - have lkup' := lkup - split at Hsome <;> try contradiction - next x val Hfind => - simp_all [-lkup] - simp [bind,StateT.bind,ExceptT.bindCont,pure] at Helim' - split at Helim' <;> try contradiction - -- refactor arg labels generation expressions - next res_arg s_arg Heqarg => - simp [←lkup'] at * - split at Helim' <;> try simp [StateT.pure, StateT.bind, ExceptT.bindCont] at Helim' <;> try cases Helim' - next argTrips => - have Heqargs : List.map Prod.snd argTrips = args := genArgExprIdentsTrip_snd Heqarg - -- refactor out labels generation expressions - generalize Heqout : (genOutExprIdentsTrip proc.header.outputs.toTrivialLTy lhs s_arg) = pair_out at Helim' - cases pair_out - next res_out s_out => - simp only [bind] at Helim' - split at Helim' <;> try simp [pure, StateT.pure] at Helim' <;> try cases Helim' - next outTrips => - have Heqouts : lhs = List.map Prod.snd outTrips := Eq.symm $ genOutExprIdentsTrip_snd Heqout - have Hrdout := InitStatesReadValues Hinitout - simp [StateT.bind, ExceptT.bindCont] at Helim' - -- refactor old expressions generation expressions - generalize Heqold : (genOldExprIdentsTrip p - (List.filter (isGlobalVar p) - (List.flatMap OldExpressions.extractOldExprVars - (OldExpressions.normalizeOldExprs - (List.map Procedure.Check.expr proc.spec.postconditions.values))).eraseDups) - s_out) = pair_old at Helim' - cases pair_old <;> simp only at Helim' - next res_old s_old => - simp only [bind] at Helim' - split at Helim' <;> try simp [pure, StateT.pure] at Helim' <;> try cases Helim' - next st' oldTrips => - -- extract well-formed program properties - cases Hwfp with - | mk wfnd Hwfp => - have Hdecl := List.Forall_mem_iff.mp Hwfp - have HH := Procedure.find_in_decls Hfind - repeat sorry - /- - cases HH with - | intro md HH => - specialize Hdecl (.proc proc md) HH - cases Hdecl with - | mk wfstmts wfloclnd Hiodisj Hinnd Houtnd Hmodsnd Hinlc Houtlc wfspec => - cases wfspec with - | mk wfpre wfpost wfmod => - have HoldDef : Imperative.isDefined σ oldTrips.unzip.snd := by - intros k Hin - apply Hgv - apply genOldExprIdentsFind ?_ Heqold Hin - intros l Hin - have HH := List.mem_filter.mp Hin - exact HH.2 - have HrdOld := isDefinedReadValues HoldDef - have Hwfgenargs : CoreGenState.WF s_arg := genArgExprIdentsTripWFMono Hwfgen Heqarg - have Hwfgenouts : CoreGenState.WF s_out := genOutExprIdentsTripWFMono Hwfgenargs Heqout - have Hwfgenolds : CoreGenState.WF cs' := genOldExprIdentsTripWFMono Hwfgenouts Heqold - have Hgenargs := genArgExprIdentsTripGeneratedWF Heqarg - have Hgenouts := genOutExprIdentsTripGeneratedWF Heqout - have Hgenolds := genOldExprIdentsTripGeneratedWF Heqold - have HargTemp : Forall (CoreIdent.isTemp ·) argTrips.unzip.1.unzip.1 := by - simp [CoreGenState.WF] at Hwfgenargs - have HH := List.Forall_mem_iff.mp Hwfgenargs.2.2.2 - simp only [← Hgenargs] at HH - refine List.Forall_mem_iff.mpr ?_ - intros x Hin - apply HH - exact List.mem_append_left γ.generated (List.mem_reverse.mpr Hin) - have HoutTemp : Forall (CoreIdent.isTemp ·) outTrips.unzip.1.unzip.1 := by - simp [CoreGenState.WF] at Hwfgenouts - have HH := List.Forall_mem_iff.mp Hwfgenouts.2.2.2 - simp only [← Hgenouts] at HH - refine List.Forall_mem_iff.mpr ?_ - intros x Hin - apply HH - exact List.mem_append_left s_arg.generated (List.mem_reverse.mpr Hin) - have HoldTemp : Forall (CoreIdent.isTemp ·) oldTrips.unzip.1.unzip.1 := by - simp [CoreGenState.WF] at Hwfgenolds - have HH := List.Forall_mem_iff.mp Hwfgenolds.2.2.2 - simp only [← Hgenolds] at HH - refine List.Forall_mem_iff.mpr ?_ - intros x Hin - apply HH - exact List.mem_append_left s_out.generated (List.mem_reverse.mpr Hin) - have HgenApp : oldTrips.unzip.fst.unzip.fst.reverse ++ - outTrips.unzip.fst.unzip.fst.reverse ++ - argTrips.unzip.fst.unzip.fst.reverse ++ - γ.generated = cs'.generated := by - simp only [← Hgenargs,← Hgenouts,← Hgenolds] - simp [List.append_assoc] - have Hgennd' : (γ.generated.reverse ++ - argTrips.unzip.fst.unzip.fst ++ - outTrips.unzip.fst.unzip.fst ++ - oldTrips.unzip.fst.unzip.fst).Nodup := by - simp [CoreGenState.WF] at Hwfgenolds - have Hnd := nodup_reverse Hwfgenolds.2.2.1 - simp only [List.reverse_append, List.reverse_reverse, ← List.append_assoc, - ← Hgenargs,← Hgenouts,← Hgenolds] at Hnd - exact Hnd - have Hgennd : (argTrips.unzip.fst.unzip.fst ++ - outTrips.unzip.fst.unzip.fst ++ - oldTrips.unzip.fst.unzip.fst).Nodup := by - simp only [List.append_assoc] at Hgennd' ⊢ - exact (List.nodup_append.mp Hgennd').2.1 - have Hinoutnd : (ListMap.keys proc.header.inputs ++ ListMap.keys proc.header.outputs).Nodup := by - apply List.Disjoint_Nodup_iff.mp - refine ⟨Hinnd, Houtnd, ?_⟩ - . exact Hiodisj - have Hndefgen : Imperative.isNotDefined σ' - (argTrips.unzip.fst.unzip.fst ++ - outTrips.unzip.fst.unzip.fst ++ - oldTrips.unzip.fst.unzip.fst) := by - have ⟨Hσeq, _⟩ := Imperative.EvalBlockEmpty Heval2 - simp only [← Hσeq] - apply UpdateStatesNotDefMonotone ?_ Hupdate - intros v Hin - have Htemp : v.isTemp = true := by - simp only [List.append_assoc, List.mem_append] at Hin - cases Hin with - | inl Hin => - exact (List.Forall_mem_iff.mp HargTemp) _ Hin - | inr Hin => cases Hin with - | inl Hin => - exact (List.Forall_mem_iff.mp HoutTemp) _ Hin - | inr Hin => - exact (List.Forall_mem_iff.mp HoldTemp) _ Hin - refine Option.not_isSome_iff_eq_none.mp ?_ - intros Hsome - have Hcontra := List.mem_reverse.mpr ((Hwfgenst v).mpr ⟨Hsome, Htemp⟩) - simp only [List.append_assoc] at Hin Hgennd' - exact (List.nodup_append.mp Hgennd').2.2 v Hcontra v Hin rfl - have Hmodglob : Forall (CoreIdent.isGlob ·) proc.spec.modifies := by - simp [WF.WFModsProp] at wfmod - apply List.Forall_PredImplies - exact wfmod - intros x HH - apply WFProgGlob Hwfp - exact WF.WFModProp.defined HH - have Holdsndglob : Forall (CoreIdent.isGlob ·) oldTrips.unzip.snd := by - simp [genOldExprIdentsTrip_snd Heqold] - apply List.Forall_PredImplies - apply List.Forall_filter - apply WFProgGlob Hwfp - -- derive some equivalence between stores - have Hrd' := ReadValuesAppKeys' Hrd - cases Hrd' with - | intro v1 Hrd' => cases Hrd' with - | intro v2 Hrd' => - have Hup1 := HavocVarsUpdateStates Hhav1 - cases Hup1 with - | intro v1' Hup1 => - have Hup2 := HavocVarsUpdateStates Hhav2 - cases Hup2 with - | intro v2' Hup2 => - cases HrdOld with - | intro oldVals HoldVals => - have Hargtriplen : argTrips.length = argVals.length := - calc argTrips.length - _ = argTrips.unzip.snd.length := by simp [List.unzip_eq_map] - _ = args.length := by simp [← Heqargs] - _ = argVals.length := by apply EvalExpressionsLength Hevalargs - have Houttriplen : outTrips.length = outVals.length := - calc outTrips.length - _ = outTrips.unzip.snd.length := by simp [List.unzip_eq_map] - _ = lhs.length := by simp [← Heqouts] - _ = (ListMap.keys proc.header.outputs).length := by simp_all [ListMap.keys.length] - _ = outVals.length := ReadValuesLength Hrdout - have Holdtriplen : oldTrips.length = oldVals.length := - calc oldTrips.length - _ = oldTrips.unzip.snd.length := by simp [List.unzip_eq_map] - _ = oldVals.length := by apply ReadValuesLength HoldVals - have Hinit := updatedStatesInit ?_ ?_ ?_ (σ:=σ') - (hs:=argTrips.unzip.fst.unzip.fst ++ - outTrips.unzip.fst.unzip.fst ++ - oldTrips.unzip.fst.unzip.fst) - (vs:=argVals ++ outVals ++ oldVals) - rotate_left - . simp [Hargtriplen, Houttriplen, Holdtriplen] - . exact Hndefgen - . exact Hgennd - . have Heq := EvalStatementsContractEmpty Heval2 - simp only [Heq] at * - have Hinit' := InitsUpdatesComm Hupdate Hinit - cases Hinit' with - | intro σ₁ Hinit' => - exists (updatedStates σ' - (argTrips.unzip.1.unzip.1 ++ outTrips.unzip.1.unzip.1 ++ oldTrips.unzip.1.unzip.1) - (argVals ++ outVals ++ oldVals)) - apply And.intro - . exact InitStatesInits Hinit - . apply EvalStatementsContractApp - . -- Prove args expression initialization is correct - apply EvalStatementsContractInits - . assumption - . assumption - . assumption - . simp [genArgExprIdentsTrip_snd Heqarg] - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . simp at HargTemp - apply HargTemp - . apply List.Forall_flatMap.mp - apply List.Forall_PredImplies Hwfargs - intros x Hp - exact WF.WFargProp.glarg Hp - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . apply List.Sublist.nodup (List.sublist_append_left _ _) ?_ - . exact outTrips.unzip.fst.unzip.fst - apply List.Sublist.nodup (List.sublist_append_left _ _) ?_ - . exact oldTrips.unzip.fst.unzip.fst - exact Hgennd - . simp - simp [Heqargs] - assumption - . -- arg vars generated are not defined - apply UpdateStatesNotDefMonotone' (σ':=σ') ?_ Hupdate - simp [Imperative.isNotDefined] at * - intros v x x' Hin - apply Hndefgen - left; exact ⟨x, x', Hin⟩ - -- Reused assumption : lhs and modifies are defined - have Hdeflm : Imperative.isDefined σ (lhs ++ proc.spec.modifies) := by - simp [Imperative.isDefinedOver, - Imperative.HasVarsTrans.allVarsTrans, - Statement.allVarsTrans, - Statement.modifiedOrDefinedVarsTrans, - Command.definedVarsTrans, - Command.definedVars, - Command.modifiedVarsTrans, - Imperative.HasVarsTrans.modifiedVarsTrans, - Procedure.modifiedVarsTrans, - lkup] at Hwf - simp [Imperative.isDefined] at * - intros v Hin - apply Hwf - cases Hin with - | inl a => right; left; exact a - | inr a => right; right; left; exact a - apply EvalStatementsContractApp (σ':=(updatedStates (updatedStates σ - argTrips.unzip.fst.unzip.fst argVals) - outTrips.unzip.fst.unzip.fst outVals)) - . -- Prove output variables initialization is correct - apply EvalStatementsContractInitVars - . assumption - . apply List.Disjoint_Nodup_iff.mp - refine ⟨?_, ?_, ?_⟩ - . exact (List.nodup_append.mp (List.nodup_append.mp Hgennd).1).2.1 - . simp [genOutExprIdentsTrip_snd Heqout] - exact Hlhs.1 - . -- Disjoint between localGlob and Temp - simp [genOutExprIdentsTrip_snd Heqout] - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . simp at HoutTemp - exact HoutTemp - . exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . simp - refine ReadValuesUpdatedStates ?_ ?_ ?_ - . simp [Hargtriplen] - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . simp at HargTemp - exact HargTemp - . simp [← Heqouts] - exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . simp [← Heqouts] - exact Hevalouts - . -- out vars generated are not defined - apply UpdatedStatesDisjNotDefMonotone - . have Hnd' := List.Disjoint_Nodup_iff.mpr (List.nodup_append.mp Hgennd).1 - exact Hnd'.2.2 - . simp [← Hargtriplen] - . apply UpdateStatesNotDefMonotone' (σ':=σ') ?_ Hupdate - simp [Imperative.isNotDefined] at * - intros v x x' Hin - apply Hndefgen - right; left; exact ⟨x, x', Hin⟩ - apply EvalStatementsContractApp (σ':=(updatedStates (updatedStates (updatedStates σ - argTrips.unzip.fst.unzip.fst argVals) - outTrips.unzip.fst.unzip.fst outVals) - oldTrips.unzip.fst.unzip.fst oldVals)) - . -- Prove old expressions initialization is correct - apply EvalStatementsContractInitVars Hwfvars - . apply List.Disjoint_Nodup_iff.mp - refine ⟨?_, ?_, ?_⟩ - . exact (List.nodup_append.mp Hgennd).2.1 - . simp [genOldExprIdentsTrip_snd Heqold] - apply filter_nodup - apply eraseDups_Nodup - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlob ·)) - . exact HoldTemp - . simp [genOldExprIdentsTrip_snd Heqold] - apply List.Forall_PredImplies - . apply List.Forall_filter - . exact WFProgGlob Hwfp - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isGlob_isGlobOrLocl - . simp - apply ReadValuesUpdatedStates - . simp [Houttriplen] - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlob ·)) - . simp at HoutTemp - exact HoutTemp - . simp [genOldExprIdentsTrip_snd Heqold] - apply List.Forall_PredImplies - . apply List.Forall_filter - . exact WFProgGlob Hwfp - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isGlob_isGlobOrLocl - apply ReadValuesUpdatedStates - . simp [Hargtriplen] - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlob ·)) - . simp at HargTemp - exact HargTemp - . simp [genOldExprIdentsTrip_snd Heqold] - apply List.Forall_PredImplies - . apply List.Forall_filter - . exact WFProgGlob Hwfp - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isGlob_isGlobOrLocl - . simp at HoldVals - exact HoldVals - . -- old vars generated are not defined - apply UpdatedStatesDisjNotDefMonotone - . simp only [List.append_assoc] at Hgennd - exact (List.Disjoint_Nodup_iff.mpr (List.nodup_append.mp Hgennd).2.1).2.2 - . simp [← Houttriplen] - apply UpdatedStatesDisjNotDefMonotone - . simp only [nodup_swap'] at Hgennd - simp only [← List.append_assoc] at Hgennd - have Hnd' := (List.Disjoint_Nodup_iff.mpr (List.nodup_append.mp Hgennd).1).2.2 - exact List.Disjoint.symm Hnd' - . simp [← Hargtriplen] - . apply UpdateStatesNotDefMonotone' (σ:=σ) (σ':=σ') ?_ Hupdate - intros x Hin - apply Hndefgen - simp_all - -- σA contains inputs as keys, while σ₁ contains the generated keys as keys - have Hinit2 := InitStatesApp' Hinit'.2.1 (by simp_all) (by simp_all) - cases Hinit2 with - | intro σ₁' Hinit2 => - have Hinit3 := InitStatesApp' Hinit2.2.1 (by simp_all) (by simp_all) - cases Hinit3 with - | intro σ₁'' Hinit3 => - -- NOTE: We split the single InitStates into three stages - -- σ |-- init argVal --> σ₁'' |-- init outVal --> σ₁' |-- init oldVal --> σ₁ - simp [← List.append_assoc] - apply EvalStatementsContractApp (σ':= - (updatedStates (updatedStates (updatedStates (updatedStates σ - (List.map (Prod.fst ∘ Prod.fst) argTrips) argVals) - (List.map (Prod.fst ∘ Prod.fst) outTrips) outVals) - (List.map (Prod.fst ∘ Prod.fst) oldTrips) oldVals) - (lhs ++ proc.spec.modifies) modvals)) - . simp [List.append_assoc] - apply EvalStatementsContractApp - . -- asserts - have Hrdin : ReadValues σAO (ListMap.keys proc.header.inputs) argVals := by - apply InitStatesReadValuesMonotone (σ:=σA) ?_ Hinitout - exact InitStatesReadValues Hinitin - have Hrdinout : ReadValues σAO - (ListMap.keys proc.header.inputs ++ ListMap.keys proc.header.outputs) - (argVals ++ outVals) := ReadValuesApp Hrdin Hrdout - have Hlen : (ListMap.keys proc.header.inputs).length = - (createFvars (List.map (Prod.fst ∘ Prod.fst) argTrips)).length := by calc - _ = argVals.length := InitStatesLength Hinitin - _ = argTrips.length := by simp_all - _ = (List.map (Prod.fst ∘ Prod.fst) argTrips).length := by simp_all - _ = _ := by rw [createFvarsLength] - rw [← (List.zip_append Hlen)] - rw [← createFvarsApp] - apply createAssertsCorrect (σA:=σAO) Hwfb Hwfvars - . assumption - . assumption - . simp_all - rw [createFvarsLength] - simp [← Hargtriplen] - . -- substNodup - have Hlen := ReadValuesLength Hrdin - simp [Imperative.substNodup] - rw [List.map_fst_zip, List.map_snd_zip] <;> simp_all - -- TODO: input names of function not overlapping with generated variables - -- can come from local/global distinction - conv => arg 1; rw [← List.append_assoc] - refine List.Disjoint_Nodup_iff.mp ⟨?_, ?_, ?_⟩ - . exact Hinoutnd - . apply List.Disjoint_Nodup_iff.mp ⟨?_, ?_, ?_⟩ - . exact (List.Disjoint_Nodup_iff.mpr Hgennd).1 - . exact Hlhs.1 - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . exact HargTemp - . exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . apply List.Disjoint.symm - apply List.Disjoint_app.mp ⟨?_, ?_⟩ - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact HargTemp - . apply List.Forall_append.mpr ⟨?_, ?_⟩ - . exact List.Forall_PredImplies Hinlc CoreIdent.isLocl_isGlobOrLocl - . exact List.Forall_PredImplies Houtlc CoreIdent.isLocl_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . intros x Hin1 Hin2 - apply Hlhsdisj Hin1 - simp_all - . -- substDefined - intros k1 k2 Hin - have Hmem := List.of_mem_zip Hin - simp only [List.mem_append] at Hmem - apply And.intro - . cases Hmem.1 with - | inl Hmem => - have Hdef : Imperative.isDefined σAO (ListMap.keys proc.header.inputs) := by - apply InitStatesDefMonotone ?_ Hinitout - exact InitStatesDefined Hinitin - exact Hdef k1 Hmem - | inr Hmem => - have Hdef : Imperative.isDefined σAO (ListMap.keys proc.header.outputs) := by - exact InitStatesDefined Hinitout - exact Hdef k1 Hmem - . cases Hmem.2 with - | inl Hmem => - apply updatedStatesDefMonotone <;> try assumption - apply updatedStatesDefMonotone <;> try assumption - apply updatedStatesDefined - simp_all - | inr Hmem => - apply updatedStatesDefMonotone <;> try assumption - apply updatedStatesDefMonotone <;> try assumption - apply updatedStatesDefMonotone <;> try assumption - . -- precondition correct - intros pre Hin; simp_all - apply And.intro - . simp [updatedStates] - rw [← updatedStates'App] - rw [← updatedStates'App] - rw [← List.zip_append] <;> try simp_all - rw [← List.zip_append] <;> try simp_all - rw [← updatedStates] - apply InvStoresExceptInvStores - apply Imperative.invStoresExceptComm - apply InvStoresExceptUpdated - apply Imperative.invStoresExceptComm - apply InvStoresExceptInitStates (σ:=σA) (ks':=ListMap.keys proc.header.outputs) - apply InvStoresExceptInitStates (σ:=σ) (ks':=ListMap.keys proc.header.inputs) - exact InvStoresExceptEmpty - exact Hinitin - exact Hinitout - simp_all - simp_all - simp [← List.append_assoc] - generalize ListMap.keys proc.header.inputs ++ - ListMap.keys proc.header.outputs ++ - List.map (Prod.fst ∘ Prod.fst) argTrips - = inoutarg - simp [List.append_assoc] - simp [List.removeAll_app] - rw [List.removeAll_comm] - apply List.Disjoint.removeAll - apply List.Disjoint.mono_right - . exact List.removeAll_Sublist - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . apply List.Forall_append.mpr - exact ⟨HoutTemp, HoldTemp⟩ - . have HH := prepostconditions_unwrap Hin - cases HH with - | intro label HH => - cases HH with - | intro attr HH => - cases HH with - | intro md HH => - have Hwf := (List.Forall_mem_iff.mp wfpre _ HH).glvars - simp at Hwf - exact Hwf - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . have HH := prepostconditions_unwrap Hin - cases HH with - | intro label HH => - cases HH with - | intro attr HH => - cases HH with - | intro md HH => - apply List.Disjoint_app.mp ⟨?_, ?_⟩ - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact HargTemp - . have Hwf := (List.Forall_mem_iff.mp wfpre _ HH).glvars - simp at Hwf - exact Hwf - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . have Hpre := (List.Forall_mem_iff.mp wfpre _ HH) - have Hlcl := List.Forall_mem_iff.mp Hpre.lvars - have Hgl := List.Forall_mem_iff.mp Hpre.glvars - simp at Hlcl Hgl - intros x Hin1 Hin2 - specialize Hgl x Hin2 - simp [CoreIdent.isGlobOrLocl] at Hgl - cases Hgl with - | inl Hg => - -- disjoint of local and global - have Hlhs := List.Forall_mem_iff.mp Hlhs.2 - specialize Hlhs x Hin1 - exact CoreIdent.Disjoint_isLocl_isGlob _ Hlhs Hg - | inr Hl => - -- disjoint because of WF - specialize Hlcl x Hin2 Hl - apply Hlhsdisj Hin1 - simp_all - . apply createFvarsSubstStores (σ:=σ₁') (σA:=σAO) - (ks2:=(ListMap.keys proc.header.inputs) ++ (ListMap.keys proc.header.outputs)) - . -- length - simp_all - rw [createFvarsLength] - simp [← Hargtriplen] - . assumption - . -- substDefined - intros k1 k2 Hin - have Hmem := List.of_mem_zip Hin - apply And.intro - . simp only [List.mem_append] at Hmem - cases Hmem.1 with - | inl Hmem => - have Hdef : Imperative.isDefined σ₁' argTrips.unzip.1.unzip.1 := by - apply InitStatesDefMonotone ?_ Hinit3.2.2 - exact InitStatesDefined Hinit3.2.1 - simp at Hdef - exact Hdef k1 Hmem - | inr Hmem => - have Hdef : Imperative.isDefined σ₁' lhs := by - simp [Hinit2.1] - apply updatedStatesDefMonotone - intros k Hin - apply Hdeflm - exact List.mem_append_left proc.spec.modifies Hin - exact Hdef _ Hmem - . apply ReadValuesIsDefined Hrdinout - exact Hmem.2 - . -- substStores - simp_all - apply ReadValuesSubstStores ?_ Hrdinout - apply ReadValuesApp - simp [updatedStates] - rw [List.zip_append] - rw [updatedStates'App] - apply ReadValuesUpdatedStates - . simp [Houttriplen] - . intros a Hin1 Hin2 - apply (List.nodup_append.mp Hgennd).2.2 a ?_ a ?_ - . rfl - . simp only at Hin2 ⊢ - exact Hin2 - . simp only at Hin1 ⊢ - exact List.mem_append_left _ Hin1 - . apply ReadValuesUpdatedStatesSame - simp [Hargtriplen] - grind - . -- length, provable - simp [Hargtriplen] - . apply ReadValuesUpdatedStates - . -- length, provable - simp [Hargtriplen, Houttriplen] - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . apply List.Forall_append.mpr ⟨HargTemp, HoutTemp⟩ - . exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . exact Hevalouts - . exact Hrdinout - . -- Read Values - exact Hrdinout - . -- substStores - apply ReadValuesSubstStores ?_ Hrdinout - apply ReadValuesApp - simp [updatedStates] - apply ReadValuesUpdatedStates - . simp [Holdtriplen] - . intros a Hin1 Hin2 - apply (List.nodup_append.mp Hgennd).2.2 a ?_ a ?_ - . rfl - . simp at Hin2 ⊢ - exact Or.inl Hin2 - . simp at Hin1 ⊢ - exact Hin1 - apply ReadValuesUpdatedStates - . simp [Houttriplen] - . intros a Hin1 Hin2 - apply (List.nodup_append.mp (List.nodup_append.mp Hgennd).1).2.2 a ?_ a ?_ - . rfl - . simp at Hin2 ⊢ - exact Hin2 - . simp at Hin1 ⊢ - exact Hin1 - . apply ReadValuesUpdatedStatesSame - simp [Hargtriplen] - grind - . apply ReadValuesUpdatedStates - . simp [Holdtriplen] - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . simp at HoldTemp - exact HoldTemp - . exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . apply ReadValuesUpdatedStates - . simp [Houttriplen] - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . simp at HoutTemp - exact HoutTemp - . exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . apply ReadValuesUpdatedStates - . simp [Hargtriplen] - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . simp at HargTemp - exact HargTemp - . exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . exact Hevalouts - . -- Prove havocs correct - simp [← createHavocsApp] - apply EvalStatementsContractHavocVars (σ':= - (updatedStates (updatedStates (updatedStates (updatedStates σ - (List.map (Prod.fst ∘ Prod.fst) argTrips) argVals) - (List.map (Prod.fst ∘ Prod.fst) outTrips) outVals) - (List.map (Prod.fst ∘ Prod.fst) oldTrips) oldVals) - (lhs ++ proc.spec.modifies) modvals)) - . assumption - . apply updatedStatesDefMonotone - apply updatedStatesDefMonotone - apply updatedStatesDefMonotone - exact Hdeflm - . apply UpdateStatesHavocVars (modvals:=modvals) - refine updatedStatesUpdate ?_ ?_ - exact UpdateStatesLength Hupdate - apply updatedStatesDefMonotone - apply updatedStatesDefMonotone - apply updatedStatesDefMonotone - exact Hdeflm - . -- Prove assumes correct - -- transform to the same store - simp [updatedStates] - rw [updatedStatesComm] - rw [updatedStatesComm (kvs':=(lhs ++ proc.spec.modifies).zip modvals)] - rw [updatedStatesComm (kvs':=(lhs ++ proc.spec.modifies).zip modvals)] - simp [UpdateStatesUpdated Hupdate, updatedStates] - rw [List.zip_append] <;> simp_all - rw [List.zip_append] - rw [updatedStates'App] - rw [updatedStates'App] - rw [← List.zip_append] - -- combine fvars - rw [← createFvarsApp] - . -- createAssumesCorrect - -- NOTE: σR here should be σR with the temporary old variables - generalize HσR₁ : (updatedStates (updatedStates σR - (List.map (Prod.fst ∘ Prod.fst) outTrips) outVals)) - (List.map (Prod.fst ∘ Prod.fst) oldTrips) oldVals = σR₁ - apply createAssumesCorrect (σA:=σR₁) Hwfb Hwfvars - . assumption - . assumption - . -- length - simp_all +private theorem callElimCmd_call_eq + {procName : String} {args : List (CallArg Expression)} + {md : Imperative.MetaData Expression} + {γ : CoreTransformState} + {γ_out : CoreTransformState} + {p : Program} + {sts' : List Statement} + (Heq : (callElimCmd (CmdExt.call procName args md)) + { γ with currentProgram := some p } + = (Except.ok (some sts'), γ_out)) : + ∃ proc argTrips outTrips genOldIdents oldTys asserts assumes + s_arg s_out s_old, + Program.Procedure.find? p ⟨procName, ()⟩ = some proc ∧ + let oldVars : List Expression.Ident := callElim_oldVars proc args + genArgExprIdentsTrip + (Lambda.LMonoTySignature.toTrivialLTy proc.header.inputs) + (CallArg.getInputExprs args) + { γ with currentProgram := some p, + statistics := γ.statistics.increment + (toString CallElim.Stats.visitedCalls) 1 } + = (Except.ok argTrips, s_arg) ∧ + genOutExprIdentsTrip + (Lambda.LMonoTySignature.toTrivialLTy proc.header.outputs) + (CallArg.getLhs args) s_arg + = (Except.ok outTrips, s_out) ∧ + genOldExprIdents oldVars s_out.genState = (genOldIdents, s_old) ∧ + oldTys.length = oldVars.length ∧ + sts' = + Core.Transform.createInits argTrips md ++ + Core.Transform.createInitVars outTrips md ++ + Core.Transform.createInitVars + ((genOldIdents.zip oldTys).zip oldVars) + md ++ + asserts ++ + Core.Transform.createHavocs (CallArg.getLhs args) md ++ + assumes ∧ + -- Structural shape of `asserts`: abstract `pres.zip labels` map. + (∃ (assertLabels : List String), + let pres := (proc.spec.preconditions.filter + (fun (_, check) => check.attr != .Free)) + let assertSubst := + ((ListMap.keys proc.header.inputs).zip + (Core.Transform.createFvars argTrips.unzip.fst.unzip.fst) ++ + (ListMap.keys proc.header.outputs).zip + (Core.Transform.createFvars (CallArg.getLhs args))) + assertLabels.length = pres.length ∧ + asserts = (pres.zip assertLabels).map (fun (entry, lbl) => + Statement.assert lbl + (Lambda.LExpr.substFvars entry.snd.expr assertSubst) + (entry.snd.md.setCallSiteFileRange md))) ∧ + -- Structural shape of `assumes`: abstract `posts.zip labels` map. + (∃ (assumeLabels : List String), + let inputOnlyOldSubst : Map Expression.Ident Expression.Expr := + callElim_inputOnlyOldSubst proc args + let oldTripsCanonical := + (((genOldIdents.zip oldTys).zip oldVars).zip + (oldVars.map (fun g => CoreIdent.mkOld g.name))).map + fun (((fresh, ty), _orig), oldG) => ((fresh, ty), oldG) + let oldSubst : Map Expression.Ident Expression.Expr := + Core.Transform.createOldVarsSubst oldTripsCanonical ++ inputOnlyOldSubst + let posts := Procedure.Spec.updateCheckExprs + (proc.spec.postconditions.values.map + (fun c => Lambda.LExpr.substFvars c.expr oldSubst)) + proc.spec.postconditions + let assumeSubst := + ((ListMap.keys proc.header.outputs).zip + (Core.Transform.createFvars (CallArg.getLhs args)) ++ + ((ListMap.keys proc.header.inputs).zip + (Core.Transform.createFvars argTrips.unzip.fst.unzip.fst)).filter + (fun (id, _) => !(ListMap.keys proc.header.outputs).contains id)) + assumeLabels.length = posts.length ∧ + assumes = (posts.zip assumeLabels).map (fun (entry, lbl) => + Statement.assume lbl + (Lambda.LExpr.substFvars entry.snd.expr assumeSubst) + (entry.snd.md.setCallSiteFileRange md))) := by + -- Unfold `callElimCmd`'s `do` block step-by-step. The first action + -- is `incrementStat` (a `modify`), then `(← get).currentProgram` is + -- matched. Because we passed `{γ with currentProgram := some p}`, + -- we can compute the post-increment state explicitly. + unfold callElimCmd at Heq + simp only [incrementStat, modify, modifyGet, MonadStateOf.modifyGet, + MonadState.modifyGet, StateT.modifyGet, + bind, StateT.bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk, + pure, ExceptT.pure, + get, getThe, MonadStateOf.get, MonadState.get, StateT.get, + monadLift, MonadLift.monadLift, liftM, ExceptT.lift, + Functor.map, StateT.map] at Heq + cases hfind : Program.Procedure.find? p ⟨procName, ()⟩ with + | none => + rw [hfind] at Heq + exact absurd Heq (by intro h; cases h) + | some proc => + rw [hfind] at Heq + bind_shell at Heq + generalize Heqarg : + (genArgExprIdentsTrip + (Lambda.LMonoTySignature.toTrivialLTy proc.header.inputs) + (CallArg.getInputExprs args) + { γ with currentProgram := some p, + statistics := γ.statistics.increment + (toString CallElim.Stats.visitedCalls) 1 }) = + pair_arg at Heq + cases pair_arg with + | mk res_arg s_arg => + cases res_arg with + | error e => + exact absurd Heq (by intro h; cases h) + | ok argTrips => + bind_shell at Heq + generalize Heqout : + (genOutExprIdentsTrip + (Lambda.LMonoTySignature.toTrivialLTy proc.header.outputs) + (CallArg.getLhs args) s_arg) = pair_out at Heq + cases pair_out with + | mk res_out s_out => + cases res_out with + | error e => + exact absurd Heq (by intro h; cases h) + | ok outTrips => + -- Now extract `genOldIdents` from the next layer. + -- The next layer is `(StateT.map Except.ok + -- (liftCoreGenM (genOldExprIdents oldVars))).bind ...`. + simp only [liftCoreGenM, bind, StateT.bind, + ExceptT.bindCont, pure, StateT.map] at Heq + -- Hoist the old-vars filter once for the rest of the proof. + let oldVars : List Expression.Ident := callElim_oldVars proc args + generalize Heqold : + (genOldExprIdents oldVars s_out.genState) = pair_old at Heq + cases pair_old with + | mk genOldIdents s_old => + -- B1: oldTys ← oldVars.mapM (oldVars ⊆ inputs.keys). + have Holdvars_in_inputs : + ∀ g ∈ oldVars, + (ListMap.keys proc.header.inputs).contains g := by + intro g Hg + have Hfilt : _ ∧ _ := List.mem_filter.mp Hg + have Hcond : _ = true := Hfilt.2 + simp only [Bool.and_eq_true] at Hcond + exact Hcond.1.1 + obtain ⟨oldTys, s_postold, Heqty, _Hlenty⟩ := + oldVars_oldTys_mapM_ok (γ := { s_out with genState := s_old }) + Holdvars_in_inputs + -- Reduce `pure`/`throw` to match Heq. + bind_shell at Heq + rw [Heqty] at Heq + bind_shell at Heq + -- ── B2 layer: asserts ← createAsserts ... ── + obtain ⟨asserts, s_assert, Heqas, _Hlenas, + assertLabels, HassertLabelsLen, HassertShape⟩ := + createAsserts_ok + (proc.spec.preconditions.filter (fun (_, check) => check.attr != .Free)) + ((ListMap.keys proc.header.inputs).zip + (Core.Transform.createFvars argTrips.unzip.fst.unzip.fst) ++ + (ListMap.keys proc.header.outputs).zip + (Core.Transform.createFvars (CallArg.getLhs args))) + md + callElimAssertPrefix + s_postold + rw [Heqas] at Heq + bind_shell at Heq + -- B2: assumes ← createAssumes (oldSubst helper). + let inputOnlyOldSubst : Map Expression.Ident Expression.Expr := + callElim_inputOnlyOldSubst proc args + let oldTrips := + (((genOldIdents.zip oldTys).zip oldVars).zip + (oldVars.map (fun g => CoreIdent.mkOld g.name))).map + fun (((fresh, ty), _orig), oldG) => ((fresh, ty), oldG) + let oldSubst : Map Expression.Ident Expression.Expr := + Core.Transform.createOldVarsSubst oldTrips ++ inputOnlyOldSubst + obtain ⟨assumes, s_assume, Heqasm, _Hlenasm, + assumeLabels, HassumeLabelsLen, HassumeShape⟩ := + createAssumes_ok + (Procedure.Spec.updateCheckExprs + (proc.spec.postconditions.values.map + (fun c => Lambda.LExpr.substFvars c.expr oldSubst)) + proc.spec.postconditions) + ((ListMap.keys proc.header.outputs).zip + (Core.Transform.createFvars (CallArg.getLhs args)) ++ + ((ListMap.keys proc.header.inputs).zip + (Core.Transform.createFvars argTrips.unzip.fst.unzip.fst)).filter + (fun (id, _) => !(ListMap.keys proc.header.outputs).contains id)) + md + callElimAssumePrefix + s_assert + rw [Heqasm] at Heq + bind_shell_state at Heq + -- ── Callgraph update ── + -- `match σ.cachedAnalyses.callGraph, σ.currentProcedureName`. + -- We split on both branches. The first branch may + -- throw via decrementEdge; refute that case. + refine ⟨proc, argTrips, outTrips, genOldIdents, oldTys, + asserts, assumes, + s_arg, s_out, s_old, + rfl, Heqarg, Heqout, Heqold, _Hlenty, ?_, + ⟨assertLabels, HassertLabelsLen, HassertShape⟩, + ⟨assumeLabels, HassumeLabelsLen, HassumeShape⟩⟩ + · -- Structural equation: split on callgraph match, + -- then read off `sts' = ...`. Use a single simp + -- set that unfolds `set`/`StateT.set`/`StateT.map` + -- so the post-callgraph pure-return reduces to a + -- raw `(Except.ok (List ...), state)` pair. + cases hcg : s_assume.cachedAnalyses.callGraph with + | none => + cases hcpn : s_assume.currentProcedureName <;> + (rw [hcg, hcpn] at Heq + bind_shell_state at Heq + have Hpair := Prod.mk.injEq _ _ _ _ |>.mp Heq + have Hexc := Except.ok.injEq _ _ |>.mp Hpair.1 + exact (Option.some.injEq _ _ |>.mp Hexc).symm) + | some cg => + cases hcpn : s_assume.currentProcedureName with + | none => + rw [hcg, hcpn] at Heq + bind_shell_state at Heq + have Hpair := Prod.mk.injEq _ _ _ _ |>.mp Heq + have Hexc := Except.ok.injEq _ _ |>.mp Hpair.1 + exact (Option.some.injEq _ _ |>.mp Hexc).symm + | some callerName => + rw [hcg, hcpn] at Heq + bind_shell_state at Heq + cases hde : + (cg.decrementEdge callerName procName) with + | error e => + rw [hde] at Heq + bind_shell_state at Heq + exact absurd Heq (by intro h; cases h) + | ok cg' => + rw [hde] at Heq + bind_shell_state at Heq + have Hpair := Prod.mk.injEq _ _ _ _ |>.mp Heq + have Hexc := Except.ok.injEq _ _ |>.mp Hpair.1 + exact (Option.some.injEq _ _ |>.mp Hexc).symm + +/-- For every non-call statement `s`, the call-elimination transformer + `callElimStmt s p` returns `[s]` unchanged. This collapses what was + eight identical simp blocks (one per `Statement` constructor that is + not a `Cmd.call`) into a single uniform reduction. Used by + `callElimStatementCorrect` to dispatch the non-call branches. -/ +private theorem callElimStmt_non_call_eq + {p : Program} {γ γ' : CoreTransformState} {sts : List Statement} + {s : Statement} + (hne : ∀ procName args md, s ≠ .cmd (CmdExt.call procName args md)) + (hH : (Except.ok sts, γ') = (runWith s (callElimStmt · p) γ)) : + sts = [s] := by + -- All 7 non-call top-level cases (cmd.cmd, block, ite, loop, exit, + -- funcDecl, typeDecl) reduce uniformly via the same simp set; the + -- inner `cmd.call` case is discharged by `hne`. + match s, hne, hH with + | .cmd (.call procName args md), hne, _ => + exact absurd rfl (hne procName args md) + | .cmd (.cmd _), _, hH + | .block _ _ _, _, hH + | .ite _ _ _ _, _, hH + | .loop _ _ _ _ _, _, hH + | .exit _ _, _, hH + | .funcDecl _ _, _, hH + | .typeDecl _ _, _, hH => + simp only [runWith, StateT.run, callElimStmt, bind, pure, + StateT.bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk, ExceptT.pure, + modify, modifyGet, MonadStateOf.modifyGet, MonadState.modifyGet, + StateT.modifyGet, monadLift, MonadLift.monadLift, ExceptT.lift, + StateT.pure, Functor.map, StateT.map, + Prod.mk.injEq, Except.ok.injEq] at hH + exact hH.1 + +/-- Call-site WF/disjointness invariants required by `callElimStatementCorrect`. + + Bundles the six call-site WF clauses that were previously expressed as a + single nested conjunction (`Hpre_post_lhs_disj`). Each field is a + universally-quantified property that fires only when `st` is a call; + for non-call statements every field is vacuously true. -/ +structure WFCallSiteProp (p : Program) + (π : String → Option Procedure) + (st : Statement) : Prop where + /-- Pre-condition free vars are not `tmp_`/`old_`-prefixed and not in the + call's `lhs`. -/ + preVarsFresh : + ∀ procName args md, st = .cmd (CmdExt.call procName args md) → + ∀ proc, π procName = some proc → + ∀ pre ∈ Procedure.Spec.getCheckExprs proc.spec.preconditions, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) pre, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ + v ∉ CallArg.getLhs args + /-- Post-condition free vars are not `tmp_`/`old_`-prefixed and not in the + call's `lhs`. -/ + postVarsFresh : + ∀ procName args md, st = .cmd (CmdExt.call procName args md) → + ∀ proc, π procName = some proc → + ∀ post ∈ Procedure.Spec.getCheckExprs proc.spec.postconditions, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) post, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ + v ∉ CallArg.getLhs args + /-- Argument-expression free vars are disjoint from the call's `lhs`. -/ + argVarsNotInLhs : + ∀ procName args md, st = .cmd (CmdExt.call procName args md) → + ∀ _proc, π procName = some _proc → + ∀ argExpr ∈ CallArg.getInputExprs args, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, + v ∉ CallArg.getLhs args + /-- Procedure input/output parameter names are not `tmp_`/`old_`-prefixed. -/ + inoutFresh : + ∀ procName args md, st = .cmd (CmdExt.call procName args md) → + ∀ proc, π procName = some proc → + ∀ v ∈ proc.header.inputs.keys ++ proc.header.outputs.keys, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v + /-- Argument-expression free vars are disjoint from the procedure's + `outputs.keys` (the global modset). -/ + argVarsNotInOutKeys : + ∀ procName args md, st = .cmd (CmdExt.call procName args md) → + ∀ proc, π procName = some proc → + ∀ argExpr ∈ CallArg.getInputExprs args, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, + v ∉ ListMap.keys proc.header.outputs + /-- Argument-expression free vars are disjoint from the procedure's + `inputs.keys` (procedure parameter names). -/ + argVarsNotInInKeys : + ∀ procName args md, st = .cmd (CmdExt.call procName args md) → + ∀ proc, π procName = some proc → + ∀ argExpr ∈ CallArg.getInputExprs args, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, + v ∉ ListMap.keys proc.header.inputs + /-- Positional-alignment WF for inout outputs: for each output parameter + `v ∈ outputs.keys` that is also an `lhs` entry (i.e., an inout pass), + the call's lhs index for `v` agrees with the procedure's outputs-keys + index. Backs the L6 `HoldEval_bridge` derivation. -/ + outAlignment : + ∀ procName args md, st = .cmd (CmdExt.call procName args md) → + ∀ proc, π procName = some proc → + ∀ v ∈ ListMap.keys proc.header.outputs, + v ∈ CallArg.getLhs args → + (CallArg.getLhs args).idxOf v = + (ListMap.keys proc.header.outputs).idxOf v + +/-- Call-site WF clauses already specialized at a fixed call form + `(procName, args, md)` and a fixed procedure `proc`. + + Bundles the seven `WFCallSiteProp` fields with the per-call + `(procName, args, md, rfl, proc, lkup)` instantiation already + applied, so call-site code can `obtain ⟨...⟩ := ... .specialize ...` + in one step instead of repeating the instantiation per field. -/ +structure WFCallSiteSpec (proc : Procedure) (args : List (CallArg Expression)) : Prop where + preVarsFresh : + ∀ pre ∈ Procedure.Spec.getCheckExprs proc.spec.preconditions, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) pre, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ + v ∉ CallArg.getLhs args + postVarsFresh : + ∀ post ∈ Procedure.Spec.getCheckExprs proc.spec.postconditions, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) post, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ + v ∉ CallArg.getLhs args + argVarsNotInLhs : + ∀ argExpr ∈ CallArg.getInputExprs args, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, + v ∉ CallArg.getLhs args + inoutFresh : + ∀ v ∈ proc.header.inputs.keys ++ proc.header.outputs.keys, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v + argVarsNotInOutKeys : + ∀ argExpr ∈ CallArg.getInputExprs args, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, + v ∉ ListMap.keys proc.header.outputs + argVarsNotInInKeys : + ∀ argExpr ∈ CallArg.getInputExprs args, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, + v ∉ ListMap.keys proc.header.inputs + outAlignment : + ∀ v ∈ ListMap.keys proc.header.outputs, + v ∈ CallArg.getLhs args → + (CallArg.getLhs args).idxOf v = + (ListMap.keys proc.header.outputs).idxOf v + +/-- Specialize all seven `WFCallSiteProp` fields at a fixed call form + `st = .cmd (CmdExt.call procName args md)` and procedure lookup + `π procName = some proc`. + + Lets the call-site case discharge the `(procName, args, md, rfl, + proc, lkup)` instantiation once and reuse the seven specialized + facts via `obtain ⟨...⟩ := Hwfcs.specialize Hst Hlkup`. -/ +theorem WFCallSiteProp.specialize {p : Program} + {π : String → Option Procedure} {st : Statement} + {procName : String} {args : List (CallArg Expression)} {md} + {proc : Procedure} + (Hwfcs : WFCallSiteProp p π st) + (Hst : st = .cmd (CmdExt.call procName args md)) + (Hlkup : π procName = some proc) : WFCallSiteSpec proc args := + ⟨ Hwfcs.preVarsFresh procName args md Hst proc Hlkup + , Hwfcs.postVarsFresh procName args md Hst proc Hlkup + , Hwfcs.argVarsNotInLhs procName args md Hst proc Hlkup + , Hwfcs.inoutFresh procName args md Hst proc Hlkup + , Hwfcs.argVarsNotInOutKeys procName args md Hst proc Hlkup + , Hwfcs.argVarsNotInInKeys procName args md Hst proc Hlkup + , Hwfcs.outAlignment procName args md Hst proc Hlkup ⟩ + +/-- Relation between the source store `σ` and the call-elim transform + state `γ`'s tracked fresh-name set. + + Bundles the two halves of the legacy `Hwfgenst` hypothesis: the + `tmp_*` alignment between `γ.genState.generated` and `σ`'s defined + keys, and the `old_*` freshness against `σ`. -/ +structure CoreGenStateRel (σ : CoreStore) (γ : CoreTransformState) : Prop where + /-- `tmp_*`-prefixed names in `γ.genState.generated` are exactly the + `tmp_*`-defined names in `σ`. -/ + tmpAlign : ∀ v, v ∈ γ.genState.generated ∧ isTempIdent v ↔ + (σ v).isSome ∧ isTempIdent v + /-- `old_*`-prefixed names are never defined in `σ`. -/ + oldFresh : ∀ v, isOldTempIdent v → (σ v).isNone + /-- The fresh-name generator state is well-formed. Folded in here so + `CoreGenStateRel` is the complete γ-vs-σ relation needed by the + call-elim proof. -/ + wfgen : CoreGenState.WF γ.genState + +/-- Bundle the σ-freshness chain: from a Nodup of the combined + `(γ.generated.reverse ++ argTemps ++ outTemps ++ genOldIdents)` plus + the temp/old predicates and a downstream `UpdateStates`, derive the + Nodup of the 3-segment list, the three per-segment σ-freshness facts, + and the lifted σ'-freshness fact. -/ +private theorem fresh_triple_σ_facts + {σ σ' : CoreStore} {γ : CoreTransformState} + {argTemps outTemps genOldIdents : List Expression.Ident} + {vs' : List Expression.Ident} {es' : List Expression.Expr} + (Hgenrel : CoreGenStateRel σ γ) + (Hgennd' : (γ.genState.generated.reverse ++ + argTemps ++ outTemps ++ genOldIdents).Nodup) + (HargTemp : Forall (fun x => isTempIdent x) argTemps) + (HoutTemp : Forall (fun x => isTempIdent x) outTemps) + (HoldIdentsTemp : Forall (fun x => isOldTempIdent x) genOldIdents) + (Hupdate : UpdateStates σ vs' es' σ') : + (argTemps ++ outTemps ++ genOldIdents).Nodup ∧ + Imperative.isNotDefined σ argTemps ∧ + Imperative.isNotDefined σ outTemps ∧ + Imperative.isNotDefined σ genOldIdents ∧ + Imperative.isNotDefined σ' (argTemps ++ outTemps ++ genOldIdents) := by + simp only [List.append_assoc] at Hgennd' + have Hsplit := List.nodup_append.mp Hgennd' + have Hnd3 : (argTemps ++ outTemps ++ genOldIdents).Nodup := by + simp only [List.append_assoc]; exact Hsplit.2.1 + have Hnot : ∀ x ∈ argTemps ++ (outTemps ++ genOldIdents), + x ∉ γ.genState.generated := fun x Hi Hg => + Hsplit.2.2 x (List.mem_reverse.mpr Hg) x Hi rfl + have HArg := fresh_temps_not_defined Hgenrel.tmpAlign + (fun _ h => Hnot _ (List.mem_append_left _ h)) HargTemp + have HOut := fresh_temps_not_defined Hgenrel.tmpAlign + (fun _ h => Hnot _ (List.mem_append_right _ (List.mem_append_left _ h))) HoutTemp + have HOld := fresh_olds_not_defined Hgenrel.oldFresh HoldIdentsTemp + refine ⟨Hnd3, HArg, HOut, HOld, UpdateStatesNotDefMonotone (fun v Hv => ?_) Hupdate⟩ + simp only [List.append_assoc, List.mem_append] at Hv + rcases Hv with h | h | h + · exact HArg v h + · exact HOut v h + · exact HOld v h + +/-- Call-elimination correctness for a single statement. + + Given a small-step `EvalStatementsContract` derivation of `[st]` + from σ to σ', the transformed list `sts` produced by `callElimStmt` + admits an `EvalStatementsContract` derivation from σ to some σ'' + that extends σ' on the freshly-introduced temp variables. The + call case chains L1–L6 via `EvalCallElim_glue`; non-call cases + are immediate. -/ +theorem callElimStatementCorrect [LawfulBEq Expression.Expr] + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} + {σ σ' : CoreStore} + {p : Program} + {γ γ' : CoreTransformState} + {st : Statement} + {sts : List Statement} + (Hp : ∀ pname, π pname = Program.Procedure.find? p ⟨pname, ()⟩) + (Heval : EvalStatementsContract π φ ⟨σ, δ, false⟩ [st] ⟨σ', δ, false⟩) + (Hwfc : WellFormedCoreEvalCong δ) + (Hwf : WF.WFStatementsProp p [st]) + (Hgenrel : CoreGenStateRel σ γ) + -- Call-site WF: pre/post vars are non-temp/non-old and disjoint + -- from `lhs`/inputs.keys/outputs.keys (six clauses; see WFCallSiteProp + -- in Strata/Languages/Core/WF.lean). + (Hwfcallsite : WFCallSiteProp p π st) + (Helim : (Except.ok sts, γ') = (runWith st (callElimStmt · p) γ)) : + ∃ σ'', + Inits σ' σ'' ∧ + EvalStatementsContract π φ ⟨σ, δ, false⟩ sts ⟨σ'', δ, false⟩ := by + -- Non-call cases close with σ'' = σ' (callElimStmt returns [st]); + -- call case extends σ' with fresh temp/old vars. Non-call branches + -- unified via `callElimStmt_non_call_eq`, dispatched through `nc_close`. + have nc_close : ∀ {b : Statement} (_ : st = b) + (_ : ∀ pn ar mt, b ≠ .cmd (CmdExt.call pn ar mt)), + ∃ σ'', Inits σ' σ'' ∧ + EvalStatementsContract π φ ⟨σ, δ, false⟩ sts ⟨σ'', δ, false⟩ := by + intro b heq hne + refine ⟨σ', Inits.init InitVars.init_none, ?_⟩ + have hsts := callElimStmt_non_call_eq hne (heq ▸ Helim) + rw [hsts]; rw [← heq]; exact Heval + cases hst : st with + | block lbl b md => exact nc_close hst (by intro _ _ _ h; cases h) + | ite cd tb eb md => exact nc_close hst (by intro _ _ _ h; cases h) + | loop g m i b md => exact nc_close hst (by intro _ _ _ h; cases h) + | exit lbl md => exact nc_close hst (by intro _ _ _ h; cases h) + | funcDecl f md => exact nc_close hst (by intro _ _ _ h; cases h) + | typeDecl tc md => exact nc_close hst (by intro _ _ _ h; cases h) + | cmd c => + cases c with + | cmd c' => exact nc_close hst (by intro _ _ _ h; cases h) + | call procName args md => + -- B1: Destructure Helim to expose triplet plumbing. + subst hst + simp only [runWith, StateT.run, callElimStmt, bind, pure, + StateT.bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk, ExceptT.pure, + modify, modifyGet, MonadStateOf.modifyGet, MonadState.modifyGet, + StateT.modifyGet, monadLift, MonadLift.monadLift, ExceptT.lift, + Functor.map, StateT.map] at Helim + -- Helim is now `(Except.ok sts, γ') = (match callElimCmd … γ_ext …)`. + -- Successive splits peel the outer pair-binder, the inner Except, + -- and the `Option (List Statement)`. + split at Helim + rename_i x_pair a_ce s_ce heq_ce + split at Helim + · -- inner `Except.ok` branch + rename_i a_opt heq_ok + -- a_opt : Option (List Statement) + -- Now Helim has a `match a_opt with | none => ... | some s' => ...`. + split at Helim + · -- `a_opt = none`: heq_ce says `callElimCmd ... = (Except.ok none, s_ce)`. + -- But `callElimCmd (CmdExt.call ...)` never returns `.none` — + -- only the `_ => return .none` catch-all does, which is + -- unreachable here. We discharge this via the equation. + refine ⟨σ', Inits.init InitVars.init_none, ?_⟩ + simp only [pure, StateT.pure, Prod.mk.injEq, Except.ok.injEq] at Helim + -- Helim.1 : sts = [Imperative.Stmt.cmd (CmdExt.call procName args md)] + rw [Helim.1]; exact Heval + · -- `a_opt = some s'`: this is the genuine call-elim case. + rename_i s' heq_some + simp only [pure, StateT.pure, Prod.mk.injEq, Except.ok.injEq] at Helim + -- B1/B2: callElimCmd_call_eq + Heval inversion to call_sem. + rw [Helim.1] + have ⟨ρ_inner, hstep_call, htail⟩ : ∃ ρ_inner, + Imperative.StepStmtStar Expression (EvalCommandContract π) + (EvalPureFunc φ) + (.stmt (Imperative.Stmt.cmd + (CmdExt.call procName args md)) + ⟨σ, δ, false⟩) + (.terminal ρ_inner) ∧ + Imperative.StepStmtStar Expression (EvalCommandContract π) + (EvalPureFunc φ) + (.stmts [] ρ_inner) + (.terminal ⟨σ', δ, false⟩) := by + unfold EvalStatementsContract Imperative.EvalStmtsSmall at Heval + match Heval with + | .step _ _ _ .step_stmts_cons hrest => + exact Imperative.seq_reaches_terminal Expression + (EvalCommandContract π) (EvalPureFunc φ) hrest + -- htail forces ρ_inner = ⟨σ',δ,false⟩. + have hρ_inner_eq : ρ_inner = ⟨σ', δ, false⟩ := by + match htail with + | .step _ _ _ .step_stmts_nil hrest' => + cases hrest' with + | refl => rfl + | step _ _ _ h _ => exact absurd h (by intro h; cases h) + subst hρ_inner_eq + -- Invert `hstep_call : StepStmtStar (.cmd (.call …)) … → terminal` to extract Hcc. + have Hcc : EvalCommandContract π δ σ + (CmdExt.call procName args md) σ' false := by + match hstep_call with + | .step _ _ _ (.step_cmd hcc) hrest => + cases hrest with + | refl => + -- call_sem hardwires the failure flag to false. + exact hcc + | step _ _ _ h _ => exact absurd h (by intro h; cases h) + cases Hcc with + | call_sem lkup hCallArgsIn hCallArgsLhs Hevalargs Hevalouts + Hwfval Hwfvars Hwfb Hwf2 HdefOver + Hinitin Hinitout Hpre Hhav1 Hpost Hrd Hupdate => + -- call_sem implicits: lhs σ₀ inArgs oVals argVals σA σAO σO proc modvals. + rename_i lhs σ₀ inArgs oVals argVals σA σAO σO proc modvals + -- B1-tail: destructure heq_ce via callElimCmd_call_eq. + obtain ⟨proc', argTrips, outTrips, genOldIdents, oldTys, + asserts, assumes, + s_arg, s_out, s_old, + Hfind, Heqarg, Heqout, Heqold, Holdtylen, + Hsts_struct, HassertsShape, HassumesShape⟩ := + callElimCmd_call_eq heq_ce + have Heqargs : argTrips.unzip.snd = + CallArg.getInputExprs args := + genArgExprIdentsTrip_snd Heqarg + have Heqouts : outTrips.unzip.snd = + CallArg.getLhs args := + genOutExprIdentsTrip_snd Heqout + -- Hoisted: arg-expr vars defined in σ (via Hevalargs). + have HargIsDef : Imperative.isDefined σ + (List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + inArgs) := + evalExpressions_isDefined_flatMap Hevalargs + -- Hoisted abbreviations for argument/output temp idents. + let argTemps : List Expression.Ident := + argTrips.unzip.fst.unzip.fst + let outTemps : List Expression.Ident := + outTrips.unzip.fst.unzip.fst + -- Pre-simped Hwfvars for repeated δ-fvar lookups. + have Hwfvr := Hwfvars + simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr + -- Generic δ-fvar lookup: `δ σ (fvar v) = σ v` for any σ. + have δ_fvar_eq : + ∀ (σ' : CoreStore) (v : Expression.Ident), + δ σ' (Lambda.LExpr.fvar () v none) = σ' v := by + intro σ' v + rw [Hwfvr (Lambda.LExpr.fvar () v none) v] + simp [Imperative.HasFvar.getFvar] + -- C1: aux facts derived from the destructured binders. + have Hwfgenargs : CoreGenState.WF s_arg.genState := by + apply genArgExprIdentsTripWFMono ?_ Heqarg + exact Hgenrel.wfgen + have Hwfgenouts : CoreGenState.WF s_out.genState := + genOutExprIdentsTripWFMono Hwfgenargs Heqout + have Hgenargs : + s_arg.genState.generated = + argTemps.reverse ++ + γ.genState.generated := by + have HH := genArgExprIdentsTripGeneratedWF Heqarg + -- {γ with ...}.genState = γ.genState; reduce. + exact HH + have Hgenouts : + s_out.genState.generated = + outTemps.reverse ++ + s_arg.genState.generated := + genOutExprIdentsTripGeneratedWF Heqout + have HargTemp : + Forall (fun x => isTempIdent x) + argTemps := + genArgExprIdentsTrip_isTempIdent Heqarg + have HoutTemp : + Forall (fun x => isTempIdent x) + outTemps := + genOutExprIdentsTrip_isTempIdent Heqout + -- Old-related aux facts. `oldVars` is the filter + -- expression in the live `callElimCmd`. + have Hwfgenolds : CoreGenState.WF s_old := + genOldExprIdentsTripWFMono Hwfgenouts Heqold + have Hgenolds : + s_old.generated = + genOldIdents.reverse ++ s_out.genState.generated := + genOldExprIdents_GeneratedWF Heqold + have HoldIdentsTemp : + Forall (fun x => isOldTempIdent x) genOldIdents := + genOldExprIdents_isOldTempIdent Heqold + -- Combined-extension equation: the post-old gen list is + -- the concatenation of all three reverse-segments and γ's gen. + have HgenApp : + s_old.generated = + genOldIdents.reverse ++ + outTemps.reverse ++ + argTemps.reverse ++ + γ.genState.generated := by + rw [Hgenolds, Hgenouts, Hgenargs] + simp [List.append_assoc] + -- Nodup of the combined list, in reversed-segment shape. + have Hgennd' : + (γ.genState.generated.reverse ++ + argTemps ++ + outTemps ++ + genOldIdents).Nodup := by + -- Project Nodup conjunct from Hwfgenolds (3-conj WF predicate). + have HndOld : s_old.generated.Nodup := Hwfgenolds.right.right + rw [HgenApp] at HndOld + have Hnd := nodup_reverse HndOld + simp only [List.reverse_append, List.reverse_reverse, + ← List.append_assoc] at Hnd + exact Hnd + -- Hgennd' nodup → 3-segment Nodup + arg/out/old σ-fresh + lifted to σ'. + obtain ⟨Hgennd, HndefArg_σ, HndefOut_σ, HndefOld_σ, Hndefgen⟩ := + fresh_triple_σ_facts Hgenrel Hgennd' HargTemp HoutTemp + HoldIdentsTemp Hupdate + -- ── Length facts ── + -- argTrips.length = argVals.length + have Hargtriplen : argTrips.length = argVals.length := by + rw [← List.unzip_snd_length argTrips, Heqargs, hCallArgsIn] exact EvalExpressionsLength Hevalargs - . -- substNoDup - simp [Imperative.substNodup] - rw [List.map_fst_zip] - rw [List.map_snd_zip] - . apply List.Disjoint_Nodup_iff.mp - refine ⟨Hinoutnd, ?_, ?_⟩ - . simp [← List.append_assoc] at Hgennd - have HH := List.nodup_append.mp Hgennd - apply List.Disjoint_Nodup_iff.mp - refine ⟨?_, ?_, ?_⟩ - . exact (List.nodup_append.mp HH.1).1 - . exact Hlhs.1 - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . exact HargTemp - . exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . apply List.Disjoint.symm - apply List.Disjoint_app.mp ⟨?_, ?_⟩ - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact HargTemp - . apply List.Forall_append.mpr ⟨?_, ?_⟩ - . exact List.Forall_PredImplies Hinlc CoreIdent.isLocl_isGlobOrLocl - . exact List.Forall_PredImplies Houtlc CoreIdent.isLocl_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . intros x Hin1 Hin2 - apply Hlhsdisj Hin1 - simp_all - . simp_all - simp [← Hargtriplen, ← Heqargs] - . simp_all - simp [← Hargtriplen, ← Heqargs] - . -- substDefined - intros k1 k2 Hin - have Hmem := List.of_mem_zip Hin - simp only [List.mem_append] at Hmem - apply And.intro - -- inputs and outputs defined in σR - . cases Hmem.1 with - | inl Hmem => - have Hdef : Imperative.isDefined σR₁ (ListMap.keys proc.header.inputs) := by - simp [← HσR₁] - apply updatedStatesDefMonotone - apply updatedStatesDefMonotone - apply HavocVarsDefMonotone ?_ Hhav2 - apply HavocVarsDefMonotone ?_ Hhav1 - apply InitStatesDefMonotone ?_ Hinitout - exact InitStatesDefined Hinitin - exact Hdef k1 Hmem - | inr Hmem => - have Hdef : Imperative.isDefined σR₁ (ListMap.keys proc.header.outputs) := by - simp [← HσR₁] - apply updatedStatesDefMonotone - apply updatedStatesDefMonotone - apply HavocVarsDefMonotone ?_ Hhav2 - apply HavocVarsDefMonotone ?_ Hhav1 - exact InitStatesDefined Hinitout - exact Hdef k1 Hmem - . cases Hmem.2 with - | inl Hmem => - apply updatedStatesDefMonotone <;> try assumption - apply updatedStatesDefMonotone <;> try assumption - apply updatedStatesDefined - simp_all - | inr Hmem => - apply updatedStatesDefMonotone <;> try assumption - apply updatedStatesDefMonotone <;> try assumption - apply updatedStatesDefMonotone <;> try assumption - apply updatedStatesDefMonotone <;> try assumption - -- args and outs are defined in σ₁ - . intros substPost HinSubst - refine ⟨?_, ?_, ?_⟩ - . -- store invariant - have Hndrd1 : (ListMap.keys proc.header.outputs ++ proc.spec.modifies).Nodup := by - refine List.Disjoint_Nodup_iff.mp ⟨Houtnd, Hmodsnd, ?_⟩ - -- disjoint between local and global - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isLocl ·)) - (Q:=(CoreIdent.isGlob ·)) - . exact Houtlc - . exact Hmodglob - . exact CoreIdent.Disjoint_isLocl_isGlob - have Hrd1 := UpdateStatesReadValues Houtnd Hup1 - have Hrd2 := UpdateStatesReadValues Hmodsnd Hup2 - have Heq2 := ReadValuesInjective Hrd2 Hrd'.2.2 - -- start reducing the update operation - apply InvStoresExceptInvStores (ks:= - (ListMap.keys proc.header.inputs ++ - ListMap.keys proc.header.outputs ++ - (List.map (Prod.fst ∘ Prod.fst) argTrips ++ - List.map Prod.snd outTrips))) - . apply Imperative.invStoresExceptComm - rw [← HσR₁] - apply InvStoresExceptUpdatedSame - apply InvStoresExceptUpdatedSame - . apply InvStoresExceptUpdatedMem - . rw [← Hrd'.1] - rw [List.zip_append] - rw [updatedStates'App] - rw [updatedStatesComm] - . apply InvStoresExceptUpdatedMem - . simp [UpdateStatesUpdated Hup2] - simp [← Heq2] - apply InvStoresExceptUpdatedSame - . apply Imperative.invStoresExceptComm - simp [UpdateStatesUpdated Hup1] - simp [InitStatesUpdated Hinitout] - simp [InitStatesUpdated Hinitin] - apply InvStoresExceptUpdatedMem - apply InvStoresExceptUpdatedMem - apply InvStoresExceptUpdatedMem - apply InvStoresExceptId - . simp [Harglen, ← Heqargs, Hargtriplen] - . intros x Hin - simp_all - . simp [Houtlen] - . intros x Hin - simp_all - . exact ReadValuesLength Hrd1 - . intros x Hin - simp_all - . exact ReadValuesLength Hrd2 - . exact Hmodsnd - . simp [← Houtlen , Houttriplen] - have Hlen := ReadValuesLength Hrd'.2.1 - simp at Hlen - exact Hlen - . intros x Hin - simp_all - . -- lhs disjoint from modifies, from WF - rw [List.unzip_zip] - rw [List.unzip_zip] - simp - . exact List.DisjointAppRight' Hlhsdisj - . simp [← Heq2] - exact ReadValuesLength Hrd2 - . have Hlen := ReadValuesLength Hrd'.2.1 - simp_all - . simp [← Houtlen , Houttriplen] - have Hlen := ReadValuesLength Hrd'.2.1 - simp at Hlen - exact Hlen - . simp [Hargtriplen] - . intros x Hin - simp_all - -- NOTE: can also use equivalent proof term: - -- exact List.mem_append.mpr (Or.inr (List.mem_append.mpr (Or.inl Hin))) - . simp [Houttriplen] - . exact (List.nodup_append.mp (List.nodup_append.mp Hgennd).2.1).1 - . simp [Holdtriplen] - . exact (List.nodup_append.mp (List.nodup_append.mp Hgennd).2.1).2.1 - . apply List.Disjoint.symm - exact List.removeAll_Disjoint - . -- TODO : all vars in substPost is a subset of subst ++ fst fst oldTrips - have Hin := postconditions_subst_unwrap HinSubst - cases Hin with - | intro post Hin => - have HH := prepostconditions_unwrap Hin.1 - cases HH with - | intro label HH => - cases HH with - | intro attr HH => - cases HH with - | intro md HH => - have Hpost := (List.Forall_mem_iff.mp wfpost _ HH) - have Hlcl := List.Forall_mem_iff.mp Hpost.lvars - have Hgl := List.Forall_mem_iff.mp Hpost.glvars - simp at Hlcl Hgl - intros x Hin1 Hin2 - have Hdisj : oldTrips.unzip.fst.unzip.fst.Disjoint oldTrips.unzip.snd := by - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlob ·)) - . simp; exact HoldTemp - . simp; exact Holdsndglob - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isGlob_isGlobOrLocl - have Hsubset := substsOldPostSubset (post:=(OldExpressions.normalizeOldExpr post)) (oldTrips:=oldTrips) Hdisj - have Hin : x ∈ (Imperative.HasVarsPure.getVars (P:=Expression) (OldExpressions.normalizeOldExpr post) ++ - oldTrips.unzip.fst.unzip.fst) := by - apply Hsubset - simp [Hin.2] at Hin2 - exact Hin2 - simp only [List.mem_append] at Hin Hin1 - cases Hin1 with - | inl Hin1 => - cases Hin with - | inl Hin => - -- disjoint of global/local with temp - have Hin := normalizeOldExprInVars Hin - specialize Hgl x Hin - apply CoreIdent.Disjoint_isTemp_isGlobOrLocl - . exact List.Forall_mem_iff.mp HargTemp x Hin1 - . exact Hgl - | inr Hin => - -- disjoint among temp - simp only [List.unzip_fst, List.map_map] at Hin - simp [CoreIdent.isGlobOrLocl] at Hgl - have HH := (List.nodup_append.mp Hgennd).2.2 - apply HH x Hin1 x - apply List.mem_append.mpr - apply (Or.inr Hin) - rfl - | inr Hin1 => - cases Hin with - | inl Hin => - have Hin := normalizeOldExprInVars Hin - specialize Hgl x Hin - -- x is either global or local - simp [CoreIdent.isGlobOrLocl] at Hgl - cases Hgl with - | inl Hg => - -- x is global - have Hlhs := List.Forall_mem_iff.mp Hlhs.2 - specialize Hlhs x Hin1 - exact CoreIdent.Disjoint_isLocl_isGlob _ Hlhs Hg - | inr Hl => - -- x is local, use wf - specialize Hlcl x Hin Hl - apply Hlhsdisj Hin1 - simp_all - | inr Hin => - -- oldTrips disjoint from lhs - simp only [List.unzip_fst, List.map_map] at Hin - apply CoreIdent.Disjoint_isTemp_isGlobOrLocl - . exact List.Forall_mem_iff.mp HoldTemp x Hin - . apply CoreIdent.isLocl_isGlobOrLocl - exact List.Forall_mem_iff.mp Hlhs.2 _ Hin1 - . -- post condition correct - have Hmem := SubstPostsMem HinSubst - cases Hmem with - | intro post Hin => - specialize Hpost post Hin.1 - simp [Hin.2] - -- simp [Imperative.WellFormedSemanticEvalBool] at Hwfb - -- apply (Hwfb _ _ _).1.1.mp - have Hsubst' : - δ σR₁ post = - δ σR₁ (OldExpressions.substsOldExpr (createOldVarsSubst oldTrips) (OldExpressions.normalizeOldExpr post)) - := by - cases Hwf2 with - | intro e Hwf2 => - rw [Hwf2.2 (e:=post)] - apply substsOldCorrect - -- wf - . assumption - . assumption - . assumption - -- wfTwoState, should be provable by setting inits to the oldVars created - . simp [WellFormedCoreEvalTwoState] - refine ⟨?_, ?_, Hwf2.2⟩ - . -- split into havoc and init, by setting inits to the oldVars created - simp [← HσR₁] - refine ⟨proc.spec.modifies, - (List.map (Prod.fst ∘ Prod.fst) outTrips) ++ - (List.map (Prod.fst ∘ Prod.fst) oldTrips), σR, ?_, ?_⟩ - . exact Hhav2 - . simp [updatedStates] - rw [← updatedStates'App] - rw [← List.zip_append] - rw [← updatedStates] - apply InitStatesInitVars - refine updatedStatesInit ?_ ?_ ?_ - . simp [Houttriplen, Holdtriplen] - . -- not defined - apply UpdateStatesNotDefMonotone _ Hup2 - apply UpdateStatesNotDefMonotone _ Hup1 - simp [InitStatesUpdated Hinitout] - apply UpdatedStatesDisjNotDefMonotone - . -- Disjoint between local and temp - apply List.Disjoint.symm - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact List.Forall_append.mpr ⟨HoutTemp, HoldTemp⟩ - . exact List.Forall_PredImplies Houtlc CoreIdent.isLocl_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . simp [Houtlen] - . simp [InitStatesUpdated Hinitin] - apply UpdatedStatesDisjNotDefMonotone - . -- Disjoint between local and temp - apply List.Disjoint.symm - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact List.Forall_append.mpr ⟨HoutTemp, HoldTemp⟩ - . exact List.Forall_PredImplies Hinlc CoreIdent.isLocl_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . simp [← Hargtriplen, Harglen, ← Heqargs] - . have Hndef := (Imperative.isNotDefinedApp' Hndefgen).2 - exact UpdateStatesNotDefMonotone' Hndef Hupdate - . exact (List.nodup_append.mp Hgennd).2.1 - . simp [Houttriplen] - . intros vs vs' σ₀ σ₁ σ m Hhav Hinit - grind - -- normalized - . apply OldExpressions.normalizeOldExprSound - have HH := prepostconditions_unwrap Hin.1 - cases HH with - | intro label HH => - cases HH with - | intro attr HH => - cases HH with - | intro md HH => - have Hwfpost := (List.Forall_mem_iff.mp wfpost _ HH).oldexprs - simp at Hwfpost - exact Hwfpost - . rw [createOldStoreSubstEq] - have Hhav := HavocVarsUpdateStates Hhav1 - cases Hhav with - | intro modvals Hhav => - apply ReadValuesSubstStores - apply UpdateStatesReadValuesMonotone (σ:=σAO) (vs:=oldVals) _ ?_ Hhav - . -- Nodup - apply List.Disjoint_Nodup_iff.mp - refine ⟨?_, ?_, ?_⟩ - . have Heq := genOldExprIdentsTrip_snd Heqold - simp [Heq] - apply filter_nodup - apply eraseDups_Nodup - . exact Houtnd - . -- Disjoint between local and temp - apply List.Disjoint.symm - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isLocl ·)) - (Q:=(CoreIdent.isGlob ·)) - . exact Houtlc - . simp [genOldExprIdentsTrip_snd Heqold] - apply List.Forall_PredImplies - . apply List.Forall_filter - . exact WFProgGlob Hwfp - . exact CoreIdent.Disjoint_isLocl_isGlob - . apply InitStatesReadValuesMonotone (σ:=σA) ?_ Hinitout - . apply InitStatesReadValuesMonotone (σ:=σ) ?_ Hinitin - simp only [List.unzip_snd] - exact HoldVals - . simp [← HσR₁] - apply ReadValuesUpdatedStatesSame - simp [Holdtriplen] - exact (List.nodup_append.mp (List.nodup_append.mp Hgennd).2.1).2.1 - . rw [createOldStoreSubstEq] - intros k1 k2 Hin - have Hmem := List.of_mem_zip Hin - apply And.intro - . have Hdef : Imperative.isDefined σO (oldTrips.unzip.snd) := by - apply HavocVarsDefMonotone ?_ Hhav1 - apply InitStatesDefMonotone ?_ Hinitout - apply InitStatesDefMonotone ?_ Hinitin - simp only [List.unzip_snd] - exact HoldDef - exact Hdef k1 Hmem.1 - . have Hdef : Imperative.isDefined σR₁ oldTrips.unzip.fst.unzip.fst := by - simp [← HσR₁] - apply updatedStatesDefined - simp [Holdtriplen] - exact Hdef k2 Hmem.2 - . rw [createOldStoreSubstEq] - simp [Imperative.substNodup] - simp [← List.unzip_fst, ← List.unzip_snd] - rw [List.unzip_zip] - simp - apply List.Disjoint_Nodup_iff.mp - . refine ⟨?_, ?_, ?_⟩ - . -- oldTrips.unzip.2 Nodup. needs some equivalence - have Heq := genOldExprIdentsTrip_snd Heqold - simp only [Heq] - apply filter_nodup - apply eraseDups_Nodup - . exact (List.nodup_append.mp (List.nodup_append.mp Hgennd).2.1).2.1 - . apply List.Disjoint.symm - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlob ·)) - . exact HoldTemp - . simp [genOldExprIdentsTrip_snd Heqold] - apply List.Forall_PredImplies - . apply List.Forall_filter - . exact WFProgGlob Hwfp - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isGlob_isGlobOrLocl - . simp [Holdtriplen] - . apply List.Disjoint_Subset_right (ks:=(Imperative.HasVarsPure.getVars post)) - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . simp - exact HoldTemp - . have HH := prepostconditions_unwrap Hin.1 - cases HH with - | intro label HH => - cases HH with - | intro attr HH => - cases HH with - | intro md HH => - have Hwf := (List.Forall_mem_iff.mp wfpost _ HH).glvars - simp at Hwf - exact Hwf - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . refine extractedOldVarsInVars ?_ - have HH := prepostconditions_unwrap Hin.1 - cases HH with - | intro label HH => - cases HH with - | intro attr HH => - cases HH with - | intro md HH => - have Hwf := (List.Forall_mem_iff.mp wfpost _ HH).oldexprs - simp at Hwf - exact Hwf - rw [← Hsubst'] - simp [← HσR₁] - apply EvalExpressionUpdatedStates <;> try assumption - . simp [Holdtriplen] - . exact (List.nodup_append.mp (List.nodup_append.mp Hgennd).2.1).2.1 - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact HoldTemp - . have HH := prepostconditions_unwrap Hin.1 - cases HH with - | intro label HH => - cases HH with - | intro attr HH => - cases HH with - | intro md HH => - have Hwf := (List.Forall_mem_iff.mp wfpost _ HH).glvars - simp at Hwf - exact Hwf - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - apply EvalExpressionUpdatedStates <;> try assumption - . simp [Houttriplen] - . exact (List.nodup_append.mp (List.nodup_append.mp Hgennd).2.1).1 - . apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact HoutTemp - . have HH := prepostconditions_unwrap Hin.1 - cases HH with - | intro label HH => - cases HH with - | intro attr HH => - cases HH with - | intro md HH => - have Hwf := (List.Forall_mem_iff.mp wfpost _ HH).glvars - simp at Hwf - exact Hwf - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact Hpost.2 - . -- substStores, provable - apply ReadValuesSubstStores (vs:=argVals ++ v1) - . apply ReadValuesApp - . simp [← HσR₁] - apply InitStatesReadValuesMonotone (σ:=σR) - . -- read values - apply UpdateStatesReadValuesMonotone (σ:=σO) _ ?_ Hup2 - . -- nodup between inputs and modifies - apply List.Disjoint_Nodup_iff.mp - refine ⟨?_, ?_, ?_⟩ - . exact Hinnd - . exact Hmodsnd - . -- Disjoint between local and temp - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isLocl ·)) - (Q:=(CoreIdent.isGlob ·)) - . exact Hinlc - . exact Hmodglob - . exact CoreIdent.Disjoint_isLocl_isGlob - . apply UpdateStatesReadValuesMonotone (σ:=σAO) _ ?_ Hup1 - . exact Hinoutnd - . apply InitStatesReadValuesMonotone (σ:=σA) _ Hinitout - . apply InitStatesReadValues (σ:=σ) Hinitin - . simp [updatedStates] - rw [← updatedStates'App] - rw [← List.zip_append] - rw [← updatedStates] - apply updatedStatesInit - . simp [Holdtriplen, Houttriplen] - . -- not defined - apply UpdateStatesNotDefMonotone _ Hup2 - apply UpdateStatesNotDefMonotone _ Hup1 - simp [InitStatesUpdated Hinitout] - apply UpdatedStatesDisjNotDefMonotone - . -- Disjoint between local and temp - apply List.Disjoint.symm - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact List.Forall_append.mpr ⟨HoutTemp, HoldTemp⟩ - . refine List.Forall_PredImplies Houtlc CoreIdent.isLocl_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . simp [Houtlen] - . simp [InitStatesUpdated Hinitin] - apply UpdatedStatesDisjNotDefMonotone - . -- Disjoint between local and temp - apply List.Disjoint.symm - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact List.Forall_append.mpr ⟨HoutTemp, HoldTemp⟩ - . refine List.Forall_PredImplies Hinlc CoreIdent.isLocl_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . simp [← Hargtriplen, Harglen, ← Heqargs] - . have Hndef := (Imperative.isNotDefinedApp' Hndefgen).2 - exact UpdateStatesNotDefMonotone' Hndef Hupdate - . exact (List.nodup_append.mp Hgennd).2.1 - . simp [Houttriplen] - . simp [← HσR₁] - apply ReadValuesUpdatedStates - . simp [Holdtriplen] - . -- Disjoint between local and temp - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact HoldTemp - . refine List.Forall_PredImplies Houtlc CoreIdent.isLocl_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . apply ReadValuesUpdatedStates - . simp [Houttriplen] - . -- Disjoint between local and temp - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . exact HoutTemp - . refine List.Forall_PredImplies Houtlc CoreIdent.isLocl_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . exact Hrd'.2.1 - . apply ReadValuesApp - . apply ReadValuesUpdatedStates - . simp [Holdtriplen] - . simp only [nodup_swap'] at Hgennd - simp only [List.append_assoc] at Hgennd - exact (List.Disjoint_Nodup_iff.mpr (List.nodup_append.mp Hgennd).2.1).2.2 - . apply ReadValuesUpdatedStates - . simp [Houttriplen] - . simp only [← List.append_assoc] at Hgennd - exact List.Disjoint.symm (List.Disjoint_Nodup_iff.mpr (List.nodup_append.mp Hgennd).1).2.2 - . apply ReadValuesUpdatedStatesSame - . simp [Hargtriplen] - . exact (List.nodup_append.mp Hgennd).1 - . simp [← Hrd'.1] - rw [List.zip_append, updatedStates'App] - . apply ReadValuesUpdatedStates - . simp [Holdtriplen] - . -- Disjoint between local and temp - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . exact HoldTemp - . exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . apply ReadValuesUpdatedStates - . simp [Houttriplen] - . -- Disjoint between local and temp - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . exact HoutTemp - . exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . apply ReadValuesUpdatedStates - . simp [Hargtriplen] - . -- Disjoint between local and temp - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isLocl ·)) - . exact HargTemp - . exact Hlhs.2 - . apply List.PredDisjoint_PredImplies_right - exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - exact CoreIdent.isLocl_isGlobOrLocl - . apply ReadValuesUpdatedStates - . exact ReadValuesLength Hrd'.2.2 - . intros x Hin1 Hin2 - apply Hlhsdisj Hin2 - simp_all - . apply ReadValuesUpdatedStatesSame - . simp [Houttriplen, ← Houtlen] - have HH := ReadValuesLength Hrd'.2.1 - simp at HH - exact HH - . exact Hlhs.1 - . simp [Houttriplen, ← Houtlen] - have HH := ReadValuesLength Hrd'.2.1 - simp at HH - exact HH - . -- length of input and argTrips - simp [createFvars] - have Heq := InitStatesLength Hinitin - simp_all - . -- length of output and outVals - simp_all - . simp - have Hlen := UpdateStatesLength Hupdate - rw [List.map_fst_zip] - rw [List.map_fst_zip] - . -- Disjoint between old labels and lhs, modified, and modvals - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . simp at HargTemp - exact HargTemp - . apply List.Forall_append.mpr ⟨?_, ?_⟩ - . exact List.Forall_PredImplies Hlhs.2 CoreIdent.isLocl_isGlobOrLocl - . exact List.Forall_PredImplies Hmodglob CoreIdent.isGlob_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . simp_all - . simp_all - . -- Disjoint between old labels and lhs, modified, and modvals - simp - rw [List.map_fst_zip] - rw [List.map_fst_zip (l₂:=modvals)] - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . simp at HoutTemp - exact HoutTemp - . apply List.Forall_append.mpr ⟨?_, ?_⟩ - . exact List.Forall_PredImplies Hlhs.2 CoreIdent.isLocl_isGlobOrLocl - . exact List.Forall_PredImplies Hmodglob CoreIdent.isGlob_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . have Hlen := UpdateStatesLength Hupdate - omega - . simp_all - . -- Disjoint between generated out labels and lhs ++ modifies - simp - rw [List.map_fst_zip] - rw [List.map_fst_zip (l₂:=modvals)] - apply List.PredDisjoint_Disjoint - (P:=(CoreIdent.isTemp ·)) - (Q:=(CoreIdent.isGlobOrLocl ·)) - . simp at HoldTemp - exact HoldTemp - . apply List.Forall_append.mpr ⟨?_, ?_⟩ - . exact List.Forall_PredImplies Hlhs.2 CoreIdent.isLocl_isGlobOrLocl - . exact List.Forall_PredImplies Hmodglob CoreIdent.isGlob_isGlobOrLocl - . exact CoreIdent.Disjoint_isTemp_isGlobOrLocl - . have Hlen := UpdateStatesLength Hupdate - omega - . simp_all - -/ - --/ --/ + -- outTrips.length = oVals.length + have Houttriplen : outTrips.length = oVals.length := by + rw [← List.unzip_snd_length outTrips, Heqouts, hCallArgsLhs] + exact ReadValuesLength Hevalouts + have HargTempsLen : argTemps.length = argVals.length := by + simp [argTemps, List.unzip_eq_map, Hargtriplen] + have HoutTempsLen : outTemps.length = oVals.length := by + simp [outTemps, List.unzip_eq_map, Houttriplen] + -- C1: Derive Hinoutnd from the call_sem InitStates binders. + have Hinnd_io : (proc.header.inputs.keys).Nodup := + InitStatesNodup Hinitin + have Houtnd_io : (proc.header.outputs.keys).Nodup := + InitStatesNodup Hinitout + have Hindef_io : + Imperative.isDefined σA (proc.header.inputs.keys) := + InitStatesDefined Hinitin + have Houtndef_io : + Imperative.isNotDefined σA (proc.header.outputs.keys) := + InitStatesNotDefined Hinitout + have Hiodisj : + (proc.header.inputs.keys).Disjoint + (proc.header.outputs.keys) := by + intro x Hin1 Hin2 + exact σ_some_contradiction + (Hindef_io x Hin1) (Houtndef_io x Hin2) + have Hinoutnd : + (proc.header.inputs.keys ++ + proc.header.outputs.keys).Nodup := by + rw [List.nodup_append] + refine ⟨Hinnd_io, Houtnd_io, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact Hiodisj Ha Hb + -- C2: bind `oldVars` (filter from Hsts_struct) for HoldVals/Holdtriplen. + let oldVars : List Expression.Ident := callElim_oldVars proc' args + -- `oldVars ⊆ lhs` because the filter narrows `lhs` ↪ `oldVars`. + -- `Hevalouts : ReadValues σ lhs oVals` then forces every + -- element of `lhs` (and hence `oldVars`) defined in σ. + have HrdOldDef : Imperative.isDefined σ oldVars := by + intro g Hg + have Hg_in_getLhs : g ∈ CallArg.getLhs args := + (List.mem_filter.mp Hg).1 + -- `hCallArgsLhs : CallArg.getLhs args = lhs` (forward). + have Hg_in_lhs : g ∈ lhs := hCallArgsLhs ▸ Hg_in_getLhs + have Hlhs_def : Imperative.isDefined σ lhs := + ReadValuesIsDefined Hevalouts + exact Hlhs_def g Hg_in_lhs + -- Existential reading of `oldVars` against σ. + obtain ⟨oldVals, HoldVals⟩ := + isDefinedReadValues HrdOldDef + -- Length facts. + have HoldValsLen : oldVals.length = oldVars.length := + (ReadValuesLength HoldVals).symm + -- genOld = oldTys = oldVars length facts for trip-shape. + have HgenOldLen : genOldIdents.length = oldVars.length := + genOldExprIdents_length Heqold + have HoldTysLen : oldTys.length = oldVars.length := Holdtylen + have HgenOldOldValsLen : genOldIdents.length = oldVals.length := by + rw [HgenOldLen, ← HoldValsLen] + have Holdtriplen : + oldVals.length = + ((genOldIdents.zip oldTys).zip oldVars).length := by + rw [HoldValsLen] + simp [List.length_zip, HgenOldLen, HoldTysLen] + -- C3: σ'' = updatedStates σ' (argTemps++outTemps++genOldIdents) (...). + have Hinit := + updatedStatesInit (P := Expression) ?_ ?_ ?_ (σ := σ') + (hs := argTemps + ++ outTemps + ++ genOldIdents) + (vs := argVals ++ oVals ++ oldVals) + rotate_left + · -- length of `hs` = length of `vs` (segment-wise close) + simp [argTemps, outTemps, List.length_append, List.unzip_eq_map, Hargtriplen, Houttriplen, HgenOldOldValsLen] + · exact Hndefgen + · exact Hgennd + -- σ'' is the updatedStates σ' … form; D2 may use InitsUpdatesComm. + refine ⟨updatedStates σ' + (argTemps + ++ outTemps + ++ genOldIdents) + (argVals ++ oVals ++ oldVals), ?_, ?_⟩ + · -- First conjunct: Inits σ' σ''. + exact InitStatesInits Hinit + · -- L1-L6 chain via EvalCallElim_glue. + obtain ⟨HargNd, HoutNd, HoldNd, + HargOutDisj, HargOldDisj, HoutOldDisj⟩ := + nodup_3_decompose Hgennd + -- argTemps fresh from σ; arg-expr vars defined in σ ⇒ disjoint. + have HdefVars : Imperative.isDefined σ + (List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + (CallArg.getInputExprs args)) := + hCallArgsIn ▸ HargIsDef + have HargExprDisj : + argTemps.Disjoint + (List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + argTrips.unzip.snd) := by + intro x Hin1 Hin2 + -- Rewrite Hin2 via Heqargs so we can use HdefVars. + rw [Heqargs] at Hin2 + -- HndefArg_σ says σ x = none; HdefVars says (σ x).isSome. + exact notin_of_isSome_isNotDefined (HdefVars x Hin2) HndefArg_σ Hin1 + -- ── L1: argInit ── + have HevalArgs' : + EvalExpressions (P:=Core.Expression) δ σ + argTrips.unzip.snd argVals := by + rw [Heqargs, hCallArgsIn] + exact Hevalargs + have HL1 : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + (Core.Transform.createInits argTrips md) + ⟨updatedStates σ argTemps + argVals, δ, false⟩ := + H_inits Hwfvars Hwfval Hwfc HargExprDisj HargNd + HevalArgs' HndefArg_σ + -- L2: outInit (lift Hevalouts to σ_arg via readValues_updatedStates). + have Hlhs_isLocl : + Imperative.isDefined σ lhs := + ReadValuesIsDefined Hevalouts + have HlhsDisjArg : lhs.Disjoint argTemps := fun x Hin1 Hin2 => + notin_of_isSome_isNotDefined (Hlhs_isLocl x Hin1) HndefArg_σ Hin2 + have HlhsDisjOut : lhs.Disjoint outTemps := fun x Hin1 Hin2 => + notin_of_isSome_isNotDefined (Hlhs_isLocl x Hin1) HndefOut_σ Hin2 + have HlhsDisjOld : lhs.Disjoint genOldIdents := fun x Hin1 Hin2 => + notin_of_isSome_isNotDefined (Hlhs_isLocl x Hin1) HndefOld_σ Hin2 + -- Out-temp Nodup append form for `H_initVars`. + have HoutSnd_eq_lhs : outTrips.unzip.snd = lhs := by + rw [Heqouts, hCallArgsLhs] + have HlhsNd : lhs.Nodup := by + -- Project WFcallProp.lhsWF via Hwf's Forall_cons head. + have Hwfst_head := (List.Forall_cons _ _ _).mp Hwf + have Hwfcall : WF.WFcallProp p procName args := Hwfst_head.1 + have Hlhs_args_nd : + (CallArg.getLhs args).Nodup := Hwfcall.lhsWF + rwa [hCallArgsLhs] at Hlhs_args_nd + have Hout_nd_app : + List.Nodup (outTemps + ++ outTrips.unzip.snd) := by + rw [HoutSnd_eq_lhs] + rw [List.nodup_append] + refine ⟨HoutNd, HlhsNd, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact HlhsDisjOut Hb Ha + -- ReadValues over the σ_arg store. + have HrdOuts_argLayer : + ReadValues + (updatedStates σ argTemps + argVals) + outTrips.unzip.snd oVals := by + rw [HoutSnd_eq_lhs] + exact readValues_updatedStates HargTempsLen HlhsDisjArg Hevalouts + -- outTemps undefined in σ_arg (argTemps disjoint from outTemps). + have HndefOut_argLayer : + Imperative.isNotDefined + (updatedStates σ argTemps + argVals) + outTemps := by + intro v Hv + have Hv_notin : v ∉ argTemps := fun Hin => HargOutDisj Hin Hv + rw [updatedStates_get_notin (σ:=σ) (ks:=argTemps) (vs:=argVals) Hv_notin] + exact HndefOut_σ v Hv + have HL2 : + EvalStatementsContract π φ + ⟨updatedStates σ argTemps + argVals, δ, false⟩ + (Core.Transform.createInitVars outTrips md) + ⟨updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals, δ, false⟩ := + H_initVars Hwfvars Hout_nd_app HrdOuts_argLayer + HndefOut_argLayer + -- L3: oldInit; oldTrips := (genOldIdents.zip oldTys).zip oldVars. + let oldTrips : + List ((Expression.Ident × Expression.Ty) × + Expression.Ident) := + (genOldIdents.zip oldTys).zip oldVars + have HoldTripsFst : + oldTrips.unzip.fst.unzip.fst = genOldIdents := by + have HzipLen : + (genOldIdents.zip oldTys).length = oldVars.length := by + simp [List.length_zip, HgenOldLen, HoldTysLen] + show ((genOldIdents.zip oldTys).zip oldVars).unzip.fst.unzip.fst + = genOldIdents + simp [List.unzip_eq_map, List.map_fst_zip, HzipLen, + HgenOldLen, HoldTysLen] + have HoldTripsSnd : + oldTrips.unzip.snd = oldVars := by + have HzipLen : + (genOldIdents.zip oldTys).length = oldVars.length := by + simp [List.length_zip, HgenOldLen, HoldTysLen] + rw [show oldTrips = (genOldIdents.zip oldTys).zip oldVars + from rfl] + simp [List.unzip_eq_map, List.map_snd_zip, HzipLen] + -- Disjointness of oldVars from argTemps/outTemps and + -- oldVars Nodup follow from `oldVars ⊆ lhs`. + have HoldVars_sub_lhs : ∀ g ∈ oldVars, g ∈ lhs := by + intro g Hg + have Hg_in_getLhs : g ∈ CallArg.getLhs args := + (List.mem_filter.mp Hg).1 + exact hCallArgsLhs ▸ Hg_in_getLhs + have oldVars_disj_via_lhs : + ∀ {ks : List Expression.Ident}, lhs.Disjoint ks → oldVars.Disjoint ks := + fun H x Hin1 Hin2 => H (HoldVars_sub_lhs x Hin1) Hin2 + have HoldVarsDisjArg : oldVars.Disjoint argTemps := oldVars_disj_via_lhs HlhsDisjArg + have HoldVarsDisjOut : oldVars.Disjoint outTemps := oldVars_disj_via_lhs HlhsDisjOut + have HoldVarsDisjOldT : oldVars.Disjoint genOldIdents := oldVars_disj_via_lhs HlhsDisjOld + have HoldVarsNd : oldVars.Nodup := by + -- oldVars ⊆ (CallArg.getLhs args) = lhs via filter sublist. + have HlhsArgs_nd : (CallArg.getLhs args).Nodup := by + rw [hCallArgsLhs] + exact HlhsNd + exact List.Sublist.nodup List.filter_sublist HlhsArgs_nd + -- Lift HoldVals through 2 layers via readValues_updatedStates. + have HrdOlds_outLayer : + ReadValues + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldVars oldVals := + readValues_updatedStates HoutTempsLen HoldVarsDisjOut + (readValues_updatedStates HargTempsLen HoldVarsDisjArg HoldVals) + -- Rewrite oldVars to oldTrips.unzip.snd for H_initVars. + have HrdOldTrips : + ReadValues + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.snd oldVals := by + rw [HoldTripsSnd] + exact HrdOlds_outLayer + -- genOldIdents disjoint from argTemps/outTemps ⇒ undef in σ_out. + have HndefOld_outLayer : + Imperative.isNotDefined + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + genOldIdents := by + intro v Hv + have Hv_notin_out : + ¬ v ∈ outTemps := by + intro Hin + exact HoutOldDisj Hin Hv + have Hv_notin_arg : + ¬ v ∈ argTemps := by + intro Hin + exact HargOldDisj Hin Hv + rw [updatedStates_2layer_get_notin + Hv_notin_arg Hv_notin_out] + exact HndefOld_σ v Hv + -- Rewrite genOldIdents to oldTrips.unzip.fst.unzip.fst for H_initVars. + have HndefOldTrips : + Imperative.isNotDefined + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst := by + rw [HoldTripsFst] + exact HndefOld_outLayer + -- Nodup precondition: (genOldIdents ++ oldVars).Nodup. + have HoldTrips_nd_app : + List.Nodup + (oldTrips.unzip.fst.unzip.fst ++ oldTrips.unzip.snd) := by + rw [HoldTripsFst, HoldTripsSnd] + rw [List.nodup_append] + refine ⟨HoldNd, HoldVarsNd, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact HoldVarsDisjOldT Hb Ha + have HL3 : + EvalStatementsContract π φ + ⟨updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals, δ, false⟩ + (Core.Transform.createInitVars oldTrips md) + ⟨updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals, δ, false⟩ := + H_initVars Hwfvars HoldTrips_nd_app HrdOldTrips + HndefOldTrips + -- D2: L4 (asserts), L5 (havocs), L6 (assumes) chain. + rw [Hsts_struct] + -- L5: build post-havoc store σ_havoc by HavocVars segments on σ' = σ.update lhs modvals. + have Hhav_σ : HavocVars σ lhs σ' := + UpdateStatesHavocVars Hupdate + have Hhav_arg : + HavocVars (updatedStates σ + argTemps argVals) + lhs + (updatedStates σ' + argTemps argVals) := + havocVars_updatedStates_lift HlhsDisjArg Hhav_σ + have Hhav_out : + HavocVars + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + lhs + (updatedStates + (updatedStates σ' + argTemps argVals) + outTemps oVals) := + havocVars_updatedStates_lift HlhsDisjOut Hhav_arg + have Hhav_old : + HavocVars + (updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) + lhs + (updatedStates + (updatedStates + (updatedStates σ' + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) := by + rw [HoldTripsFst] + apply havocVars_updatedStates_lift HlhsDisjOld Hhav_out + -- isDefined σ_old lhs (via 3-layer extension monotone). + have HlhsDef_old : + Imperative.isDefined + (updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) lhs := + isDefined_3layer_lift HlhsDisjArg HlhsDisjOut + (HoldTripsFst ▸ HlhsDisjOld) Hlhs_isLocl + -- HL5: 3-layer havocs over lhs from σ_old → σ_havoc (uses hCallArgsLhs.symm). + have HL5_pre : + EvalStatementsContract π φ + ⟨updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals, δ, false⟩ + (Core.Transform.createHavocs lhs md) + ⟨updatedStates + (updatedStates + (updatedStates σ' + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals, δ, false⟩ := + H_havocs Hwfvars HlhsDef_old Hhav_old + -- Equality: σ_havoc (3-layer over σ') = σ'' (flat) via zip-append. + have HoldFstLen : + oldTrips.unzip.fst.unzip.fst.length = oldVals.length := by + rw [HoldTripsFst, HgenOldLen, HoldValsLen] + have Hflatten_eq : + updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) = + updatedStates + (updatedStates + (updatedStates σ' + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals := by + rw [HoldTripsFst] + simp only [updatedStates] + -- (a ++ b ++ c).zip (av ++ bv ++ cv) = a.zip av ++ b.zip bv ++ c.zip cv. + have Hzip1 : + ((argTemps ++ + outTemps) ++ genOldIdents).zip + ((argVals ++ oVals) ++ oldVals) = + (argTemps ++ + outTemps).zip + (argVals ++ oVals) ++ + genOldIdents.zip oldVals := + List.zip_append (by + rw [List.length_append, List.length_append, + HargTempsLen, HoutTempsLen]) + have Hzip2 : + (argTemps ++ + outTemps).zip + (argVals ++ oVals) = + argTemps.zip argVals ++ + outTemps.zip oVals := + List.zip_append HargTempsLen + rw [Hzip1, Hzip2] + rw [updatedStates'App, updatedStates'App] + have HL5 : + EvalStatementsContract π φ + ⟨updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals, δ, false⟩ + (Core.Transform.createHavocs (CallArg.getLhs args) md) + ⟨updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals), δ, false⟩ := by + rw [Hflatten_eq, hCallArgsLhs] + exact HL5_pre + -- D2a: per-precondition payload for L4 (asserts). + have HprocEq : proc' = proc := by + have Hπ := Hp procName + rw [Hπ] at lkup + rw [Hfind] at lkup + exact (Option.some_inj.mp lkup.symm).symm + -- Bridge `c ∈ proc'.spec.postconditions.values` to + -- `c.expr ∈ getCheckExprs proc.spec.postconditions` via HprocEq. + have c_in_postExprs_of_proc' : + ∀ c, c ∈ proc'.spec.postconditions.values → + c.expr ∈ Procedure.Spec.getCheckExprs + proc.spec.postconditions := by + intro c Hc_in + simp only [Procedure.Spec.getCheckExprs, List.mem_map] + refine ⟨c, ?_, rfl⟩ + rw [HprocEq] at Hc_in + rw [ListMap.values_eq_map_snd] + rwa [ListMap.values_eq_map_snd] at Hc_in + -- Specialize Hwfcallsite (over `proc`) to the call form; + -- spike uses `proc'` which HprocEq bridges. + obtain ⟨HpreVarsFresh, HpostVarsFresh, HargVarsNotInLhs, + HinoutFresh, HargVarsNotInOutKeys, + HargVarsNotInInKeys, HoutAlign⟩ := + Hwfcallsite.specialize (procName := procName) + (args := args) (md := md) rfl lkup + -- Lift HpostVarsFresh to take c ∈ proc'.spec.postconditions.values. + have HpostVarsFresh_via_c : + ∀ c ∈ proc'.spec.postconditions.values, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) c.expr, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ + v ∉ CallArg.getLhs args := by + intro c Hc_in v Hv + exact HpostVarsFresh c.expr (c_in_postExprs_of_proc' c Hc_in) v Hv + -- C-aux: hoisted disjointness facts (used by L4 + L6). + have HinputsFresh : + ∀ v ∈ proc.header.inputs.keys, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v := by + intro v Hv + exact HinoutFresh v (List.mem_append.mpr (Or.inl Hv)) + have HoutputsFresh : + ∀ v ∈ proc.header.outputs.keys, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v := by + intro v Hv + exact HinoutFresh v (List.mem_append.mpr (Or.inr Hv)) + -- inputs.keys ∩ argTemps = ∅ (inputs not tmp_). + have HinKeys_disj_argTemps : proc.header.inputs.keys.Disjoint argTemps := + fun v Hv1 Hv2 => notMem_of_Forall_neg HargTemp (HinputsFresh v Hv1).1 Hv2 + have HinKeys_disj_outTemps : proc.header.inputs.keys.Disjoint outTemps := + fun v Hv1 Hv2 => notMem_of_Forall_neg HoutTemp (HinputsFresh v Hv1).1 Hv2 + have HinKeys_disj_olds : proc.header.inputs.keys.Disjoint genOldIdents := + fun v Hv1 Hv2 => notMem_of_Forall_neg HoldIdentsTemp (HinputsFresh v Hv1).2 Hv2 + have HoutKeys_disj_argTemps : proc.header.outputs.keys.Disjoint argTemps := + fun v Hv1 Hv2 => notMem_of_Forall_neg HargTemp (HoutputsFresh v Hv1).1 Hv2 + have HoutKeys_disj_outTemps : proc.header.outputs.keys.Disjoint outTemps := + fun v Hv1 Hv2 => notMem_of_Forall_neg HoutTemp (HoutputsFresh v Hv1).1 Hv2 + have HoutKeys_disj_olds : proc.header.outputs.keys.Disjoint genOldIdents := + fun v Hv1 Hv2 => notMem_of_Forall_neg HoldIdentsTemp (HoutputsFresh v Hv1).2 Hv2 + -- inputs.keys ∩ lhs = ∅: σ-undefined inputs vs σ-defined lhs. + have HinKeys_disj_lhs : + proc.header.inputs.keys.Disjoint lhs := fun v Hv1 Hv2 => + notin_of_isSome_isNotDefined (Hlhs_isLocl v Hv2) (InitStatesNotDefined Hinitin) Hv1 + -- outputs.keys ∩ lhs = ∅: σA-undefined outputs vs σ-defined lhs. + have HoutKeys_disj_lhs : + proc.header.outputs.keys.Disjoint lhs := by + intro v Hv1 Hv2 + have HvσA_none : σA v = none := Houtndef_io v Hv1 + have HvNotInInputs : v ∉ proc.header.inputs.keys := + fun h => Hiodisj h Hv1 + have HvσA_eq_σ : σA v = σ v := + initStates_get_notin Hinitin HvNotInInputs + have Hvσ_none : σ v = none := by + rw [← HvσA_eq_σ]; exact HvσA_none + exact σ_some_contradiction (Hlhs_isLocl v Hv2) Hvσ_none + -- Restrict to the filtered preconditions. + let presFiltered : List (CoreLabel × Procedure.Check) := + proc.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free) + -- Bind σAO definedness/eval-tt for each filtered entry. + have HpreFiltered : + ∀ entry ∈ presFiltered, + Imperative.isDefinedOver + (Imperative.HasVarsPure.getVars (P:=Expression)) + σAO entry.snd.expr ∧ + δ σAO entry.snd.expr = some Imperative.HasBool.tt := by + intro entry Hentry + exact Hpre entry.snd.expr (filterCheck_in_getCheckExprs Hentry) + -- Pre-var freshness lemma against σ_old / σAO. + have HpresVarsFresh' : + ∀ entry ∈ presFiltered, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ + v ∉ CallArg.getLhs args := fun entry Hentry v Hv => + HpreVarsFresh entry.snd.expr + (filterCheck_mem_getCheckExprs Hentry) v Hv + -- HpresPayload (D2a output). + have HpresPayload : + ∀ entry ∈ presFiltered, + Imperative.invStores σAO + (updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) + ((Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr).removeAll + ((proc.header.inputs.keys ++ + proc.header.outputs.keys) ++ + (argTemps ++ lhs))) ∧ + (argTemps ++ lhs).Disjoint + (Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr) ∧ + δ σAO entry.snd.expr = some Imperative.HasBool.tt := by + intro entry Hentry + -- Unpack per-entry facts. + have HpreEnt := HpreFiltered entry Hentry + -- preVars are not tmp_/old_ and not in lhs. + have HfreshEnt := HpresVarsFresh' entry Hentry + -- (1) Hpred_disj: (argT ++ lhs).Disjoint preVars. + have Hpred_disj : + (argTemps ++ lhs).Disjoint + (Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr) := by + intro x Hin1 Hin2 + cases List.mem_append.mp Hin1 with + | inl HxArg => + -- x ∈ argT (tmp_), x ∈ preVars (not tmp_). + have HxTemp : isTempIdent x := (List.Forall_mem_iff.mp HargTemp) x HxArg + have HxNotTemp : ¬ isTempIdent x := + (HfreshEnt x Hin2).1 + exact HxNotTemp HxTemp + | inr HxLhs => + -- x ∈ lhs, x ∉ lhs via HfreshEnt + hCallArgsLhs. + have HxNotInLhs : x ∉ CallArg.getLhs args := + (HfreshEnt x Hin2).2.2 + rw [hCallArgsLhs] at HxNotInLhs + exact HxNotInLhs HxLhs + -- (2) Hinv: invStores σAO σ_old (preVars.removeAll ...). + have Hinv : + Imperative.invStores σAO + (updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) + ((Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr).removeAll + ((proc.header.inputs.keys ++ + proc.header.outputs.keys) ++ + (argTemps ++ lhs))) := by + simp only [Imperative.invStores, Imperative.substStores] + intros k1 k2 Hkin + obtain rfl := zip_self_eq Hkin + have Hk1_in : k1 ∈ + (Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr).removeAll + ((proc.header.inputs.keys ++ + proc.header.outputs.keys) ++ + (argTemps ++ lhs)) := + (List.of_mem_zip Hkin).1 + -- Decompose the removeAll membership. + simp only [List.removeAll, List.mem_filter, + List.elem_eq_mem, Bool.not_eq_true', + decide_eq_false_iff_not] at Hk1_in + obtain ⟨Hk1_pre, Hk1_notin⟩ := Hk1_in + obtain ⟨Hk1_notin_inputs, Hk1_notin_outputs, + Hk1_notin_argT, _Hk1_notin_lhs⟩ := + List.notin_append4 Hk1_notin + -- preVar k1 fresh facts (not tmp_, not old_, not in lhs). + have HfreshK := HfreshEnt k1 Hk1_pre + have Hk1_notTemp : ¬ isTempIdent k1 := HfreshK.1 + have Hk1_notOld : ¬ isOldTempIdent k1 := HfreshK.2.1 + -- k1 ∉ outT (since outT are tmp_). + have Hk1_notin_outT : k1 ∉ outTemps := + notMem_of_Forall_neg HoutTemp Hk1_notTemp + -- k1 ∉ genOldIdents (since olds are old_). + have Hk1_notin_olds : k1 ∉ genOldIdents := + notMem_of_Forall_neg HoldIdentsTemp Hk1_notOld + -- σ_old k1 = σ k1 by 3-layer fall-through. + have Hold_eq_σ : + (updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) k1 = σ k1 := by + have Hk1_notin_oldFst : + k1 ∉ oldTrips.unzip.fst.unzip.fst := by + rw [HoldTripsFst]; exact Hk1_notin_olds + exact updatedStates_3layer_get_notin + Hk1_notin_argT Hk1_notin_outT Hk1_notin_oldFst + -- σAO k1 = σ k1 via Hinitout/Hinitin fall-through. + have HAO_eq_σ : σAO k1 = σ k1 := by + rw [initStates_get_notin Hinitout Hk1_notin_outputs, + initStates_get_notin Hinitin Hk1_notin_inputs] + -- Conclude: σAO k1 = σ_old k1. + rw [HAO_eq_σ, Hold_eq_σ] + refine ⟨Hinv, Hpred_disj, ?_⟩ + exact HpreEnt.2 + -- D2b: per-postcondition payload (HpostFiltered, HpostSubFresh). + let postsFiltered : List (CoreLabel × Procedure.Check) := + proc.spec.postconditions.filter + (fun (_, c) => c.attr ≠ .Free) + -- D2c: σ_R1 + L6 substStores/substDefined facts. + let σ_R1 : CoreStore := + updatedStates σO genOldIdents oldVals + -- σ_havoc abbreviation (matches HL5's RHS). + let σ_havoc : CoreStore := + updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) + -- Positional read of σ_R1 on genOldIdents. + have HrdR1_olds : ReadValues σ_R1 genOldIdents oldVals := by + show ReadValues (updatedStates σO genOldIdents oldVals) _ _ + exact readValues_updatedStatesSame HgenOldOldValsLen HoldNd + have σ_R1_read_olds : + ∀ (i : Nat) (Hi : i < genOldIdents.length) + (Hi' : i < oldVals.length), + σ_R1 (genOldIdents[i]'Hi) = + some (oldVals[i]'Hi') := fun i Hi Hi' => + readValues_get HrdR1_olds (i:=i) (hi:=Hi) (hi':=Hi') + -- Filtered argument substitution shape. Matches + -- `arg_subst_filtered` in `callElimCmd` (CallElim.lean:133). + let filtered_argSubst : + List (Expression.Ident × Expression.Ident) := + (proc.header.inputs.keys.zip argTemps).filter + (fun pr => + ¬ (proc.header.outputs.keys).contains pr.1) + let filtered_inputs : List Expression.Ident := + filtered_argSubst.unzip.fst + let filtered_argTemps : List Expression.Ident := + filtered_argSubst.unzip.snd + let filtered_ks : List Expression.Ident := + proc.header.outputs.keys ++ filtered_inputs + let filtered_ks' : List Expression.Ident := + lhs ++ filtered_argTemps + -- inputs.keys.length = argTemps.length (both = argVals.length). + have HinKeys_argTemps_len : + proc.header.inputs.keys.length = argTemps.length := by + have H1 : proc.header.inputs.keys.length = + argVals.length := InitStatesLength Hinitin + omega + -- Pre-filter zip's unzip = (inputs.keys, argTemps). + have Hzip_unzip : + (proc.header.inputs.keys.zip argTemps).unzip = + (proc.header.inputs.keys, argTemps) := by + apply List.unzip_zip + exact HinKeys_argTemps_len + -- Filter sub-membership: each (id, t) ∈ filtered_argSubst + -- is in the original zip and satisfies the filter. + have Hfilter_in : + ∀ pr ∈ filtered_argSubst, + pr ∈ proc.header.inputs.keys.zip argTemps ∧ + pr.1 ∉ proc.header.outputs.keys := by + intro pr Hpr + have := List.mem_filter.mp Hpr + refine ⟨this.1, ?_⟩ + simpa using this.2 + -- Length symmetry of filtered halves. + have Hfilt_len_sym : + filtered_inputs.length = filtered_argTemps.length := by + show filtered_argSubst.unzip.fst.length = + filtered_argSubst.unzip.snd.length + simp [List.unzip_eq_map] + -- outputs.keys.length = lhs.length (both = oVals.length). + have HoutKeys_lhs_len : + proc.header.outputs.keys.length = lhs.length := by + have H1 : proc.header.outputs.keys.length = oVals.length := + InitStatesLength Hinitout + have H2 : lhs.length = oVals.length := + ReadValuesLength Hevalouts + omega + -- Hkslen (Goal #4): + -- filtered_ks.length = filtered_ks'.length. + have Hkslen : + filtered_ks.length = filtered_ks'.length := by + show (proc.header.outputs.keys ++ + filtered_inputs).length = + (lhs ++ filtered_argTemps).length + rw [List.length_append, List.length_append, + HoutKeys_lhs_len, Hfilt_len_sym] + -- filtered_inputs ⊆ inputs.keys (via the filter zip path). + have Hfilt_in_eq_map : + filtered_inputs = filtered_argSubst.map Prod.fst := by + show filtered_argSubst.unzip.fst = _ + simp [List.unzip_eq_map] + have Hfilt_argT_eq_map : + filtered_argTemps = filtered_argSubst.map Prod.snd := by + show filtered_argSubst.unzip.snd = _ + simp [List.unzip_eq_map] + have Hfilt_in_sub_inputs : + ∀ v ∈ filtered_inputs, v ∈ proc.header.inputs.keys := by + intro v Hv + have Hv' : v ∈ filtered_argSubst.map Prod.fst := + Hfilt_in_eq_map ▸ Hv + rcases List.mem_map.mp Hv' with ⟨pr, Hpr_in, Hpr_eq⟩ + have HinZip := (Hfilter_in pr Hpr_in).1 + have Hofzip := List.of_mem_zip HinZip + rw [← Hpr_eq] + exact Hofzip.1 + have Hfilt_argT_sub_argTemps : + ∀ v ∈ filtered_argTemps, v ∈ argTemps := by + intro v Hv + have Hv' : v ∈ filtered_argSubst.map Prod.snd := + Hfilt_argT_eq_map ▸ Hv + rcases List.mem_map.mp Hv' with ⟨pr, Hpr_in, Hpr_eq⟩ + have HinZip := (Hfilter_in pr Hpr_in).1 + have Hofzip := List.of_mem_zip HinZip + rw [← Hpr_eq] + exact Hofzip.2 + have Hfilt_in_disj_outs : + filtered_inputs.Disjoint proc.header.outputs.keys := by + intro v Hv1 Hv2 + have Hv' : v ∈ filtered_argSubst.map Prod.fst := + Hfilt_in_eq_map ▸ Hv1 + rcases List.mem_map.mp Hv' with ⟨pr, Hpr_in, Hpr_eq⟩ + have HnotIn := (Hfilter_in pr Hpr_in).2 + rw [Hpr_eq] at HnotIn + exact HnotIn Hv2 + -- Hnd: substNodup of filtered_ks.zip filtered_ks'. + have Hnd : Imperative.substNodup + (filtered_ks.zip filtered_ks') := by + -- Unfold substNodup; rewrite via unzip_zip. + have HzipUnzip : + (filtered_ks.zip filtered_ks').unzip = + (filtered_ks, filtered_ks') := + List.unzip_zip Hkslen + show ((filtered_ks.zip filtered_ks').unzip.fst ++ + (filtered_ks.zip filtered_ks').unzip.snd).Nodup + rw [HzipUnzip] + -- Now goal: (filtered_ks ++ filtered_ks').Nodup. + show ((proc.header.outputs.keys ++ filtered_inputs) ++ + (lhs ++ filtered_argTemps)).Nodup + -- ((outs ++ filt_in) ++ (lhs ++ filt_argT)).Nodup: each + -- Nodup + pairwise disjoints (C-aux supplies most). + have Hfilt_in_disj_lhs : + filtered_inputs.Disjoint lhs := by + intro v Hv1 Hv2 + exact HinKeys_disj_lhs (Hfilt_in_sub_inputs v Hv1) Hv2 + -- outs ∩ filt_argT: filt_argT ⊆ argTemps. + -- outputs ∩ argTemps = ∅ (HoutKeys_disj_argTemps). + have HoutKeys_disj_filt_argT : + proc.header.outputs.keys.Disjoint + filtered_argTemps := by + intro v Hv1 Hv2 + exact HoutKeys_disj_argTemps Hv1 + (Hfilt_argT_sub_argTemps v Hv2) + -- filt_in ∩ filt_argT: subsets of inputs / argTemps. + have Hfilt_in_disj_filt_argT : + filtered_inputs.Disjoint filtered_argTemps := by + intro v Hv1 Hv2 + exact HinKeys_disj_argTemps + (Hfilt_in_sub_inputs v Hv1) + (Hfilt_argT_sub_argTemps v Hv2) + -- lhs ∩ filt_argT: lhs ∩ argTemps = ∅ (HlhsDisjArg). + have Hlhs_disj_filt_argT : + lhs.Disjoint filtered_argTemps := by + intro v Hv1 Hv2 + exact HlhsDisjArg Hv1 + (Hfilt_argT_sub_argTemps v Hv2) + -- inputs.keys.Nodup → Pairwise distinct fst on filter → Nodup on (filter.map fst). + have Hin_nd_pw : + List.Pairwise + (· ≠ ·) proc.header.inputs.keys := + List.nodup_iff_pairwise_ne.mp Hinnd_io + have HargT_nd_pw : + List.Pairwise (· ≠ ·) argTemps := + List.nodup_iff_pairwise_ne.mp HargNd + -- Pairwise-distinct on the full zip. + have Hzip_pw_fst : + List.Pairwise + (fun (p q : + Expression.Ident × Expression.Ident) => + p.1 ≠ q.1) + (proc.header.inputs.keys.zip argTemps) := by + -- Lift via pairwise_map + map_fst_zip from inputs.keys Pairwise. + rw [show (fun (p q : Expression.Ident × Expression.Ident) => + p.1 ≠ q.1) = + (fun p q => Prod.fst p ≠ Prod.fst q) from rfl] + rw [← List.pairwise_map] + rw [List.map_fst_zip + (Nat.le_of_eq HinKeys_argTemps_len)] + exact Hin_nd_pw + have Hzip_pw_snd : + List.Pairwise + (fun (p q : + Expression.Ident × Expression.Ident) => + p.2 ≠ q.2) + (proc.header.inputs.keys.zip argTemps) := by + rw [show (fun (p q : Expression.Ident × Expression.Ident) => + p.2 ≠ q.2) = + (fun p q => Prod.snd p ≠ Prod.snd q) from rfl] + rw [← List.pairwise_map] + rw [List.map_snd_zip + (Nat.le_of_eq HinKeys_argTemps_len.symm)] + exact HargT_nd_pw + -- Filter preserves Pairwise (sublist). + have Hfilt_pw_fst : + List.Pairwise + (fun (p q : + Expression.Ident × Expression.Ident) => + p.1 ≠ q.1) + filtered_argSubst := + List.Pairwise.sublist List.filter_sublist Hzip_pw_fst + have Hfilt_pw_snd : + List.Pairwise + (fun (p q : + Expression.Ident × Expression.Ident) => + p.2 ≠ q.2) + filtered_argSubst := + List.Pairwise.sublist List.filter_sublist Hzip_pw_snd + have Hfilt_in_nodup : filtered_inputs.Nodup := by + show filtered_argSubst.unzip.fst.Nodup + simp [List.unzip_eq_map] + rw [List.nodup_iff_pairwise_ne] + rw [List.pairwise_map] + exact Hfilt_pw_fst + have Hfilt_argT_nodup : filtered_argTemps.Nodup := by + show filtered_argSubst.unzip.snd.Nodup + simp [List.unzip_eq_map] + rw [List.nodup_iff_pairwise_ne] + rw [List.pairwise_map] + exact Hfilt_pw_snd + -- Step: assemble (filtered_ks ++ filtered_ks').Nodup. + -- = (outputs ++ filtered_inputs ++ lhs ++ filtered_argTemps).Nodup. + rw [List.nodup_append] + refine ⟨?_, ?_, ?_⟩ + · -- (outputs ++ filtered_inputs).Nodup. + rw [List.nodup_append] + refine ⟨Houtnd_io, Hfilt_in_nodup, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact Hfilt_in_disj_outs Hb Ha + · -- (lhs ++ filtered_argTemps).Nodup. + rw [List.nodup_append] + refine ⟨HlhsNd, Hfilt_argT_nodup, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact Hlhs_disj_filt_argT Ha Hb + · -- (outputs ++ filtered_inputs).Disjoint + -- (lhs ++ filtered_argTemps). + intro a Ha b Hb Heq + subst Heq + cases List.mem_append.mp Ha with + | inl HaOuts => + cases List.mem_append.mp Hb with + | inl HbLhs => + exact HoutKeys_disj_lhs HaOuts HbLhs + | inr HbArgT => + exact HoutKeys_disj_filt_argT HaOuts HbArgT + | inr HaIn => + cases List.mem_append.mp Hb with + | inl HbLhs => + exact Hfilt_in_disj_lhs HaIn HbLhs + | inr HbArgT => + exact Hfilt_in_disj_filt_argT HaIn HbArgT + -- Hdef: substDefined σ_R1 σ_havoc. + have HσO_def_outs : + Imperative.isDefined σO proc.header.outputs.keys := by + apply HavocVarsDefMonotone ?_ Hhav1 + exact InitStatesDefined Hinitout + have HσO_def_inputs : + Imperative.isDefined σO proc.header.inputs.keys := by + apply HavocVarsDefMonotone ?_ Hhav1 + apply InitStatesDefMonotone ?_ Hinitout + exact InitStatesDefined Hinitin + -- σ_R1 = σO off genOldIdents (single closure). + have σR1_off_olds : + ∀ {v}, v ∉ genOldIdents → σ_R1 v = σO v := fun Hv => + updatedStates_get_notin Hv + have Hσ_R1_def_outs : + Imperative.isDefined σ_R1 proc.header.outputs.keys := + fun v Hv => by + rw [show σ_R1 v = σO v from σR1_off_olds (HoutKeys_disj_olds Hv)] + exact HσO_def_outs v Hv + have Hσ_R1_def_filt_in : + Imperative.isDefined σ_R1 filtered_inputs := + fun v Hv => by + have Hv_in := Hfilt_in_sub_inputs v Hv + rw [show σ_R1 v = σO v from σR1_off_olds (HinKeys_disj_olds Hv_in)] + exact HσO_def_inputs v Hv_in + -- σ_havoc definedness on lhs. + have Hσ_havoc_def_lhs : + Imperative.isDefined σ_havoc lhs := by + intro v Hv + show (updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) v).isSome = true + have Hv_notin : v ∉ argTemps ++ outTemps ++ genOldIdents := + notin_3_append_of (HlhsDisjArg Hv) (HlhsDisjOut Hv) (HlhsDisjOld Hv) + rw [updatedStates_get_notin Hv_notin] + exact HavocVarsDefined (UpdateStatesHavocVars Hupdate) v Hv + -- σ_havoc definedness on filtered_argTemps. + have Hσ_havoc_def_filt_argT : + Imperative.isDefined σ_havoc filtered_argTemps := by + intro v Hv + have Hv_argT : v ∈ argTemps := + Hfilt_argT_sub_argTemps v Hv + -- σ_havoc[v] for v ∈ argTemps: 3-layer updatedStatesDefined. + show (updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) v).isSome = true + apply updatedStatesDefined + · simp [argTemps, outTemps, List.length_append, List.unzip_eq_map, Hargtriplen, Houttriplen, HgenOldOldValsLen] + · simp only [List.mem_append] + exact Or.inl (Or.inl Hv_argT) + -- Now assemble Hdef. + have Hdef : Imperative.substDefined σ_R1 σ_havoc + (filtered_ks.zip filtered_ks') := + substDefined_of_app Hσ_R1_def_outs Hσ_R1_def_filt_in + Hσ_havoc_def_lhs Hσ_havoc_def_filt_argT + -- Hsubst: substStores σ_R1 σ_havoc. + have Hσ'_eq : σ' = updatedStates σ lhs modvals := + UpdateStatesUpdated Hupdate + -- σ_R1 k = σ_havoc k for k off all touched layers. + have σR1_eq_σhavoc : + ∀ {k : Expression.Ident}, + k ∉ proc.header.inputs.keys → + k ∉ proc.header.outputs.keys → + k ∉ argTemps → k ∉ outTemps → + k ∉ genOldIdents → k ∉ lhs → + σ_R1 k = σ_havoc k := by + intro k Hk_ins Hk_outs Hk_argT Hk_outT Hk_genOld Hk_lhs + have HσR1_σ : updatedStates σO genOldIdents oldVals k = σ k := + σR1_eq_σ_for_notTouched Hinitin Hinitout Hhav1 + Hk_ins Hk_outs Hk_genOld + have H5 : σ k = σ' k := by + rw [Hσ'_eq, updatedStates_get_notin Hk_lhs] + have Hk_notin_layered : k ∉ argTemps ++ outTemps ++ genOldIdents := + notin_3_append_of Hk_argT Hk_outT Hk_genOld + have H6 : σ' k = σ_havoc k := by + show σ' k = updatedStates σ' + (argTemps ++ outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) k + rw [updatedStates_get_notin Hk_notin_layered] + show updatedStates σO genOldIdents oldVals k = σ_havoc k + rw [HσR1_σ, H5, H6] + -- modvals length = lhs length. + have HmodvalsLen : modvals.length = lhs.length := by + have := UpdateStatesLength Hupdate + omega + -- σO outputs = modvals (via Hrd). + -- σO inputs = σA inputs (via the σAO/σA fall-through chain). + -- σ_havoc on lhs = σ' lhs. + have Hσ_havoc_lhs_eq : + ∀ v ∈ lhs, σ_havoc v = σ' v := by + intro v Hv + have Hv_notin : v ∉ argTemps ++ outTemps ++ genOldIdents := + notin_3_append_of (HlhsDisjArg Hv) (HlhsDisjOut Hv) (HlhsDisjOld Hv) + show updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) v = σ' v + exact updatedStates_get_notin Hv_notin + -- σ_R1 on outputs = σO on outputs. + have Hσ_R1_outs_eq : + ∀ v ∈ proc.header.outputs.keys, σ_R1 v = σO v := fun v Hv => + σR1_off_olds (HoutKeys_disj_olds Hv) + -- σ_R1 on inputs = σO on inputs. + have Hσ_R1_ins_eq : + ∀ v ∈ proc.header.inputs.keys, σ_R1 v = σO v := fun v Hv => + σR1_off_olds (HinKeys_disj_olds Hv) + -- σO = σAO off outputs.keys (via Hhav1 + UpdateStatesUpdated). + have σO_eq_σAO_off_outs : + ∀ {v}, v ∉ proc.header.outputs.keys → σO v = σAO v := by + obtain ⟨ovh, Hup_havoc⟩ := HavocVarsUpdateStates Hhav1 + intro v Hv + rw [UpdateStatesUpdated Hup_havoc, updatedStates_get_notin Hv] + -- σO on inputs = σA on inputs (Hhav1 preserves on non-outputs; + -- Hinitout preserves on non-outputs). + have HσO_ins_eq_σA : + ∀ v ∈ proc.header.inputs.keys, σO v = σA v := fun v Hv => by + have Hv_notin : v ∉ proc.header.outputs.keys := + fun h => Hiodisj Hv h + rw [σO_eq_σAO_off_outs Hv_notin] + exact initStates_get_notin Hinitout Hv_notin + -- σA on inputs = positional argVals (via Hinitin). + have HrdA : ReadValues σA proc.header.inputs.keys argVals := + InitStatesReadValues Hinitin + -- ── Build Hsubst via parallel ReadValues over output / filtered-input pairs ── + have HinKVlen : + proc.header.inputs.keys.length = argVals.length := + InitStatesLength Hinitin + -- σ_R1 reads inputs.keys → argVals (full). + have Hrd_R1_in_full : + ReadValues σ_R1 proc.header.inputs.keys argVals := by + apply readValues_updatedStates HgenOldOldValsLen HinKeys_disj_olds + -- ReadValues σO inputs.keys argVals. + have HrdAO : ReadValues σAO proc.header.inputs.keys argVals := by + apply InitStatesReadValuesMonotone (σ:=σA) ?_ Hinitout + exact InitStatesReadValues Hinitin + have Hh1 := HavocVarsUpdateStates Hhav1 + rcases Hh1 with ⟨ovh, Hup_havoc⟩ + apply UpdateStatesReadValuesMonotone (σ:=σAO) _ ?_ Hup_havoc + · exact Hinoutnd + · exact HrdAO + -- σ_R1 reads outputs.keys → modvals (full). + have Hrd_R1_outs : + ReadValues σ_R1 proc.header.outputs.keys modvals := + readValues_updatedStates HgenOldOldValsLen HoutKeys_disj_olds Hrd + -- σ_havoc reads argTemps → argVals (layer-1). + have Hrd_havoc_argT : + ReadValues σ_havoc argTemps argVals := by + show ReadValues + (updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals)) + argTemps argVals + rw [Hflatten_eq] + have HargF_σ' : + ReadValues + (updatedStates σ' argTemps argVals) + argTemps argVals := + readValues_updatedStatesSame HargTempsLen HargNd + have HargF_step1 : + ReadValues + (updatedStates + (updatedStates σ' argTemps argVals) + outTemps oVals) argTemps argVals := + readValues_updatedStates HoutTempsLen HargOutDisj HargF_σ' + rw [HoldTripsFst] + exact readValues_updatedStates HgenOldOldValsLen HargOldDisj HargF_step1 + -- σ_havoc reads lhs → modvals (fall-through to σ'). + have HmodvalsLen' : lhs.length = modvals.length := by + have := UpdateStatesLength Hupdate; omega + have Hrd_havoc_lhs : + ReadValues σ_havoc lhs modvals := by + apply readValues_updatedStates + · simp [argTemps, outTemps, List.length_append, List.unzip_eq_map, Hargtriplen, Houttriplen, HgenOldOldValsLen] + · intro v Hv1 Hv2 + cases List.mem_append.mp Hv2 with + | inl h => cases List.mem_append.mp h with + | inl ha => exact HlhsDisjArg Hv1 ha + | inr ho => exact HlhsDisjOut Hv1 ho + | inr ho => exact HlhsDisjOld Hv1 ho + · rw [Hσ'_eq] + exact readValues_updatedStatesSame HmodvalsLen' HlhsNd + -- Filtered halves via the triple zip. + have Hsubst : Imperative.substStores σ_R1 σ_havoc + (filtered_ks.zip filtered_ks') := by + intro k1 k2 Hkin + show σ_R1 k1 = σ_havoc k2 + -- (k1, k2) ∈ filtered_ks.zip filtered_ks'. + -- Get the underlying pair shape: either output-pair + -- or filtered-input-pair. + rcases List.mem_iff_get.mp Hkin with ⟨n, Hn⟩ + have Hn_lt_ks : n.val < filtered_ks.length := by + have := n.isLt; simp [List.length_zip, Hkslen] at this; omega + have Hn_lt_ks' : n.val < filtered_ks'.length := by + rw [← Hkslen]; exact Hn_lt_ks + have ⟨Hk1_eq, Hk2_eq⟩ := + zip_pair_split Hn_lt_ks Hn_lt_ks' Hn + by_cases Hsplit : n.val < proc.header.outputs.keys.length + · -- Output-half. + have Hks_app_lt : + n.val < (proc.header.outputs.keys ++ + filtered_inputs).length := by + rw [List.length_append]; omega + have HoutLhsLen : n.val < lhs.length := by + rw [← HoutKeys_lhs_len]; exact Hsplit + have Hks'_app_lt : + n.val < (lhs ++ filtered_argTemps).length := by + rw [List.length_append]; omega + have Hk1_app : + k1 = proc.header.outputs.keys[n.val]'Hsplit := by + rw [Hk1_eq] + show (proc.header.outputs.keys ++ + filtered_inputs)[n.val]'_ = _ + rw [List.getElem_append_left (h := Hsplit)] + have Hk2_app : k2 = lhs[n.val]'HoutLhsLen := by + rw [Hk2_eq] + show (lhs ++ filtered_argTemps)[n.val]'_ = _ + rw [List.getElem_append_left (h := HoutLhsLen)] + -- σ_R1 k1 = some modvals[n.val] (via Hrd_R1_outs). + have HmodLen_outs : + n.val < modvals.length := by + have := ReadValuesLength Hrd_R1_outs; omega + have HrdR1_get : + σ_R1 (proc.header.outputs.keys[n.val]'Hsplit) = + some (modvals[n.val]'HmodLen_outs) := + readValues_get + (σ:=σ_R1) (ks:=proc.header.outputs.keys) + (vs:=modvals) Hrd_R1_outs + (i:=n.val) (hi:=Hsplit) (hi':=HmodLen_outs) + have HrdHavoc_get : + σ_havoc (lhs[n.val]'HoutLhsLen) = + some (modvals[n.val]'HmodLen_outs) := + readValues_get + (σ:=σ_havoc) (ks:=lhs) (vs:=modvals) + Hrd_havoc_lhs + (i:=n.val) (hi:=HoutLhsLen) (hi':=HmodLen_outs) + rw [Hk1_app, HrdR1_get, Hk2_app, HrdHavoc_get] + · -- Input-half. + have Hsplit_le : proc.header.outputs.keys.length ≤ n.val := + Nat.le_of_not_lt Hsplit + have Hlhs_le : lhs.length ≤ n.val := by + rw [← HoutKeys_lhs_len]; exact Hsplit_le + have Hk1_app : + k1 = filtered_inputs[n.val - + proc.header.outputs.keys.length]'(by + have Hl : filtered_ks.length = + proc.header.outputs.keys.length + + filtered_inputs.length := + List.length_append + omega) := by + rw [Hk1_eq] + show (proc.header.outputs.keys ++ + filtered_inputs)[n.val]'_ = _ + rw [List.getElem_append_right (h₁ := Hsplit_le)] + have Hk2_app : + k2 = filtered_argTemps[n.val - lhs.length]'(by + have Hl : filtered_ks'.length = + lhs.length + filtered_argTemps.length := + List.length_append + omega) := by + rw [Hk2_eq] + show (lhs ++ filtered_argTemps)[n.val]'_ = _ + rw [List.getElem_append_right (h₁ := Hlhs_le)] + -- The two filtered halves' indices line up: + -- n - outputs.length = n - lhs.length (by HoutKeys_lhs_len). + have Hidx_eq : + n.val - proc.header.outputs.keys.length = + n.val - lhs.length := by + rw [HoutKeys_lhs_len] + let j : Nat := + n.val - proc.header.outputs.keys.length + have Hj_lt_filt : + j < filtered_inputs.length := by + have Hl : filtered_ks.length = + proc.header.outputs.keys.length + + filtered_inputs.length := + List.length_append + omega + have Hj_lt_argT : + j < filtered_argTemps.length := by + rw [← Hfilt_len_sym]; exact Hj_lt_filt + have Hj_lt_subst : + j < filtered_argSubst.length := by + show j < filtered_argSubst.length + rw [show filtered_argSubst.length = + filtered_argSubst.unzip.fst.length from by + simp [List.unzip_eq_map]] + exact Hj_lt_filt + -- Pair at index j in filtered_argSubst is (k1, k2). + have HpairAtJ : + filtered_argSubst[j]'Hj_lt_subst = (k1, k2) := by + -- filtered_inputs[j] = (filtered_argSubst[j]).fst. + have HfilGetFst : + filtered_inputs[j]'Hj_lt_filt = + (filtered_argSubst[j]'Hj_lt_subst).fst := by + show filtered_argSubst.unzip.fst[j]'_ = _ + simp [List.unzip_eq_map] + have HfilGetSnd : + filtered_argTemps[j]'Hj_lt_argT = + (filtered_argSubst[j]'Hj_lt_subst).snd := by + show filtered_argSubst.unzip.snd[j]'_ = _ + simp [List.unzip_eq_map] + ext + · -- fst component. + rw [← HfilGetFst, ← Hk1_app] + · -- snd component. + rw [← HfilGetSnd] + have : filtered_argTemps[n.val - lhs.length]'(by + have Hl : filtered_ks'.length = + lhs.length + filtered_argTemps.length := + List.length_append + omega) = filtered_argTemps[j]'Hj_lt_argT := by + congr 1 + exact Hidx_eq.symm + rw [Hk2_app, this] + -- Pair (k1, k2) ∈ filtered_argSubst. + have HpairIn : (k1, k2) ∈ filtered_argSubst := by + rw [← HpairAtJ] + exact List.getElem_mem _ + -- (k1, k2) ∈ inputs.keys.zip argTemps via Hfilter_in. + have HpairZip := (Hfilter_in (k1, k2) HpairIn).1 + obtain ⟨m, Hm_lt_in, Hm_lt_argT, Hk1_inGet, Hk2_argTGet⟩ := + pair_in_zip_pos_decomp HinKeys_argTemps_len HpairZip + have Hm_lt_argV : m < argVals.length := HinKVlen ▸ Hm_lt_in + have HrdR1_get : + σ_R1 (proc.header.inputs.keys[m]'Hm_lt_in) = + some (argVals[m]'Hm_lt_argV) := + readValues_get (σ:=σ_R1) (ks:=proc.header.inputs.keys) + (vs:=argVals) Hrd_R1_in_full + (i:=m) (hi:=Hm_lt_in) (hi':=Hm_lt_argV) + have HrdHavoc_get : + σ_havoc (argTemps[m]'Hm_lt_argT) = + some (argVals[m]'Hm_lt_argV) := + readValues_get (σ:=σ_havoc) (ks:=argTemps) (vs:=argVals) + Hrd_havoc_argT + (i:=m) (hi:=Hm_lt_argT) (hi':=Hm_lt_argV) + rw [Hk1_inGet, HrdR1_get, Hk2_argTGet, HrdHavoc_get] + -- ── D2e: Apply H_asserts_zip to derive HL4 ── + -- σ_old = post-L3 store (3-layer over argT/outT/oldTrips.fst.fst). + let σ_old : CoreStore := + updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals + -- L4 ks/ks' bindings with explicit type annotation + -- so `substNodup` can unify the identifier type. + let ks_L4 : List Expression.Ident := + proc.header.inputs.keys ++ proc.header.outputs.keys + let ks'_L4 : List Expression.Ident := + argTemps ++ lhs + -- ── L4 length facts ── + have Hks_len_L4 : + ks_L4.length = ks'_L4.length := by + show (proc.header.inputs.keys ++ + proc.header.outputs.keys).length = + (argTemps ++ lhs).length + rw [List.length_append, List.length_append, + HinKeys_argTemps_len, HoutKeys_lhs_len] + -- ── L4 substNodup: ((inputs ++ outputs) ++ (argTemps ++ lhs)).Nodup ── + have HargT_lhs_nd : + (argTemps ++ lhs).Nodup := by + rw [List.nodup_append] + refine ⟨HargNd, HlhsNd, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact HlhsDisjArg Hb Ha + have Hbignd_L4 : + (ks_L4 ++ ks'_L4).Nodup := by + rw [List.nodup_append] + refine ⟨Hinoutnd, HargT_lhs_nd, fun a Ha b Hb Heq => ?_⟩ + subst Heq + rcases List.mem_append.mp Ha with HaIn | HaOut <;> + rcases List.mem_append.mp Hb with HbArg | HbLhs + · exact HinKeys_disj_argTemps HaIn HbArg + · exact HinKeys_disj_lhs HaIn HbLhs + · exact HoutKeys_disj_argTemps HaOut HbArg + · exact HoutKeys_disj_lhs HaOut HbLhs + have Hnd_L4 : Imperative.substNodup + (ks_L4.zip ks'_L4) := by + unfold Imperative.substNodup + rw [List.unzip_zip Hks_len_L4] + exact Hbignd_L4 + -- ── L4 substDefined ── + have HσAO_def_in_L4 : + Imperative.isDefined σAO proc.header.inputs.keys := by + apply InitStatesDefMonotone ?_ Hinitout + exact InitStatesDefined Hinitin + have HσAO_def_out_L4 : + Imperative.isDefined σAO proc.header.outputs.keys := + InitStatesDefined Hinitout + -- σ_old definedness on argTemps via layer-1 fall-through (HargOldDisj/HargOutDisj). + have Hσ_old_def_argT : + Imperative.isDefined σ_old + argTemps := by + intro v Hv + show ((updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) v).isSome = + true + rw [updatedStates_get_notin (HoldTripsFst.symm ▸ HargOldDisj Hv), + updatedStates_get_notin (HargOutDisj Hv)] + exact updatedStatesDefined HargTempsLen v Hv + -- σ_old definedness on lhs (reuses C-aux HlhsDef_old). + have Hσ_old_def_lhs : + Imperative.isDefined σ_old lhs := HlhsDef_old + have Hdef_L4 : Imperative.substDefined σAO σ_old + (ks_L4.zip ks'_L4) := + substDefined_of_app HσAO_def_in_L4 HσAO_def_out_L4 + Hσ_old_def_argT Hσ_old_def_lhs + -- ── L4 substStores: substStores σ_old σAO ((argTemps ++ lhs).zip (inputs ++ outputs)) ── + -- Build matching ReadValues on σ_old and σAO, close via ReadValuesSubstStores. + have HrdAO_in_L4 : + ReadValues σAO proc.header.inputs.keys argVals := by + have HrdA_in : ReadValues σA proc.header.inputs.keys argVals := + InitStatesReadValues Hinitin + apply InitStatesReadValuesMonotone HrdA_in Hinitout + have HrdAO_out_L4 : + ReadValues σAO proc.header.outputs.keys oVals := + InitStatesReadValues Hinitout + have HrdAO_inout_L4 : + ReadValues σAO + (proc.header.inputs.keys ++ + proc.header.outputs.keys) + (argVals ++ oVals) := + ReadValuesApp HrdAO_in_L4 HrdAO_out_L4 + -- σ_old reads argTemps ↦ argVals: layer-1 init lifted via readValues_updatedStates. + have HrdLayer3_argT : + ReadValues σ_old + argTemps argVals := + readValues_updatedStates HoldFstLen + (HoldTripsFst ▸ HargOldDisj) + (readValues_updatedStates HoutTempsLen HargOutDisj + (readValues_updatedStatesSame HargTempsLen + (List.nodup_append.mp (List.nodup_append.mp Hgennd).1).1)) + -- σ_old reads lhs ↦ oVals. Path: σ(lhs) = oVals via + -- Hevalouts, lifted across the 3-layer extension. + have HrdLayer3_lhs : + ReadValues σ_old lhs oVals := + readValues_3layer_lift HargTempsLen HlhsDisjArg + HoutTempsLen HlhsDisjOut + HoldFstLen (HoldTripsFst ▸ HlhsDisjOld) Hevalouts + have HrdOld_inout_L4 : + ReadValues σ_old + (argTemps ++ lhs) + (argVals ++ oVals) := + ReadValuesApp HrdLayer3_argT HrdLayer3_lhs + have Hsubst_L4 : Imperative.substStores σ_old σAO + (ks'_L4.zip ks_L4) := + ReadValuesSubstStores HrdOld_inout_L4 HrdAO_inout_L4 + -- ── Apply H_asserts_zip ── + obtain ⟨assertLabels, HassertLabelsLen, HassertShape⟩ := + HassertsShape + -- HassertsShape's subst = ks_L4.zip (createFvars ks'_L4). + have HassertSubst_eq : + ((proc.header.inputs.keys.zip + (Core.Transform.createFvars + argTemps)) ++ + (proc.header.outputs.keys.zip + (Core.Transform.createFvars + (CallArg.getLhs args)))) = + ks_L4.zip + (Core.Transform.createFvars ks'_L4) := by + show _ = + (proc.header.inputs.keys ++ + proc.header.outputs.keys).zip + (Core.Transform.createFvars + (argTemps ++ lhs)) + rw [hCallArgsLhs, createFvarsApp] + rw [List.zip_append] + rw [createFvarsLength] + exact HinKeys_argTemps_len + -- Apply H_asserts_zip; bne_iff_ne bridges the != / ≠ filter forms. + have HL4_pre : + EvalStatementsContract π φ ⟨σ_old, δ, false⟩ + (((proc.spec.preconditions.filter + (fun (_, check) => check.attr != .Free)).zip + assertLabels).map (fun (entry, lbl) => + Statement.assert lbl + (Lambda.LExpr.substFvars entry.snd.expr + (ks_L4.zip + (Core.Transform.createFvars ks'_L4))) + (entry.snd.md.setCallSiteFileRange md))) + ⟨σ_old, δ, false⟩ := by + apply H_asserts_zip + (σA := σAO) (σ' := σ_old) + (ks := ks_L4) + (ks' := ks'_L4) + (pres := proc.spec.preconditions.filter + (fun (_, check) => check.attr != .Free)) + (labels := assertLabels) + Hwfb Hwfvars Hwfval Hwfc + Hks_len_L4 Hnd_L4 Hdef_L4 Hsubst_L4 + -- HpresPayload over presFiltered. Two filter forms + -- (`!=` boolean ↔ `≠` Prop) agree via decide reduction. + intros entry Hentry + have Hentry' : entry ∈ presFiltered := by + show entry ∈ proc.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free) + have Hin : + entry ∈ + (List.filter + (fun x => match x with + | (_, check) => check.attr != Procedure.CheckAttr.Free) + proc.spec.preconditions) := Hentry + rw [List.mem_filter] at Hin ⊢ + refine ⟨Hin.1, ?_⟩ + simp only [decide_not, Bool.not_eq_eq_eq_not, Bool.not_true, + decide_eq_false_iff_not, ne_eq] + have := Hin.2 + simp only [bne_iff_ne, ne_eq] at this + exact this + exact HpresPayload entry Hentry' + -- Bridge to the actual `asserts` list via HassertsShape. + have HL4 : + EvalStatementsContract π φ ⟨σ_old, δ, false⟩ + asserts ⟨σ_old, δ, false⟩ := by + -- Rewrite asserts using HassertShape; the resulting list + -- is over `proc'`-keys, which equal `proc`-keys via HprocEq. + rw [HassertShape] + -- Push proc' = proc through to reach the L4-derived form. + rw [HprocEq] + -- Rewrite the inner substitution map via HassertSubst_eq. + rw [HassertSubst_eq] + exact HL4_pre + -- D2d-bridge: σO ↔ σAO old-binding bridge. + -- (a) Trivial empty-init witness. + have HInitVars_empty : InitVars σO [] σO := InitVars.init_none + -- (b) Per-output bridge via Hwf2's universal clause. + have Hwf2_univ : + ∀ v ∈ proc.header.outputs.keys, + δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) + none) = + σAO v := by + intro v Hv + -- Unfold Hwf2 to expose the `∧` structure. + simp only [WellFormedCoreEvalTwoState] at Hwf2 + -- Hwf2.2 : universal clause; instantiate at + -- (vs := outputs.keys, vs' := [], σ₀ := σAO, σ₁ := σO, + -- σ_arg := σO) using `Hhav1 ∧ HInitVars_empty`. + have HH := Hwf2.2 proc.header.outputs.keys [] σAO σO σO + ⟨Hhav1, HInitVars_empty⟩ v + exact HH.1 Hv + -- (c) σAO[v] = σ[v] for v ∉ outputs ∪ inputs. + have HσAO_notin_eq_σ : + ∀ v, v ∉ proc.header.outputs.keys → + v ∉ proc.header.inputs.keys → + σAO v = σ v := by + intro v Hv_notout Hv_notin + rw [initStates_get_notin Hinitout Hv_notout, + initStates_get_notin Hinitin Hv_notin] + -- (d) σAO reads outputs ↦ oVals (positional). + have HσAO_reads_outs : + ReadValues σAO proc.header.outputs.keys oVals := + InitStatesReadValues Hinitout + -- (e) Positional alignment via HoutAlign (Hwfcallsite.specialize). + -- (f) Per-index δ-eval bridge: δ σO (mkOld oldVars[i].name) = some oldVals[i]. + -- For v ∈ oldVars, v is in CallArg.getLhs args (filter). + have HoldVars_sub_callLhs : ∀ v ∈ oldVars, v ∈ CallArg.getLhs args := by + intro v Hv + exact (List.mem_filter.mp Hv).1 + -- For v ∈ oldVars, v is in proc'.header.outputs.keys (filter). + -- Bridge proc' = proc via HprocEq. + have HoldVars_sub_outs : ∀ v ∈ oldVars, + v ∈ ListMap.keys proc.header.outputs := by + intro v Hv + have Hv_filt := List.mem_filter.mp Hv + have Hbool := Hv_filt.2 + -- Project the outputs.contains conjunct. + simp only [Bool.and_eq_true] at Hbool + have HinOuts' : (ListMap.keys proc'.header.outputs).contains v := by + exact Hbool.1.2 + rw [HprocEq] at HinOuts' + exact List.contains_iff_mem.mp HinOuts' + -- Per-index positional bridge for downstream consumers. + have HoldEval_bridge : + ∀ (i : Nat) (Hi : i < oldVars.length), + δ σO + (Lambda.LExpr.fvar () + (CoreIdent.mkOld (oldVars[i]'Hi).name) none) = + some (oldVals[i]'(HoldValsLen.symm ▸ Hi)) := by + intro i Hi + let v : Expression.Ident := oldVars[i]'Hi + have Hv_mem : v ∈ oldVars := List.getElem_mem _ + have Hv_out : v ∈ ListMap.keys proc.header.outputs := + HoldVars_sub_outs v Hv_mem + have Hv_lhs : v ∈ lhs := HoldVars_sub_lhs v Hv_mem + have Hv_callLhs : v ∈ CallArg.getLhs args := + HoldVars_sub_callLhs v Hv_mem + -- ReadValues σ' ks vs ∧ v ∈ ks ⇒ σ' v = some vs[ks.idxOf v]. + have read_at : ∀ {σ' : Expression.Ident → Option _} + {ks : List Expression.Ident} {vs : List _} + (_ : ReadValues σ' ks vs) (Hmem : v ∈ ks) + (Hidx_lt : ks.idxOf v < vs.length), + σ' v = some (vs[ks.idxOf v]'Hidx_lt) := by + intro σ' ks vs Hrv Hmem Hidx_lt + have Hg := readValues_get (σ:=σ') (ks:=ks) (vs:=vs) Hrv + (i:=ks.idxOf v) + (hi:=List.idxOf_lt_length_of_mem Hmem) (hi':=Hidx_lt) + have Hk : ks[ks.idxOf v]'(List.idxOf_lt_length_of_mem Hmem) = v := by + unfold List.idxOf + simpa using @List.findIdx_getElem _ (· == v) ks + (List.idxOf_lt_length_of_mem Hmem) + rwa [Hk] at Hg + -- Step 1: δ σO (mkOld v.name) = σAO v. + have HStep1 : + δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) + none) = + σAO v := + Hwf2_univ v Hv_out + -- Step 2: σAO v = oVals[outputs.keys.idxOf v] via HσAO_reads_outs. + let j_out := (ListMap.keys proc.header.outputs).idxOf v + have Hj_out_lt_oVals : j_out < oVals.length := by + rw [← InitStatesLength Hinitout] + exact List.idxOf_lt_length_of_mem Hv_out + have HStep2 : σAO v = some (oVals[j_out]'Hj_out_lt_oVals) := + read_at HσAO_reads_outs Hv_out Hj_out_lt_oVals + -- Step 3: lhs.idxOf v = outputs.keys.idxOf v (alignment). + have HAlign_lhs : lhs.idxOf v = j_out := by + show lhs.idxOf v = (ListMap.keys proc.header.outputs).idxOf v + rw [← HoutAlign v Hv_out Hv_callLhs, hCallArgsLhs] + -- Step 4: σ v = oVals[lhs.idxOf v]'_. + let j_lhs := lhs.idxOf v + have Hj_lhs_lt_oVals : j_lhs < oVals.length := by + rw [← ReadValuesLength Hevalouts] + exact List.idxOf_lt_length_of_mem Hv_lhs + have HStep4 : σ v = some (oVals[j_lhs]'Hj_lhs_lt_oVals) := + read_at Hevalouts Hv_lhs Hj_lhs_lt_oVals + -- Step 5: σ v = some oldVals[i]'_ (HoldVals positional). + have Hi_oldVals : i < oldVals.length := HoldValsLen.symm ▸ Hi + have HStep5 : σ v = some (oldVals[i]'Hi_oldVals) := + readValues_get (σ:=σ) (ks:=oldVars) (vs:=oldVals) HoldVals + (i:=i) (hi:=Hi) (hi':=Hi_oldVals) + -- Combine: δ σO (mkOld v.name) = some oldVals[i]. + show δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) none) + = some (oldVals[i]'Hi_oldVals) + rw [HStep1, HStep2] + have Hj_eq : oVals[j_out]'Hj_out_lt_oVals = + oVals[j_lhs]'Hj_lhs_lt_oVals := by + congr 1; exact HAlign_lhs.symm + rw [Hj_eq, ← HStep4, HStep5] + -- D2d: Structural pieces of HpostPayload (per-entry). + let oldTripsCanonical_L6 : + List ((Expression.Ident × Expression.Ty) × + Expression.Ident) := + (((genOldIdents.zip oldTys).zip oldVars).zip + (oldVars.map (fun g => CoreIdent.mkOld g.name))).map + fun (((fresh, ty), _orig), oldG) => ((fresh, ty), oldG) + let inputOnlyOldSubst_L6 : + Map Expression.Ident Expression.Expr := + callElim_inputOnlyOldSubst proc' args + let oldSubst_L6 : Map Expression.Ident Expression.Expr := + Core.Transform.createOldVarsSubst oldTripsCanonical_L6 ++ + inputOnlyOldSubst_L6 + let posts_filtered_L6 : + ListMap CoreLabel Procedure.Check := + Procedure.Spec.updateCheckExprs + (proc'.spec.postconditions.values.map + (fun c => + Lambda.LExpr.substFvars c.expr oldSubst_L6)) + proc'.spec.postconditions + -- Per-entry decomposition helper: posts_filtered_L6 entries + -- correspond to original posts via updateCheckExprs_substFvars_mem. + have forall_post_filtered_decompose : + ∀ entry : CoreLabel × Procedure.Check, + entry ∈ posts_filtered_L6.toList → + ∃ c ∈ proc'.spec.postconditions.values, + entry.snd.expr = + Lambda.LExpr.substFvars c.expr oldSubst_L6 := by + intro entry Hentry + apply updateCheckExprs_substFvars_mem + rw [updateCheckExprs_walk_eq_go] + show entry ∈ + (proc'.spec.postconditions.keys.zip + (Procedure.Spec.updateCheckExprs.go _ _)) + exact Hentry + -- D2d-eval: per-fvar bridges for substFvars eval (split via + -- oldSubst_L6 = createOldVarsSubst ++ inputOnlyOldSubst). + have HoldSubBridge : + ∀ k w, + Map.find? + (Core.Transform.createOldVarsSubst + oldTripsCanonical_L6) k = some w → + δ σ_R1 w = + δ σO (Lambda.LExpr.fvar () k none) := by + intro k w Hf + -- Positional decomposition via createOldVarsSubst_pos_decomp. + obtain ⟨ni_val, Hni_lt, Hk_eqMkOld, Hw_eq⟩ := + createOldVarsSubst_pos_decomp HgenOldLen HoldTysLen Hf + have Hni_lt_genOld : ni_val < genOldIdents.length := HgenOldLen.symm ▸ Hni_lt + -- LHS: δ σ_R1 w = σ_R1 genOldIdents[i] = some oldVals[i]. + have Hni_lt_oldVals : ni_val < oldVals.length := HoldValsLen.symm ▸ Hni_lt + have HrdR1_get : + σ_R1 (genOldIdents[ni_val]'Hni_lt_genOld) = + some (oldVals[ni_val]'Hni_lt_oldVals) := + σ_R1_read_olds ni_val Hni_lt_genOld Hni_lt_oldVals + -- δ σ_R1 (createFvar gen) = σ_R1 gen. + have HwfL : + δ σ_R1 (Core.Transform.createFvar + (genOldIdents[ni_val]'Hni_lt_genOld)) = + σ_R1 (genOldIdents[ni_val]'Hni_lt_genOld) := by + show δ σ_R1 (Lambda.LExpr.fvar () _ none) = _ + exact δ_fvar_eq σ_R1 _ + -- RHS via HoldEval_bridge. + have HoldEv : + δ σO (Lambda.LExpr.fvar () + (CoreIdent.mkOld + (oldVars[ni_val]'Hni_lt).name) + none) = + some (oldVals[ni_val]'Hni_lt_oldVals) := + HoldEval_bridge ni_val Hni_lt + -- Conclude. + rw [Hw_eq, HwfL, HrdR1_get, Hk_eqMkOld, HoldEv] + -- (2b) HinputSubBridge: inputOnlyOldSubst codomain. + have HinputSubBridge : + ∀ k w, + Map.find? inputOnlyOldSubst_L6 k = some w → + δ σ_R1 w = + δ σO (Lambda.LExpr.fvar () k none) := by + intro k w Hf + -- Positional decomposition via the shared helper. + obtain ⟨ni_val, Hni_lt_inKeys, Hni_lt_inArgs, + Hk_eq_proc', Hw_eq_proc', Hin_notin_outs_proc'⟩ := + inputOnlyOldSubst_pos_decomp Hf + -- Bridge proc' = proc. + have Hni_lt_inKeys' : + ni_val < proc.header.inputs.keys.length := by + have HEqLen : proc'.header.inputs.keys.length = + proc.header.inputs.keys.length := by rw [HprocEq] + omega + have HpinKeys : + proc'.header.inputs.keys[ni_val]'Hni_lt_inKeys = + proc.header.inputs.keys[ni_val]'Hni_lt_inKeys' := by + subst HprocEq; rfl + -- Let `inputId := inputs.keys[ni_val]`. + let inputId : Expression.Ident := + proc.header.inputs.keys[ni_val]'Hni_lt_inKeys' + have HinputId_in : inputId ∈ proc.header.inputs.keys := + List.getElem_mem _ + have HinputId_notin_outs : + inputId ∉ proc.header.outputs.keys := + fun h => Hiodisj HinputId_in h + -- argExpr := the snd projection. + let argExpr : Expression.Expr := + (CallArg.getInputExprs args)[ni_val]'Hni_lt_inArgs + have HargExpr_in : argExpr ∈ CallArg.getInputExprs args := + List.getElem_mem _ + -- k = mkOld inputId.name. + have Hk_mkOld : k = CoreIdent.mkOld inputId.name := by + rw [Hk_eq_proc', HpinKeys] + -- w = argExpr. + have Hw_argExpr : w = argExpr := Hw_eq_proc' + -- Fin-packaging so existing `ni : Fin …` users still apply. + let ni : Fin (CallArg.getInputExprs args).length := + ⟨ni_val, Hni_lt_inArgs⟩ + have Hni_lt_inArgsCall : ni.val < inArgs.length := by + have : (CallArg.getInputExprs args).length = + inArgs.length := by rw [hCallArgsIn] + rw [← this] + exact Hni_lt_inArgs + have HargExpr_eq_inArgs : + argExpr = inArgs[ni.val]'Hni_lt_inArgsCall := by + show (CallArg.getInputExprs args)[ni.val]'Hni_lt_inArgs = + inArgs[ni.val]'Hni_lt_inArgsCall + congr 1 <;> exact hCallArgsIn + -- argVals length facts. + have HinKeys_argVals_len : + proc.header.inputs.keys.length = argVals.length := + InitStatesLength Hinitin + have Hni_lt_argVals : ni.val < argVals.length := by + rw [← HinKeys_argVals_len] + exact Hni_lt_inKeys' + -- ── RHS chain (StepA→StepD fused): δ σO (mkOld inputId.name) + -- = some argVals[ni.val] via Hwf2 → σO_eq_σAO_off_outs → + -- initStates_get_notin → readValues_get. ── + have HRHS_oldEqArgVal : + δ σO (Lambda.LExpr.fvar () + (CoreIdent.mkOld inputId.name) none) = + some (argVals[ni.val]'Hni_lt_argVals) := by + simp only [WellFormedCoreEvalTwoState] at Hwf2 + rw [(Hwf2.2 proc.header.outputs.keys [] σAO σO σO + ⟨Hhav1, HInitVars_empty⟩ inputId).2 HinputId_notin_outs, + σO_eq_σAO_off_outs HinputId_notin_outs, + initStates_get_notin Hinitout HinputId_notin_outs] + exact readValues_get (InitStatesReadValues Hinitin) + (i:=ni.val) (hi:=Hni_lt_inKeys') (hi':=Hni_lt_argVals) + -- ── RHS Step E: argVals[ni.val] = δ σ argExpr + -- via evalExpressions_get + hCallArgsIn. ── + have HRHS_StepE : + δ σ argExpr = + some (argVals[ni.val]'Hni_lt_argVals) := by + have Hev := evalExpressions_get Hevalargs + Hni_lt_inArgsCall Hni_lt_argVals + -- Bridge δ σ argExpr = δ σ inArgs[ni.val]. + have HargList : + List.get inArgs ⟨ni.val, Hni_lt_inArgsCall⟩ = + inArgs[ni.val]'Hni_lt_inArgsCall := rfl + have HvalList : + List.get argVals ⟨ni.val, Hni_lt_argVals⟩ = + argVals[ni.val]'Hni_lt_argVals := rfl + rw [HargList, HvalList] at Hev + rw [HargExpr_eq_inArgs] + exact Hev + -- LHS Step F: δ σ_R1 argExpr = δ σ argExpr. + -- For v ∈ getVars argExpr, σ v is some (definedness lift). + have HargExpr_in_argList : + argExpr ∈ inArgs := by + rw [HargExpr_eq_inArgs] + exact List.getElem_mem _ + have HargExpr_in_callList : + argExpr ∈ CallArg.getInputExprs args := HargExpr_in + -- σ_R1 ↔ σ pointwise on argExpr's free vars. + have Hσ_R1_eq_σ_argVars : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) + argExpr, + σ_R1 v = σ v := by + intro v Hv + have Hσv_some : (σ v).isSome := HargIsDef v <| + List.mem_flatMap.mpr ⟨argExpr, HargExpr_in_argList, Hv⟩ + have HvNotGen : v ∉ genOldIdents := + notMem_of_Forall_neg HoldIdentsTemp fun Hold => + σ_some_contradiction Hσv_some + (Option.isNone_iff_eq_none.mp (Hgenrel.oldFresh v Hold)) + show updatedStates σO genOldIdents oldVals v = σ v + exact σR1_eq_σ_for_notTouched Hinitin Hinitout Hhav1 + (HargVarsNotInInKeys argExpr HargExpr_in_callList v Hv) + (HargVarsNotInOutKeys argExpr HargExpr_in_callList v Hv) + HvNotGen + -- Lift to δ-eval via Hwfvars (fvarcongr-like). + have Hδ_R1_eq_δ_σ : + δ σ_R1 argExpr = δ σ argExpr := by + -- Apply subst_fvars_eval_bridge with empty subst map. + have Hsurv : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) + argExpr, + Map.find? (∅ : Map Expression.Ident + Expression.Expr) v = none → + δ σ_R1 (Lambda.LExpr.fvar () v none) = + δ σ (Lambda.LExpr.fvar () v none) := by + intro v Hv _ + rw [δ_fvar_eq σ_R1 v, δ_fvar_eq σ v] + exact Hσ_R1_eq_σ_argVars v Hv + have Hsub : + ∀ k' w', k' ∈ Imperative.HasVarsPure.getVars + (P:=Expression) argExpr → + Map.find? (∅ : Map Expression.Ident + Expression.Expr) k' = some w' → + δ σ_R1 w' = + δ σ (Lambda.LExpr.fvar () k' none) := by + intro k' w' _ Hf + simp [Map.find?] at Hf + have Hbridge : + δ σ_R1 (Lambda.LExpr.substFvars argExpr + (∅ : Map Expression.Ident + Expression.Expr)) = + δ σ argExpr := + subst_fvars_eval_bridge Hwfc Hwfvars Hwfval + (sm:=∅) + Hsurv Hsub + -- substFvars argExpr ∅ = argExpr. + have HsubstEmpty : + Lambda.LExpr.substFvars argExpr + (∅ : Map Expression.Ident Expression.Expr) = + argExpr := by + induction argExpr with + | fvar m name ty => + rw [Lambda.LExpr.substFvars_fvar_none m name ty]; rfl + | _ => simp [Lambda.LExpr.substFvars_abs, + Lambda.LExpr.substFvars_quant, + Lambda.LExpr.substFvars_app, + Lambda.LExpr.substFvars_eq, + Lambda.LExpr.substFvars_ite, *] + rwa [HsubstEmpty] at Hbridge + rw [Hw_argExpr, Hδ_R1_eq_δ_σ, HRHS_StepE, + ← HRHS_oldEqArgVal, ← Hk_mkOld] + -- HpostEval_bridge: per-entry σ_R1 eval bridge via + -- subst_fvars_eval_bridge + HpostFiltered_corresp. + have HpostEval_bridge : + ∀ entry : CoreLabel × Procedure.Check, + entry ∈ posts_filtered_L6.toList → + δ σ_R1 entry.snd.expr = + some Imperative.HasBool.tt := by + intro entry Hentry + obtain ⟨c, Hc_in, Hentry_eq⟩ := + forall_post_filtered_decompose entry Hentry + -- entry.snd.expr = substFvars c.expr oldSubst_L6. + rw [Hentry_eq] + -- Build the combined Hsub for subst_fvars_eval_bridge. + have Hsub : + ∀ k w, k ∈ Imperative.HasVarsPure.getVars + (P:=Expression) c.expr → + Map.find? oldSubst_L6 k = some w → + δ σ_R1 w = + δ σO (Lambda.LExpr.fvar () k none) := by + intro k w _Hk Hf + -- oldSubst_L6 = createOldVarsSubst ... ++ inputOnlyOldSubst_L6; + -- split via `find?_append_{some_eq, none_elim}`. + cases hfind : Map.find? + (Core.Transform.createOldVarsSubst + oldTripsCanonical_L6) k with + | some v => + have Hvw : v = w := find?_append_some_eq hfind Hf + rw [← Hvw] + exact HoldSubBridge k v hfind + | none => + exact HinputSubBridge k w (find?_append_none_elim hfind Hf) + -- Build HsurvBridge specialized to c. + have Hc_filtered : c ∈ postsFiltered.map (·.snd) ∨ + c ∈ proc'.spec.postconditions.values := by + right; exact Hc_in + -- v ∈ getVars c.expr ⇒ ¬ isOldTempIdent v, via HpostVarsFresh. + have HsurvBridgeC : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) + c.expr, + Map.find? oldSubst_L6 v = none → + δ σ_R1 (Lambda.LExpr.fvar () v none) = + δ σO (Lambda.LExpr.fvar () v none) := by + intro v Hv _Hnone + -- v ∈ getVars c.expr where c ∈ proc'.spec.postconditions.values. + have HvFresh := HpostVarsFresh_via_c c Hc_in v Hv + have HvNotOld : ¬ isOldTempIdent v := HvFresh.2.1 + have HvNotGen : v ∉ genOldIdents := + notMem_of_Forall_neg HoldIdentsTemp HvNotOld + have Hσ_R1_v_eq_σO : + σ_R1 v = σO v := by + show (updatedStates σO genOldIdents oldVals) v = σO v + exact updatedStates_get_notin HvNotGen + rw [δ_fvar_eq σ_R1 v, δ_fvar_eq σO v] + exact Hσ_R1_v_eq_σO + -- Apply subst_fvars_eval_bridge. + have Hbridge : + δ σ_R1 (Lambda.LExpr.substFvars c.expr oldSubst_L6) = + δ σO c.expr := + subst_fvars_eval_bridge Hwfc Hwfvars Hwfval + HsurvBridgeC Hsub + rw [Hbridge] + -- Now `δ σO c.expr = some HasBool.tt`. + -- Bridge proc'.spec.postconditions ↔ proc.spec.postconditions. + have Hin_full := c_in_postExprs_of_proc' c Hc_in + have Hin_contains : + (Procedure.Spec.getCheckExprs + proc.spec.postconditions).contains c.expr = true := + List.contains_iff_mem.mpr Hin_full + exact (Hpost c.expr Hin_contains).2 + -- Hinv: residual invStores σ_R1 σ_havoc. + have HrdHavoc_olds_pos : + ∀ (i : Nat) (Hi : i < genOldIdents.length) + (Hi' : i < oldVals.length), + σ_havoc (genOldIdents[i]'Hi) = + some (oldVals[i]'Hi') := by + -- σ_havoc on genOldIdents: split via List.zip_append. + have HzipAppend2 : + ((argTemps ++ + outTemps) ++ genOldIdents).zip + ((argVals ++ oVals) ++ oldVals) = + ((argTemps ++ + outTemps).zip + (argVals ++ oVals)) ++ + (genOldIdents.zip oldVals) := by + apply List.zip_append + simp [List.length_append, HargTempsLen, HoutTempsLen] + have HsplitOverlay : + σ_havoc = + updatedStates + (updatedStates σ' + (argTemps ++ + outTemps) + (argVals ++ oVals)) + genOldIdents oldVals := by + show updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) = _ + simp only [updatedStates] + rw [HzipAppend2, updatedStates'App] + have HrdHavoc : + ReadValues σ_havoc genOldIdents oldVals := by + rw [HsplitOverlay] + exact readValues_updatedStatesSame HgenOldOldValsLen HoldNd + intro i Hi Hi' + exact readValues_get HrdHavoc (i:=i) (hi:=Hi) (hi':=Hi') + -- Shared class-(b) decompositions for Hinv/Hpred_disj + -- via oldSubst_L6 = createOldVarsSubst ++ inputOnlyOldSubst. + have b1_var_witness : + ∀ {var : Expression.Ident} + {k : Expression.Ident} {w w' : Expression.Expr} + (_hfind : Map.find? + (Core.Transform.createOldVarsSubst + oldTripsCanonical_L6) k = some w') + (_Hf : Map.find? oldSubst_L6 k = some w) + (_Hv_in : var ∈ Imperative.HasVarsPure.getVars + (P:=Expression) w), + ∃ (ni : Nat) (Hni : ni < genOldIdents.length), + w = Core.Transform.createFvar + (genOldIdents[ni]'Hni) ∧ + var = genOldIdents[ni]'Hni := by + intro var k w w' hfind Hf Hv_in + have Hw'w : w' = w := find?_append_some_eq hfind Hf + obtain ⟨ni_val, Hni_lt, _Hk_eqMkOld, Hw'_eq⟩ := + createOldVarsSubst_pos_decomp HgenOldLen HoldTysLen hfind + have Hni_lt_genOld : ni_val < genOldIdents.length := HgenOldLen.symm ▸ Hni_lt + have Hw_eq : w = + Core.Transform.createFvar + (genOldIdents[ni_val]'Hni_lt_genOld) := by + rw [← Hw'w]; exact Hw'_eq + refine ⟨ni_val, Hni_lt_genOld, Hw_eq, ?_⟩ + rw [Hw_eq] at Hv_in + have Hv_in' : + var ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Core.Transform.createFvar + (genOldIdents[ni_val]'Hni_lt_genOld)) := Hv_in + show var = _ + simp [Core.Transform.createFvar, + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars] at Hv_in' + exact Hv_in' + -- (b2): miss on createOldVarsSubst, hit on inputOnlyOldSubst. + -- Yields `w = inArgs[ni2]`, `w ∈ inArgs`, the input-key + -- positional fact, and `var ∈ flatMap getVars inArgs`. + have b2_var_witness : + ∀ {var : Expression.Ident} + {k : Expression.Ident} {w : Expression.Expr} + (_hfind_none : Map.find? + (Core.Transform.createOldVarsSubst + oldTripsCanonical_L6) k = none) + (_Hf : Map.find? oldSubst_L6 k = some w) + (_Hv_in : var ∈ Imperative.HasVarsPure.getVars + (P:=Expression) w), + w ∈ CallArg.getInputExprs args ∧ + var ∈ List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + inArgs := by + intro var k w hfind_none Hf Hv_in + obtain ⟨ni2_val, _Hni2_lt_inKeys, Hni2_lt_inArgs, + _Hk_eq_proc', Hw_eq_proc', _Hin_notin_outs⟩ := + inputOnlyOldSubst_pos_decomp + (find?_append_none_elim hfind_none Hf) + have HargExpr_def : + w = (CallArg.getInputExprs args)[ni2_val]'Hni2_lt_inArgs := + Hw_eq_proc' + have Hni2_lt_inArgsCall : + ni2_val < inArgs.length := by + have : (CallArg.getInputExprs args).length = + inArgs.length := by rw [hCallArgsIn] + rw [← this] + exact Hni2_lt_inArgs + have HargExpr_eq_inArgs : + w = inArgs[ni2_val]'Hni2_lt_inArgsCall := by + rw [HargExpr_def] + show (CallArg.getInputExprs args)[ni2_val]'Hni2_lt_inArgs = + inArgs[ni2_val]'Hni2_lt_inArgsCall + congr 1 <;> exact hCallArgsIn + have Hk1_in_inArgs : w ∈ inArgs := by + rw [HargExpr_eq_inArgs]; exact List.getElem_mem _ + have HargExpr_in : w ∈ CallArg.getInputExprs args := by + rw [HargExpr_def]; exact List.getElem_mem _ + have Hk1_flat : + var ∈ List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + inArgs := by + rw [List.mem_flatMap] + exact ⟨w, Hk1_in_inArgs, Hv_in⟩ + exact ⟨HargExpr_in, Hk1_flat⟩ + have Hinv : + ∀ entry : CoreLabel × Procedure.Check, + entry ∈ posts_filtered_L6.toList → + Imperative.invStores σ_R1 σ_havoc + ((Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr).removeAll + (filtered_ks ++ filtered_ks')) := by + intro entry Hentry + obtain ⟨c, Hc_in, Hentry_eq⟩ := + forall_post_filtered_decompose entry Hentry + -- Open invStores. + simp only [Imperative.invStores, Imperative.substStores] + intros k1 k2 Hkin + obtain rfl := zip_self_eq Hkin + have Hk1_in : k1 ∈ + (Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr).removeAll + (filtered_ks ++ filtered_ks') := + (List.of_mem_zip Hkin).1 + -- Decompose removeAll. + simp only [List.removeAll, List.mem_filter, + List.elem_eq_mem, Bool.not_eq_true', + decide_eq_false_iff_not] at Hk1_in + obtain ⟨Hk1_pre, Hk1_notin_combined⟩ := Hk1_in + -- Decompose `k1 ∉ (outputs ++ filtered_inputs) ++ + -- (lhs ++ filtered_argTemps)` into 4 leaf facts. + obtain ⟨Hk1_notin_outs, Hk1_notin_filtIn, + Hk1_notin_lhs, Hk1_notin_filtArgT⟩ := + List.notin_append4 Hk1_notin_combined + -- entry.snd.expr = substFvars c.expr oldSubst_L6. + rw [Hentry_eq] at Hk1_pre + -- Decompose k1 ∈ getVars (substFvars c.expr oldSubst_L6). + rcases getVars_substFvars_mem Hk1_pre with + Hclass_a | ⟨k, w, Hk_in, Hf, Hv_in⟩ + · -- ── Class (a): k1 ∈ getVars c.expr ∧ find? oldSubst_L6 k1 = none ── + obtain ⟨Hk1_post, _Hf_none⟩ := Hclass_a + -- HpostsVarsFresh_orig: ¬tmp_, ¬old_, k1 ∉ lhs. + have HfreshK := HpostVarsFresh_via_c c Hc_in k1 Hk1_post + have Hk1_notTemp : ¬ isTempIdent k1 := HfreshK.1 + have Hk1_notOld : ¬ isOldTempIdent k1 := HfreshK.2.1 + -- k1 ∉ argTemps (tmp_). + have Hk1_notin_argT : k1 ∉ argTemps := + notMem_of_Forall_neg HargTemp Hk1_notTemp + have Hk1_notin_outT : k1 ∉ outTemps := + notMem_of_Forall_neg HoutTemp Hk1_notTemp + have Hk1_notin_genOld : k1 ∉ genOldIdents := + notMem_of_Forall_neg HoldIdentsTemp Hk1_notOld + -- k1 ∉ inputs.keys (since k1 ∉ outputs and k1 ∉ filtered_inputs). + have Hk1_notin_ins : + k1 ∉ proc.header.inputs.keys := by + intro h + -- k1 ∈ inputs.keys, k1 ∉ outputs.keys ⇒ k1 ∈ filtered_inputs. + rcases List.mem_iff_get.mp h with ⟨n, Hn⟩ + have Hn_lt_in : n.val < proc.header.inputs.keys.length := n.isLt + have Hn_lt_argT : n.val < argTemps.length := + HinKeys_argTemps_len ▸ Hn_lt_in + have HkE : + proc.header.inputs.keys[n.val]'Hn_lt_in = k1 := Hn + have Hpair_in_zip : + (k1, argTemps[n.val]'Hn_lt_argT) ∈ + proc.header.inputs.keys.zip argTemps := by + rw [← HkE] + exact pair_in_zip_of_pos Hn_lt_in Hn_lt_argT + have Hpair_in_filtAS : + (k1, argTemps[n.val]'Hn_lt_argT) ∈ + filtered_argSubst := by + apply List.mem_filter.mpr + refine ⟨Hpair_in_zip, ?_⟩ + simp only [decide_not, Bool.not_eq_eq_eq_not, + Bool.not_true, decide_eq_false_iff_not, + List.contains_iff_mem] + exact Hk1_notin_outs + have Hk1_in_unzip : + k1 ∈ filtered_inputs := by + show k1 ∈ filtered_argSubst.unzip.fst + simp only [List.unzip_eq_map, List.mem_map] + refine ⟨(k1, argTemps[n.val]'Hn_lt_argT), Hpair_in_filtAS, rfl⟩ + exact Hk1_notin_filtIn Hk1_in_unzip + exact σR1_eq_σhavoc Hk1_notin_ins Hk1_notin_outs + Hk1_notin_argT Hk1_notin_outT Hk1_notin_genOld Hk1_notin_lhs + · -- ── Class (b): k1 ∈ getVars w for some (k, w) ∈ oldSubst_L6 ── + -- Split via Map.find?_append. + cases hfind : Map.find? + (Core.Transform.createOldVarsSubst + oldTripsCanonical_L6) k with + | some w' => + -- (b1) createOldVarsSubst flavor — via shared helper. + obtain ⟨ni_val, Hni_lt_genOld, _Hw_eq, Hv_eq_gen⟩ := + b1_var_witness hfind Hf Hv_in + -- σ_R1 k1 = oldVals[ni_val]; σ_havoc k1 = oldVals[ni_val]. + have Hni_lt_oldVals : ni_val < oldVals.length := + HoldValsLen.symm ▸ HgenOldLen ▸ Hni_lt_genOld + have Hσ_R1_v : + σ_R1 (genOldIdents[ni_val]'Hni_lt_genOld) = + some (oldVals[ni_val]'Hni_lt_oldVals) := + σ_R1_read_olds ni_val Hni_lt_genOld Hni_lt_oldVals + have Hσ_havoc_v : + σ_havoc (genOldIdents[ni_val]'Hni_lt_genOld) = + some (oldVals[ni_val]'Hni_lt_oldVals) := + HrdHavoc_olds_pos ni_val Hni_lt_genOld Hni_lt_oldVals + rw [Hv_eq_gen, Hσ_R1_v, Hσ_havoc_v] + | none => + -- (b2) inputOnlyOldSubst flavor — via shared helper. + obtain ⟨HargExpr_in, Hk1_flat⟩ := + b2_var_witness hfind Hf Hv_in + -- k1 ∈ getVars w. By HargVarsNotIn{Out,In}Keys: + have Hk1_notin_outs' : + k1 ∉ proc.header.outputs.keys := + HargVarsNotInOutKeys w HargExpr_in k1 Hv_in + have Hk1_notin_ins' : + k1 ∉ proc.header.inputs.keys := + HargVarsNotInInKeys w HargExpr_in k1 Hv_in + -- k1 ∈ σ-defined via Hevalargs. + have Hk1_σ_some : (σ k1).isSome := HargIsDef k1 Hk1_flat + -- k1 not isOldTempIdent. + have Hk1_notOld' : ¬ isOldTempIdent k1 := fun Hold => + σ_some_contradiction Hk1_σ_some + (Option.isNone_iff_eq_none.mp (Hgenrel.oldFresh k1 Hold)) + -- k1 not isTempIdent. Via isNotDefined of argTemps/outTemps. + have Hk1_notin_argT' : k1 ∉ argTemps := notin_of_isSome_isNotDefined Hk1_σ_some HndefArg_σ + have Hk1_notin_outT' : k1 ∉ outTemps := notin_of_isSome_isNotDefined Hk1_σ_some HndefOut_σ + have Hk1_notin_genOld' : k1 ∉ genOldIdents := notin_of_isSome_isNotDefined Hk1_σ_some HndefOld_σ + exact σR1_eq_σhavoc Hk1_notin_ins' Hk1_notin_outs' + Hk1_notin_argT' Hk1_notin_outT' Hk1_notin_genOld' + Hk1_notin_lhs + -- Hpred_disj: filtered_ks' disjoint from entry's vars. + have HfiltArgT_sub_argT : + ∀ x ∈ filtered_argTemps, x ∈ argTemps := by + intro x Hx + show x ∈ argTemps + -- filtered_argTemps = filtered_argSubst.unzip.snd ⊆ argTemps. + have Hx' : x ∈ filtered_argSubst.unzip.snd := Hx + simp only [List.unzip_eq_map, List.mem_map] at Hx' + rcases Hx' with ⟨pair, Hpair_mem, Hpair_snd⟩ + have Hpair_in_zip := (List.mem_filter.mp Hpair_mem).1 + -- pair ∈ inputs.keys.zip argTemps ⇒ pair.snd ∈ argTemps. + have Hsnd_in : + pair.snd ∈ argTemps := + (List.of_mem_zip Hpair_in_zip).2 + rw [← Hpair_snd]; exact Hsnd_in + have Hpred_disj : + ∀ entry : CoreLabel × Procedure.Check, + entry ∈ posts_filtered_L6.toList → + filtered_ks'.Disjoint + (Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr) := by + intro entry Hentry + obtain ⟨c, Hc_in, Hentry_eq⟩ := + forall_post_filtered_decompose entry Hentry + intro x Hin1 Hin2 + -- x ∈ filtered_ks' = lhs ++ filtered_argTemps. + -- x ∈ entry.snd.expr.getVars. + rw [Hentry_eq] at Hin2 + rcases getVars_substFvars_mem Hin2 with + Hclass_a | ⟨k', w, Hk_in, Hf, Hv_in⟩ + · -- ── Class (a): x ∈ getVars c.expr ── + obtain ⟨Hx_post, _Hf_none⟩ := Hclass_a + -- HpostsVarsFresh_orig: ¬tmp_, ¬old_, x ∉ lhs. + have HfreshK := HpostVarsFresh_via_c c Hc_in x Hx_post + have Hx_notTemp : ¬ isTempIdent x := HfreshK.1 + have Hx_notLhs : x ∉ CallArg.getLhs args := HfreshK.2.2 + -- Show contradiction. + cases List.mem_append.mp Hin1 with + | inl Hx_lhs => + rw [hCallArgsLhs] at Hx_notLhs + exact Hx_notLhs Hx_lhs + | inr Hx_filtArgT => + have Hx_argT : x ∈ argTemps := + HfiltArgT_sub_argT x Hx_filtArgT + exact Hx_notTemp ((List.Forall_mem_iff.mp HargTemp) x Hx_argT) + · -- ── Class (b): x ∈ getVars w for some (k', w) ∈ oldSubst_L6 ── + cases hfind : Map.find? + (Core.Transform.createOldVarsSubst + oldTripsCanonical_L6) k' with + | some w' => + -- (b1) createOldVarsSubst flavor — via shared helper. + obtain ⟨ni_val, Hni_lt_genOld, _Hw_eq, Hx_eq_gen⟩ := + b1_var_witness hfind Hf Hv_in + rw [Hx_eq_gen] at Hin1 + -- genOldIdents[ni_val] ∈ filtered_ks' = lhs ++ filtered_argTemps. + -- Each branch yields contradiction. + cases List.mem_append.mp Hin1 with + | inl Hx_lhs => + -- HlhsDisjOld: lhs.Disjoint genOldIdents. + exact HlhsDisjOld Hx_lhs (List.getElem_mem _) + | inr Hx_filtArgT => + -- genOldIdents[i] is isOldTempIdent; filt_argT ⊆ argT + -- (isTempIdent); the two predicates are disjoint. + have Hx_argT : + genOldIdents[ni_val]'Hni_lt_genOld ∈ argTemps := + HfiltArgT_sub_argT _ Hx_filtArgT + have Hx_isTemp : isTempIdent (genOldIdents[ni_val]'Hni_lt_genOld) := + (List.Forall_mem_iff.mp HargTemp) _ Hx_argT + have Hx_isOld : isOldTempIdent (genOldIdents[ni_val]'Hni_lt_genOld) := + (List.Forall_mem_iff.mp HoldIdentsTemp) _ (List.getElem_mem _) + exact isTempIdent_isOldTempIdent_disjoint + Hx_isTemp Hx_isOld + | none => + -- (b2) inputOnlyOldSubst flavor — via shared helper. + obtain ⟨HargExpr_in, Hx_flat⟩ := + b2_var_witness hfind Hf Hv_in + -- x ∈ σ-defined via Hevalargs. + have Hx_σ_some : (σ x).isSome := HargIsDef x Hx_flat + -- Now case-split on x ∈ filtered_ks'. + cases List.mem_append.mp Hin1 with + | inl Hx_lhs => + -- x ∉ lhs via HargVarsNotInLhs (clause 3). + have Hx_notLhs : + x ∉ CallArg.getLhs args := + HargVarsNotInLhs w HargExpr_in x Hv_in + rw [hCallArgsLhs] at Hx_notLhs + exact Hx_notLhs Hx_lhs + | inr Hx_filtArgT => + -- x ∈ argTemps ⇒ σ x = none, but σ x is some. + have Hx_argT : + x ∈ argTemps := + HfiltArgT_sub_argT x Hx_filtArgT + exact σ_some_contradiction Hx_σ_some + (HndefArg_σ x Hx_argT) + -- HpostPayload: combined per-entry payload for L6. + have HpostPayload : + ∀ entry : CoreLabel × Procedure.Check, + entry ∈ posts_filtered_L6.toList → + Imperative.invStores σ_R1 σ_havoc + ((Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr).removeAll + (filtered_ks ++ filtered_ks')) ∧ + filtered_ks'.Disjoint + (Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr) ∧ + δ σ_R1 entry.snd.expr = + some Imperative.HasBool.tt := by + intro entry Hentry + refine ⟨Hinv entry Hentry, + Hpred_disj entry Hentry, + HpostEval_bridge entry Hentry⟩ + -- D2f: Apply H_assumes_zip to derive HL6 (L6 segment of glue). + obtain ⟨assumeLabels, _HassumeLabelsLen, HassumeShape⟩ := + HassumesShape + -- Bridge: `assumeSubst = filtered_ks.zip (createFvars filtered_ks')`. + have HassumeSubst_eq : + ((proc'.header.outputs.keys.zip + (Core.Transform.createFvars (CallArg.getLhs args))) ++ + (proc'.header.inputs.keys.zip + (Core.Transform.createFvars argTemps)).filter + (fun (id, _) => + !(ListMap.keys proc'.header.outputs).contains id)) = + filtered_ks.zip + (Core.Transform.createFvars filtered_ks') := by + rw [HprocEq] + show _ = (proc.header.outputs.keys ++ filtered_inputs).zip + (Core.Transform.createFvars (lhs ++ filtered_argTemps)) + rw [createFvarsApp] + rw [List.zip_append + (show proc.header.outputs.keys.length = + (Core.Transform.createFvars lhs).length by + rw [createFvarsLength, + HoutKeys_lhs_len])] + -- Head: bridge via hCallArgsLhs. + rw [hCallArgsLhs] + congr 1 + show (proc.header.inputs.keys.zip + (argTemps.map Core.Transform.createFvar)).filter _ = + filtered_argSubst.unzip.fst.zip + (filtered_argSubst.unzip.snd.map + Core.Transform.createFvar) + rw [List.zip_map_right] + rw [List.filter_map] + -- Bridge composed `!`/`Prod.map` filter to filtered_argSubst. + have HfiltEq : + (proc.header.inputs.keys.zip argTemps).filter + ((fun (x : Expression.Ident × Expression.Expr) => + !(ListMap.keys proc.header.outputs).contains x.1) ∘ + Prod.map id Core.Transform.createFvar) = + filtered_argSubst := by + show _ = (proc.header.inputs.keys.zip argTemps).filter + (fun pr => + ¬ (proc.header.outputs.keys).contains pr.1) + apply List.filter_congr + intro pr _ + cases pr with + | mk a b => simp [Function.comp, Prod.map] + rw [HfiltEq] + -- Massage the RHS: zip_map_right reverse + zip_unzip. + rw [show filtered_argSubst.unzip.fst.zip + (filtered_argSubst.unzip.snd.map + Core.Transform.createFvar) = + (filtered_argSubst.unzip.fst.zip + filtered_argSubst.unzip.snd).map + (Prod.map id Core.Transform.createFvar) from + List.zip_map_right] + rw [show filtered_argSubst.unzip.fst.zip + filtered_argSubst.unzip.snd = + filtered_argSubst from List.zip_unzip _] + -- ── Apply H_assumes_zip ── + have HL6_pre : + EvalStatementsContract π φ ⟨σ_havoc, δ, false⟩ + ((posts_filtered_L6.zip assumeLabels).map + (fun (entry, lbl) => + Statement.assume lbl + (Lambda.LExpr.substFvars entry.snd.expr + (filtered_ks.zip + (Core.Transform.createFvars filtered_ks'))) + (entry.snd.md.setCallSiteFileRange md))) + ⟨σ_havoc, δ, false⟩ := by + apply H_assumes_zip + (σA := σ_R1) (σ' := σ_havoc) + (ks := filtered_ks) + (ks' := filtered_ks') + (posts := posts_filtered_L6.toList) + (labels := assumeLabels) + Hwfb Hwfvars Hwfval Hwfc + Hkslen Hnd Hdef Hsubst + intros entry Hentry + exact HpostPayload entry Hentry + -- Bridge to the actual `assumes` list via HassumeShape. + have HL6 : + EvalStatementsContract π φ ⟨σ_havoc, δ, false⟩ + assumes ⟨σ_havoc, δ, false⟩ := by + -- HassumeShape proc'-keys agree with proc via HprocEq. + rw [HassumeShape] + rw [HassumeSubst_eq] + exact HL6_pre + -- ── D2g: Chain L1-L6 via EvalCallElim_glue ── + exact EvalCallElim_glue HL1 HL2 HL3 HL4 HL5 HL6 + · -- inner `Except.error` branch — contradiction + rename_i e_err heq_err + simp only [pure, StateT.pure, Prod.mk.injEq] at Helim + exact absurd Helim.1 (by simp) end -- public section diff --git a/Strata/Transform/CoreTransform.lean b/Strata/Transform/CoreTransform.lean index d621676ee0..78566c9367 100644 --- a/Strata/Transform/CoreTransform.lean +++ b/Strata/Transform/CoreTransform.lean @@ -20,9 +20,12 @@ namespace Transform open LabelGen +@[expose] def oldVarPrefix (id : String) : String := s!"old_{id}" +@[expose] def tmpVarPrefix (id : String) : String := s!"tmp_{id}" +@[expose] def createHavoc (ident : Expression.Ident) (md : Imperative.MetaData Expression) : Statement := Statement.havoc ident md @@ -31,6 +34,7 @@ def createHavoc (ident : Expression.Ident) def createHavocs (ident : List Expression.Ident) (md : (Imperative.MetaData Expression)) : List Statement := ident.map (createHavoc · md) +@[expose] def createFvar (ident : Expression.Ident) : Expression.Expr := Lambda.LExpr.fvar ((): ExpressionMetadata) ident none @@ -40,6 +44,7 @@ def createFvars (ident : List Expression.Ident) : List Expression.Expr := ident.map createFvar +@[expose] def genIdent (ident : Expression.Ident) (pf : String → String) : CoreGenM Expression.Ident := CoreGenState.gen (pf ident.name) @@ -47,10 +52,12 @@ def genIdent (ident : Expression.Ident) (pf : String → String) /-- Generate identifiers in the form of arg_... that can be used to reduce argument expressions to temporary variables. -/ +@[expose] def genArgExprIdent : CoreGenM Expression.Ident := genIdent "arg" tmpVarPrefix +@[expose] def genArgExprIdents (n:Nat) : CoreGenM (List Expression.Ident) := List.mapM (fun _ => genArgExprIdent) (List.replicate n ()) @@ -59,10 +66,12 @@ def genArgExprIdents (n:Nat) Retrieves a fresh identifier from the counter generator the given identifier "ident" within old(...), or retrieve an existing one from the exprMap Assumes that ident contains no duplicates -/ +@[expose] def genOutExprIdent (ident : Expression.Ident) : CoreGenM Expression.Ident := genIdent ident tmpVarPrefix +@[expose] def genOutExprIdents (idents : List Expression.Ident) : CoreGenM (List Expression.Ident) := List.mapM genOutExprIdent idents @@ -71,10 +80,12 @@ def genOutExprIdents (idents : List Expression.Ident) Retrieves a fresh identifier from the counter generator the given identifier "ident" within old(...), or retrieve an existing one from the exprMap Assumes that ident contains no duplicates -/ +@[expose] def genOldExprIdent (ident : Expression.Ident) : CoreGenM Expression.Ident := genIdent ident oldVarPrefix +@[expose] def genOldExprIdents (idents : List Expression.Ident) : CoreGenM (List Expression.Ident) := List.mapM genOldExprIdent idents @@ -133,6 +144,7 @@ abbrev Err := Strata.DiagnosticModel abbrev CoreTransformM := ExceptT Err (StateM CoreTransformState) /-- A lifter from CoreGenM to (StateM CoreTransformState) -/ +@[expose] def liftCoreGenM {α : Type} (cgm : CoreGenM α) : StateM CoreTransformState α := fun coreTransformState => let res := cgm coreTransformState.genState @@ -164,6 +176,7 @@ def setFactory (F : @Lambda.Factory CoreLParams) : CoreTransformM Unit := modify fun σ => { σ with factory := some F } /-- Increment a statistics counter by `n` (default 1), initializing if absent. -/ +@[expose] def incrementStat (key : String) (n : Nat := 1) : CoreTransformM Unit := modify fun σ => { σ with statistics := σ.statistics.increment key n } @@ -174,6 +187,7 @@ returned list has the shape ((generated_name, ty), original_expr) Only types of the 'inputs' parameter are used -/ +@[expose] def genArgExprIdentsTrip (inputs : @Lambda.LTySignature Visibility) (args : List Expression.Expr) @@ -188,6 +202,7 @@ returned list has the shape `((generated_name, ty), original_name)` Only types of the 'outputs' parameter are used. -/ +@[expose] def genOutExprIdentsTrip (outputs : @Lambda.LTySignature Visibility) (lhs : List Expression.Ident) @@ -199,12 +214,14 @@ def genOutExprIdentsTrip /-- Generate an init statement with rhs as expression -/ +@[expose] def createInit (trip : (Expression.Ident × Expression.Ty) × Expression.Expr) (md:Imperative.MetaData Expression) : Statement := match trip with | ((v', ty), e) => Statement.init v' ty (.det e) md +@[expose] def createInits (trips : List ((Expression.Ident × Expression.Ty) × Expression.Expr)) (md: (Imperative.MetaData Expression)) : List Statement := @@ -213,18 +230,21 @@ def createInits (trips : List ((Expression.Ident × Expression.Ty) × Expression /-- Generate an init statement with rhs as a free variable reference -/ +@[expose] def createInitVar (trip : (Expression.Ident × Expression.Ty) × Expression.Ident) (md:Imperative.MetaData Expression) : Statement := match trip with | ((v', ty), v) => Statement.init v' ty (.det (Lambda.LExpr.fvar () v none)) md +@[expose] def createInitVars (trips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)) (md : (Imperative.MetaData Expression)) : List Statement := trips.map (createInitVar · md) /-- turns a list of preconditions into asserts with substitution -/ +@[expose] def createAsserts (conds : ListMap CoreLabel Procedure.Check) (subst : Map Expression.Ident Expression.Expr) @@ -240,6 +260,7 @@ def createAsserts return Statement.assert newLabel.toPretty (Lambda.LExpr.substFvars check.expr subst) assertMd) /-- turns a list of preconditions into assumes with substitution -/ +@[expose] def createAssumes (conds : ListMap CoreLabel Procedure.Check) (subst : Map Expression.Ident Expression.Expr) @@ -258,6 +279,7 @@ def createAssumes /-- Generate the substitution pairs needed for the body of the procedure -/ +@[expose] def createOldVarsSubst (trips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)) : Map Expression.Ident Expression.Expr := diff --git a/Strata/Transform/CoreTransformSemantics.lean b/Strata/Transform/CoreTransformSemantics.lean new file mode 100644 index 0000000000..bbdc106678 --- /dev/null +++ b/Strata/Transform/CoreTransformSemantics.lean @@ -0,0 +1,1151 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.Languages.Core.StatementSemanticsProps +public import Strata.Transform.CoreTransform +public import Strata.DL.Util.String +import all Strata.Languages.Core.StatementSemantics +import all Strata.Languages.Core.StatementSemanticsProps + +/-! # Block-evaluator helpers for `CoreTransform`-generated statements + + These helpers connect `Core.Transform.create{Havocs,Inits,InitVars}` (defined + in `Strata.Transform.CoreTransform`) to the small-step + `EvalStatementsContract` semantics from + `Strata.Languages.Core.StatementSemantics`. + + They were previously private to `Strata.Transform.CallElimCorrect`; moving them + here lets multiple downstream proofs reuse them, and avoids the import cycle + that would arise from extending `StatementSemanticsProps` directly (which + cannot depend on `CoreTransform`). +-/ + +public section + +namespace Core + +open Imperative + +/-- A single contract-evaluating command produces a single-statement + `EvalStatementsContract` derivation. Reusable scaffold for the + block helpers below. -/ +theorem singleCmdToStmts + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ σ' : CoreStore} {c : Core.Command} + (Hcmd : Core.EvalCommandContract π δ σ c σ' false) : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + [Imperative.Stmt.cmd c] + ⟨σ', δ, false⟩ := by + unfold EvalStatementsContract Imperative.EvalStmtsSmall + apply ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_cons + apply ReflTrans.step _ _ _ + (Imperative.StepStmt.step_seq_inner (Imperative.StepStmt.step_cmd Hcmd)) + apply ReflTrans.step _ _ _ Imperative.StepStmt.step_seq_done + exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) + +/-- Singleton-eval helper for `Statement.assert`: lifts the assert evaluation + rule into a single-statement `EvalStatementsContract`. -/ +theorem singletonAssertEval + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ : CoreStore} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression) + (Hev : δ σ e = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ, δ, false⟩ [Statement.assert lbl e m] ⟨σ, δ, false⟩ := + singleCmdToStmts (π := π) (φ := φ) + (Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_assert_pass Hev Hwfb)) + +/-- Singleton-eval helper for `Statement.assume`. -/ +theorem singletonAssumeEval + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ : CoreStore} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression) + (Hev : δ σ e = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ, δ, false⟩ [Statement.assume lbl e m] ⟨σ, δ, false⟩ := + singleCmdToStmts (π := π) (φ := φ) + (Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_assume Hev Hwfb)) + +/-- Evaluating `createHavocs vs md` under contract semantics steps from σ + through `HavocVars vs` to σ'. -/ +theorem H_havocs + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ σ' : CoreStore} + {vs : List Expression.Ident} + {md : Imperative.MetaData Expression} + (Hwfv : Imperative.WellFormedSemanticEvalVar δ) + (Hdef : Imperative.isDefined σ vs) + (Hhav : HavocVars σ vs σ') : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + (Core.Transform.createHavocs vs md) + ⟨σ', δ, false⟩ := by + induction vs generalizing σ with + | nil => + have heq : σ' = σ := by cases Hhav; rfl + subst heq + exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) + | cons h t ih => + cases Hhav with + | update_some hUp hTail => + rename_i v σmid + have Hcmd : Core.EvalCommandContract π δ σ + (Core.CmdExt.cmd (Imperative.Cmd.set h .nondet md)) + σmid false := + Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_set_nondet hUp Hwfv) + have Hdef_tail : Imperative.isDefined σ t := + fun v hv => Hdef v (List.mem_cons_of_mem h hv) + have HdefTail : Imperative.isDefined σmid t := + Imperative.UpdateStateDefMonotone Hdef_tail hUp + have HrecTail := ih HdefTail hTail + simp only [Core.Transform.createHavocs, List.map_cons, + Core.Transform.createHavoc] + exact EvalStatementsContractApp (singleCmdToStmts Hcmd) HrecTail + +/-- Evaluating a single `Statement.init x ty (.det e) md` under contract + semantics steps from σ to `updatedState σ x v`, given `δ σ e = some v` + and that `x` is currently undefined in σ. -/ +theorem H_init + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ : CoreStore} + {x : Expression.Ident} {ty : Expression.Ty} + {e : Expression.Expr} {v : Expression.Expr} + {md : Imperative.MetaData Expression} + (Heval : δ σ e = some v) + (Hnone : σ x = none) + (Hwfv : Imperative.WellFormedSemanticEvalVar δ) : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + [Statement.init x ty (.det e) md] + ⟨updatedState σ x v, δ, false⟩ := by + have Hinit : Imperative.InitState Expression σ x v (updatedState σ x v) := by + apply Imperative.InitState.init Hnone + · simp [updatedState] + · intro y Hne + simp [updatedState] + intro Heq + exact absurd Heq.symm Hne + have Hcmd : Core.EvalCommandContract π δ σ + (Core.CmdExt.cmd (Imperative.Cmd.init x ty (.det e) md)) + (updatedState σ x v) false := + Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_init Heval Hinit Hwfv) + exact singleCmdToStmts Hcmd + +/-- If `k ∉ ks`, then `ReadValues σ ks vs` is preserved when extending σ + with an unrelated key. Re-derived from the legacy `ReadValuesUpdatedState`. -/ +theorem readValues_updatedState + {σ : CoreStore} {k : Expression.Ident} {v : Expression.Expr} + {ks : List Expression.Ident} {vs : List Expression.Expr} + (Hnin : ¬ k ∈ ks) + (Hrd : ReadValues σ ks vs) : + ReadValues (updatedState σ k v) ks vs := by + induction ks generalizing vs with + | nil => + cases Hrd + exact ReadValues.read_none + | cons x xs ih => + cases vs with + | nil => cases Hrd + | cons v' vs' => + cases Hrd with + | read_some Hsome Hrest => + have Hxk : x ≠ k := + fun heq => Hnin (heq ▸ List.mem_cons_self) + have Hnin_t : ¬ k ∈ xs := + fun hin => Hnin (List.mem_cons_of_mem _ hin) + have Hsome' : updatedState σ k v x = some v' := by + simp [updatedState, Hxk] + exact Hsome + exact ReadValues.read_some Hsome' (ih Hnin_t Hrest) + +/-- Evaluating `createInitVars trips md` under contract semantics steps σ + through one `Statement.init` per trip, given: + - generated names disjoint from referenced source names (Nodup gen ++ src), + - `ReadValues σ source-names readVals`, + - generated names not currently defined in σ. -/ +theorem H_initVars + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ : CoreStore} + {trips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)} + {readVals : List Expression.Expr} + {md : Imperative.MetaData Expression} + (Hwfv : Imperative.WellFormedSemanticEvalVar δ) + (Hndup : List.Nodup (trips.unzip.fst.unzip.fst ++ trips.unzip.snd)) + (Hrd : ReadValues σ trips.unzip.snd readVals) + (Hndef : Imperative.isNotDefined σ trips.unzip.fst.unzip.fst) : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + (Core.Transform.createInitVars trips md) + ⟨updatedStates σ trips.unzip.fst.unzip.fst readVals, δ, false⟩ := by + induction trips generalizing σ readVals with + | nil => + cases Hrd + simp only [Core.Transform.createInitVars, List.map_nil, + List.unzip_nil, updatedStates, updatedStates', List.zip_nil_left] + exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) + | cons h t ih => + obtain ⟨⟨x', ty⟩, src⟩ := h + -- Unfold the head Read, and the indices in goal/Hndup/Hndup + simp only [List.unzip_cons] at Hrd Hndup Hndef ⊢ + -- Hrd : ReadValues σ (src :: t.unzip.snd) readVals + -- Use a separate term-mode lemma to invert Hrd cleanly. + rcases Hrd with _ | ⟨_, Hrest_rd⟩ + rename_i tail_vals vv Hsrc + -- After simp, Hndup : List.Nodup (x' :: t.unzip.fst.unzip.fst ++ + -- src :: t.unzip.snd) + -- Tail Nodup: drop x' from heads, drop src from tails + have Hndup_tail : + List.Nodup (t.unzip.fst.unzip.fst ++ t.unzip.snd) := by + rw [List.cons_append] at Hndup + have Hndup1 : List.Nodup (t.unzip.fst.unzip.fst ++ src :: t.unzip.snd) := + (List.nodup_cons.mp Hndup).2 + apply List.Sublist.nodup ?_ Hndup1 + apply List.Sublist.append_left + exact List.sublist_cons_self src t.unzip.snd + -- isNotDefined for the tail keys after updating x' + have Hndef_t : Imperative.isNotDefined σ t.unzip.fst.unzip.fst := by + unfold Imperative.isNotDefined + intro y hy + exact Hndef y (List.mem_cons_of_mem _ hy) + -- Read-values preserved on updated state for the tail's source list. + -- We need `¬ x' ∈ t.unzip.snd` from Hndup. + have Hxsrc_tail : ¬ x' ∈ t.unzip.snd := by + rw [List.cons_append] at Hndup + -- Hndup : List.Nodup (x' :: (t.unzip.fst.unzip.fst ++ src :: t.unzip.snd)) + have Hnotin : x' ∉ (t.unzip.fst.unzip.fst ++ src :: t.unzip.snd) := + (List.nodup_cons.mp Hndup).1 + intro Hin + apply Hnotin + apply List.mem_append_right + exact List.mem_cons_of_mem _ Hin + have Hrest_rd' : ReadValues (updatedState σ x' vv) t.unzip.snd tail_vals := + readValues_updatedState Hxsrc_tail Hrest_rd + -- isNotDefined preserved on the updated state for the rest of heads. + have Hndef_t' : + Imperative.isNotDefined (updatedState σ x' vv) t.unzip.fst.unzip.fst := by + unfold Imperative.isNotDefined + intro y hy + have Hyne : y ≠ x' := by + intro heq + rw [List.cons_append] at Hndup + have Hnotin : x' ∉ (t.unzip.fst.unzip.fst ++ src :: t.unzip.snd) := + (List.nodup_cons.mp Hndup).1 + apply Hnotin + apply List.mem_append_left + exact heq.symm ▸ hy + simp [updatedState, Hyne] + exact Hndef_t y hy + -- Recursive call. + have Hrec := ih Hndup_tail Hrest_rd' Hndef_t' + -- Build the head step: Statement.init x' ty (.det (fvar src)) md + have Hsrc_eval : δ σ (Lambda.LExpr.fvar () src none) = some vv := by + have := Hwfv (Lambda.LExpr.fvar () src none) src σ + simp [Imperative.HasFvar.getFvar] at this + rw [this] + exact Hsrc + have Hxnone : σ x' = none := Hndef x' (by simp) + have Hhead : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + [Statement.init x' ty + (.det (Lambda.LExpr.fvar () src none)) md] + ⟨updatedState σ x' vv, δ, false⟩ := + H_init Hsrc_eval Hxnone Hwfv + -- Glue: createInitVars unfolds to head :: rest, and the updated states + -- compose. + have Hshape : + updatedStates σ (x' :: t.unzip.fst.unzip.fst) (vv :: tail_vals) = + updatedStates (updatedState σ x' vv) t.unzip.fst.unzip.fst tail_vals := by + simp [updatedStates, updatedStates'] + rw [Hshape] + have Hcombined : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + ([Statement.init x' ty + (.det (Lambda.LExpr.fvar () src none)) md] ++ + Core.Transform.createInitVars t md) + ⟨updatedStates (updatedState σ x' vv) t.unzip.fst.unzip.fst tail_vals, + δ, false⟩ := EvalStatementsContractApp Hhead Hrec + have Hunfold : + Core.Transform.createInitVars (((x', ty), src) :: t) md = + [Statement.init x' ty (.det (Lambda.LExpr.fvar () src none)) md] ++ + Core.Transform.createInitVars t md := by + simp [Core.Transform.createInitVars, Core.Transform.createInitVar] + rw [Hunfold] + exact Hcombined + +/-- If `k` is not in the free variables of `e`, evaluating `e` is unchanged + when σ is extended with `k ↦ v`. Re-derived from the legacy + `EvalExpressionUpdatedState` for the small-step proof. -/ +theorem evalExpression_updatedState + {δ : CoreEval} {σ : CoreStore} + {k : Expression.Ident} {v : Expression.Expr} + {e v' : Expression.Expr} + (Hwfv : Imperative.WellFormedSemanticEvalVar δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal δ) + (Hnin : ¬ k ∈ Imperative.HasVarsPure.getVars e) + (Heval : δ σ e = some v') : + δ (updatedState σ k v) e = some v' := by + simp [Imperative.WellFormedSemanticEvalVar, Imperative.HasFvar.getFvar] at Hwfv + simp [Imperative.WellFormedSemanticEvalVal] at Hwfvl + have Hval := Hwfvl.2 + simp [← Heval] at * + induction e <;> + simp [Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * + case const c | op o ty | bvar b => + rw [Hval]; rw [Hval]; constructor; constructor + case fvar m n ty => + simp [Hwfv] + simp [updatedState] + grind + case abs m ty e ih => + apply ((Hwfc.1 (updatedState σ k v) σ)) + grind + case quant m kk ty tr e trih eih => + apply Hwfc.quantcongr <;> grind + case app m fn e fnih eih => + apply Hwfc.appcongr <;> grind + case ite m c t e cih tih eih => + apply Hwfc.itecongr <;> grind + case eq m e1 e2 e1ih e2ih => + apply Hwfc.eqcongr <;> grind + +/-- List version: if `k` is not in the union of free variables of any `e ∈ es`, + `EvalExpressions δ σ es vs` survives the extension `σ[k ↦ v]`. -/ +theorem evalExpressions_updatedState + {δ : CoreEval} {σ : CoreStore} + {k : Expression.Ident} {v : Expression.Expr} + {es : List Expression.Expr} {vs : List Expression.Expr} + (Hwfv : Imperative.WellFormedSemanticEvalVar δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal δ) + (Hnin : ¬ k ∈ es.flatMap (Imperative.HasVarsPure.getVars (P:=Expression))) + (Heval : EvalExpressions (P:=Core.Expression) δ σ es vs) : + EvalExpressions (P:=Core.Expression) δ (updatedState σ k v) es vs := by + induction es generalizing vs with + | nil => + cases Heval + exact EvalExpressions.eval_none + | cons e' es_t ih => + cases vs with + | nil => cases Heval + | cons v_h vs_t => + cases Heval with + | eval_some Hdef He Hes => + have Hnin_h : ¬ k ∈ Imperative.HasVarsPure.getVars (P:=Expression) e' := by + intro Hin + apply Hnin + simp [List.mem_flatMap] + exact Or.inl Hin + have Hnin_t : ¬ k ∈ + es_t.flatMap (Imperative.HasVarsPure.getVars (P:=Expression)) := by + intro Hin + apply Hnin + simp [List.mem_flatMap] + right + simp [List.mem_flatMap] at Hin + obtain ⟨e2, He2_in, He2_var⟩ := Hin + exact ⟨e2, He2_in, He2_var⟩ + have Hdef' : Imperative.isDefined (updatedState σ k v) + (Imperative.HasVarsPure.getVars e') := by + unfold Imperative.isDefined + intro x Hx + have Hsome := Hdef x Hx + simp [updatedState] + split <;> simp_all + have He' : δ (updatedState σ k v) e' = some v_h := + evalExpression_updatedState Hwfv Hwfc Hwfvl Hnin_h He + exact EvalExpressions.eval_some Hdef' He' (ih Hnin_t Hes) + +/-- Evaluating `createInits trips md` under contract semantics steps σ + through one `Statement.init` per trip with the trip's expression + evaluating to the corresponding value. -/ +theorem H_inits + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ : CoreStore} + {trips : List ((Expression.Ident × Expression.Ty) × Expression.Expr)} + {evalVals : List Expression.Expr} + {md : Imperative.MetaData Expression} + (Hwfv : Imperative.WellFormedSemanticEvalVar δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hdisj : trips.unzip.fst.unzip.fst.Disjoint + (List.flatMap (Imperative.HasVarsPure.getVars (P:=Expression)) + trips.unzip.snd)) + (Hndup : List.Nodup trips.unzip.fst.unzip.fst) + (Heval : EvalExpressions (P:=Core.Expression) δ σ trips.unzip.snd evalVals) + (Hndef : Imperative.isNotDefined σ trips.unzip.fst.unzip.fst) : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + (Core.Transform.createInits trips md) + ⟨updatedStates σ trips.unzip.fst.unzip.fst evalVals, δ, false⟩ := by + induction trips generalizing σ evalVals with + | nil => + cases Heval + simp only [Core.Transform.createInits, List.map_nil, + List.unzip_nil, updatedStates, updatedStates', List.zip_nil_left] + exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) + | cons h t ih => + obtain ⟨⟨x', ty⟩, e⟩ := h + simp only [List.unzip_cons] at Heval Hdisj Hndup Hndef ⊢ + cases Heval + rename_i tail_vals vv Hdef He Hes + have Hndup_t : List.Nodup t.unzip.fst.unzip.fst := + (List.nodup_cons.mp Hndup).2 + have Hxnotin_e : ¬ x' ∈ Imperative.HasVarsPure.getVars (P:=Expression) e := by + intro Hin + have Hxmem : x' ∈ (x' :: t.unzip.fst.unzip.fst) := by simp + have Hflat : x' ∈ (e :: t.unzip.snd).flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) := by + simp [List.mem_flatMap] + exact Or.inl Hin + exact Hdisj Hxmem Hflat + have Hxnotin_es : ¬ x' ∈ t.unzip.snd.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) := by + intro Hin + have Hxmem : x' ∈ (x' :: t.unzip.fst.unzip.fst) := by simp + have Hflat : x' ∈ (e :: t.unzip.snd).flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) := by + simp [List.mem_flatMap] + right + simp [List.mem_flatMap] at Hin + obtain ⟨e2, He2_in, He2_var⟩ := Hin + exact ⟨e2, He2_in, He2_var⟩ + exact Hdisj Hxmem Hflat + have Hes' : EvalExpressions (P:=Core.Expression) δ + (updatedState σ x' vv) t.unzip.snd tail_vals := + evalExpressions_updatedState Hwfv Hwfc Hwfvl Hxnotin_es Hes + have Hxnone : σ x' = none := Hndef x' (by simp) + have Hndef_t : Imperative.isNotDefined σ t.unzip.fst.unzip.fst := by + unfold Imperative.isNotDefined + intro y hy + exact Hndef y (List.mem_cons_of_mem _ hy) + have Hndef_t' : Imperative.isNotDefined (updatedState σ x' vv) + t.unzip.fst.unzip.fst := by + unfold Imperative.isNotDefined + intro y hy + have Hyne : y ≠ x' := by + intro heq + have Hnotin : x' ∉ t.unzip.fst.unzip.fst := + (List.nodup_cons.mp Hndup).1 + apply Hnotin + exact heq ▸ hy + simp [updatedState, Hyne] + exact Hndef_t y hy + have Hdisj_t : + t.unzip.fst.unzip.fst.Disjoint + (List.flatMap (Imperative.HasVarsPure.getVars (P:=Expression)) + t.unzip.snd) := by + intro y Hy_in_t Hy_in_var + have Hy_in_h : y ∈ (x' :: t.unzip.fst.unzip.fst) := + List.mem_cons_of_mem _ Hy_in_t + have Hflat : y ∈ (e :: t.unzip.snd).flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) := by + simp [List.mem_flatMap] + right + simp [List.mem_flatMap] at Hy_in_var + obtain ⟨e2, He2_in_t, He2_var⟩ := Hy_in_var + exact ⟨e2, He2_in_t, He2_var⟩ + exact Hdisj Hy_in_h Hflat + have Hrec : EvalStatementsContract π φ ⟨updatedState σ x' vv, δ, false⟩ + (Core.Transform.createInits t md) + ⟨updatedStates (updatedState σ x' vv) t.unzip.fst.unzip.fst + tail_vals, δ, false⟩ := + ih Hdisj_t Hndup_t Hes' Hndef_t' + have Hhead : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + [Statement.init x' ty (.det e) md] + ⟨updatedState σ x' vv, δ, false⟩ := + H_init He Hxnone Hwfv + have Hshape : + updatedStates σ (x' :: t.unzip.fst.unzip.fst) (vv :: tail_vals) = + updatedStates (updatedState σ x' vv) t.unzip.fst.unzip.fst tail_vals := by + simp [updatedStates, updatedStates'] + rw [Hshape] + have Hcombined : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + ([Statement.init x' ty (.det e) md] ++ Core.Transform.createInits t md) + ⟨updatedStates (updatedState σ x' vv) t.unzip.fst.unzip.fst tail_vals, + δ, false⟩ := EvalStatementsContractApp Hhead Hrec + have Hunfold : + Core.Transform.createInits (((x', ty), e) :: t) md = + [Statement.init x' ty (.det e) md] ++ Core.Transform.createInits t md := by + simp [Core.Transform.createInits, Core.Transform.createInit] + rw [Hunfold] + exact Hcombined + +/-! ### Generic `mapM`-over-`CoreGenM` helpers + +The Arg/Out/Old gen-ident families share the structural shape +`List.mapM (g : α → CoreGenM Ident) l`, where the only difference is +`α` (Unit for Arg, Ident for Out/Old) and the per-element generator `g`. +The four facts below — length preservation, generated-stack accounting, +WF preservation, and `Forall`-lifting — depend only on (i) `mapM`'s +recursion shape and (ii) a pointwise hypothesis on the per-element +generator. We prove each generically once and derive the 12 +single-iterator specializations (3 each for Arg/Out/Old × length / +GeneratedWF / WFMono / Forall) as one-line corollaries. -/ + +/-- Length preservation for any `List.mapM` against `CoreGenM`. -/ +theorem genIdentMapM_length' {α : Type} + {g : α → CoreGenM Expression.Ident} + {l : List α} {s : CoreGenState} : + (List.mapM g l s).fst.length = l.length := by + induction l generalizing s <;> simp_all + case nil => + simp [pure, StateT.pure] + case cons h t ih => + simp [bind, StateT.bind, Functor.map] + split + simp [StateT.map, Functor.map] + apply ih + +/-- Generated-stack accounting for `List.mapM` once the per-element + generator is known to push exactly one element onto `generated`. -/ +theorem genIdentMapM_GeneratedWF {α : Type} + {g : α → CoreGenM Expression.Ident} + (Hone : ∀ {a : α} {s s' : CoreGenState} {l : Expression.Ident}, + g a s = (l, s') → s'.generated = l :: s.generated) + {l : List α} {s s' : CoreGenState} {ls : List Expression.Ident} + (Hgen : List.mapM g l s = (ls, s')) : + s'.generated = ls.reverse ++ s.generated := by + induction l generalizing s s' ls with + | nil => + simp only [List.mapM_nil, pure, StateT.pure] at Hgen + cases Hgen + simp + | cons h t ih => + simp only [List.mapM_cons, bind, StateT.bind, pure, StateT.pure] at Hgen + cases hg1 : g h s with + | mk a₁ s₁ => + rw [hg1] at Hgen + simp only at Hgen + cases hg2 : List.mapM g t s₁ with + | mk a₂ s₂ => + rw [hg2] at Hgen + cases Hgen + have HH₁ := Hone hg1 + have HH₂ := ih hg2 + rw [HH₂, HH₁] + simp + +/-- WF preservation for `List.mapM` once the per-element generator + preserves WF. -/ +theorem genIdentMapM_WFMono {α : Type} + {g : α → CoreGenM Expression.Ident} + (Hone : ∀ {a : α} {s s' : CoreGenState} {l : Expression.Ident}, + CoreGenState.WF s → g a s = (l, s') → CoreGenState.WF s') + {l : List α} {s s' : CoreGenState} {ls : List Expression.Ident} + (Hwf : CoreGenState.WF s) (Hgen : List.mapM g l s = (ls, s')) : + CoreGenState.WF s' := by + induction l generalizing s s' ls with + | nil => + simp only [List.mapM_nil, pure, StateT.pure] at Hgen + cases Hgen + exact Hwf + | cons h t ih => + simp only [List.mapM_cons, bind, StateT.bind, pure, StateT.pure] at Hgen + cases hg1 : g h s with + | mk a₁ s₁ => + rw [hg1] at Hgen + simp only at Hgen + cases hg2 : List.mapM g t s₁ with + | mk a₂ s₂ => + rw [hg2] at Hgen + cases Hgen + exact ih (Hone Hwf hg1) hg2 + +/-- `Forall`-lifting for `List.mapM` once the per-element generator + produces values satisfying the predicate. -/ +theorem genIdentMapM_Forall {α : Type} {P : Expression.Ident → Prop} + {g : α → CoreGenM Expression.Ident} + (Hone : ∀ {a : α} {s s' : CoreGenState} {l : Expression.Ident}, + g a s = (l, s') → P l) + {l : List α} {s s' : CoreGenState} {ls : List Expression.Ident} + (Hgen : List.mapM g l s = (ls, s')) : + Forall P ls := by + induction l generalizing s s' ls with + | nil => + simp only [List.mapM_nil, pure, StateT.pure] at Hgen + cases Hgen + simp [Forall] + | cons h t ih => + simp only [List.mapM_cons, bind, StateT.bind, pure, StateT.pure] at Hgen + cases hg1 : g h s with + | mk a₁ s₁ => + rw [hg1] at Hgen + simp only at Hgen + cases hg2 : List.mapM g t s₁ with + | mk a₂ s₂ => + rw [hg2] at Hgen + cases Hgen + simp [List.Forall_cons] + exact ⟨Hone hg1, ih hg2⟩ + +/-! ### Length lemmas for the `gen*ExprIdents{,Trip}` family + +The `_snd` and `*GeneratedWF` helpers below need to know that +`genArgExprIdents n` produces a list of length exactly `n`, etc. These +follow inductively from `genIdent`'s contract. Proved here so that the +trip-level helpers can quote them directly. -/ + +/-- The fst-projection of running `genArgExprIdent` `t.length`-many times + (with `t : List Unit`) is a list of length `t.length`. This is the + raw form; `genArgExprIdents_length'` specializes to `n = t.length`. -/ +theorem genArgExprIdent_len' + {t : List Unit} {s : CoreGenState} : + (List.mapM (fun _ => Core.Transform.genArgExprIdent) t s).fst.length = t.length := + genIdentMapM_length' + +theorem genArgExprIdents_length' + (n : Nat) (s : CoreGenState) : + (Core.Transform.genArgExprIdents n s).fst.length = n := by + simp only [Core.Transform.genArgExprIdents] + rw [genArgExprIdent_len'] + simp + +theorem genArgExprIdents_length + {n : Nat} {s s' : CoreGenState} {ls : List Expression.Ident} + (Hgen : Core.Transform.genArgExprIdents n s = (ls, s')) : + ls.length = n := by + have := genArgExprIdents_length' n s + rw [Hgen] at this + exact this + +theorem genOutExprIdent_len' + {t : List Expression.Ident} {s : CoreGenState} : + (List.mapM Core.Transform.genOutExprIdent t s).fst.length = t.length := + genIdentMapM_length' + +theorem genOutExprIdents_length' + (idents : List Expression.Ident) (s : CoreGenState) : + (Core.Transform.genOutExprIdents idents s).fst.length = idents.length := by + simp only [Core.Transform.genOutExprIdents] + exact genOutExprIdent_len' + +theorem genOutExprIdents_length + {idents : List Expression.Ident} {s s' : CoreGenState} + {ls : List Expression.Ident} + (Hgen : Core.Transform.genOutExprIdents idents s = (ls, s')) : + ls.length = idents.length := by + have := genOutExprIdents_length' idents s + rw [Hgen] at this + exact this + +theorem genOldExprIdent_len' + {t : List Expression.Ident} {s : CoreGenState} : + (List.mapM Core.Transform.genOldExprIdent t s).fst.length = t.length := + genIdentMapM_length' + +theorem genOldExprIdents_length' + (idents : List Expression.Ident) (s : CoreGenState) : + (Core.Transform.genOldExprIdents idents s).fst.length = idents.length := by + simp only [Core.Transform.genOldExprIdents] + exact genOldExprIdent_len' + +theorem genOldExprIdents_length + {idents : List Expression.Ident} {s s' : CoreGenState} + {ls : List Expression.Ident} + (Hgen : Core.Transform.genOldExprIdents idents s = (ls, s')) : + ls.length = idents.length := by + have := genOldExprIdents_length' idents s + rw [Hgen] at this + exact this + +/-! ### Trip-level success extractors + +The Arg and Out trip wrappers share a uniform success-branch shape: they +length-check, run a `genXxxExprIdents` call, and `return +(gen_idents.zip ys).zip xs`. Extracting the post-condition once removes +~80 LoC of repeated monad-layer simping. -/ + +theorem genArgExprIdentsTrip_extract + {inputs : @Lambda.LTySignature Visibility} {args : List Expression.Expr} + {s s' : Core.Transform.CoreTransformState} + {argTrips : List ((Expression.Ident × Lambda.LTy) × Expression.Expr)} + (Hgen : Core.Transform.genArgExprIdentsTrip inputs args s = (Except.ok argTrips, s')) : + let gen_idents := (Core.Transform.genArgExprIdents args.length s.genState).fst + let s_gen := (Core.Transform.genArgExprIdents args.length s.genState).snd + (gen_idents.zip (List.map Prod.snd inputs)).zip args = argTrips ∧ + s' = { s with genState := s_gen } ∧ + inputs.length = args.length := by + simp only [Core.Transform.genArgExprIdentsTrip] at Hgen + split at Hgen + case isTrue Hne => + simp [throw, throwThe, MonadExceptOf.throw, ExceptT.mk, pure, StateT.pure] at Hgen + cases Hgen + case isFalse Hlen => + simp [bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk, ExceptT.lift, + ExceptT.pure, StateT.bind, StateT.pure, pure, monadLift, + MonadLift.monadLift, liftM, Functor.map, StateT.map, + Core.Transform.liftCoreGenM] at Hgen + refine ⟨?_, ?_, ?_⟩ + · have := congrArg Prod.fst Hgen + simp at this + exact this + · have := congrArg Prod.snd Hgen + simp at this + exact this.symm + · simp at Hlen; exact Hlen + +theorem genOutExprIdentsTrip_extract + {outputs : @Lambda.LTySignature Visibility} {lhs : List Expression.Ident} + {s s' : Core.Transform.CoreTransformState} + {outTrips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)} + (Hgen : Core.Transform.genOutExprIdentsTrip outputs lhs s = (Except.ok outTrips, s')) : + let gen_idents := (Core.Transform.genOutExprIdents lhs s.genState).fst + let s_gen := (Core.Transform.genOutExprIdents lhs s.genState).snd + (gen_idents.zip (List.map Prod.snd outputs)).zip lhs = outTrips ∧ + s' = { s with genState := s_gen } ∧ + outputs.length = lhs.length := by + simp only [Core.Transform.genOutExprIdentsTrip] at Hgen + split at Hgen + case isTrue Hne => + simp [throw, throwThe, MonadExceptOf.throw, ExceptT.mk, pure, StateT.pure] at Hgen + cases Hgen + case isFalse Hlen => + simp [bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk, ExceptT.lift, + ExceptT.pure, StateT.bind, StateT.pure, pure, monadLift, + MonadLift.monadLift, liftM, Functor.map, StateT.map, + Core.Transform.liftCoreGenM] at Hgen + refine ⟨?_, ?_, ?_⟩ + · have := congrArg Prod.fst Hgen + simp at this + exact this + · have := congrArg Prod.snd Hgen + simp at this + exact this.symm + · simp at Hlen; exact Hlen + +/-! ### Trip-shape geometry helpers + +The Arg/Out/Old trip lemmas all share a `((g.zip ys).zip xs)` outer +shape and project either the `.unzip.snd` (= `xs`, given length +agreement) or `.unzip.fst.unzip.fst` (= `g`, ditto). These pure list +facts are extracted once so that the trip-level lemmas can short-cut +their unzip/zip ceremony. -/ + +theorem zip_zip_unzip_snd_of_lengths {α β γ} + {g : List α} {ys : List β} {xs : List γ} + (Hgx : g.length = xs.length) (Hyx : ys.length = xs.length) : + ((g.zip ys).zip xs).unzip.snd = xs := by + rw [List.unzip_zip_right] + rw [List.length_zip] + omega + +theorem zip_zip_unzip_fst_unzip_fst_of_lengths {α β γ} + {g : List α} {ys : List β} {xs : List γ} + (Hgx : g.length = xs.length) (Hyx : ys.length = xs.length) : + ((g.zip ys).zip xs).unzip.fst.unzip.fst = g := by + rw [List.unzip_zip_left (l₁ := (g.zip ys)) (l₂ := xs)] + · rw [List.unzip_zip_left (l₁ := g) (l₂ := ys)] + omega + · rw [List.length_zip] + omega + +/-! ### `_snd` projection lemmas for the `gen*ExprIdentsTrip` family + +These say: the `Prod.snd` projection of the trip list is exactly the +input arguments/lhs/old-vars list. The legacy proofs went through +intricate splittings; the live forms are short reductions through the +monad layers because we have the structural form +`(gen_idents.zip inputs.unzip.2).zip args` directly visible. -/ + +theorem genArgExprIdentsTrip_snd + {inputs : @Lambda.LTySignature Visibility} {args : List Expression.Expr} + {s s' : Core.Transform.CoreTransformState} + {argTrips : List ((Expression.Ident × Lambda.LTy) × Expression.Expr)} + (Hgen : Core.Transform.genArgExprIdentsTrip inputs args s = (Except.ok argTrips, s')) : + argTrips.unzip.snd = args := by + obtain ⟨Hat, _, Hilen⟩ := genArgExprIdentsTrip_extract Hgen + rw [← Hat] + exact zip_zip_unzip_snd_of_lengths + (genArgExprIdents_length' args.length s.genState) + (by simp [List.length_map]; omega) + +theorem genOutExprIdentsTrip_snd + {outputs : @Lambda.LTySignature Visibility} {lhs : List Expression.Ident} + {s s' : Core.Transform.CoreTransformState} + {outTrips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)} + (Hgen : Core.Transform.genOutExprIdentsTrip outputs lhs s = (Except.ok outTrips, s')) : + outTrips.unzip.snd = lhs := by + obtain ⟨Hot, _, Hilen⟩ := genOutExprIdentsTrip_extract Hgen + rw [← Hot] + exact zip_zip_unzip_snd_of_lengths + (genOutExprIdents_length' lhs s.genState) + (by simp [List.length_map]; omega) + +/-- The "snd" projection lemma for the `oldTripsRaw` shape used in the + live `callElimCmd`: `oldTripsRaw = (genOldIdents.zip oldTys).zip oldVars`, + so its `snd` projection is `oldVars` provided + `genOldIdents.length = oldVars.length` and `oldTys.length = oldVars.length`. + + Unlike the arg/out cases, the live `callElimCmd` does not call a + dedicated `genOldExprIdentsTrip` wrapper; instead it constructs + `oldTripsRaw` inline. This helper provides the equivalent + structural fact. -/ +theorem genOldExprIdentsTrip_snd + {oldVars : List Expression.Ident} + {oldTys : List Lambda.LTy} + {s s' : CoreGenState} + {genOldIdents : List Expression.Ident} + (Hgen : Core.Transform.genOldExprIdents oldVars s = (genOldIdents, s')) + (Htylen : oldTys.length = oldVars.length) : + ((genOldIdents.zip oldTys).zip oldVars).unzip.snd = oldVars := + zip_zip_unzip_snd_of_lengths (genOldExprIdents_length Hgen) Htylen + +/-! ### `*GeneratedWF` lemmas: each generator pushes its results to `generated` + +`CoreGenState.gen` extends `generated` by one cons; running `mapM` of a +generator over a list extends `generated` by the produced list reversed. +The trip-wrapper variants quote these and additionally lift the +`generated` accounting through `CoreTransformState`. -/ + +theorem genCoreIdentGeneratedWF + {pf : Expression.Ident} {s s' : CoreGenState} {l : Expression.Ident} + (Hgen : CoreGenState.gen pf s = (l, s')) : + s'.generated = l :: s.generated := by + unfold CoreGenState.gen at Hgen + have Hl : l = ⟨(StringGenState.gen pf.name s.cs).fst, ()⟩ := by + have := congrArg Prod.fst Hgen + simp at this + exact this.symm + have Hs : s' = { cs := (StringGenState.gen pf.name s.cs).snd, + generated := ⟨(StringGenState.gen pf.name s.cs).fst, ()⟩ :: s.generated } := by + have := congrArg Prod.snd Hgen + simp at this + exact this.symm + rw [Hl, Hs] + +theorem genIdentGeneratedWF + {ident : Expression.Ident} {pf : String → String} + {s s' : CoreGenState} {l : Expression.Ident} + (Hgen : Core.Transform.genIdent ident pf s = (l, s')) : + s'.generated = l :: s.generated := + genCoreIdentGeneratedWF Hgen + +theorem genArgExprIdents_GeneratedWF + {n : Nat} {s s' : CoreGenState} {ls : List Expression.Ident} + (Hgen : Core.Transform.genArgExprIdents n s = (ls, s')) : + s'.generated = ls.reverse ++ s.generated := + genIdentMapM_GeneratedWF + (g := fun (_ : Unit) => Core.Transform.genArgExprIdent) + (fun H => genCoreIdentGeneratedWF H) Hgen + +theorem genOutExprIdents_GeneratedWF + {idents : List Expression.Ident} {s s' : CoreGenState} + {ls : List Expression.Ident} + (Hgen : Core.Transform.genOutExprIdents idents s = (ls, s')) : + s'.generated = ls.reverse ++ s.generated := + genIdentMapM_GeneratedWF + (g := Core.Transform.genOutExprIdent) + (fun H => genCoreIdentGeneratedWF H) Hgen + +theorem genOldExprIdents_GeneratedWF + {idents : List Expression.Ident} {s s' : CoreGenState} + {ls : List Expression.Ident} + (Hgen : Core.Transform.genOldExprIdents idents s = (ls, s')) : + s'.generated = ls.reverse ++ s.generated := + genIdentMapM_GeneratedWF + (g := Core.Transform.genOldExprIdent) + (fun H => genCoreIdentGeneratedWF H) Hgen + +/-- Trip-level GeneratedWF for arg trips: the generated list is extended + with `argTrips.unzip.fst.unzip.fst.reverse`. -/ +theorem genArgExprIdentsTripGeneratedWF + {inputs : @Lambda.LTySignature Visibility} {args : List Expression.Expr} + {s s' : Core.Transform.CoreTransformState} + {argTrips : List ((Expression.Ident × Lambda.LTy) × Expression.Expr)} + (Hgen : Core.Transform.genArgExprIdentsTrip inputs args s = (Except.ok argTrips, s')) : + s'.genState.generated = + argTrips.unzip.fst.unzip.fst.reverse ++ s.genState.generated := by + obtain ⟨Hat, Hs', Hilen⟩ := genArgExprIdentsTrip_extract Hgen + rw [Hs']; simp only + rw [genArgExprIdents_GeneratedWF (s := s.genState) + (s' := (Core.Transform.genArgExprIdents args.length s.genState).snd) + (ls := (Core.Transform.genArgExprIdents args.length s.genState).fst) rfl] + congr 1 + rw [← Hat] + rw [zip_zip_unzip_fst_unzip_fst_of_lengths + (genArgExprIdents_length' args.length s.genState) + (by simp [List.length_map]; omega)] + +theorem genOutExprIdentsTripGeneratedWF + {outputs : @Lambda.LTySignature Visibility} {lhs : List Expression.Ident} + {s s' : Core.Transform.CoreTransformState} + {outTrips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)} + (Hgen : Core.Transform.genOutExprIdentsTrip outputs lhs s = (Except.ok outTrips, s')) : + s'.genState.generated = + outTrips.unzip.fst.unzip.fst.reverse ++ s.genState.generated := by + obtain ⟨Hot, Hs', Hilen⟩ := genOutExprIdentsTrip_extract Hgen + rw [Hs']; simp only + rw [genOutExprIdents_GeneratedWF (s := s.genState) + (s' := (Core.Transform.genOutExprIdents lhs s.genState).snd) + (ls := (Core.Transform.genOutExprIdents lhs s.genState).fst) rfl] + congr 1 + rw [← Hot] + rw [zip_zip_unzip_fst_unzip_fst_of_lengths + (genOutExprIdents_length' lhs s.genState) + (by simp [List.length_map]; omega)] + +/-! ### `*WFMono` lemmas: each generator preserves `CoreGenState.WF` + +These lift `CoreGenState.WFMono'` through the inductive structure of +`gen*ExprIdents` and the `CoreTransformM` wrapping of `gen*ExprIdentsTrip`. -/ + +theorem genArgExprIdents_WFMono + {n : Nat} {s s' : CoreGenState} {ls : List Expression.Ident} + (Hwf : CoreGenState.WF s) (Hgen : Core.Transform.genArgExprIdents n s = (ls, s')) : + CoreGenState.WF s' := + genIdentMapM_WFMono + (g := fun (_ : Unit) => Core.Transform.genArgExprIdent) + (fun H1 H2 => CoreGenState.WFMono' H1 H2) Hwf Hgen + +theorem genOutExprIdents_WFMono + {idents : List Expression.Ident} {s s' : CoreGenState} + {ls : List Expression.Ident} + (Hwf : CoreGenState.WF s) (Hgen : Core.Transform.genOutExprIdents idents s = (ls, s')) : + CoreGenState.WF s' := + genIdentMapM_WFMono + (g := Core.Transform.genOutExprIdent) + (fun H1 H2 => CoreGenState.WFMono' H1 H2) Hwf Hgen + +theorem genOldExprIdents_WFMono + {idents : List Expression.Ident} {s s' : CoreGenState} + {ls : List Expression.Ident} + (Hwf : CoreGenState.WF s) (Hgen : Core.Transform.genOldExprIdents idents s = (ls, s')) : + CoreGenState.WF s' := + genIdentMapM_WFMono + (g := Core.Transform.genOldExprIdent) + (fun H1 H2 => CoreGenState.WFMono' H1 H2) Hwf Hgen + +/-- Trip-level WFMono for arg trips. -/ +theorem genArgExprIdentsTripWFMono + {inputs : @Lambda.LTySignature Visibility} {args : List Expression.Expr} + {s s' : Core.Transform.CoreTransformState} + {argTrips : List ((Expression.Ident × Lambda.LTy) × Expression.Expr)} + (Hwf : CoreGenState.WF s.genState) + (Hgen : Core.Transform.genArgExprIdentsTrip inputs args s = (Except.ok argTrips, s')) : + CoreGenState.WF s'.genState := by + obtain ⟨_, Hs', _⟩ := genArgExprIdentsTrip_extract Hgen + rw [Hs']; simp only + exact genArgExprIdents_WFMono (s := s.genState) + (s' := (Core.Transform.genArgExprIdents args.length s.genState).snd) + (ls := (Core.Transform.genArgExprIdents args.length s.genState).fst) Hwf rfl + +/-- Trip-level WFMono for out trips. -/ +theorem genOutExprIdentsTripWFMono + {outputs : @Lambda.LTySignature Visibility} {lhs : List Expression.Ident} + {s s' : Core.Transform.CoreTransformState} + {outTrips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)} + (Hwf : CoreGenState.WF s.genState) + (Hgen : Core.Transform.genOutExprIdentsTrip outputs lhs s = (Except.ok outTrips, s')) : + CoreGenState.WF s'.genState := by + obtain ⟨_, Hs', _⟩ := genOutExprIdentsTrip_extract Hgen + rw [Hs']; simp only + exact genOutExprIdents_WFMono (s := s.genState) + (s' := (Core.Transform.genOutExprIdents lhs s.genState).snd) + (ls := (Core.Transform.genOutExprIdents lhs s.genState).fst) Hwf rfl + +/-- Bare WFMono for old vars (live `callElimCmd` builds `oldTripsRaw` inline). -/ +theorem genOldExprIdentsTripWFMono + {oldVars : List Expression.Ident} + {s s' : CoreGenState} {genOldIdents : List Expression.Ident} + (Hwf : CoreGenState.WF s) + (Hgen : Core.Transform.genOldExprIdents oldVars s = (genOldIdents, s')) : + CoreGenState.WF s' := + genOldExprIdents_WFMono Hwf Hgen + +/-- Trip-level GeneratedWF for old trips, parameterized over the bare + `genOldExprIdents` (since the live `callElimCmd` constructs its + `oldTripsRaw` inline rather than through a wrapper). -/ +theorem genOldExprIdentsTripGeneratedWF + {oldVars : List Expression.Ident} {oldTys : List Lambda.LTy} + {s s' : CoreGenState} {genOldIdents : List Expression.Ident} + (Hgen : Core.Transform.genOldExprIdents oldVars s = (genOldIdents, s')) + (Htylen : oldTys.length = oldVars.length) : + s'.generated = + ((genOldIdents.zip oldTys).zip oldVars).unzip.fst.unzip.fst.reverse ++ s.generated := by + rw [genOldExprIdents_GeneratedWF Hgen] + rw [zip_zip_unzip_fst_unzip_fst_of_lengths + (genOldExprIdents_length Hgen) Htylen] + +/-! ### `isTempIdent` / `isOldTempIdent` predicates and producing-side lemmas + +A `CoreIdent` is a call-elim temp if its name has the `tmp_` prefix +used by `Core.Transform.tmpVarPrefix`. The check is implemented via +`List.isPrefixOf` on the `toList` representation rather than +`String.startsWith` so that we can discharge it via the elementary +`isPrefixOf_append_self` lemma without going through the opaque +`String.Slice`/`Pattern` machinery. + +These predicates and their producing-side `genIdent → isTempIdent` +lemmas are housed here alongside the rest of the `gen*` helper family. -/ + +def isTempIdent (v : Expression.Ident) : Bool := + "tmp_".toList.isPrefixOf v.name.toList + +/-- Mirror of `isTempIdent` for `old`-prefixed identifiers (those generated + by `oldVarPrefix` via `genOldExprIdent`). See + `Core.Transform.oldVarPrefix`. -/ +def isOldTempIdent (v : Expression.Ident) : Bool := + "old_".toList.isPrefixOf v.name.toList + +/-- `tmp_*` and `old_*` prefixed identifiers are pairwise disjoint: + no identifier can be both `isTempIdent` and `isOldTempIdent`. -/ +theorem isTempIdent_isOldTempIdent_disjoint + {x : Expression.Ident} + (Htmp : isTempIdent x = true) (Hold : isOldTempIdent x = true) : False := by + unfold isTempIdent at Htmp + unfold isOldTempIdent at Hold + match hL : x.name.toList with + | [] => + rw [hL] at Htmp + simp at Htmp + | c :: cs => + rw [hL] at Htmp Hold + simp [List.isPrefixOf] at Htmp Hold + have h1 : 't' = c := Htmp.1 + have h2 : 'o' = c := Hold.1 + rw [← h1] at h2 + exact absurd h2 (by decide) + +/-! ### Producing-side `genIdent → isTempIdent` lemmas + +The `CoreGenState.gen pf s` operation produces an identifier whose name is +`pf.name ++ "_" ++ toString counter` (cf. `StringGenState.gen`). When +`pf.name` itself begins with the literal `"tmp_"` (resp. `"old_"`) +prefix — as it does for `genIdent _ tmpVarPrefix` (resp. +`genIdent _ oldVarPrefix`) — the resulting identifier satisfies +`isTempIdent` (resp. `isOldTempIdent`). -/ + +/-- A single application of `CoreGenState.gen` against the `tmpVarPrefix` + family of prefixes produces an identifier satisfying `isTempIdent`. -/ +theorem genIdent_tmp_isTempIdent + {ident : String} {s s' : CoreGenState} {l : Expression.Ident} + (Hgen : (CoreGenState.gen ⟨Core.Transform.tmpVarPrefix ident, ()⟩ s) = (l, s')) : + isTempIdent l = true := by + unfold CoreGenState.gen StringGenState.gen Core.Transform.tmpVarPrefix at Hgen + have Hl : l = ⟨"tmp_" ++ ident ++ "_" ++ toString (Counter.genCounter s.cs.cs).fst, ()⟩ := by + have := congrArg Prod.fst Hgen + simp at this + rw [show (s!"tmp_{ident}" : String) = "tmp_" ++ ident from rfl] at this + exact this.symm + rw [Hl] + simp only [isTempIdent] + simp only [String.toList_append, List.append_assoc] + exact isPrefixOf_append_self _ _ + +/-- Mirror of `genIdent_tmp_isTempIdent` for the `oldVarPrefix` family. -/ +theorem genIdent_old_isOldTempIdent + {ident : String} {s s' : CoreGenState} {l : Expression.Ident} + (Hgen : (CoreGenState.gen ⟨Core.Transform.oldVarPrefix ident, ()⟩ s) = (l, s')) : + isOldTempIdent l = true := by + unfold CoreGenState.gen StringGenState.gen Core.Transform.oldVarPrefix at Hgen + have Hl : l = ⟨"old_" ++ ident ++ "_" ++ toString (Counter.genCounter s.cs.cs).fst, ()⟩ := by + have := congrArg Prod.fst Hgen + simp at this + rw [show (s!"old_{ident}" : String) = "old_" ++ ident from rfl] at this + exact this.symm + rw [Hl] + simp only [isOldTempIdent] + simp only [String.toList_append, List.append_assoc] + exact isPrefixOf_append_self _ _ + +/-! ### `gen*ExprIdents{,Trip}_isTempIdent` lemmas + +Each fresh identifier produced by `gen{Arg,Out}ExprIdent` (which calls +`genIdent _ tmpVarPrefix`) satisfies `isTempIdent`; each produced by +`genOldExprIdent` satisfies `isOldTempIdent`. These lift through the +list-mapM iterators (`gen*ExprIdents`) and the trip wrappers +(`gen*ExprIdentsTrip`). -/ + +theorem genArgExprIdents_isTempIdent + {n : Nat} {s s' : CoreGenState} {ls : List Expression.Ident} + (Hgen : Core.Transform.genArgExprIdents n s = (ls, s')) : + Forall (fun x => isTempIdent x) ls := + genIdentMapM_Forall + (g := fun (_ : Unit) => Core.Transform.genArgExprIdent) + (fun H => by + simp only [Core.Transform.genArgExprIdent, Core.Transform.genIdent] at H + exact genIdent_tmp_isTempIdent H) Hgen + +theorem genOutExprIdents_isTempIdent + {idents : List Expression.Ident} {s s' : CoreGenState} + {ls : List Expression.Ident} + (Hgen : Core.Transform.genOutExprIdents idents s = (ls, s')) : + Forall (fun x => isTempIdent x) ls := + genIdentMapM_Forall + (g := Core.Transform.genOutExprIdent) + (fun H => by + simp only [Core.Transform.genOutExprIdent, Core.Transform.genIdent] at H + exact genIdent_tmp_isTempIdent H) Hgen + +theorem genOldExprIdents_isOldTempIdent + {idents : List Expression.Ident} {s s' : CoreGenState} + {ls : List Expression.Ident} + (Hgen : Core.Transform.genOldExprIdents idents s = (ls, s')) : + Forall (fun x => isOldTempIdent x) ls := + genIdentMapM_Forall + (g := Core.Transform.genOldExprIdent) + (fun H => by + simp only [Core.Transform.genOldExprIdent, Core.Transform.genIdent] at H + exact genIdent_old_isOldTempIdent H) Hgen + +/-- Trip-level isTempIdent for arg trips: every fresh ident produced by + `genArgExprIdentsTrip` satisfies `isTempIdent`. -/ +theorem genArgExprIdentsTrip_isTempIdent + {inputs : @Lambda.LTySignature Visibility} {args : List Expression.Expr} + {s s' : Core.Transform.CoreTransformState} + {argTrips : List ((Expression.Ident × Lambda.LTy) × Expression.Expr)} + (Hgen : Core.Transform.genArgExprIdentsTrip inputs args s = (Except.ok argTrips, s')) : + Forall (fun x => isTempIdent x) argTrips.unzip.fst.unzip.fst := by + obtain ⟨Hat, _, Hilen⟩ := genArgExprIdentsTrip_extract Hgen + rw [← Hat] + rw [zip_zip_unzip_fst_unzip_fst_of_lengths + (genArgExprIdents_length' args.length s.genState) + (by simp [List.length_map]; omega)] + exact genArgExprIdents_isTempIdent (s := s.genState) + (s' := (Core.Transform.genArgExprIdents args.length s.genState).snd) + (ls := (Core.Transform.genArgExprIdents args.length s.genState).fst) rfl + +theorem genOutExprIdentsTrip_isTempIdent + {outputs : @Lambda.LTySignature Visibility} {lhs : List Expression.Ident} + {s s' : Core.Transform.CoreTransformState} + {outTrips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)} + (Hgen : Core.Transform.genOutExprIdentsTrip outputs lhs s = (Except.ok outTrips, s')) : + Forall (fun x => isTempIdent x) outTrips.unzip.fst.unzip.fst := by + obtain ⟨Hot, _, Hilen⟩ := genOutExprIdentsTrip_extract Hgen + rw [← Hot] + rw [zip_zip_unzip_fst_unzip_fst_of_lengths + (genOutExprIdents_length' lhs s.genState) + (by simp [List.length_map]; omega)] + exact genOutExprIdents_isTempIdent (s := s.genState) + (s' := (Core.Transform.genOutExprIdents lhs s.genState).snd) + (ls := (Core.Transform.genOutExprIdents lhs s.genState).fst) rfl + +/-- For the live `callElimCmd`, `oldTrips`'s `fst.fst` projection is exactly + the fresh `genOldIdents` produced by `genOldExprIdents`, since the trip + structure is `((freshIdent, ty), origVar)`. -/ +theorem genOldExprIdentsTrip_isOldTempIdent + {oldVars : List Expression.Ident} + {oldTys : List Lambda.LTy} + {s s' : CoreGenState} + {genOldIdents : List Expression.Ident} + (Hgen : Core.Transform.genOldExprIdents oldVars s = (genOldIdents, s')) + (Htylen : oldTys.length = oldVars.length) : + Forall (fun x => isOldTempIdent x) + ((genOldIdents.zip oldTys).zip oldVars).unzip.fst.unzip.fst := by + rw [zip_zip_unzip_fst_unzip_fst_of_lengths + (genOldExprIdents_length Hgen) Htylen] + exact genOldExprIdents_isOldTempIdent Hgen + +end Core + +end -- public section diff --git a/Strata/Transform/SubstSemantics.lean b/Strata/Transform/SubstSemantics.lean new file mode 100644 index 0000000000..ed57d184f1 --- /dev/null +++ b/Strata/Transform/SubstSemantics.lean @@ -0,0 +1,1721 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +import Init.Data.List.Basic +import Init.Data.List.Lemmas +public import Strata.DL.Lambda.Lambda +public import Strata.DL.Imperative.CmdSemantics +public import Strata.Languages.Core.StatementSemantics +public import Strata.Transform.CoreTransform +public import Strata.Transform.CoreTransformSemantics +import Strata.Languages.Core.StatementSemanticsProps +import Strata.DL.Util.ListUtils + +/-! # Substitution-Correctness Stack + + Reusable substitution-correctness lemmas for `LExpr.substFvar` / + `substFvars` against `substStores` / `invStores`. Used by `CallElimCorrect`; + applicable to any transform that introduces fresh variables and + substitutes them (procedure-inlining, loop-elimination, etc.). +-/ + +namespace Core.Transform +open Imperative + +public section + +/-! ### Substitution-correctness lemmas (small-step) + + These re-derive the legacy `Lambda.LExpr.substFvarCorrect` and + `Lambda.LExpr.substFvarsCorrect` proofs using only currently-live + infrastructure. They are pure expression-level lemmas and are the + workhorses behind `H_asserts` / `H_assumes`. -/ + +/-- Substitution of a single free variable preserves expression evaluation + when the source/target stores agree on the substitution and on + everything-else used in `e`. -/ +theorem subst_fvar_correct + {δ : CoreEval} + {σ σ' : CoreStore} + {fro to : Expression.Ident} + {e : Expression.Expr} + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hsubst : Imperative.substStores σ σ' [(fro, to)]) + (Hinv : Imperative.invStores σ σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) e).removeAll [fro])) : + δ σ e = δ σ' (e.substFvar fro (Core.Transform.createFvar to)) := by + induction e <;> simp [Lambda.LExpr.substFvar, Core.Transform.createFvar] at * + case const c | op o ty | bvar x => + rw [Hwfvl.2] + rw [Hwfvl.2] + constructor + constructor + case fvar name ty => + simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr + split <;> try simp_all + . simp [Imperative.substStores] at Hsubst + rw [Hwfvr] + rw [Hwfvr] + exact Hsubst + simp [Imperative.HasFvar.getFvar] + simp [Imperative.HasFvar.getFvar] + . next Hne => + simp [Imperative.invStores, Imperative.substStores, + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, List.removeAll, Hne] at Hinv + rw [Hwfvr] + rw [Hwfvr] + exact Hinv + simp [Imperative.HasFvar.getFvar] + simp [Imperative.HasFvar.getFvar] + case abs m ty e ih => + specialize ih Hinv + have Hwfca := Hwfc.1 σ σ' e ((e.substFvar fro (Lambda.LExpr.fvar () to none))) + grind + case quant m k ty tr e trih eih => + simp [Imperative.invStores, Imperative.substStores, + Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * + simp [List.app_removeAll, List.zip_append] at * + specialize eih ?_ + · intros k1 k2 Hin + rw [Hinv] + right; + assumption + specialize trih ?_ + · intros k1 k2 Hin + rw [Hinv] + left; + assumption + apply Hwfc.quantcongr <;> grind + case app m c fn fih eih => + simp [Imperative.invStores, Imperative.substStores, + Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * + simp [List.app_removeAll, List.zip_append] at * + specialize fih ?_ + . intros k1 k2 Hin + rw [Hinv] + left; assumption + specialize eih ?_ + . intros k1 k2 Hin + rw [Hinv] + right; assumption + apply Hwfc.appcongr <;> grind + case ite m c t e cih tih eih => + simp [Imperative.invStores, Imperative.substStores, + Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * + simp [List.app_removeAll, List.zip_append] at * + specialize cih ?_ + . intros k1 k2 Hin + rw [Hinv] + left; assumption + specialize tih ?_ + . intros k1 k2 Hin + rw [Hinv] + right; left; assumption + specialize eih ?_ + . intros k1 k2 Hin + rw [Hinv] + right; right; assumption + apply Hwfc.itecongr <;> grind + case eq m e1 e2 e1ih e2ih => + simp [Imperative.invStores, Imperative.substStores, + Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * + simp [List.app_removeAll, List.zip_append] at * + specialize e1ih ?_ + . intros k1 k2 Hin + rw [Hinv] + left; assumption + specialize e2ih ?_ + . intros k1 k2 Hin + rw [Hinv] + right; assumption + apply Hwfc.eqcongr <;> grind + +/-- Zero-substitution case: when the source/target stores agree on every + free variable of `e`, evaluation is unchanged. Re-derived from the + legacy `Lambda.LExpr.substFvarsCorrectZero`. -/ +theorem subst_fvarsZero_correct + {δ : CoreEval} + {σ σ' : CoreStore} + {e : Expression.Expr} + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hinv : Imperative.invStores σ σ' + (Imperative.HasVarsPure.getVars (P:=Expression) e)) : + δ σ e = δ σ' e := by + induction e <;> simp at * + case const c | op o ty | bvar x => + rw [Hwfvl.2] + rw [Hwfvl.2] + constructor + constructor + case fvar m name ty => + simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr + specialize Hwfvr (Lambda.LExpr.fvar m name ty) name + rw [Hwfvr] + rw [Hwfvr] + rw [Hinv] + simp [Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] + simp [Imperative.HasFvar.getFvar] + simp [Imperative.HasFvar.getFvar] + case abs m ty e ih => + specialize ih Hinv + have Hwfca := Hwfc.abscongr σ σ' e e ih + apply Hwfca + case quant m k ty tr e trih eih => + simp [Imperative.invStores, Imperative.substStores, + Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * + simp [List.zip_append] at * + specialize trih ?_ + . intros k1 k2 Hin + rw [Hinv] + left; assumption + specialize eih ?_ + . intros k1 k2 Hin + rw [Hinv] + right; assumption + apply Hwfc.quantcongr <;> grind + case app m fn e fih eih => + simp [Imperative.invStores, Imperative.substStores, + Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * + simp [List.zip_append] at * + specialize fih ?_ + . intros k1 k2 Hin + rw [Hinv] + left; assumption + specialize eih ?_ + . intros k1 k2 Hin + rw [Hinv] + right; assumption + apply Hwfc.appcongr <;> grind + case ite m c t e cih tih eih => + simp [Imperative.invStores, Imperative.substStores, + Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * + simp [List.zip_append] at * + specialize cih ?_ + . intros k1 k2 Hin + rw [Hinv] + left; assumption + specialize tih ?_ + . intros k1 k2 Hin + rw [Hinv] + right; left; assumption + specialize eih ?_ + . intros k1 k2 Hin + rw [Hinv] + right; right; assumption + apply Hwfc.itecongr <;> grind + case eq m e1 e2 e1ih e2ih => + simp [Imperative.invStores, Imperative.substStores, + Imperative.HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] at * + simp [List.zip_append] at * + specialize e1ih ?_ + . intros k1 k2 Hin + rw [Hinv] + left; assumption + specialize e2ih ?_ + . intros k1 k2 Hin + rw [Hinv] + right; assumption + apply Hwfc.eqcongr <;> grind + +/-! ### Substitution-list helpers + + Re-derived from the legacy code (currently in the comment block) so the + new small-step proofs of `H_asserts`/`H_assumes` can stand on their own. + These are pure list-level / store-level lemmas about + `substDefined`, `substNodup`, `substStores`, and `invStores`. -/ + +theorem updatedStateIsDefinedMono' + {σ : CoreStore} {k : Expression.Ident} {v : Expression.Expr} + {x : Expression.Ident} : + (σ x).isSome = true → ((updatedState σ k v) x).isSome = true := by + intros Hsome + simp [updatedState] + split <;> simp_all + +theorem subst_defined_tail + {σ σ' : CoreStore} {h : Expression.Ident × Expression.Ident} + {t : List (Expression.Ident × Expression.Ident)} : + Imperative.substDefined σ σ' (h :: t) → + Imperative.substDefined σ σ' t := by + intros Hsubst k1 k2 Hin + apply Hsubst + exact List.mem_cons_of_mem h Hin + +theorem subst_nodup_tail + {h : Expression.Ident × Expression.Ident} + {t : List (Expression.Ident × Expression.Ident)} : + Imperative.substNodup (h :: t) → + Imperative.substNodup t := by + intros Hsubst + simp [Imperative.substNodup] at * + exact (List.nodup_cons.mp (nodup_middle Hsubst.right)).right + +theorem subst_defined_updatedState + {σ σ' : CoreStore} {k : Expression.Ident} {v : Expression.Expr} + {ls : List (Expression.Ident × Expression.Ident)} : + Imperative.substDefined σ σ' ls → + Imperative.substDefined (updatedState σ k v) σ' ls := by + intros Hsubst k1 k2 Hin + refine ⟨?_, (Hsubst k1 k2 Hin).2⟩ + exact updatedStateIsDefinedMono' (Hsubst k1 k2 Hin).1 + +theorem zip_notin_fst_pair + {h : Expression.Ident} + {t : List Expression.Ident} {t' : List Expression.Ident} : + t.length = t'.length → + (∀ x, ¬(h, x) ∈ List.zip t t') → + ¬ h ∈ t := by + intros Hlen H + induction t generalizing t' h <;> simp_all + case cons h t ih => + cases t' with + | nil => simp at Hlen + | cons h' t' => + simp_all + have HH := H h' + simp_all + exact ih rfl H + +theorem zip_notin_snd_pair + {h : Expression.Ident} + {t : List Expression.Ident} {t' : List Expression.Ident} : + t.length = t'.length → + (∀ x, ¬(x, h) ∈ List.zip t t') → + ¬ h ∈ t' := by + intros Hlen H + induction t' generalizing t h <;> simp_all + case cons h t ih => + cases t with + | nil => simp at Hlen + | cons h' t' => + simp_all + have HH := H h' + simp_all + exact ih Hlen H + +theorem subst_nodup_ht + {h h' : Expression.Ident} + {t t' : List Expression.Ident} : + t.length = t'.length → + Imperative.substNodup ((h, h') :: List.zip t t') → + ¬ h ∈ t ∧ ¬ h' ∈ t' := by + intros Hlen Hsubst + simp [Imperative.substNodup] at Hsubst + refine ⟨?_, ?_⟩ + · exact zip_notin_fst_pair Hlen Hsubst.1.1 + · have Hnd := nodup_middle Hsubst.2 + simp at Hnd + have Hnd' := Hnd.1.2 + exact zip_notin_snd_pair Hlen Hnd' + +theorem getVars_substFvar_or + {e : Expression.Expr} {h h' v : Expression.Ident} : + v ∈ (Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.substFvar e h (Core.Transform.createFvar h'))) → + v ∈ (Imperative.HasVarsPure.getVars (P:=Expression) e) ∨ v = h' := by + intros Hin + induction e <;> + simp [Lambda.LExpr.substFvar, + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + Core.Transform.createFvar + ] at * <;> try simp_all + case fvar name ty => + split at Hin <;> simp [Lambda.LExpr.LExpr.getVars] at * <;> simp_all + case app m fn e fn_ih e_ih => + cases Hin <;> simp_all + · cases fn_ih <;> simp_all + · cases e_ih <;> simp_all + case quant m qk name ty tr e tr_ih e_ih => + cases Hin <;> simp_all + · cases tr_ih <;> simp_all + · cases e_ih <;> simp_all + case ite m c t e c_ih t_ih e_ih => + cases Hin with + | inl Hin => cases (c_ih Hin) <;> simp_all + | inr Hin => + cases Hin with + | inl Hin => cases (t_ih Hin) <;> simp_all + | inr Hin => cases (e_ih Hin) <;> simp_all + case eq m e1 e2 e1_ih e2_ih => + cases Hin <;> simp_all + · cases e1_ih <;> simp_all + · cases e2_ih <;> simp_all + +theorem getVars_substFvar_replace + {e : Expression.Expr} {h h' : Expression.Ident} : + (Imperative.HasVarsPure.getVars + (Lambda.LExpr.substFvar e h (Core.Transform.createFvar h'))) = + (Imperative.HasVarsPure.getVars (P:=Expression) e).replaceAll h h' := by + induction e <;> + simp [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + Lambda.LExpr.substFvar, + Core.Transform.createFvar, + List.replaceAll] at * <;> try assumption + case fvar name ty => + by_cases h_eq : name = h + · subst h_eq + simp [Lambda.LExpr.LExpr.getVars] + · simp [h_eq, Lambda.LExpr.LExpr.getVars] + have hbeq : (h == name) = false := by + simp; intro heq; exact h_eq heq.symm + rw [hbeq] + case app fn e fn_ih e_ih => + rw [fn_ih, e_ih, List.replaceAll_app] + case quant qk ty tr_ih e_ih => + rw [tr_ih, e_ih, List.replaceAll_app] + case ite c t e c_ih t_ih e_ih => + rw [c_ih, t_ih, e_ih, List.replaceAll_app, List.replaceAll_app] + case eq e1 e2 e1_ih e2_ih => + rw [e1_ih, e2_ih, List.replaceAll_app] + +theorem updatedStores_invStores + {σ : CoreStore} {k : Expression.Ident} {v : Expression.Expr} + {ks : List Expression.Ident} : + ¬ k ∈ ks → + Imperative.invStores σ (updatedState σ k v) ks := by + intros Hnin k1 k2 Hin + have Heq : k1 = k2 := zip_self_eq Hin + simp_all + have Hin := (List.of_mem_zip Hin).1 + have Hne : k2 ≠ k := ne_of_mem_of_not_mem Hin Hnin + simp [updatedState] + simp_all + +theorem invStores_subst_head + {σ : CoreStore} {h h' : Expression.Ident} {v₁ : Expression.Expr} + {vs : List Expression.Ident} : + Imperative.substStores (P := Expression) σ (updatedState σ h' v₁) [(h, h')] → + ¬ h' ∈ vs → + Imperative.invStores σ (updatedState σ h' v₁) (List.removeAll vs [h]) := by + intros _ Hnin + apply updatedStores_invStores + simp [List.removeAll] + simp_all + +theorem invStores_subst_tail + {σ σ' : CoreStore} {h h' : Expression.Ident} {v₁ : Expression.Expr} + {t t' vs : List Expression.Ident} : + Imperative.substStores (P := Expression) σ σ' ((h, h') :: t.zip t') → + Imperative.substStores (P := Expression) (updatedState σ h' v₁) σ' (t.zip t') → + σ h = some v₁ → + h ≠ h' → + Imperative.invStores σ σ' (List.removeAll vs ((h :: t) ++ (h' :: t'))) → + Imperative.invStores (updatedState σ h' v₁) σ' + (List.removeAll (vs.replaceAll h h') (t ++ t')) := by + intros Hsubst1 _ Hsome Hne Hinv k1 k2 Hin + have Heq := zip_self_eq Hin + simp_all + simp [Imperative.invStores, Imperative.substStores] at * + simp [updatedState] + split + · rw [← Hsubst1 h] <;> simp_all + · next neq => + apply Hinv + apply zip_self_eq' + have Hin := (List.of_mem_zip Hin).1 + have Hsub := removeAll_sublist (vs.replaceAll h h') (t ++ t') + have Hin' : k2 ∈ (vs.replaceAll h h') := List.Sublist.mem Hin Hsub + have Hor := in_replaceAll_removeAll Hin + cases Hor <;> simp_all + apply removeAll_cons + · intros Heq + simp_all + have Hnmem : ¬ h ∈ vs.replaceAll h h' := replaceAll_not_mem Hne + exact Hnmem Hin' + · simp [List.removeAll] at * + simp_all + +/-- Helper: `Map.find? rest h' = none` when `h'` is not a key in `rest`. -/ +theorem map_find_none_of_not_key + {h' : Expression.Ident} + {rest : List (Expression.Ident × Expression.Expr)} : + (∀ a b, (a, b) ∈ rest → a ≠ h') → + Map.find? rest h' = none := by + intro Hnk + induction rest with + | nil => rfl + | cons p rs ih => + obtain ⟨a, b⟩ := p + have hane : a ≠ h' := Hnk a b List.mem_cons_self + have ih' : Map.find? rs h' = none := by + apply ih + intros a' b' hin + exact Hnk a' b' (List.mem_cons_of_mem _ hin) + show (if a = h' then some b else Map.find? rs h') = none + rw [if_neg hane, ih'] + +/-- Helper: `Map.find? ((h, v) :: rest) name = Map.find? rest name` when `name ≠ h`. -/ +theorem map_find_cons_ne + {h name : Expression.Ident} {v : Expression.Expr} + {rest : List (Expression.Ident × Expression.Expr)} : + name ≠ h → + Map.find? ((h, v) :: rest) name = Map.find? rest name := by + intro Hne + show (if h = name then some v else Map.find? rest name) = Map.find? rest name + rw [if_neg (fun heq => Hne heq.symm)] + +/-- For a cons-substitution `(h, fv) :: rest`, when `h` and `h'` (the source of + `fv = createFvar h'`) are not keys, `substFvars` decomposes as a leading + single-var substitution. -/ +theorem substFvars_cons_eq + {e : Expression.Expr} {h h' : Expression.Ident} + {rest : List (Expression.Ident × Expression.Expr)} + (Hh_notin_keys : ∀ a b, (a, b) ∈ rest → a ≠ h) + (Hh'_notin_keys : ∀ a b, (a, b) ∈ rest → a ≠ h') : + Lambda.LExpr.substFvars e ((h, Core.Transform.createFvar h') :: rest) = + Lambda.LExpr.substFvars + (Lambda.LExpr.substFvar e h (Core.Transform.createFvar h')) rest := by + induction e with + | const m c => + simp only [Lambda.LExpr.substFvar, Lambda.LExpr.substFvars_const'] + | op m n t => + simp only [Lambda.LExpr.substFvar, Lambda.LExpr.substFvars_op'] + | bvar m i => + simp only [Lambda.LExpr.substFvar, Lambda.LExpr.substFvars_bvar] + | fvar m name ty => + by_cases heq : name = h + · subst heq + -- LHS: substFvars (fvar name) ((name, fv) :: rest) = fv + have hfind_lhs : Map.find? + ((name, Core.Transform.createFvar h') :: rest) name = + some (Core.Transform.createFvar h') := by + show (if name = name then some (Core.Transform.createFvar h') + else Map.find? rest name) = _ + rw [if_pos rfl] + have hLHS := Lambda.LExpr.substFvars_fvar_find m name ty + ((name, Core.Transform.createFvar h') :: rest) + (Core.Transform.createFvar h') hfind_lhs + -- RHS: substFvar (fvar name) name fv = fv = createFvar h' + have hsubst : Lambda.LExpr.substFvar + (Lambda.LExpr.fvar m name ty) + name (Core.Transform.createFvar h') = + Core.Transform.createFvar h' := by + show (if (name == name) = true then _ else _) = _ + simp + rw [hsubst] + -- Now goal: substFvars (fvar name ...) (...) = substFvars (createFvar h') rest + -- LHS rewrites via hLHS to createFvar h' + rw [hLHS] + -- RHS: substFvars (createFvar h' = fvar h') rest + have hfind_rhs : Map.find? rest h' = none := + map_find_none_of_not_key Hh'_notin_keys + -- Use substFvars_fvar_none, with implicits inferred from rest's type + have hRHS : Lambda.LExpr.substFvars + (Core.Transform.createFvar h' : + Expression.Expr) rest = + Core.Transform.createFvar h' := by + unfold Core.Transform.createFvar + exact Lambda.LExpr.substFvars_fvar_none _ _ _ _ hfind_rhs + show Core.Transform.createFvar h' = + Lambda.LExpr.substFvars (Core.Transform.createFvar h' : Expression.Expr) rest + rw [hRHS] + · -- name ≠ h + have hsubst : Lambda.LExpr.substFvar + (Lambda.LExpr.fvar m name ty) + h (Core.Transform.createFvar h') = + Lambda.LExpr.fvar m name ty := by + show (if (name == h) = true then _ else _) = _ + rw [if_neg] + intro hbeq + exact heq (beq_iff_eq.mp hbeq) + rw [hsubst] + have hcons := map_find_cons_ne (h := h) (v := Core.Transform.createFvar h') + (name := name) (rest := rest) heq + cases hf : Map.find? rest name with + | none => + have hf' : Map.find? ((h, Core.Transform.createFvar h') :: rest) name = none := by + rw [hcons]; exact hf + rw [Lambda.LExpr.substFvars_fvar_none m name ty _ hf'] + rw [Lambda.LExpr.substFvars_fvar_none m name ty rest hf] + | some v => + have hf' : Map.find? ((h, Core.Transform.createFvar h') :: rest) name = some v := by + rw [hcons]; exact hf + rw [Lambda.LExpr.substFvars_fvar_find m name ty _ v hf'] + rw [Lambda.LExpr.substFvars_fvar_find m name ty rest v hf] + | abs m pn ty body ih => + simp only [Lambda.LExpr.substFvar, Lambda.LExpr.substFvars_abs, ih] + | quant m qk pn ty tr body trih bih => + simp only [Lambda.LExpr.substFvar, Lambda.LExpr.substFvars_quant, trih, bih] + | app m fn arg fih aih => + simp only [Lambda.LExpr.substFvar, Lambda.LExpr.substFvars_app, fih, aih] + | ite m c t f cih tih fih => + simp only [Lambda.LExpr.substFvar, Lambda.LExpr.substFvars_ite, cih, tih, fih] + | eq m e1 e2 ih1 ih2 => + simp only [Lambda.LExpr.substFvar, Lambda.LExpr.substFvars_eq, ih1, ih2] + +/-- Helper: if `h' ∉ ts`, then `h'` is not a key in `(t.zip (createFvars ts)).fst`. -/ +theorem zip_createFvars_keys_notin + {h : Expression.Ident} + {t : List Expression.Ident} {ts : List Expression.Ident} : + ¬ h ∈ t → + ∀ a b, (a, b) ∈ t.zip (Core.Transform.createFvars ts) → a ≠ h := by + intros Hnin a b Hin Heq + subst Heq + exact Hnin (List.of_mem_zip Hin).1 + +/-- Multi-variable substitution preserves expression evaluation. Re-derived + from the legacy `Lambda.LExpr.substFvarsCorrect`. -/ +theorem subst_fvars_correct + {δ : CoreEval} + {σ σ' : CoreStore} + {fro to : List Expression.Ident} + {e : Expression.Expr} + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hlen : fro.length = to.length) + (Hdef : Imperative.substDefined σ σ' (fro.zip to)) + (Hnd : Imperative.substNodup (fro.zip to)) + (Hsubst : Imperative.substStores σ σ' (fro.zip to)) + (Hnin : to.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) e)) + (Hinv : Imperative.invStores σ σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) e).removeAll (fro ++ to))) : + δ σ e = δ σ' (e.substFvars (fro.zip (Core.Transform.createFvars to))) := by + induction fro generalizing to σ σ' e + case nil => + have Hemp : to = [] := List.eq_nil_of_length_eq_zero (Eq.symm Hlen) + subst Hemp + simp only [Core.Transform.createFvars, List.map_nil, List.zip_nil_right] + -- substFvars on empty map is identity + have hsubstEmp : + Lambda.LExpr.substFvars e ([] : Map Expression.Ident Expression.Expr) = e := by + simp [Lambda.LExpr.substFvars, Map.isEmpty] + rw [hsubstEmp] + -- Hinv came in with `removeAll ([] ++ [])`, simplify + have HinvSimp : + Imperative.invStores σ σ' + (Imperative.HasVarsPure.getVars (P:=Expression) e) := by + have := Hinv + simp at this + exact this + exact subst_fvarsZero_correct Hwfc Hwfvr Hwfvl HinvSimp + case cons h t ih => + cases to with + | nil => simp at Hlen + | cons h' t' => + have Hlen_t : t.length = t'.length := by + simp at Hlen; exact Hlen + have Hnd_t : Imperative.substNodup (t.zip t') := subst_nodup_tail Hnd + have Hht := subst_nodup_ht Hlen_t Hnd + have Hne : h ≠ h' := by + intro heq + subst heq + simp [Imperative.substNodup] at Hnd + have Hsubst1 := substStoresCons' Hnd Hdef Hsubst + obtain ⟨σ₁, v₁, Hsome, Hstore, Hsubst', Hsubst1⟩ := Hsubst1 + subst Hstore + -- Step 1: rewrite δ σ e using subst_fvar_correct. + have Hinv_head : Imperative.invStores σ (updatedState σ h' v₁) + ((Imperative.HasVarsPure.getVars (P:=Expression) e).removeAll [h]) := by + apply invStores_subst_head Hsubst' + intro Hin + exact Hnin (List.mem_cons_self) Hin + have Hhead : δ σ e = + δ (updatedState σ h' v₁) + (Lambda.LExpr.substFvar e h (Core.Transform.createFvar h')) := + subst_fvar_correct Hwfc Hwfvr Hwfvl Hsubst' Hinv_head + rw [Hhead] + -- Step 2: rewrite using IH. We apply IH at e' = substFvar e h (createFvar h'). + have Hdef_σ₁ : Imperative.substDefined (updatedState σ h' v₁) σ' (t.zip t') := + subst_defined_updatedState (subst_defined_tail Hdef) + have Hnin_t : t'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.substFvar e h (Core.Transform.createFvar h'))) := by + intros a' Hin Hin2 + have Hor := getVars_substFvar_or Hin2 + cases Hor with + | inl Hin3 => + exact Hnin (List.mem_cons_of_mem h' Hin) Hin3 + | inr Heq => + subst Heq + exact Hht.2 Hin + have Hinv_t : Imperative.invStores (updatedState σ h' v₁) σ' + ((Imperative.HasVarsPure.getVars + (Lambda.LExpr.substFvar e h (Core.Transform.createFvar h'))).removeAll + (t ++ t')) := by + rw [getVars_substFvar_replace] + have HinvE : Imperative.invStores σ σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) e).removeAll + ((h :: t) ++ (h' :: t'))) := by + have heq : (h :: t) ++ (h' :: t') = h :: t ++ h' :: t' := by simp + rw [heq]; exact Hinv + exact invStores_subst_tail Hsubst Hsubst1 Hsome Hne HinvE + have Hres := ih Hlen_t Hdef_σ₁ Hnd_t Hsubst1 Hnin_t Hinv_t + rw [Hres] + -- Step 3: align substFvars-cons with substFvars after substFvar. + have Hh_notin : ∀ a b, (a, b) ∈ t.zip (Core.Transform.createFvars t') → a ≠ h := + zip_createFvars_keys_notin Hht.1 + -- substNodup: nodup of fst++snd = h::t ++ h'::t'. h' ∉ t (and h' ∉ t'). + have Hh'_notin_t : ¬ h' ∈ t := by + intro hh + have HzipUnzip : (t.zip t').unzip = (t, t') := by + rw [List.unzip_zip]; exact Hlen_t + have HndStart : List.Nodup + (((h, h') :: t.zip t').unzip.fst ++ + ((h, h') :: t.zip t').unzip.snd) := Hnd + -- Manually unfold: ((h,h')::t.zip t').unzip = (h :: t, h' :: t') + have Hcons_fst : + ((h, h') :: t.zip t').unzip.fst = h :: t := by + simp [HzipUnzip] + have Hcons_snd : + ((h, h') :: t.zip t').unzip.snd = h' :: t' := by + simp [HzipUnzip] + rw [Hcons_fst, Hcons_snd] at HndStart + -- HndStart : Nodup (h :: t ++ h' :: t') + have HtailNd : List.Nodup (t ++ h' :: t') := by + have : List.Nodup ((h :: t) ++ h' :: t') := HndStart + rw [List.cons_append] at this + exact (List.nodup_cons.mp this).2 + have HmidNd := nodup_middle HtailNd + have Hnotin : h' ∉ t ++ t' := (List.nodup_cons.mp HmidNd).1 + exact Hnotin (List.mem_append_left _ hh) + have Hh'_notin : ∀ a b, (a, b) ∈ t.zip (Core.Transform.createFvars t') → a ≠ h' := by + intros a b Hin Heq + subst Heq + exact Hh'_notin_t ((List.of_mem_zip Hin).1) + have Hcons := substFvars_cons_eq (e := e) (h := h) (h' := h') + (rest := t.zip (Core.Transform.createFvars t')) + Hh_notin Hh'_notin + rw [← Hcons] + simp [Core.Transform.createFvars] + +/-! ### Structural decomposition for `getVars (substFvars e sm)`. + + For the L6 (assumes) site of `callElimStatementCorrect`, we need to + reason about the free variables of the post-`oldSubst` postcondition + expressions. The decomposition lemma below shows that any variable + in `getVars (substFvars e sm)` either survives from `e` (when it is + not a key of `sm`) or comes from the codomain expression of some + key-substitution that `e` references. This is the multi-step + analogue of the existing `getVars_substFvar_or` lemma. -/ + +/-- Multi-step substitution decomposition: every free variable of + `substFvars e sm` either (a) was free in `e` and not a key of `sm`, + or (b) was contributed by the codomain expression `w` of some + `(k, w) ∈ sm` where `k` was a free variable of `e`. -/ +theorem getVars_substFvars_mem + {e : Expression.Expr} {v : Expression.Ident} + {sm : Map Expression.Ident Expression.Expr} + (Hin : v ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.substFvars e sm)) : + (v ∈ Imperative.HasVarsPure.getVars (P:=Expression) e ∧ + Map.find? sm v = none) ∨ + (∃ k w, + k ∈ Imperative.HasVarsPure.getVars (P:=Expression) e ∧ + Map.find? sm k = some w ∧ + v ∈ Imperative.HasVarsPure.getVars (P:=Expression) w) := by + induction e with + | const m c => + simp only [Lambda.LExpr.substFvars_const', + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.not_mem_nil] at Hin + | op m n t => + simp only [Lambda.LExpr.substFvars_op', + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.not_mem_nil] at Hin + | bvar m i => + simp only [Lambda.LExpr.substFvars_bvar, + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.not_mem_nil] at Hin + | fvar m name ty => + -- substFvars (fvar name) sm = match sm.find? name with | some w => w | none => fvar name + by_cases hfind : Map.find? sm name = none + · rw [Lambda.LExpr.substFvars_fvar_none m name ty sm hfind] at Hin + -- Hin : v ∈ getVars (fvar name) = [name] + simp only [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.mem_singleton] at Hin + subst Hin + refine Or.inl ⟨?_, hfind⟩ + simp [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars] + · -- find? returns some w + rcases Option.ne_none_iff_exists.mp hfind with ⟨w, hf⟩ + rw [Lambda.LExpr.substFvars_fvar_find m name ty sm w hf.symm] at Hin + -- Hin : v ∈ getVars w + refine Or.inr ⟨name, w, ?_, hf.symm, Hin⟩ + simp [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars] + | abs m name ty body ih => + simp only [Lambda.LExpr.substFvars_abs, + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars] at Hin + have Hbody := ih Hin + simp only [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars] + exact Hbody + | quant m qk name ty tr body trih bih => + simp only [Lambda.LExpr.substFvars_quant, + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.mem_append] at Hin + simp only [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.mem_append] + cases Hin with + | inl Hin => + cases trih Hin with + | inl h => exact Or.inl ⟨Or.inl h.1, h.2⟩ + | inr h => + obtain ⟨k, w, Hk, Hf, Hv⟩ := h + exact Or.inr ⟨k, w, Or.inl Hk, Hf, Hv⟩ + | inr Hin => + cases bih Hin with + | inl h => exact Or.inl ⟨Or.inr h.1, h.2⟩ + | inr h => + obtain ⟨k, w, Hk, Hf, Hv⟩ := h + exact Or.inr ⟨k, w, Or.inr Hk, Hf, Hv⟩ + | app m fn arg fih aih => + simp only [Lambda.LExpr.substFvars_app, + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.mem_append] at Hin + simp only [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.mem_append] + cases Hin with + | inl Hin => + cases fih Hin with + | inl h => exact Or.inl ⟨Or.inl h.1, h.2⟩ + | inr h => + obtain ⟨k, w, Hk, Hf, Hv⟩ := h + exact Or.inr ⟨k, w, Or.inl Hk, Hf, Hv⟩ + | inr Hin => + cases aih Hin with + | inl h => exact Or.inl ⟨Or.inr h.1, h.2⟩ + | inr h => + obtain ⟨k, w, Hk, Hf, Hv⟩ := h + exact Or.inr ⟨k, w, Or.inr Hk, Hf, Hv⟩ + | ite m c t f cih tih fih => + simp only [Lambda.LExpr.substFvars_ite, + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.mem_append] at Hin + simp only [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.mem_append] + cases Hin with + | inl Hin => + cases Hin with + | inl Hin => + cases cih Hin with + | inl h => exact Or.inl ⟨Or.inl (Or.inl h.1), h.2⟩ + | inr h => + obtain ⟨k, w, Hk, Hf, Hv⟩ := h + exact Or.inr ⟨k, w, Or.inl (Or.inl Hk), Hf, Hv⟩ + | inr Hin => + cases tih Hin with + | inl h => exact Or.inl ⟨Or.inl (Or.inr h.1), h.2⟩ + | inr h => + obtain ⟨k, w, Hk, Hf, Hv⟩ := h + exact Or.inr ⟨k, w, Or.inl (Or.inr Hk), Hf, Hv⟩ + | inr Hin => + cases fih Hin with + | inl h => exact Or.inl ⟨Or.inr h.1, h.2⟩ + | inr h => + obtain ⟨k, w, Hk, Hf, Hv⟩ := h + exact Or.inr ⟨k, w, Or.inr Hk, Hf, Hv⟩ + | eq m e1 e2 e1ih e2ih => + simp only [Lambda.LExpr.substFvars_eq, + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.mem_append] at Hin + simp only [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars, + List.mem_append] + cases Hin with + | inl Hin => + cases e1ih Hin with + | inl h => exact Or.inl ⟨Or.inl h.1, h.2⟩ + | inr h => + obtain ⟨k, w, Hk, Hf, Hv⟩ := h + exact Or.inr ⟨k, w, Or.inl Hk, Hf, Hv⟩ + | inr Hin => + cases e2ih Hin with + | inl h => exact Or.inl ⟨Or.inr h.1, h.2⟩ + | inr h => + obtain ⟨k, w, Hk, Hf, Hv⟩ := h + exact Or.inr ⟨k, w, Or.inr Hk, Hf, Hv⟩ + +/-- Pointwise δ-eval bridge for an arbitrary substitution `sm`. Given two + pointwise hypotheses — (a) δ σ' agrees with δ σ on every "surviving" + free variable of `e` (those with `find? sm = none`), and (b) for every + `(k, w) ∈ sm` with `k ∈ getVars e`, δ σ' w equals δ σ (fvar k) — we + obtain `δ σ' (substFvars e sm) = δ σ e`. + + This generalizes `subst_fvars_correct` (which only handles + `createFvars to`-style codomain) to arbitrary expression codomains. + Used at the call site to bridge `δ σ_R1 (substFvars c.expr oldSubst_L6)` + to `δ σO c.expr` for the L6 post-substitution eval. -/ +theorem subst_fvars_eval_bridge + {δ : CoreEval} + {σ σ' : CoreStore} + {e : Expression.Expr} + {sm : Map Expression.Ident Expression.Expr} + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hsurv : ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) e, + Map.find? sm v = none → + δ σ' (Lambda.LExpr.fvar () v none) = + δ σ (Lambda.LExpr.fvar () v none)) + (Hsub : ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) e → + Map.find? sm k = some w → + δ σ' w = δ σ (Lambda.LExpr.fvar () k none)) : + δ σ' (Lambda.LExpr.substFvars e sm) = δ σ e := by + induction e with + | const m c => + simp only [Lambda.LExpr.substFvars_const'] + rw [Hwfvl.2, Hwfvl.2] + constructor; constructor + | op m n t => + simp only [Lambda.LExpr.substFvars_op'] + rw [Hwfvl.2, Hwfvl.2] + constructor; constructor + | bvar m i => + simp only [Lambda.LExpr.substFvars_bvar] + rw [Hwfvl.2, Hwfvl.2] + constructor; constructor + | fvar m name ty => + by_cases hfind : Map.find? sm name = none + · rw [Lambda.LExpr.substFvars_fvar_none m name ty sm hfind] + simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr + have HwfL : δ σ' (Lambda.LExpr.fvar m name ty) = σ' name := by + rw [Hwfvr (Lambda.LExpr.fvar m name ty) name] + simp [Imperative.HasFvar.getFvar] + have HwfR : δ σ (Lambda.LExpr.fvar m name ty) = σ name := by + rw [Hwfvr (Lambda.LExpr.fvar m name ty) name] + simp [Imperative.HasFvar.getFvar] + have HwfL' : δ σ' (Lambda.LExpr.fvar () name none) = σ' name := by + rw [Hwfvr (Lambda.LExpr.fvar () name none) name] + simp [Imperative.HasFvar.getFvar] + have HwfR' : δ σ (Lambda.LExpr.fvar () name none) = σ name := by + rw [Hwfvr (Lambda.LExpr.fvar () name none) name] + simp [Imperative.HasFvar.getFvar] + have HsurvAt := + Hsurv name + (by simp [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars]) + hfind + rw [HwfL', HwfR'] at HsurvAt + rw [HwfL, HwfR] + exact HsurvAt + · rcases Option.ne_none_iff_exists.mp hfind with ⟨w, hf⟩ + rw [Lambda.LExpr.substFvars_fvar_find m name ty sm w hf.symm] + have Hself : + name ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.fvar m name ty) := by + simp [Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars] + have HsubAt := Hsub name w Hself hf.symm + simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr + have HwfR : δ σ (Lambda.LExpr.fvar m name ty) = σ name := by + rw [Hwfvr (Lambda.LExpr.fvar m name ty) name] + simp [Imperative.HasFvar.getFvar] + have HwfR' : δ σ (Lambda.LExpr.fvar () name none) = σ name := by + rw [Hwfvr (Lambda.LExpr.fvar () name none) name] + simp [Imperative.HasFvar.getFvar] + rw [HwfR] + rw [HwfR'] at HsubAt + exact HsubAt + | abs m name ty body ih => + simp only [Lambda.LExpr.substFvars_abs] + have Hsurv_body : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) body, + Map.find? sm v = none → + δ σ' (Lambda.LExpr.fvar () v none) = + δ σ (Lambda.LExpr.fvar () v none) := by + intro v Hv Hnone + apply Hsurv v ?_ Hnone + show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.abs m name ty body) + simp [Lambda.LExpr.LExpr.getVars] + show v ∈ Lambda.LExpr.LExpr.getVars body + exact Hv + have Hsub_body : + ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) body → + Map.find? sm k = some w → + δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by + intro k w Hk Hf + apply Hsub k w ?_ Hf + show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.abs m name ty body) + simp [Lambda.LExpr.LExpr.getVars] + show k ∈ Lambda.LExpr.LExpr.getVars body + exact Hk + have Hbody := ih Hsurv_body Hsub_body + exact Hwfc.abscongr σ' σ _ _ Hbody m name ty + | quant m qk name ty tr body trih bih => + simp only [Lambda.LExpr.substFvars_quant] + have Hsurv_tr : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) tr, + Map.find? sm v = none → + δ σ' (Lambda.LExpr.fvar () v none) = + δ σ (Lambda.LExpr.fvar () v none) := by + intro v Hv Hnone + apply Hsurv v ?_ Hnone + show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.quant m qk name ty tr body) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inl Hv + have Hsurv_body : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) body, + Map.find? sm v = none → + δ σ' (Lambda.LExpr.fvar () v none) = + δ σ (Lambda.LExpr.fvar () v none) := by + intro v Hv Hnone + apply Hsurv v ?_ Hnone + show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.quant m qk name ty tr body) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inr Hv + have Hsub_tr : + ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) tr → + Map.find? sm k = some w → + δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by + intro k w Hk Hf + apply Hsub k w ?_ Hf + show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.quant m qk name ty tr body) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inl Hk + have Hsub_body : + ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) body → + Map.find? sm k = some w → + δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by + intro k w Hk Hf + apply Hsub k w ?_ Hf + show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.quant m qk name ty tr body) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inr Hk + have Htr := trih Hsurv_tr Hsub_tr + have Hbody := bih Hsurv_body Hsub_body + exact Hwfc.quantcongr σ' σ m qk name ty _ _ _ _ Htr Hbody + | app m fn arg fih aih => + simp only [Lambda.LExpr.substFvars_app] + have Hsurv_fn : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) fn, + Map.find? sm v = none → + δ σ' (Lambda.LExpr.fvar () v none) = + δ σ (Lambda.LExpr.fvar () v none) := by + intro v Hv Hnone + apply Hsurv v ?_ Hnone + show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.app m fn arg) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inl Hv + have Hsurv_arg : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) arg, + Map.find? sm v = none → + δ σ' (Lambda.LExpr.fvar () v none) = + δ σ (Lambda.LExpr.fvar () v none) := by + intro v Hv Hnone + apply Hsurv v ?_ Hnone + show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.app m fn arg) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inr Hv + have Hsub_fn : + ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) fn → + Map.find? sm k = some w → + δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by + intro k w Hk Hf + apply Hsub k w ?_ Hf + show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.app m fn arg) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inl Hk + have Hsub_arg : + ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) arg → + Map.find? sm k = some w → + δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by + intro k w Hk Hf + apply Hsub k w ?_ Hf + show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.app m fn arg) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inr Hk + have Hfn := fih Hsurv_fn Hsub_fn + have Harg := aih Hsurv_arg Hsub_arg + exact Hwfc.appcongr σ' σ m _ _ _ _ Hfn Harg + | ite m c t f cih tih fih => + simp only [Lambda.LExpr.substFvars_ite] + have HmkLeft : ∀ {x : Expression.Ident}, + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) c → + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.ite m c t f) := by + intro x Hx + show x ∈ Lambda.LExpr.LExpr.getVars c ++ Lambda.LExpr.LExpr.getVars t + ++ Lambda.LExpr.LExpr.getVars f + exact List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inl Hx))) + have HmkMid : ∀ {x : Expression.Ident}, + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) t → + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.ite m c t f) := by + intro x Hx + show x ∈ Lambda.LExpr.LExpr.getVars c ++ Lambda.LExpr.LExpr.getVars t + ++ Lambda.LExpr.LExpr.getVars f + exact List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inr Hx))) + have HmkRight : ∀ {x : Expression.Ident}, + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) f → + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.ite m c t f) := by + intro x Hx + show x ∈ Lambda.LExpr.LExpr.getVars c ++ Lambda.LExpr.LExpr.getVars t + ++ Lambda.LExpr.LExpr.getVars f + exact List.mem_append.mpr (Or.inr Hx) + have Hc := cih (fun v Hv Hnone => Hsurv v (HmkLeft Hv) Hnone) + (fun k w Hk Hf => Hsub k w (HmkLeft Hk) Hf) + have Ht := tih (fun v Hv Hnone => Hsurv v (HmkMid Hv) Hnone) + (fun k w Hk Hf => Hsub k w (HmkMid Hk) Hf) + have Hf' := fih (fun v Hv Hnone => Hsurv v (HmkRight Hv) Hnone) + (fun k w Hk Hf => Hsub k w (HmkRight Hk) Hf) + exact Hwfc.itecongr σ' σ m _ _ _ _ _ _ Ht Hf' Hc + | eq m e1 e2 e1ih e2ih => + simp only [Lambda.LExpr.substFvars_eq] + have Hsurv_l : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) e1, + Map.find? sm v = none → + δ σ' (Lambda.LExpr.fvar () v none) = + δ σ (Lambda.LExpr.fvar () v none) := by + intro v Hv Hnone + apply Hsurv v ?_ Hnone + show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.eq m e1 e2) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inl Hv + have Hsurv_r : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) e2, + Map.find? sm v = none → + δ σ' (Lambda.LExpr.fvar () v none) = + δ σ (Lambda.LExpr.fvar () v none) := by + intro v Hv Hnone + apply Hsurv v ?_ Hnone + show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.eq m e1 e2) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inr Hv + have Hsub_l : + ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) e1 → + Map.find? sm k = some w → + δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by + intro k w Hk Hf + apply Hsub k w ?_ Hf + show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.eq m e1 e2) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inl Hk + have Hsub_r : + ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) e2 → + Map.find? sm k = some w → + δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by + intro k w Hk Hf + apply Hsub k w ?_ Hf + show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.eq m e1 e2) + simp [Lambda.LExpr.LExpr.getVars, List.mem_append] + exact Or.inr Hk + have Hl := e1ih Hsurv_l Hsub_l + have Hr := e2ih Hsurv_r Hsub_r + exact Hwfc.eqcongr σ' σ m _ _ _ _ Hl Hr + +/-! ### Small-step block helpers for assert/assume sequences -/ + +/-- Generic block-evaluator helper for assert/assume statement lists with + substituted predicates. Parameterized by `mkStmt` (the `Statement.assert` + or `Statement.assume` constructor) and `mkSingletonEval` (a function that + builds a singleton `EvalStatementsContract` from the eval-true witness). + Used to derive both `H_asserts` and `H_assumes`. -/ +theorem H_check_block + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σA σ' : CoreStore} + {ks ks' : List Expression.Ident} + {entries : List (CoreLabel × Procedure.Check)} + {md : Imperative.MetaData Expression} + {labelPrefix : String} + (mkStmt : String → Expression.Expr → Imperative.MetaData Expression → Statement) + (mkSingletonEval : + ∀ (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression), + δ σ' e = some Imperative.HasBool.tt → + EvalStatementsContract π φ ⟨σ', δ, false⟩ [mkStmt lbl e m] ⟨σ', δ, false⟩) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hlen : ks.length = ks'.length) + (Hnd : Imperative.substNodup (ks.zip ks')) + (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) + (Hsubst : Imperative.substStores σA σ' (ks.zip ks')) + (Hentries : ∀ entry, entry ∈ entries → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ', δ, false⟩ + (entries.mapIdx (fun i (lbl, check) => + mkStmt s!"{labelPrefix}{i}_{lbl}" + (Lambda.LExpr.substFvars check.expr + (ks.zip (Core.Transform.createFvars ks'))) + (check.md.setCallSiteFileRange md))) + ⟨σ', δ, false⟩ := by + -- Generalize over the starting index of mapIdx so we can induct on the list. + suffices Hgen : + ∀ (i : Nat) (l : List (CoreLabel × Procedure.Check)), + (∀ entry, entry ∈ l → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt) → + EvalStatementsContract π φ ⟨σ', δ, false⟩ + (l.mapIdx (fun j (lbl, check) => + mkStmt s!"{labelPrefix}{i + j}_{lbl}" + (Lambda.LExpr.substFvars check.expr + (ks.zip (Core.Transform.createFvars ks'))) + (check.md.setCallSiteFileRange md))) + ⟨σ', δ, false⟩ by + have := Hgen 0 entries Hentries + simpa using this + intros i l Hl + induction l generalizing i with + | nil => + simp [List.mapIdx] + exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) + | cons head tail ih => + obtain ⟨lbl, check⟩ := head + have HtailHyp : + ∀ entry, entry ∈ tail → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt := by + intros entry hin; exact Hl entry (List.mem_cons_of_mem _ hin) + have Htail := ih (i + 1) HtailHyp + have HlHead := Hl (lbl, check) List.mem_cons_self + obtain ⟨HinvHead, HnininHead, HevHead⟩ := HlHead + have Heq : δ σA check.expr = + δ σ' (Lambda.LExpr.substFvars check.expr + (ks.zip (Core.Transform.createFvars ks'))) := + subst_fvars_correct Hwfc Hwfvr Hwfvl Hlen Hdef Hnd Hsubst HnininHead HinvHead + have HevSubst : δ σ' (Lambda.LExpr.substFvars check.expr + (ks.zip (Core.Transform.createFvars ks'))) = + some Imperative.HasBool.tt := by + rw [← Heq]; exact HevHead + have HheadStmts := mkSingletonEval s!"{labelPrefix}{i}_{lbl}" + (Lambda.LExpr.substFvars check.expr (ks.zip (Core.Transform.createFvars ks'))) + (check.md.setCallSiteFileRange md) HevSubst + have Hcombined : + EvalStatementsContract π φ ⟨σ', δ, false⟩ + ([mkStmt s!"{labelPrefix}{i}_{lbl}" + (Lambda.LExpr.substFvars check.expr + (ks.zip (Core.Transform.createFvars ks'))) + (check.md.setCallSiteFileRange md)] ++ + tail.mapIdx (fun j p => + mkStmt s!"{labelPrefix}{i + 1 + j}_{p.fst}" + (Lambda.LExpr.substFvars p.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (p.snd.md.setCallSiteFileRange md))) + ⟨σ', δ, false⟩ := EvalStatementsContractApp HheadStmts Htail + have Hgoal_eq : + ((lbl, check) :: tail).mapIdx (fun j p => + mkStmt s!"{labelPrefix}{i + j}_{p.fst}" + (Lambda.LExpr.substFvars p.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (p.snd.md.setCallSiteFileRange md)) = + [mkStmt s!"{labelPrefix}{i}_{lbl}" + (Lambda.LExpr.substFvars check.expr + (ks.zip (Core.Transform.createFvars ks'))) + (check.md.setCallSiteFileRange md)] ++ + tail.mapIdx (fun j p => + mkStmt s!"{labelPrefix}{i + 1 + j}_{p.fst}" + (Lambda.LExpr.substFvars p.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (p.snd.md.setCallSiteFileRange md)) := by + rw [List.mapIdx_cons] + simp only [List.singleton_append, List.cons.injEq, Nat.add_zero, true_and] + apply List.mapIdx_eq_iff.mpr + intros k + simp [List.getElem?_mapIdx] + cases hh : tail[k]? with + | none => rfl + | some p => + have : i + 1 + k = i + (k + 1) := by omega + rw [this] + show EvalStatementsContract π φ ⟨σ', δ, false⟩ + (((lbl, check) :: tail).mapIdx (fun j p => + mkStmt s!"{labelPrefix}{i + j}_{p.fst}" + (Lambda.LExpr.substFvars p.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (p.snd.md.setCallSiteFileRange md))) ⟨σ', δ, false⟩ + rw [Hgoal_eq] + exact Hcombined + +/-- Generic block-evaluator helper for the labels-aware (`zip`) variant of + assert/assume statement lists. Used to derive both `H_asserts_zip` and + `H_assumes_zip`. -/ +theorem H_check_block_zip + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σA σ' : CoreStore} + {ks ks' : List Expression.Ident} + {entries : List (CoreLabel × Procedure.Check)} + {labels : List String} + {md : Imperative.MetaData Expression} + (mkStmt : String → Expression.Expr → Imperative.MetaData Expression → Statement) + (mkSingletonEval : + ∀ (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression), + δ σ' e = some Imperative.HasBool.tt → + EvalStatementsContract π φ ⟨σ', δ, false⟩ [mkStmt lbl e m] ⟨σ', δ, false⟩) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hlen : ks.length = ks'.length) + (Hnd : Imperative.substNodup (ks.zip ks')) + (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) + (Hsubst : Imperative.substStores σA σ' (ks.zip ks')) + (Hentries : ∀ entry, entry ∈ entries → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ', δ, false⟩ + ((entries.zip labels).map (fun (entry, lbl) => + mkStmt lbl + (Lambda.LExpr.substFvars entry.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (entry.snd.md.setCallSiteFileRange md))) + ⟨σ', δ, false⟩ := by + induction entries generalizing labels with + | nil => + simp [List.zip_nil_left, List.map_nil] + exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) + | cons head tail ih => + cases labels with + | nil => + simp [List.zip_nil_right, List.map_nil] + exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) + | cons lbl labels' => + obtain ⟨_, check⟩ := head + have HtailHyp : + ∀ entry, entry ∈ tail → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt := by + intros entry hin; exact Hentries entry (List.mem_cons_of_mem _ hin) + have Htail := ih (labels := labels') HtailHyp + have HlHead := Hentries _ List.mem_cons_self + obtain ⟨HinvHead, HnininHead, HevHead⟩ := HlHead + have Heq : δ σA check.expr = + δ σ' (Lambda.LExpr.substFvars check.expr + (ks.zip (Core.Transform.createFvars ks'))) := + subst_fvars_correct Hwfc Hwfvr Hwfvl Hlen Hdef Hnd Hsubst HnininHead HinvHead + have HevSubst : δ σ' (Lambda.LExpr.substFvars check.expr + (ks.zip (Core.Transform.createFvars ks'))) = + some Imperative.HasBool.tt := by + rw [← Heq]; exact HevHead + have HheadStmts := mkSingletonEval lbl + (Lambda.LExpr.substFvars check.expr (ks.zip (Core.Transform.createFvars ks'))) + (check.md.setCallSiteFileRange md) HevSubst + simp only [List.zip_cons_cons, List.map_cons] + exact EvalStatementsContractApp HheadStmts Htail + +/-! ### Pure list-shape analogues of `createAsserts` / `createAssumes`. + + The monadic `Core.Transform.createAsserts` / `createAssumes` use a fresh + label generator. For the small-step proof we need a pure-list version that + we can induct over directly. -/ + +/-- Pure-list analogue of `Core.Transform.createAsserts` (without the + monadic label generator). Produces `Statement.assert` statements, + one per entry, with substituted predicates. -/ +def createAsserts_list + (entries : List (CoreLabel × Procedure.Check)) + (subst : Map Expression.Ident Expression.Expr) + (md : Imperative.MetaData Expression) + (labelPrefix : String) : + List Statement := + entries.mapIdx (fun i (l, check) => + Statement.assert s!"{labelPrefix}{i}_{l}" + (Lambda.LExpr.substFvars check.expr subst) + (check.md.setCallSiteFileRange md)) + +/-- Pure-list analogue of `Core.Transform.createAssumes`. -/ +def createAssumes_list + (entries : List (CoreLabel × Procedure.Check)) + (subst : Map Expression.Ident Expression.Expr) + (md : Imperative.MetaData Expression) + (labelPrefix : String) : + List Statement := + entries.mapIdx (fun i (l, check) => + Statement.assume s!"{labelPrefix}{i}_{l}" + (Lambda.LExpr.substFvars check.expr subst) + (check.md.setCallSiteFileRange md)) + +/-- A list of `Statement.assert` with substituted predicates evaluates from + σ' to σ' (store unchanged) under contract semantics, given that each + substituted predicate evaluates to `tt` in σ' and the substitution + well-formedness assumptions hold. -/ +theorem H_asserts + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σA σ' : CoreStore} + {ks ks' : List Expression.Ident} + {pres : List (CoreLabel × Procedure.Check)} + {md : Imperative.MetaData Expression} + {labelPrefix : String} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hlen : ks.length = ks'.length) + (Hnd : Imperative.substNodup (ks.zip ks')) + (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) + (Hsubst : Imperative.substStores σ' σA (ks'.zip ks)) + (Hpres : ∀ entry, entry ∈ pres → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ', δ, false⟩ + (createAsserts_list pres (ks.zip (Core.Transform.createFvars ks')) md labelPrefix) + ⟨σ', δ, false⟩ := by + have Hsubst' : Imperative.substStores σA σ' (ks.zip ks') := by + apply Imperative.substStoresFlip' + simp [Imperative.substSwap, zip_swap] + exact Hsubst + have := H_check_block (π := π) (φ := φ) (md := md) (labelPrefix := labelPrefix) + (entries := pres) Statement.assert + (mkSingletonEval := singletonAssertEval Hwfb) + Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst' Hpres + simpa [createAsserts_list] using this + +/-- Symmetric to `H_asserts`: a list of `Statement.assume` with substituted + predicates evaluates from σ' to σ'. -/ +theorem H_assumes + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σA σ' : CoreStore} + {ks ks' : List Expression.Ident} + {posts : List (CoreLabel × Procedure.Check)} + {md : Imperative.MetaData Expression} + {labelPrefix : String} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hlen : ks.length = ks'.length) + (Hnd : Imperative.substNodup (ks.zip ks')) + (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) + (Hsubst : Imperative.substStores σA σ' (ks.zip ks')) + (Hposts : ∀ entry, entry ∈ posts → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ', δ, false⟩ + (createAssumes_list posts (ks.zip (Core.Transform.createFvars ks')) md labelPrefix) + ⟨σ', δ, false⟩ := by + have := H_check_block (π := π) (φ := φ) (md := md) (labelPrefix := labelPrefix) + (entries := posts) Statement.assume + (mkSingletonEval := singletonAssumeEval Hwfb) + Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hposts + simpa [createAssumes_list] using this + +/-- Labels-aware variant of `H_asserts`: takes a separate `labels` + list (paired positionally with `pres` via `zip`) rather than a + `labelOf` projection. This matches the shape exposed by the + `HassertsShape` clause of `callElimCmd_call_eq` (B3 layer), which + forms the asserts list as `(pres.zip labels).map (fun (entry, lbl) => …)`. -/ +theorem H_asserts_zip + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σA σ' : CoreStore} + {ks ks' : List Expression.Ident} + {pres : List (CoreLabel × Procedure.Check)} + {labels : List String} + {md : Imperative.MetaData Expression} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hlen : ks.length = ks'.length) + (Hnd : Imperative.substNodup (ks.zip ks')) + (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) + (Hsubst : Imperative.substStores σ' σA (ks'.zip ks)) + (Hpres : ∀ entry, entry ∈ pres → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ', δ, false⟩ + ((pres.zip labels).map (fun (entry, lbl) => + Statement.assert lbl + (Lambda.LExpr.substFvars entry.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (entry.snd.md.setCallSiteFileRange md))) + ⟨σ', δ, false⟩ := by + have Hsubst' : Imperative.substStores σA σ' (ks.zip ks') := by + apply Imperative.substStoresFlip' + simp [Imperative.substSwap, zip_swap] + exact Hsubst + exact H_check_block_zip (entries := pres) (labels := labels) Statement.assert + (mkSingletonEval := singletonAssertEval Hwfb) + Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst' Hpres + +/-- Labels-aware variant of `H_assumes`: takes a separate `labels` + list (paired positionally with `posts` via `zip`) rather than a + `labelOf` projection. This matches the shape exposed by the + `HassumesShape` clause of `callElimCmd_call_eq` (B3 layer), which + forms the assumes list as `(posts.zip labels).map (fun (entry, lbl) => …)`. -/ +theorem H_assumes_zip + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σA σ' : CoreStore} + {ks ks' : List Expression.Ident} + {posts : List (CoreLabel × Procedure.Check)} + {labels : List String} + {md : Imperative.MetaData Expression} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hlen : ks.length = ks'.length) + (Hnd : Imperative.substNodup (ks.zip ks')) + (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) + (Hsubst : Imperative.substStores σA σ' (ks.zip ks')) + (Hposts : ∀ entry, entry ∈ posts → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ', δ, false⟩ + ((posts.zip labels).map (fun (entry, lbl) => + Statement.assume lbl + (Lambda.LExpr.substFvars entry.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (entry.snd.md.setCallSiteFileRange md))) + ⟨σ', δ, false⟩ := + H_check_block_zip (entries := posts) (labels := labels) Statement.assume + (mkSingletonEval := singletonAssumeEval Hwfb) + Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hposts + +/-- Helper: lifting `ReadValues σ ks vs` across an `updatedStates` extension + by names disjoint from `ks`. Live-code analogue of the legacy + `ReadValuesUpdatedStates`. -/ +theorem readValues_updatedStates + {σ : CoreStore} {ks ks' : List Expression.Ident} + {vs : List Expression.Expr} {vs' : List Expression.Expr} + (Hlen : ks'.length = vs'.length) + (Hdisj : ks.Disjoint ks') + (Hrd : ReadValues σ ks vs) : + ReadValues (updatedStates σ ks' vs') ks vs := by + induction ks' generalizing σ vs' with + | nil => + cases vs' <;> simp_all [updatedStates, updatedStates'] + | cons k' ks'' ih => + cases vs' with + | nil => simp at Hlen + | cons v' vs'' => + simp only [updatedStates, List.zip_cons_cons, updatedStates'] + have Hdisj' : ks.Disjoint ks'' := by + intro x Hin1 Hin2 + exact Hdisj Hin1 (List.mem_cons_of_mem _ Hin2) + -- Prove ReadValues (updatedState σ k' v') ks vs using readValues_updatedState. + have Hk'_notin : ¬ k' ∈ ks := by + intro Hin + exact Hdisj Hin List.mem_cons_self + have Hrd_step : ReadValues (updatedState σ k' v') ks vs := + readValues_updatedState (k:=k') (v:=v') Hk'_notin Hrd + have Hlen' : ks''.length = vs''.length := by + simp at Hlen + exact Hlen + -- Apply ih on the remaining list. + exact ih (σ:=updatedState σ k' v') Hlen' Hdisj' Hrd_step + +/-- Lift `ReadValues σ ks vs` across three nested `updatedStates` extensions + given `ks` is disjoint from each layer. Used to bridge a base read in + `σ` to the σ_old / σ_havoc 3-layer initialization in CallElim. -/ +theorem readValues_3layer_lift + {σ : CoreStore} {ks : List Expression.Ident} {vs : List Expression.Expr} + {ts1 ts2 ts3 : List Expression.Ident} + {vs1 vs2 vs3 : List Expression.Expr} + (Hlen1 : ts1.length = vs1.length) (Hdisj1 : ks.Disjoint ts1) + (Hlen2 : ts2.length = vs2.length) (Hdisj2 : ks.Disjoint ts2) + (Hlen3 : ts3.length = vs3.length) (Hdisj3 : ks.Disjoint ts3) + (Hrd : ReadValues σ ks vs) : + ReadValues + (updatedStates + (updatedStates (updatedStates σ ts1 vs1) ts2 vs2) ts3 vs3) ks vs := + readValues_updatedStates Hlen3 Hdisj3 + (readValues_updatedStates Hlen2 Hdisj2 + (readValues_updatedStates Hlen1 Hdisj1 Hrd)) + +/-- Lift `Imperative.isDefined σ lhs` across three nested `updatedStates` + extensions given `lhs` is disjoint from each layer. -/ +theorem isDefined_3layer_lift + {σ : CoreStore} {lhs : List Expression.Ident} + {ts1 ts2 ts3 : List Expression.Ident} + {vs1 vs2 vs3 : List Expression.Expr} + (Hdisj1 : lhs.Disjoint ts1) (Hdisj2 : lhs.Disjoint ts2) + (Hdisj3 : lhs.Disjoint ts3) + (Hdef : Imperative.isDefined σ lhs) : + Imperative.isDefined + (updatedStates + (updatedStates (updatedStates σ ts1 vs1) ts2 vs2) ts3 vs3) lhs := + fun v Hv => by + rw [updatedStates_get_notin (fun Hin => Hdisj3 Hv Hin), + updatedStates_get_notin (fun Hin => Hdisj2 Hv Hin), + updatedStates_get_notin (fun Hin => Hdisj1 Hv Hin)] + exact Hdef v Hv + +/-! ### Temp-extension lift helpers + +`updateState_updatedStates_lift` / `havocVars_updatedStates_lift` lift a +single `UpdateState` / `HavocVars` derivation across an `updatedStates` temp +extension, given suitable disjointness. -/ + +/-- A single `UpdateState` lifts across an `updatedStates` temp extension as + long as the updated variable `x` is disjoint from the temp variables. -/ +theorem updateState_updatedStates_lift + {σ σ' : CoreStore} {x : Expression.Ident} {v : Expression.Expr} + {tempVars : List Expression.Ident} {tempVals : List Expression.Expr} + (Hnotin : ¬ x ∈ tempVars) + (Hup : Imperative.UpdateState (P:=Expression) σ x v σ') : + Imperative.UpdateState (P:=Expression) + (updatedStates σ tempVars tempVals) x v + (updatedStates σ' tempVars tempVals) := by + cases Hup with + | update Hsome Hsome' Hother => + rename_i v' + -- Lookup x in extended σ. + have HlookupL : + (updatedStates σ tempVars tempVals) x = some v' := by + simp [updatedStates] + have : ∀ (ts : List Expression.Ident) (vs : List Expression.Expr) (s : CoreStore), + ¬ x ∈ ts → s x = some v' → + (updatedStates' s (ts.zip vs)) x = some v' := by + intro ts + induction ts with + | nil => intros vs s _ Hs; simp [updatedStates']; exact Hs + | cons t ts ih => + intro vs s Hxn Hs + cases vs with + | nil => simp [updatedStates', List.zip]; exact Hs + | cons w ws => + simp [updatedStates', List.zip, List.zipWith] + have Hxt : x ≠ t := fun h => Hxn (h ▸ List.mem_cons_self) + have Hxts : ¬ x ∈ ts := fun h => Hxn (List.mem_cons_of_mem _ h) + have HsTail : (updatedState s t w) x = some v' := by + simp [updatedState, Hxt]; exact Hs + exact ih ws (updatedState s t w) Hxts HsTail + exact this tempVars tempVals σ Hnotin Hsome + have HlookupR : + (updatedStates σ' tempVars tempVals) x = some v := by + simp [updatedStates] + have : ∀ (ts : List Expression.Ident) (vs : List Expression.Expr) (s : CoreStore), + ¬ x ∈ ts → s x = some v → + (updatedStates' s (ts.zip vs)) x = some v := by + intro ts + induction ts with + | nil => intros vs s _ Hs; simp [updatedStates']; exact Hs + | cons t ts ih => + intro vs s Hxn Hs + cases vs with + | nil => simp [updatedStates', List.zip]; exact Hs + | cons w ws => + simp [updatedStates', List.zip, List.zipWith] + have Hxt : x ≠ t := fun h => Hxn (h ▸ List.mem_cons_self) + have Hxts : ¬ x ∈ ts := fun h => Hxn (List.mem_cons_of_mem _ h) + have HsTail : (updatedState s t w) x = some v := by + simp [updatedState, Hxt]; exact Hs + exact ih ws (updatedState s t w) Hxts HsTail + exact this tempVars tempVals σ' Hnotin Hsome' + have Hframe : ∀ y, x ≠ y → + (updatedStates σ' tempVars tempVals) y = + (updatedStates σ tempVars tempVals) y := by + intro y Hne + simp [updatedStates] + -- Induct over tempVars, tempVals together. + have : ∀ (ts : List Expression.Ident) (vs : List Expression.Expr) + (s s2 : CoreStore), + (∀ z, x ≠ z → s2 z = s z) → + (updatedStates' s2 (ts.zip vs)) y = + (updatedStates' s (ts.zip vs)) y := by + intro ts + induction ts with + | nil => intros vs s s2 Hs2; simp [updatedStates']; exact Hs2 y Hne + | cons t ts ih => + intro vs s s2 Hs2 + cases vs with + | nil => simp [updatedStates', List.zip]; exact Hs2 y Hne + | cons w ws => + simp [updatedStates', List.zip, List.zipWith] + apply ih ws (updatedState s t w) (updatedState s2 t w) + intro z Hxz + simp [updatedState] + split + · rfl + · exact Hs2 z Hxz + exact this tempVars tempVals σ σ' Hother + exact Imperative.UpdateState.update HlookupL HlookupR Hframe + +/-- Lift a `HavocVars` derivation across a temp-extension, given the havoc'd + variables are disjoint from the temp variables. -/ +theorem havocVars_updatedStates_lift + {σ σ' : CoreStore} {ks tempVars : List Expression.Ident} + {tempVals : List Expression.Expr} + (Hdisj : ks.Disjoint tempVars) + (Hhav : HavocVars σ ks σ') : + HavocVars (updatedStates σ tempVars tempVals) ks + (updatedStates σ' tempVars tempVals) := by + induction Hhav with + | update_none => exact HavocVars.update_none + | @update_some σ_a x v σ_b ks_t σ_c hUp hTail ih => + have Hxnotin : ¬ x ∈ tempVars := + fun hin => Hdisj (List.mem_cons_self) hin + have Hdisj_t : ks_t.Disjoint tempVars := by + intro y Hy_in_t Hy_in_temp + exact Hdisj (List.mem_cons_of_mem _ Hy_in_t) Hy_in_temp + have hUp' : Imperative.UpdateState (P:=Expression) + (updatedStates σ_a tempVars tempVals) x v + (updatedStates σ_b tempVars tempVals) := + updateState_updatedStates_lift Hxnotin hUp + have hTail' : HavocVars (updatedStates σ_b tempVars tempVals) ks_t + (updatedStates σ_c tempVars tempVals) := + ih Hdisj_t + exact HavocVars.update_some hUp' hTail' + +/-- Glue lemma: chain L1–L6 via `EvalStatementsContractApp` to produce the + full call-elim block evaluation from σ to σ_havoc. -/ +theorem EvalCallElim_glue + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ σ_arg σ_out σ_old σ_havoc : CoreStore} + {argInit outInit oldInit asserts havocs assumes : List Statement} + (HL1 : EvalStatementsContract π φ ⟨σ, δ, false⟩ argInit ⟨σ_arg, δ, false⟩) + (HL2 : EvalStatementsContract π φ ⟨σ_arg, δ, false⟩ outInit ⟨σ_out, δ, false⟩) + (HL3 : EvalStatementsContract π φ ⟨σ_out, δ, false⟩ oldInit ⟨σ_old, δ, false⟩) + (HL4 : EvalStatementsContract π φ ⟨σ_old, δ, false⟩ asserts ⟨σ_old, δ, false⟩) + (HL5 : EvalStatementsContract π φ ⟨σ_old, δ, false⟩ havocs ⟨σ_havoc, δ, false⟩) + (HL6 : EvalStatementsContract π φ ⟨σ_havoc, δ, false⟩ assumes ⟨σ_havoc, δ, false⟩) : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + (argInit ++ outInit ++ oldInit ++ asserts ++ havocs ++ assumes) + ⟨σ_havoc, δ, false⟩ := by + have H12 := EvalStatementsContractApp HL1 HL2 + have H123 := EvalStatementsContractApp H12 HL3 + have H1234 := EvalStatementsContractApp H123 HL4 + have H12345 := EvalStatementsContractApp H1234 HL5 + exact EvalStatementsContractApp H12345 HL6 + +end + +end Core.Transform From 3710bb339970713932791738e4fa680538dd14c5 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 4 Jun 2026 11:57:39 -0700 Subject: [PATCH 02/12] CallElimCorrect: add exit-arm to callElimStatementCorrect MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Address PR #1306 review comment from @aqjune-aws: the previous statement of `callElimStatementCorrect` only covered programs reaching `.terminal`, silently excluding programs whose top-level execution ends in an `.exiting lbl ρ` configuration (e.g., `[call f(); exit "L"]` outside an enclosing block). `EvalStatementsContract` unfolds to `StepStmtStar (.terminal _)`, so such runs failed the hypothesis and were vacuously "covered" by the existing proof. Mirror the conjunctive shape used by `Specification.Overapproximates` (Specification.lean:594) and `TripleBlock` (Specification.lean:211): return `(terminal-arm) ∧ (∀ lbl, exiting-arm)`. Refactor into three theorems for clarity: - `callElimStatementCorrect_terminal` (private, unchanged): the existing call-elim chain via `EvalCallElim_glue`. - `callElimStatementCorrect_exit` (private, new): non-call cases reuse the original `Heval` via `callElimStmt_non_call_eq` (sts = [st]); the call case is vacuously discharged because `step_cmd` only ever yields `.terminal`, so `(.stmts [.cmd (.call ...)] _) →* .exiting lbl _` is unreachable (proven by `seq_reaches_exiting` plus inversion). - `callElimStatementCorrect` (public): assembles the two arms. No label-collision hazard: callElim only introduces fresh temp idents, not block labels, so exit labels transport unchanged. Zero external callers, so the conjunctive signature change is free downstream. --- Strata/Transform/CallElimCorrect.lean | 111 +++++++++++++++++++++++++- 1 file changed, 110 insertions(+), 1 deletion(-) diff --git a/Strata/Transform/CallElimCorrect.lean b/Strata/Transform/CallElimCorrect.lean index 7266890cb4..bd6982b211 100644 --- a/Strata/Transform/CallElimCorrect.lean +++ b/Strata/Transform/CallElimCorrect.lean @@ -1321,7 +1321,7 @@ private theorem fresh_triple_σ_facts that extends σ' on the freshly-introduced temp variables. The call case chains L1–L6 via `EvalCallElim_glue`; non-call cases are immediate. -/ -theorem callElimStatementCorrect [LawfulBEq Expression.Expr] +private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] {π : String → Option Procedure} {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} {δ : CoreEval} @@ -3809,6 +3809,115 @@ theorem callElimStatementCorrect [LawfulBEq Expression.Expr] simp only [pure, StateT.pure, Prod.mk.injEq] at Helim exact absurd Helim.1 (by simp) +/-- Exit-arm correctness of `callElimStmt` per source statement. + + Non-call sources reuse the original `Heval` verbatim: `callElimStmt_non_call_eq` + gives `sts = [st]`, so we close with `σ'' = σ'`. Call sources are vacuously + discharged: `step_cmd` only ever produces `.terminal`, never `.exiting`, so + `(.stmts [.cmd (.call …)] _) →* .exiting lbl _` is unreachable. -/ +private theorem callElimStatementCorrect_exit [LawfulBEq Expression.Expr] + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} + {σ σ' : CoreStore} + {p : Program} + {γ γ' : CoreTransformState} + {st : Statement} + {sts : List Statement} + {lbl : String} + (Heval : Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) + (.stmts [st] ⟨σ, δ, false⟩) (.exiting lbl ⟨σ', δ, false⟩)) + (Helim : (Except.ok sts, γ') = (runWith st (callElimStmt · p) γ)) : + ∃ σ'', + Inits σ' σ'' ∧ + Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) + (.stmts sts ⟨σ, δ, false⟩) (.exiting lbl ⟨σ'', δ, false⟩) := by + have nc_close_exit : ∀ {b : Statement} (_ : st = b) + (_ : ∀ pn ar mt, b ≠ .cmd (CmdExt.call pn ar mt)), + ∃ σ'', Inits σ' σ'' ∧ + Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) + (.stmts sts ⟨σ, δ, false⟩) (.exiting lbl ⟨σ'', δ, false⟩) := by + intro b heq hne + refine ⟨σ', Inits.init InitVars.init_none, ?_⟩ + have hsts := callElimStmt_non_call_eq hne (heq ▸ Helim) + rw [hsts]; rw [← heq]; exact Heval + cases hst : st with + | block lbl' b md => exact nc_close_exit hst (by intro _ _ _ h; cases h) + | ite cd tb eb md => exact nc_close_exit hst (by intro _ _ _ h; cases h) + | loop g m i b md => exact nc_close_exit hst (by intro _ _ _ h; cases h) + | exit lbl' md => exact nc_close_exit hst (by intro _ _ _ h; cases h) + | funcDecl f md => exact nc_close_exit hst (by intro _ _ _ h; cases h) + | typeDecl tc md => exact nc_close_exit hst (by intro _ _ _ h; cases h) + | cmd c => + cases c with + | cmd c' => exact nc_close_exit hst (by intro _ _ _ h; cases h) + | call procName args md => + -- Vacuous: a call statement reaches only `.terminal`. + subst hst + -- Peel `.stmts (s :: [])` → `.seq (.stmt s ρ) []` via step_stmts_cons. + match Heval with + | .step _ _ _ .step_stmts_cons hrest => + -- Use seq_reaches_exiting to split. + match Imperative.seq_reaches_exiting Expression + (EvalCommandContract π) (EvalPureFunc φ) hrest with + | .inl hexit => + -- Inner `.stmt (.cmd (.call …)) ρ →* .exiting lbl ρ` is + -- impossible: step_cmd targets only `.terminal`. + match hexit with + | .step _ _ _ (.step_cmd _) hrest' => + cases hrest' with + | step _ _ _ h _ => exact absurd h (by intro h; cases h) + | .inr ⟨_, _, htail⟩ => + -- Tail: `.stmts [] ρ₁ →* .exiting lbl ρ'`. step_stmts_nil + -- yields `.terminal ρ₁`, which cannot step further to `.exiting`. + match htail with + | .step _ _ _ .step_stmts_nil hrest' => + cases hrest' with + | step _ _ _ h _ => exact absurd h (by intro h; cases h) + +/-- Correctness of `callElimStmt` per source statement, in conjunctive + `Specification.Overapproximates`-style shape: terminal-arm and + exit-arm are quantified separately so that an exiting source trace + is mirrored by an exiting target trace. + + The terminal arm reuses the call-elim chain via + `callElimStatementCorrect_terminal`. The exit arm dispatches to + `callElimStatementCorrect_exit`. -/ +theorem callElimStatementCorrect [LawfulBEq Expression.Expr] + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} + {σ : CoreStore} + {p : Program} + {γ γ' : CoreTransformState} + {st : Statement} + {sts : List Statement} + (Hp : ∀ pname, π pname = Program.Procedure.find? p ⟨pname, ()⟩) + (Hwfc : WellFormedCoreEvalCong δ) + (Hwf : WF.WFStatementsProp p [st]) + (Hgenrel : CoreGenStateRel σ γ) + (Hwfcallsite : WFCallSiteProp p π st) + (Helim : (Except.ok sts, γ') = (runWith st (callElimStmt · p) γ)) : + -- Terminal arm + (∀ {σ' : CoreStore}, + Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) + (.stmts [st] ⟨σ, δ, false⟩) (.terminal ⟨σ', δ, false⟩) → + ∃ σ'', + Inits σ' σ'' ∧ + Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) + (.stmts sts ⟨σ, δ, false⟩) (.terminal ⟨σ'', δ, false⟩)) + ∧ + -- Exit arm + (∀ {lbl : String} {σ' : CoreStore}, + Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) + (.stmts [st] ⟨σ, δ, false⟩) (.exiting lbl ⟨σ', δ, false⟩) → + ∃ σ'', + Inits σ' σ'' ∧ + Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) + (.stmts sts ⟨σ, δ, false⟩) (.exiting lbl ⟨σ'', δ, false⟩)) := + ⟨fun Heval => callElimStatementCorrect_terminal Hp Heval Hwfc Hwf Hgenrel Hwfcallsite Helim, + fun Heval => callElimStatementCorrect_exit Heval Helim⟩ + end -- public section end CallElimCorrect From 0eb0342ee5c086a650fe4a75869f42277cd6719d Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 4 Jun 2026 13:30:32 -0700 Subject: [PATCH 03/12] CallElimCorrect: relocate generic lemmas + rename *Semantics to *SemanticsProps Address PR #1306 review feedback from @aqjune-aws: * Files holding only lemmas (not actual semantics defs) follow the existing repo convention `*SemanticsProps.lean` (e.g., `Strata/Languages/Core/StatementSemanticsProps.lean`): - `Strata/Transform/CoreTransformSemantics.lean` -> `Strata/Transform/CoreTransformSemanticsProps.lean` - `Strata/Transform/SubstSemantics.lean` -> `Strata/Transform/SubstSemanticsProps.lean` Audited `SubstSemantics.lean`'s deps: still requires `Core.Transform.createFvar(s)` and `singletonAssertEval`/ `singletonAssumeEval`, so it stays under `Strata/Transform/`. * Generic lemmas relocated to their proper homes: - Pure list lemmas -> `Strata/DL/Util/ListUtils.lean` (now in `List` namespace): `zip_pair_split`, `nodup_3_decompose`, `notin_3_append_of`, `zip_zip_unzip_snd_of_lengths`, `zip_zip_unzip_fst_unzip_fst_of_lengths`, `zip_notin_fst_pair`, `zip_notin_snd_pair` - Pure-Imperative lemmas -> new `Strata/DL/Imperative/CmdSemanticsProps.lean` (generalized from CoreStore/Expression.Ident to P : PureExpr, now in `Imperative` namespace): `subst_defined_tail`, `subst_nodup_tail` - Core-substitution helper moved out of `CallElimCorrect.lean` into `SubstSemanticsProps.lean`: `substDefined_of_app` * Imports updated: `CallElimCorrect`, `SubstSemanticsProps`, and `Strata/DL/Imperative/Imperative.lean` (added new `CmdSemanticsProps` import). --- Strata/DL/Imperative/CmdSemanticsProps.lean | 50 +++++++++++ Strata/DL/Imperative/Imperative.lean | 1 + Strata/DL/Util/ListUtils.lean | 88 +++++++++++++++++++ Strata/Transform/CallElimCorrect.lean | 54 ++---------- ....lean => CoreTransformSemanticsProps.lean} | 44 ++-------- ...emantics.lean => SubstSemanticsProps.lean} | 69 ++++----------- 6 files changed, 170 insertions(+), 136 deletions(-) create mode 100644 Strata/DL/Imperative/CmdSemanticsProps.lean rename Strata/Transform/{CoreTransformSemantics.lean => CoreTransformSemanticsProps.lean} (97%) rename Strata/Transform/{SubstSemantics.lean => SubstSemanticsProps.lean} (97%) diff --git a/Strata/DL/Imperative/CmdSemanticsProps.lean b/Strata/DL/Imperative/CmdSemanticsProps.lean new file mode 100644 index 0000000000..06fe410141 --- /dev/null +++ b/Strata/DL/Imperative/CmdSemanticsProps.lean @@ -0,0 +1,50 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.CmdSemantics +public import Strata.DL.Util.ListUtils +public import Strata.DL.Util.Nodup +import all Strata.DL.Util.ListUtils +import all Strata.DL.Util.Nodup + +/-! # Generic property lemmas for `Imperative.CmdSemantics` + + Pure-Imperative property lemmas about `substDefined` / `substNodup` + that do not depend on any specific `PureExpr` instantiation (e.g., + Core). Live here rather than in `Strata.Transform.SubstSemanticsProps` + because they are reusable across any transform that introduces fresh + variables and substitutes them. -/ + +public section + +namespace Imperative + +/-- The tail of a `substDefined` cons-list still satisfies `substDefined`. -/ +theorem subst_defined_tail + {P : PureExpr} {σ σ' : SemanticStore P} + {h : P.Ident × P.Ident} + {t : List (P.Ident × P.Ident)} : + Imperative.substDefined σ σ' (h :: t) → + Imperative.substDefined σ σ' t := by + intros Hsubst k1 k2 Hin + apply Hsubst + exact List.mem_cons_of_mem h Hin + +/-- The tail of a `substNodup` cons-list still satisfies `substNodup`. -/ +theorem subst_nodup_tail + {P : PureExpr} + {h : P.Ident × P.Ident} + {t : List (P.Ident × P.Ident)} : + Imperative.substNodup (h :: t) → + Imperative.substNodup t := by + intros Hsubst + simp [Imperative.substNodup] at * + exact (List.nodup_cons.mp (nodup_middle Hsubst.right)).right + +end Imperative + +end -- public section diff --git a/Strata/DL/Imperative/Imperative.lean b/Strata/DL/Imperative/Imperative.lean index 7713f0753e..c0bb0eadae 100644 --- a/Strata/DL/Imperative/Imperative.lean +++ b/Strata/DL/Imperative/Imperative.lean @@ -12,6 +12,7 @@ public import Strata.DL.Imperative.MetaData public import Strata.DL.Imperative.CmdEval public import Strata.DL.Imperative.CmdType public import Strata.DL.Imperative.CmdSemantics +public import Strata.DL.Imperative.CmdSemanticsProps public import Strata.DL.Imperative.StmtSemantics public import Strata.DL.Imperative.KleeneStmt diff --git a/Strata/DL/Util/ListUtils.lean b/Strata/DL/Util/ListUtils.lean index 0d74bf1d1a..3ed48987f4 100644 --- a/Strata/DL/Util/ListUtils.lean +++ b/Strata/DL/Util/ListUtils.lean @@ -556,3 +556,91 @@ public theorem List.nodup_append_three_disjoint a.Disjoint b ∧ b.Disjoint c ∧ a.Disjoint c := let ⟨h1, h2, h3⟩ := List.disjoint_of_nodup_append_three Hnd ⟨h1, h3, h2⟩ + +/-- If `(h, x) ∉ List.zip t t'` for every `x : β` and `t.length = t'.length`, + then `h ∉ t`. Pure list lemma with no Imperative or Core dependencies. -/ +public theorem List.zip_notin_fst_pair {α β : Type _} + {h : α} {t : List α} {t' : List β} : + t.length = t'.length → + (∀ x, ¬(h, x) ∈ List.zip t t') → + ¬ h ∈ t := by + intros Hlen H + induction t generalizing t' h <;> simp_all + case cons h t ih => + cases t' with + | nil => simp at Hlen + | cons h' t' => + simp_all + have HH := H h' + simp_all + exact ih rfl H + +/-- Symmetric to `zip_notin_fst_pair`: if `(x, h) ∉ List.zip t t'` for every + `x : α` and `t.length = t'.length`, then `h ∉ t'`. -/ +public theorem List.zip_notin_snd_pair {α β : Type _} + {h : β} {t : List α} {t' : List β} : + t.length = t'.length → + (∀ x, ¬(x, h) ∈ List.zip t t') → + ¬ h ∈ t' := by + intros Hlen H + induction t' generalizing t h <;> simp_all + case cons h t ih => + cases t with + | nil => simp at Hlen + | cons h' t' => + simp_all + have HH := H h' + simp_all + exact ih Hlen H + +/-- Decompose `(ks.zip ks').get n = (k1, k2)` into per-component equalities, + given explicit bounds for each list. -/ +public theorem List.zip_pair_split {α β} {ks : List α} {ks' : List β} + {n : Fin (ks.zip ks').length} {k1 : α} {k2 : β} + (hn : n.val < ks.length) (hn' : n.val < ks'.length) + (heq : (ks.zip ks').get n = (k1, k2)) : + k1 = ks[n.val]'hn ∧ k2 = ks'[n.val]'hn' := by + rw [show (ks.zip ks').get n = (ks.zip ks')[n.val]'n.isLt from rfl, + List.getElem_zip] at heq + exact ⟨((Prod.mk.injEq _ _ _ _).mp heq.symm).1, + ((Prod.mk.injEq _ _ _ _).mp heq.symm).2⟩ + +/-- Decompose `(a ++ b ++ c).Nodup` into its three component-Nodups and three + pairwise disjointnesses (in the local `List.Disjoint` form: `a → b → False`). + Repackages `List.nodup_append` and `List.disjoint_of_nodup_append_three`. -/ +public theorem List.nodup_3_decompose {α} {a b c : List α} + (Hnd : (a ++ b ++ c).Nodup) : + a.Nodup ∧ b.Nodup ∧ c.Nodup ∧ + a.Disjoint b ∧ a.Disjoint c ∧ b.Disjoint c := + let Hsplit := List.nodup_append.mp Hnd + let Hab := List.nodup_append.mp Hsplit.1 + let ⟨Hd_ab, Hd_ac, Hd_bc⟩ := List.disjoint_of_nodup_append_three Hnd + ⟨Hab.1, Hab.2.1, Hsplit.2.1, Hd_ab, Hd_ac, Hd_bc⟩ + +/-- Build `x ∉ a ++ b ++ c` from per-list non-membership. -/ +public theorem List.notin_3_append_of {α} [DecidableEq α] {a b c : List α} {x : α} + (h₁ : x ∉ a) (h₂ : x ∉ b) (h₃ : x ∉ c) : x ∉ a ++ b ++ c := by + simp only [List.mem_append, not_or]; exact ⟨⟨h₁, h₂⟩, h₃⟩ + +/-- Project the snd-component out of a doubly-zipped triple-list, given the + matching length facts. Pure list-shape geometry helper used in + trip-shape computations. -/ +public theorem List.zip_zip_unzip_snd_of_lengths {α β γ} + {g : List α} {ys : List β} {xs : List γ} + (Hgx : g.length = xs.length) (Hyx : ys.length = xs.length) : + ((g.zip ys).zip xs).unzip.snd = xs := by + rw [List.unzip_zip_right] + rw [List.length_zip] + omega + +/-- Project the fst-fst-component out of a doubly-zipped triple-list, given + the matching length facts. Pure list-shape geometry helper. -/ +public theorem List.zip_zip_unzip_fst_unzip_fst_of_lengths {α β γ} + {g : List α} {ys : List β} {xs : List γ} + (Hgx : g.length = xs.length) (Hyx : ys.length = xs.length) : + ((g.zip ys).zip xs).unzip.fst.unzip.fst = g := by + rw [List.unzip_zip_left (l₁ := (g.zip ys)) (l₂ := xs)] + · rw [List.unzip_zip_left (l₁ := g) (l₂ := ys)] + omega + · rw [List.length_zip] + omega diff --git a/Strata/Transform/CallElimCorrect.lean b/Strata/Transform/CallElimCorrect.lean index bd6982b211..09283c7285 100644 --- a/Strata/Transform/CallElimCorrect.lean +++ b/Strata/Transform/CallElimCorrect.lean @@ -18,8 +18,8 @@ public import Strata.Transform.CallElim public import Strata.DL.Imperative.CmdSemantics public import Strata.Languages.Core.StatementSemantics import Strata.Languages.Core.StatementSemanticsProps -public import Strata.Transform.SubstSemantics -import Strata.Transform.CoreTransformSemantics +public import Strata.Transform.SubstSemanticsProps +import Strata.Transform.CoreTransformSemanticsProps import Strata.DL.Util.ListUtils public import Strata.DL.Util.String @@ -56,46 +56,6 @@ private theorem notin_of_isSome_isNotDefined {P : Imperative.PureExpr} (Hsome : (σ k).isSome) (Hndef : Imperative.isNotDefined σ ks) : k ∉ ks := fun h => σ_some_contradiction Hsome (Hndef k h) -/-- Build `substDefined σ σ' ((a₁ ++ b₁).zip (a₂ ++ b₂))` from per-half - `isDefined` facts. -/ -private theorem substDefined_of_app - {σ σ' : CoreStore} {a₁ b₁ a₂ b₂ : List Expression.Ident} - (Hσ_a : Imperative.isDefined σ a₁) (Hσ_b : Imperative.isDefined σ b₁) - (Hσ'_a : Imperative.isDefined σ' a₂) (Hσ'_b : Imperative.isDefined σ' b₂) : - Imperative.substDefined σ σ' ((a₁ ++ b₁).zip (a₂ ++ b₂)) := by - intro k1 k2 Hkin - have Hmem := List.of_mem_zip Hkin - exact ⟨(List.mem_append.mp Hmem.1).elim (Hσ_a _) (Hσ_b _), - (List.mem_append.mp Hmem.2).elim (Hσ'_a _) (Hσ'_b _)⟩ - -/-- Decompose `(ks.zip ks').get n = (k1, k2)` into per-component equalities, - given explicit bounds for each list. -/ -private theorem zip_pair_split {α β} {ks : List α} {ks' : List β} - {n : Fin (ks.zip ks').length} {k1 : α} {k2 : β} - (hn : n.val < ks.length) (hn' : n.val < ks'.length) - (heq : (ks.zip ks').get n = (k1, k2)) : - k1 = ks[n.val]'hn ∧ k2 = ks'[n.val]'hn' := by - rw [show (ks.zip ks').get n = (ks.zip ks')[n.val]'n.isLt from rfl, - List.getElem_zip] at heq - exact ⟨((Prod.mk.injEq _ _ _ _).mp heq.symm).1, - ((Prod.mk.injEq _ _ _ _).mp heq.symm).2⟩ - -/-- Decompose `(a ++ b ++ c).Nodup` into its three component-Nodups and three - pairwise disjointnesses (in the local `List.Disjoint` form: `a → b → False`). - Repackages `List.nodup_append` and `List.disjoint_of_nodup_append_three`. -/ -private theorem nodup_3_decompose {α} {a b c : List α} - (Hnd : (a ++ b ++ c).Nodup) : - a.Nodup ∧ b.Nodup ∧ c.Nodup ∧ - a.Disjoint b ∧ a.Disjoint c ∧ b.Disjoint c := - let Hsplit := List.nodup_append.mp Hnd - let Hab := List.nodup_append.mp Hsplit.1 - let ⟨Hd_ab, Hd_ac, Hd_bc⟩ := List.disjoint_of_nodup_append_three Hnd - ⟨Hab.1, Hab.2.1, Hsplit.2.1, Hd_ab, Hd_ac, Hd_bc⟩ - -/-- Build `x ∉ a ++ b ++ c` from per-list non-membership. -/ -private theorem notin_3_append_of {α} [DecidableEq α] {a b c : List α} {x : α} - (h₁ : x ∉ a) (h₂ : x ∉ b) (h₃ : x ∉ c) : x ∉ a ++ b ++ c := by - simp only [List.mem_append, not_or]; exact ⟨⟨h₁, h₂⟩, h₃⟩ /-- `Map.find?_append` "some" branch packaged: if a key resolves to `some v` in `l₁` and to `some w` in `l₁ ++ l₂`, then `v = w`. -/ @@ -1626,7 +1586,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] · -- L1-L6 chain via EvalCallElim_glue. obtain ⟨HargNd, HoutNd, HoldNd, HargOutDisj, HargOldDisj, HoutOldDisj⟩ := - nodup_3_decompose Hgennd + List.nodup_3_decompose Hgennd -- argTemps fresh from σ; arg-expr vars defined in σ ⇒ disjoint. have HdefVars : Imperative.isDefined σ (List.flatMap @@ -2444,7 +2404,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] outTemps ++ genOldIdents) (argVals ++ oVals ++ oldVals) v).isSome = true have Hv_notin : v ∉ argTemps ++ outTemps ++ genOldIdents := - notin_3_append_of (HlhsDisjArg Hv) (HlhsDisjOut Hv) (HlhsDisjOld Hv) + List.notin_3_append_of (HlhsDisjArg Hv) (HlhsDisjOut Hv) (HlhsDisjOld Hv) rw [updatedStates_get_notin Hv_notin] exact HavocVarsDefined (UpdateStatesHavocVars Hupdate) v Hv -- σ_havoc definedness on filtered_argTemps. @@ -2485,7 +2445,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] have H5 : σ k = σ' k := by rw [Hσ'_eq, updatedStates_get_notin Hk_lhs] have Hk_notin_layered : k ∉ argTemps ++ outTemps ++ genOldIdents := - notin_3_append_of Hk_argT Hk_outT Hk_genOld + List.notin_3_append_of Hk_argT Hk_outT Hk_genOld have H6 : σ' k = σ_havoc k := by show σ' k = updatedStates σ' (argTemps ++ outTemps ++ genOldIdents) @@ -2504,7 +2464,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] ∀ v ∈ lhs, σ_havoc v = σ' v := by intro v Hv have Hv_notin : v ∉ argTemps ++ outTemps ++ genOldIdents := - notin_3_append_of (HlhsDisjArg Hv) (HlhsDisjOut Hv) (HlhsDisjOld Hv) + List.notin_3_append_of (HlhsDisjArg Hv) (HlhsDisjOut Hv) (HlhsDisjOld Hv) show updatedStates σ' (argTemps ++ outTemps ++ genOldIdents) @@ -2608,7 +2568,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] have Hn_lt_ks' : n.val < filtered_ks'.length := by rw [← Hkslen]; exact Hn_lt_ks have ⟨Hk1_eq, Hk2_eq⟩ := - zip_pair_split Hn_lt_ks Hn_lt_ks' Hn + List.zip_pair_split Hn_lt_ks Hn_lt_ks' Hn by_cases Hsplit : n.val < proc.header.outputs.keys.length · -- Output-half. have Hks_app_lt : diff --git a/Strata/Transform/CoreTransformSemantics.lean b/Strata/Transform/CoreTransformSemanticsProps.lean similarity index 97% rename from Strata/Transform/CoreTransformSemantics.lean rename to Strata/Transform/CoreTransformSemanticsProps.lean index bbdc106678..ebd59ca9bf 100644 --- a/Strata/Transform/CoreTransformSemantics.lean +++ b/Strata/Transform/CoreTransformSemanticsProps.lean @@ -723,32 +723,6 @@ theorem genOutExprIdentsTrip_extract exact this.symm · simp at Hlen; exact Hlen -/-! ### Trip-shape geometry helpers - -The Arg/Out/Old trip lemmas all share a `((g.zip ys).zip xs)` outer -shape and project either the `.unzip.snd` (= `xs`, given length -agreement) or `.unzip.fst.unzip.fst` (= `g`, ditto). These pure list -facts are extracted once so that the trip-level lemmas can short-cut -their unzip/zip ceremony. -/ - -theorem zip_zip_unzip_snd_of_lengths {α β γ} - {g : List α} {ys : List β} {xs : List γ} - (Hgx : g.length = xs.length) (Hyx : ys.length = xs.length) : - ((g.zip ys).zip xs).unzip.snd = xs := by - rw [List.unzip_zip_right] - rw [List.length_zip] - omega - -theorem zip_zip_unzip_fst_unzip_fst_of_lengths {α β γ} - {g : List α} {ys : List β} {xs : List γ} - (Hgx : g.length = xs.length) (Hyx : ys.length = xs.length) : - ((g.zip ys).zip xs).unzip.fst.unzip.fst = g := by - rw [List.unzip_zip_left (l₁ := (g.zip ys)) (l₂ := xs)] - · rw [List.unzip_zip_left (l₁ := g) (l₂ := ys)] - omega - · rw [List.length_zip] - omega - /-! ### `_snd` projection lemmas for the `gen*ExprIdentsTrip` family These say: the `Prod.snd` projection of the trip list is exactly the @@ -765,7 +739,7 @@ theorem genArgExprIdentsTrip_snd argTrips.unzip.snd = args := by obtain ⟨Hat, _, Hilen⟩ := genArgExprIdentsTrip_extract Hgen rw [← Hat] - exact zip_zip_unzip_snd_of_lengths + exact List.zip_zip_unzip_snd_of_lengths (genArgExprIdents_length' args.length s.genState) (by simp [List.length_map]; omega) @@ -777,7 +751,7 @@ theorem genOutExprIdentsTrip_snd outTrips.unzip.snd = lhs := by obtain ⟨Hot, _, Hilen⟩ := genOutExprIdentsTrip_extract Hgen rw [← Hot] - exact zip_zip_unzip_snd_of_lengths + exact List.zip_zip_unzip_snd_of_lengths (genOutExprIdents_length' lhs s.genState) (by simp [List.length_map]; omega) @@ -798,7 +772,7 @@ theorem genOldExprIdentsTrip_snd (Hgen : Core.Transform.genOldExprIdents oldVars s = (genOldIdents, s')) (Htylen : oldTys.length = oldVars.length) : ((genOldIdents.zip oldTys).zip oldVars).unzip.snd = oldVars := - zip_zip_unzip_snd_of_lengths (genOldExprIdents_length Hgen) Htylen + List.zip_zip_unzip_snd_of_lengths (genOldExprIdents_length Hgen) Htylen /-! ### `*GeneratedWF` lemmas: each generator pushes its results to `generated` @@ -872,7 +846,7 @@ theorem genArgExprIdentsTripGeneratedWF (ls := (Core.Transform.genArgExprIdents args.length s.genState).fst) rfl] congr 1 rw [← Hat] - rw [zip_zip_unzip_fst_unzip_fst_of_lengths + rw [List.zip_zip_unzip_fst_unzip_fst_of_lengths (genArgExprIdents_length' args.length s.genState) (by simp [List.length_map]; omega)] @@ -890,7 +864,7 @@ theorem genOutExprIdentsTripGeneratedWF (ls := (Core.Transform.genOutExprIdents lhs s.genState).fst) rfl] congr 1 rw [← Hot] - rw [zip_zip_unzip_fst_unzip_fst_of_lengths + rw [List.zip_zip_unzip_fst_unzip_fst_of_lengths (genOutExprIdents_length' lhs s.genState) (by simp [List.length_map]; omega)] @@ -973,7 +947,7 @@ theorem genOldExprIdentsTripGeneratedWF s'.generated = ((genOldIdents.zip oldTys).zip oldVars).unzip.fst.unzip.fst.reverse ++ s.generated := by rw [genOldExprIdents_GeneratedWF Hgen] - rw [zip_zip_unzip_fst_unzip_fst_of_lengths + rw [List.zip_zip_unzip_fst_unzip_fst_of_lengths (genOldExprIdents_length Hgen) Htylen] /-! ### `isTempIdent` / `isOldTempIdent` predicates and producing-side lemmas @@ -1108,7 +1082,7 @@ theorem genArgExprIdentsTrip_isTempIdent Forall (fun x => isTempIdent x) argTrips.unzip.fst.unzip.fst := by obtain ⟨Hat, _, Hilen⟩ := genArgExprIdentsTrip_extract Hgen rw [← Hat] - rw [zip_zip_unzip_fst_unzip_fst_of_lengths + rw [List.zip_zip_unzip_fst_unzip_fst_of_lengths (genArgExprIdents_length' args.length s.genState) (by simp [List.length_map]; omega)] exact genArgExprIdents_isTempIdent (s := s.genState) @@ -1123,7 +1097,7 @@ theorem genOutExprIdentsTrip_isTempIdent Forall (fun x => isTempIdent x) outTrips.unzip.fst.unzip.fst := by obtain ⟨Hot, _, Hilen⟩ := genOutExprIdentsTrip_extract Hgen rw [← Hot] - rw [zip_zip_unzip_fst_unzip_fst_of_lengths + rw [List.zip_zip_unzip_fst_unzip_fst_of_lengths (genOutExprIdents_length' lhs s.genState) (by simp [List.length_map]; omega)] exact genOutExprIdents_isTempIdent (s := s.genState) @@ -1142,7 +1116,7 @@ theorem genOldExprIdentsTrip_isOldTempIdent (Htylen : oldTys.length = oldVars.length) : Forall (fun x => isOldTempIdent x) ((genOldIdents.zip oldTys).zip oldVars).unzip.fst.unzip.fst := by - rw [zip_zip_unzip_fst_unzip_fst_of_lengths + rw [List.zip_zip_unzip_fst_unzip_fst_of_lengths (genOldExprIdents_length Hgen) Htylen] exact genOldExprIdents_isOldTempIdent Hgen diff --git a/Strata/Transform/SubstSemantics.lean b/Strata/Transform/SubstSemanticsProps.lean similarity index 97% rename from Strata/Transform/SubstSemantics.lean rename to Strata/Transform/SubstSemanticsProps.lean index ed57d184f1..8b8ca44c2b 100644 --- a/Strata/Transform/SubstSemantics.lean +++ b/Strata/Transform/SubstSemanticsProps.lean @@ -9,9 +9,10 @@ import Init.Data.List.Basic import Init.Data.List.Lemmas public import Strata.DL.Lambda.Lambda public import Strata.DL.Imperative.CmdSemantics +public import Strata.DL.Imperative.CmdSemanticsProps public import Strata.Languages.Core.StatementSemantics public import Strata.Transform.CoreTransform -public import Strata.Transform.CoreTransformSemantics +public import Strata.Transform.CoreTransformSemanticsProps import Strata.Languages.Core.StatementSemanticsProps import Strata.DL.Util.ListUtils @@ -241,24 +242,6 @@ theorem updatedStateIsDefinedMono' simp [updatedState] split <;> simp_all -theorem subst_defined_tail - {σ σ' : CoreStore} {h : Expression.Ident × Expression.Ident} - {t : List (Expression.Ident × Expression.Ident)} : - Imperative.substDefined σ σ' (h :: t) → - Imperative.substDefined σ σ' t := by - intros Hsubst k1 k2 Hin - apply Hsubst - exact List.mem_cons_of_mem h Hin - -theorem subst_nodup_tail - {h : Expression.Ident × Expression.Ident} - {t : List (Expression.Ident × Expression.Ident)} : - Imperative.substNodup (h :: t) → - Imperative.substNodup t := by - intros Hsubst - simp [Imperative.substNodup] at * - exact (List.nodup_cons.mp (nodup_middle Hsubst.right)).right - theorem subst_defined_updatedState {σ σ' : CoreStore} {k : Expression.Ident} {v : Expression.Expr} {ls : List (Expression.Ident × Expression.Ident)} : @@ -268,39 +251,17 @@ theorem subst_defined_updatedState refine ⟨?_, (Hsubst k1 k2 Hin).2⟩ exact updatedStateIsDefinedMono' (Hsubst k1 k2 Hin).1 -theorem zip_notin_fst_pair - {h : Expression.Ident} - {t : List Expression.Ident} {t' : List Expression.Ident} : - t.length = t'.length → - (∀ x, ¬(h, x) ∈ List.zip t t') → - ¬ h ∈ t := by - intros Hlen H - induction t generalizing t' h <;> simp_all - case cons h t ih => - cases t' with - | nil => simp at Hlen - | cons h' t' => - simp_all - have HH := H h' - simp_all - exact ih rfl H - -theorem zip_notin_snd_pair - {h : Expression.Ident} - {t : List Expression.Ident} {t' : List Expression.Ident} : - t.length = t'.length → - (∀ x, ¬(x, h) ∈ List.zip t t') → - ¬ h ∈ t' := by - intros Hlen H - induction t' generalizing t h <;> simp_all - case cons h t ih => - cases t with - | nil => simp at Hlen - | cons h' t' => - simp_all - have HH := H h' - simp_all - exact ih Hlen H +/-- Build `substDefined σ σ' ((a₁ ++ b₁).zip (a₂ ++ b₂))` from per-half + `isDefined` facts. -/ +theorem substDefined_of_app + {σ σ' : CoreStore} {a₁ b₁ a₂ b₂ : List Expression.Ident} + (Hσ_a : Imperative.isDefined σ a₁) (Hσ_b : Imperative.isDefined σ b₁) + (Hσ'_a : Imperative.isDefined σ' a₂) (Hσ'_b : Imperative.isDefined σ' b₂) : + Imperative.substDefined σ σ' ((a₁ ++ b₁).zip (a₂ ++ b₂)) := by + intro k1 k2 Hkin + have Hmem := List.of_mem_zip Hkin + exact ⟨(List.mem_append.mp Hmem.1).elim (Hσ_a _) (Hσ_b _), + (List.mem_append.mp Hmem.2).elim (Hσ'_a _) (Hσ'_b _)⟩ theorem subst_nodup_ht {h h' : Expression.Ident} @@ -311,11 +272,11 @@ theorem subst_nodup_ht intros Hlen Hsubst simp [Imperative.substNodup] at Hsubst refine ⟨?_, ?_⟩ - · exact zip_notin_fst_pair Hlen Hsubst.1.1 + · exact List.zip_notin_fst_pair Hlen Hsubst.1.1 · have Hnd := nodup_middle Hsubst.2 simp at Hnd have Hnd' := Hnd.1.2 - exact zip_notin_snd_pair Hlen Hnd' + exact List.zip_notin_snd_pair Hlen Hnd' theorem getVars_substFvar_or {e : Expression.Expr} {h h' v : Expression.Ident} : From 4bfccc31bf4695f0c6178963d1a4cdb8cb3d3867 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 4 Jun 2026 15:20:30 -0700 Subject: [PATCH 04/12] Core: integrate hasFailure flag into EvalCommand.call_sem MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Layer-A small-step semantics for procedure calls now propagates the callee body's terminal hasFailure flag to the caller. Previously, EvalCommand.call_sem hardcoded the output flag to `false`, silently dropping any failures inside callee bodies (a soundness gap inherited from the original semantics). The change exposes a previously-vacuous case in `evalCommand_failure_implies_assert_ff` (StatementSemanticsProps.lean): when call_sem yields `true`, the failing assert lives somewhere inside the callee body, not at the call site itself, so the lemma's existing existential `∃ a, coreIsAtAssert (.stmt (.cmd c) ρ) a ∧ …` cannot be discharged structurally. Closure strategy: a new precondition `CalleesNoFailure π φ` asserts that every procedure body in `π`, run from a non-failing init env, terminates with `hasFailure = false`. This is threaded through both `evalCommand_failure_implies_assert_ff` and `core_noFailure_preserved`. The call_sem arm of the former is then discharged by applying `hCallees` to the body trace bound by call_sem and contradicting the resulting `false` against the `true` index. Downstream: `procBodyVerify_procedureCorrect` (the sole consumer of `core_noFailure_preserved`) takes `CalleesNoFailure` as a new hypothesis. The hypothesis is exactly the body-noFailure clause that clause 2 of `ProcedureCorrect` (this theorem's own conclusion) establishes per procedure, so callers can discharge it inductively across all procedures in `π` once the program is verified. No new sorries, no axioms, no termination admits. Build clean (488 jobs). --- Strata/Languages/Core/StatementSemantics.lean | 2 +- .../Core/StatementSemanticsProps.lean | 39 ++++++++++++++++++- Strata/Transform/ProcBodyVerifyCorrect.lean | 13 +++++-- 3 files changed, 49 insertions(+), 5 deletions(-) diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 66ff4b4d85..cac3badec2 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -330,7 +330,7 @@ inductive EvalCommand (π : String → Option Procedure) (φ : CoreEval → Pure -- positional: modvals[i] written back to lhs[i] UpdateStates σ lhs modvals σ' → ---- - EvalCommand π φ δ σ (CmdExt.call n callArgs md) σ' false + EvalCommand π φ δ σ (CmdExt.call n callArgs md) σ' ρ'.hasFailure end diff --git a/Strata/Languages/Core/StatementSemanticsProps.lean b/Strata/Languages/Core/StatementSemanticsProps.lean index cca16c2248..a151d15fea 100644 --- a/Strata/Languages/Core/StatementSemanticsProps.lean +++ b/Strata/Languages/Core/StatementSemanticsProps.lean @@ -2644,20 +2644,57 @@ private theorem coreIsAtAssert_block_of_inner {label} {σ_parent} {inner : CoreConfig} {a} (h : coreIsAtAssert inner a) : coreIsAtAssert (.block label σ_parent inner) a := h +/-- Program-level precondition: every procedure body, run from a non-failing + initial environment, terminates with `hasFailure = false`. + + Required by `evalCommand_failure_implies_assert_ff` and + `core_noFailure_preserved` because `EvalCommand.call_sem` propagates the + callee body's terminal `hasFailure` flag (Layer-A small-step semantics). + Without this hypothesis, a failing assert inside a callee body would + surface as `EvalCommand … σ' true` at the call site, but the call site + itself is not an assert location (per `coreIsAtAssert`), so the lemma's + existential witness would be unprovable. + + The hypothesis is discharged by the caller using + `procBodyVerify_procedureCorrect` (clause 2 of `ProcedureCorrect`), which + establishes exactly this fact for each verified procedure. -/ +@[expose] def CalleesNoFailure + (π : String → Option Procedure) + (φ : CoreEval → PureFunc Expression → CoreEval) : Prop := + ∀ (n : String) (p : Procedure) (ρ ρ' : Env Expression), + π n = some p → + ρ.hasFailure = false → + CoreStepStar π φ (.stmts p.body ρ) (.terminal ρ') → + ρ'.hasFailure = false + private theorem evalCommand_failure_implies_assert_ff {π : String → Option Procedure} {φ : CoreEval → PureFunc Expression → CoreEval} {ρ : Env Expression} {c : Command} {σ'} + (hCallees : CalleesNoFailure π φ) (hcmd : EvalCommand π φ ρ.eval ρ.store c σ' true) : ∃ a : AssertId Expression, coreIsAtAssert (.stmt (.cmd c) ρ) a ∧ ρ.eval ρ.store a.expr = some HasBool.ff := by + -- Generalize the `true` index so dependent elimination can split both + -- constructors of `EvalCommand` (the `call_sem` case carries an opaque + -- `ρ'.hasFailure` index that does not unify with the literal `true`). + generalize hb : (true : Bool) = b at hcmd cases hcmd with | cmd_sem heval => + subst hb cases heval with | eval_assert_fail hff _ => exact ⟨⟨_, _⟩, ⟨rfl, rfl⟩, hff⟩ + | call_sem hπ _ _ _ _ _ _ _ _ _ _ _ _ hbody _ _ _ => + -- `call_sem` body trace: `CoreStepStar π φ (.stmts p.body ⟨σAO, δ, false⟩) + -- (.terminal ρ')` plus + -- `hb : true = ρ'.hasFailure`. Apply `hCallees` to extract + -- `ρ'.hasFailure = false`, contradicting `hb`. + have hρ' : _ = false := hCallees _ _ _ _ hπ rfl hbody + exact absurd (hb.trans hρ') (by decide) theorem core_noFailure_preserved (c₁ c₂ : CoreConfig) + (hCallees : CalleesNoFailure π φ) (hvalid : ∀ (a : AssertId Expression) (cfg : CoreConfig), CoreStepStar π φ c₁ cfg → coreIsAtAssert cfg a → @@ -2683,7 +2720,7 @@ theorem core_noFailure_preserved (Imperative.step_preserves_noFailure (P := Expression) (extendEval := EvalPureFunc φ) coreIsAtAssert - evalCommand_failure_implies_assert_ff + (evalCommand_failure_implies_assert_ff hCallees) coreIsAtAssert_of_inv_mem coreIsAtAssert_seq_of_inner coreIsAtAssert_block_of_inner diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index b8bb5896a6..0f3016309d 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -9,7 +9,7 @@ public import Strata.Transform.ProcBodyVerify public import Strata.Transform.CoreSpecification import Std.Tactic.BVDecide.Normalize.Prop import Strata.Languages.Core.ProcedureWF -import Strata.Languages.Core.StatementSemanticsProps +public import Strata.Languages.Core.StatementSemanticsProps public section @@ -639,7 +639,14 @@ theorem procBodyVerify_procedureCorrect -- `h_wf_ext`: the evaluator extension `φ` is well-formed (h_wf_ext : Core.WFEvalExtension φ) -- `h_wf_proc`: the procedure is well-formed - (h_wf_proc : WF.WFProcedureProp p proc) : + (h_wf_proc : WF.WFProcedureProp p proc) + -- `h_callees`: every procedure body in `π`, run from a non-failing init + -- env, terminates with `hasFailure = false`. Required by + -- `core_noFailure_preserved` because `EvalCommand.call_sem` propagates + -- the callee body's terminal `hasFailure` flag (Layer-A small-step + -- semantics). Discharged by the caller via repeated application of + -- this very theorem to all procedures in `π`. + (h_callees : Core.CalleesNoFailure π φ) : -- Conclusion: ProcedureCorrect holds. Core.Specification.ProcedureCorrect π φ proc p := by @@ -771,7 +778,7 @@ theorem procBodyVerify_procedureCorrect -- hasFailure = false have h_nf' : ρ'.hasFailure = Bool.false := Core.core_noFailure_preserved π φ - (.stmts proc.body ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term + (.stmts proc.body ρ₀) (.terminal ρ') h_callees h_valid h_wf.noFailure h_term -- wfBool preservation have h_wfb_term : WellFormedSemanticEvalBool ρ'.eval := Core.core_wfBool_preserved π φ h_wf_ext From e679bd56006050bc90e428bc52fff6846247faee Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 4 Jun 2026 16:26:12 -0700 Subject: [PATCH 05/12] Rename CoreTransformSemanticsProps -> CoreTransformProps; SubstSemanticsProps -> SubstProps MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Address PR #1306 follow-up review comment: the *Semantics qualifier in the prior names is misleading since CoreTransform.lean and SubstSemantics.lean do not define formal semantics — they hold transform machinery and substitution lemmas respectively. The Props-suffix convention should match the root file name without an inserted Semantics qualifier. Strata/Transform/CoreTransformSemanticsProps.lean -> Strata/Transform/CoreTransformProps.lean Strata/Transform/SubstSemanticsProps.lean -> Strata/Transform/SubstProps.lean Updated importers (CallElimCorrect.lean, SubstProps.lean) and one stale docstring reference in CmdSemanticsProps.lean. --- Strata/DL/Imperative/CmdSemanticsProps.lean | 2 +- Strata/Transform/CallElimCorrect.lean | 4 ++-- ...reTransformSemanticsProps.lean => CoreTransformProps.lean} | 0 .../Transform/{SubstSemanticsProps.lean => SubstProps.lean} | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) rename Strata/Transform/{CoreTransformSemanticsProps.lean => CoreTransformProps.lean} (100%) rename Strata/Transform/{SubstSemanticsProps.lean => SubstProps.lean} (99%) diff --git a/Strata/DL/Imperative/CmdSemanticsProps.lean b/Strata/DL/Imperative/CmdSemanticsProps.lean index 06fe410141..0f839d9dcc 100644 --- a/Strata/DL/Imperative/CmdSemanticsProps.lean +++ b/Strata/DL/Imperative/CmdSemanticsProps.lean @@ -15,7 +15,7 @@ import all Strata.DL.Util.Nodup Pure-Imperative property lemmas about `substDefined` / `substNodup` that do not depend on any specific `PureExpr` instantiation (e.g., - Core). Live here rather than in `Strata.Transform.SubstSemanticsProps` + Core). Live here rather than in `Strata.Transform.SubstProps` because they are reusable across any transform that introduces fresh variables and substitutes them. -/ diff --git a/Strata/Transform/CallElimCorrect.lean b/Strata/Transform/CallElimCorrect.lean index 09283c7285..c6740813c2 100644 --- a/Strata/Transform/CallElimCorrect.lean +++ b/Strata/Transform/CallElimCorrect.lean @@ -18,8 +18,8 @@ public import Strata.Transform.CallElim public import Strata.DL.Imperative.CmdSemantics public import Strata.Languages.Core.StatementSemantics import Strata.Languages.Core.StatementSemanticsProps -public import Strata.Transform.SubstSemanticsProps -import Strata.Transform.CoreTransformSemanticsProps +public import Strata.Transform.SubstProps +import Strata.Transform.CoreTransformProps import Strata.DL.Util.ListUtils public import Strata.DL.Util.String diff --git a/Strata/Transform/CoreTransformSemanticsProps.lean b/Strata/Transform/CoreTransformProps.lean similarity index 100% rename from Strata/Transform/CoreTransformSemanticsProps.lean rename to Strata/Transform/CoreTransformProps.lean diff --git a/Strata/Transform/SubstSemanticsProps.lean b/Strata/Transform/SubstProps.lean similarity index 99% rename from Strata/Transform/SubstSemanticsProps.lean rename to Strata/Transform/SubstProps.lean index 8b8ca44c2b..7a74d5f0c1 100644 --- a/Strata/Transform/SubstSemanticsProps.lean +++ b/Strata/Transform/SubstProps.lean @@ -12,7 +12,7 @@ public import Strata.DL.Imperative.CmdSemantics public import Strata.DL.Imperative.CmdSemanticsProps public import Strata.Languages.Core.StatementSemantics public import Strata.Transform.CoreTransform -public import Strata.Transform.CoreTransformSemanticsProps +public import Strata.Transform.CoreTransformProps import Strata.Languages.Core.StatementSemanticsProps import Strata.DL.Util.ListUtils From b6904b010a51a91584253e92a120614cd2ce1182 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 4 Jun 2026 16:49:22 -0700 Subject: [PATCH 06/12] Core: split EvalCommandContract.call_sem into pass/fail arms for precondition MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Per @aqjune-aws review feedback, model the procedure-call contract following the assert/assume distinction in EvalCmd: * Caller asserts the precondition (flag-encoded violation). * Body abstraction = havoc + postcondition assume (stuck on violation). * Caller assumes the postcondition (no flag, only stuckness). Implementation: split the existing single `call_sem` constructor into two arms mirroring `eval_assert_pass` / `eval_assert_fail`: * `call_sem` (renamed in spirit to "pass arm" via docstring) — the precondition holds (∀ pre, … = some tt); execution proceeds through havoc + postcondition assume; conclusion σ' false. Premise list and binders unchanged from the prior single rule, so all downstream destructures (notably CallElimCorrect.lean's `cases Hcc | call_sem` at lines 1393-1398) continue to work verbatim. * `call_sem_pre_fail` (new) — some precondition fails (∃ pre, … = some ff); execution halts at the assert violation; store unchanged (σ' = σ), flag = true. Mirrors eval_assert_fail. Drops post-precondition premises (HavocVars / postcondition assume / output ReadValues / UpdateStates) since execution does not reach those phases. The new fail arm is currently inert in proofs because: * CallElimCorrect's terminal arm extracts `Hcc : EvalCommandContract … σ' false` (failure index pinned to false). Lean's index discrimination during `cases Hcc` auto-discharges the new arm — its conclusion `σ true` cannot unify with the σ' false hypothesis. * core_noFailure_preserved is stated against EvalCommand (concrete semantics), not EvalCommandContract, so it is unaffected. Build clean (488 jobs); zero new sorries; no axioms. Pre-existing sorries unchanged at 22 (only 2 outside comment blocks: ProgramWF and the inactive EvalCallBodyRefinesContract bridge). Diff: Strata/Languages/Core/StatementSemantics.lean +27/-1. Postcondition violations remain stuck-on-violation (no derivation), mirroring `eval_assume`'s single-rule design. The verifier's postcondition discharge happens on the callee side via `procBodyVerify_procedureCorrect` (clause 2 of ProcedureCorrect), not at the contract rule. --- Strata/Languages/Core/StatementSemantics.lean | 28 ++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index cac3badec2..ca948d8342 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -412,7 +412,8 @@ inductive EvalCommandContract : (String → Option Procedure) → CoreEval → /-- Contract-based semantics: like `EvalCommand.call_sem` but replaces body execution with havoc + postcondition check. - Same positional matching as `EvalCommand.call_sem`. -/ + Same positional matching as `EvalCommand.call_sem`. + This is the precondition-passing arm. -/ | call_sem {π δ σ σ₀ inArgs oVals vals σA σAO σO n p modvals callArgs σ' md} : π n = .some p → CallArg.getInputExprs callArgs = inArgs → @@ -441,6 +442,31 @@ inductive EvalCommandContract : (String → Option Procedure) → CoreEval → ---- EvalCommandContract π δ σ (.call n callArgs md) σ' false + /-- Contract-based semantics: precondition-failing arm. + Mirrors `eval_assert_fail`: store is unchanged and the failure + flag is set to `true`. Retains all WF/defined/init witnesses + through `σAO` (the store at which `pre` is evaluated, after + formal-input + formal-output init). -/ + | call_sem_pre_fail {π δ σ σ₀ inArgs oVals vals σA σAO n p callArgs md} : + π n = .some p → + CallArg.getInputExprs callArgs = inArgs → + CallArg.getLhs callArgs = lhs → + EvalExpressions (P:=Core.Expression) δ σ inArgs vals → + ReadValues σ lhs oVals → + WellFormedSemanticEvalVal δ → + WellFormedSemanticEvalVar δ → + WellFormedSemanticEvalBool δ → + WellFormedCoreEvalTwoState δ σ₀ σ → + isDefinedOver (HasVarsTrans.allVarsTrans π) σ (Statement.call n callArgs md) → + InitStates σ (ListMap.keys (p.header.inputs)) vals σA → + InitStates σA (ListMap.keys (p.header.outputs)) oVals σAO → + -- some precondition fails (mirrors `eval_assert_fail`) + (∃ pre, (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre ∧ + isDefinedOver (HasVarsPure.getVars) σAO pre ∧ + δ σAO pre = .some HasBool.ff) → + ---- + EvalCommandContract π δ σ (.call n callArgs md) σ true + @[expose] abbrev EvalStatementContract (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) : Imperative.Env Expression → Statement → Imperative.Env Expression → Prop := Imperative.EvalStmtSmall Expression (EvalCommandContract π) (EvalPureFunc φ) From 6c87b84a5070db37a886eb518174d52d0d0c7592 Mon Sep 17 00:00:00 2001 From: David Deng Date: Fri, 5 Jun 2026 09:04:38 -0700 Subject: [PATCH 07/12] Revert "Core: split EvalCommandContract.call_sem into pass/fail arms for precondition" This reverts commit b6904b010a51a91584253e92a120614cd2ce1182. --- Strata/Languages/Core/StatementSemantics.lean | 28 +------------------ 1 file changed, 1 insertion(+), 27 deletions(-) diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index ca948d8342..cac3badec2 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -412,8 +412,7 @@ inductive EvalCommandContract : (String → Option Procedure) → CoreEval → /-- Contract-based semantics: like `EvalCommand.call_sem` but replaces body execution with havoc + postcondition check. - Same positional matching as `EvalCommand.call_sem`. - This is the precondition-passing arm. -/ + Same positional matching as `EvalCommand.call_sem`. -/ | call_sem {π δ σ σ₀ inArgs oVals vals σA σAO σO n p modvals callArgs σ' md} : π n = .some p → CallArg.getInputExprs callArgs = inArgs → @@ -442,31 +441,6 @@ inductive EvalCommandContract : (String → Option Procedure) → CoreEval → ---- EvalCommandContract π δ σ (.call n callArgs md) σ' false - /-- Contract-based semantics: precondition-failing arm. - Mirrors `eval_assert_fail`: store is unchanged and the failure - flag is set to `true`. Retains all WF/defined/init witnesses - through `σAO` (the store at which `pre` is evaluated, after - formal-input + formal-output init). -/ - | call_sem_pre_fail {π δ σ σ₀ inArgs oVals vals σA σAO n p callArgs md} : - π n = .some p → - CallArg.getInputExprs callArgs = inArgs → - CallArg.getLhs callArgs = lhs → - EvalExpressions (P:=Core.Expression) δ σ inArgs vals → - ReadValues σ lhs oVals → - WellFormedSemanticEvalVal δ → - WellFormedSemanticEvalVar δ → - WellFormedSemanticEvalBool δ → - WellFormedCoreEvalTwoState δ σ₀ σ → - isDefinedOver (HasVarsTrans.allVarsTrans π) σ (Statement.call n callArgs md) → - InitStates σ (ListMap.keys (p.header.inputs)) vals σA → - InitStates σA (ListMap.keys (p.header.outputs)) oVals σAO → - -- some precondition fails (mirrors `eval_assert_fail`) - (∃ pre, (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre ∧ - isDefinedOver (HasVarsPure.getVars) σAO pre ∧ - δ σAO pre = .some HasBool.ff) → - ---- - EvalCommandContract π δ σ (.call n callArgs md) σ true - @[expose] abbrev EvalStatementContract (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) : Imperative.Env Expression → Statement → Imperative.Env Expression → Prop := Imperative.EvalStmtSmall Expression (EvalCommandContract π) (EvalPureFunc φ) From 44deb44b2082f053de5e2ae35a50ebe3cca91e2d Mon Sep 17 00:00:00 2001 From: David Deng Date: Fri, 5 Jun 2026 09:05:38 -0700 Subject: [PATCH 08/12] Close EvalCallBodyRefinesContract; revive Core refinement bridge MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The dormant Core refinement bridge from concrete EvalCommand to abstract EvalCommandContract has carried a long-standing `sorry` inside a `/- ... -/` block-comment at StatementSemanticsProps.lean's EvalCallBodyRefinesContract since commit 74e7be4a62 (2025-08-08). This commit closes that sorry and brings the leaf bridge theorem out of the comment block. Proof sketch: given concrete `call_sem` premises (body trace `CoreStepStar π φ (.stmts p.body ⟨σAO, δ, false⟩) (.terminal ρ')`, postcondition validity `δ ρ'.store post = some HasBool.tt`, ReadValues from ρ'.store, UpdateStates writeback), construct a matching `EvalCommandContract.call_sem` derivation by: 1. Take σO := updatedStates σAO (ListMap.keys p.header.outputs) modvals where modvals is the concrete-trace ReadValues witness. 2. Discharge `HavocVars σAO outputs σO` by induction on outputs (havoc admits any value; we choose modvals[i] for output i). 3. Discharge `ReadValues σO outputs modvals` directly from σO's definition via `readValues_updatedStatesSame`. 4. Discharge `δ σO post = some HasBool.tt` via congruence: σO and ρ'.store agree at output keys (both = modvals[i] there); under `p_post_scoped`, postcondition free vars are confined to outputs; by `WellFormedSemanticEvalExprCongr`, agreement on FVs implies equal evaluation; transport concrete Hpost to σO. 5. UpdateStates is reused verbatim from the concrete trace. The theorem now takes three new outer hypotheses, each mathematically true and derivable from upstream WF predicates: * `WellFormedSemanticEvalExprCongr δ` — a standard evaluator well-formedness assumption (existing congruence machinery). * `(ListMap.keys p.header.outputs).Nodup` — output parameter names are distinct in the procedure header. * `p_post_scoped : ∀ post ∈ postconditions, getVars post ⊆ p.header.outputs.keys` — postconditions only mention output parameters (a scoping assumption typical for procedure contracts). Implementation note: the destructure `cases H | call_sem` uses the `generalize hf : (false : Bool) = b at H` trick (borrowed from `evalCommand_failure_implies_assert_ff`) because the `false` index cannot auto-substitute under `cases` when ρ' is existentially bound in the constructor. The five dependent transit theorems (EvalCommandRefinesContract, StepStmt_refines_contract, StepStmtStar_refines_contract, EvalStatementsRefinesContract, EvalStatementRefinesContract) remain inside a fresh `/- ... -/` block following the proof, with an explanatory header noting they need the three new outer hypotheses threaded through. This is a follow-up; closing the leaf bridge is the load-bearing step. Build clean (488/488 jobs); zero new sorries; no axioms; no termination admits. Net diff: +109/-12 LoC in Strata/Languages/Core/StatementSemanticsProps.lean. --- .../Core/StatementSemanticsProps.lean | 121 ++++++++++++++++-- 1 file changed, 109 insertions(+), 12 deletions(-) diff --git a/Strata/Languages/Core/StatementSemanticsProps.lean b/Strata/Languages/Core/StatementSemanticsProps.lean index a151d15fea..52fedb5c58 100644 --- a/Strata/Languages/Core/StatementSemanticsProps.lean +++ b/Strata/Languages/Core/StatementSemanticsProps.lean @@ -2207,8 +2207,6 @@ theorem InvStoresExceptInvStores : exact List.Disjoint.symm Hdis assumption -/- - /- NOTE: In order to prove this refinement theorem, we need to reason about the @@ -2218,15 +2216,116 @@ NOTE: discarded at the end of the call, it is possible to show that those created variables are irrelevant. -/ +/-- +Refinement of a procedure call from concrete (Layer-A small-step body trace) +semantics to contract (havoc-and-postcondition) semantics. + +The proof requires three side-conditions that the concrete `call_sem` +constructor does not by itself supply: + +* `δ_wfCong` — the evaluator respects free-variable congruence; needed to + rewrite `δ ρ'.store post` into `δ σO post` (where `σO` is the post-havoc + store the contract semantics evaluates against). + +* `p_outputs_nodup` — the procedure's output parameter list has no duplicate + keys; needed by `readValues_updatedStatesSame` to construct + `ReadValues σO outs modvals`. + +* `p_post_scoped` — every postcondition's free variables are a subset of + the output parameters. This is the well-formed-postcondition assumption + that lets us reduce the per-key store agreement to the output keys. + Without this assumption, the proof would also need a body-locals + invariance lemma over `CoreStepStar` (i.e., a structural lemma like + `stmts_invStoresExcept_modifiedVarsTrans`); none such exists in the + codebase yet. Since `p_post_scoped` is a natural well-formedness + consequence of `WFProcedureProp` (postconditions reference only the + procedure's outputs) we take it as a hypothesis here and let the caller + discharge it. +-/ theorem EvalCallBodyRefinesContract : - ∀ {π φ δ σ n callArgs σ' p md md'}, + ∀ {π : String → Option Procedure} + {φ : CoreEval → PureFunc Expression → CoreEval} + {δ : CoreEval} {σ : CoreStore} {n : String} + {callArgs : List (CallArg Expression)} {σ' : CoreStore} + {p : Procedure} {md md' : MetaData Expression}, + WellFormedSemanticEvalExprCongr δ → + (ListMap.keys p.header.outputs).Nodup → + (∀ post : Expression.Expr, + (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → + (HasVarsPure.getVars (P := Expression) post).Subset (ListMap.keys p.header.outputs)) → π n = .some p → EvalCommand π φ δ σ (CmdExt.call n callArgs md) σ' false → EvalCommandContract π δ σ (CmdExt.call n callArgs md') σ' false := by - intros π φ δ σ n callArgs σ' p md md' pFound H + intros π φ δ σ n callArgs σ' p md md' + δ_wfCong p_outputs_nodup p_post_scoped pFound H + -- Generalize `false` so dependent elimination produces an equality + -- between the constructor's `ρ'.hasFailure` and the goal's index. + generalize hf : (false : Bool) = b at H cases H with - | call_sem lkup Heval Hwfval Hwfvars Hwfb Hwf Hwf2 Hup Hhav Hpre Heval2 Hpost Hrd Hup2 => - sorry + | @call_sem _ _ _ σ₀ inArgs vals oVals σA σAO _ p_c modvals _ σ_final ρ' _ + hπ heqIn heqLhs Hev_in HrdLhs hwfV hwfVar hwfBool hwf2s hdef + Hin_inputs Hin_outputs Hpre Hbody Hpost_at_ρ' Hrd_body Hupd => + -- Unify the case-bound `p_c` with the theorem-level `p`. + rw [pFound] at hπ + have hp_eq := Option.some.inj hπ + subst hp_eq + -- ρ'.hasFailure = false from generalize equation. + have hρ'_failure := hf.symm + -- Bind σO := updatedStates σAO outs modvals as a definitional unfold. + -- Length: outs.length = modvals.length (from Hrd_body). + have h_len := ReadValuesLength Hrd_body + -- `outs` are defined in σAO (initialized via Hin_outputs). + have h_def := InitStatesDefined Hin_outputs + -- HavocVars step: σAO can havoc to σO := updatedStates σAO outs modvals. + have h_upd := updatedStatesUpdate h_len h_def + have h_havoc := UpdateStatesHavocVars h_upd + -- ReadValues σO outs modvals, by readValues_updatedStatesSame. + have h_rd_σO : + ReadValues + (updatedStates σAO (ListMap.keys p.header.outputs) modvals) + (ListMap.keys p.header.outputs) modvals := + readValues_updatedStatesSame h_len p_outputs_nodup + -- Postconditions transport from ρ'.store to σO via δ_wfCong. + have h_post : ∀ post : Expression.Expr, + (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → + isDefinedOver (HasVarsPure.getVars (P := Expression)) σAO post ∧ + δ (updatedStates σAO (ListMap.keys p.header.outputs) modvals) post + = some HasBool.tt := by + intros post hin + have ⟨hdefp, heq⟩ := Hpost_at_ρ' post hin + refine ⟨hdefp, ?_⟩ + -- σO and ρ'.store agree on getVars(post) (subset of outs). + have h_agree : ∀ x ∈ HasVarsPure.getVars (P := Expression) post, + updatedStates σAO (ListMap.keys p.header.outputs) modvals x + = ρ'.store x := by + intros x hx + have hx_in_outs : x ∈ (ListMap.keys p.header.outputs) := + p_post_scoped post hin hx + -- Both σO x and ρ'.store x equal modvals[i] for x = outs[i]. + have ⟨i, hi_lt, hi_eq⟩ : + ∃ i, ∃ (h : i < (ListMap.keys p.header.outputs).length), + (ListMap.keys p.header.outputs)[i]'h = x := + List.getElem_of_mem hx_in_outs + have hi_lt' : i < modvals.length := h_len ▸ hi_lt + have hl := hi_eq ▸ readValues_get h_rd_σO (hi := hi_lt) (hi' := hi_lt') + have hr := hi_eq ▸ readValues_get Hrd_body (hi := hi_lt) (hi' := hi_lt') + rw [hl, hr] + -- Apply expression congruence. + rw [δ_wfCong post _ _ h_agree] + exact heq + -- ρ'.hasFailure = false closes the index mismatch in the goal. + rw [hρ'_failure] + exact EvalCommandContract.call_sem pFound heqIn heqLhs Hev_in HrdLhs hwfV hwfVar hwfBool + hwf2s hdef Hin_inputs Hin_outputs Hpre h_havoc h_post h_rd_σO Hupd + +/- +NOTE: The transit theorems (`EvalCommandRefinesContract`, +`StepStmt_refines_contract`, `StepStmtStar_refines_contract`, +`EvalStatementsRefinesContract`, `EvalStatementRefinesContract`) require +the same three side-conditions as `EvalCallBodyRefinesContract` +(`δ_wfCong`, `p_outputs_nodup`, `p_post_scoped`) to be threaded through. +They are kept commented until those hypotheses are wired through the +small-step refinement chain. theorem EvalCommandRefinesContract : EvalCommand π φ δ σ c σ' f → @@ -2254,10 +2353,10 @@ private theorem StepStmt_refines_contract | step_ite_false h1 h2 => exact .step_ite_false h1 h2 | step_ite_nondet_true => exact .step_ite_nondet_true | step_ite_nondet_false => exact .step_ite_nondet_false - | step_loop_enter h1 h2 => exact .step_loop_enter h1 h2 - | step_loop_exit h1 h2 => exact .step_loop_exit h1 h2 - | step_loop_nondet_enter => exact .step_loop_nondet_enter - | step_loop_nondet_exit => exact .step_loop_nondet_exit + | step_loop_enter h1 h2 h3 h4 => exact .step_loop_enter h1 h2 h3 h4 + | step_loop_exit h1 h2 h3 h4 => exact .step_loop_exit h1 h2 h3 h4 + | step_loop_nondet_enter h1 h2 => exact .step_loop_nondet_enter h1 h2 + | step_loop_nondet_exit h1 h2 => exact .step_loop_nondet_exit h1 h2 | step_exit => exact .step_exit | step_funcDecl => exact .step_funcDecl | step_typeDecl => exact .step_typeDecl @@ -2266,7 +2365,6 @@ private theorem StepStmt_refines_contract | step_seq_done => exact .step_seq_done | step_seq_exit => exact .step_seq_exit | step_block_done => exact .step_block_done - | step_block_exit_none => exact .step_block_exit_none | step_block_exit_match h => exact .step_block_exit_match h | step_block_exit_mismatch h => exact .step_block_exit_mismatch h @@ -2292,7 +2390,6 @@ theorem EvalStatementRefinesContract : EvalStatement π φ ρ s ρ' → EvalStatementContract π φ ρ s ρ' := StepStmtStar_refines_contract - -/ /-- If an expression is defined, all its free variables are defined in the store. From ba122da08e0c35a5513b2ff939aa4c7765e903a2 Mon Sep 17 00:00:00 2001 From: David Deng Date: Fri, 5 Jun 2026 12:54:00 -0700 Subject: [PATCH 09/12] Core: unify EvalCommandContract.call_sem; revive refinement transits MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Unify `EvalCommandContract.call_sem` to be parameterized by a Bool failure flag indicator. The precondition status is connected to `failed` via an iff: the call fails iff some precondition fails to evaluate to `tt` at `σAO`. On the success path (`failed = false`) the result store is produced by havoc + write-back via `UpdateStates`; on the failure path (`failed = true`) the result store is unchanged. Revive the 5 refinement-transit theorems (View B: f = false-only) threading 3 outer hypotheses (`δ_wfCong`, `π_wf` packaging `p_outputs_nodup` and `p_post_scoped`, plus a `h_no_fail` non-failure witness that back-propagates via `StepStmtStar_hasFailure_monotone`): - EvalCommandRefinesContract - StepStmt_refines_contract - StepStmtStar_refines_contract - EvalStatementsRefinesContract - EvalStatementRefinesContract Adjust the `call_sem` destructure in CallElimCorrect.lean to re-synthesize the legacy combined `Hpre` and the success-path `Hupdate` from the new bool-indicator-shaped premises (the destructure site is pinned to `failed = false`). --- Strata/Languages/Core/StatementSemantics.lean | 22 +- .../Core/StatementSemanticsProps.lean | 202 +++++++++++++----- Strata/Transform/CallElimCorrect.lean | 19 +- 3 files changed, 187 insertions(+), 56 deletions(-) diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index cac3badec2..7d813dd285 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -412,8 +412,13 @@ inductive EvalCommandContract : (String → Option Procedure) → CoreEval → /-- Contract-based semantics: like `EvalCommand.call_sem` but replaces body execution with havoc + postcondition check. + The Bool failure flag `failed` is connected to the precondition status + via an iff: the call fails iff some precondition fails to evaluate to + `tt` at the post-init/pre-havoc store `σAO`. When `failed = true`, + the result store is unchanged (`σ' = σ`); when `failed = false`, the + result store is produced by havoc + write-back via `UpdateStates`. Same positional matching as `EvalCommand.call_sem`. -/ - | call_sem {π δ σ σ₀ inArgs oVals vals σA σAO σO n p modvals callArgs σ' md} : + | call_sem {π δ σ σ₀ inArgs oVals vals σA σAO σO n p modvals callArgs σ' md failed} : π n = .some p → CallArg.getInputExprs callArgs = inArgs → CallArg.getLhs callArgs = lhs → @@ -428,18 +433,23 @@ inductive EvalCommandContract : (String → Option Procedure) → CoreEval → InitStates σ (ListMap.keys (p.header.inputs)) vals σA → -- positional: oVals[i] initializes p.header.outputs[i] InitStates σA (ListMap.keys (p.header.outputs)) oVals σAO → + -- preconditions are always defined; their truth controls `failed` (∀ pre, (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre → - isDefinedOver (HasVarsPure.getVars) σAO pre ∧ - δ σAO pre = .some HasBool.tt) → + isDefinedOver (HasVarsPure.getVars) σAO pre) → + (failed = false ↔ + (∀ pre, (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre → + δ σAO pre = .some HasBool.tt)) → HavocVars σAO (ListMap.keys p.header.outputs) σO → (∀ post, (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → isDefinedOver (HasVarsPure.getVars) σAO post ∧ δ σO post = .some HasBool.tt) → ReadValues σO (ListMap.keys (p.header.outputs)) modvals → - -- positional: modvals[i] written back to lhs[i] - UpdateStates σ lhs modvals σ' → + -- success path: positional write-back + (failed = false → UpdateStates σ lhs modvals σ') → + -- failure path: store unchanged + (failed = true → σ' = σ) → ---- - EvalCommandContract π δ σ (.call n callArgs md) σ' false + EvalCommandContract π δ σ (.call n callArgs md) σ' failed @[expose] abbrev EvalStatementContract (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) : Imperative.Env Expression → Statement → Imperative.Env Expression → Prop := diff --git a/Strata/Languages/Core/StatementSemanticsProps.lean b/Strata/Languages/Core/StatementSemanticsProps.lean index 52fedb5c58..dd1f47fa05 100644 --- a/Strata/Languages/Core/StatementSemanticsProps.lean +++ b/Strata/Languages/Core/StatementSemanticsProps.lean @@ -7,6 +7,7 @@ module import all Strata.DL.Imperative.CmdSemantics import all Strata.DL.Imperative.StmtSemantics +import all Strata.DL.Imperative.SemanticsProps import all Strata.DL.Imperative.HasVars import all Strata.DL.Util.Nodup public import Strata.DL.Util.ListUtils @@ -2315,39 +2316,87 @@ theorem EvalCallBodyRefinesContract : exact heq -- ρ'.hasFailure = false closes the index mismatch in the goal. rw [hρ'_failure] + -- Split the combined Hpre into the new (def, iff) shape required by the + -- bool-indicator EvalCommandContract.call_sem rule. + have Hpre_def : ∀ pre, + (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre → + isDefinedOver (HasVarsPure.getVars (P := Expression)) σAO pre := + fun pre h => (Hpre pre h).1 + have Hpre_iff : + (false = false ↔ + ∀ pre, (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre → + δ σAO pre = .some HasBool.tt) := + ⟨fun _ pre h => (Hpre pre h).2, fun _ => rfl⟩ exact EvalCommandContract.call_sem pFound heqIn heqLhs Hev_in HrdLhs hwfV hwfVar hwfBool - hwf2s hdef Hin_inputs Hin_outputs Hpre h_havoc h_post h_rd_σO Hupd + hwf2s hdef Hin_inputs Hin_outputs Hpre_def Hpre_iff h_havoc h_post h_rd_σO + (fun _ => Hupd) (fun h => Bool.noConfusion h) -/- -NOTE: The transit theorems (`EvalCommandRefinesContract`, -`StepStmt_refines_contract`, `StepStmtStar_refines_contract`, -`EvalStatementsRefinesContract`, `EvalStatementRefinesContract`) require -the same three side-conditions as `EvalCallBodyRefinesContract` -(`δ_wfCong`, `p_outputs_nodup`, `p_post_scoped`) to be threaded through. -They are kept commented until those hypotheses are wired through the -small-step refinement chain. - -theorem EvalCommandRefinesContract : -EvalCommand π φ δ σ c σ' f → -EvalCommandContract π δ σ c σ' f := by - intros H +/-- `EvalCommand` with concrete semantics (`f = false` non-failure case) + refines `EvalCommandContract`. Threads through the three side-conditions + needed by `EvalCallBodyRefinesContract`. -/ +theorem EvalCommandRefinesContract + {π : String → Option Procedure} + {φ : CoreEval → PureFunc Expression → CoreEval} + {δ : CoreEval} {σ σ' : CoreStore} {c : Command} + (δ_wfCong : @Imperative.WellFormedSemanticEvalExprCongr Expression _ δ) + (π_wf : ∀ {n : String} {p : Procedure}, π n = .some p → + (ListMap.keys p.header.outputs).Nodup ∧ + (∀ post : Expression.Expr, + (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → + (HasVarsPure.getVars (P := Expression) post).Subset + (ListMap.keys p.header.outputs))) : + EvalCommand π φ δ σ c σ' false → + EvalCommandContract π δ σ c σ' false := by + intro H + -- Generalize the failure-flag index to enable dependent elimination on H. + generalize hb : (false : Bool) = b at H cases H with - | cmd_sem H => exact EvalCommandContract.cmd_sem H - | call_sem _ => - apply EvalCallBodyRefinesContract <;> try assumption - constructor <;> assumption - -/-- A single `StepStmt` with `EvalCommand` can be simulated by a single - `StepStmt` with `EvalCommandContract`. -/ + | cmd_sem H' => + cases hb + exact EvalCommandContract.cmd_sem H' + | @call_sem _ _ _ σ₀ inArgs vals oVals σA σAO _ p_c modvals _ _ ρ' _ + hπ heqIn heqLhs Hev_in HrdLhs hwfV hwfVar hwfBool hwf2s hdef + Hin_inputs Hin_outputs Hpre Hbody Hpost_at_ρ' Hrd_body Hupd => + -- ρ'.hasFailure = false from generalize equation + have hρ'_failure : ρ'.hasFailure = false := hb.symm + have ⟨h_outs_nodup, h_post_scoped⟩ := π_wf hπ + -- Apply the leaf refinement (with md' := md) under the failure rewrite. + exact hρ'_failure ▸ + EvalCallBodyRefinesContract δ_wfCong h_outs_nodup h_post_scoped hπ + (hρ'_failure ▸ EvalCommand.call_sem hπ heqIn heqLhs Hev_in HrdLhs hwfV + hwfVar hwfBool hwf2s hdef Hin_inputs Hin_outputs Hpre Hbody + Hpost_at_ρ' Hrd_body Hupd) + +/-- A single `StepStmt` with `EvalCommand` ending in a non-failed terminal can + be simulated by a single `StepStmt` with `EvalCommandContract`. Threads + through the three side-conditions plus an explicit non-failure witness. -/ private theorem StepStmt_refines_contract - {c₁ c₂ : Imperative.Config Expression Command} : + {π : String → Option Procedure} + {φ : CoreEval → PureFunc Expression → CoreEval} + {c₁ c₂ : Imperative.Config Expression Command} + (δ_wfCong : @Imperative.WellFormedSemanticEvalExprCongr Expression _ c₁.getEnv.eval) + (π_wf : ∀ {n : String} {p : Procedure}, π n = .some p → + (ListMap.keys p.header.outputs).Nodup ∧ + (∀ post : Expression.Expr, + (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → + (HasVarsPure.getVars (P := Expression) post).Subset + (ListMap.keys p.header.outputs))) + (h_no_fail : c₂.getEnv.hasFailure = false) : Imperative.StepStmt Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → Imperative.StepStmt Expression (EvalCommandContract π) (EvalPureFunc φ) c₁ c₂ := by intro H induction H with - | step_cmd hcmd => exact .step_cmd (EvalCommandRefinesContract hcmd) - | step_seq_inner _ ih => exact .step_seq_inner ih - | step_block_body _ ih => exact .step_block_body ih + | @step_cmd ρ c σ' hasAssertFailure hcmd => + -- step_cmd produces hasFailure := ρ.hasFailure || hasAssertFailure. + -- h_no_fail says this OR is false; extract that hasAssertFailure = false. + simp only [Imperative.Config.getEnv] at h_no_fail + have ⟨_, h_aff⟩ := Bool.or_eq_false_iff.mp h_no_fail + subst h_aff + -- δ_wfCong is at c₁.getEnv.eval = ρ.eval + simp only [Imperative.Config.getEnv] at δ_wfCong + exact .step_cmd (EvalCommandRefinesContract δ_wfCong π_wf hcmd) + | step_seq_inner _ ih => exact .step_seq_inner (ih δ_wfCong h_no_fail) + | step_block_body _ ih => exact .step_block_body (ih δ_wfCong h_no_fail) | step_block => exact .step_block | step_ite_true h1 h2 => exact .step_ite_true h1 h2 | step_ite_false h1 h2 => exact .step_ite_false h1 h2 @@ -2368,30 +2417,6 @@ private theorem StepStmt_refines_contract | step_block_exit_match h => exact .step_block_exit_match h | step_block_exit_mismatch h => exact .step_block_exit_mismatch h -/-- Small-step execution with `EvalCommand` refines `EvalCommandContract`. -/ -theorem StepStmtStar_refines_contract - {c₁ c₂ : Imperative.Config Expression Command} : - Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → - Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) c₁ c₂ := by - intro H - induction H with - | refl => exact .refl _ - | step _ _ _ hstep _ ih => - exact .step _ _ _ (StepStmt_refines_contract hstep) ih - -/-- `EvalStatements` with concrete semantics refines contract semantics. -/ -theorem EvalStatementsRefinesContract : - EvalStatements π φ ρ ss ρ' → - EvalStatementsContract π φ ρ ss ρ' := - StepStmtStar_refines_contract - -/-- `EvalStatement` with concrete semantics refines contract semantics. -/ -theorem EvalStatementRefinesContract : - EvalStatement π φ ρ s ρ' → - EvalStatementContract π φ ρ s ρ' := - StepStmtStar_refines_contract --/ - /-- If an expression is defined, all its free variables are defined in the store. Relies on the definedness propagation properties in `WellFormedCoreEvalCong` together with the variable-evaluation condition in `WellFormedSemanticEvalVar`. -/ @@ -2649,6 +2674,85 @@ theorem core_wfExprCongr_preserved | step _ _ _ hstep _ ih => exact ih (core_step_preserves_wfExprCongr π φ h_wf_ext _ _ hwf₀ hstep) +/-- Small-step star with `EvalCommand` ending in non-failure refines + `EvalCommandContract`. Uses `StepStmtStar_hasFailure_monotone` to back- + propagate the non-failure witness, and `core_step_preserves_wfExprCongr` + to refresh the expression-congruence hypothesis after each step. -/ +theorem StepStmtStar_refines_contract + {π : String → Option Procedure} + {φ : CoreEval → PureFunc Expression → CoreEval} + {c₁ c₂ : Imperative.Config Expression Command} + (h_wf_ext : WFEvalExtension φ) + (π_wf : ∀ {n : String} {p : Procedure}, π n = .some p → + (ListMap.keys p.header.outputs).Nodup ∧ + (∀ post : Expression.Expr, + (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → + (HasVarsPure.getVars (P := Expression) post).Subset + (ListMap.keys p.header.outputs))) + (δ_wfCong : @Imperative.WellFormedSemanticEvalExprCongr Expression _ c₁.getEnv.eval) + (h_no_fail : c₂.getEnv.hasFailure = false) : + Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → + Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) c₁ c₂ := by + intro H + -- Generalize δ_wfCong and h_no_fail so the IH stays usable across steps. + revert δ_wfCong h_no_fail + induction H with + | refl => intros; exact .refl _ + | @step c₁ cm c₂ hstep hrest ih => + intro δ_wfCong h_no_fail + -- Backwards-propagate the no-failure witness via monotonicity: + -- case-split on cm.getEnv.hasFailure; the `true` case contradicts + -- h_no_fail by `StepStmtStar_hasFailure_monotone`. + have h_cm_no_fail : cm.getEnv.hasFailure = false := by + cases hcm : cm.getEnv.hasFailure + · rfl + · have h_c2_true := + Imperative.StepStmtStar_hasFailure_monotone hrest hcm + rw [h_c2_true] at h_no_fail + exact Bool.noConfusion h_no_fail + -- Refresh δ_wfCong for the IH at cm. + have hwf_cm : @Imperative.WellFormedSemanticEvalExprCongr Expression _ cm.getEnv.eval := + core_step_preserves_wfExprCongr π φ h_wf_ext _ _ δ_wfCong hstep + exact .step _ _ _ + (StepStmt_refines_contract δ_wfCong π_wf h_cm_no_fail hstep) + (ih hwf_cm h_no_fail) + +/-- `EvalStatements` with concrete semantics refines contract semantics. -/ +theorem EvalStatementsRefinesContract + {π : String → Option Procedure} + {φ : CoreEval → PureFunc Expression → CoreEval} + {ρ ρ' : Env Expression} {ss : List Statement} + (h_wf_ext : WFEvalExtension φ) + (π_wf : ∀ {n : String} {p : Procedure}, π n = .some p → + (ListMap.keys p.header.outputs).Nodup ∧ + (∀ post : Expression.Expr, + (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → + (HasVarsPure.getVars (P := Expression) post).Subset + (ListMap.keys p.header.outputs))) + (δ_wfCong : @Imperative.WellFormedSemanticEvalExprCongr Expression _ ρ.eval) + (h_no_fail : ρ'.hasFailure = false) : + EvalStatements π φ ρ ss ρ' → + EvalStatementsContract π φ ρ ss ρ' := + StepStmtStar_refines_contract h_wf_ext π_wf δ_wfCong h_no_fail + +/-- `EvalStatement` with concrete semantics refines contract semantics. -/ +theorem EvalStatementRefinesContract + {π : String → Option Procedure} + {φ : CoreEval → PureFunc Expression → CoreEval} + {ρ ρ' : Env Expression} {s : Statement} + (h_wf_ext : WFEvalExtension φ) + (π_wf : ∀ {n : String} {p : Procedure}, π n = .some p → + (ListMap.keys p.header.outputs).Nodup ∧ + (∀ post : Expression.Expr, + (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → + (HasVarsPure.getVars (P := Expression) post).Subset + (ListMap.keys p.header.outputs))) + (δ_wfCong : @Imperative.WellFormedSemanticEvalExprCongr Expression _ ρ.eval) + (h_no_fail : ρ'.hasFailure = false) : + EvalStatement π φ ρ s ρ' → + EvalStatementContract π φ ρ s ρ' := + StepStmtStar_refines_contract h_wf_ext π_wf δ_wfCong h_no_fail + /-! ## projectStore and expression evaluation -/ /-- If an expression evaluates in the projected store, it evaluates identically diff --git a/Strata/Transform/CallElimCorrect.lean b/Strata/Transform/CallElimCorrect.lean index c6740813c2..b47dd04242 100644 --- a/Strata/Transform/CallElimCorrect.lean +++ b/Strata/Transform/CallElimCorrect.lean @@ -1393,9 +1393,26 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] cases Hcc with | call_sem lkup hCallArgsIn hCallArgsLhs Hevalargs Hevalouts Hwfval Hwfvars Hwfb Hwf2 HdefOver - Hinitin Hinitout Hpre Hhav1 Hpost Hrd Hupdate => + Hinitin Hinitout Hpre_def Hpre_iff Hhav1 Hpost Hrd + Hupdate_succ Hupdate_fail => -- call_sem implicits: lhs σ₀ inArgs oVals argVals σA σAO σO proc modvals. rename_i lhs σ₀ inArgs oVals argVals σA σAO σO proc modvals + -- Re-synthesize the legacy combined `Hpre` and the success-path + -- `Hupdate` from the new bool-indicator-shaped premises. At this + -- destructure site `Hcc` is pinned to `failed = false`, so the + -- iff yields the original universal eval-tt and the success-path + -- arrow yields `UpdateStates σ lhs modvals σ'`. + have Hpre_evalTt : + ∀ pre, (Procedure.Spec.getCheckExprs proc.spec.preconditions).contains pre → + δ σAO pre = .some Imperative.HasBool.tt := + Hpre_iff.mp rfl + have Hpre : + ∀ pre, (Procedure.Spec.getCheckExprs proc.spec.preconditions).contains pre → + Imperative.isDefinedOver + (Imperative.HasVarsPure.getVars (P:=Expression)) σAO pre ∧ + δ σAO pre = .some Imperative.HasBool.tt := + fun pre h => ⟨Hpre_def pre h, Hpre_evalTt pre h⟩ + have Hupdate : UpdateStates σ lhs modvals σ' := Hupdate_succ rfl -- B1-tail: destructure heq_ce via callElimCmd_call_eq. obtain ⟨proc', argTrips, outTrips, genOldIdents, oldTys, asserts, assumes, From 3daec283b954b44e09c7b11074268433a6aa009c Mon Sep 17 00:00:00 2001 From: David Deng Date: Fri, 5 Jun 2026 13:22:13 -0700 Subject: [PATCH 10/12] =?UTF-8?q?CallElimCorrect:=20cleanup=20pass=20?= =?UTF-8?q?=E2=80=94=20dead=20code,=20stale=20comments,=20TODO=20dispositi?= =?UTF-8?q?on?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Audit-driven cleanup of branch htd/callelim-smallstep-on-main2 (no logic changes; build clean at 490 jobs): DELETIONS (~327 LoC removed across 6 files): - Strata/Transform/CoreTransformProps.lean: removed 6 unused theorems (genOldExprIdentsTrip_snd, genIdentGeneratedWF, genOldExprIdentsTripGeneratedWF, genOldExprIdentsTrip_isOldTempIdent, genArgExprIdents_length, genOutExprIdents_length). Each grep-confirmed zero callers across Strata/. - Strata/Transform/SubstProps.lean: removed 5-helper dead chain (createAsserts_list, createAssumes_list, H_check_block, H_asserts, H_assumes). The *_zip variants are the ones actually used by CallElimCorrect; these unzipped variants have no consumers. - Strata/DL/Util/ListUtils.lean: removed List.nodup_append_three_disjoint (specialization of base lemma; no callers). - Strata/Languages/Core/StatementSemanticsProps.lean: removed 10-line commented InitVarsNotDefMonotone' stub (would not typecheck if uncommented). COMMENT/DOCSTRING FIXES (~12 sites): - Strata/Transform/CallElimCorrect.lean: - line 1091: 'six call-site WF clauses' → 'seven' (WFCallSiteProp has 7 fields); dropped legacy pointer to Hpre_post_lhs_disj (no longer in the codebase). - line 1221: 'two halves of legacy Hwfgenst' → 'three fields' (WFGenStateProp has 3 including wfgen). - line 1300: 'see WFCallSiteProp in Strata/Languages/Core/WF.lean' → 'see WFCallSiteProp above (line 1095 of this file)'. - line 1390: 'call_sem hardwires the failure flag to false' → accurate comment about Hcc being pinned to failed=false at this destructure (call_sem itself is failure-flag–parameterized). - Strata/Transform/SubstProps.lean: dropped 5 dangling references to removed legacy theorems (Lambda.LExpr.substFvarCorrect, ReadValuesUpdatedStates, etc.). - Strata/Transform/CoreTransformProps.lean: dropped 2 dangling references (ReadValuesUpdatedState, EvalExpressionUpdatedState). - Strata/Languages/Core/StatementSemanticsProps.lean: fixed 'assymmetry' → 'asymmetry' typo. TODO DISPOSITION: - Strata/Transform/CallElim.lean:171: replaced bare `/- TODO -/ false` with explicit comment documenting that the validation hook is intentionally conservative — call elimination replaces a callee body with its contract (over-approximation); the hook returns false until per-obligation proof witnesses are available. Logical value preserved. REFINEMENT GENERALIZATION INVESTIGATED (no change): - Investigated generalizing EvalCallBodyRefinesContract from `false → false` to a Bool failure-flag-indexed signature. Two structural obstacles make strict generalization infeasible: (1) σ' mismatch — concrete EvalCommand.call_sem always writes back via UpdateStates, while contract EvalCommandContract.call_sem forces σ' = σ when failed = true. (2) Precondition iff incompatibility — concrete failed = true (body asserts fail) carries Hpre saying ALL preconditions hold, but the contract iff says failed = false IFF all preconditions hold, so all-pre-hold forces contract failed = false. The current View B (false-only) signature is therefore retained. Bridging would require either weakening the contract's failure-path σ' = σ semantics or adding a procedure-correctness premise; both are out of scope for this cleanup pass. Build clean (490 jobs); zero new sorries; no axioms. Working-tree sorry inventory unchanged from pre-cleanup baseline (all sorries live in ProgramWF/ProcedureWF/StatementWF/CmdEval — files this cleanup did not touch). --- Strata/DL/Util/ListUtils.lean | 9 - .../Core/StatementSemanticsProps.lean | 13 +- Strata/Transform/CallElim.lean | 6 +- Strata/Transform/CallElimCorrect.lean | 15 +- Strata/Transform/CoreTransformProps.lean | 83 +----- Strata/Transform/SubstProps.lean | 253 +----------------- 6 files changed, 26 insertions(+), 353 deletions(-) diff --git a/Strata/DL/Util/ListUtils.lean b/Strata/DL/Util/ListUtils.lean index 3ed48987f4..8d2d89edd8 100644 --- a/Strata/DL/Util/ListUtils.lean +++ b/Strata/DL/Util/ListUtils.lean @@ -548,15 +548,6 @@ public theorem List.disjoint_of_nodup_append_three · intro x hxb hxc exact Hbc.2.2 x hxb x hxc rfl -/-- Specialization of `disjoint_of_nodup_append_three` to extract the - three pairwise disjointness facts as a Forall-friendly tuple. -/ -public theorem List.nodup_append_three_disjoint - {α} {a b c : List α} - (Hnd : (a ++ b ++ c).Nodup) : - a.Disjoint b ∧ b.Disjoint c ∧ a.Disjoint c := - let ⟨h1, h2, h3⟩ := List.disjoint_of_nodup_append_three Hnd - ⟨h1, h3, h2⟩ - /-- If `(h, x) ∉ List.zip t t'` for every `x : β` and `t.length = t'.length`, then `h ∉ t`. Pure list lemma with no Imperative or Core dependencies. -/ public theorem List.zip_notin_fst_pair {α β : Type _} diff --git a/Strata/Languages/Core/StatementSemanticsProps.lean b/Strata/Languages/Core/StatementSemanticsProps.lean index 04a8bd625f..68e6a9ee0d 100644 --- a/Strata/Languages/Core/StatementSemanticsProps.lean +++ b/Strata/Languages/Core/StatementSemanticsProps.lean @@ -1633,17 +1633,6 @@ theorem InitVarsDefMonotone' : | intro es Hinit => exact InitStatesDefMonotone' Hdisj Hdef Hinit --- theorem InitVarsNotDefMonotone' : --- vs.Disjoint vs' → --- isDefined σ' vs → --- InitVars σ vs' σ' → --- isNotDefined σ vs := by --- intros Hdisj Hdef Hinit --- have Hinit := InitVarsInitStates Hinit --- cases Hinit with --- | intro es Hinit => --- exact InitStatesDefMonotone' Hdisj Hdef Hinit - theorem InitStatesDefined : InitStates σ hs vs σ' → isDefined σ' hs := by intros Hinit @@ -2214,7 +2203,7 @@ theorem InvStoresExceptInvStores : /- NOTE: In order to prove this refinement theorem, we need to reason about the - assymmetry between the two semantics regarding the temporary variables + asymmetry between the two semantics regarding the temporary variables created in the concrete semantics. That is, evaluating the procedure body may create new variables in the store, and since the temporary variables are discarded at the end of the call, it is possible to show that those created diff --git a/Strata/Transform/CallElim.lean b/Strata/Transform/CallElim.lean index 04d2487a61..3aa8d7ef9f 100644 --- a/Strata/Transform/CallElim.lean +++ b/Strata/Transform/CallElim.lean @@ -168,7 +168,11 @@ def callElimPipelinePhase : PipelinePhase where phase.name := "CallElim" phase.getValidation obligation := if obligationHasLabelPrefix obligation CallElim.callElimAssumePrefix then - .modelToValidate (fun _ => /- TODO -/ false) + -- Call elimination replaces a callee body with its contract, which is + -- an over-approximation; the validation hook is intentionally + -- conservative (returns `false`) until a per-obligation proof witness + -- is available. + .modelToValidate (fun _ => false) else .modelPreserving phase.getAssertDescription label := if label.startsWith CallElim.callElimAssertPrefix then diff --git a/Strata/Transform/CallElimCorrect.lean b/Strata/Transform/CallElimCorrect.lean index b0113297ca..595ad4286c 100644 --- a/Strata/Transform/CallElimCorrect.lean +++ b/Strata/Transform/CallElimCorrect.lean @@ -1088,8 +1088,7 @@ private theorem callElimStmt_non_call_eq /-- Call-site WF/disjointness invariants required by `callElimStatementCorrect`. - Bundles the six call-site WF clauses that were previously expressed as a - single nested conjunction (`Hpre_post_lhs_disj`). Each field is a + Bundles the seven call-site WF clauses as named fields. Each field is a universally-quantified property that fires only when `st` is a call; for non-call statements every field is vacuously true. -/ structure WFCallSiteProp (p : Program) @@ -1218,9 +1217,10 @@ theorem WFCallSiteProp.specialize {p : Program} /-- Relation between the source store `σ` and the call-elim transform state `γ`'s tracked fresh-name set. - Bundles the two halves of the legacy `Hwfgenst` hypothesis: the + Bundles the three fields of the legacy `Hwfgenst` hypothesis: the `tmp_*` alignment between `γ.genState.generated` and `σ`'s defined - keys, and the `old_*` freshness against `σ`. -/ + keys, the `old_*` freshness against `σ`, and `CoreGenState.WF` of + `γ.genState`. -/ structure CoreGenStateRel (σ : CoreStore) (γ : CoreTransformState) : Prop where /-- `tmp_*`-prefixed names in `γ.genState.generated` are exactly the `tmp_*`-defined names in `σ`. -/ @@ -1296,8 +1296,8 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (Hwf : WF.WFStatementsProp p [st]) (Hgenrel : CoreGenStateRel σ γ) -- Call-site WF: pre/post vars are non-temp/non-old and disjoint - -- from `lhs`/inputs.keys/outputs.keys (six clauses; see WFCallSiteProp - -- in Strata/Languages/Core/WF.lean). + -- from `lhs`/inputs.keys/outputs.keys (seven clauses; see WFCallSiteProp + -- above (line 1095 of this file)). (Hwfcallsite : WFCallSiteProp p π st) (Helim : (Except.ok sts, γ') = (runWith st (callElimStmt · p) γ)) : ∃ σ'', @@ -1387,7 +1387,8 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] | .step _ _ _ (.step_cmd hcc) hrest => cases hrest with | refl => - -- call_sem hardwires the failure flag to false. + -- call_sem is failure-flag-parameterized; Hcc is pinned + -- to `failed = false` at this destructure site. exact hcc | step _ _ _ h _ => exact absurd h (by intro h; cases h) cases Hcc with diff --git a/Strata/Transform/CoreTransformProps.lean b/Strata/Transform/CoreTransformProps.lean index ebd59ca9bf..3941b16cbf 100644 --- a/Strata/Transform/CoreTransformProps.lean +++ b/Strata/Transform/CoreTransformProps.lean @@ -139,7 +139,7 @@ theorem H_init exact singleCmdToStmts Hcmd /-- If `k ∉ ks`, then `ReadValues σ ks vs` is preserved when extending σ - with an unrelated key. Re-derived from the legacy `ReadValuesUpdatedState`. -/ + with an unrelated key. -/ theorem readValues_updatedState {σ : CoreStore} {k : Expression.Ident} {v : Expression.Expr} {ks : List Expression.Ident} {vs : List Expression.Expr} @@ -280,8 +280,7 @@ theorem H_initVars exact Hcombined /-- If `k` is not in the free variables of `e`, evaluating `e` is unchanged - when σ is extended with `k ↦ v`. Re-derived from the legacy - `EvalExpressionUpdatedState` for the small-step proof. -/ + when σ is extended with `k ↦ v`. -/ theorem evalExpression_updatedState {δ : CoreEval} {σ : CoreStore} {k : Expression.Ident} {v : Expression.Expr} @@ -610,14 +609,6 @@ theorem genArgExprIdents_length' rw [genArgExprIdent_len'] simp -theorem genArgExprIdents_length - {n : Nat} {s s' : CoreGenState} {ls : List Expression.Ident} - (Hgen : Core.Transform.genArgExprIdents n s = (ls, s')) : - ls.length = n := by - have := genArgExprIdents_length' n s - rw [Hgen] at this - exact this - theorem genOutExprIdent_len' {t : List Expression.Ident} {s : CoreGenState} : (List.mapM Core.Transform.genOutExprIdent t s).fst.length = t.length := @@ -629,15 +620,6 @@ theorem genOutExprIdents_length' simp only [Core.Transform.genOutExprIdents] exact genOutExprIdent_len' -theorem genOutExprIdents_length - {idents : List Expression.Ident} {s s' : CoreGenState} - {ls : List Expression.Ident} - (Hgen : Core.Transform.genOutExprIdents idents s = (ls, s')) : - ls.length = idents.length := by - have := genOutExprIdents_length' idents s - rw [Hgen] at this - exact this - theorem genOldExprIdent_len' {t : List Expression.Ident} {s : CoreGenState} : (List.mapM Core.Transform.genOldExprIdent t s).fst.length = t.length := @@ -726,9 +708,8 @@ theorem genOutExprIdentsTrip_extract /-! ### `_snd` projection lemmas for the `gen*ExprIdentsTrip` family These say: the `Prod.snd` projection of the trip list is exactly the -input arguments/lhs/old-vars list. The legacy proofs went through -intricate splittings; the live forms are short reductions through the -monad layers because we have the structural form +input arguments/lhs/old-vars list. The forms are short reductions through +the monad layers because we have the structural form `(gen_idents.zip inputs.unzip.2).zip args` directly visible. -/ theorem genArgExprIdentsTrip_snd @@ -755,25 +736,6 @@ theorem genOutExprIdentsTrip_snd (genOutExprIdents_length' lhs s.genState) (by simp [List.length_map]; omega) -/-- The "snd" projection lemma for the `oldTripsRaw` shape used in the - live `callElimCmd`: `oldTripsRaw = (genOldIdents.zip oldTys).zip oldVars`, - so its `snd` projection is `oldVars` provided - `genOldIdents.length = oldVars.length` and `oldTys.length = oldVars.length`. - - Unlike the arg/out cases, the live `callElimCmd` does not call a - dedicated `genOldExprIdentsTrip` wrapper; instead it constructs - `oldTripsRaw` inline. This helper provides the equivalent - structural fact. -/ -theorem genOldExprIdentsTrip_snd - {oldVars : List Expression.Ident} - {oldTys : List Lambda.LTy} - {s s' : CoreGenState} - {genOldIdents : List Expression.Ident} - (Hgen : Core.Transform.genOldExprIdents oldVars s = (genOldIdents, s')) - (Htylen : oldTys.length = oldVars.length) : - ((genOldIdents.zip oldTys).zip oldVars).unzip.snd = oldVars := - List.zip_zip_unzip_snd_of_lengths (genOldExprIdents_length Hgen) Htylen - /-! ### `*GeneratedWF` lemmas: each generator pushes its results to `generated` `CoreGenState.gen` extends `generated` by one cons; running `mapM` of a @@ -797,13 +759,6 @@ theorem genCoreIdentGeneratedWF exact this.symm rw [Hl, Hs] -theorem genIdentGeneratedWF - {ident : Expression.Ident} {pf : String → String} - {s s' : CoreGenState} {l : Expression.Ident} - (Hgen : Core.Transform.genIdent ident pf s = (l, s')) : - s'.generated = l :: s.generated := - genCoreIdentGeneratedWF Hgen - theorem genArgExprIdents_GeneratedWF {n : Nat} {s s' : CoreGenState} {ls : List Expression.Ident} (Hgen : Core.Transform.genArgExprIdents n s = (ls, s')) : @@ -936,20 +891,6 @@ theorem genOldExprIdentsTripWFMono CoreGenState.WF s' := genOldExprIdents_WFMono Hwf Hgen -/-- Trip-level GeneratedWF for old trips, parameterized over the bare - `genOldExprIdents` (since the live `callElimCmd` constructs its - `oldTripsRaw` inline rather than through a wrapper). -/ -theorem genOldExprIdentsTripGeneratedWF - {oldVars : List Expression.Ident} {oldTys : List Lambda.LTy} - {s s' : CoreGenState} {genOldIdents : List Expression.Ident} - (Hgen : Core.Transform.genOldExprIdents oldVars s = (genOldIdents, s')) - (Htylen : oldTys.length = oldVars.length) : - s'.generated = - ((genOldIdents.zip oldTys).zip oldVars).unzip.fst.unzip.fst.reverse ++ s.generated := by - rw [genOldExprIdents_GeneratedWF Hgen] - rw [List.zip_zip_unzip_fst_unzip_fst_of_lengths - (genOldExprIdents_length Hgen) Htylen] - /-! ### `isTempIdent` / `isOldTempIdent` predicates and producing-side lemmas A `CoreIdent` is a call-elim temp if its name has the `tmp_` prefix @@ -1104,22 +1045,6 @@ theorem genOutExprIdentsTrip_isTempIdent (s' := (Core.Transform.genOutExprIdents lhs s.genState).snd) (ls := (Core.Transform.genOutExprIdents lhs s.genState).fst) rfl -/-- For the live `callElimCmd`, `oldTrips`'s `fst.fst` projection is exactly - the fresh `genOldIdents` produced by `genOldExprIdents`, since the trip - structure is `((freshIdent, ty), origVar)`. -/ -theorem genOldExprIdentsTrip_isOldTempIdent - {oldVars : List Expression.Ident} - {oldTys : List Lambda.LTy} - {s s' : CoreGenState} - {genOldIdents : List Expression.Ident} - (Hgen : Core.Transform.genOldExprIdents oldVars s = (genOldIdents, s')) - (Htylen : oldTys.length = oldVars.length) : - Forall (fun x => isOldTempIdent x) - ((genOldIdents.zip oldTys).zip oldVars).unzip.fst.unzip.fst := by - rw [List.zip_zip_unzip_fst_unzip_fst_of_lengths - (genOldExprIdents_length Hgen) Htylen] - exact genOldExprIdents_isOldTempIdent Hgen - end Core end -- public section diff --git a/Strata/Transform/SubstProps.lean b/Strata/Transform/SubstProps.lean index 1c6885b3e4..17a8ccf3c5 100644 --- a/Strata/Transform/SubstProps.lean +++ b/Strata/Transform/SubstProps.lean @@ -31,10 +31,10 @@ public section /-! ### Substitution-correctness lemmas (small-step) - These re-derive the legacy `Lambda.LExpr.substFvarCorrect` and - `Lambda.LExpr.substFvarsCorrect` proofs using only currently-live - infrastructure. They are pure expression-level lemmas and are the - workhorses behind `H_asserts` / `H_assumes`. -/ + Pure expression-level lemmas establishing that substitution of free + variables preserves expression evaluation when the source/target stores + agree on the substitution and on the surrounding context. They are the + workhorses behind `H_asserts_zip` / `H_assumes_zip`. -/ /-- Substitution of a single free variable preserves expression evaluation when the source/target stores agree on the substitution and on @@ -229,10 +229,9 @@ theorem subst_fvarsZero_correct /-! ### Substitution-list helpers - Re-derived from the legacy code (currently in the comment block) so the - new small-step proofs of `H_asserts`/`H_assumes` can stand on their own. - These are pure list-level / store-level lemmas about - `substDefined`, `substNodup`, `substStores`, and `invStores`. -/ + Pure list-level / store-level lemmas about `substDefined`, `substNodup`, + `substStores`, and `invStores` that back the small-step proofs of + `H_asserts_zip` / `H_assumes_zip`. -/ theorem updatedStateIsDefinedMono' {σ : CoreStore} {k : Expression.Ident} {v : Expression.Expr} @@ -1082,137 +1081,6 @@ theorem subst_fvars_eval_bridge /-! ### Small-step block helpers for assert/assume sequences -/ -/-- Generic block-evaluator helper for assert/assume statement lists with - substituted predicates. Parameterized by `mkStmt` (the `Statement.assert` - or `Statement.assume` constructor) and `mkSingletonEval` (a function that - builds a singleton `EvalStatementsContract` from the eval-true witness). - Used to derive both `H_asserts` and `H_assumes`. -/ -theorem H_check_block - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σA σ' : CoreStore} - {ks ks' : List Expression.Ident} - {entries : List (CoreLabel × Procedure.Check)} - {md : Imperative.MetaData Expression} - {labelPrefix : String} - (mkStmt : String → Expression.Expr → Imperative.MetaData Expression → Statement) - (mkSingletonEval : - ∀ (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression), - δ σ' e = some Imperative.HasBool.tt → - EvalStatementsContract π φ ⟨σ', δ, false⟩ [mkStmt lbl e m] ⟨σ', δ, false⟩) - (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) - (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) - (Hwfc : Core.WellFormedCoreEvalCong δ) - (Hlen : ks.length = ks'.length) - (Hnd : Imperative.substNodup (ks.zip ks')) - (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) - (Hsubst : Imperative.substStores σA σ' (ks.zip ks')) - (Hentries : ∀ entry, entry ∈ entries → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll - (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ - δ σA entry.snd.expr = some Imperative.HasBool.tt) : - EvalStatementsContract π φ ⟨σ', δ, false⟩ - (entries.mapIdx (fun i (lbl, check) => - mkStmt s!"{labelPrefix}{i}_{lbl}" - (Lambda.LExpr.substFvars check.expr - (ks.zip (Core.Transform.createFvars ks'))) - (check.md.setCallSiteFileRange md))) - ⟨σ', δ, false⟩ := by - -- Generalize over the starting index of mapIdx so we can induct on the list. - suffices Hgen : - ∀ (i : Nat) (l : List (CoreLabel × Procedure.Check)), - (∀ entry, entry ∈ l → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll - (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ - δ σA entry.snd.expr = some Imperative.HasBool.tt) → - EvalStatementsContract π φ ⟨σ', δ, false⟩ - (l.mapIdx (fun j (lbl, check) => - mkStmt s!"{labelPrefix}{i + j}_{lbl}" - (Lambda.LExpr.substFvars check.expr - (ks.zip (Core.Transform.createFvars ks'))) - (check.md.setCallSiteFileRange md))) - ⟨σ', δ, false⟩ by - have := Hgen 0 entries Hentries - simpa using this - intros i l Hl - induction l generalizing i with - | nil => - simp [List.mapIdx] - exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) - | cons head tail ih => - obtain ⟨lbl, check⟩ := head - have HtailHyp : - ∀ entry, entry ∈ tail → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll - (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ - δ σA entry.snd.expr = some Imperative.HasBool.tt := by - intros entry hin; exact Hl entry (List.mem_cons_of_mem _ hin) - have Htail := ih (i + 1) HtailHyp - have HlHead := Hl (lbl, check) List.mem_cons_self - obtain ⟨HinvHead, HnininHead, HevHead⟩ := HlHead - have Heq : δ σA check.expr = - δ σ' (Lambda.LExpr.substFvars check.expr - (ks.zip (Core.Transform.createFvars ks'))) := - subst_fvars_correct Hwfc Hwfvr Hwfvl Hlen Hdef Hnd Hsubst HnininHead HinvHead - have HevSubst : δ σ' (Lambda.LExpr.substFvars check.expr - (ks.zip (Core.Transform.createFvars ks'))) = - some Imperative.HasBool.tt := by - rw [← Heq]; exact HevHead - have HheadStmts := mkSingletonEval s!"{labelPrefix}{i}_{lbl}" - (Lambda.LExpr.substFvars check.expr (ks.zip (Core.Transform.createFvars ks'))) - (check.md.setCallSiteFileRange md) HevSubst - have Hcombined : - EvalStatementsContract π φ ⟨σ', δ, false⟩ - ([mkStmt s!"{labelPrefix}{i}_{lbl}" - (Lambda.LExpr.substFvars check.expr - (ks.zip (Core.Transform.createFvars ks'))) - (check.md.setCallSiteFileRange md)] ++ - tail.mapIdx (fun j p => - mkStmt s!"{labelPrefix}{i + 1 + j}_{p.fst}" - (Lambda.LExpr.substFvars p.snd.expr - (ks.zip (Core.Transform.createFvars ks'))) - (p.snd.md.setCallSiteFileRange md))) - ⟨σ', δ, false⟩ := EvalStatementsContractApp HheadStmts Htail - have Hgoal_eq : - ((lbl, check) :: tail).mapIdx (fun j p => - mkStmt s!"{labelPrefix}{i + j}_{p.fst}" - (Lambda.LExpr.substFvars p.snd.expr - (ks.zip (Core.Transform.createFvars ks'))) - (p.snd.md.setCallSiteFileRange md)) = - [mkStmt s!"{labelPrefix}{i}_{lbl}" - (Lambda.LExpr.substFvars check.expr - (ks.zip (Core.Transform.createFvars ks'))) - (check.md.setCallSiteFileRange md)] ++ - tail.mapIdx (fun j p => - mkStmt s!"{labelPrefix}{i + 1 + j}_{p.fst}" - (Lambda.LExpr.substFvars p.snd.expr - (ks.zip (Core.Transform.createFvars ks'))) - (p.snd.md.setCallSiteFileRange md)) := by - rw [List.mapIdx_cons] - simp only [List.singleton_append, List.cons.injEq, Nat.add_zero, true_and] - apply List.mapIdx_eq_iff.mpr - intros k - simp [List.getElem?_mapIdx] - cases hh : tail[k]? with - | none => rfl - | some p => - have : i + 1 + k = i + (k + 1) := by omega - rw [this] - show EvalStatementsContract π φ ⟨σ', δ, false⟩ - (((lbl, check) :: tail).mapIdx (fun j p => - mkStmt s!"{labelPrefix}{i + j}_{p.fst}" - (Lambda.LExpr.substFvars p.snd.expr - (ks.zip (Core.Transform.createFvars ks'))) - (p.snd.md.setCallSiteFileRange md))) ⟨σ', δ, false⟩ - rw [Hgoal_eq] - exact Hcombined - /-- Generic block-evaluator helper for the labels-aware (`zip`) variant of assert/assume statement lists. Used to derive both `H_asserts_zip` and `H_assumes_zip`. -/ @@ -1285,110 +1153,6 @@ theorem H_check_block_zip simp only [List.zip_cons_cons, List.map_cons] exact EvalStatementsContractApp HheadStmts Htail -/-! ### Pure list-shape analogues of `createAsserts` / `createAssumes`. - - The monadic `Core.Transform.createAsserts` / `createAssumes` use a fresh - label generator. For the small-step proof we need a pure-list version that - we can induct over directly. -/ - -/-- Pure-list analogue of `Core.Transform.createAsserts` (without the - monadic label generator). Produces `Statement.assert` statements, - one per entry, with substituted predicates. -/ -def createAsserts_list - (entries : List (CoreLabel × Procedure.Check)) - (subst : Map Expression.Ident Expression.Expr) - (md : Imperative.MetaData Expression) - (labelPrefix : String) : - List Statement := - entries.mapIdx (fun i (l, check) => - Statement.assert s!"{labelPrefix}{i}_{l}" - (Lambda.LExpr.substFvars check.expr subst) - (check.md.setCallSiteFileRange md)) - -/-- Pure-list analogue of `Core.Transform.createAssumes`. -/ -def createAssumes_list - (entries : List (CoreLabel × Procedure.Check)) - (subst : Map Expression.Ident Expression.Expr) - (md : Imperative.MetaData Expression) - (labelPrefix : String) : - List Statement := - entries.mapIdx (fun i (l, check) => - Statement.assume s!"{labelPrefix}{i}_{l}" - (Lambda.LExpr.substFvars check.expr subst) - (check.md.setCallSiteFileRange md)) - -/-- A list of `Statement.assert` with substituted predicates evaluates from - σ' to σ' (store unchanged) under contract semantics, given that each - substituted predicate evaluates to `tt` in σ' and the substitution - well-formedness assumptions hold. -/ -theorem H_asserts - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σA σ' : CoreStore} - {ks ks' : List Expression.Ident} - {pres : List (CoreLabel × Procedure.Check)} - {md : Imperative.MetaData Expression} - {labelPrefix : String} - (Hwfb : Imperative.WellFormedSemanticEvalBool δ) - (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) - (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) - (Hwfc : Core.WellFormedCoreEvalCong δ) - (Hlen : ks.length = ks'.length) - (Hnd : Imperative.substNodup (ks.zip ks')) - (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) - (Hsubst : Imperative.substStores σ' σA (ks'.zip ks)) - (Hpres : ∀ entry, entry ∈ pres → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll - (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ - δ σA entry.snd.expr = some Imperative.HasBool.tt) : - EvalStatementsContract π φ ⟨σ', δ, false⟩ - (createAsserts_list pres (ks.zip (Core.Transform.createFvars ks')) md labelPrefix) - ⟨σ', δ, false⟩ := by - have Hsubst' : Imperative.substStores σA σ' (ks.zip ks') := by - apply Imperative.substStoresFlip' - simp [Imperative.substSwap, zip_swap] - exact Hsubst - have := H_check_block (π := π) (φ := φ) (md := md) (labelPrefix := labelPrefix) - (entries := pres) Statement.assert - (mkSingletonEval := singletonAssertEval Hwfb) - Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst' Hpres - simpa [createAsserts_list] using this - -/-- Symmetric to `H_asserts`: a list of `Statement.assume` with substituted - predicates evaluates from σ' to σ'. -/ -theorem H_assumes - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σA σ' : CoreStore} - {ks ks' : List Expression.Ident} - {posts : List (CoreLabel × Procedure.Check)} - {md : Imperative.MetaData Expression} - {labelPrefix : String} - (Hwfb : Imperative.WellFormedSemanticEvalBool δ) - (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) - (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) - (Hwfc : Core.WellFormedCoreEvalCong δ) - (Hlen : ks.length = ks'.length) - (Hnd : Imperative.substNodup (ks.zip ks')) - (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) - (Hsubst : Imperative.substStores σA σ' (ks.zip ks')) - (Hposts : ∀ entry, entry ∈ posts → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll - (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ - δ σA entry.snd.expr = some Imperative.HasBool.tt) : - EvalStatementsContract π φ ⟨σ', δ, false⟩ - (createAssumes_list posts (ks.zip (Core.Transform.createFvars ks')) md labelPrefix) - ⟨σ', δ, false⟩ := by - have := H_check_block (π := π) (φ := φ) (md := md) (labelPrefix := labelPrefix) - (entries := posts) Statement.assume - (mkSingletonEval := singletonAssumeEval Hwfb) - Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hposts - simpa [createAssumes_list] using this - /-- Labels-aware variant of `H_asserts`: takes a separate `labels` list (paired positionally with `pres` via `zip`) rather than a `labelOf` projection. This matches the shape exposed by the @@ -1470,8 +1234,7 @@ theorem H_assumes_zip Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hposts /-- Helper: lifting `ReadValues σ ks vs` across an `updatedStates` extension - by names disjoint from `ks`. Live-code analogue of the legacy - `ReadValuesUpdatedStates`. -/ + by names disjoint from `ks`. -/ theorem readValues_updatedStates {σ : CoreStore} {ks ks' : List Expression.Ident} {vs : List Expression.Expr} {vs' : List Expression.Expr} From be987fddc476f30d834de292260b67ebc2faef1e Mon Sep 17 00:00:00 2001 From: David Deng Date: Mon, 8 Jun 2026 08:28:00 -0700 Subject: [PATCH 11/12] CallElimCorrect: lift _terminal to polymorphic {f : Bool} (#1340) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ## Summary Lifts `callElimStatementCorrect_terminal` from the parent branch's `f = false → false` shape (PR #1306, success-only refinement) to fully polymorphic `{f : Bool}`: a source trace ending in failure maps to a target trace ending in failure, and a source success trace maps to a target success trace, in one statement. Downstream consumers no longer case-split on the failure flag at the call site. This is a foundational refactor + generalization, not a feature. Reviewers should follow the proof structure: Stages 1-3 are pure extractions (success theorem unchanged), Path 1 narrows a public iff for semantic alignment, Stage 6 (split into a scaffold and a fill-in) lands the actual polymorphic-f result. ## Base branch This PR sits on top of `htd/callelim-smallstep-on-main2` (PR #1306, currently open). Merge into that branch, or rebase onto `main` once #1306 lands. ## Why this matters The parent's success-only theorem suffices to argue that call-elimination preserves the *absence* of bugs, but it leaves a dual gap: it does not say anything about preserving the *presence* of bugs. Without the failure arm, callElim could in principle turn a buggy program into one that verifies. Lifting `_terminal` to `{f : Bool}` makes that argument compositional — the same lemma covers both directions, and any future transform layered on top of call-elimination inherits the polymorphic guarantee for free. The failure arm also exercises corners of the contract semantics the success arm never touches: the assert-zip on call-site preconditions, havoc of out-parameters in the failure branch, and the assume-zip on call-site postconditions all have to compose correctly under `hasFailure = true`. Closing it flushed out a real semantic mismatch in `EvalCommandContract.call_sem` (Path 1 below) that was invisible from the success-only side. ## Commit-by-commit walkthrough Read the seven commits in order: ### 1. 193dee2d6 — WIP: polymorphic-f infrastructure (no live consumers) Forward-looking scaffolding, kept as a separate commit so that the consumer-side proof changes in later commits aren't buried under unrelated infrastructure. Lands in: - `Strata/Languages/Core/StatementSemantics.lean` — **Change A**: collapses the two conditional `Hupdate` premises of `EvalCommandContract.call_sem` into a single unconditional `UpdateStates` premise. The failure path no longer pins `σ' = σ`, which is what makes a polymorphic-f rule shape coherent. - `Strata/Languages/Core/WF.lean` — `WFPrePostProp.boolTyped` clause added (zero migration cost, no live construction sites yet). - `Strata/Transform/CoreTransformProps.lean` and `Strata/Transform/SubstProps.lean` — new helpers `singleCmdToStmts_poly`, `singletonAssumeEval_poly`, `H_havocs_poly`, `H_check_block_zip_poly`, `H_assumes_zip_poly`, `singletonAssertFailEval`, `singletonAssertEval_poly`, plus the substantive new walker `H_asserts_zip_fail` (L4 flag-flip from `false` to `true` via a failing-pre witness) and `EvalCallElim_glue_fail` (composes L1-L6 with the L4 flip). Build clean, sorry-free, axiom-free at this commit. ### 2. 580ef2d26 — Stage 1: extract `HoldEval_bridge_at_σO` Pure refactor. Lifts the per-index δ-eval bridge for `mkOld` old-variable fvars at the post-havoc store `σO` out of `callElimStatementCorrect_terminal`'s call arm into a private theorem with 11 explicit hypotheses. Net diff in `Strata/Transform/CallElimCorrect.lean`: +114 / -61. Same proof body as the inline version; the signature overhead is intentional because Stage 6 will share this helper between the success and failure arms. Sorry count and axiom set unchanged. ### 3. 5406b08d0 — Stage 2a: extract `HoldSubBridge_at_σO` Pure refactor in `Strata/Transform/CallElimCorrect.lean`. Lifts the per-fvar bridge for `createOldVarsSubst`'s codomain at the L6 intermediate stores `σ_R1` / `σO` into a private theorem with 6 hypotheses; the inline block becomes a one-line call. Net diff: +82 / -29. Sorry count and axiom set unchanged. `HinputSubBridge` (the larger sibling, originally targeted for Stage 4) is deferred, then ultimately made redundant by the flag-generalization approach (see "Stages 4 & 5: skipped" below). ### 4. cf10129ef — Stage 3: extract `b1`/`b2_var_witness_at_oldSubst` Pure refactor in `Strata/Transform/CallElimCorrect.lean`. Lifts the two class-(b) substitution-decomposition witnesses out of the call arm: - `b1_var_witness_at_oldSubst`: when a `Map.find?` lands in the `createOldVarsSubst` segment of `oldSubst_L6`, the codomain entry is a fresh-old `createFvar gen` and the witness `var ∈ getVars w` forces `var = genOldIdents[i]`. - `b2_var_witness_at_oldSubst`: when the lookup misses `createOldVarsSubst` and hits `callElim_inputOnlyOldSubst`, the codomain is a positional `inArgs` element. Both helpers take `proc'` and `args` directly so `callElim_inputOnlyOldSubst` can be referenced by name (needed for `find?_append_none_elim` unification at the consumer). 4 callsites each in `_terminal` (inv + post variants); Stage 6's failure arm reuses the same callsites with identical arguments. Net diff: +123 / -77. ### Stages 4 & 5: skipped Originally planned to extract `HinputSubBridge` and a final shared-plumbing block. The flag-generalization approach made these unnecessary — the call branch in `_terminal` `cases` on `f`, and the `false` arm reuses its existing 2200-LoC body verbatim, so we never needed shared sub-helpers between the two arms. Keeping the inline block on the `false` side was strictly cheaper than extracting it. ### 5. fdf2fc43c — Path 1: narrow `EvalCommandContract.call_sem` iff to non-Free preconditions This is the semantic alignment that makes the failure arm provable. `callElimCmd` only emits asserts for non-`Free` preconditions (Free requires are assumed by the implementation, not checked at call sites). The previous `call_sem` iff ranged over **all** preconditions, which made the polymorphic-f failure arm unattainable: a witness `pre` with `eval ≠ tt` at `σAO` could fall in the Free segment, giving no L4 entry to flip the flag. That mismatch was harmless at `f = false` (the success arm never relies on the iff direction that exposed it) but a hard blocker on the failure arm. Restricting the iff to non-Free preconditions aligned the two semantics without changing any existing proof: - `Strata/Languages/Core/StatementSemantics.lean`: `call_sem` rule's `Hpre_def` and `Hpre_iff` now range over `getCheckExprs (preconditions.filter (·.attr ≠ .Free))`. - `Strata/Languages/Core/StatementSemanticsProps.lean`: `EvalCallBodyRefinesContract` / `EvalCommandRefinesContract` / `StepStmt[Star]_refines_contract` / `EvalStatement[s]RefinesContract` gain `[LawfulBEq Expression.Expr]` instances (needed for the contains↔mem bridge in the new `presFiltered_subset` derivation that powers the rule constructor). - `Strata/Transform/CallElimCorrect.lean`: success arm's `Hpre_evalTt` / `Hpre` re-synthesis ranges over filtered preconditions; `HpreFiltered` no longer needs `filterCheck_in_getCheckExprs` — direct membership in `presFiltered` transports straight to the filtered contains-form. Failure-arm helper signature updated to take `Hpre_def` / `Hpre_iff` at the new filtered shape. Build clean (490 jobs) with one expected sorry at line 1654 (failure-arm body, filled by the next commit). ### 6. 45db77d87 — Stage 6 scaffold: lift `_terminal` to `{f : Bool}`, delegate failure arm Shape change without filling in the body. In `Strata/Transform/CallElimCorrect.lean`, `callElimStatementCorrect_terminal`'s signature lifts from `f = false → false` to `{f : Bool}`, with `Heval` and the conclusion both at flag `f`. Non-call cases close polymorphically via `nc_close` (`Heval` passes through unchanged for identity statements). The call branch dispatches: ```lean cases f with | false => existing 2200-LoC body verbatim (f=false case) | true => exact callElimStatementCorrect_terminal_call_arm_fail ... ``` The `_terminal_call_arm_fail` helper is declared with full signature (~25 hypotheses from the `cases Hcc` destructure) and a `sorry` body, ready for the final commit. Splitting the signature lift from the proof close means the lifted public signature is reviewable and buildable on its own, and the failure-arm proof body lands against an already-stable interface. Sorry count: 18 → 19 (temporary). ### 7. be35c7f31 — Stage 6: close polymorphic-f failure arm + lift public signature Replaces the sorry-stubbed `callElimStatementCorrect_terminal_call_arm_fail` in `Strata/Transform/CallElimCorrect.lean` with the full proof body (~2,148 LoC) that mirrors the success arm's L1-L3 + L5/L6 plumbing while flag-flipping at L4: - **L1, L2, L3**: identical to success (init segments produce `f = false → false`). - **L4 (asserts)**: `H_asserts_zip_fail` with failing-pre witness. - **L5 (havocs)**: `H_havocs_poly` at `f := true`. - **L6 (assumes)**: `H_assumes_zip_poly` at `f := true`. - **Glue**: `EvalCallElim_glue_fail` composing `false → false → false → false → true`. Failing-pre witness derivation (now unblocked by Path 1): 1. `Hpre_iff` at `flag = true`: `Classical.em` on "all preconditions eval to `tt`" → contrapositive gives `∃ pre ∈ presFiltered, δ σAO pre ≠ some tt`. 2. Bool-totality from new `WFCallSiteProp.preBoolTyped` field (mirrors the `boolTyped` clause on `WFPrePostProp`): `δ σAO pre = some tt ∨ ff`. 3. Combine → `∃ pre, δ σAO pre = some HasBool.ff`. 4. Transport `σAO ↦ σ_old` via `subst_fvars_correct` against `Hsubst_L4`. WF additions in `Strata/Languages/Core/WF.lean`: - `WFCallSiteProp.preBoolTyped` (~line 1156): per-precondition bool-totality. - `WFCallSiteSpec.preBoolTyped` (~line 1207): per-call specialization. - `WFCallSiteProp.specialize` forwards the new field. The exit arm is unchanged — call statements never produce `.exiting`. Sorry count: 19 → 18 (back to baseline). Build clean, no new axioms. ## Polymorphic helpers — all genuinely consumed | Helper | Source | Callsites | | --- | --- | --- | | `EvalCallElim_glue_fail` | `Strata/Transform/CoreTransformProps.lean` | 1 | | `H_asserts_zip_fail` | `Strata/Transform/SubstProps.lean` | 1 | | `H_havocs_poly` | `Strata/Transform/CoreTransformProps.lean` | 1 | | `H_assumes_zip_poly` | `Strata/Transform/CoreTransformProps.lean` | 1 | | `WFPrePostProp.preBoolTyped` | `Strata/Languages/Core/WF.lean` | 1 | Helpers are deliberately single-callsite for now: the polymorphic-f infrastructure is staged to be reusable, but until a second consumer materializes the helpers stay scoped to this proof and we avoid speculative API design. No dormant scaffolding. ## Soundness - **Build**: clean (490 jobs) - **New sorries**: 0 (baseline 18 in `Strata/Languages/Core/WF.lean` are pre-existing and unrelated to this work) - **New admits**: 0 - **New axioms**: 0 - **`#print axioms callElimStatementCorrect_terminal`**: `[propext, Classical.choice, Quot.sound]` — Lean stdlib only, no project-local axioms - **Helper consumption**: all 4 polymorphic helpers + `preBoolTyped` have ≥ 1 live callsite (verified above) - **Path 1 conservativity**: the narrowed `call_sem` iff matches `callElimCmd`'s actual emission rule (asserts only for non-Free precondition components); success-arm reproof is mechanical ## Commit list ``` be35c7f31 Stage 6: close polymorphic-f failure arm + lift public signature fdf2fc43c Path 1: narrow EvalCommandContract.call_sem iff to non-Free preconditions 45db77d87 Stage 6 scaffold: lift _terminal to {f : Bool}, delegate failure arm cf10129ef Stage 3: extract b1/b2_var_witness_at_oldSubst helpers 5406b08d0 Stage 2a: extract HoldSubBridge_at_σO helper 580ef2d26 Stage 1: extract HoldEval_bridge_at_σO helper 193dee2d6 WIP: polymorphic-f infrastructure (no live consumers) ``` ## Test plan - [x] `lake build` clean across all 490 jobs - [x] Zero new sorries introduced (baseline 18 in `Strata/Languages/Core/WF.lean` preserved) - [x] Zero new admits/axioms introduced - [x] `#print axioms callElimStatementCorrect_terminal` → Lean stdlib only (`[propext, Classical.choice, Quot.sound]`) - [x] Each polymorphic helper genuinely consumed (`EvalCallElim_glue_fail`, `H_asserts_zip_fail`, `H_havocs_poly`, `H_assumes_zip_poly`, `WFPrePostProp.preBoolTyped` — 1 callsite each) - [ ] Reviewer: spot-check Stages 1 / 2a / 3 (580ef2d26, 5406b08d0, cf10129ef) are pure refactors by diffing helper bodies against the inline blocks they replaced - [ ] Reviewer: confirm Path 1 (fdf2fc43c) preserves success-arm soundness — `Hpre_evalTt` re-synthesis over filtered preconditions is the only consumer-side change in the success arm - [ ] Reviewer: confirm Change A in 193dee2d6 (collapsed `UpdateStates` premise on `call_sem`) preserves the parent branch's `false → false` semantics - [ ] Downstream consumers of `_terminal` (none on `htd/callelim-smallstep-on-main2` today; re-check after rebase if #1306 lands first) --- Strata/Languages/Core/StatementSemantics.lean | 27 +- .../Core/StatementSemanticsProps.lean | 289 -- Strata/Transform/CallElimCorrect.lean | 3416 +++++++++++++---- Strata/Transform/CoreTransformProps.lean | 120 +- Strata/Transform/SubstProps.lean | 532 ++- 5 files changed, 3233 insertions(+), 1151 deletions(-) diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 7d813dd285..0b7350de41 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -413,10 +413,13 @@ inductive EvalCommandContract : (String → Option Procedure) → CoreEval → /-- Contract-based semantics: like `EvalCommand.call_sem` but replaces body execution with havoc + postcondition check. The Bool failure flag `failed` is connected to the precondition status - via an iff: the call fails iff some precondition fails to evaluate to - `tt` at the post-init/pre-havoc store `σAO`. When `failed = true`, - the result store is unchanged (`σ' = σ`); when `failed = false`, the - result store is produced by havoc + write-back via `UpdateStates`. + via an iff: the call fails iff some *checked* precondition fails to + evaluate to `tt` at the post-init/pre-havoc store `σAO`. Free + preconditions (`free requires`) are assumed by the implementation but + not checked at call sites (Procedure.lean §92), so they are excluded + from the iff — the iff and definedness premises both range over + non-Free preconditions only. The result store `σ'` is unconditionally + the writeback result via `UpdateStates`, regardless of `failed`. Same positional matching as `EvalCommand.call_sem`. -/ | call_sem {π δ σ σ₀ inArgs oVals vals σA σAO σO n p modvals callArgs σ' md failed} : π n = .some p → @@ -433,21 +436,23 @@ inductive EvalCommandContract : (String → Option Procedure) → CoreEval → InitStates σ (ListMap.keys (p.header.inputs)) vals σA → -- positional: oVals[i] initializes p.header.outputs[i] InitStates σA (ListMap.keys (p.header.outputs)) oVals σAO → - -- preconditions are always defined; their truth controls `failed` - (∀ pre, (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre → + -- non-Free preconditions are always defined; their truth controls `failed` + (∀ pre, (Procedure.Spec.getCheckExprs + (p.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free))).contains pre → isDefinedOver (HasVarsPure.getVars) σAO pre) → (failed = false ↔ - (∀ pre, (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre → + (∀ pre, (Procedure.Spec.getCheckExprs + (p.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free))).contains pre → δ σAO pre = .some HasBool.tt)) → HavocVars σAO (ListMap.keys p.header.outputs) σO → (∀ post, (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → isDefinedOver (HasVarsPure.getVars) σAO post ∧ δ σO post = .some HasBool.tt) → ReadValues σO (ListMap.keys (p.header.outputs)) modvals → - -- success path: positional write-back - (failed = false → UpdateStates σ lhs modvals σ') → - -- failure path: store unchanged - (failed = true → σ' = σ) → + -- positional write-back (unconditional) + UpdateStates σ lhs modvals σ' → ---- EvalCommandContract π δ σ (.call n callArgs md) σ' failed diff --git a/Strata/Languages/Core/StatementSemanticsProps.lean b/Strata/Languages/Core/StatementSemanticsProps.lean index 68e6a9ee0d..5ae3832471 100644 --- a/Strata/Languages/Core/StatementSemanticsProps.lean +++ b/Strata/Languages/Core/StatementSemanticsProps.lean @@ -2200,215 +2200,6 @@ theorem InvStoresExceptInvStores : exact List.Disjoint.symm Hdis assumption -/- -NOTE: - In order to prove this refinement theorem, we need to reason about the - asymmetry between the two semantics regarding the temporary variables - created in the concrete semantics. That is, evaluating the procedure body may - create new variables in the store, and since the temporary variables are - discarded at the end of the call, it is possible to show that those created - variables are irrelevant. --/ -/-- -Refinement of a procedure call from concrete (Layer-A small-step body trace) -semantics to contract (havoc-and-postcondition) semantics. - -The proof requires three side-conditions that the concrete `call_sem` -constructor does not by itself supply: - -* `δ_wfCong` — the evaluator respects free-variable congruence; needed to - rewrite `δ ρ'.store post` into `δ σO post` (where `σO` is the post-havoc - store the contract semantics evaluates against). - -* `p_outputs_nodup` — the procedure's output parameter list has no duplicate - keys; needed by `readValues_updatedStatesSame` to construct - `ReadValues σO outs modvals`. - -* `p_post_scoped` — every postcondition's free variables are a subset of - the output parameters. This is the well-formed-postcondition assumption - that lets us reduce the per-key store agreement to the output keys. - Without this assumption, the proof would also need a body-locals - invariance lemma over `CoreStepStar` (i.e., a structural lemma like - `stmts_invStoresExcept_modifiedVarsTrans`); none such exists in the - codebase yet. Since `p_post_scoped` is a natural well-formedness - consequence of `WFProcedureProp` (postconditions reference only the - procedure's outputs) we take it as a hypothesis here and let the caller - discharge it. --/ -theorem EvalCallBodyRefinesContract : - ∀ {π : String → Option Procedure} - {φ : CoreEval → PureFunc Expression → CoreEval} - {δ : CoreEval} {σ : CoreStore} {n : String} - {callArgs : List (CallArg Expression)} {σ' : CoreStore} - {p : Procedure} {md md' : MetaData Expression}, - WellFormedSemanticEvalExprCongr δ → - (ListMap.keys p.header.outputs).Nodup → - (∀ post : Expression.Expr, - (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → - (HasVarsPure.getVars (P := Expression) post).Subset (ListMap.keys p.header.outputs)) → - π n = .some p → - EvalCommand π φ δ σ (CmdExt.call n callArgs md) σ' false → - EvalCommandContract π δ σ (CmdExt.call n callArgs md') σ' false := by - intros π φ δ σ n callArgs σ' p md md' - δ_wfCong p_outputs_nodup p_post_scoped pFound H - -- Generalize `false` so dependent elimination produces an equality - -- between the constructor's `ρ'.hasFailure` and the goal's index. - generalize hf : (false : Bool) = b at H - cases H with - | @call_sem _ _ _ σ₀ inArgs vals oVals σA σAO _ p_c modvals _ σ_final ρ' _ - hπ heqIn heqLhs Hev_in HrdLhs hwfV hwfVar hwfBool hwf2s hdef - Hin_inputs Hin_outputs Hpre Hbody Hpost_at_ρ' Hrd_body Hupd => - -- Unify the case-bound `p_c` with the theorem-level `p`. - rw [pFound] at hπ - have hp_eq := Option.some.inj hπ - subst hp_eq - -- ρ'.hasFailure = false from generalize equation. - have hρ'_failure := hf.symm - -- Bind σO := updatedStates σAO outs modvals as a definitional unfold. - -- Length: outs.length = modvals.length (from Hrd_body). - have h_len := ReadValuesLength Hrd_body - -- `outs` are defined in σAO (initialized via Hin_outputs). - have h_def := InitStatesDefined Hin_outputs - -- HavocVars step: σAO can havoc to σO := updatedStates σAO outs modvals. - have h_upd := updatedStatesUpdate h_len h_def - have h_havoc := UpdateStatesHavocVars h_upd - -- ReadValues σO outs modvals, by readValues_updatedStatesSame. - have h_rd_σO : - ReadValues - (updatedStates σAO (ListMap.keys p.header.outputs) modvals) - (ListMap.keys p.header.outputs) modvals := - readValues_updatedStatesSame h_len p_outputs_nodup - -- Postconditions transport from ρ'.store to σO via δ_wfCong. - have h_post : ∀ post : Expression.Expr, - (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → - isDefinedOver (HasVarsPure.getVars (P := Expression)) σAO post ∧ - δ (updatedStates σAO (ListMap.keys p.header.outputs) modvals) post - = some HasBool.tt := by - intros post hin - have ⟨hdefp, heq⟩ := Hpost_at_ρ' post hin - refine ⟨hdefp, ?_⟩ - -- σO and ρ'.store agree on getVars(post) (subset of outs). - have h_agree : ∀ x ∈ HasVarsPure.getVars (P := Expression) post, - updatedStates σAO (ListMap.keys p.header.outputs) modvals x - = ρ'.store x := by - intros x hx - have hx_in_outs : x ∈ (ListMap.keys p.header.outputs) := - p_post_scoped post hin hx - -- Both σO x and ρ'.store x equal modvals[i] for x = outs[i]. - have ⟨i, hi_lt, hi_eq⟩ : - ∃ i, ∃ (h : i < (ListMap.keys p.header.outputs).length), - (ListMap.keys p.header.outputs)[i]'h = x := - List.getElem_of_mem hx_in_outs - have hi_lt' : i < modvals.length := h_len ▸ hi_lt - have hl := hi_eq ▸ readValues_get h_rd_σO (hi := hi_lt) (hi' := hi_lt') - have hr := hi_eq ▸ readValues_get Hrd_body (hi := hi_lt) (hi' := hi_lt') - rw [hl, hr] - -- Apply expression congruence. - rw [δ_wfCong post _ _ h_agree] - exact heq - -- ρ'.hasFailure = false closes the index mismatch in the goal. - rw [hρ'_failure] - -- Split the combined Hpre into the new (def, iff) shape required by the - -- bool-indicator EvalCommandContract.call_sem rule. - have Hpre_def : ∀ pre, - (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre → - isDefinedOver (HasVarsPure.getVars (P := Expression)) σAO pre := - fun pre h => (Hpre pre h).1 - have Hpre_iff : - (false = false ↔ - ∀ pre, (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre → - δ σAO pre = .some HasBool.tt) := - ⟨fun _ pre h => (Hpre pre h).2, fun _ => rfl⟩ - exact EvalCommandContract.call_sem pFound heqIn heqLhs Hev_in HrdLhs hwfV hwfVar hwfBool - hwf2s hdef Hin_inputs Hin_outputs Hpre_def Hpre_iff h_havoc h_post h_rd_σO - (fun _ => Hupd) (fun h => Bool.noConfusion h) - -/-- `EvalCommand` with concrete semantics (`f = false` non-failure case) - refines `EvalCommandContract`. Threads through the three side-conditions - needed by `EvalCallBodyRefinesContract`. -/ -theorem EvalCommandRefinesContract - {π : String → Option Procedure} - {φ : CoreEval → PureFunc Expression → CoreEval} - {δ : CoreEval} {σ σ' : CoreStore} {c : Command} - (δ_wfCong : @Imperative.WellFormedSemanticEvalExprCongr Expression _ δ) - (π_wf : ∀ {n : String} {p : Procedure}, π n = .some p → - (ListMap.keys p.header.outputs).Nodup ∧ - (∀ post : Expression.Expr, - (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → - (HasVarsPure.getVars (P := Expression) post).Subset - (ListMap.keys p.header.outputs))) : - EvalCommand π φ δ σ c σ' false → - EvalCommandContract π δ σ c σ' false := by - intro H - -- Generalize the failure-flag index to enable dependent elimination on H. - generalize hb : (false : Bool) = b at H - cases H with - | cmd_sem H' => - cases hb - exact EvalCommandContract.cmd_sem H' - | @call_sem _ _ _ σ₀ inArgs vals oVals σA σAO _ p_c modvals _ _ ρ' _ - hπ heqIn heqLhs Hev_in HrdLhs hwfV hwfVar hwfBool hwf2s hdef - Hin_inputs Hin_outputs Hpre Hbody Hpost_at_ρ' Hrd_body Hupd => - -- ρ'.hasFailure = false from generalize equation - have hρ'_failure : ρ'.hasFailure = false := hb.symm - have ⟨h_outs_nodup, h_post_scoped⟩ := π_wf hπ - -- Apply the leaf refinement (with md' := md) under the failure rewrite. - exact hρ'_failure ▸ - EvalCallBodyRefinesContract δ_wfCong h_outs_nodup h_post_scoped hπ - (hρ'_failure ▸ EvalCommand.call_sem hπ heqIn heqLhs Hev_in HrdLhs hwfV - hwfVar hwfBool hwf2s hdef Hin_inputs Hin_outputs Hpre Hbody - Hpost_at_ρ' Hrd_body Hupd) - -/-- A single `StepStmt` with `EvalCommand` ending in a non-failed terminal can - be simulated by a single `StepStmt` with `EvalCommandContract`. Threads - through the three side-conditions plus an explicit non-failure witness. -/ -private theorem StepStmt_refines_contract - {π : String → Option Procedure} - {φ : CoreEval → PureFunc Expression → CoreEval} - {c₁ c₂ : Imperative.Config Expression Command} - (δ_wfCong : @Imperative.WellFormedSemanticEvalExprCongr Expression _ c₁.getEnv.eval) - (π_wf : ∀ {n : String} {p : Procedure}, π n = .some p → - (ListMap.keys p.header.outputs).Nodup ∧ - (∀ post : Expression.Expr, - (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → - (HasVarsPure.getVars (P := Expression) post).Subset - (ListMap.keys p.header.outputs))) - (h_no_fail : c₂.getEnv.hasFailure = false) : - Imperative.StepStmt Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → - Imperative.StepStmt Expression (EvalCommandContract π) (EvalPureFunc φ) c₁ c₂ := by - intro H - induction H with - | @step_cmd ρ c σ' hasAssertFailure hcmd => - -- step_cmd produces hasFailure := ρ.hasFailure || hasAssertFailure. - -- h_no_fail says this OR is false; extract that hasAssertFailure = false. - simp only [Imperative.Config.getEnv] at h_no_fail - have ⟨_, h_aff⟩ := Bool.or_eq_false_iff.mp h_no_fail - subst h_aff - -- δ_wfCong is at c₁.getEnv.eval = ρ.eval - simp only [Imperative.Config.getEnv] at δ_wfCong - exact .step_cmd (EvalCommandRefinesContract δ_wfCong π_wf hcmd) - | step_seq_inner _ ih => exact .step_seq_inner (ih δ_wfCong h_no_fail) - | step_block_body _ ih => exact .step_block_body (ih δ_wfCong h_no_fail) - | step_block => exact .step_block - | step_ite_true h1 h2 => exact .step_ite_true h1 h2 - | step_ite_false h1 h2 => exact .step_ite_false h1 h2 - | step_ite_nondet_true => exact .step_ite_nondet_true - | step_ite_nondet_false => exact .step_ite_nondet_false - | step_loop_enter h1 h2 h3 h4 => exact .step_loop_enter h1 h2 h3 h4 - | step_loop_exit h1 h2 h3 h4 => exact .step_loop_exit h1 h2 h3 h4 - | step_loop_nondet_enter h1 h2 => exact .step_loop_nondet_enter h1 h2 - | step_loop_nondet_exit h1 h2 => exact .step_loop_nondet_exit h1 h2 - | step_exit => exact .step_exit - | step_funcDecl => exact .step_funcDecl - | step_typeDecl => exact .step_typeDecl - | step_stmts_nil => exact .step_stmts_nil - | step_stmts_cons => exact .step_stmts_cons - | step_seq_done => exact .step_seq_done - | step_seq_exit => exact .step_seq_exit - | step_block_done => exact .step_block_done - | step_block_exit_match h => exact .step_block_exit_match h - | step_block_exit_mismatch h => exact .step_block_exit_mismatch h - /-- If an expression is defined, all its free variables are defined in the store. Relies on the definedness propagation properties in `WellFormedCoreEvalCong` together with the variable-evaluation condition in `WellFormedSemanticEvalVar`. -/ @@ -2666,86 +2457,6 @@ theorem core_wfExprCongr_preserved | step _ _ _ hstep _ ih => exact ih (core_step_preserves_wfExprCongr π φ h_wf_ext _ _ hwf₀ hstep) -/-- Small-step star with `EvalCommand` ending in non-failure refines - `EvalCommandContract`. Uses `StepStmtStar_hasFailure_monotone` to back- - propagate the non-failure witness, and `core_step_preserves_wfExprCongr` - to refresh the expression-congruence hypothesis after each step. -/ -theorem StepStmtStar_refines_contract - {π : String → Option Procedure} - {φ : CoreEval → PureFunc Expression → CoreEval} - {c₁ c₂ : Imperative.Config Expression Command} - (h_wf_ext : WFEvalExtension φ) - (π_wf : ∀ {n : String} {p : Procedure}, π n = .some p → - (ListMap.keys p.header.outputs).Nodup ∧ - (∀ post : Expression.Expr, - (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → - (HasVarsPure.getVars (P := Expression) post).Subset - (ListMap.keys p.header.outputs))) - (δ_wfCong : @Imperative.WellFormedSemanticEvalExprCongr Expression _ c₁.getEnv.eval) - (h_no_fail : c₂.getEnv.hasFailure = false) : - Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → - Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) c₁ c₂ := by - intro H - -- Generalize δ_wfCong and h_no_fail so the IH stays usable across steps. - revert δ_wfCong h_no_fail - induction H with - | refl => intros; exact .refl _ - | @step c₁ cm c₂ hstep hrest ih => - intro δ_wfCong h_no_fail - -- Backwards-propagate the no-failure witness via monotonicity: - -- case-split on cm.getEnv.hasFailure; the `true` case contradicts - -- h_no_fail by `StepStmtStar_hasFailure_monotone`. - have h_cm_no_fail : cm.getEnv.hasFailure = false := by - cases hcm : cm.getEnv.hasFailure - · rfl - · have h_c2_true := - Imperative.StepStmtStar_hasFailure_monotone Expression - (EvalCommand π φ) (EvalPureFunc φ) hrest hcm - rw [h_c2_true] at h_no_fail - exact Bool.noConfusion h_no_fail - -- Refresh δ_wfCong for the IH at cm. - have hwf_cm : @Imperative.WellFormedSemanticEvalExprCongr Expression _ cm.getEnv.eval := - core_step_preserves_wfExprCongr π φ h_wf_ext _ _ δ_wfCong hstep - exact .step _ _ _ - (StepStmt_refines_contract δ_wfCong π_wf h_cm_no_fail hstep) - (ih hwf_cm h_no_fail) - -/-- `EvalStatements` with concrete semantics refines contract semantics. -/ -theorem EvalStatementsRefinesContract - {π : String → Option Procedure} - {φ : CoreEval → PureFunc Expression → CoreEval} - {ρ ρ' : Env Expression} {ss : List Statement} - (h_wf_ext : WFEvalExtension φ) - (π_wf : ∀ {n : String} {p : Procedure}, π n = .some p → - (ListMap.keys p.header.outputs).Nodup ∧ - (∀ post : Expression.Expr, - (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → - (HasVarsPure.getVars (P := Expression) post).Subset - (ListMap.keys p.header.outputs))) - (δ_wfCong : @Imperative.WellFormedSemanticEvalExprCongr Expression _ ρ.eval) - (h_no_fail : ρ'.hasFailure = false) : - EvalStatements π φ ρ ss ρ' → - EvalStatementsContract π φ ρ ss ρ' := - StepStmtStar_refines_contract h_wf_ext π_wf δ_wfCong h_no_fail - -/-- `EvalStatement` with concrete semantics refines contract semantics. -/ -theorem EvalStatementRefinesContract - {π : String → Option Procedure} - {φ : CoreEval → PureFunc Expression → CoreEval} - {ρ ρ' : Env Expression} {s : Statement} - (h_wf_ext : WFEvalExtension φ) - (π_wf : ∀ {n : String} {p : Procedure}, π n = .some p → - (ListMap.keys p.header.outputs).Nodup ∧ - (∀ post : Expression.Expr, - (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → - (HasVarsPure.getVars (P := Expression) post).Subset - (ListMap.keys p.header.outputs))) - (δ_wfCong : @Imperative.WellFormedSemanticEvalExprCongr Expression _ ρ.eval) - (h_no_fail : ρ'.hasFailure = false) : - EvalStatement π φ ρ s ρ' → - EvalStatementContract π φ ρ s ρ' := - StepStmtStar_refines_contract h_wf_ext π_wf δ_wfCong h_no_fail - /-! ## projectStore and expression evaluation -/ /-- If an expression evaluates in the projected store, it evaluates identically diff --git a/Strata/Transform/CallElimCorrect.lean b/Strata/Transform/CallElimCorrect.lean index 595ad4286c..69c908199b 100644 --- a/Strata/Transform/CallElimCorrect.lean +++ b/Strata/Transform/CallElimCorrect.lean @@ -311,6 +311,33 @@ private theorem notMem_of_Forall_neg (Hforall : Forall p l) (Hnotp : ¬ p x) : x ∉ l := fun h => Hnotp ((List.Forall_mem_iff.mp Hforall) x h) +/-- Decompose the recurring `(k1, k2) ∈ zip self self` membership with + `self = (getVars expr).removeAll ((l₁ ++ l₂) ++ (l₃ ++ l₄))` into + the six leaf facts used at every per-entry `Hinv` site: + `k1 = k2`, `k1 ∈ getVars expr`, and `k1 ∉ lᵢ` for each `i`. + Replaces the recurring `zip_self_eq` + `simp [List.removeAll, ...]` + + `notin_append4` cascade. -/ +private theorem zip_removeAll4_decompose + {expr : Expression.Expr} + {l₁ l₂ l₃ l₄ : List Expression.Ident} + {k1 k2 : Expression.Ident} + (Hkin : (k1, k2) ∈ + ((Imperative.HasVarsPure.getVars (P:=Expression) expr).removeAll + ((l₁ ++ l₂) ++ (l₃ ++ l₄))).zip + ((Imperative.HasVarsPure.getVars (P:=Expression) expr).removeAll + ((l₁ ++ l₂) ++ (l₃ ++ l₄)))) : + k1 = k2 ∧ + k1 ∈ Imperative.HasVarsPure.getVars (P:=Expression) expr ∧ + k1 ∉ l₁ ∧ k1 ∉ l₂ ∧ k1 ∉ l₃ ∧ k1 ∉ l₄ := by + refine ⟨zip_self_eq Hkin, ?_⟩ + have Hk1_in := (List.of_mem_zip Hkin).1 + simp only [List.removeAll, List.mem_filter, + List.elem_eq_mem, Bool.not_eq_true', + decide_eq_false_iff_not] at Hk1_in + obtain ⟨Hk1_pre, Hk1_notin⟩ := Hk1_in + obtain ⟨H1, H2, H3, H4⟩ := List.notin_append4 Hk1_notin + exact ⟨Hk1_pre, H1, H2, H3, H4⟩ + /-- Positional decomposition for `(k1, k2) ∈ ks.zip ks'` under length equality: produce a position `n` together with the bounds and the pair-projection equalities `k1 = ks[n]` and `k2 = ks'[n]`. Absorbs the @@ -373,19 +400,6 @@ private theorem fresh_temps_not_defined simp [hσ] exact ((Hwfgentmp v).mpr Hbundle).1 -/-- Bridge from the `old_` half of `Hwfgenst` to `isNotDefined` for a list - of fresh `old_`-prefixed names: if every name is `isOldTempIdent`, then - each must be undefined in σ by the freshness clause. -/ -private theorem fresh_olds_not_defined - {σ : CoreStore} - (Hwfgenold : ∀ v, isOldTempIdent v → (σ v).isNone) - {newOlds : List Expression.Ident} - (HoldPred : Forall (fun x => isOldTempIdent x) newOlds) : - Imperative.isNotDefined σ newOlds := by - intro v Hin - have Hold : isOldTempIdent v := (List.Forall_mem_iff.mp HoldPred) v Hin - exact Option.isNone_iff_eq_none.mp (Hwfgenold v Hold) - /-- Positional decomposition for `Map.find?` against the L6 canonical `createOldVarsSubst` map. Given a hit `Map.find? (createOldVarsSubst (...zip-form...)) k = some w`, extract @@ -572,17 +586,45 @@ private theorem filterCheck_mem_getCheckExprs rw [ListMap.values_eq_map_snd] exact List.mem_map_of_mem Hin_full -/-- `.contains` form of `filterCheck_mem_getCheckExprs`. Used at the - pre-filtered and post-filtered sites of `callElimStatementCorrect` to - bridge filter membership to the `.contains` argument expected by the - `Hpre`/`Hpost` hypotheses from `call_sem`. -/ -private theorem filterCheck_in_getCheckExprs [LawfulBEq Expression.Expr] - {conds : ListMap CoreLabel Procedure.Check} - {f : CoreLabel × Procedure.Check → Bool} - {entry : CoreLabel × Procedure.Check} - (Hentry : entry ∈ conds.filter f) : - (Procedure.Spec.getCheckExprs conds).contains entry.snd.expr := - List.contains_iff_mem.mpr (filterCheck_mem_getCheckExprs Hentry) +/-- `Hp`+`Hfind`+`lkup` ⇒ `proc' = proc` ∧ postcondition-membership lift + `proc' ↦ proc`. Aligns `Hwfcallsite` (over `proc`) with checks indexed + by the destructured `proc'` at both call-arm sites. -/ +private theorem procEq_and_postExprs_bridge + {π : String → Option Procedure} + {p : Program} {procName : String} {proc proc' : Procedure} + (Hp : ∀ pname, π pname = Program.Procedure.find? p ⟨pname, ()⟩) + (Hfind : Program.Procedure.find? p ⟨procName, ()⟩ = some proc') + (lkup : π procName = some proc) : + proc' = proc ∧ + (∀ c, c ∈ proc'.spec.postconditions.values → + c.expr ∈ Procedure.Spec.getCheckExprs proc.spec.postconditions) := by + have HprocEq : proc' = proc := by + have Hπ := Hp procName; rw [Hπ] at lkup; rw [Hfind] at lkup + exact (Option.some_inj.mp lkup.symm).symm + refine ⟨HprocEq, fun c Hc_in => ?_⟩ + simp only [Procedure.Spec.getCheckExprs, List.mem_map] + refine ⟨c, ?_, rfl⟩ + rw [HprocEq] at Hc_in + rw [ListMap.values_eq_map_snd] + rwa [ListMap.values_eq_map_snd] at Hc_in + +/-- Bridge between the boolean (`!=`) and propositional (`≠`) forms of the + "non-Free" precondition filter. Both filters select the same entries; the + proof is a per-entry `decide` reduction. Used at three sites in the + fail-arm of `callElimStatementCorrect_terminal_call_arm_fail` to align + `presFiltered` (uses `≠`) with the filter shape produced by the L4 + `H_asserts_zip_fail` chain (uses `!=`). -/ +private theorem filter_bne_eq_filter_ne + (preconditions : List (CoreLabel × Procedure.Check)) : + preconditions.filter (fun (_, check) => check.attr != .Free) = + preconditions.filter (fun (_, c) => c.attr ≠ .Free) := by + apply List.filter_congr + intro entry _ + cases entry with + | mk _ c => + by_cases hc : c.attr = Procedure.CheckAttr.Free + · simp [hc] + · simp [hc] /-- Store-agreement helper for `σ_R1`-style stacks (the σ_R1 layer overlaying `genOldIdents ↦ oldVals` on σO, plus the σO ← σAO ← @@ -684,28 +726,40 @@ private theorem oldVars_oldTys_mapM_ok rfl · simp [Hlen] -/-- No-throw fact for `Core.Transform.createAsserts`. Its inner - `mapM` only invokes `genIdent` (a pure non-throwing state mutation), - so the computation always reduces to `Except.ok asserts` with - `asserts.length = conds.length`. The `asserts_shape` conjunct - exposes the list as a `conds.zip labels`-shape that the - label-agnostic downstream consumer needs. -/ -private theorem createAsserts_ok +/-- Polymorphic no-throw fact for the shared body of + `Core.Transform.createAsserts` and `Core.Transform.createAssumes`. + Both functions are byte-identical modulo the `Statement` + constructor (`assert` vs `assume`); their inner `mapM` only + invokes `genIdent` (a pure non-throwing state mutation), so the + computation always reduces to `Except.ok stmts` with + `stmts.length = conds.length`. The shape conjunct exposes the + list as a `conds.zip labels`-shape that the label-agnostic + downstream consumer needs. Parameterized by the constructor + `mkStmt` so both `_ok` lemmas can share this proof. -/ +private theorem createCheckStmts_ok + (mkStmt : String → Expression.Expr → Imperative.MetaData Expression → Statement) (conds : ListMap CoreLabel Procedure.Check) (subst : Map Expression.Ident Expression.Expr) (md : Imperative.MetaData Expression) (labelPrefix : String) (γ : CoreTransformState) : - ∃ (asserts : List Statement) (γ' : CoreTransformState), - Core.Transform.createAsserts conds subst md labelPrefix γ - = (Except.ok asserts, γ') ∧ - asserts.length = conds.length ∧ + ∃ (stmts : List Statement) (γ' : CoreTransformState), + (conds.mapM + (fun (entry : CoreLabel × Procedure.Check) => + (do + let newLabel ← Core.Transform.genIdent entry.fst + (fun s => s!"{labelPrefix}{s}") + return mkStmt newLabel.toPretty + (Lambda.LExpr.substFvars entry.snd.expr subst) + (entry.snd.md.setCallSiteFileRange md) + : CoreTransformM Statement))) γ + = (Except.ok stmts, γ') ∧ + stmts.length = conds.length ∧ ∃ (labels : List String), labels.length = conds.length ∧ - asserts = (conds.zip labels).map (fun (entry, lbl) => - Statement.assert lbl + stmts = (conds.zip labels).map (fun (entry, lbl) => + mkStmt lbl (Lambda.LExpr.substFvars entry.snd.expr subst) (entry.snd.md.setCallSiteFileRange md)) := by - unfold Core.Transform.createAsserts -- `ListMap α β := List (α × β)`, so `conds.mapM` is `List.mapM` over -- the underlying list. Induct on that list, threading the state. induction conds generalizing γ with @@ -725,13 +779,11 @@ private theorem createAsserts_ok cachedAnalyses := γ.cachedAnalyses, factory := γ.factory, statistics := γ.statistics } - obtain ⟨asserts', γ'', Heqtail, Hlen, labelsTail, HlblsLen, Hshape⟩ := ih (γ := γhead) - refine ⟨Statement.assert newLabel.toPretty + obtain ⟨stmts', γ'', Heqtail, Hlen, labelsTail, HlblsLen, Hshape⟩ := ih (γ := γhead) + refine ⟨mkStmt newLabel.toPretty (Lambda.LExpr.substFvars check.expr subst) - (check.md.setCallSiteFileRange md) :: asserts', γ'', ?_, ?_, ?_⟩ + (check.md.setCallSiteFileRange md) :: stmts', γ'', ?_, ?_, ?_⟩ · -- Reduce both sides to the same `List.mapM` core, then chain via Heqtail. - -- Apply the same simp set on both the goal and Heqtail so the inner-mapM - -- shape matches. simp only [List.mapM_cons, bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk, ExceptT.lift, ExceptT.pure, StateT.bind, StateT.pure, pure, @@ -746,9 +798,28 @@ private theorem createAsserts_ok · simp only [List.zip_cons_cons, List.map_cons] rw [Hshape] -/-- No-throw fact for `Core.Transform.createAssumes`. Mirror of - `createAsserts_ok` for the assume case. Same `genIdent`-only - structure, same conclusion, same caveats about labels. -/ +/-- No-throw fact for `Core.Transform.createAsserts`. Specialization + of `createCheckStmts_ok` to the `Statement.assert` constructor. -/ +private theorem createAsserts_ok + (conds : ListMap CoreLabel Procedure.Check) + (subst : Map Expression.Ident Expression.Expr) + (md : Imperative.MetaData Expression) + (labelPrefix : String) + (γ : CoreTransformState) : + ∃ (asserts : List Statement) (γ' : CoreTransformState), + Core.Transform.createAsserts conds subst md labelPrefix γ + = (Except.ok asserts, γ') ∧ + asserts.length = conds.length ∧ + ∃ (labels : List String), labels.length = conds.length ∧ + asserts = (conds.zip labels).map (fun (entry, lbl) => + Statement.assert lbl + (Lambda.LExpr.substFvars entry.snd.expr subst) + (entry.snd.md.setCallSiteFileRange md)) := by + unfold Core.Transform.createAsserts + exact createCheckStmts_ok Statement.assert conds subst md labelPrefix γ + +/-- No-throw fact for `Core.Transform.createAssumes`. Specialization + of `createCheckStmts_ok` to the `Statement.assume` constructor. -/ private theorem createAssumes_ok (conds : ListMap CoreLabel Procedure.Check) (subst : Map Expression.Ident Expression.Expr) @@ -765,39 +836,7 @@ private theorem createAssumes_ok (Lambda.LExpr.substFvars entry.snd.expr subst) (entry.snd.md.setCallSiteFileRange md)) := by unfold Core.Transform.createAssumes - induction conds generalizing γ with - | nil => - exact ⟨[], γ, by simp [List.mapM_nil, pure, ExceptT.pure, StateT.pure, ExceptT.mk], - rfl, [], rfl, by simp⟩ - | cons head rest ih => - obtain ⟨l, check⟩ := head - cases hgi : Core.Transform.genIdent l (fun s => s!"{labelPrefix}{s}") γ.genState with - | mk newLabel γgen' => - let γhead : CoreTransformState := - { genState := γgen', - currentProgram := γ.currentProgram, - currentProcedureName := γ.currentProcedureName, - cachedAnalyses := γ.cachedAnalyses, - factory := γ.factory, - statistics := γ.statistics } - obtain ⟨assumes', γ'', Heqtail, Hlen, labelsTail, HlblsLen, Hshape⟩ := ih (γ := γhead) - refine ⟨Statement.assume newLabel.toPretty - (Lambda.LExpr.substFvars check.expr subst) - (check.md.setCallSiteFileRange md) :: assumes', γ'', ?_, ?_, ?_⟩ - · -- Reduce both sides to the same `List.mapM` core, then chain via Heqtail. - simp only [List.mapM_cons, bind, ExceptT.bind, ExceptT.bindCont, - ExceptT.mk, ExceptT.lift, ExceptT.pure, - StateT.bind, StateT.pure, pure, - monadLift, MonadLift.monadLift, liftM, - Functor.map, StateT.map, liftCoreGenM, hgi] - bind_shell_state at Heqtail - rw [Heqtail] - rfl - · simp [Hlen] - · refine ⟨newLabel.toPretty :: labelsTail, ?_, ?_⟩ - · simp [HlblsLen] - · simp only [List.zip_cons_cons, List.map_cons] - rw [Hshape] + exact createCheckStmts_ok Statement.assume conds subst md labelPrefix γ /-- Internal-shape destructuring of a successful `callElimCmd` call. @@ -1152,6 +1191,20 @@ structure WFCallSiteProp (p : Program) v ∈ CallArg.getLhs args → (CallArg.getLhs args).idxOf v = (ListMap.keys proc.header.outputs).idxOf v + /-- Bool-totality of preconditions (`WFPrePostProp.boolTyped` clause): a + precondition expression evaluates to either `tt` or `ff` whenever + its free variables are defined in the store. Backs the failing-arm + witness derivation in `callElimStatementCorrect_terminal_call_arm_fail`. -/ + preBoolTyped : + ∀ procName args md, st = .cmd (CmdExt.call procName args md) → + ∀ proc, π procName = some proc → + ∀ pre ∈ Procedure.Spec.getCheckExprs proc.spec.preconditions, + ∀ (δ : Imperative.SemanticEval Expression) + (σ : Imperative.SemanticStore Expression), + Imperative.isDefinedOver + (Imperative.HasVarsPure.getVars (P := Expression)) σ pre → + δ σ pre = some Imperative.HasBool.tt ∨ + δ σ pre = some Imperative.HasBool.ff /-- Call-site WF clauses already specialized at a fixed call form `(procName, args, md)` and a fixed procedure `proc`. @@ -1191,6 +1244,14 @@ structure WFCallSiteSpec (proc : Procedure) (args : List (CallArg Expression)) : v ∈ CallArg.getLhs args → (CallArg.getLhs args).idxOf v = (ListMap.keys proc.header.outputs).idxOf v + preBoolTyped : + ∀ pre ∈ Procedure.Spec.getCheckExprs proc.spec.preconditions, + ∀ (δ : Imperative.SemanticEval Expression) + (σ : Imperative.SemanticStore Expression), + Imperative.isDefinedOver + (Imperative.HasVarsPure.getVars (P := Expression)) σ pre → + δ σ pre = some Imperative.HasBool.tt ∨ + δ σ pre = some Imperative.HasBool.ff /-- Specialize all seven `WFCallSiteProp` fields at a fixed call form `st = .cmd (CmdExt.call procName args md)` and procedure lookup @@ -1212,7 +1273,8 @@ theorem WFCallSiteProp.specialize {p : Program} , Hwfcs.inoutFresh procName args md Hst proc Hlkup , Hwfcs.argVarsNotInOutKeys procName args md Hst proc Hlkup , Hwfcs.argVarsNotInInKeys procName args md Hst proc Hlkup - , Hwfcs.outAlignment procName args md Hst proc Hlkup ⟩ + , Hwfcs.outAlignment procName args md Hst proc Hlkup + , Hwfcs.preBoolTyped procName args md Hst proc Hlkup ⟩ /-- Relation between the source store `σ` and the call-elim transform state `γ`'s tracked fresh-name set. @@ -1233,6 +1295,20 @@ structure CoreGenStateRel (σ : CoreStore) (γ : CoreTransformState) : Prop wher call-elim proof. -/ wfgen : CoreGenState.WF γ.genState +/-- Generic δ-fvar lookup: from a `WellFormedSemanticEvalVar` witness on + the evaluator, evaluating an `fvar v` at any store reduces to the store + lookup `σ v`. Used wherever the call-elim proof needs to push δ through + a free-variable expression. -/ +private theorem delta_fvar_eq_of_wfvars + {delta : CoreEval} + (Hwfvars : Imperative.WellFormedSemanticEvalVar delta) + (sigma : CoreStore) (v : Expression.Ident) : + delta sigma (Lambda.LExpr.fvar () v none) = sigma v := by + have Hwfvr := Hwfvars + simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr + rw [Hwfvr (Lambda.LExpr.fvar () v none) v] + simp [Imperative.HasFvar.getFvar] + /-- Bundle the σ-freshness chain: from a Nodup of the combined `(γ.generated.reverse ++ argTemps ++ outTemps ++ genOldIdents)` plus the temp/old predicates and a downstream `UpdateStates`, derive the @@ -1265,7 +1341,9 @@ private theorem fresh_triple_σ_facts (fun _ h => Hnot _ (List.mem_append_left _ h)) HargTemp have HOut := fresh_temps_not_defined Hgenrel.tmpAlign (fun _ h => Hnot _ (List.mem_append_right _ (List.mem_append_left _ h))) HoutTemp - have HOld := fresh_olds_not_defined Hgenrel.oldFresh HoldIdentsTemp + have HOld : Imperative.isNotDefined _ _ := fun v Hin => + Option.isNone_iff_eq_none.mp + (Hgenrel.oldFresh v ((List.Forall_mem_iff.mp HoldIdentsTemp) v Hin)) refine ⟨Hnd3, HArg, HOut, HOld, UpdateStatesNotDefMonotone (fun v Hv => ?_) Hupdate⟩ simp only [List.append_assoc, List.mem_append] at Hv rcases Hv with h | h | h @@ -1273,6 +1351,2477 @@ private theorem fresh_triple_σ_facts · exact HOut v h · exact HOld v h +/-- Bundle of WF/generated/Nodup facts threaded through the + `genArgExprIdentsTrip → genOutExprIdentsTrip → genOldExprIdents` + pipeline. Both call-elim arms (success and failure) need the same + Nodup-of-the-combined-list witness in order to invoke + `fresh_triple_σ_facts`; this helper absorbs the seven `have`-blocks + that previously expanded inline in each arm. -/ +private theorem genTrips_combined_nodup + {s0 s_arg s_out : Core.Transform.CoreTransformState} + {s_old : CoreGenState} + {inputs : @Lambda.LTySignature Visibility} {args : List Expression.Expr} + {argTrips : List ((Expression.Ident × Lambda.LTy) × Expression.Expr)} + {outputs : @Lambda.LTySignature Visibility} {lhs : List Expression.Ident} + {outTrips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)} + {oldVars : List Expression.Ident} + {genOldIdents : List Expression.Ident} + (Heqarg : Core.Transform.genArgExprIdentsTrip inputs args s0 + = (Except.ok argTrips, s_arg)) + (Heqout : Core.Transform.genOutExprIdentsTrip outputs lhs s_arg + = (Except.ok outTrips, s_out)) + (Heqold : Core.Transform.genOldExprIdents oldVars s_out.genState + = (genOldIdents, s_old)) + (Hwf0 : CoreGenState.WF s0.genState) : + (s0.genState.generated.reverse ++ + argTrips.unzip.fst.unzip.fst ++ + outTrips.unzip.fst.unzip.fst ++ + genOldIdents).Nodup := by + have Hwfgenargs : CoreGenState.WF s_arg.genState := + genArgExprIdentsTripWFMono Hwf0 Heqarg + have Hwfgenouts : CoreGenState.WF s_out.genState := + genOutExprIdentsTripWFMono Hwfgenargs Heqout + have Hwfgenolds : CoreGenState.WF s_old := + genOldExprIdentsTripWFMono Hwfgenouts Heqold + have Hgenargs : s_arg.genState.generated = + argTrips.unzip.fst.unzip.fst.reverse ++ s0.genState.generated := + genArgExprIdentsTripGeneratedWF Heqarg + have Hgenouts : s_out.genState.generated = + outTrips.unzip.fst.unzip.fst.reverse ++ s_arg.genState.generated := + genOutExprIdentsTripGeneratedWF Heqout + have Hgenolds : s_old.generated = + genOldIdents.reverse ++ s_out.genState.generated := + genOldExprIdents_GeneratedWF Heqold + have HgenApp : s_old.generated = + genOldIdents.reverse ++ + outTrips.unzip.fst.unzip.fst.reverse ++ + argTrips.unzip.fst.unzip.fst.reverse ++ + s0.genState.generated := by + rw [Hgenolds, Hgenouts, Hgenargs] + simp [List.append_assoc] + have HndOld : s_old.generated.Nodup := Hwfgenolds.right.right + rw [HgenApp] at HndOld + have Hnd := nodup_reverse HndOld + simp only [List.reverse_append, List.reverse_reverse, + ← List.append_assoc] at Hnd + exact Hnd + +/-- Prelude bundle for `HoldEval_bridge_at_σO` call sites. + + Both arms of `_terminal`'s call branch derive the same four facts: + the per-output `Hwf2.2`-bridge, `σAO`-reads-outputs, and the two + `oldVars`-subset facts (filtered into `lhs`/`outputs.keys`). -/ +private theorem holdEval_bridge_prelude + {δ : CoreEval} {σ₀ σ σA σAO σO : CoreStore} + {proc proc' : Procedure} {args : List (CallArg Expression)} + {oVals : List Expression.Expr} + (Hwf2 : WellFormedCoreEvalTwoState δ σ₀ σ) + (Hhav1 : HavocVars σAO (ListMap.keys proc.header.outputs) σO) + (Hinitout : + InitStates σA (ListMap.keys proc.header.outputs) oVals σAO) + (HprocEq : proc' = proc) : + (∀ v ∈ proc.header.outputs.keys, + δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) none) = σAO v) ∧ + ReadValues σAO proc.header.outputs.keys oVals ∧ + (∀ v ∈ callElim_oldVars proc' args, v ∈ CallArg.getLhs args) ∧ + (∀ v ∈ callElim_oldVars proc' args, + v ∈ ListMap.keys proc.header.outputs) := by + refine ⟨?_, InitStatesReadValues Hinitout, ?_, ?_⟩ + · intro v Hv + simp only [WellFormedCoreEvalTwoState] at Hwf2 + have HH := Hwf2.2 proc.header.outputs.keys [] σAO σO σO + ⟨Hhav1, InitVars.init_none⟩ v + exact HH.1 Hv + · intro v Hv + exact (List.mem_filter.mp Hv).1 + · intro v Hv + have Hv_filt := List.mem_filter.mp Hv + have Hbool := Hv_filt.2 + simp only [Bool.and_eq_true] at Hbool + have HinOuts' : (ListMap.keys proc'.header.outputs).contains v := Hbool.1.2 + rw [HprocEq] at HinOuts' + exact List.contains_iff_mem.mp HinOuts' + +/-- Per-index δ-eval bridge for `mkOld`-prefixed old-variable fvars at the + post-havoc store `σO`. + + For each `i < oldVars.length`, the evaluator at `σO` of the old-name + fvar `mkOld oldVars[i].name` returns the pre-call value `oldVals[i]`. + Backs the L6 `HoldSubBridge` derivation in `_terminal`'s call arm. + + Inputs: + * `Hwf2_univ`: per-output bridge `δ σO (mkOld v.name) = σAO v` (derived + from `Hwf2.2` instantiated at `(outputs.keys, [], σAO, σO, σO)` with + `Hhav1 ∧ InitVars.init_none`). + * `Hinitout`: positional init witness for outputs at `σA → σAO`. + * `HσAO_reads_outs`: `ReadValues σAO outputs.keys oVals` (just + `InitStatesReadValues Hinitout`). + * `Hevalouts`, `hCallArgsLhs`: caller-side lhs read + the callArgs + shape equality. + * `HoutAlign`: positional alignment from `WFCallSiteSpec` (lhs idx + agrees with outputs.keys idx for shared inout outputs). + * `HoldVars_sub_outs`, `HoldVars_sub_lhs`, `HoldVars_sub_callLhs`: + `oldVars` is the filter that narrows `lhs` ↪ `oldVars`, so each + element is in `outputs.keys`, `lhs`, and `CallArg.getLhs args`. + * `HoldVals`: `ReadValues σ oldVars oldVals`. + * `HoldValsLen`: `oldVals.length = oldVars.length`. -/ +private theorem HoldEval_bridge_at_σO + {δ : CoreEval} {σ σAO σO : CoreStore} + {oldVars lhs : List Expression.Ident} {oldVals oVals : List Expression.Expr} + {proc : Procedure} {args : List (CallArg Expression)} + {σA : CoreStore} + (Hwf2_univ : + ∀ v ∈ proc.header.outputs.keys, + δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) none) = σAO v) + (Hinitout : + InitStates σA (ListMap.keys proc.header.outputs) oVals σAO) + (HσAO_reads_outs : ReadValues σAO proc.header.outputs.keys oVals) + (Hevalouts : ReadValues σ lhs oVals) + (hCallArgsLhs : CallArg.getLhs args = lhs) + (HoutAlign : + ∀ v ∈ ListMap.keys proc.header.outputs, + v ∈ CallArg.getLhs args → + (CallArg.getLhs args).idxOf v = + (ListMap.keys proc.header.outputs).idxOf v) + (HoldVars_sub_outs : ∀ v ∈ oldVars, v ∈ proc.header.outputs.keys) + (HoldVars_sub_lhs : ∀ v ∈ oldVars, v ∈ lhs) + (HoldVars_sub_callLhs : ∀ v ∈ oldVars, v ∈ CallArg.getLhs args) + (HoldVals : ReadValues σ oldVars oldVals) + (HoldValsLen : oldVals.length = oldVars.length) : + ∀ (i : Nat) (Hi : i < oldVars.length), + δ σO + (Lambda.LExpr.fvar () + (CoreIdent.mkOld (oldVars[i]'Hi).name) none) = + some (oldVals[i]'(HoldValsLen.symm ▸ Hi)) := by + intro i Hi + let v : Expression.Ident := oldVars[i]'Hi + have Hv_mem : v ∈ oldVars := List.getElem_mem _ + have Hv_out : v ∈ ListMap.keys proc.header.outputs := + HoldVars_sub_outs v Hv_mem + have Hv_lhs : v ∈ lhs := HoldVars_sub_lhs v Hv_mem + have Hv_callLhs : v ∈ CallArg.getLhs args := + HoldVars_sub_callLhs v Hv_mem + -- ReadValues σ' ks vs ∧ v ∈ ks ⇒ σ' v = some vs[ks.idxOf v]. + have read_at : ∀ {σ' : Expression.Ident → Option _} + {ks : List Expression.Ident} {vs : List _} + (_ : ReadValues σ' ks vs) (Hmem : v ∈ ks) + (Hidx_lt : ks.idxOf v < vs.length), + σ' v = some (vs[ks.idxOf v]'Hidx_lt) := by + intro σ' ks vs Hrv Hmem Hidx_lt + have Hg := readValues_get (σ:=σ') (ks:=ks) (vs:=vs) Hrv + (i:=ks.idxOf v) + (hi:=List.idxOf_lt_length_of_mem Hmem) (hi':=Hidx_lt) + have Hk : ks[ks.idxOf v]'(List.idxOf_lt_length_of_mem Hmem) = v := by + unfold List.idxOf + simpa using @List.findIdx_getElem _ (· == v) ks + (List.idxOf_lt_length_of_mem Hmem) + rwa [Hk] at Hg + -- Step 1: δ σO (mkOld v.name) = σAO v. + have HStep1 : + δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) none) = σAO v := + Hwf2_univ v Hv_out + -- Step 2: σAO v = oVals[outputs.keys.idxOf v] via HσAO_reads_outs. + let j_out := (ListMap.keys proc.header.outputs).idxOf v + have Hj_out_lt_oVals : j_out < oVals.length := by + exact (InitStatesLength Hinitout).symm ▸ List.idxOf_lt_length_of_mem Hv_out + have HStep2 : σAO v = some (oVals[j_out]'Hj_out_lt_oVals) := + read_at HσAO_reads_outs Hv_out Hj_out_lt_oVals + -- Step 3: lhs.idxOf v = outputs.keys.idxOf v (alignment). + have HAlign_lhs : lhs.idxOf v = j_out := by + show lhs.idxOf v = (ListMap.keys proc.header.outputs).idxOf v + rw [← HoutAlign v Hv_out Hv_callLhs, hCallArgsLhs] + -- Step 4: σ v = oVals[lhs.idxOf v]'_. + let j_lhs := lhs.idxOf v + have Hj_lhs_lt_oVals : j_lhs < oVals.length := by + exact (ReadValuesLength Hevalouts).symm ▸ List.idxOf_lt_length_of_mem Hv_lhs + have HStep4 : σ v = some (oVals[j_lhs]'Hj_lhs_lt_oVals) := + read_at Hevalouts Hv_lhs Hj_lhs_lt_oVals + -- Step 5: σ v = some oldVals[i]'_ (HoldVals positional). + have Hi_oldVals : i < oldVals.length := HoldValsLen.symm ▸ Hi + have HStep5 : σ v = some (oldVals[i]'Hi_oldVals) := + readValues_get (σ:=σ) (ks:=oldVars) (vs:=oldVals) HoldVals + (i:=i) (hi:=Hi) (hi':=Hi_oldVals) + -- Combine: δ σO (mkOld v.name) = some oldVals[i]. + show δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) none) + = some (oldVals[i]'Hi_oldVals) + rw [HStep1, HStep2] + have Hj_eq : oVals[j_out]'Hj_out_lt_oVals = + oVals[j_lhs]'Hj_lhs_lt_oVals := by + congr 1; exact HAlign_lhs.symm + rw [Hj_eq, ← HStep4, HStep5] + +/-- Per-fvar bridge for `createOldVarsSubst`'s codomain at the L6 + intermediate stores `σ_R1`/`σO`. + + For any `(k, w) ∈ createOldVarsSubst oldTripsCanonical`, the evaluator + at `σ_R1` of `w` (a fresh-old `createFvar gen`) coincides with the + evaluator at `σO` of the fvar `k = mkOld oldVars[i].name`, because + both reduce to `some oldVals[i]` for the same positional `i`. + + Backs the L6 `Hsub` derivation: combines this with `HinputSubBridge` + (input-side codomain) to discharge `subst_fvars_eval_bridge`'s + sub-evaluator hypothesis on `oldSubst_L6 = createOldVarsSubst ++ + inputOnlyOldSubst`. + + Inputs: + * `oldTripsCanonical`: the canonical trip-list aligning `genOldIdents`, + `oldTys`, `oldVars`, and the `mkOld` keys. + * `HgenOldLen`, `HoldTysLen`, `HoldValsLen`: positional length facts. + * `σ_R1_read_olds`: positional reads `σ_R1 genOldIdents[i] = some oldVals[i]`. + * `HoldEval_bridge`: positional bridge from Stage 1's helper. -/ +private theorem HoldSubBridge_at_σO + {δ : CoreEval} {σ_R1 σO : CoreStore} + {oldVars genOldIdents : List Expression.Ident} + {oldTys : List Expression.Ty} + {oldVals : List Expression.Expr} + (Hwfvars : Imperative.WellFormedSemanticEvalVar δ) + (HgenOldLen : genOldIdents.length = oldVars.length) + (HoldTysLen : oldTys.length = oldVars.length) + (HoldValsLen : oldVals.length = oldVars.length) + (σ_R1_read_olds : + ∀ (i : Nat) (Hi : i < genOldIdents.length) + (Hi' : i < oldVals.length), + σ_R1 (genOldIdents[i]'Hi) = some (oldVals[i]'Hi')) + (HoldEval_bridge : + ∀ (i : Nat) (Hi : i < oldVars.length), + δ σO + (Lambda.LExpr.fvar () + (CoreIdent.mkOld (oldVars[i]'Hi).name) none) = + some (oldVals[i]'(HoldValsLen.symm ▸ Hi))) : + ∀ k w, + Map.find? + (Core.Transform.createOldVarsSubst + ((((genOldIdents.zip oldTys).zip oldVars).zip + (oldVars.map (fun g => CoreIdent.mkOld g.name))).map + fun (((fresh, ty), _orig), oldG) => ((fresh, ty), oldG))) k = some w → + δ σ_R1 w = + δ σO (Lambda.LExpr.fvar () k none) := by + -- Generic δ-fvar lookup derived from Hwfvars. + have δ_fvar_eq := delta_fvar_eq_of_wfvars Hwfvars (delta := δ) + intro k w Hf + obtain ⟨ni_val, Hni_lt, Hk_eqMkOld, Hw_eq⟩ := + createOldVarsSubst_pos_decomp HgenOldLen HoldTysLen Hf + have Hni_lt_genOld : ni_val < genOldIdents.length := HgenOldLen.symm ▸ Hni_lt + have Hni_lt_oldVals : ni_val < oldVals.length := HoldValsLen.symm ▸ Hni_lt + have HrdR1_get : + σ_R1 (genOldIdents[ni_val]'Hni_lt_genOld) = + some (oldVals[ni_val]'Hni_lt_oldVals) := + σ_R1_read_olds ni_val Hni_lt_genOld Hni_lt_oldVals + have HwfL : + δ σ_R1 (Core.Transform.createFvar + (genOldIdents[ni_val]'Hni_lt_genOld)) = + σ_R1 (genOldIdents[ni_val]'Hni_lt_genOld) := + δ_fvar_eq σ_R1 _ + have HoldEv : + δ σO (Lambda.LExpr.fvar () + (CoreIdent.mkOld + (oldVars[ni_val]'Hni_lt).name) + none) = + some (oldVals[ni_val]'Hni_lt_oldVals) := + HoldEval_bridge ni_val Hni_lt + rw [Hw_eq, HwfL, HrdR1_get, Hk_eqMkOld, HoldEv] + +/-- Class-(b1) decomposition for `Hinv`/`Hpred_disj` derivations: when + `oldSubst_L6 = createOldVarsSubst oldTripsCanonical_L6 ++ + callElim_inputOnlyOldSubst proc' args` and a variable hits a key in + the `createOldVarsSubst` segment, the codomain entry is a fresh-old + `createFvar gen` and the variable equals that fresh ident. + + Used by L6's `Hinv` and `Hpred_disj` to walk the substitution split: + when a `find?` lookup in `oldSubst_L6` lands in the old-trip side, + the witness `var ∈ getVars w` collapses (since `w` is a single fvar) + and forces `var = genOldIdents[i]` for the same positional `i`. -/ +private theorem b1_var_witness_at_oldSubst + {oldVars genOldIdents : List Expression.Ident} + {oldTys : List Expression.Ty} + {proc' : Procedure} {args : List (CallArg Expression)} + (HgenOldLen : genOldIdents.length = oldVars.length) + (HoldTysLen : oldTys.length = oldVars.length) : + ∀ {var : Expression.Ident} + {k : Expression.Ident} {w w' : Expression.Expr} + (_hfind : Map.find? + (Core.Transform.createOldVarsSubst + ((((genOldIdents.zip oldTys).zip oldVars).zip + (oldVars.map (fun g => CoreIdent.mkOld g.name))).map + fun (((fresh, ty), _orig), oldG) => ((fresh, ty), oldG))) k = some w') + (_Hf : Map.find? + (Core.Transform.createOldVarsSubst + ((((genOldIdents.zip oldTys).zip oldVars).zip + (oldVars.map (fun g => CoreIdent.mkOld g.name))).map + fun (((fresh, ty), _orig), oldG) => ((fresh, ty), oldG)) ++ + callElim_inputOnlyOldSubst proc' args) k = some w) + (_Hv_in : var ∈ Imperative.HasVarsPure.getVars (P:=Expression) w), + ∃ (ni : Nat) (Hni : ni < genOldIdents.length), + w = Core.Transform.createFvar + (genOldIdents[ni]'Hni) ∧ + var = genOldIdents[ni]'Hni := by + intro var k w w' hfind Hf Hv_in + have Hw'w : w' = w := find?_append_some_eq hfind Hf + obtain ⟨ni_val, Hni_lt, _Hk_eqMkOld, Hw'_eq⟩ := + createOldVarsSubst_pos_decomp HgenOldLen HoldTysLen hfind + have Hni_lt_genOld : ni_val < genOldIdents.length := HgenOldLen.symm ▸ Hni_lt + have Hw_eq : w = + Core.Transform.createFvar + (genOldIdents[ni_val]'Hni_lt_genOld) := by + rw [← Hw'w]; exact Hw'_eq + refine ⟨ni_val, Hni_lt_genOld, Hw_eq, ?_⟩ + rw [Hw_eq] at Hv_in + have Hv_in' : + var ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Core.Transform.createFvar + (genOldIdents[ni_val]'Hni_lt_genOld)) := Hv_in + show var = _ + simp [Core.Transform.createFvar, + Imperative.HasVarsPure.getVars, + Lambda.LExpr.LExpr.getVars] at Hv_in' + exact Hv_in' + +/-- Class-(b2) decomposition for `Hinv`/`Hpred_disj`: when the lookup + misses `createOldVarsSubst` and hits `callElim_inputOnlyOldSubst`, + the codomain entry is a positional `inArgs` element and the variable + appears in the flatMap of `inArgs`'s free vars. + + Companion to `b1_var_witness_at_oldSubst`. -/ +private theorem b2_var_witness_at_oldSubst + {oldVars genOldIdents : List Expression.Ident} + {oldTys : List Expression.Ty} + {proc' : Procedure} {args : List (CallArg Expression)} + {inArgs : List Expression.Expr} + (hCallArgsIn : CallArg.getInputExprs args = inArgs) : + ∀ {var : Expression.Ident} + {k : Expression.Ident} {w : Expression.Expr} + (_hfind_none : Map.find? + (Core.Transform.createOldVarsSubst + ((((genOldIdents.zip oldTys).zip oldVars).zip + (oldVars.map (fun g => CoreIdent.mkOld g.name))).map + fun (((fresh, ty), _orig), oldG) => ((fresh, ty), oldG))) k = none) + (_Hf : Map.find? + (Core.Transform.createOldVarsSubst + ((((genOldIdents.zip oldTys).zip oldVars).zip + (oldVars.map (fun g => CoreIdent.mkOld g.name))).map + fun (((fresh, ty), _orig), oldG) => ((fresh, ty), oldG)) ++ + callElim_inputOnlyOldSubst proc' args) k = some w) + (_Hv_in : var ∈ Imperative.HasVarsPure.getVars (P:=Expression) w), + w ∈ CallArg.getInputExprs args ∧ + var ∈ List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + inArgs := by + intro var k w hfind_none Hf Hv_in + obtain ⟨ni2_val, _Hni2_lt_inKeys, Hni2_lt_inArgs, + _Hk_eq_proc', Hw_eq_proc', _Hin_notin_outs⟩ := + inputOnlyOldSubst_pos_decomp + (find?_append_none_elim hfind_none Hf) + have HargExpr_def : + w = (CallArg.getInputExprs args)[ni2_val]'Hni2_lt_inArgs := + Hw_eq_proc' + have Hni2_lt_inArgsCall : + ni2_val < inArgs.length := by + have : (CallArg.getInputExprs args).length = + inArgs.length := by rw [hCallArgsIn] + exact this.symm ▸ Hni2_lt_inArgs + have HargExpr_eq_inArgs : + w = inArgs[ni2_val]'Hni2_lt_inArgsCall := by + rw [HargExpr_def] + show (CallArg.getInputExprs args)[ni2_val]'Hni2_lt_inArgs = + inArgs[ni2_val]'Hni2_lt_inArgsCall + congr 1 <;> exact hCallArgsIn + have Hk1_in_inArgs : w ∈ inArgs := by + rw [HargExpr_eq_inArgs]; exact List.getElem_mem _ + have HargExpr_in : w ∈ CallArg.getInputExprs args := by + rw [HargExpr_def]; exact List.getElem_mem _ + have Hk1_flat : + var ∈ List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + inArgs := by + rw [List.mem_flatMap] + exact ⟨w, Hk1_in_inArgs, Hv_in⟩ + exact ⟨HargExpr_in, Hk1_flat⟩ + +/-- Per-fvar bridge for `callElim_inputOnlyOldSubst`'s codomain at the L6 + intermediate stores `σ_R1`/`σO`. + + For any `(k, w) ∈ callElim_inputOnlyOldSubst proc' args`, the evaluator + at `σ_R1` of `w` (a positional `inArgs` element) coincides with the + evaluator at `σO` of the fvar `k = mkOld inputId.name`, because both + reduce to `some argVals[ni]` for the same positional `ni`. + + Mirror of `HoldSubBridge_at_σO` for the input-only old substitution + map; backs the L6 `Hsub` derivation in both the success and failure + arms of `callElimStatementCorrect`'s call-statement case. -/ +private theorem HinputSubBridge_at_σO + {δ : CoreEval} + {σ σ_R1 σO σAO σA σ₀ σ₂ : CoreStore} + {γ : CoreTransformState} + {genOldIdents : List Expression.Ident} + {oldVals argVals : List Expression.Expr} + {proc proc' : Procedure} + {args : List (CallArg Expression)} + {inArgs : List Expression.Expr} + {oVals : List Expression.Expr} + (Hwfvars : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfval : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hwf2 : WellFormedCoreEvalTwoState δ σ₀ σ₂) + (HprocEq : proc' = proc) + (Hiodisj : + (proc.header.inputs.keys).Disjoint + (proc.header.outputs.keys)) + (Hinitin : + InitStates σ proc.header.inputs.keys argVals σA) + (Hinitout : + InitStates σA proc.header.outputs.keys oVals σAO) + (Hhav1 : HavocVars σAO proc.header.outputs.keys σO) + (HInitVars_empty : InitVars σO [] σO) + (Hevalargs : + EvalExpressions (P:=Expression) δ σ inArgs argVals) + (hCallArgsIn : CallArg.getInputExprs args = inArgs) + (HargIsDef : + ∀ v ∈ List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + inArgs, + (σ v).isSome) + (HoldIdentsTemp : + Forall (fun x => isOldTempIdent x) genOldIdents) + (Hgenrel : CoreGenStateRel σ γ) + (HargVarsNotInInKeys : + ∀ argExpr ∈ CallArg.getInputExprs args, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, + v ∉ proc.header.inputs.keys) + (HargVarsNotInOutKeys : + ∀ argExpr ∈ CallArg.getInputExprs args, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, + v ∉ proc.header.outputs.keys) + (Hσ_R1_eq : + σ_R1 = updatedStates σO genOldIdents oldVals) : + ∀ k w, + Map.find? + (callElim_inputOnlyOldSubst proc' args) k = some w → + δ σ_R1 w = + δ σO (Lambda.LExpr.fvar () k none) := by + -- Generic δ-fvar lookup derived from Hwfvars. + have δ_fvar_eq := delta_fvar_eq_of_wfvars Hwfvars (delta := δ) + intro k w Hf + obtain ⟨ni_val, Hni_lt_inKeys, Hni_lt_inArgs, + Hk_eq_proc', Hw_eq_proc', _Hin_notin_outs_proc'⟩ := + inputOnlyOldSubst_pos_decomp Hf + have Hni_lt_inKeys' : + ni_val < proc.header.inputs.keys.length := by + have HEqLen : proc'.header.inputs.keys.length = + proc.header.inputs.keys.length := by rw [HprocEq] + omega + have HpinKeys : + proc'.header.inputs.keys[ni_val]'Hni_lt_inKeys = + proc.header.inputs.keys[ni_val]'Hni_lt_inKeys' := by + subst HprocEq; rfl + let inputId : Expression.Ident := + proc.header.inputs.keys[ni_val]'Hni_lt_inKeys' + have HinputId_in : inputId ∈ proc.header.inputs.keys := + List.getElem_mem _ + have HinputId_notin_outs : + inputId ∉ proc.header.outputs.keys := + fun h => Hiodisj HinputId_in h + let argExpr : Expression.Expr := + (CallArg.getInputExprs args)[ni_val]'Hni_lt_inArgs + have HargExpr_in : argExpr ∈ CallArg.getInputExprs args := + List.getElem_mem _ + have Hk_mkOld : k = CoreIdent.mkOld inputId.name := by + rw [Hk_eq_proc', HpinKeys] + have Hw_argExpr : w = argExpr := Hw_eq_proc' + let ni : Fin (CallArg.getInputExprs args).length := + ⟨ni_val, Hni_lt_inArgs⟩ + have Hni_lt_inArgsCall : ni.val < inArgs.length := by + have : (CallArg.getInputExprs args).length = + inArgs.length := by rw [hCallArgsIn] + rw [← this] + exact Hni_lt_inArgs + have HargExpr_eq_inArgs : + argExpr = inArgs[ni.val]'Hni_lt_inArgsCall := by + show (CallArg.getInputExprs args)[ni.val]'Hni_lt_inArgs = + inArgs[ni.val]'Hni_lt_inArgsCall + congr 1 <;> exact hCallArgsIn + have HinKeys_argVals_len : + proc.header.inputs.keys.length = argVals.length := + InitStatesLength Hinitin + have Hni_lt_argVals : ni.val < argVals.length := by + exact HinKeys_argVals_len.symm ▸ Hni_lt_inKeys' + have σO_eq_σAO_off_outs : + ∀ {v}, v ∉ proc.header.outputs.keys → σO v = σAO v := by + obtain ⟨_ovh, Hup_havoc⟩ := HavocVarsUpdateStates Hhav1 + intro v Hv + rw [UpdateStatesUpdated Hup_havoc, updatedStates_get_notin Hv] + have HRHS_oldEqArgVal : + δ σO (Lambda.LExpr.fvar () + (CoreIdent.mkOld inputId.name) none) = + some (argVals[ni.val]'Hni_lt_argVals) := by + simp only [WellFormedCoreEvalTwoState] at Hwf2 + rw [(Hwf2.2 proc.header.outputs.keys [] σAO σO σO + ⟨Hhav1, HInitVars_empty⟩ inputId).2 HinputId_notin_outs, + σO_eq_σAO_off_outs HinputId_notin_outs, + initStates_get_notin Hinitout HinputId_notin_outs] + exact readValues_get (InitStatesReadValues Hinitin) + (i:=ni.val) (hi:=Hni_lt_inKeys') (hi':=Hni_lt_argVals) + have HRHS_StepE : + δ σ argExpr = + some (argVals[ni.val]'Hni_lt_argVals) := by + have Hev := evalExpressions_get Hevalargs + Hni_lt_inArgsCall Hni_lt_argVals + have HargList : + List.get inArgs ⟨ni.val, Hni_lt_inArgsCall⟩ = + inArgs[ni.val]'Hni_lt_inArgsCall := rfl + have HvalList : + List.get argVals ⟨ni.val, Hni_lt_argVals⟩ = + argVals[ni.val]'Hni_lt_argVals := rfl + rw [HargList, HvalList] at Hev + exact HargExpr_eq_inArgs ▸ Hev + have HargExpr_in_argList : argExpr ∈ inArgs := by + exact HargExpr_eq_inArgs ▸ List.getElem_mem _ + have HargExpr_in_callList : + argExpr ∈ CallArg.getInputExprs args := HargExpr_in + have Hσ_R1_eq_σ_argVars : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) + argExpr, + σ_R1 v = σ v := by + intro v Hv + have Hσv_some : (σ v).isSome := HargIsDef v <| + List.mem_flatMap.mpr ⟨argExpr, HargExpr_in_argList, Hv⟩ + have HvNotGen : v ∉ genOldIdents := + notMem_of_Forall_neg HoldIdentsTemp fun Hold => + σ_some_contradiction Hσv_some + (Option.isNone_iff_eq_none.mp (Hgenrel.oldFresh v Hold)) + rw [Hσ_R1_eq] + exact σR1_eq_σ_for_notTouched Hinitin Hinitout Hhav1 + (HargVarsNotInInKeys argExpr HargExpr_in_callList v Hv) + (HargVarsNotInOutKeys argExpr HargExpr_in_callList v Hv) + HvNotGen + have Hδ_R1_eq_δ_σ : + δ σ_R1 argExpr = δ σ argExpr := by + have Hsurv : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) + argExpr, + Map.find? (∅ : Map Expression.Ident + Expression.Expr) v = none → + δ σ_R1 (Lambda.LExpr.fvar () v none) = + δ σ (Lambda.LExpr.fvar () v none) := by + intro v Hv _ + rw [δ_fvar_eq σ_R1 v, δ_fvar_eq σ v] + exact Hσ_R1_eq_σ_argVars v Hv + have Hsub : + ∀ k' w', k' ∈ Imperative.HasVarsPure.getVars + (P:=Expression) argExpr → + Map.find? (∅ : Map Expression.Ident + Expression.Expr) k' = some w' → + δ σ_R1 w' = + δ σ (Lambda.LExpr.fvar () k' none) := by + intro k' w' _ Hf + simp [Map.find?] at Hf + have Hbridge : + δ σ_R1 (Lambda.LExpr.substFvars argExpr + (∅ : Map Expression.Ident + Expression.Expr)) = + δ σ argExpr := + subst_fvars_eval_bridge Hwfc Hwfvars Hwfval + (sm:=∅) + Hsurv Hsub + have HsubstEmpty : + Lambda.LExpr.substFvars argExpr + (∅ : Map Expression.Ident Expression.Expr) = + argExpr := by + induction argExpr with + | fvar m name ty => + rw [Lambda.LExpr.substFvars_fvar_none m name ty]; rfl + | _ => simp [Lambda.LExpr.substFvars_abs, + Lambda.LExpr.substFvars_quant, + Lambda.LExpr.substFvars_app, + Lambda.LExpr.substFvars_eq, + Lambda.LExpr.substFvars_ite, *] + rwa [HsubstEmpty] at Hbridge + rw [Hw_argExpr, Hδ_R1_eq_δ_σ, HRHS_StepE, + ← HRHS_oldEqArgVal, ← Hk_mkOld] + +/-- Call-arm failure-flag branch of `callElimStatementCorrect_terminal`. + + Discharges the `f = true` (precondition-failure) case after the call_sem + destructure: builds the failing assert chain via `H_asserts_zip_fail`, + havocs via `H_havocs_poly`, assumes via `H_assumes_zip_poly`, and glues + via `EvalCallElim_glue_fail`. The bool-totality witness for the failing + precondition is extracted from `WFCallSiteProp.preBoolTyped` (boolTyped + clause on `WFPrePostProp`) combined with `Hpre_iff.mpr`'s contrapositive. + + All inputs after `Hwfcallsite` are the destructured outputs from + `cases Hcc with | call_sem ...` at `failed = true`. -/ +private theorem callElimStatementCorrect_terminal_call_arm_fail + [LawfulBEq Expression.Expr] + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} + {σ σ' : CoreStore} + {p : Program} + {γ s_ce : CoreTransformState} + {procName : String} + {args : List (CallArg Expression)} + {md : Imperative.MetaData Expression} + {s' : List Statement} + {lhs : List Expression.Ident} + {σ₀ σA σAO σO : CoreStore} + {inArgs : List Expression.Expr} + {oVals argVals modvals : List Expression.Expr} + {proc : Procedure} + (Hp : ∀ pname, π pname = Program.Procedure.find? p ⟨pname, ()⟩) + (Hwfc : WellFormedCoreEvalCong δ) + (Hwf : WF.WFStatementsProp p [.cmd (CmdExt.call procName args md)]) + (Hgenrel : CoreGenStateRel σ γ) + (Hwfcallsite : WFCallSiteProp p π (.cmd (CmdExt.call procName args md))) + (heq_ce : + CallElim.callElimCmd (CmdExt.call procName args md) + { γ with currentProgram := some p } = + (Except.ok (some s'), s_ce)) + (lkup : π procName = .some proc) + (hCallArgsIn : CallArg.getInputExprs args = inArgs) + (hCallArgsLhs : CallArg.getLhs args = lhs) + (Hevalargs : EvalExpressions (P:=Expression) δ σ inArgs argVals) + (Hevalouts : ReadValues σ lhs oVals) + (Hwfval : Imperative.WellFormedSemanticEvalVal δ) + (Hwfvars : Imperative.WellFormedSemanticEvalVar δ) + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (Hwf2 : WellFormedCoreEvalTwoState δ σ₀ σ) + (Hinitin : + InitStates σ (ListMap.keys proc.header.inputs) argVals σA) + (Hinitout : + InitStates σA (ListMap.keys proc.header.outputs) oVals σAO) + (Hpre_def : + ∀ pre, (Procedure.Spec.getCheckExprs + (proc.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free))).contains pre → + Imperative.isDefinedOver (Imperative.HasVarsPure.getVars) σAO pre) + (Hpre_iff : + true = false ↔ + ∀ pre, (Procedure.Spec.getCheckExprs + (proc.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free))).contains pre → + δ σAO pre = .some Imperative.HasBool.tt) + (Hhav1 : + HavocVars σAO (ListMap.keys proc.header.outputs) σO) + (Hpost : + ∀ post, (Procedure.Spec.getCheckExprs proc.spec.postconditions).contains post → + Imperative.isDefinedOver (Imperative.HasVarsPure.getVars) σAO post ∧ + δ σO post = .some Imperative.HasBool.tt) + (Hrd : + ReadValues σO (ListMap.keys proc.header.outputs) modvals) + (Hupdate : UpdateStates σ lhs modvals σ') : + ∃ σ'', + Inits σ' σ'' ∧ + EvalStatementsContract π φ ⟨σ, δ, false⟩ s' ⟨σ'', δ, true⟩ := by + -- B1-tail: destructure heq_ce via callElimCmd_call_eq. + obtain ⟨proc', argTrips, outTrips, genOldIdents, oldTys, + asserts, assumes, + s_arg, s_out, s_old, + Hfind, Heqarg, Heqout, Heqold, Holdtylen, + Hsts_struct, HassertsShape, _HassumesShape⟩ := + callElimCmd_call_eq heq_ce + have Heqargs : argTrips.unzip.snd = + CallArg.getInputExprs args := + genArgExprIdentsTrip_snd Heqarg + have Heqouts : outTrips.unzip.snd = + CallArg.getLhs args := + genOutExprIdentsTrip_snd Heqout + -- Hoisted: arg-expr vars defined in σ (via Hevalargs). + have HargIsDef : Imperative.isDefined σ + (List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + inArgs) := + evalExpressions_isDefined_flatMap Hevalargs + -- Hoisted abbreviations for argument/output temp idents. + let argTemps : List Expression.Ident := + argTrips.unzip.fst.unzip.fst + let outTemps : List Expression.Ident := + outTrips.unzip.fst.unzip.fst + -- C1: aux facts derived from the destructured binders. + have HargTemp : + Forall (fun x => isTempIdent x) argTemps := + genArgExprIdentsTrip_isTempIdent Heqarg + have HoutTemp : + Forall (fun x => isTempIdent x) outTemps := + genOutExprIdentsTrip_isTempIdent Heqout + have HoldIdentsTemp : + Forall (fun x => isOldTempIdent x) genOldIdents := + genOldExprIdents_isOldTempIdent Heqold + have Hgennd' : + (γ.genState.generated.reverse ++ + argTemps ++ outTemps ++ genOldIdents).Nodup := by + apply genTrips_combined_nodup Heqarg Heqout Heqold + exact Hgenrel.wfgen + obtain ⟨Hgennd, HndefArg_σ, HndefOut_σ, HndefOld_σ, Hndefgen⟩ := + fresh_triple_σ_facts Hgenrel Hgennd' HargTemp HoutTemp + HoldIdentsTemp Hupdate + -- ── Length facts ── + have Hargtriplen : argTrips.length = argVals.length := by + rw [← List.unzip_snd_length argTrips, Heqargs, hCallArgsIn] + exact EvalExpressionsLength Hevalargs + have Houttriplen : outTrips.length = oVals.length := by + rw [← List.unzip_snd_length outTrips, Heqouts, hCallArgsLhs] + exact ReadValuesLength Hevalouts + have HargTempsLen : argTemps.length = argVals.length := by + simp [argTemps, List.unzip_eq_map, Hargtriplen] + have HoutTempsLen : outTemps.length = oVals.length := by + simp [outTemps, List.unzip_eq_map, Houttriplen] + -- C1: Derive Hinoutnd from the call_sem InitStates binders. + have Hinnd_io : (proc.header.inputs.keys).Nodup := + InitStatesNodup Hinitin + have Houtnd_io : (proc.header.outputs.keys).Nodup := + InitStatesNodup Hinitout + have Hindef_io : + Imperative.isDefined σA (proc.header.inputs.keys) := + InitStatesDefined Hinitin + have Houtndef_io : + Imperative.isNotDefined σA (proc.header.outputs.keys) := + InitStatesNotDefined Hinitout + have Hiodisj : + (proc.header.inputs.keys).Disjoint + (proc.header.outputs.keys) := by + intro x Hin1 Hin2 + exact σ_some_contradiction + (Hindef_io x Hin1) (Houtndef_io x Hin2) + have Hinoutnd : + (proc.header.inputs.keys ++ + proc.header.outputs.keys).Nodup := by + rw [List.nodup_append] + refine ⟨Hinnd_io, Houtnd_io, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact Hiodisj Ha Hb + -- C2: bind `oldVars`. + let oldVars : List Expression.Ident := callElim_oldVars proc' args + have HrdOldDef : Imperative.isDefined σ oldVars := by + intro g Hg + have Hg_in_getLhs : g ∈ CallArg.getLhs args := + (List.mem_filter.mp Hg).1 + have Hg_in_lhs : g ∈ lhs := hCallArgsLhs ▸ Hg_in_getLhs + have Hlhs_def : Imperative.isDefined σ lhs := + ReadValuesIsDefined Hevalouts + exact Hlhs_def g Hg_in_lhs + obtain ⟨oldVals, HoldVals⟩ := + isDefinedReadValues HrdOldDef + have HoldValsLen : oldVals.length = oldVars.length := + (ReadValuesLength HoldVals).symm + have HgenOldLen : genOldIdents.length = oldVars.length := + genOldExprIdents_length Heqold + have HoldTysLen : oldTys.length = oldVars.length := Holdtylen + have HgenOldOldValsLen : genOldIdents.length = oldVals.length := by + rw [HgenOldLen, ← HoldValsLen] + -- C3: σ'' candidate. + have Hinit := + updatedStatesInit (P := Expression) ?_ ?_ ?_ (σ := σ') + (hs := argTemps + ++ outTemps + ++ genOldIdents) + (vs := argVals ++ oVals ++ oldVals) + rotate_left + · simp [argTemps, outTemps, List.length_append, List.unzip_eq_map, + Hargtriplen, Houttriplen, HgenOldOldValsLen] + · exact Hndefgen + · exact Hgennd + refine ⟨updatedStates σ' + (argTemps + ++ outTemps + ++ genOldIdents) + (argVals ++ oVals ++ oldVals), ?_, ?_⟩ + · exact InitStatesInits Hinit + · -- L1-L6 chain via EvalCallElim_glue_fail. + obtain ⟨HargNd, HoutNd, HoldNd, + HargOutDisj, HargOldDisj, HoutOldDisj⟩ := + List.nodup_3_decompose Hgennd + -- argTemps fresh from σ; arg-expr vars defined in σ ⇒ disjoint. + have HdefVars : Imperative.isDefined σ + (List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + (CallArg.getInputExprs args)) := + hCallArgsIn ▸ HargIsDef + have HargExprDisj : + argTemps.Disjoint + (List.flatMap + (Imperative.HasVarsPure.getVars (P:=Expression)) + argTrips.unzip.snd) := by + intro x Hin1 Hin2 + rw [Heqargs] at Hin2 + exact notin_of_isSome_isNotDefined (HdefVars x Hin2) HndefArg_σ Hin1 + -- ── L1: argInit ── + have HevalArgs' : + EvalExpressions (P:=Core.Expression) δ σ + argTrips.unzip.snd argVals := by + rw [Heqargs, hCallArgsIn] + exact Hevalargs + have HL1 : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + (Core.Transform.createInits argTrips md) + ⟨updatedStates σ argTemps + argVals, δ, false⟩ := + H_inits Hwfvars Hwfval Hwfc HargExprDisj HargNd + HevalArgs' HndefArg_σ + -- L2: outInit (lift Hevalouts to σ_arg via readValues_updatedStates). + have Hlhs_isLocl : + Imperative.isDefined σ lhs := + ReadValuesIsDefined Hevalouts + have HlhsDisjArg : lhs.Disjoint argTemps := fun x Hin1 Hin2 => + notin_of_isSome_isNotDefined (Hlhs_isLocl x Hin1) HndefArg_σ Hin2 + have HlhsDisjOut : lhs.Disjoint outTemps := fun x Hin1 Hin2 => + notin_of_isSome_isNotDefined (Hlhs_isLocl x Hin1) HndefOut_σ Hin2 + have HlhsDisjOld : lhs.Disjoint genOldIdents := fun x Hin1 Hin2 => + notin_of_isSome_isNotDefined (Hlhs_isLocl x Hin1) HndefOld_σ Hin2 + have HoutSnd_eq_lhs : outTrips.unzip.snd = lhs := by + rw [Heqouts, hCallArgsLhs] + have HlhsNd : lhs.Nodup := by + have Hwfst_head := (List.Forall_cons _ _ _).mp Hwf + have Hwfcall : WF.WFcallProp p procName args := Hwfst_head.1 + have Hlhs_args_nd : + (CallArg.getLhs args).Nodup := Hwfcall.lhsWF + rwa [hCallArgsLhs] at Hlhs_args_nd + have Hout_nd_app : + List.Nodup (outTemps + ++ outTrips.unzip.snd) := by + rw [HoutSnd_eq_lhs] + rw [List.nodup_append] + refine ⟨HoutNd, HlhsNd, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact HlhsDisjOut Hb Ha + have HrdOuts_argLayer : + ReadValues + (updatedStates σ argTemps + argVals) + outTrips.unzip.snd oVals := by + exact HoutSnd_eq_lhs ▸ readValues_updatedStates HargTempsLen HlhsDisjArg Hevalouts + have HndefOut_argLayer : + Imperative.isNotDefined + (updatedStates σ argTemps + argVals) + outTemps := by + intro v Hv + have Hv_notin : v ∉ argTemps := fun Hin => HargOutDisj Hin Hv + exact (updatedStates_get_notin (σ:=σ) (ks:=argTemps) (vs:=argVals) Hv_notin) ▸ HndefOut_σ v Hv + have HL2 : + EvalStatementsContract π φ + ⟨updatedStates σ argTemps + argVals, δ, false⟩ + (Core.Transform.createInitVars outTrips md) + ⟨updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals, δ, false⟩ := + H_initVars Hwfvars Hout_nd_app HrdOuts_argLayer + HndefOut_argLayer + -- L3: oldInit; oldTrips := (genOldIdents.zip oldTys).zip oldVars. + let oldTrips : + List ((Expression.Ident × Expression.Ty) × + Expression.Ident) := + (genOldIdents.zip oldTys).zip oldVars + have HoldTripsFst : + oldTrips.unzip.fst.unzip.fst = genOldIdents := by + have HzipLen : + (genOldIdents.zip oldTys).length = oldVars.length := by + simp [List.length_zip, HgenOldLen, HoldTysLen] + show ((genOldIdents.zip oldTys).zip oldVars).unzip.fst.unzip.fst + = genOldIdents + simp [List.unzip_eq_map, List.map_fst_zip, HzipLen, + HgenOldLen, HoldTysLen] + have HoldTripsSnd : + oldTrips.unzip.snd = oldVars := by + have HzipLen : + (genOldIdents.zip oldTys).length = oldVars.length := by + simp [List.length_zip, HgenOldLen, HoldTysLen] + rw [show oldTrips = (genOldIdents.zip oldTys).zip oldVars + from rfl] + simp [List.unzip_eq_map, List.map_snd_zip, HzipLen] + have HoldVars_sub_lhs : ∀ g ∈ oldVars, g ∈ lhs := by + intro g Hg + have Hg_in_getLhs : g ∈ CallArg.getLhs args := + (List.mem_filter.mp Hg).1 + exact hCallArgsLhs ▸ Hg_in_getLhs + have oldVars_disj_via_lhs : + ∀ {ks : List Expression.Ident}, lhs.Disjoint ks → oldVars.Disjoint ks := + fun H x Hin1 Hin2 => H (HoldVars_sub_lhs x Hin1) Hin2 + have HoldVarsDisjArg : oldVars.Disjoint argTemps := oldVars_disj_via_lhs HlhsDisjArg + have HoldVarsDisjOut : oldVars.Disjoint outTemps := oldVars_disj_via_lhs HlhsDisjOut + have HoldVarsDisjOldT : oldVars.Disjoint genOldIdents := oldVars_disj_via_lhs HlhsDisjOld + have HoldVarsNd : oldVars.Nodup := by + have HlhsArgs_nd : (CallArg.getLhs args).Nodup := hCallArgsLhs ▸ HlhsNd + exact List.Sublist.nodup List.filter_sublist HlhsArgs_nd + have HrdOlds_outLayer : + ReadValues + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldVars oldVals := + readValues_updatedStates HoutTempsLen HoldVarsDisjOut + (readValues_updatedStates HargTempsLen HoldVarsDisjArg HoldVals) + have HrdOldTrips : + ReadValues + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.snd oldVals := by + exact HoldTripsSnd ▸ HrdOlds_outLayer + have HndefOld_outLayer : + Imperative.isNotDefined + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + genOldIdents := by + intro v Hv + have Hv_notin_out : ¬ v ∈ outTemps := fun Hin => HoutOldDisj Hin Hv + have Hv_notin_arg : ¬ v ∈ argTemps := fun Hin => HargOldDisj Hin Hv + rw [updatedStates_2layer_get_notin + Hv_notin_arg Hv_notin_out] + exact HndefOld_σ v Hv + have HndefOldTrips : + Imperative.isNotDefined + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst := by + exact HoldTripsFst ▸ HndefOld_outLayer + have HoldTrips_nd_app : + List.Nodup + (oldTrips.unzip.fst.unzip.fst ++ oldTrips.unzip.snd) := by + rw [HoldTripsFst, HoldTripsSnd] + rw [List.nodup_append] + refine ⟨HoldNd, HoldVarsNd, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact HoldVarsDisjOldT Hb Ha + have HL3 : + EvalStatementsContract π φ + ⟨updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals, δ, false⟩ + (Core.Transform.createInitVars oldTrips md) + ⟨updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals, δ, false⟩ := + H_initVars Hwfvars HoldTrips_nd_app HrdOldTrips + HndefOldTrips + rw [Hsts_struct] + -- L5 setup: build havocs from σ_old to σ_havoc, polymorphic-flag. + have Hhav_σ : HavocVars σ lhs σ' := + UpdateStatesHavocVars Hupdate + have Hhav_arg : + HavocVars (updatedStates σ + argTemps argVals) + lhs + (updatedStates σ' + argTemps argVals) := + havocVars_updatedStates_lift HlhsDisjArg Hhav_σ + have Hhav_out : + HavocVars + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + lhs + (updatedStates + (updatedStates σ' + argTemps argVals) + outTemps oVals) := + havocVars_updatedStates_lift HlhsDisjOut Hhav_arg + have Hhav_old : + HavocVars + (updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) + lhs + (updatedStates + (updatedStates + (updatedStates σ' + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) := by + rw [HoldTripsFst] + apply havocVars_updatedStates_lift HlhsDisjOld Hhav_out + have HlhsDef_old : + Imperative.isDefined + (updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) lhs := + isDefined_3layer_lift HlhsDisjArg HlhsDisjOut + (HoldTripsFst ▸ HlhsDisjOld) Hlhs_isLocl + -- HL5 (poly): havocs at flag=true. + have HL5_pre : + EvalStatementsContract π φ + ⟨updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals, δ, true⟩ + (Core.Transform.createHavocs lhs md) + ⟨updatedStates + (updatedStates + (updatedStates σ' + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals, δ, true⟩ := + H_havocs_poly Hwfvars HlhsDef_old Hhav_old + have HoldFstLen : + oldTrips.unzip.fst.unzip.fst.length = oldVals.length := by + rw [HoldTripsFst, HgenOldLen, HoldValsLen] + have Hflatten_eq : + updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) = + updatedStates + (updatedStates + (updatedStates σ' + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals := by + rw [HoldTripsFst] + simp only [updatedStates] + have Hzip1 : + ((argTemps ++ + outTemps) ++ genOldIdents).zip + ((argVals ++ oVals) ++ oldVals) = + (argTemps ++ + outTemps).zip + (argVals ++ oVals) ++ + genOldIdents.zip oldVals := + List.zip_append (by + rw [List.length_append, List.length_append, + HargTempsLen, HoutTempsLen]) + have Hzip2 : + (argTemps ++ + outTemps).zip + (argVals ++ oVals) = + argTemps.zip argVals ++ + outTemps.zip oVals := + List.zip_append HargTempsLen + rw [Hzip1, Hzip2] + rw [updatedStates'App, updatedStates'App] + have HL5 : + EvalStatementsContract π φ + ⟨updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals, δ, true⟩ + (Core.Transform.createHavocs (CallArg.getLhs args) md) + ⟨updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals), δ, true⟩ := by + rw [Hflatten_eq, hCallArgsLhs] + exact HL5_pre + -- ── D2a: per-precondition payload for L4 (asserts) ── + obtain ⟨HprocEq, c_in_postExprs_of_proc'⟩ := + procEq_and_postExprs_bridge Hp Hfind lkup + obtain ⟨HpreVarsFresh, _HpostVarsFresh, _HargVarsNotInLhs, + HinoutFresh, HargVarsNotInOutKeys, + HargVarsNotInInKeys, _HoutAlign, HpreBoolTyped⟩ := + Hwfcallsite.specialize (procName := procName) + (args := args) (md := md) rfl lkup + have HinputsFresh : + ∀ v ∈ proc.header.inputs.keys, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v := by + intro v Hv + exact HinoutFresh v (List.mem_append.mpr (Or.inl Hv)) + have HoutputsFresh : + ∀ v ∈ proc.header.outputs.keys, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v := by + intro v Hv + exact HinoutFresh v (List.mem_append.mpr (Or.inr Hv)) + have HinKeys_disj_argTemps : proc.header.inputs.keys.Disjoint argTemps := + fun v Hv1 Hv2 => notMem_of_Forall_neg HargTemp (HinputsFresh v Hv1).1 Hv2 + have HinKeys_disj_outTemps : proc.header.inputs.keys.Disjoint outTemps := + fun v Hv1 Hv2 => notMem_of_Forall_neg HoutTemp (HinputsFresh v Hv1).1 Hv2 + have HinKeys_disj_olds : proc.header.inputs.keys.Disjoint genOldIdents := + fun v Hv1 Hv2 => notMem_of_Forall_neg HoldIdentsTemp (HinputsFresh v Hv1).2 Hv2 + have HoutKeys_disj_argTemps : proc.header.outputs.keys.Disjoint argTemps := + fun v Hv1 Hv2 => notMem_of_Forall_neg HargTemp (HoutputsFresh v Hv1).1 Hv2 + have HoutKeys_disj_outTemps : proc.header.outputs.keys.Disjoint outTemps := + fun v Hv1 Hv2 => notMem_of_Forall_neg HoutTemp (HoutputsFresh v Hv1).1 Hv2 + have HoutKeys_disj_olds : proc.header.outputs.keys.Disjoint genOldIdents := + fun v Hv1 Hv2 => notMem_of_Forall_neg HoldIdentsTemp (HoutputsFresh v Hv1).2 Hv2 + have HinKeys_disj_lhs : + proc.header.inputs.keys.Disjoint lhs := fun v Hv1 Hv2 => + notin_of_isSome_isNotDefined (Hlhs_isLocl v Hv2) (InitStatesNotDefined Hinitin) Hv1 + have HoutKeys_disj_lhs : + proc.header.outputs.keys.Disjoint lhs := by + intro v Hv1 Hv2 + have HvσA_none : σA v = none := Houtndef_io v Hv1 + have HvNotInInputs : v ∉ proc.header.inputs.keys := + fun h => Hiodisj h Hv1 + have HvσA_eq_σ : σA v = σ v := + initStates_get_notin Hinitin HvNotInInputs + have Hvσ_none : σ v = none := by + rw [← HvσA_eq_σ]; exact HvσA_none + exact σ_some_contradiction (Hlhs_isLocl v Hv2) Hvσ_none + -- Filtered preconditions. + let presFiltered : List (CoreLabel × Procedure.Check) := + proc.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free) + -- Pre-var freshness restricted to presFiltered (filtered ⊆ unfiltered). + have HpresVarsFresh' : + ∀ entry ∈ presFiltered, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ + v ∉ CallArg.getLhs args := fun entry Hentry v Hv => + HpreVarsFresh entry.snd.expr + (filterCheck_mem_getCheckExprs Hentry) v Hv + -- L4 ks/ks' bindings. + let ks_L4 : List Expression.Ident := + proc.header.inputs.keys ++ proc.header.outputs.keys + let ks'_L4 : List Expression.Ident := + argTemps ++ lhs + have HinKeys_argTemps_len : + proc.header.inputs.keys.length = argTemps.length := by + have H1 : proc.header.inputs.keys.length = + argVals.length := InitStatesLength Hinitin + omega + have HoutKeys_lhs_len : + proc.header.outputs.keys.length = lhs.length := by + have H1 : proc.header.outputs.keys.length = oVals.length := + InitStatesLength Hinitout + have H2 : lhs.length = oVals.length := + ReadValuesLength Hevalouts + omega + have Hks_len_L4 : + ks_L4.length = ks'_L4.length := by + show (proc.header.inputs.keys ++ + proc.header.outputs.keys).length = + (argTemps ++ lhs).length + rw [List.length_append, List.length_append, + HinKeys_argTemps_len, HoutKeys_lhs_len] + have HargT_lhs_nd : + (argTemps ++ lhs).Nodup := by + rw [List.nodup_append] + refine ⟨HargNd, HlhsNd, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact HlhsDisjArg Hb Ha + have Hbignd_L4 : + (ks_L4 ++ ks'_L4).Nodup := by + rw [List.nodup_append] + refine ⟨Hinoutnd, HargT_lhs_nd, fun a Ha b Hb Heq => ?_⟩ + subst Heq + rcases List.mem_append.mp Ha with HaIn | HaOut <;> + rcases List.mem_append.mp Hb with HbArg | HbLhs + · exact HinKeys_disj_argTemps HaIn HbArg + · exact HinKeys_disj_lhs HaIn HbLhs + · exact HoutKeys_disj_argTemps HaOut HbArg + · exact HoutKeys_disj_lhs HaOut HbLhs + have Hnd_L4 : Imperative.substNodup + (ks_L4.zip ks'_L4) := by + unfold Imperative.substNodup + exact (List.unzip_zip Hks_len_L4) ▸ Hbignd_L4 + have HσAO_def_in_L4 : + Imperative.isDefined σAO proc.header.inputs.keys := + InitStatesDefMonotone (InitStatesDefined Hinitin) Hinitout + have HσAO_def_out_L4 : + Imperative.isDefined σAO proc.header.outputs.keys := + InitStatesDefined Hinitout + let σ_old : CoreStore := + updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals + have Hσ_old_def_argT : + Imperative.isDefined σ_old + argTemps := by + intro v Hv + show ((updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) v).isSome = + true + rw [updatedStates_get_notin (HoldTripsFst.symm ▸ HargOldDisj Hv), + updatedStates_get_notin (HargOutDisj Hv)] + exact updatedStatesDefined HargTempsLen v Hv + have Hσ_old_def_lhs : + Imperative.isDefined σ_old lhs := HlhsDef_old + have Hdef_L4 : Imperative.substDefined σAO σ_old + (ks_L4.zip ks'_L4) := + substDefined_of_app HσAO_def_in_L4 HσAO_def_out_L4 + Hσ_old_def_argT Hσ_old_def_lhs + -- Build matching ReadValues on σ_old and σAO, close via ReadValuesSubstStores. + have HrdAO_in_L4 : + ReadValues σAO proc.header.inputs.keys argVals := by + have HrdA_in : ReadValues σA proc.header.inputs.keys argVals := + InitStatesReadValues Hinitin + apply InitStatesReadValuesMonotone HrdA_in Hinitout + have HrdAO_out_L4 : + ReadValues σAO proc.header.outputs.keys oVals := + InitStatesReadValues Hinitout + have HrdAO_inout_L4 : + ReadValues σAO + (proc.header.inputs.keys ++ + proc.header.outputs.keys) + (argVals ++ oVals) := + ReadValuesApp HrdAO_in_L4 HrdAO_out_L4 + have HrdLayer3_argT : + ReadValues σ_old + argTemps argVals := + readValues_updatedStates HoldFstLen + (HoldTripsFst ▸ HargOldDisj) + (readValues_updatedStates HoutTempsLen HargOutDisj + (readValues_updatedStatesSame HargTempsLen + (List.nodup_append.mp (List.nodup_append.mp Hgennd).1).1)) + have HrdLayer3_lhs : + ReadValues σ_old lhs oVals := + readValues_3layer_lift HargTempsLen HlhsDisjArg + HoutTempsLen HlhsDisjOut + HoldFstLen (HoldTripsFst ▸ HlhsDisjOld) Hevalouts + have HrdOld_inout_L4 : + ReadValues σ_old + (argTemps ++ lhs) + (argVals ++ oVals) := + ReadValuesApp HrdLayer3_argT HrdLayer3_lhs + have Hsubst_L4 : Imperative.substStores σ_old σAO + (ks'_L4.zip ks_L4) := + ReadValuesSubstStores HrdOld_inout_L4 HrdAO_inout_L4 + -- Flip to the `(ks_L4.zip ks'_L4)` direction for subst_fvars_correct. + have Hsubst_L4_flipped : Imperative.substStores σAO σ_old + (ks_L4.zip ks'_L4) := by + apply Imperative.substStoresFlip' + simp [Imperative.substSwap, zip_swap] + exact Hsubst_L4 + -- ── Apply H_asserts_zip_fail ── + obtain ⟨assertLabels, HassertLabelsLen, HassertShape⟩ := + HassertsShape + have HassertSubst_eq : + ((proc.header.inputs.keys.zip + (Core.Transform.createFvars + argTemps)) ++ + (proc.header.outputs.keys.zip + (Core.Transform.createFvars + (CallArg.getLhs args)))) = + ks_L4.zip + (Core.Transform.createFvars ks'_L4) := by + show _ = + (proc.header.inputs.keys ++ + proc.header.outputs.keys).zip + (Core.Transform.createFvars + (argTemps ++ lhs)) + rw [hCallArgsLhs, createFvarsApp] + rw [List.zip_append] + rw [createFvarsLength] + exact HinKeys_argTemps_len + -- Per-pair "tt or ff" totality fact at σ_old via subst_fvars_correct + boolTyped. + -- For each pair (entry, lbl) ∈ presFiltered.zip assertLabels, + -- build the totality witness at σ_old. + -- First derive HpresPayload-like facts (without the eval-tt — use boolTyped). + -- Bool-totality witness at σAO for filtered preconditions. + have HpreFilteredBool : + ∀ entry ∈ presFiltered, + δ σAO entry.snd.expr = some Imperative.HasBool.tt ∨ + δ σAO entry.snd.expr = some Imperative.HasBool.ff := by + intro entry Hentry + have Hcontains : + (Procedure.Spec.getCheckExprs + proc.spec.preconditions).contains entry.snd.expr := by + rw [List.contains_iff_mem] + simp only [Procedure.Spec.getCheckExprs, + ListMap.values_eq_map_snd, List.mem_map, + List.map_map] + refine ⟨entry, ?_, rfl⟩ + exact (List.mem_filter.mp Hentry).1 + have Hpre_in : + entry.snd.expr ∈ Procedure.Spec.getCheckExprs + proc.spec.preconditions := + List.contains_iff_mem.mp Hcontains + -- Use HpreBoolTyped at (δ, σAO) with the definedness witness. + have Hcontains_filt : + (Procedure.Spec.getCheckExprs + (proc.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free))).contains entry.snd.expr := by + rw [List.contains_iff_mem] + simp only [Procedure.Spec.getCheckExprs, + ListMap.values_eq_map_snd, List.mem_map, + List.map_map] + refine ⟨entry, Hentry, rfl⟩ + have HdefAO : Imperative.isDefinedOver + (Imperative.HasVarsPure.getVars (P:=Expression)) + σAO entry.snd.expr := + Hpre_def entry.snd.expr Hcontains_filt + exact HpreBoolTyped entry.snd.expr Hpre_in δ σAO HdefAO + -- HpresPayload-like (defined and freshness/disjoint info), shared with success arm. + -- We need: + -- * For each entry ∈ presFiltered, the per-entry invStores σAO σ_old + + -- ks'_L4.Disjoint (getVars entry.snd.expr) used by subst_fvars_correct. + have HpresInfo : + ∀ entry ∈ presFiltered, + Imperative.invStores σAO σ_old + ((Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr).removeAll + (ks_L4 ++ ks'_L4)) ∧ + ks'_L4.Disjoint + (Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr) := by + intro entry Hentry + have HfreshEnt := HpresVarsFresh' entry Hentry + have Hpred_disj : + ks'_L4.Disjoint + (Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr) := by + intro x Hin1 Hin2 + cases List.mem_append.mp Hin1 with + | inl HxArg => + have HxTemp : isTempIdent x := (List.Forall_mem_iff.mp HargTemp) x HxArg + have HxNotTemp : ¬ isTempIdent x := + (HfreshEnt x Hin2).1 + exact HxNotTemp HxTemp + | inr HxLhs => + have HxNotInLhs : x ∉ CallArg.getLhs args := + (HfreshEnt x Hin2).2.2 + rw [hCallArgsLhs] at HxNotInLhs + exact HxNotInLhs HxLhs + have Hinv : + Imperative.invStores σAO σ_old + ((Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr).removeAll + (ks_L4 ++ ks'_L4)) := by + simp only [Imperative.invStores, Imperative.substStores] + intros k1 k2 Hkin + obtain ⟨rfl, Hk1_pre, Hk1_notin_inputs, Hk1_notin_outputs, + Hk1_notin_argT, _Hk1_notin_lhs⟩ := + zip_removeAll4_decompose Hkin + have HfreshK := HfreshEnt k1 Hk1_pre + have Hk1_notTemp : ¬ isTempIdent k1 := HfreshK.1 + have Hk1_notOld : ¬ isOldTempIdent k1 := HfreshK.2.1 + have Hk1_notin_outT : k1 ∉ outTemps := + notMem_of_Forall_neg HoutTemp Hk1_notTemp + have Hk1_notin_olds : k1 ∉ genOldIdents := + notMem_of_Forall_neg HoldIdentsTemp Hk1_notOld + have Hold_eq_σ : + σ_old k1 = σ k1 := by + have Hk1_notin_oldFst : + k1 ∉ oldTrips.unzip.fst.unzip.fst := by + rw [HoldTripsFst]; exact Hk1_notin_olds + show (updatedStates + (updatedStates + (updatedStates σ + argTemps argVals) + outTemps oVals) + oldTrips.unzip.fst.unzip.fst oldVals) k1 = σ k1 + exact updatedStates_3layer_get_notin + Hk1_notin_argT Hk1_notin_outT Hk1_notin_oldFst + have HAO_eq_σ : σAO k1 = σ k1 := by + rw [initStates_get_notin Hinitout Hk1_notin_outputs, + initStates_get_notin Hinitin Hk1_notin_inputs] + rw [HAO_eq_σ, Hold_eq_σ] + exact ⟨Hinv, Hpred_disj⟩ + -- Per-pair tt-or-ff witness at σ_old. + have HboolAtOld : + ∀ pair ∈ presFiltered.zip assertLabels, + δ σ_old (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks_L4.zip (Core.Transform.createFvars ks'_L4))) = + some Imperative.HasBool.tt ∨ + δ σ_old (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks_L4.zip (Core.Transform.createFvars ks'_L4))) = + some Imperative.HasBool.ff := by + intro pair Hpair + have Hentry_in : pair.fst ∈ presFiltered := + (List.of_mem_zip Hpair).1 + have ⟨Hinv, Hpred_disj⟩ := HpresInfo pair.fst Hentry_in + -- subst_fvars_correct: δ σAO expr = δ σ_old (substFvars expr (ks.zip createFvars ks')). + have Heq : δ σAO pair.fst.snd.expr = + δ σ_old (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks_L4.zip (Core.Transform.createFvars ks'_L4))) := + subst_fvars_correct Hwfc Hwfvars Hwfval Hks_len_L4 + Hdef_L4 Hnd_L4 Hsubst_L4_flipped Hpred_disj Hinv + have Hbool_AO := HpreFilteredBool pair.fst Hentry_in + cases Hbool_AO with + | inl Htt => left; rw [← Heq]; exact Htt + | inr Hff => right; rw [← Heq]; exact Hff + -- Build the failing-pre witness at σ_old via Hpre_iff contrapositive. + have Hfail_or_input : + (false : Bool) = true ∨ + ∃ pair ∈ presFiltered.zip assertLabels, + δ σ_old (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks_L4.zip (Core.Transform.createFvars ks'_L4))) = + some Imperative.HasBool.ff := by + right + -- "Not all preconditions evaluate to tt at σAO" via Hpre_iff.mpr. + have Hnot_all : + ¬ (∀ pre, (Procedure.Spec.getCheckExprs + (proc.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free))).contains pre → + δ σAO pre = .some Imperative.HasBool.tt) := by + intro Hall + have : true = false := Hpre_iff.mpr Hall + cases this + -- From Hnot_all, extract a witness pre that fails to eval to tt. + -- Combined with bool-totality, that pre evaluates to ff. + -- We need to find an entry in presFiltered. + -- Use classical reasoning to find the first failing entry. + have HexFail : + ∃ entry ∈ presFiltered, δ σAO entry.snd.expr ≠ some Imperative.HasBool.tt := by + -- Prove via Classical.byContradiction: assume not exists, derive ∀, contradict. + apply Classical.byContradiction + intro Hno + apply Hnot_all + intro pre Hpre + rw [List.contains_iff_mem] at Hpre + simp only [Procedure.Spec.getCheckExprs, + ListMap.values_eq_map_snd, List.mem_map, + List.map_map] at Hpre + obtain ⟨entry, Hentry_in, Hpre_eq⟩ := Hpre + rw [← Hpre_eq] + -- entry ∈ presFiltered ⇒ either eval-tt or contradict Hno. + by_cases Htt : δ σAO entry.snd.expr = some Imperative.HasBool.tt + · exact Htt + · exact absurd ⟨entry, Hentry_in, Htt⟩ Hno + obtain ⟨entryFail, HentryFail_in, HentryFail_ne_tt⟩ := HexFail + -- bool-totality: entryFail evaluates to either tt or ff at σAO. + have HboolAO := HpreFilteredBool entryFail HentryFail_in + have HentryFail_ff : δ σAO entryFail.snd.expr = some Imperative.HasBool.ff := by + cases HboolAO with + | inl Htt => exact absurd Htt HentryFail_ne_tt + | inr Hff => exact Hff + -- Transport to σ_old. + have ⟨Hinv, Hpred_disj⟩ := HpresInfo entryFail HentryFail_in + have Heq : δ σAO entryFail.snd.expr = + δ σ_old (Lambda.LExpr.substFvars entryFail.snd.expr + (ks_L4.zip (Core.Transform.createFvars ks'_L4))) := + subst_fvars_correct Hwfc Hwfvars Hwfval Hks_len_L4 + Hdef_L4 Hnd_L4 Hsubst_L4_flipped Hpred_disj Hinv + have HentryFail_old_ff : + δ σ_old (Lambda.LExpr.substFvars entryFail.snd.expr + (ks_L4.zip (Core.Transform.createFvars ks'_L4))) = + some Imperative.HasBool.ff := by + rw [← Heq]; exact HentryFail_ff + -- Find the position of entryFail in presFiltered to pair with assertLabels. + have Hfilter_eq_pres : + (proc.spec.preconditions.filter + (fun (_, check) => check.attr != .Free)) = presFiltered := + filter_bne_eq_filter_ne proc.spec.preconditions + have HassertLen' : presFiltered.length = assertLabels.length := by + have HH := HassertLabelsLen + rw [HprocEq] at HH + rw [Hfilter_eq_pres] at HH + exact HH.symm + have HentryFail_idx : ∃ i, ∃ (Hi : i < presFiltered.length) + (Hi' : i < assertLabels.length), + presFiltered[i]'Hi = entryFail := by + rcases List.mem_iff_get.mp HentryFail_in with ⟨n, Hn_eq⟩ + refine ⟨n.val, n.isLt, ?_, ?_⟩ + · rw [← HassertLen']; exact n.isLt + · exact Hn_eq + obtain ⟨i, Hi, Hi', Hi_eq⟩ := HentryFail_idx + let lblFail := assertLabels[i]'Hi' + have HpairIn : (entryFail, lblFail) ∈ presFiltered.zip assertLabels := by + have Hzip_get : + (presFiltered.zip assertLabels)[i]'(by + exact List.length_zip ▸ Nat.lt_min.mpr ⟨Hi, Hi'⟩) = + (entryFail, lblFail) := by + rw [List.getElem_zip] + show (presFiltered[i]'Hi, assertLabels[i]'Hi') = (entryFail, lblFail) + rw [Hi_eq] + exact Hzip_get.symm ▸ List.getElem_mem _ + refine ⟨(entryFail, lblFail), HpairIn, ?_⟩ + exact HentryFail_old_ff + have HL4_pre : + EvalStatementsContract π φ ⟨σ_old, δ, false⟩ + (((proc.spec.preconditions.filter + (fun (_, check) => check.attr != .Free)).zip + assertLabels).map (fun (entry, lbl) => + Statement.assert lbl + (Lambda.LExpr.substFvars entry.snd.expr + (ks_L4.zip + (Core.Transform.createFvars ks'_L4))) + (entry.snd.md.setCallSiteFileRange md))) + ⟨σ_old, δ, true⟩ := by + apply H_asserts_zip_fail + (σ' := σ_old) (f := false) + (ks := ks_L4) + (ks' := ks'_L4) + (pres := proc.spec.preconditions.filter + (fun (_, check) => check.attr != .Free)) + (labels := assertLabels) + Hwfb + · -- Hbool: per-pair "tt or ff". Bridge filter forms. + intro pair Hpair + have Hpair' : pair ∈ presFiltered.zip assertLabels := by + show pair ∈ (proc.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free)).zip assertLabels + exact (filter_bne_eq_filter_ne proc.spec.preconditions).symm ▸ Hpair + exact HboolAtOld pair Hpair' + · -- Hfail_or_input: false = true ∨ ∃ failing pair. Bridge filter forms. + rcases Hfail_or_input with Hf | ⟨pair, Hpair_in, Hpair_ff⟩ + · exact Or.inl Hf + · refine Or.inr ⟨pair, ?_, Hpair_ff⟩ + exact (filter_bne_eq_filter_ne proc.spec.preconditions) ▸ Hpair_in + have HL4 : + EvalStatementsContract π φ ⟨σ_old, δ, false⟩ + asserts ⟨σ_old, δ, true⟩ := by + rw [HassertShape] + rw [HprocEq] + exact HassertSubst_eq ▸ HL4_pre + -- L6 (assumes): polymorphic-flag, both endpoints at f=true. + -- Use H_assumes_zip_poly with a Disj/SubstStores/Defined setup that + -- doesn't require the eval-tt witness — but H_assumes_zip_poly's + -- shape DOES require it. Instead we observe that since both endpoints + -- of HL6 are at f=true and the assume statements may carry any + -- evaluation behavior, we just need a polymorphic-flag walk that + -- terminates with the same flag. + -- The simplest approach: show the assumes evaluate to tt at σ_havoc + -- (mirroring success arm's HpostPayload), then apply H_assumes_zip_poly. + -- This is the same setup as the success arm with f := true. + -- But we can also bypass HpostPayload entirely: just need to show + -- that L6 is a no-op walk through assume statements at flag=true. + -- For simplicity and correctness, mirror the success arm's HpostPayload. + -- (continued below) + -- σ_havoc abbreviation. + let σ_havoc : CoreStore := + updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) + have Hσ'_eq : σ' = updatedStates σ lhs modvals := + UpdateStatesUpdated Hupdate + -- D2c: σ_R1 = σO with old-bindings. + let σ_R1 : CoreStore := + updatedStates σO genOldIdents oldVals + -- ─── Prepare HpostPayload for H_assumes_zip_poly ─── + -- Filtered argument substitution shape — same as success arm. + let filtered_argSubst : + List (Expression.Ident × Expression.Ident) := + (proc.header.inputs.keys.zip argTemps).filter + (fun pr => + ¬ (proc.header.outputs.keys).contains pr.1) + let filtered_inputs : List Expression.Ident := + filtered_argSubst.unzip.fst + let filtered_argTemps : List Expression.Ident := + filtered_argSubst.unzip.snd + let filtered_ks : List Expression.Ident := + proc.header.outputs.keys ++ filtered_inputs + let filtered_ks' : List Expression.Ident := + lhs ++ filtered_argTemps + have Hzip_unzip : + (proc.header.inputs.keys.zip argTemps).unzip = + (proc.header.inputs.keys, argTemps) := + List.unzip_zip HinKeys_argTemps_len + have Hfilter_in : + ∀ pr ∈ filtered_argSubst, + pr ∈ proc.header.inputs.keys.zip argTemps ∧ + pr.1 ∉ proc.header.outputs.keys := by + intro pr Hpr + have := List.mem_filter.mp Hpr + refine ⟨this.1, ?_⟩ + simpa using this.2 + have Hfilt_len_sym : + filtered_inputs.length = filtered_argTemps.length := by + show filtered_argSubst.unzip.fst.length = + filtered_argSubst.unzip.snd.length + simp [List.unzip_eq_map] + have Hkslen : + filtered_ks.length = filtered_ks'.length := by + show (proc.header.outputs.keys ++ + filtered_inputs).length = + (lhs ++ filtered_argTemps).length + rw [List.length_append, List.length_append, + HoutKeys_lhs_len, Hfilt_len_sym] + have Hfilt_in_eq_map : + filtered_inputs = filtered_argSubst.map Prod.fst := by + show filtered_argSubst.unzip.fst = _ + simp [List.unzip_eq_map] + have Hfilt_argT_eq_map : + filtered_argTemps = filtered_argSubst.map Prod.snd := by + show filtered_argSubst.unzip.snd = _ + simp [List.unzip_eq_map] + have Hfilt_in_sub_inputs : + ∀ v ∈ filtered_inputs, v ∈ proc.header.inputs.keys := by + intro v Hv + have Hv' : v ∈ filtered_argSubst.map Prod.fst := + Hfilt_in_eq_map ▸ Hv + rcases List.mem_map.mp Hv' with ⟨pr, Hpr_in, Hpr_eq⟩ + have HinZip := (Hfilter_in pr Hpr_in).1 + have Hofzip := List.of_mem_zip HinZip + exact Hpr_eq.symm ▸ Hofzip.1 + have Hfilt_argT_sub_argTemps : + ∀ v ∈ filtered_argTemps, v ∈ argTemps := by + intro v Hv + have Hv' : v ∈ filtered_argSubst.map Prod.snd := + Hfilt_argT_eq_map ▸ Hv + rcases List.mem_map.mp Hv' with ⟨pr, Hpr_in, Hpr_eq⟩ + have HinZip := (Hfilter_in pr Hpr_in).1 + have Hofzip := List.of_mem_zip HinZip + exact Hpr_eq.symm ▸ Hofzip.2 + have Hfilt_in_disj_outs : + filtered_inputs.Disjoint proc.header.outputs.keys := by + intro v Hv1 Hv2 + have Hv' : v ∈ filtered_argSubst.map Prod.fst := + Hfilt_in_eq_map ▸ Hv1 + rcases List.mem_map.mp Hv' with ⟨pr, Hpr_in, Hpr_eq⟩ + have HnotIn := (Hfilter_in pr Hpr_in).2 + rw [Hpr_eq] at HnotIn + exact HnotIn Hv2 + have Hnd : Imperative.substNodup + (filtered_ks.zip filtered_ks') := by + have HzipUnzip : + (filtered_ks.zip filtered_ks').unzip = + (filtered_ks, filtered_ks') := + List.unzip_zip Hkslen + show ((filtered_ks.zip filtered_ks').unzip.fst ++ + (filtered_ks.zip filtered_ks').unzip.snd).Nodup + rw [HzipUnzip] + show ((proc.header.outputs.keys ++ filtered_inputs) ++ + (lhs ++ filtered_argTemps)).Nodup + have Hfilt_in_disj_lhs : + filtered_inputs.Disjoint lhs := by + intro v Hv1 Hv2 + exact HinKeys_disj_lhs (Hfilt_in_sub_inputs v Hv1) Hv2 + have HoutKeys_disj_filt_argT : + proc.header.outputs.keys.Disjoint + filtered_argTemps := by + intro v Hv1 Hv2 + exact HoutKeys_disj_argTemps Hv1 + (Hfilt_argT_sub_argTemps v Hv2) + have Hfilt_in_disj_filt_argT : + filtered_inputs.Disjoint filtered_argTemps := by + intro v Hv1 Hv2 + exact HinKeys_disj_argTemps + (Hfilt_in_sub_inputs v Hv1) + (Hfilt_argT_sub_argTemps v Hv2) + have Hlhs_disj_filt_argT : + lhs.Disjoint filtered_argTemps := by + intro v Hv1 Hv2 + exact HlhsDisjArg Hv1 + (Hfilt_argT_sub_argTemps v Hv2) + have Hin_nd_pw : + List.Pairwise + (· ≠ ·) proc.header.inputs.keys := + List.nodup_iff_pairwise_ne.mp Hinnd_io + have HargT_nd_pw : + List.Pairwise (· ≠ ·) argTemps := + List.nodup_iff_pairwise_ne.mp HargNd + have Hzip_pw_fst : + List.Pairwise + (fun (p q : + Expression.Ident × Expression.Ident) => + p.1 ≠ q.1) + (proc.header.inputs.keys.zip argTemps) := by + rw [show (fun (p q : Expression.Ident × Expression.Ident) => + p.1 ≠ q.1) = + (fun p q => Prod.fst p ≠ Prod.fst q) from rfl] + rw [← List.pairwise_map] + rw [List.map_fst_zip + (Nat.le_of_eq HinKeys_argTemps_len)] + exact Hin_nd_pw + have Hzip_pw_snd : + List.Pairwise + (fun (p q : + Expression.Ident × Expression.Ident) => + p.2 ≠ q.2) + (proc.header.inputs.keys.zip argTemps) := by + rw [show (fun (p q : Expression.Ident × Expression.Ident) => + p.2 ≠ q.2) = + (fun p q => Prod.snd p ≠ Prod.snd q) from rfl] + rw [← List.pairwise_map] + rw [List.map_snd_zip + (Nat.le_of_eq HinKeys_argTemps_len.symm)] + exact HargT_nd_pw + have Hfilt_pw_fst : + List.Pairwise + (fun (p q : + Expression.Ident × Expression.Ident) => + p.1 ≠ q.1) + filtered_argSubst := + List.Pairwise.sublist List.filter_sublist Hzip_pw_fst + have Hfilt_pw_snd : + List.Pairwise + (fun (p q : + Expression.Ident × Expression.Ident) => + p.2 ≠ q.2) + filtered_argSubst := + List.Pairwise.sublist List.filter_sublist Hzip_pw_snd + have Hfilt_in_nodup : filtered_inputs.Nodup := by + show filtered_argSubst.unzip.fst.Nodup + simp [List.unzip_eq_map] + rw [List.nodup_iff_pairwise_ne] + rw [List.pairwise_map] + exact Hfilt_pw_fst + have Hfilt_argT_nodup : filtered_argTemps.Nodup := by + show filtered_argSubst.unzip.snd.Nodup + simp [List.unzip_eq_map] + rw [List.nodup_iff_pairwise_ne] + rw [List.pairwise_map] + exact Hfilt_pw_snd + rw [List.nodup_append] + refine ⟨?_, ?_, ?_⟩ + · rw [List.nodup_append] + refine ⟨Houtnd_io, Hfilt_in_nodup, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact Hfilt_in_disj_outs Hb Ha + · rw [List.nodup_append] + refine ⟨HlhsNd, Hfilt_argT_nodup, ?_⟩ + intro a Ha b Hb Heq + subst Heq + exact Hlhs_disj_filt_argT Ha Hb + · intro a Ha b Hb Heq + subst Heq + cases List.mem_append.mp Ha with + | inl HaOuts => + cases List.mem_append.mp Hb with + | inl HbLhs => + exact HoutKeys_disj_lhs HaOuts HbLhs + | inr HbArgT => + exact HoutKeys_disj_filt_argT HaOuts HbArgT + | inr HaIn => + cases List.mem_append.mp Hb with + | inl HbLhs => + exact Hfilt_in_disj_lhs HaIn HbLhs + | inr HbArgT => + exact Hfilt_in_disj_filt_argT HaIn HbArgT + -- σO/σ_R1/σ_havoc definedness facts. + have HσO_def_outs : + Imperative.isDefined σO proc.header.outputs.keys := + HavocVarsDefMonotone (InitStatesDefined Hinitout) Hhav1 + have HσO_def_inputs : + Imperative.isDefined σO proc.header.inputs.keys := + HavocVarsDefMonotone + (InitStatesDefMonotone (InitStatesDefined Hinitin) Hinitout) Hhav1 + have σR1_off_olds : + ∀ {v}, v ∉ genOldIdents → σ_R1 v = σO v := fun Hv => + updatedStates_get_notin Hv + have Hσ_R1_def_outs : + Imperative.isDefined σ_R1 proc.header.outputs.keys := fun v Hv => + (show σ_R1 v = σO v from σR1_off_olds (HoutKeys_disj_olds Hv)) ▸ HσO_def_outs v Hv + have Hσ_R1_def_filt_in : + Imperative.isDefined σ_R1 filtered_inputs := fun v Hv => + let Hv_in := Hfilt_in_sub_inputs v Hv + (show σ_R1 v = σO v from σR1_off_olds (HinKeys_disj_olds Hv_in)) ▸ HσO_def_inputs v Hv_in + have Hσ_havoc_def_lhs : + Imperative.isDefined σ_havoc lhs := by + intro v Hv + show (updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) v).isSome = true + have Hv_notin : v ∉ argTemps ++ outTemps ++ genOldIdents := + List.notin_3_append_of (HlhsDisjArg Hv) (HlhsDisjOut Hv) (HlhsDisjOld Hv) + exact (updatedStates_get_notin Hv_notin) ▸ HavocVarsDefined (UpdateStatesHavocVars Hupdate) v Hv + have Hσ_havoc_def_filt_argT : + Imperative.isDefined σ_havoc filtered_argTemps := by + intro v Hv + have Hv_argT : v ∈ argTemps := + Hfilt_argT_sub_argTemps v Hv + show (updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) v).isSome = true + apply updatedStatesDefined + · simp [argTemps, outTemps, List.length_append, List.unzip_eq_map, + Hargtriplen, Houttriplen, HgenOldOldValsLen] + · simp only [List.mem_append] + exact Or.inl (Or.inl Hv_argT) + have Hdef : Imperative.substDefined σ_R1 σ_havoc + (filtered_ks.zip filtered_ks') := + substDefined_of_app Hσ_R1_def_outs Hσ_R1_def_filt_in + Hσ_havoc_def_lhs Hσ_havoc_def_filt_argT + -- σ_R1 = σ_havoc on filtered_ks.zip filtered_ks' — copy success-arm Hsubst. + have HmodvalsLen' : lhs.length = modvals.length := by + have := UpdateStatesLength Hupdate; omega + -- σ_R1 reads: same as success arm. + have HinKVlen : + proc.header.inputs.keys.length = argVals.length := + InitStatesLength Hinitin + have Hrd_R1_in_full : + ReadValues σ_R1 proc.header.inputs.keys argVals := by + apply readValues_updatedStates HgenOldOldValsLen HinKeys_disj_olds + have HrdAO : ReadValues σAO proc.header.inputs.keys argVals := + InitStatesReadValuesMonotone (σ:=σA) (InitStatesReadValues Hinitin) Hinitout + have Hh1 := HavocVarsUpdateStates Hhav1 + rcases Hh1 with ⟨ovh, Hup_havoc⟩ + apply UpdateStatesReadValuesMonotone (σ:=σAO) _ ?_ Hup_havoc + · exact Hinoutnd + · exact HrdAO + have Hrd_R1_outs : + ReadValues σ_R1 proc.header.outputs.keys modvals := + readValues_updatedStates HgenOldOldValsLen HoutKeys_disj_olds Hrd + have Hrd_havoc_argT : + ReadValues σ_havoc argTemps argVals := by + show ReadValues + (updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals)) + argTemps argVals + rw [Hflatten_eq] + have HargF_σ' : + ReadValues + (updatedStates σ' argTemps argVals) + argTemps argVals := + readValues_updatedStatesSame HargTempsLen HargNd + have HargF_step1 : + ReadValues + (updatedStates + (updatedStates σ' argTemps argVals) + outTemps oVals) argTemps argVals := + readValues_updatedStates HoutTempsLen HargOutDisj HargF_σ' + exact HoldTripsFst ▸ readValues_updatedStates HgenOldOldValsLen HargOldDisj HargF_step1 + have Hrd_havoc_lhs : + ReadValues σ_havoc lhs modvals := by + apply readValues_updatedStates + · simp [argTemps, outTemps, List.length_append, List.unzip_eq_map, + Hargtriplen, Houttriplen, HgenOldOldValsLen] + · intro v Hv1 Hv2 + cases List.mem_append.mp Hv2 with + | inl h => cases List.mem_append.mp h with + | inl ha => exact HlhsDisjArg Hv1 ha + | inr ho => exact HlhsDisjOut Hv1 ho + | inr ho => exact HlhsDisjOld Hv1 ho + · rw [Hσ'_eq] + exact readValues_updatedStatesSame HmodvalsLen' HlhsNd + have Hsubst : Imperative.substStores σ_R1 σ_havoc + (filtered_ks.zip filtered_ks') := by + intro k1 k2 Hkin + show σ_R1 k1 = σ_havoc k2 + rcases List.mem_iff_get.mp Hkin with ⟨n, Hn⟩ + have Hn_lt_ks : n.val < filtered_ks.length := by + have := n.isLt; simp [List.length_zip, Hkslen] at this; omega + have Hn_lt_ks' : n.val < filtered_ks'.length := by + rw [← Hkslen]; exact Hn_lt_ks + have ⟨Hk1_eq, Hk2_eq⟩ := + List.zip_pair_split Hn_lt_ks Hn_lt_ks' Hn + by_cases Hsplit : n.val < proc.header.outputs.keys.length + · have HoutLhsLen : n.val < lhs.length := by + rw [← HoutKeys_lhs_len]; exact Hsplit + have Hk1_app : + k1 = proc.header.outputs.keys[n.val]'Hsplit := by + rw [Hk1_eq] + show (proc.header.outputs.keys ++ + filtered_inputs)[n.val]'_ = _ + rw [List.getElem_append_left (h := Hsplit)] + have Hk2_app : k2 = lhs[n.val]'HoutLhsLen := by + rw [Hk2_eq] + show (lhs ++ filtered_argTemps)[n.val]'_ = _ + rw [List.getElem_append_left (h := HoutLhsLen)] + have HmodLen_outs : + n.val < modvals.length := by + have := ReadValuesLength Hrd_R1_outs; omega + have HrdR1_get : + σ_R1 (proc.header.outputs.keys[n.val]'Hsplit) = + some (modvals[n.val]'HmodLen_outs) := + readValues_get + (σ:=σ_R1) (ks:=proc.header.outputs.keys) + (vs:=modvals) Hrd_R1_outs + (i:=n.val) (hi:=Hsplit) (hi':=HmodLen_outs) + have HrdHavoc_get : + σ_havoc (lhs[n.val]'HoutLhsLen) = + some (modvals[n.val]'HmodLen_outs) := + readValues_get + (σ:=σ_havoc) (ks:=lhs) (vs:=modvals) + Hrd_havoc_lhs + (i:=n.val) (hi:=HoutLhsLen) (hi':=HmodLen_outs) + rw [Hk1_app, HrdR1_get, Hk2_app, HrdHavoc_get] + · have Hsplit_le : proc.header.outputs.keys.length ≤ n.val := + Nat.le_of_not_lt Hsplit + have Hlhs_le : lhs.length ≤ n.val := by + rw [← HoutKeys_lhs_len]; exact Hsplit_le + have Hk1_app : + k1 = filtered_inputs[n.val - + proc.header.outputs.keys.length]'(by + have Hl : filtered_ks.length = + proc.header.outputs.keys.length + + filtered_inputs.length := + List.length_append + omega) := by + rw [Hk1_eq] + show (proc.header.outputs.keys ++ + filtered_inputs)[n.val]'_ = _ + rw [List.getElem_append_right (h₁ := Hsplit_le)] + have Hk2_app : + k2 = filtered_argTemps[n.val - lhs.length]'(by + have Hl : filtered_ks'.length = + lhs.length + filtered_argTemps.length := + List.length_append + omega) := by + rw [Hk2_eq] + show (lhs ++ filtered_argTemps)[n.val]'_ = _ + rw [List.getElem_append_right (h₁ := Hlhs_le)] + have Hidx_eq : + n.val - proc.header.outputs.keys.length = + n.val - lhs.length := by + rw [HoutKeys_lhs_len] + let j : Nat := + n.val - proc.header.outputs.keys.length + have Hj_lt_filt : + j < filtered_inputs.length := by + have Hl : filtered_ks.length = + proc.header.outputs.keys.length + + filtered_inputs.length := + List.length_append + omega + have Hj_lt_argT : + j < filtered_argTemps.length := by + rw [← Hfilt_len_sym]; exact Hj_lt_filt + have Hj_lt_subst : + j < filtered_argSubst.length := by + show j < filtered_argSubst.length + rw [show filtered_argSubst.length = + filtered_argSubst.unzip.fst.length from by + simp [List.unzip_eq_map]] + exact Hj_lt_filt + have HpairAtJ : + filtered_argSubst[j]'Hj_lt_subst = (k1, k2) := by + have HfilGetFst : + filtered_inputs[j]'Hj_lt_filt = + (filtered_argSubst[j]'Hj_lt_subst).fst := by + show filtered_argSubst.unzip.fst[j]'_ = _ + simp [List.unzip_eq_map] + have HfilGetSnd : + filtered_argTemps[j]'Hj_lt_argT = + (filtered_argSubst[j]'Hj_lt_subst).snd := by + show filtered_argSubst.unzip.snd[j]'_ = _ + simp [List.unzip_eq_map] + ext + · rw [← HfilGetFst, ← Hk1_app] + · rw [← HfilGetSnd] + have : filtered_argTemps[n.val - lhs.length]'(by + have Hl : filtered_ks'.length = + lhs.length + filtered_argTemps.length := + List.length_append + omega) = filtered_argTemps[j]'Hj_lt_argT := by + congr 1 + exact Hidx_eq.symm + rw [Hk2_app, this] + have HpairIn : (k1, k2) ∈ filtered_argSubst := by + exact HpairAtJ.symm ▸ List.getElem_mem _ + have HpairZip := (Hfilter_in (k1, k2) HpairIn).1 + obtain ⟨m, Hm_lt_in, Hm_lt_argT, Hk1_inGet, Hk2_argTGet⟩ := + pair_in_zip_pos_decomp HinKeys_argTemps_len HpairZip + have Hm_lt_argV : m < argVals.length := HinKVlen ▸ Hm_lt_in + have HrdR1_get : + σ_R1 (proc.header.inputs.keys[m]'Hm_lt_in) = + some (argVals[m]'Hm_lt_argV) := + readValues_get (σ:=σ_R1) (ks:=proc.header.inputs.keys) + (vs:=argVals) Hrd_R1_in_full + (i:=m) (hi:=Hm_lt_in) (hi':=Hm_lt_argV) + have HrdHavoc_get : + σ_havoc (argTemps[m]'Hm_lt_argT) = + some (argVals[m]'Hm_lt_argV) := + readValues_get (σ:=σ_havoc) (ks:=argTemps) (vs:=argVals) + Hrd_havoc_argT + (i:=m) (hi:=Hm_lt_argT) (hi':=Hm_lt_argV) + rw [Hk1_inGet, HrdR1_get, Hk2_argTGet, HrdHavoc_get] + -- L6 (assumes): the assumes list is some list of statements built + -- by callElimCmd. At flag=true, evaluating any well-formed assume + -- stays at flag=true regardless of the post evaluation, but we + -- need a derivation. We can simply use the fact that + -- `EvalStatementsContract` over an empty list is reflexive and + -- skip-via-step_stmts_cons walk is provided by + -- `H_assumes_zip_poly` once we have HpostPayload. + -- Mirror the success arm's HpostPayload setup. + -- HpostPayload requires δ σ_R1 expr = some tt for each filtered post. + -- The success arm derives this; we copy. + -- ── L6 plumbing (mirror success arm) ── + have HInitVars_empty : InitVars σO [] σO := InitVars.init_none + obtain ⟨Hwf2_univ, HσAO_reads_outs, HoldVars_sub_callLhs, + HoldVars_sub_outs⟩ := + holdEval_bridge_prelude (args := args) Hwf2 Hhav1 Hinitout HprocEq + have HσAO_notin_eq_σ : + ∀ v, v ∉ proc.header.outputs.keys → + v ∉ proc.header.inputs.keys → + σAO v = σ v := by + intro v Hv_notout Hv_notin + rw [initStates_get_notin Hinitout Hv_notout, + initStates_get_notin Hinitin Hv_notin] + have δ_fvar_eq := delta_fvar_eq_of_wfvars Hwfvars (delta := δ) + -- σ_R1 read olds positional. + have HrdR1_olds : ReadValues σ_R1 genOldIdents oldVals := by + show ReadValues (updatedStates σO genOldIdents oldVals) _ _ + exact readValues_updatedStatesSame HgenOldOldValsLen HoldNd + have σ_R1_read_olds : + ∀ (i : Nat) (Hi : i < genOldIdents.length) + (Hi' : i < oldVals.length), + σ_R1 (genOldIdents[i]'Hi) = + some (oldVals[i]'Hi') := fun i Hi Hi' => + readValues_get HrdR1_olds (i:=i) (hi:=Hi) (hi':=Hi') + have HoldEval_bridge : + ∀ (i : Nat) (Hi : i < oldVars.length), + δ σO + (Lambda.LExpr.fvar () + (CoreIdent.mkOld (oldVars[i]'Hi).name) none) = + some (oldVals[i]'(HoldValsLen.symm ▸ Hi)) := + HoldEval_bridge_at_σO Hwf2_univ Hinitout HσAO_reads_outs + Hevalouts hCallArgsLhs _HoutAlign HoldVars_sub_outs + HoldVars_sub_lhs HoldVars_sub_callLhs HoldVals HoldValsLen + -- L6 oldTripsCanonical/oldSubst/posts_filtered shape. + let oldTripsCanonical_L6 : + List ((Expression.Ident × Expression.Ty) × + Expression.Ident) := + (((genOldIdents.zip oldTys).zip oldVars).zip + (oldVars.map (fun g => CoreIdent.mkOld g.name))).map + fun (((fresh, ty), _orig), oldG) => ((fresh, ty), oldG) + let inputOnlyOldSubst_L6 : + Map Expression.Ident Expression.Expr := + callElim_inputOnlyOldSubst proc' args + let oldSubst_L6 : Map Expression.Ident Expression.Expr := + Core.Transform.createOldVarsSubst oldTripsCanonical_L6 ++ + inputOnlyOldSubst_L6 + let posts_filtered_L6 : + ListMap CoreLabel Procedure.Check := + Procedure.Spec.updateCheckExprs + (proc'.spec.postconditions.values.map + (fun c => + Lambda.LExpr.substFvars c.expr oldSubst_L6)) + proc'.spec.postconditions + have forall_post_filtered_decompose : + ∀ entry : CoreLabel × Procedure.Check, + entry ∈ posts_filtered_L6.toList → + ∃ c ∈ proc'.spec.postconditions.values, + entry.snd.expr = + Lambda.LExpr.substFvars c.expr oldSubst_L6 := by + intro entry Hentry + apply updateCheckExprs_substFvars_mem + rw [updateCheckExprs_walk_eq_go] + show entry ∈ + (proc'.spec.postconditions.keys.zip + (Procedure.Spec.updateCheckExprs.go _ _)) + exact Hentry + have HoldSubBridge : + ∀ k w, + Map.find? + (Core.Transform.createOldVarsSubst + oldTripsCanonical_L6) k = some w → + δ σ_R1 w = + δ σO (Lambda.LExpr.fvar () k none) := + HoldSubBridge_at_σO Hwfvars HgenOldLen HoldTysLen + HoldValsLen σ_R1_read_olds HoldEval_bridge + have HinputSubBridge : + ∀ k w, + Map.find? inputOnlyOldSubst_L6 k = some w → + δ σ_R1 w = + δ σO (Lambda.LExpr.fvar () k none) := + HinputSubBridge_at_σO Hwfvars Hwfval Hwfc Hwf2 HprocEq Hiodisj + Hinitin Hinitout Hhav1 HInitVars_empty Hevalargs hCallArgsIn + HargIsDef HoldIdentsTemp Hgenrel + HargVarsNotInInKeys HargVarsNotInOutKeys rfl + have HpostEval_bridge : + ∀ entry : CoreLabel × Procedure.Check, + entry ∈ posts_filtered_L6.toList → + δ σ_R1 entry.snd.expr = + some Imperative.HasBool.tt := by + intro entry Hentry + obtain ⟨c, Hc_in, Hentry_eq⟩ := + forall_post_filtered_decompose entry Hentry + rw [Hentry_eq] + have Hsub : + ∀ k w, k ∈ Imperative.HasVarsPure.getVars + (P:=Expression) c.expr → + Map.find? oldSubst_L6 k = some w → + δ σ_R1 w = + δ σO (Lambda.LExpr.fvar () k none) := by + intro k w _Hk Hf + cases hfind : Map.find? + (Core.Transform.createOldVarsSubst + oldTripsCanonical_L6) k with + | some v => + have Hvw : v = w := find?_append_some_eq hfind Hf + exact Hvw.symm ▸ HoldSubBridge k v hfind + | none => + exact HinputSubBridge k w (find?_append_none_elim hfind Hf) + have HpostVarsFresh_via_c : + ∀ c ∈ proc'.spec.postconditions.values, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) c.expr, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ + v ∉ CallArg.getLhs args := by + intro c Hc_in v Hv + exact _HpostVarsFresh c.expr (c_in_postExprs_of_proc' c Hc_in) v Hv + have HsurvBridgeC : + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) + c.expr, + Map.find? oldSubst_L6 v = none → + δ σ_R1 (Lambda.LExpr.fvar () v none) = + δ σO (Lambda.LExpr.fvar () v none) := by + intro v Hv _Hnone + have HvFresh := HpostVarsFresh_via_c c Hc_in v Hv + have HvNotOld : ¬ isOldTempIdent v := HvFresh.2.1 + have HvNotGen : v ∉ genOldIdents := + notMem_of_Forall_neg HoldIdentsTemp HvNotOld + have Hσ_R1_v_eq_σO : + σ_R1 v = σO v := by + show (updatedStates σO genOldIdents oldVals) v = σO v + exact updatedStates_get_notin HvNotGen + rw [δ_fvar_eq σ_R1 v, δ_fvar_eq σO v] + exact Hσ_R1_v_eq_σO + have Hbridge : + δ σ_R1 (Lambda.LExpr.substFvars c.expr oldSubst_L6) = + δ σO c.expr := + subst_fvars_eval_bridge Hwfc Hwfvars Hwfval + HsurvBridgeC Hsub + rw [Hbridge] + have Hin_full := c_in_postExprs_of_proc' c Hc_in + have Hin_contains : + (Procedure.Spec.getCheckExprs + proc.spec.postconditions).contains c.expr = true := + List.contains_iff_mem.mpr Hin_full + exact (Hpost c.expr Hin_contains).2 + -- Hinv: residual invStores σ_R1 σ_havoc — copy from success arm. + have HrdHavoc_olds_pos : + ∀ (i : Nat) (Hi : i < genOldIdents.length) + (Hi' : i < oldVals.length), + σ_havoc (genOldIdents[i]'Hi) = + some (oldVals[i]'Hi') := by + have HzipAppend2 : + ((argTemps ++ + outTemps) ++ genOldIdents).zip + ((argVals ++ oVals) ++ oldVals) = + ((argTemps ++ + outTemps).zip + (argVals ++ oVals)) ++ + (genOldIdents.zip oldVals) := by + apply List.zip_append + simp [List.length_append, HargTempsLen, HoutTempsLen] + have HsplitOverlay : + σ_havoc = + updatedStates + (updatedStates σ' + (argTemps ++ + outTemps) + (argVals ++ oVals)) + genOldIdents oldVals := by + show updatedStates σ' + (argTemps ++ + outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) = _ + simp only [updatedStates] + rw [HzipAppend2, updatedStates'App] + have HrdHavoc : + ReadValues σ_havoc genOldIdents oldVals := by + exact HsplitOverlay ▸ readValues_updatedStatesSame HgenOldOldValsLen HoldNd + intro i Hi Hi' + exact readValues_get HrdHavoc (i:=i) (hi:=Hi) (hi':=Hi') + have b1_var_witness := + @b1_var_witness_at_oldSubst oldVars genOldIdents oldTys + proc' args HgenOldLen HoldTysLen + have b2_var_witness := + @b2_var_witness_at_oldSubst oldVars genOldIdents oldTys + proc' args inArgs hCallArgsIn + -- σR1_eq_σhavoc: pointwise equality off all touched layers. + have σR1_eq_σhavoc : + ∀ {k : Expression.Ident}, + k ∉ proc.header.inputs.keys → + k ∉ proc.header.outputs.keys → + k ∉ argTemps → k ∉ outTemps → + k ∉ genOldIdents → k ∉ lhs → + σ_R1 k = σ_havoc k := by + intro k Hk_ins Hk_outs Hk_argT Hk_outT Hk_genOld Hk_lhs + have HσR1_σ : updatedStates σO genOldIdents oldVals k = σ k := + σR1_eq_σ_for_notTouched Hinitin Hinitout Hhav1 + Hk_ins Hk_outs Hk_genOld + have H5 : σ k = σ' k := by + rw [Hσ'_eq, updatedStates_get_notin Hk_lhs] + have Hk_notin_layered : k ∉ argTemps ++ outTemps ++ genOldIdents := + List.notin_3_append_of Hk_argT Hk_outT Hk_genOld + have H6 : σ' k = σ_havoc k := by + show σ' k = updatedStates σ' + (argTemps ++ outTemps ++ genOldIdents) + (argVals ++ oVals ++ oldVals) k + rw [updatedStates_get_notin Hk_notin_layered] + show updatedStates σO genOldIdents oldVals k = σ_havoc k + rw [HσR1_σ, H5, H6] + have HargVarsNotInLhs : + ∀ argExpr ∈ CallArg.getInputExprs args, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, + v ∉ CallArg.getLhs args := _HargVarsNotInLhs + have HpostVarsFresh_via_c : + ∀ c ∈ proc'.spec.postconditions.values, + ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) c.expr, + ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ + v ∉ CallArg.getLhs args := by + intro c Hc_in v Hv + exact _HpostVarsFresh c.expr (c_in_postExprs_of_proc' c Hc_in) v Hv + have HfiltArgT_sub_argT : + ∀ x ∈ filtered_argTemps, x ∈ argTemps := by + intro x Hx + show x ∈ argTemps + have Hx' : x ∈ filtered_argSubst.unzip.snd := Hx + simp only [List.unzip_eq_map, List.mem_map] at Hx' + rcases Hx' with ⟨pair, Hpair_mem, Hpair_snd⟩ + have Hpair_in_zip := (List.mem_filter.mp Hpair_mem).1 + have Hsnd_in : + pair.snd ∈ argTemps := + (List.of_mem_zip Hpair_in_zip).2 + rw [← Hpair_snd]; exact Hsnd_in + have Hinv : + ∀ entry : CoreLabel × Procedure.Check, + entry ∈ posts_filtered_L6.toList → + Imperative.invStores σ_R1 σ_havoc + ((Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr).removeAll + (filtered_ks ++ filtered_ks')) := by + intro entry Hentry + obtain ⟨c, Hc_in, Hentry_eq⟩ := + forall_post_filtered_decompose entry Hentry + simp only [Imperative.invStores, Imperative.substStores] + intros k1 k2 Hkin + obtain ⟨rfl, Hk1_pre, Hk1_notin_outs, Hk1_notin_filtIn, + Hk1_notin_lhs, Hk1_notin_filtArgT⟩ := + zip_removeAll4_decompose Hkin + rw [Hentry_eq] at Hk1_pre + rcases getVars_substFvars_mem Hk1_pre with + Hclass_a | ⟨k, w, Hk_in, Hf, Hv_in⟩ + · obtain ⟨Hk1_post, _Hf_none⟩ := Hclass_a + have HfreshK := HpostVarsFresh_via_c c Hc_in k1 Hk1_post + have Hk1_notTemp : ¬ isTempIdent k1 := HfreshK.1 + have Hk1_notOld : ¬ isOldTempIdent k1 := HfreshK.2.1 + have Hk1_notin_argT : k1 ∉ argTemps := + notMem_of_Forall_neg HargTemp Hk1_notTemp + have Hk1_notin_outT : k1 ∉ outTemps := + notMem_of_Forall_neg HoutTemp Hk1_notTemp + have Hk1_notin_genOld : k1 ∉ genOldIdents := + notMem_of_Forall_neg HoldIdentsTemp Hk1_notOld + have Hk1_notin_ins : + k1 ∉ proc.header.inputs.keys := by + intro h + rcases List.mem_iff_get.mp h with ⟨n, Hn⟩ + have Hn_lt_in : n.val < proc.header.inputs.keys.length := n.isLt + have Hn_lt_argT : n.val < argTemps.length := + HinKeys_argTemps_len ▸ Hn_lt_in + have HkE : + proc.header.inputs.keys[n.val]'Hn_lt_in = k1 := Hn + have Hpair_in_zip : + (k1, argTemps[n.val]'Hn_lt_argT) ∈ + proc.header.inputs.keys.zip argTemps := by + exact HkE.symm ▸ pair_in_zip_of_pos Hn_lt_in Hn_lt_argT + have Hpair_in_filtAS : + (k1, argTemps[n.val]'Hn_lt_argT) ∈ + filtered_argSubst := by + apply List.mem_filter.mpr + refine ⟨Hpair_in_zip, ?_⟩ + simp only [decide_not, Bool.not_eq_eq_eq_not, + Bool.not_true, decide_eq_false_iff_not, + List.contains_iff_mem] + exact Hk1_notin_outs + have Hk1_in_unzip : + k1 ∈ filtered_inputs := by + show k1 ∈ filtered_argSubst.unzip.fst + simp only [List.unzip_eq_map, List.mem_map] + refine ⟨(k1, argTemps[n.val]'Hn_lt_argT), Hpair_in_filtAS, rfl⟩ + exact Hk1_notin_filtIn Hk1_in_unzip + exact σR1_eq_σhavoc Hk1_notin_ins Hk1_notin_outs + Hk1_notin_argT Hk1_notin_outT Hk1_notin_genOld Hk1_notin_lhs + · cases hfind : Map.find? + (Core.Transform.createOldVarsSubst + oldTripsCanonical_L6) k with + | some w' => + obtain ⟨ni_val, Hni_lt_genOld, _Hw_eq, Hv_eq_gen⟩ := + b1_var_witness hfind Hf Hv_in + have Hni_lt_oldVals : ni_val < oldVals.length := + HoldValsLen.symm ▸ HgenOldLen ▸ Hni_lt_genOld + have Hσ_R1_v : + σ_R1 (genOldIdents[ni_val]'Hni_lt_genOld) = + some (oldVals[ni_val]'Hni_lt_oldVals) := + σ_R1_read_olds ni_val Hni_lt_genOld Hni_lt_oldVals + have Hσ_havoc_v : + σ_havoc (genOldIdents[ni_val]'Hni_lt_genOld) = + some (oldVals[ni_val]'Hni_lt_oldVals) := + HrdHavoc_olds_pos ni_val Hni_lt_genOld Hni_lt_oldVals + rw [Hv_eq_gen, Hσ_R1_v, Hσ_havoc_v] + | none => + obtain ⟨HargExpr_in, Hk1_flat⟩ := + b2_var_witness hfind Hf Hv_in + have Hk1_notin_outs' : + k1 ∉ proc.header.outputs.keys := + HargVarsNotInOutKeys w HargExpr_in k1 Hv_in + have Hk1_notin_ins' : + k1 ∉ proc.header.inputs.keys := + HargVarsNotInInKeys w HargExpr_in k1 Hv_in + have Hk1_σ_some : (σ k1).isSome := HargIsDef k1 Hk1_flat + have Hk1_notOld' : ¬ isOldTempIdent k1 := fun Hold => + σ_some_contradiction Hk1_σ_some + (Option.isNone_iff_eq_none.mp (Hgenrel.oldFresh k1 Hold)) + have Hk1_notin_argT' : k1 ∉ argTemps := + notin_of_isSome_isNotDefined Hk1_σ_some HndefArg_σ + have Hk1_notin_outT' : k1 ∉ outTemps := + notin_of_isSome_isNotDefined Hk1_σ_some HndefOut_σ + have Hk1_notin_genOld' : k1 ∉ genOldIdents := + notin_of_isSome_isNotDefined Hk1_σ_some HndefOld_σ + exact σR1_eq_σhavoc Hk1_notin_ins' Hk1_notin_outs' + Hk1_notin_argT' Hk1_notin_outT' Hk1_notin_genOld' + Hk1_notin_lhs + have Hpred_disj : + ∀ entry : CoreLabel × Procedure.Check, + entry ∈ posts_filtered_L6.toList → + filtered_ks'.Disjoint + (Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr) := by + intro entry Hentry + obtain ⟨c, Hc_in, Hentry_eq⟩ := + forall_post_filtered_decompose entry Hentry + intro x Hin1 Hin2 + rw [Hentry_eq] at Hin2 + rcases getVars_substFvars_mem Hin2 with + Hclass_a | ⟨k', w, Hk_in, Hf, Hv_in⟩ + · obtain ⟨Hx_post, _Hf_none⟩ := Hclass_a + have HfreshK := HpostVarsFresh_via_c c Hc_in x Hx_post + have Hx_notTemp : ¬ isTempIdent x := HfreshK.1 + have Hx_notLhs : x ∉ CallArg.getLhs args := HfreshK.2.2 + cases List.mem_append.mp Hin1 with + | inl Hx_lhs => + rw [hCallArgsLhs] at Hx_notLhs + exact Hx_notLhs Hx_lhs + | inr Hx_filtArgT => + have Hx_argT : x ∈ argTemps := + HfiltArgT_sub_argT x Hx_filtArgT + exact Hx_notTemp ((List.Forall_mem_iff.mp HargTemp) x Hx_argT) + · cases hfind : Map.find? + (Core.Transform.createOldVarsSubst + oldTripsCanonical_L6) k' with + | some w' => + obtain ⟨ni_val, Hni_lt_genOld, _Hw_eq, Hx_eq_gen⟩ := + b1_var_witness hfind Hf Hv_in + rw [Hx_eq_gen] at Hin1 + cases List.mem_append.mp Hin1 with + | inl Hx_lhs => + exact HlhsDisjOld Hx_lhs (List.getElem_mem _) + | inr Hx_filtArgT => + have Hx_argT : + genOldIdents[ni_val]'Hni_lt_genOld ∈ argTemps := + HfiltArgT_sub_argT _ Hx_filtArgT + have Hx_isTemp : + isTempIdent (genOldIdents[ni_val]'Hni_lt_genOld) := + (List.Forall_mem_iff.mp HargTemp) _ Hx_argT + have Hx_isOld : + isOldTempIdent (genOldIdents[ni_val]'Hni_lt_genOld) := + (List.Forall_mem_iff.mp HoldIdentsTemp) _ (List.getElem_mem _) + exact isTempIdent_isOldTempIdent_disjoint + Hx_isTemp Hx_isOld + | none => + obtain ⟨HargExpr_in, Hx_flat⟩ := + b2_var_witness hfind Hf Hv_in + have Hx_σ_some : (σ x).isSome := HargIsDef x Hx_flat + cases List.mem_append.mp Hin1 with + | inl Hx_lhs => + have Hx_notLhs : + x ∉ CallArg.getLhs args := + HargVarsNotInLhs w HargExpr_in x Hv_in + rw [hCallArgsLhs] at Hx_notLhs + exact Hx_notLhs Hx_lhs + | inr Hx_filtArgT => + have Hx_argT : + x ∈ argTemps := + HfiltArgT_sub_argT x Hx_filtArgT + exact σ_some_contradiction Hx_σ_some + (HndefArg_σ x Hx_argT) + have HpostPayload : + ∀ entry : CoreLabel × Procedure.Check, + entry ∈ posts_filtered_L6.toList → + Imperative.invStores σ_R1 σ_havoc + ((Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr).removeAll + (filtered_ks ++ filtered_ks')) ∧ + filtered_ks'.Disjoint + (Imperative.HasVarsPure.getVars (P:=Expression) + entry.snd.expr) ∧ + δ σ_R1 entry.snd.expr = + some Imperative.HasBool.tt := by + intro entry Hentry + refine ⟨Hinv entry Hentry, + Hpred_disj entry Hentry, + HpostEval_bridge entry Hentry⟩ + -- L6 (assumes) via H_assumes_zip_poly with f := true. + obtain ⟨assumeLabels, _HassumeLabelsLen, HassumeShape⟩ := + _HassumesShape + have HassumeSubst_eq : + ((proc'.header.outputs.keys.zip + (Core.Transform.createFvars (CallArg.getLhs args))) ++ + (proc'.header.inputs.keys.zip + (Core.Transform.createFvars argTemps)).filter + (fun (id, _) => + !(ListMap.keys proc'.header.outputs).contains id)) = + filtered_ks.zip + (Core.Transform.createFvars filtered_ks') := by + rw [HprocEq] + show _ = (proc.header.outputs.keys ++ filtered_inputs).zip + (Core.Transform.createFvars (lhs ++ filtered_argTemps)) + rw [createFvarsApp] + rw [List.zip_append + (show proc.header.outputs.keys.length = + (Core.Transform.createFvars lhs).length by + rw [createFvarsLength, + HoutKeys_lhs_len])] + rw [hCallArgsLhs] + congr 1 + show (proc.header.inputs.keys.zip + (argTemps.map Core.Transform.createFvar)).filter _ = + filtered_argSubst.unzip.fst.zip + (filtered_argSubst.unzip.snd.map + Core.Transform.createFvar) + rw [List.zip_map_right] + rw [List.filter_map] + have HfiltEq : + (proc.header.inputs.keys.zip argTemps).filter + ((fun (x : Expression.Ident × Expression.Expr) => + !(ListMap.keys proc.header.outputs).contains x.1) ∘ + Prod.map id Core.Transform.createFvar) = + filtered_argSubst := by + show _ = (proc.header.inputs.keys.zip argTemps).filter + (fun pr => + ¬ (proc.header.outputs.keys).contains pr.1) + apply List.filter_congr + intro pr _ + cases pr with + | mk a b => simp [Function.comp, Prod.map] + rw [HfiltEq] + rw [show filtered_argSubst.unzip.fst.zip + (filtered_argSubst.unzip.snd.map + Core.Transform.createFvar) = + (filtered_argSubst.unzip.fst.zip + filtered_argSubst.unzip.snd).map + (Prod.map id Core.Transform.createFvar) from + List.zip_map_right] + rw [show filtered_argSubst.unzip.fst.zip + filtered_argSubst.unzip.snd = + filtered_argSubst from List.zip_unzip _] + have HL6_pre : + EvalStatementsContract π φ ⟨σ_havoc, δ, true⟩ + ((posts_filtered_L6.zip assumeLabels).map + (fun (entry, lbl) => + Statement.assume lbl + (Lambda.LExpr.substFvars entry.snd.expr + (filtered_ks.zip + (Core.Transform.createFvars filtered_ks'))) + (entry.snd.md.setCallSiteFileRange md))) + ⟨σ_havoc, δ, true⟩ := by + apply H_assumes_zip_poly + (σA := σ_R1) (σ' := σ_havoc) (f := true) + (ks := filtered_ks) + (ks' := filtered_ks') + (posts := posts_filtered_L6.toList) + (labels := assumeLabels) + Hwfb Hwfvars Hwfval Hwfc + Hkslen Hnd Hdef Hsubst + intros entry Hentry + exact HpostPayload entry Hentry + have HL6 : + EvalStatementsContract π φ ⟨σ_havoc, δ, true⟩ + assumes ⟨σ_havoc, δ, true⟩ := by + rw [HassumeShape] + exact HassumeSubst_eq ▸ HL6_pre + -- ── D2g: Glue via EvalCallElim_glue_fail ── + exact EvalCallElim_glue_fail HL1 HL2 HL3 HL4 HL5 HL6 + /-- Call-elimination correctness for a single statement. Given a small-step `EvalStatementsContract` derivation of `[st]` @@ -1286,12 +3835,13 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} {δ : CoreEval} {σ σ' : CoreStore} + {f : Bool} {p : Program} {γ γ' : CoreTransformState} {st : Statement} {sts : List Statement} (Hp : ∀ pname, π pname = Program.Procedure.find? p ⟨pname, ()⟩) - (Heval : EvalStatementsContract π φ ⟨σ, δ, false⟩ [st] ⟨σ', δ, false⟩) + (Heval : EvalStatementsContract π φ ⟨σ, δ, false⟩ [st] ⟨σ', δ, f⟩) (Hwfc : WellFormedCoreEvalCong δ) (Hwf : WF.WFStatementsProp p [st]) (Hgenrel : CoreGenStateRel σ γ) @@ -1302,14 +3852,14 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (Helim : (Except.ok sts, γ') = (runWith st (callElimStmt · p) γ)) : ∃ σ'', Inits σ' σ'' ∧ - EvalStatementsContract π φ ⟨σ, δ, false⟩ sts ⟨σ'', δ, false⟩ := by + EvalStatementsContract π φ ⟨σ, δ, false⟩ sts ⟨σ'', δ, f⟩ := by -- Non-call cases close with σ'' = σ' (callElimStmt returns [st]); -- call case extends σ' with fresh temp/old vars. Non-call branches -- unified via `callElimStmt_non_call_eq`, dispatched through `nc_close`. have nc_close : ∀ {b : Statement} (_ : st = b) (_ : ∀ pn ar mt, b ≠ .cmd (CmdExt.call pn ar mt)), ∃ σ'', Inits σ' σ'' ∧ - EvalStatementsContract π φ ⟨σ, δ, false⟩ sts ⟨σ'', δ, false⟩ := by + EvalStatementsContract π φ ⟨σ, δ, false⟩ sts ⟨σ'', δ, f⟩ := by intro b heq hne refine ⟨σ', Inits.init InitVars.init_none, ?_⟩ have hsts := callElimStmt_non_call_eq hne (heq ▸ Helim) @@ -1366,14 +3916,14 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) (.stmts [] ρ_inner) - (.terminal ⟨σ', δ, false⟩) := by + (.terminal ⟨σ', δ, f⟩) := by unfold EvalStatementsContract Imperative.EvalStmtsSmall at Heval match Heval with | .step _ _ _ .step_stmts_cons hrest => exact Imperative.seq_reaches_terminal Expression (EvalCommandContract π) (EvalPureFunc φ) hrest - -- htail forces ρ_inner = ⟨σ',δ,false⟩. - have hρ_inner_eq : ρ_inner = ⟨σ', δ, false⟩ := by + -- htail forces ρ_inner = ⟨σ',δ,f⟩. + have hρ_inner_eq : ρ_inner = ⟨σ', δ, f⟩ := by match htail with | .step _ _ _ .step_stmts_nil hrest' => cases hrest' with @@ -1382,38 +3932,61 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] subst hρ_inner_eq -- Invert `hstep_call : StepStmtStar (.cmd (.call …)) … → terminal` to extract Hcc. have Hcc : EvalCommandContract π δ σ - (CmdExt.call procName args md) σ' false := by + (CmdExt.call procName args md) σ' f := by match hstep_call with | .step _ _ _ (.step_cmd hcc) hrest => cases hrest with | refl => - -- call_sem is failure-flag-parameterized; Hcc is pinned - -- to `failed = false` at this destructure site. + -- call_sem is failure-flag-parameterized; Hcc carries the + -- caller's outer flag `f` here. exact hcc | step _ _ _ h _ => exact absurd h (by intro h; cases h) cases Hcc with | call_sem lkup hCallArgsIn hCallArgsLhs Hevalargs Hevalouts Hwfval Hwfvars Hwfb Hwf2 HdefOver Hinitin Hinitout Hpre_def Hpre_iff Hhav1 Hpost Hrd - Hupdate_succ Hupdate_fail => + Hupdate => -- call_sem implicits: lhs σ₀ inArgs oVals argVals σA σAO σO proc modvals. rename_i lhs σ₀ inArgs oVals argVals σA σAO σO proc modvals - -- Re-synthesize the legacy combined `Hpre` and the success-path - -- `Hupdate` from the new bool-indicator-shaped premises. At this - -- destructure site `Hcc` is pinned to `failed = false`, so the - -- iff yields the original universal eval-tt and the success-path - -- arrow yields `UpdateStates σ lhs modvals σ'`. + -- Dispatch on the source-side failure flag `f`. + -- * `f = false`: success arm — preconditions all hold, write + -- back via `H_asserts_zip + H_havocs + H_assumes_zip`, + -- glue via `EvalCallElim_glue`. + -- * `f = true`: failure arm — at least one precondition + -- fails, write back via `H_asserts_zip_fail + H_havocs_poly + -- + H_assumes_zip_poly`, glue via `EvalCallElim_glue_fail`. + cases f with + | true => + -- Stage 6 failure arm: derive bool-totality witness via + -- Hwfcallsite → boolTyped, build failing assert chain, glue + -- with EvalCallElim_glue_fail. Delegated to a sibling + -- private theorem for proof-body manageability. + exact callElimStatementCorrect_terminal_call_arm_fail + Hp Hwfc Hwf Hgenrel Hwfcallsite heq_ce + lkup hCallArgsIn hCallArgsLhs Hevalargs Hevalouts + Hwfval Hwfvars Hwfb Hwf2 + Hinitin Hinitout Hpre_def Hpre_iff Hhav1 Hpost Hrd + Hupdate + | false => + -- Re-synthesize the legacy combined `Hpre` from the new + -- bool-indicator-shaped premises. At this destructure site `Hcc` + -- is pinned to `failed = false`, so the iff yields universal + -- eval-tt over non-Free preconditions only — exactly what + -- the L4 callElim asserts chain (which filters out Free) needs. have Hpre_evalTt : - ∀ pre, (Procedure.Spec.getCheckExprs proc.spec.preconditions).contains pre → + ∀ pre, (Procedure.Spec.getCheckExprs + (proc.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free))).contains pre → δ σAO pre = .some Imperative.HasBool.tt := Hpre_iff.mp rfl have Hpre : - ∀ pre, (Procedure.Spec.getCheckExprs proc.spec.preconditions).contains pre → + ∀ pre, (Procedure.Spec.getCheckExprs + (proc.spec.preconditions.filter + (fun (_, c) => c.attr ≠ .Free))).contains pre → Imperative.isDefinedOver (Imperative.HasVarsPure.getVars (P:=Expression)) σAO pre ∧ δ σAO pre = .some Imperative.HasBool.tt := fun pre h => ⟨Hpre_def pre h, Hpre_evalTt pre h⟩ - have Hupdate : UpdateStates σ lhs modvals σ' := Hupdate_succ rfl -- B1-tail: destructure heq_ce via callElimCmd_call_eq. obtain ⟨proc', argTrips, outTrips, genOldIdents, oldTys, asserts, assumes, @@ -1438,76 +4011,23 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] argTrips.unzip.fst.unzip.fst let outTemps : List Expression.Ident := outTrips.unzip.fst.unzip.fst - -- Pre-simped Hwfvars for repeated δ-fvar lookups. - have Hwfvr := Hwfvars - simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr -- Generic δ-fvar lookup: `δ σ (fvar v) = σ v` for any σ. - have δ_fvar_eq : - ∀ (σ' : CoreStore) (v : Expression.Ident), - δ σ' (Lambda.LExpr.fvar () v none) = σ' v := by - intro σ' v - rw [Hwfvr (Lambda.LExpr.fvar () v none) v] - simp [Imperative.HasFvar.getFvar] + have δ_fvar_eq := delta_fvar_eq_of_wfvars Hwfvars (delta := δ) -- C1: aux facts derived from the destructured binders. - have Hwfgenargs : CoreGenState.WF s_arg.genState := by - apply genArgExprIdentsTripWFMono ?_ Heqarg - exact Hgenrel.wfgen - have Hwfgenouts : CoreGenState.WF s_out.genState := - genOutExprIdentsTripWFMono Hwfgenargs Heqout - have Hgenargs : - s_arg.genState.generated = - argTemps.reverse ++ - γ.genState.generated := by - have HH := genArgExprIdentsTripGeneratedWF Heqarg - -- {γ with ...}.genState = γ.genState; reduce. - exact HH - have Hgenouts : - s_out.genState.generated = - outTemps.reverse ++ - s_arg.genState.generated := - genOutExprIdentsTripGeneratedWF Heqout have HargTemp : - Forall (fun x => isTempIdent x) - argTemps := + Forall (fun x => isTempIdent x) argTemps := genArgExprIdentsTrip_isTempIdent Heqarg have HoutTemp : - Forall (fun x => isTempIdent x) - outTemps := + Forall (fun x => isTempIdent x) outTemps := genOutExprIdentsTrip_isTempIdent Heqout - -- Old-related aux facts. `oldVars` is the filter - -- expression in the live `callElimCmd`. - have Hwfgenolds : CoreGenState.WF s_old := - genOldExprIdentsTripWFMono Hwfgenouts Heqold - have Hgenolds : - s_old.generated = - genOldIdents.reverse ++ s_out.genState.generated := - genOldExprIdents_GeneratedWF Heqold have HoldIdentsTemp : Forall (fun x => isOldTempIdent x) genOldIdents := genOldExprIdents_isOldTempIdent Heqold - -- Combined-extension equation: the post-old gen list is - -- the concatenation of all three reverse-segments and γ's gen. - have HgenApp : - s_old.generated = - genOldIdents.reverse ++ - outTemps.reverse ++ - argTemps.reverse ++ - γ.genState.generated := by - rw [Hgenolds, Hgenouts, Hgenargs] - simp [List.append_assoc] - -- Nodup of the combined list, in reversed-segment shape. have Hgennd' : (γ.genState.generated.reverse ++ - argTemps ++ - outTemps ++ - genOldIdents).Nodup := by - -- Project Nodup conjunct from Hwfgenolds (3-conj WF predicate). - have HndOld : s_old.generated.Nodup := Hwfgenolds.right.right - rw [HgenApp] at HndOld - have Hnd := nodup_reverse HndOld - simp only [List.reverse_append, List.reverse_reverse, - ← List.append_assoc] at Hnd - exact Hnd + argTemps ++ outTemps ++ genOldIdents).Nodup := by + apply genTrips_combined_nodup Heqarg Heqout Heqold + exact Hgenrel.wfgen -- Hgennd' nodup → 3-segment Nodup + arg/out/old σ-fresh + lifted to σ'. obtain ⟨Hgennd, HndefArg_σ, HndefOut_σ, HndefOld_σ, Hndefgen⟩ := fresh_triple_σ_facts Hgenrel Hgennd' HargTemp HoutTemp @@ -1669,8 +4189,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (updatedStates σ argTemps argVals) outTrips.unzip.snd oVals := by - rw [HoutSnd_eq_lhs] - exact readValues_updatedStates HargTempsLen HlhsDisjArg Hevalouts + exact HoutSnd_eq_lhs ▸ readValues_updatedStates HargTempsLen HlhsDisjArg Hevalouts -- outTemps undefined in σ_arg (argTemps disjoint from outTemps). have HndefOut_argLayer : Imperative.isNotDefined @@ -1679,8 +4198,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] outTemps := by intro v Hv have Hv_notin : v ∉ argTemps := fun Hin => HargOutDisj Hin Hv - rw [updatedStates_get_notin (σ:=σ) (ks:=argTemps) (vs:=argVals) Hv_notin] - exact HndefOut_σ v Hv + exact (updatedStates_get_notin (σ:=σ) (ks:=argTemps) (vs:=argVals) Hv_notin) ▸ HndefOut_σ v Hv have HL2 : EvalStatementsContract π φ ⟨updatedStates σ argTemps @@ -1730,8 +4248,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] have HoldVarsNd : oldVars.Nodup := by -- oldVars ⊆ (CallArg.getLhs args) = lhs via filter sublist. have HlhsArgs_nd : (CallArg.getLhs args).Nodup := by - rw [hCallArgsLhs] - exact HlhsNd + exact hCallArgsLhs ▸ HlhsNd exact List.Sublist.nodup List.filter_sublist HlhsArgs_nd -- Lift HoldVals through 2 layers via readValues_updatedStates. have HrdOlds_outLayer : @@ -1751,8 +4268,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] argTemps argVals) outTemps oVals) oldTrips.unzip.snd oldVals := by - rw [HoldTripsSnd] - exact HrdOlds_outLayer + exact HoldTripsSnd ▸ HrdOlds_outLayer -- genOldIdents disjoint from argTemps/outTemps ⇒ undef in σ_out. have HndefOld_outLayer : Imperative.isNotDefined @@ -1781,8 +4297,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] argTemps argVals) outTemps oVals) oldTrips.unzip.fst.unzip.fst := by - rw [HoldTripsFst] - exact HndefOld_outLayer + exact HoldTripsFst ▸ HndefOld_outLayer -- Nodup precondition: (genOldIdents ++ oldVars).Nodup. have HoldTrips_nd_app : List.Nodup @@ -1931,23 +4446,8 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] rw [Hflatten_eq, hCallArgsLhs] exact HL5_pre -- D2a: per-precondition payload for L4 (asserts). - have HprocEq : proc' = proc := by - have Hπ := Hp procName - rw [Hπ] at lkup - rw [Hfind] at lkup - exact (Option.some_inj.mp lkup.symm).symm - -- Bridge `c ∈ proc'.spec.postconditions.values` to - -- `c.expr ∈ getCheckExprs proc.spec.postconditions` via HprocEq. - have c_in_postExprs_of_proc' : - ∀ c, c ∈ proc'.spec.postconditions.values → - c.expr ∈ Procedure.Spec.getCheckExprs - proc.spec.postconditions := by - intro c Hc_in - simp only [Procedure.Spec.getCheckExprs, List.mem_map] - refine ⟨c, ?_, rfl⟩ - rw [HprocEq] at Hc_in - rw [ListMap.values_eq_map_snd] - rwa [ListMap.values_eq_map_snd] at Hc_in + obtain ⟨HprocEq, c_in_postExprs_of_proc'⟩ := + procEq_and_postExprs_bridge Hp Hfind lkup -- Specialize Hwfcallsite (over `proc`) to the call form; -- spike uses `proc'` which HprocEq bridges. obtain ⟨HpreVarsFresh, HpostVarsFresh, HargVarsNotInLhs, @@ -2008,6 +4508,10 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] proc.spec.preconditions.filter (fun (_, c) => c.attr ≠ .Free) -- Bind σAO definedness/eval-tt for each filtered entry. + -- Hpre's domain is `getCheckExprs presFiltered.contains`, so + -- mapping `entry ∈ presFiltered` to that contains-membership + -- is direct: it's the membership of `entry.snd.expr` in + -- `getCheckExprs presFiltered` (no filter-bridge needed). have HpreFiltered : ∀ entry ∈ presFiltered, Imperative.isDefinedOver @@ -2015,7 +4519,13 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] σAO entry.snd.expr ∧ δ σAO entry.snd.expr = some Imperative.HasBool.tt := by intro entry Hentry - exact Hpre entry.snd.expr (filterCheck_in_getCheckExprs Hentry) + apply Hpre entry.snd.expr + rw [List.contains_iff_mem] + simp only [Procedure.Spec.getCheckExprs, + ListMap.values_eq_map_snd, List.mem_map, + List.map_map] + refine ⟨entry, Hentry, ?_⟩ + rfl -- Pre-var freshness lemma against σ_old / σAO. have HpresVarsFresh' : ∀ entry ∈ presFiltered, @@ -2083,22 +4593,9 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (argTemps ++ lhs))) := by simp only [Imperative.invStores, Imperative.substStores] intros k1 k2 Hkin - obtain rfl := zip_self_eq Hkin - have Hk1_in : k1 ∈ - (Imperative.HasVarsPure.getVars (P:=Expression) - entry.snd.expr).removeAll - ((proc.header.inputs.keys ++ - proc.header.outputs.keys) ++ - (argTemps ++ lhs)) := - (List.of_mem_zip Hkin).1 - -- Decompose the removeAll membership. - simp only [List.removeAll, List.mem_filter, - List.elem_eq_mem, Bool.not_eq_true', - decide_eq_false_iff_not] at Hk1_in - obtain ⟨Hk1_pre, Hk1_notin⟩ := Hk1_in - obtain ⟨Hk1_notin_inputs, Hk1_notin_outputs, + obtain ⟨rfl, Hk1_pre, Hk1_notin_inputs, Hk1_notin_outputs, Hk1_notin_argT, _Hk1_notin_lhs⟩ := - List.notin_append4 Hk1_notin + zip_removeAll4_decompose Hkin -- preVar k1 fresh facts (not tmp_, not old_, not in lhs). have HfreshK := HfreshEnt k1 Hk1_pre have Hk1_notTemp : ¬ isTempIdent k1 := HfreshK.1 @@ -2177,9 +4674,8 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] -- Pre-filter zip's unzip = (inputs.keys, argTemps). have Hzip_unzip : (proc.header.inputs.keys.zip argTemps).unzip = - (proc.header.inputs.keys, argTemps) := by - apply List.unzip_zip - exact HinKeys_argTemps_len + (proc.header.inputs.keys, argTemps) := + List.unzip_zip HinKeys_argTemps_len -- Filter sub-membership: each (id, t) ∈ filtered_argSubst -- is in the original zip and satisfies the filter. have Hfilter_in : @@ -2230,8 +4726,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] rcases List.mem_map.mp Hv' with ⟨pr, Hpr_in, Hpr_eq⟩ have HinZip := (Hfilter_in pr Hpr_in).1 have Hofzip := List.of_mem_zip HinZip - rw [← Hpr_eq] - exact Hofzip.1 + exact Hpr_eq.symm ▸ Hofzip.1 have Hfilt_argT_sub_argTemps : ∀ v ∈ filtered_argTemps, v ∈ argTemps := by intro v Hv @@ -2240,8 +4735,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] rcases List.mem_map.mp Hv' with ⟨pr, Hpr_in, Hpr_eq⟩ have HinZip := (Hfilter_in pr Hpr_in).1 have Hofzip := List.of_mem_zip HinZip - rw [← Hpr_eq] - exact Hofzip.2 + exact Hpr_eq.symm ▸ Hofzip.2 have Hfilt_in_disj_outs : filtered_inputs.Disjoint proc.header.outputs.keys := by intro v Hv1 Hv2 @@ -2390,29 +4884,23 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] exact Hfilt_in_disj_filt_argT HaIn HbArgT -- Hdef: substDefined σ_R1 σ_havoc. have HσO_def_outs : - Imperative.isDefined σO proc.header.outputs.keys := by - apply HavocVarsDefMonotone ?_ Hhav1 - exact InitStatesDefined Hinitout + Imperative.isDefined σO proc.header.outputs.keys := + HavocVarsDefMonotone (InitStatesDefined Hinitout) Hhav1 have HσO_def_inputs : - Imperative.isDefined σO proc.header.inputs.keys := by - apply HavocVarsDefMonotone ?_ Hhav1 - apply InitStatesDefMonotone ?_ Hinitout - exact InitStatesDefined Hinitin + Imperative.isDefined σO proc.header.inputs.keys := + HavocVarsDefMonotone + (InitStatesDefMonotone (InitStatesDefined Hinitin) Hinitout) Hhav1 -- σ_R1 = σO off genOldIdents (single closure). have σR1_off_olds : ∀ {v}, v ∉ genOldIdents → σ_R1 v = σO v := fun Hv => updatedStates_get_notin Hv have Hσ_R1_def_outs : - Imperative.isDefined σ_R1 proc.header.outputs.keys := - fun v Hv => by - rw [show σ_R1 v = σO v from σR1_off_olds (HoutKeys_disj_olds Hv)] - exact HσO_def_outs v Hv + Imperative.isDefined σ_R1 proc.header.outputs.keys := fun v Hv => + (show σ_R1 v = σO v from σR1_off_olds (HoutKeys_disj_olds Hv)) ▸ HσO_def_outs v Hv have Hσ_R1_def_filt_in : - Imperative.isDefined σ_R1 filtered_inputs := - fun v Hv => by - have Hv_in := Hfilt_in_sub_inputs v Hv - rw [show σ_R1 v = σO v from σR1_off_olds (HinKeys_disj_olds Hv_in)] - exact HσO_def_inputs v Hv_in + Imperative.isDefined σ_R1 filtered_inputs := fun v Hv => + let Hv_in := Hfilt_in_sub_inputs v Hv + (show σ_R1 v = σO v from σR1_off_olds (HinKeys_disj_olds Hv_in)) ▸ HσO_def_inputs v Hv_in -- σ_havoc definedness on lhs. have Hσ_havoc_def_lhs : Imperative.isDefined σ_havoc lhs := by @@ -2423,8 +4911,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (argVals ++ oVals ++ oldVals) v).isSome = true have Hv_notin : v ∉ argTemps ++ outTemps ++ genOldIdents := List.notin_3_append_of (HlhsDisjArg Hv) (HlhsDisjOut Hv) (HlhsDisjOld Hv) - rw [updatedStates_get_notin Hv_notin] - exact HavocVarsDefined (UpdateStatesHavocVars Hupdate) v Hv + exact (updatedStates_get_notin Hv_notin) ▸ HavocVarsDefined (UpdateStatesHavocVars Hupdate) v Hv -- σ_havoc definedness on filtered_argTemps. have Hσ_havoc_def_filt_argT : Imperative.isDefined σ_havoc filtered_argTemps := by @@ -2505,11 +4992,9 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] -- σO on inputs = σA on inputs (Hhav1 preserves on non-outputs; -- Hinitout preserves on non-outputs). have HσO_ins_eq_σA : - ∀ v ∈ proc.header.inputs.keys, σO v = σA v := fun v Hv => by - have Hv_notin : v ∉ proc.header.outputs.keys := - fun h => Hiodisj Hv h - rw [σO_eq_σAO_off_outs Hv_notin] - exact initStates_get_notin Hinitout Hv_notin + ∀ v ∈ proc.header.inputs.keys, σO v = σA v := fun v Hv => + let Hv_notin : v ∉ proc.header.outputs.keys := fun h => Hiodisj Hv h + (σO_eq_σAO_off_outs Hv_notin) ▸ initStates_get_notin Hinitout Hv_notin -- σA on inputs = positional argVals (via Hinitin). have HrdA : ReadValues σA proc.header.inputs.keys argVals := InitStatesReadValues Hinitin @@ -2522,9 +5007,8 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] ReadValues σ_R1 proc.header.inputs.keys argVals := by apply readValues_updatedStates HgenOldOldValsLen HinKeys_disj_olds -- ReadValues σO inputs.keys argVals. - have HrdAO : ReadValues σAO proc.header.inputs.keys argVals := by - apply InitStatesReadValuesMonotone (σ:=σA) ?_ Hinitout - exact InitStatesReadValues Hinitin + have HrdAO : ReadValues σAO proc.header.inputs.keys argVals := + InitStatesReadValuesMonotone (σ:=σA) (InitStatesReadValues Hinitin) Hinitout have Hh1 := HavocVarsUpdateStates Hhav1 rcases Hh1 with ⟨ovh, Hup_havoc⟩ apply UpdateStatesReadValuesMonotone (σ:=σAO) _ ?_ Hup_havoc @@ -2555,8 +5039,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (updatedStates σ' argTemps argVals) outTemps oVals) argTemps argVals := readValues_updatedStates HoutTempsLen HargOutDisj HargF_σ' - rw [HoldTripsFst] - exact readValues_updatedStates HgenOldOldValsLen HargOldDisj HargF_step1 + exact HoldTripsFst ▸ readValues_updatedStates HgenOldOldValsLen HargOldDisj HargF_step1 -- σ_havoc reads lhs → modvals (fall-through to σ'). have HmodvalsLen' : lhs.length = modvals.length := by have := UpdateStatesLength Hupdate; omega @@ -2707,8 +5190,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] rw [Hk2_app, this] -- Pair (k1, k2) ∈ filtered_argSubst. have HpairIn : (k1, k2) ∈ filtered_argSubst := by - rw [← HpairAtJ] - exact List.getElem_mem _ + exact HpairAtJ.symm ▸ List.getElem_mem _ -- (k1, k2) ∈ inputs.keys.zip argTemps via Hfilter_in. have HpairZip := (Hfilter_in (k1, k2) HpairIn).1 obtain ⟨m, Hm_lt_in, Hm_lt_argT, Hk1_inGet, Hk2_argTGet⟩ := @@ -2772,13 +5254,11 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] have Hnd_L4 : Imperative.substNodup (ks_L4.zip ks'_L4) := by unfold Imperative.substNodup - rw [List.unzip_zip Hks_len_L4] - exact Hbignd_L4 + exact (List.unzip_zip Hks_len_L4) ▸ Hbignd_L4 -- ── L4 substDefined ── have HσAO_def_in_L4 : - Imperative.isDefined σAO proc.header.inputs.keys := by - apply InitStatesDefMonotone ?_ Hinitout - exact InitStatesDefined Hinitin + Imperative.isDefined σAO proc.header.inputs.keys := + InitStatesDefMonotone (InitStatesDefined Hinitin) Hinitout have HσAO_def_out_L4 : Imperative.isDefined σAO proc.header.outputs.keys := InitStatesDefined Hinitout @@ -2887,25 +5367,12 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (labels := assertLabels) Hwfb Hwfvars Hwfval Hwfc Hks_len_L4 Hnd_L4 Hdef_L4 Hsubst_L4 - -- HpresPayload over presFiltered. Two filter forms - -- (`!=` boolean ↔ `≠` Prop) agree via decide reduction. + -- HpresPayload over presFiltered. Bridge `!=` ↔ `≠` filter forms. intros entry Hentry have Hentry' : entry ∈ presFiltered := by show entry ∈ proc.spec.preconditions.filter (fun (_, c) => c.attr ≠ .Free) - have Hin : - entry ∈ - (List.filter - (fun x => match x with - | (_, check) => check.attr != Procedure.CheckAttr.Free) - proc.spec.preconditions) := Hentry - rw [List.mem_filter] at Hin ⊢ - refine ⟨Hin.1, ?_⟩ - simp only [decide_not, Bool.not_eq_eq_eq_not, Bool.not_true, - decide_eq_false_iff_not, ne_eq] - have := Hin.2 - simp only [bne_iff_ne, ne_eq] at this - exact this + exact (filter_bne_eq_filter_ne proc.spec.preconditions).symm ▸ Hentry exact HpresPayload entry Hentry' -- Bridge to the actual `asserts` list via HassertsShape. have HL4 : @@ -2917,27 +5384,16 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] -- Push proc' = proc through to reach the L4-derived form. rw [HprocEq] -- Rewrite the inner substitution map via HassertSubst_eq. - rw [HassertSubst_eq] - exact HL4_pre + exact HassertSubst_eq ▸ HL4_pre -- D2d-bridge: σO ↔ σAO old-binding bridge. - -- (a) Trivial empty-init witness. + -- (a) Trivial empty-init witness (used by callee bridges). have HInitVars_empty : InitVars σO [] σO := InitVars.init_none - -- (b) Per-output bridge via Hwf2's universal clause. - have Hwf2_univ : - ∀ v ∈ proc.header.outputs.keys, - δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) - none) = - σAO v := by - intro v Hv - -- Unfold Hwf2 to expose the `∧` structure. - simp only [WellFormedCoreEvalTwoState] at Hwf2 - -- Hwf2.2 : universal clause; instantiate at - -- (vs := outputs.keys, vs' := [], σ₀ := σAO, σ₁ := σO, - -- σ_arg := σO) using `Hhav1 ∧ HInitVars_empty`. - have HH := Hwf2.2 proc.header.outputs.keys [] σAO σO σO - ⟨Hhav1, HInitVars_empty⟩ v - exact HH.1 Hv - -- (c) σAO[v] = σ[v] for v ∉ outputs ∪ inputs. + -- (b) Per-output bridge, σAO reads outputs, oldVars ⊆ lhs/outs. + obtain ⟨Hwf2_univ, HσAO_reads_outs, HoldVars_sub_callLhs, + HoldVars_sub_outs⟩ := + holdEval_bridge_prelude (args := args) + Hwf2 Hhav1 Hinitout HprocEq + -- (b) σAO[v] = σ[v] for v ∉ outputs ∪ inputs. have HσAO_notin_eq_σ : ∀ v, v ∉ proc.header.outputs.keys → v ∉ proc.header.inputs.keys → @@ -2945,96 +5401,16 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] intro v Hv_notout Hv_notin rw [initStates_get_notin Hinitout Hv_notout, initStates_get_notin Hinitin Hv_notin] - -- (d) σAO reads outputs ↦ oVals (positional). - have HσAO_reads_outs : - ReadValues σAO proc.header.outputs.keys oVals := - InitStatesReadValues Hinitout - -- (e) Positional alignment via HoutAlign (Hwfcallsite.specialize). - -- (f) Per-index δ-eval bridge: δ σO (mkOld oldVars[i].name) = some oldVals[i]. - -- For v ∈ oldVars, v is in CallArg.getLhs args (filter). - have HoldVars_sub_callLhs : ∀ v ∈ oldVars, v ∈ CallArg.getLhs args := by - intro v Hv - exact (List.mem_filter.mp Hv).1 - -- For v ∈ oldVars, v is in proc'.header.outputs.keys (filter). - -- Bridge proc' = proc via HprocEq. - have HoldVars_sub_outs : ∀ v ∈ oldVars, - v ∈ ListMap.keys proc.header.outputs := by - intro v Hv - have Hv_filt := List.mem_filter.mp Hv - have Hbool := Hv_filt.2 - -- Project the outputs.contains conjunct. - simp only [Bool.and_eq_true] at Hbool - have HinOuts' : (ListMap.keys proc'.header.outputs).contains v := by - exact Hbool.1.2 - rw [HprocEq] at HinOuts' - exact List.contains_iff_mem.mp HinOuts' -- Per-index positional bridge for downstream consumers. have HoldEval_bridge : ∀ (i : Nat) (Hi : i < oldVars.length), δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld (oldVars[i]'Hi).name) none) = - some (oldVals[i]'(HoldValsLen.symm ▸ Hi)) := by - intro i Hi - let v : Expression.Ident := oldVars[i]'Hi - have Hv_mem : v ∈ oldVars := List.getElem_mem _ - have Hv_out : v ∈ ListMap.keys proc.header.outputs := - HoldVars_sub_outs v Hv_mem - have Hv_lhs : v ∈ lhs := HoldVars_sub_lhs v Hv_mem - have Hv_callLhs : v ∈ CallArg.getLhs args := - HoldVars_sub_callLhs v Hv_mem - -- ReadValues σ' ks vs ∧ v ∈ ks ⇒ σ' v = some vs[ks.idxOf v]. - have read_at : ∀ {σ' : Expression.Ident → Option _} - {ks : List Expression.Ident} {vs : List _} - (_ : ReadValues σ' ks vs) (Hmem : v ∈ ks) - (Hidx_lt : ks.idxOf v < vs.length), - σ' v = some (vs[ks.idxOf v]'Hidx_lt) := by - intro σ' ks vs Hrv Hmem Hidx_lt - have Hg := readValues_get (σ:=σ') (ks:=ks) (vs:=vs) Hrv - (i:=ks.idxOf v) - (hi:=List.idxOf_lt_length_of_mem Hmem) (hi':=Hidx_lt) - have Hk : ks[ks.idxOf v]'(List.idxOf_lt_length_of_mem Hmem) = v := by - unfold List.idxOf - simpa using @List.findIdx_getElem _ (· == v) ks - (List.idxOf_lt_length_of_mem Hmem) - rwa [Hk] at Hg - -- Step 1: δ σO (mkOld v.name) = σAO v. - have HStep1 : - δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) - none) = - σAO v := - Hwf2_univ v Hv_out - -- Step 2: σAO v = oVals[outputs.keys.idxOf v] via HσAO_reads_outs. - let j_out := (ListMap.keys proc.header.outputs).idxOf v - have Hj_out_lt_oVals : j_out < oVals.length := by - rw [← InitStatesLength Hinitout] - exact List.idxOf_lt_length_of_mem Hv_out - have HStep2 : σAO v = some (oVals[j_out]'Hj_out_lt_oVals) := - read_at HσAO_reads_outs Hv_out Hj_out_lt_oVals - -- Step 3: lhs.idxOf v = outputs.keys.idxOf v (alignment). - have HAlign_lhs : lhs.idxOf v = j_out := by - show lhs.idxOf v = (ListMap.keys proc.header.outputs).idxOf v - rw [← HoutAlign v Hv_out Hv_callLhs, hCallArgsLhs] - -- Step 4: σ v = oVals[lhs.idxOf v]'_. - let j_lhs := lhs.idxOf v - have Hj_lhs_lt_oVals : j_lhs < oVals.length := by - rw [← ReadValuesLength Hevalouts] - exact List.idxOf_lt_length_of_mem Hv_lhs - have HStep4 : σ v = some (oVals[j_lhs]'Hj_lhs_lt_oVals) := - read_at Hevalouts Hv_lhs Hj_lhs_lt_oVals - -- Step 5: σ v = some oldVals[i]'_ (HoldVals positional). - have Hi_oldVals : i < oldVals.length := HoldValsLen.symm ▸ Hi - have HStep5 : σ v = some (oldVals[i]'Hi_oldVals) := - readValues_get (σ:=σ) (ks:=oldVars) (vs:=oldVals) HoldVals - (i:=i) (hi:=Hi) (hi':=Hi_oldVals) - -- Combine: δ σO (mkOld v.name) = some oldVals[i]. - show δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) none) - = some (oldVals[i]'Hi_oldVals) - rw [HStep1, HStep2] - have Hj_eq : oVals[j_out]'Hj_out_lt_oVals = - oVals[j_lhs]'Hj_lhs_lt_oVals := by - congr 1; exact HAlign_lhs.symm - rw [Hj_eq, ← HStep4, HStep5] + some (oldVals[i]'(HoldValsLen.symm ▸ Hi)) := + HoldEval_bridge_at_σO Hwf2_univ Hinitout HσAO_reads_outs + Hevalouts hCallArgsLhs HoutAlign HoldVars_sub_outs + HoldVars_sub_lhs HoldVars_sub_callLhs HoldVals HoldValsLen -- D2d: Structural pieces of HpostPayload (per-entry). let oldTripsCanonical_L6 : List ((Expression.Ident × Expression.Ty) × @@ -3078,197 +5454,20 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (Core.Transform.createOldVarsSubst oldTripsCanonical_L6) k = some w → δ σ_R1 w = - δ σO (Lambda.LExpr.fvar () k none) := by - intro k w Hf - -- Positional decomposition via createOldVarsSubst_pos_decomp. - obtain ⟨ni_val, Hni_lt, Hk_eqMkOld, Hw_eq⟩ := - createOldVarsSubst_pos_decomp HgenOldLen HoldTysLen Hf - have Hni_lt_genOld : ni_val < genOldIdents.length := HgenOldLen.symm ▸ Hni_lt - -- LHS: δ σ_R1 w = σ_R1 genOldIdents[i] = some oldVals[i]. - have Hni_lt_oldVals : ni_val < oldVals.length := HoldValsLen.symm ▸ Hni_lt - have HrdR1_get : - σ_R1 (genOldIdents[ni_val]'Hni_lt_genOld) = - some (oldVals[ni_val]'Hni_lt_oldVals) := - σ_R1_read_olds ni_val Hni_lt_genOld Hni_lt_oldVals - -- δ σ_R1 (createFvar gen) = σ_R1 gen. - have HwfL : - δ σ_R1 (Core.Transform.createFvar - (genOldIdents[ni_val]'Hni_lt_genOld)) = - σ_R1 (genOldIdents[ni_val]'Hni_lt_genOld) := by - show δ σ_R1 (Lambda.LExpr.fvar () _ none) = _ - exact δ_fvar_eq σ_R1 _ - -- RHS via HoldEval_bridge. - have HoldEv : - δ σO (Lambda.LExpr.fvar () - (CoreIdent.mkOld - (oldVars[ni_val]'Hni_lt).name) - none) = - some (oldVals[ni_val]'Hni_lt_oldVals) := - HoldEval_bridge ni_val Hni_lt - -- Conclude. - rw [Hw_eq, HwfL, HrdR1_get, Hk_eqMkOld, HoldEv] + δ σO (Lambda.LExpr.fvar () k none) := + HoldSubBridge_at_σO Hwfvars HgenOldLen HoldTysLen + HoldValsLen σ_R1_read_olds HoldEval_bridge -- (2b) HinputSubBridge: inputOnlyOldSubst codomain. have HinputSubBridge : ∀ k w, Map.find? inputOnlyOldSubst_L6 k = some w → δ σ_R1 w = - δ σO (Lambda.LExpr.fvar () k none) := by - intro k w Hf - -- Positional decomposition via the shared helper. - obtain ⟨ni_val, Hni_lt_inKeys, Hni_lt_inArgs, - Hk_eq_proc', Hw_eq_proc', Hin_notin_outs_proc'⟩ := - inputOnlyOldSubst_pos_decomp Hf - -- Bridge proc' = proc. - have Hni_lt_inKeys' : - ni_val < proc.header.inputs.keys.length := by - have HEqLen : proc'.header.inputs.keys.length = - proc.header.inputs.keys.length := by rw [HprocEq] - omega - have HpinKeys : - proc'.header.inputs.keys[ni_val]'Hni_lt_inKeys = - proc.header.inputs.keys[ni_val]'Hni_lt_inKeys' := by - subst HprocEq; rfl - -- Let `inputId := inputs.keys[ni_val]`. - let inputId : Expression.Ident := - proc.header.inputs.keys[ni_val]'Hni_lt_inKeys' - have HinputId_in : inputId ∈ proc.header.inputs.keys := - List.getElem_mem _ - have HinputId_notin_outs : - inputId ∉ proc.header.outputs.keys := - fun h => Hiodisj HinputId_in h - -- argExpr := the snd projection. - let argExpr : Expression.Expr := - (CallArg.getInputExprs args)[ni_val]'Hni_lt_inArgs - have HargExpr_in : argExpr ∈ CallArg.getInputExprs args := - List.getElem_mem _ - -- k = mkOld inputId.name. - have Hk_mkOld : k = CoreIdent.mkOld inputId.name := by - rw [Hk_eq_proc', HpinKeys] - -- w = argExpr. - have Hw_argExpr : w = argExpr := Hw_eq_proc' - -- Fin-packaging so existing `ni : Fin …` users still apply. - let ni : Fin (CallArg.getInputExprs args).length := - ⟨ni_val, Hni_lt_inArgs⟩ - have Hni_lt_inArgsCall : ni.val < inArgs.length := by - have : (CallArg.getInputExprs args).length = - inArgs.length := by rw [hCallArgsIn] - rw [← this] - exact Hni_lt_inArgs - have HargExpr_eq_inArgs : - argExpr = inArgs[ni.val]'Hni_lt_inArgsCall := by - show (CallArg.getInputExprs args)[ni.val]'Hni_lt_inArgs = - inArgs[ni.val]'Hni_lt_inArgsCall - congr 1 <;> exact hCallArgsIn - -- argVals length facts. - have HinKeys_argVals_len : - proc.header.inputs.keys.length = argVals.length := - InitStatesLength Hinitin - have Hni_lt_argVals : ni.val < argVals.length := by - rw [← HinKeys_argVals_len] - exact Hni_lt_inKeys' - -- ── RHS chain (StepA→StepD fused): δ σO (mkOld inputId.name) - -- = some argVals[ni.val] via Hwf2 → σO_eq_σAO_off_outs → - -- initStates_get_notin → readValues_get. ── - have HRHS_oldEqArgVal : - δ σO (Lambda.LExpr.fvar () - (CoreIdent.mkOld inputId.name) none) = - some (argVals[ni.val]'Hni_lt_argVals) := by - simp only [WellFormedCoreEvalTwoState] at Hwf2 - rw [(Hwf2.2 proc.header.outputs.keys [] σAO σO σO - ⟨Hhav1, HInitVars_empty⟩ inputId).2 HinputId_notin_outs, - σO_eq_σAO_off_outs HinputId_notin_outs, - initStates_get_notin Hinitout HinputId_notin_outs] - exact readValues_get (InitStatesReadValues Hinitin) - (i:=ni.val) (hi:=Hni_lt_inKeys') (hi':=Hni_lt_argVals) - -- ── RHS Step E: argVals[ni.val] = δ σ argExpr - -- via evalExpressions_get + hCallArgsIn. ── - have HRHS_StepE : - δ σ argExpr = - some (argVals[ni.val]'Hni_lt_argVals) := by - have Hev := evalExpressions_get Hevalargs - Hni_lt_inArgsCall Hni_lt_argVals - -- Bridge δ σ argExpr = δ σ inArgs[ni.val]. - have HargList : - List.get inArgs ⟨ni.val, Hni_lt_inArgsCall⟩ = - inArgs[ni.val]'Hni_lt_inArgsCall := rfl - have HvalList : - List.get argVals ⟨ni.val, Hni_lt_argVals⟩ = - argVals[ni.val]'Hni_lt_argVals := rfl - rw [HargList, HvalList] at Hev - rw [HargExpr_eq_inArgs] - exact Hev - -- LHS Step F: δ σ_R1 argExpr = δ σ argExpr. - -- For v ∈ getVars argExpr, σ v is some (definedness lift). - have HargExpr_in_argList : - argExpr ∈ inArgs := by - rw [HargExpr_eq_inArgs] - exact List.getElem_mem _ - have HargExpr_in_callList : - argExpr ∈ CallArg.getInputExprs args := HargExpr_in - -- σ_R1 ↔ σ pointwise on argExpr's free vars. - have Hσ_R1_eq_σ_argVars : - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) - argExpr, - σ_R1 v = σ v := by - intro v Hv - have Hσv_some : (σ v).isSome := HargIsDef v <| - List.mem_flatMap.mpr ⟨argExpr, HargExpr_in_argList, Hv⟩ - have HvNotGen : v ∉ genOldIdents := - notMem_of_Forall_neg HoldIdentsTemp fun Hold => - σ_some_contradiction Hσv_some - (Option.isNone_iff_eq_none.mp (Hgenrel.oldFresh v Hold)) - show updatedStates σO genOldIdents oldVals v = σ v - exact σR1_eq_σ_for_notTouched Hinitin Hinitout Hhav1 - (HargVarsNotInInKeys argExpr HargExpr_in_callList v Hv) - (HargVarsNotInOutKeys argExpr HargExpr_in_callList v Hv) - HvNotGen - -- Lift to δ-eval via Hwfvars (fvarcongr-like). - have Hδ_R1_eq_δ_σ : - δ σ_R1 argExpr = δ σ argExpr := by - -- Apply subst_fvars_eval_bridge with empty subst map. - have Hsurv : - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) - argExpr, - Map.find? (∅ : Map Expression.Ident - Expression.Expr) v = none → - δ σ_R1 (Lambda.LExpr.fvar () v none) = - δ σ (Lambda.LExpr.fvar () v none) := by - intro v Hv _ - rw [δ_fvar_eq σ_R1 v, δ_fvar_eq σ v] - exact Hσ_R1_eq_σ_argVars v Hv - have Hsub : - ∀ k' w', k' ∈ Imperative.HasVarsPure.getVars - (P:=Expression) argExpr → - Map.find? (∅ : Map Expression.Ident - Expression.Expr) k' = some w' → - δ σ_R1 w' = - δ σ (Lambda.LExpr.fvar () k' none) := by - intro k' w' _ Hf - simp [Map.find?] at Hf - have Hbridge : - δ σ_R1 (Lambda.LExpr.substFvars argExpr - (∅ : Map Expression.Ident - Expression.Expr)) = - δ σ argExpr := - subst_fvars_eval_bridge Hwfc Hwfvars Hwfval - (sm:=∅) - Hsurv Hsub - -- substFvars argExpr ∅ = argExpr. - have HsubstEmpty : - Lambda.LExpr.substFvars argExpr - (∅ : Map Expression.Ident Expression.Expr) = - argExpr := by - induction argExpr with - | fvar m name ty => - rw [Lambda.LExpr.substFvars_fvar_none m name ty]; rfl - | _ => simp [Lambda.LExpr.substFvars_abs, - Lambda.LExpr.substFvars_quant, - Lambda.LExpr.substFvars_app, - Lambda.LExpr.substFvars_eq, - Lambda.LExpr.substFvars_ite, *] - rwa [HsubstEmpty] at Hbridge - rw [Hw_argExpr, Hδ_R1_eq_δ_σ, HRHS_StepE, - ← HRHS_oldEqArgVal, ← Hk_mkOld] + δ σO (Lambda.LExpr.fvar () k none) := + HinputSubBridge_at_σO Hwfvars Hwfval Hwfc Hwf2 + HprocEq Hiodisj Hinitin Hinitout Hhav1 + HInitVars_empty Hevalargs hCallArgsIn HargIsDef + HoldIdentsTemp Hgenrel HargVarsNotInInKeys + HargVarsNotInOutKeys rfl -- HpostEval_bridge: per-entry σ_R1 eval bridge via -- subst_fvars_eval_bridge + HpostFiltered_corresp. have HpostEval_bridge : @@ -3296,8 +5495,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] oldTripsCanonical_L6) k with | some v => have Hvw : v = w := find?_append_some_eq hfind Hf - rw [← Hvw] - exact HoldSubBridge k v hfind + exact Hvw.symm ▸ HoldSubBridge k v hfind | none => exact HinputSubBridge k w (find?_append_none_elim hfind Hf) -- Build HsurvBridge specialized to c. @@ -3371,92 +5569,20 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] rw [HzipAppend2, updatedStates'App] have HrdHavoc : ReadValues σ_havoc genOldIdents oldVals := by - rw [HsplitOverlay] - exact readValues_updatedStatesSame HgenOldOldValsLen HoldNd + exact HsplitOverlay ▸ readValues_updatedStatesSame HgenOldOldValsLen HoldNd intro i Hi Hi' exact readValues_get HrdHavoc (i:=i) (hi:=Hi) (hi':=Hi') -- Shared class-(b) decompositions for Hinv/Hpred_disj -- via oldSubst_L6 = createOldVarsSubst ++ inputOnlyOldSubst. - have b1_var_witness : - ∀ {var : Expression.Ident} - {k : Expression.Ident} {w w' : Expression.Expr} - (_hfind : Map.find? - (Core.Transform.createOldVarsSubst - oldTripsCanonical_L6) k = some w') - (_Hf : Map.find? oldSubst_L6 k = some w) - (_Hv_in : var ∈ Imperative.HasVarsPure.getVars - (P:=Expression) w), - ∃ (ni : Nat) (Hni : ni < genOldIdents.length), - w = Core.Transform.createFvar - (genOldIdents[ni]'Hni) ∧ - var = genOldIdents[ni]'Hni := by - intro var k w w' hfind Hf Hv_in - have Hw'w : w' = w := find?_append_some_eq hfind Hf - obtain ⟨ni_val, Hni_lt, _Hk_eqMkOld, Hw'_eq⟩ := - createOldVarsSubst_pos_decomp HgenOldLen HoldTysLen hfind - have Hni_lt_genOld : ni_val < genOldIdents.length := HgenOldLen.symm ▸ Hni_lt - have Hw_eq : w = - Core.Transform.createFvar - (genOldIdents[ni_val]'Hni_lt_genOld) := by - rw [← Hw'w]; exact Hw'_eq - refine ⟨ni_val, Hni_lt_genOld, Hw_eq, ?_⟩ - rw [Hw_eq] at Hv_in - have Hv_in' : - var ∈ Imperative.HasVarsPure.getVars (P:=Expression) - (Core.Transform.createFvar - (genOldIdents[ni_val]'Hni_lt_genOld)) := Hv_in - show var = _ - simp [Core.Transform.createFvar, - Imperative.HasVarsPure.getVars, - Lambda.LExpr.LExpr.getVars] at Hv_in' - exact Hv_in' + have b1_var_witness := + @b1_var_witness_at_oldSubst oldVars genOldIdents oldTys + proc' args HgenOldLen HoldTysLen -- (b2): miss on createOldVarsSubst, hit on inputOnlyOldSubst. -- Yields `w = inArgs[ni2]`, `w ∈ inArgs`, the input-key -- positional fact, and `var ∈ flatMap getVars inArgs`. - have b2_var_witness : - ∀ {var : Expression.Ident} - {k : Expression.Ident} {w : Expression.Expr} - (_hfind_none : Map.find? - (Core.Transform.createOldVarsSubst - oldTripsCanonical_L6) k = none) - (_Hf : Map.find? oldSubst_L6 k = some w) - (_Hv_in : var ∈ Imperative.HasVarsPure.getVars - (P:=Expression) w), - w ∈ CallArg.getInputExprs args ∧ - var ∈ List.flatMap - (Imperative.HasVarsPure.getVars (P:=Expression)) - inArgs := by - intro var k w hfind_none Hf Hv_in - obtain ⟨ni2_val, _Hni2_lt_inKeys, Hni2_lt_inArgs, - _Hk_eq_proc', Hw_eq_proc', _Hin_notin_outs⟩ := - inputOnlyOldSubst_pos_decomp - (find?_append_none_elim hfind_none Hf) - have HargExpr_def : - w = (CallArg.getInputExprs args)[ni2_val]'Hni2_lt_inArgs := - Hw_eq_proc' - have Hni2_lt_inArgsCall : - ni2_val < inArgs.length := by - have : (CallArg.getInputExprs args).length = - inArgs.length := by rw [hCallArgsIn] - rw [← this] - exact Hni2_lt_inArgs - have HargExpr_eq_inArgs : - w = inArgs[ni2_val]'Hni2_lt_inArgsCall := by - rw [HargExpr_def] - show (CallArg.getInputExprs args)[ni2_val]'Hni2_lt_inArgs = - inArgs[ni2_val]'Hni2_lt_inArgsCall - congr 1 <;> exact hCallArgsIn - have Hk1_in_inArgs : w ∈ inArgs := by - rw [HargExpr_eq_inArgs]; exact List.getElem_mem _ - have HargExpr_in : w ∈ CallArg.getInputExprs args := by - rw [HargExpr_def]; exact List.getElem_mem _ - have Hk1_flat : - var ∈ List.flatMap - (Imperative.HasVarsPure.getVars (P:=Expression)) - inArgs := by - rw [List.mem_flatMap] - exact ⟨w, Hk1_in_inArgs, Hv_in⟩ - exact ⟨HargExpr_in, Hk1_flat⟩ + have b2_var_witness := + @b2_var_witness_at_oldSubst oldVars genOldIdents oldTys + proc' args inArgs hCallArgsIn have Hinv : ∀ entry : CoreLabel × Procedure.Check, entry ∈ posts_filtered_L6.toList → @@ -3470,22 +5596,9 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] -- Open invStores. simp only [Imperative.invStores, Imperative.substStores] intros k1 k2 Hkin - obtain rfl := zip_self_eq Hkin - have Hk1_in : k1 ∈ - (Imperative.HasVarsPure.getVars (P:=Expression) - entry.snd.expr).removeAll - (filtered_ks ++ filtered_ks') := - (List.of_mem_zip Hkin).1 - -- Decompose removeAll. - simp only [List.removeAll, List.mem_filter, - List.elem_eq_mem, Bool.not_eq_true', - decide_eq_false_iff_not] at Hk1_in - obtain ⟨Hk1_pre, Hk1_notin_combined⟩ := Hk1_in - -- Decompose `k1 ∉ (outputs ++ filtered_inputs) ++ - -- (lhs ++ filtered_argTemps)` into 4 leaf facts. - obtain ⟨Hk1_notin_outs, Hk1_notin_filtIn, + obtain ⟨rfl, Hk1_pre, Hk1_notin_outs, Hk1_notin_filtIn, Hk1_notin_lhs, Hk1_notin_filtArgT⟩ := - List.notin_append4 Hk1_notin_combined + zip_removeAll4_decompose Hkin -- entry.snd.expr = substFvars c.expr oldSubst_L6. rw [Hentry_eq] at Hk1_pre -- Decompose k1 ∈ getVars (substFvars c.expr oldSubst_L6). @@ -3518,8 +5631,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] have Hpair_in_zip : (k1, argTemps[n.val]'Hn_lt_argT) ∈ proc.header.inputs.keys.zip argTemps := by - rw [← HkE] - exact pair_in_zip_of_pos Hn_lt_in Hn_lt_argT + exact HkE.symm ▸ pair_in_zip_of_pos Hn_lt_in Hn_lt_argT have Hpair_in_filtAS : (k1, argTemps[n.val]'Hn_lt_argT) ∈ filtered_argSubst := by @@ -3778,8 +5890,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] assumes ⟨σ_havoc, δ, false⟩ := by -- HassumeShape proc'-keys agree with proc via HprocEq. rw [HassumeShape] - rw [HassumeSubst_eq] - exact HL6_pre + exact HassumeSubst_eq ▸ HL6_pre -- ── D2g: Chain L1-L6 via EvalCallElim_glue ── exact EvalCallElim_glue HL1 HL2 HL3 HL4 HL5 HL6 · -- inner `Except.error` branch — contradiction @@ -3876,14 +5987,17 @@ theorem callElimStatementCorrect [LawfulBEq Expression.Expr] (Hgenrel : CoreGenStateRel σ γ) (Hwfcallsite : WFCallSiteProp p π st) (Helim : (Except.ok sts, γ') = (runWith st (callElimStmt · p) γ)) : - -- Terminal arm - (∀ {σ' : CoreStore}, + -- Terminal arm: polymorphic over the source-side failure flag `f`. + -- The transformed statements admit a derivation at the same flag, + -- so source-fail traces map to target-fail traces and source-success + -- traces map to target-success traces. + (∀ {σ' : CoreStore} {f : Bool}, Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) - (.stmts [st] ⟨σ, δ, false⟩) (.terminal ⟨σ', δ, false⟩) → + (.stmts [st] ⟨σ, δ, false⟩) (.terminal ⟨σ', δ, f⟩) → ∃ σ'', Inits σ' σ'' ∧ Imperative.StepStmtStar Expression (EvalCommandContract π) (EvalPureFunc φ) - (.stmts sts ⟨σ, δ, false⟩) (.terminal ⟨σ'', δ, false⟩)) + (.stmts sts ⟨σ, δ, false⟩) (.terminal ⟨σ'', δ, f⟩)) ∧ -- Exit arm (∀ {lbl : String} {σ' : CoreStore}, diff --git a/Strata/Transform/CoreTransformProps.lean b/Strata/Transform/CoreTransformProps.lean index 3941b16cbf..5b7cfabc00 100644 --- a/Strata/Transform/CoreTransformProps.lean +++ b/Strata/Transform/CoreTransformProps.lean @@ -30,26 +30,74 @@ namespace Core open Imperative -/-- A single contract-evaluating command produces a single-statement - `EvalStatementsContract` derivation. Reusable scaffold for the - block helpers below. -/ -theorem singleCmdToStmts +/-! ### Polymorphic-flag block helpers + +The polymorphic-`f` lemmas below lift command derivations whose local +failure flag is `false` (i.e., `Hcmd` produces `σ' false`) into a step +starting from any input flag `f` and ending at `f`. This is sound +because the small-step `step_cmd` rule OR-s the per-command flag into +the cumulative flag, and `f || false = f`. + +These polymorphic variants are needed at the L4 (asserts) flag-flip in +`EvalCallElim_glue_fail`, where pre-L4 segments stay at `f = false`, +the failing precondition flips `f` to `true`, and post-failure segments +must continue propagating `f = true`. The flag-`false` corollaries +beneath each `_poly` lemma are one-line specializations for callers +that don't need a polymorphic flag. -/ + +/-- Polymorphic-`f` variant: lift any flag-`false` command derivation + into an `EvalStatementsContract` step that preserves the input + failure flag `f`. Reusable scaffold for the block helpers below. -/ +theorem singleCmdToStmts_poly {π : String → Option Procedure} {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ σ' : CoreStore} {c : Core.Command} + {δ : CoreEval} {σ σ' : CoreStore} {c : Core.Command} {f : Bool} (Hcmd : Core.EvalCommandContract π δ σ c σ' false) : - EvalStatementsContract π φ ⟨σ, δ, false⟩ + EvalStatementsContract π φ ⟨σ, δ, f⟩ [Imperative.Stmt.cmd c] - ⟨σ', δ, false⟩ := by + ⟨σ', δ, f⟩ := by unfold EvalStatementsContract Imperative.EvalStmtsSmall apply ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_cons + -- step_cmd produces hasFailure := f || false = f. + have Hstep_cmd : + Imperative.StepStmt Expression (EvalCommandContract π) (EvalPureFunc φ) + (.stmt (Imperative.Stmt.cmd c) ⟨σ, δ, f⟩) + (.terminal ⟨σ', δ, f⟩) := by + have := Imperative.StepStmt.step_cmd (P := Expression) + (EvalCmd := EvalCommandContract π) (extendEval := EvalPureFunc φ) + (ρ := ⟨σ, δ, f⟩) (c := c) (σ' := σ') (hasAssertFailure := false) + Hcmd + simpa using this apply ReflTrans.step _ _ _ - (Imperative.StepStmt.step_seq_inner (Imperative.StepStmt.step_cmd Hcmd)) + (Imperative.StepStmt.step_seq_inner Hstep_cmd) apply ReflTrans.step _ _ _ Imperative.StepStmt.step_seq_done exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) -/-- Singleton-eval helper for `Statement.assert`: lifts the assert evaluation - rule into a single-statement `EvalStatementsContract`. -/ +/-- Flag-`false` corollary of `singleCmdToStmts_poly`. -/ +theorem singleCmdToStmts + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ σ' : CoreStore} {c : Core.Command} + (Hcmd : Core.EvalCommandContract π δ σ c σ' false) : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + [Imperative.Stmt.cmd c] + ⟨σ', δ, false⟩ := + singleCmdToStmts_poly (π := π) (φ := φ) (f := false) Hcmd + +/-- Polymorphic-`f` variant of `singletonAssertEval`: lifts assert-pass + into a flag-`f`-preserving step. -/ +theorem singletonAssertEval_poly + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ : CoreStore} {f : Bool} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression) + (Hev : δ σ e = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ, δ, f⟩ [Statement.assert lbl e m] ⟨σ, δ, f⟩ := + singleCmdToStmts_poly (π := π) (φ := φ) (f := f) + (Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_assert_pass Hev Hwfb)) + +/-- Flag-`false` corollary of `singletonAssertEval_poly`. -/ theorem singletonAssertEval {π : String → Option Procedure} {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} @@ -58,10 +106,21 @@ theorem singletonAssertEval (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression) (Hev : δ σ e = some Imperative.HasBool.tt) : EvalStatementsContract π φ ⟨σ, δ, false⟩ [Statement.assert lbl e m] ⟨σ, δ, false⟩ := - singleCmdToStmts (π := π) (φ := φ) - (Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_assert_pass Hev Hwfb)) + singletonAssertEval_poly (π := π) (φ := φ) (f := false) Hwfb lbl e m Hev + +/-- Polymorphic-`f` variant of `singletonAssumeEval`. -/ +theorem singletonAssumeEval_poly + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ : CoreStore} {f : Bool} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression) + (Hev : δ σ e = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ, δ, f⟩ [Statement.assume lbl e m] ⟨σ, δ, f⟩ := + singleCmdToStmts_poly (π := π) (φ := φ) (f := f) + (Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_assume Hev Hwfb)) -/-- Singleton-eval helper for `Statement.assume`. -/ +/-- Flag-`false` corollary of `singletonAssumeEval_poly`. -/ theorem singletonAssumeEval {π : String → Option Procedure} {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} @@ -70,23 +129,24 @@ theorem singletonAssumeEval (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression) (Hev : δ σ e = some Imperative.HasBool.tt) : EvalStatementsContract π φ ⟨σ, δ, false⟩ [Statement.assume lbl e m] ⟨σ, δ, false⟩ := - singleCmdToStmts (π := π) (φ := φ) - (Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_assume Hev Hwfb)) + singletonAssumeEval_poly (π := π) (φ := φ) (f := false) Hwfb lbl e m Hev -/-- Evaluating `createHavocs vs md` under contract semantics steps from σ - through `HavocVars vs` to σ'. -/ -theorem H_havocs +/-- Polymorphic-`f` variant: havoc commands locally produce `flag=false`, + and OR-ing into the running `f` keeps it as `f`. Evaluating + `createHavocs vs md` under contract semantics steps from σ through + `HavocVars vs` to σ'. -/ +theorem H_havocs_poly {π : String → Option Procedure} {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ σ' : CoreStore} + {δ : CoreEval} {σ σ' : CoreStore} {f : Bool} {vs : List Expression.Ident} {md : Imperative.MetaData Expression} (Hwfv : Imperative.WellFormedSemanticEvalVar δ) (Hdef : Imperative.isDefined σ vs) (Hhav : HavocVars σ vs σ') : - EvalStatementsContract π φ ⟨σ, δ, false⟩ + EvalStatementsContract π φ ⟨σ, δ, f⟩ (Core.Transform.createHavocs vs md) - ⟨σ', δ, false⟩ := by + ⟨σ', δ, f⟩ := by induction vs generalizing σ with | nil => have heq : σ' = σ := by cases Hhav; rfl @@ -107,7 +167,23 @@ theorem H_havocs have HrecTail := ih HdefTail hTail simp only [Core.Transform.createHavocs, List.map_cons, Core.Transform.createHavoc] - exact EvalStatementsContractApp (singleCmdToStmts Hcmd) HrecTail + exact EvalStatementsContractApp + (singleCmdToStmts_poly (f := f) Hcmd) HrecTail + +/-- Flag-`false` corollary of `H_havocs_poly`. -/ +theorem H_havocs + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ σ' : CoreStore} + {vs : List Expression.Ident} + {md : Imperative.MetaData Expression} + (Hwfv : Imperative.WellFormedSemanticEvalVar δ) + (Hdef : Imperative.isDefined σ vs) + (Hhav : HavocVars σ vs σ') : + EvalStatementsContract π φ ⟨σ, δ, false⟩ + (Core.Transform.createHavocs vs md) + ⟨σ', δ, false⟩ := + H_havocs_poly (π := π) (φ := φ) (f := false) Hwfv Hdef Hhav /-- Evaluating a single `Statement.init x ty (.det e) md` under contract semantics steps from σ to `updatedState σ x v`, given `δ σ e = some v` diff --git a/Strata/Transform/SubstProps.lean b/Strata/Transform/SubstProps.lean index 17a8ccf3c5..c5a0435905 100644 --- a/Strata/Transform/SubstProps.lean +++ b/Strata/Transform/SubstProps.lean @@ -837,16 +837,9 @@ theorem subst_fvars_eval_bridge δ σ' w = δ σ (Lambda.LExpr.fvar () k none)) : δ σ' (Lambda.LExpr.substFvars e sm) = δ σ e := by induction e with - | const m c => - simp only [Lambda.LExpr.substFvars_const'] - rw [Hwfvl.2, Hwfvl.2] - constructor; constructor - | op m n t => - simp only [Lambda.LExpr.substFvars_op'] - rw [Hwfvl.2, Hwfvl.2] - constructor; constructor - | bvar m i => - simp only [Lambda.LExpr.substFvars_bvar] + | const | op | bvar => + simp only [Lambda.LExpr.substFvars_const', Lambda.LExpr.substFvars_op', + Lambda.LExpr.substFvars_bvar] rw [Hwfvl.2, Hwfvl.2] constructor; constructor | fvar m name ty => @@ -893,114 +886,57 @@ theorem subst_fvars_eval_bridge exact HsubAt | abs m name ty body ih => simp only [Lambda.LExpr.substFvars_abs] - have Hsurv_body : - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) body, - Map.find? sm v = none → - δ σ' (Lambda.LExpr.fvar () v none) = - δ σ (Lambda.LExpr.fvar () v none) := by - intro v Hv Hnone - apply Hsurv v ?_ Hnone - show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.abs m name ty body) - simp [Lambda.LExpr.LExpr.getVars] - show v ∈ Lambda.LExpr.LExpr.getVars body - exact Hv - have Hsub_body : - ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) body → - Map.find? sm k = some w → - δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by - intro k w Hk Hf - apply Hsub k w ?_ Hf - show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.abs m name ty body) - simp [Lambda.LExpr.LExpr.getVars] - show k ∈ Lambda.LExpr.LExpr.getVars body - exact Hk - have Hbody := ih Hsurv_body Hsub_body + have Hmk : ∀ {x : Expression.Ident}, + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) body → + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.abs m name ty body) := by + intro x Hx + show x ∈ Lambda.LExpr.LExpr.getVars body + exact Hx + have Hbody := ih (fun v Hv Hnone => Hsurv v (Hmk Hv) Hnone) + (fun k w Hk Hf => Hsub k w (Hmk Hk) Hf) exact Hwfc.abscongr σ' σ _ _ Hbody m name ty | quant m qk name ty tr body trih bih => simp only [Lambda.LExpr.substFvars_quant] - have Hsurv_tr : - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) tr, - Map.find? sm v = none → - δ σ' (Lambda.LExpr.fvar () v none) = - δ σ (Lambda.LExpr.fvar () v none) := by - intro v Hv Hnone - apply Hsurv v ?_ Hnone - show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.quant m qk name ty tr body) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inl Hv - have Hsurv_body : - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) body, - Map.find? sm v = none → - δ σ' (Lambda.LExpr.fvar () v none) = - δ σ (Lambda.LExpr.fvar () v none) := by - intro v Hv Hnone - apply Hsurv v ?_ Hnone - show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.quant m qk name ty tr body) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inr Hv - have Hsub_tr : - ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) tr → - Map.find? sm k = some w → - δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by - intro k w Hk Hf - apply Hsub k w ?_ Hf - show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.quant m qk name ty tr body) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inl Hk - have Hsub_body : - ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) body → - Map.find? sm k = some w → - δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by - intro k w Hk Hf - apply Hsub k w ?_ Hf - show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.quant m qk name ty tr body) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inr Hk - have Htr := trih Hsurv_tr Hsub_tr - have Hbody := bih Hsurv_body Hsub_body + have HmkL : ∀ {x : Expression.Ident}, + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) tr → + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.quant m qk name ty tr body) := by + intro x Hx + show x ∈ Lambda.LExpr.LExpr.getVars tr ++ Lambda.LExpr.LExpr.getVars body + exact List.mem_append.mpr (Or.inl Hx) + have HmkR : ∀ {x : Expression.Ident}, + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) body → + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.quant m qk name ty tr body) := by + intro x Hx + show x ∈ Lambda.LExpr.LExpr.getVars tr ++ Lambda.LExpr.LExpr.getVars body + exact List.mem_append.mpr (Or.inr Hx) + have Htr := trih (fun v Hv Hnone => Hsurv v (HmkL Hv) Hnone) + (fun k w Hk Hf => Hsub k w (HmkL Hk) Hf) + have Hbody := bih (fun v Hv Hnone => Hsurv v (HmkR Hv) Hnone) + (fun k w Hk Hf => Hsub k w (HmkR Hk) Hf) exact Hwfc.quantcongr σ' σ m qk name ty _ _ _ _ Htr Hbody | app m fn arg fih aih => simp only [Lambda.LExpr.substFvars_app] - have Hsurv_fn : - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) fn, - Map.find? sm v = none → - δ σ' (Lambda.LExpr.fvar () v none) = - δ σ (Lambda.LExpr.fvar () v none) := by - intro v Hv Hnone - apply Hsurv v ?_ Hnone - show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.app m fn arg) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inl Hv - have Hsurv_arg : - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) arg, - Map.find? sm v = none → - δ σ' (Lambda.LExpr.fvar () v none) = - δ σ (Lambda.LExpr.fvar () v none) := by - intro v Hv Hnone - apply Hsurv v ?_ Hnone - show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.app m fn arg) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inr Hv - have Hsub_fn : - ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) fn → - Map.find? sm k = some w → - δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by - intro k w Hk Hf - apply Hsub k w ?_ Hf - show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.app m fn arg) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inl Hk - have Hsub_arg : - ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) arg → - Map.find? sm k = some w → - δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by - intro k w Hk Hf - apply Hsub k w ?_ Hf - show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.app m fn arg) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inr Hk - have Hfn := fih Hsurv_fn Hsub_fn - have Harg := aih Hsurv_arg Hsub_arg + have HmkL : ∀ {x : Expression.Ident}, + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) fn → + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.app m fn arg) := by + intro x Hx + show x ∈ Lambda.LExpr.LExpr.getVars fn ++ Lambda.LExpr.LExpr.getVars arg + exact List.mem_append.mpr (Or.inl Hx) + have HmkR : ∀ {x : Expression.Ident}, + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) arg → + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.app m fn arg) := by + intro x Hx + show x ∈ Lambda.LExpr.LExpr.getVars fn ++ Lambda.LExpr.LExpr.getVars arg + exact List.mem_append.mpr (Or.inr Hx) + have Hfn := fih (fun v Hv Hnone => Hsurv v (HmkL Hv) Hnone) + (fun k w Hk Hf => Hsub k w (HmkL Hk) Hf) + have Harg := aih (fun v Hv Hnone => Hsurv v (HmkR Hv) Hnone) + (fun k w Hk Hf => Hsub k w (HmkR Hk) Hf) exact Hwfc.appcongr σ' σ m _ _ _ _ Hfn Harg | ite m c t f cih tih fih => simp only [Lambda.LExpr.substFvars_ite] @@ -1037,57 +973,39 @@ theorem subst_fvars_eval_bridge exact Hwfc.itecongr σ' σ m _ _ _ _ _ _ Ht Hf' Hc | eq m e1 e2 e1ih e2ih => simp only [Lambda.LExpr.substFvars_eq] - have Hsurv_l : - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) e1, - Map.find? sm v = none → - δ σ' (Lambda.LExpr.fvar () v none) = - δ σ (Lambda.LExpr.fvar () v none) := by - intro v Hv Hnone - apply Hsurv v ?_ Hnone - show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.eq m e1 e2) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inl Hv - have Hsurv_r : - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) e2, - Map.find? sm v = none → - δ σ' (Lambda.LExpr.fvar () v none) = - δ σ (Lambda.LExpr.fvar () v none) := by - intro v Hv Hnone - apply Hsurv v ?_ Hnone - show v ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.eq m e1 e2) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inr Hv - have Hsub_l : - ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) e1 → - Map.find? sm k = some w → - δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by - intro k w Hk Hf - apply Hsub k w ?_ Hf - show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.eq m e1 e2) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inl Hk - have Hsub_r : - ∀ k w, k ∈ Imperative.HasVarsPure.getVars (P:=Expression) e2 → - Map.find? sm k = some w → - δ σ' w = δ σ (Lambda.LExpr.fvar () k none) := by - intro k w Hk Hf - apply Hsub k w ?_ Hf - show k ∈ Lambda.LExpr.LExpr.getVars (Lambda.LExpr.eq m e1 e2) - simp [Lambda.LExpr.LExpr.getVars, List.mem_append] - exact Or.inr Hk - have Hl := e1ih Hsurv_l Hsub_l - have Hr := e2ih Hsurv_r Hsub_r + have HmkL : ∀ {x : Expression.Ident}, + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) e1 → + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.eq m e1 e2) := by + intro x Hx + show x ∈ Lambda.LExpr.LExpr.getVars e1 ++ Lambda.LExpr.LExpr.getVars e2 + exact List.mem_append.mpr (Or.inl Hx) + have HmkR : ∀ {x : Expression.Ident}, + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) e2 → + x ∈ Imperative.HasVarsPure.getVars (P:=Expression) + (Lambda.LExpr.eq m e1 e2) := by + intro x Hx + show x ∈ Lambda.LExpr.LExpr.getVars e1 ++ Lambda.LExpr.LExpr.getVars e2 + exact List.mem_append.mpr (Or.inr Hx) + have Hl := e1ih (fun v Hv Hnone => Hsurv v (HmkL Hv) Hnone) + (fun k w Hk Hf => Hsub k w (HmkL Hk) Hf) + have Hr := e2ih (fun v Hv Hnone => Hsurv v (HmkR Hv) Hnone) + (fun k w Hk Hf => Hsub k w (HmkR Hk) Hf) exact Hwfc.eqcongr σ' σ m _ _ _ _ Hl Hr /-! ### Small-step block helpers for assert/assume sequences -/ /-- Generic block-evaluator helper for the labels-aware (`zip`) variant of - assert/assume statement lists. Used to derive both `H_asserts_zip` and - `H_assumes_zip`. -/ -theorem H_check_block_zip + assert/assume statement lists. Polymorphic-`f` form: lifts any + flag-`f` singleton callback through the `(entries.zip labels).map` + shape. Used by `H_assumes_zip_poly` to keep the L5/L6 + (havocs/assumes) segments at `f = true` after the L4 flag flip, + and by the `f := false` corollary `H_check_block_zip` (and + `H_asserts_zip` / `H_assumes_zip` through it). -/ +theorem H_check_block_zip_poly {π : String → Option Procedure} {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σA σ' : CoreStore} + {δ : CoreEval} {σA σ' : CoreStore} {f : Bool} {ks ks' : List Expression.Ident} {entries : List (CoreLabel × Procedure.Check)} {labels : List String} @@ -1096,7 +1014,7 @@ theorem H_check_block_zip (mkSingletonEval : ∀ (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression), δ σ' e = some Imperative.HasBool.tt → - EvalStatementsContract π φ ⟨σ', δ, false⟩ [mkStmt lbl e m] ⟨σ', δ, false⟩) + EvalStatementsContract π φ ⟨σ', δ, f⟩ [mkStmt lbl e m] ⟨σ', δ, f⟩) (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) (Hwfc : Core.WellFormedCoreEvalCong δ) @@ -1110,13 +1028,13 @@ theorem H_check_block_zip (ks ++ ks')) ∧ ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ δ σA entry.snd.expr = some Imperative.HasBool.tt) : - EvalStatementsContract π φ ⟨σ', δ, false⟩ + EvalStatementsContract π φ ⟨σ', δ, f⟩ ((entries.zip labels).map (fun (entry, lbl) => mkStmt lbl (Lambda.LExpr.substFvars entry.snd.expr (ks.zip (Core.Transform.createFvars ks'))) (entry.snd.md.setCallSiteFileRange md))) - ⟨σ', δ, false⟩ := by + ⟨σ', δ, f⟩ := by induction entries generalizing labels with | nil => simp [List.zip_nil_left, List.map_nil] @@ -1153,6 +1071,45 @@ theorem H_check_block_zip simp only [List.zip_cons_cons, List.map_cons] exact EvalStatementsContractApp HheadStmts Htail +/-- `f := false` specialization of `H_check_block_zip_poly`. Kept as a + corollary so existing call sites (`H_asserts_zip`) continue to work + after the polymorphic lift. -/ +theorem H_check_block_zip + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σA σ' : CoreStore} + {ks ks' : List Expression.Ident} + {entries : List (CoreLabel × Procedure.Check)} + {labels : List String} + {md : Imperative.MetaData Expression} + (mkStmt : String → Expression.Expr → Imperative.MetaData Expression → Statement) + (mkSingletonEval : + ∀ (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression), + δ σ' e = some Imperative.HasBool.tt → + EvalStatementsContract π φ ⟨σ', δ, false⟩ [mkStmt lbl e m] ⟨σ', δ, false⟩) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hlen : ks.length = ks'.length) + (Hnd : Imperative.substNodup (ks.zip ks')) + (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) + (Hsubst : Imperative.substStores σA σ' (ks.zip ks')) + (Hentries : ∀ entry, entry ∈ entries → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ', δ, false⟩ + ((entries.zip labels).map (fun (entry, lbl) => + mkStmt lbl + (Lambda.LExpr.substFvars entry.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (entry.snd.md.setCallSiteFileRange md))) + ⟨σ', δ, false⟩ := + H_check_block_zip_poly (f := false) mkStmt mkSingletonEval + Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hentries + /-- Labels-aware variant of `H_asserts`: takes a separate `labels` list (paired positionally with `pres` via `zip`) rather than a `labelOf` projection. This matches the shape exposed by the @@ -1195,11 +1152,46 @@ theorem H_asserts_zip (mkSingletonEval := singletonAssertEval Hwfb) Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst' Hpres +/-- Polymorphic-`f` variant of `H_assumes_zip`. Lets the L6 (assumes) + segment of the call-elim glue stay at `f = true` once the L4 flag + flip has fired. See `EvalCallElim_glue_fail`. -/ +theorem H_assumes_zip_poly + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σA σ' : CoreStore} {f : Bool} + {ks ks' : List Expression.Ident} + {posts : List (CoreLabel × Procedure.Check)} + {labels : List String} + {md : Imperative.MetaData Expression} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) + (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) + (Hwfc : Core.WellFormedCoreEvalCong δ) + (Hlen : ks.length = ks'.length) + (Hnd : Imperative.substNodup (ks.zip ks')) + (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) + (Hsubst : Imperative.substStores σA σ' (ks.zip ks')) + (Hposts : ∀ entry, entry ∈ posts → + Imperative.invStores σA σ' + ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll + (ks ++ ks')) ∧ + ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ + δ σA entry.snd.expr = some Imperative.HasBool.tt) : + EvalStatementsContract π φ ⟨σ', δ, f⟩ + ((posts.zip labels).map (fun (entry, lbl) => + Statement.assume lbl + (Lambda.LExpr.substFvars entry.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (entry.snd.md.setCallSiteFileRange md))) + ⟨σ', δ, f⟩ := + H_check_block_zip_poly (entries := posts) (labels := labels) (f := f) + Statement.assume + (mkSingletonEval := singletonAssumeEval_poly Hwfb) + Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hposts + /-- Labels-aware variant of `H_assumes`: takes a separate `labels` list (paired positionally with `posts` via `zip`) rather than a - `labelOf` projection. This matches the shape exposed by the - `HassumesShape` clause of `callElimCmd_call_eq` (B3 layer), which - forms the assumes list as `(posts.zip labels).map (fun (entry, lbl) => …)`. -/ + `labelOf` projection. `f := false` corollary of `H_assumes_zip_poly`. -/ theorem H_assumes_zip {π : String → Option Procedure} {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} @@ -1229,9 +1221,7 @@ theorem H_assumes_zip (ks.zip (Core.Transform.createFvars ks'))) (entry.snd.md.setCallSiteFileRange md))) ⟨σ', δ, false⟩ := - H_check_block_zip (entries := posts) (labels := labels) Statement.assume - (mkSingletonEval := singletonAssumeEval Hwfb) - Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hposts + H_assumes_zip_poly (f := false) Hwfb Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hposts /-- Helper: lifting `ReadValues σ ks vs` across an `updatedStates` extension by names disjoint from `ks`. -/ @@ -1418,27 +1408,213 @@ theorem havocVars_updatedStates_lift ih Hdisj_t exact HavocVars.update_some hUp' hTail' -/-- Glue lemma: chain L1–L6 via `EvalStatementsContractApp` to produce the - full call-elim block evaluation from σ to σ_havoc. -/ -theorem EvalCallElim_glue +/-! ### Failing-arm helpers for `EvalCallElim_glue_fail` + +These helpers walk the asserts segment when at least one precondition +evaluates to `ff` after substitution, producing an `EvalStatementsContract` +derivation that flips the cumulative `hasFailure` flag from `false` to +`true`. The walk handles entries before, at, and after the failing +witness uniformly via the OR-stable accumulator. See +`EvalCallElim_glue_fail` below for the orchestration. -/ + +/-- Singleton-eval helper for `Statement.assert` at the failing arm: + lifts the assert-fail evaluation rule into a single-statement + `EvalStatementsContract` that flips `f` to `f || true = true`. -/ +private theorem singletonAssertFailEval + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ : CoreStore} {f : Bool} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression) + (Hev : δ σ e = some Imperative.HasBool.ff) : + EvalStatementsContract π φ ⟨σ, δ, f⟩ + [Statement.assert lbl e m] + ⟨σ, δ, f || true⟩ := by + unfold EvalStatementsContract Imperative.EvalStmtsSmall + apply ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_cons + have Hcmd : Core.EvalCommandContract π δ σ + (Core.CmdExt.cmd (Imperative.Cmd.assert lbl e m)) + σ true := + Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_assert_fail Hev Hwfb) + have Hstep_cmd : + Imperative.StepStmt Expression (EvalCommandContract π) (EvalPureFunc φ) + (.stmt (Imperative.Stmt.cmd (Core.CmdExt.cmd (Imperative.Cmd.assert lbl e m))) + ⟨σ, δ, f⟩) + (.terminal ⟨σ, δ, f || true⟩) := by + have := Imperative.StepStmt.step_cmd (P := Expression) + (EvalCmd := EvalCommandContract π) (extendEval := EvalPureFunc φ) + (ρ := ⟨σ, δ, f⟩) (c := Core.CmdExt.cmd (Imperative.Cmd.assert lbl e m)) + (σ' := σ) (hasAssertFailure := true) Hcmd + simpa using this + apply ReflTrans.step _ _ _ + (Imperative.StepStmt.step_seq_inner Hstep_cmd) + apply ReflTrans.step _ _ _ Imperative.StepStmt.step_seq_done + exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) + +/-- Walk the asserts segment in the failing arm. Each entry's substituted + expression evaluates either to `tt` (pass) or `ff` (fail) at `σ'`; at + least one entry fails (or the input flag is already `true`). Output + cumulative flag is `true`. + + The `Hbool` and `Hfail_or_input` premises range over `(pres.zip labels)` + — the actually-realized statement list — rather than over `pres` alone, + so length-mismatched corner cases (`labels.length < pres.length`) are + avoided. Callers ensure `labels.length = pres.length`. -/ +theorem H_asserts_zip_fail + {π : String → Option Procedure} + {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} + {δ : CoreEval} {σ' : CoreStore} {f : Bool} + {ks ks' : List Expression.Ident} + {pres : List (CoreLabel × Procedure.Check)} + {labels : List String} + {md : Imperative.MetaData Expression} + (Hwfb : Imperative.WellFormedSemanticEvalBool δ) + (Hbool : + ∀ pair ∈ pres.zip labels, + δ σ' (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) = + some Imperative.HasBool.tt ∨ + δ σ' (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) = + some Imperative.HasBool.ff) + (Hfail_or_input : + f = true ∨ + ∃ pair ∈ pres.zip labels, + δ σ' (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) = + some Imperative.HasBool.ff) : + EvalStatementsContract π φ ⟨σ', δ, f⟩ + ((pres.zip labels).map (fun (entry, lbl) => + Statement.assert lbl + (Lambda.LExpr.substFvars entry.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (entry.snd.md.setCallSiteFileRange md))) + ⟨σ', δ, true⟩ := by + induction pres generalizing labels f with + | nil => + -- No entries → witness must be `f = true`. + simp only [List.zip_nil_left] at Hbool Hfail_or_input + rcases Hfail_or_input with Hf | ⟨pair, Hin, _⟩ + · subst Hf + simp [List.map_nil] + exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) + · cases Hin + | cons head tail ih => + cases labels with + | nil => + -- No labels → empty zip; witness must be `f = true`. + simp only [List.zip_nil_right] at Hbool Hfail_or_input + rcases Hfail_or_input with Hf | ⟨pair, Hin, _⟩ + · subst Hf + simp [List.map_nil] + exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) + · cases Hin + | cons lbl labels' => + -- Walk the head, then recurse. + have HheadCase := Hbool (head, lbl) (by simp [List.zip_cons_cons]) + have HtailBool : ∀ pair ∈ tail.zip labels', + δ σ' (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) = + some Imperative.HasBool.tt ∨ + δ σ' (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) = + some Imperative.HasBool.ff := by + intro pair Hin + exact Hbool pair (by simp [List.zip_cons_cons]; exact Or.inr Hin) + simp only [List.zip_cons_cons, List.map_cons] + -- Two branches based on head's eval. + rcases HheadCase with HheadTt | HheadFf + · -- Head passes; flag stays at f. + have HheadStep : + EvalStatementsContract π φ ⟨σ', δ, f⟩ + [Statement.assert lbl + (Lambda.LExpr.substFvars head.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (head.snd.md.setCallSiteFileRange md)] + ⟨σ', δ, f⟩ := + singletonAssertEval_poly Hwfb _ _ _ HheadTt + -- Witness migration: f=true OR ∃ in tail (since head passes). + have HtailWitness : + f = true ∨ + ∃ pair ∈ tail.zip labels', + δ σ' (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) = + some Imperative.HasBool.ff := by + rcases Hfail_or_input with Hf | ⟨pair, Hin_zip, Heq⟩ + · exact Or.inl Hf + · simp only [List.zip_cons_cons, List.mem_cons] at Hin_zip + cases Hin_zip with + | inl Hpair_eq => + -- pair = (head, lbl); but head evaluates to tt, contradicting Heq. + subst Hpair_eq + simp at Heq + exact absurd HheadTt (by rw [Heq]; intro h; injection h with h; cases h) + | inr Hin_tail => + exact Or.inr ⟨pair, Hin_tail, Heq⟩ + have Htail := ih (labels := labels') (f := f) HtailBool HtailWitness + exact EvalStatementsContractApp HheadStep Htail + · -- Head fails; flag flips from f to true. + have HheadStep_pre : + EvalStatementsContract π φ ⟨σ', δ, f⟩ + [Statement.assert lbl + (Lambda.LExpr.substFvars head.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (head.snd.md.setCallSiteFileRange md)] + ⟨σ', δ, f || true⟩ := + singletonAssertFailEval Hwfb _ _ _ HheadFf + have HheadStep : + EvalStatementsContract π φ ⟨σ', δ, f⟩ + [Statement.assert lbl + (Lambda.LExpr.substFvars head.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) + (head.snd.md.setCallSiteFileRange md)] + ⟨σ', δ, true⟩ := by + have Hftrue : f || true = true := Bool.or_true f + rw [← Hftrue]; exact HheadStep_pre + -- Recurse on tail with f := true. + have HtailWitness : + (true : Bool) = true ∨ + ∃ pair ∈ tail.zip labels', + δ σ' (Lambda.LExpr.substFvars pair.fst.snd.expr + (ks.zip (Core.Transform.createFvars ks'))) = + some Imperative.HasBool.ff := + Or.inl rfl + have Htail := ih (labels := labels') (f := true) HtailBool HtailWitness + exact EvalStatementsContractApp HheadStep Htail + +/-- Unified glue lemma: chain L1–L6 via `EvalStatementsContractApp` to + produce the full call-elim block evaluation from σ to σ_havoc. The + flag `f` is inferred from `HL4`'s output: `f = false` recovers the + passing arm, `f = true` the failing arm (asserts flips from `false` + to `true`, then L5/L6 stay at `true` via the polymorphic-`f` lifts). + + The L4 flag-flip in the failing arm is materialized via + `H_asserts_zip_fail`; L5 uses `H_havocs_poly`; L6 uses + `H_assumes_zip_poly`. `EvalCallElim_glue` is a deprecated alias — + new code should reference this name directly. -/ +theorem EvalCallElim_glue_fail {π : String → Option Procedure} {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ σ_arg σ_out σ_old σ_havoc : CoreStore} + {δ : CoreEval} {σ σ_arg σ_out σ_old σ_havoc : CoreStore} {f : Bool} {argInit outInit oldInit asserts havocs assumes : List Statement} (HL1 : EvalStatementsContract π φ ⟨σ, δ, false⟩ argInit ⟨σ_arg, δ, false⟩) (HL2 : EvalStatementsContract π φ ⟨σ_arg, δ, false⟩ outInit ⟨σ_out, δ, false⟩) (HL3 : EvalStatementsContract π φ ⟨σ_out, δ, false⟩ oldInit ⟨σ_old, δ, false⟩) - (HL4 : EvalStatementsContract π φ ⟨σ_old, δ, false⟩ asserts ⟨σ_old, δ, false⟩) - (HL5 : EvalStatementsContract π φ ⟨σ_old, δ, false⟩ havocs ⟨σ_havoc, δ, false⟩) - (HL6 : EvalStatementsContract π φ ⟨σ_havoc, δ, false⟩ assumes ⟨σ_havoc, δ, false⟩) : + (HL4 : EvalStatementsContract π φ ⟨σ_old, δ, false⟩ asserts ⟨σ_old, δ, f⟩) + (HL5 : EvalStatementsContract π φ ⟨σ_old, δ, f⟩ havocs ⟨σ_havoc, δ, f⟩) + (HL6 : EvalStatementsContract π φ ⟨σ_havoc, δ, f⟩ assumes ⟨σ_havoc, δ, f⟩) : EvalStatementsContract π φ ⟨σ, δ, false⟩ (argInit ++ outInit ++ oldInit ++ asserts ++ havocs ++ assumes) - ⟨σ_havoc, δ, false⟩ := by - have H12 := EvalStatementsContractApp HL1 HL2 - have H123 := EvalStatementsContractApp H12 HL3 - have H1234 := EvalStatementsContractApp H123 HL4 - have H12345 := EvalStatementsContractApp H1234 HL5 - exact EvalStatementsContractApp H12345 HL6 + ⟨σ_havoc, δ, f⟩ := + EvalStatementsContractApp + (EvalStatementsContractApp + (EvalStatementsContractApp + (EvalStatementsContractApp + (EvalStatementsContractApp HL1 HL2) HL3) HL4) HL5) HL6 + +/-- Passing-arm alias for `EvalCallElim_glue_fail` (`f` is inferred from + `HL4` as `false`). -/ +abbrev EvalCallElim_glue := @EvalCallElim_glue_fail end From 73531081751f6a7b9267273a537b67420fd65ae9 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 9 Jun 2026 15:14:05 -0700 Subject: [PATCH 12/12] CallElimCorrect: round 3 tier-1 cleanups (-287 LoC) (#1344) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ## Summary Round 3 tier-1 cleanups for the polymorphic-`f` callElim work merged in #1340. These commits were authored on top of #1340's head before the squash merge but were not included; this PR brings them onto the parent branch. Net delta: **-287 LoC** (5 files, +181/-468) across 19 small, atomic commits. No new sorries, no new axioms, no behavioral change. ## Highlights | Commit | Description | LoC | |---|---|---| | 2bb66b37b | R3-1: collapse `WFCallSiteProp` into `WFCallSiteSpec` via def-wrapper | -64 | | ca67ea7d8 | R3-2: drop f=false corollaries; rely on poly versions | -121 | | 680e0925d | R3-12: hoist `π/φ/δ` binders into file-scope `variable` block | -10 | | 26bf9aecd | R3-10: extract `havocVars_3layer_lift` helper | -23 | | ed3725dcf | R3-8: add `Procedure.Spec.checkedPreconditions` abbrev | -12 | | 7b6fbb36b | R3-19: simplify HentryFail mem-zip pattern in fail arm | -10 | | 8e3bc3fdd | R3-32: flatten nested mem_append cases via rcases | -14 | Plus 12 smaller items: bool-totality cleanup, redundant hypothesis drops, helper extractions, doc fixes (stale "seven" counts, removed references to deleted `WFPrePostProp.boolTyped`, fixed inverted section header hierarchy, dropped legacy `Hwfgenst` references). ## Soundness - **Build clean**: 490 jobs, no warnings or errors - **Sorries**: 0 in modified files - **Axioms**: `callElimStatementCorrect` depends only on `[propext, Classical.choice, Quot.sound]` — Lean stdlib only - **No behavioral change**: each commit is a refactor verified by `lake build` ## Test plan - [ ] CI green - [ ] No sorry/axiom regressions vs base --- Strata/Languages/Core/Procedure.lean | 6 + Strata/Languages/Core/StatementSemantics.lean | 8 +- Strata/Transform/CallElimCorrect.lean | 485 ++++++------------ Strata/Transform/CoreTransformProps.lean | 50 +- Strata/Transform/SubstProps.lean | 100 +--- 5 files changed, 181 insertions(+), 468 deletions(-) diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index bf0e4c2fd8..814f0c8a03 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -255,6 +255,12 @@ def Procedure.Spec.preconditionNames (s : Procedure.Spec) : List CoreLabel := def Procedure.Spec.postconditionNames (s : Procedure.Spec) : List CoreLabel := s.postconditions.keys +/-- Non-`Free` preconditions: those that are *checked* at call sites. + See `Procedure.CheckAttr` and Procedure.lean §92 for the meaning of `Free`. -/ +@[expose] abbrev Procedure.Spec.checkedPreconditions (s : Procedure.Spec) : + List (CoreLabel × Procedure.Check) := + s.preconditions.filter (fun (_, c) => c.attr ≠ .Free) + def Procedure.Spec.eraseTypes (s : Procedure.Spec) : Procedure.Spec := { s with preconditions := s.preconditions.map (fun (l, c) => (l, c.eraseTypes)), diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 0b7350de41..855ead14c8 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -437,14 +437,10 @@ inductive EvalCommandContract : (String → Option Procedure) → CoreEval → -- positional: oVals[i] initializes p.header.outputs[i] InitStates σA (ListMap.keys (p.header.outputs)) oVals σAO → -- non-Free preconditions are always defined; their truth controls `failed` - (∀ pre, (Procedure.Spec.getCheckExprs - (p.spec.preconditions.filter - (fun (_, c) => c.attr ≠ .Free))).contains pre → + (∀ pre, (Procedure.Spec.getCheckExprs p.spec.checkedPreconditions).contains pre → isDefinedOver (HasVarsPure.getVars) σAO pre) → (failed = false ↔ - (∀ pre, (Procedure.Spec.getCheckExprs - (p.spec.preconditions.filter - (fun (_, c) => c.attr ≠ .Free))).contains pre → + (∀ pre, (Procedure.Spec.getCheckExprs p.spec.checkedPreconditions).contains pre → δ σAO pre = .some HasBool.tt)) → HavocVars σAO (ListMap.keys p.header.outputs) σO → (∀ post, (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → diff --git a/Strata/Transform/CallElimCorrect.lean b/Strata/Transform/CallElimCorrect.lean index 69c908199b..9eebc7ed2b 100644 --- a/Strata/Transform/CallElimCorrect.lean +++ b/Strata/Transform/CallElimCorrect.lean @@ -35,6 +35,10 @@ open Core Core.Transform CallElim public section +variable {π : String → Option Procedure} +variable {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} +variable {δ : CoreEval} + -- inidividual lemmas private theorem createFvarsApp : @@ -105,7 +109,7 @@ private theorem find?_append_none_elim {α β} [DecidableEq α] then some (oldVar, argExpr) else none -/-! ### Top-level call-elimination correctness theorem -/ +/-! ## Top-level call-elimination correctness theorem -/ /-- Returns the call-elim transformation result of a single command: either the rewritten statement list (for a `.call`) or `[s]` @@ -370,10 +374,11 @@ private theorem pair_in_zip_of_pos List.mem_iff_get.mpr ⟨⟨n, by rw [List.length_zip]; omega⟩, List.getElem_zip⟩ -/-- Bridge from the `tmp_` half of `Hwfgenst` to `isNotDefined` for a list - of fresh temp names: if a name is `isTempIdent` and is *not* in - `γ.generated`, then it must be undefined in σ (otherwise the iff in - `Hwfgentmp` would put it in `γ.generated`). +/-- Bridge from the `tmp_*` alignment between `γ.genState.generated` and + `σ`'s defined keys to `isNotDefined` for a list of fresh temp names: + if a name is `isTempIdent` and is *not* in `γ.generated`, then it + must be undefined in σ (otherwise the iff in `Hwfgentmp` would put + it in `γ.generated`). Takes the dual-clause `tmp_` half: for every `v`, `v ∈ generated ∧ isTempIdent v ↔ (σ v).isSome ∧ isTempIdent v`. -/ @@ -590,7 +595,6 @@ private theorem filterCheck_mem_getCheckExprs `proc' ↦ proc`. Aligns `Hwfcallsite` (over `proc`) with checks indexed by the destructured `proc'` at both call-arm sites. -/ private theorem procEq_and_postExprs_bridge - {π : String → Option Procedure} {p : Program} {procName : String} {proc proc' : Procedure} (Hp : ∀ pname, π pname = Program.Procedure.find? p ⟨pname, ()⟩) (Hfind : Program.Procedure.find? p ⟨procName, ()⟩ = some proc') @@ -1125,19 +1129,15 @@ private theorem callElimStmt_non_call_eq Prod.mk.injEq, Except.ok.injEq] at hH exact hH.1 -/-- Call-site WF/disjointness invariants required by `callElimStatementCorrect`. +/-- Call-site WF clauses specialized at a fixed call form + `(procName, args, md)` and a fixed procedure `proc`. - Bundles the seven call-site WF clauses as named fields. Each field is a - universally-quantified property that fires only when `st` is a call; - for non-call statements every field is vacuously true. -/ -structure WFCallSiteProp (p : Program) - (π : String → Option Procedure) - (st : Statement) : Prop where + Bundles the eight call-site WF clauses as named fields, so call-site + code can `obtain ⟨...⟩ := Hwfcs.specialize Hst Hlkup` in one step. -/ +structure WFCallSiteSpec (proc : Procedure) (args : List (CallArg Expression)) : Prop where /-- Pre-condition free vars are not `tmp_`/`old_`-prefixed and not in the call's `lhs`. -/ preVarsFresh : - ∀ procName args md, st = .cmd (CmdExt.call procName args md) → - ∀ proc, π procName = some proc → ∀ pre ∈ Procedure.Spec.getCheckExprs proc.spec.preconditions, ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) pre, ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ @@ -1145,38 +1145,28 @@ structure WFCallSiteProp (p : Program) /-- Post-condition free vars are not `tmp_`/`old_`-prefixed and not in the call's `lhs`. -/ postVarsFresh : - ∀ procName args md, st = .cmd (CmdExt.call procName args md) → - ∀ proc, π procName = some proc → ∀ post ∈ Procedure.Spec.getCheckExprs proc.spec.postconditions, ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) post, ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ v ∉ CallArg.getLhs args /-- Argument-expression free vars are disjoint from the call's `lhs`. -/ argVarsNotInLhs : - ∀ procName args md, st = .cmd (CmdExt.call procName args md) → - ∀ _proc, π procName = some _proc → ∀ argExpr ∈ CallArg.getInputExprs args, ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, v ∉ CallArg.getLhs args /-- Procedure input/output parameter names are not `tmp_`/`old_`-prefixed. -/ inoutFresh : - ∀ procName args md, st = .cmd (CmdExt.call procName args md) → - ∀ proc, π procName = some proc → ∀ v ∈ proc.header.inputs.keys ++ proc.header.outputs.keys, ¬ isTempIdent v ∧ ¬ isOldTempIdent v /-- Argument-expression free vars are disjoint from the procedure's `outputs.keys` (the global modset). -/ argVarsNotInOutKeys : - ∀ procName args md, st = .cmd (CmdExt.call procName args md) → - ∀ proc, π procName = some proc → ∀ argExpr ∈ CallArg.getInputExprs args, ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, v ∉ ListMap.keys proc.header.outputs /-- Argument-expression free vars are disjoint from the procedure's `inputs.keys` (procedure parameter names). -/ argVarsNotInInKeys : - ∀ procName args md, st = .cmd (CmdExt.call procName args md) → - ∀ proc, π procName = some proc → ∀ argExpr ∈ CallArg.getInputExprs args, ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, v ∉ ListMap.keys proc.header.inputs @@ -1185,19 +1175,15 @@ structure WFCallSiteProp (p : Program) the call's lhs index for `v` agrees with the procedure's outputs-keys index. Backs the L6 `HoldEval_bridge` derivation. -/ outAlignment : - ∀ procName args md, st = .cmd (CmdExt.call procName args md) → - ∀ proc, π procName = some proc → ∀ v ∈ ListMap.keys proc.header.outputs, v ∈ CallArg.getLhs args → (CallArg.getLhs args).idxOf v = (ListMap.keys proc.header.outputs).idxOf v - /-- Bool-totality of preconditions (`WFPrePostProp.boolTyped` clause): a - precondition expression evaluates to either `tt` or `ff` whenever - its free variables are defined in the store. Backs the failing-arm - witness derivation in `callElimStatementCorrect_terminal_call_arm_fail`. -/ + /-- Bool-totality of preconditions: a precondition expression evaluates + to either `tt` or `ff` whenever its free variables are defined in + the store. Backs the failing-arm witness derivation in + `callElimStatementCorrect_terminal_call_arm_fail`. -/ preBoolTyped : - ∀ procName args md, st = .cmd (CmdExt.call procName args md) → - ∀ proc, π procName = some proc → ∀ pre ∈ Procedure.Spec.getCheckExprs proc.spec.preconditions, ∀ (δ : Imperative.SemanticEval Expression) (σ : Imperative.SemanticStore Expression), @@ -1206,83 +1192,44 @@ structure WFCallSiteProp (p : Program) δ σ pre = some Imperative.HasBool.tt ∨ δ σ pre = some Imperative.HasBool.ff -/-- Call-site WF clauses already specialized at a fixed call form - `(procName, args, md)` and a fixed procedure `proc`. - - Bundles the seven `WFCallSiteProp` fields with the per-call - `(procName, args, md, rfl, proc, lkup)` instantiation already - applied, so call-site code can `obtain ⟨...⟩ := ... .specialize ...` - in one step instead of repeating the instantiation per field. -/ -structure WFCallSiteSpec (proc : Procedure) (args : List (CallArg Expression)) : Prop where - preVarsFresh : - ∀ pre ∈ Procedure.Spec.getCheckExprs proc.spec.preconditions, - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) pre, - ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ - v ∉ CallArg.getLhs args - postVarsFresh : - ∀ post ∈ Procedure.Spec.getCheckExprs proc.spec.postconditions, - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) post, - ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ - v ∉ CallArg.getLhs args - argVarsNotInLhs : - ∀ argExpr ∈ CallArg.getInputExprs args, - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, - v ∉ CallArg.getLhs args - inoutFresh : - ∀ v ∈ proc.header.inputs.keys ++ proc.header.outputs.keys, - ¬ isTempIdent v ∧ ¬ isOldTempIdent v - argVarsNotInOutKeys : - ∀ argExpr ∈ CallArg.getInputExprs args, - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, - v ∉ ListMap.keys proc.header.outputs - argVarsNotInInKeys : - ∀ argExpr ∈ CallArg.getInputExprs args, - ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) argExpr, - v ∉ ListMap.keys proc.header.inputs - outAlignment : - ∀ v ∈ ListMap.keys proc.header.outputs, - v ∈ CallArg.getLhs args → - (CallArg.getLhs args).idxOf v = - (ListMap.keys proc.header.outputs).idxOf v - preBoolTyped : - ∀ pre ∈ Procedure.Spec.getCheckExprs proc.spec.preconditions, - ∀ (δ : Imperative.SemanticEval Expression) - (σ : Imperative.SemanticStore Expression), - Imperative.isDefinedOver - (Imperative.HasVarsPure.getVars (P := Expression)) σ pre → - δ σ pre = some Imperative.HasBool.tt ∨ - δ σ pre = some Imperative.HasBool.ff +/-- Call-site WF/disjointness invariants required by `callElimStatementCorrect`. -/-- Specialize all seven `WFCallSiteProp` fields at a fixed call form - `st = .cmd (CmdExt.call procName args md)` and procedure lookup - `π procName = some proc`. + A `WFCallSiteSpec` parameterized by the call form: fires only when + `st` is a call; for non-call statements vacuously true. Specialize + via `Hwfcs.specialize Hst Hlkup`. -/ +def WFCallSiteProp (_p : Program) + (π : String → Option Procedure) + (st : Statement) : Prop := + ∀ procName args md, st = .cmd (CmdExt.call procName args md) → + ∀ proc, π procName = some proc → + WFCallSiteSpec proc args - Lets the call-site case discharge the `(procName, args, md, rfl, - proc, lkup)` instantiation once and reuse the seven specialized - facts via `obtain ⟨...⟩ := Hwfcs.specialize Hst Hlkup`. -/ +/-- Specialize the universally-quantified `WFCallSiteProp` at a fixed call + form `st = .cmd (CmdExt.call procName args md)` and procedure lookup + `π procName = some proc`. -/ theorem WFCallSiteProp.specialize {p : Program} - {π : String → Option Procedure} {st : Statement} + {st : Statement} {procName : String} {args : List (CallArg Expression)} {md} {proc : Procedure} (Hwfcs : WFCallSiteProp p π st) (Hst : st = .cmd (CmdExt.call procName args md)) (Hlkup : π procName = some proc) : WFCallSiteSpec proc args := - ⟨ Hwfcs.preVarsFresh procName args md Hst proc Hlkup - , Hwfcs.postVarsFresh procName args md Hst proc Hlkup - , Hwfcs.argVarsNotInLhs procName args md Hst proc Hlkup - , Hwfcs.inoutFresh procName args md Hst proc Hlkup - , Hwfcs.argVarsNotInOutKeys procName args md Hst proc Hlkup - , Hwfcs.argVarsNotInInKeys procName args md Hst proc Hlkup - , Hwfcs.outAlignment procName args md Hst proc Hlkup - , Hwfcs.preBoolTyped procName args md Hst proc Hlkup ⟩ + Hwfcs procName args md Hst proc Hlkup + +/-- Project `WFcallProp.lhsWF` out of a `WFStatementsProp` whose head is a call. -/ +private theorem callArgsLhs_nodup_of_wf {p : Program} {procName : String} + {args : List (CallArg Expression)} {md : Imperative.MetaData Expression} + {rest : List Statement} {lhs : List Expression.Ident} + (Hwf : WF.WFStatementsProp p (.cmd (CmdExt.call procName args md) :: rest)) + (hCallArgsLhs : CallArg.getLhs args = lhs) : lhs.Nodup := + hCallArgsLhs ▸ ((List.Forall_cons _ _ _).mp Hwf).1.lhsWF /-- Relation between the source store `σ` and the call-elim transform state `γ`'s tracked fresh-name set. - Bundles the three fields of the legacy `Hwfgenst` hypothesis: the - `tmp_*` alignment between `γ.genState.generated` and `σ`'s defined - keys, the `old_*` freshness against `σ`, and `CoreGenState.WF` of - `γ.genState`. -/ + Bundles three facts: the `tmp_*` alignment between + `γ.genState.generated` and `σ`'s defined keys, the `old_*` freshness + against `σ`, and `CoreGenState.WF` of `γ.genState`. -/ structure CoreGenStateRel (σ : CoreStore) (γ : CoreTransformState) : Prop where /-- `tmp_*`-prefixed names in `γ.genState.generated` are exactly the `tmp_*`-defined names in `σ`. -/ @@ -1304,9 +1251,8 @@ private theorem delta_fvar_eq_of_wfvars (Hwfvars : Imperative.WellFormedSemanticEvalVar delta) (sigma : CoreStore) (v : Expression.Ident) : delta sigma (Lambda.LExpr.fvar () v none) = sigma v := by - have Hwfvr := Hwfvars - simp [Imperative.WellFormedSemanticEvalVar] at Hwfvr - rw [Hwfvr (Lambda.LExpr.fvar () v none) v] + simp [Imperative.WellFormedSemanticEvalVar] at Hwfvars + rw [Hwfvars (Lambda.LExpr.fvar () v none) v] simp [Imperative.HasFvar.getFvar] /-- Bundle the σ-freshness chain: from a Nodup of the combined @@ -1408,11 +1354,13 @@ private theorem genTrips_combined_nodup /-- Prelude bundle for `HoldEval_bridge_at_σO` call sites. - Both arms of `_terminal`'s call branch derive the same four facts: - the per-output `Hwf2.2`-bridge, `σAO`-reads-outputs, and the two - `oldVars`-subset facts (filtered into `lhs`/`outputs.keys`). -/ + Both arms of `_terminal`'s call branch derive the same three facts: + the per-output `Hwf2.2`-bridge, `σAO`-reads-outputs, and the + `oldVars ⊆ outputs.keys` subset fact. (Membership in `lhs` / + `CallArg.getLhs args` is recovered locally via `hCallArgsLhs` and + `List.mem_filter`.) -/ private theorem holdEval_bridge_prelude - {δ : CoreEval} {σ₀ σ σA σAO σO : CoreStore} + {σ₀ σ σA σAO σO : CoreStore} {proc proc' : Procedure} {args : List (CallArg Expression)} {oVals : List Expression.Expr} (Hwf2 : WellFormedCoreEvalTwoState δ σ₀ σ) @@ -1423,17 +1371,14 @@ private theorem holdEval_bridge_prelude (∀ v ∈ proc.header.outputs.keys, δ σO (Lambda.LExpr.fvar () (CoreIdent.mkOld v.name) none) = σAO v) ∧ ReadValues σAO proc.header.outputs.keys oVals ∧ - (∀ v ∈ callElim_oldVars proc' args, v ∈ CallArg.getLhs args) ∧ (∀ v ∈ callElim_oldVars proc' args, v ∈ ListMap.keys proc.header.outputs) := by - refine ⟨?_, InitStatesReadValues Hinitout, ?_, ?_⟩ + refine ⟨?_, InitStatesReadValues Hinitout, ?_⟩ · intro v Hv simp only [WellFormedCoreEvalTwoState] at Hwf2 have HH := Hwf2.2 proc.header.outputs.keys [] σAO σO σO ⟨Hhav1, InitVars.init_none⟩ v exact HH.1 Hv - · intro v Hv - exact (List.mem_filter.mp Hv).1 · intro v Hv have Hv_filt := List.mem_filter.mp Hv have Hbool := Hv_filt.2 @@ -1460,13 +1405,14 @@ private theorem holdEval_bridge_prelude shape equality. * `HoutAlign`: positional alignment from `WFCallSiteSpec` (lhs idx agrees with outputs.keys idx for shared inout outputs). - * `HoldVars_sub_outs`, `HoldVars_sub_lhs`, `HoldVars_sub_callLhs`: - `oldVars` is the filter that narrows `lhs` ↪ `oldVars`, so each - element is in `outputs.keys`, `lhs`, and `CallArg.getLhs args`. + * `HoldVars_sub_outs`, `HoldVars_sub_lhs`: `oldVars` is the filter + that narrows `lhs` ↪ `oldVars`, so each element is in + `outputs.keys` and `lhs` (membership in `CallArg.getLhs args` + follows from `hCallArgsLhs`). * `HoldVals`: `ReadValues σ oldVars oldVals`. * `HoldValsLen`: `oldVals.length = oldVars.length`. -/ private theorem HoldEval_bridge_at_σO - {δ : CoreEval} {σ σAO σO : CoreStore} + {σ σAO σO : CoreStore} {oldVars lhs : List Expression.Ident} {oldVals oVals : List Expression.Expr} {proc : Procedure} {args : List (CallArg Expression)} {σA : CoreStore} @@ -1485,7 +1431,6 @@ private theorem HoldEval_bridge_at_σO (ListMap.keys proc.header.outputs).idxOf v) (HoldVars_sub_outs : ∀ v ∈ oldVars, v ∈ proc.header.outputs.keys) (HoldVars_sub_lhs : ∀ v ∈ oldVars, v ∈ lhs) - (HoldVars_sub_callLhs : ∀ v ∈ oldVars, v ∈ CallArg.getLhs args) (HoldVals : ReadValues σ oldVars oldVals) (HoldValsLen : oldVals.length = oldVars.length) : ∀ (i : Nat) (Hi : i < oldVars.length), @@ -1499,8 +1444,7 @@ private theorem HoldEval_bridge_at_σO have Hv_out : v ∈ ListMap.keys proc.header.outputs := HoldVars_sub_outs v Hv_mem have Hv_lhs : v ∈ lhs := HoldVars_sub_lhs v Hv_mem - have Hv_callLhs : v ∈ CallArg.getLhs args := - HoldVars_sub_callLhs v Hv_mem + have Hv_callLhs : v ∈ CallArg.getLhs args := hCallArgsLhs ▸ Hv_lhs -- ReadValues σ' ks vs ∧ v ∈ ks ⇒ σ' v = some vs[ks.idxOf v]. have read_at : ∀ {σ' : Expression.Ident → Option _} {ks : List Expression.Ident} {vs : List _} @@ -1570,7 +1514,7 @@ private theorem HoldEval_bridge_at_σO * `σ_R1_read_olds`: positional reads `σ_R1 genOldIdents[i] = some oldVals[i]`. * `HoldEval_bridge`: positional bridge from Stage 1's helper. -/ private theorem HoldSubBridge_at_σO - {δ : CoreEval} {σ_R1 σO : CoreStore} + {σ_R1 σO : CoreStore} {oldVars genOldIdents : List Expression.Ident} {oldTys : List Expression.Ty} {oldVals : List Expression.Expr} @@ -1652,8 +1596,6 @@ private theorem b1_var_witness_at_oldSubst callElim_inputOnlyOldSubst proc' args) k = some w) (_Hv_in : var ∈ Imperative.HasVarsPure.getVars (P:=Expression) w), ∃ (ni : Nat) (Hni : ni < genOldIdents.length), - w = Core.Transform.createFvar - (genOldIdents[ni]'Hni) ∧ var = genOldIdents[ni]'Hni := by intro var k w w' hfind Hf Hv_in have Hw'w : w' = w := find?_append_some_eq hfind Hf @@ -1664,7 +1606,7 @@ private theorem b1_var_witness_at_oldSubst Core.Transform.createFvar (genOldIdents[ni_val]'Hni_lt_genOld) := by rw [← Hw'w]; exact Hw'_eq - refine ⟨ni_val, Hni_lt_genOld, Hw_eq, ?_⟩ + refine ⟨ni_val, Hni_lt_genOld, ?_⟩ rw [Hw_eq] at Hv_in have Hv_in' : var ∈ Imperative.HasVarsPure.getVars (P:=Expression) @@ -1749,7 +1691,6 @@ private theorem b2_var_witness_at_oldSubst map; backs the L6 `Hsub` derivation in both the success and failure arms of `callElimStatementCorrect`'s call-statement case. -/ private theorem HinputSubBridge_at_σO - {δ : CoreEval} {σ σ_R1 σO σAO σA σ₀ σ₂ : CoreStore} {γ : CoreTransformState} {genOldIdents : List Expression.Ident} @@ -1944,16 +1885,13 @@ private theorem HinputSubBridge_at_σO destructure: builds the failing assert chain via `H_asserts_zip_fail`, havocs via `H_havocs_poly`, assumes via `H_assumes_zip_poly`, and glues via `EvalCallElim_glue_fail`. The bool-totality witness for the failing - precondition is extracted from `WFCallSiteProp.preBoolTyped` (boolTyped - clause on `WFPrePostProp`) combined with `Hpre_iff.mpr`'s contrapositive. + precondition is extracted from `WFCallSiteSpec.preBoolTyped` combined + with `Hpre_iff.mpr`'s contrapositive. All inputs after `Hwfcallsite` are the destructured outputs from `cases Hcc with | call_sem ...` at `failed = true`. -/ private theorem callElimStatementCorrect_terminal_call_arm_fail [LawfulBEq Expression.Expr] - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ σ' : CoreStore} {p : Program} {γ s_ce : CoreTransformState} @@ -1989,15 +1927,11 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail (Hinitout : InitStates σA (ListMap.keys proc.header.outputs) oVals σAO) (Hpre_def : - ∀ pre, (Procedure.Spec.getCheckExprs - (proc.spec.preconditions.filter - (fun (_, c) => c.attr ≠ .Free))).contains pre → + ∀ pre, (Procedure.Spec.getCheckExprs proc.spec.checkedPreconditions).contains pre → Imperative.isDefinedOver (Imperative.HasVarsPure.getVars) σAO pre) (Hpre_iff : true = false ↔ - ∀ pre, (Procedure.Spec.getCheckExprs - (proc.spec.preconditions.filter - (fun (_, c) => c.attr ≠ .Free))).contains pre → + ∀ pre, (Procedure.Spec.getCheckExprs proc.spec.checkedPreconditions).contains pre → δ σAO pre = .some Imperative.HasBool.tt) (Hhav1 : HavocVars σAO (ListMap.keys proc.header.outputs) σO) @@ -2016,7 +1950,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail asserts, assumes, s_arg, s_out, s_old, Hfind, Heqarg, Heqout, Heqold, Holdtylen, - Hsts_struct, HassertsShape, _HassumesShape⟩ := + Hsts_struct, HassertsShape, HassumesShape⟩ := callElimCmd_call_eq heq_ce have Heqargs : argTrips.unzip.snd = CallArg.getInputExprs args := @@ -2169,12 +2103,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail notin_of_isSome_isNotDefined (Hlhs_isLocl x Hin1) HndefOld_σ Hin2 have HoutSnd_eq_lhs : outTrips.unzip.snd = lhs := by rw [Heqouts, hCallArgsLhs] - have HlhsNd : lhs.Nodup := by - have Hwfst_head := (List.Forall_cons _ _ _).mp Hwf - have Hwfcall : WF.WFcallProp p procName args := Hwfst_head.1 - have Hlhs_args_nd : - (CallArg.getLhs args).Nodup := Hwfcall.lhsWF - rwa [hCallArgsLhs] at Hlhs_args_nd + have HlhsNd : lhs.Nodup := callArgsLhs_nodup_of_wf Hwf hCallArgsLhs have Hout_nd_app : List.Nodup (outTemps ++ outTrips.unzip.snd) := by @@ -2231,11 +2160,8 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail rw [show oldTrips = (genOldIdents.zip oldTys).zip oldVars from rfl] simp [List.unzip_eq_map, List.map_snd_zip, HzipLen] - have HoldVars_sub_lhs : ∀ g ∈ oldVars, g ∈ lhs := by - intro g Hg - have Hg_in_getLhs : g ∈ CallArg.getLhs args := - (List.mem_filter.mp Hg).1 - exact hCallArgsLhs ▸ Hg_in_getLhs + have HoldVars_sub_lhs : ∀ g ∈ oldVars, g ∈ lhs := fun _ Hg => + hCallArgsLhs ▸ (List.mem_filter.mp Hg).1 have oldVars_disj_via_lhs : ∀ {ks : List Expression.Ident}, lhs.Disjoint ks → oldVars.Disjoint ks := fun H x Hin1 Hin2 => H (HoldVars_sub_lhs x Hin1) Hin2 @@ -2309,27 +2235,6 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail HndefOldTrips rw [Hsts_struct] -- L5 setup: build havocs from σ_old to σ_havoc, polymorphic-flag. - have Hhav_σ : HavocVars σ lhs σ' := - UpdateStatesHavocVars Hupdate - have Hhav_arg : - HavocVars (updatedStates σ - argTemps argVals) - lhs - (updatedStates σ' - argTemps argVals) := - havocVars_updatedStates_lift HlhsDisjArg Hhav_σ - have Hhav_out : - HavocVars - (updatedStates - (updatedStates σ - argTemps argVals) - outTemps oVals) - lhs - (updatedStates - (updatedStates σ' - argTemps argVals) - outTemps oVals) := - havocVars_updatedStates_lift HlhsDisjOut Hhav_arg have Hhav_old : HavocVars (updatedStates @@ -2344,9 +2249,9 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail (updatedStates σ' argTemps argVals) outTemps oVals) - oldTrips.unzip.fst.unzip.fst oldVals) := by - rw [HoldTripsFst] - apply havocVars_updatedStates_lift HlhsDisjOld Hhav_out + oldTrips.unzip.fst.unzip.fst oldVals) := + havocVars_3layer_lift HlhsDisjArg HlhsDisjOut + (HoldTripsFst ▸ HlhsDisjOld) (UpdateStatesHavocVars Hupdate) have HlhsDef_old : Imperative.isDefined (updatedStates @@ -2428,9 +2333,9 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail -- ── D2a: per-precondition payload for L4 (asserts) ── obtain ⟨HprocEq, c_in_postExprs_of_proc'⟩ := procEq_and_postExprs_bridge Hp Hfind lkup - obtain ⟨HpreVarsFresh, _HpostVarsFresh, _HargVarsNotInLhs, + obtain ⟨HpreVarsFresh, HpostVarsFresh, _HargVarsNotInLhs, HinoutFresh, HargVarsNotInOutKeys, - HargVarsNotInInKeys, _HoutAlign, HpreBoolTyped⟩ := + HargVarsNotInInKeys, HoutAlign, HpreBoolTyped⟩ := Hwfcallsite.specialize (procName := procName) (args := args) (md := md) rfl lkup have HinputsFresh : @@ -2471,8 +2376,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail exact σ_some_contradiction (Hlhs_isLocl v Hv2) Hvσ_none -- Filtered preconditions. let presFiltered : List (CoreLabel × Procedure.Check) := - proc.spec.preconditions.filter - (fun (_, c) => c.attr ≠ .Free) + proc.spec.checkedPreconditions -- Pre-var freshness restricted to presFiltered (filtered ⊆ unfiltered). have HpresVarsFresh' : ∀ entry ∈ presFiltered, @@ -2623,11 +2527,8 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail rw [List.zip_append] rw [createFvarsLength] exact HinKeys_argTemps_len - -- Per-pair "tt or ff" totality fact at σ_old via subst_fvars_correct + boolTyped. - -- For each pair (entry, lbl) ∈ presFiltered.zip assertLabels, - -- build the totality witness at σ_old. - -- First derive HpresPayload-like facts (without the eval-tt — use boolTyped). - -- Bool-totality witness at σAO for filtered preconditions. + -- Bool-totality witness at σAO for filtered preconditions, via + -- subst_fvars_correct + preBoolTyped (no eval-tt assumed). have HpreFilteredBool : ∀ entry ∈ presFiltered, δ σAO entry.snd.expr = some Imperative.HasBool.tt ∨ @@ -2648,9 +2549,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail List.contains_iff_mem.mp Hcontains -- Use HpreBoolTyped at (δ, σAO) with the definedness witness. have Hcontains_filt : - (Procedure.Spec.getCheckExprs - (proc.spec.preconditions.filter - (fun (_, c) => c.attr ≠ .Free))).contains entry.snd.expr := by + (Procedure.Spec.getCheckExprs proc.spec.checkedPreconditions).contains entry.snd.expr := by rw [List.contains_iff_mem] simp only [Procedure.Spec.getCheckExprs, ListMap.values_eq_map_snd, List.mem_map, @@ -2727,6 +2626,13 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail initStates_get_notin Hinitin Hk1_notin_inputs] rw [HAO_eq_σ, Hold_eq_σ] exact ⟨Hinv, Hpred_disj⟩ + -- Hoisted subst_fvars_correct: δ σAO expr = δ σ_old (substFvars expr …). + have HsubstCorrect : ∀ entry ∈ presFiltered, + δ σAO entry.snd.expr = + δ σ_old (Lambda.LExpr.substFvars entry.snd.expr + (ks_L4.zip (Core.Transform.createFvars ks'_L4))) := fun entry H => + subst_fvars_correct Hwfc Hwfvars Hwfval Hks_len_L4 + Hdef_L4 Hnd_L4 Hsubst_L4_flipped (HpresInfo entry H).2 (HpresInfo entry H).1 -- Per-pair tt-or-ff witness at σ_old. have HboolAtOld : ∀ pair ∈ presFiltered.zip assertLabels, @@ -2739,13 +2645,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail intro pair Hpair have Hentry_in : pair.fst ∈ presFiltered := (List.of_mem_zip Hpair).1 - have ⟨Hinv, Hpred_disj⟩ := HpresInfo pair.fst Hentry_in - -- subst_fvars_correct: δ σAO expr = δ σ_old (substFvars expr (ks.zip createFvars ks')). - have Heq : δ σAO pair.fst.snd.expr = - δ σ_old (Lambda.LExpr.substFvars pair.fst.snd.expr - (ks_L4.zip (Core.Transform.createFvars ks'_L4))) := - subst_fvars_correct Hwfc Hwfvars Hwfval Hks_len_L4 - Hdef_L4 Hnd_L4 Hsubst_L4_flipped Hpred_disj Hinv + have Heq := HsubstCorrect pair.fst Hentry_in have Hbool_AO := HpreFilteredBool pair.fst Hentry_in cases Hbool_AO with | inl Htt => left; rw [← Heq]; exact Htt @@ -2758,25 +2658,13 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail (ks_L4.zip (Core.Transform.createFvars ks'_L4))) = some Imperative.HasBool.ff := by right - -- "Not all preconditions evaluate to tt at σAO" via Hpre_iff.mpr. - have Hnot_all : - ¬ (∀ pre, (Procedure.Spec.getCheckExprs - (proc.spec.preconditions.filter - (fun (_, c) => c.attr ≠ .Free))).contains pre → - δ σAO pre = .some Imperative.HasBool.tt) := by - intro Hall - have : true = false := Hpre_iff.mpr Hall - cases this - -- From Hnot_all, extract a witness pre that fails to eval to tt. - -- Combined with bool-totality, that pre evaluates to ff. - -- We need to find an entry in presFiltered. - -- Use classical reasoning to find the first failing entry. + -- Extract a precondition failing eval-tt at σAO via Hpre_iff.mpr's + -- contrapositive: if all eval-tt, then `true = false`, impossible. have HexFail : ∃ entry ∈ presFiltered, δ σAO entry.snd.expr ≠ some Imperative.HasBool.tt := by - -- Prove via Classical.byContradiction: assume not exists, derive ∀, contradict. apply Classical.byContradiction intro Hno - apply Hnot_all + refine Bool.noConfusion (Hpre_iff.mpr ?_) intro pre Hpre rw [List.contains_iff_mem] at Hpre simp only [Procedure.Spec.getCheckExprs, @@ -2796,12 +2684,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail | inl Htt => exact absurd Htt HentryFail_ne_tt | inr Hff => exact Hff -- Transport to σ_old. - have ⟨Hinv, Hpred_disj⟩ := HpresInfo entryFail HentryFail_in - have Heq : δ σAO entryFail.snd.expr = - δ σ_old (Lambda.LExpr.substFvars entryFail.snd.expr - (ks_L4.zip (Core.Transform.createFvars ks'_L4))) := - subst_fvars_correct Hwfc Hwfvars Hwfval Hks_len_L4 - Hdef_L4 Hnd_L4 Hsubst_L4_flipped Hpred_disj Hinv + have Heq := HsubstCorrect entryFail HentryFail_in have HentryFail_old_ff : δ σ_old (Lambda.LExpr.substFvars entryFail.snd.expr (ks_L4.zip (Core.Transform.createFvars ks'_L4))) = @@ -2817,26 +2700,16 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail rw [HprocEq] at HH rw [Hfilter_eq_pres] at HH exact HH.symm - have HentryFail_idx : ∃ i, ∃ (Hi : i < presFiltered.length) - (Hi' : i < assertLabels.length), - presFiltered[i]'Hi = entryFail := by - rcases List.mem_iff_get.mp HentryFail_in with ⟨n, Hn_eq⟩ - refine ⟨n.val, n.isLt, ?_, ?_⟩ - · rw [← HassertLen']; exact n.isLt - · exact Hn_eq - obtain ⟨i, Hi, Hi', Hi_eq⟩ := HentryFail_idx - let lblFail := assertLabels[i]'Hi' - have HpairIn : (entryFail, lblFail) ∈ presFiltered.zip assertLabels := by - have Hzip_get : - (presFiltered.zip assertLabels)[i]'(by - exact List.length_zip ▸ Nat.lt_min.mpr ⟨Hi, Hi'⟩) = - (entryFail, lblFail) := by - rw [List.getElem_zip] - show (presFiltered[i]'Hi, assertLabels[i]'Hi') = (entryFail, lblFail) - rw [Hi_eq] - exact Hzip_get.symm ▸ List.getElem_mem _ - refine ⟨(entryFail, lblFail), HpairIn, ?_⟩ - exact HentryFail_old_ff + rcases List.mem_iff_get.mp HentryFail_in with ⟨n, Hn_eq⟩ + have Hi' : n.val < assertLabels.length := HassertLen' ▸ n.isLt + have Hi_eq : presFiltered[n.val]'n.isLt = entryFail := Hn_eq + refine ⟨(entryFail, assertLabels[n.val]'Hi'), ?_, HentryFail_old_ff⟩ + have Hzip_get : + (presFiltered.zip assertLabels)[n.val]'(by + exact List.length_zip ▸ Nat.lt_min.mpr ⟨n.isLt, Hi'⟩) = + (entryFail, assertLabels[n.val]'Hi') := by + rw [List.getElem_zip, Hi_eq] + exact Hzip_get.symm ▸ List.getElem_mem _ have HL4_pre : EvalStatementsContract π φ ⟨σ_old, δ, false⟩ (((proc.spec.preconditions.filter @@ -3078,19 +2951,12 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail exact Hlhs_disj_filt_argT Ha Hb · intro a Ha b Hb Heq subst Heq - cases List.mem_append.mp Ha with - | inl HaOuts => - cases List.mem_append.mp Hb with - | inl HbLhs => - exact HoutKeys_disj_lhs HaOuts HbLhs - | inr HbArgT => - exact HoutKeys_disj_filt_argT HaOuts HbArgT - | inr HaIn => - cases List.mem_append.mp Hb with - | inl HbLhs => - exact Hfilt_in_disj_lhs HaIn HbLhs - | inr HbArgT => - exact Hfilt_in_disj_filt_argT HaIn HbArgT + rcases List.mem_append.mp Ha with HaOuts | HaIn <;> + rcases List.mem_append.mp Hb with HbLhs | HbArgT + · exact HoutKeys_disj_lhs HaOuts HbLhs + · exact HoutKeys_disj_filt_argT HaOuts HbArgT + · exact Hfilt_in_disj_lhs HaIn HbLhs + · exact Hfilt_in_disj_filt_argT HaIn HbArgT -- σO/σ_R1/σ_havoc definedness facts. have HσO_def_outs : Imperative.isDefined σO proc.header.outputs.keys := @@ -3184,11 +3050,11 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail · simp [argTemps, outTemps, List.length_append, List.unzip_eq_map, Hargtriplen, Houttriplen, HgenOldOldValsLen] · intro v Hv1 Hv2 - cases List.mem_append.mp Hv2 with - | inl h => cases List.mem_append.mp h with - | inl ha => exact HlhsDisjArg Hv1 ha - | inr ho => exact HlhsDisjOut Hv1 ho - | inr ho => exact HlhsDisjOld Hv1 ho + simp only [List.mem_append] at Hv2 + rcases Hv2 with (ha | ho) | ho + · exact HlhsDisjArg Hv1 ha + · exact HlhsDisjOut Hv1 ho + · exact HlhsDisjOld Hv1 ho · rw [Hσ'_eq] exact readValues_updatedStatesSame HmodvalsLen' HlhsNd have Hsubst : Imperative.substStores σ_R1 σ_havoc @@ -3335,8 +3201,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail -- The success arm derives this; we copy. -- ── L6 plumbing (mirror success arm) ── have HInitVars_empty : InitVars σO [] σO := InitVars.init_none - obtain ⟨Hwf2_univ, HσAO_reads_outs, HoldVars_sub_callLhs, - HoldVars_sub_outs⟩ := + obtain ⟨Hwf2_univ, HσAO_reads_outs, HoldVars_sub_outs⟩ := holdEval_bridge_prelude (args := args) Hwf2 Hhav1 Hinitout HprocEq have HσAO_notin_eq_σ : ∀ v, v ∉ proc.header.outputs.keys → @@ -3363,8 +3228,8 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail (CoreIdent.mkOld (oldVars[i]'Hi).name) none) = some (oldVals[i]'(HoldValsLen.symm ▸ Hi)) := HoldEval_bridge_at_σO Hwf2_univ Hinitout HσAO_reads_outs - Hevalouts hCallArgsLhs _HoutAlign HoldVars_sub_outs - HoldVars_sub_lhs HoldVars_sub_callLhs HoldVals HoldValsLen + Hevalouts hCallArgsLhs HoutAlign HoldVars_sub_outs + HoldVars_sub_lhs HoldVals HoldValsLen -- L6 oldTripsCanonical/oldSubst/posts_filtered shape. let oldTripsCanonical_L6 : List ((Expression.Ident × Expression.Ty) × @@ -3446,7 +3311,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ v ∉ CallArg.getLhs args := by intro c Hc_in v Hv - exact _HpostVarsFresh c.expr (c_in_postExprs_of_proc' c Hc_in) v Hv + exact HpostVarsFresh c.expr (c_in_postExprs_of_proc' c Hc_in) v Hv have HsurvBridgeC : ∀ v ∈ Imperative.HasVarsPure.getVars (P:=Expression) c.expr, @@ -3550,7 +3415,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail ¬ isTempIdent v ∧ ¬ isOldTempIdent v ∧ v ∉ CallArg.getLhs args := by intro c Hc_in v Hv - exact _HpostVarsFresh c.expr (c_in_postExprs_of_proc' c Hc_in) v Hv + exact HpostVarsFresh c.expr (c_in_postExprs_of_proc' c Hc_in) v Hv have HfiltArgT_sub_argT : ∀ x ∈ filtered_argTemps, x ∈ argTemps := by intro x Hx @@ -3625,7 +3490,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail (Core.Transform.createOldVarsSubst oldTripsCanonical_L6) k with | some w' => - obtain ⟨ni_val, Hni_lt_genOld, _Hw_eq, Hv_eq_gen⟩ := + obtain ⟨ni_val, Hni_lt_genOld, Hv_eq_gen⟩ := b1_var_witness hfind Hf Hv_in have Hni_lt_oldVals : ni_val < oldVals.length := HoldValsLen.symm ▸ HgenOldLen ▸ Hni_lt_genOld @@ -3689,7 +3554,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail (Core.Transform.createOldVarsSubst oldTripsCanonical_L6) k' with | some w' => - obtain ⟨ni_val, Hni_lt_genOld, _Hw_eq, Hx_eq_gen⟩ := + obtain ⟨ni_val, Hni_lt_genOld, Hx_eq_gen⟩ := b1_var_witness hfind Hf Hv_in rw [Hx_eq_gen] at Hin1 cases List.mem_append.mp Hin1 with @@ -3742,7 +3607,7 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail HpostEval_bridge entry Hentry⟩ -- L6 (assumes) via H_assumes_zip_poly with f := true. obtain ⟨assumeLabels, _HassumeLabelsLen, HassumeShape⟩ := - _HassumesShape + HassumesShape have HassumeSubst_eq : ((proc'.header.outputs.keys.zip (Core.Transform.createFvars (CallArg.getLhs args))) ++ @@ -3831,9 +3696,6 @@ private theorem callElimStatementCorrect_terminal_call_arm_fail call case chains L1–L6 via `EvalCallElim_glue`; non-call cases are immediate. -/ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ σ' : CoreStore} {f : Bool} {p : Program} @@ -3846,7 +3708,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (Hwf : WF.WFStatementsProp p [st]) (Hgenrel : CoreGenStateRel σ γ) -- Call-site WF: pre/post vars are non-temp/non-old and disjoint - -- from `lhs`/inputs.keys/outputs.keys (seven clauses; see WFCallSiteProp + -- from `lhs`/inputs.keys/outputs.keys (eight clauses; see WFCallSiteProp -- above (line 1095 of this file)). (Hwfcallsite : WFCallSiteProp p π st) (Helim : (Except.ok sts, γ') = (runWith st (callElimStmt · p) γ)) : @@ -3958,8 +3820,8 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] cases f with | true => -- Stage 6 failure arm: derive bool-totality witness via - -- Hwfcallsite → boolTyped, build failing assert chain, glue - -- with EvalCallElim_glue_fail. Delegated to a sibling + -- Hwfcallsite → preBoolTyped, build failing assert chain, + -- glue with EvalCallElim_glue_fail. Delegated to a sibling -- private theorem for proof-body manageability. exact callElimStatementCorrect_terminal_call_arm_fail Hp Hwfc Hwf Hgenrel Hwfcallsite heq_ce @@ -3974,15 +3836,11 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] -- eval-tt over non-Free preconditions only — exactly what -- the L4 callElim asserts chain (which filters out Free) needs. have Hpre_evalTt : - ∀ pre, (Procedure.Spec.getCheckExprs - (proc.spec.preconditions.filter - (fun (_, c) => c.attr ≠ .Free))).contains pre → + ∀ pre, (Procedure.Spec.getCheckExprs proc.spec.checkedPreconditions).contains pre → δ σAO pre = .some Imperative.HasBool.tt := Hpre_iff.mp rfl have Hpre : - ∀ pre, (Procedure.Spec.getCheckExprs - (proc.spec.preconditions.filter - (fun (_, c) => c.attr ≠ .Free))).contains pre → + ∀ pre, (Procedure.Spec.getCheckExprs proc.spec.checkedPreconditions).contains pre → Imperative.isDefinedOver (Imperative.HasVarsPure.getVars (P:=Expression)) σAO pre ∧ δ σAO pre = .some Imperative.HasBool.tt := @@ -4167,13 +4025,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] -- Out-temp Nodup append form for `H_initVars`. have HoutSnd_eq_lhs : outTrips.unzip.snd = lhs := by rw [Heqouts, hCallArgsLhs] - have HlhsNd : lhs.Nodup := by - -- Project WFcallProp.lhsWF via Hwf's Forall_cons head. - have Hwfst_head := (List.Forall_cons _ _ _).mp Hwf - have Hwfcall : WF.WFcallProp p procName args := Hwfst_head.1 - have Hlhs_args_nd : - (CallArg.getLhs args).Nodup := Hwfcall.lhsWF - rwa [hCallArgsLhs] at Hlhs_args_nd + have HlhsNd : lhs.Nodup := callArgsLhs_nodup_of_wf Hwf hCallArgsLhs have Hout_nd_app : List.Nodup (outTemps ++ outTrips.unzip.snd) := by @@ -4234,11 +4086,8 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] simp [List.unzip_eq_map, List.map_snd_zip, HzipLen] -- Disjointness of oldVars from argTemps/outTemps and -- oldVars Nodup follow from `oldVars ⊆ lhs`. - have HoldVars_sub_lhs : ∀ g ∈ oldVars, g ∈ lhs := by - intro g Hg - have Hg_in_getLhs : g ∈ CallArg.getLhs args := - (List.mem_filter.mp Hg).1 - exact hCallArgsLhs ▸ Hg_in_getLhs + have HoldVars_sub_lhs : ∀ g ∈ oldVars, g ∈ lhs := fun _ Hg => + hCallArgsLhs ▸ (List.mem_filter.mp Hg).1 have oldVars_disj_via_lhs : ∀ {ks : List Expression.Ident}, lhs.Disjoint ks → oldVars.Disjoint ks := fun H x Hin1 Hin2 => H (HoldVars_sub_lhs x Hin1) Hin2 @@ -4326,27 +4175,6 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] -- D2: L4 (asserts), L5 (havocs), L6 (assumes) chain. rw [Hsts_struct] -- L5: build post-havoc store σ_havoc by HavocVars segments on σ' = σ.update lhs modvals. - have Hhav_σ : HavocVars σ lhs σ' := - UpdateStatesHavocVars Hupdate - have Hhav_arg : - HavocVars (updatedStates σ - argTemps argVals) - lhs - (updatedStates σ' - argTemps argVals) := - havocVars_updatedStates_lift HlhsDisjArg Hhav_σ - have Hhav_out : - HavocVars - (updatedStates - (updatedStates σ - argTemps argVals) - outTemps oVals) - lhs - (updatedStates - (updatedStates σ' - argTemps argVals) - outTemps oVals) := - havocVars_updatedStates_lift HlhsDisjOut Hhav_arg have Hhav_old : HavocVars (updatedStates @@ -4361,9 +4189,9 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (updatedStates σ' argTemps argVals) outTemps oVals) - oldTrips.unzip.fst.unzip.fst oldVals) := by - rw [HoldTripsFst] - apply havocVars_updatedStates_lift HlhsDisjOld Hhav_out + oldTrips.unzip.fst.unzip.fst oldVals) := + havocVars_3layer_lift HlhsDisjArg HlhsDisjOut + (HoldTripsFst ▸ HlhsDisjOld) (UpdateStatesHavocVars Hupdate) -- isDefined σ_old lhs (via 3-layer extension monotone). have HlhsDef_old : Imperative.isDefined @@ -4391,7 +4219,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] argTemps argVals) outTemps oVals) oldTrips.unzip.fst.unzip.fst oldVals, δ, false⟩ := - H_havocs Hwfvars HlhsDef_old Hhav_old + H_havocs_poly Hwfvars HlhsDef_old Hhav_old -- Equality: σ_havoc (3-layer over σ') = σ'' (flat) via zip-append. have HoldFstLen : oldTrips.unzip.fst.unzip.fst.length = oldVals.length := by @@ -4505,8 +4333,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] exact σ_some_contradiction (Hlhs_isLocl v Hv2) Hvσ_none -- Restrict to the filtered preconditions. let presFiltered : List (CoreLabel × Procedure.Check) := - proc.spec.preconditions.filter - (fun (_, c) => c.attr ≠ .Free) + proc.spec.checkedPreconditions -- Bind σAO definedness/eval-tt for each filtered entry. -- Hpre's domain is `getCheckExprs presFiltered.contains`, so -- mapping `entry ∈ presFiltered` to that contains-membership @@ -4869,19 +4696,12 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] -- (lhs ++ filtered_argTemps). intro a Ha b Hb Heq subst Heq - cases List.mem_append.mp Ha with - | inl HaOuts => - cases List.mem_append.mp Hb with - | inl HbLhs => - exact HoutKeys_disj_lhs HaOuts HbLhs - | inr HbArgT => - exact HoutKeys_disj_filt_argT HaOuts HbArgT - | inr HaIn => - cases List.mem_append.mp Hb with - | inl HbLhs => - exact Hfilt_in_disj_lhs HaIn HbLhs - | inr HbArgT => - exact Hfilt_in_disj_filt_argT HaIn HbArgT + rcases List.mem_append.mp Ha with HaOuts | HaIn <;> + rcases List.mem_append.mp Hb with HbLhs | HbArgT + · exact HoutKeys_disj_lhs HaOuts HbLhs + · exact HoutKeys_disj_filt_argT HaOuts HbArgT + · exact Hfilt_in_disj_lhs HaIn HbLhs + · exact Hfilt_in_disj_filt_argT HaIn HbArgT -- Hdef: substDefined σ_R1 σ_havoc. have HσO_def_outs : Imperative.isDefined σO proc.header.outputs.keys := @@ -5048,11 +4868,11 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] apply readValues_updatedStates · simp [argTemps, outTemps, List.length_append, List.unzip_eq_map, Hargtriplen, Houttriplen, HgenOldOldValsLen] · intro v Hv1 Hv2 - cases List.mem_append.mp Hv2 with - | inl h => cases List.mem_append.mp h with - | inl ha => exact HlhsDisjArg Hv1 ha - | inr ho => exact HlhsDisjOut Hv1 ho - | inr ho => exact HlhsDisjOld Hv1 ho + simp only [List.mem_append] at Hv2 + rcases Hv2 with (ha | ho) | ho + · exact HlhsDisjArg Hv1 ha + · exact HlhsDisjOut Hv1 ho + · exact HlhsDisjOld Hv1 ho · rw [Hσ'_eq] exact readValues_updatedStatesSame HmodvalsLen' HlhsNd -- Filtered halves via the triple zip. @@ -5389,8 +5209,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] -- (a) Trivial empty-init witness (used by callee bridges). have HInitVars_empty : InitVars σO [] σO := InitVars.init_none -- (b) Per-output bridge, σAO reads outputs, oldVars ⊆ lhs/outs. - obtain ⟨Hwf2_univ, HσAO_reads_outs, HoldVars_sub_callLhs, - HoldVars_sub_outs⟩ := + obtain ⟨Hwf2_univ, HσAO_reads_outs, HoldVars_sub_outs⟩ := holdEval_bridge_prelude (args := args) Hwf2 Hhav1 Hinitout HprocEq -- (b) σAO[v] = σ[v] for v ∉ outputs ∪ inputs. @@ -5410,7 +5229,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] some (oldVals[i]'(HoldValsLen.symm ▸ Hi)) := HoldEval_bridge_at_σO Hwf2_univ Hinitout HσAO_reads_outs Hevalouts hCallArgsLhs HoutAlign HoldVars_sub_outs - HoldVars_sub_lhs HoldVars_sub_callLhs HoldVals HoldValsLen + HoldVars_sub_lhs HoldVals HoldValsLen -- D2d: Structural pieces of HpostPayload (per-entry). let oldTripsCanonical_L6 : List ((Expression.Ident × Expression.Ty) × @@ -5656,7 +5475,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] oldTripsCanonical_L6) k with | some w' => -- (b1) createOldVarsSubst flavor — via shared helper. - obtain ⟨ni_val, Hni_lt_genOld, _Hw_eq, Hv_eq_gen⟩ := + obtain ⟨ni_val, Hni_lt_genOld, Hv_eq_gen⟩ := b1_var_witness hfind Hf Hv_in -- σ_R1 k1 = oldVals[ni_val]; σ_havoc k1 = oldVals[ni_val]. have Hni_lt_oldVals : ni_val < oldVals.length := @@ -5745,7 +5564,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] oldTripsCanonical_L6) k' with | some w' => -- (b1) createOldVarsSubst flavor — via shared helper. - obtain ⟨ni_val, Hni_lt_genOld, _Hw_eq, Hx_eq_gen⟩ := + obtain ⟨ni_val, Hni_lt_genOld, Hx_eq_gen⟩ := b1_var_witness hfind Hf Hv_in rw [Hx_eq_gen] at Hin1 -- genOldIdents[ni_val] ∈ filtered_ks' = lhs ++ filtered_argTemps. @@ -5874,7 +5693,7 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] (Core.Transform.createFvars filtered_ks'))) (entry.snd.md.setCallSiteFileRange md))) ⟨σ_havoc, δ, false⟩ := by - apply H_assumes_zip + apply H_assumes_zip_poly (f := false) (σA := σ_R1) (σ' := σ_havoc) (ks := filtered_ks) (ks' := filtered_ks') @@ -5905,9 +5724,6 @@ private theorem callElimStatementCorrect_terminal [LawfulBEq Expression.Expr] discharged: `step_cmd` only ever produces `.terminal`, never `.exiting`, so `(.stmts [.cmd (.call …)] _) →* .exiting lbl _` is unreachable. -/ private theorem callElimStatementCorrect_exit [LawfulBEq Expression.Expr] - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ σ' : CoreStore} {p : Program} {γ γ' : CoreTransformState} @@ -5973,9 +5789,6 @@ private theorem callElimStatementCorrect_exit [LawfulBEq Expression.Expr] `callElimStatementCorrect_terminal`. The exit arm dispatches to `callElimStatementCorrect_exit`. -/ theorem callElimStatementCorrect [LawfulBEq Expression.Expr] - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ : CoreStore} {p : Program} {γ γ' : CoreTransformState} diff --git a/Strata/Transform/CoreTransformProps.lean b/Strata/Transform/CoreTransformProps.lean index 5b7cfabc00..c6da706f39 100644 --- a/Strata/Transform/CoreTransformProps.lean +++ b/Strata/Transform/CoreTransformProps.lean @@ -73,17 +73,6 @@ theorem singleCmdToStmts_poly apply ReflTrans.step _ _ _ Imperative.StepStmt.step_seq_done exact ReflTrans.step _ _ _ Imperative.StepStmt.step_stmts_nil (.refl _) -/-- Flag-`false` corollary of `singleCmdToStmts_poly`. -/ -theorem singleCmdToStmts - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ σ' : CoreStore} {c : Core.Command} - (Hcmd : Core.EvalCommandContract π δ σ c σ' false) : - EvalStatementsContract π φ ⟨σ, δ, false⟩ - [Imperative.Stmt.cmd c] - ⟨σ', δ, false⟩ := - singleCmdToStmts_poly (π := π) (φ := φ) (f := false) Hcmd - /-- Polymorphic-`f` variant of `singletonAssertEval`: lifts assert-pass into a flag-`f`-preserving step. -/ theorem singletonAssertEval_poly @@ -97,17 +86,6 @@ theorem singletonAssertEval_poly singleCmdToStmts_poly (π := π) (φ := φ) (f := f) (Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_assert_pass Hev Hwfb)) -/-- Flag-`false` corollary of `singletonAssertEval_poly`. -/ -theorem singletonAssertEval - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ : CoreStore} - (Hwfb : Imperative.WellFormedSemanticEvalBool δ) - (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression) - (Hev : δ σ e = some Imperative.HasBool.tt) : - EvalStatementsContract π φ ⟨σ, δ, false⟩ [Statement.assert lbl e m] ⟨σ, δ, false⟩ := - singletonAssertEval_poly (π := π) (φ := φ) (f := false) Hwfb lbl e m Hev - /-- Polymorphic-`f` variant of `singletonAssumeEval`. -/ theorem singletonAssumeEval_poly {π : String → Option Procedure} @@ -120,17 +98,6 @@ theorem singletonAssumeEval_poly singleCmdToStmts_poly (π := π) (φ := φ) (f := f) (Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_assume Hev Hwfb)) -/-- Flag-`false` corollary of `singletonAssumeEval_poly`. -/ -theorem singletonAssumeEval - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ : CoreStore} - (Hwfb : Imperative.WellFormedSemanticEvalBool δ) - (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression) - (Hev : δ σ e = some Imperative.HasBool.tt) : - EvalStatementsContract π φ ⟨σ, δ, false⟩ [Statement.assume lbl e m] ⟨σ, δ, false⟩ := - singletonAssumeEval_poly (π := π) (φ := φ) (f := false) Hwfb lbl e m Hev - /-- Polymorphic-`f` variant: havoc commands locally produce `flag=false`, and OR-ing into the running `f` keeps it as `f`. Evaluating `createHavocs vs md` under contract semantics steps from σ through @@ -170,21 +137,6 @@ theorem H_havocs_poly exact EvalStatementsContractApp (singleCmdToStmts_poly (f := f) Hcmd) HrecTail -/-- Flag-`false` corollary of `H_havocs_poly`. -/ -theorem H_havocs - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σ σ' : CoreStore} - {vs : List Expression.Ident} - {md : Imperative.MetaData Expression} - (Hwfv : Imperative.WellFormedSemanticEvalVar δ) - (Hdef : Imperative.isDefined σ vs) - (Hhav : HavocVars σ vs σ') : - EvalStatementsContract π φ ⟨σ, δ, false⟩ - (Core.Transform.createHavocs vs md) - ⟨σ', δ, false⟩ := - H_havocs_poly (π := π) (φ := φ) (f := false) Hwfv Hdef Hhav - /-- Evaluating a single `Statement.init x ty (.det e) md` under contract semantics steps from σ to `updatedState σ x v`, given `δ σ e = some v` and that `x` is currently undefined in σ. -/ @@ -212,7 +164,7 @@ theorem H_init (Core.CmdExt.cmd (Imperative.Cmd.init x ty (.det e) md)) (updatedState σ x v) false := Core.EvalCommandContract.cmd_sem (Imperative.EvalCmd.eval_init Heval Hinit Hwfv) - exact singleCmdToStmts Hcmd + exact singleCmdToStmts_poly Hcmd /-- If `k ∉ ks`, then `ReadValues σ ks vs` is preserved when extending σ with an unrelated key. -/ diff --git a/Strata/Transform/SubstProps.lean b/Strata/Transform/SubstProps.lean index c5a0435905..2c907a8a06 100644 --- a/Strata/Transform/SubstProps.lean +++ b/Strata/Transform/SubstProps.lean @@ -1000,8 +1000,7 @@ theorem subst_fvars_eval_bridge flag-`f` singleton callback through the `(entries.zip labels).map` shape. Used by `H_assumes_zip_poly` to keep the L5/L6 (havocs/assumes) segments at `f = true` after the L4 flag flip, - and by the `f := false` corollary `H_check_block_zip` (and - `H_asserts_zip` / `H_assumes_zip` through it). -/ + and by `H_asserts_zip` (with `f := false`). -/ theorem H_check_block_zip_poly {π : String → Option Procedure} {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} @@ -1071,45 +1070,6 @@ theorem H_check_block_zip_poly simp only [List.zip_cons_cons, List.map_cons] exact EvalStatementsContractApp HheadStmts Htail -/-- `f := false` specialization of `H_check_block_zip_poly`. Kept as a - corollary so existing call sites (`H_asserts_zip`) continue to work - after the polymorphic lift. -/ -theorem H_check_block_zip - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σA σ' : CoreStore} - {ks ks' : List Expression.Ident} - {entries : List (CoreLabel × Procedure.Check)} - {labels : List String} - {md : Imperative.MetaData Expression} - (mkStmt : String → Expression.Expr → Imperative.MetaData Expression → Statement) - (mkSingletonEval : - ∀ (lbl : String) (e : Expression.Expr) (m : Imperative.MetaData Expression), - δ σ' e = some Imperative.HasBool.tt → - EvalStatementsContract π φ ⟨σ', δ, false⟩ [mkStmt lbl e m] ⟨σ', δ, false⟩) - (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) - (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) - (Hwfc : Core.WellFormedCoreEvalCong δ) - (Hlen : ks.length = ks'.length) - (Hnd : Imperative.substNodup (ks.zip ks')) - (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) - (Hsubst : Imperative.substStores σA σ' (ks.zip ks')) - (Hentries : ∀ entry, entry ∈ entries → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll - (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ - δ σA entry.snd.expr = some Imperative.HasBool.tt) : - EvalStatementsContract π φ ⟨σ', δ, false⟩ - ((entries.zip labels).map (fun (entry, lbl) => - mkStmt lbl - (Lambda.LExpr.substFvars entry.snd.expr - (ks.zip (Core.Transform.createFvars ks'))) - (entry.snd.md.setCallSiteFileRange md))) - ⟨σ', δ, false⟩ := - H_check_block_zip_poly (f := false) mkStmt mkSingletonEval - Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hentries - /-- Labels-aware variant of `H_asserts`: takes a separate `labels` list (paired positionally with `pres` via `zip`) rather than a `labelOf` projection. This matches the shape exposed by the @@ -1148,8 +1108,9 @@ theorem H_asserts_zip apply Imperative.substStoresFlip' simp [Imperative.substSwap, zip_swap] exact Hsubst - exact H_check_block_zip (entries := pres) (labels := labels) Statement.assert - (mkSingletonEval := singletonAssertEval Hwfb) + exact H_check_block_zip_poly (entries := pres) (labels := labels) (f := false) + Statement.assert + (mkSingletonEval := singletonAssertEval_poly Hwfb) Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst' Hpres /-- Polymorphic-`f` variant of `H_assumes_zip`. Lets the L6 (assumes) @@ -1189,40 +1150,6 @@ theorem H_assumes_zip_poly (mkSingletonEval := singletonAssumeEval_poly Hwfb) Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hposts -/-- Labels-aware variant of `H_assumes`: takes a separate `labels` - list (paired positionally with `posts` via `zip`) rather than a - `labelOf` projection. `f := false` corollary of `H_assumes_zip_poly`. -/ -theorem H_assumes_zip - {π : String → Option Procedure} - {φ : CoreEval → Imperative.PureFunc Expression → CoreEval} - {δ : CoreEval} {σA σ' : CoreStore} - {ks ks' : List Expression.Ident} - {posts : List (CoreLabel × Procedure.Check)} - {labels : List String} - {md : Imperative.MetaData Expression} - (Hwfb : Imperative.WellFormedSemanticEvalBool δ) - (Hwfvr : Imperative.WellFormedSemanticEvalVar (P:=Expression) δ) - (Hwfvl : Imperative.WellFormedSemanticEvalVal (P:=Expression) δ) - (Hwfc : Core.WellFormedCoreEvalCong δ) - (Hlen : ks.length = ks'.length) - (Hnd : Imperative.substNodup (ks.zip ks')) - (Hdef : Imperative.substDefined σA σ' (ks.zip ks')) - (Hsubst : Imperative.substStores σA σ' (ks.zip ks')) - (Hposts : ∀ entry, entry ∈ posts → - Imperative.invStores σA σ' - ((Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr).removeAll - (ks ++ ks')) ∧ - ks'.Disjoint (Imperative.HasVarsPure.getVars (P:=Expression) entry.snd.expr) ∧ - δ σA entry.snd.expr = some Imperative.HasBool.tt) : - EvalStatementsContract π φ ⟨σ', δ, false⟩ - ((posts.zip labels).map (fun (entry, lbl) => - Statement.assume lbl - (Lambda.LExpr.substFvars entry.snd.expr - (ks.zip (Core.Transform.createFvars ks'))) - (entry.snd.md.setCallSiteFileRange md))) - ⟨σ', δ, false⟩ := - H_assumes_zip_poly (f := false) Hwfb Hwfvr Hwfvl Hwfc Hlen Hnd Hdef Hsubst Hposts - /-- Helper: lifting `ReadValues σ ks vs` across an `updatedStates` extension by names disjoint from `ks`. -/ theorem readValues_updatedStates @@ -1408,6 +1335,25 @@ theorem havocVars_updatedStates_lift ih Hdisj_t exact HavocVars.update_some hUp' hTail' +/-- Lift `HavocVars σ lhs σ'` across three nested `updatedStates` extensions + given `lhs` is disjoint from each layer's identifiers. -/ +theorem havocVars_3layer_lift + {σ σ' : CoreStore} {lhs : List Expression.Ident} + {ts1 ts2 ts3 : List Expression.Ident} + {vs1 vs2 vs3 : List Expression.Expr} + (Hdisj1 : lhs.Disjoint ts1) (Hdisj2 : lhs.Disjoint ts2) + (Hdisj3 : lhs.Disjoint ts3) + (Hhav : HavocVars σ lhs σ') : + HavocVars + (updatedStates + (updatedStates (updatedStates σ ts1 vs1) ts2 vs2) ts3 vs3) + lhs + (updatedStates + (updatedStates (updatedStates σ' ts1 vs1) ts2 vs2) ts3 vs3) := + havocVars_updatedStates_lift Hdisj3 + (havocVars_updatedStates_lift Hdisj2 + (havocVars_updatedStates_lift Hdisj1 Hhav)) + /-! ### Failing-arm helpers for `EvalCallElim_glue_fail` These helpers walk the asserts segment when at least one precondition