From c81249b49b03978610f514e807c75d49df47a35a Mon Sep 17 00:00:00 2001 From: David Deng Date: Mon, 8 Jun 2026 12:43:06 -0700 Subject: [PATCH 01/33] feat: structured-to-unstructured forward soundness for simple-shape programs Adds structuredToUnstructured_sound (axiom-free, sorry-free) for programs satisfying Block.simpleShape (no nondeterministic ites, no loops of any kind), built on top of htd/small-step-infra. Main file: Strata/Transform/StructuredToUnstructuredCorrect.lean (7,331 LoC). Small-step variant of the proof originally landed in origin/htd/structured-to-unstructured-simple-on-infra. The block-at-a-time EvalDetBlock relation is gone from CFGSemantics.lean; the simulation is now driven by the per-command StepCFG with three configuration shapes (.atBlock / .inBlock / .terminal) and five constructors. The proof file adapts to that shape via three run_block_* helpers (atBlock entry, inBlock prefix, terminal exit) plus an EvalCmds_to_StepCFG_chain bridge that lifts a structured EvalCmds derivation to a StepCFGStar trace through one block. Diff vs the original proof file: 181 insertions, 196 deletions. Foundational additions on the infra branch (unchanged from the original proof's prerequisite list, all already present in htd/small-step-infra): - LawfulHasFvar / LawfulHasBool / LawfulHasIdent / LawfulHasIntOrder / LawfulHasNot instances for Core.Expression in StatementSemantics.lean - @[expose] on DetTransferCmd.goto, ExprOrNondet.getVars, updateFailure, StepCFGStar, flushCmds, stmtsToBlocks, stmtsToCFGM, stmtsToCFG - HasVarsPure typeclass and WellFormedSemanticEvalExprCongr premise threaded through StepCFG's conditional-goto constructors (replacing the EvalDetBlock-level premises from the original proof) - synthesizedMd promoted from private to public abbrev - flushCmds rewritten to materialize blocks for explicit transfers (so condGoto is emitted even when accum is empty); stmtsToBlocks block-rest arm uses accumEntry as the new entry (test goldens updated to match) - DetTransferCmd.goto default md := .empty Translator output change: synthesized-provenance metadata is suppressed on the auxiliary condGoto blocks emitted by flushCmds; goldens in StrataTest/Languages/Core/Examples/{Exit,Loops}.lean were updated on the infra branch. Sorry/axiom count: 0/0 in the proof file. Builds against the infra branch's 488 jobs; tests green (modulo the pre-existing ion-java jar issue in Languages.Java.TestGen). --- Strata.lean | 1 + .../StructuredToUnstructuredCorrect.lean | 7331 +++++++++++++++++ 2 files changed, 7332 insertions(+) create mode 100644 Strata/Transform/StructuredToUnstructuredCorrect.lean diff --git a/Strata.lean b/Strata.lean index 5457e4d54a..2f6e2aeff0 100644 --- a/Strata.lean +++ b/Strata.lean @@ -34,6 +34,7 @@ import Strata.Transform.CallElimCorrect import Strata.Transform.CoreSpecification import Strata.Transform.DetToKleeneCorrect import Strata.Transform.ProcBodyVerifyCorrect +import Strata.Transform.StructuredToUnstructuredCorrect /- Strata Languages — additional -/ import Strata.Languages.B3 diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean new file mode 100644 index 0000000000..8f7ea90cc3 --- /dev/null +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -0,0 +1,7331 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.StmtSemantics +public import Strata.DL.Imperative.StmtSemanticsProps +public import Strata.DL.Imperative.CmdSemanticsProps +public import Strata.DL.Imperative.CFGSemantics +public import Strata.DL.Imperative.KleeneSemanticsProps +public import Strata.Transform.StructuredToUnstructured +public import Strata.Transform.Specification +public import Strata.Transform.SpecificationProps +public import Strata.DL.Util.StringGen +public import Strata.Languages.Core.StatementSemantics +import all Strata.DL.Imperative.BasicBlock +import all Strata.DL.Imperative.Cmd + +/-! # Structured-to-Unstructured Transformation Correctness + +This file proves that `stmtsToCFG` is semantics-preserving: the generated CFG +overapproximates the original structured statements. Specifically, any terminal +store reachable by executing the structured program is also reachable by +executing the CFG. + +The top-level theorem is `structuredToUnstructured_sound`. + +## Proof Strategy + +The proof is a forward simulation: we show that each structured execution trace +corresponds to a CFG execution trace reaching the same terminal store. + +The key insight is that `stmtsToBlocks k ss exitConts accum` processes statements +backwards (CPS-style), threading a continuation label `k`. The simulation must +track the relationship between: +- The current position in the structured statement list +- The current CFG block label (entry point returned by `stmtsToBlocks`) +- The accumulated commands buffer (which becomes part of the next flushed block) + +The proof proceeds by: +1. A generalized simulation lemma (`stmtsToBlocks_simulation`) over the structure + of the statement list, parameterized by continuation and accumulator. +2. Per-constructor lemmas that show each statement kind's generated blocks + correctly simulate that statement's structured semantics. +3. A `flushCmds` lemma that connects command accumulation to `EvalCmds`. +4. Composition via `ReflTrans` transitivity to build the full `StepCFGStar` trace. +-/ + +public section + +namespace StructuredToUnstructuredCorrect + +open Imperative Specification + +/-! ## Abbreviations -/ +@[simp] +abbrev StepDetCFGStar {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (cfg : CFG String (DetBlock String (Cmd P) P)) := + @StepCFGStar String (Cmd P) _ P (EvalCmd P) extendEval _ _ cfg + +theorem StepDetCFGStar_trans {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {cfg : CFG String (DetBlock String (Cmd P) P)} + {a b c : CFGConfig String (Cmd P) P} + (h₁ : StepDetCFGStar extendEval cfg a b) + (h₂ : StepDetCFGStar extendEval cfg b c) : + StepDetCFGStar extendEval cfg a c := + ReflTrans_Transitive _ _ _ _ h₁ h₂ + +/-- `NoGenSuffix xs` says every ident in `xs` was supplied by user source — +i.e. is `HasIdent.ident s` only for strings `s` that are *not* of the +underscore-digit-suffix gen shape. Abbreviates a 1-line predicate that +appears verbatim ~89 times in the proofs below. -/ +@[expose] abbrev NoGenSuffix {P : PureExpr} [HasIdent P] + (xs : List P.Ident) : Prop := + ∀ x ∈ xs, ∀ s : String, + x = HasIdent.ident (P := P) s → ¬ String.HasUnderscoreDigitSuffix s + +/-! ## Bridge: EvalCmds and connector to per-command StepCFG + +`EvalCmds` is a structured-side helper inductive used by every simulation +lemma to package up the structured evaluation of an accumulated command list. +We bridge it into the new per-command `StepCFG` by lifting each +`eval_cmds_some` step into one `StepCFG.step_cmd` step inside `.inBlock`. -/ + +inductive EvalCmds + {CmdT : Type} + (P : PureExpr) + (EvalCmdR : EvalCmdParam P CmdT) : + SemanticEval P → SemanticStore P → List CmdT → SemanticStore P → Bool → Prop where + | eval_cmds_none : + EvalCmds P EvalCmdR δ σ [] σ false + | eval_cmds_some : + EvalCmdR δ σ c σ' failed → + EvalCmds P EvalCmdR δ σ' cs σ'' failed' → + EvalCmds P EvalCmdR δ σ (c :: cs) σ'' (failed || failed') + +/-- Bridge: lift an `EvalCmds` derivation for the command list `cs` into a +chain of `StepCFG.step_cmd` steps inside `.inBlock`, threading the residual +list and accumulating failure on the right via `||`. -/ +theorem EvalCmds_to_StepCFG_chain {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {cfg : CFG String (DetBlock String (Cmd P) P)} + {δ : SemanticEval P} {σ σ' : SemanticStore P} + {cs : List (Cmd P)} {f : Bool} + (h_cmds : EvalCmds P (EvalCmd P) δ σ cs σ' f) : + ∀ (t : String) (tr : DetTransferCmd String P) (f_base : Bool), + StepCFGStar P (EvalCmd P) extendEval cfg + (.inBlock t cs tr σ f_base) + (.inBlock t [] tr σ' (f_base || f)) := by + induction h_cmds with + | eval_cmds_none => + intro t tr f_base + -- (.inBlock t [] tr σ f_base) ↦* (.inBlock t [] tr σ (f_base || false)) + rw [Bool.or_false] + exact ReflTrans.refl _ + | eval_cmds_some hcmd hcmds ih => + rename_i δ' σ_in c σ_mid failed cs_t σ_out f_t + intro t tr f_base + -- one step_cmd consumes c + have h1 : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.inBlock t (c :: cs_t) tr σ_in f_base) + (.inBlock t cs_t tr σ_mid (f_base || failed)) := + StepCFG.step_cmd (extendEval := extendEval) hcmd + have h2 := ih t tr (f_base || failed) + -- Recompute the failure flag: ((f_base || failed) || f_t) = (f_base || (failed || f_t)) + have h_or : + ((f_base || failed) || f_t) = (f_base || (failed || f_t)) := + Bool.or_assoc _ _ _ + rw [h_or] at h2 + exact ReflTrans.step _ _ _ h1 h2 + +/-- Run a deterministic block from `.atBlock t` to `.atBlock tlbl` via the +true branch of a `condGoto`: fetch + chain + goto_true. -/ +theorem run_block_goto_true {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {cfg : CFG String (DetBlock String (Cmd P) P)} + {δ : SemanticEval P} {σ σ' : SemanticStore P} + {cs : List (Cmd P)} {c : P.Expr} {tlbl elbl : String} {md : MetaData P} + {f_base f : Bool} {t : String} + (h_lkp : List.lookup t cfg.blocks = .some ⟨cs, .condGoto c tlbl elbl md⟩) + (h_cmds : EvalCmds P (EvalCmd P) δ σ cs σ' f) + (h_cond : δ σ' c = .some HasBool.tt) + (hwfb : WellFormedSemanticEvalBool δ) + (hwfcongr : WellFormedSemanticEvalExprCongr δ) : + StepCFGStar P (EvalCmd P) extendEval cfg + (.atBlock t σ f_base) + (.atBlock tlbl σ' (f_base || f)) := by + have h_fetch : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.atBlock t σ f_base) + (.inBlock t cs (.condGoto c tlbl elbl md) σ f_base) := + StepCFG.fetch (extendEval := extendEval) h_lkp + have h_chain := EvalCmds_to_StepCFG_chain (extendEval := extendEval) + (cfg := cfg) h_cmds t (.condGoto c tlbl elbl md) f_base + have h_goto : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.inBlock t [] (.condGoto c tlbl elbl md) σ' (f_base || f)) + (.atBlock tlbl σ' (f_base || f)) := + StepCFG.goto_true (extendEval := extendEval) h_cond hwfb hwfcongr + exact ReflTrans.step _ _ _ h_fetch + (ReflTrans_Transitive _ _ _ _ h_chain + (ReflTrans.step _ _ _ h_goto (ReflTrans.refl _))) + +/-- Run a deterministic block from `.atBlock t` to `.atBlock elbl` via the +false branch of a `condGoto`: fetch + chain + goto_false. -/ +theorem run_block_goto_false {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {cfg : CFG String (DetBlock String (Cmd P) P)} + {δ : SemanticEval P} {σ σ' : SemanticStore P} + {cs : List (Cmd P)} {c : P.Expr} {tlbl elbl : String} {md : MetaData P} + {f_base f : Bool} {t : String} + (h_lkp : List.lookup t cfg.blocks = .some ⟨cs, .condGoto c tlbl elbl md⟩) + (h_cmds : EvalCmds P (EvalCmd P) δ σ cs σ' f) + (h_cond : δ σ' c = .some HasBool.ff) + (hwfb : WellFormedSemanticEvalBool δ) + (hwfcongr : WellFormedSemanticEvalExprCongr δ) : + StepCFGStar P (EvalCmd P) extendEval cfg + (.atBlock t σ f_base) + (.atBlock elbl σ' (f_base || f)) := by + have h_fetch : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.atBlock t σ f_base) + (.inBlock t cs (.condGoto c tlbl elbl md) σ f_base) := + StepCFG.fetch (extendEval := extendEval) h_lkp + have h_chain := EvalCmds_to_StepCFG_chain (extendEval := extendEval) + (cfg := cfg) h_cmds t (.condGoto c tlbl elbl md) f_base + have h_goto : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.inBlock t [] (.condGoto c tlbl elbl md) σ' (f_base || f)) + (.atBlock elbl σ' (f_base || f)) := + StepCFG.goto_false (extendEval := extendEval) h_cond hwfb hwfcongr + exact ReflTrans.step _ _ _ h_fetch + (ReflTrans_Transitive _ _ _ _ h_chain + (ReflTrans.step _ _ _ h_goto (ReflTrans.refl _))) + +/-- Run a deterministic block from `.atBlock t` to `.terminal`: fetch + chain ++ finish. -/ +theorem run_block_finish {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {cfg : CFG String (DetBlock String (Cmd P) P)} + {δ : SemanticEval P} {σ σ' : SemanticStore P} + {cs : List (Cmd P)} {md : MetaData P} + {f_base f : Bool} {t : String} + (h_lkp : List.lookup t cfg.blocks = .some ⟨cs, .finish md⟩) + (h_cmds : EvalCmds P (EvalCmd P) δ σ cs σ' f) : + StepCFGStar P (EvalCmd P) extendEval cfg + (.atBlock t σ f_base) + (.terminal σ' (f_base || f)) := by + have h_fetch : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.atBlock t σ f_base) + (.inBlock t cs (.finish md) σ f_base) := + StepCFG.fetch (extendEval := extendEval) h_lkp + have h_chain := EvalCmds_to_StepCFG_chain (extendEval := extendEval) + (cfg := cfg) h_cmds t (.finish md) f_base + have h_finish : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.inBlock t [] (.finish md) σ' (f_base || f)) + (.terminal σ' (f_base || f)) := + StepCFG.finish (extendEval := extendEval) + exact ReflTrans.step _ _ _ h_fetch + (ReflTrans_Transitive _ _ _ _ h_chain + (ReflTrans.step _ _ _ h_finish (ReflTrans.refl _))) + +/-! ## Temporary -/ + +theorem stmts_nil_terminal {P : PureExpr} [HasBool P] [HasNot P] + {CmdT : Type} + (EvalCmdR : EvalCmdParam P CmdT) + (extendEval : ExtendEval P) + (ρ₀ ρ' : Env P) + (h : StepStmtStar P EvalCmdR extendEval (.stmts [] ρ₀) (.terminal ρ')) : + ρ₀ = ρ' := by + rcases h + rename_i h₁ h₂ h₃ + cases h₂ + cases h₃ + · rfl + · rename_i h₁ _ + cases h₁ + +theorem EvalCmds_snoc {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + (δ : SemanticEval P) (σ σ' σ'' : SemanticStore P) + (cs : List (Cmd P)) (c : Cmd P) (f₁ f₂ : Bool) + (h₁ : EvalCmds P (@EvalCmd P _ _ _ _) δ σ cs σ' f₁) + (h₂ : @EvalCmd P _ _ _ _ δ σ' c σ'' f₂) : + EvalCmds P (@EvalCmd P _ _ _ _) δ σ (cs ++ [c]) σ'' (f₁ || f₂) := by + induction cs generalizing σ f₁ with + | nil => + cases h₁ + simp + have : f₂ = (f₂ || false) := by simp + rw [this] + exact EvalCmds.eval_cmds_some h₂ EvalCmds.eval_cmds_none + | cons c' cs' ih => + cases h₁ with + | eval_cmds_some hcmd hrest => + simp only [List.cons_append] + rw [Bool.or_assoc] + exact EvalCmds.eval_cmds_some hcmd (ih _ _ hrest) + +theorem EvalCmds_inv {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + (δ : SemanticEval P) (σ σ' : SemanticStore P) (f : Bool) + (h : EvalCmds P (@EvalCmd P _ _ _ _) δ σ [] σ' f) : + σ = σ' ∧ f = false := by + cases h; + exact ⟨ rfl, rfl ⟩ + +/-! ## Agreement-preserving replay of `EvalCmd` / `EvalCmds` + +A structured-side `EvalCmd c σ_struct₀ σ_struct₁ failed` can be replayed on +a CFG-side store `σ_cfg₀` that agrees with `σ_struct₀` (in the +`StoreAgreement` sense), yielding some `σ_cfg₁` that agrees with `σ_struct₁`. + +For the `eval_init` case, we additionally require that the variable being +initialized is fresh in `σ_cfg₀` (otherwise the CFG-side `InitState` +constructor cannot fire). At the higher-level chained version +(`EvalCmds_under_agreement`), this freshness is supplied by `Block.uniqueInits` ++ the property that any `init` only succeeds if the variable was unset. +-/ + +/-- Pointwise equality of two stores on the variables of a single expression +follows from `StoreAgreement` plus `isDefined` of those variables. -/ +private theorem store_agreement_pointwise_on_expr_vars + {P : PureExpr} [HasVarsPure P P.Expr] + (σ_struct σ_cfg : SemanticStore P) (e : P.Expr) + (h_agree : StoreAgreement σ_struct σ_cfg) + (h_def : isDefined σ_struct (HasVarsPure.getVars e)) : + ∀ x ∈ HasVarsPure.getVars e, σ_struct x = σ_cfg x := by + intro x hx + have h_def_x : isDefined σ_struct [x] := by + intro v hv + rw [List.mem_singleton] at hv + rw [hv] + exact h_def x hx + exact h_agree x h_def_x + +private theorem Cmds.definedVars_cons + {P : PureExpr} (c : Cmd P) (cs : List (Cmd P)) : + Cmds.definedVars (c :: cs) = Cmd.definedVars c ++ Cmds.definedVars cs := by + rw [Cmds.definedVars.eq_def] + +private theorem Cmds.modifiedVars_cons + {P : PureExpr} (c : Cmd P) (cs : List (Cmd P)) : + Cmds.modifiedVars (c :: cs) = Cmd.modifiedVars c ++ Cmds.modifiedVars cs := by + rw [Cmds.modifiedVars.eq_def] + +-- Local exposed mirror of `Block.modifiedVars` from `Stmt.lean` for the +-- transform proof. The library version is not `@[expose]`, which prevents +-- unfolding inside this file's mutual block. This local version is +-- `@[expose]` so its match cases are definitionally available. +-- Defined as `transformModVars` to avoid namespace clash with the library. +mutual +@[expose] def transformStmtModVars {P : PureExpr} : + Stmt P (Cmd P) → List P.Ident + | .cmd c => Cmd.modifiedVars c + | .block _ bss _ => transformBlockModVars bss + | .ite _ tss ess _ => transformBlockModVars tss ++ transformBlockModVars ess + | .loop _ _ _ bss _ => transformBlockModVars bss + | .exit _ _ => [] + | .funcDecl _ _ => [] + | .typeDecl _ _ => [] +@[expose] def transformBlockModVars {P : PureExpr} : + List (Stmt P (Cmd P)) → List P.Ident + | [] => [] + | s :: rest => transformStmtModVars s ++ transformBlockModVars rest +end + +-- Equation lemmas for transformStmtModVars / transformBlockModVars +-- (definitional via @[expose]). +private theorem transformBlockModVars_cons {P : PureExpr} + (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) : + transformBlockModVars (s :: rest) = + transformStmtModVars s ++ transformBlockModVars rest := rfl + +private theorem transformStmtModVars_cmd {P : PureExpr} (c : Cmd P) : + transformStmtModVars (P := P) (Stmt.cmd c) = Cmd.modifiedVars c := rfl + +private theorem transformStmtModVars_block {P : PureExpr} + (label : String) (body : List (Stmt P (Cmd P))) (md : MetaData P) : + transformStmtModVars (P := P) (Stmt.block label body md) = + transformBlockModVars body := rfl + +private theorem transformStmtModVars_ite {P : PureExpr} + (c : ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) : + transformStmtModVars (P := P) (Stmt.ite c tss ess md) = + transformBlockModVars tss ++ transformBlockModVars ess := rfl + +private theorem transformStmtModVars_typeDecl {P : PureExpr} + (tc : TypeConstructor) (md : MetaData P) : + transformStmtModVars (P := P) (Stmt.typeDecl tc md : Stmt P (Cmd P)) = [] := rfl + +/-- Single-command agreement-preservation. -/ +private theorem EvalCmd_under_agreement {P : PureExpr} + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + (δ : SemanticEval P) (σ_struct₀ σ_cfg₀ : SemanticStore P) + (c : Cmd P) (σ_struct₁ : SemanticStore P) (failed : Bool) + (h_agree : StoreAgreement σ_struct₀ σ_cfg₀) + (h_eval : @EvalCmd P _ _ _ _ δ σ_struct₀ c σ_struct₁ failed) + (h_wf_def : WellFormedSemanticEvalDef δ) + (h_congr : WellFormedSemanticEvalExprCongr δ) + (h_fresh : ∀ x ∈ Cmd.definedVars c, σ_cfg₀ x = none) : + ∃ σ_cfg₁, @EvalCmd P _ _ _ _ δ σ_cfg₀ c σ_cfg₁ failed + ∧ StoreAgreement σ_struct₁ σ_cfg₁ := by + cases h_eval with + | eval_init heval hinit hwfvar hwfcongr => + -- Constructor: EvalCmd δ σ_struct₀ (.init x ty (.det e) md) σ_struct₁ false + -- rename_i introduces in order: ty, md, x, v, e + rename_i ty md x v e + -- Need δ σ_cfg₀ e = some v. Use congr + agreement on e's vars. + have h_def_e : isDefined σ_struct₀ (HasVarsPure.getVars e) := + h_wf_def e v σ_struct₀ heval + have h_pointwise : + ∀ y ∈ HasVarsPure.getVars e, σ_struct₀ y = σ_cfg₀ y := + store_agreement_pointwise_on_expr_vars σ_struct₀ σ_cfg₀ e h_agree h_def_e + have h_eval_cfg : δ σ_cfg₀ e = .some v := by + rw [← heval]; exact (h_congr e σ_struct₀ σ_cfg₀ h_pointwise).symm + -- Witness σ_cfg₁ + let σ_cfg₁ : SemanticStore P := fun y => if y = x then some v else σ_cfg₀ y + have h_x_fresh : σ_cfg₀ x = none := by + apply h_fresh x + have h_dv_eq : Cmd.definedVars (Cmd.init x ty (ExprOrNondet.det e) md) = [x] := by + with_unfolding_all rfl + rw [h_dv_eq] + exact List.mem_singleton.mpr rfl + have h_cfg_x : σ_cfg₁ x = some v := by + show (if x = x then some v else σ_cfg₀ x) = some v + simp + have h_cfg_other : ∀ y, x ≠ y → σ_cfg₁ y = σ_cfg₀ y := by + intro y hxy + show (if y = x then some v else σ_cfg₀ y) = σ_cfg₀ y + have hne : ¬ (y = x) := fun h => hxy h.symm + rw [if_neg hne] + have h_init_cfg : InitState P σ_cfg₀ x v σ_cfg₁ := + InitState.init h_x_fresh h_cfg_x h_cfg_other + refine ⟨σ_cfg₁, EvalCmd.eval_init h_eval_cfg h_init_cfg hwfvar hwfcongr, ?_⟩ + -- StoreAgreement σ_struct₁ σ_cfg₁ + intro y h_def_y + cases hinit with + | init h_xn h_xv h_other => + by_cases hyx : y = x + · subst hyx + rw [h_xv, h_cfg_x] + · have h_struct_y : σ_struct₁ y = σ_struct₀ y := h_other y (fun h => hyx h.symm) + have h_cfg_y : σ_cfg₁ y = σ_cfg₀ y := h_cfg_other y (fun h => hyx h.symm) + rw [h_struct_y, h_cfg_y] + have h_def_y' : isDefined σ_struct₀ [y] := by + intro w hw + rw [List.mem_singleton] at hw + rw [hw] + have h_y_def_in_σ' : (σ_struct₁ y).isSome = true := + h_def_y y (List.mem_singleton.mpr rfl) + exact h_struct_y ▸ h_y_def_in_σ' + exact h_agree y h_def_y' + | eval_init_unconstrained hinit hwfvar => + rename_i ty md x v + let σ_cfg₁ : SemanticStore P := fun y => if y = x then some v else σ_cfg₀ y + have h_x_fresh : σ_cfg₀ x = none := by + apply h_fresh x + have h_dv_eq : Cmd.definedVars (Cmd.init x ty ExprOrNondet.nondet md) = [x] := by + with_unfolding_all rfl + rw [h_dv_eq] + exact List.mem_singleton.mpr rfl + have h_cfg_x : σ_cfg₁ x = some v := by + show (if x = x then some v else σ_cfg₀ x) = some v + simp + have h_cfg_other : ∀ y, x ≠ y → σ_cfg₁ y = σ_cfg₀ y := by + intro y hxy + show (if y = x then some v else σ_cfg₀ y) = σ_cfg₀ y + have hne : ¬ (y = x) := fun h => hxy h.symm + rw [if_neg hne] + have h_init_cfg : InitState P σ_cfg₀ x v σ_cfg₁ := + InitState.init h_x_fresh h_cfg_x h_cfg_other + refine ⟨σ_cfg₁, EvalCmd.eval_init_unconstrained h_init_cfg hwfvar, ?_⟩ + intro y h_def_y + cases hinit with + | init h_xn h_xv h_other => + by_cases hyx : y = x + · subst hyx + rw [h_xv, h_cfg_x] + · have h_struct_y : σ_struct₁ y = σ_struct₀ y := h_other y (fun h => hyx h.symm) + have h_cfg_y : σ_cfg₁ y = σ_cfg₀ y := h_cfg_other y (fun h => hyx h.symm) + rw [h_struct_y, h_cfg_y] + have h_def_y' : isDefined σ_struct₀ [y] := by + intro w hw + rw [List.mem_singleton] at hw + rw [hw] + have h_y_def_in_σ' : (σ_struct₁ y).isSome = true := + h_def_y y (List.mem_singleton.mpr rfl) + exact h_struct_y ▸ h_y_def_in_σ' + exact h_agree y h_def_y' + | eval_set heval hupdate hwfvar hwfcongr => + rename_i md x v e + have h_def_e : isDefined σ_struct₀ (HasVarsPure.getVars e) := + h_wf_def e v σ_struct₀ heval + have h_pointwise : + ∀ y ∈ HasVarsPure.getVars e, σ_struct₀ y = σ_cfg₀ y := + store_agreement_pointwise_on_expr_vars σ_struct₀ σ_cfg₀ e h_agree h_def_e + have h_eval_cfg : δ σ_cfg₀ e = .some v := by + rw [← heval]; exact (h_congr e σ_struct₀ σ_cfg₀ h_pointwise).symm + cases hupdate with + | update h_xv' h_xv h_other => + rename_i v' + have h_x_def_struct : isDefined σ_struct₀ [x] := by + intro y hy + rw [List.mem_singleton] at hy + rw [hy, h_xv'] + rfl + have h_cfg_x_old : σ_cfg₀ x = some v' := by + have h_eq : σ_struct₀ x = σ_cfg₀ x := h_agree x h_x_def_struct + rw [← h_eq]; exact h_xv' + let σ_cfg₁ : SemanticStore P := fun y => if y = x then some v else σ_cfg₀ y + have h_cfg_x_new : σ_cfg₁ x = some v := by + show (if x = x then some v else σ_cfg₀ x) = some v + simp + have h_cfg_other : ∀ y, x ≠ y → σ_cfg₁ y = σ_cfg₀ y := by + intro y hxy + show (if y = x then some v else σ_cfg₀ y) = σ_cfg₀ y + have hne : ¬ (y = x) := fun h => hxy h.symm + rw [if_neg hne] + have h_upd : UpdateState P σ_cfg₀ x v σ_cfg₁ := + UpdateState.update h_cfg_x_old h_cfg_x_new h_cfg_other + refine ⟨σ_cfg₁, EvalCmd.eval_set h_eval_cfg h_upd hwfvar hwfcongr, ?_⟩ + intro y h_def_y + by_cases hyx : y = x + · subst hyx + rw [h_xv, h_cfg_x_new] + · have h_struct_y : σ_struct₁ y = σ_struct₀ y := h_other y (fun h => hyx h.symm) + have h_cfg_y : σ_cfg₁ y = σ_cfg₀ y := h_cfg_other y (fun h => hyx h.symm) + rw [h_struct_y, h_cfg_y] + have h_def_y' : isDefined σ_struct₀ [y] := by + intro w hw + rw [List.mem_singleton] at hw + rw [hw] + have h_y_def_in_σ' : (σ_struct₁ y).isSome = true := + h_def_y y (List.mem_singleton.mpr rfl) + exact h_struct_y ▸ h_y_def_in_σ' + exact h_agree y h_def_y' + | eval_set_nondet hupdate hwfvar => + rename_i md x v + cases hupdate with + | update h_xv' h_xv h_other => + rename_i v' + have h_x_def_struct : isDefined σ_struct₀ [x] := by + intro y hy + rw [List.mem_singleton] at hy + rw [hy, h_xv'] + rfl + have h_cfg_x_old : σ_cfg₀ x = some v' := by + have h_eq : σ_struct₀ x = σ_cfg₀ x := h_agree x h_x_def_struct + rw [← h_eq]; exact h_xv' + let σ_cfg₁ : SemanticStore P := fun y => if y = x then some v else σ_cfg₀ y + have h_cfg_x_new : σ_cfg₁ x = some v := by + show (if x = x then some v else σ_cfg₀ x) = some v + simp + have h_cfg_other : ∀ y, x ≠ y → σ_cfg₁ y = σ_cfg₀ y := by + intro y hxy + show (if y = x then some v else σ_cfg₀ y) = σ_cfg₀ y + have hne : ¬ (y = x) := fun h => hxy h.symm + rw [if_neg hne] + have h_upd : UpdateState P σ_cfg₀ x v σ_cfg₁ := + UpdateState.update h_cfg_x_old h_cfg_x_new h_cfg_other + refine ⟨σ_cfg₁, EvalCmd.eval_set_nondet h_upd hwfvar, ?_⟩ + intro y h_def_y + by_cases hyx : y = x + · subst hyx + rw [h_xv, h_cfg_x_new] + · have h_struct_y : σ_struct₁ y = σ_struct₀ y := h_other y (fun h => hyx h.symm) + have h_cfg_y : σ_cfg₁ y = σ_cfg₀ y := h_cfg_other y (fun h => hyx h.symm) + rw [h_struct_y, h_cfg_y] + have h_def_y' : isDefined σ_struct₀ [y] := by + intro w hw + rw [List.mem_singleton] at hw + rw [hw] + have h_y_def_in_σ' : (σ_struct₁ y).isSome = true := + h_def_y y (List.mem_singleton.mpr rfl) + exact h_struct_y ▸ h_y_def_in_σ' + exact h_agree y h_def_y' + | eval_assert_pass hcond hwfb hwfcongr => + rename_i l md e + have h_def_e : isDefined σ_struct₀ (HasVarsPure.getVars e) := + h_wf_def e HasBool.tt σ_struct₀ hcond + have h_pointwise : + ∀ y ∈ HasVarsPure.getVars e, σ_struct₀ y = σ_cfg₀ y := + store_agreement_pointwise_on_expr_vars σ_struct₀ σ_cfg₀ e h_agree h_def_e + have h_eval_cfg : δ σ_cfg₀ e = .some HasBool.tt := by + rw [← hcond]; exact (h_congr e σ_struct₀ σ_cfg₀ h_pointwise).symm + exact ⟨σ_cfg₀, EvalCmd.eval_assert_pass h_eval_cfg hwfb hwfcongr, h_agree⟩ + | eval_assert_fail hcond hwfb hwfcongr => + rename_i l md e + have h_def_e : isDefined σ_struct₀ (HasVarsPure.getVars e) := + h_wf_def e HasBool.ff σ_struct₀ hcond + have h_pointwise : + ∀ y ∈ HasVarsPure.getVars e, σ_struct₀ y = σ_cfg₀ y := + store_agreement_pointwise_on_expr_vars σ_struct₀ σ_cfg₀ e h_agree h_def_e + have h_eval_cfg : δ σ_cfg₀ e = .some HasBool.ff := by + rw [← hcond]; exact (h_congr e σ_struct₀ σ_cfg₀ h_pointwise).symm + exact ⟨σ_cfg₀, EvalCmd.eval_assert_fail h_eval_cfg hwfb hwfcongr, h_agree⟩ + | eval_assume hcond hwfb hwfcongr => + rename_i l md e + have h_def_e : isDefined σ_struct₀ (HasVarsPure.getVars e) := + h_wf_def e HasBool.tt σ_struct₀ hcond + have h_pointwise : + ∀ y ∈ HasVarsPure.getVars e, σ_struct₀ y = σ_cfg₀ y := + store_agreement_pointwise_on_expr_vars σ_struct₀ σ_cfg₀ e h_agree h_def_e + have h_eval_cfg : δ σ_cfg₀ e = .some HasBool.tt := by + rw [← hcond]; exact (h_congr e σ_struct₀ σ_cfg₀ h_pointwise).symm + exact ⟨σ_cfg₀, EvalCmd.eval_assume h_eval_cfg hwfb hwfcongr, h_agree⟩ + | eval_cover hwfb => + exact ⟨σ_cfg₀, EvalCmd.eval_cover hwfb, h_agree⟩ + +/-- A helper: if `EvalCmd c σ σ' f` succeeds and `x` is not in `c`'s definedVars +(so `c` does not init x), and `σ x = none`, then `σ' x = none`. This holds because +`c` either doesn't touch x, or modifies x via `set` (which requires `σ x = some _`, +contradicting `σ x = none`). -/ +private theorem agreement_helper_unchanged_at_x {P : PureExpr} + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {δ : SemanticEval P} {σ σ' : SemanticStore P} {c : Cmd P} {failed : Bool} + {x : P.Ident} + (h_eval : @EvalCmd P _ _ _ _ δ σ c σ' failed) + (h_x_not_def : x ∉ Cmd.definedVars c) + (h_σ_x : σ x = none) : + σ' x = none := by + cases h_eval with + | eval_init heval hinit hwfvar hwfcongr => + cases hinit with + | init h_xn h_xv h_other => + -- After cases on hinit, anonymous vars (from EvalCmd's eval_init constructor): + -- `x✝² : P.Ty`, `x✝¹ : MetaData`, `x✝ : P.Ident`, `v✝ e✝ : P.Expr`. + rename_i ty md x_init v e + have h_x_ne : x_init ≠ x := by + intro h_eq + apply h_x_not_def + show x ∈ Cmd.definedVars (Cmd.init x_init ty (ExprOrNondet.det e) md) + have h_dv : + Cmd.definedVars (Cmd.init x_init ty (ExprOrNondet.det e) md) = [x_init] := by + with_unfolding_all rfl + rw [h_dv, h_eq] + exact List.mem_singleton.mpr rfl + rw [h_other x h_x_ne]; exact h_σ_x + | eval_init_unconstrained hinit hwfvar => + cases hinit with + | init h_xn h_xv h_other => + rename_i ty md x_init v + have h_x_ne : x_init ≠ x := by + intro h_eq + apply h_x_not_def + show x ∈ Cmd.definedVars (Cmd.init x_init ty ExprOrNondet.nondet md) + have h_dv : + Cmd.definedVars (Cmd.init x_init ty ExprOrNondet.nondet md) = [x_init] := by + with_unfolding_all rfl + rw [h_dv, h_eq] + exact List.mem_singleton.mpr rfl + rw [h_other x h_x_ne]; exact h_σ_x + | eval_set heval hupdate hwfvar hwfcongr => + cases hupdate with + | update h_xv' h_xv h_other => + rename_i md x_set v e v' + by_cases h_eq : x_set = x + · subst h_eq + rw [h_σ_x] at h_xv' + cases h_xv' + · rw [h_other x h_eq]; exact h_σ_x + | eval_set_nondet hupdate hwfvar => + cases hupdate with + | update h_xv' h_xv h_other => + rename_i md x_set v v' + by_cases h_eq : x_set = x + · subst h_eq + rw [h_σ_x] at h_xv' + cases h_xv' + · rw [h_other x h_eq]; exact h_σ_x + | eval_assert_pass _ _ _ => exact h_σ_x + | eval_assert_fail _ _ _ => exact h_σ_x + | eval_assume _ _ _ => exact h_σ_x + | eval_cover _ => exact h_σ_x + +/-- Multi-command extension of `agreement_helper_unchanged_at_x`: if `EvalCmds` +takes σ to σ' over a list `cmds`, and `x` is not in `cmds.definedVars`, and +`σ x = none`, then `σ' x = none`. By induction on `EvalCmds`. -/ +private theorem agreement_helper_unchanged_at_x_multi {P : PureExpr} + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {δ : SemanticEval P} {σ σ' : SemanticStore P} {cmds : List (Cmd P)} {failed : Bool} + {x : P.Ident} + (h_eval : EvalCmds P (@EvalCmd P _ _ _ _) δ σ cmds σ' failed) + (h_x_not_def : x ∉ Cmds.definedVars cmds) + (h_σ_x : σ x = none) : + σ' x = none := by + induction h_eval with + | eval_cmds_none => exact h_σ_x + | eval_cmds_some hcmd hrest ih => + rename_i σ_a c σ_b _ cs σ_c _ + -- σ_a x = none, want σ_c x = none + -- step 1: σ_b x = none from single-cmd helper + have h_x_not_in_head : x ∉ Cmd.definedVars c := by + intro h_x_in_head + apply h_x_not_def + rw [Cmds.definedVars_cons] + exact List.mem_append_left _ h_x_in_head + have h_σ_b_x : σ_b x = none := + agreement_helper_unchanged_at_x hcmd h_x_not_in_head h_σ_x + -- step 2: σ_c x = none from inductive hypothesis on rest + have h_x_not_in_tail : x ∉ Cmds.definedVars cs := by + intro h_x_in_tail + apply h_x_not_def + rw [Cmds.definedVars_cons] + exact List.mem_append_right _ h_x_in_tail + exact ih h_x_not_in_tail h_σ_b_x + +/-- Multi-command agreement-preservation, by induction on `cs`. -/ +private theorem EvalCmds_under_agreement {P : PureExpr} + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + (δ : SemanticEval P) + (cs : List (Cmd P)) + (h_wf_def : WellFormedSemanticEvalDef δ) + (h_congr : WellFormedSemanticEvalExprCongr δ) : + ∀ (σ_struct₀ σ_cfg₀ σ_struct₁ : SemanticStore P) (failed : Bool), + StoreAgreement σ_struct₀ σ_cfg₀ → + EvalCmds P (@EvalCmd P _ _ _ _) δ σ_struct₀ cs σ_struct₁ failed → + (∀ x ∈ Cmds.definedVars cs, σ_cfg₀ x = none) → + (Cmds.definedVars cs).Nodup → + ∃ σ_cfg₁, EvalCmds P (@EvalCmd P _ _ _ _) δ σ_cfg₀ cs σ_cfg₁ failed + ∧ StoreAgreement σ_struct₁ σ_cfg₁ := by + induction cs with + | nil => + intro σ_struct₀ σ_cfg₀ σ_struct₁ failed h_agree h_eval _ _ + cases h_eval + exact ⟨σ_cfg₀, EvalCmds.eval_cmds_none, h_agree⟩ + | cons c cs ih => + intro σ_struct₀ σ_cfg₀ σ_struct₁ failed h_agree h_eval h_fresh h_unique + cases h_eval with + | eval_cmds_some hcmd hrest => + rename_i σ_mid f f' + have h_fresh_head : ∀ x ∈ Cmd.definedVars c, σ_cfg₀ x = none := by + intro x hx + have hx' : x ∈ Cmds.definedVars (c :: cs) := by + rw [Cmds.definedVars_cons] + exact List.mem_append_left _ hx + exact h_fresh x hx' + have h_fresh_tail_init : ∀ x ∈ Cmds.definedVars cs, σ_cfg₀ x = none := by + intro x hx + have hx' : x ∈ Cmds.definedVars (c :: cs) := by + rw [Cmds.definedVars_cons] + exact List.mem_append_right _ hx + exact h_fresh x hx' + -- Apply EvalCmd_under_agreement to head cmd c. + have ⟨σ_cfg_mid, h_cmd_cfg, h_agree_mid⟩ := + EvalCmd_under_agreement δ σ_struct₀ σ_cfg₀ c σ_mid f h_agree hcmd h_wf_def h_congr + h_fresh_head + -- Now we need σ_cfg_mid to satisfy the freshness for the tail cs. + have h_fresh_tail : ∀ x ∈ Cmds.definedVars cs, σ_cfg_mid x = none := by + intro x hx + have h_x_not_in_head : x ∉ Cmd.definedVars c := by + intro h_x_in_head + have h_nodup_split : + ∀ a ∈ Cmd.definedVars c, ∀ b ∈ Cmds.definedVars cs, a ≠ b := by + have h_unique' : (Cmds.definedVars (c :: cs)).Nodup := h_unique + rw [Cmds.definedVars_cons] at h_unique' + exact (List.nodup_append.mp h_unique').2.2 + exact h_nodup_split x h_x_in_head x hx rfl + have h_cfg₀_x : σ_cfg₀ x = none := h_fresh_tail_init x hx + exact agreement_helper_unchanged_at_x h_cmd_cfg h_x_not_in_head h_cfg₀_x + have h_unique_tail : (Cmds.definedVars cs).Nodup := by + have : (Cmds.definedVars (c :: cs)).Nodup := h_unique + rw [Cmds.definedVars_cons] at this + exact (List.nodup_append.mp this).2.1 + have ⟨σ_cfg_end, h_rest_cfg, h_agree_end⟩ := + ih σ_mid σ_cfg_mid σ_struct₁ f' h_agree_mid hrest h_fresh_tail + h_unique_tail + exact ⟨σ_cfg_end, EvalCmds.eval_cmds_some h_cmd_cfg h_rest_cfg, h_agree_end⟩ + +theorem single_cmd_eval {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (c : Cmd P) (ρ₀ ρ₁ : Env P) + (h : StepStmtStar P (@EvalCmd P _ _ _ _) extendEval + (.stmts [.cmd c] ρ₀) (.terminal ρ₁)) : + ∃ σ' failed, @EvalCmd P _ _ _ _ ρ₀.eval ρ₀.store c σ' failed ∧ + ρ₁.store = σ' ∧ ρ₁.eval = ρ₀.eval ∧ + ρ₁.hasFailure = (ρ₀.hasFailure || failed) := by + cases h with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have ⟨ρ_mid, h_inner, h_tail⟩ := seq_reaches_terminal P (@EvalCmd P _ _ _ _) extendEval hrest1 + have h_eq := stmts_nil_terminal (@EvalCmd P _ _ _ _) extendEval _ _ h_tail + subst h_eq + cases h_inner with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_cmd heval => + cases hrest2 with + | refl => exact ⟨_, _, heval, rfl, rfl, rfl⟩ + | step _ _ _ hstep3 _ => exact absurd hstep3 (by intro h; cases h) + +/-! ## Sub-theorems for ite case -/ + +/-- If a list of pairs has unique keys (Nodup), then membership implies +the key can be looked up to find the corresponding value. -/ +private theorem List.lookup_of_mem_nodup + {α β : Type} [BEq α] [LawfulBEq α] (l : List (α × β)) + (h_nodup : (l.map Prod.fst).Nodup) + (k : α) (v : β) + (h_mem : (k, v) ∈ l) : + l.lookup k = some v := by + induction l with + | nil => cases h_mem + | cons hd tl ih => + obtain ⟨k', v'⟩ := hd + rw [List.mem_cons] at h_mem + rcases h_mem with h_eq | h_tl + · simp [List.lookup]; injection h_eq with h1 h2; subst h1; subst h2; simp + · simp at h_nodup + obtain ⟨h_not_in, h_nodup_tl⟩ := h_nodup + have h_neq : ¬(k == k') = true := by + intro h_eq + rw [beq_iff_eq] at h_eq + subst h_eq + exact h_not_in v h_tl + simp [List.lookup, h_neq] + exact ih h_nodup_tl h_tl + +/-! ### Invariant about `stmtsToBlocks` and `flushCmds` + +`GenInv gen gen' blocks` packages the invariant tying together a +`StringGenState` transition `gen → gen'` with the produced `blocks`. It +extends `StringGenState.GenStep` (well-formedness preservation + monotone +label list) with two block-specific properties: +- every block label was generated during this call (fresh w.r.t. `gen`), +- block labels are pairwise distinct. -/ + +/-- The invariant for `stmtsToBlocks` / `flushCmds` outputs. + +`GenInv gen gen' userLabels blocks` means: starting in state `gen`, the +computation produced state `gen'` and emitted `blocks`, where every block +label is either freshly generated (in `stringGens gen' \ stringGens gen`) +or one of the supplied `userLabels` (provided by the user via `Stmt.block`). + +`userLabels` is a list of user-supplied strings, all of which: +- are shape-free (no `_` suffix), and +- are not in `stringGens gen'` (hence not in `stringGens gen` either), +- are pairwise distinct. + +This lets the `Stmt.block` case introduce a user label into the output +without breaking the freshness/Nodup tracking. -/ +private structure GenInv {P : PureExpr} (gen gen' : StringGenState) + (userLabels : List String) + (blocks : List (String × DetBlock String (Cmd P) P)) : Prop + extends StringGenState.GenStep gen gen' where + /-- WF is preserved (and hence we also get WF gen' = wf_mono of gen). -/ + wf_in : StringGenState.WF gen + /-- Every user label is shape-free. -/ + user_shape : ∀ l ∈ userLabels, ¬ String.HasUnderscoreDigitSuffix l + /-- Every user label is absent from `stringGens gen'`. -/ + user_disj : ∀ l ∈ userLabels, l ∉ StringGenState.stringGens gen' + /-- User labels are pairwise distinct. -/ + user_nodup : userLabels.Nodup + /-- Each block label is either generated by this call or one of the user labels. -/ + fresh : ∀ l ∈ blocks.map Prod.fst, + (l ∈ StringGenState.stringGens gen' ∧ l ∉ StringGenState.stringGens gen) + ∨ l ∈ userLabels + /-- Block labels are pairwise distinct. -/ + nodup : (blocks.map Prod.fst).Nodup + +/-- Convenience: `WF gen'` follows from `GenInv` (since `WF gen` is carried +and `gen → gen'` is a `GenStep`). -/ +private theorem GenInv.wf_out {P : PureExpr} + {gen gen' : StringGenState} {userLabels : List String} + {blocks : List (String × DetBlock String (Cmd P) P)} + (h : @GenInv P gen gen' userLabels blocks) : + StringGenState.WF gen' := + h.wf_mono h.wf_in + +/-- A shape-free user label is never in `stringGens` of any WF state. -/ +private theorem userLabel_not_in_stringGens_of_shape_free + {σ : StringGenState} (hwf : StringGenState.WF σ) + {l : String} (h_shape : ¬ String.HasUnderscoreDigitSuffix l) : + l ∉ StringGenState.stringGens σ := + StringGenState.not_mem_stringGens_of_not_hasUnderscoreDigitSuffix hwf h_shape + +/-- The invariant for `flushCmds`: emitted blocks have fresh, unique labels. +`flushCmds` produces no user-labeled blocks, so `userLabels = []`. -/ +private theorem flushCmds_invariant {P : PureExpr} [HasBool P] + (pfx : String) (accum : List (Cmd P)) + (tr? : Option (DetTransferCmd String P)) (k : String) + (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P) + (h_gen : flushCmds pfx accum tr? k gen = ((entry, blocks), gen')) + (hwf : StringGenState.WF gen) : + @GenInv P gen gen' [] blocks := by + unfold flushCmds at h_gen + cases h_tr : tr? with + | none => + rw [h_tr] at h_gen + simp only at h_gen + by_cases h_empty : accum.isEmpty + · rw [if_pos h_empty] at h_gen + simp only [pure, StateT.pure] at h_gen + injection h_gen with h_pair h_gen_eq + injection h_pair with h_entry_eq h_blocks_eq + subst h_blocks_eq; subst h_gen_eq + refine ⟨StringGenState.GenStep.refl _, hwf, ?_, ?_, ?_, ?_, ?_⟩ + · intros l hl; simp at hl + · intros l hl; simp at hl + · simp + · intros l hl; simp at hl + · simp + · rw [if_neg h_empty] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure, Id] at h_gen + injection h_gen with h_pair h_gen_eq + injection h_pair with h_entry_eq h_blocks_eq + subst h_entry_eq; subst h_blocks_eq; subst h_gen_eq + refine ⟨StringGenState.GenStep.of_gen pfx gen, hwf, ?_, ?_, ?_, ?_, ?_⟩ + · intros l hl; simp at hl + · intros l hl; simp at hl + · simp + · intro l hl + simp at hl; subst hl + left + refine ⟨?_, ?_⟩ + · rw [StringGenState.stringGens_gen]; exact List.mem_cons.mpr (Or.inl rfl) + · exact StringGenState.stringGens_gen_not_in pfx gen hwf + · simp + | some tr => + rw [h_tr] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure, Id] at h_gen + injection h_gen with h_pair h_gen_eq + injection h_pair with h_entry_eq h_blocks_eq + subst h_entry_eq; subst h_blocks_eq; subst h_gen_eq + refine ⟨StringGenState.GenStep.of_gen pfx gen, hwf, ?_, ?_, ?_, ?_, ?_⟩ + · intros l hl; simp at hl + · intros l hl; simp at hl + · simp + · intro l hl + simp at hl; subst hl + left + refine ⟨?_, ?_⟩ + · rw [StringGenState.stringGens_gen]; exact List.mem_cons.mpr (Or.inl rfl) + · exact StringGenState.stringGens_gen_not_in pfx gen hwf + · simp + +/-- Composition lemma: if both `gen → gen_mid` (with `blocks₁`) and +`gen_mid → gen'` (with `blocks₂`) satisfy `GenInv`, then `gen → gen'` +with `blocks₁ ++ blocks₂` does too. -/ +private theorem GenInv.trans {P : PureExpr} + (gen gen_mid gen' : StringGenState) + (userLabels₁ userLabels₂ : List String) + (blocks₁ blocks₂ : List (String × DetBlock String (Cmd P) P)) + (h₁ : @GenInv P gen gen_mid userLabels₁ blocks₁) + (h₂ : @GenInv P gen_mid gen' userLabels₂ blocks₂) + -- Cross-disjointness premise: user labels in the two halves don't overlap. + (h_user_disj : ∀ l ∈ userLabels₁, l ∉ userLabels₂) : + @GenInv P gen gen' (userLabels₁ ++ userLabels₂) (blocks₁ ++ blocks₂) := by + have hwf_mid : StringGenState.WF gen_mid := h₁.wf_out + have hwf_out : StringGenState.WF gen' := h₂.wf_out + refine ⟨h₁.toGenStep.trans h₂.toGenStep, h₁.wf_in, ?_, ?_, ?_, ?_, ?_⟩ + · -- user_shape + intro l hl + rw [List.mem_append] at hl + exact hl.elim (fun h => h₁.user_shape l h) (fun h => h₂.user_shape l h) + · -- user_disj: user labels are absent from stringGens gen'. + -- Shape-free + WF gen' ⇒ not in stringGens gen'. + intro l hl + rw [List.mem_append] at hl + have h_shape : ¬ String.HasUnderscoreDigitSuffix l := by + exact hl.elim (fun h => h₁.user_shape l h) (fun h => h₂.user_shape l h) + exact userLabel_not_in_stringGens_of_shape_free hwf_out h_shape + · -- user_nodup + rw [List.nodup_append] + refine ⟨h₁.user_nodup, h₂.user_nodup, ?_⟩ + intro x hx y hy h_eq + subst h_eq + exact h_user_disj x hx hy + · -- fresh + intro l hl + rw [List.map_append, List.mem_append] at hl + rcases hl with h | h + · rcases h₁.fresh l h with h_gen | h_user + · left + exact ⟨h₂.subset h_gen.1, h_gen.2⟩ + · right + exact List.mem_append.mpr (Or.inl h_user) + · rcases h₂.fresh l h with h_gen | h_user + · left + refine ⟨h_gen.1, ?_⟩ + intro h_in_gen + exact h_gen.2 (h₁.subset h_in_gen) + · right + exact List.mem_append.mpr (Or.inr h_user) + · -- nodup + rw [List.map_append, List.nodup_append] + refine ⟨h₁.nodup, h₂.nodup, ?_⟩ + intro x hx y hy h_eq + subst h_eq + rcases h₁.fresh x hx with h_x_gen₁ | h_x_user₁ + · rcases h₂.fresh x hy with h_x_gen₂ | h_x_user₂ + · exact h_x_gen₂.2 h_x_gen₁.1 + · -- x ∈ stringGens gen_mid (from h_x_gen₁.1) but x ∈ userLabels₂ (shape-free). + -- WF gen_mid + shape-free ⇒ x ∉ stringGens gen_mid. Contradiction. + exact (userLabel_not_in_stringGens_of_shape_free hwf_mid + (h₂.user_shape x h_x_user₂)) h_x_gen₁.1 |>.elim + · rcases h₂.fresh x hy with h_x_gen₂ | h_x_user₂ + · -- x ∈ userLabels₁ (shape-free), but x ∈ stringGens gen'. + -- WF gen' + shape-free ⇒ x ∉ stringGens gen'. Contradiction. + exact (userLabel_not_in_stringGens_of_shape_free hwf_out + (h₁.user_shape x h_x_user₁)) h_x_gen₂.1 |>.elim + · exact h_user_disj x h_x_user₁ h_x_user₂ + +/-- `GenInv` is closed under list permutation of the blocks (the freshness +and Nodup properties are permutation-invariant). -/ +private theorem GenInv.perm {P : PureExpr} + (gen gen' : StringGenState) + (userLabels : List String) + (blocks₁ blocks₂ : List (String × DetBlock String (Cmd P) P)) + (h : @GenInv P gen gen' userLabels blocks₁) + (hperm : blocks₁.Perm blocks₂) : + @GenInv P gen gen' userLabels blocks₂ := by + refine ⟨h.toGenStep, h.wf_in, h.user_shape, h.user_disj, h.user_nodup, ?_, ?_⟩ + · intro l hl + apply h.fresh + rw [List.Perm.mem_iff (List.Perm.map _ hperm)] + exact hl + · rw [(List.Perm.map _ hperm).nodup_iff.symm] + exact h.nodup + +/-- Convenience: extending `GenInv` by prepending a single new block whose +label was just generated by `gen` from `gen_mid`. -/ +private theorem GenInv.cons_gen {P : PureExpr} + (gen gen_mid gen' : StringGenState) + (userLabels : List String) + (blocks : List (String × DetBlock String (Cmd P) P)) + (l : String) (b : DetBlock String (Cmd P) P) + (hwf_gen : StringGenState.WF gen) + (h_step : StringGenState.GenStep gen gen_mid) + (h_blocks : @GenInv P gen_mid gen' userLabels blocks) + (h_l_in : l ∈ StringGenState.stringGens gen') + (h_l_notin_gen : l ∉ StringGenState.stringGens gen) + (h_l_notin_blocks : l ∉ blocks.map Prod.fst) : + @GenInv P gen gen' userLabels ((l, b) :: blocks) := by + refine ⟨h_step.trans h_blocks.toGenStep, hwf_gen, + h_blocks.user_shape, h_blocks.user_disj, h_blocks.user_nodup, ?_, ?_⟩ + · intro x hx + rw [List.map_cons, List.mem_cons] at hx + rcases hx with h_eq | h_in + · subst h_eq + exact .inl ⟨h_l_in, h_l_notin_gen⟩ + · rcases h_blocks.fresh _ h_in with h_gen | h_user + · refine .inl ⟨h_gen.1, ?_⟩ + intro hgen + exact h_gen.2 (h_step.subset hgen) + · exact .inr h_user + · rw [List.map_cons, List.nodup_cons] + exact ⟨h_l_notin_blocks, h_blocks.nodup⟩ + +/-- An empty-block invariant: a pure `GenStep gen gen'` (without emitting any +blocks or user labels) yields a trivial `GenInv`. Useful for absorbing +intermediate `gen` calls between sub-computations. -/ +private theorem GenInv.empty_step {P : PureExpr} + (gen gen' : StringGenState) + (hwf : StringGenState.WF gen) + (h_step : StringGenState.GenStep gen gen') : + @GenInv P gen gen' [] [] := by + refine ⟨h_step, hwf, ?_, ?_, ?_, ?_, ?_⟩ + · intro l hl; simp at hl + · intro l hl; simp at hl + · simp + · intro l hl; simp at hl + · simp + +/-- A more general `mapM_genStep` for any function in `StringGenM` whose +single-step behaviour is a `GenStep`. The lemma traces through the entire +list, building a `GenStep` from the initial state to the final state. -/ +private theorem mapM_genStep {α β : Type} + (f : α → LabelGen.StringGenM β) + (h_step : ∀ (a : α) (gen gen' : StringGenState) (b : β), + f a gen = (b, gen') → StringGenState.GenStep gen gen') + (xs : List α) + (gen gen' : StringGenState) (ys : List β) + (h_eq : xs.mapM f gen = (ys, gen')) : + StringGenState.GenStep gen gen' := by + -- Use List.mapM_cons / mapM_nil rewrites to reduce. + induction xs generalizing gen gen' ys with + | nil => + rw [List.mapM_nil] at h_eq + -- (pure []) gen = ([], gen) for the StateM monad + simp only [pure, StateT.pure] at h_eq + have h_gen' : gen = gen' := (Prod.mk.inj h_eq).2 + exact h_gen' ▸ StringGenState.GenStep.refl gen + | cons hd tl ih => + rw [List.mapM_cons] at h_eq + simp only [bind, StateT.bind, pure, StateT.pure] at h_eq + generalize h_f : f hd gen = r1 at h_eq + obtain ⟨y, gen_mid⟩ := r1 + simp only at h_eq + generalize h_tail : tl.mapM f gen_mid = r2 at h_eq + obtain ⟨ys', gen_end⟩ := r2 + simp only at h_eq + have h_gen' : gen_end = gen' := (Prod.mk.inj h_eq).2 + have h1 : StringGenState.GenStep gen gen_mid := h_step hd gen gen_mid y h_f + have h2 : StringGenState.GenStep gen_mid gen_end := + ih gen_mid gen_end ys' h_tail + exact h_gen' ▸ h1.trans h2 + +/-- Weakening: if `userLabels` shrinks (a sublist), the invariant still holds +provided the additional shape/disjointness/Nodup constraints transfer. The +common usage: a parent list of user labels is provided that includes the +actual user labels in `blocks` plus extras. -/ +private theorem GenInv.weaken_userLabels {P : PureExpr} + (gen gen' : StringGenState) + (userLabels userLabels' : List String) + (blocks : List (String × DetBlock String (Cmd P) P)) + (h : @GenInv P gen gen' userLabels blocks) + (h_subset : ∀ l ∈ userLabels, l ∈ userLabels') + (h_shape' : ∀ l ∈ userLabels', ¬ String.HasUnderscoreDigitSuffix l) + (h_disj' : ∀ l ∈ userLabels', l ∉ StringGenState.stringGens gen') + (h_nodup' : userLabels'.Nodup) : + @GenInv P gen gen' userLabels' blocks := by + refine ⟨h.toGenStep, h.wf_in, h_shape', h_disj', h_nodup', ?_, h.nodup⟩ + intro l hl + cases h.fresh l hl with + | inl h_gen => exact .inl h_gen + | inr h_user => exact .inr (h_subset l h_user) + +/-- Prepending a user-labeled block to `GenInv`. The new label `l` becomes +part of `userLabels` of the result. -/ +private theorem GenInv.cons_user {P : PureExpr} + (gen gen' : StringGenState) + (userLabels : List String) + (blocks : List (String × DetBlock String (Cmd P) P)) + (l : String) (b : DetBlock String (Cmd P) P) + (h_blocks : @GenInv P gen gen' userLabels blocks) + (h_l_shape : ¬ String.HasUnderscoreDigitSuffix l) + (h_l_notin_user : l ∉ userLabels) + (h_l_notin_blocks : l ∉ blocks.map Prod.fst) : + @GenInv P gen gen' (l :: userLabels) ((l, b) :: blocks) := by + have hwf_out := h_blocks.wf_out + refine ⟨h_blocks.toGenStep, h_blocks.wf_in, ?_, ?_, ?_, ?_, ?_⟩ + · intro x hx + rw [List.mem_cons] at hx + cases hx with + | inl h_eq => subst h_eq; exact h_l_shape + | inr h_in => exact h_blocks.user_shape x h_in + · intro x hx + rw [List.mem_cons] at hx + rcases hx with h_eq | h_in + · subst h_eq + exact userLabel_not_in_stringGens_of_shape_free hwf_out h_l_shape + · exact h_blocks.user_disj x h_in + · rw [List.nodup_cons] + exact ⟨h_l_notin_user, h_blocks.user_nodup⟩ + · intro x hx + rw [List.map_cons, List.mem_cons] at hx + rcases hx with h_eq | h_in + · subst h_eq + exact .inr (List.mem_cons.mpr (Or.inl rfl)) + · cases h_blocks.fresh _ h_in with + | inl h_gen => exact .inl h_gen + | inr h_user => exact .inr (List.mem_cons.mpr (Or.inr h_user)) + · rw [List.map_cons, List.nodup_cons] + exact ⟨h_l_notin_blocks, h_blocks.nodup⟩ + +/-- All user-provided `Stmt.block` labels appearing in a list of statements. +Uses a `where`-helper that recurses on the statement constructor; the helper +calls back into the list-level recursion for nested statement lists. -/ +@[expose] def Block.userBlockLabels {P : PureExpr} : + List (Stmt P (Cmd P)) → List String + | [] => [] + | s :: rest => stmtUserBlockLabels s ++ Block.userBlockLabels rest +where + stmtUserBlockLabels : Stmt P (Cmd P) → List String + | .block l ss _ => l :: Block.userBlockLabels ss + | .ite _ tss ess _ => Block.userBlockLabels tss ++ Block.userBlockLabels ess + | .loop _ _ _ ss _ => Block.userBlockLabels ss + | _ => [] + +/-! Equational lemmas for `userBlockLabels` (proved via `unfold`). -/ + +theorem Block.userBlockLabels_block_cons {P : PureExpr} + (l : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) : + Block.userBlockLabels (.block l bss md :: rest) = + (l :: Block.userBlockLabels bss) ++ Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +theorem Block.userBlockLabels_ite_cons {P : PureExpr} + (c : Imperative.ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) + (md : MetaData P) (rest : List (Stmt P (Cmd P))) : + Block.userBlockLabels (.ite c tss ess md :: rest) = + (Block.userBlockLabels tss ++ Block.userBlockLabels ess) + ++ Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +theorem Block.userBlockLabels_loop_cons {P : PureExpr} + (c : Imperative.ExprOrNondet P) (m : Option P.Expr) + (is : List (String × P.Expr)) (bss : List (Stmt P (Cmd P))) + (md : MetaData P) (rest : List (Stmt P (Cmd P))) : + Block.userBlockLabels (.loop c m is bss md :: rest) = + Block.userBlockLabels bss ++ Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +theorem Block.userBlockLabels_cmd_cons {P : PureExpr} + (c : Cmd P) (rest : List (Stmt P (Cmd P))) : + Block.userBlockLabels (.cmd c :: rest) = Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +theorem Block.userBlockLabels_funcDecl_cons {P : PureExpr} + (decl : Imperative.PureFunc P) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) : + Block.userBlockLabels (.funcDecl decl md :: rest) = + Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +theorem Block.userBlockLabels_typeDecl_cons {P : PureExpr} + (tc : TypeConstructor) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) : + Block.userBlockLabels (.typeDecl tc md :: rest) = + Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +theorem Block.userBlockLabels_exit_cons {P : PureExpr} + (l : String) (md : MetaData P) (rest : List (Stmt P (Cmd P))) : + Block.userBlockLabels (.exit l md :: rest) = + Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +/-- A predicate stating that user-provided block labels: +1. are shape-free (do not have the `_` generator suffix), and +2. consequently do not collide with any label in any WF generator state, and +3. are pairwise distinct (no two `Stmt.block` constructors share a label). + +This is the precondition needed for `stmtsToBlocks` to produce a CFG with +unique block labels. The shape-free clause is what cleanly distinguishes user +labels from generator output: client code chooses readable labels (e.g. +`"my_block"`) which never collide with `gen`'s `pf_42`-style output. -/ +@[expose] def Block.userLabelsDisjoint {P : PureExpr} + (ss : List (Stmt P (Cmd P))) (gen' : StringGenState) : Prop := + (∀ l ∈ Block.userBlockLabels ss, ¬ String.HasUnderscoreDigitSuffix l) ∧ + (Block.userBlockLabels ss).Nodup ∧ + (∀ l ∈ Block.userBlockLabels ss, l ∉ StringGenState.stringGens gen') + +/-- `userLabelsDisjoint` distributes over `cons`: if a longer list is +disjoint, so is the tail. -/ +private theorem Block.userLabelsDisjoint_tail {P : PureExpr} + (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) (gen' : StringGenState) + (h : Block.userLabelsDisjoint (s :: rest) gen') : + Block.userLabelsDisjoint rest gen' := by + obtain ⟨h_shape, h_nodup, h_disj⟩ := h + refine ⟨?_, ?_, ?_⟩ + · intro l hl; apply h_shape; unfold Block.userBlockLabels + exact List.mem_append.mpr (Or.inr hl) + · unfold Block.userBlockLabels at h_nodup + exact (List.nodup_append.mp h_nodup).2.1 + · intro l hl; apply h_disj; unfold Block.userBlockLabels + exact List.mem_append.mpr (Or.inr hl) + +/-- `userLabelsDisjoint` is antitone in the generator state: a smaller +generator state can only have fewer labels, so disjointness is preserved +when restricting to a subset. -/ +private theorem Block.userLabelsDisjoint_mono {P : PureExpr} + (ss : List (Stmt P (Cmd P))) (gen gen' : StringGenState) + (h : Block.userLabelsDisjoint ss gen') + (h_sub : StringGenState.stringGens gen ⊆ StringGenState.stringGens gen') : + Block.userLabelsDisjoint ss gen := by + obtain ⟨h_shape, h_nodup, h_disj⟩ := h + refine ⟨h_shape, h_nodup, ?_⟩ + intro l hl h_in_gen + exact h_disj l hl (h_sub h_in_gen) + +/-- `userLabelsDisjoint` for the body of a `Stmt.block`: if the outer +`Stmt.block l bss md :: rest` is disjoint, so are `bss`'s user labels. -/ +private theorem Block.userLabelsDisjoint_block_body {P : PureExpr} + (l : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) (gen' : StringGenState) + (h : Block.userLabelsDisjoint (Stmt.block l bss md :: rest) gen') : + Block.userLabelsDisjoint bss gen' := by + obtain ⟨h_shape, h_nodup, h_disj⟩ := h + refine ⟨?_, ?_, ?_⟩ + · intro x hx + apply h_shape + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels + exact List.mem_append.mpr (Or.inl (List.mem_cons.mpr (Or.inr hx))) + · -- bss's labels appear inside (l :: bss-labels) ++ rest-labels, so Nodup follows + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels at h_nodup + have := (List.nodup_append.mp h_nodup).1 + exact (List.nodup_cons.mp this).2 + · intro x hx + apply h_disj + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels + exact List.mem_append.mpr (Or.inl (List.mem_cons.mpr (Or.inr hx))) + +/-- `userLabelsDisjoint` for the then/else branches of a `Stmt.ite`. -/ +private theorem Block.userLabelsDisjoint_ite_then {P : PureExpr} + (c : Imperative.ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) (gen' : StringGenState) + (h : Block.userLabelsDisjoint (Stmt.ite c tss ess md :: rest) gen') : + Block.userLabelsDisjoint tss gen' := by + obtain ⟨h_shape, h_nodup, h_disj⟩ := h + refine ⟨?_, ?_, ?_⟩ + · intro x hx; apply h_shape + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels + exact List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inl hx))) + · unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels at h_nodup + have := (List.nodup_append.mp h_nodup).1 + exact (List.nodup_append.mp this).1 + · intro x hx; apply h_disj + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels + exact List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inl hx))) + +private theorem Block.userLabelsDisjoint_ite_else {P : PureExpr} + (c : Imperative.ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) (gen' : StringGenState) + (h : Block.userLabelsDisjoint (Stmt.ite c tss ess md :: rest) gen') : + Block.userLabelsDisjoint ess gen' := by + obtain ⟨h_shape, h_nodup, h_disj⟩ := h + refine ⟨?_, ?_, ?_⟩ + · intro x hx; apply h_shape + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels + exact List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inr hx))) + · unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels at h_nodup + have := (List.nodup_append.mp h_nodup).1 + exact (List.nodup_append.mp this).2.1 + · intro x hx; apply h_disj + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels + exact List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inr hx))) + +/-- `userLabelsDisjoint` for the body of a `Stmt.loop`. -/ +private theorem Block.userLabelsDisjoint_loop_body {P : PureExpr} + (c : Imperative.ExprOrNondet P) (m : Option P.Expr) (is : List (String × P.Expr)) + (bss : List (Stmt P (Cmd P))) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) (gen' : StringGenState) + (h : Block.userLabelsDisjoint (Stmt.loop c m is bss md :: rest) gen') : + Block.userLabelsDisjoint bss gen' := by + obtain ⟨h_shape, h_nodup, h_disj⟩ := h + refine ⟨?_, ?_, ?_⟩ + · intro x hx; apply h_shape + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels + exact List.mem_append.mpr (Or.inl hx) + · unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels at h_nodup + exact (List.nodup_append.mp h_nodup).1 + · intro x hx; apply h_disj + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels + exact List.mem_append.mpr (Or.inl hx) + +/-- Cross-disjointness for `ite`: `tss`'s and `ess`'s user labels are +disjoint (lifted from the outer `Nodup`). -/ +private theorem Block.userLabels_ite_cross_disj {P : PureExpr} + (c : Imperative.ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) (gen' : StringGenState) + (h : Block.userLabelsDisjoint (Stmt.ite c tss ess md :: rest) gen') : + (∀ x ∈ Block.userBlockLabels tss, x ∉ Block.userBlockLabels ess) ∧ + (∀ x ∈ Block.userBlockLabels tss, x ∉ Block.userBlockLabels rest) ∧ + (∀ x ∈ Block.userBlockLabels ess, x ∉ Block.userBlockLabels rest) := by + obtain ⟨_, h_nodup, _⟩ := h + rw [Block.userBlockLabels_ite_cons] at h_nodup + -- h_nodup : ((tss-lbls ++ ess-lbls) ++ rest-lbls).Nodup + have h_outer := List.nodup_append.mp h_nodup + -- left = tss-lbls ++ ess-lbls; right = rest-lbls + have h_te_nodup := h_outer.1 + have h_te_inner := List.nodup_append.mp h_te_nodup + refine ⟨?_, ?_, ?_⟩ + · -- tss vs ess + intro x h_t h_e + exact h_te_inner.2.2 x h_t x h_e rfl + · -- tss vs rest: x ∈ tss-lbls ⊆ left, x ∈ rest-lbls = right + intro x h_t h_r + exact h_outer.2.2 x (List.mem_append.mpr (Or.inl h_t)) x h_r rfl + · -- ess vs rest + intro x h_e h_r + exact h_outer.2.2 x (List.mem_append.mpr (Or.inr h_e)) x h_r rfl + +/-- Cross-disjointness for `loop`: `bss`'s user labels are disjoint from +`rest`'s user labels. -/ +private theorem Block.userLabels_loop_cross_disj {P : PureExpr} + (c : Imperative.ExprOrNondet P) (m : Option P.Expr) (is : List (String × P.Expr)) + (bss : List (Stmt P (Cmd P))) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) (gen' : StringGenState) + (h : Block.userLabelsDisjoint (Stmt.loop c m is bss md :: rest) gen') : + ∀ x ∈ Block.userBlockLabels bss, x ∉ Block.userBlockLabels rest := by + obtain ⟨_, h_nodup, _⟩ := h + rw [Block.userBlockLabels_loop_cons] at h_nodup + have h_outer := List.nodup_append.mp h_nodup + intro x h_b h_r + exact h_outer.2.2 x h_b x h_r rfl + +/-- The label `l` of a `Stmt.block l bss md` is in the user-label list, so we +can lift the shape-free, Nodup, and disjointness facts to it. -/ +private theorem Block.userLabel_of_block_head {P : PureExpr} + (l : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) (gen' : StringGenState) + (h : Block.userLabelsDisjoint (Stmt.block l bss md :: rest) gen') : + ¬ String.HasUnderscoreDigitSuffix l ∧ + l ∉ StringGenState.stringGens gen' ∧ + l ∉ Block.userBlockLabels bss ∧ + l ∉ Block.userBlockLabels rest := by + obtain ⟨h_shape, h_nodup, h_disj⟩ := h + have h_l_in : l ∈ Block.userBlockLabels (Stmt.block l bss md :: rest) := by + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels + exact List.mem_append.mpr (Or.inl (List.mem_cons.mpr (Or.inl rfl))) + refine ⟨h_shape l h_l_in, h_disj l h_l_in, ?_, ?_⟩ + · -- l ∉ Block.userBlockLabels bss: from Nodup of (l :: bss-labels) ++ rest-labels + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels at h_nodup + have h_left := (List.nodup_append.mp h_nodup).1 + exact (List.nodup_cons.mp h_left).1 + · -- l ∉ Block.userBlockLabels rest: from cross-list disjointness in Nodup append + unfold Block.userBlockLabels Block.userBlockLabels.stmtUserBlockLabels at h_nodup + have h_disj_lr := (List.nodup_append.mp h_nodup).2.2 + intro h_in + exact h_disj_lr l (List.mem_cons.mpr (Or.inl rfl)) l h_in rfl + +/-- `flushCmds` always produces a `GenStep`, regardless of WF. -/ +private theorem flushCmds_genStep {P : PureExpr} [HasBool P] + (pfx : String) (accum : List (Cmd P)) + (tr? : Option (DetTransferCmd String P)) (k : String) + (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P) + (h_gen : flushCmds pfx accum tr? k gen = ((entry, blocks), gen')) : + StringGenState.GenStep gen gen' := by + unfold flushCmds at h_gen + cases h_tr : tr? with + | none => + rw [h_tr] at h_gen + simp only at h_gen + by_cases h_empty : accum.isEmpty + · rw [if_pos h_empty] at h_gen + simp only [pure, StateT.pure] at h_gen + have : gen' = gen := (Prod.mk.inj h_gen).2.symm + rw [this] + exact StringGenState.GenStep.refl _ + · rw [if_neg h_empty] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure, Id] at h_gen + have : gen' = (StringGenState.gen pfx gen).2 := (Prod.mk.inj h_gen).2.symm + rw [this] + exact StringGenState.GenStep.of_gen pfx gen + | some tr => + rw [h_tr] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure, Id] at h_gen + have : gen' = (StringGenState.gen pfx gen).2 := (Prod.mk.inj h_gen).2.symm + rw [this] + exact StringGenState.GenStep.of_gen pfx gen + +/-- A weaker invariant for `stmtsToBlocks`: just the `GenStep` part +(WF preservation + monotone label list). This holds without any +disjointness assumption and is used to bootstrap the full invariant. -/ +private theorem stmtsToBlocks_genStep + {P : PureExpr} [HasBool P] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] + (k : String) (ss : List (Stmt P (Cmd P))) + (exitConts : List (Option String × String)) + (accum : List (Cmd P)) + (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P) + (h_gen : stmtsToBlocks k ss exitConts accum gen = ((entry, blocks), gen')) : + StringGenState.GenStep gen gen' := by + match h_match : ss with + | [] => + unfold stmtsToBlocks at h_gen + exact flushCmds_genStep "l$" accum .none k gen gen' entry blocks h_gen + | .cmd c :: rest => + unfold stmtsToBlocks at h_gen + exact stmtsToBlocks_genStep k rest exitConts (c :: accum) gen gen' entry blocks h_gen + | .funcDecl _ _ :: rest => + unfold stmtsToBlocks at h_gen + exact stmtsToBlocks_genStep k rest exitConts accum gen gen' entry blocks h_gen + | .typeDecl _ _ :: rest => + unfold stmtsToBlocks at h_gen + exact stmtsToBlocks_genStep k rest exitConts accum gen gen' entry blocks h_gen + | .exit l? md :: _ => + unfold stmtsToBlocks at h_gen + exact flushCmds_genStep _ accum _ _ gen gen' entry blocks h_gen + | .block l bss md :: rest => + simp only [stmtsToBlocks, bind, StateT.bind, pure] at h_gen + generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen + obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest + simp at h_gen + generalize h_body_eq : stmtsToBlocks kNext bss + ((some l, kNext) :: exitConts) [] gen_r = r_body at h_gen + obtain ⟨⟨bl, bbs⟩, gen_b⟩ := r_body + simp at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "blk$" accum .none bl gen_b = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_step_rest := stmtsToBlocks_genStep k rest exitConts [] gen gen_r + kNext bsNext h_rest_eq + have h_step_body := stmtsToBlocks_genStep kNext bss _ [] gen_r gen_b + bl bbs h_body_eq + have h_step_flush := flushCmds_genStep "blk$" accum .none bl gen_b gen_f + accumEntry accumBlocks h_flush_eq + have h_gen_eq : gen_f = gen' := by + simp only at h_gen + by_cases h_eq : l = bl + · rw [if_pos h_eq] at h_gen + simp only [pure, StateT.pure] at h_gen + exact (Prod.mk.inj h_gen).2 + · rw [if_neg h_eq] at h_gen + simp only [pure, StateT.pure] at h_gen + exact (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ (h_step_rest.trans h_step_body).trans h_step_flush + | .ite c tss fss md :: rest => + simp only [stmtsToBlocks, bind, StateT.bind, pure] at h_gen + generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen + obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest + simp only at h_gen + generalize h_ite_label : StringGenState.gen "ite" gen_r = r_ite at h_gen + obtain ⟨l_ite, gen_ite⟩ := r_ite + simp only at h_gen + generalize h_then_eq : stmtsToBlocks kNext tss exitConts [] gen_ite = r_then at h_gen + obtain ⟨⟨tl, tbs⟩, gen_t⟩ := r_then + simp only at h_gen + generalize h_else_eq : stmtsToBlocks kNext fss exitConts [] gen_t = r_else at h_gen + obtain ⟨⟨fl, fbs⟩, gen_e⟩ := r_else + simp only at h_gen + have h_step_rest := stmtsToBlocks_genStep k rest exitConts [] gen gen_r + kNext bsNext h_rest_eq + have h_step_ite : StringGenState.GenStep gen_r gen_ite := by + rw [show gen_ite = (StringGenState.gen "ite" gen_r).2 from + (by rw [h_ite_label])] + exact StringGenState.GenStep.of_gen "ite" gen_r + have h_step_then := stmtsToBlocks_genStep kNext tss exitConts [] gen_ite gen_t + tl tbs h_then_eq + have h_step_else := stmtsToBlocks_genStep kNext fss exitConts [] gen_t gen_e + fl fbs h_else_eq + cases c with + | det e => + simp only [bind, StateT.bind, pure, StateT.pure, List.append_nil] at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "ite$" accum + (.some (DetTransferCmd.condGoto e tl fl md)) l_ite gen_e = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_step_flush : StringGenState.GenStep gen_e gen_f := + flushCmds_genStep "ite$" accum _ l_ite gen_e gen_f + accumEntry accumBlocks h_flush_eq + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ ((((h_step_rest.trans h_step_ite).trans h_step_then).trans h_step_else).trans + h_step_flush) + | nondet => + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_nondet_gen : StringGenState.gen "$__nondet_ite$" gen_e = r_nd at h_gen + obtain ⟨freshName, gen_n⟩ := r_nd + simp only at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "ite$" + (accum ++ [HasInit.init (HasIdent.ident (P := P) freshName) HasBool.boolTy + ExprOrNondet.nondet synthesizedMd]) + (.some (DetTransferCmd.condGoto + (HasFvar.mkFvar (HasIdent.ident (P := P) freshName)) tl fl md)) l_ite gen_n = + r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_step_nondet : StringGenState.GenStep gen_e gen_n := by + rw [show gen_n = (StringGenState.gen "$__nondet_ite$" gen_e).2 from + (by rw [h_nondet_gen])] + exact StringGenState.GenStep.of_gen "$__nondet_ite$" gen_e + have h_step_flush : StringGenState.GenStep gen_n gen_f := + flushCmds_genStep "ite$" _ _ l_ite gen_n gen_f + accumEntry accumBlocks h_flush_eq + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ (((((h_step_rest.trans h_step_ite).trans h_step_then).trans h_step_else).trans + h_step_nondet).trans h_step_flush) + | .loop c m is bss md :: rest => + simp only [stmtsToBlocks, bind, StateT.bind] at h_gen + -- Decompose generic prefix: rest and lentry. + generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen + obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest + simp only at h_gen + generalize h_lentry_def : StringGenState.gen "loop_entry$" gen_r = r_le at h_gen + obtain ⟨lentry, gen_le⟩ := r_le + simp only at h_gen + have h_step_rest := stmtsToBlocks_genStep k rest exitConts [] gen gen_r + kNext bsNext h_rest_eq + have h_step_le : StringGenState.GenStep gen_r gen_le := by + rw [show gen_le = (StringGenState.gen "loop_entry$" gen_r).2 from + (by rw [h_lentry_def])] + exact StringGenState.GenStep.of_gen "loop_entry$" gen_r + -- Split on m and c simultaneously to flatten nested matches. + cases h_m_cases : m with + | none => + rw [h_m_cases] at h_gen + simp only [pure, StateT.pure, bind, StateT.bind] at h_gen + -- Decompose body, mapM, and the c-cases. + generalize h_body_eq : + stmtsToBlocks lentry bss ((none, kNext) :: exitConts) [] gen_le = r_body at h_gen + obtain ⟨⟨bl, bbs⟩, gen_b⟩ := r_body + simp only at h_gen + generalize h_inv_def : + ((is.mapM (fun (srcLabel, i) => do + let assertLabel ← + if srcLabel.isEmpty then StringGenState.gen "inv$" + else pure srcLabel + pure (HasPassiveCmds.assert (P := P) (CmdT := Cmd P) assertLabel i synthesizedMd))) + : LabelGen.StringGenM (List (Cmd P))) gen_b = r_inv at h_gen + obtain ⟨invCmds, gen_i⟩ := r_inv + have h_step_body := stmtsToBlocks_genStep lentry bss _ [] gen_le gen_b bl bbs h_body_eq + have h_step_inv : StringGenState.GenStep gen_b gen_i := by + apply mapM_genStep _ _ is gen_b gen_i invCmds h_inv_def + intro a g g' b h_step + obtain ⟨srcLabel, i⟩ := a + by_cases h_empty : srcLabel.isEmpty + · simp only [h_empty, if_true, bind, StateT.bind, pure, StateT.pure] at h_step + have h_g_eq : g' = (StringGenState.gen "inv$" g).2 := (Prod.mk.inj h_step).2.symm + rw [h_g_eq] + exact StringGenState.GenStep.of_gen "inv$" g + · simp only [h_empty, bind, pure] at h_step + have h_g_eq : g' = g := (Prod.mk.inj h_step).2.symm + rw [h_g_eq] + exact StringGenState.GenStep.refl g + have h_step_prefix : StringGenState.GenStep gen gen_i := + ((h_step_rest.trans h_step_le).trans h_step_body).trans h_step_inv + cases c with + | det e => + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "before_loop$" accum + Option.none lentry gen_i = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_step_flush : StringGenState.GenStep gen_i gen_f := + flushCmds_genStep "before_loop$" accum _ lentry gen_i gen_f + accumEntry accumBlocks h_flush_eq + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ h_step_prefix.trans h_step_flush + | nondet => + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_nondet_gen : StringGenState.gen "$__nondet_loop$" gen_i = r_nd at h_gen + obtain ⟨freshName, gen_n⟩ := r_nd + generalize h_flush_eq : @flushCmds P (Cmd P) _ "before_loop$" accum + Option.none lentry gen_n = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_step_nondet : StringGenState.GenStep gen_i gen_n := by + rw [show gen_n = (StringGenState.gen "$__nondet_loop$" gen_i).2 from + (by rw [h_nondet_gen])] + exact StringGenState.GenStep.of_gen "$__nondet_loop$" gen_i + have h_step_flush : StringGenState.GenStep gen_n gen_f := + flushCmds_genStep "before_loop$" accum _ lentry gen_n gen_f + accumEntry accumBlocks h_flush_eq + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ (h_step_prefix.trans h_step_nondet).trans h_step_flush + | some mExpr => + rw [h_m_cases] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_ml_def : StringGenState.gen "loop_measure$" gen_le = r_ml at h_gen + obtain ⟨mLabel, gen_ml⟩ := r_ml + simp only at h_gen + generalize h_ldec_def : StringGenState.gen "measure_decrease$" gen_ml = r_ldec at h_gen + obtain ⟨ldec, gen_ldec⟩ := r_ldec + simp only at h_gen + have h_step_ml : StringGenState.GenStep gen_le gen_ml := by + rw [show gen_ml = (StringGenState.gen "loop_measure$" gen_le).2 from + (by rw [h_ml_def])] + exact StringGenState.GenStep.of_gen "loop_measure$" gen_le + have h_step_ldec : StringGenState.GenStep gen_ml gen_ldec := by + rw [show gen_ldec = (StringGenState.gen "measure_decrease$" gen_ml).2 from + (by rw [h_ldec_def])] + exact StringGenState.GenStep.of_gen "measure_decrease$" gen_ml + generalize h_body_eq : + stmtsToBlocks ldec bss ((none, kNext) :: exitConts) [] gen_ldec = r_body at h_gen + obtain ⟨⟨bl, bbs⟩, gen_b⟩ := r_body + simp only at h_gen + generalize h_inv_def : + ((is.mapM (fun (srcLabel, i) => do + let assertLabel ← + if srcLabel.isEmpty then StringGenState.gen "inv$" + else pure srcLabel + pure (HasPassiveCmds.assert (P := P) (CmdT := Cmd P) assertLabel i synthesizedMd))) + : LabelGen.StringGenM (List (Cmd P))) gen_b = r_inv at h_gen + obtain ⟨invCmds, gen_i⟩ := r_inv + have h_step_body := stmtsToBlocks_genStep ldec bss _ [] gen_ldec gen_b bl bbs h_body_eq + have h_step_inv : StringGenState.GenStep gen_b gen_i := by + apply mapM_genStep _ _ is gen_b gen_i invCmds h_inv_def + intro a g g' b h_step + obtain ⟨srcLabel, i⟩ := a + by_cases h_empty : srcLabel.isEmpty + · simp only [h_empty, if_true, bind, StateT.bind, pure, StateT.pure] at h_step + have h_g_eq : g' = (StringGenState.gen "inv$" g).2 := (Prod.mk.inj h_step).2.symm + rw [h_g_eq] + exact StringGenState.GenStep.of_gen "inv$" g + · simp only [h_empty, bind, pure] at h_step + have h_g_eq : g' = g := (Prod.mk.inj h_step).2.symm + rw [h_g_eq] + exact StringGenState.GenStep.refl g + have h_step_prefix : StringGenState.GenStep gen gen_i := + ((((h_step_rest.trans h_step_le).trans h_step_ml).trans h_step_ldec).trans + h_step_body).trans h_step_inv + cases c with + | det e => + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "before_loop$" accum + Option.none lentry gen_i = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_step_flush : StringGenState.GenStep gen_i gen_f := + flushCmds_genStep "before_loop$" accum _ lentry gen_i gen_f + accumEntry accumBlocks h_flush_eq + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ h_step_prefix.trans h_step_flush + | nondet => + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_nondet_gen : StringGenState.gen "$__nondet_loop$" gen_i = r_nd at h_gen + obtain ⟨freshName, gen_n⟩ := r_nd + generalize h_flush_eq : @flushCmds P (Cmd P) _ "before_loop$" accum + Option.none lentry gen_n = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_step_nondet : StringGenState.GenStep gen_i gen_n := by + rw [show gen_n = (StringGenState.gen "$__nondet_loop$" gen_i).2 from + (by rw [h_nondet_gen])] + exact StringGenState.GenStep.of_gen "$__nondet_loop$" gen_i + have h_step_flush : StringGenState.GenStep gen_n gen_f := + flushCmds_genStep "before_loop$" accum _ lentry gen_n gen_f + accumEntry accumBlocks h_flush_eq + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ (h_step_prefix.trans h_step_nondet).trans h_step_flush +termination_by sizeOf ss +decreasing_by all_goals (subst h_match; simp_wf; omega) + +/-- The main invariant for `stmtsToBlocks`. +We require WF on `gen` and obtain WF on `gen'`, plus freshness/nodup of +the produced block labels. + +The proof is by well-founded recursion on `sizeOf ss` (so that recursive +calls on sub-lists `tss`, `fss`, `bss`, `body` work). For each statement +constructor, we: +1. Decompose the monadic computation via `generalize` + `obtain`, +2. Apply the IH to recursive sub-calls and `flushCmds_invariant` to flushes, +3. Combine results via `GenInv.trans`. + +We require `userLabelsDisjoint`: user-provided block labels (from +`Stmt.block l ...`) must not collide with any generated label in the +final state. Without this, the `block` case can produce duplicate keys. -/ +private theorem stmtsToBlocks_invariant + {P : PureExpr} [HasBool P] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] + (k : String) (ss : List (Stmt P (Cmd P))) + (exitConts : List (Option String × String)) + (accum : List (Cmd P)) + (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P) + (h_gen : stmtsToBlocks k ss exitConts accum gen = ((entry, blocks), gen')) + (hwf : StringGenState.WF gen) + (h_disj : Block.userLabelsDisjoint ss gen') : + @GenInv P gen gen' (Block.userBlockLabels ss) blocks := by + match h_match : ss with + | [] => + -- stmtsToBlocks reduces to flushCmds "l$" accum .none k + unfold stmtsToBlocks at h_gen + -- Block.userBlockLabels [] = [] + show @GenInv P gen gen' [] blocks + exact flushCmds_invariant "l$" accum .none k gen gen' entry blocks h_gen hwf + | .cmd c :: rest => + -- Recurse with extended accumulator + unfold stmtsToBlocks at h_gen + rw [Block.userBlockLabels_cmd_cons] + exact stmtsToBlocks_invariant k rest exitConts (c :: accum) gen gen' entry blocks h_gen hwf + (Block.userLabelsDisjoint_tail _ _ _ h_disj) + | .funcDecl _ _ :: rest => + -- Skip funcDecl, recurse on rest + unfold stmtsToBlocks at h_gen + rw [Block.userBlockLabels_funcDecl_cons] + exact stmtsToBlocks_invariant k rest exitConts accum gen gen' entry blocks h_gen hwf + (Block.userLabelsDisjoint_tail _ _ _ h_disj) + | .typeDecl _ _ :: rest => + -- Skip typeDecl, recurse on rest + unfold stmtsToBlocks at h_gen + rw [Block.userBlockLabels_typeDecl_cons] + exact stmtsToBlocks_invariant k rest exitConts accum gen gen' entry blocks h_gen hwf + (Block.userLabelsDisjoint_tail _ _ _ h_disj) + | .exit l? md :: _ => + -- The bk computation is pure (no gen calls); only flushCmds is stateful. + -- exit truncates so blocks only come from flushCmds (no user labels). + unfold stmtsToBlocks at h_gen + rw [Block.userBlockLabels_exit_cons] + have h_inv : @GenInv P gen gen' [] blocks := + flushCmds_invariant _ accum _ _ gen gen' entry blocks h_gen hwf + -- Weaken from [] to userBlockLabels of the rest (which we discard from h_disj). + have h_disj_rest := Block.userLabelsDisjoint_tail _ _ _ h_disj + apply GenInv.weaken_userLabels gen gen' [] _ blocks h_inv + · intro l hl; simp at hl + · exact h_disj_rest.1 + · exact h_disj_rest.2.2 + · exact h_disj_rest.2.1 + | .block l bss md :: rest => + simp only [stmtsToBlocks, bind, StateT.bind, pure] at h_gen + -- Decompose the monadic chain + generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen + obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest + simp at h_gen + generalize h_body_eq : stmtsToBlocks kNext bss + ((some l, kNext) :: exitConts) [] gen_r = r_body at h_gen + obtain ⟨⟨bl, bbs⟩, gen_b⟩ := r_body + simp at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "blk$" accum .none bl gen_b = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + -- Disjointness for sub-lists w.r.t. gen' (the outer final state) + have h_disj_rest_gen' : Block.userLabelsDisjoint rest gen' := + Block.userLabelsDisjoint_tail _ _ _ h_disj + have h_disj_bss_gen' : Block.userLabelsDisjoint bss gen' := + Block.userLabelsDisjoint_block_body l bss md rest gen' h_disj + -- Use the simpler `stmtsToBlocks_genStep` to get subset relations + -- without needing the full GenInv (which requires disjointness premises). + have h_step_rest := stmtsToBlocks_genStep k rest exitConts [] gen gen_r + kNext bsNext h_rest_eq + have h_step_body := stmtsToBlocks_genStep kNext bss _ [] gen_r gen_b + bl bbs h_body_eq + -- Also need genStep for flushCmds (without requiring WF) + have h_step_flush : StringGenState.GenStep gen_b gen_f := + flushCmds_genStep "blk$" accum .none bl gen_b gen_f + accumEntry accumBlocks h_flush_eq + -- gen_r ⊆ gen_b ⊆ gen_f. We have userLabelsDisjoint w.r.t. gen' (outer), + -- but for sub-calls we need it w.r.t. gen_r and gen_b respectively. + -- We first establish gen_f = gen' from h_gen, then chain. + simp only at h_gen + have h_gen_eq : gen_f = gen' := by + by_cases h_eq : l = bl + · rw [if_pos h_eq] at h_gen + simp only [pure, StateT.pure] at h_gen + exact (Prod.mk.inj h_gen).2 + · rw [if_neg h_eq] at h_gen + simp only [pure, StateT.pure] at h_gen + exact (Prod.mk.inj h_gen).2 + -- Use h_gen_eq to derive subsets w.r.t. gen' (= gen_f) + have h_subset_r_gen' : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ (h_step_body.trans h_step_flush).subset + have h_subset_b_gen' : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ h_step_flush.subset + have h_disj_rest_gen_r : Block.userLabelsDisjoint rest gen_r := + Block.userLabelsDisjoint_mono _ _ _ h_disj_rest_gen' h_subset_r_gen' + have h_disj_bss_gen_b : Block.userLabelsDisjoint bss gen_b := + Block.userLabelsDisjoint_mono _ _ _ h_disj_bss_gen' h_subset_b_gen' + -- Get invariants for each step using IH on smaller statement lists. + -- Each IH returns GenInv ... (userBlockLabels ) . + have h_inv_rest : + @GenInv P gen gen_r (Block.userBlockLabels rest) bsNext := + stmtsToBlocks_invariant k rest exitConts [] gen gen_r kNext bsNext h_rest_eq hwf + h_disj_rest_gen_r + have hwf_r := h_inv_rest.wf_out + have h_inv_body : + @GenInv P gen_r gen_b (Block.userBlockLabels bss) bbs := + stmtsToBlocks_invariant kNext bss _ [] gen_r gen_b bl bbs h_body_eq hwf_r + h_disj_bss_gen_b + have hwf_b := h_inv_body.wf_out + have h_inv_flush : @GenInv P gen_b gen_f [] accumBlocks := + flushCmds_invariant "blk$" accum .none bl gen_b gen_f accumEntry accumBlocks + h_flush_eq hwf_b + -- Cross-disjointness premises for trans. + -- userBlockLabels rest is disjoint from userBlockLabels bss because the + -- outer userLabelsDisjoint contains pairwise-distinct labels. + have h_user_disj_rest_bss : + ∀ x ∈ Block.userBlockLabels rest, x ∉ Block.userBlockLabels bss := by + intro x h_x_rest h_x_bss + have h_block := h_disj + obtain ⟨_, h_nodup_outer, _⟩ := h_block + rw [Block.userBlockLabels_block_cons] at h_nodup_outer + -- nodup_outer : (l :: userBlockLabels bss ++ userBlockLabels rest).Nodup + have h_disj_lr := List.nodup_append.mp h_nodup_outer + -- left = l :: userBlockLabels bss; right = userBlockLabels rest + have h_cross := h_disj_lr.2.2 + exact h_cross x (List.mem_cons.mpr (Or.inr h_x_bss)) x h_x_rest rfl + have h_user_disj_rb_flush : + ∀ x ∈ Block.userBlockLabels rest ++ Block.userBlockLabels bss, x ∉ ([] : List String) := by + intros _ _ h_in; simp at h_in + -- Compose chronologically: gen → gen_r → gen_b → gen_f + have h_inv_rb : + @GenInv P gen gen_b + (Block.userBlockLabels rest ++ Block.userBlockLabels bss) + (bsNext ++ bbs) := + GenInv.trans gen gen_r gen_b _ _ _ _ h_inv_rest h_inv_body h_user_disj_rest_bss + have h_inv_chron : + @GenInv P gen gen_f + ((Block.userBlockLabels rest ++ Block.userBlockLabels bss) ++ []) + ((bsNext ++ bbs) ++ accumBlocks) := + GenInv.trans gen gen_b gen_f _ _ _ _ h_inv_rb h_inv_flush h_user_disj_rb_flush + -- Simplify userLabels: rest++bss++[] = rest++bss + have h_user_simp : + Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ ([] : List String) + = Block.userBlockLabels rest ++ Block.userBlockLabels bss := by + simp + rw [h_user_simp] at h_inv_chron + -- Permutation on blocks: (bsNext ++ bbs) ++ accumBlocks ~ accumBlocks ++ bbs ++ bsNext + have h_perm : ((bsNext ++ bbs) ++ accumBlocks).Perm (accumBlocks ++ bbs ++ bsNext) := by + have h1 : ((bsNext ++ bbs) ++ accumBlocks).Perm (accumBlocks ++ (bsNext ++ bbs)) := + List.perm_append_comm + have h2 : (accumBlocks ++ (bsNext ++ bbs)).Perm (accumBlocks ++ (bbs ++ bsNext)) := + List.Perm.append_left accumBlocks List.perm_append_comm + have h3 : (accumBlocks ++ (bbs ++ bsNext)) = (accumBlocks ++ bbs ++ bsNext) := by + rw [List.append_assoc] + exact (h1.trans h2).trans (h3 ▸ List.Perm.refl _) + have h_inv_out : + @GenInv P gen gen_f + (Block.userBlockLabels rest ++ Block.userBlockLabels bss) + (accumBlocks ++ bbs ++ bsNext) := + GenInv.perm gen gen_f _ _ _ h_inv_chron h_perm + -- The expected userLabels in our goal is `userBlockLabels (.block l bss md :: rest)` + -- = l :: userBlockLabels bss ++ userBlockLabels rest. We have rest ++ bss; we need to + -- weaken/permute. Since `weaken` only requires sublist, we use it: + have h_l_props := Block.userLabel_of_block_head l bss md rest gen' h_disj + have h_subset : + ∀ x ∈ Block.userBlockLabels rest ++ Block.userBlockLabels bss, + x ∈ Block.userBlockLabels (.block l bss md :: rest) := by + intro x hx + rw [Block.userBlockLabels_block_cons] + rw [List.mem_append] at hx + exact hx.elim + (fun h => List.mem_append.mpr (Or.inr h)) + (fun h => List.mem_append.mpr (Or.inl (List.mem_cons.mpr (Or.inr h)))) + -- Now case-split on the if l == bl + by_cases h_eq : l = bl + · -- l = bl: result blocks = accumBlocks ++ bbs ++ bsNext, no extra l-block + rw [if_pos h_eq] at h_gen + simp only [pure, StateT.pure] at h_gen + have h_pair := (Prod.mk.inj h_gen).1 + have h_entry_eq : accumEntry = entry := (Prod.mk.inj h_pair).1 + have h_blocks_eq : accumBlocks ++ (bbs ++ bsNext) = blocks := (Prod.mk.inj h_pair).2 + subst h_entry_eq + have h_blks : blocks = accumBlocks ++ bbs ++ bsNext := by + rw [List.append_assoc]; exact h_blocks_eq.symm + rw [h_blks, ← h_gen_eq] + -- Weaken to the goal's userLabels. + apply GenInv.weaken_userLabels gen gen_f _ _ _ h_inv_out h_subset + · -- shape on the outer userLabels + intro x hx + exact h_disj.1 x hx + · -- disj on the outer userLabels w.r.t. gen_f = gen' + intro x hx h_in + rw [h_gen_eq] at h_in + exact h_disj.2.2 x hx h_in + · exact h_disj.2.1 + · -- l ≠ bl: blocks = accumBlocks ++ (l, .goto bl md) :: (bbs ++ bsNext), + -- entry = accumEntry (after the bug fix that uses accumEntry rather than l). + rw [if_neg h_eq] at h_gen + simp only [pure, StateT.pure] at h_gen + have h_pair := (Prod.mk.inj h_gen).1 + -- Entry is `accumEntry`; we don't constrain entry in GenInv, so this hypothesis + -- is unused below. + have h_entry_eq : accumEntry = entry := (Prod.mk.inj h_pair).1 + let lBlk : DetBlock String (Cmd P) P := + { cmds := [], transfer := DetTransferCmd.goto bl md } + have h_blocks_eq : + accumBlocks ++ (l, lBlk) :: (bbs ++ bsNext) = blocks := + (Prod.mk.inj h_pair).2 + -- We have h_inv_out : GenInv ... (rest_lbls ++ bss_lbls) (accumBlocks ++ bbs ++ bsNext) + -- Goal: GenInv ... (l :: bss_lbls ++ rest_lbls) blocks + -- = GenInv ... (l :: bss_lbls ++ rest_lbls) (accumBlocks ++ [(l, lBlk)] ++ bbs ++ bsNext) + -- The (l, lBlk) needs to be inserted as a USER-labeled block (label l). + rw [← h_blocks_eq] + -- First permute h_inv_out's blocks to put accumBlocks at the start, then bbs, bsNext. + -- h_inv_out blocks = accumBlocks ++ bbs ++ bsNext (already this form). + -- We use cons_user to add (l, lBlk): + have h_l_props := Block.userLabel_of_block_head l bss md rest gen' h_disj + -- l ∉ user labels of (rest ++ bss): from disjointness in the outer Nodup. + have h_l_notin_user_combined : l ∉ Block.userBlockLabels rest ++ Block.userBlockLabels bss := by + intro h_in + rw [List.mem_append] at h_in + exact h_in.elim (fun h => h_l_props.2.2.2 h) (fun h => h_l_props.2.2.1 h) + -- l ∉ map fst of (accumBlocks ++ bbs ++ bsNext): from h_inv_out.fresh, none of those + -- labels equal l (l is a user label, and the existing blocks' labels are either + -- generated or in rest++bss user labels — both disjoint from l). + have h_l_notin_blks : l ∉ List.map Prod.fst (accumBlocks ++ bbs ++ bsNext) := by + intro h_in + rcases h_inv_out.fresh l h_in with h_gen | h_user + · -- l shape-free vs l ∈ stringGens gen_f (= gen'): contradiction via shape. + have hwf_out : StringGenState.WF gen_f := h_inv_out.wf_out + exact userLabel_not_in_stringGens_of_shape_free hwf_out h_l_props.1 h_gen.1 + · exact h_l_notin_user_combined h_user + -- Now use cons_user, then perm to align block ordering. + have h_inv_with_l : + @GenInv P gen gen_f + (l :: (Block.userBlockLabels rest ++ Block.userBlockLabels bss)) + ((l, lBlk) :: (accumBlocks ++ bbs ++ bsNext)) := + GenInv.cons_user gen gen_f _ _ l lBlk h_inv_out + h_l_props.1 h_l_notin_user_combined h_l_notin_blks + -- Permute blocks: (l, lBlk) :: (accumBlocks ++ bbs ++ bsNext) + -- ~ accumBlocks ++ [(l, lBlk)] ++ bbs ++ bsNext + have h_perm_l : ((l, lBlk) :: (accumBlocks ++ bbs ++ bsNext)).Perm + (accumBlocks ++ (l, lBlk) :: (bbs ++ bsNext)) := by + rw [List.append_assoc accumBlocks bbs bsNext] + exact (List.perm_middle (a := (l, lBlk)) + (l₁ := accumBlocks) (l₂ := bbs ++ bsNext)).symm + have h_inv_perm := GenInv.perm gen gen_f _ _ _ h_inv_with_l h_perm_l + rw [← h_gen_eq] + -- Convert userLabels: l :: (rest ++ bss) ~ goal's userLabels (l :: bss ++ rest) + apply GenInv.weaken_userLabels gen gen_f _ _ _ h_inv_perm + · -- subset + intro x hx + rw [Block.userBlockLabels_block_cons] + rw [List.mem_cons] at hx + cases hx with + | inl h => subst h; exact List.mem_append.mpr (Or.inl (List.mem_cons.mpr (Or.inl rfl))) + | inr h => + rw [List.mem_append] at h + exact h.elim + (fun h => List.mem_append.mpr (Or.inr h)) + (fun h => List.mem_append.mpr (Or.inl (List.mem_cons.mpr (Or.inr h)))) + · -- shape on goal's userLabels + intro x hx + exact h_disj.1 x hx + · -- disj on goal's userLabels + intro x hx h_in + rw [h_gen_eq] at h_in + exact h_disj.2.2 x hx h_in + · exact h_disj.2.1 + | .ite c tss fss md :: rest => + -- Sub-computations: rest, gen "ite", tss, fss, optional gen "$__nondet_ite$", + -- flushCmds (with condGoto transfer). The output is + -- accumBlocks ++ tbs ++ fbs ++ bsNext. + simp only [stmtsToBlocks, bind, StateT.bind, pure, StateT.pure] at h_gen + -- Decompose monadic chain + generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen + obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest + simp only at h_gen + generalize h_ite_label : StringGenState.gen "ite" gen_r = r_ite at h_gen + obtain ⟨l_ite, gen_ite⟩ := r_ite + simp only at h_gen + generalize h_then_eq : stmtsToBlocks kNext tss exitConts [] gen_ite = r_then at h_gen + obtain ⟨⟨tl, tbs⟩, gen_t⟩ := r_then + simp only at h_gen + generalize h_else_eq : stmtsToBlocks kNext fss exitConts [] gen_t = r_else at h_gen + obtain ⟨⟨fl, fbs⟩, gen_e⟩ := r_else + simp only at h_gen + -- Branch on c (det vs nondet) — this affects extraCmds and possibly an extra gen call. + cases h_c : c with + | det e => + rw [h_c] at h_gen + -- After matching c, the structure is: + -- (do let (e_, ec) ← pure (e, []); flushCmds ...) gen_e = ((entry, blocks), gen') + -- Unfold pure-bind: this becomes flushCmds "ite$" (accum ++ []) ... gen_e = ... + -- Then List.append_nil simplifies (accum ++ []) to accum. + simp only [bind, StateT.bind, pure, StateT.pure, List.append_nil] at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "ite$" accum + (.some (DetTransferCmd.condGoto e tl fl md)) l_ite gen_e = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_pair := (Prod.mk.inj h_gen).1 + have h_entry_eq : accumEntry = entry := (Prod.mk.inj h_pair).1 + have h_blocks_eq : accumBlocks ++ tbs ++ fbs ++ bsNext = blocks := + (Prod.mk.inj h_pair).2 + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + subst h_entry_eq + -- GenStep chain: gen → gen_r → gen_ite → gen_t → gen_e → gen_f + have h_step_rest := stmtsToBlocks_genStep k rest exitConts [] gen gen_r + kNext bsNext h_rest_eq + have h_step_ite : StringGenState.GenStep gen_r gen_ite := by + rw [show gen_ite = (StringGenState.gen "ite" gen_r).2 from + (by rw [h_ite_label])] + exact StringGenState.GenStep.of_gen "ite" gen_r + have h_step_then := stmtsToBlocks_genStep kNext tss exitConts [] gen_ite gen_t + tl tbs h_then_eq + have h_step_else := stmtsToBlocks_genStep kNext fss exitConts [] gen_t gen_e + fl fbs h_else_eq + have h_step_flush : StringGenState.GenStep gen_e gen_f := + flushCmds_genStep "ite$" accum _ l_ite gen_e gen_f + accumEntry accumBlocks h_flush_eq + -- Build subset relations w.r.t. gen' (= gen_f) for monotonicity of disjointness. + have h_subset_r_gen' : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ ((((h_step_ite.trans h_step_then).trans h_step_else)).trans h_step_flush).subset + have h_subset_ite_gen' : StringGenState.stringGens gen_ite ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ (((h_step_then.trans h_step_else)).trans h_step_flush).subset + have h_subset_t_gen' : StringGenState.stringGens gen_t ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ (h_step_else.trans h_step_flush).subset + have h_subset_e_gen' : StringGenState.stringGens gen_e ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ h_step_flush.subset + -- Disjointness of sub-statements w.r.t. their respective gen states. + have h_disj_rest_gen' : Block.userLabelsDisjoint rest gen' := + Block.userLabelsDisjoint_tail _ _ _ h_disj + have h_disj_tss_gen' : Block.userLabelsDisjoint tss gen' := + Block.userLabelsDisjoint_ite_then c tss fss md rest gen' h_disj + have h_disj_fss_gen' : Block.userLabelsDisjoint fss gen' := + Block.userLabelsDisjoint_ite_else c tss fss md rest gen' h_disj + have h_disj_rest_gen_r : Block.userLabelsDisjoint rest gen_r := + Block.userLabelsDisjoint_mono _ _ _ h_disj_rest_gen' h_subset_r_gen' + -- For sub-IH inputs we need disjointness w.r.t. each call's OUTPUT state + -- (since stmtsToBlocks_invariant takes h_disj : disj ss gen'). + have h_disj_tss_gen_t : Block.userLabelsDisjoint tss gen_t := + Block.userLabelsDisjoint_mono _ _ _ h_disj_tss_gen' h_subset_t_gen' + have h_disj_fss_gen_e : Block.userLabelsDisjoint fss gen_e := + Block.userLabelsDisjoint_mono _ _ _ h_disj_fss_gen' h_subset_e_gen' + -- Apply IH to each sub-list. + have h_inv_rest : + @GenInv P gen gen_r (Block.userBlockLabels rest) bsNext := + stmtsToBlocks_invariant k rest exitConts [] gen gen_r kNext bsNext h_rest_eq hwf + h_disj_rest_gen_r + have hwf_r := h_inv_rest.wf_out + -- Step gen_r → gen_ite has no blocks emitted: build empty GenInv. + have h_inv_ite_step : @GenInv P gen_r gen_ite [] [] := + GenInv.empty_step gen_r gen_ite hwf_r h_step_ite + have hwf_ite : StringGenState.WF gen_ite := h_inv_ite_step.wf_out + have h_inv_then : + @GenInv P gen_ite gen_t (Block.userBlockLabels tss) tbs := + stmtsToBlocks_invariant kNext tss exitConts [] gen_ite gen_t tl tbs h_then_eq + hwf_ite h_disj_tss_gen_t + have hwf_t := h_inv_then.wf_out + have h_inv_else : + @GenInv P gen_t gen_e (Block.userBlockLabels fss) fbs := + stmtsToBlocks_invariant kNext fss exitConts [] gen_t gen_e fl fbs h_else_eq + hwf_t h_disj_fss_gen_e + have hwf_e := h_inv_else.wf_out + have h_inv_flush : @GenInv P gen_e gen_f [] accumBlocks := + flushCmds_invariant "ite$" accum _ l_ite gen_e gen_f accumEntry accumBlocks + h_flush_eq hwf_e + -- Cross-disjointness premises for trans: extract from outer Nodup. + have ⟨h_te, h_tr, h_er⟩ := + Block.userLabels_ite_cross_disj c tss fss md rest gen' h_disj + -- Compose chronologically: gen → gen_r → gen_ite → gen_t → gen_e → gen_f + -- Step 1: gen → gen_ite, blocks = bsNext, user = userBlockLabels rest. + have h_inv_r_ite : + @GenInv P gen gen_ite (Block.userBlockLabels rest ++ []) (bsNext ++ []) := + GenInv.trans gen gen_r gen_ite _ _ _ _ h_inv_rest h_inv_ite_step + (by intros _ _ h_in; simp at h_in) + have h_user_r_simp : + Block.userBlockLabels rest ++ ([] : List String) = Block.userBlockLabels rest := by simp + have h_blks_r_simp : bsNext ++ ([] : List (String × DetBlock String (Cmd P) P)) = bsNext := by simp + rw [h_user_r_simp, h_blks_r_simp] at h_inv_r_ite + -- Step 2: gen → gen_t, blocks = bsNext ++ tbs, user = userBlockLabels rest ++ userBlockLabels tss + have h_inv_r_t : + @GenInv P gen gen_t + (Block.userBlockLabels rest ++ Block.userBlockLabels tss) + (bsNext ++ tbs) := + GenInv.trans gen gen_ite gen_t _ _ _ _ h_inv_r_ite h_inv_then + (by intro x h_x_r h_x_t; exact h_tr x h_x_t h_x_r) + -- Step 3: gen → gen_e, blocks = bsNext ++ tbs ++ fbs, user = ... ++ userBlockLabels fss + have h_inv_r_e : + @GenInv P gen gen_e + (Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss) + ((bsNext ++ tbs) ++ fbs) := by + apply GenInv.trans gen gen_t gen_e _ _ _ _ h_inv_r_t h_inv_else + intro x h_x_in h_x_f + rw [List.mem_append] at h_x_in + exact h_x_in.elim (fun h_x_r => h_er x h_x_f h_x_r) (fun h_x_t => h_te x h_x_t h_x_f) + -- Step 4: gen → gen_f, blocks = ... ++ accumBlocks, user unchanged (flush has []) + have h_inv_chron : + @GenInv P gen gen_f + ((Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss) ++ []) + (((bsNext ++ tbs) ++ fbs) ++ accumBlocks) := + GenInv.trans gen gen_e gen_f _ _ _ _ h_inv_r_e h_inv_flush + (by intros _ _ h_in; simp at h_in) + have h_user_simp : + Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss ++ ([] : List String) + = Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss := by simp + rw [h_user_simp] at h_inv_chron + -- Permute blocks: bsNext ++ tbs ++ fbs ++ accumBlocks ~ accumBlocks ++ tbs ++ fbs ++ bsNext + have h_perm_blocks : + (((bsNext ++ tbs) ++ fbs) ++ accumBlocks).Perm + (accumBlocks ++ tbs ++ fbs ++ bsNext) := by + -- Reassociate: ((bsNext ++ tbs) ++ fbs) ++ accumBlocks = bsNext ++ (tbs ++ fbs ++ accumBlocks) + -- And we want: accumBlocks ++ tbs ++ fbs ++ bsNext = (accumBlocks ++ tbs ++ fbs) ++ bsNext + -- These are perm via "rotate bsNext to the end". + have h1 : (((bsNext ++ tbs) ++ fbs) ++ accumBlocks).Perm + (accumBlocks ++ ((bsNext ++ tbs) ++ fbs)) := List.perm_append_comm + have h2 : (accumBlocks ++ ((bsNext ++ tbs) ++ fbs)).Perm + (accumBlocks ++ ((tbs ++ fbs) ++ bsNext)) := + List.Perm.append_left accumBlocks (by + -- (bsNext ++ tbs) ++ fbs ~ (tbs ++ fbs) ++ bsNext + have hh1 : ((bsNext ++ tbs) ++ fbs).Perm (fbs ++ (bsNext ++ tbs)) := + List.perm_append_comm + have hh2 : (fbs ++ (bsNext ++ tbs)).Perm (fbs ++ (tbs ++ bsNext)) := + List.Perm.append_left fbs List.perm_append_comm + -- (tbs ++ fbs) ++ bsNext = tbs ++ fbs ++ bsNext = tbs ++ (fbs ++ bsNext) + -- Need to massage to fbs ++ tbs ++ bsNext. They differ. + -- Instead, just compute: ((bsNext ++ tbs) ++ fbs) ~ (tbs ++ fbs) ++ bsNext + have hh3 : (fbs ++ (tbs ++ bsNext)).Perm ((tbs ++ fbs) ++ bsNext) := by + -- fbs ++ tbs ++ bsNext ~ tbs ++ fbs ++ bsNext via swap of fbs/tbs + have a : (fbs ++ (tbs ++ bsNext)) = (fbs ++ tbs) ++ bsNext := by + rw [List.append_assoc] + have b : ((tbs ++ fbs) ++ bsNext) = (tbs ++ fbs) ++ bsNext := rfl + rw [a] + exact List.Perm.append_right bsNext List.perm_append_comm + exact (hh1.trans hh2).trans hh3) + have h3 : accumBlocks ++ ((tbs ++ fbs) ++ bsNext) = accumBlocks ++ tbs ++ fbs ++ bsNext := by + rw [← List.append_assoc, ← List.append_assoc] + exact (h1.trans h2).trans (h3 ▸ List.Perm.refl _) + -- The blocks in `blocks` are: accumBlocks ++ tbs ++ fbs ++ bsNext (from h_blocks_eq). + have h_blks : blocks = accumBlocks ++ tbs ++ fbs ++ bsNext := h_blocks_eq.symm + rw [h_blks, ← h_gen_eq] + have h_inv_perm := + GenInv.perm gen gen_f _ _ _ h_inv_chron h_perm_blocks + -- Convert userLabels: (rest ++ tss ++ fss) ⊆ goal's userLabels = (tss ++ fss ++ rest) + apply GenInv.weaken_userLabels gen gen_f _ _ _ h_inv_perm + · -- subset + intro x hx + rw [Block.userBlockLabels_ite_cons] + rw [List.mem_append, List.mem_append] at hx + rcases hx with (h_r | h_t) | h_f + · exact List.mem_append.mpr (Or.inr h_r) + · exact List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inl h_t))) + · exact List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inr h_f))) + · -- shape on goal's userLabels (the outer ones from h_disj) + intro x hx + exact h_disj.1 x hx + · -- disj on goal's userLabels w.r.t. gen_f = gen' + intro x hx h_in + rw [h_gen_eq] at h_in + exact h_disj.2.2 x hx h_in + · exact h_disj.2.1 + | nondet => + -- Nondet adds an extra `gen "$__nondet_ite$"` call before flushCmds, plus an init + -- command in extraCmds. The structure is otherwise identical. + rw [h_c] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_nondet_gen : StringGenState.gen "$__nondet_ite$" gen_e = r_nd at h_gen + obtain ⟨freshName, gen_n⟩ := r_nd + simp only at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "ite$" + (accum ++ [HasInit.init (HasIdent.ident (P := P) freshName) HasBool.boolTy + ExprOrNondet.nondet synthesizedMd]) + (.some (DetTransferCmd.condGoto + (HasFvar.mkFvar (HasIdent.ident (P := P) freshName)) tl fl md)) l_ite gen_n = + r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_pair := (Prod.mk.inj h_gen).1 + have h_entry_eq : accumEntry = entry := (Prod.mk.inj h_pair).1 + have h_blocks_eq : accumBlocks ++ tbs ++ fbs ++ bsNext = blocks := + (Prod.mk.inj h_pair).2 + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + subst h_entry_eq + -- GenStep chain: gen → gen_r → gen_ite → gen_t → gen_e → gen_n → gen_f + have h_step_rest := stmtsToBlocks_genStep k rest exitConts [] gen gen_r + kNext bsNext h_rest_eq + have h_step_ite : StringGenState.GenStep gen_r gen_ite := by + rw [show gen_ite = (StringGenState.gen "ite" gen_r).2 from + (by rw [h_ite_label])] + exact StringGenState.GenStep.of_gen "ite" gen_r + have h_step_then := stmtsToBlocks_genStep kNext tss exitConts [] gen_ite gen_t + tl tbs h_then_eq + have h_step_else := stmtsToBlocks_genStep kNext fss exitConts [] gen_t gen_e + fl fbs h_else_eq + have h_step_nondet : StringGenState.GenStep gen_e gen_n := by + rw [show gen_n = (StringGenState.gen "$__nondet_ite$" gen_e).2 from + (by rw [h_nondet_gen])] + exact StringGenState.GenStep.of_gen "$__nondet_ite$" gen_e + have h_step_flush : StringGenState.GenStep gen_n gen_f := + flushCmds_genStep "ite$" _ _ l_ite gen_n gen_f + accumEntry accumBlocks h_flush_eq + -- Subset relations w.r.t. gen' (= gen_f) + have h_step_r_to_f : StringGenState.GenStep gen_r gen_f := + (((h_step_ite.trans h_step_then).trans h_step_else).trans h_step_nondet).trans + h_step_flush + have h_subset_r_gen' : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ h_step_r_to_f.subset + have h_subset_ite_gen' : StringGenState.stringGens gen_ite ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ (((h_step_then.trans h_step_else).trans h_step_nondet).trans h_step_flush).subset + have h_subset_t_gen' : StringGenState.stringGens gen_t ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ ((h_step_else.trans h_step_nondet).trans h_step_flush).subset + have h_subset_e_gen' : StringGenState.stringGens gen_e ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ (h_step_nondet.trans h_step_flush).subset + -- Disjointness of sub-statements (extracted from outer ite). + have h_disj_rest_gen' : Block.userLabelsDisjoint rest gen' := + Block.userLabelsDisjoint_tail _ _ _ h_disj + have h_disj_tss_gen' : Block.userLabelsDisjoint tss gen' := + Block.userLabelsDisjoint_ite_then c tss fss md rest gen' h_disj + have h_disj_fss_gen' : Block.userLabelsDisjoint fss gen' := + Block.userLabelsDisjoint_ite_else c tss fss md rest gen' h_disj + have h_disj_rest_gen_r : Block.userLabelsDisjoint rest gen_r := + Block.userLabelsDisjoint_mono _ _ _ h_disj_rest_gen' h_subset_r_gen' + have h_disj_tss_gen_t : Block.userLabelsDisjoint tss gen_t := + Block.userLabelsDisjoint_mono _ _ _ h_disj_tss_gen' h_subset_t_gen' + have h_disj_fss_gen_e : Block.userLabelsDisjoint fss gen_e := + Block.userLabelsDisjoint_mono _ _ _ h_disj_fss_gen' h_subset_e_gen' + -- Apply IH to each sub-list. + have h_inv_rest : + @GenInv P gen gen_r (Block.userBlockLabels rest) bsNext := + stmtsToBlocks_invariant k rest exitConts [] gen gen_r kNext bsNext h_rest_eq hwf + h_disj_rest_gen_r + have hwf_r := h_inv_rest.wf_out + have h_inv_ite_step : @GenInv P gen_r gen_ite [] [] := + GenInv.empty_step gen_r gen_ite hwf_r h_step_ite + have hwf_ite : StringGenState.WF gen_ite := h_inv_ite_step.wf_out + have h_inv_then : + @GenInv P gen_ite gen_t (Block.userBlockLabels tss) tbs := + stmtsToBlocks_invariant kNext tss exitConts [] gen_ite gen_t tl tbs h_then_eq + hwf_ite h_disj_tss_gen_t + have hwf_t := h_inv_then.wf_out + have h_inv_else : + @GenInv P gen_t gen_e (Block.userBlockLabels fss) fbs := + stmtsToBlocks_invariant kNext fss exitConts [] gen_t gen_e fl fbs h_else_eq + hwf_t h_disj_fss_gen_e + have hwf_e := h_inv_else.wf_out + have h_inv_nondet_step : @GenInv P gen_e gen_n [] [] := + GenInv.empty_step gen_e gen_n hwf_e h_step_nondet + have hwf_n : StringGenState.WF gen_n := h_inv_nondet_step.wf_out + have h_inv_flush : @GenInv P gen_n gen_f [] accumBlocks := + flushCmds_invariant "ite$" _ _ l_ite gen_n gen_f accumEntry accumBlocks + h_flush_eq hwf_n + -- Cross-disjointness premises for trans: extract from outer Nodup. + have ⟨h_te, h_tr, h_er⟩ := + Block.userLabels_ite_cross_disj c tss fss md rest gen' h_disj + -- Compose chronologically + have h_inv_r_ite : + @GenInv P gen gen_ite (Block.userBlockLabels rest ++ []) (bsNext ++ []) := + GenInv.trans gen gen_r gen_ite _ _ _ _ h_inv_rest h_inv_ite_step + (by intros _ _ h_in; simp at h_in) + have h_user_r_simp : + Block.userBlockLabels rest ++ ([] : List String) = Block.userBlockLabels rest := by simp + have h_blks_r_simp : bsNext ++ ([] : List (String × DetBlock String (Cmd P) P)) = bsNext := by simp + rw [h_user_r_simp, h_blks_r_simp] at h_inv_r_ite + have h_inv_r_t : + @GenInv P gen gen_t + (Block.userBlockLabels rest ++ Block.userBlockLabels tss) + (bsNext ++ tbs) := + GenInv.trans gen gen_ite gen_t _ _ _ _ h_inv_r_ite h_inv_then + (by intro x h_x_r h_x_t; exact h_tr x h_x_t h_x_r) + have h_inv_r_e : + @GenInv P gen gen_e + (Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss) + ((bsNext ++ tbs) ++ fbs) := by + apply GenInv.trans gen gen_t gen_e _ _ _ _ h_inv_r_t h_inv_else + intro x h_x_in h_x_f + rw [List.mem_append] at h_x_in + exact h_x_in.elim (fun h_x_r => h_er x h_x_f h_x_r) (fun h_x_t => h_te x h_x_t h_x_f) + -- Step 4: gen → gen_n via empty step + have h_inv_r_n : + @GenInv P gen gen_n + ((Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss) ++ []) + (((bsNext ++ tbs) ++ fbs) ++ []) := + GenInv.trans gen gen_e gen_n _ _ _ _ h_inv_r_e h_inv_nondet_step + (by intros _ _ h_in; simp at h_in) + have h_user_simp_n : + Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss ++ ([] : List String) + = Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss := by simp + have h_blks_simp_n : + (bsNext ++ tbs) ++ fbs ++ ([] : List (String × DetBlock String (Cmd P) P)) + = (bsNext ++ tbs) ++ fbs := by simp + rw [h_user_simp_n, h_blks_simp_n] at h_inv_r_n + -- Step 5: gen → gen_f via flush + have h_inv_chron : + @GenInv P gen gen_f + ((Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss) ++ []) + (((bsNext ++ tbs) ++ fbs) ++ accumBlocks) := + GenInv.trans gen gen_n gen_f _ _ _ _ h_inv_r_n h_inv_flush + (by intros _ _ h_in; simp at h_in) + have h_user_simp : + Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss ++ ([] : List String) + = Block.userBlockLabels rest ++ Block.userBlockLabels tss ++ + Block.userBlockLabels fss := by simp + rw [h_user_simp] at h_inv_chron + -- Permute blocks: identical to det case + have h_perm_blocks : + (((bsNext ++ tbs) ++ fbs) ++ accumBlocks).Perm + (accumBlocks ++ tbs ++ fbs ++ bsNext) := by + have h1 : (((bsNext ++ tbs) ++ fbs) ++ accumBlocks).Perm + (accumBlocks ++ ((bsNext ++ tbs) ++ fbs)) := List.perm_append_comm + have h2 : (accumBlocks ++ ((bsNext ++ tbs) ++ fbs)).Perm + (accumBlocks ++ ((tbs ++ fbs) ++ bsNext)) := + List.Perm.append_left accumBlocks (by + have hh1 : ((bsNext ++ tbs) ++ fbs).Perm (fbs ++ (bsNext ++ tbs)) := + List.perm_append_comm + have hh2 : (fbs ++ (bsNext ++ tbs)).Perm (fbs ++ (tbs ++ bsNext)) := + List.Perm.append_left fbs List.perm_append_comm + have hh3 : (fbs ++ (tbs ++ bsNext)).Perm ((tbs ++ fbs) ++ bsNext) := by + have a : (fbs ++ (tbs ++ bsNext)) = (fbs ++ tbs) ++ bsNext := by + rw [List.append_assoc] + rw [a] + exact List.Perm.append_right bsNext List.perm_append_comm + exact (hh1.trans hh2).trans hh3) + have h3 : accumBlocks ++ ((tbs ++ fbs) ++ bsNext) = accumBlocks ++ tbs ++ fbs ++ bsNext := by + rw [← List.append_assoc, ← List.append_assoc] + exact (h1.trans h2).trans (h3 ▸ List.Perm.refl _) + have h_blks : blocks = accumBlocks ++ tbs ++ fbs ++ bsNext := h_blocks_eq.symm + rw [h_blks, ← h_gen_eq] + have h_inv_perm := + GenInv.perm gen gen_f _ _ _ h_inv_chron h_perm_blocks + apply GenInv.weaken_userLabels gen gen_f _ _ _ h_inv_perm + · intro x hx + rw [Block.userBlockLabels_ite_cons] + rw [List.mem_append, List.mem_append] at hx + rcases hx with (h_r | h_t) | h_f + · exact List.mem_append.mpr (Or.inr h_r) + · exact List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inl h_t))) + · exact List.mem_append.mpr (Or.inl (List.mem_append.mpr (Or.inr h_f))) + · intro x hx + exact h_disj.1 x hx + · intro x hx h_in + rw [h_gen_eq] at h_in + exact h_disj.2.2 x hx h_in + · exact h_disj.2.1 + | .loop c m is bss md :: rest => + -- Chronological pipeline: + -- gen → gen_r: stmtsToBlocks rest + -- gen_r → gen_le: gen "loop_entry$" + -- gen_le → gen_m: match m (none: id; some: gen "loop_measure$" then gen "measure_decrease$") + -- gen_m → gen_b: stmtsToBlocks bss + -- gen_b → gen_i: is.mapM + -- gen_i → gen_? : match c (det: id; nondet: gen "$__nondet_loop$") + -- gen_? → gen_f: flushCmds "before_loop$" + -- + -- We split on `m` first (this also reduces the contractMd `match m`), + -- then on `c`, giving 4 sub-branches (none/some × det/nondet). + simp only [stmtsToBlocks, bind, StateT.bind] at h_gen + -- Decompose: rest and lentry. + generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen + obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest + simp only at h_gen + generalize h_lentry_def : StringGenState.gen "loop_entry$" gen_r = r_le at h_gen + obtain ⟨lentry, gen_le⟩ := r_le + simp only at h_gen + -- GenStep helpers (for subset relations and monotonicity). + have h_step_rest := stmtsToBlocks_genStep k rest exitConts [] gen gen_r + kNext bsNext h_rest_eq + have h_step_le : StringGenState.GenStep gen_r gen_le := by + rw [show gen_le = (StringGenState.gen "loop_entry$" gen_r).2 from + (by rw [h_lentry_def])] + exact StringGenState.GenStep.of_gen "loop_entry$" gen_r + -- Disjointness for sub-lists w.r.t. gen' (the outer final state). + have h_disj_rest_gen' : Block.userLabelsDisjoint rest gen' := + Block.userLabelsDisjoint_tail _ _ _ h_disj + have h_disj_bss_gen' : Block.userLabelsDisjoint bss gen' := + Block.userLabelsDisjoint_loop_body c m is bss md rest gen' h_disj + have h_user_disj_bss_rest : + ∀ x ∈ Block.userBlockLabels bss, x ∉ Block.userBlockLabels rest := + Block.userLabels_loop_cross_disj c m is bss md rest gen' h_disj + -- Now branch on m, then on c. + cases h_m_cases : m with + | none => + rw [h_m_cases] at h_gen + simp only [pure, StateT.pure, bind, StateT.bind] at h_gen + -- Decompose body, mapM. + generalize h_body_eq : + stmtsToBlocks lentry bss ((none, kNext) :: exitConts) [] gen_le = r_body at h_gen + obtain ⟨⟨bl, bbs⟩, gen_b⟩ := r_body + simp only at h_gen + generalize h_inv_def : + ((is.mapM (fun (srcLabel, i) => do + let assertLabel ← + if srcLabel.isEmpty then StringGenState.gen "inv$" + else pure srcLabel + pure (HasPassiveCmds.assert (P := P) (CmdT := Cmd P) assertLabel i synthesizedMd))) + : LabelGen.StringGenM (List (Cmd P))) gen_b = r_inv at h_gen + obtain ⟨invCmds, gen_i⟩ := r_inv + simp only at h_gen + have h_step_body := stmtsToBlocks_genStep lentry bss _ [] gen_le gen_b bl bbs h_body_eq + have h_step_inv : StringGenState.GenStep gen_b gen_i := by + apply mapM_genStep _ _ is gen_b gen_i invCmds h_inv_def + intro a g g' b' h_step + obtain ⟨srcLabel, i⟩ := a + by_cases h_empty : srcLabel.isEmpty + · simp only [h_empty, if_true, bind, StateT.bind, pure, StateT.pure] at h_step + have h_g_eq : g' = (StringGenState.gen "inv$" g).2 := (Prod.mk.inj h_step).2.symm + rw [h_g_eq]; exact StringGenState.GenStep.of_gen "inv$" g + · simp only [h_empty, bind, pure] at h_step + have h_g_eq : g' = g := (Prod.mk.inj h_step).2.symm + rw [h_g_eq]; exact StringGenState.GenStep.refl g + cases h_c : c with + | det e => + rw [h_c] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "before_loop$" accum + Option.none lentry gen_i = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_pair := (Prod.mk.inj h_gen).1 + have h_entry_eq : accumEntry = entry := (Prod.mk.inj h_pair).1 + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + subst h_entry_eq + -- The lentry block content. + let contractMd : MetaData P := is.foldl (fun md (_, inv) => + md.pushElem MetaData.specLoopInvariant (.expr inv)) md + let lentryBlk : DetBlock String (Cmd P) P := + { cmds := invCmds ++ [], + transfer := DetTransferCmd.condGoto e bl kNext contractMd } + have h_blocks_eq : + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [] ++ bsNext = blocks := + (Prod.mk.inj h_pair).2 + have h_step_flush : StringGenState.GenStep gen_i gen_f := + flushCmds_genStep "before_loop$" accum _ lentry gen_i gen_f + accumEntry accumBlocks h_flush_eq + -- Subset relations w.r.t. gen' = gen_f. + have h_step_chain_r_to_f : StringGenState.GenStep gen_r gen_f := + (((h_step_le.trans h_step_body).trans h_step_inv).trans h_step_flush) + have h_subset_r_gen' : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens gen' := by + rw [← h_gen_eq]; exact h_step_chain_r_to_f.subset + have h_subset_le_gen' : StringGenState.stringGens gen_le ⊆ StringGenState.stringGens gen' := by + rw [← h_gen_eq]; exact ((h_step_body.trans h_step_inv).trans h_step_flush).subset + have h_subset_b_gen' : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens gen' := by + rw [← h_gen_eq]; exact (h_step_inv.trans h_step_flush).subset + have h_subset_i_gen' : StringGenState.stringGens gen_i ⊆ StringGenState.stringGens gen' := by + rw [← h_gen_eq]; exact h_step_flush.subset + -- Disjointness for sub-IH inputs. + have h_disj_rest_gen_r : Block.userLabelsDisjoint rest gen_r := + Block.userLabelsDisjoint_mono _ _ _ h_disj_rest_gen' h_subset_r_gen' + have h_disj_bss_gen_b : Block.userLabelsDisjoint bss gen_b := + Block.userLabelsDisjoint_mono _ _ _ h_disj_bss_gen' h_subset_b_gen' + -- IH on rest. + have h_inv_rest : + @GenInv P gen gen_r (Block.userBlockLabels rest) bsNext := + stmtsToBlocks_invariant k rest exitConts [] gen gen_r kNext bsNext h_rest_eq hwf + h_disj_rest_gen_r + have hwf_r := h_inv_rest.wf_out + -- gen_r → gen_le via empty_step. + have h_inv_le_step : @GenInv P gen_r gen_le [] [] := + GenInv.empty_step gen_r gen_le hwf_r h_step_le + have hwf_le : StringGenState.WF gen_le := h_inv_le_step.wf_out + -- IH on body (bss). + have h_inv_body : + @GenInv P gen_le gen_b (Block.userBlockLabels bss) bbs := + stmtsToBlocks_invariant lentry bss _ [] gen_le gen_b bl bbs h_body_eq hwf_le + h_disj_bss_gen_b + have hwf_b := h_inv_body.wf_out + -- gen_b → gen_i via empty_step. + have h_inv_inv_step : @GenInv P gen_b gen_i [] [] := + GenInv.empty_step gen_b gen_i hwf_b h_step_inv + have hwf_i : StringGenState.WF gen_i := h_inv_inv_step.wf_out + -- gen_i → gen_f via flush invariant. + have h_inv_flush : @GenInv P gen_i gen_f [] accumBlocks := + flushCmds_invariant "before_loop$" accum _ lentry gen_i gen_f + accumEntry accumBlocks h_flush_eq hwf_i + -- Compose chronologically: gen → gen_r → gen_le → gen_b → gen_i → gen_f. + have h_inv_r_le : + @GenInv P gen gen_le (Block.userBlockLabels rest ++ []) (bsNext ++ []) := + GenInv.trans gen gen_r gen_le _ _ _ _ h_inv_rest h_inv_le_step + (by intros _ _ h_in; simp at h_in) + have h_user_r_simp : + Block.userBlockLabels rest ++ ([] : List String) = Block.userBlockLabels rest := by simp + have h_blks_r_simp : bsNext ++ ([] : List (String × DetBlock String (Cmd P) P)) = bsNext := by simp + rw [h_user_r_simp, h_blks_r_simp] at h_inv_r_le + have h_inv_r_b : + @GenInv P gen gen_b + (Block.userBlockLabels rest ++ Block.userBlockLabels bss) + (bsNext ++ bbs) := + GenInv.trans gen gen_le gen_b _ _ _ _ h_inv_r_le h_inv_body + (by intro x h_x_r h_x_b; exact h_user_disj_bss_rest x h_x_b h_x_r) + have h_inv_r_i : + @GenInv P gen gen_i + (Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ []) + ((bsNext ++ bbs) ++ []) := + GenInv.trans gen gen_b gen_i _ _ _ _ h_inv_r_b h_inv_inv_step + (by intros _ _ h_in; simp at h_in) + have h_user_simp_i : + Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ ([] : List String) + = Block.userBlockLabels rest ++ Block.userBlockLabels bss := by simp + have h_blks_simp_i : + (bsNext ++ bbs) ++ ([] : List (String × DetBlock String (Cmd P) P)) + = bsNext ++ bbs := by simp + rw [h_user_simp_i, h_blks_simp_i] at h_inv_r_i + have h_inv_chron : + @GenInv P gen gen_f + (Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ []) + ((bsNext ++ bbs) ++ accumBlocks) := + GenInv.trans gen gen_i gen_f _ _ _ _ h_inv_r_i h_inv_flush + (by intros _ _ h_in; simp at h_in) + have h_user_simp : + Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ ([] : List String) + = Block.userBlockLabels rest ++ Block.userBlockLabels bss := by simp + rw [h_user_simp] at h_inv_chron + -- Prepend (lentry, lentryBlk) using cons_gen. lentry is generated from gen_r. + have h_lentry_in_gen_le : lentry ∈ StringGenState.stringGens gen_le := by + rw [show lentry = (StringGenState.gen "loop_entry$" gen_r).1 from + (by rw [h_lentry_def])] + rw [show gen_le = (StringGenState.gen "loop_entry$" gen_r).2 from + (by rw [h_lentry_def])] + rw [StringGenState.stringGens_gen] + exact List.mem_cons.mpr (Or.inl rfl) + have h_lentry_in_gen_f : lentry ∈ StringGenState.stringGens gen_f := + ((h_step_body.trans h_step_inv).trans h_step_flush).subset h_lentry_in_gen_le + have h_lentry_notin_gen_r : lentry ∉ StringGenState.stringGens gen_r := by + intro h_in + have h_lentry_eq : lentry = (StringGenState.gen "loop_entry$" gen_r).1 := by + rw [h_lentry_def] + have h_notin := + StringGenState.stringGens_gen_not_in "loop_entry$" gen_r hwf_r + rw [h_lentry_eq] at h_in + exact h_notin h_in + have h_lentry_notin_gen : lentry ∉ StringGenState.stringGens gen := by + intro h_in; exact h_lentry_notin_gen_r (h_step_rest.subset h_in) + -- lentry not in any of the existing block labels (bsNext, bbs, accumBlocks). + have h_lentry_notin_blks : lentry ∉ List.map Prod.fst ((bsNext ++ bbs) ++ accumBlocks) := by + intro h_in + rcases h_inv_chron.fresh lentry h_in with h_g | h_user + · -- lentry ∈ gen_f \ gen — but lentry was generated from gen_r, so + -- lentry was generated before this whole computation? No, lentry IS + -- in gen_le ⊆ gen_f, but we've shown lentry ∉ gen_r. So + -- lentry ∉ gen ⇒ contradicts h_g.2. Actually h_g.2 says lentry ∉ gen, + -- which is true. So this branch tells us nothing inconsistent; + -- we need to show this lentry-as-block-label is impossible. + -- Actually the issue: cons_gen requires lentry ∉ existing block labels. + -- One of bsNext, bbs, accumBlocks could have lentry as a label. + -- But: bsNext came from gen → gen_r (so its labels are in gen_r), + -- bbs came from gen_le → gen_b (labels in gen_b), + -- accumBlocks came from gen_i → gen_f (labels in gen_f \ gen_i). + -- bsNext's labels ⊆ gen_r: but lentry ∉ gen_r. Good. + -- bbs's labels: each is in gen_b \ gen_le or in user labels of bss. + -- (a) gen_b \ gen_le: lentry ∈ gen_le, so excludes lentry. + -- (b) user labels of bss: would mean lentry has user shape, but + -- lentry was just generated, so it has gen-shape from gen_le. + -- More precisely, by user_disj of h_disj on bss, user-labels + -- are not in gen' = gen_f. But lentry ∈ gen_f, so lentry is + -- NOT a user label. + -- accumBlocks's labels ⊆ gen_f \ gen_i. lentry ∈ gen_le ⊆ gen_i, so + -- lentry is in gen_i. Contradicts the freshness condition. + -- We have h_g.2 : lentry ∉ stringGens gen. That's just true, not contradictory. + -- We need the deeper fact: lentry is not in any of these block-label sets. + -- The cleanest route: show separately for each of the three block lists. + rw [List.map_append, List.map_append, List.mem_append, List.mem_append] at h_in + rcases h_in with (h_bs | h_bb) | h_ac + · -- bsNext: from h_inv_rest.fresh + rcases h_inv_rest.fresh lentry h_bs with h_gr | h_user + · exact h_lentry_notin_gen_r h_gr.1 + · have h_shape := h_inv_rest.user_shape lentry h_user + have h_shape_lentry : + String.HasUnderscoreDigitSuffix lentry := by + have := StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + (h_inv_le_step.wf_out) h_lentry_in_gen_le + exact this + exact h_shape h_shape_lentry + · -- bbs: from h_inv_body.fresh + rcases h_inv_body.fresh lentry h_bb with h_gb | h_user + · -- lentry ∉ stringGens gen_le (= h_gb.2): but h_lentry_in_gen_le says lentry ∈ gen_le. + exact h_gb.2 h_lentry_in_gen_le + · -- lentry would be a user label of bss + have h_shape := h_inv_body.user_shape lentry h_user + have h_shape_lentry : + String.HasUnderscoreDigitSuffix lentry := + StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + (h_inv_le_step.wf_out) h_lentry_in_gen_le + exact h_shape h_shape_lentry + · -- accumBlocks: from h_inv_flush.fresh + cases h_inv_flush.fresh lentry h_ac with + | inl h_gf => exact h_gf.2 ((h_step_body.trans h_step_inv).subset h_lentry_in_gen_le) + | inr h_user => simp at h_user + · -- lentry would be in (rest ++ bss) user labels: shape contradiction. + have h_shape : ¬ String.HasUnderscoreDigitSuffix lentry := by + rw [List.mem_append] at h_user + exact h_user.elim + (fun h_r => h_inv_rest.user_shape lentry h_r) + (fun h_b => h_inv_body.user_shape lentry h_b) + have h_shape_lentry : + String.HasUnderscoreDigitSuffix lentry := + StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + (h_inv_le_step.wf_out) h_lentry_in_gen_le + exact h_shape h_shape_lentry + -- Now apply cons_gen. + have h_inv_with_lentry : + @GenInv P gen gen_f + (Block.userBlockLabels rest ++ Block.userBlockLabels bss) + ((lentry, lentryBlk) :: ((bsNext ++ bbs) ++ accumBlocks)) := + GenInv.cons_gen gen gen gen_f _ _ lentry lentryBlk hwf + (StringGenState.GenStep.refl gen) h_inv_chron h_lentry_in_gen_f + h_lentry_notin_gen h_lentry_notin_blks + -- Permute to align with output ordering: accumBlocks ++ [(lentry,_)] ++ bbs ++ [] ++ bsNext + -- ~ (lentry,_) :: (bsNext ++ bbs ++ accumBlocks). + have h_perm : + ((lentry, lentryBlk) :: ((bsNext ++ bbs) ++ accumBlocks)).Perm + (accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [] ++ bsNext) := by + have h_target : + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ ([] : List (String × DetBlock String (Cmd P) P)) ++ bsNext + = accumBlocks ++ ((lentry, lentryBlk) :: (bbs ++ bsNext)) := by + simp [List.append_assoc, List.singleton_append] + rw [h_target] + have h1 : ((lentry, lentryBlk) :: ((bsNext ++ bbs) ++ accumBlocks)).Perm + ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ bbs))) := + List.Perm.cons _ List.perm_append_comm + have h2 : ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ bbs))).Perm + (accumBlocks ++ (lentry, lentryBlk) :: (bsNext ++ bbs)) := + (List.perm_middle (a := (lentry, lentryBlk)) + (l₁ := accumBlocks) (l₂ := bsNext ++ bbs)).symm + have h3 : (accumBlocks ++ (lentry, lentryBlk) :: (bsNext ++ bbs)).Perm + (accumBlocks ++ (lentry, lentryBlk) :: (bbs ++ bsNext)) := + List.Perm.append_left accumBlocks + (List.Perm.cons _ List.perm_append_comm) + exact (h1.trans h2).trans h3 + have h_inv_perm := GenInv.perm gen gen_f _ _ _ h_inv_with_lentry h_perm + rw [← h_blocks_eq, ← h_gen_eq] + -- Goal userLabels: userBlockLabels (.loop ...) = bss-labels ++ rest-labels + rw [Block.userBlockLabels_loop_cons] + apply GenInv.weaken_userLabels gen gen_f _ _ _ h_inv_perm + · intro x hx + rw [List.mem_append] at hx + rw [List.mem_append] + exact hx.elim (fun h_r => Or.inr h_r) (fun h_b => Or.inl h_b) + · intro x hx; exact h_disj.1 x hx + · intro x hx h_in + rw [h_gen_eq] at h_in + exact h_disj.2.2 x hx h_in + · exact h_disj.2.1 + | nondet => + rw [h_c] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_nondet_gen : StringGenState.gen "$__nondet_loop$" gen_i = r_nd at h_gen + obtain ⟨freshName, gen_n⟩ := r_nd + simp only at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "before_loop$" accum + Option.none lentry gen_n = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_pair := (Prod.mk.inj h_gen).1 + have h_entry_eq : accumEntry = entry := (Prod.mk.inj h_pair).1 + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + subst h_entry_eq + let contractMd : MetaData P := is.foldl (fun md (_, inv) => + md.pushElem MetaData.specLoopInvariant (.expr inv)) md + let lentryBlk : DetBlock String (Cmd P) P := + { cmds := [HasInit.init (HasIdent.ident (P := P) freshName) + HasBool.boolTy ExprOrNondet.nondet synthesizedMd] ++ invCmds ++ [], + transfer := DetTransferCmd.condGoto + (HasFvar.mkFvar (HasIdent.ident (P := P) freshName)) bl kNext contractMd } + have h_blocks_eq : + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [] ++ bsNext = blocks := + (Prod.mk.inj h_pair).2 + have h_step_nondet : StringGenState.GenStep gen_i gen_n := by + rw [show gen_n = (StringGenState.gen "$__nondet_loop$" gen_i).2 from + (by rw [h_nondet_gen])] + exact StringGenState.GenStep.of_gen "$__nondet_loop$" gen_i + have h_step_flush : StringGenState.GenStep gen_n gen_f := + flushCmds_genStep "before_loop$" accum _ lentry gen_n gen_f + accumEntry accumBlocks h_flush_eq + -- Subset relations. + have h_step_chain_r_to_f : StringGenState.GenStep gen_r gen_f := + ((((h_step_le.trans h_step_body).trans h_step_inv).trans h_step_nondet).trans + h_step_flush) + have h_subset_r_gen' : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens gen' := by + rw [← h_gen_eq]; exact h_step_chain_r_to_f.subset + have h_subset_b_gen' : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ ((h_step_inv.trans h_step_nondet).trans h_step_flush).subset + -- Disjointness for sub-IH. + have h_disj_rest_gen_r : Block.userLabelsDisjoint rest gen_r := + Block.userLabelsDisjoint_mono _ _ _ h_disj_rest_gen' h_subset_r_gen' + have h_disj_bss_gen_b : Block.userLabelsDisjoint bss gen_b := + Block.userLabelsDisjoint_mono _ _ _ h_disj_bss_gen' h_subset_b_gen' + have h_inv_rest : + @GenInv P gen gen_r (Block.userBlockLabels rest) bsNext := + stmtsToBlocks_invariant k rest exitConts [] gen gen_r kNext bsNext h_rest_eq hwf + h_disj_rest_gen_r + have hwf_r := h_inv_rest.wf_out + have h_inv_le_step : @GenInv P gen_r gen_le [] [] := + GenInv.empty_step gen_r gen_le hwf_r h_step_le + have hwf_le : StringGenState.WF gen_le := h_inv_le_step.wf_out + have h_inv_body : + @GenInv P gen_le gen_b (Block.userBlockLabels bss) bbs := + stmtsToBlocks_invariant lentry bss _ [] gen_le gen_b bl bbs h_body_eq hwf_le + h_disj_bss_gen_b + have hwf_b := h_inv_body.wf_out + have h_inv_inv_step : @GenInv P gen_b gen_i [] [] := + GenInv.empty_step gen_b gen_i hwf_b h_step_inv + have hwf_i : StringGenState.WF gen_i := h_inv_inv_step.wf_out + have h_inv_nondet_step : @GenInv P gen_i gen_n [] [] := + GenInv.empty_step gen_i gen_n hwf_i h_step_nondet + have hwf_n : StringGenState.WF gen_n := h_inv_nondet_step.wf_out + have h_inv_flush : @GenInv P gen_n gen_f [] accumBlocks := + flushCmds_invariant "before_loop$" accum _ lentry gen_n gen_f + accumEntry accumBlocks h_flush_eq hwf_n + -- Compose chronologically. + have h_inv_r_le : + @GenInv P gen gen_le (Block.userBlockLabels rest ++ []) (bsNext ++ []) := + GenInv.trans gen gen_r gen_le _ _ _ _ h_inv_rest h_inv_le_step + (by intros _ _ h_in; simp at h_in) + have h_user_r_simp : + Block.userBlockLabels rest ++ ([] : List String) = Block.userBlockLabels rest := by simp + have h_blks_r_simp : bsNext ++ ([] : List (String × DetBlock String (Cmd P) P)) = bsNext := by simp + rw [h_user_r_simp, h_blks_r_simp] at h_inv_r_le + have h_inv_r_b : + @GenInv P gen gen_b + (Block.userBlockLabels rest ++ Block.userBlockLabels bss) + (bsNext ++ bbs) := + GenInv.trans gen gen_le gen_b _ _ _ _ h_inv_r_le h_inv_body + (by intro x h_x_r h_x_b; exact h_user_disj_bss_rest x h_x_b h_x_r) + have h_inv_r_i : + @GenInv P gen gen_i + (Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ []) + ((bsNext ++ bbs) ++ []) := + GenInv.trans gen gen_b gen_i _ _ _ _ h_inv_r_b h_inv_inv_step + (by intros _ _ h_in; simp at h_in) + have h_user_simp_i : + Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ ([] : List String) + = Block.userBlockLabels rest ++ Block.userBlockLabels bss := by simp + have h_blks_simp_i : + (bsNext ++ bbs) ++ ([] : List (String × DetBlock String (Cmd P) P)) + = bsNext ++ bbs := by simp + rw [h_user_simp_i, h_blks_simp_i] at h_inv_r_i + have h_inv_r_n : + @GenInv P gen gen_n + (Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ []) + ((bsNext ++ bbs) ++ []) := + GenInv.trans gen gen_i gen_n _ _ _ _ h_inv_r_i h_inv_nondet_step + (by intros _ _ h_in; simp at h_in) + rw [h_user_simp_i, h_blks_simp_i] at h_inv_r_n + have h_inv_chron : + @GenInv P gen gen_f + (Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ []) + ((bsNext ++ bbs) ++ accumBlocks) := + GenInv.trans gen gen_n gen_f _ _ _ _ h_inv_r_n h_inv_flush + (by intros _ _ h_in; simp at h_in) + rw [h_user_simp_i] at h_inv_chron + -- Prepend lentry block via cons_gen. + have h_lentry_in_gen_le : lentry ∈ StringGenState.stringGens gen_le := by + rw [show lentry = (StringGenState.gen "loop_entry$" gen_r).1 from + (by rw [h_lentry_def])] + rw [show gen_le = (StringGenState.gen "loop_entry$" gen_r).2 from + (by rw [h_lentry_def])] + rw [StringGenState.stringGens_gen] + exact List.mem_cons.mpr (Or.inl rfl) + have h_lentry_in_gen_f : lentry ∈ StringGenState.stringGens gen_f := + (((h_step_body.trans h_step_inv).trans h_step_nondet).trans h_step_flush).subset + h_lentry_in_gen_le + have h_lentry_notin_gen_r : lentry ∉ StringGenState.stringGens gen_r := by + intro h_in + have h_lentry_eq : lentry = (StringGenState.gen "loop_entry$" gen_r).1 := by + rw [h_lentry_def] + have h_notin := + StringGenState.stringGens_gen_not_in "loop_entry$" gen_r hwf_r + rw [h_lentry_eq] at h_in + exact h_notin h_in + have h_lentry_notin_gen : lentry ∉ StringGenState.stringGens gen := by + intro h_in; exact h_lentry_notin_gen_r (h_step_rest.subset h_in) + have h_lentry_notin_blks : lentry ∉ List.map Prod.fst ((bsNext ++ bbs) ++ accumBlocks) := by + intro h_in + rw [List.map_append, List.map_append, List.mem_append, List.mem_append] at h_in + rcases h_in with (h_bs | h_bb) | h_ac + · rcases h_inv_rest.fresh lentry h_bs with h_gr | h_user + · exact h_lentry_notin_gen_r h_gr.1 + · have h_shape := h_inv_rest.user_shape lentry h_user + exact h_shape (StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + (h_inv_le_step.wf_out) h_lentry_in_gen_le) + · rcases h_inv_body.fresh lentry h_bb with h_gb | h_user + · exact h_gb.2 h_lentry_in_gen_le + · have h_shape := h_inv_body.user_shape lentry h_user + exact h_shape (StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + (h_inv_le_step.wf_out) h_lentry_in_gen_le) + · rcases h_inv_flush.fresh lentry h_ac with h_gf | h_user + · -- lentry ∈ gen_le ⊆ gen_n: contradicts h_gf.2 (lentry ∉ gen_n). + exact h_gf.2 (((h_step_body.trans h_step_inv).trans h_step_nondet).subset + h_lentry_in_gen_le) + · simp at h_user + have h_inv_with_lentry : + @GenInv P gen gen_f + (Block.userBlockLabels rest ++ Block.userBlockLabels bss) + ((lentry, lentryBlk) :: ((bsNext ++ bbs) ++ accumBlocks)) := + GenInv.cons_gen gen gen gen_f _ _ lentry lentryBlk hwf + (StringGenState.GenStep.refl gen) h_inv_chron h_lentry_in_gen_f + h_lentry_notin_gen h_lentry_notin_blks + have h_perm : + ((lentry, lentryBlk) :: ((bsNext ++ bbs) ++ accumBlocks)).Perm + (accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [] ++ bsNext) := by + have h_target : + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ ([] : List (String × DetBlock String (Cmd P) P)) ++ bsNext + = accumBlocks ++ ((lentry, lentryBlk) :: (bbs ++ bsNext)) := by + simp [List.append_assoc, List.singleton_append] + rw [h_target] + have h1 : ((lentry, lentryBlk) :: ((bsNext ++ bbs) ++ accumBlocks)).Perm + ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ bbs))) := + List.Perm.cons _ List.perm_append_comm + have h2 : ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ bbs))).Perm + (accumBlocks ++ (lentry, lentryBlk) :: (bsNext ++ bbs)) := + (List.perm_middle (a := (lentry, lentryBlk)) + (l₁ := accumBlocks) (l₂ := bsNext ++ bbs)).symm + have h3 : (accumBlocks ++ (lentry, lentryBlk) :: (bsNext ++ bbs)).Perm + (accumBlocks ++ (lentry, lentryBlk) :: (bbs ++ bsNext)) := + List.Perm.append_left accumBlocks + (List.Perm.cons _ List.perm_append_comm) + exact (h1.trans h2).trans h3 + have h_inv_perm := GenInv.perm gen gen_f _ _ _ h_inv_with_lentry h_perm + rw [← h_blocks_eq, ← h_gen_eq, Block.userBlockLabels_loop_cons] + apply GenInv.weaken_userLabels gen gen_f _ _ _ h_inv_perm + · intro x hx + rw [List.mem_append] at hx + rw [List.mem_append] + exact hx.elim (fun h_r => Or.inr h_r) (fun h_b => Or.inl h_b) + · intro x hx; exact h_disj.1 x hx + · intro x hx h_in + rw [h_gen_eq] at h_in + exact h_disj.2.2 x hx h_in + · exact h_disj.2.1 + | some mExpr => + rw [h_m_cases] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_ml_def : StringGenState.gen "loop_measure$" gen_le = r_ml at h_gen + obtain ⟨mLabel, gen_ml⟩ := r_ml + simp only at h_gen + generalize h_ldec_def : StringGenState.gen "measure_decrease$" gen_ml = r_ldec at h_gen + obtain ⟨ldec, gen_ldec⟩ := r_ldec + simp only at h_gen + have h_step_ml : StringGenState.GenStep gen_le gen_ml := by + rw [show gen_ml = (StringGenState.gen "loop_measure$" gen_le).2 from + (by rw [h_ml_def])] + exact StringGenState.GenStep.of_gen "loop_measure$" gen_le + have h_step_ldec : StringGenState.GenStep gen_ml gen_ldec := by + rw [show gen_ldec = (StringGenState.gen "measure_decrease$" gen_ml).2 from + (by rw [h_ldec_def])] + exact StringGenState.GenStep.of_gen "measure_decrease$" gen_ml + generalize h_body_eq : + stmtsToBlocks ldec bss ((none, kNext) :: exitConts) [] gen_ldec = r_body at h_gen + obtain ⟨⟨bl, bbs⟩, gen_b⟩ := r_body + simp only at h_gen + generalize h_inv_def : + ((is.mapM (fun (srcLabel, i) => do + let assertLabel ← + if srcLabel.isEmpty then StringGenState.gen "inv$" + else pure srcLabel + pure (HasPassiveCmds.assert (P := P) (CmdT := Cmd P) assertLabel i synthesizedMd))) + : LabelGen.StringGenM (List (Cmd P))) gen_b = r_inv at h_gen + obtain ⟨invCmds, gen_i⟩ := r_inv + simp only at h_gen + have h_step_body := stmtsToBlocks_genStep ldec bss _ [] gen_ldec gen_b bl bbs h_body_eq + have h_step_inv : StringGenState.GenStep gen_b gen_i := by + apply mapM_genStep _ _ is gen_b gen_i invCmds h_inv_def + intro a g g' b' h_step + obtain ⟨srcLabel, i⟩ := a + by_cases h_empty : srcLabel.isEmpty + · simp only [h_empty, if_true, bind, StateT.bind, pure, StateT.pure] at h_step + have h_g_eq : g' = (StringGenState.gen "inv$" g).2 := (Prod.mk.inj h_step).2.symm + rw [h_g_eq]; exact StringGenState.GenStep.of_gen "inv$" g + · simp only [h_empty, bind, pure] at h_step + have h_g_eq : g' = g := (Prod.mk.inj h_step).2.symm + rw [h_g_eq]; exact StringGenState.GenStep.refl g + cases h_c : c with + | det e => + rw [h_c] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "before_loop$" accum + Option.none lentry gen_i = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_pair := (Prod.mk.inj h_gen).1 + have h_entry_eq : accumEntry = entry := (Prod.mk.inj h_pair).1 + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + subst h_entry_eq + let mIdent := HasIdent.ident (P := P) mLabel + let mOldExpr := HasFvar.mkFvar (P := P) mIdent + let initCmd : Cmd P := + HasInit.init mIdent HasIntOrder.intTy ExprOrNondet.nondet synthesizedMd + let assumeCmd : Cmd P := + HasPassiveCmds.assume s!"assume_{mLabel}" + (HasIntOrder.eq mOldExpr mExpr) synthesizedMd + let lbCmd : Cmd P := + HasPassiveCmds.assert s!"measure_lb_{mLabel}" + (HasNot.not (HasIntOrder.lt mOldExpr HasIntOrder.zero)) synthesizedMd + let decCmd : Cmd P := + HasPassiveCmds.assert s!"measure_decrease_{mLabel}" + (HasIntOrder.lt mExpr mOldExpr) synthesizedMd + let measureCmds : List (Cmd P) := [initCmd, assumeCmd, lbCmd] + let decBlock : String × DetBlock String (Cmd P) P := + (ldec, { cmds := [decCmd], transfer := DetTransferCmd.goto lentry synthesizedMd }) + let contractMd : MetaData P := + (is.foldl (fun md (_, inv) => + md.pushElem MetaData.specLoopInvariant (.expr inv)) md).pushElem + MetaData.specDecreases (.expr mExpr) + let lentryBlk : DetBlock String (Cmd P) P := + { cmds := invCmds ++ measureCmds, + transfer := DetTransferCmd.condGoto e bl kNext contractMd } + have h_blocks_eq : + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [decBlock] ++ bsNext = blocks := + (Prod.mk.inj h_pair).2 + have h_step_flush : StringGenState.GenStep gen_i gen_f := + flushCmds_genStep "before_loop$" accum _ lentry gen_i gen_f + accumEntry accumBlocks h_flush_eq + have h_step_le_to_b : StringGenState.GenStep gen_le gen_b := + ((h_step_ml.trans h_step_ldec).trans h_step_body) + have h_step_chain_r_to_f : StringGenState.GenStep gen_r gen_f := + ((((h_step_le.trans h_step_le_to_b).trans h_step_inv)).trans h_step_flush) + have h_subset_r_gen' : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens gen' := by + rw [← h_gen_eq]; exact h_step_chain_r_to_f.subset + have h_subset_b_gen' : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens gen' := by + rw [← h_gen_eq]; exact (h_step_inv.trans h_step_flush).subset + have h_disj_rest_gen_r : Block.userLabelsDisjoint rest gen_r := + Block.userLabelsDisjoint_mono _ _ _ h_disj_rest_gen' h_subset_r_gen' + have h_disj_bss_gen_b : Block.userLabelsDisjoint bss gen_b := + Block.userLabelsDisjoint_mono _ _ _ h_disj_bss_gen' h_subset_b_gen' + have h_inv_rest : + @GenInv P gen gen_r (Block.userBlockLabels rest) bsNext := + stmtsToBlocks_invariant k rest exitConts [] gen gen_r kNext bsNext h_rest_eq hwf + h_disj_rest_gen_r + have hwf_r := h_inv_rest.wf_out + have h_inv_le_step : @GenInv P gen_r gen_le [] [] := + GenInv.empty_step gen_r gen_le hwf_r h_step_le + have hwf_le : StringGenState.WF gen_le := h_inv_le_step.wf_out + -- After cases on m has simplified, the match-result here is + -- (measureCmds, ldec, [decBlock]) at gen_ldec. Build it directly via cons_gen. + have hwf_ml : StringGenState.WF gen_ml := h_step_ml.wf_mono hwf_le + have h_inv_ml_step : @GenInv P gen_le gen_ml [] [] := + GenInv.empty_step gen_le gen_ml hwf_le h_step_ml + have h_inv_ldec_step : @GenInv P gen_ml gen_ldec [] [] := + GenInv.empty_step gen_ml gen_ldec hwf_ml h_step_ldec + have hwf_ldec : StringGenState.WF gen_ldec := h_inv_ldec_step.wf_out + -- ldec freshly generated from gen_ml. + have h_ldec_in_gen_ldec : ldec ∈ StringGenState.stringGens gen_ldec := by + rw [show ldec = (StringGenState.gen "measure_decrease$" gen_ml).1 from + (by rw [h_ldec_def])] + rw [show gen_ldec = (StringGenState.gen "measure_decrease$" gen_ml).2 from + (by rw [h_ldec_def])] + rw [StringGenState.stringGens_gen] + exact List.mem_cons.mpr (Or.inl rfl) + have h_ldec_notin_gen_ml : ldec ∉ StringGenState.stringGens gen_ml := by + intro h_in + have h_ldec_eq : ldec = (StringGenState.gen "measure_decrease$" gen_ml).1 := by + rw [h_ldec_def] + have h_notin := + StringGenState.stringGens_gen_not_in "measure_decrease$" gen_ml hwf_ml + rw [h_ldec_eq] at h_in + exact h_notin h_in + -- IH on body. + have h_inv_body : + @GenInv P gen_ldec gen_b (Block.userBlockLabels bss) bbs := + stmtsToBlocks_invariant ldec bss _ [] gen_ldec gen_b bl bbs h_body_eq hwf_ldec + h_disj_bss_gen_b + have hwf_b := h_inv_body.wf_out + have h_inv_inv_step : @GenInv P gen_b gen_i [] [] := + GenInv.empty_step gen_b gen_i hwf_b h_step_inv + have hwf_i : StringGenState.WF gen_i := h_inv_inv_step.wf_out + have h_inv_flush : @GenInv P gen_i gen_f [] accumBlocks := + flushCmds_invariant "before_loop$" accum _ lentry gen_i gen_f + accumEntry accumBlocks h_flush_eq hwf_i + -- Compose chain. + have h_inv_r_le : + @GenInv P gen gen_le (Block.userBlockLabels rest ++ []) (bsNext ++ []) := + GenInv.trans gen gen_r gen_le _ _ _ _ h_inv_rest h_inv_le_step + (by intros _ _ h_in; simp at h_in) + have h_user_r_simp : + Block.userBlockLabels rest ++ ([] : List String) = Block.userBlockLabels rest := by simp + have h_blks_r_simp : bsNext ++ ([] : List (String × DetBlock String (Cmd P) P)) = bsNext := by simp + rw [h_user_r_simp, h_blks_r_simp] at h_inv_r_le + have h_inv_r_ml : + @GenInv P gen gen_ml (Block.userBlockLabels rest ++ []) (bsNext ++ []) := + GenInv.trans gen gen_le gen_ml _ _ _ _ h_inv_r_le h_inv_ml_step + (by intros _ _ h_in; simp at h_in) + rw [h_user_r_simp, h_blks_r_simp] at h_inv_r_ml + -- Build GenInv at gen_ldec including the decrease block. + -- decrease block lives in gen_ldec only (ldec freshly generated). + have h_inv_ldec_only : @GenInv P gen_ml gen_ldec [] [decBlock] := by + apply GenInv.cons_gen gen_ml gen_ml gen_ldec [] [] ldec _ + hwf_ml (StringGenState.GenStep.refl gen_ml) h_inv_ldec_step + h_ldec_in_gen_ldec h_ldec_notin_gen_ml + simp + have h_inv_r_ldec : + @GenInv P gen gen_ldec + (Block.userBlockLabels rest ++ []) + (bsNext ++ [decBlock]) := + GenInv.trans gen gen_ml gen_ldec _ _ _ _ h_inv_r_ml h_inv_ldec_only + (by intros _ _ h_in; simp at h_in) + rw [h_user_r_simp] at h_inv_r_ldec + -- gen_ldec → gen_b via IH on body. + have h_inv_r_b : + @GenInv P gen gen_b + (Block.userBlockLabels rest ++ Block.userBlockLabels bss) + ((bsNext ++ [decBlock]) ++ bbs) := by + apply GenInv.trans gen gen_ldec gen_b _ _ _ _ h_inv_r_ldec h_inv_body + intro x h_x_r h_x_b; exact h_user_disj_bss_rest x h_x_b h_x_r + have h_inv_r_i : + @GenInv P gen gen_i + (Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ []) + (((bsNext ++ [decBlock]) ++ bbs) ++ []) := + GenInv.trans gen gen_b gen_i _ _ _ _ h_inv_r_b h_inv_inv_step + (by intros _ _ h_in; simp at h_in) + have h_user_simp_i : + Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ ([] : List String) + = Block.userBlockLabels rest ++ Block.userBlockLabels bss := by simp + rw [h_user_simp_i] at h_inv_r_i + have h_blks_simp : + ((bsNext ++ [decBlock]) ++ bbs) ++ ([] : List (String × DetBlock String (Cmd P) P)) + = bsNext ++ [decBlock] ++ bbs := by simp + rw [h_blks_simp] at h_inv_r_i + have h_inv_chron : + @GenInv P gen gen_f + (Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ []) + ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks) := + GenInv.trans gen gen_i gen_f _ _ _ _ h_inv_r_i h_inv_flush + (by intros _ _ h_in; simp at h_in) + rw [h_user_simp_i] at h_inv_chron + -- Now prepend (lentry, lentryBlk) via cons_gen. + have h_lentry_in_gen_le : lentry ∈ StringGenState.stringGens gen_le := by + rw [show lentry = (StringGenState.gen "loop_entry$" gen_r).1 from + (by rw [h_lentry_def])] + rw [show gen_le = (StringGenState.gen "loop_entry$" gen_r).2 from + (by rw [h_lentry_def])] + rw [StringGenState.stringGens_gen] + exact List.mem_cons.mpr (Or.inl rfl) + have h_lentry_in_gen_f : lentry ∈ StringGenState.stringGens gen_f := + ((h_step_le_to_b.trans h_step_inv).trans h_step_flush).subset h_lentry_in_gen_le + have h_lentry_notin_gen_r : lentry ∉ StringGenState.stringGens gen_r := by + intro h_in + have h_lentry_eq : lentry = (StringGenState.gen "loop_entry$" gen_r).1 := by + rw [h_lentry_def] + have h_notin := + StringGenState.stringGens_gen_not_in "loop_entry$" gen_r hwf_r + rw [h_lentry_eq] at h_in + exact h_notin h_in + have h_lentry_notin_gen : lentry ∉ StringGenState.stringGens gen := by + intro h_in; exact h_lentry_notin_gen_r (h_step_rest.subset h_in) + have h_lentry_notin_blks : + lentry ∉ List.map Prod.fst ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks) := by + intro h_in + rw [List.map_append, List.map_append, List.map_append, List.mem_append, List.mem_append, + List.mem_append] at h_in + rcases h_in with ((h_bs | h_dec) | h_bb) | h_ac + · rcases h_inv_rest.fresh lentry h_bs with h_gr | h_user + · exact h_lentry_notin_gen_r h_gr.1 + · have h_shape := h_inv_rest.user_shape lentry h_user + exact h_shape (StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + (h_inv_le_step.wf_out) h_lentry_in_gen_le) + · -- decBlock: lentry = ldec? ldec was generated from gen_ml, lentry from gen_r + -- We need: lentry ≠ ldec. + simp only [List.map_cons, List.map_nil, List.mem_singleton] at h_dec + -- h_dec : lentry = ldec.fst = ldec; this means lentry = ldec (= decBlock.1) + -- ldec ∈ gen_ldec, lentry ∈ gen_le ⊆ gen_ml. ldec ∉ gen_ml. + -- So if lentry = ldec then ldec ∈ gen_ml — contradicting h_ldec_notin_gen_ml. + rw [h_dec] at h_lentry_in_gen_le + -- h_lentry_in_gen_le : ldec ∈ gen_le + exact h_ldec_notin_gen_ml (h_step_ml.subset h_lentry_in_gen_le) + · rcases h_inv_body.fresh lentry h_bb with h_gb | h_user + · -- lentry ∈ gen_le ⊆ gen_ldec, but h_gb.2 says lentry ∉ gen_ldec. + exact h_gb.2 ((h_step_ml.trans h_step_ldec).subset h_lentry_in_gen_le) + · have h_shape := h_inv_body.user_shape lentry h_user + exact h_shape (StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + (h_inv_le_step.wf_out) h_lentry_in_gen_le) + · rcases h_inv_flush.fresh lentry h_ac with h_gf | h_user + · exact h_gf.2 ((h_step_le_to_b.trans h_step_inv).subset h_lentry_in_gen_le) + · simp at h_user + have h_inv_with_lentry : + @GenInv P gen gen_f + (Block.userBlockLabels rest ++ Block.userBlockLabels bss) + ((lentry, lentryBlk) :: ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks)) := + GenInv.cons_gen gen gen gen_f _ _ lentry lentryBlk hwf + (StringGenState.GenStep.refl gen) h_inv_chron h_lentry_in_gen_f + h_lentry_notin_gen h_lentry_notin_blks + -- Permute to align with output ordering. + -- accumBlocks ++ [(lentry, _)] ++ bbs ++ [decBlock] ++ bsNext + have h_perm : + ((lentry, lentryBlk) :: ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks)).Perm + (accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [decBlock] ++ bsNext) := by + have h_target : + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [decBlock] ++ bsNext + = accumBlocks ++ ((lentry, lentryBlk) :: (bbs ++ [decBlock] ++ bsNext)) := by + simp [List.append_assoc, List.singleton_append] + rw [h_target] + have h1 : ((lentry, lentryBlk) :: ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks)).Perm + ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ [decBlock] ++ bbs))) := + List.Perm.cons _ List.perm_append_comm + have h2 : ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ [decBlock] ++ bbs))).Perm + (accumBlocks ++ (lentry, lentryBlk) :: (bsNext ++ [decBlock] ++ bbs)) := + (List.perm_middle (a := (lentry, lentryBlk)) + (l₁ := accumBlocks) (l₂ := bsNext ++ [decBlock] ++ bbs)).symm + have h3 : (accumBlocks ++ (lentry, lentryBlk) :: (bsNext ++ [decBlock] ++ bbs)).Perm + (accumBlocks ++ (lentry, lentryBlk) :: (bbs ++ [decBlock] ++ bsNext)) := + List.Perm.append_left accumBlocks + (List.Perm.cons _ (by + -- bsNext ++ [decBlock] ++ bbs ~ bbs ++ [decBlock] ++ bsNext + have hh1 : (bsNext ++ [decBlock] ++ bbs).Perm + (bbs ++ (bsNext ++ [decBlock])) := + List.perm_append_comm + have hh2 : (bbs ++ (bsNext ++ [decBlock])).Perm + (bbs ++ ([decBlock] ++ bsNext)) := + List.Perm.append_left bbs List.perm_append_comm + have hh3 : (bbs ++ ([decBlock] ++ bsNext)) = (bbs ++ [decBlock] ++ bsNext) := by + rw [List.append_assoc] + exact (hh1.trans hh2).trans (hh3 ▸ List.Perm.refl _))) + exact (h1.trans h2).trans h3 + have h_inv_perm := GenInv.perm gen gen_f _ _ _ h_inv_with_lentry h_perm + rw [← h_blocks_eq, ← h_gen_eq, Block.userBlockLabels_loop_cons] + apply GenInv.weaken_userLabels gen gen_f _ _ _ h_inv_perm + · intro x hx + rw [List.mem_append] at hx + rw [List.mem_append] + exact hx.elim (fun h_r => Or.inr h_r) (fun h_b => Or.inl h_b) + · intro x hx; exact h_disj.1 x hx + · intro x hx h_in + rw [h_gen_eq] at h_in + exact h_disj.2.2 x hx h_in + · exact h_disj.2.1 + | nondet => + rw [h_c] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_nondet_gen : StringGenState.gen "$__nondet_loop$" gen_i = r_nd at h_gen + obtain ⟨freshName, gen_n⟩ := r_nd + simp only at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "before_loop$" accum + Option.none lentry gen_n = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_pair := (Prod.mk.inj h_gen).1 + have h_entry_eq : accumEntry = entry := (Prod.mk.inj h_pair).1 + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + subst h_entry_eq + let mIdent := HasIdent.ident (P := P) mLabel + let mOldExpr := HasFvar.mkFvar (P := P) mIdent + let initCmd : Cmd P := + HasInit.init mIdent HasIntOrder.intTy ExprOrNondet.nondet synthesizedMd + let assumeCmd : Cmd P := + HasPassiveCmds.assume s!"assume_{mLabel}" + (HasIntOrder.eq mOldExpr mExpr) synthesizedMd + let lbCmd : Cmd P := + HasPassiveCmds.assert s!"measure_lb_{mLabel}" + (HasNot.not (HasIntOrder.lt mOldExpr HasIntOrder.zero)) synthesizedMd + let decCmd : Cmd P := + HasPassiveCmds.assert s!"measure_decrease_{mLabel}" + (HasIntOrder.lt mExpr mOldExpr) synthesizedMd + let measureCmds : List (Cmd P) := [initCmd, assumeCmd, lbCmd] + let decBlock : String × DetBlock String (Cmd P) P := + (ldec, { cmds := [decCmd], transfer := DetTransferCmd.goto lentry synthesizedMd }) + let contractMd : MetaData P := + (is.foldl (fun md (_, inv) => + md.pushElem MetaData.specLoopInvariant (.expr inv)) md).pushElem + MetaData.specDecreases (.expr mExpr) + let lentryBlk : DetBlock String (Cmd P) P := + { cmds := [HasInit.init (HasIdent.ident (P := P) freshName) + HasBool.boolTy ExprOrNondet.nondet synthesizedMd] ++ invCmds ++ measureCmds, + transfer := DetTransferCmd.condGoto + (HasFvar.mkFvar (HasIdent.ident (P := P) freshName)) bl kNext contractMd } + have h_blocks_eq : + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [decBlock] ++ bsNext = blocks := + (Prod.mk.inj h_pair).2 + have h_step_nondet : StringGenState.GenStep gen_i gen_n := by + rw [show gen_n = (StringGenState.gen "$__nondet_loop$" gen_i).2 from + (by rw [h_nondet_gen])] + exact StringGenState.GenStep.of_gen "$__nondet_loop$" gen_i + have h_step_flush : StringGenState.GenStep gen_n gen_f := + flushCmds_genStep "before_loop$" accum _ lentry gen_n gen_f + accumEntry accumBlocks h_flush_eq + have h_step_le_to_b : StringGenState.GenStep gen_le gen_b := + ((h_step_ml.trans h_step_ldec).trans h_step_body) + have h_step_chain_r_to_f : StringGenState.GenStep gen_r gen_f := + (((((h_step_le.trans h_step_le_to_b).trans h_step_inv)).trans h_step_nondet).trans + h_step_flush) + have h_subset_r_gen' : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens gen' := by + rw [← h_gen_eq]; exact h_step_chain_r_to_f.subset + have h_subset_b_gen' : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens gen' := by + exact h_gen_eq ▸ ((h_step_inv.trans h_step_nondet).trans h_step_flush).subset + have h_disj_rest_gen_r : Block.userLabelsDisjoint rest gen_r := + Block.userLabelsDisjoint_mono _ _ _ h_disj_rest_gen' h_subset_r_gen' + have h_disj_bss_gen_b : Block.userLabelsDisjoint bss gen_b := + Block.userLabelsDisjoint_mono _ _ _ h_disj_bss_gen' h_subset_b_gen' + have h_inv_rest : + @GenInv P gen gen_r (Block.userBlockLabels rest) bsNext := + stmtsToBlocks_invariant k rest exitConts [] gen gen_r kNext bsNext h_rest_eq hwf + h_disj_rest_gen_r + have hwf_r := h_inv_rest.wf_out + have h_inv_le_step : @GenInv P gen_r gen_le [] [] := + GenInv.empty_step gen_r gen_le hwf_r h_step_le + have hwf_le : StringGenState.WF gen_le := h_inv_le_step.wf_out + have hwf_ml : StringGenState.WF gen_ml := h_step_ml.wf_mono hwf_le + have h_inv_ml_step : @GenInv P gen_le gen_ml [] [] := + GenInv.empty_step gen_le gen_ml hwf_le h_step_ml + have h_inv_ldec_step : @GenInv P gen_ml gen_ldec [] [] := + GenInv.empty_step gen_ml gen_ldec hwf_ml h_step_ldec + have hwf_ldec : StringGenState.WF gen_ldec := h_inv_ldec_step.wf_out + have h_ldec_in_gen_ldec : ldec ∈ StringGenState.stringGens gen_ldec := by + rw [show ldec = (StringGenState.gen "measure_decrease$" gen_ml).1 from + (by rw [h_ldec_def])] + rw [show gen_ldec = (StringGenState.gen "measure_decrease$" gen_ml).2 from + (by rw [h_ldec_def])] + rw [StringGenState.stringGens_gen] + exact List.mem_cons.mpr (Or.inl rfl) + have h_ldec_notin_gen_ml : ldec ∉ StringGenState.stringGens gen_ml := by + intro h_in + have h_ldec_eq : ldec = (StringGenState.gen "measure_decrease$" gen_ml).1 := by + rw [h_ldec_def] + have h_notin := + StringGenState.stringGens_gen_not_in "measure_decrease$" gen_ml hwf_ml + rw [h_ldec_eq] at h_in + exact h_notin h_in + have h_inv_body : + @GenInv P gen_ldec gen_b (Block.userBlockLabels bss) bbs := + stmtsToBlocks_invariant ldec bss _ [] gen_ldec gen_b bl bbs h_body_eq hwf_ldec + h_disj_bss_gen_b + have hwf_b := h_inv_body.wf_out + have h_inv_inv_step : @GenInv P gen_b gen_i [] [] := + GenInv.empty_step gen_b gen_i hwf_b h_step_inv + have hwf_i : StringGenState.WF gen_i := h_inv_inv_step.wf_out + have h_inv_nondet_step : @GenInv P gen_i gen_n [] [] := + GenInv.empty_step gen_i gen_n hwf_i h_step_nondet + have hwf_n : StringGenState.WF gen_n := h_inv_nondet_step.wf_out + have h_inv_flush : @GenInv P gen_n gen_f [] accumBlocks := + flushCmds_invariant "before_loop$" accum _ lentry gen_n gen_f + accumEntry accumBlocks h_flush_eq hwf_n + -- Compose chain: gen → gen_r → gen_le → gen_ml → gen_ldec → gen_b → gen_i → gen_n → gen_f + have h_inv_r_le : + @GenInv P gen gen_le (Block.userBlockLabels rest ++ []) (bsNext ++ []) := + GenInv.trans gen gen_r gen_le _ _ _ _ h_inv_rest h_inv_le_step + (by intros _ _ h_in; simp at h_in) + have h_user_r_simp : + Block.userBlockLabels rest ++ ([] : List String) = Block.userBlockLabels rest := by simp + have h_blks_r_simp : bsNext ++ ([] : List (String × DetBlock String (Cmd P) P)) = bsNext := by simp + rw [h_user_r_simp, h_blks_r_simp] at h_inv_r_le + have h_inv_r_ml : + @GenInv P gen gen_ml (Block.userBlockLabels rest ++ []) (bsNext ++ []) := + GenInv.trans gen gen_le gen_ml _ _ _ _ h_inv_r_le h_inv_ml_step + (by intros _ _ h_in; simp at h_in) + rw [h_user_r_simp, h_blks_r_simp] at h_inv_r_ml + have h_inv_ldec_only : @GenInv P gen_ml gen_ldec [] [decBlock] := by + apply GenInv.cons_gen gen_ml gen_ml gen_ldec [] [] ldec _ + hwf_ml (StringGenState.GenStep.refl gen_ml) h_inv_ldec_step + h_ldec_in_gen_ldec h_ldec_notin_gen_ml + simp + have h_inv_r_ldec : + @GenInv P gen gen_ldec + (Block.userBlockLabels rest ++ []) + (bsNext ++ [decBlock]) := + GenInv.trans gen gen_ml gen_ldec _ _ _ _ h_inv_r_ml h_inv_ldec_only + (by intros _ _ h_in; simp at h_in) + rw [h_user_r_simp] at h_inv_r_ldec + have h_inv_r_b : + @GenInv P gen gen_b + (Block.userBlockLabels rest ++ Block.userBlockLabels bss) + ((bsNext ++ [decBlock]) ++ bbs) := by + apply GenInv.trans gen gen_ldec gen_b _ _ _ _ h_inv_r_ldec h_inv_body + intro x h_x_r h_x_b; exact h_user_disj_bss_rest x h_x_b h_x_r + have h_inv_r_i : + @GenInv P gen gen_i + (Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ []) + (((bsNext ++ [decBlock]) ++ bbs) ++ []) := + GenInv.trans gen gen_b gen_i _ _ _ _ h_inv_r_b h_inv_inv_step + (by intros _ _ h_in; simp at h_in) + have h_user_simp_i : + Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ ([] : List String) + = Block.userBlockLabels rest ++ Block.userBlockLabels bss := by simp + rw [h_user_simp_i] at h_inv_r_i + have h_blks_simp : + ((bsNext ++ [decBlock]) ++ bbs) ++ ([] : List (String × DetBlock String (Cmd P) P)) + = bsNext ++ [decBlock] ++ bbs := by simp + rw [h_blks_simp] at h_inv_r_i + have h_inv_r_n : + @GenInv P gen gen_n + (Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ []) + ((bsNext ++ [decBlock] ++ bbs) ++ []) := + GenInv.trans gen gen_i gen_n _ _ _ _ h_inv_r_i h_inv_nondet_step + (by intros _ _ h_in; simp at h_in) + rw [h_user_simp_i] at h_inv_r_n + have h_blks_simp_n : + bsNext ++ [decBlock] ++ bbs ++ ([] : List (String × DetBlock String (Cmd P) P)) + = bsNext ++ [decBlock] ++ bbs := by simp + rw [h_blks_simp_n] at h_inv_r_n + have h_inv_chron : + @GenInv P gen gen_f + (Block.userBlockLabels rest ++ Block.userBlockLabels bss ++ []) + ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks) := + GenInv.trans gen gen_n gen_f _ _ _ _ h_inv_r_n h_inv_flush + (by intros _ _ h_in; simp at h_in) + rw [h_user_simp_i] at h_inv_chron + -- Prepend lentry block. + have h_lentry_in_gen_le : lentry ∈ StringGenState.stringGens gen_le := by + rw [show lentry = (StringGenState.gen "loop_entry$" gen_r).1 from + (by rw [h_lentry_def])] + rw [show gen_le = (StringGenState.gen "loop_entry$" gen_r).2 from + (by rw [h_lentry_def])] + rw [StringGenState.stringGens_gen] + exact List.mem_cons.mpr (Or.inl rfl) + have h_lentry_in_gen_f : lentry ∈ StringGenState.stringGens gen_f := + (((h_step_le_to_b.trans h_step_inv).trans h_step_nondet).trans h_step_flush).subset + h_lentry_in_gen_le + have h_lentry_notin_gen_r : lentry ∉ StringGenState.stringGens gen_r := by + intro h_in + have h_lentry_eq : lentry = (StringGenState.gen "loop_entry$" gen_r).1 := by + rw [h_lentry_def] + have h_notin := + StringGenState.stringGens_gen_not_in "loop_entry$" gen_r hwf_r + rw [h_lentry_eq] at h_in + exact h_notin h_in + have h_lentry_notin_gen : lentry ∉ StringGenState.stringGens gen := by + intro h_in; exact h_lentry_notin_gen_r (h_step_rest.subset h_in) + have h_lentry_notin_blks : + lentry ∉ List.map Prod.fst ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks) := by + intro h_in + rw [List.map_append, List.map_append, List.map_append, List.mem_append, List.mem_append, + List.mem_append] at h_in + rcases h_in with ((h_bs | h_dec) | h_bb) | h_ac + · rcases h_inv_rest.fresh lentry h_bs with h_gr | h_user + · exact h_lentry_notin_gen_r h_gr.1 + · have h_shape := h_inv_rest.user_shape lentry h_user + exact h_shape (StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + (h_inv_le_step.wf_out) h_lentry_in_gen_le) + · simp only [List.map_cons, List.map_nil, List.mem_singleton] at h_dec + rw [h_dec] at h_lentry_in_gen_le + exact h_ldec_notin_gen_ml (h_step_ml.subset h_lentry_in_gen_le) + · rcases h_inv_body.fresh lentry h_bb with h_gb | h_user + · exact h_gb.2 ((h_step_ml.trans h_step_ldec).subset h_lentry_in_gen_le) + · have h_shape := h_inv_body.user_shape lentry h_user + exact h_shape (StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + (h_inv_le_step.wf_out) h_lentry_in_gen_le) + · rcases h_inv_flush.fresh lentry h_ac with h_gf | h_user + · exact h_gf.2 (((h_step_le_to_b.trans h_step_inv).trans h_step_nondet).subset + h_lentry_in_gen_le) + · simp at h_user + have h_inv_with_lentry : + @GenInv P gen gen_f + (Block.userBlockLabels rest ++ Block.userBlockLabels bss) + ((lentry, lentryBlk) :: ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks)) := + GenInv.cons_gen gen gen gen_f _ _ lentry lentryBlk hwf + (StringGenState.GenStep.refl gen) h_inv_chron h_lentry_in_gen_f + h_lentry_notin_gen h_lentry_notin_blks + have h_perm : + ((lentry, lentryBlk) :: ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks)).Perm + (accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [decBlock] ++ bsNext) := by + have h_target : + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [decBlock] ++ bsNext + = accumBlocks ++ ((lentry, lentryBlk) :: (bbs ++ [decBlock] ++ bsNext)) := by + simp [List.append_assoc, List.singleton_append] + rw [h_target] + have h1 : ((lentry, lentryBlk) :: ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks)).Perm + ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ [decBlock] ++ bbs))) := + List.Perm.cons _ List.perm_append_comm + have h2 : ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ [decBlock] ++ bbs))).Perm + (accumBlocks ++ (lentry, lentryBlk) :: (bsNext ++ [decBlock] ++ bbs)) := + (List.perm_middle (a := (lentry, lentryBlk)) + (l₁ := accumBlocks) (l₂ := bsNext ++ [decBlock] ++ bbs)).symm + have h3 : (accumBlocks ++ (lentry, lentryBlk) :: (bsNext ++ [decBlock] ++ bbs)).Perm + (accumBlocks ++ (lentry, lentryBlk) :: (bbs ++ [decBlock] ++ bsNext)) := + List.Perm.append_left accumBlocks + (List.Perm.cons _ (by + have hh1 : (bsNext ++ [decBlock] ++ bbs).Perm + (bbs ++ (bsNext ++ [decBlock])) := + List.perm_append_comm + have hh2 : (bbs ++ (bsNext ++ [decBlock])).Perm + (bbs ++ ([decBlock] ++ bsNext)) := + List.Perm.append_left bbs List.perm_append_comm + have hh3 : (bbs ++ ([decBlock] ++ bsNext)) = (bbs ++ [decBlock] ++ bsNext) := by + rw [List.append_assoc] + exact (hh1.trans hh2).trans (hh3 ▸ List.Perm.refl _))) + exact (h1.trans h2).trans h3 + have h_inv_perm := GenInv.perm gen gen_f _ _ _ h_inv_with_lentry h_perm + rw [← h_blocks_eq, ← h_gen_eq, Block.userBlockLabels_loop_cons] + apply GenInv.weaken_userLabels gen gen_f _ _ _ h_inv_perm + · intro x hx + rw [List.mem_append] at hx + rw [List.mem_append] + exact hx.elim (fun h_r => Or.inr h_r) (fun h_b => Or.inl h_b) + · intro x hx; exact h_disj.1 x hx + · intro x hx h_in + rw [h_gen_eq] at h_in + exact h_disj.2.2 x hx h_in + · exact h_disj.2.1 +termination_by sizeOf ss +decreasing_by all_goals (subst h_match; simp_wf; omega) + +/-- The CFG produced by `stmtsToCFG` has unique labels. +This holds because all labels are generated fresh by `StringGenState`, +which is monotone (each generated label is fresh w.r.t. previously generated ones). + +Reduces to `stmtsToBlocks_invariant`: the final block label `lend` is generated +*before* the `stmtsToBlocks` call, so it is in `gen0.gens`. The invariant says +the inner blocks' labels are NOT in `gen0.gens`, so `lend` is disjoint from them. -/ +private theorem stmtsToCFG_nodup_keys {P : PureExpr} + [HasBool P] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] + (ss : List (Stmt P (Cmd P))) + (h_disj : ∀ gen', Block.userLabelsDisjoint ss gen') : + ((stmtsToCFG ss).blocks.map Prod.fst).Nodup := by + -- Define the generator state after generating "end$" and the resulting label. + let p_end := StringGenState.gen "end$" StringGenState.emp + let lend : String := p_end.1 + let gen0 : StringGenState := p_end.2 + let r := stmtsToBlocks (P := P) (CmdT := Cmd P) lend ss + ([] : List (Option String × String)) ([] : List (Cmd P)) gen0 + -- The blocks of stmtsToCFG ss are r.1.2 ++ [(lend, ...)] + have h_unfold : ((stmtsToCFG ss).blocks.map Prod.fst) = + (r.1.2.map Prod.fst) ++ [lend] := by + show List.map Prod.fst ((stmtsToCFG ss).blocks) = _ + unfold stmtsToCFG stmtsToCFGM + simp only [bind, StateT.bind, pure, StateT.pure, Id] + show List.map Prod.fst (_ ++ [(lend, _)]) = _ + rw [List.map_append] + rfl + rw [h_unfold] + -- WF of empty state + have hwf_emp : StringGenState.WF StringGenState.emp := StringGenState.wf_emp + -- WF of gen0 + have hwf0 : StringGenState.WF gen0 := + StringGenState.WFMono hwf_emp rfl + -- lend ∈ StringGenState.stringGens gen0 + have h_lend_in_gen0 : lend ∈ StringGenState.stringGens gen0 := by + show lend ∈ StringGenState.stringGens p_end.2 + rw [StringGenState.stringGens_gen]; exact List.mem_cons.mpr (Or.inl rfl) + -- Get invariant from the helper + have h_eq : stmtsToBlocks lend ss [] [] gen0 = ((r.1.1, r.1.2), r.2) := rfl + have h_inv : @GenInv P gen0 r.2 (Block.userBlockLabels ss) r.1.2 := + stmtsToBlocks_invariant lend ss [] [] gen0 r.2 _ _ h_eq hwf0 (h_disj _) + -- Build Nodup of r.1.2.map Prod.fst ++ [lend] + rw [List.nodup_append] + refine ⟨h_inv.nodup, ?_, ?_⟩ + · simp + · -- disjointness: lend not in r.1.2.map Prod.fst + intro x hx y hy h_eq + rw [List.mem_singleton] at hy + subst hy + subst h_eq + rcases h_inv.fresh _ hx with h_gen | h_user + · -- lend ∈ stringGens r.2 \ stringGens gen0; but lend ∈ stringGens gen0. Contradiction. + exact h_gen.2 h_lend_in_gen0 + · -- lend is a user label of ss; but lend = (gen "end$" emp).1 has shape, so it's not user. + -- We instead use that user labels are disjoint from stringGens (h_inv.user_disj) + have h_lend_in_r2 : lend ∈ StringGenState.stringGens r.2 := by + have h_step := h_inv.toGenStep + exact h_step.subset h_lend_in_gen0 + exact h_inv.user_disj _ h_user h_lend_in_r2 + + + +/-- Evaluator well-formedness (Bool) is preserved by structured execution when +no `funcDecl` statements are executed (i.e., the evaluator doesn't change). +This holds because only `step_funcDecl` modifies `eval`. -/ +private theorem StepStmtStar_wfb_preserved {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) + (h : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) + (hnofd : Block.noFuncDecl ss = true) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) : + WellFormedSemanticEvalBool ρ'.eval := by + have h_eval_eq : ρ'.eval = ρ₀.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval ss ρ₀ ρ' hnofd h + rw [h_eval_eq] + exact hwfb + +/-- Same as above but for `WellFormedSemanticEvalVal`. -/ +private theorem StepStmtStar_wfv_preserved {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) + (h : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) + (hnofd : Block.noFuncDecl ss = true) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) : + WellFormedSemanticEvalVal ρ'.eval := by + have h_eval_eq : ρ'.eval = ρ₀.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval ss ρ₀ ρ' hnofd h + rw [h_eval_eq] + exact hwfv + +/-! ## Agreement-based variants of flushCmds_condGoto_* + +These variants take the CFG-side accumulated trace pre-lifted via +`EvalCmds_under_agreement`, allowing the agreement gap (between structured and +CFG entry stores) to be threaded through the simulation. -/ + +/-- Variant of `flushCmds_condGoto_true` that operates under StoreAgreement: +the input accum trace is on the CFG side (lifted via `EvalCmds_under_agreement`) +and reaches `σ_cfg_after`, which agrees with `ρ₀.store`. -/ +private theorem flushCmds_condGoto_true_agree {P : PureExpr} [HasFvar P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (accum : List (Cmd P)) + (e : P.Expr) (tl fl : String) (md : MetaData P) + (l_ite : String) (gen_e gen_f : StringGenState) + (accumEntry : String) (accumBlocks : DetBlocks String (Cmd P) P) + (h_flush_eq : flushCmds "ite$" accum + (some (DetTransferCmd.condGoto e tl fl md)) l_ite gen_e = ((accumEntry, accumBlocks), gen_f)) + (σ_base σ_cfg_after : SemanticStore P) (hf_base hf_accum : Bool) + (ρ₀ : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (h_wf_def : WellFormedSemanticEvalDef ρ₀.eval) + (h_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (h_accum_cfg : EvalCmds P (EvalCmd P) ρ₀.eval σ_base accum.reverse σ_cfg_after hf_accum) + (h_agree_after : StoreAgreement ρ₀.store σ_cfg_after) + (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) + (h_cond : ρ₀.eval ρ₀.store e = .some HasBool.tt) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks) + (h_lookup : ∀ lbl blk, (lbl, blk) ∈ cfg.blocks → + cfg.blocks.lookup lbl = some blk) : + StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock tl σ_cfg_after ρ₀.hasFailure) := by + simp only [flushCmds, bind, StateT.bind, pure, StateT.pure, Id] at h_flush_eq + injection h_flush_eq with h_pair h_gen_eq + injection h_pair with h_entry_eq h_blks_eq + subst h_entry_eq; subst h_blks_eq + have h_def_e : isDefined ρ₀.store (HasVarsPure.getVars e) := + h_wf_def e HasBool.tt ρ₀.store h_cond + have h_pointwise : + ∀ y ∈ HasVarsPure.getVars e, ρ₀.store y = σ_cfg_after y := + store_agreement_pointwise_on_expr_vars ρ₀.store σ_cfg_after e h_agree_after h_def_e + have h_cond_cfg : ρ₀.eval σ_cfg_after e = .some HasBool.tt := by + exact h_cond ▸ (h_congr e ρ₀.store σ_cfg_after h_pointwise).symm + have h_mem := h_cfg_accum _ (List.Mem.head _) + have h_lkp := h_lookup _ _ h_mem + have h_run := run_block_goto_true (extendEval := extendEval) (cfg := cfg) + (f_base := hf_base) h_lkp h_accum_cfg h_cond_cfg hwfb h_congr + -- (hf_base || hf_accum) = ρ₀.hasFailure via h_hf + rw [← h_hf] at h_run + exact h_run + +/-- Variant of `flushCmds_condGoto_false` that operates under StoreAgreement. -/ +private theorem flushCmds_condGoto_false_agree {P : PureExpr} [HasFvar P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (accum : List (Cmd P)) + (e : P.Expr) (tl fl : String) (md : MetaData P) + (l_ite : String) (gen_e gen_f : StringGenState) + (accumEntry : String) (accumBlocks : DetBlocks String (Cmd P) P) + (h_flush_eq : flushCmds "ite$" accum + (some (DetTransferCmd.condGoto e tl fl md)) l_ite gen_e = ((accumEntry, accumBlocks), gen_f)) + (σ_base σ_cfg_after : SemanticStore P) (hf_base hf_accum : Bool) + (ρ₀ : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (h_wf_def : WellFormedSemanticEvalDef ρ₀.eval) + (h_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (h_accum_cfg : EvalCmds P (EvalCmd P) ρ₀.eval σ_base accum.reverse σ_cfg_after hf_accum) + (h_agree_after : StoreAgreement ρ₀.store σ_cfg_after) + (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) + (h_cond : ρ₀.eval ρ₀.store e = .some HasBool.ff) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks) + (h_lookup : ∀ lbl blk, (lbl, blk) ∈ cfg.blocks → + cfg.blocks.lookup lbl = some blk) : + StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock fl σ_cfg_after ρ₀.hasFailure) := by + simp only [flushCmds, bind, StateT.bind, pure, StateT.pure, Id] at h_flush_eq + injection h_flush_eq with h_pair h_gen_eq + injection h_pair with h_entry_eq h_blks_eq + subst h_entry_eq; subst h_blks_eq + have h_def_e : isDefined ρ₀.store (HasVarsPure.getVars e) := + h_wf_def e HasBool.ff ρ₀.store h_cond + have h_pointwise : + ∀ y ∈ HasVarsPure.getVars e, ρ₀.store y = σ_cfg_after y := + store_agreement_pointwise_on_expr_vars ρ₀.store σ_cfg_after e h_agree_after h_def_e + have h_cond_cfg : ρ₀.eval σ_cfg_after e = .some HasBool.ff := by + exact h_cond ▸ (h_congr e ρ₀.store σ_cfg_after h_pointwise).symm + have h_mem := h_cfg_accum _ (List.Mem.head _) + have h_lkp := h_lookup _ _ h_mem + have h_run := run_block_goto_false (extendEval := extendEval) (cfg := cfg) + (f_base := hf_base) h_lkp h_accum_cfg h_cond_cfg hwfb h_congr + rw [← h_hf] at h_run + exact h_run +/-! ## Block.uniqueInits projection helpers + +`Block.uniqueInits ss` is a Nodup property of the cumulative `Block.initVars ss` +list. These mechanical helpers project Nodup down to sub-lists that recursive +simulation calls produce. -/ + +private theorem Block.uniqueInits.tail {P : PureExpr} + {s : Stmt P (Cmd P)} {ss : List (Stmt P (Cmd P))} + (h : Block.uniqueInits (s :: ss)) : Block.uniqueInits ss := by + unfold Block.uniqueInits at h ⊢ + rw [Block.initVars] at h + exact (List.nodup_append.mp h).2.1 + +private theorem Block.uniqueInits.head_stmt {P : PureExpr} + {s : Stmt P (Cmd P)} {ss : List (Stmt P (Cmd P))} + (h : Block.uniqueInits (s :: ss)) : (Stmt.initVars s).Nodup := by + unfold Block.uniqueInits at h + rw [Block.initVars] at h + exact (List.nodup_append.mp h).1 + +private theorem Block.uniqueInits.block_body {P : PureExpr} + {label : String} {bss : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.uniqueInits (.block label bss md :: rest)) : + Block.uniqueInits bss := by + have h_head := Block.uniqueInits.head_stmt h + -- Stmt.initVars (.block ...) = Block.initVars bss; so Nodup carries over. + unfold Stmt.initVars at h_head + exact h_head + +private theorem Block.uniqueInits.ite_then {P : PureExpr} + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.uniqueInits (.ite g tss ess md :: rest)) : + Block.uniqueInits tss := by + have h_head := Block.uniqueInits.head_stmt h + -- Stmt.initVars (.ite _ tss ess _) = Block.initVars tss ++ Block.initVars ess + unfold Stmt.initVars at h_head + exact (List.nodup_append.mp h_head).1 + +private theorem Block.uniqueInits.ite_else {P : PureExpr} + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.uniqueInits (.ite g tss ess md :: rest)) : + Block.uniqueInits ess := by + have h_head := Block.uniqueInits.head_stmt h + unfold Stmt.initVars at h_head + exact (List.nodup_append.mp h_head).2.1 + + +/-! ## Generalized simulation + +The central lemma: for any continuation `k`, exit-continuation stack, and +accumulated commands, if the structured execution of `ss` from `ρ₀` terminates +(or exits), then the CFG blocks produced by `stmtsToBlocks` can step from the +entry label to the continuation `k` (or the resolved exit target). -/ + +/-- Simulation lemma operating under StoreAgreement: the input accum trace +runs from `σ_struct_base` (struct side) to `ρ₀.store` (struct side), and +`StoreAgreement σ_struct_base σ_base` holds at the entry. -/ +private theorem flushCmds_simulation_agree {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + (extendEval : ExtendEval P) + (pfx : String) + (k : String) + (accum : List (Cmd P)) + (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P) + (h_gen : (flushCmds pfx accum .none k gen) = ((entry, blocks), gen')) + (σ_struct_base σ_base : SemanticStore P) + (hf_base hf_accum : Bool) + (ρ₀ : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (h_wf_def : WellFormedSemanticEvalDef ρ₀.eval) + (h_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (h_accum : EvalCmds P (EvalCmd P) ρ₀.eval σ_struct_base accum.reverse ρ₀.store hf_accum) + (h_agree_entry : StoreAgreement σ_struct_base σ_base) + (h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none) + (h_unique_accum : (Cmds.definedVars accum.reverse).Nodup) + (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (h_cfg_blocks : ∀ b ∈ blocks, b ∈ cfg.blocks) + (h_cfg_nodup : (cfg.blocks.map Prod.fst).Nodup) : + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock entry σ_base hf_base) + (.atBlock k σ_cfg ρ₀.hasFailure) + ∧ StoreAgreement ρ₀.store σ_cfg + ∧ (∀ x, σ_base x = none → x ∉ Cmds.definedVars accum.reverse → σ_cfg x = none) := by + unfold flushCmds at h_gen + simp only at h_gen + split at h_gen + case isTrue h_empty => + have ⟨h_entry, h_blocks⟩ := Prod.mk.inj (Prod.mk.inj h_gen).1 + subst h_entry; subst h_blocks + have h_nil : accum.reverse = [] := by + simp [List.isEmpty_iff] at h_empty; simp [h_empty] + have ⟨h_store, h_fail⟩ := EvalCmds_inv ρ₀.eval σ_struct_base ρ₀.store hf_accum + (h_nil ▸ h_accum) + subst h_store; subst h_fail + simp [Bool.or_false] at h_hf + rw [h_hf] + refine ⟨σ_base, ReflTrans.refl _, h_agree_entry, ?_⟩ + intro x h_σ_x _ + exact h_σ_x + case isFalse h_nonempty => + simp only [bind, StateT.bind, pure, StateT.pure, Id] at h_gen + injection h_gen with h_pair h_gen_eq + injection h_pair with h_entry_eq h_blks_eq + subst h_entry_eq; subst h_blks_eq + have ⟨σ_cfg_after, h_accum_cfg, h_agree_after⟩ := + EvalCmds_under_agreement ρ₀.eval accum.reverse h_wf_def h_congr + σ_struct_base σ_base ρ₀.store hf_accum h_agree_entry h_accum h_fresh_accum + h_unique_accum + have h_mem : + ((StringGenState.gen pfx gen).fst, + ({ cmds := accum.reverse, transfer := DetTransferCmd.goto k } + : DetBlock String (Cmd P) P)) ∈ cfg.blocks := + h_cfg_blocks _ (List.Mem.head _) + have h_cond_tt : ρ₀.eval σ_cfg_after HasBool.tt = .some HasBool.tt := + eval_tt_is_tt ρ₀.eval σ_cfg_after hwfv + have h_lkp : cfg.blocks.lookup (StringGenState.gen pfx gen).fst = + some { cmds := accum.reverse, transfer := DetTransferCmd.goto k } := + List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup _ _ h_mem + -- `.goto k` ≡ `.condGoto tt k k .empty`; reuse `run_block_goto_true`. + have h_lkp' : cfg.blocks.lookup (StringGenState.gen pfx gen).fst = + some { cmds := accum.reverse, + transfer := DetTransferCmd.condGoto HasBool.tt k k .empty } := h_lkp + have h_run := run_block_goto_true (extendEval := extendEval) (cfg := cfg) + (f_base := hf_base) h_lkp' h_accum_cfg h_cond_tt hwfb h_congr + rw [← h_hf] at h_run + refine ⟨σ_cfg_after, h_run, h_agree_after, ?_⟩ + intro x h_σ_base_x h_x_not_def + exact agreement_helper_unchanged_at_x_multi h_accum_cfg h_x_not_def h_σ_base_x + +/-- Helper: variant of `flushCmds_simulation_agree` for the `flushCmds` shape +where the transfer is provided as `.some (.goto bk md)` (used in the `.exit` +constructor of `stmtsToBlocks`). The block always materializes a single +fresh block (regardless of whether `accum` is empty), since the transfer is +explicit. -/ +private theorem flushCmds_goto_simulation_agree {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + (extendEval : ExtendEval P) + (pfx : String) (accum : List (Cmd P)) (md : MetaData P) (bk : String) + (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P) + (h_gen : flushCmds pfx accum (.some (.goto bk md)) bk gen + = ((entry, blocks), gen')) + (σ_struct_base σ_base : SemanticStore P) + (hf_base hf_accum : Bool) + (ρ₀ : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (h_wf_def : WellFormedSemanticEvalDef ρ₀.eval) + (h_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (h_accum : EvalCmds P (EvalCmd P) ρ₀.eval σ_struct_base accum.reverse ρ₀.store hf_accum) + (h_agree_entry : StoreAgreement σ_struct_base σ_base) + (h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none) + (h_unique_accum : (Cmds.definedVars accum.reverse).Nodup) + (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (h_cfg_blocks : ∀ b ∈ blocks, b ∈ cfg.blocks) + (h_cfg_nodup : (cfg.blocks.map Prod.fst).Nodup) : + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock entry σ_base hf_base) + (.atBlock bk σ_cfg ρ₀.hasFailure) + ∧ StoreAgreement ρ₀.store σ_cfg + ∧ (∀ x, σ_base x = none → x ∉ Cmds.definedVars accum.reverse → σ_cfg x = none) := by + unfold flushCmds at h_gen + simp only [bind, StateT.bind, pure, StateT.pure, Id] at h_gen + injection h_gen with h_pair h_gen_eq + injection h_pair with h_entry_eq h_blks_eq + subst h_entry_eq; subst h_blks_eq + have ⟨σ_cfg_after, h_accum_cfg, h_agree_after⟩ := + EvalCmds_under_agreement ρ₀.eval accum.reverse h_wf_def h_congr + σ_struct_base σ_base ρ₀.store hf_accum h_agree_entry h_accum h_fresh_accum + h_unique_accum + have h_mem : + ((StringGenState.gen pfx gen).fst, + ({ cmds := accum.reverse, transfer := DetTransferCmd.goto bk md } + : DetBlock String (Cmd P) P)) ∈ cfg.blocks := + h_cfg_blocks _ (List.Mem.head _) + have h_cond_tt : ρ₀.eval σ_cfg_after HasBool.tt = .some HasBool.tt := + eval_tt_is_tt ρ₀.eval σ_cfg_after hwfv + have h_lkp : cfg.blocks.lookup (StringGenState.gen pfx gen).fst = + some { cmds := accum.reverse, transfer := DetTransferCmd.goto bk md } := + List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup _ _ h_mem + -- `.goto bk md` ≡ `.condGoto tt bk bk md`; reuse `run_block_goto_true`. + have h_lkp' : cfg.blocks.lookup (StringGenState.gen pfx gen).fst = + some { cmds := accum.reverse, + transfer := DetTransferCmd.condGoto HasBool.tt bk bk md } := h_lkp + have h_run := run_block_goto_true (extendEval := extendEval) (cfg := cfg) + (f_base := hf_base) h_lkp' h_accum_cfg h_cond_tt hwfb h_congr + rw [← h_hf] at h_run + refine ⟨σ_cfg_after, h_run, h_agree_after, ?_⟩ + intro x h_σ_base_x h_x_not_def + exact agreement_helper_unchanged_at_x_multi h_accum_cfg h_x_not_def h_σ_base_x + +/-- Stronger inversion of `.block (.some label') σ_parent inner → .exiting lbl ρ'`: + when the block has an explicit label and propagates an exit, the inner exit + label `lbl_inner` is exactly the propagated `lbl`, AND the block's own label + `label'` differs from `lbl` (since the propagation rule + `step_block_exit_mismatch` requires `.some label' ≠ .some lbl`). -/ +private theorem block_some_reaches_exiting {P : PureExpr} {CmdT : Type} + [HasBool P] [HasNot P] + {EvalCmd : EvalCmdParam P CmdT} {extendEval : ExtendEval P} + {inner : Config P CmdT} {label' : String} {σ_parent : SemanticStore P} + {lbl : String} {ρ' : Env P} + (hstar : StepStmtStar P EvalCmd extendEval + (.block (.some label') σ_parent inner) (.exiting lbl ρ')) : + label' ≠ lbl ∧ + ∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } := by + suffices ∀ src tgt, StepStmtStar P EvalCmd extendEval src tgt → + ∀ inner lbl ρ', src = .block (.some label') σ_parent inner → + tgt = .exiting lbl ρ' → + label' ≠ lbl ∧ + ∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } from + this _ _ hstar _ _ _ rfl rfl + intro src tgt hstar_g + induction hstar_g with + | refl => intro _ _ _ hsrc htgt; subst hsrc; cases htgt + | step _ mid _ hstep hrest ih => + intro inner lbl ρ' hsrc htgt; subst hsrc + cases hstep with + | step_block_body h => + have ⟨hne, ρ_inner, hexit, heq⟩ := ih _ _ _ rfl htgt + exact ⟨hne, ρ_inner, .step _ _ _ h hexit, heq⟩ + | step_block_exit_mismatch hne => + subst htgt + cases hrest with + | refl => + refine ⟨?_, _, .refl _, rfl⟩ + intro h + apply hne + exact congrArg some h + | step _ _ _ h _ => cases h + | step_block_done | step_block_exit_match => + subst htgt; cases hrest with | step _ _ _ h _ => cases h + +/-- Helper for cascading the `h_store_no_gens` precondition from `σ_base` +to `σ_cfg_after = (lifted accum)` after running accum on the CFG side. +Uses the digit-suffix property of `s` together with the assumption that no +accum-defined variable has a digit-suffixed shape to argue that +`ident s ∉ Cmds.definedVars accum.reverse`, then invokes +`agreement_helper_unchanged_at_x_multi`. -/ +private theorem store_no_gens_lift_after_accum {P : PureExpr} + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [HasIdent P] [DecidableEq P.Ident] + {δ : SemanticEval P} {σ_base σ_cfg_after : SemanticStore P} + {accum : List (Cmd P)} {failed : Bool} + (h_accum_cfg : EvalCmds P (@EvalCmd P _ _ _ _) δ σ_base accum.reverse σ_cfg_after failed) + (gen : StringGenState) + (h_store_no_gens : ∀ x : String, + String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens gen → + σ_base (HasIdent.ident (P := P) x) = none) + (h_accum_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars accum.reverse)) : + ∀ x : String, + String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens gen → + σ_cfg_after (HasIdent.ident (P := P) x) = none := by + intro x h_suf h_not_in + have h_x_not_def : HasIdent.ident (P := P) x ∉ Cmds.definedVars accum.reverse := by + intro h_in + exact h_accum_no_gen_suffix _ h_in x rfl h_suf + exact agreement_helper_unchanged_at_x_multi h_accum_cfg h_x_not_def + (h_store_no_gens x h_suf h_not_in) + +/-- Sibling of `store_no_gens_lift_after_accum` that lifts `h_store_no_gens` +through the freshness-preservation clause produced by `flushCmds_simulation_agree`, +i.e. `h_preserve_flush : ∀ x, σ_base x = none → x ∉ Cmds.definedVars accum.reverse → +σ_cfg_after x = none`. -/ +private theorem store_no_gens_lift_after_flush {P : PureExpr} + [HasIdent P] + {σ_base σ_cfg_after : SemanticStore P} + {accum : List (Cmd P)} + (h_preserve_flush : ∀ x : P.Ident, + σ_base x = none → x ∉ Cmds.definedVars accum.reverse → σ_cfg_after x = none) + (gen : StringGenState) + (h_store_no_gens : ∀ x : String, + String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens gen → + σ_base (HasIdent.ident (P := P) x) = none) + (h_accum_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars accum.reverse)) : + ∀ x : String, + String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens gen → + σ_cfg_after (HasIdent.ident (P := P) x) = none := by + intro x h_suf h_not_in + have h_x_not_accum : HasIdent.ident (P := P) x ∉ Cmds.definedVars accum.reverse := by + intro h_in + exact h_accum_no_gen_suffix _ h_in x rfl h_suf + exact h_preserve_flush _ (h_store_no_gens x h_suf h_not_in) h_x_not_accum + +/-- Helper for cascading `h_store_no_gens_upper` through a sub-simulation +that runs `(empty accum)` and produces a final store `σ_branch` agreeing with +the sub's terminal structured store. + +Consumes the strengthened (4-premise) `h_preserve` from the sub-simulation +directly. Discharges the disjunction-guard premise using the upper-bound +subset chain `gen_inner' ⊆ genUpperBound`: at a gen-suffix `x` with +`x ∉ stringGens genUpperBound`, the disjunction `s ∈ gen_inner ∨ +s ∉ gen_inner'` is discharged by `Or.inr` since `gen_inner' ⊆ genUpperBound`. -/ +private theorem store_no_gens_upper_lift_through_subsim {P : PureExpr} + [HasIdent P] [LawfulHasIdent P] + {σ_in σ_branch : SemanticStore P} + {sub_init : List P.Ident} + (gen_inner gen_inner' genUpperBound : StringGenState) + (h_outer_upper : StringGenState.stringGens gen_inner' ⊆ + StringGenState.stringGens genUpperBound) + (h_preserve : ∀ x : P.Ident, σ_in x = none → + x ∉ Cmds.definedVars ([] : List (Cmd P)).reverse → x ∉ sub_init → + (∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_inner ∨ + s ∉ StringGenState.stringGens gen_inner') → + σ_branch x = none) + (h_store_no_gens_upper : ∀ x : String, + String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_in (HasIdent.ident (P := P) x) = none) + (h_sub_no_gen_suffix : NoGenSuffix (P := P) sub_init) : + ∀ x : String, + String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_branch (HasIdent.ident (P := P) x) = none := by + intro x h_suf h_not_in + have h_nil : HasIdent.ident (P := P) x ∉ Cmds.definedVars ([] : List (Cmd P)).reverse := by + simp [Cmds.definedVars] + have h_not_sub : HasIdent.ident (P := P) x ∉ sub_init := by + intro h_in + exact h_sub_no_gen_suffix _ h_in x rfl h_suf + refine h_preserve _ (h_store_no_gens_upper x h_suf h_not_in) h_nil h_not_sub ?_ + intro s heq + have hxs : x = s := LawfulHasIdent.ident_inj heq + exact Or.inr (fun h_in_inner' => h_not_in (h_outer_upper (hxs ▸ h_in_inner'))) +/-- Snoc/cons rebracketing bundle for the `.cmd c :: rest` arm of +`stmtsToBlocks_simulation`. -/ +private theorem cmd_arm_combined_lemmas {P : PureExpr} + [HasIdent P] [HasVarsPure P P.Expr] + (c : Cmd P) (accum : List (Cmd P)) (rest : List (Stmt P (Cmd P))) + (σ_base : SemanticStore P) + (h_fresh : ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars (.cmd c :: rest), σ_base x = none) + (h_uniq : (Cmds.definedVars accum.reverse ++ Block.initVars (.cmd c :: rest)).Nodup) + (h_no_d : NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ Block.initVars (.cmd c :: rest))) + (h_no_m : NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars (.cmd c :: rest))) + (h_no_g : NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ Block.getVars (.cmd c :: rest))) : + Cmds.definedVars (accum.reverse ++ [c]) = Cmds.definedVars accum.reverse ++ Cmd.definedVars c + ∧ (∀ x ∈ Cmds.definedVars (c :: accum).reverse ++ Block.initVars rest, σ_base x = none) + ∧ (Cmds.definedVars (c :: accum).reverse ++ Block.initVars rest).Nodup + ∧ (NoGenSuffix (P := P) (Cmds.definedVars (c :: accum).reverse ++ Block.initVars rest)) + ∧ (NoGenSuffix (P := P) (Cmds.modifiedVars (c :: accum).reverse ++ transformBlockModVars rest)) + ∧ (NoGenSuffix (P := P) (Cmds.getVars (c :: accum).reverse ++ Block.getVars rest)) := by + have h_d_snoc : Cmds.definedVars (accum.reverse ++ [c]) = + Cmds.definedVars accum.reverse ++ Cmd.definedVars c := by + induction accum.reverse with + | nil => simp [Cmds.definedVars] + | cons hd tl ih => + rw [List.cons_append, Cmds.definedVars_cons, Cmds.definedVars_cons, ih, List.append_assoc] + have h_d : Cmds.definedVars (c :: accum).reverse ++ Block.initVars rest = + Cmds.definedVars accum.reverse ++ Block.initVars (.cmd c :: rest) := by + rw [List.reverse_cons, h_d_snoc, Block.initVars] + cases c <;> simp [Stmt.initVars, Cmd.definedVars, List.append_assoc] + have h_m_snoc : Cmds.modifiedVars (accum.reverse ++ [c]) = + Cmds.modifiedVars accum.reverse ++ Cmd.modifiedVars c := by + induction accum.reverse with + | nil => simp [Cmds.modifiedVars] + | cons hd tl ih => + rw [List.cons_append, Cmds.modifiedVars_cons, Cmds.modifiedVars_cons, ih, List.append_assoc] + have h_m : Cmds.modifiedVars (c :: accum).reverse ++ transformBlockModVars rest = + Cmds.modifiedVars accum.reverse ++ transformBlockModVars (.cmd c :: rest) := by + rw [List.reverse_cons, h_m_snoc, transformBlockModVars_cons, + transformStmtModVars_cmd, List.append_assoc] + have h_get_cons : ∀ (cd : Cmd P) (cs : List (Cmd P)), + Cmds.getVars (cd :: cs) = Cmd.getVars cd ++ Cmds.getVars cs := + fun _ _ => by rw [Cmds.getVars.eq_def] + have h_g_snoc : Cmds.getVars (accum.reverse ++ [c]) = + Cmds.getVars accum.reverse ++ Cmd.getVars c := by + induction accum.reverse with + | nil => simp [Cmds.getVars] + | cons hd tl ih => + rw [List.cons_append, h_get_cons hd (tl ++ [c]), h_get_cons hd tl, ih, List.append_assoc] + have h_g : Cmds.getVars (c :: accum).reverse ++ Block.getVars rest = + Cmds.getVars accum.reverse ++ Block.getVars (.cmd c :: rest) := by + rw [List.reverse_cons, h_g_snoc] + show Cmds.getVars accum.reverse ++ Cmd.getVars c ++ Block.getVars rest + = Cmds.getVars accum.reverse ++ (Cmd.getVars c ++ Block.getVars rest) + rw [List.append_assoc] + exact ⟨h_d_snoc, + fun x hx => h_fresh x (h_d ▸ hx), + h_d ▸ h_uniq, + fun x hx s heq => h_no_d x (h_d ▸ hx) s heq, + fun x hx s heq => h_no_m x (h_m ▸ hx) s heq, + fun x hx s heq => h_no_g x (h_g ▸ hx) s heq⟩ + +/-- Lift the outer guard `gen → gen'` to the inner guard `gen_r → gen_b`, + given the GenStep chain `gen → gen_r` and `gen_b → gen_f = gen'`. + Used after every body/then/else recursive arm in `stmtsToBlocks_simulation`. -/ +private theorem inner_guard_step_b {P : PureExpr} [HasIdent P] + {gen gen_r gen_b gen_f gen' : StringGenState} {x : P.Ident} + (h_step_gen_to_r : StringGenState.GenStep gen gen_r) + (h_step_b_to_f : StringGenState.GenStep gen_b gen_f) + (h_gen_eq_f : gen_f = gen') + (h_outer_guard : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen') : + ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_r ∨ + s ∉ StringGenState.stringGens gen_b := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl (h_step_gen_to_r.subset h_in) + | Or.inr h_not_in => Or.inr (fun h_in_b => h_not_in + (h_gen_eq_f ▸ h_step_b_to_f.subset h_in_b)) + +/-- Lift the outer guard `gen → gen'` to the inner guard `gen → gen_r`, + given the GenStep chain `gen_r → gen_b → gen_f = gen'`. + Used after every body/then/else recursive arm in `stmtsToBlocks_simulation`. -/ +private theorem inner_guard_step_r {P : PureExpr} [HasIdent P] + {gen gen_r gen_b gen_f gen' : StringGenState} {x : P.Ident} + (h_step_b_to_f : StringGenState.GenStep gen_b gen_f) + (h_step_r_to_b : StringGenState.GenStep gen_r gen_b) + (h_gen_eq_f : gen_f = gen') + (h_outer_guard : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen') : + ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen_r := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl h_in + | Or.inr h_not_in => Or.inr (fun h_in_r => h_not_in + (h_gen_eq_f ▸ h_step_b_to_f.subset (h_step_r_to_b.subset h_in_r))) + +/-- Freshness lift through `flushCmds` for `rest`'s init vars. + Discharges `σ_cfg_after x = none` for every `x ∈ Block.initVars rest`, + given the standard combined-Nodup, fresh-on-combined, and + `flushCmds`-preservation hypotheses, plus the 2-way `h_initvars_eq` shape. + Used at every body/then/else paired site in `stmtsToBlocks_simulation`. -/ +private theorem fresh_rest_inits_after_step {P : PureExpr} [HasIdent P] + {accum : List (Cmd P)} + {head : Stmt P (Cmd P)} {body rest : List (Stmt P (Cmd P))} + {σ_base σ_cfg_after : SemanticStore P} + (h_initvars_eq : Block.initVars (head :: rest) = + Block.initVars body ++ Block.initVars rest) + (h_unique_combined : + (Cmds.definedVars accum.reverse ++ Block.initVars (head :: rest)).Nodup) + (h_fresh_combined : + ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars (head :: rest), + σ_base x = none) + (h_preserve_flush : ∀ x : P.Ident, + σ_base x = none → x ∉ Cmds.definedVars accum.reverse → σ_cfg_after x = none) : + ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun h_in_accum => + (h_initvars_eq ▸ List.nodup_append.mp h_unique_combined).2.2 + x h_in_accum x (List.mem_append_right _ hx) rfl + have h_σ_base_x : σ_base x = none := by + apply h_fresh_combined + apply List.mem_append_right + rw [h_initvars_eq] + exact List.mem_append_right _ hx + exact h_preserve_flush x h_σ_base_x h_x_not_accum + +/-- Freshness lift through `flushCmds` for `body`'s init vars (mirror of + `fresh_rest_inits_after_step`, but for the left slot of the 2-way + `h_initvars_eq`). Discharges `σ_cfg_after x = none` for every + `x ∈ Block.initVars body`. -/ +private theorem fresh_body_inits_after_step {P : PureExpr} [HasIdent P] + {accum : List (Cmd P)} + {head : Stmt P (Cmd P)} {body rest : List (Stmt P (Cmd P))} + {σ_base σ_cfg_after : SemanticStore P} + (h_initvars_eq : Block.initVars (head :: rest) = + Block.initVars body ++ Block.initVars rest) + (h_unique_combined : + (Cmds.definedVars accum.reverse ++ Block.initVars (head :: rest)).Nodup) + (h_fresh_combined : + ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars (head :: rest), + σ_base x = none) + (h_preserve_flush : ∀ x : P.Ident, + σ_base x = none → x ∉ Cmds.definedVars accum.reverse → σ_cfg_after x = none) : + ∀ x ∈ Block.initVars body, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun h_in_accum => + (h_initvars_eq ▸ List.nodup_append.mp h_unique_combined).2.2 + x h_in_accum x (List.mem_append_left _ hx) rfl + have h_σ_base_x : σ_base x = none := by + apply h_fresh_combined + apply List.mem_append_right + rw [h_initvars_eq] + exact List.mem_append_left _ hx + exact h_preserve_flush x h_σ_base_x h_x_not_accum + +/-- Freshness lift through the body sub-simulation's `h_preserve_body` for + `rest`'s init vars. Consumes the `_after` freshness from + `fresh_rest_inits_after_step`, plus `h_unique`, the 2-way `h_initvars_eq`, + `h_preserve_body` (5-premise form), `h_wf_b`, and the per-element + no-gen-suffix discharge. + Used at every body/then/else paired site in `stmtsToBlocks_simulation`. -/ +private theorem fresh_rest_inits_body_step {P : PureExpr} [HasIdent P] + {head : Stmt P (Cmd P)} {body rest : List (Stmt P (Cmd P))} + {σ_cfg_after σ_cfg_body : SemanticStore P} + {gen_pre gen_b : StringGenState} + (h_initvars_eq : Block.initVars (head :: rest) = + Block.initVars body ++ Block.initVars rest) + (h_unique : Block.uniqueInits (head :: rest)) + (h_preserve_body : ∀ x : P.Ident, + σ_cfg_after x = none → + x ∉ Cmds.definedVars ([] : List (Cmd P)).reverse → + x ∉ Block.initVars body → + (∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_pre ∨ + s ∉ StringGenState.stringGens gen_b) → + σ_cfg_body x = none) + (h_wf_b : StringGenState.WF gen_b) + (h_rest_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars ([] : List (Cmd P)).reverse ++ Block.initVars rest)) + (h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none) : + ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := by + intro x hx + have h_x_not_body : x ∉ Block.initVars body := by + intro h_in_body + unfold Block.uniqueInits at h_unique + rw [h_initvars_eq] at h_unique + have h_disj_lr := (List.nodup_append.mp h_unique).2.2 + exact h_disj_lr x h_in_body x hx rfl + have h_σ_after_x : σ_cfg_after x = none := h_fresh_rest_inits_after x hx + have h_nil_not : x ∉ Cmds.definedVars ([] : List (Cmd P)).reverse := by + simp [Cmds.definedVars] + exact h_preserve_body x h_σ_after_x h_nil_not h_x_not_body + (fun s heq => Or.inr + (StringGenState.not_mem_stringGens_of_not_hasUnderscoreDigitSuffix h_wf_b + (h_rest_no_gen_suffix x (by simp [Cmds.definedVars]; exact hx) s heq))) + +/-- Project the `thenBranch` slot's init-vars Nodup out of the .ite-arm + `h_unique_outer_inits`. Used for `h_unique_combined_then`. -/ +private theorem unique_combined_ite_then {P : PureExpr} [HasIdent P] + {accum : List (Cmd P)} {thenBranch elseBranch rest : List (Stmt P (Cmd P))} + (h_unique_outer_inits : + (Cmds.definedVars accum.reverse ++ + ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ + Block.initVars rest)).Nodup) : + (Cmds.definedVars ([] : List (Cmd P)).reverse ++ Block.initVars thenBranch).Nodup := by + simp [Cmds.definedVars] + exact (List.nodup_append.mp + (List.nodup_append.mp (List.nodup_append.mp h_unique_outer_inits).2.1).1).1 + +/-- Project the `elseBranch` slot's init-vars Nodup out of the .ite-arm + `h_unique_outer_inits`. Used for `h_unique_combined_else`. -/ +private theorem unique_combined_ite_else {P : PureExpr} [HasIdent P] + {accum : List (Cmd P)} {thenBranch elseBranch rest : List (Stmt P (Cmd P))} + (h_unique_outer_inits : + (Cmds.definedVars accum.reverse ++ + ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ + Block.initVars rest)).Nodup) : + (Cmds.definedVars ([] : List (Cmd P)).reverse ++ Block.initVars elseBranch).Nodup := by + simp [Cmds.definedVars] + exact (List.nodup_append.mp + (List.nodup_append.mp (List.nodup_append.mp h_unique_outer_inits).2.1).1).2.1 + +/-- Project the `rest` slot's init-vars Nodup out of the .ite-arm + `h_unique_outer_inits`. Used for `h_unique_combined_rest` after .ite. -/ +private theorem unique_combined_ite_rest {P : PureExpr} [HasIdent P] + {accum : List (Cmd P)} {thenBranch elseBranch rest : List (Stmt P (Cmd P))} + (h_unique_outer_inits : + (Cmds.definedVars accum.reverse ++ + ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ + Block.initVars rest)).Nodup) : + (Cmds.definedVars ([] : List (Cmd P)).reverse ++ Block.initVars rest).Nodup := by + simp [Cmds.definedVars] + exact (List.nodup_append.mp (List.nodup_append.mp h_unique_outer_inits).2.1).2.1 + +/-- No-op-prepend bundle for the `.typeDecl` arm of `stmtsToBlocks_simulation`. -/ +private theorem typeDecl_arm_combined_lemmas {P : PureExpr} + [HasIdent P] [HasVarsPure P P.Expr] + (tc : TypeConstructor) (md : MetaData P) (accum : List (Cmd P)) + (rest : List (Stmt P (Cmd P))) (σ_base : SemanticStore P) + (h_fresh : ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars (.typeDecl tc md :: rest), σ_base x = none) + (h_uniq : (Cmds.definedVars accum.reverse ++ Block.initVars (.typeDecl tc md :: rest)).Nodup) + (h_no_d : NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ Block.initVars (.typeDecl tc md :: rest))) + (h_no_m : NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars (.typeDecl tc md :: rest))) + (h_no_g : NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ Block.getVars (.typeDecl tc md :: rest))) : + (∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars rest, σ_base x = none) + ∧ (Cmds.definedVars accum.reverse ++ Block.initVars rest).Nodup + ∧ (NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ Block.initVars rest)) + ∧ (NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars rest)) + ∧ (NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ Block.getVars rest)) := by + have h_d : Cmds.definedVars accum.reverse ++ Block.initVars rest = + Cmds.definedVars accum.reverse ++ Block.initVars (.typeDecl tc md :: rest) := by + simp [Block.initVars, Stmt.initVars] + have h_m : Cmds.modifiedVars accum.reverse ++ transformBlockModVars rest = + Cmds.modifiedVars accum.reverse ++ transformBlockModVars (.typeDecl tc md :: rest) := by + rw [transformBlockModVars_cons, transformStmtModVars_typeDecl, List.nil_append] + have h_g : Cmds.getVars accum.reverse ++ Block.getVars rest = + Cmds.getVars accum.reverse ++ Block.getVars (.typeDecl tc md :: rest) := by + show Cmds.getVars accum.reverse ++ Block.getVars rest = + Cmds.getVars accum.reverse ++ (Stmt.getVars (Stmt.typeDecl tc md) ++ Block.getVars rest) + rfl + exact ⟨fun x hx => h_fresh x (h_d ▸ hx), + h_d ▸ h_uniq, + fun x hx s heq => h_no_d x (h_d ▸ hx) s heq, + fun x hx s heq => h_no_m x (h_m ▸ hx) s heq, + fun x hx s heq => h_no_g x (h_g ▸ hx) s heq⟩ + +set_option maxHeartbeats 3200000 in +set_option maxRecDepth 4096 in +mutual +/-- The central simulation lemma, written in a StoreAgreement-based shape. + +The structured execution runs `accum.reverse` from `σ_struct_base` to `ρ₀.store`, +then continues into `ss` reaching `ρ'`. The CFG starts at `entry` with store +`σ_base` (which agrees with `σ_struct_base`) and the same accumulated commands +get folded into block prefixes. We require: + +- `h_agree_entry : StoreAgreement σ_struct_base σ_base` — the CFG-side store + agrees with the structured-side accum-base. +- `h_fresh_combined : ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars ss, + σ_base x = none` — every variable that will be initialized (either by accum + or by upcoming `ss`) is currently fresh on the CFG side. +- `h_unique_combined : (Cmds.definedVars accum.reverse ++ Block.initVars ss).Nodup` + — those initialized variables form a Nodup list. + +The conclusion adds a freshness-preservation conjunct: if `σ_base x = none` +and `x` is not in either accum's defs or `ss`'s inits, then the CFG-side +`σ_cfg x = none`. This propagates freshness through CFG transitions into +the recursive call on the rest of the program. -/ +private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] + [LawfulHasIntOrder P] [LawfulHasNot P] + (extendEval : ExtendEval P) + (k : String) (ss : List (Stmt P (Cmd P))) + (exitConts : List (Option String × String)) + (accum : List (Cmd P)) + (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P) + (h_gen : (stmtsToBlocks k ss exitConts accum gen) = ((entry, blocks), gen')) + (h_nofd : Block.noFuncDecl ss = true) + (h_simple : Block.simpleShape ss = true) + (h_unique : Block.uniqueInits ss) + (σ_struct_base σ_base : SemanticStore P) + (hf_base : Bool) + (hf_accum : Bool) + (ρ₀ ρ' : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.terminal ρ')) + (h_accum : EvalCmds P (EvalCmd P) ρ₀.eval σ_struct_base accum.reverse ρ₀.store hf_accum) + (h_agree_entry : StoreAgreement σ_struct_base σ_base) + (h_fresh_combined : + ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars ss, σ_base x = none) + (h_unique_combined : + (Cmds.definedVars accum.reverse ++ Block.initVars ss).Nodup) + (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) + (h_wf_gen : StringGenState.WF gen) + (h_combined_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ Block.initVars ss)) + (h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars ss)) + (h_combined_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ Block.getVars ss)) + (genUpperBound : StringGenState) + (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) + (h_store_no_gens_upper : ∀ x : String, + String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_base (HasIdent.ident (P := P) x) = none) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (h_cfg_blocks : ∀ b ∈ blocks, b ∈ cfg.blocks) + (h_cfg_nodup : (cfg.blocks.map Prod.fst).Nodup) : + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock entry σ_base hf_base) + (.atBlock k σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg + ∧ (∀ x, σ_base x = none → + x ∉ Cmds.definedVars accum.reverse → x ∉ Block.initVars ss → + (∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen') → + σ_cfg x = none) := by + match h_match : ss with + | [] => + -- stmtsToBlocks k [] exitConts accum = flushCmds "l$" accum .none k + unfold stmtsToBlocks at h_gen + have h_ρ : ρ₀ = ρ' := stmts_nil_terminal (EvalCmd P) extendEval _ _ h_term + subst h_ρ + -- Block.initVars [] = [], so combined-fresh reduces to fresh on accum. + have h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none := by + intro x hx + apply h_fresh_combined x + simp [Block.initVars] + exact hx + have h_unique_accum : (Cmds.definedVars accum.reverse).Nodup := by + have h := h_unique_combined + simp [Block.initVars] at h + exact h + have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := + flushCmds_simulation_agree extendEval "l$" k accum gen gen' entry blocks h_gen + σ_struct_base σ_base hf_base hf_accum ρ₀ hwfb hwfv hwf_def hwf_congr h_accum + h_agree_entry h_fresh_accum h_unique_accum h_hf cfg h_cfg_blocks h_cfg_nodup + refine ⟨σ_cfg, h_step, h_agree, ?_⟩ + intro x h_σ_x h_x_not_accum _ _ + exact h_preserve x h_σ_x h_x_not_accum + | .cmd c :: rest => + unfold stmtsToBlocks at h_gen + -- Structured semantics: execute c then rest + have ⟨ρ₁, h_c_star, h_rest_star⟩ := + stmts_append_terminates P (EvalCmd P) extendEval [.cmd c] rest ρ₀ ρ' + (by simp at h_term ⊢; exact h_term) + have ⟨σ_c, failed_c, heval_c, hstore_c, heval_eq_c, hfail_c⟩ := + single_cmd_eval extendEval c ρ₀ ρ₁ h_c_star + have h_accum' : EvalCmds P (EvalCmd P) ρ₁.eval σ_struct_base + (c :: accum).reverse ρ₁.store (hf_accum || failed_c) := by + simp [List.reverse_cons] + rw [heval_eq_c, hstore_c] + exact EvalCmds_snoc ρ₀.eval σ_struct_base ρ₀.store σ_c accum.reverse c hf_accum failed_c + h_accum heval_c + have h_hf' : ρ₁.hasFailure = (hf_base || (hf_accum || failed_c)) := by + rw [hfail_c, h_hf, Bool.or_assoc] + have hwfb' : WellFormedSemanticEvalBool ρ₁.eval := by rw [heval_eq_c]; exact hwfb + have hwfv' : WellFormedSemanticEvalVal ρ₁.eval := by rw [heval_eq_c]; exact hwfv + have hwf_def' : WellFormedSemanticEvalDef ρ₁.eval := by rw [heval_eq_c]; exact hwf_def + have hwf_congr' : WellFormedSemanticEvalExprCongr ρ₁.eval := by + rw [heval_eq_c]; exact hwf_congr + have hwf_var' : WellFormedSemanticEvalVar ρ₁.eval := by rw [heval_eq_c]; exact hwf_var + have h_nofd_rest : Block.noFuncDecl rest = true := by + simp [Block.noFuncDecl] at h_nofd; exact h_nofd.2 + have h_simple_rest : Block.simpleShape rest = true := + (Block.simpleShape_cons_iff.mp h_simple).2 + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + -- Snoc/cons rebracketing facts shared between _simulation and _to_cont. + have ⟨h_definedVars_snoc, h_fresh_combined', h_unique_combined', + h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', + h_combined_no_gen_suffix_get'⟩ := + cmd_arm_combined_lemmas c accum rest σ_base + h_fresh_combined h_unique_combined + h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + h_combined_no_gen_suffix_get + have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := + stmtsToBlocks_simulation extendEval k rest exitConts (c :: accum) gen gen' + entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest + σ_struct_base σ_base hf_base (hf_accum || failed_c) + ρ₁ ρ' hwfb' hwfv' hwf_def' hwf_congr' hwf_var' + h_rest_star h_accum' + h_agree_entry h_fresh_combined' h_unique_combined' h_hf' + h_wf_gen h_combined_no_gen_suffix' h_combined_no_gen_suffix_mod' + h_combined_no_gen_suffix_get' + genUpperBound h_outer_upper h_store_no_gens_upper + cfg h_cfg_blocks h_cfg_nodup + refine ⟨σ_cfg, h_step, h_agree, ?_⟩ + intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + -- σ_base x = none ∧ x ∉ accum ∧ x ∉ Block.initVars (.cmd c :: rest) + -- Need: σ_cfg x = none. + -- Goal premises for h_preserve: + -- x ∉ Cmds.definedVars (c :: accum).reverse ∧ x ∉ Block.initVars rest + have h_x_not_new_accum : x ∉ Cmds.definedVars (c :: accum).reverse := by + rw [List.reverse_cons, h_definedVars_snoc] + intro h_in + cases List.mem_append.mp h_in with + | inl h => exact h_x_not_accum h + | inr h => + -- x in Cmd.definedVars c; this means c is .init x ... + cases c with + | init x' _ _ _ => + simp [Cmd.definedVars] at h + subst h + apply h_x_not_inits + simp [Block.initVars, Stmt.initVars] + | _ => simp [Cmd.definedVars] at h + have h_x_not_rest_inits : x ∉ Block.initVars rest := by + intro h + apply h_x_not_inits + rw [Block.initVars] + -- Stmt.initVars (.cmd _) is either [x'] or [], in either case x ∈ rhs ∪ Block.initVars rest + cases c <;> simp [Stmt.initVars] <;> first | right; exact h | exact h + exact h_preserve x h_σ_x h_x_not_new_accum h_x_not_rest_inits h_outer_guard + | .ite (.det e) thenBranch elseBranch md :: rest => + unfold stmtsToBlocks at h_gen + simp [bind, StateT.bind, pure, StateT.pure, List.append_nil] at h_gen + -- Decompose the monadic h_gen into component computations + generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen + obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest + simp at h_gen + generalize h_ite_label : StringGenState.gen "ite" gen_r = r_ite at h_gen + obtain ⟨l_ite, gen_ite⟩ := r_ite + simp at h_gen + generalize h_then_eq : stmtsToBlocks kNext thenBranch exitConts [] gen_ite = r_then at h_gen + obtain ⟨⟨tl, tbs⟩, gen_t⟩ := r_then + simp at h_gen + generalize h_else_eq : stmtsToBlocks kNext elseBranch exitConts [] gen_t = r_else at h_gen + obtain ⟨⟨fl, fbs⟩, gen_e⟩ := r_else + simp at h_gen + generalize h_flush_eq : flushCmds "ite$" accum + (some (DetTransferCmd.condGoto e tl fl md)) l_ite gen_e = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_entry : accumEntry = entry := (Prod.mk.inj (Prod.mk.inj h_gen).1).1 + have h_blocks : accumBlocks ++ (tbs ++ (fbs ++ bsNext)) = blocks := + (Prod.mk.inj (Prod.mk.inj h_gen).1).2 + subst h_entry + -- Decompose the structured execution of (ite :: rest) + have ⟨ρ₁, h_ite_star, h_rest_star⟩ := + stmts_append_terminates P (EvalCmd P) extendEval + [.ite (.det e) thenBranch elseBranch md] rest ρ₀ ρ' + (by simp at h_term ⊢; exact h_term) + -- Invert: the ite steps to either then-branch or else-branch + have h_ite_inv : (StepStmtStar P (EvalCmd P) extendEval + (.stmts thenBranch ρ₀) (.terminal ρ₁) ∧ + ρ₀.eval ρ₀.store e = .some HasBool.tt) ∨ + (StepStmtStar P (EvalCmd P) extendEval + (.stmts elseBranch ρ₀) (.terminal ρ₁) ∧ + ρ₀.eval ρ₀.store e = .some HasBool.ff) := by + cases h_ite_star with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have ⟨ρ_mid, h_inner, h_nil⟩ := + seq_reaches_terminal P (EvalCmd P) extendEval hrest1 + have h_eq := stmts_nil_terminal (EvalCmd P) extendEval _ _ h_nil + subst h_eq + cases h_inner with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_ite_true h_eval_tt _ => + exact Or.inl ⟨hrest2, h_eval_tt⟩ + | step_ite_false h_eval_ff _ => + exact Or.inr ⟨hrest2, h_eval_ff⟩ + -- Block membership: distribute h_cfg_blocks over concatenated blocks + subst h_blocks + have h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_left _ hb) + have h_cfg_tbs : ∀ b ∈ tbs, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ + (List.mem_append_left _ hb)) + have h_cfg_fbs : ∀ b ∈ fbs, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ + (List.mem_append_right _ (List.mem_append_left _ hb))) + have h_cfg_rest : ∀ b ∈ bsNext, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ + (List.mem_append_right _ (List.mem_append_right _ hb))) + -- Extract noFuncDecl for sub-blocks from h_nofd + have h_nofd_then : Block.noFuncDecl thenBranch = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.1.1 + have h_nofd_else : Block.noFuncDecl elseBranch = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.1.2 + have h_nofd_rest : Block.noFuncDecl rest = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.2 + -- Extract simpleShape for sub-blocks from h_simple + have h_simple_head : Stmt.simpleShape (.ite (.det e) thenBranch elseBranch md) = true := + (Block.simpleShape_cons_iff.mp h_simple).1 + have h_simple_rest : Block.simpleShape rest = true := + (Block.simpleShape_cons_iff.mp h_simple).2 + have h_simple_then : Block.simpleShape thenBranch = true := + Stmt.simpleShape_branch_then h_simple_head + have h_simple_else : Block.simpleShape elseBranch = true := + Stmt.simpleShape_branch_else h_simple_head + -- Eval well-formedness preservation through ite branch + have h_eval_eq : ρ₁.eval = ρ₀.eval := by + rcases h_ite_inv with h | h + · exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + thenBranch ρ₀ ρ₁ h_nofd_then h.1 + · exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + elseBranch ρ₀ ρ₁ h_nofd_else h.1 + have hwfb₁ : WellFormedSemanticEvalBool ρ₁.eval := h_eval_eq ▸ hwfb + have hwfv₁ : WellFormedSemanticEvalVal ρ₁.eval := h_eval_eq ▸ hwfv + have hwf_def₁ : WellFormedSemanticEvalDef ρ₁.eval := h_eval_eq ▸ hwf_def + have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ₁.eval := h_eval_eq ▸ hwf_congr + have hwf_var₁ : WellFormedSemanticEvalVar ρ₁.eval := h_eval_eq ▸ hwf_var + have h_unique_then : Block.uniqueInits thenBranch := + Block.uniqueInits.ite_then h_unique + have h_unique_else : Block.uniqueInits elseBranch := + Block.uniqueInits.ite_else h_unique + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + -- Lift accum to the CFG side via EvalCmds_under_agreement. + -- This produces σ_cfg_after, the CFG store after running accum. + have h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none := by + intro x hx + exact h_fresh_combined x (List.mem_append_left _ hx) + have h_unique_accum : (Cmds.definedVars accum.reverse).Nodup := + (List.nodup_append.mp h_unique_combined).1 + have ⟨σ_cfg_after, h_accum_cfg, h_agree_after⟩ := + EvalCmds_under_agreement ρ₀.eval accum.reverse hwf_def hwf_congr + σ_struct_base σ_base ρ₀.store hf_accum h_agree_entry h_accum h_fresh_accum + h_unique_accum + -- Freshness preservation through the lifted accum. + have h_preserve_after : + ∀ x, σ_base x = none → x ∉ Cmds.definedVars accum.reverse → + σ_cfg_after x = none := by + intro x h_σ h_x_not + exact agreement_helper_unchanged_at_x_multi h_accum_cfg h_x_not h_σ + -- Block.initVars decomposition: outer ss = .ite ... :: rest, so + -- Block.initVars ss = Block.initVars tss ++ Block.initVars ess ++ Block.initVars rest + have h_initvars_eq : + Block.initVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md :: rest) = + (Block.initVars thenBranch ++ Block.initVars elseBranch) ++ Block.initVars rest := by + rw [Block.initVars] + simp [Stmt.initVars] + have h_unique_outer_inits : + (Cmds.definedVars accum.reverse ++ + ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ Block.initVars rest)).Nodup := by + rw [← h_initvars_eq]; exact h_unique_combined + -- Freshness for sub-branch and rest recursions. + have h_fresh_then_inits : ∀ x ∈ Block.initVars thenBranch, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun hx_acc => + (List.nodup_append.mp h_unique_outer_inits).2.2 x hx_acc x + (List.mem_append_left _ (List.mem_append_left _ hx)) rfl + have h_σ_x : σ_base x = none := + h_fresh_combined x (List.mem_append_right _ + (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_left _ hx))) + exact h_preserve_after x h_σ_x h_x_not_accum + have h_fresh_else_inits : ∀ x ∈ Block.initVars elseBranch, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun hx_acc => + (List.nodup_append.mp h_unique_outer_inits).2.2 x hx_acc x + (List.mem_append_left _ (List.mem_append_right _ hx)) rfl + have h_σ_x : σ_base x = none := + h_fresh_combined x (List.mem_append_right _ + (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_right _ hx))) + exact h_preserve_after x h_σ_x h_x_not_accum + have h_fresh_rest_inits_after : + ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun hx_acc => + (List.nodup_append.mp h_unique_outer_inits).2.2 x hx_acc x + (List.mem_append_right _ hx) rfl + have h_σ_x : σ_base x = none := + h_fresh_combined x (List.mem_append_right _ + (h_initvars_eq ▸ List.mem_append_right _ hx)) + exact h_preserve_after x h_σ_x h_x_not_accum + -- Combined freshness for branch recursion (empty accum + branch's inits). + have h_combined_then : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars thenBranch, + σ_cfg_after x = none := + fun x hx => h_fresh_then_inits x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_then : + (Cmds.definedVars [].reverse ++ Block.initVars thenBranch).Nodup := + unique_combined_ite_then h_unique_outer_inits + have h_combined_else : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars elseBranch, + σ_cfg_after x = none := + fun x hx => h_fresh_else_inits x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_else : + (Cmds.definedVars [].reverse ++ Block.initVars elseBranch).Nodup := + unique_combined_ite_else h_unique_outer_inits + -- Lookup helper for the condGoto helpers + have h_lookup : ∀ lbl blk, (lbl, blk) ∈ cfg.blocks → + cfg.blocks.lookup lbl = some blk := + fun lbl blk h_mem => List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup lbl blk h_mem + -- GenStep chains for WF and subset. + have h_gen_eq_f : gen_f = gen' := (Prod.mk.inj h_gen).2 + have h_step_e_to_f : StringGenState.GenStep gen_e gen_f := + flushCmds_genStep _ _ _ _ _ _ _ _ h_flush_eq + have h_step_t_to_e : StringGenState.GenStep gen_t gen_e := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_else_eq + have h_step_ite_to_t : StringGenState.GenStep gen_ite gen_t := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_then_eq + have h_step_r_to_ite : StringGenState.GenStep gen_r gen_ite := by + have h_eq : (StringGenState.gen "ite" gen_r).2 = gen_ite := congrArg Prod.snd h_ite_label + exact h_eq ▸ StringGenState.GenStep.of_gen "ite" gen_r + have h_step_gen_to_r : StringGenState.GenStep gen gen_r := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_rest_eq + have h_step_gen_to_ite : StringGenState.GenStep gen gen_ite := + h_step_gen_to_r.trans h_step_r_to_ite + have h_step_gen_to_t : StringGenState.GenStep gen gen_t := + h_step_gen_to_ite.trans h_step_ite_to_t + have h_step_gen_to_e : StringGenState.GenStep gen gen_e := + h_step_gen_to_t.trans h_step_t_to_e + have h_wf_t : StringGenState.WF gen_t := h_step_gen_to_t.wf_mono h_wf_gen + have h_wf_e : StringGenState.WF gen_e := h_step_gen_to_e.wf_mono h_wf_gen + have h_wf_r : StringGenState.WF gen_r := h_step_gen_to_r.wf_mono h_wf_gen + have h_wf_ite : StringGenState.WF gen_ite := h_step_gen_to_ite.wf_mono h_wf_gen + -- Lift store-no-gens-upper to σ_cfg_after for the upper-bound form. + have h_store_no_gens_upper_after : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_after (HasIdent.ident (P := P) x) = none := + store_no_gens_lift_after_accum h_accum_cfg genUpperBound h_store_no_gens_upper + (fun x hx => h_combined_no_gen_suffix x (List.mem_append_left _ hx)) + -- Subset chains lifting outer upper-bound to inner gen' subsets. + have h_outer_upper_e : StringGenState.stringGens gen_e ⊆ StringGenState.stringGens genUpperBound := + h_step_e_to_f.subset.trans (h_gen_eq_f ▸ h_outer_upper) + have h_outer_upper_t : StringGenState.stringGens gen_t ⊆ StringGenState.stringGens genUpperBound := + h_step_t_to_e.subset.trans h_outer_upper_e + have h_outer_upper_r : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens genUpperBound := + h_step_r_to_ite.subset.trans (h_step_ite_to_t.subset.trans h_outer_upper_t) + -- Sub-branch and rest combined-no-gen-suffix discharges. + have h_then_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars thenBranch) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.definedVars] using hx)))) s heq + have h_else_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars elseBranch) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.definedVars] using hx)))) s heq + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hx))) s heq + -- Mirror of h_initvars_eq / no_gen_suffix discharges for modifiedVars. + have h_modvars_eq : + transformBlockModVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md :: rest) = + (transformBlockModVars thenBranch ++ transformBlockModVars elseBranch) ++ transformBlockModVars rest := by + rw [transformBlockModVars_cons, transformStmtModVars_ite] + have h_then_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars thenBranch) := fun x hx s heq => + h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hx)))) s heq + have h_else_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars elseBranch) := fun x hx s heq => + h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx)))) s heq + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun x hx s heq => + h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq + -- Mirror of h_initvars_eq / no_gen_suffix discharges for getVars. + have h_getvars_eq : + Block.getVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md :: rest) = + (HasVarsPure.getVars e ++ Block.getVars thenBranch ++ Block.getVars elseBranch) ++ + Block.getVars rest := by + show Stmt.getVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md) ++ + Block.getVars rest = _ + rfl + have h_then_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars thenBranch) := fun x hx s heq => + h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (List.mem_append_right _ + (by simpa [Cmds.getVars] using hx))))) s heq + have h_else_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars elseBranch) := fun x hx s heq => + h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.getVars] using hx)))) s heq + have h_rest_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := fun x hx s heq => + h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq + rcases h_ite_inv with h_true | h_false + · obtain ⟨h_then_term, h_cond_tt⟩ := h_true + -- Step from accumEntry to tl via the lifted accum + condGoto. + have h_flush_sim : StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock tl σ_cfg_after ρ₀.hasFailure) := + flushCmds_condGoto_true_agree extendEval accum e tl fl md l_ite gen_e gen_f + accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ + hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_tt cfg + h_cfg_accum h_lookup + -- Recurse on thenBranch. + have h_accum_nil_t : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨σ_branch, h_then_step, h_agree_then, h_preserve_then⟩ := + stmtsToBlocks_simulation extendEval kNext thenBranch exitConts [] + gen_ite gen_t tl tbs h_then_eq h_nofd_then h_simple_then h_unique_then + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ₁ hwfb hwfv hwf_def hwf_congr hwf_var + h_then_term h_accum_nil_t h_agree_after + h_combined_then h_unique_combined_then (by simp) + h_wf_ite h_then_no_gen_suffix h_then_no_gen_suffix_mod + h_then_no_gen_suffix_get + genUpperBound h_outer_upper_t h_store_no_gens_upper_after + cfg h_cfg_tbs h_cfg_nodup + -- Freshness of rest's inits at σ_branch. + have h_fresh_rest_inits_branch : + ∀ x ∈ Block.initVars rest, σ_branch x = none := by + intro x hx + have h_x_not_then : x ∉ Block.initVars thenBranch := by + intro h_in_then + have h1 : ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ + Block.initVars rest).Nodup := + (List.nodup_append.mp h_unique_outer_inits).2.1 + have h_disj_lr := (List.nodup_append.mp h1).2.2 + have h_in_then_else : x ∈ Block.initVars thenBranch ++ Block.initVars elseBranch := + List.mem_append_left _ h_in_then + exact h_disj_lr x h_in_then_else x hx rfl + have h_σ_after_x : σ_cfg_after x = none := h_fresh_rest_inits_after x hx + have : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + exact h_preserve_then x h_σ_after_x this h_x_not_then + (fun s heq => Or.inr + (StringGenState.not_mem_stringGens_of_not_hasUnderscoreDigitSuffix h_wf_t + (h_rest_no_gen_suffix x (by simp [Cmds.definedVars]; exact hx) s heq))) + -- Combined freshness for rest recursion. + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_branch x = none := fun x hx => + h_fresh_rest_inits_branch x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := + unique_combined_ite_rest h_unique_outer_inits + -- Recurse on rest. + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ₁.eval ρ₁.store + [].reverse ρ₁.store false := EvalCmds.eval_cmds_none + -- Lift `h_store_no_gens_upper` through the thenBranch sub-simulation + -- using the strengthened (4-premise) `h_preserve_then` directly. + have h_store_no_gens_upper_branch_t : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_branch (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_ite gen_t genUpperBound + h_outer_upper_t h_preserve_then h_store_no_gens_upper_after + (fun x hx s heq => h_then_no_gen_suffix x (List.mem_append_right _ hx) s heq) + have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ₁.store σ_branch ρ₁.hasFailure false + ρ₁ ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_star h_accum_nil_r h_agree_then + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_t + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ + · exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_flush_sim h_then_step) h_rest_sim + · -- Freshness preservation for the outer call. + intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + -- Decompose h_x_not_inits: x ∉ Block.initVars (.ite ... :: rest) + -- = x ∉ Block.initVars tss ∧ x ∉ Block.initVars ess ∧ x ∉ Block.initVars rest + have h_x_not_then : x ∉ Block.initVars thenBranch := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_left _ hx)) + have h_x_not_else : x ∉ Block.initVars elseBranch := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_right _ hx)) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_after x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from the outer guard via GenStep monotonicity. + -- Chain: gen → gen_r → gen_ite → gen_t → gen_e → gen_f = gen'. + have h_inner_guard_t : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_ite ∨ + s ∉ StringGenState.stringGens gen_t := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl (h_step_gen_to_ite.subset h_in) + | Or.inr h_not_in => Or.inr + (fun h_in_t => h_not_in + (h_gen_eq_f ▸ h_step_e_to_f.subset (h_step_t_to_e.subset h_in_t))) + have h_inner_guard_r : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen_r := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl h_in + | Or.inr h_not_in => Or.inr (fun h_in_r => h_not_in + (h_gen_eq_f ▸ h_step_e_to_f.subset (h_step_t_to_e.subset + (h_step_ite_to_t.subset (h_step_r_to_ite.subset h_in_r))))) + have h_σ_branch_x : σ_branch x = none := + h_preserve_then x h_σ_after_x h_nil_not h_x_not_then h_inner_guard_t + exact h_preserve_rest x h_σ_branch_x h_nil_not h_x_not_rest h_inner_guard_r + · obtain ⟨h_else_term, h_cond_ff⟩ := h_false + -- Step from accumEntry to fl via the lifted accum + condGoto. + have h_flush_sim : StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock fl σ_cfg_after ρ₀.hasFailure) := + flushCmds_condGoto_false_agree extendEval accum e tl fl md l_ite gen_e gen_f + accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ + hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_ff cfg + h_cfg_accum h_lookup + -- Recurse on elseBranch. + have h_accum_nil_f : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨σ_branch, h_else_step, h_agree_else, h_preserve_else⟩ := + stmtsToBlocks_simulation extendEval kNext elseBranch exitConts [] + gen_t gen_e fl fbs h_else_eq h_nofd_else h_simple_else h_unique_else + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ₁ hwfb hwfv hwf_def hwf_congr hwf_var + h_else_term h_accum_nil_f h_agree_after + h_combined_else h_unique_combined_else (by simp) + h_wf_t h_else_no_gen_suffix h_else_no_gen_suffix_mod + h_else_no_gen_suffix_get + genUpperBound h_outer_upper_e h_store_no_gens_upper_after + cfg h_cfg_fbs h_cfg_nodup + -- Freshness of rest's inits at σ_branch. + have h_fresh_rest_inits_branch : + ∀ x ∈ Block.initVars rest, σ_branch x = none := by + intro x hx + have h_x_not_else : x ∉ Block.initVars elseBranch := by + intro h_in_else + have h1 : ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ + Block.initVars rest).Nodup := + (List.nodup_append.mp h_unique_outer_inits).2.1 + have h_disj_lr := (List.nodup_append.mp h1).2.2 + have h_in_then_else : x ∈ Block.initVars thenBranch ++ Block.initVars elseBranch := + List.mem_append_right _ h_in_else + exact h_disj_lr x h_in_then_else x hx rfl + have h_σ_after_x : σ_cfg_after x = none := h_fresh_rest_inits_after x hx + have : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + exact h_preserve_else x h_σ_after_x this h_x_not_else + (fun s heq => Or.inr + (StringGenState.not_mem_stringGens_of_not_hasUnderscoreDigitSuffix h_wf_e + (h_rest_no_gen_suffix x (by simp [Cmds.definedVars]; exact hx) s heq))) + -- Combined freshness for rest recursion. + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_branch x = none := fun x hx => + h_fresh_rest_inits_branch x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := + unique_combined_ite_rest h_unique_outer_inits + -- Recurse on rest. + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ₁.eval ρ₁.store + [].reverse ρ₁.store false := EvalCmds.eval_cmds_none + -- Lift `h_store_no_gens_upper` through the elseBranch sub-simulation + -- using the strengthened (4-premise) `h_preserve_else` directly. + have h_store_no_gens_upper_branch_e : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_branch (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_t gen_e genUpperBound + h_outer_upper_e h_preserve_else h_store_no_gens_upper_after + (fun x hx s heq => h_else_no_gen_suffix x (List.mem_append_right _ hx) s heq) + have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ₁.store σ_branch ρ₁.hasFailure false + ρ₁ ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_star h_accum_nil_r h_agree_else + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_e + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ + · exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_flush_sim h_else_step) h_rest_sim + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_then : x ∉ Block.initVars thenBranch := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_left _ hx)) + have h_x_not_else : x ∉ Block.initVars elseBranch := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_right _ hx)) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_after x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + -- Chain: gen → gen_r → gen_ite → gen_t → gen_e → gen_f = gen'. + have h_inner_guard_e : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_t ∨ + s ∉ StringGenState.stringGens gen_e := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl (h_step_gen_to_t.subset h_in) + | Or.inr h_not_in => Or.inr (fun h_in_e => h_not_in + (h_gen_eq_f ▸ h_step_e_to_f.subset h_in_e)) + have h_inner_guard_r : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen_r := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl h_in + | Or.inr h_not_in => Or.inr (fun h_in_r => h_not_in + (h_gen_eq_f ▸ h_step_e_to_f.subset (h_step_t_to_e.subset + (h_step_ite_to_t.subset (h_step_r_to_ite.subset h_in_r))))) + have h_σ_branch_x : σ_branch x = none := + h_preserve_else x h_σ_after_x h_nil_not h_x_not_else h_inner_guard_e + exact h_preserve_rest x h_σ_branch_x h_nil_not h_x_not_rest h_inner_guard_r + | .ite .nondet _ _ _ :: _ => + exact absurd (Block.simpleShape_cons_iff.mp h_simple).1 (by simp [Stmt.simpleShape]) + | .loop _ _ _ _ _ :: _ => + exact absurd (Block.simpleShape_cons_iff.mp h_simple).1 (by simp [Stmt.simpleShape]) + | .block label body md :: rest => + simp only [stmtsToBlocks, bind, StateT.bind, pure, StateT.pure] at h_gen + -- Decompose the monadic chain + generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen + obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest + simp at h_gen + generalize h_body_eq : stmtsToBlocks kNext body + ((some label, kNext) :: exitConts) [] gen_r = r_body at h_gen + obtain ⟨⟨bl, bbs⟩, gen_b⟩ := r_body + simp at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "blk$" accum .none bl gen_b + = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + -- Decompose structured execution of [.block label body md :: rest] + have ⟨ρ_blk, h_block_star, h_rest_star⟩ := + stmts_append_terminates P (EvalCmd P) extendEval + [.block label body md] rest ρ₀ ρ' + (by simp at h_term ⊢; exact h_term) + -- Invert: structured execution of [.block label body md] to terminal ρ_blk. + -- Step 1: step_stmts_cons. + -- Step 2: step_block enters the block (saves parent store ρ₀.store). + -- Step 3: body executes in the block context. + -- Step 4: step_block_done OR step_block_exit_match terminates the block, + -- producing { ρ_inner with store := projectStore ρ₀.store ρ_inner.store }. + -- Use the stronger inversion `block_some_reaches_terminal` for our explicitly-labelled + -- block; this constrains the exit-match label to equal `label`. + have h_block_inv : + (∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ₀) (.terminal ρ_inner) ∧ + ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store }) ∨ + (∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ₀) (.exiting label ρ_inner) ∧ + ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store }) := by + cases h_block_star with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have ⟨ρ_mid, h_inner, h_nil⟩ := + seq_reaches_terminal P (EvalCmd P) extendEval hrest1 + have h_eq := stmts_nil_terminal (EvalCmd P) extendEval _ _ h_nil + subst h_eq + cases h_inner with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_block => + exact block_some_reaches_terminal P (EvalCmd P) extendEval hrest2 + -- Extract ρ_inner. In both cases (terminal/exit-match), the projection eq holds. + obtain ⟨ρ_inner, h_body_term_or_exit, h_ρ_blk_eq⟩ : ∃ ρ_inner, + (StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ₀) (.terminal ρ_inner) ∨ + StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ₀) (.exiting label ρ_inner)) ∧ + ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store } := by + rcases h_block_inv with h | h + · obtain ⟨ρ_i, hterm, heq⟩ := h + exact ⟨ρ_i, Or.inl hterm, heq⟩ + · obtain ⟨ρ_i, hexit, heq⟩ := h + exact ⟨ρ_i, Or.inr hexit, heq⟩ + -- noFuncDecl projections. + have h_nofd_body : Block.noFuncDecl body = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.1 + have h_nofd_rest : Block.noFuncDecl rest = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.2 + -- simpleShape projections. + have h_simple_head : Stmt.simpleShape (.block label body md) = true := + (Block.simpleShape_cons_iff.mp h_simple).1 + have h_simple_rest : Block.simpleShape rest = true := + (Block.simpleShape_cons_iff.mp h_simple).2 + have h_simple_body : Block.simpleShape body = true := by + simp only [Stmt.simpleShape] at h_simple_head; exact h_simple_head + -- uniqueInits projections. + have h_unique_body : Block.uniqueInits body := + Block.uniqueInits.block_body h_unique + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + -- Block.initVars decomposition: outer ss = .block label body md :: rest, so + -- Block.initVars ss = Block.initVars body ++ Block.initVars rest. + have h_initvars_eq : + Block.initVars (Stmt.block label body md :: rest) = + Block.initVars body ++ Block.initVars rest := by + rw [Block.initVars] + simp [Stmt.initVars] + -- Sub-block and rest combined-no-gen-suffix discharges (used for both + -- `label = bl` and `label ≠ bl` sub-cases). + have h_body_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars body) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.definedVars] using hx))) s heq + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hx))) s heq + -- Mirror of h_initvars_eq / no_gen_suffix discharges for modifiedVars. + have h_modvars_eq : + transformBlockModVars (Stmt.block label body md :: rest) = + transformBlockModVars body ++ transformBlockModVars rest := by + rw [transformBlockModVars_cons, transformStmtModVars_block] + have h_body_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := fun x hx s heq => + h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hx))) s heq + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun x hx s heq => + h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq + -- Mirror of h_initvars_eq / no_gen_suffix discharges for getVars. + have h_getvars_eq : + Block.getVars (Stmt.block label body md :: rest) = + Block.getVars body ++ Block.getVars rest := by + show Stmt.getVars (Stmt.block label body md) ++ Block.getVars rest = _ + rfl + have h_body_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars body) := fun x hx s heq => + h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.getVars] using hx))) s heq + have h_rest_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := fun x hx s heq => + h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq + -- GenStep chains for WF and subset (block case). + have h_step_b_to_f : StringGenState.GenStep gen_b gen_f := + flushCmds_genStep _ _ _ _ _ _ _ _ h_flush_eq + have h_step_r_to_b : StringGenState.GenStep gen_r gen_b := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_body_eq + have h_step_gen_to_r : StringGenState.GenStep gen gen_r := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_rest_eq + have h_step_gen_to_b : StringGenState.GenStep gen gen_b := + h_step_gen_to_r.trans h_step_r_to_b + have h_wf_r : StringGenState.WF gen_r := h_step_gen_to_r.wf_mono h_wf_gen + have h_wf_b : StringGenState.WF gen_b := h_step_gen_to_b.wf_mono h_wf_gen + -- Block membership distribution. We split based on l = bl vs l ≠ bl. + -- Convert h_gen via the if: extract entry and the blocks shape. + by_cases h_l_eq_bl : label = bl + · -- Case l = bl: blocks = accumBlocks ++ bbs ++ bsNext, entry = accumEntry. + simp [h_l_eq_bl] at h_gen + have h_entry_eq : accumEntry = entry := + (Prod.mk.inj (Prod.mk.inj h_gen).1).1 + have h_gen_eq_f : gen_f = gen' := (Prod.mk.inj h_gen).2 + have h_outer_upper_b : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens genUpperBound := + h_step_b_to_f.subset.trans (h_gen_eq_f ▸ h_outer_upper) + have h_outer_upper_r : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens genUpperBound := + h_step_r_to_b.subset.trans h_outer_upper_b + have h_blocks_eq : accumBlocks ++ (bbs ++ bsNext) = blocks := + (Prod.mk.inj (Prod.mk.inj h_gen).1).2 + subst h_entry_eq + subst h_blocks_eq + -- Lift store-no-gens to σ_cfg_after using the new helper. + -- (Bound after `flushCmds_simulation_agree` produces σ_cfg_after; introduced below.) + -- Block membership for sub-blocks. + have h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_left _ hb) + have h_cfg_bbs : ∀ b ∈ bbs, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ (List.mem_append_left _ hb)) + have h_cfg_rest : ∀ b ∈ bsNext, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ (List.mem_append_right _ hb)) + -- Case analysis: in the case l = bl, we use flushCmds_simulation_agree directly. + -- Compute h_fresh_accum / h_unique_accum from h_fresh_combined / h_unique_combined. + have h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none := by + intro x hx + exact h_fresh_combined x (List.mem_append_left _ hx) + have h_unique_accum : (Cmds.definedVars accum.reverse).Nodup := + (List.nodup_append.mp h_unique_combined).1 + -- Flush phase: step from accumEntry (= entry) to bl using flushCmds_simulation_agree. + have ⟨σ_cfg_after, h_step_flush, h_agree_after, h_preserve_flush⟩ := + flushCmds_simulation_agree extendEval "blk$" bl accum gen_b gen_f accumEntry + accumBlocks h_flush_eq σ_struct_base σ_base hf_base hf_accum ρ₀ + hwfb hwfv hwf_def hwf_congr h_accum h_agree_entry h_fresh_accum h_unique_accum + h_hf cfg h_cfg_accum h_cfg_nodup + -- Now we have: (.atBlock accumEntry σ_base hf_base) → (.atBlock bl σ_cfg_after ρ₀.hasFailure) + -- Body recursion: from (.atBlock bl σ_cfg_after ρ₀.hasFailure) to (.atBlock kNext σ_cfg_body _). + -- Body's structured run is from ρ₀ to ρ_inner. + -- Need to handle both terminal and exit-match cases for body. + rcases h_body_term_or_exit with h_body_term | h_body_exit_star + · -- Body terminates with ρ_inner; use that for the sim. + -- Freshness for body recursion (initVars body must be fresh in σ_cfg_after). + have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun h_in_accum => + -- x in body's initVars and accum's defs both, contradicting Nodup. + (h_initvars_eq ▸ List.nodup_append.mp h_unique_combined).2.2 + x h_in_accum x (List.mem_append_left _ hx) rfl + have h_σ_base_x : σ_base x = none := by + apply h_fresh_combined + apply List.mem_append_right + rw [h_initvars_eq] + exact List.mem_append_left _ hx + exact h_preserve_flush x h_σ_base_x h_x_not_accum + have h_combined_body : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_after x = none := + fun x hx => h_fresh_body_inits_after x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_body : + (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_body + have h_accum_nil : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + -- Lift store-no-gens-upper to σ_cfg_after. + have h_store_no_gens_upper_after : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_after (HasIdent.ident (P := P) x) = none := + store_no_gens_lift_after_flush h_preserve_flush genUpperBound h_store_no_gens_upper + (fun x hx => h_combined_no_gen_suffix x (List.mem_append_left _ hx)) + -- Recurse on body. + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation extendEval kNext body + ((some label, kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq + h_nofd_body h_simple_body h_unique_body + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_inner hwfb hwfv hwf_def hwf_congr hwf_var + h_body_term h_accum_nil h_agree_after + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_store_no_gens_upper_after + cfg h_cfg_bbs h_cfg_nodup + -- h_agree_body : StoreAgreement ρ_inner.store σ_cfg_body + -- Bridge structured-side projection to CFG. + have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := + StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body + -- Eval well-formedness preservation through body. + have h_eval_blk : ρ_blk.eval = ρ₀.eval := by + rw [h_ρ_blk_eq] + exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body ρ₀ ρ_inner h_nofd_body h_body_term + have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb + have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv + have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def + have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr + have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var + -- Freshness for rest's inits at σ_cfg_body. + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := + fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b + h_rest_no_gen_suffix h_fresh_rest_inits_after + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_cfg_body x = none := fun x hx => + h_fresh_rest_inits_body x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_rest + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_blk.eval ρ_blk.store + [].reverse ρ_blk.store false := EvalCmds.eval_cmds_none + -- ρ_blk.hasFailure = ρ_inner.hasFailure (since projection only changes store) + have h_hasFail_blk : ρ_blk.hasFailure = ρ_inner.hasFailure := by + rw [h_ρ_blk_eq] + -- Lift `h_store_no_gens_upper` through the body sub-simulation + -- using the strengthened (4-premise) `h_preserve_body` directly. + have h_store_no_gens_upper_body : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_body (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_r gen_b genUpperBound + h_outer_upper_b h_preserve_body h_store_no_gens_upper_after + (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) + -- Recurse on rest. + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + ρ_blk.hasFailure false ρ_blk ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_star h_accum_nil_r h_agree_block_body + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_body + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ + · -- Compose the CFG steps. h_step_body returns at ρ_inner.hasFailure; + -- transport to ρ_blk.hasFailure via h_hasFail_blk.symm. + exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest + · -- Freshness preservation for the outer call. + intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_body : x ∉ Block.initVars body := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ hx) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + -- Chain: gen → gen_r → gen_b → gen_f = gen'. + have h_inner_guard_b := + inner_guard_step_b h_step_gen_to_r h_step_b_to_f h_gen_eq_f h_outer_guard + have h_inner_guard_r := + inner_guard_step_r h_step_b_to_f h_step_r_to_b h_gen_eq_f h_outer_guard + have h_σ_body_x : σ_cfg_body x = none := + h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b + exact h_preserve_rest x h_σ_body_x h_nil_not h_x_not_rest h_inner_guard_r + · -- Body exits with matching label. Same final-store shape as inl: + -- ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store }. + -- CFG-side: body's exitCont (some label, kNext) resolves `.exit label` + -- inside body to a goto-kNext, so body's CFG reaches kNext. Use + -- `stmtsToBlocks_simulation_to_cont` for the body recursion. + -- exitConts for body = (some label, kNext) :: exitConts. + have h_label_lookup : + ((some label, kNext) :: exitConts).lookup (some label) = some kNext := by + simp [List.lookup] + -- Freshness for body recursion. + have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := + fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_combined_body : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_after x = none := + fun x hx => h_fresh_body_inits_after x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_body : + (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_body + have h_accum_nil : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + -- Lift store-no-gens-upper to σ_cfg_after. + have h_store_no_gens_upper_after : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_after (HasIdent.ident (P := P) x) = none := + store_no_gens_lift_after_flush h_preserve_flush genUpperBound h_store_no_gens_upper + (fun x hx => h_combined_no_gen_suffix x (List.mem_append_left _ hx)) + -- Recurse on body with _to_cont. + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation_to_cont extendEval kNext body + ((some label, kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq + h_nofd_body h_simple_body h_unique_body + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_inner label kNext h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var + h_body_exit_star h_accum_nil h_agree_after + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_store_no_gens_upper_after + cfg h_cfg_bbs h_cfg_nodup + -- Bridge structured-side projection to CFG. + have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := + StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body + -- Eval well-formedness preservation through body (to .exiting). + have h_eval_blk : ρ_blk.eval = ρ₀.eval := by + rw [h_ρ_blk_eq] + exact smallStep_noFuncDecl_preserves_eval_block_exiting P (EvalCmd P) extendEval + body ρ₀ ρ_inner label h_nofd_body h_body_exit_star + have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb + have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv + have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def + have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr + have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var + -- Freshness for rest's inits at σ_cfg_body. + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := + fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b + h_rest_no_gen_suffix h_fresh_rest_inits_after + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_cfg_body x = none := fun x hx => + h_fresh_rest_inits_body x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_rest + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_blk.eval ρ_blk.store + [].reverse ρ_blk.store false := EvalCmds.eval_cmds_none + have h_hasFail_blk : ρ_blk.hasFailure = ρ_inner.hasFailure := by + rw [h_ρ_blk_eq] + -- Lift `h_store_no_gens_upper` through the body sub-simulation + -- using the strengthened (4-premise) `h_preserve_body` directly. + have h_store_no_gens_upper_body : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_body (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_r gen_b genUpperBound + h_outer_upper_b h_preserve_body h_store_no_gens_upper_after + (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) + -- Recurse on rest with _simulation. + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + ρ_blk.hasFailure false ρ_blk ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_star h_accum_nil_r h_agree_block_body + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_body + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ + · -- Transport h_step_body from ρ_inner.hasFailure to ρ_blk.hasFailure. + exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_body : x ∉ Block.initVars body := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ hx) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + -- Chain: gen → gen_r → gen_b → gen_f = gen'. + have h_inner_guard_b := + inner_guard_step_b h_step_gen_to_r h_step_b_to_f h_gen_eq_f h_outer_guard + have h_inner_guard_r := + inner_guard_step_r h_step_b_to_f h_step_r_to_b h_gen_eq_f h_outer_guard + have h_σ_body_x : σ_cfg_body x = none := + h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b + exact h_preserve_rest x h_σ_body_x h_nil_not h_x_not_rest h_inner_guard_r + · -- Case l ≠ bl: blocks = accumBlocks ++ [(label, {cmds:=[], goto bl})] ++ bbs ++ bsNext, + -- entry = accumEntry (after the bug fix). CFG flow is the same as l = bl: + -- accumEntry → bl (via accumBlocks) → kNext (via body) → k (via rest). + -- The (label, ...) block is vestigial — not on the reachable path. + simp [h_l_eq_bl] at h_gen + have h_entry_eq : accumEntry = entry := + (Prod.mk.inj (Prod.mk.inj h_gen).1).1 + let lBlk : DetBlock String (Cmd P) P := + { cmds := [], transfer := DetTransferCmd.goto bl md } + have h_blocks_eq : + accumBlocks ++ (label, lBlk) :: (bbs ++ bsNext) = blocks := + (Prod.mk.inj (Prod.mk.inj h_gen).1).2 + have h_gen_eq_f : gen_f = gen' := (Prod.mk.inj h_gen).2 + subst h_entry_eq + have h_outer_upper_b : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens genUpperBound := + h_step_b_to_f.subset.trans (h_gen_eq_f ▸ h_outer_upper) + have h_outer_upper_r : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens genUpperBound := + h_step_r_to_b.subset.trans h_outer_upper_b + -- Block membership: extract from h_cfg_blocks. + -- blocks = accumBlocks ++ (label, lBlk) :: (bbs ++ bsNext) + have h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks := by + intro b hb + exact h_cfg_blocks b (h_blocks_eq ▸ List.mem_append_left _ hb) + have h_cfg_bbs : ∀ b ∈ bbs, b ∈ cfg.blocks := by + intro b hb + exact h_cfg_blocks b + (h_blocks_eq ▸ List.mem_append_right _ (List.mem_cons_of_mem _ (List.mem_append_left _ hb))) + have h_cfg_rest : ∀ b ∈ bsNext, b ∈ cfg.blocks := by + intro b hb + exact h_cfg_blocks b + (h_blocks_eq ▸ List.mem_append_right _ (List.mem_cons_of_mem _ (List.mem_append_right _ hb))) + -- Now the proof proceeds exactly as in l = bl. + have h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none := by + intro x hx + exact h_fresh_combined x (List.mem_append_left _ hx) + have h_unique_accum : (Cmds.definedVars accum.reverse).Nodup := + (List.nodup_append.mp h_unique_combined).1 + have ⟨σ_cfg_after, h_step_flush, h_agree_after, h_preserve_flush⟩ := + flushCmds_simulation_agree extendEval "blk$" bl accum gen_b gen_f accumEntry + accumBlocks h_flush_eq σ_struct_base σ_base hf_base hf_accum ρ₀ + hwfb hwfv hwf_def hwf_congr h_accum h_agree_entry h_fresh_accum h_unique_accum + h_hf cfg h_cfg_accum h_cfg_nodup + have h_store_no_gens_upper_after : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_after (HasIdent.ident (P := P) x) = none := + store_no_gens_lift_after_flush h_preserve_flush genUpperBound h_store_no_gens_upper + (fun x hx => h_combined_no_gen_suffix x (List.mem_append_left _ hx)) + rcases h_body_term_or_exit with h_body_term | h_body_exit_star + · -- Body terminates with ρ_inner. + have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := + fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_combined_body : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_after x = none := + fun x hx => h_fresh_body_inits_after x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_body : + (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_body + have h_accum_nil : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation extendEval kNext body + ((some label, kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq + h_nofd_body h_simple_body h_unique_body + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_inner hwfb hwfv hwf_def hwf_congr hwf_var + h_body_term h_accum_nil h_agree_after + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_store_no_gens_upper_after + cfg h_cfg_bbs h_cfg_nodup + have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := + StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body + have h_eval_blk : ρ_blk.eval = ρ₀.eval := by + rw [h_ρ_blk_eq] + exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body ρ₀ ρ_inner h_nofd_body h_body_term + have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb + have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv + have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def + have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr + have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := + fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b + h_rest_no_gen_suffix h_fresh_rest_inits_after + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_cfg_body x = none := fun x hx => + h_fresh_rest_inits_body x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_rest + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_blk.eval ρ_blk.store + [].reverse ρ_blk.store false := EvalCmds.eval_cmds_none + have h_hasFail_blk : ρ_blk.hasFailure = ρ_inner.hasFailure := by + rw [h_ρ_blk_eq] + -- Lift `h_store_no_gens_upper` through the body sub-simulation + -- using the strengthened (4-premise) `h_preserve_body` directly. + have h_store_no_gens_upper_body : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_body (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_r gen_b genUpperBound + h_outer_upper_b h_preserve_body h_store_no_gens_upper_after + (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + ρ_blk.hasFailure false ρ_blk ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_star h_accum_nil_r h_agree_block_body + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_body + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ + · -- Transport h_step_body from ρ_inner.hasFailure to ρ_blk.hasFailure. + exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_body : x ∉ Block.initVars body := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ hx) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + have h_inner_guard_b := + inner_guard_step_b h_step_gen_to_r h_step_b_to_f h_gen_eq_f h_outer_guard + have h_inner_guard_r := + inner_guard_step_r h_step_b_to_f h_step_r_to_b h_gen_eq_f h_outer_guard + have h_σ_body_x : σ_cfg_body x = none := + h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b + exact h_preserve_rest x h_σ_body_x h_nil_not h_x_not_rest h_inner_guard_r + · -- Body exits with matching label; same as l = bl body-exit case. + have h_label_lookup : + ((some label, kNext) :: exitConts).lookup (some label) = some kNext := by + simp [List.lookup] + have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := + fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_combined_body : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_after x = none := + fun x hx => h_fresh_body_inits_after x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_body : + (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_body + have h_accum_nil : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation_to_cont extendEval kNext body + ((some label, kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq + h_nofd_body h_simple_body h_unique_body + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_inner label kNext h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var + h_body_exit_star h_accum_nil h_agree_after + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_store_no_gens_upper_after + cfg h_cfg_bbs h_cfg_nodup + have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := + StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body + have h_eval_blk : ρ_blk.eval = ρ₀.eval := by + rw [h_ρ_blk_eq] + exact smallStep_noFuncDecl_preserves_eval_block_exiting P (EvalCmd P) extendEval + body ρ₀ ρ_inner label h_nofd_body h_body_exit_star + have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb + have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv + have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def + have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr + have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := + fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b + h_rest_no_gen_suffix h_fresh_rest_inits_after + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_cfg_body x = none := fun x hx => + h_fresh_rest_inits_body x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_rest + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_blk.eval ρ_blk.store + [].reverse ρ_blk.store false := EvalCmds.eval_cmds_none + have h_hasFail_blk : ρ_blk.hasFailure = ρ_inner.hasFailure := by + rw [h_ρ_blk_eq] + -- Lift `h_store_no_gens_upper` through the body sub-simulation + -- using the strengthened (4-premise) `h_preserve_body` directly. + have h_store_no_gens_upper_body : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_body (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_r gen_b genUpperBound + h_outer_upper_b h_preserve_body h_store_no_gens_upper_after + (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + ρ_blk.hasFailure false ρ_blk ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_star h_accum_nil_r h_agree_block_body + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_body + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ + · -- Transport h_step_body from ρ_inner.hasFailure to ρ_blk.hasFailure. + exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_body : x ∉ Block.initVars body := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ hx) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + have h_inner_guard_b := + inner_guard_step_b h_step_gen_to_r h_step_b_to_f h_gen_eq_f h_outer_guard + have h_inner_guard_r := + inner_guard_step_r h_step_b_to_f h_step_r_to_b h_gen_eq_f h_outer_guard + have h_σ_body_x : σ_cfg_body x = none := + h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b + exact h_preserve_rest x h_σ_body_x h_nil_not h_x_not_rest h_inner_guard_r + | .exit label md :: rest => + -- Vacuous: structured semantics for .exit produces .exiting, never .terminal. + exfalso + cases h_term with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have ⟨ρ_mid, h_inner, _h_tail⟩ := + seq_reaches_terminal P (EvalCmd P) extendEval hrest1 + cases h_inner with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_exit => + -- After step_exit the config is .exiting label ρ₀, which cannot + -- step further to .terminal. + cases hrest2 with + | step _ _ _ h _ => cases h + | .funcDecl decl md :: rest => + -- Precluded by h_nofd : Block.noFuncDecl ss = true + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd + | .typeDecl tc md :: rest => + unfold stmtsToBlocks at h_gen + -- typeDecl is a no-op; structured semantics steps to terminal with unchanged env + have ⟨ρ₁, h_td_star, h_rest_star⟩ := + stmts_append_terminates P (EvalCmd P) extendEval [.typeDecl tc md] rest ρ₀ ρ' + (by simp at h_term ⊢; exact h_term) + have h_ρ₁ : ρ₁ = ρ₀ := by + cases h_td_star with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have ⟨ρ_mid, h_inner, h_nil⟩ := seq_reaches_terminal P (EvalCmd P) extendEval hrest1 + have h_eq := stmts_nil_terminal (EvalCmd P) extendEval _ _ h_nil + subst h_eq + cases h_inner with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_typeDecl => + cases hrest2 with + | refl => rfl + | step _ _ _ h _ => exact absurd h (by intro h; cases h) + rw [h_ρ₁] at h_rest_star + have h_nofd_rest : Block.noFuncDecl rest = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd + have h_simple_rest : Block.simpleShape rest = true := + (Block.simpleShape_cons_iff.mp h_simple).2 + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + have ⟨h_fresh_combined', h_unique_combined', + h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', + h_combined_no_gen_suffix_get'⟩ := + typeDecl_arm_combined_lemmas tc md accum rest σ_base + h_fresh_combined h_unique_combined + h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + h_combined_no_gen_suffix_get + have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := + stmtsToBlocks_simulation extendEval k rest exitConts accum gen gen' + entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest σ_struct_base σ_base hf_base hf_accum + ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var + h_rest_star h_accum h_agree_entry + h_fresh_combined' h_unique_combined' h_hf + h_wf_gen h_combined_no_gen_suffix' h_combined_no_gen_suffix_mod' + h_combined_no_gen_suffix_get' + genUpperBound h_outer_upper h_store_no_gens_upper + cfg h_cfg_blocks h_cfg_nodup + refine ⟨σ_cfg, h_step, h_agree, ?_⟩ + intro x h_σ_x h_x_not_accum h_x_not_inits + have h_x_not_rest : x ∉ Block.initVars rest := by + intro hx + apply h_x_not_inits + simp [Block.initVars, Stmt.initVars]; exact hx + exact h_preserve x h_σ_x h_x_not_accum h_x_not_rest +termination_by sizeOf ss +decreasing_by + all_goals (subst h_match; simp_wf; omega) + +/-- Sibling lemma to `stmtsToBlocks_simulation`: handles the case where the +structured execution `.exiting label` is caught by an entry in `exitConts`. +The CFG-side reaches the labeled continuation `bk_target` (the cont stored +in `exitConts`). + +Same accum/agreement/freshness preconditions as `stmtsToBlocks_simulation`. + +Used by `.block` simulation when the body exits with the block's matching +label: body's exitConts contains `(some label, kNext) :: outerExitConts`, +so the body's exit resolves to a goto to `kNext`. -/ +private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] + [LawfulHasIntOrder P] [LawfulHasNot P] + (extendEval : ExtendEval P) + (k : String) (ss : List (Stmt P (Cmd P))) + (exitConts : List (Option String × String)) + (accum : List (Cmd P)) + (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P) + (h_gen : (stmtsToBlocks k ss exitConts accum gen) = ((entry, blocks), gen')) + (h_nofd : Block.noFuncDecl ss = true) + (h_simple : Block.simpleShape ss = true) + (h_unique : Block.uniqueInits ss) + (σ_struct_base σ_base : SemanticStore P) + (hf_base : Bool) + (hf_accum : Bool) + (ρ₀ ρ' : Env P) + (label : String) + (bk_target : String) + (h_label : exitConts.lookup (some label) = some bk_target) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (h_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.exiting label ρ')) + (h_accum : EvalCmds P (EvalCmd P) ρ₀.eval σ_struct_base accum.reverse ρ₀.store hf_accum) + (h_agree_entry : StoreAgreement σ_struct_base σ_base) + (h_fresh_combined : + ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars ss, σ_base x = none) + (h_unique_combined : + (Cmds.definedVars accum.reverse ++ Block.initVars ss).Nodup) + (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) + (h_wf_gen : StringGenState.WF gen) + (h_combined_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ Block.initVars ss)) + (h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars ss)) + (h_combined_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ Block.getVars ss)) + (genUpperBound : StringGenState) + (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) + (h_store_no_gens_upper : ∀ x : String, + String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_base (HasIdent.ident (P := P) x) = none) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (h_cfg_blocks : ∀ b ∈ blocks, b ∈ cfg.blocks) + (h_cfg_nodup : (cfg.blocks.map Prod.fst).Nodup) : + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock entry σ_base hf_base) + (.atBlock bk_target σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg + ∧ (∀ x, σ_base x = none → + x ∉ Cmds.definedVars accum.reverse → x ∉ Block.initVars ss → + (∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen') → + σ_cfg x = none) := by + match h_match : ss with + | [] => + -- Empty stmt list cannot reach .exiting (only .terminal via stmts_nil_terminal-style) + exfalso + rcases h_exit with _ | ⟨_, _, _, hstep, hrest⟩ + cases hstep + cases hrest with + | step _ _ _ h _ => cases h + | .cmd c :: rest => + -- Same shape as _simulation: head executes, then recurse on rest with _to_cont. + unfold stmtsToBlocks at h_gen + -- Decompose `.cmd c :: rest` exit: cmd cannot exit, so it must terminate at ρ₁, + -- then rest exits. + have ⟨ρ₁, h_c_star, h_rest_exit⟩ : ∃ ρ₁, + StepStmtStar P (EvalCmd P) extendEval (.stmts [.cmd c] ρ₀) (.terminal ρ₁) ∧ + StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ₁) (.exiting label ρ') := by + cases h_exit with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have h_seq_inv := seq_reaches_exiting P (EvalCmd P) extendEval hrest1 + rcases h_seq_inv with h_inner_exit | h_term_exit + · -- Inner is `.stmt (.cmd c) ρ₀` which can only terminate; cannot exit. + exfalso + cases h_inner_exit with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_cmd _ => + cases hrest2 with + | step _ _ _ h _ => cases h + · obtain ⟨ρ_mid, h_inner_term, h_rest_exit⟩ := h_term_exit + -- ρ_mid = ρ₁; .stmt (.cmd c) ρ₀ → .terminal ρ_mid via step_cmd + -- Then .stmts rest ρ_mid → .exiting label ρ' + refine ⟨ρ_mid, ?_, h_rest_exit⟩ + -- .stmts [.cmd c] ρ₀ → .stmts [] ρ_mid (via stmts_cons_step) → .terminal ρ_mid (step_stmts_nil) + have h_stp : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.cmd c] ρ₀) (.stmts [] ρ_mid) := + stmts_cons_step P (EvalCmd P) extendEval (.cmd c) [] ρ₀ ρ_mid h_inner_term + exact ReflTrans_Transitive _ _ _ _ h_stp + (.step _ _ _ .step_stmts_nil (.refl _)) + have ⟨σ_c, failed_c, heval_c, hstore_c, heval_eq_c, hfail_c⟩ := + single_cmd_eval extendEval c ρ₀ ρ₁ h_c_star + have h_accum' : EvalCmds P (EvalCmd P) ρ₁.eval σ_struct_base + (c :: accum).reverse ρ₁.store (hf_accum || failed_c) := by + simp [List.reverse_cons] + rw [heval_eq_c, hstore_c] + exact EvalCmds_snoc ρ₀.eval σ_struct_base ρ₀.store σ_c accum.reverse c hf_accum failed_c + h_accum heval_c + have h_hf' : ρ₁.hasFailure = (hf_base || (hf_accum || failed_c)) := by + rw [hfail_c, h_hf, Bool.or_assoc] + have hwfb' : WellFormedSemanticEvalBool ρ₁.eval := by rw [heval_eq_c]; exact hwfb + have hwfv' : WellFormedSemanticEvalVal ρ₁.eval := by rw [heval_eq_c]; exact hwfv + have hwf_def' : WellFormedSemanticEvalDef ρ₁.eval := by rw [heval_eq_c]; exact hwf_def + have hwf_congr' : WellFormedSemanticEvalExprCongr ρ₁.eval := by + rw [heval_eq_c]; exact hwf_congr + have hwf_var' : WellFormedSemanticEvalVar ρ₁.eval := by rw [heval_eq_c]; exact hwf_var + have h_nofd_rest : Block.noFuncDecl rest = true := by + simp [Block.noFuncDecl] at h_nofd; exact h_nofd.2 + have h_simple_rest : Block.simpleShape rest = true := + (Block.simpleShape_cons_iff.mp h_simple).2 + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + -- Snoc/cons rebracketing facts shared between _simulation and _to_cont. + have ⟨h_definedVars_snoc, h_fresh_combined', h_unique_combined', + h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', + h_combined_no_gen_suffix_get'⟩ := + cmd_arm_combined_lemmas c accum rest σ_base + h_fresh_combined h_unique_combined + h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + h_combined_no_gen_suffix_get + have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := + stmtsToBlocks_simulation_to_cont extendEval k rest exitConts (c :: accum) gen gen' + entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest + σ_struct_base σ_base hf_base (hf_accum || failed_c) + ρ₁ ρ' label bk_target h_label hwfb' hwfv' hwf_def' hwf_congr' hwf_var' + h_rest_exit h_accum' + h_agree_entry h_fresh_combined' h_unique_combined' h_hf' + h_wf_gen h_combined_no_gen_suffix' h_combined_no_gen_suffix_mod' + h_combined_no_gen_suffix_get' + genUpperBound h_outer_upper h_store_no_gens_upper + cfg h_cfg_blocks h_cfg_nodup + refine ⟨σ_cfg, h_step, h_agree, ?_⟩ + intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_new_accum : x ∉ Cmds.definedVars (c :: accum).reverse := by + rw [List.reverse_cons, h_definedVars_snoc] + intro h_in + cases List.mem_append.mp h_in with + | inl h => exact h_x_not_accum h + | inr h => + cases c with + | init x' _ _ _ => + simp [Cmd.definedVars] at h + subst h + apply h_x_not_inits + simp [Block.initVars, Stmt.initVars] + | _ => simp [Cmd.definedVars] at h + have h_x_not_rest : x ∉ Block.initVars rest := by + intro h + apply h_x_not_inits + rw [Block.initVars] + cases c <;> simp [Stmt.initVars] <;> first | right; exact h | exact h + exact h_preserve x h_σ_x h_x_not_new_accum h_x_not_rest h_outer_guard + | .funcDecl _ _ :: _ => + -- Excluded by h_nofd + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd + | .typeDecl tc md :: rest => + unfold stmtsToBlocks at h_gen + -- typeDecl is a no-op in structured semantics; recurse on rest. + -- Decompose: typeDecl steps to .terminal ρ₀, then rest exits at ρ'. + have h_rest_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts rest ρ₀) (.exiting label ρ') := by + cases h_exit with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have h_seq_inv := seq_reaches_exiting P (EvalCmd P) extendEval hrest1 + rcases h_seq_inv with h_inner_exit | h_term_exit + · -- inner is .stmt (.typeDecl ..) ρ₀; cannot exit. + exfalso + cases h_inner_exit with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_typeDecl => + cases hrest2 with + | step _ _ _ h _ => cases h + · obtain ⟨ρ_mid, h_inner_term, h_rest_exit⟩ := h_term_exit + -- .stmt (.typeDecl ..) ρ₀ → .terminal ρ_mid via step_typeDecl, so ρ_mid = ρ₀. + cases h_inner_term with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_typeDecl => + cases hrest2 with + | refl => exact h_rest_exit + | step _ _ _ h _ => exact absurd h (by intro h; cases h) + have h_nofd_rest : Block.noFuncDecl rest = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd + have h_simple_rest : Block.simpleShape rest = true := + (Block.simpleShape_cons_iff.mp h_simple).2 + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + have ⟨h_fresh_combined', h_unique_combined', + h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', + h_combined_no_gen_suffix_get'⟩ := + typeDecl_arm_combined_lemmas tc md accum rest σ_base + h_fresh_combined h_unique_combined + h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + h_combined_no_gen_suffix_get + have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := + stmtsToBlocks_simulation_to_cont extendEval k rest exitConts accum gen gen' + entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest σ_struct_base σ_base hf_base hf_accum + ρ₀ ρ' label bk_target h_label hwfb hwfv hwf_def hwf_congr hwf_var + h_rest_exit h_accum h_agree_entry + h_fresh_combined' h_unique_combined' h_hf + h_wf_gen h_combined_no_gen_suffix' h_combined_no_gen_suffix_mod' + h_combined_no_gen_suffix_get' + genUpperBound h_outer_upper h_store_no_gens_upper + cfg h_cfg_blocks h_cfg_nodup + refine ⟨σ_cfg, h_step, h_agree, ?_⟩ + intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_rest : x ∉ Block.initVars rest := by + intro hx + apply h_x_not_inits + simp [Block.initVars, Stmt.initVars]; exact hx + exact h_preserve x h_σ_x h_x_not_accum h_x_not_rest h_outer_guard + | .exit l' md :: _ => + -- The structured side: `.exit l'` produces `.exiting l'`. For the trace + -- to reach `.exiting label`, we need `l' = label`. + -- Also: ρ' = ρ₀ (.exit doesn't modify the environment). + have h_combined : l' = label ∧ ρ' = ρ₀ := by + cases h_exit with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have h_seq_inv := seq_reaches_exiting P (EvalCmd P) extendEval hrest1 + rcases h_seq_inv with h_inner_exit | h_term + · cases h_inner_exit with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_exit => + cases hrest2 with + | refl => exact ⟨rfl, rfl⟩ + | step _ _ _ h _ => cases h + · obtain ⟨ρ_mid, h_inner_term, _⟩ := h_term + cases h_inner_term with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_exit => + cases hrest2 with + | step _ _ _ h _ => cases h + obtain ⟨h_l'_eq, h_ρ_eq⟩ := h_combined + -- We want to keep `label` as the canonical name; rewrite l' → label in h_gen. + rw [h_l'_eq] at h_gen + rw [h_ρ_eq] + -- stmtsToBlocks for .exit label: flushCmds with .some (.goto bk md), where + -- bk = lookup (.some label) exitConts = bk_target. + unfold stmtsToBlocks at h_gen + -- Simplify the lookup using h_label. + rw [h_label] at h_gen + simp only at h_gen + -- Now h_gen : flushCmds "block$..." accum (.some (.goto bk_target md)) bk_target gen + -- = ((entry, blocks), gen') + have h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none := by + intro x hx + apply h_fresh_combined + apply List.mem_append_left + exact hx + have h_unique_accum : (Cmds.definedVars accum.reverse).Nodup := + (List.nodup_append.mp h_unique_combined).1 + have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := + flushCmds_goto_simulation_agree extendEval (s!"block${label}$") accum md bk_target + gen gen' entry blocks h_gen σ_struct_base σ_base hf_base hf_accum ρ₀ + hwfb hwfv hwf_def hwf_congr h_accum h_agree_entry h_fresh_accum h_unique_accum h_hf + cfg h_cfg_blocks h_cfg_nodup + refine ⟨σ_cfg, h_step, h_agree, ?_⟩ + intro x h_σ_x h_x_not_accum _ _ + exact h_preserve x h_σ_x h_x_not_accum + | .block label' body md :: rest => + simp only [stmtsToBlocks, bind, StateT.bind, pure, StateT.pure] at h_gen + -- Decompose the monadic chain + generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen + obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest + simp at h_gen + generalize h_body_eq : stmtsToBlocks kNext body + ((some label', kNext) :: exitConts) [] gen_r = r_body at h_gen + obtain ⟨⟨bl, bbs⟩, gen_b⟩ := r_body + simp at h_gen + generalize h_flush_eq : @flushCmds P (Cmd P) _ "blk$" accum .none bl gen_b + = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + -- Decompose `.stmts (.block label' body md :: rest) ρ₀ → .exiting label ρ'`. + -- Two cases via seq_reaches_exiting on the inner-step: + -- (A) `.stmt (.block ..) ρ₀ → .exiting label ρ'` (block propagates exit; + -- requires label' ≠ label, body exits with `label`, rest does not run). + -- (B) `.stmt (.block ..) ρ₀ → .terminal ρ_blk` then + -- `.stmts rest ρ_blk → .exiting label ρ'`. Body either terminates + -- (B1) or exits matching `label'` (B2). + have h_decomp : + -- (A): body exits with `label`, label' ≠ label, ρ' is projected. + (label' ≠ label ∧ + ∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ₀) (.exiting label ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store }) ∨ + -- (B): block terminates then rest exits. + (∃ ρ_blk, ((∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ₀) (.terminal ρ_inner) ∧ + ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store }) ∨ + (∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ₀) (.exiting label' ρ_inner) ∧ + ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store })) ∧ + StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ_blk) (.exiting label ρ')) := by + cases h_exit with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have h_seq_inv := seq_reaches_exiting P (EvalCmd P) extendEval hrest1 + rcases h_seq_inv with h_inner_exit | h_term_exit + · -- inner = .stmt (.block ..) ρ₀ → .exiting label ρ' + cases h_inner_exit with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_block => + -- hrest2 : .block (.some label') ρ₀.store (.stmts body ρ₀) → .exiting label ρ' + have ⟨h_ne, ρ_inner, h_body_exit, h_eq⟩ := + block_some_reaches_exiting hrest2 + exact Or.inl ⟨h_ne, ρ_inner, h_body_exit, h_eq⟩ + · obtain ⟨ρ_blk, h_inner_term, h_rest_exit⟩ := h_term_exit + cases h_inner_term with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_block => + -- hrest2 : .block (.some label') ρ₀.store (.stmts body ρ₀) → .terminal ρ_blk + have h_blk_inv := block_some_reaches_terminal P (EvalCmd P) extendEval hrest2 + rcases h_blk_inv with h_term | h_match + · obtain ⟨ρ_i, h_body_term, heq⟩ := h_term + exact Or.inr ⟨ρ_blk, Or.inl ⟨ρ_i, h_body_term, heq⟩, h_rest_exit⟩ + · obtain ⟨ρ_i, h_body_match, heq⟩ := h_match + exact Or.inr ⟨ρ_blk, Or.inr ⟨ρ_i, h_body_match, heq⟩, h_rest_exit⟩ + -- noFuncDecl projections. + have h_nofd_body : Block.noFuncDecl body = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.1 + have h_nofd_rest : Block.noFuncDecl rest = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.2 + -- simpleShape projections. + have h_simple_head : Stmt.simpleShape (.block label' body md) = true := + (Block.simpleShape_cons_iff.mp h_simple).1 + have h_simple_rest : Block.simpleShape rest = true := + (Block.simpleShape_cons_iff.mp h_simple).2 + have h_simple_body : Block.simpleShape body = true := by + simp only [Stmt.simpleShape] at h_simple_head; exact h_simple_head + have h_unique_body : Block.uniqueInits body := + Block.uniqueInits.block_body h_unique + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + have h_initvars_eq : + Block.initVars (Stmt.block label' body md :: rest) = + Block.initVars body ++ Block.initVars rest := by + rw [Block.initVars] + simp [Stmt.initVars] + -- Sub-block and rest combined-no-gen-suffix discharges. + have h_body_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars body) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.definedVars] using hx))) s heq + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hx))) s heq + -- Mirror of h_initvars_eq / no_gen_suffix discharges for modifiedVars. + have h_modvars_eq : + transformBlockModVars (Stmt.block label' body md :: rest) = + transformBlockModVars body ++ transformBlockModVars rest := by + rw [transformBlockModVars_cons, transformStmtModVars_block] + have h_body_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := fun x hx s heq => + h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hx))) s heq + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun x hx s heq => + h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq + -- Mirror of h_initvars_eq / no_gen_suffix discharges for getVars. + have h_getvars_eq : + Block.getVars (Stmt.block label' body md :: rest) = + Block.getVars body ++ Block.getVars rest := by + show Stmt.getVars (Stmt.block label' body md) ++ Block.getVars rest = _ + rfl + have h_body_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars body) := fun x hx s heq => + h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.getVars] using hx))) s heq + have h_rest_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := fun x hx s heq => + h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq + -- GenStep chains for WF and subset (block case). + have h_step_b_to_f : StringGenState.GenStep gen_b gen_f := + flushCmds_genStep _ _ _ _ _ _ _ _ h_flush_eq + have h_step_r_to_b : StringGenState.GenStep gen_r gen_b := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_body_eq + have h_step_gen_to_r : StringGenState.GenStep gen gen_r := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_rest_eq + have h_step_gen_to_b : StringGenState.GenStep gen gen_b := + h_step_gen_to_r.trans h_step_r_to_b + have h_wf_r : StringGenState.WF gen_r := h_step_gen_to_r.wf_mono h_wf_gen + have h_wf_b : StringGenState.WF gen_b := h_step_gen_to_b.wf_mono h_wf_gen + -- Block membership distribution. Split on l = bl vs l ≠ bl. + by_cases h_l_eq_bl : label' = bl + · -- Case label' = bl: blocks = accumBlocks ++ bbs ++ bsNext, entry = accumEntry. + simp [h_l_eq_bl] at h_gen + have h_entry_eq : accumEntry = entry := + (Prod.mk.inj (Prod.mk.inj h_gen).1).1 + have h_blocks_eq : accumBlocks ++ (bbs ++ bsNext) = blocks := + (Prod.mk.inj (Prod.mk.inj h_gen).1).2 + have h_gen_eq_f : gen_f = gen' := (Prod.mk.inj h_gen).2 + subst h_entry_eq + subst h_blocks_eq + have h_outer_upper_b : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens genUpperBound := + h_step_b_to_f.subset.trans (h_gen_eq_f ▸ h_outer_upper) + have h_outer_upper_r : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens genUpperBound := + h_step_r_to_b.subset.trans h_outer_upper_b + have h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_left _ hb) + have h_cfg_bbs : ∀ b ∈ bbs, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ (List.mem_append_left _ hb)) + have h_cfg_rest : ∀ b ∈ bsNext, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ (List.mem_append_right _ hb)) + have h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none := by + intro x hx + exact h_fresh_combined x (List.mem_append_left _ hx) + have h_unique_accum : (Cmds.definedVars accum.reverse).Nodup := + (List.nodup_append.mp h_unique_combined).1 + have ⟨σ_cfg_after, h_step_flush, h_agree_after, h_preserve_flush⟩ := + flushCmds_simulation_agree extendEval "blk$" bl accum gen_b gen_f accumEntry + accumBlocks h_flush_eq σ_struct_base σ_base hf_base hf_accum ρ₀ + hwfb hwfv hwf_def hwf_congr h_accum h_agree_entry h_fresh_accum h_unique_accum + h_hf cfg h_cfg_accum h_cfg_nodup + have h_store_no_gens_upper_after : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_after (HasIdent.ident (P := P) x) = none := + store_no_gens_lift_after_flush h_preserve_flush genUpperBound h_store_no_gens_upper + (fun x hx => h_combined_no_gen_suffix x (List.mem_append_left _ hx)) + rcases h_decomp with h_caseA | h_caseB + · -- (A) Body exits with `label`, label' ≠ label. Use _to_cont on body. + obtain ⟨h_label_ne, ρ_inner, h_body_exit, h_ρ'_eq⟩ := h_caseA + -- Body's exitConts: ((some label', kNext) :: exitConts). + -- Lookup of (some label) yields exitConts.lookup (some label) = bk_target. + have h_label_lookup : + ((some label', kNext) :: exitConts).lookup (some label) = some bk_target := by + show (match label == label' with + | true => some kNext + | false => List.lookup (some label) exitConts) = some bk_target + have h_beq : (label == label') = false := by + rw [beq_eq_false_iff_ne]; intro h; exact h_label_ne h.symm + rw [h_beq]; exact h_label + -- Freshness for body recursion at σ_cfg_after. + have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := + fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_combined_body : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_after x = none := + fun x hx => h_fresh_body_inits_after x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_body : + (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_body + have h_accum_nil : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + -- Recurse on body with _to_cont (target = bk_target). + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation_to_cont extendEval kNext body + ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq + h_nofd_body h_simple_body h_unique_body + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_inner label bk_target h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var + h_body_exit h_accum_nil h_agree_after + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_store_no_gens_upper_after + cfg h_cfg_bbs h_cfg_nodup + -- Bridge structured-side projection to CFG. + have h_agree_ρ' : StoreAgreement ρ'.store σ_cfg_body := + StoreAgreement.through_projectStore h_ρ'_eq h_agree_body + refine ⟨σ_cfg_body, ?_, h_agree_ρ', ?_⟩ + · -- Compose: entry → bl (flush) → bk_target. Transport h_step_body from + -- ρ_inner.hasFailure to ρ'.hasFailure (equal since projectStore preserves hasFailure). + have h_hasFail_ρ' : ρ'.hasFailure = ρ_inner.hasFailure := by rw [h_ρ'_eq] + exact StepDetCFGStar_trans h_step_flush (h_hasFail_ρ'.symm ▸ h_step_body) + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_body : x ∉ Block.initVars body := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guard at (gen_r, gen_b) from outer guard at (gen, gen'). + have h_inner_guard_b := + inner_guard_step_b h_step_gen_to_r h_step_b_to_f h_gen_eq_f h_outer_guard + exact h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b + · -- (B) Block terminates with ρ_blk, then rest exits. + obtain ⟨ρ_blk, h_body_or_match, h_rest_exit⟩ := h_caseB + -- Freshness for body recursion at σ_cfg_after. + have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := + fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_combined_body : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_after x = none := + fun x hx => h_fresh_body_inits_after x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_body : + (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_body + have h_accum_nil : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have h_hf_body : ρ₀.hasFailure = (ρ₀.hasFailure || false) := by simp + have h_label_lookup : + ((some label', kNext) :: exitConts).lookup (some label') = some kNext := by + simp [List.lookup] + -- Run body to σ_cfg_body via either _simulation (terminate) or _to_cont (match exit). + -- Use a manual case-split to avoid binding ρ_inner with elaboration ambiguity. + rcases h_body_or_match with h_term | h_match_branch + · obtain ⟨ρ_inner, h_body_term, h_ρ_blk_eq⟩ := h_term + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation extendEval kNext body + ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq + h_nofd_body h_simple_body h_unique_body + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_inner hwfb hwfv hwf_def hwf_congr hwf_var + h_body_term h_accum_nil h_agree_after + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_store_no_gens_upper_after + cfg h_cfg_bbs h_cfg_nodup + have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := + StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body + have h_eval_blk : ρ_blk.eval = ρ₀.eval := by + rw [h_ρ_blk_eq] + exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body ρ₀ ρ_inner h_nofd_body h_body_term + have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb + have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv + have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def + have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr + have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := + fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b + h_rest_no_gen_suffix h_fresh_rest_inits_after + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_cfg_body x = none := fun x hx => + h_fresh_rest_inits_body x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_rest + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_blk.eval ρ_blk.store + [].reverse ρ_blk.store false := EvalCmds.eval_cmds_none + have h_hasFail_blk : ρ_blk.hasFailure = ρ_inner.hasFailure := by + rw [h_ρ_blk_eq] + -- Lift `h_store_no_gens_upper` through the body sub-simulation + -- using the strengthened (4-premise) `h_preserve_body` directly. + have h_store_no_gens_upper_body : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_body (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_r gen_b genUpperBound + h_outer_upper_b h_preserve_body h_store_no_gens_upper_after + (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + ρ_blk.hasFailure false ρ_blk ρ' label bk_target h_label + hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_exit h_accum_nil_r h_agree_block_body + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_body + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ + · -- Transport h_step_body from ρ_inner.hasFailure to ρ_blk.hasFailure. + exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_body : x ∉ Block.initVars body := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ hx) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + have h_inner_guard_b := + inner_guard_step_b h_step_gen_to_r h_step_b_to_f h_gen_eq_f h_outer_guard + have h_inner_guard_r := + inner_guard_step_r h_step_b_to_f h_step_r_to_b h_gen_eq_f h_outer_guard + have h_σ_body_x : σ_cfg_body x = none := + h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b + exact h_preserve_rest x h_σ_body_x h_nil_not h_x_not_rest h_inner_guard_r + · obtain ⟨ρ_inner, h_body_match, h_ρ_blk_eq⟩ := h_match_branch + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation_to_cont extendEval kNext body + ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq + h_nofd_body h_simple_body h_unique_body + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_inner label' kNext h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var + h_body_match h_accum_nil h_agree_after + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_store_no_gens_upper_after + cfg h_cfg_bbs h_cfg_nodup + have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := + StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body + have h_eval_blk : ρ_blk.eval = ρ₀.eval := by + rw [h_ρ_blk_eq] + exact smallStep_noFuncDecl_preserves_eval_block_exiting P (EvalCmd P) extendEval + body ρ₀ ρ_inner label' h_nofd_body h_body_match + have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb + have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv + have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def + have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr + have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := + fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b + h_rest_no_gen_suffix h_fresh_rest_inits_after + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_cfg_body x = none := fun x hx => + h_fresh_rest_inits_body x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_rest + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_blk.eval ρ_blk.store + [].reverse ρ_blk.store false := EvalCmds.eval_cmds_none + have h_hasFail_blk : ρ_blk.hasFailure = ρ_inner.hasFailure := by + rw [h_ρ_blk_eq] + -- Lift `h_store_no_gens_upper` through the body sub-simulation + -- using the strengthened (4-premise) `h_preserve_body` directly. + have h_store_no_gens_upper_body : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_body (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_r gen_b genUpperBound + h_outer_upper_b h_preserve_body h_store_no_gens_upper_after + (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + ρ_blk.hasFailure false ρ_blk ρ' label bk_target h_label + hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_exit h_accum_nil_r h_agree_block_body + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_body + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ + · -- Transport h_step_body from ρ_inner.hasFailure to ρ_blk.hasFailure. + exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_body : x ∉ Block.initVars body := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ hx) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + have h_inner_guard_b := + inner_guard_step_b h_step_gen_to_r h_step_b_to_f h_gen_eq_f h_outer_guard + have h_inner_guard_r := + inner_guard_step_r h_step_b_to_f h_step_r_to_b h_gen_eq_f h_outer_guard + have h_σ_body_x : σ_cfg_body x = none := + h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b + exact h_preserve_rest x h_σ_body_x h_nil_not h_x_not_rest h_inner_guard_r + · -- Case label' ≠ bl: blocks = accumBlocks ++ (label', lBlk) :: (bbs ++ bsNext), + -- entry = accumEntry. Same flow as label' = bl plus a vestigial (label', goto bl) block. + simp [h_l_eq_bl] at h_gen + have h_entry_eq : accumEntry = entry := + (Prod.mk.inj (Prod.mk.inj h_gen).1).1 + let lBlk : DetBlock String (Cmd P) P := + { cmds := [], transfer := DetTransferCmd.goto bl md } + have h_blocks_eq : + accumBlocks ++ (label', lBlk) :: (bbs ++ bsNext) = blocks := + (Prod.mk.inj (Prod.mk.inj h_gen).1).2 + have h_gen_eq_f : gen_f = gen' := (Prod.mk.inj h_gen).2 + subst h_entry_eq + have h_outer_upper_b : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens genUpperBound := + h_step_b_to_f.subset.trans (h_gen_eq_f ▸ h_outer_upper) + have h_outer_upper_r : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens genUpperBound := + h_step_r_to_b.subset.trans h_outer_upper_b + have h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks := by + intro b hb + exact h_cfg_blocks b (h_blocks_eq ▸ List.mem_append_left _ hb) + have h_cfg_bbs : ∀ b ∈ bbs, b ∈ cfg.blocks := by + intro b hb + exact h_cfg_blocks b + (h_blocks_eq ▸ List.mem_append_right _ (List.mem_cons_of_mem _ (List.mem_append_left _ hb))) + have h_cfg_rest : ∀ b ∈ bsNext, b ∈ cfg.blocks := by + intro b hb + exact h_cfg_blocks b + (h_blocks_eq ▸ List.mem_append_right _ (List.mem_cons_of_mem _ (List.mem_append_right _ hb))) + have h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none := by + intro x hx + exact h_fresh_combined x (List.mem_append_left _ hx) + have h_unique_accum : (Cmds.definedVars accum.reverse).Nodup := + (List.nodup_append.mp h_unique_combined).1 + have ⟨σ_cfg_after, h_step_flush, h_agree_after, h_preserve_flush⟩ := + flushCmds_simulation_agree extendEval "blk$" bl accum gen_b gen_f accumEntry + accumBlocks h_flush_eq σ_struct_base σ_base hf_base hf_accum ρ₀ + hwfb hwfv hwf_def hwf_congr h_accum h_agree_entry h_fresh_accum h_unique_accum + h_hf cfg h_cfg_accum h_cfg_nodup + have h_store_no_gens_upper_after : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_after (HasIdent.ident (P := P) x) = none := + store_no_gens_lift_after_flush h_preserve_flush genUpperBound h_store_no_gens_upper + (fun x hx => h_combined_no_gen_suffix x (List.mem_append_left _ hx)) + rcases h_decomp with h_caseA | h_caseB + · obtain ⟨h_label_ne, ρ_inner, h_body_exit, h_ρ'_eq⟩ := h_caseA + have h_label_lookup : + ((some label', kNext) :: exitConts).lookup (some label) = some bk_target := by + show (match label == label' with + | true => some kNext + | false => List.lookup (some label) exitConts) = some bk_target + have h_beq : (label == label') = false := by + rw [beq_eq_false_iff_ne]; intro h; exact h_label_ne h.symm + rw [h_beq]; exact h_label + have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := + fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_combined_body : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_after x = none := + fun x hx => h_fresh_body_inits_after x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_body : + (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_body + have h_accum_nil : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation_to_cont extendEval kNext body + ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq + h_nofd_body h_simple_body h_unique_body + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_inner label bk_target h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var + h_body_exit h_accum_nil h_agree_after + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_store_no_gens_upper_after + cfg h_cfg_bbs h_cfg_nodup + have h_agree_ρ' : StoreAgreement ρ'.store σ_cfg_body := + StoreAgreement.through_projectStore h_ρ'_eq h_agree_body + refine ⟨σ_cfg_body, ?_, h_agree_ρ', ?_⟩ + · -- Transport h_step_body from ρ_inner.hasFailure to ρ'.hasFailure. + have h_hasFail_ρ' : ρ'.hasFailure = ρ_inner.hasFailure := by rw [h_ρ'_eq] + exact StepDetCFGStar_trans h_step_flush (h_hasFail_ρ'.symm ▸ h_step_body) + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_body : x ∉ Block.initVars body := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guard at (gen_r, gen_b) from outer guard at (gen, gen'). + have h_inner_guard_b := + inner_guard_step_b h_step_gen_to_r h_step_b_to_f h_gen_eq_f h_outer_guard + exact h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b + · obtain ⟨ρ_blk, h_body_or_match, h_rest_exit⟩ := h_caseB + have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := + fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_combined_body : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_after x = none := + fun x hx => h_fresh_body_inits_after x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_body : + (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_body + have h_accum_nil : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have h_hf_body : ρ₀.hasFailure = (ρ₀.hasFailure || false) := by simp + have h_label_lookup : + ((some label', kNext) :: exitConts).lookup (some label') = some kNext := by + simp [List.lookup] + rcases h_body_or_match with h_term | h_match_branch + · obtain ⟨ρ_inner, h_body_term, h_ρ_blk_eq⟩ := h_term + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation extendEval kNext body + ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq + h_nofd_body h_simple_body h_unique_body + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_inner hwfb hwfv hwf_def hwf_congr hwf_var + h_body_term h_accum_nil h_agree_after + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_store_no_gens_upper_after + cfg h_cfg_bbs h_cfg_nodup + have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := + StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body + have h_eval_blk : ρ_blk.eval = ρ₀.eval := by + rw [h_ρ_blk_eq] + exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body ρ₀ ρ_inner h_nofd_body h_body_term + have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb + have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv + have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def + have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr + have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := + fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b + h_rest_no_gen_suffix h_fresh_rest_inits_after + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_cfg_body x = none := fun x hx => + h_fresh_rest_inits_body x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_rest + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_blk.eval ρ_blk.store + [].reverse ρ_blk.store false := EvalCmds.eval_cmds_none + have h_hasFail_blk : ρ_blk.hasFailure = ρ_inner.hasFailure := by + rw [h_ρ_blk_eq] + -- Lift `h_store_no_gens_upper` through the body sub-simulation + -- using the strengthened (4-premise) `h_preserve_body` directly. + have h_store_no_gens_upper_body : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_body (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_r gen_b genUpperBound + h_outer_upper_b h_preserve_body h_store_no_gens_upper_after + (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + ρ_blk.hasFailure false ρ_blk ρ' label bk_target h_label + hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_exit h_accum_nil_r h_agree_block_body + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_body + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ + · -- Transport h_step_body from ρ_inner.hasFailure to ρ_blk.hasFailure. + exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_body : x ∉ Block.initVars body := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ hx) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + have h_inner_guard_b := + inner_guard_step_b h_step_gen_to_r h_step_b_to_f h_gen_eq_f h_outer_guard + have h_inner_guard_r := + inner_guard_step_r h_step_b_to_f h_step_r_to_b h_gen_eq_f h_outer_guard + have h_σ_body_x : σ_cfg_body x = none := + h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b + exact h_preserve_rest x h_σ_body_x h_nil_not h_x_not_rest h_inner_guard_r + · obtain ⟨ρ_inner, h_body_match, h_ρ_blk_eq⟩ := h_match_branch + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation_to_cont extendEval kNext body + ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq + h_nofd_body h_simple_body h_unique_body + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_inner label' kNext h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var + h_body_match h_accum_nil h_agree_after + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_store_no_gens_upper_after + cfg h_cfg_bbs h_cfg_nodup + have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := + StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body + have h_eval_blk : ρ_blk.eval = ρ₀.eval := by + rw [h_ρ_blk_eq] + exact smallStep_noFuncDecl_preserves_eval_block_exiting P (EvalCmd P) extendEval + body ρ₀ ρ_inner label' h_nofd_body h_body_match + have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb + have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv + have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def + have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr + have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := + fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush + have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b + h_rest_no_gen_suffix h_fresh_rest_inits_after + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_cfg_body x = none := fun x hx => + h_fresh_rest_inits_body x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_rest + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_blk.eval ρ_blk.store + [].reverse ρ_blk.store false := EvalCmds.eval_cmds_none + have h_hasFail_blk : ρ_blk.hasFailure = ρ_inner.hasFailure := by + rw [h_ρ_blk_eq] + -- Lift `h_store_no_gens_upper` through the body sub-simulation + -- using the strengthened (4-premise) `h_preserve_body` directly. + have h_store_no_gens_upper_body : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_body (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_r gen_b genUpperBound + h_outer_upper_b h_preserve_body h_store_no_gens_upper_after + (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + ρ_blk.hasFailure false ρ_blk ρ' label bk_target h_label + hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_exit h_accum_nil_r h_agree_block_body + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_body + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ + · -- Transport h_step_body from ρ_inner.hasFailure to ρ_blk.hasFailure. + exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_body : x ∉ Block.initVars body := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ hx) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + have h_inner_guard_b := + inner_guard_step_b h_step_gen_to_r h_step_b_to_f h_gen_eq_f h_outer_guard + have h_inner_guard_r := + inner_guard_step_r h_step_b_to_f h_step_r_to_b h_gen_eq_f h_outer_guard + have h_σ_body_x : σ_cfg_body x = none := + h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b + exact h_preserve_rest x h_σ_body_x h_nil_not h_x_not_rest h_inner_guard_r + | .ite (.det e) thenBranch elseBranch md :: rest => + unfold stmtsToBlocks at h_gen + simp [bind, StateT.bind, pure, StateT.pure, List.append_nil] at h_gen + -- Decompose the monadic h_gen + generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen + obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest + simp at h_gen + generalize h_ite_label : StringGenState.gen "ite" gen_r = r_ite at h_gen + obtain ⟨l_ite, gen_ite⟩ := r_ite + simp at h_gen + generalize h_then_eq : stmtsToBlocks kNext thenBranch exitConts [] gen_ite = r_then at h_gen + obtain ⟨⟨tl, tbs⟩, gen_t⟩ := r_then + simp at h_gen + generalize h_else_eq : stmtsToBlocks kNext elseBranch exitConts [] gen_t = r_else at h_gen + obtain ⟨⟨fl, fbs⟩, gen_e⟩ := r_else + simp at h_gen + generalize h_flush_eq : flushCmds "ite$" accum + (some (DetTransferCmd.condGoto e tl fl md)) l_ite gen_e = r_flush at h_gen + obtain ⟨⟨accumEntry, accumBlocks⟩, gen_f⟩ := r_flush + have h_entry : accumEntry = entry := (Prod.mk.inj (Prod.mk.inj h_gen).1).1 + have h_blocks : accumBlocks ++ (tbs ++ (fbs ++ bsNext)) = blocks := + (Prod.mk.inj (Prod.mk.inj h_gen).1).2 + subst h_entry + -- Decompose the structured execution of (.ite ... :: rest) reaching .exiting label. + -- Two outer cases via seq_reaches_exiting: + -- (caseA) inner `.stmt (.ite ..) ρ₀` already exits with `label`; rest doesn't run. + -- (caseB) inner terminates at ρ_mid, then rest exits. + have h_decomp : + -- caseA: branch itself exits with `label`. Either thenBranch (cond=tt) or elseBranch (cond=ff). + ((StepStmtStar P (EvalCmd P) extendEval + (.stmts thenBranch ρ₀) (.exiting label ρ') ∧ + ρ₀.eval ρ₀.store e = .some HasBool.tt) ∨ + (StepStmtStar P (EvalCmd P) extendEval + (.stmts elseBranch ρ₀) (.exiting label ρ') ∧ + ρ₀.eval ρ₀.store e = .some HasBool.ff)) ∨ + -- caseB: branch terminates at ρ_mid, rest exits with `label`. + (∃ ρ_mid, + ((StepStmtStar P (EvalCmd P) extendEval + (.stmts thenBranch ρ₀) (.terminal ρ_mid) ∧ + ρ₀.eval ρ₀.store e = .some HasBool.tt) ∨ + (StepStmtStar P (EvalCmd P) extendEval + (.stmts elseBranch ρ₀) (.terminal ρ_mid) ∧ + ρ₀.eval ρ₀.store e = .some HasBool.ff)) ∧ + StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ_mid) (.exiting label ρ')) := by + cases h_exit with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have h_seq_inv := seq_reaches_exiting P (EvalCmd P) extendEval hrest1 + rcases h_seq_inv with h_inner_exit | h_term_exit + · -- inner = .stmt (.ite ..) ρ₀ → .exiting label ρ' + cases h_inner_exit with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_ite_true h_eval_tt _ => + exact Or.inl (Or.inl ⟨hrest2, h_eval_tt⟩) + | step_ite_false h_eval_ff _ => + exact Or.inl (Or.inr ⟨hrest2, h_eval_ff⟩) + · obtain ⟨ρ_mid_outer, h_inner_term, h_rest_exit⟩ := h_term_exit + -- inner = .stmt (.ite ..) ρ₀ → .terminal ρ_mid_outer + cases h_inner_term with + | step _ _ _ hstep2 hrest2 => + cases hstep2 with + | step_ite_true h_eval_tt _ => + exact Or.inr ⟨ρ_mid_outer, Or.inl ⟨hrest2, h_eval_tt⟩, h_rest_exit⟩ + | step_ite_false h_eval_ff _ => + exact Or.inr ⟨ρ_mid_outer, Or.inr ⟨hrest2, h_eval_ff⟩, h_rest_exit⟩ + -- Block membership: distribute h_cfg_blocks over concatenated blocks. + subst h_blocks + have h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_left _ hb) + have h_cfg_tbs : ∀ b ∈ tbs, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ + (List.mem_append_left _ hb)) + have h_cfg_fbs : ∀ b ∈ fbs, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ + (List.mem_append_right _ (List.mem_append_left _ hb))) + have h_cfg_rest : ∀ b ∈ bsNext, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ + (List.mem_append_right _ (List.mem_append_right _ hb))) + -- noFuncDecl projections. + have h_nofd_then : Block.noFuncDecl thenBranch = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.1.1 + have h_nofd_else : Block.noFuncDecl elseBranch = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.1.2 + have h_nofd_rest : Block.noFuncDecl rest = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.2 + -- simpleShape projections. + have h_simple_head : Stmt.simpleShape (.ite (.det e) thenBranch elseBranch md) = true := + (Block.simpleShape_cons_iff.mp h_simple).1 + have h_simple_rest : Block.simpleShape rest = true := + (Block.simpleShape_cons_iff.mp h_simple).2 + have h_simple_then : Block.simpleShape thenBranch = true := + Stmt.simpleShape_branch_then h_simple_head + have h_simple_else : Block.simpleShape elseBranch = true := + Stmt.simpleShape_branch_else h_simple_head + have h_unique_then : Block.uniqueInits thenBranch := + Block.uniqueInits.ite_then h_unique + have h_unique_else : Block.uniqueInits elseBranch := + Block.uniqueInits.ite_else h_unique + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + -- Lift accum to the CFG side via EvalCmds_under_agreement. + have h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none := by + intro x hx + exact h_fresh_combined x (List.mem_append_left _ hx) + have h_unique_accum : (Cmds.definedVars accum.reverse).Nodup := + (List.nodup_append.mp h_unique_combined).1 + have ⟨σ_cfg_after, h_accum_cfg, h_agree_after⟩ := + EvalCmds_under_agreement ρ₀.eval accum.reverse hwf_def hwf_congr + σ_struct_base σ_base ρ₀.store hf_accum h_agree_entry h_accum h_fresh_accum + h_unique_accum + -- Freshness preservation through the lifted accum. + have h_preserve_after : + ∀ x, σ_base x = none → x ∉ Cmds.definedVars accum.reverse → + σ_cfg_after x = none := by + intro x h_σ h_x_not + exact agreement_helper_unchanged_at_x_multi h_accum_cfg h_x_not h_σ + -- Block.initVars decomposition. + have h_initvars_eq : + Block.initVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md :: rest) = + (Block.initVars thenBranch ++ Block.initVars elseBranch) ++ Block.initVars rest := by + rw [Block.initVars] + simp [Stmt.initVars] + have h_unique_outer_inits : + (Cmds.definedVars accum.reverse ++ + ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ Block.initVars rest)).Nodup := by + rw [← h_initvars_eq]; exact h_unique_combined + -- Freshness for sub-branch and rest recursions. + have h_fresh_then_inits : ∀ x ∈ Block.initVars thenBranch, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun hx_acc => + (List.nodup_append.mp h_unique_outer_inits).2.2 x hx_acc x + (List.mem_append_left _ (List.mem_append_left _ hx)) rfl + have h_σ_x : σ_base x = none := + h_fresh_combined x (List.mem_append_right _ + (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_left _ hx))) + exact h_preserve_after x h_σ_x h_x_not_accum + have h_fresh_else_inits : ∀ x ∈ Block.initVars elseBranch, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun hx_acc => + (List.nodup_append.mp h_unique_outer_inits).2.2 x hx_acc x + (List.mem_append_left _ (List.mem_append_right _ hx)) rfl + have h_σ_x : σ_base x = none := + h_fresh_combined x (List.mem_append_right _ + (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_right _ hx))) + exact h_preserve_after x h_σ_x h_x_not_accum + have h_fresh_rest_inits_after : + ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun hx_acc => + (List.nodup_append.mp h_unique_outer_inits).2.2 x hx_acc x + (List.mem_append_right _ hx) rfl + have h_σ_x : σ_base x = none := + h_fresh_combined x (List.mem_append_right _ + (h_initvars_eq ▸ List.mem_append_right _ hx)) + exact h_preserve_after x h_σ_x h_x_not_accum + have h_combined_then : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars thenBranch, + σ_cfg_after x = none := + fun x hx => h_fresh_then_inits x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_then : + (Cmds.definedVars [].reverse ++ Block.initVars thenBranch).Nodup := + unique_combined_ite_then h_unique_outer_inits + have h_combined_else : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars elseBranch, + σ_cfg_after x = none := + fun x hx => h_fresh_else_inits x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_else : + (Cmds.definedVars [].reverse ++ Block.initVars elseBranch).Nodup := + unique_combined_ite_else h_unique_outer_inits + have h_lookup : ∀ lbl blk, (lbl, blk) ∈ cfg.blocks → + cfg.blocks.lookup lbl = some blk := + fun lbl blk h_mem => List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup lbl blk h_mem + -- GenStep chains for WF and subset. + have h_gen_eq_f : gen_f = gen' := (Prod.mk.inj h_gen).2 + have h_step_e_to_f : StringGenState.GenStep gen_e gen_f := + flushCmds_genStep _ _ _ _ _ _ _ _ h_flush_eq + have h_step_t_to_e : StringGenState.GenStep gen_t gen_e := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_else_eq + have h_step_ite_to_t : StringGenState.GenStep gen_ite gen_t := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_then_eq + have h_step_r_to_ite : StringGenState.GenStep gen_r gen_ite := by + have h_eq : (StringGenState.gen "ite" gen_r).2 = gen_ite := congrArg Prod.snd h_ite_label + exact h_eq ▸ StringGenState.GenStep.of_gen "ite" gen_r + have h_step_gen_to_r : StringGenState.GenStep gen gen_r := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_rest_eq + have h_step_gen_to_ite : StringGenState.GenStep gen gen_ite := + h_step_gen_to_r.trans h_step_r_to_ite + have h_step_gen_to_t : StringGenState.GenStep gen gen_t := + h_step_gen_to_ite.trans h_step_ite_to_t + have h_step_gen_to_e : StringGenState.GenStep gen gen_e := + h_step_gen_to_t.trans h_step_t_to_e + have h_wf_t : StringGenState.WF gen_t := h_step_gen_to_t.wf_mono h_wf_gen + have h_wf_e : StringGenState.WF gen_e := h_step_gen_to_e.wf_mono h_wf_gen + have h_wf_r : StringGenState.WF gen_r := h_step_gen_to_r.wf_mono h_wf_gen + have h_wf_ite : StringGenState.WF gen_ite := h_step_gen_to_ite.wf_mono h_wf_gen + -- Lift store-no-gens to σ_cfg_after at the lemma's local `gen` precondition. + have h_store_no_gens_upper_after : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_after (HasIdent.ident (P := P) x) = none := + store_no_gens_lift_after_accum h_accum_cfg genUpperBound h_store_no_gens_upper + (fun x hx => h_combined_no_gen_suffix x (List.mem_append_left _ hx)) + -- Subset chains lifting outer upper-bound to inner gen' subsets. + have h_outer_upper_e : StringGenState.stringGens gen_e ⊆ StringGenState.stringGens genUpperBound := + h_step_e_to_f.subset.trans (h_gen_eq_f ▸ h_outer_upper) + have h_outer_upper_t : StringGenState.stringGens gen_t ⊆ StringGenState.stringGens genUpperBound := + h_step_t_to_e.subset.trans h_outer_upper_e + have h_outer_upper_r : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens genUpperBound := + h_step_r_to_ite.subset.trans (h_step_ite_to_t.subset.trans h_outer_upper_t) + -- Sub-branch and rest combined-no-gen-suffix discharges. + have h_then_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars thenBranch) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.definedVars] using hx)))) s heq + have h_else_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars elseBranch) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.definedVars] using hx)))) s heq + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hx))) s heq + -- Mirror of h_initvars_eq / no_gen_suffix discharges for modifiedVars. + have h_modvars_eq : + transformBlockModVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md :: rest) = + (transformBlockModVars thenBranch ++ transformBlockModVars elseBranch) ++ transformBlockModVars rest := by + rw [transformBlockModVars_cons, transformStmtModVars_ite] + have h_then_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars thenBranch) := fun x hx s heq => + h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hx)))) s heq + have h_else_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars elseBranch) := fun x hx s heq => + h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx)))) s heq + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun x hx s heq => + h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq + -- Mirror of h_initvars_eq / no_gen_suffix discharges for getVars. + have h_getvars_eq : + Block.getVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md :: rest) = + (HasVarsPure.getVars e ++ Block.getVars thenBranch ++ Block.getVars elseBranch) ++ + Block.getVars rest := by + show Stmt.getVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md) ++ + Block.getVars rest = _ + rfl + have h_then_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars thenBranch) := fun x hx s heq => + h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (List.mem_append_right _ + (by simpa [Cmds.getVars] using hx))))) s heq + have h_else_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars elseBranch) := fun x hx s heq => + h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.getVars] using hx)))) s heq + have h_rest_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := fun x hx s heq => + h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq + rcases h_decomp with h_caseA | h_caseB + · -- Branch itself exits with `label`; rest does not run. + rcases h_caseA with h_true | h_false + · obtain ⟨h_then_exit, h_cond_tt⟩ := h_true + have h_flush_sim : StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock tl σ_cfg_after ρ₀.hasFailure) := + flushCmds_condGoto_true_agree extendEval accum e tl fl md l_ite gen_e gen_f + accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ + hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_tt cfg + h_cfg_accum h_lookup + -- Recurse on thenBranch with _to_cont (target = bk_target). + have h_accum_nil_t : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨σ_cfg_branch, h_then_step, h_agree_branch, h_preserve_branch⟩ := + stmtsToBlocks_simulation_to_cont extendEval kNext thenBranch exitConts [] + gen_ite gen_t tl tbs h_then_eq h_nofd_then h_simple_then h_unique_then + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ' label bk_target h_label hwfb hwfv hwf_def hwf_congr hwf_var + h_then_exit h_accum_nil_t h_agree_after + h_combined_then h_unique_combined_then (by simp) + h_wf_ite h_then_no_gen_suffix h_then_no_gen_suffix_mod + h_then_no_gen_suffix_get + genUpperBound h_outer_upper_t h_store_no_gens_upper_after + cfg h_cfg_tbs h_cfg_nodup + refine ⟨σ_cfg_branch, ?_, h_agree_branch, ?_⟩ + · exact StepDetCFGStar_trans h_flush_sim h_then_step + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_then : x ∉ Block.initVars thenBranch := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_left _ hx)) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_after x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guard at (gen_ite, gen_t) from outer guard at (gen, gen'). + have h_inner_guard_t : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_ite ∨ + s ∉ StringGenState.stringGens gen_t := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl (h_step_gen_to_ite.subset h_in) + | Or.inr h_not_in => Or.inr (fun h_in_t => h_not_in + (h_gen_eq_f ▸ h_step_e_to_f.subset (h_step_t_to_e.subset h_in_t))) + exact h_preserve_branch x h_σ_after_x h_nil_not h_x_not_then h_inner_guard_t + · obtain ⟨h_else_exit, h_cond_ff⟩ := h_false + have h_flush_sim : StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock fl σ_cfg_after ρ₀.hasFailure) := + flushCmds_condGoto_false_agree extendEval accum e tl fl md l_ite gen_e gen_f + accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ + hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_ff cfg + h_cfg_accum h_lookup + have h_accum_nil_f : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨σ_cfg_branch, h_else_step, h_agree_branch, h_preserve_branch⟩ := + stmtsToBlocks_simulation_to_cont extendEval kNext elseBranch exitConts [] + gen_t gen_e fl fbs h_else_eq h_nofd_else h_simple_else h_unique_else + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ' label bk_target h_label hwfb hwfv hwf_def hwf_congr hwf_var + h_else_exit h_accum_nil_f h_agree_after + h_combined_else h_unique_combined_else (by simp) + h_wf_t h_else_no_gen_suffix h_else_no_gen_suffix_mod + h_else_no_gen_suffix_get + genUpperBound h_outer_upper_e h_store_no_gens_upper_after + cfg h_cfg_fbs h_cfg_nodup + refine ⟨σ_cfg_branch, ?_, h_agree_branch, ?_⟩ + · exact StepDetCFGStar_trans h_flush_sim h_else_step + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_else : x ∉ Block.initVars elseBranch := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_right _ hx)) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_after x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guard at (gen_t, gen_e) from outer guard at (gen, gen'). + have h_inner_guard_e : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_t ∨ + s ∉ StringGenState.stringGens gen_e := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl (h_step_gen_to_t.subset h_in) + | Or.inr h_not_in => Or.inr (fun h_in_e => h_not_in + (h_gen_eq_f ▸ h_step_e_to_f.subset h_in_e)) + exact h_preserve_branch x h_σ_after_x h_nil_not h_x_not_else h_inner_guard_e + · -- Branch terminates at ρ_mid, then rest exits with `label`. + obtain ⟨ρ_mid, h_branch_term_or, h_rest_exit⟩ := h_caseB + -- Eval well-formedness preservation through the branch (terminal). + have hwfb₁ : WellFormedSemanticEvalBool ρ_mid.eval := by + exact h_branch_term_or.elim + (fun h => StepStmtStar_wfb_preserved extendEval thenBranch ρ₀ ρ_mid h.1 h_nofd_then hwfb) + (fun h => StepStmtStar_wfb_preserved extendEval elseBranch ρ₀ ρ_mid h.1 h_nofd_else hwfb) + have hwfv₁ : WellFormedSemanticEvalVal ρ_mid.eval := by + exact h_branch_term_or.elim + (fun h => StepStmtStar_wfv_preserved extendEval thenBranch ρ₀ ρ_mid h.1 h_nofd_then hwfv) + (fun h => StepStmtStar_wfv_preserved extendEval elseBranch ρ₀ ρ_mid h.1 h_nofd_else hwfv) + have h_eval_eq : ρ_mid.eval = ρ₀.eval := by + rcases h_branch_term_or with h | h + · exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + thenBranch ρ₀ ρ_mid h_nofd_then h.1 + · exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + elseBranch ρ₀ ρ_mid h_nofd_else h.1 + have hwf_def₁ : WellFormedSemanticEvalDef ρ_mid.eval := by + rw [h_eval_eq]; exact hwf_def + have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_mid.eval := by + rw [h_eval_eq]; exact hwf_congr + have hwf_var₁ : WellFormedSemanticEvalVar ρ_mid.eval := by + rw [h_eval_eq]; exact hwf_var + rcases h_branch_term_or with h_true | h_false + · obtain ⟨h_then_term, h_cond_tt⟩ := h_true + have h_flush_sim : StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock tl σ_cfg_after ρ₀.hasFailure) := + flushCmds_condGoto_true_agree extendEval accum e tl fl md l_ite gen_e gen_f + accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ + hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_tt cfg + h_cfg_accum h_lookup + have h_accum_nil_t : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨σ_branch, h_then_step, h_agree_then, h_preserve_then⟩ := + stmtsToBlocks_simulation extendEval kNext thenBranch exitConts [] + gen_ite gen_t tl tbs h_then_eq h_nofd_then h_simple_then h_unique_then + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_mid hwfb hwfv hwf_def hwf_congr hwf_var + h_then_term h_accum_nil_t h_agree_after + h_combined_then h_unique_combined_then (by simp) + h_wf_ite h_then_no_gen_suffix h_then_no_gen_suffix_mod + h_then_no_gen_suffix_get + genUpperBound h_outer_upper_t h_store_no_gens_upper_after + cfg h_cfg_tbs h_cfg_nodup + -- Freshness of rest's inits at σ_branch. + have h_fresh_rest_inits_branch : + ∀ x ∈ Block.initVars rest, σ_branch x = none := by + intro x hx + have h_x_not_then : x ∉ Block.initVars thenBranch := by + intro h_in_then + have h1 : ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ + Block.initVars rest).Nodup := + (List.nodup_append.mp h_unique_outer_inits).2.1 + have h_disj_lr := (List.nodup_append.mp h1).2.2 + have h_in_then_else : x ∈ Block.initVars thenBranch ++ Block.initVars elseBranch := + List.mem_append_left _ h_in_then + exact h_disj_lr x h_in_then_else x hx rfl + have h_σ_after_x : σ_cfg_after x = none := h_fresh_rest_inits_after x hx + have : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + exact h_preserve_then x h_σ_after_x this h_x_not_then + (fun s heq => Or.inr + (StringGenState.not_mem_stringGens_of_not_hasUnderscoreDigitSuffix h_wf_t + (h_rest_no_gen_suffix x (by simp [Cmds.definedVars]; exact hx) s heq))) + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_branch x = none := fun x hx => + h_fresh_rest_inits_branch x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := + unique_combined_ite_rest h_unique_outer_inits + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_mid.eval ρ_mid.store + [].reverse ρ_mid.store false := EvalCmds.eval_cmds_none + -- Lift `h_store_no_gens_upper` through the thenBranch sub-simulation + -- using the strengthened (4-premise) `h_preserve_then` directly. + have h_store_no_gens_upper_branch_t : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_branch (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_ite gen_t genUpperBound + h_outer_upper_t h_preserve_then h_store_no_gens_upper_after + (fun x hx s heq => h_then_no_gen_suffix x (List.mem_append_right _ hx) s heq) + have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_mid.store σ_branch ρ_mid.hasFailure false + ρ_mid ρ' label bk_target h_label + hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_exit h_accum_nil_r h_agree_then + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_t + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ + · exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_flush_sim h_then_step) h_rest_sim + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_then : x ∉ Block.initVars thenBranch := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_left _ hx)) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_after x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + have h_inner_guard_t : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_ite ∨ + s ∉ StringGenState.stringGens gen_t := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl (h_step_gen_to_ite.subset h_in) + | Or.inr h_not_in => Or.inr (fun h_in_t => h_not_in + (h_gen_eq_f ▸ h_step_e_to_f.subset (h_step_t_to_e.subset h_in_t))) + have h_inner_guard_r : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen_r := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl h_in + | Or.inr h_not_in => Or.inr (fun h_in_r => h_not_in + (h_gen_eq_f ▸ h_step_e_to_f.subset (h_step_t_to_e.subset + (h_step_ite_to_t.subset (h_step_r_to_ite.subset h_in_r))))) + have h_σ_branch_x : σ_branch x = none := + h_preserve_then x h_σ_after_x h_nil_not h_x_not_then h_inner_guard_t + exact h_preserve_rest x h_σ_branch_x h_nil_not h_x_not_rest h_inner_guard_r + · obtain ⟨h_else_term, h_cond_ff⟩ := h_false + have h_flush_sim : StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock fl σ_cfg_after ρ₀.hasFailure) := + flushCmds_condGoto_false_agree extendEval accum e tl fl md l_ite gen_e gen_f + accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ + hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_ff cfg + h_cfg_accum h_lookup + have h_accum_nil_f : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨σ_branch, h_else_step, h_agree_else, h_preserve_else⟩ := + stmtsToBlocks_simulation extendEval kNext elseBranch exitConts [] + gen_t gen_e fl fbs h_else_eq h_nofd_else h_simple_else h_unique_else + ρ₀.store σ_cfg_after ρ₀.hasFailure false + ρ₀ ρ_mid hwfb hwfv hwf_def hwf_congr hwf_var + h_else_term h_accum_nil_f h_agree_after + h_combined_else h_unique_combined_else (by simp) + h_wf_t h_else_no_gen_suffix h_else_no_gen_suffix_mod + h_else_no_gen_suffix_get + genUpperBound h_outer_upper_e h_store_no_gens_upper_after + cfg h_cfg_fbs h_cfg_nodup + have h_fresh_rest_inits_branch : + ∀ x ∈ Block.initVars rest, σ_branch x = none := by + intro x hx + have h_x_not_else : x ∉ Block.initVars elseBranch := by + intro h_in_else + have h1 : ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ + Block.initVars rest).Nodup := + (List.nodup_append.mp h_unique_outer_inits).2.1 + have h_disj_lr := (List.nodup_append.mp h1).2.2 + have h_in_then_else : x ∈ Block.initVars thenBranch ++ Block.initVars elseBranch := + List.mem_append_right _ h_in_else + exact h_disj_lr x h_in_then_else x hx rfl + have h_σ_after_x : σ_cfg_after x = none := h_fresh_rest_inits_after x hx + have : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + exact h_preserve_else x h_σ_after_x this h_x_not_else + (fun s heq => Or.inr + (StringGenState.not_mem_stringGens_of_not_hasUnderscoreDigitSuffix h_wf_e + (h_rest_no_gen_suffix x (by simp [Cmds.definedVars]; exact hx) s heq))) + have h_combined_rest : + ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_branch x = none := fun x hx => + h_fresh_rest_inits_branch x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := + unique_combined_ite_rest h_unique_outer_inits + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_mid.eval ρ_mid.store + [].reverse ρ_mid.store false := EvalCmds.eval_cmds_none + -- Lift `h_store_no_gens_upper` through the elseBranch sub-simulation + -- using the strengthened (4-premise) `h_preserve_else` directly. + have h_store_no_gens_upper_branch_e : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_branch (HasIdent.ident (P := P) x) = none := + store_no_gens_upper_lift_through_subsim gen_t gen_e genUpperBound + h_outer_upper_e h_preserve_else h_store_no_gens_upper_after + (fun x hx s heq => h_else_no_gen_suffix x (List.mem_append_right _ hx) s heq) + have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_mid.store σ_branch ρ_mid.hasFailure false + ρ_mid ρ' label bk_target h_label + hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_exit h_accum_nil_r h_agree_else + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_e + cfg h_cfg_rest h_cfg_nodup + refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ + · exact StepDetCFGStar_trans + (StepDetCFGStar_trans h_flush_sim h_else_step) h_rest_sim + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_else : x ∉ Block.initVars elseBranch := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_right _ hx)) + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ List.mem_append_right _ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_after x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- Build inner guards from outer guard via GenStep monotonicity. + have h_inner_guard_e : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_t ∨ + s ∉ StringGenState.stringGens gen_e := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl (h_step_gen_to_t.subset h_in) + | Or.inr h_not_in => Or.inr (fun h_in_e => h_not_in + (h_gen_eq_f ▸ h_step_e_to_f.subset h_in_e)) + have h_inner_guard_r : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen_r := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl h_in + | Or.inr h_not_in => Or.inr (fun h_in_r => h_not_in + (h_gen_eq_f ▸ h_step_e_to_f.subset (h_step_t_to_e.subset + (h_step_ite_to_t.subset (h_step_r_to_ite.subset h_in_r))))) + have h_σ_branch_x : σ_branch x = none := + h_preserve_else x h_σ_after_x h_nil_not h_x_not_else h_inner_guard_e + exact h_preserve_rest x h_σ_branch_x h_nil_not h_x_not_rest h_inner_guard_r + | .ite .nondet _ _ _ :: _ => + exact absurd (Block.simpleShape_cons_iff.mp h_simple).1 (by simp [Stmt.simpleShape]) + | .loop _ _ _ _ _ :: _ => + exact absurd (Block.simpleShape_cons_iff.mp h_simple).1 (by simp [Stmt.simpleShape]) +termination_by sizeOf ss +decreasing_by + all_goals (subst h_match; simp_wf; omega) +end + +/-- Variant of `stmtsToBlocks_simulation` for when the structured execution +"exits". Under the `exitsCoveredByBlocks` invariant such an execution is +impossible, so the conclusion holds vacuously. -/ +private theorem stmtsToBlocks_simulation_exiting {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVal P] [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) + (entry : String) + (σ_base : SemanticStore P) + (hf_base : Bool) + (ρ₀ ρ' : Env P) (lbl : String) + (h_exits : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks [] ss) + (h_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.exiting lbl ρ')) + (cfg : CFG String (DetBlock String (Cmd P) P)) : + ∃ σ_final failed, StepDetCFGStar extendEval cfg + (.atBlock entry σ_base hf_base) + (.terminal σ_final failed) ∧ σ_final = ρ'.store := + absurd h_exit + (block_exitsCoveredByBlocks_noEscape (P := P) (EvalCmd P) extendEval ss h_exits ρ₀ lbl ρ') + +/-! ## Top-level theorems -/ + +/-- Specification lemma: `stmtsToCFG` produces a CFG whose blocks come from +`stmtsToBlocks` plus a terminal block, and whose entry matches. +Specialized to `CmdT = Cmd P` so we can use `stmtsToBlocks_invariant` +(which depends on the `[HasNot P]` instance present on `Cmd P`). -/ +theorem stmtsToCFG_stmtsToBlocks_spec {P : PureExpr} + [HasBool P] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] + (ss : List (Stmt P (Cmd P))) + (h_disj : ∀ gen', Block.userLabelsDisjoint ss gen') : + ∃ (lend : String) (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P), + stmtsToBlocks lend ss [] [] gen = ((entry, blocks), gen') ∧ + (stmtsToCFG ss).entry = entry ∧ + (∀ b ∈ blocks, b ∈ (stmtsToCFG ss).blocks) ∧ + (stmtsToCFG ss).blocks.lookup lend = + some ({ cmds := [], transfer := .finish synthesizedMd } : BasicBlock (DetTransferCmd String P) (Cmd P)) ∧ + StringGenState.WF gen := by + let p_end := StringGenState.gen "end$" StringGenState.emp + let lend := p_end.1 + let gen0 := p_end.2 + let r := stmtsToBlocks lend ss ([] : List (Option String × String)) ([] : List (Cmd P)) gen0 + have h_cfg : stmtsToCFG ss = + { entry := r.1.1, blocks := r.1.2 ++ [(lend, { cmds := [], transfer := .finish synthesizedMd })] } := by + simp [stmtsToCFG, stmtsToCFGM] + rfl + -- WF of gen0 (after one gen call from emp) + have hwf0 : StringGenState.WF gen0 := + StringGenState.WFMono StringGenState.wf_emp rfl + refine ⟨lend, gen0, r.2, r.1.1, r.1.2, rfl, ?_, ?_, ?_, hwf0⟩ + · simp [h_cfg] + · intro b hb; simp [h_cfg]; exact Or.inl hb + · -- Show lookup of lend in (r.1.2 ++ [(lend, finish)]) is the finish block. + -- Strategy: use stmtsToBlocks_invariant to show lend ∉ r.1.2.map Prod.fst, + -- then List.lookup skips past r.1.2 to find lend at the end. + rw [h_cfg] + show List.lookup lend (r.1.2 ++ [(lend, _)]) = _ + -- WF of gen0 (after one gen call from emp) + have hwf0 : StringGenState.WF gen0 := + StringGenState.WFMono StringGenState.wf_emp rfl + -- lend ∈ stringGens gen0 + have h_lend_in_gen0 : lend ∈ StringGenState.stringGens gen0 := by + show lend ∈ StringGenState.stringGens p_end.2 + rw [StringGenState.stringGens_gen]; exact List.mem_cons.mpr (Or.inl rfl) + -- All labels in r.1.2 are NOT in stringGens gen0 (by invariant fresh field) + have h_eq : stmtsToBlocks lend ss [] [] gen0 = ((r.1.1, r.1.2), r.2) := rfl + have h_inv : @GenInv P gen0 r.2 (Block.userBlockLabels ss) r.1.2 := + stmtsToBlocks_invariant lend ss [] [] gen0 r.2 _ _ h_eq hwf0 (h_disj _) + have h_lend_not_in_blocks : lend ∉ r.1.2.map Prod.fst := by + intro h_in + cases h_inv.fresh _ h_in with + | inl h_gen => exact h_gen.2 h_lend_in_gen0 + | inr h_user => + have h_lend_in_r2 : lend ∈ StringGenState.stringGens r.2 := + h_inv.toGenStep.subset h_lend_in_gen0 + exact h_inv.user_disj _ h_user h_lend_in_r2 + -- Now lookup lend in r.1.2 ++ [(lend, _)] = lookup lend [(lend, _)] + rw [List.lookup_append] + -- Helper lemma: lookup = some v implies (key, v) ∈ list + have lookup_to_mem : ∀ {α β : Type} [BEq α] [LawfulBEq α] + (l : List (α × β)) (k : α) (v : β), l.lookup k = some v → (k, v) ∈ l := by + intro α β _ _ l k v hlk + induction l with + | nil => simp [List.lookup] at hlk + | cons hd tl ih => + obtain ⟨k', v'⟩ := hd + by_cases h_eq : k = k' + · subst h_eq + simp [List.lookup] at hlk + subst hlk + exact List.Mem.head _ + · have h_neq : ¬(k == k') = true := by simp [h_eq] + simp [List.lookup, h_neq] at hlk + exact List.mem_cons_of_mem _ (ih hlk) + have h_lookup_none : List.lookup lend r.1.2 = none := by + rcases h : List.lookup lend r.1.2 with _ | v + · rfl + · exfalso + apply h_lend_not_in_blocks + exact List.mem_map.mpr ⟨(lend, v), lookup_to_mem _ _ _ h, rfl⟩ + rw [h_lookup_none] + simp [List.lookup, Option.or] + rfl + +private theorem end_block_terminal {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (lend : String) (σ : SemanticStore P) (δ : SemanticEval P) (failed : Bool) + (h_lookup : cfg.blocks.lookup lend = + some ({ cmds := [], transfer := .finish synthesizedMd } : DetBlock String (Cmd P) P)) : + StepDetCFGStar extendEval cfg + (.atBlock lend σ failed) + (.terminal σ failed) := by + have h_cmds : EvalCmds P (EvalCmd P) δ σ [] σ false := + EvalCmds.eval_cmds_none + have h_run := run_block_finish (extendEval := extendEval) (cfg := cfg) + (f_base := failed) h_lookup h_cmds + rw [Bool.or_false] at h_run + exact h_run + +/-- If the structured program reaches a terminal state, the CFG also reaches + a corresponding terminal state. Requires that the initial failure flag is + false, since the CFG always starts with failure = false. + + The CFG end-store agrees with the structured end-store on every defined + variable (`StoreAgreement`); they may differ only on variables introduced + by inner scopes (e.g. `.block`'s local frames). -/ +theorem stmtsToCFG_terminal {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] + [LawfulHasIntOrder P] [LawfulHasNot P] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) + (ρ₀ ρ' : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (hf₀ : ρ₀.hasFailure = false) + (h_nofd : Block.noFuncDecl ss = true) + (h_simple : Block.simpleShape ss = true) + (h_unique : Block.uniqueInits ss) + (h_fresh_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) + (h_disj : ∀ gen', Block.userLabelsDisjoint ss gen') + (h_store_clean : ∀ ident : P.Ident, ρ₀.store ident = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) (transformBlockModVars ss)) + (h_input_no_gen_suffix_get : NoGenSuffix (P := P) (Block.getVars ss)) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.terminal ρ')) : + let cfg := stmtsToCFG ss + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock cfg.entry ρ₀.store false) + (.terminal σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := by + intro cfg + have ⟨lend, gen, gen', entry, blocks, h_gen, h_entry, h_blocks, h_lend, h_wf_gen⟩ := + stmtsToCFG_stmtsToBlocks_spec ss h_disj + rw [h_entry] + have h_accum : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := + EvalCmds.eval_cmds_none + have h_hf : ρ₀.hasFailure = (false || false) := by simp [hf₀] + have h_nodup := stmtsToCFG_nodup_keys ss h_disj + -- Combined freshness/Nodup: empty accum, so reduces to just inits. + have h_fresh_combined : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars ss, + ρ₀.store x = none := by + intro x hx + simp [Cmds.definedVars] at hx + exact h_fresh_inits x hx + have h_unique_combined : (Cmds.definedVars [].reverse ++ Block.initVars ss).Nodup := by + simp [Cmds.definedVars] + exact h_unique + have h_combined_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars ss) := by + intro x hx s heq + simp [Cmds.definedVars] at hx + exact h_input_no_gen_suffix x hx s heq + have h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars ss) := by + intro x hx s heq + simp [Cmds.modifiedVars] at hx + exact h_input_no_gen_suffix_mod x hx s heq + have h_combined_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars ss) := by + intro x hx s heq + simp [Cmds.getVars] at hx + exact h_input_no_gen_suffix_get x hx s heq + have h_store_no_gens_upper : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens gen' → + ρ₀.store (HasIdent.ident (P := P) x) = none := fun x _ _ => h_store_clean _ + have ⟨σ_cfg, h_sim, h_agree, _h_preserve⟩ := + stmtsToBlocks_simulation extendEval lend ss [] [] gen gen' entry blocks + h_gen h_nofd h_simple h_unique ρ₀.store ρ₀.store false false ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var + h_term h_accum (StoreAgreement.refl _) h_fresh_combined h_unique_combined h_hf + h_wf_gen h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + h_combined_no_gen_suffix_get + gen' (fun _ h => h) h_store_no_gens_upper + cfg h_blocks h_nodup + have h_end := end_block_terminal extendEval cfg lend σ_cfg ρ'.eval ρ'.hasFailure h_lend + exact ⟨σ_cfg, StepDetCFGStar_trans h_sim h_end, h_agree⟩ + +/-- If the structured program reaches an exiting state, the CFG also reaches + a corresponding terminal state (vacuously, since `exitsCoveredByBlocks` + rules out top-level `.exiting`). -/ +theorem stmtsToCFG_exiting {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVal P] [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) + (ρ₀ ρ' : Env P) (lbl : String) + (h_exits : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks [] ss) + (h_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.exiting lbl ρ')) : + let cfg := stmtsToCFG ss + ∃ σ_final failed, + StepDetCFGStar extendEval cfg + (.atBlock cfg.entry ρ₀.store false) + (.terminal σ_final failed) ∧ + σ_final = ρ'.store := + stmtsToBlocks_simulation_exiting extendEval ss (stmtsToCFG ss).entry + ρ₀.store false ρ₀ ρ' lbl h_exits h_exit (stmtsToCFG ss) + +/-! ## Main theorems -/ + +/-- `stmtsToCFG` is sound: any terminal state reachable from the structured + execution is reachable from the CFG execution at a store that agrees with + the structured store on every defined variable. + + Since CFGs have no "exiting" configs (exits are compiled to jumps), the + exiting case is ruled out by the `h_exits` precondition. -/ +theorem structuredToUnstructured_sound {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] + [LawfulHasIntOrder P] [LawfulHasNot P] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) + (ρ₀ ρ' : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (hf₀ : ρ₀.hasFailure = false) + (h_nofd : Block.noFuncDecl ss = true) + (h_simple : Block.simpleShape ss = true) + (h_unique : Block.uniqueInits ss) + (h_fresh_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) + (h_disj : ∀ gen', Block.userLabelsDisjoint ss gen') + (h_store_clean : ∀ ident : P.Ident, ρ₀.store ident = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) (transformBlockModVars ss)) + (h_input_no_gen_suffix_get : NoGenSuffix (P := P) (Block.getVars ss)) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.terminal ρ')) : + let cfg := stmtsToCFG ss + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock cfg.entry ρ₀.store false) + (.terminal σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := + stmtsToCFG_terminal extendEval ss ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var + hf₀ + h_nofd h_simple h_unique h_fresh_inits h_disj h_store_clean h_input_no_gen_suffix + h_input_no_gen_suffix_mod h_input_no_gen_suffix_get h_term + +end StructuredToUnstructuredCorrect + +end -- public section From 187a81931262b9c39dfb6dce949f8200a5fa9f91 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 9 Jun 2026 10:55:40 -0700 Subject: [PATCH 02/33] wip: skeleton for loop extension (no invs, no measures, no body inits) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds three new predicates to Strata/DL/Imperative/Stmt.lean and weakens simpleShape so that .loop is permitted when its body has simpleShape: - Block.loopBodyNoInits — body's initVars must be empty - Block.loopHasNoInvariants — invariants list must be empty - Block.noMeasureLoops — measure must be .none Threads the three preconditions through the simulation theorems (stmtsToBlocks_simulation, stmtsToBlocks_simulation_to_cont, top-level structuredToUnstructured_sound). Adds a LoopArm namespace with framework helpers carrying real signatures. Build green: 489/489 jobs. Sorries: 8, all at named lemma boundaries (2 top-level loop arms + 6 LoopArm framework helpers). Axioms: 0. This commit captures the skeleton from workflow wf_c2c8cd66-3b1, which died at the auth boundary after writing the file but before launching closure waves. Closure waves pick up from this commit. --- Strata/DL/Imperative/Stmt.lean | 265 +++++++- .../StructuredToUnstructuredCorrect.lean | 586 +++++++++++++++++- 2 files changed, 829 insertions(+), 22 deletions(-) diff --git a/Strata/DL/Imperative/Stmt.lean b/Strata/DL/Imperative/Stmt.lean index 4d62ea0493..a62d679488 100644 --- a/Strata/DL/Imperative/Stmt.lean +++ b/Strata/DL/Imperative/Stmt.lean @@ -206,7 +206,11 @@ pattern the CFG cannot replicate. -/ Predicate stating that a statement or block has a "simple" shape suitable for the structured-to-CFG soundness proof under axiom-free assumptions: - no nondeterministic `.ite` -- no `.loop` of any kind (the `.loop` arm discharges by contradiction) +- `.loop` is permitted **provided its body is itself simple-shape**. + Auxiliary predicates `loopBodyNoInits`, `loopHasNoInvariants`, and + `noMeasureLoops` further restrict which loops are admissible for the + current proof scope (no body-local var inits, no labeled invariants, + no termination measure). Those predicates are defined below. `.ite (.det _)`, `.block`, sequential `.cmd`s, `.exit`, `.funcDecl`, and `.typeDecl` are all allowed. @@ -220,7 +224,7 @@ mutual | .block _ bss _ => Block.simpleShape bss | .ite (.det _) tss ess _ => Block.simpleShape tss && Block.simpleShape ess | .ite .nondet _ _ _ => false - | .loop _ _ _ _ _ => false + | .loop _ _ _ bss _ => Block.simpleShape bss | .exit _ _ => true | .funcDecl _ _ => true | .typeDecl _ _ => true @@ -259,6 +263,263 @@ theorem Stmt.simpleShape_branch_else intro h exact h.2 +/-- The body of a `.block` is simple when the whole block-statement is. -/ +theorem Stmt.simpleShape_block_body + {label : String} {body : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.simpleShape (.block label body md) = true → + Block.simpleShape body = true := by + simp only [Stmt.simpleShape] + intro h; exact h + +/-- The body of a `.loop` is simple when the whole loop-statement is. -/ +theorem Stmt.simpleShape_loop_body + {g : ExprOrNondet P} {m : Option P.Expr} + {is : List (String × P.Expr)} {body : List (Stmt P (Cmd P))} + {md : MetaData P} : + Stmt.simpleShape (.loop g m is body md) = true → + Block.simpleShape body = true := by + simp only [Stmt.simpleShape] + intro h; exact h + +--------------------------------------------------------------------- + +/-! ### LoopBodyNoInits + +Predicate stating that every `.loop _ _ _ bss _` reachable inside a +statement (or block) has `Block.initVars bss = []`. Used by the +structured-to-CFG soundness proof: the CFG flat namespace cannot +re-execute body inits at iteration ≥ 2, so we restrict to loops whose +body declares no local variables. +-/ + +mutual +/-- Returns true if every reachable loop's body declares no local vars. -/ +@[expose] def Stmt.loopBodyNoInits (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd _ => true + | .block _ bss _ => Block.loopBodyNoInits bss + | .ite _ tss ess _ => Block.loopBodyNoInits tss && Block.loopBodyNoInits ess + | .loop _ _ _ bss _ => + (Block.initVars bss).isEmpty && Block.loopBodyNoInits bss + | .exit _ _ => true + | .funcDecl _ _ => true + | .typeDecl _ _ => true + termination_by (Stmt.sizeOf s) + +/-- Block-level lifting of `Stmt.loopBodyNoInits`. -/ +@[expose] def Block.loopBodyNoInits (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => true + | s :: srest => Stmt.loopBodyNoInits s && Block.loopBodyNoInits srest + termination_by (Block.sizeOf ss) +end + +theorem Block.loopBodyNoInits_cons_iff + {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} : + Block.loopBodyNoInits (s :: rest) = true ↔ + Stmt.loopBodyNoInits s = true ∧ Block.loopBodyNoInits rest = true := by + simp only [Block.loopBodyNoInits, Bool.and_eq_true] + +theorem Stmt.loopBodyNoInits_branch_then + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.loopBodyNoInits (.ite g tss ess md) = true → + Block.loopBodyNoInits tss = true := by + simp only [Stmt.loopBodyNoInits, Bool.and_eq_true] + intro h; exact h.1 + +theorem Stmt.loopBodyNoInits_branch_else + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.loopBodyNoInits (.ite g tss ess md) = true → + Block.loopBodyNoInits ess = true := by + simp only [Stmt.loopBodyNoInits, Bool.and_eq_true] + intro h; exact h.2 + +theorem Stmt.loopBodyNoInits_block_body + {label : String} {body : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.loopBodyNoInits (.block label body md) = true → + Block.loopBodyNoInits body = true := by + simp only [Stmt.loopBodyNoInits] + intro h; exact h + +/-- A loop's body has no local variable initializations. -/ +theorem Stmt.loopBodyNoInits_loop_body + {g : ExprOrNondet P} {m : Option P.Expr} + {is : List (String × P.Expr)} {body : List (Stmt P (Cmd P))} + {md : MetaData P} : + Stmt.loopBodyNoInits (.loop g m is body md) = true → + Block.initVars body = [] := by + simp only [Stmt.loopBodyNoInits, Bool.and_eq_true, List.isEmpty_iff] + intro h; exact h.1 + +/-- The recursive `loopBodyNoInits` discharge for a loop's body. -/ +theorem Stmt.loopBodyNoInits_loop_body_rec + {g : ExprOrNondet P} {m : Option P.Expr} + {is : List (String × P.Expr)} {body : List (Stmt P (Cmd P))} + {md : MetaData P} : + Stmt.loopBodyNoInits (.loop g m is body md) = true → + Block.loopBodyNoInits body = true := by + simp only [Stmt.loopBodyNoInits, Bool.and_eq_true] + intro h; exact h.2 + +--------------------------------------------------------------------- + +/-! ### LoopHasNoInvariants + +Predicate stating that every `.loop _ _ is _ _` reachable inside a +statement (or block) has `is = []` (no labeled invariants). Used by +the structured-to-CFG soundness proof to collapse the assert-chain +at the loop entry block to empty. +-/ + +mutual +/-- Returns true if every reachable loop has no invariants. -/ +@[expose] def Stmt.loopHasNoInvariants (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd _ => true + | .block _ bss _ => Block.loopHasNoInvariants bss + | .ite _ tss ess _ => Block.loopHasNoInvariants tss && Block.loopHasNoInvariants ess + | .loop _ _ is bss _ => + is.isEmpty && Block.loopHasNoInvariants bss + | .exit _ _ => true + | .funcDecl _ _ => true + | .typeDecl _ _ => true + termination_by (Stmt.sizeOf s) + +/-- Block-level lifting of `Stmt.loopHasNoInvariants`. -/ +@[expose] def Block.loopHasNoInvariants (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => true + | s :: srest => Stmt.loopHasNoInvariants s && Block.loopHasNoInvariants srest + termination_by (Block.sizeOf ss) +end + +theorem Block.loopHasNoInvariants_cons_iff + {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} : + Block.loopHasNoInvariants (s :: rest) = true ↔ + Stmt.loopHasNoInvariants s = true ∧ Block.loopHasNoInvariants rest = true := by + simp only [Block.loopHasNoInvariants, Bool.and_eq_true] + +theorem Stmt.loopHasNoInvariants_branch_then + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.loopHasNoInvariants (.ite g tss ess md) = true → + Block.loopHasNoInvariants tss = true := by + simp only [Stmt.loopHasNoInvariants, Bool.and_eq_true] + intro h; exact h.1 + +theorem Stmt.loopHasNoInvariants_branch_else + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.loopHasNoInvariants (.ite g tss ess md) = true → + Block.loopHasNoInvariants ess = true := by + simp only [Stmt.loopHasNoInvariants, Bool.and_eq_true] + intro h; exact h.2 + +theorem Stmt.loopHasNoInvariants_block_body + {label : String} {body : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.loopHasNoInvariants (.block label body md) = true → + Block.loopHasNoInvariants body = true := by + simp only [Stmt.loopHasNoInvariants] + intro h; exact h + +/-- A loop has no labeled invariants. -/ +theorem Stmt.loopHasNoInvariants_loop_invs + {g : ExprOrNondet P} {m : Option P.Expr} + {is : List (String × P.Expr)} {body : List (Stmt P (Cmd P))} + {md : MetaData P} : + Stmt.loopHasNoInvariants (.loop g m is body md) = true → + is = [] := by + simp only [Stmt.loopHasNoInvariants, Bool.and_eq_true, List.isEmpty_iff] + intro h; exact h.1 + +/-- The recursive `loopHasNoInvariants` discharge for a loop's body. -/ +theorem Stmt.loopHasNoInvariants_loop_body_rec + {g : ExprOrNondet P} {m : Option P.Expr} + {is : List (String × P.Expr)} {body : List (Stmt P (Cmd P))} + {md : MetaData P} : + Stmt.loopHasNoInvariants (.loop g m is body md) = true → + Block.loopHasNoInvariants body = true := by + simp only [Stmt.loopHasNoInvariants, Bool.and_eq_true] + intro h; exact h.2 + +--------------------------------------------------------------------- + +/-! ### NoMeasureLoops + +Predicate stating that every `.loop _ m _ _ _` reachable inside a +statement (or block) has `m = .none` (no termination measure). Used +by the structured-to-CFG soundness proof to collapse the +`measure_lb` / `measure_decrease` blocks in the translator's loop +CFG layout. +-/ + +mutual +/-- Returns true if every reachable loop has no termination measure. -/ +@[expose] def Stmt.noMeasureLoops (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd _ => true + | .block _ bss _ => Block.noMeasureLoops bss + | .ite _ tss ess _ => Block.noMeasureLoops tss && Block.noMeasureLoops ess + | .loop _ m _ bss _ => + m.isNone && Block.noMeasureLoops bss + | .exit _ _ => true + | .funcDecl _ _ => true + | .typeDecl _ _ => true + termination_by (Stmt.sizeOf s) + +/-- Block-level lifting of `Stmt.noMeasureLoops`. -/ +@[expose] def Block.noMeasureLoops (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => true + | s :: srest => Stmt.noMeasureLoops s && Block.noMeasureLoops srest + termination_by (Block.sizeOf ss) +end + +theorem Block.noMeasureLoops_cons_iff + {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} : + Block.noMeasureLoops (s :: rest) = true ↔ + Stmt.noMeasureLoops s = true ∧ Block.noMeasureLoops rest = true := by + simp only [Block.noMeasureLoops, Bool.and_eq_true] + +theorem Stmt.noMeasureLoops_branch_then + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.noMeasureLoops (.ite g tss ess md) = true → + Block.noMeasureLoops tss = true := by + simp only [Stmt.noMeasureLoops, Bool.and_eq_true] + intro h; exact h.1 + +theorem Stmt.noMeasureLoops_branch_else + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.noMeasureLoops (.ite g tss ess md) = true → + Block.noMeasureLoops ess = true := by + simp only [Stmt.noMeasureLoops, Bool.and_eq_true] + intro h; exact h.2 + +theorem Stmt.noMeasureLoops_block_body + {label : String} {body : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.noMeasureLoops (.block label body md) = true → + Block.noMeasureLoops body = true := by + simp only [Stmt.noMeasureLoops] + intro h; exact h + +/-- A loop has no termination measure. -/ +theorem Stmt.noMeasureLoops_loop_measure + {g : ExprOrNondet P} {m : Option P.Expr} + {is : List (String × P.Expr)} {body : List (Stmt P (Cmd P))} + {md : MetaData P} : + Stmt.noMeasureLoops (.loop g m is body md) = true → + m = .none := by + simp only [Stmt.noMeasureLoops, Bool.and_eq_true, Option.isNone_iff_eq_none] + intro h; exact h.1 + +/-- The recursive `noMeasureLoops` discharge for a loop's body. -/ +theorem Stmt.noMeasureLoops_loop_body_rec + {g : ExprOrNondet P} {m : Option P.Expr} + {is : List (String × P.Expr)} {body : List (Stmt P (Cmd P))} + {md : MetaData P} : + Stmt.noMeasureLoops (.loop g m is body md) = true → + Block.noMeasureLoops body = true := by + simp only [Stmt.noMeasureLoops, Bool.and_eq_true] + intro h; exact h.2 + --------------------------------------------------------------------- /-! ### NoBlocks diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 8f7ea90cc3..da77acf3bb 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4203,6 +4203,9 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (h_nofd : Block.noFuncDecl ss = true) (h_simple : Block.simpleShape ss = true) (h_unique : Block.uniqueInits ss) + (h_lbni : Block.loopBodyNoInits ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) (σ_struct_base σ_base : SemanticStore P) (hf_base : Bool) (hf_accum : Bool) @@ -4297,6 +4300,12 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have h_simple_rest : Block.simpleShape rest = true := (Block.simpleShape_cons_iff.mp h_simple).2 have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + have h_lbni_rest : Block.loopBodyNoInits rest = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 + have h_lhni_rest : Block.loopHasNoInvariants rest = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 + have h_nml_rest : Block.noMeasureLoops rest = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).2 -- Snoc/cons rebracketing facts shared between _simulation and _to_cont. have ⟨h_definedVars_snoc, h_fresh_combined', h_unique_combined', h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', @@ -4308,6 +4317,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := stmtsToBlocks_simulation extendEval k rest exitConts (c :: accum) gen gen' entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest σ_struct_base σ_base hf_base (hf_accum || failed_c) ρ₁ ρ' hwfb' hwfv' hwf_def' hwf_congr' hwf_var' h_rest_star h_accum' @@ -4422,6 +4432,31 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] Stmt.simpleShape_branch_then h_simple_head have h_simple_else : Block.simpleShape elseBranch = true := Stmt.simpleShape_branch_else h_simple_head + -- Extract loopBodyNoInits / loopHasNoInvariants / noMeasureLoops for sub-blocks. + have h_lbni_head : Stmt.loopBodyNoInits (.ite (.det e) thenBranch elseBranch md) = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).1 + have h_lbni_rest : Block.loopBodyNoInits rest = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 + have h_lbni_then : Block.loopBodyNoInits thenBranch = true := + Stmt.loopBodyNoInits_branch_then h_lbni_head + have h_lbni_else : Block.loopBodyNoInits elseBranch = true := + Stmt.loopBodyNoInits_branch_else h_lbni_head + have h_lhni_head : Stmt.loopHasNoInvariants (.ite (.det e) thenBranch elseBranch md) = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).1 + have h_lhni_rest : Block.loopHasNoInvariants rest = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 + have h_lhni_then : Block.loopHasNoInvariants thenBranch = true := + Stmt.loopHasNoInvariants_branch_then h_lhni_head + have h_lhni_else : Block.loopHasNoInvariants elseBranch = true := + Stmt.loopHasNoInvariants_branch_else h_lhni_head + have h_nml_head : Stmt.noMeasureLoops (.ite (.det e) thenBranch elseBranch md) = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).1 + have h_nml_rest : Block.noMeasureLoops rest = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).2 + have h_nml_then : Block.noMeasureLoops thenBranch = true := + Stmt.noMeasureLoops_branch_then h_nml_head + have h_nml_else : Block.noMeasureLoops elseBranch = true := + Stmt.noMeasureLoops_branch_else h_nml_head -- Eval well-formedness preservation through ite branch have h_eval_eq : ρ₁.eval = ρ₀.eval := by rcases h_ite_inv with h | h @@ -4619,6 +4654,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have ⟨σ_branch, h_then_step, h_agree_then, h_preserve_then⟩ := stmtsToBlocks_simulation extendEval kNext thenBranch exitConts [] gen_ite gen_t tl tbs h_then_eq h_nofd_then h_simple_then h_unique_then + h_lbni_then h_lhni_then h_nml_then ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ₁ hwfb hwfv hwf_def hwf_congr hwf_var h_then_term h_accum_nil_t h_agree_after @@ -4668,7 +4704,9 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (fun x hx s heq => h_then_no_gen_suffix x (List.mem_append_right _ hx) s heq) have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ₁.store σ_branch ρ₁.hasFailure false + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest + ρ₁.store σ_branch ρ₁.hasFailure false ρ₁ ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_star h_accum_nil_r h_agree_then h_combined_rest h_unique_combined_rest (by simp) @@ -4727,6 +4765,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have ⟨σ_branch, h_else_step, h_agree_else, h_preserve_else⟩ := stmtsToBlocks_simulation extendEval kNext elseBranch exitConts [] gen_t gen_e fl fbs h_else_eq h_nofd_else h_simple_else h_unique_else + h_lbni_else h_lhni_else h_nml_else ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ₁ hwfb hwfv hwf_def hwf_congr hwf_var h_else_term h_accum_nil_f h_agree_after @@ -4776,7 +4815,9 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (fun x hx s heq => h_else_no_gen_suffix x (List.mem_append_right _ hx) s heq) have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ₁.store σ_branch ρ₁.hasFailure false + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest + ρ₁.store σ_branch ρ₁.hasFailure false ρ₁ ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_star h_accum_nil_r h_agree_else h_combined_rest h_unique_combined_rest (by simp) @@ -4818,8 +4859,13 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] exact h_preserve_rest x h_σ_branch_x h_nil_not h_x_not_rest h_inner_guard_r | .ite .nondet _ _ _ :: _ => exact absurd (Block.simpleShape_cons_iff.mp h_simple).1 (by simp [Stmt.simpleShape]) - | .loop _ _ _ _ _ :: _ => - exact absurd (Block.simpleShape_cons_iff.mp h_simple).1 (by simp [Stmt.simpleShape]) + | .loop guard measure invariants body md :: rest => + -- SORRY-SITE: LoopArm.loop_arm_simulation + -- The .loop arm of stmtsToBlocks_simulation. Discharged via the + -- framework helper LoopArm.loop_arm_simulation declared below the + -- mutual block; that helper takes the body and rest simulation calls + -- as callbacks. + sorry | .block label body md :: rest => simp only [stmtsToBlocks, bind, StateT.bind, pure, StateT.pure] at h_gen -- Decompose the monadic chain @@ -4890,6 +4936,25 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (Block.simpleShape_cons_iff.mp h_simple).2 have h_simple_body : Block.simpleShape body = true := by simp only [Stmt.simpleShape] at h_simple_head; exact h_simple_head + -- loopBodyNoInits/loopHasNoInvariants/noMeasureLoops projections for body and rest. + have h_lbni_head : Stmt.loopBodyNoInits (.block label body md) = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).1 + have h_lbni_rest : Block.loopBodyNoInits rest = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 + have h_lbni_body : Block.loopBodyNoInits body = true := + Stmt.loopBodyNoInits_block_body h_lbni_head + have h_lhni_head : Stmt.loopHasNoInvariants (.block label body md) = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).1 + have h_lhni_rest : Block.loopHasNoInvariants rest = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 + have h_lhni_body : Block.loopHasNoInvariants body = true := + Stmt.loopHasNoInvariants_block_body h_lhni_head + have h_nml_head : Stmt.noMeasureLoops (.block label body md) = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).1 + have h_nml_rest : Block.noMeasureLoops rest = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).2 + have h_nml_body : Block.noMeasureLoops body = true := + Stmt.noMeasureLoops_block_body h_nml_head -- uniqueInits projections. have h_unique_body : Block.uniqueInits body := Block.uniqueInits.block_body h_unique @@ -5027,6 +5092,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] stmtsToBlocks_simulation extendEval kNext body ((some label, kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_inner hwfb hwfv hwf_def hwf_congr hwf_var h_body_term h_accum_nil h_agree_after @@ -5080,7 +5146,9 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] -- Recurse on rest. have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest + ρ_blk.store σ_cfg_body ρ_blk.hasFailure false ρ_blk ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_star h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) @@ -5144,6 +5212,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] stmtsToBlocks_simulation_to_cont extendEval kNext body ((some label, kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_inner label kNext h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var h_body_exit_star h_accum_nil h_agree_after @@ -5195,7 +5264,9 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] -- Recurse on rest with _simulation. have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest + ρ_blk.store σ_cfg_body ρ_blk.hasFailure false ρ_blk ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_star h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) @@ -5289,6 +5360,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] stmtsToBlocks_simulation extendEval kNext body ((some label, kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_inner hwfb hwfv hwf_def hwf_congr hwf_var h_body_term h_accum_nil h_agree_after @@ -5336,7 +5408,8 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest ρ_blk.store σ_cfg_body ρ_blk.hasFailure false ρ_blk ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_star h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) @@ -5383,6 +5456,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] stmtsToBlocks_simulation_to_cont extendEval kNext body ((some label, kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_inner label kNext h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var h_body_exit_star h_accum_nil h_agree_after @@ -5430,7 +5504,8 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest ρ_blk.store σ_cfg_body ρ_blk.hasFailure false ρ_blk ρ' hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_star h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) @@ -5504,6 +5579,12 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have h_simple_rest : Block.simpleShape rest = true := (Block.simpleShape_cons_iff.mp h_simple).2 have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + have h_lbni_rest : Block.loopBodyNoInits rest = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 + have h_lhni_rest : Block.loopHasNoInvariants rest = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 + have h_nml_rest : Block.noMeasureLoops rest = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).2 have ⟨h_fresh_combined', h_unique_combined', h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', h_combined_no_gen_suffix_get'⟩ := @@ -5513,7 +5594,9 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_combined_no_gen_suffix_get have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := stmtsToBlocks_simulation extendEval k rest exitConts accum gen gen' - entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest σ_struct_base σ_base hf_base hf_accum + entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest + σ_struct_base σ_base hf_base hf_accum ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var h_rest_star h_accum h_agree_entry h_fresh_combined' h_unique_combined' h_hf @@ -5557,6 +5640,9 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (h_nofd : Block.noFuncDecl ss = true) (h_simple : Block.simpleShape ss = true) (h_unique : Block.uniqueInits ss) + (h_lbni : Block.loopBodyNoInits ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) (σ_struct_base σ_base : SemanticStore P) (hf_base : Bool) (hf_accum : Bool) @@ -5665,6 +5751,12 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have h_simple_rest : Block.simpleShape rest = true := (Block.simpleShape_cons_iff.mp h_simple).2 have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + have h_lbni_rest : Block.loopBodyNoInits rest = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 + have h_lhni_rest : Block.loopHasNoInvariants rest = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 + have h_nml_rest : Block.noMeasureLoops rest = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).2 -- Snoc/cons rebracketing facts shared between _simulation and _to_cont. have ⟨h_definedVars_snoc, h_fresh_combined', h_unique_combined', h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', @@ -5676,6 +5768,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts (c :: accum) gen gen' entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest σ_struct_base σ_base hf_base (hf_accum || failed_c) ρ₁ ρ' label bk_target h_label hwfb' hwfv' hwf_def' hwf_congr' hwf_var' h_rest_exit h_accum' @@ -5742,6 +5835,12 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have h_simple_rest : Block.simpleShape rest = true := (Block.simpleShape_cons_iff.mp h_simple).2 have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + have h_lbni_rest : Block.loopBodyNoInits rest = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 + have h_lhni_rest : Block.loopHasNoInvariants rest = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 + have h_nml_rest : Block.noMeasureLoops rest = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).2 have ⟨h_fresh_combined', h_unique_combined', h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', h_combined_no_gen_suffix_get'⟩ := @@ -5751,7 +5850,9 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_combined_no_gen_suffix_get have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts accum gen gen' - entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest σ_struct_base σ_base hf_base hf_accum + entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest + σ_struct_base σ_base hf_base hf_accum ρ₀ ρ' label bk_target h_label hwfb hwfv hwf_def hwf_congr hwf_var h_rest_exit h_accum h_agree_entry h_fresh_combined' h_unique_combined' h_hf @@ -5891,6 +5992,25 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (Block.simpleShape_cons_iff.mp h_simple).2 have h_simple_body : Block.simpleShape body = true := by simp only [Stmt.simpleShape] at h_simple_head; exact h_simple_head + -- loopBodyNoInits/loopHasNoInvariants/noMeasureLoops projections for body and rest. + have h_lbni_head : Stmt.loopBodyNoInits (.block label' body md) = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).1 + have h_lbni_rest : Block.loopBodyNoInits rest = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 + have h_lbni_body : Block.loopBodyNoInits body = true := + Stmt.loopBodyNoInits_block_body h_lbni_head + have h_lhni_head : Stmt.loopHasNoInvariants (.block label' body md) = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).1 + have h_lhni_rest : Block.loopHasNoInvariants rest = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 + have h_lhni_body : Block.loopHasNoInvariants body = true := + Stmt.loopHasNoInvariants_block_body h_lhni_head + have h_nml_head : Stmt.noMeasureLoops (.block label' body md) = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).1 + have h_nml_rest : Block.noMeasureLoops rest = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).2 + have h_nml_body : Block.noMeasureLoops body = true := + Stmt.noMeasureLoops_block_body h_nml_head have h_unique_body : Block.uniqueInits body := Block.uniqueInits.block_body h_unique have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique @@ -6014,6 +6134,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has stmtsToBlocks_simulation_to_cont extendEval kNext body ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_inner label bk_target h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var h_body_exit h_accum_nil h_agree_after @@ -6066,6 +6187,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has stmtsToBlocks_simulation extendEval kNext body ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_inner hwfb hwfv hwf_def hwf_congr hwf_var h_body_term h_accum_nil h_agree_after @@ -6113,7 +6235,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest ρ_blk.store σ_cfg_body ρ_blk.hasFailure false ρ_blk ρ' label bk_target h_label hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_exit h_accum_nil_r h_agree_block_body @@ -6146,6 +6269,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has stmtsToBlocks_simulation_to_cont extendEval kNext body ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_inner label' kNext h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var h_body_match h_accum_nil h_agree_after @@ -6193,7 +6317,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest ρ_blk.store σ_cfg_body ρ_blk.hasFailure false ρ_blk ρ' label bk_target h_label hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_exit h_accum_nil_r h_agree_block_body @@ -6290,6 +6415,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has stmtsToBlocks_simulation_to_cont extendEval kNext body ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_inner label bk_target h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var h_body_exit h_accum_nil h_agree_after @@ -6336,6 +6462,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has stmtsToBlocks_simulation extendEval kNext body ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_inner hwfb hwfv hwf_def hwf_congr hwf_var h_body_term h_accum_nil h_agree_after @@ -6383,7 +6510,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest ρ_blk.store σ_cfg_body ρ_blk.hasFailure false ρ_blk ρ' label bk_target h_label hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_exit h_accum_nil_r h_agree_block_body @@ -6416,6 +6544,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has stmtsToBlocks_simulation_to_cont extendEval kNext body ((some label', kNext) :: exitConts) [] gen_r gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_inner label' kNext h_label_lookup hwfb hwfv hwf_def hwf_congr hwf_var h_body_match h_accum_nil h_agree_after @@ -6463,7 +6592,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (fun x hx s heq => h_body_no_gen_suffix x (List.mem_append_right _ hx) s heq) have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_blk.store σ_cfg_body + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest ρ_blk.store σ_cfg_body ρ_blk.hasFailure false ρ_blk ρ' label bk_target h_label hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_exit h_accum_nil_r h_agree_block_body @@ -6587,6 +6717,31 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has Stmt.simpleShape_branch_then h_simple_head have h_simple_else : Block.simpleShape elseBranch = true := Stmt.simpleShape_branch_else h_simple_head + -- loopBodyNoInits/loopHasNoInvariants/noMeasureLoops projections. + have h_lbni_head : Stmt.loopBodyNoInits (.ite (.det e) thenBranch elseBranch md) = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).1 + have h_lbni_rest : Block.loopBodyNoInits rest = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 + have h_lbni_then : Block.loopBodyNoInits thenBranch = true := + Stmt.loopBodyNoInits_branch_then h_lbni_head + have h_lbni_else : Block.loopBodyNoInits elseBranch = true := + Stmt.loopBodyNoInits_branch_else h_lbni_head + have h_lhni_head : Stmt.loopHasNoInvariants (.ite (.det e) thenBranch elseBranch md) = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).1 + have h_lhni_rest : Block.loopHasNoInvariants rest = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 + have h_lhni_then : Block.loopHasNoInvariants thenBranch = true := + Stmt.loopHasNoInvariants_branch_then h_lhni_head + have h_lhni_else : Block.loopHasNoInvariants elseBranch = true := + Stmt.loopHasNoInvariants_branch_else h_lhni_head + have h_nml_head : Stmt.noMeasureLoops (.ite (.det e) thenBranch elseBranch md) = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).1 + have h_nml_rest : Block.noMeasureLoops rest = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).2 + have h_nml_then : Block.noMeasureLoops thenBranch = true := + Stmt.noMeasureLoops_branch_then h_nml_head + have h_nml_else : Block.noMeasureLoops elseBranch = true := + Stmt.noMeasureLoops_branch_else h_nml_head have h_unique_then : Block.uniqueInits thenBranch := Block.uniqueInits.ite_then h_unique have h_unique_else : Block.uniqueInits elseBranch := @@ -6769,6 +6924,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have ⟨σ_cfg_branch, h_then_step, h_agree_branch, h_preserve_branch⟩ := stmtsToBlocks_simulation_to_cont extendEval kNext thenBranch exitConts [] gen_ite gen_t tl tbs h_then_eq h_nofd_then h_simple_then h_unique_then + h_lbni_then h_lhni_then h_nml_then ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ' label bk_target h_label hwfb hwfv hwf_def hwf_congr hwf_var h_then_exit h_accum_nil_t h_agree_after @@ -6806,6 +6962,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have ⟨σ_cfg_branch, h_else_step, h_agree_branch, h_preserve_branch⟩ := stmtsToBlocks_simulation_to_cont extendEval kNext elseBranch exitConts [] gen_t gen_e fl fbs h_else_eq h_nofd_else h_simple_else h_unique_else + h_lbni_else h_lhni_else h_nml_else ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ' label bk_target h_label hwfb hwfv hwf_def hwf_congr hwf_var h_else_exit h_accum_nil_f h_agree_after @@ -6867,6 +7024,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have ⟨σ_branch, h_then_step, h_agree_then, h_preserve_then⟩ := stmtsToBlocks_simulation extendEval kNext thenBranch exitConts [] gen_ite gen_t tl tbs h_then_eq h_nofd_then h_simple_then h_unique_then + h_lbni_then h_lhni_then h_nml_then ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_mid hwfb hwfv hwf_def hwf_congr hwf_var h_then_term h_accum_nil_t h_agree_after @@ -6914,7 +7072,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (fun x hx s heq => h_then_no_gen_suffix x (List.mem_append_right _ hx) s heq) have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_mid.store σ_branch ρ_mid.hasFailure false + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest ρ_mid.store σ_branch ρ_mid.hasFailure false ρ_mid ρ' label bk_target h_label hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_exit h_accum_nil_r h_agree_then @@ -6965,6 +7124,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have ⟨σ_branch, h_else_step, h_agree_else, h_preserve_else⟩ := stmtsToBlocks_simulation extendEval kNext elseBranch exitConts [] gen_t gen_e fl fbs h_else_eq h_nofd_else h_simple_else h_unique_else + h_lbni_else h_lhni_else h_nml_else ρ₀.store σ_cfg_after ρ₀.hasFailure false ρ₀ ρ_mid hwfb hwfv hwf_def hwf_congr hwf_var h_else_term h_accum_nil_f h_agree_after @@ -7011,7 +7171,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (fun x hx s heq => h_else_no_gen_suffix x (List.mem_append_right _ hx) s heq) have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsNext - h_rest_eq h_nofd_rest h_simple_rest h_unique_rest ρ_mid.store σ_branch ρ_mid.hasFailure false + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest ρ_mid.store σ_branch ρ_mid.hasFailure false ρ_mid ρ' label bk_target h_label hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ h_rest_exit h_accum_nil_r h_agree_else @@ -7051,13 +7212,390 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has exact h_preserve_rest x h_σ_branch_x h_nil_not h_x_not_rest h_inner_guard_r | .ite .nondet _ _ _ :: _ => exact absurd (Block.simpleShape_cons_iff.mp h_simple).1 (by simp [Stmt.simpleShape]) - | .loop _ _ _ _ _ :: _ => - exact absurd (Block.simpleShape_cons_iff.mp h_simple).1 (by simp [Stmt.simpleShape]) + | .loop guard measure invariants body md :: rest => + -- SORRY-SITE: LoopArm.loop_arm_simulation_to_cont + -- The .loop arm of stmtsToBlocks_simulation_to_cont. Discharged via + -- the framework helper LoopArm.loop_arm_simulation_to_cont declared + -- below the mutual block. + sorry termination_by sizeOf ss decreasing_by all_goals (subst h_match; simp_wf; omega) end +/-! ## Loop simulation framework + +These framework helpers close the `.loop` arms of `stmtsToBlocks_simulation` +and `stmtsToBlocks_simulation_to_cont` under the three new restrictions +`Block.loopBodyNoInits`, `Block.loopHasNoInvariants`, and +`Block.noMeasureLoops`. Each helper has a real signature naming the +`StepDetCFGStar` / `StoreAgreement` / preservation conclusion that the loop +arm needs; the body of each helper is currently `sorry` and will be closed +in a follow-up wave. + +The structure follows the path-b smoke-test framework but adapted to +small-step: + +* `loop_iterations_det` — given a structured trace of `.loop` to terminal, + produce a CFG `StepDetCFGStar` from `lentry` to `kNext`. The inner + per-iteration callback `h_body_sim_at` carries the body simulation and + threads `h_eval_eq : ρ_iter.eval = ρ_pre.eval` through the recursive + iterations. +* `loop_iterations_nondet` — analog for `.nondet` guards (currently rejected + by `simpleShape`, kept for future expansion). +* `peel_off_one_iteration_det` — decomposes a structured `.loop` trace at + the boundary of a single iteration (pure structured-side, no CFG terms). +* `loop_det_decompose_h_gen` / `loop_nondet_decompose_h_gen` — decompose + the translator's monadic state for the `.loop` arm into the components + (kNext, bsNext, lentry, bl, bbs, accum*) needed by the arm. Under + `loopHasNoInvariants` (so `invCmds = []`) and `noMeasureLoops` (so + `decreaseBlocks = []`), the layout simplifies to + `accumBlocks ++ [(lentry, condGoto)] ++ bbs ++ bsNext`. +* `loop_arm_simulation` / `loop_arm_simulation_to_cont` — top-level loop + arm wrappers that consume the new precondition trio and produce the + arm's `∃ σ_cfg, StepDetCFGStar … ∧ StoreAgreement … ∧ preservation` + conjunction. -/ + +namespace LoopArm + +/-- Pure structured-side decomposition of a `.loop` trace into a single +peeled iteration plus the residual loop trace. Independent of the CFG. -/ +private theorem peel_off_one_iteration_det {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + (extendEval : ExtendEval P) + (g : P.Expr) + (invariants : List (String × P.Expr)) + (body : List (Stmt P (Cmd P))) + (md : MetaData P) + (ρ_pre ρ_post : Env P) + (h_cond_tt : ρ_pre.eval ρ_pre.store g = .some HasBool.tt) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) .none invariants body md) ρ_pre) + (.terminal ρ_post)) : + ∃ ρ_inner, + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_pre) (.terminal ρ_inner) ∧ + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) .none invariants body md) ρ_inner) + (.terminal ρ_post) := by + -- SORRY-SITE: LoopArm.peel_off_one_iteration_det + sorry + +/-- Single-iteration CFG step under `loopBodyNoInits` + `loopHasNoInvariants` ++ `noMeasureLoops`: `lentry → bl → ... → lentry`. + +Under `loopHasNoInvariants`, the `lentry` block's `cmds = []`, so the +`condGoto` transitions immediately. Under `noMeasureLoops`, there is no +measure-decrease block to traverse. Under `loopBodyNoInits`, the body has +no init commands so iter-2 doesn't get stuck on duplicate `.init`. -/ +private theorem step_loop_iteration_det {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + (extendEval : ExtendEval P) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (lentry kNext bl : String) + (g : P.Expr) + (lentryBlk : DetBlock String (Cmd P) P) + (md : MetaData P) + (σ_cfg_pre : SemanticStore P) + (hf : Bool) + (h_lentry_lookup : cfg.blocks.lookup lentry = some lentryBlk) + (h_lentryBlk_cmds_nil : lentryBlk.cmds = []) + (h_lentryBlk_transfer : + lentryBlk.transfer = .condGoto g bl kNext md) + (δ : SemanticEval P) + (h_cond_tt : δ σ_cfg_pre g = .some HasBool.tt) + (σ_cfg_after_body : SemanticStore P) + (h_body_step : StepDetCFGStar extendEval cfg + (.atBlock bl σ_cfg_pre hf) + (.atBlock lentry σ_cfg_after_body hf)) : + StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre hf) + (.atBlock lentry σ_cfg_after_body hf) := by + -- SORRY-SITE: LoopArm.step_loop_iteration_det + sorry + +/-- The Nat-bounded inner induction over the `.loop` trace length. + +Iteratively applies `step_loop_iteration_det` to compose `n` body steps, +then applies the loop-exit step (`condGoto false → kNext`). Threads +`h_eval_eq : ρ_iter.eval = ρ_pre.eval` through every iteration so that the +body simulation callback can be invoked at each step. -/ +private theorem loop_iterations_det {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + (extendEval : ExtendEval P) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (lentry kNext bl : String) + (g : P.Expr) + (invariants : List (String × P.Expr)) + (body : List (Stmt P (Cmd P))) + (md transferMd : MetaData P) + (lentryBlk : DetBlock String (Cmd P) P) + (σ_cfg_pre : SemanticStore P) + (hf : Bool) + (ρ_pre ρ_post_loop : Env P) + (h_lentry_lookup : cfg.blocks.lookup lentry = some lentryBlk) + (h_lentryBlk_cmds_nil : lentryBlk.cmds = []) + (h_lentryBlk_transfer : + lentryBlk.transfer = .condGoto g bl kNext transferMd) + (h_invs_nil : invariants = []) + (h_agree_pre : StoreAgreement ρ_pre.store σ_cfg_pre) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) .none invariants body md) ρ_pre) + (.terminal ρ_post_loop)) + (h_body_sim_at : ∀ ρ_iter σ_cfg_iter, + ρ_iter.eval = ρ_pre.eval → + StoreAgreement ρ_iter.store σ_cfg_iter → + ρ_iter.eval σ_cfg_iter g = .some HasBool.tt → + ∀ ρ_body, StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_iter) (.terminal ρ_body) → + ∃ σ_cfg_after_body, StepDetCFGStar extendEval cfg + (.atBlock bl σ_cfg_iter hf) + (.atBlock lentry σ_cfg_after_body hf) ∧ + StoreAgreement ρ_body.store σ_cfg_after_body) : + ∃ σ_cfg_post, StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre hf) + (.atBlock kNext σ_cfg_post hf) ∧ + StoreAgreement ρ_post_loop.store σ_cfg_post ∧ + ρ_post_loop.eval = ρ_pre.eval := by + -- SORRY-SITE: LoopArm.loop_iterations_det + sorry + +/-- Decomposition of the translator's monadic state for the `.loop` arm +under `(.det g)` guard, `noMeasureLoops` (so measure-cmds and +decrease-blocks are empty), and `loopHasNoInvariants` (so invariant +commands are empty). + +This packages the existential witnesses produced by destructuring +`stmtsToBlocks k (.loop ... :: rest)`. -/ +private theorem loop_det_decompose_h_gen {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + (k : String) (rest : List (Stmt P (Cmd P))) + (g : P.Expr) + (body : List (Stmt P (Cmd P))) + (md : MetaData P) + (exitConts : List (Option String × String)) + (accum : List (Cmd P)) + (gen gen' : StringGenState) + (entry : String) + (blocks : DetBlocks String (Cmd P) P) + (h_gen : + stmtsToBlocks k (.loop (.det g) .none [] body md :: rest) exitConts accum gen + = ((entry, blocks), gen')) : + ∃ kNext bsNext lentry bl bbs gen_r gen_lentry gen_b accumEntry accumBlocks gen_f, + stmtsToBlocks k rest exitConts [] gen = ((kNext, bsNext), gen_r) ∧ + StringGenState.gen "loop_entry$" gen_r = (lentry, gen_lentry) ∧ + stmtsToBlocks lentry body ((.none, kNext) :: exitConts) [] gen_lentry + = ((bl, bbs), gen_b) ∧ + flushCmds (P := P) (CmdT := Cmd P) "before_loop$" accum .none lentry gen_b + = ((accumEntry, accumBlocks), gen_f) ∧ + entry = accumEntry ∧ + blocks = accumBlocks ++ + [(lentry, { cmds := [], + transfer := .condGoto g bl kNext md })] ++ bbs ++ bsNext ∧ + gen' = gen_f := by + -- SORRY-SITE: LoopArm.loop_det_decompose_h_gen + sorry + +/-- Top-level loop-arm wrapper for `stmtsToBlocks_simulation`. + +Handles the `.loop (.det g) .none [] body md :: rest` arm. The structured +execution either exits the loop normally (terminal) or via an `.exit` +inside the body (which is caught by the `(.none, kNext) :: exitConts` +prepend, so it terminates at `kNext`). + +Discharge strategy: +1. Apply `loop_det_decompose_h_gen` to extract the translator's components. +2. Use `loop_iterations_det` to produce the CFG simulation from `lentry` + to `kNext`, supplying the body simulation as the per-iteration callback + (the body callback is the recursive `stmtsToBlocks_simulation` call + passed in via the `body_sim` hypothesis). +3. Compose the flush prefix (accum) with the loop-iteration star. +4. Recurse on `rest` via `rest_sim`. -/ +private theorem loop_arm_simulation {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] + [LawfulHasIntOrder P] [LawfulHasNot P] + (extendEval : ExtendEval P) + (k : String) + (g : P.Expr) + (body : List (Stmt P (Cmd P))) + (md : MetaData P) + (rest : List (Stmt P (Cmd P))) + (exitConts : List (Option String × String)) + (accum : List (Cmd P)) + (gen gen' : StringGenState) + (entry : String) + (blocks : DetBlocks String (Cmd P) P) + (h_gen : (stmtsToBlocks k (.loop (.det g) .none [] body md :: rest) exitConts accum gen) + = ((entry, blocks), gen')) + (h_nofd : Block.noFuncDecl (.loop (.det g) .none [] body md :: rest) = true) + (h_simple : Block.simpleShape (.loop (.det g) .none [] body md :: rest) = true) + (h_unique : Block.uniqueInits (.loop (.det g) .none [] body md :: rest)) + (h_lbni : Block.loopBodyNoInits (.loop (.det g) .none [] body md :: rest) = true) + (h_lhni : Block.loopHasNoInvariants (.loop (.det g) .none [] body md :: rest) = true) + (h_nml : Block.noMeasureLoops (.loop (.det g) .none [] body md :: rest) = true) + (σ_struct_base σ_base : SemanticStore P) + (hf_base hf_accum : Bool) + (ρ₀ ρ' : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts (.loop (.det g) .none [] body md :: rest) ρ₀) (.terminal ρ')) + (h_accum : EvalCmds P (EvalCmd P) ρ₀.eval σ_struct_base accum.reverse ρ₀.store hf_accum) + (h_agree_entry : StoreAgreement σ_struct_base σ_base) + (h_fresh_combined : + ∀ x ∈ Cmds.definedVars accum.reverse ++ + Block.initVars (.loop (.det g) .none [] body md :: rest), σ_base x = none) + (h_unique_combined : + (Cmds.definedVars accum.reverse ++ + Block.initVars (.loop (.det g) .none [] body md :: rest)).Nodup) + (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) + (h_wf_gen : StringGenState.WF gen) + (h_combined_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ + Block.initVars (.loop (.det g) .none [] body md :: rest))) + (h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ + transformBlockModVars (.loop (.det g) .none [] body md :: rest))) + (h_combined_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ + Block.getVars (.loop (.det g) .none [] body md :: rest))) + (genUpperBound : StringGenState) + (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) + (h_store_no_gens_upper : ∀ x : String, + String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_base (HasIdent.ident (P := P) x) = none) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (h_cfg_blocks : ∀ b ∈ blocks, b ∈ cfg.blocks) + (h_cfg_nodup : (cfg.blocks.map Prod.fst).Nodup) : + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock entry σ_base hf_base) + (.atBlock k σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg + ∧ (∀ x, σ_base x = none → + x ∉ Cmds.definedVars accum.reverse → + x ∉ Block.initVars (.loop (.det g) .none [] body md :: rest) → + (∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen') → + σ_cfg x = none) := by + -- SORRY-SITE: LoopArm.loop_arm_simulation + -- Closure plan: + -- 1. Apply `loop_det_decompose_h_gen` to extract `kNext`, `bsNext`, + -- `lentry`, `bl`, `bbs`, `accumEntry`, `accumBlocks`, `gen_*`. + -- 2. Lift `accum` to the CFG via `EvalCmds_under_agreement`, producing + -- `σ_cfg_after`. + -- 3. Step from `accumEntry = entry` to `lentry` via the flush helper + -- (`flushCmds_simulation_agree`). + -- 4. Apply `loop_iterations_det` with the per-iteration callback being + -- the recursive `stmtsToBlocks_simulation` body call (legal because + -- the body recursion is on `body`, which is structurally smaller + -- than the outer `.loop _ ... :: rest`). + -- 5. Recurse on `rest` via `stmtsToBlocks_simulation` for the post-loop + -- continuation. + -- 6. Compose the steps and discharge freshness via `h_preserve_*` + -- callbacks. + sorry + +/-- Top-level loop-arm wrapper for `stmtsToBlocks_simulation_to_cont`. + +Same shape as `loop_arm_simulation` but produces an `.exiting` → +`.atBlock bk_target` simulation: the structured loop exits via `.exit l` +inside `body`, with `l` matching some entry in the outer `exitConts`. -/ +private theorem loop_arm_simulation_to_cont {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] + [LawfulHasIntOrder P] [LawfulHasNot P] + (extendEval : ExtendEval P) + (k : String) + (g : P.Expr) + (body : List (Stmt P (Cmd P))) + (md : MetaData P) + (rest : List (Stmt P (Cmd P))) + (exitConts : List (Option String × String)) + (accum : List (Cmd P)) + (gen gen' : StringGenState) + (entry : String) + (blocks : DetBlocks String (Cmd P) P) + (h_gen : (stmtsToBlocks k (.loop (.det g) .none [] body md :: rest) exitConts accum gen) + = ((entry, blocks), gen')) + (h_nofd : Block.noFuncDecl (.loop (.det g) .none [] body md :: rest) = true) + (h_simple : Block.simpleShape (.loop (.det g) .none [] body md :: rest) = true) + (h_unique : Block.uniqueInits (.loop (.det g) .none [] body md :: rest)) + (h_lbni : Block.loopBodyNoInits (.loop (.det g) .none [] body md :: rest) = true) + (h_lhni : Block.loopHasNoInvariants (.loop (.det g) .none [] body md :: rest) = true) + (h_nml : Block.noMeasureLoops (.loop (.det g) .none [] body md :: rest) = true) + (σ_struct_base σ_base : SemanticStore P) + (hf_base hf_accum : Bool) + (ρ₀ ρ' : Env P) + (label : String) (bk_target : String) + (h_label : exitConts.lookup (some label) = some bk_target) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (h_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts (.loop (.det g) .none [] body md :: rest) ρ₀) (.exiting label ρ')) + (h_accum : EvalCmds P (EvalCmd P) ρ₀.eval σ_struct_base accum.reverse ρ₀.store hf_accum) + (h_agree_entry : StoreAgreement σ_struct_base σ_base) + (h_fresh_combined : + ∀ x ∈ Cmds.definedVars accum.reverse ++ + Block.initVars (.loop (.det g) .none [] body md :: rest), σ_base x = none) + (h_unique_combined : + (Cmds.definedVars accum.reverse ++ + Block.initVars (.loop (.det g) .none [] body md :: rest)).Nodup) + (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) + (h_wf_gen : StringGenState.WF gen) + (h_combined_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ + Block.initVars (.loop (.det g) .none [] body md :: rest))) + (h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ + transformBlockModVars (.loop (.det g) .none [] body md :: rest))) + (h_combined_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ + Block.getVars (.loop (.det g) .none [] body md :: rest))) + (genUpperBound : StringGenState) + (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) + (h_store_no_gens_upper : ∀ x : String, + String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_base (HasIdent.ident (P := P) x) = none) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (h_cfg_blocks : ∀ b ∈ blocks, b ∈ cfg.blocks) + (h_cfg_nodup : (cfg.blocks.map Prod.fst).Nodup) : + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock entry σ_base hf_base) + (.atBlock bk_target σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg + ∧ (∀ x, σ_base x = none → + x ∉ Cmds.definedVars accum.reverse → + x ∉ Block.initVars (.loop (.det g) .none [] body md :: rest) → + (∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ + s ∉ StringGenState.stringGens gen') → + σ_cfg x = none) := by + -- SORRY-SITE: LoopArm.loop_arm_simulation_to_cont + -- Same closure plan as `loop_arm_simulation`, except the body must + -- exit via the fresh `(.none, kNext)` exit-cont prepend, which forces + -- the body to terminate at `kNext`, NOT at `bk_target`. Then the loop + -- structurally cannot exit via `bk_target` because the cmd-list inside + -- the loop body cannot transitively reach the outer label without going + -- through the inner `kNext` jump first. + sorry + +end LoopArm + /-- Variant of `stmtsToBlocks_simulation` for when the structured execution "exits". Under the `exitsCoveredByBlocks` invariant such an execution is impossible, so the conclusion holds vacuously. -/ @@ -7203,6 +7741,9 @@ theorem stmtsToCFG_terminal {P : PureExpr} [HasFvar P] [HasNot P] (h_nofd : Block.noFuncDecl ss = true) (h_simple : Block.simpleShape ss = true) (h_unique : Block.uniqueInits ss) + (h_lbni : Block.loopBodyNoInits ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) (h_fresh_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) (h_disj : ∀ gen', Block.userLabelsDisjoint ss gen') (h_store_clean : ∀ ident : P.Ident, ρ₀.store ident = none) @@ -7254,7 +7795,8 @@ theorem stmtsToCFG_terminal {P : PureExpr} [HasFvar P] [HasNot P] ρ₀.store (HasIdent.ident (P := P) x) = none := fun x _ _ => h_store_clean _ have ⟨σ_cfg, h_sim, h_agree, _h_preserve⟩ := stmtsToBlocks_simulation extendEval lend ss [] [] gen gen' entry blocks - h_gen h_nofd h_simple h_unique ρ₀.store ρ₀.store false false ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var + h_gen h_nofd h_simple h_unique h_lbni h_lhni h_nml + ρ₀.store ρ₀.store false false ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var h_term h_accum (StoreAgreement.refl _) h_fresh_combined h_unique_combined h_hf h_wf_gen h_combined_no_gen_suffix h_combined_no_gen_suffix_mod h_combined_no_gen_suffix_get @@ -7308,6 +7850,9 @@ theorem structuredToUnstructured_sound {P : PureExpr} [HasFvar P] [HasNot P] (h_nofd : Block.noFuncDecl ss = true) (h_simple : Block.simpleShape ss = true) (h_unique : Block.uniqueInits ss) + (h_lbni : Block.loopBodyNoInits ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) (h_fresh_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) (h_disj : ∀ gen', Block.userLabelsDisjoint ss gen') (h_store_clean : ∀ ident : P.Ident, ρ₀.store ident = none) @@ -7323,7 +7868,8 @@ theorem structuredToUnstructured_sound {P : PureExpr} [HasFvar P] [HasNot P] ∧ StoreAgreement ρ'.store σ_cfg := stmtsToCFG_terminal extendEval ss ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var hf₀ - h_nofd h_simple h_unique h_fresh_inits h_disj h_store_clean h_input_no_gen_suffix + h_nofd h_simple h_unique h_lbni h_lhni h_nml + h_fresh_inits h_disj h_store_clean h_input_no_gen_suffix h_input_no_gen_suffix_mod h_input_no_gen_suffix_get h_term end StructuredToUnstructuredCorrect From 4979a641161931cdf0e36be996f9258ac20eebb9 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 9 Jun 2026 16:58:28 -0700 Subject: [PATCH 03/33] =?UTF-8?q?wip(pause):=20v3=20inline=20loop-arm=20?= =?UTF-8?q?=E2=80=94=20mid-implementation=20checkpoint?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Paused workflow wf_174290ca-040 (task wxh3di8mi) during the Implement phase. State is intentionally incomplete but builds green. Done: - simpleShape strengthened to det-only loops (Stmt.lean) - LoopArm namespace deleted; helpers being ported inline - loop_det_decompose_h_gen monadic-chain decomposition mostly wired Remaining (4 sorries, 0 axioms, build green): - L4243/4244: gen-threading equalities in the decompose helper (`gen_kn = gen_r`; the skeleton's fictional "kNext$" gen step needs removal) - L4968: terminal .loop arm — iteration-induction infra (decompose + peel_off_one_iteration + loop_iterations_det) ported to small-step - L7342: _to_cont .loop arm — same iteration-induction gap, exit variant Resume by relaunching the v3 workflow with resumeFromRunId so cached Setup/Understand return instantly and Implement picks up from here. --- Strata/DL/Imperative/Stmt.lean | 24 +- .../StructuredToUnstructuredCorrect.lean | 512 +++++------------- 2 files changed, 152 insertions(+), 384 deletions(-) diff --git a/Strata/DL/Imperative/Stmt.lean b/Strata/DL/Imperative/Stmt.lean index a62d679488..440af248c0 100644 --- a/Strata/DL/Imperative/Stmt.lean +++ b/Strata/DL/Imperative/Stmt.lean @@ -206,6 +206,7 @@ pattern the CFG cannot replicate. -/ Predicate stating that a statement or block has a "simple" shape suitable for the structured-to-CFG soundness proof under axiom-free assumptions: - no nondeterministic `.ite` +- no nondeterministic `.loop` guards (only `.det _` loops are admitted) - `.loop` is permitted **provided its body is itself simple-shape**. Auxiliary predicates `loopBodyNoInits`, `loopHasNoInvariants`, and `noMeasureLoops` further restrict which loops are admissible for the @@ -224,7 +225,8 @@ mutual | .block _ bss _ => Block.simpleShape bss | .ite (.det _) tss ess _ => Block.simpleShape tss && Block.simpleShape ess | .ite .nondet _ _ _ => false - | .loop _ _ _ bss _ => Block.simpleShape bss + | .loop guard _ _ bss _ => + (match guard with | .det _ => true | .nondet => false) && Block.simpleShape bss | .exit _ _ => true | .funcDecl _ _ => true | .typeDecl _ _ => true @@ -278,8 +280,24 @@ theorem Stmt.simpleShape_loop_body {md : MetaData P} : Stmt.simpleShape (.loop g m is body md) = true → Block.simpleShape body = true := by - simp only [Stmt.simpleShape] - intro h; exact h + intro h + unfold Stmt.simpleShape at h + cases g with + | det ge => simpa using h + | nondet => simp at h + +/-- The guard of a simple-shape `.loop` is deterministic. -/ +theorem Stmt.simpleShape_loop_guard_det + {g : ExprOrNondet P} {m : Option P.Expr} + {is : List (String × P.Expr)} {body : List (Stmt P (Cmd P))} + {md : MetaData P} : + Stmt.simpleShape (.loop g m is body md) = true → + ∃ ge, g = .det ge := by + intro h + unfold Stmt.simpleShape at h + cases g with + | det ge => exact ⟨ge, rfl⟩ + | nondet => simp at h --------------------------------------------------------------------- diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index da77acf3bb..7e7821c614 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4166,6 +4166,85 @@ private theorem typeDecl_arm_combined_lemmas {P : PureExpr} fun x hx s heq => h_no_m x (h_m ▸ hx) s heq, fun x hx s heq => h_no_g x (h_g ▸ hx) s heq⟩ +/-! ### InlineLoopHelpers + +Non-recursive helpers that the inlined `.loop` arm proofs in +`stmtsToBlocks_simulation` / `stmtsToBlocks_simulation_to_cont` rely on. + +These helpers MUST NOT call `stmtsToBlocks_simulation` or +`stmtsToBlocks_simulation_to_cont` (those are inside the mutual block +below). Helpers may freely use CFG semantics, small-step stmt semantics, +and any prior file-level lemmas. -/ + +namespace InlineLoopHelpers + +/-- Decompose `h_gen` for the +`.loop (.det g) none [] body md :: rest` arm of the translator. +Splits the monadic state-thread into named witnesses for each generation +step, plus equalities matching the translator's output shape. + +Specialized to `measure = .none` and `invariants = []` (the only forms +admitted under `noMeasureLoops` and `loopHasNoInvariants`). Under these +preconditions: `measureCmds = []`, `decreaseBlocks = []`, `invCmds = []`, +`bodyK = lentry`, `contractMd = md`. The block list is +`accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ bsRest` where +`bsRest`'s entry label is `kNext`. -/ +theorem loop_det_decompose_h_gen + {P : PureExpr} [HasFvar P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] + [LawfulHasIntOrder P] [LawfulHasNot P] + (k : String) (gen gen' : StringGenState) + (entry : String) (blocks : List (String × DetBlock String (Cmd P) P)) + (accum : List (Cmd P)) + (g : P.Expr) (body : List (Stmt P (Cmd P))) (md : MetaData P) + (exitConts : List (Option String × String)) + (rest : List (Stmt P (Cmd P))) + (h_gen : stmtsToBlocks k (.loop (.det g) none [] body md :: rest) + exitConts accum gen = ((entry, blocks), gen')) : + ∃ kNext lentry bl bbs bsRest accumEntry accumBlocks, + ∃ gen_kn gen_le gen_b gen_r gen_f, + StringGenState.gen "kNext$" gen = (kNext, gen_kn) ∧ + StringGenState.gen "loop_entry$" gen_kn = (lentry, gen_le) ∧ + stmtsToBlocks k rest exitConts [] gen = ((kNext, bsRest), gen_kn) ∧ + stmtsToBlocks lentry body ((.none, kNext) :: exitConts) [] gen_le + = ((bl, bbs), gen_b) ∧ + flushCmds (P := P) (CmdT := Cmd P) "before_loop$" accum .none lentry gen_b + = ((accumEntry, accumBlocks), gen_f) ∧ + gen_f = gen' ∧ + accumEntry = entry ∧ + gen_r = gen_b ∧ + let lentryBlk : DetBlock String (Cmd P) P := + { cmds := [], + transfer := DetTransferCmd.condGoto g bl kNext md } + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ bsRest = blocks := by + -- Provide all witness terms as projections so the witness equations + -- become `rfl`. For the structural part we compute via the translator. + -- Translator order: rest first, then loop_entry, then body, then flush. + let restStep := stmtsToBlocks k rest exitConts [] gen + let kNext := restStep.1.1 + let bsRest := restStep.1.2 + let gen_kn := restStep.2 + let lentry := (StringGenState.gen "loop_entry$" gen_kn).1 + let gen_le := (StringGenState.gen "loop_entry$" gen_kn).2 + let body_step := stmtsToBlocks lentry body ((none, kNext) :: exitConts) [] gen_le + let bl := body_step.1.1 + let bbs := body_step.1.2 + let gen_b := body_step.2 + let flushStep := @flushCmds P (Cmd P) _ "before_loop$" accum Option.none lentry gen_b + let accumEntry := flushStep.1.1 + let accumBlocks := flushStep.1.2 + let gen_f := flushStep.2 + have h_kn_eq : StringGenState.gen "kNext$" gen = (kNext, gen_kn) := by + -- The translator generates "kNext$" but actually `kNext` is stmtsToBlocks's + -- output entry label. The skeleton's "kNext$" gen step is *fictional*; the + -- translator's `let (kNext, bsNext) ← stmtsToBlocks k rest ...` simply + -- threads `gen` through `rest` directly. So `gen_kn = gen_r`. + sorry + sorry + +end InlineLoopHelpers + set_option maxHeartbeats 3200000 in set_option maxRecDepth 4096 in mutual @@ -4860,11 +4939,32 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] | .ite .nondet _ _ _ :: _ => exact absurd (Block.simpleShape_cons_iff.mp h_simple).1 (by simp [Stmt.simpleShape]) | .loop guard measure invariants body md :: rest => - -- SORRY-SITE: LoopArm.loop_arm_simulation - -- The .loop arm of stmtsToBlocks_simulation. Discharged via the - -- framework helper LoopArm.loop_arm_simulation declared below the - -- mutual block; that helper takes the body and rest simulation calls - -- as callbacks. + -- Subdispatch on guard: .nondet is excluded by strengthened simpleShape. + -- Only `.det _` reaches the main proof. + have h_simple_head : Stmt.simpleShape (.loop guard measure invariants body md) = true := + (Block.simpleShape_cons_iff.mp h_simple).1 + have ⟨guardExpr, hg_eq⟩ : ∃ ge, guard = .det ge := + Stmt.simpleShape_loop_guard_det h_simple_head + subst hg_eq + -- Subdispatch on measure: only `.none` is admitted by noMeasureLoops. + have h_nml_head : Stmt.noMeasureLoops (.loop (.det guardExpr) measure invariants body md) = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).1 + have h_measure_none : measure = .none := by + simp only [Stmt.noMeasureLoops, Bool.and_eq_true, Option.isNone_iff_eq_none] at h_nml_head + exact h_nml_head.1 + subst h_measure_none + -- Subdispatch on invariants: only `[]` is admitted by loopHasNoInvariants. + have h_lhni_head : Stmt.loopHasNoInvariants + (.loop (.det guardExpr) (none : Option P.Expr) invariants body md) = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).1 + have h_invs_nil : invariants = [] := + Stmt.loopHasNoInvariants_loop_invs h_lhni_head + subst h_invs_nil + -- Now we have `.loop (.det guardExpr) none [] body md :: rest` to handle. + -- The full structural simulation requires extensive helper infrastructure + -- (loop_det_decompose_h_gen, peel_off_one_iteration_det, loop_iterations_det) + -- ported to small-step semantics, plus the inline iteration induction + -- with body/rest recursion. This is the residual obstacle. sorry | .block label body md :: rest => simp only [stmtsToBlocks, bind, StateT.bind, pure, StateT.pure] at h_gen @@ -7213,388 +7313,38 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has | .ite .nondet _ _ _ :: _ => exact absurd (Block.simpleShape_cons_iff.mp h_simple).1 (by simp [Stmt.simpleShape]) | .loop guard measure invariants body md :: rest => - -- SORRY-SITE: LoopArm.loop_arm_simulation_to_cont - -- The .loop arm of stmtsToBlocks_simulation_to_cont. Discharged via - -- the framework helper LoopArm.loop_arm_simulation_to_cont declared - -- below the mutual block. + -- Subdispatch on guard: .nondet is excluded by strengthened simpleShape. + have h_simple_head : Stmt.simpleShape (.loop guard measure invariants body md) = true := + (Block.simpleShape_cons_iff.mp h_simple).1 + have ⟨guardExpr, hg_eq⟩ : ∃ ge, guard = .det ge := + Stmt.simpleShape_loop_guard_det h_simple_head + subst hg_eq + -- Subdispatch on measure: only `.none` is admitted by noMeasureLoops. + have h_nml_head : Stmt.noMeasureLoops (.loop (.det guardExpr) measure invariants body md) = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).1 + have h_measure_none : measure = .none := by + simp only [Stmt.noMeasureLoops, Bool.and_eq_true, Option.isNone_iff_eq_none] at h_nml_head + exact h_nml_head.1 + subst h_measure_none + -- Subdispatch on invariants: only `[]` is admitted by loopHasNoInvariants. + have h_lhni_head : Stmt.loopHasNoInvariants + (.loop (.det guardExpr) (none : Option P.Expr) invariants body md) = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).1 + have h_invs_nil : invariants = [] := + Stmt.loopHasNoInvariants_loop_invs h_lhni_head + subst h_invs_nil + -- Now we have `.loop (.det guardExpr) none [] body md :: rest` to handle + -- in the _to_cont arm. The body is wrapped in `.block .none ρ.store ...` + -- so the loop itself never produces an `.exiting`; instead `rest` exits + -- with `label` and we route through the post-loop continuation. This + -- residual obstacle inherits the same iteration-induction infrastructure + -- gap as the terminal arm. sorry termination_by sizeOf ss decreasing_by all_goals (subst h_match; simp_wf; omega) end -/-! ## Loop simulation framework - -These framework helpers close the `.loop` arms of `stmtsToBlocks_simulation` -and `stmtsToBlocks_simulation_to_cont` under the three new restrictions -`Block.loopBodyNoInits`, `Block.loopHasNoInvariants`, and -`Block.noMeasureLoops`. Each helper has a real signature naming the -`StepDetCFGStar` / `StoreAgreement` / preservation conclusion that the loop -arm needs; the body of each helper is currently `sorry` and will be closed -in a follow-up wave. - -The structure follows the path-b smoke-test framework but adapted to -small-step: - -* `loop_iterations_det` — given a structured trace of `.loop` to terminal, - produce a CFG `StepDetCFGStar` from `lentry` to `kNext`. The inner - per-iteration callback `h_body_sim_at` carries the body simulation and - threads `h_eval_eq : ρ_iter.eval = ρ_pre.eval` through the recursive - iterations. -* `loop_iterations_nondet` — analog for `.nondet` guards (currently rejected - by `simpleShape`, kept for future expansion). -* `peel_off_one_iteration_det` — decomposes a structured `.loop` trace at - the boundary of a single iteration (pure structured-side, no CFG terms). -* `loop_det_decompose_h_gen` / `loop_nondet_decompose_h_gen` — decompose - the translator's monadic state for the `.loop` arm into the components - (kNext, bsNext, lentry, bl, bbs, accum*) needed by the arm. Under - `loopHasNoInvariants` (so `invCmds = []`) and `noMeasureLoops` (so - `decreaseBlocks = []`), the layout simplifies to - `accumBlocks ++ [(lentry, condGoto)] ++ bbs ++ bsNext`. -* `loop_arm_simulation` / `loop_arm_simulation_to_cont` — top-level loop - arm wrappers that consume the new precondition trio and produce the - arm's `∃ σ_cfg, StepDetCFGStar … ∧ StoreAgreement … ∧ preservation` - conjunction. -/ - -namespace LoopArm - -/-- Pure structured-side decomposition of a `.loop` trace into a single -peeled iteration plus the residual loop trace. Independent of the CFG. -/ -private theorem peel_off_one_iteration_det {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] - (extendEval : ExtendEval P) - (g : P.Expr) - (invariants : List (String × P.Expr)) - (body : List (Stmt P (Cmd P))) - (md : MetaData P) - (ρ_pre ρ_post : Env P) - (h_cond_tt : ρ_pre.eval ρ_pre.store g = .some HasBool.tt) - (h_term : StepStmtStar P (EvalCmd P) extendEval - (.stmt (.loop (.det g) .none invariants body md) ρ_pre) - (.terminal ρ_post)) : - ∃ ρ_inner, - StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_pre) (.terminal ρ_inner) ∧ - StepStmtStar P (EvalCmd P) extendEval - (.stmt (.loop (.det g) .none invariants body md) ρ_inner) - (.terminal ρ_post) := by - -- SORRY-SITE: LoopArm.peel_off_one_iteration_det - sorry - -/-- Single-iteration CFG step under `loopBodyNoInits` + `loopHasNoInvariants` -+ `noMeasureLoops`: `lentry → bl → ... → lentry`. - -Under `loopHasNoInvariants`, the `lentry` block's `cmds = []`, so the -`condGoto` transitions immediately. Under `noMeasureLoops`, there is no -measure-decrease block to traverse. Under `loopBodyNoInits`, the body has -no init commands so iter-2 doesn't get stuck on duplicate `.init`. -/ -private theorem step_loop_iteration_det {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] - (extendEval : ExtendEval P) - (cfg : CFG String (DetBlock String (Cmd P) P)) - (lentry kNext bl : String) - (g : P.Expr) - (lentryBlk : DetBlock String (Cmd P) P) - (md : MetaData P) - (σ_cfg_pre : SemanticStore P) - (hf : Bool) - (h_lentry_lookup : cfg.blocks.lookup lentry = some lentryBlk) - (h_lentryBlk_cmds_nil : lentryBlk.cmds = []) - (h_lentryBlk_transfer : - lentryBlk.transfer = .condGoto g bl kNext md) - (δ : SemanticEval P) - (h_cond_tt : δ σ_cfg_pre g = .some HasBool.tt) - (σ_cfg_after_body : SemanticStore P) - (h_body_step : StepDetCFGStar extendEval cfg - (.atBlock bl σ_cfg_pre hf) - (.atBlock lentry σ_cfg_after_body hf)) : - StepDetCFGStar extendEval cfg - (.atBlock lentry σ_cfg_pre hf) - (.atBlock lentry σ_cfg_after_body hf) := by - -- SORRY-SITE: LoopArm.step_loop_iteration_det - sorry - -/-- The Nat-bounded inner induction over the `.loop` trace length. - -Iteratively applies `step_loop_iteration_det` to compose `n` body steps, -then applies the loop-exit step (`condGoto false → kNext`). Threads -`h_eval_eq : ρ_iter.eval = ρ_pre.eval` through every iteration so that the -body simulation callback can be invoked at each step. -/ -private theorem loop_iterations_det {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] - (extendEval : ExtendEval P) - (cfg : CFG String (DetBlock String (Cmd P) P)) - (lentry kNext bl : String) - (g : P.Expr) - (invariants : List (String × P.Expr)) - (body : List (Stmt P (Cmd P))) - (md transferMd : MetaData P) - (lentryBlk : DetBlock String (Cmd P) P) - (σ_cfg_pre : SemanticStore P) - (hf : Bool) - (ρ_pre ρ_post_loop : Env P) - (h_lentry_lookup : cfg.blocks.lookup lentry = some lentryBlk) - (h_lentryBlk_cmds_nil : lentryBlk.cmds = []) - (h_lentryBlk_transfer : - lentryBlk.transfer = .condGoto g bl kNext transferMd) - (h_invs_nil : invariants = []) - (h_agree_pre : StoreAgreement ρ_pre.store σ_cfg_pre) - (h_term : StepStmtStar P (EvalCmd P) extendEval - (.stmt (.loop (.det g) .none invariants body md) ρ_pre) - (.terminal ρ_post_loop)) - (h_body_sim_at : ∀ ρ_iter σ_cfg_iter, - ρ_iter.eval = ρ_pre.eval → - StoreAgreement ρ_iter.store σ_cfg_iter → - ρ_iter.eval σ_cfg_iter g = .some HasBool.tt → - ∀ ρ_body, StepStmtStar P (EvalCmd P) extendEval - (.stmts body ρ_iter) (.terminal ρ_body) → - ∃ σ_cfg_after_body, StepDetCFGStar extendEval cfg - (.atBlock bl σ_cfg_iter hf) - (.atBlock lentry σ_cfg_after_body hf) ∧ - StoreAgreement ρ_body.store σ_cfg_after_body) : - ∃ σ_cfg_post, StepDetCFGStar extendEval cfg - (.atBlock lentry σ_cfg_pre hf) - (.atBlock kNext σ_cfg_post hf) ∧ - StoreAgreement ρ_post_loop.store σ_cfg_post ∧ - ρ_post_loop.eval = ρ_pre.eval := by - -- SORRY-SITE: LoopArm.loop_iterations_det - sorry - -/-- Decomposition of the translator's monadic state for the `.loop` arm -under `(.det g)` guard, `noMeasureLoops` (so measure-cmds and -decrease-blocks are empty), and `loopHasNoInvariants` (so invariant -commands are empty). - -This packages the existential witnesses produced by destructuring -`stmtsToBlocks k (.loop ... :: rest)`. -/ -private theorem loop_det_decompose_h_gen {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] - (k : String) (rest : List (Stmt P (Cmd P))) - (g : P.Expr) - (body : List (Stmt P (Cmd P))) - (md : MetaData P) - (exitConts : List (Option String × String)) - (accum : List (Cmd P)) - (gen gen' : StringGenState) - (entry : String) - (blocks : DetBlocks String (Cmd P) P) - (h_gen : - stmtsToBlocks k (.loop (.det g) .none [] body md :: rest) exitConts accum gen - = ((entry, blocks), gen')) : - ∃ kNext bsNext lentry bl bbs gen_r gen_lentry gen_b accumEntry accumBlocks gen_f, - stmtsToBlocks k rest exitConts [] gen = ((kNext, bsNext), gen_r) ∧ - StringGenState.gen "loop_entry$" gen_r = (lentry, gen_lentry) ∧ - stmtsToBlocks lentry body ((.none, kNext) :: exitConts) [] gen_lentry - = ((bl, bbs), gen_b) ∧ - flushCmds (P := P) (CmdT := Cmd P) "before_loop$" accum .none lentry gen_b - = ((accumEntry, accumBlocks), gen_f) ∧ - entry = accumEntry ∧ - blocks = accumBlocks ++ - [(lentry, { cmds := [], - transfer := .condGoto g bl kNext md })] ++ bbs ++ bsNext ∧ - gen' = gen_f := by - -- SORRY-SITE: LoopArm.loop_det_decompose_h_gen - sorry - -/-- Top-level loop-arm wrapper for `stmtsToBlocks_simulation`. - -Handles the `.loop (.det g) .none [] body md :: rest` arm. The structured -execution either exits the loop normally (terminal) or via an `.exit` -inside the body (which is caught by the `(.none, kNext) :: exitConts` -prepend, so it terminates at `kNext`). - -Discharge strategy: -1. Apply `loop_det_decompose_h_gen` to extract the translator's components. -2. Use `loop_iterations_det` to produce the CFG simulation from `lentry` - to `kNext`, supplying the body simulation as the per-iteration callback - (the body callback is the recursive `stmtsToBlocks_simulation` call - passed in via the `body_sim` hypothesis). -3. Compose the flush prefix (accum) with the loop-iteration star. -4. Recurse on `rest` via `rest_sim`. -/ -private theorem loop_arm_simulation {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] - [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] - [LawfulHasIntOrder P] [LawfulHasNot P] - (extendEval : ExtendEval P) - (k : String) - (g : P.Expr) - (body : List (Stmt P (Cmd P))) - (md : MetaData P) - (rest : List (Stmt P (Cmd P))) - (exitConts : List (Option String × String)) - (accum : List (Cmd P)) - (gen gen' : StringGenState) - (entry : String) - (blocks : DetBlocks String (Cmd P) P) - (h_gen : (stmtsToBlocks k (.loop (.det g) .none [] body md :: rest) exitConts accum gen) - = ((entry, blocks), gen')) - (h_nofd : Block.noFuncDecl (.loop (.det g) .none [] body md :: rest) = true) - (h_simple : Block.simpleShape (.loop (.det g) .none [] body md :: rest) = true) - (h_unique : Block.uniqueInits (.loop (.det g) .none [] body md :: rest)) - (h_lbni : Block.loopBodyNoInits (.loop (.det g) .none [] body md :: rest) = true) - (h_lhni : Block.loopHasNoInvariants (.loop (.det g) .none [] body md :: rest) = true) - (h_nml : Block.noMeasureLoops (.loop (.det g) .none [] body md :: rest) = true) - (σ_struct_base σ_base : SemanticStore P) - (hf_base hf_accum : Bool) - (ρ₀ ρ' : Env P) - (hwfb : WellFormedSemanticEvalBool ρ₀.eval) - (hwfv : WellFormedSemanticEvalVal ρ₀.eval) - (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) - (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) - (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) - (h_term : StepStmtStar P (EvalCmd P) extendEval - (.stmts (.loop (.det g) .none [] body md :: rest) ρ₀) (.terminal ρ')) - (h_accum : EvalCmds P (EvalCmd P) ρ₀.eval σ_struct_base accum.reverse ρ₀.store hf_accum) - (h_agree_entry : StoreAgreement σ_struct_base σ_base) - (h_fresh_combined : - ∀ x ∈ Cmds.definedVars accum.reverse ++ - Block.initVars (.loop (.det g) .none [] body md :: rest), σ_base x = none) - (h_unique_combined : - (Cmds.definedVars accum.reverse ++ - Block.initVars (.loop (.det g) .none [] body md :: rest)).Nodup) - (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) - (h_wf_gen : StringGenState.WF gen) - (h_combined_no_gen_suffix : - NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ - Block.initVars (.loop (.det g) .none [] body md :: rest))) - (h_combined_no_gen_suffix_mod : - NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ - transformBlockModVars (.loop (.det g) .none [] body md :: rest))) - (h_combined_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ - Block.getVars (.loop (.det g) .none [] body md :: rest))) - (genUpperBound : StringGenState) - (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) - (h_store_no_gens_upper : ∀ x : String, - String.HasUnderscoreDigitSuffix x → - x ∉ StringGenState.stringGens genUpperBound → - σ_base (HasIdent.ident (P := P) x) = none) - (cfg : CFG String (DetBlock String (Cmd P) P)) - (h_cfg_blocks : ∀ b ∈ blocks, b ∈ cfg.blocks) - (h_cfg_nodup : (cfg.blocks.map Prod.fst).Nodup) : - ∃ σ_cfg, StepDetCFGStar extendEval cfg - (.atBlock entry σ_base hf_base) - (.atBlock k σ_cfg ρ'.hasFailure) - ∧ StoreAgreement ρ'.store σ_cfg - ∧ (∀ x, σ_base x = none → - x ∉ Cmds.definedVars accum.reverse → - x ∉ Block.initVars (.loop (.det g) .none [] body md :: rest) → - (∀ s : String, x = HasIdent.ident (P := P) s → - s ∈ StringGenState.stringGens gen ∨ - s ∉ StringGenState.stringGens gen') → - σ_cfg x = none) := by - -- SORRY-SITE: LoopArm.loop_arm_simulation - -- Closure plan: - -- 1. Apply `loop_det_decompose_h_gen` to extract `kNext`, `bsNext`, - -- `lentry`, `bl`, `bbs`, `accumEntry`, `accumBlocks`, `gen_*`. - -- 2. Lift `accum` to the CFG via `EvalCmds_under_agreement`, producing - -- `σ_cfg_after`. - -- 3. Step from `accumEntry = entry` to `lentry` via the flush helper - -- (`flushCmds_simulation_agree`). - -- 4. Apply `loop_iterations_det` with the per-iteration callback being - -- the recursive `stmtsToBlocks_simulation` body call (legal because - -- the body recursion is on `body`, which is structurally smaller - -- than the outer `.loop _ ... :: rest`). - -- 5. Recurse on `rest` via `stmtsToBlocks_simulation` for the post-loop - -- continuation. - -- 6. Compose the steps and discharge freshness via `h_preserve_*` - -- callbacks. - sorry - -/-- Top-level loop-arm wrapper for `stmtsToBlocks_simulation_to_cont`. - -Same shape as `loop_arm_simulation` but produces an `.exiting` → -`.atBlock bk_target` simulation: the structured loop exits via `.exit l` -inside `body`, with `l` matching some entry in the outer `exitConts`. -/ -private theorem loop_arm_simulation_to_cont {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] - [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] - [LawfulHasIntOrder P] [LawfulHasNot P] - (extendEval : ExtendEval P) - (k : String) - (g : P.Expr) - (body : List (Stmt P (Cmd P))) - (md : MetaData P) - (rest : List (Stmt P (Cmd P))) - (exitConts : List (Option String × String)) - (accum : List (Cmd P)) - (gen gen' : StringGenState) - (entry : String) - (blocks : DetBlocks String (Cmd P) P) - (h_gen : (stmtsToBlocks k (.loop (.det g) .none [] body md :: rest) exitConts accum gen) - = ((entry, blocks), gen')) - (h_nofd : Block.noFuncDecl (.loop (.det g) .none [] body md :: rest) = true) - (h_simple : Block.simpleShape (.loop (.det g) .none [] body md :: rest) = true) - (h_unique : Block.uniqueInits (.loop (.det g) .none [] body md :: rest)) - (h_lbni : Block.loopBodyNoInits (.loop (.det g) .none [] body md :: rest) = true) - (h_lhni : Block.loopHasNoInvariants (.loop (.det g) .none [] body md :: rest) = true) - (h_nml : Block.noMeasureLoops (.loop (.det g) .none [] body md :: rest) = true) - (σ_struct_base σ_base : SemanticStore P) - (hf_base hf_accum : Bool) - (ρ₀ ρ' : Env P) - (label : String) (bk_target : String) - (h_label : exitConts.lookup (some label) = some bk_target) - (hwfb : WellFormedSemanticEvalBool ρ₀.eval) - (hwfv : WellFormedSemanticEvalVal ρ₀.eval) - (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) - (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) - (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) - (h_exit : StepStmtStar P (EvalCmd P) extendEval - (.stmts (.loop (.det g) .none [] body md :: rest) ρ₀) (.exiting label ρ')) - (h_accum : EvalCmds P (EvalCmd P) ρ₀.eval σ_struct_base accum.reverse ρ₀.store hf_accum) - (h_agree_entry : StoreAgreement σ_struct_base σ_base) - (h_fresh_combined : - ∀ x ∈ Cmds.definedVars accum.reverse ++ - Block.initVars (.loop (.det g) .none [] body md :: rest), σ_base x = none) - (h_unique_combined : - (Cmds.definedVars accum.reverse ++ - Block.initVars (.loop (.det g) .none [] body md :: rest)).Nodup) - (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) - (h_wf_gen : StringGenState.WF gen) - (h_combined_no_gen_suffix : - NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ - Block.initVars (.loop (.det g) .none [] body md :: rest))) - (h_combined_no_gen_suffix_mod : - NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ - transformBlockModVars (.loop (.det g) .none [] body md :: rest))) - (h_combined_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ - Block.getVars (.loop (.det g) .none [] body md :: rest))) - (genUpperBound : StringGenState) - (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) - (h_store_no_gens_upper : ∀ x : String, - String.HasUnderscoreDigitSuffix x → - x ∉ StringGenState.stringGens genUpperBound → - σ_base (HasIdent.ident (P := P) x) = none) - (cfg : CFG String (DetBlock String (Cmd P) P)) - (h_cfg_blocks : ∀ b ∈ blocks, b ∈ cfg.blocks) - (h_cfg_nodup : (cfg.blocks.map Prod.fst).Nodup) : - ∃ σ_cfg, StepDetCFGStar extendEval cfg - (.atBlock entry σ_base hf_base) - (.atBlock bk_target σ_cfg ρ'.hasFailure) - ∧ StoreAgreement ρ'.store σ_cfg - ∧ (∀ x, σ_base x = none → - x ∉ Cmds.definedVars accum.reverse → - x ∉ Block.initVars (.loop (.det g) .none [] body md :: rest) → - (∀ s : String, x = HasIdent.ident (P := P) s → - s ∈ StringGenState.stringGens gen ∨ - s ∉ StringGenState.stringGens gen') → - σ_cfg x = none) := by - -- SORRY-SITE: LoopArm.loop_arm_simulation_to_cont - -- Same closure plan as `loop_arm_simulation`, except the body must - -- exit via the fresh `(.none, kNext)` exit-cont prepend, which forces - -- the body to terminate at `kNext`, NOT at `bk_target`. Then the loop - -- structurally cannot exit via `bk_target` because the cmd-list inside - -- the loop body cannot transitively reach the outer label without going - -- through the inner `kNext` jump first. - sorry - -end LoopArm /-- Variant of `stmtsToBlocks_simulation` for when the structured execution "exits". Under the `exitsCoveredByBlocks` invariant such an execution is From aac90d5d0f87c85e44becfc19b27a9ddfc4c0e4e Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 9 Jun 2026 22:40:49 -0700 Subject: [PATCH 04/33] wip(checkpoint): rewrite loop_det_decompose_h_gen to v3 translator shape (no fictional kNext$); 2 sorries remain --- .../StructuredToUnstructuredCorrect.lean | 52 +++++++++++++------ 1 file changed, 37 insertions(+), 15 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 7e7821c614..49cb8cdac8 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4203,17 +4203,15 @@ theorem loop_det_decompose_h_gen (h_gen : stmtsToBlocks k (.loop (.det g) none [] body md :: rest) exitConts accum gen = ((entry, blocks), gen')) : ∃ kNext lentry bl bbs bsRest accumEntry accumBlocks, - ∃ gen_kn gen_le gen_b gen_r gen_f, - StringGenState.gen "kNext$" gen = (kNext, gen_kn) ∧ - StringGenState.gen "loop_entry$" gen_kn = (lentry, gen_le) ∧ - stmtsToBlocks k rest exitConts [] gen = ((kNext, bsRest), gen_kn) ∧ + ∃ gen_r gen_le gen_b gen_f, + stmtsToBlocks k rest exitConts [] gen = ((kNext, bsRest), gen_r) ∧ + StringGenState.gen "loop_entry$" gen_r = (lentry, gen_le) ∧ stmtsToBlocks lentry body ((.none, kNext) :: exitConts) [] gen_le = ((bl, bbs), gen_b) ∧ flushCmds (P := P) (CmdT := Cmd P) "before_loop$" accum .none lentry gen_b = ((accumEntry, accumBlocks), gen_f) ∧ gen_f = gen' ∧ accumEntry = entry ∧ - gen_r = gen_b ∧ let lentryBlk : DetBlock String (Cmd P) P := { cmds := [], transfer := DetTransferCmd.condGoto g bl kNext md } @@ -4224,9 +4222,9 @@ theorem loop_det_decompose_h_gen let restStep := stmtsToBlocks k rest exitConts [] gen let kNext := restStep.1.1 let bsRest := restStep.1.2 - let gen_kn := restStep.2 - let lentry := (StringGenState.gen "loop_entry$" gen_kn).1 - let gen_le := (StringGenState.gen "loop_entry$" gen_kn).2 + let gen_r := restStep.2 + let lentry := (StringGenState.gen "loop_entry$" gen_r).1 + let gen_le := (StringGenState.gen "loop_entry$" gen_r).2 let body_step := stmtsToBlocks lentry body ((none, kNext) :: exitConts) [] gen_le let bl := body_step.1.1 let bbs := body_step.1.2 @@ -4235,13 +4233,37 @@ theorem loop_det_decompose_h_gen let accumEntry := flushStep.1.1 let accumBlocks := flushStep.1.2 let gen_f := flushStep.2 - have h_kn_eq : StringGenState.gen "kNext$" gen = (kNext, gen_kn) := by - -- The translator generates "kNext$" but actually `kNext` is stmtsToBlocks's - -- output entry label. The skeleton's "kNext$" gen step is *fictional*; the - -- translator's `let (kNext, bsNext) ← stmtsToBlocks k rest ...` simply - -- threads `gen` through `rest` directly. So `gen_kn = gen_r`. - sorry - sorry + have h_rest_eq : stmtsToBlocks k rest exitConts [] gen = ((kNext, bsRest), gen_r) := by + show restStep = ((restStep.1.1, restStep.1.2), restStep.2); rfl + have h_le_eq : StringGenState.gen "loop_entry$" gen_r = (lentry, gen_le) := by + show StringGenState.gen "loop_entry$" gen_r + = ((StringGenState.gen "loop_entry$" gen_r).1, (StringGenState.gen "loop_entry$" gen_r).2) + rfl + have h_body_eq : + stmtsToBlocks lentry body ((none, kNext) :: exitConts) [] gen_le = ((bl, bbs), gen_b) := by + show body_step = ((body_step.1.1, body_step.1.2), body_step.2); rfl + have h_flush_eq : + flushCmds (P := P) (CmdT := Cmd P) "before_loop$" accum .none lentry gen_b + = ((accumEntry, accumBlocks), gen_f) := by + show flushStep = ((flushStep.1.1, flushStep.1.2), flushStep.2); rfl + let lentryBlk : DetBlock String (Cmd P) P := + { cmds := ([] : List (Cmd P)), + transfer := DetTransferCmd.condGoto g bl kNext md } + have h_gen_red : + stmtsToBlocks k (.loop (.det g) none [] body md :: rest) exitConts accum gen + = ((accumEntry, accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ bsRest), gen_f) := by + unfold stmtsToBlocks + simp only [bind, StateT.bind, pure, StateT.pure, List.append_nil, + List.nil_append, List.foldl_nil] + rfl + have h_eq_full := h_gen_red.symm.trans h_gen + have h_pair := (Prod.mk.inj h_eq_full).1 + have h_entry_eq : accumEntry = entry := (Prod.mk.inj h_pair).1 + have h_blocks_eq := (Prod.mk.inj h_pair).2 + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_eq_full).2 + exact ⟨kNext, lentry, bl, bbs, bsRest, accumEntry, accumBlocks, + gen_r, gen_le, gen_b, gen_f, + h_rest_eq, h_le_eq, h_body_eq, h_flush_eq, h_gen_eq, h_entry_eq, h_blocks_eq⟩ end InlineLoopHelpers From 8e36e9640ed3af1fe42ff51f5d805bde49583cee Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 9 Jun 2026 22:52:23 -0700 Subject: [PATCH 05/33] wip(checkpoint): add ReflTransT structured peeling helpers (seqT/stmtsT/blockT terminal+exiting) + import all Relations; 2 sorries remain --- .../StructuredToUnstructuredCorrect.lean | 138 ++++++++++++++++++ 1 file changed, 138 insertions(+) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 49cb8cdac8..cd7629e4bb 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -17,6 +17,7 @@ public import Strata.DL.Util.StringGen public import Strata.Languages.Core.StatementSemantics import all Strata.DL.Imperative.BasicBlock import all Strata.DL.Imperative.Cmd +import all Strata.DL.Util.Relations /-! # Structured-to-Unstructured Transformation Correctness @@ -4178,6 +4179,143 @@ and any prior file-level lemmas. -/ namespace InlineLoopHelpers +/-! ### ReflTransT structured-side peeling helpers + +These are length-indexed (Type-valued) variants of the `seq`/`block`/`stmts` +inversion lemmas, used to drive the loop-iteration induction on the structured +derivation length. They are re-declared here (verbatim ports of the `private` +versions in `DetToKleeneCorrect.lean` and the smoke-test) because the upstream +ones are `private`. -/ + +private theorem seqT_reaches_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + {inner : Config P (Cmd P)} {ss : List (Stmt P (Cmd P))} {ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.seq inner ss) (.terminal ρ')) : + ∃ (ρ₁ : Env P), ∃ (h1 : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.terminal ρ₁)), + ∃ (h2 : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmts ss ρ₁) (.terminal ρ')), + h1.len + h2.len < hstar.len := by + match hstar with + | .step _ _ _ (.step_seq_inner h) hrest => + have ⟨ρ₁, hterm, htail, hlen⟩ := seqT_reaches_terminal' extendEval hrest + exact ⟨ρ₁, .step _ _ _ h hterm, htail, by simp [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_seq_done hrest => + exact ⟨_, .refl _, hrest, by show 0 + hrest.len < 1 + hrest.len; omega⟩ + | .step _ _ _ .step_seq_exit hrest => + match hrest with + | .step _ _ _ h _ => exact nomatch h + +private theorem stmtsT_cons_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} {ρ₀ ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmts (s :: rest) ρ₀) (.terminal ρ')) : + ∃ (ρ₁ : Env P), ∃ (h1 : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt s ρ₀) (.terminal ρ₁)), + ∃ (h2 : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmts rest ρ₁) (.terminal ρ')), + h1.len + h2.len + 2 ≤ hstar.len := by + match hstar with + | .step _ _ _ .step_stmts_cons hrest => + have ⟨ρ₁, h1, h2, hlen⟩ := seqT_reaches_terminal' extendEval hrest + exact ⟨ρ₁, h1, h2, by simp [ReflTransT.len]; omega⟩ + +private theorem seqT_reaches_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + {inner : Config P (Cmd P)} {ss : List (Stmt P (Cmd P))} + {label : String} {ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq inner ss) (.exiting label ρ')) : + (∃ (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.exiting label ρ')), + h.len < hstar.len) ∨ + (∃ (ρ₁ : Env P) + (h1 : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.terminal ρ₁)) + (h2 : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmts ss ρ₁) (.exiting label ρ')), + h1.len + h2.len < hstar.len) := by + match hstar with + | .step _ _ _ (.step_seq_inner h) hrest => + match seqT_reaches_exiting' extendEval hrest with + | .inl ⟨hexit, hlen⟩ => + exact .inl ⟨.step _ _ _ h hexit, by simp [ReflTransT.len]; omega⟩ + | .inr ⟨ρ₁, h1, h2, hlen⟩ => + exact .inr ⟨ρ₁, .step _ _ _ h h1, h2, by simp [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_seq_done hrest => + exact .inr ⟨_, .refl _, hrest, by show 0 + hrest.len < 1 + hrest.len; omega⟩ + | .step _ _ _ .step_seq_exit hrest => + match hrest with + | .refl _ => exact .inl ⟨.refl _, by show 0 < 1; omega⟩ + | .step _ _ _ h _ => exact nomatch h + +private theorem stmtsT_cons_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} + {ρ₀ : Env P} {label : String} {ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmts (s :: rest) ρ₀) (.exiting label ρ')) : + (∃ (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt s ρ₀) (.exiting label ρ')), + h.len < hstar.len) ∨ + (∃ (ρ₁ : Env P) + (h1 : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt s ρ₀) (.terminal ρ₁)) + (h2 : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmts rest ρ₁) (.exiting label ρ')), + h1.len + h2.len < hstar.len) := by + match hstar with + | .step _ _ _ .step_stmts_cons hrest => + match seqT_reaches_exiting' extendEval hrest with + | .inl ⟨hexit, hlen⟩ => + exact .inl ⟨hexit, by simp [ReflTransT.len]; omega⟩ + | .inr ⟨ρ₁, h1, h2, hlen⟩ => + exact .inr ⟨ρ₁, h1, h2, by simp [ReflTransT.len]; omega⟩ + +private theorem blockT_none_reaches_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + {inner : Config P (Cmd P)} {σ_parent : SemanticStore P} {ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.block .none σ_parent inner) (.terminal ρ')) : + ∃ (ρ_inner : Env P) (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.terminal ρ_inner)), + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } ∧ + h.len < hstar.len := by + match hstar with + | .step _ (.block _ _ inner₁) _ (.step_block_body h) hrest => + have ⟨ρ_inner, hterm, heq, hlen⟩ := blockT_none_reaches_terminal' extendEval hrest + exact ⟨ρ_inner, .step _ _ _ h hterm, heq, by simp [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_block_done hrest => + match hrest with + | .refl _ => exact ⟨_, .refl _, rfl, by simp [ReflTransT.len]⟩ + | .step _ _ _ h _ => exact nomatch h + | .step _ _ _ (.step_block_exit_match heq) hrest => exact (nomatch heq) + | .step _ _ _ (.step_block_exit_mismatch _) hrest => + match hrest with + | .step _ _ _ h _ => exact nomatch h + +private theorem blockT_none_reaches_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + {inner : Config P (Cmd P)} {σ_parent : SemanticStore P} + {label : String} {ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.block .none σ_parent inner) (.exiting label ρ')) : + ∃ (ρ_inner : Env P) + (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.exiting label ρ_inner)), + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } ∧ + h.len < hstar.len := by + match hstar with + | .step _ (.block _ _ inner₁) _ (.step_block_body h) hrest => + have ⟨ρ_inner, hexit, heq, hlen⟩ := blockT_none_reaches_exiting' extendEval hrest + exact ⟨ρ_inner, .step _ _ _ h hexit, heq, by simp [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_block_done hrest => + match hrest with + | .step _ _ _ h _ => exact nomatch h + | .step _ _ _ (.step_block_exit_match heq) _ => exact (nomatch heq) + | .step _ _ _ (.step_block_exit_mismatch hne) hrest => + match hrest with + | .refl _ => exact ⟨_, .refl _, rfl, by simp [ReflTransT.len]⟩ + | .step _ _ _ h _ => exact nomatch h + /-- Decompose `h_gen` for the `.loop (.det g) none [] body md :: rest` arm of the translator. Splits the monadic state-thread into named witnesses for each generation From 88eb4d4f2973757c8aed7c4fedb11ad2a482273d Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 9 Jun 2026 23:12:48 -0700 Subject: [PATCH 06/33] wip(checkpoint): add loop_iterations_det + peel_off_one_iteration_det/_to_cont + lentry_condGoto helpers (small-step); 2 .loop arm sorries remain --- .../StructuredToUnstructuredCorrect.lean | 304 ++++++++++++++++++ 1 file changed, 304 insertions(+) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index cd7629e4bb..86d908830e 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4403,6 +4403,310 @@ theorem loop_det_decompose_h_gen gen_r, gen_le, gen_b, gen_f, h_rest_eq, h_le_eq, h_body_eq, h_flush_eq, h_gen_eq, h_entry_eq, h_blocks_eq⟩ +/-- Run the (empty-cmds) loop-entry `condGoto` to its true branch: from +`.atBlock lentry σ hf` to `.atBlock bl σ hf`. Bridges the structured guard +`ρ.eval ρ.store g = tt` to the CFG store via `StoreAgreement` + congruence. -/ +private theorem lentry_condGoto_true {P : PureExpr} [HasFvar P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (lentry bl kNext : String) (md : MetaData P) (g : P.Expr) + (δ : SemanticEval P) (σ_struct σ_cfg : SemanticStore P) (hf : Bool) + (h_lkp : cfg.blocks.lookup lentry = some ⟨[], .condGoto g bl kNext md⟩) + (h_agree : StoreAgreement σ_struct σ_cfg) + (hwfb : WellFormedSemanticEvalBool δ) + (h_wf_def : WellFormedSemanticEvalDef δ) + (h_congr : WellFormedSemanticEvalExprCongr δ) + (h_cond : δ σ_struct g = .some HasBool.tt) : + StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg hf) (.atBlock bl σ_cfg hf) := by + have h_def_g : isDefined σ_struct (HasVarsPure.getVars g) := + h_wf_def g HasBool.tt σ_struct h_cond + have h_pointwise : ∀ y ∈ HasVarsPure.getVars g, σ_struct y = σ_cfg y := + store_agreement_pointwise_on_expr_vars σ_struct σ_cfg g h_agree h_def_g + have h_cond_cfg : δ σ_cfg g = .some HasBool.tt := + h_cond ▸ (h_congr g σ_struct σ_cfg h_pointwise).symm + have h_run := run_block_goto_true (extendEval := extendEval) (cfg := cfg) + (f_base := hf) h_lkp (EvalCmds.eval_cmds_none) h_cond_cfg hwfb h_congr + simpa using h_run + +/-- Run the (empty-cmds) loop-entry `condGoto` to its false branch: from +`.atBlock lentry σ hf` to `.atBlock kNext σ hf`. -/ +private theorem lentry_condGoto_false {P : PureExpr} [HasFvar P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (lentry bl kNext : String) (md : MetaData P) (g : P.Expr) + (δ : SemanticEval P) (σ_struct σ_cfg : SemanticStore P) (hf : Bool) + (h_lkp : cfg.blocks.lookup lentry = some ⟨[], .condGoto g bl kNext md⟩) + (h_agree : StoreAgreement σ_struct σ_cfg) + (hwfb : WellFormedSemanticEvalBool δ) + (h_wf_def : WellFormedSemanticEvalDef δ) + (h_congr : WellFormedSemanticEvalExprCongr δ) + (h_cond : δ σ_struct g = .some HasBool.ff) : + StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg hf) (.atBlock kNext σ_cfg hf) := by + have h_def_g : isDefined σ_struct (HasVarsPure.getVars g) := + h_wf_def g HasBool.ff σ_struct h_cond + have h_pointwise : ∀ y ∈ HasVarsPure.getVars g, σ_struct y = σ_cfg y := + store_agreement_pointwise_on_expr_vars σ_struct σ_cfg g h_agree h_def_g + have h_cond_cfg : δ σ_cfg g = .some HasBool.ff := + h_cond ▸ (h_congr g σ_struct σ_cfg h_pointwise).symm + have h_run := run_block_goto_false (extendEval := extendEval) (cfg := cfg) + (f_base := hf) h_lkp (EvalCmds.eval_cmds_none) h_cond_cfg hwfb h_congr + simpa using h_run + +/-- Peel one iteration off a det loop's body+continuation derivation. Given +the `step_loop_enter` continuation `.seq (.block .none ρ_pre.store (.stmts body +ρ_body_init)) [.loop ...]` reaches terminal, decompose into: the body's stmts +run reaches `.terminal ρ_inner`; the block projection produces `ρ_block`; and +the next loop iteration's `.stmt loop ρ_block` derivation reaches the same +terminal with strictly smaller length. Specialized to `inv = []`, `m = none`, +and `ρ_body_init = ρ_pre` (the `|| false` collapse). -/ +private theorem peel_off_one_iteration_det {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (g : P.Expr) (body : List (Stmt P (Cmd P))) (md : MetaData P) + (ρ_pre ρ_post_loop : Env P) + (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ_pre.store + (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false })) + [.loop (.det g) none [] body md]) + (.terminal ρ_post_loop)) : + ∃ (ρ_inner : Env P) (ρ_block : Env P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false }) + (.terminal ρ_inner) ∧ + ρ_block = { ρ_inner with store := projectStore ρ_pre.store ρ_inner.store } ∧ + ∃ (h_inner_T : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (Stmt.loop (.det g) none [] body md) ρ_block) + (.terminal ρ_post_loop)), + h_inner_T.len < hrest.len := by + have ⟨ρ_block_temp, h_block_term, h_loop_stmts, hlen_seq⟩ := + seqT_reaches_terminal' extendEval hrest + have ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_none_reaches_terminal' extendEval h_block_term + have ⟨ρ_x, h_loop_T_T, h_nil, hlen_cons⟩ := + stmtsT_cons_terminal' extendEval h_loop_stmts + have hρ_x_eq : ρ_x = ρ_post_loop := by + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + subst hρ_x_eq + refine ⟨ρ_inner, ρ_block_temp, ?_, heq_ρ_block, h_loop_T_T, ?_⟩ + · exact reflTransT_to_prop h_inner_term + · omega + +/-- `_to_cont` peel for the det loop: given the body+continuation derivation +reaches `.exiting label`, decompose into a `Sum`: either this iteration's body +exits (caseA), or this iteration terminates and the next loop iteration exits +(caseB, with strictly smaller derivation length). -/ +private theorem peel_off_one_iteration_to_cont_det {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (g : P.Expr) (body : List (Stmt P (Cmd P))) (md : MetaData P) + (ρ_pre ρ_post_loop : Env P) (label : String) + (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ_pre.store + (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false })) + [.loop (.det g) none [] body md]) + (.exiting label ρ_post_loop)) : + (∃ ρ_body_exit, + StepStmtStar P (EvalCmd P) extendEval + (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false }) + (.exiting label ρ_body_exit) ∧ + ρ_post_loop = { ρ_body_exit with + store := projectStore ρ_pre.store ρ_body_exit.store }) ∨ + (∃ (ρ_inner : Env P) (ρ_block : Env P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false }) + (.terminal ρ_inner) ∧ + ρ_block = { ρ_inner with store := projectStore ρ_pre.store ρ_inner.store } ∧ + ∃ (h_inner_T : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (Stmt.loop (.det g) none [] body md) ρ_block) + (.exiting label ρ_post_loop)), + h_inner_T.len < hrest.len) := by + match seqT_reaches_exiting' extendEval hrest with + | .inl ⟨h_block_exit, hlen_seq⟩ => + have ⟨ρ_body_exit, h_body_exit_T, heq_ρ_post, hlen_block⟩ := + blockT_none_reaches_exiting' extendEval h_block_exit + exact .inl ⟨ρ_body_exit, reflTransT_to_prop h_body_exit_T, heq_ρ_post⟩ + | .inr ⟨ρ_block_temp, h_block_term, h_loop_stmts, hlen_seq⟩ => + have ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_none_reaches_terminal' extendEval h_block_term + match stmtsT_cons_exiting' extendEval h_loop_stmts with + | .inl ⟨h_loop_T_E, hlen_cons⟩ => + refine .inr ⟨ρ_inner, ρ_block_temp, reflTransT_to_prop h_inner_term, + heq_ρ_block, h_loop_T_E, ?_⟩ + omega + | .inr ⟨ρ_x, h_loop_T_T, h_nil, hlen_cons⟩ => + exfalso + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .step _ _ _ h _ => exact nomatch h + +set_option linter.unusedVariables false in +/-- Iterate the deterministic loop until termination (small-step). Inducts on +the structured-loop derivation length; each iteration consumes a +`step_loop_enter` prefix of `h_term`, leaving a strictly shorter tail. +Base case: `step_loop_exit` (guard false), where lentry's condGoto picks +`kNext`. The CFG side of each iteration is `lentry →(cond true) bl →(body +sim) lentry`; the failure flag tracks `ρ_pre'.hasFailure` per iteration. -/ +private theorem loop_iterations_det + {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] + [LawfulHasIntOrder P] [LawfulHasNot P] + (extendEval : ExtendEval P) + (g : P.Expr) (body : List (Stmt P (Cmd P))) (md : MetaData P) + (ρ_pre ρ_post_loop : Env P) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (lentry kNext bl : String) + (σ_cfg_pre : SemanticStore P) + (h_lentry_lkp : cfg.blocks.lookup lentry = some ⟨[], .condGoto g bl kNext md⟩) + (h_agree_pre : StoreAgreement ρ_pre.store σ_cfg_pre) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) + (.terminal ρ_post_loop)) + (h_body_no_inits : Block.initVars body = []) + (h_nofd_body : Block.noFuncDecl body = true) + (h_body_sim_at : + ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), + ρ_iter.eval = ρ_pre.eval → + StoreAgreement ρ_iter.store σ_cfg_iter → + ∀ (ρ_body : Env P), StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_iter) (.terminal ρ_body) → + ∃ σ_cfg_after_body, + StepDetCFGStar extendEval cfg + (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) + (.atBlock lentry σ_cfg_after_body ρ_body.hasFailure) ∧ + StoreAgreement ρ_body.store σ_cfg_after_body) + (hwfb_pre : WellFormedSemanticEvalBool ρ_pre.eval) + (hwfv_pre : WellFormedSemanticEvalVal ρ_pre.eval) + (hwfvar_pre : WellFormedSemanticEvalVar ρ_pre.eval) + (hwf_def_pre : WellFormedSemanticEvalDef ρ_pre.eval) + (hwfcongr_pre : WellFormedSemanticEvalExprCongr ρ_pre.eval) : + ∃ σ_cfg_kNext, + StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre ρ_pre.hasFailure) + (.atBlock kNext σ_cfg_kNext ρ_post_loop.hasFailure) ∧ + StoreAgreement ρ_post_loop.store σ_cfg_kNext := by + have hT : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) + (.terminal ρ_post_loop) := reflTrans_to_T h_term + suffices h_inner : + ∀ n (ρ_pre' ρ_post' : Env P) (σ_cfg_pre' : SemanticStore P), + ρ_pre'.eval = ρ_pre.eval → + WellFormedSemanticEvalBool ρ_pre'.eval → + WellFormedSemanticEvalDef ρ_pre'.eval → + WellFormedSemanticEvalExprCongr ρ_pre'.eval → + StoreAgreement ρ_pre'.store σ_cfg_pre' → + ∀ (hT' : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre') + (.terminal ρ_post')), + hT'.len ≤ n → + ∃ σ_cfg_kNext', + StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) + (.atBlock kNext σ_cfg_kNext' ρ_post'.hasFailure) ∧ + StoreAgreement ρ_post'.store σ_cfg_kNext' from + h_inner hT.len ρ_pre ρ_post_loop σ_cfg_pre rfl + hwfb_pre hwf_def_pre hwfcongr_pre h_agree_pre hT (Nat.le_refl _) + intro n + induction n with + | zero => + intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' hT' hlen' + match hT', hlen' with + | .step _ _ _ hab hbc, hl => simp [ReflTransT.len] at hl + | succ n ih => + intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' hT' hlen' + match hT', hlen' with + | .step _ _ _ (@StepStmt.step_loop_exit _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure hg_false hinv_eval hff_iff hwfb_step) hrest, hl_succ => + -- BASE CASE: guard false. inv = [], so hasInvFailure = false. + have h_hif : hasInvFailure = false := by + cases hasInvFailure with + | false => rfl + | true => + obtain ⟨le, hle, _⟩ := hff_iff.mp rfl + simp at hle + subst h_hif + have hρ_eq : ρ_post' = ρ_pre' := by + have : ρ_post' = { ρ_pre' with hasFailure := ρ_pre'.hasFailure || false } := by + match hrest with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + simpa using this + subst hρ_eq + refine ⟨σ_cfg_pre', ?_, h_agree'⟩ + exact lentry_condGoto_false extendEval cfg lentry bl kNext md g + ρ_post'.eval ρ_post'.store σ_cfg_pre' ρ_post'.hasFailure h_lentry_lkp h_agree' + hwfb' hwf_def' hwfcongr' hg_false + | .step _ _ _ (@StepStmt.step_loop_enter _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure hg_true hinv_eval hff_iff hwfb_step) hrest, hl_succ => + -- INDUCTIVE CASE: guard true. inv = [], so hasInvFailure = false. + have h_hif : hasInvFailure = false := by + cases hasInvFailure with + | false => rfl + | true => + obtain ⟨le, hle, _⟩ := hff_iff.mp rfl + simp at hle + subst h_hif + -- Peel one iteration off the structured derivation. + have ⟨ρ_inner, ρ_block, h_body_struct, hρ_block_eq, h_inner_T, h_inner_len⟩ := + peel_off_one_iteration_det extendEval g body md ρ_pre' ρ_post' hrest + -- The body runs from ρ_body_init := { ρ_pre' with hasFailure := ρ_pre'.hasFailure || false }. + -- Simplify: ρ_body_init = ρ_pre' (since || false is identity on hasFailure). + have h_body_init_eq : + ({ ρ_pre' with hasFailure := ρ_pre'.hasFailure || false } : Env P) = ρ_pre' := by + simp + rw [h_body_init_eq] at h_body_struct + -- CFG step 1: lentry → bl (guard true). + have h_step_enter : StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) + (.atBlock bl σ_cfg_pre' ρ_pre'.hasFailure) := + lentry_condGoto_true extendEval cfg lentry bl kNext md g + ρ_pre'.eval ρ_pre'.store σ_cfg_pre' ρ_pre'.hasFailure h_lentry_lkp h_agree' + hwfb' hwf_def' hwfcongr' hg_true + -- CFG step 2: bl → lentry (body sim). + have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body⟩ := + h_body_sim_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' ρ_inner h_body_struct + -- ρ_block = { ρ_inner with store := projectStore ρ_pre'.store ρ_inner.store }. + -- Block.initVars body = [], so projection leaves the store agreement intact. + have h_agree_block : StoreAgreement ρ_block.store σ_cfg_after_body := + StoreAgreement.through_projectStore hρ_block_eq h_agree_after_body + have h_hf_block : ρ_block.hasFailure = ρ_inner.hasFailure := by rw [hρ_block_eq] + have hρ_block_eval : ρ_block.eval = ρ_pre'.eval := by + rw [hρ_block_eq] + show ρ_inner.eval = ρ_pre'.eval + have := smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval body + ρ_pre' ρ_inner h_nofd_body h_body_struct + rw [this] + have h_eval_eq_block : ρ_block.eval = ρ_pre.eval := by + rw [hρ_block_eval]; exact h_eval_eq + have hwfb_block : WellFormedSemanticEvalBool ρ_block.eval := by + rw [hρ_block_eval]; exact hwfb' + have hwf_def_block : WellFormedSemanticEvalDef ρ_block.eval := by + rw [hρ_block_eval]; exact hwf_def' + have hwfcongr_block : WellFormedSemanticEvalExprCongr ρ_block.eval := by + rw [hρ_block_eval]; exact hwfcongr' + have h_inner_le_n : h_inner_T.len ≤ n := by + simp [ReflTransT.len] at hl_succ; omega + -- Recurse on the next iteration. + have ⟨σ_cfg_kNext, h_run_recurse, h_agree_post⟩ := + ih ρ_block ρ_post' σ_cfg_after_body h_eval_eq_block + hwfb_block hwf_def_block hwfcongr_block + h_agree_block h_inner_T h_inner_le_n + refine ⟨σ_cfg_kNext, ?_, h_agree_post⟩ + -- Compose: lentry → bl → lentry → ... → kNext. + -- Transport h_run_recurse's start flag ρ_block.hasFailure to ρ_inner.hasFailure. + rw [h_hf_block] at h_run_recurse + exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_enter h_step_body) h_run_recurse + end InlineLoopHelpers set_option maxHeartbeats 3200000 in From 55f8180ea6fc53bf5bae8c61ea8ff86bad89f524 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 9 Jun 2026 23:19:00 -0700 Subject: [PATCH 07/33] wip(checkpoint): add loop_iterations_to_cont_det helper (exit variant); 2 .loop arm sorries remain --- .../StructuredToUnstructuredCorrect.lean | 156 ++++++++++++++++++ 1 file changed, 156 insertions(+) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 86d908830e..d7c1169e6a 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4707,6 +4707,162 @@ private theorem loop_iterations_det rw [h_hf_block] at h_run_recurse exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_enter h_step_body) h_run_recurse +set_option linter.unusedVariables false in +/-- `_to_cont` iteration helper for the det loop: the loop runs some number of +terminating iterations, then on some iteration the body exits with `label`, +propagating out of the surrounding `.block .none` and hence out of the loop. +The CFG side runs `lentry →(true) bl →(body terminal sim) lentry` for each +completed iteration, then `lentry →(true) bl →(body _to_cont sim) bk_target` +for the exiting iteration. -/ +private theorem loop_iterations_to_cont_det + {P : PureExpr} [HasFvar P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] + [LawfulHasIntOrder P] [LawfulHasNot P] + (extendEval : ExtendEval P) + (g : P.Expr) (body : List (Stmt P (Cmd P))) (md : MetaData P) + (ρ_pre ρ_post_loop : Env P) (label : String) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (lentry kNext bl bk_target : String) + (σ_cfg_pre : SemanticStore P) + (h_lentry_lkp : cfg.blocks.lookup lentry = some ⟨[], .condGoto g bl kNext md⟩) + (h_agree_pre : StoreAgreement ρ_pre.store σ_cfg_pre) + (h_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) + (.exiting label ρ_post_loop)) + (h_nofd_body : Block.noFuncDecl body = true) + (h_body_sim_at : + ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), + ρ_iter.eval = ρ_pre.eval → + StoreAgreement ρ_iter.store σ_cfg_iter → + ∀ (ρ_body : Env P), StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_iter) (.terminal ρ_body) → + ∃ σ_cfg_after_body, + StepDetCFGStar extendEval cfg + (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) + (.atBlock lentry σ_cfg_after_body ρ_body.hasFailure) ∧ + StoreAgreement ρ_body.store σ_cfg_after_body) + (h_body_sim_exit_at : + ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), + ρ_iter.eval = ρ_pre.eval → + StoreAgreement ρ_iter.store σ_cfg_iter → + ∀ (ρ_body : Env P), StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_iter) (.exiting label ρ_body) → + ∃ σ_cfg_after_body, + StepDetCFGStar extendEval cfg + (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) + (.atBlock bk_target σ_cfg_after_body ρ_body.hasFailure) ∧ + StoreAgreement ρ_body.store σ_cfg_after_body) + (hwfb_pre : WellFormedSemanticEvalBool ρ_pre.eval) + (hwf_def_pre : WellFormedSemanticEvalDef ρ_pre.eval) + (hwfcongr_pre : WellFormedSemanticEvalExprCongr ρ_pre.eval) : + ∃ σ_cfg_bk, + StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre ρ_pre.hasFailure) + (.atBlock bk_target σ_cfg_bk ρ_post_loop.hasFailure) ∧ + StoreAgreement ρ_post_loop.store σ_cfg_bk := by + have hT : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) + (.exiting label ρ_post_loop) := reflTrans_to_T h_exit + suffices h_inner : + ∀ n (ρ_pre' ρ_post' : Env P) (σ_cfg_pre' : SemanticStore P), + ρ_pre'.eval = ρ_pre.eval → + WellFormedSemanticEvalBool ρ_pre'.eval → + WellFormedSemanticEvalDef ρ_pre'.eval → + WellFormedSemanticEvalExprCongr ρ_pre'.eval → + StoreAgreement ρ_pre'.store σ_cfg_pre' → + ∀ (hT' : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre') + (.exiting label ρ_post')), + hT'.len ≤ n → + ∃ σ_cfg_bk', + StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) + (.atBlock bk_target σ_cfg_bk' ρ_post'.hasFailure) ∧ + StoreAgreement ρ_post'.store σ_cfg_bk' from + h_inner hT.len ρ_pre ρ_post_loop σ_cfg_pre rfl + hwfb_pre hwf_def_pre hwfcongr_pre h_agree_pre hT (Nat.le_refl _) + intro n + induction n with + | zero => + intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' hT' hlen' + match hT', hlen' with + | .step _ _ _ hab hbc, hl => simp [ReflTransT.len] at hl + | succ n ih => + intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' hT' hlen' + match hT', hlen' with + | .step _ _ _ (@StepStmt.step_loop_exit _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure hg_false hinv_eval hff_iff hwfb_step) hrest, hl_succ => + -- A loop that exits via guard-false would reach .terminal, not .exiting. + exfalso + match hrest with + | .step _ _ _ h _ => exact nomatch h + | .step _ _ _ (@StepStmt.step_loop_enter _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure hg_true hinv_eval hff_iff hwfb_step) hrest, hl_succ => + have h_hif : hasInvFailure = false := by + cases hasInvFailure with + | false => rfl + | true => + obtain ⟨le, hle, _⟩ := hff_iff.mp rfl + simp at hle + subst h_hif + have h_body_init_eq : + ({ ρ_pre' with hasFailure := ρ_pre'.hasFailure || false } : Env P) = ρ_pre' := by + simp + -- CFG step 1: lentry → bl (guard true). + have h_step_enter : StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) + (.atBlock bl σ_cfg_pre' ρ_pre'.hasFailure) := + lentry_condGoto_true extendEval cfg lentry bl kNext md g + ρ_pre'.eval ρ_pre'.store σ_cfg_pre' ρ_pre'.hasFailure h_lentry_lkp h_agree' + hwfb' hwf_def' hwfcongr' hg_true + rcases peel_off_one_iteration_to_cont_det extendEval g body md ρ_pre' ρ_post' label hrest with + h_caseA | h_caseB + · -- caseA: this iteration's body exits with label. + obtain ⟨ρ_body_exit, h_body_exit_struct, hρ_post_eq⟩ := h_caseA + rw [h_body_init_eq] at h_body_exit_struct + have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body⟩ := + h_body_sim_exit_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' ρ_body_exit h_body_exit_struct + -- ρ_post' = { ρ_body_exit with store := projectStore ρ_pre'.store ρ_body_exit.store }. + have h_agree_post : StoreAgreement ρ_post'.store σ_cfg_after_body := + StoreAgreement.through_projectStore hρ_post_eq h_agree_after_body + have h_hf_post : ρ_post'.hasFailure = ρ_body_exit.hasFailure := by rw [hρ_post_eq] + refine ⟨σ_cfg_after_body, ?_, h_agree_post⟩ + rw [h_hf_post] + exact StepDetCFGStar_trans h_step_enter h_step_body + · -- caseB: this iteration terminates; recurse on next iteration's exit. + obtain ⟨ρ_inner, ρ_block, h_body_struct, hρ_block_eq, h_inner_T, h_inner_len⟩ := h_caseB + rw [h_body_init_eq] at h_body_struct + have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body⟩ := + h_body_sim_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' ρ_inner h_body_struct + have h_agree_block : StoreAgreement ρ_block.store σ_cfg_after_body := + StoreAgreement.through_projectStore hρ_block_eq h_agree_after_body + have h_hf_block : ρ_block.hasFailure = ρ_inner.hasFailure := by rw [hρ_block_eq] + have hρ_block_eval : ρ_block.eval = ρ_pre'.eval := by + rw [hρ_block_eq] + show ρ_inner.eval = ρ_pre'.eval + have := smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval body + ρ_pre' ρ_inner h_nofd_body h_body_struct + rw [this] + have h_eval_eq_block : ρ_block.eval = ρ_pre.eval := by + rw [hρ_block_eval]; exact h_eval_eq + have hwfb_block : WellFormedSemanticEvalBool ρ_block.eval := by + rw [hρ_block_eval]; exact hwfb' + have hwf_def_block : WellFormedSemanticEvalDef ρ_block.eval := by + rw [hρ_block_eval]; exact hwf_def' + have hwfcongr_block : WellFormedSemanticEvalExprCongr ρ_block.eval := by + rw [hρ_block_eval]; exact hwfcongr' + have h_inner_le_n : h_inner_T.len ≤ n := by + simp [ReflTransT.len] at hl_succ; omega + have ⟨σ_cfg_bk, h_run_recurse, h_agree_post⟩ := + ih ρ_block ρ_post' σ_cfg_after_body h_eval_eq_block + hwfb_block hwf_def_block hwfcongr_block + h_agree_block h_inner_T h_inner_le_n + refine ⟨σ_cfg_bk, ?_, h_agree_post⟩ + rw [h_hf_block] at h_run_recurse + exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_enter h_step_body) h_run_recurse + end InlineLoopHelpers set_option maxHeartbeats 3200000 in From f4b690ed65c78d2cfe65cde770e4e6f78e31a9c8 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 9 Jun 2026 23:27:17 -0700 Subject: [PATCH 08/33] wip(checkpoint): strengthen loop_iterations_det with freshVars preservation conjunct; 2 .loop arm sorries remain --- .../StructuredToUnstructuredCorrect.lean | 29 ++++++++++++------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index d7c1169e6a..f83503b56d 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4567,6 +4567,7 @@ private theorem loop_iterations_det (cfg : CFG String (DetBlock String (Cmd P) P)) (lentry kNext bl : String) (σ_cfg_pre : SemanticStore P) + (freshVars : P.Ident → Prop) (h_lentry_lkp : cfg.blocks.lookup lentry = some ⟨[], .condGoto g bl kNext md⟩) (h_agree_pre : StoreAgreement ρ_pre.store σ_cfg_pre) (h_term : StepStmtStar P (EvalCmd P) extendEval @@ -4584,7 +4585,8 @@ private theorem loop_iterations_det StepDetCFGStar extendEval cfg (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) (.atBlock lentry σ_cfg_after_body ρ_body.hasFailure) ∧ - StoreAgreement ρ_body.store σ_cfg_after_body) + StoreAgreement ρ_body.store σ_cfg_after_body ∧ + (∀ x, freshVars x → σ_cfg_iter x = none → σ_cfg_after_body x = none)) (hwfb_pre : WellFormedSemanticEvalBool ρ_pre.eval) (hwfv_pre : WellFormedSemanticEvalVal ρ_pre.eval) (hwfvar_pre : WellFormedSemanticEvalVar ρ_pre.eval) @@ -4594,7 +4596,8 @@ private theorem loop_iterations_det StepDetCFGStar extendEval cfg (.atBlock lentry σ_cfg_pre ρ_pre.hasFailure) (.atBlock kNext σ_cfg_kNext ρ_post_loop.hasFailure) ∧ - StoreAgreement ρ_post_loop.store σ_cfg_kNext := by + StoreAgreement ρ_post_loop.store σ_cfg_kNext ∧ + (∀ x, freshVars x → σ_cfg_pre x = none → σ_cfg_kNext x = none) := by have hT : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) (.terminal ρ_post_loop) := reflTrans_to_T h_term @@ -4613,7 +4616,8 @@ private theorem loop_iterations_det StepDetCFGStar extendEval cfg (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) (.atBlock kNext σ_cfg_kNext' ρ_post'.hasFailure) ∧ - StoreAgreement ρ_post'.store σ_cfg_kNext' from + StoreAgreement ρ_post'.store σ_cfg_kNext' ∧ + (∀ x, freshVars x → σ_cfg_pre' x = none → σ_cfg_kNext' x = none) from h_inner hT.len ρ_pre ρ_post_loop σ_cfg_pre rfl hwfb_pre hwf_def_pre hwfcongr_pre h_agree_pre hT (Nat.le_refl _) intro n @@ -4642,7 +4646,7 @@ private theorem loop_iterations_det | .step _ _ _ h _ => exact nomatch h simpa using this subst hρ_eq - refine ⟨σ_cfg_pre', ?_, h_agree'⟩ + refine ⟨σ_cfg_pre', ?_, h_agree', fun x _ h => h⟩ exact lentry_condGoto_false extendEval cfg lentry bl kNext md g ρ_post'.eval ρ_post'.store σ_cfg_pre' ρ_post'.hasFailure h_lentry_lkp h_agree' hwfb' hwf_def' hwfcongr' hg_false @@ -4673,7 +4677,7 @@ private theorem loop_iterations_det ρ_pre'.eval ρ_pre'.store σ_cfg_pre' ρ_pre'.hasFailure h_lentry_lkp h_agree' hwfb' hwf_def' hwfcongr' hg_true -- CFG step 2: bl → lentry (body sim). - have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body⟩ := + have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body, h_preserve_body⟩ := h_body_sim_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' ρ_inner h_body_struct -- ρ_block = { ρ_inner with store := projectStore ρ_pre'.store ρ_inner.store }. -- Block.initVars body = [], so projection leaves the store agreement intact. @@ -4697,15 +4701,18 @@ private theorem loop_iterations_det have h_inner_le_n : h_inner_T.len ≤ n := by simp [ReflTransT.len] at hl_succ; omega -- Recurse on the next iteration. - have ⟨σ_cfg_kNext, h_run_recurse, h_agree_post⟩ := + have ⟨σ_cfg_kNext, h_run_recurse, h_agree_post, h_preserve_recurse⟩ := ih ρ_block ρ_post' σ_cfg_after_body h_eval_eq_block hwfb_block hwf_def_block hwfcongr_block h_agree_block h_inner_T h_inner_le_n - refine ⟨σ_cfg_kNext, ?_, h_agree_post⟩ - -- Compose: lentry → bl → lentry → ... → kNext. - -- Transport h_run_recurse's start flag ρ_block.hasFailure to ρ_inner.hasFailure. - rw [h_hf_block] at h_run_recurse - exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_enter h_step_body) h_run_recurse + refine ⟨σ_cfg_kNext, ?_, h_agree_post, ?_⟩ + · -- Compose: lentry → bl → lentry → ... → kNext. + -- Transport h_run_recurse's start flag ρ_block.hasFailure to ρ_inner.hasFailure. + rw [h_hf_block] at h_run_recurse + exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_enter h_step_body) h_run_recurse + · -- Freshness: thread through one iteration then the recursion. + intro x h_fresh h_σ_pre + exact h_preserve_recurse x h_fresh (h_preserve_body x h_fresh h_σ_pre) set_option linter.unusedVariables false in /-- `_to_cont` iteration helper for the det loop: the loop runs some number of From e583ce767c3a15a15ea4a9ad15f3f2c1ae0b7cfa Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 00:10:41 -0700 Subject: [PATCH 09/33] wip(checkpoint): close stmtsToBlocks_simulation .loop arm inline (terminal); 1 sorry remains (_to_cont) --- .../StructuredToUnstructuredCorrect.lean | 413 ++++++++++++++++-- 1 file changed, 373 insertions(+), 40 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index f83503b56d..cc4f70c320 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -349,6 +349,12 @@ private theorem transformStmtModVars_typeDecl {P : PureExpr} (tc : TypeConstructor) (md : MetaData P) : transformStmtModVars (P := P) (Stmt.typeDecl tc md : Stmt P (Cmd P)) = [] := rfl +private theorem transformStmtModVars_loop {P : PureExpr} + (c : ExprOrNondet P) (m : Option P.Expr) (is : List (String × P.Expr)) + (body : List (Stmt P (Cmd P))) (md : MetaData P) : + transformStmtModVars (P := P) (Stmt.loop c m is body md) = + transformBlockModVars body := rfl + /-- Single-command agreement-preservation. -/ private theorem EvalCmd_under_agreement {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] @@ -4567,9 +4573,10 @@ private theorem loop_iterations_det (cfg : CFG String (DetBlock String (Cmd P) P)) (lentry kNext bl : String) (σ_cfg_pre : SemanticStore P) - (freshVars : P.Ident → Prop) + (storeInv : SemanticStore P → Prop) (h_lentry_lkp : cfg.blocks.lookup lentry = some ⟨[], .condGoto g bl kNext md⟩) (h_agree_pre : StoreAgreement ρ_pre.store σ_cfg_pre) + (h_inv_pre : storeInv σ_cfg_pre) (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) (.terminal ρ_post_loop)) @@ -4579,6 +4586,7 @@ private theorem loop_iterations_det ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), ρ_iter.eval = ρ_pre.eval → StoreAgreement ρ_iter.store σ_cfg_iter → + storeInv σ_cfg_iter → ∀ (ρ_body : Env P), StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_iter) (.terminal ρ_body) → ∃ σ_cfg_after_body, @@ -4586,7 +4594,7 @@ private theorem loop_iterations_det (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) (.atBlock lentry σ_cfg_after_body ρ_body.hasFailure) ∧ StoreAgreement ρ_body.store σ_cfg_after_body ∧ - (∀ x, freshVars x → σ_cfg_iter x = none → σ_cfg_after_body x = none)) + storeInv σ_cfg_after_body) (hwfb_pre : WellFormedSemanticEvalBool ρ_pre.eval) (hwfv_pre : WellFormedSemanticEvalVal ρ_pre.eval) (hwfvar_pre : WellFormedSemanticEvalVar ρ_pre.eval) @@ -4597,7 +4605,7 @@ private theorem loop_iterations_det (.atBlock lentry σ_cfg_pre ρ_pre.hasFailure) (.atBlock kNext σ_cfg_kNext ρ_post_loop.hasFailure) ∧ StoreAgreement ρ_post_loop.store σ_cfg_kNext ∧ - (∀ x, freshVars x → σ_cfg_pre x = none → σ_cfg_kNext x = none) := by + storeInv σ_cfg_kNext := by have hT : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) (.terminal ρ_post_loop) := reflTrans_to_T h_term @@ -4608,6 +4616,7 @@ private theorem loop_iterations_det WellFormedSemanticEvalDef ρ_pre'.eval → WellFormedSemanticEvalExprCongr ρ_pre'.eval → StoreAgreement ρ_pre'.store σ_cfg_pre' → + storeInv σ_cfg_pre' → ∀ (hT' : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre') (.terminal ρ_post')), @@ -4617,17 +4626,17 @@ private theorem loop_iterations_det (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) (.atBlock kNext σ_cfg_kNext' ρ_post'.hasFailure) ∧ StoreAgreement ρ_post'.store σ_cfg_kNext' ∧ - (∀ x, freshVars x → σ_cfg_pre' x = none → σ_cfg_kNext' x = none) from + storeInv σ_cfg_kNext' from h_inner hT.len ρ_pre ρ_post_loop σ_cfg_pre rfl - hwfb_pre hwf_def_pre hwfcongr_pre h_agree_pre hT (Nat.le_refl _) + hwfb_pre hwf_def_pre hwfcongr_pre h_agree_pre h_inv_pre hT (Nat.le_refl _) intro n induction n with | zero => - intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' hT' hlen' + intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' h_inv' hT' hlen' match hT', hlen' with | .step _ _ _ hab hbc, hl => simp [ReflTransT.len] at hl | succ n ih => - intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' hT' hlen' + intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' h_inv' hT' hlen' match hT', hlen' with | .step _ _ _ (@StepStmt.step_loop_exit _ _ _ _ _ _ _ _ _ _ _ _ hasInvFailure hg_false hinv_eval hff_iff hwfb_step) hrest, hl_succ => @@ -4646,7 +4655,7 @@ private theorem loop_iterations_det | .step _ _ _ h _ => exact nomatch h simpa using this subst hρ_eq - refine ⟨σ_cfg_pre', ?_, h_agree', fun x _ h => h⟩ + refine ⟨σ_cfg_pre', ?_, h_agree', h_inv'⟩ exact lentry_condGoto_false extendEval cfg lentry bl kNext md g ρ_post'.eval ρ_post'.store σ_cfg_pre' ρ_post'.hasFailure h_lentry_lkp h_agree' hwfb' hwf_def' hwfcongr' hg_false @@ -4677,8 +4686,8 @@ private theorem loop_iterations_det ρ_pre'.eval ρ_pre'.store σ_cfg_pre' ρ_pre'.hasFailure h_lentry_lkp h_agree' hwfb' hwf_def' hwfcongr' hg_true -- CFG step 2: bl → lentry (body sim). - have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body, h_preserve_body⟩ := - h_body_sim_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' ρ_inner h_body_struct + have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body, h_inv_after⟩ := + h_body_sim_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' h_inv' ρ_inner h_body_struct -- ρ_block = { ρ_inner with store := projectStore ρ_pre'.store ρ_inner.store }. -- Block.initVars body = [], so projection leaves the store agreement intact. have h_agree_block : StoreAgreement ρ_block.store σ_cfg_after_body := @@ -4701,18 +4710,15 @@ private theorem loop_iterations_det have h_inner_le_n : h_inner_T.len ≤ n := by simp [ReflTransT.len] at hl_succ; omega -- Recurse on the next iteration. - have ⟨σ_cfg_kNext, h_run_recurse, h_agree_post, h_preserve_recurse⟩ := + have ⟨σ_cfg_kNext, h_run_recurse, h_agree_post, h_inv_post⟩ := ih ρ_block ρ_post' σ_cfg_after_body h_eval_eq_block hwfb_block hwf_def_block hwfcongr_block - h_agree_block h_inner_T h_inner_le_n - refine ⟨σ_cfg_kNext, ?_, h_agree_post, ?_⟩ - · -- Compose: lentry → bl → lentry → ... → kNext. - -- Transport h_run_recurse's start flag ρ_block.hasFailure to ρ_inner.hasFailure. - rw [h_hf_block] at h_run_recurse - exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_enter h_step_body) h_run_recurse - · -- Freshness: thread through one iteration then the recursion. - intro x h_fresh h_σ_pre - exact h_preserve_recurse x h_fresh (h_preserve_body x h_fresh h_σ_pre) + h_agree_block h_inv_after h_inner_T h_inner_le_n + refine ⟨σ_cfg_kNext, ?_, h_agree_post, h_inv_post⟩ + -- Compose: lentry → bl → lentry → ... → kNext. + -- Transport h_run_recurse's start flag ρ_block.hasFailure to ρ_inner.hasFailure. + rw [h_hf_block] at h_run_recurse + exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_enter h_step_body) h_run_recurse set_option linter.unusedVariables false in /-- `_to_cont` iteration helper for the det loop: the loop runs some number of @@ -4733,8 +4739,10 @@ private theorem loop_iterations_to_cont_det (cfg : CFG String (DetBlock String (Cmd P) P)) (lentry kNext bl bk_target : String) (σ_cfg_pre : SemanticStore P) + (storeInv : SemanticStore P → Prop) (h_lentry_lkp : cfg.blocks.lookup lentry = some ⟨[], .condGoto g bl kNext md⟩) (h_agree_pre : StoreAgreement ρ_pre.store σ_cfg_pre) + (h_inv_pre : storeInv σ_cfg_pre) (h_exit : StepStmtStar P (EvalCmd P) extendEval (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) (.exiting label ρ_post_loop)) @@ -4743,24 +4751,28 @@ private theorem loop_iterations_to_cont_det ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), ρ_iter.eval = ρ_pre.eval → StoreAgreement ρ_iter.store σ_cfg_iter → + storeInv σ_cfg_iter → ∀ (ρ_body : Env P), StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_iter) (.terminal ρ_body) → ∃ σ_cfg_after_body, StepDetCFGStar extendEval cfg (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) (.atBlock lentry σ_cfg_after_body ρ_body.hasFailure) ∧ - StoreAgreement ρ_body.store σ_cfg_after_body) + StoreAgreement ρ_body.store σ_cfg_after_body ∧ + storeInv σ_cfg_after_body) (h_body_sim_exit_at : ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), ρ_iter.eval = ρ_pre.eval → StoreAgreement ρ_iter.store σ_cfg_iter → + storeInv σ_cfg_iter → ∀ (ρ_body : Env P), StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_iter) (.exiting label ρ_body) → ∃ σ_cfg_after_body, StepDetCFGStar extendEval cfg (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) (.atBlock bk_target σ_cfg_after_body ρ_body.hasFailure) ∧ - StoreAgreement ρ_body.store σ_cfg_after_body) + StoreAgreement ρ_body.store σ_cfg_after_body ∧ + storeInv σ_cfg_after_body) (hwfb_pre : WellFormedSemanticEvalBool ρ_pre.eval) (hwf_def_pre : WellFormedSemanticEvalDef ρ_pre.eval) (hwfcongr_pre : WellFormedSemanticEvalExprCongr ρ_pre.eval) : @@ -4768,7 +4780,8 @@ private theorem loop_iterations_to_cont_det StepDetCFGStar extendEval cfg (.atBlock lentry σ_cfg_pre ρ_pre.hasFailure) (.atBlock bk_target σ_cfg_bk ρ_post_loop.hasFailure) ∧ - StoreAgreement ρ_post_loop.store σ_cfg_bk := by + StoreAgreement ρ_post_loop.store σ_cfg_bk ∧ + storeInv σ_cfg_bk := by have hT : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) (.exiting label ρ_post_loop) := reflTrans_to_T h_exit @@ -4779,6 +4792,7 @@ private theorem loop_iterations_to_cont_det WellFormedSemanticEvalDef ρ_pre'.eval → WellFormedSemanticEvalExprCongr ρ_pre'.eval → StoreAgreement ρ_pre'.store σ_cfg_pre' → + storeInv σ_cfg_pre' → ∀ (hT' : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre') (.exiting label ρ_post')), @@ -4787,17 +4801,18 @@ private theorem loop_iterations_to_cont_det StepDetCFGStar extendEval cfg (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) (.atBlock bk_target σ_cfg_bk' ρ_post'.hasFailure) ∧ - StoreAgreement ρ_post'.store σ_cfg_bk' from + StoreAgreement ρ_post'.store σ_cfg_bk' ∧ + storeInv σ_cfg_bk' from h_inner hT.len ρ_pre ρ_post_loop σ_cfg_pre rfl - hwfb_pre hwf_def_pre hwfcongr_pre h_agree_pre hT (Nat.le_refl _) + hwfb_pre hwf_def_pre hwfcongr_pre h_agree_pre h_inv_pre hT (Nat.le_refl _) intro n induction n with | zero => - intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' hT' hlen' + intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' h_inv' hT' hlen' match hT', hlen' with | .step _ _ _ hab hbc, hl => simp [ReflTransT.len] at hl | succ n ih => - intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' hT' hlen' + intros ρ_pre' ρ_post' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' h_inv' hT' hlen' match hT', hlen' with | .step _ _ _ (@StepStmt.step_loop_exit _ _ _ _ _ _ _ _ _ _ _ _ hasInvFailure hg_false hinv_eval hff_iff hwfb_step) hrest, hl_succ => @@ -4829,20 +4844,20 @@ private theorem loop_iterations_to_cont_det · -- caseA: this iteration's body exits with label. obtain ⟨ρ_body_exit, h_body_exit_struct, hρ_post_eq⟩ := h_caseA rw [h_body_init_eq] at h_body_exit_struct - have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body⟩ := - h_body_sim_exit_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' ρ_body_exit h_body_exit_struct + have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body, h_inv_after⟩ := + h_body_sim_exit_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' h_inv' ρ_body_exit h_body_exit_struct -- ρ_post' = { ρ_body_exit with store := projectStore ρ_pre'.store ρ_body_exit.store }. have h_agree_post : StoreAgreement ρ_post'.store σ_cfg_after_body := StoreAgreement.through_projectStore hρ_post_eq h_agree_after_body have h_hf_post : ρ_post'.hasFailure = ρ_body_exit.hasFailure := by rw [hρ_post_eq] - refine ⟨σ_cfg_after_body, ?_, h_agree_post⟩ + refine ⟨σ_cfg_after_body, ?_, h_agree_post, h_inv_after⟩ rw [h_hf_post] exact StepDetCFGStar_trans h_step_enter h_step_body · -- caseB: this iteration terminates; recurse on next iteration's exit. obtain ⟨ρ_inner, ρ_block, h_body_struct, hρ_block_eq, h_inner_T, h_inner_len⟩ := h_caseB rw [h_body_init_eq] at h_body_struct - have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body⟩ := - h_body_sim_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' ρ_inner h_body_struct + have ⟨σ_cfg_after_body, h_step_body, h_agree_after_body, h_inv_after⟩ := + h_body_sim_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' h_inv' ρ_inner h_body_struct have h_agree_block : StoreAgreement ρ_block.store σ_cfg_after_body := StoreAgreement.through_projectStore hρ_block_eq h_agree_after_body have h_hf_block : ρ_block.hasFailure = ρ_inner.hasFailure := by rw [hρ_block_eq] @@ -4862,11 +4877,11 @@ private theorem loop_iterations_to_cont_det rw [hρ_block_eval]; exact hwfcongr' have h_inner_le_n : h_inner_T.len ≤ n := by simp [ReflTransT.len] at hl_succ; omega - have ⟨σ_cfg_bk, h_run_recurse, h_agree_post⟩ := + have ⟨σ_cfg_bk, h_run_recurse, h_agree_post, h_inv_post⟩ := ih ρ_block ρ_post' σ_cfg_after_body h_eval_eq_block hwfb_block hwf_def_block hwfcongr_block - h_agree_block h_inner_T h_inner_le_n - refine ⟨σ_cfg_bk, ?_, h_agree_post⟩ + h_agree_block h_inv_after h_inner_T h_inner_le_n + refine ⟨σ_cfg_bk, ?_, h_agree_post, h_inv_post⟩ rw [h_hf_block] at h_run_recurse exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_enter h_step_body) h_run_recurse @@ -5588,11 +5603,329 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] Stmt.loopHasNoInvariants_loop_invs h_lhni_head subst h_invs_nil -- Now we have `.loop (.det guardExpr) none [] body md :: rest` to handle. - -- The full structural simulation requires extensive helper infrastructure - -- (loop_det_decompose_h_gen, peel_off_one_iteration_det, loop_iterations_det) - -- ported to small-step semantics, plus the inline iteration induction - -- with body/rest recursion. This is the residual obstacle. - sorry + -- === STEP 1: Decompose h_gen. === + obtain ⟨kNext, lentry, bl, bbs, bsRest, accumEntry, accumBlocks, + gen_r, gen_le, gen_b, gen_f, + h_rest_eq, h_le_eq, h_body_eq, h_flush_eq, h_gen_eq, h_entry_eq, h_blocks_eq⟩ := + InlineLoopHelpers.loop_det_decompose_h_gen k gen gen' entry blocks accum + guardExpr body md exitConts rest h_gen + -- === STEP 2: Project sub-block preconditions. === + have h_body_no_inits : Block.initVars body = [] := + Stmt.loopBodyNoInits_loop_body ((Block.loopBodyNoInits_cons_iff.mp h_lbni).1) + have h_nofd_body : Block.noFuncDecl body = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.1 + have h_nofd_rest : Block.noFuncDecl rest = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.2 + have h_simple_body : Block.simpleShape body = true := + Stmt.simpleShape_loop_body h_simple_head + have h_simple_rest : Block.simpleShape rest = true := + (Block.simpleShape_cons_iff.mp h_simple).2 + have h_unique_body : Block.uniqueInits body := by + have h := Block.uniqueInits.head_stmt h_unique + simp only [Stmt.initVars] at h; exact h + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + have h_lbni_body : Block.loopBodyNoInits body = true := + Stmt.loopBodyNoInits_loop_body_rec ((Block.loopBodyNoInits_cons_iff.mp h_lbni).1) + have h_lbni_rest : Block.loopBodyNoInits rest = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 + have h_lhni_body : Block.loopHasNoInvariants body = true := + Stmt.loopHasNoInvariants_loop_body_rec h_lhni_head + have h_lhni_rest : Block.loopHasNoInvariants rest = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 + have h_nml_body : Block.noMeasureLoops body = true := + Stmt.noMeasureLoops_loop_body_rec h_nml_head + have h_nml_rest : Block.noMeasureLoops rest = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).2 + -- Block.initVars (.loop ... :: rest) = Block.initVars rest (since body has no inits). + have h_initvars_eq : + Block.initVars (Stmt.loop (.det guardExpr) none [] body md :: rest) = + Block.initVars rest := by + rw [Block.initVars]; simp only [Stmt.initVars, h_body_no_inits, List.nil_append] + -- === STEP 3: Split h_term into loop run + rest run. === + have ⟨ρ_loop_post, h_loop_term, h_rest_term⟩ := + stmts_append_terminates P (EvalCmd P) extendEval + [.loop (.det guardExpr) none [] body md] rest ρ₀ ρ' + (by simpa using h_term) + -- Convert loop run from `.stmts [loop]` to `.stmt loop`. + have h_loop_stmt : StepStmtStar P (EvalCmd P) extendEval + (.stmt (Stmt.loop (.det guardExpr) none [] body md) ρ₀) (.terminal ρ_loop_post) := by + cases h_loop_term with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + have ⟨ρ_mid, h_inner, h_nil2⟩ := seq_reaches_terminal P (EvalCmd P) extendEval hrest1 + have h_eq := stmts_nil_terminal (EvalCmd P) extendEval _ _ h_nil2 + subst h_eq; exact h_inner + -- === STEP 3b: GenStep chain gen → gen_r → gen_le → gen_b → gen_f = gen'. === + subst h_entry_eq + subst h_gen_eq + have h_step_gen_to_r : StringGenState.GenStep gen gen_r := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_rest_eq + have h_step_r_to_le : StringGenState.GenStep gen_r gen_le := by + rw [show gen_le = (StringGenState.gen "loop_entry$" gen_r).2 from (by rw [h_le_eq])] + exact StringGenState.GenStep.of_gen "loop_entry$" gen_r + have h_step_le_to_b : StringGenState.GenStep gen_le gen_b := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_body_eq + have h_step_b_to_f : StringGenState.GenStep gen_b gen_f := + flushCmds_genStep _ _ _ _ _ _ _ _ h_flush_eq + have h_step_gen_to_le : StringGenState.GenStep gen gen_le := h_step_gen_to_r.trans h_step_r_to_le + have h_step_gen_to_b : StringGenState.GenStep gen gen_b := h_step_gen_to_le.trans h_step_le_to_b + have h_wf_r : StringGenState.WF gen_r := h_step_gen_to_r.wf_mono h_wf_gen + have h_wf_le : StringGenState.WF gen_le := h_step_gen_to_le.wf_mono h_wf_gen + have h_wf_b : StringGenState.WF gen_b := h_step_gen_to_b.wf_mono h_wf_gen + have h_outer_upper_b : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens genUpperBound := + h_step_b_to_f.subset.trans h_outer_upper + have h_outer_upper_le : StringGenState.stringGens gen_le ⊆ StringGenState.stringGens genUpperBound := + h_step_le_to_b.subset.trans h_outer_upper_b + have h_outer_upper_r : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens genUpperBound := + h_step_r_to_le.subset.trans h_outer_upper_le + -- === STEP 3c: Block-list membership distribution. === + -- blocks = accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ bsRest. + let lentryBlk : DetBlock String (Cmd P) P := + { cmds := ([] : List (Cmd P)), transfer := DetTransferCmd.condGoto guardExpr bl kNext md } + have h_blocks_full : + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ bsRest = blocks := h_blocks_eq + subst h_blocks_full + have h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_left _ (List.mem_append_left _ (List.mem_append_left _ hb))) + have h_cfg_lentry : (lentry, lentryBlk) ∈ cfg.blocks := + h_cfg_blocks _ (List.mem_append_left _ (List.mem_append_left _ + (List.mem_append_right _ (List.Mem.head _)))) + have h_cfg_bbs : ∀ b ∈ bbs, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_left _ (List.mem_append_right _ hb)) + have h_cfg_bsRest : ∀ b ∈ bsRest, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ hb) + have h_lentry_lkp : cfg.blocks.lookup lentry = some lentryBlk := + List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup _ _ h_cfg_lentry + -- === STEP 4: Lift accum to CFG (accumEntry → lentry). === + have h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none := fun x hx => + h_fresh_combined x (List.mem_append_left _ hx) + have h_unique_accum : (Cmds.definedVars accum.reverse).Nodup := + (List.nodup_append.mp h_unique_combined).1 + have ⟨σ_cfg_after, h_step_flush, h_agree_after, h_preserve_flush⟩ := + flushCmds_simulation_agree extendEval "before_loop$" lentry accum gen_b gen_f + accumEntry accumBlocks h_flush_eq σ_struct_base σ_base hf_base hf_accum ρ₀ + hwfb hwfv hwf_def hwf_congr h_accum h_agree_entry h_fresh_accum h_unique_accum + h_hf cfg h_cfg_accum h_cfg_nodup + -- === STEP 5: no-gen-suffix discharges for body and rest. === + -- Block.initVars (.loop... :: rest) = Block.initVars rest, so the loop arm's + -- defined-vars list is rest's. body's defined-vars list is empty. + have h_body_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars body) := by + rw [h_body_no_inits]; intro x hx; simp [Cmds.definedVars] at hx + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + (by simpa [Cmds.definedVars] using hx))) s heq + have h_body_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := + fun x hx s heq => h_combined_no_gen_suffix_mod x + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hx))) s heq + have h_getvars_eq : + Block.getVars (Stmt.loop (.det guardExpr) none [] body md :: rest) = + (HasVarsPure.getVars guardExpr ++ Block.getVars body) ++ Block.getVars rest := by + show Stmt.getVars (Stmt.loop (.det guardExpr) none [] body md) ++ Block.getVars rest = _ + simp only [Stmt.getVars, ExprOrNondet.getVars, List.flatMap_nil, + List.append_nil, List.nil_append] + have h_body_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars body) := + fun x hx s heq => h_combined_no_gen_suffix_get x + (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ + (by simpa [Cmds.getVars] using hx)))) s heq + -- The store invariant threaded through the loop preserves freshness (relative + -- to σ_cfg_after) for any var satisfying the body's gen-guard `P_keep`. Both + -- rest's inits and the outer-call's fresh var satisfy `P_keep`. + let P_keep : P.Ident → Prop := fun x => + ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_le ∨ s ∉ StringGenState.stringGens gen_b + let storeInv : SemanticStore P → Prop := fun σ => + ∀ x, P_keep x → σ_cfg_after x = none → σ x = none + have h_inv_after : storeInv σ_cfg_after := fun x _ h => h + -- === STEP 6: Build the body-sim oracle (recurse on body). === + have h_body_sim_at : + ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), + ρ_iter.eval = ρ₀.eval → + StoreAgreement ρ_iter.store σ_cfg_iter → + storeInv σ_cfg_iter → + ∀ (ρ_body : Env P), StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_iter) (.terminal ρ_body) → + ∃ σ_cfg_after_body, + StepDetCFGStar extendEval cfg + (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) + (.atBlock lentry σ_cfg_after_body ρ_body.hasFailure) ∧ + StoreAgreement ρ_body.store σ_cfg_after_body ∧ + storeInv σ_cfg_after_body := by + intro ρ_iter σ_cfg_iter h_eval_iter h_agree_iter h_inv_iter ρ_body h_body_run + -- WF facts on ρ_iter.eval lifted from ρ₀.eval. + have hwfb_iter : WellFormedSemanticEvalBool ρ_iter.eval := h_eval_iter ▸ hwfb + have hwfv_iter : WellFormedSemanticEvalVal ρ_iter.eval := h_eval_iter ▸ hwfv + have hwf_def_iter : WellFormedSemanticEvalDef ρ_iter.eval := h_eval_iter ▸ hwf_def + have hwf_congr_iter : WellFormedSemanticEvalExprCongr ρ_iter.eval := h_eval_iter ▸ hwf_congr + have hwf_var_iter : WellFormedSemanticEvalVar ρ_iter.eval := h_eval_iter ▸ hwf_var + have h_combined_body : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_iter x = none := by + intro x hx; rw [h_body_no_inits] at hx; simp [Cmds.definedVars] at hx + have h_unique_combined_body : (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + rw [h_body_no_inits]; simp [Cmds.definedVars] + have h_accum_nil : EvalCmds P (EvalCmd P) ρ_iter.eval ρ_iter.store + [].reverse ρ_iter.store false := EvalCmds.eval_cmds_none + have h_hf_iter : ρ_iter.hasFailure = (ρ_iter.hasFailure || false) := by simp + -- The body sim needs its own store-no-gens at gen_b's upper-bound. We use the + -- bound `gen_b` itself: any gen-suffix var outside gen_b's gens that's fresh at + -- σ_cfg_after stays fresh at σ_cfg_iter (storeInv), hence fresh. But we need it + -- at arbitrary gen-suffix x ∉ genUpperBound. Such x satisfy P_keep (s ∉ gen_b + -- because gen_b ⊆ genUpperBound), and are fresh at σ_cfg_after (store_no_gens), + -- so storeInv gives σ_cfg_iter freshness. + have h_sng_iter : ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_iter (HasIdent.ident (P := P) x) = none := by + intro x hx_sfx hx_notin + have h_keep : P_keep (HasIdent.ident (P := P) x) := by + intro s heq + have hs_eq : x = s := LawfulHasIdent.ident_inj heq + subst hs_eq + exact Or.inr (fun h_in_b => hx_notin (h_outer_upper_b h_in_b)) + have h_after_x : σ_cfg_after (HasIdent.ident (P := P) x) = none := by + have := store_no_gens_lift_after_flush h_preserve_flush genUpperBound h_store_no_gens_upper + (fun y hy => h_combined_no_gen_suffix y (List.mem_append_left _ hy)) + exact this x hx_sfx hx_notin + exact h_inv_iter _ h_keep h_after_x + -- Recurse on body. body's k = lentry, exitConts = (.none, kNext) :: exitConts, + -- entry = bl, gen = gen_le, gen' = gen_b. + have ⟨σ_cfg_after_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation extendEval lentry body ((.none, kNext) :: exitConts) [] + gen_le gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body + ρ_iter.store σ_cfg_iter ρ_iter.hasFailure false + ρ_iter ρ_body hwfb_iter hwfv_iter hwf_def_iter hwf_congr_iter hwf_var_iter + h_body_run h_accum_nil h_agree_iter + h_combined_body h_unique_combined_body h_hf_iter + h_wf_le h_body_no_gen_suffix h_body_no_gen_suffix_mod h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b h_sng_iter + cfg h_cfg_bbs h_cfg_nodup + refine ⟨σ_cfg_after_body, h_step_body, h_agree_body, ?_⟩ + -- storeInv preserved: for x with P_keep and σ_cfg_after x = none, derive + -- σ_cfg_after_body x = none from σ_cfg_iter x = none (via storeInv) + body preserve. + intro x h_keep h_after_x + have h_iter_x : σ_cfg_iter x = none := h_inv_iter x h_keep h_after_x + have h_nil_not : x ∉ Cmds.definedVars ([] : List (Cmd P)).reverse := by simp [Cmds.definedVars] + have h_not_body : x ∉ Block.initVars body := by rw [h_body_no_inits]; simp + exact h_preserve_body x h_iter_x h_nil_not h_not_body h_keep + -- store-no-gens at σ_cfg_after (after the flush), reused below. + have h_store_no_gens_upper_after : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_after (HasIdent.ident (P := P) x) = none := + store_no_gens_lift_after_flush h_preserve_flush genUpperBound h_store_no_gens_upper + (fun y hy => h_combined_no_gen_suffix y (List.mem_append_left _ hy)) + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun h_in_accum => + (List.nodup_append.mp (h_initvars_eq ▸ h_unique_combined)).2.2 x h_in_accum x hx rfl + have h_σ_base_x : σ_base x = none := + h_fresh_combined x (h_initvars_eq ▸ List.mem_append_right _ hx) + exact h_preserve_flush x h_σ_base_x h_x_not_accum + -- === STEP 7: Iterate the loop (lentry → kNext). === + have ⟨σ_cfg_kNext, h_loop_run, h_agree_loop, h_inv_loop⟩ := + InlineLoopHelpers.loop_iterations_det extendEval guardExpr body md ρ₀ ρ_loop_post + cfg lentry kNext bl σ_cfg_after storeInv h_lentry_lkp h_agree_after h_inv_after + h_loop_stmt h_body_no_inits h_nofd_body h_body_sim_at + hwfb hwfv hwf_var hwf_def hwf_congr + -- Recover store-no-gens and rest-freshness at σ_cfg_kNext from storeInv. + have h_sng_loop : ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_kNext (HasIdent.ident (P := P) x) = none := by + intro x hx_sfx hx_notin + have h_keep : P_keep (HasIdent.ident (P := P) x) := by + intro s heq + have hs_eq : x = s := LawfulHasIdent.ident_inj heq + subst hs_eq + exact Or.inr (fun h_in_b => hx_notin (h_outer_upper_b h_in_b)) + exact h_inv_loop _ h_keep (h_store_no_gens_upper_after x hx_sfx hx_notin) + have h_fresh_rest_loop : ∀ x ∈ Block.initVars rest, σ_cfg_kNext x = none := by + intro x hx + have h_keep : P_keep x := by + intro s heq + exact Or.inr (fun h_in_b => + StringGenState.not_mem_stringGens_of_not_hasUnderscoreDigitSuffix h_wf_b + (h_rest_no_gen_suffix x (by simpa [Cmds.definedVars] using hx) s heq) h_in_b) + exact h_inv_loop x h_keep (h_fresh_rest_inits_after x hx) + -- ρ_loop_post.eval = ρ₀.eval (loop body has no funcDecls). + have h_eval_loop : ρ_loop_post.eval = ρ₀.eval := by + have := smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + [.loop (.det guardExpr) none [] body md] ρ₀ ρ_loop_post + (by simp [Block.noFuncDecl, Stmt.noFuncDecl, h_nofd_body]) + (by simpa using h_loop_term) + exact this + have hwfb_loop : WellFormedSemanticEvalBool ρ_loop_post.eval := h_eval_loop ▸ hwfb + have hwfv_loop : WellFormedSemanticEvalVal ρ_loop_post.eval := h_eval_loop ▸ hwfv + have hwf_def_loop : WellFormedSemanticEvalDef ρ_loop_post.eval := h_eval_loop ▸ hwf_def + have hwf_congr_loop : WellFormedSemanticEvalExprCongr ρ_loop_post.eval := h_eval_loop ▸ hwf_congr + have hwf_var_loop : WellFormedSemanticEvalVar ρ_loop_post.eval := h_eval_loop ▸ hwf_var + -- === STEP 8: Recurse on rest (kNext → k). === + have h_combined_rest : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_cfg_kNext x = none := fun x hx => + h_fresh_rest_loop x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_rest + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_loop_post.eval ρ_loop_post.store + [].reverse ρ_loop_post.store false := EvalCmds.eval_cmds_none + have h_hf_loop : ρ_loop_post.hasFailure = (ρ_loop_post.hasFailure || false) := by simp + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := + fun x hx s heq => h_combined_no_gen_suffix_mod x + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq + have h_rest_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := + fun x hx s heq => h_combined_no_gen_suffix_get x + (List.mem_append_right _ (by + show x ∈ Stmt.getVars (Stmt.loop (.det guardExpr) none [] body md) ++ Block.getVars rest + exact List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq + have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsRest + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest + ρ_loop_post.store σ_cfg_kNext ρ_loop_post.hasFailure false + ρ_loop_post ρ' hwfb_loop hwfv_loop hwf_def_loop hwf_congr_loop hwf_var_loop + h_rest_term h_accum_nil_r h_agree_loop + h_combined_rest h_unique_combined_rest h_hf_loop + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_sng_loop + cfg h_cfg_bsRest h_cfg_nodup + -- === STEP 9: Compose and discharge. === + refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ + · exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_flush h_loop_run) h_rest_sim + · -- Freshness preservation for the outer call. + intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + -- x ∉ Block.initVars (.loop ... :: rest) = Block.initVars rest. + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + -- x satisfies P_keep: the outer guard gives s ∈ gens gen ∨ s ∉ gens gen'. + -- gen ⊆ gen_le (so s ∈ gen → s ∈ gen_le), and gen_b ⊆ gen' = gen_f (so + -- s ∉ gen' → s ∉ gen_b). Hence the body's gen-guard `s ∈ gen_le ∨ s ∉ gen_b`. + have h_keep : P_keep x := by + intro s heq + rcases h_outer_guard s heq with h_in_gen | h_notin_gen' + · exact Or.inl (h_step_gen_to_le.subset h_in_gen) + · exact Or.inr (fun h_in_b => h_notin_gen' (h_step_b_to_f.subset h_in_b)) + -- The loop preserves x's freshness (storeInv applied to σ_cfg_kNext). + have h_x_fresh_loop : σ_cfg_kNext x = none := h_inv_loop x h_keep h_σ_after_x + -- The rest sim's gen-guard is over gen_r (rest's gen'); weaken from gen_f. + -- gen_r ⊆ gen_f, so s ∉ gen_f → s ∉ gen_r. + have h_guard_rest : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ s ∉ StringGenState.stringGens gen_r := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl h_in + | Or.inr h_notin => Or.inr (fun h_in_r => h_notin + (h_step_b_to_f.subset (h_step_le_to_b.subset (h_step_r_to_le.subset h_in_r)))) + exact h_preserve_rest x h_x_fresh_loop h_nil_not h_x_not_rest h_guard_rest | .block label body md :: rest => simp only [stmtsToBlocks, bind, StateT.bind, pure, StateT.pure] at h_gen -- Decompose the monadic chain From 0762a29f5bfd1c2521f35f0e50b7c5e6c3ee3020 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 00:30:52 -0700 Subject: [PATCH 10/33] feat: close both .loop arm sorries inline (terminal + _to_cont); 0 sorries, 0 axioms, build green --- .../StructuredToUnstructuredCorrect.lean | 374 +++++++++++++++++- 1 file changed, 366 insertions(+), 8 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index cc4f70c320..7a01293f41 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4887,7 +4887,7 @@ private theorem loop_iterations_to_cont_det end InlineLoopHelpers -set_option maxHeartbeats 3200000 in +set_option maxHeartbeats 12800000 in set_option maxRecDepth 4096 in mutual /-- The central simulation lemma, written in a StoreAgreement-based shape. @@ -8293,13 +8293,371 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have h_invs_nil : invariants = [] := Stmt.loopHasNoInvariants_loop_invs h_lhni_head subst h_invs_nil - -- Now we have `.loop (.det guardExpr) none [] body md :: rest` to handle - -- in the _to_cont arm. The body is wrapped in `.block .none ρ.store ...` - -- so the loop itself never produces an `.exiting`; instead `rest` exits - -- with `label` and we route through the post-loop continuation. This - -- residual obstacle inherits the same iteration-induction infrastructure - -- gap as the terminal arm. - sorry + -- === STEP 1: Decompose h_gen. === + obtain ⟨kNext, lentry, bl, bbs, bsRest, accumEntry, accumBlocks, + gen_r, gen_le, gen_b, gen_f, + h_rest_eq, h_le_eq, h_body_eq, h_flush_eq, h_gen_eq, h_entry_eq, h_blocks_eq⟩ := + InlineLoopHelpers.loop_det_decompose_h_gen k gen gen' entry blocks accum + guardExpr body md exitConts rest h_gen + -- === STEP 2: Project sub-block preconditions (same as terminal arm). === + have h_body_no_inits : Block.initVars body = [] := + Stmt.loopBodyNoInits_loop_body ((Block.loopBodyNoInits_cons_iff.mp h_lbni).1) + have h_nofd_body : Block.noFuncDecl body = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.1 + have h_nofd_rest : Block.noFuncDecl rest = true := by + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd; exact h_nofd.2 + have h_simple_body : Block.simpleShape body = true := + Stmt.simpleShape_loop_body h_simple_head + have h_simple_rest : Block.simpleShape rest = true := + (Block.simpleShape_cons_iff.mp h_simple).2 + have h_unique_body : Block.uniqueInits body := by + have h := Block.uniqueInits.head_stmt h_unique + simp only [Stmt.initVars] at h; exact h + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + have h_lbni_body : Block.loopBodyNoInits body = true := + Stmt.loopBodyNoInits_loop_body_rec ((Block.loopBodyNoInits_cons_iff.mp h_lbni).1) + have h_lbni_rest : Block.loopBodyNoInits rest = true := + (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 + have h_lhni_body : Block.loopHasNoInvariants body = true := + Stmt.loopHasNoInvariants_loop_body_rec h_lhni_head + have h_lhni_rest : Block.loopHasNoInvariants rest = true := + (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 + have h_nml_body : Block.noMeasureLoops body = true := + Stmt.noMeasureLoops_loop_body_rec h_nml_head + have h_nml_rest : Block.noMeasureLoops rest = true := + (Block.noMeasureLoops_cons_iff.mp h_nml).2 + have h_initvars_eq : + Block.initVars (Stmt.loop (.det guardExpr) none [] body md :: rest) = + Block.initVars rest := by + rw [Block.initVars]; simp only [Stmt.initVars, h_body_no_inits, List.nil_append] + -- === STEP 3: Split h_exit (loop :: rest exits with label). === + -- Two cases: (a) the loop body exits with label (loop produces .exiting), or + -- (b) the loop terminates, then rest exits with label. + have h_exit_dispatch : + (∃ ρ_loop_post, StepStmtStar P (EvalCmd P) extendEval + (.stmt (Stmt.loop (.det guardExpr) none [] body md) ρ₀) (.exiting label ρ_loop_post) ∧ + ρ' = ρ_loop_post) ∨ + (∃ ρ_loop_post, StepStmtStar P (EvalCmd P) extendEval + (.stmt (Stmt.loop (.det guardExpr) none [] body md) ρ₀) (.terminal ρ_loop_post) ∧ + StepStmtStar P (EvalCmd P) extendEval + (.stmts rest ρ_loop_post) (.exiting label ρ')) := by + cases h_exit with + | step _ _ _ hstep1 hrest1 => + cases hstep1 with + | step_stmts_cons => + rcases seq_reaches_exiting P (EvalCmd P) extendEval hrest1 with h_inner | h_term + · exact Or.inl ⟨ρ', h_inner, rfl⟩ + · obtain ⟨ρ_loop_post, h_loop_term, h_rest_exit⟩ := h_term + exact Or.inr ⟨ρ_loop_post, h_loop_term, h_rest_exit⟩ + -- === STEP 3b: GenStep chain. === + subst h_entry_eq + subst h_gen_eq + have h_step_gen_to_r : StringGenState.GenStep gen gen_r := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_rest_eq + have h_step_r_to_le : StringGenState.GenStep gen_r gen_le := by + rw [show gen_le = (StringGenState.gen "loop_entry$" gen_r).2 from (by rw [h_le_eq])] + exact StringGenState.GenStep.of_gen "loop_entry$" gen_r + have h_step_le_to_b : StringGenState.GenStep gen_le gen_b := + stmtsToBlocks_genStep _ _ _ _ _ _ _ _ h_body_eq + have h_step_b_to_f : StringGenState.GenStep gen_b gen_f := + flushCmds_genStep _ _ _ _ _ _ _ _ h_flush_eq + have h_step_gen_to_le : StringGenState.GenStep gen gen_le := h_step_gen_to_r.trans h_step_r_to_le + have h_step_gen_to_b : StringGenState.GenStep gen gen_b := h_step_gen_to_le.trans h_step_le_to_b + have h_wf_r : StringGenState.WF gen_r := h_step_gen_to_r.wf_mono h_wf_gen + have h_wf_le : StringGenState.WF gen_le := h_step_gen_to_le.wf_mono h_wf_gen + have h_wf_b : StringGenState.WF gen_b := h_step_gen_to_b.wf_mono h_wf_gen + have h_outer_upper_b : StringGenState.stringGens gen_b ⊆ StringGenState.stringGens genUpperBound := + h_step_b_to_f.subset.trans h_outer_upper + have h_outer_upper_le : StringGenState.stringGens gen_le ⊆ StringGenState.stringGens genUpperBound := + h_step_le_to_b.subset.trans h_outer_upper_b + have h_outer_upper_r : StringGenState.stringGens gen_r ⊆ StringGenState.stringGens genUpperBound := + h_step_r_to_le.subset.trans h_outer_upper_le + -- === STEP 3c: Block-list membership. === + let lentryBlk : DetBlock String (Cmd P) P := + { cmds := ([] : List (Cmd P)), transfer := DetTransferCmd.condGoto guardExpr bl kNext md } + have h_blocks_full : + accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ bsRest = blocks := h_blocks_eq + subst h_blocks_full + have h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_left _ (List.mem_append_left _ (List.mem_append_left _ hb))) + have h_cfg_lentry : (lentry, lentryBlk) ∈ cfg.blocks := + h_cfg_blocks _ (List.mem_append_left _ (List.mem_append_left _ + (List.mem_append_right _ (List.Mem.head _)))) + have h_cfg_bbs : ∀ b ∈ bbs, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_left _ (List.mem_append_right _ hb)) + have h_cfg_bsRest : ∀ b ∈ bsRest, b ∈ cfg.blocks := fun b hb => + h_cfg_blocks b (List.mem_append_right _ hb) + have h_lentry_lkp : cfg.blocks.lookup lentry = some lentryBlk := + List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup _ _ h_cfg_lentry + -- === STEP 4: Lift accum to CFG (accumEntry → lentry). === + have h_fresh_accum : ∀ x ∈ Cmds.definedVars accum.reverse, σ_base x = none := fun x hx => + h_fresh_combined x (List.mem_append_left _ hx) + have h_unique_accum : (Cmds.definedVars accum.reverse).Nodup := + (List.nodup_append.mp h_unique_combined).1 + have ⟨σ_cfg_after, h_step_flush, h_agree_after, h_preserve_flush⟩ := + flushCmds_simulation_agree extendEval "before_loop$" lentry accum gen_b gen_f + accumEntry accumBlocks h_flush_eq σ_struct_base σ_base hf_base hf_accum ρ₀ + hwfb hwfv hwf_def hwf_congr h_accum h_agree_entry h_fresh_accum h_unique_accum + h_hf cfg h_cfg_accum h_cfg_nodup + -- === STEP 5: no-gen-suffix discharges and the store invariant. === + have h_body_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars body) := by + rw [h_body_no_inits]; intro x hx; simp [Cmds.definedVars] at hx + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun x hx s heq => + h_combined_no_gen_suffix x (List.mem_append_right _ (h_initvars_eq ▸ + (by simpa [Cmds.definedVars] using hx))) s heq + have h_body_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := + fun x hx s heq => h_combined_no_gen_suffix_mod x + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hx))) s heq + have h_getvars_eq : + Block.getVars (Stmt.loop (.det guardExpr) none [] body md :: rest) = + (HasVarsPure.getVars guardExpr ++ Block.getVars body) ++ Block.getVars rest := by + show Stmt.getVars (Stmt.loop (.det guardExpr) none [] body md) ++ Block.getVars rest = _ + simp only [Stmt.getVars, ExprOrNondet.getVars, List.flatMap_nil, + List.append_nil, List.nil_append] + have h_body_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars body) := + fun x hx s heq => h_combined_no_gen_suffix_get x + (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ + (by simpa [Cmds.getVars] using hx)))) s heq + let P_keep : P.Ident → Prop := fun x => + ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen_le ∨ s ∉ StringGenState.stringGens gen_b + let storeInv : SemanticStore P → Prop := fun σ => + ∀ x, P_keep x → σ_cfg_after x = none → σ x = none + have h_inv_after : storeInv σ_cfg_after := fun x _ h => h + have h_store_no_gens_upper_after : + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_after (HasIdent.ident (P := P) x) = none := + store_no_gens_lift_after_flush h_preserve_flush genUpperBound h_store_no_gens_upper + (fun y hy => h_combined_no_gen_suffix y (List.mem_append_left _ hy)) + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := by + intro x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun h_in_accum => + (List.nodup_append.mp (h_initvars_eq ▸ h_unique_combined)).2.2 x h_in_accum x hx rfl + have h_σ_base_x : σ_base x = none := + h_fresh_combined x (h_initvars_eq ▸ List.mem_append_right _ hx) + exact h_preserve_flush x h_σ_base_x h_x_not_accum + -- The store-no-gens-iter derivation shared between the two body-sim oracles. + have h_sng_of_inv : ∀ σ, storeInv σ → + ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ (HasIdent.ident (P := P) x) = none := by + intro σ h_inv x hx_sfx hx_notin + have h_keep : P_keep (HasIdent.ident (P := P) x) := by + intro s heq + have hs_eq : x = s := LawfulHasIdent.ident_inj heq + subst hs_eq + exact Or.inr (fun h_in_b => hx_notin (h_outer_upper_b h_in_b)) + exact h_inv _ h_keep (h_store_no_gens_upper_after x hx_sfx hx_notin) + -- === STEP 6: Body-sim oracle for terminating iterations. === + have h_body_sim_at : + ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), + ρ_iter.eval = ρ₀.eval → + StoreAgreement ρ_iter.store σ_cfg_iter → + storeInv σ_cfg_iter → + ∀ (ρ_body : Env P), StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_iter) (.terminal ρ_body) → + ∃ σ_cfg_after_body, + StepDetCFGStar extendEval cfg + (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) + (.atBlock lentry σ_cfg_after_body ρ_body.hasFailure) ∧ + StoreAgreement ρ_body.store σ_cfg_after_body ∧ + storeInv σ_cfg_after_body := by + intro ρ_iter σ_cfg_iter h_eval_iter h_agree_iter h_inv_iter ρ_body h_body_run + have hwfb_iter : WellFormedSemanticEvalBool ρ_iter.eval := h_eval_iter ▸ hwfb + have hwfv_iter : WellFormedSemanticEvalVal ρ_iter.eval := h_eval_iter ▸ hwfv + have hwf_def_iter : WellFormedSemanticEvalDef ρ_iter.eval := h_eval_iter ▸ hwf_def + have hwf_congr_iter : WellFormedSemanticEvalExprCongr ρ_iter.eval := h_eval_iter ▸ hwf_congr + have hwf_var_iter : WellFormedSemanticEvalVar ρ_iter.eval := h_eval_iter ▸ hwf_var + have h_combined_body : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_iter x = none := by + intro x hx; rw [h_body_no_inits] at hx; simp [Cmds.definedVars] at hx + have h_unique_combined_body : (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + rw [h_body_no_inits]; simp [Cmds.definedVars] + have h_accum_nil : EvalCmds P (EvalCmd P) ρ_iter.eval ρ_iter.store + [].reverse ρ_iter.store false := EvalCmds.eval_cmds_none + have h_hf_iter : ρ_iter.hasFailure = (ρ_iter.hasFailure || false) := by simp + have ⟨σ_cfg_after_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation extendEval lentry body ((.none, kNext) :: exitConts) [] + gen_le gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body + ρ_iter.store σ_cfg_iter ρ_iter.hasFailure false + ρ_iter ρ_body hwfb_iter hwfv_iter hwf_def_iter hwf_congr_iter hwf_var_iter + h_body_run h_accum_nil h_agree_iter + h_combined_body h_unique_combined_body h_hf_iter + h_wf_le h_body_no_gen_suffix h_body_no_gen_suffix_mod h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b (h_sng_of_inv σ_cfg_iter h_inv_iter) + cfg h_cfg_bbs h_cfg_nodup + refine ⟨σ_cfg_after_body, h_step_body, h_agree_body, ?_⟩ + intro x h_keep h_after_x + have h_iter_x : σ_cfg_iter x = none := h_inv_iter x h_keep h_after_x + have h_nil_not : x ∉ Cmds.definedVars ([] : List (Cmd P)).reverse := by simp [Cmds.definedVars] + have h_not_body : x ∉ Block.initVars body := by rw [h_body_no_inits]; simp + exact h_preserve_body x h_iter_x h_nil_not h_not_body h_keep + -- === STEP 6b: Body-sim oracle for the exiting iteration. === + -- The label resolution: ((.none, kNext) :: exitConts).lookup (.some label) = bk_target. + have h_label_lookup : + ((.none, kNext) :: exitConts).lookup (.some label) = some bk_target := by + simp [List.lookup, h_label] + have h_body_sim_exit_at : + ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), + ρ_iter.eval = ρ₀.eval → + StoreAgreement ρ_iter.store σ_cfg_iter → + storeInv σ_cfg_iter → + ∀ (ρ_body : Env P), StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_iter) (.exiting label ρ_body) → + ∃ σ_cfg_after_body, + StepDetCFGStar extendEval cfg + (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) + (.atBlock bk_target σ_cfg_after_body ρ_body.hasFailure) ∧ + StoreAgreement ρ_body.store σ_cfg_after_body ∧ + storeInv σ_cfg_after_body := by + intro ρ_iter σ_cfg_iter h_eval_iter h_agree_iter h_inv_iter ρ_body h_body_exit + have hwfb_iter : WellFormedSemanticEvalBool ρ_iter.eval := h_eval_iter ▸ hwfb + have hwfv_iter : WellFormedSemanticEvalVal ρ_iter.eval := h_eval_iter ▸ hwfv + have hwf_def_iter : WellFormedSemanticEvalDef ρ_iter.eval := h_eval_iter ▸ hwf_def + have hwf_congr_iter : WellFormedSemanticEvalExprCongr ρ_iter.eval := h_eval_iter ▸ hwf_congr + have hwf_var_iter : WellFormedSemanticEvalVar ρ_iter.eval := h_eval_iter ▸ hwf_var + have h_combined_body : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, + σ_cfg_iter x = none := by + intro x hx; rw [h_body_no_inits] at hx; simp [Cmds.definedVars] at hx + have h_unique_combined_body : (Cmds.definedVars [].reverse ++ Block.initVars body).Nodup := by + rw [h_body_no_inits]; simp [Cmds.definedVars] + have h_accum_nil : EvalCmds P (EvalCmd P) ρ_iter.eval ρ_iter.store + [].reverse ρ_iter.store false := EvalCmds.eval_cmds_none + have h_hf_iter : ρ_iter.hasFailure = (ρ_iter.hasFailure || false) := by simp + have ⟨σ_cfg_after_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation_to_cont extendEval lentry body ((.none, kNext) :: exitConts) [] + gen_le gen_b bl bbs h_body_eq h_nofd_body h_simple_body h_unique_body + h_lbni_body h_lhni_body h_nml_body + ρ_iter.store σ_cfg_iter ρ_iter.hasFailure false + ρ_iter ρ_body label bk_target h_label_lookup + hwfb_iter hwfv_iter hwf_def_iter hwf_congr_iter hwf_var_iter + h_body_exit h_accum_nil h_agree_iter + h_combined_body h_unique_combined_body h_hf_iter + h_wf_le h_body_no_gen_suffix h_body_no_gen_suffix_mod h_body_no_gen_suffix_get + genUpperBound h_outer_upper_b (h_sng_of_inv σ_cfg_iter h_inv_iter) + cfg h_cfg_bbs h_cfg_nodup + refine ⟨σ_cfg_after_body, h_step_body, h_agree_body, ?_⟩ + intro x h_keep h_after_x + have h_iter_x : σ_cfg_iter x = none := h_inv_iter x h_keep h_after_x + have h_nil_not : x ∉ Cmds.definedVars ([] : List (Cmd P)).reverse := by simp [Cmds.definedVars] + have h_not_body : x ∉ Block.initVars body := by rw [h_body_no_inits]; simp + exact h_preserve_body x h_iter_x h_nil_not h_not_body h_keep + -- === STEP 7: Dispatch on the exit. === + rcases h_exit_dispatch with ⟨ρ_loop_post, h_loop_exit, hρ'_eq⟩ | h_caseB + · -- CASE A: loop body exits with label → bk_target directly. + subst hρ'_eq + have ⟨σ_cfg_bk, h_loop_run, h_agree_bk, h_inv_bk⟩ := + InlineLoopHelpers.loop_iterations_to_cont_det extendEval guardExpr body md + ρ₀ ρ' label cfg lentry kNext bl bk_target σ_cfg_after storeInv + h_lentry_lkp h_agree_after h_inv_after h_loop_exit h_nofd_body + h_body_sim_at h_body_sim_exit_at hwfb hwf_def hwf_congr + refine ⟨σ_cfg_bk, ?_, h_agree_bk, ?_⟩ + · exact StepDetCFGStar_trans h_step_flush h_loop_run + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_keep : P_keep x := by + intro s heq + rcases h_outer_guard s heq with h_in_gen | h_notin_gen' + · exact Or.inl (h_step_gen_to_le.subset h_in_gen) + · exact Or.inr (fun h_in_b => h_notin_gen' (h_step_b_to_f.subset h_in_b)) + exact h_inv_bk x h_keep h_σ_after_x + · -- CASE B: loop terminates, then rest exits with label. + obtain ⟨ρ_loop_post, h_loop_term, h_rest_exit⟩ := h_caseB + have h_loop_stmt := h_loop_term + have ⟨σ_cfg_kNext, h_loop_run, h_agree_loop, h_inv_loop⟩ := + InlineLoopHelpers.loop_iterations_det extendEval guardExpr body md ρ₀ ρ_loop_post + cfg lentry kNext bl σ_cfg_after storeInv h_lentry_lkp h_agree_after h_inv_after + h_loop_stmt h_body_no_inits h_nofd_body h_body_sim_at + hwfb hwfv hwf_var hwf_def hwf_congr + have h_sng_loop : ∀ x : String, String.HasUnderscoreDigitSuffix x → + x ∉ StringGenState.stringGens genUpperBound → + σ_cfg_kNext (HasIdent.ident (P := P) x) = none := + h_sng_of_inv σ_cfg_kNext h_inv_loop + have h_fresh_rest_loop : ∀ x ∈ Block.initVars rest, σ_cfg_kNext x = none := by + intro x hx + have h_keep : P_keep x := by + intro s heq + exact Or.inr (fun h_in_b => + StringGenState.not_mem_stringGens_of_not_hasUnderscoreDigitSuffix h_wf_b + (h_rest_no_gen_suffix x (by simpa [Cmds.definedVars] using hx) s heq) h_in_b) + exact h_inv_loop x h_keep (h_fresh_rest_inits_after x hx) + have h_loop_stmts : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.loop (.det guardExpr) none [] body md] ρ₀) (.terminal ρ_loop_post) := + ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval _ [] ρ₀ ρ_loop_post h_loop_term) + (.step _ _ _ .step_stmts_nil (.refl _)) + have h_eval_loop : ρ_loop_post.eval = ρ₀.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + [.loop (.det guardExpr) none [] body md] ρ₀ ρ_loop_post + (by simp [Block.noFuncDecl, Stmt.noFuncDecl, h_nofd_body]) + h_loop_stmts + have hwfb_loop : WellFormedSemanticEvalBool ρ_loop_post.eval := h_eval_loop ▸ hwfb + have hwfv_loop : WellFormedSemanticEvalVal ρ_loop_post.eval := h_eval_loop ▸ hwfv + have hwf_def_loop : WellFormedSemanticEvalDef ρ_loop_post.eval := h_eval_loop ▸ hwf_def + have hwf_congr_loop : WellFormedSemanticEvalExprCongr ρ_loop_post.eval := h_eval_loop ▸ hwf_congr + have hwf_var_loop : WellFormedSemanticEvalVar ρ_loop_post.eval := h_eval_loop ▸ hwf_var + have h_combined_rest : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars rest, + σ_cfg_kNext x = none := fun x hx => + h_fresh_rest_loop x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_rest : (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := by + simpa [Cmds.definedVars, Block.uniqueInits] using h_unique_rest + have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_loop_post.eval ρ_loop_post.store + [].reverse ρ_loop_post.store false := EvalCmds.eval_cmds_none + have h_hf_loop : ρ_loop_post.hasFailure = (ρ_loop_post.hasFailure || false) := by simp + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := + fun x hx s heq => h_combined_no_gen_suffix_mod x + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq + have h_rest_no_gen_suffix_get : + NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := + fun x hx s heq => h_combined_no_gen_suffix_get x + (List.mem_append_right _ (h_getvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq + have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsRest + h_rest_eq h_nofd_rest h_simple_rest h_unique_rest + h_lbni_rest h_lhni_rest h_nml_rest + ρ_loop_post.store σ_cfg_kNext ρ_loop_post.hasFailure false + ρ_loop_post ρ' label bk_target h_label + hwfb_loop hwfv_loop hwf_def_loop hwf_congr_loop hwf_var_loop + h_rest_exit h_accum_nil_r h_agree_loop + h_combined_rest h_unique_combined_rest h_hf_loop + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod h_rest_no_gen_suffix_get + genUpperBound h_outer_upper_r h_sng_loop + cfg h_cfg_bsRest h_cfg_nodup + refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ + · exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_flush h_loop_run) h_rest_sim + · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard + have h_x_not_rest : x ∉ Block.initVars rest := fun hx => + h_x_not_inits (h_initvars_eq ▸ hx) + have h_σ_after_x : σ_cfg_after x = none := h_preserve_flush x h_σ_x h_x_not_accum + have h_nil_not : x ∉ Cmds.definedVars [].reverse := by simp [Cmds.definedVars] + have h_keep : P_keep x := by + intro s heq + rcases h_outer_guard s heq with h_in_gen | h_notin_gen' + · exact Or.inl (h_step_gen_to_le.subset h_in_gen) + · exact Or.inr (fun h_in_b => h_notin_gen' (h_step_b_to_f.subset h_in_b)) + have h_x_fresh_loop : σ_cfg_kNext x = none := h_inv_loop x h_keep h_σ_after_x + have h_guard_rest : ∀ s : String, x = HasIdent.ident (P := P) s → + s ∈ StringGenState.stringGens gen ∨ s ∉ StringGenState.stringGens gen_r := + fun s heq => match h_outer_guard s heq with + | Or.inl h_in => Or.inl h_in + | Or.inr h_notin => Or.inr (fun h_in_r => h_notin + (h_step_b_to_f.subset (h_step_le_to_b.subset (h_step_r_to_le.subset h_in_r)))) + exact h_preserve_rest x h_x_fresh_loop h_nil_not h_x_not_rest h_guard_rest termination_by sizeOf ss decreasing_by all_goals (subst h_match; simp_wf; omega) From bfcc6b115cf9f76e1f326d1d6441c09eb3bcffd3 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 01:11:23 -0700 Subject: [PATCH 11/33] docs: add loop-extension-v3 design document --- docs/loop-extension-v3-design.md | 291 +++++++++++++++++++++++++++++++ 1 file changed, 291 insertions(+) create mode 100644 docs/loop-extension-v3-design.md diff --git a/docs/loop-extension-v3-design.md b/docs/loop-extension-v3-design.md new file mode 100644 index 0000000000..ea8eb6065a --- /dev/null +++ b/docs/loop-extension-v3-design.md @@ -0,0 +1,291 @@ +# Structured-to-Unstructured Loop Extension (v3) — Design Document + +Branch: `htd/structured-to-unstructured-loops-v3` +Commit: 0762a29f5bfd1c2521f35f0e50b7c5e6c3ee3020 +Forked from: v2 skeleton at 187a81931 (baseline proof state +`origin/htd/structured-to-unstructured-small-step-proof`, commit c81249b49). + +Status: 0 sorries, 0 axioms, full project builds green (489 jobs). + +--- + +## 1. Goal + +Extend the structured-to-unstructured (str→unstr) correctness proof so that +`while` loops are admitted by the simulation theorems, closing all remaining +`sorry`s in `Strata/Transform/StructuredToUnstructuredCorrect.lean`. + +Loops are admitted ONLY when ALL of the following hold: + +| Predicate | Meaning | +|---|---| +| `Block.loopBodyNoInits` | the body has no `init` (variable-declaration) commands at any nesting depth | +| `Block.loopHasNoInvariants` | the loop carries an empty invariants list (no `invariant` clauses) | +| `Block.noMeasureLoops` | the loop carries no `measure` / termination-metric clause | +| det guard | the loop guard is `.det _` (a deterministic boolean expression), NOT `.nondet` | + +These are exactly the loops whose CFG lowering is a clean back-edge with no +havoc, no auxiliary assertion injection, and no source-side variable +introduction — the cases where the structured and unstructured executions stay +in lockstep under the small-step semantics. + +--- + +## 2. The strengthened `simpleShape` (det loops only) + +`Stmt.simpleShape` (in `Strata/DL/Imperative/Stmt.lean`) is the syntactic +admissibility predicate threaded through the simulation theorems. Its `.loop` +arm was strengthened to reject nondeterministic guards: + +```lean +@[expose] def Stmt.simpleShape (s : Stmt P (Cmd P)) : Bool := + match s with + ... + | .loop guard _ _ bss _ => + (match guard with | .det _ => true | .nondet => false) && Block.simpleShape bss +``` + +Two consequences: + +1. **Nondet loops are statically dischargeable.** In any simulation arm that is + handed `Stmt.simpleShape (.loop .nondet ...) = true`, the hypothesis is + `false = true`, so the arm closes by `absurd ... (by simp [Stmt.simpleShape])`. + No nondet-loop proof obligation ever reaches the main body. + +2. **Det loops expose their guard.** A new lemma extracts the guard expression: + + ```lean + theorem Stmt.simpleShape_loop_guard_det : + Stmt.simpleShape (.loop g m is body md) = true → ∃ ge, g = .det ge + ``` + + The existing `Stmt.simpleShape_loop_body` lemma was updated to use + `unfold + cases on guard` (a bare `simp only` no longer makes progress on the + strengthened definition). + +The module docstring of `Stmt.lean` was updated to note that nondet loops are +excluded from `simpleShape`. + +--- + +## 3. The three admissibility predicates + +All three are `Bool`-valued, defined `@[expose]` and lifted to block level +(`Block.foo ss := ss.all Stmt.foo`-style recursion). For each, the file +provides a `_cons_iff` decomposition (head/tail), branch/block recursion +lemmas, and a leaf lemma that projects the relevant fact out of the `.loop` +constructor. + +### `Block.loopBodyNoInits` (`Stmt.lean:315`) + +```lean +| .loop _ _ _ bss _ => (Block.initVars bss).isEmpty && Block.loopBodyNoInits bss +``` + +Recursively requires every loop in the term to have a body whose `initVars` are +empty. This is what makes the loop's CFG lowering avoid a havoc/re-declaration +block: with no inits in the body, `Block.initVars (.loop ... :: rest) = +Block.initVars rest`, so the loop contributes nothing to the surrounding init +set and the body re-enters its entry block on each back-edge with the same +variable footprint. + +### `Block.loopHasNoInvariants` (`Stmt.lean:394`) + +```lean +| .loop _ _ invs bss _ => invs.isEmpty && Block.loopHasNoInvariants bss +``` + +Requires the invariants list to be empty. With invariants present, the +translator injects `assert`/`assume` blocks at the loop head that have no +structured-side counterpart in the small-step semantics, breaking lockstep. +The leaf lemma `Stmt.loopHasNoInvariants_loop_invs` yields `invariants = []`. + +### `Block.noMeasureLoops` (`Stmt.lean:474`) + +```lean +| .loop _ m _ bss _ => m.isNone && Block.noMeasureLoops bss +``` + +Requires the measure/termination-metric clause to be `none`. A measure clause +likewise triggers translator-side instrumentation absent from the structured +small-step run. The leaf gives `measure = .none`. + +In the `.loop` dispatch arm these three combine to rewrite the head statement +to the canonical admitted shape `.loop (.det guardExpr) none [] body md :: rest` +via three successive `subst`s. + +--- + +## 4. Why the `LoopArm` namespace was deleted (the forward-reference issue) + +The v2 skeleton carried a `namespace LoopArm` containing six helpers: +`peel_off_one_iteration_det`, `step_loop_iteration_det`, `loop_iterations_det`, +`loop_det_decompose_h_gen`, `loop_arm_simulation`, `loop_arm_simulation_to_cont`. + +The last two (`loop_arm_simulation`, `loop_arm_simulation_to_cont`) had to +recurse on the body and on `rest` — i.e. they needed to call +`stmtsToBlocks_simulation` / `stmtsToBlocks_simulation_to_cont`. But those +simulation theorems live **inside** the `mutual` block and are defined **after** +the namespace. A standalone helper that calls them is a forward reference: +Lean cannot define `LoopArm.loop_arm_simulation` before the mutual block, and +cannot place it inside the mutual block while it lives in a separate namespace +with its own `termination_by`. The skeleton papered over this with two `sorry`s +in `loop_det_decompose_h_gen` plus stubbed iteration lemmas. + +The fix removes the namespace entirely and **inlines the loop-arm proof bodies +directly into the `.loop` dispatch arms** of `stmtsToBlocks_simulation` +(line ~5583) and `stmtsToBlocks_simulation_to_cont` (line ~8290). From there, +the recursive calls to the simulation theorems are ordinary mutual-recursion +calls — the exact same mechanism the `.block` and `.ite` arms already use +(e.g. body recursion at line 5799, `rest` recursion at line 5890). Termination +is the shared `termination_by sizeOf ss` / `decreasing_by simp_wf; omega`. + +The genuinely reusable, **non-recursive** pieces (those depending only on CFG + +small-step stmt semantics, never on the simulation theorems) were kept as +private helpers in a new `namespace InlineLoopHelpers` placed *before* the +mutual block. Its docstring explicitly states these helpers MUST NOT call the +simulation theorems, preserving the no-forward-reference discipline. + +--- + +## 5. The inline proof strategy + +### 5.1 Helpers in `InlineLoopHelpers` + +`ReflTransT`-inversion ("length-indexed") lemmas that peel one structural layer +off a small-step run and return the residual run plus a strict length decrease +(the length index drives the iteration induction): + +| Helper | LoC | Role | +|---|---|---| +| `seqT_reaches_terminal'` | 18 | `.seq → .terminal` inversion (re-declared because the upstream version is private) | +| `stmtsT_cons_terminal'` | 13 | `.stmts (s::rest) → .terminal` inversion | +| `seqT_reaches_exiting'` | 28 | `.seq → .exiting` (Sum: inner-exit vs inner-term-then-tail-exit) | +| `stmtsT_cons_exiting'` | 24 | `.stmts (s::rest) → .exiting` inversion | +| `blockT_none_reaches_terminal'` | 22 | unlabeled `.block .none → .terminal` projection | +| `blockT_none_reaches_exiting'` | 22 | unlabeled `.block .none → .exiting` exit-propagation | +| `loop_det_decompose_h_gen` | 79 | translator-shape decomposition of `stmtsToBlocks` on the admitted loop | + +`loop_det_decompose_h_gen` was the 2-`sorry` skeleton stub. It was rewritten to +the **actual** v3 translator shape: the fictional `kNext$`-gen step and the +join block of the skeleton were removed, and the emitted block list is +`accumBlocks ++ [(lentry, lentryBlk)] ++ bodyBlocks ++ restBlocks` matching what +`stmtsToBlocks` actually produces for `.loop (.det g) none [] body md :: rest`. + +### 5.2 Nat-bounded induction over iteration count + +The loop arm proves, by induction on the **length index** of the structured +small-step run, that for any number of loop iterations the structured run and +the CFG run stay in lockstep: + +1. **Decompose** `h_gen` with `loop_det_decompose_h_gen` to learn the exact + block layout (entry block `lentry`, body blocks, rest blocks, generator + threading `gen → gen_r → gen_le → gen_b → gen_f`). +2. **Split** the terminal/exiting run of `[loop] ++ rest` into a loop run and a + `rest` run with `stmts_append_terminates`. +3. **Iterate.** Each iteration is: evaluate the det guard; if true, run the body + (recursive `stmtsToBlocks_simulation` call on `body` with a back-edge + continuation), which strictly shrinks the length index, then recurse on the + shorter run; if false, exit to the loop's successor. The strict length + decrease from the `ReflTransT`-inversion helpers is what discharges + termination of the iteration induction (it is bounded by the length of the + structured run, not by a loop-trip count, so non-terminating source loops + never arise — a terminal small-step run is finite by construction). +4. **Continue** with the `rest` recursion (`stmtsToBlocks_simulation` on `rest`) + to reach the final config. + +The arm carries a strengthened iteration lemma (`loop_iterations_det`) with a +`freshVars`-preservation conjunct so that the generator/freshness invariants the +surrounding mutual proof relies on are maintained across every back-edge. + +The `_to_cont` arm (line ~8290) mirrors this but targets the case where the +structured run ends in `.exiting label` caught by an `exitConts` entry, reaching +the labeled CFG continuation instead of the fallthrough. + +Inlined sizes: simulation `.loop` arm ≈ 346 LoC; `_to_cont` `.loop` arm ≈ 386 LoC. + +--- + +## 6. Adversarial verification: 6 skeptics across 2 rounds + +The proof was subjected to two independent rounds of adversarial review, three +skeptics per round (6 total), each tasked with finding an unsound step, a +hidden axiom, a circular dependency, a forward reference, or a vacuous +hypothesis. + +- **Round 1 (Verify1):** sound, sound, sound. +- **Round 2 (Verify2):** sound, sound, sound. + +Consensus across both rounds: **all 6 skeptics report sound.** No skeptic found +an `axiom`, a `True := trivial` placeholder, a `sorry`, an `admit`, a +`native_decide`/`implemented_by` escape hatch, or a circular/forward reference. +The mutual recursion is the only recursion and is justified by a genuine +`termination_by sizeOf ss` with `decreasing_by simp_wf; omega`. + +Independent re-verification performed for this report: +- `grep -niw sorry` over both files: 0 matches. +- `grep -nE '^\s*axiom\b'` over both files: 0 matches. +- `grep -n 'admit'` over the proof file: 0 matches. +- `grep -n 'namespace LoopArm\|LoopArm\.'`: 0 matches (namespace fully removed). +- Full `lake build`: "Build completed successfully (489 jobs)", exit 0, no + errors and no `declaration uses 'sorry'` warnings (only cosmetic + `linter.unusedSimpArgs` and unused-section-variable warnings remain). + +--- + +## 7. Remaining sorries + +**0.** Both `.loop` arm sorries (terminal and `_to_cont`) are closed. There are +no remaining `sorry`s, `admit`s, or `axiom`s anywhere in +`StructuredToUnstructuredCorrect.lean` or `Stmt.lean`. + +--- + +## 8. LoC delta vs baseline + +Baseline = `origin/htd/structured-to-unstructured-small-step-proof` (c81249b49). + +| File | Baseline | v3 | Δ | +|---|---|---|---| +| `Strata/Transform/StructuredToUnstructuredCorrect.lean` | 7331 | 8945 | +1614 | +| `Strata/DL/Imperative/Stmt.lean` | 554 | 833 | +279 | +| **Total** | **7885** | **9778** | **+1893** | + +`git diff --stat` over the two files: +1916 insertions, −23 deletions +(net +1893). The +279 in `Stmt.lean` is the strengthened `simpleShape`, the +three admissibility predicates with their full lemma families, and the two new +`simpleShape` lemmas. The +1614 in the proof file is the two inlined loop arms +(≈732 LoC combined) plus the `InlineLoopHelpers` namespace (≈206 LoC of helper +lemmas including the rewritten `loop_det_decompose_h_gen`), net of the deleted +372-line `LoopArm` namespace. + +--- + +## 9. Recommended next steps + +1. **Land v3 onto the small-step proof line.** v3 is sorry/axiom-free and builds + green for the whole project; it supersedes the v2 skeleton. Open a PR from + `htd/structured-to-unstructured-loops-v3` into the small-step proof branch. +2. **Add end-to-end runtime coverage for the `.cfg` (unstructured) form with a + loop.** Per the standing project memory, `StrataTest/.../Examples/*.lean` + SMT-goldens exercise only the structured form; no test drives a lowered loop + through `ProcedureEval`. Add a golden that round-trips a det `while` with no + inits/invariants/measure so the newly-proved path has live coverage. +3. **Clear the cosmetic `linter.unusedSimpArgs` warnings** introduced by the + inlined arms (lines 4401, 5731, 5930, 6983, 8421). Trim the unused + `StateT.pure` / `List.nil_append` / `List.append_nil` simp args. Mechanical; + no proof risk. +4. **Relax the admissibility predicates incrementally.** The det-only, + no-inits/invariants/measure fragment is the lockstep core. The natural next + extensions, in increasing difficulty: (a) loops whose body declares inits + (requires modeling the translator's havoc/re-declaration block — see the + `.loop` axiom-unprovability note); (b) loops with invariants (requires + relating the injected `assert`/`assume` blocks to a structured-side + obligation); (c) nondet guards (requires the demonic-branch simulation that + `simpleShape` currently excludes). Each is a separate workstream and should + not be folded into the lockstep proof. +5. **Promote the `InlineLoopHelpers` `ReflTransT`-inversion helpers** if other + arms (block/ite) could reuse them; several are general small-step inversions + that currently duplicate private upstream lemmas (`seqT_reaches_terminal'` + was re-declared only because the upstream is private — consider de-privatising + upstream and deleting the `'` copy). From 346a9cf19828edbbcbe75b2465ac8edfa7159b06 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 02:28:31 -0700 Subject: [PATCH 12/33] =?UTF-8?q?simplify(1):=20unused-simp-nil-append=20?= =?UTF-8?q?=E2=80=94=20drop=20never-firing=20List.nil=5Fappend=20simp=20ar?= =?UTF-8?q?gs=20(3=20sites)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Strata/Transform/StructuredToUnstructuredCorrect.lean | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 7a01293f41..57cbdc738f 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4398,7 +4398,7 @@ theorem loop_det_decompose_h_gen = ((accumEntry, accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ bsRest), gen_f) := by unfold stmtsToBlocks simp only [bind, StateT.bind, pure, StateT.pure, List.append_nil, - List.nil_append, List.foldl_nil] + List.foldl_nil] rfl have h_eq_full := h_gen_red.symm.trans h_gen have h_pair := (Prod.mk.inj h_eq_full).1 @@ -5728,7 +5728,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (HasVarsPure.getVars guardExpr ++ Block.getVars body) ++ Block.getVars rest := by show Stmt.getVars (Stmt.loop (.det guardExpr) none [] body md) ++ Block.getVars rest = _ simp only [Stmt.getVars, ExprOrNondet.getVars, List.flatMap_nil, - List.append_nil, List.nil_append] + List.append_nil] have h_body_no_gen_suffix_get : NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars body) := fun x hx s heq => h_combined_no_gen_suffix_get x @@ -8418,7 +8418,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (HasVarsPure.getVars guardExpr ++ Block.getVars body) ++ Block.getVars rest := by show Stmt.getVars (Stmt.loop (.det guardExpr) none [] body md) ++ Block.getVars rest = _ simp only [Stmt.getVars, ExprOrNondet.getVars, List.flatMap_nil, - List.append_nil, List.nil_append] + List.append_nil] have h_body_no_gen_suffix_get : NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars body) := fun x hx s heq => h_combined_no_gen_suffix_get x From 016669e130d263b1401fbdbfb6a118cfcb1b89dc Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 02:33:42 -0700 Subject: [PATCH 13/33] =?UTF-8?q?simplify(1):=20unused-simp-statet-pure=20?= =?UTF-8?q?=E2=80=94=20drop=20never-firing=20StateT.pure=20simp=20arg=20(3?= =?UTF-8?q?=20sites)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Strata/Transform/StructuredToUnstructuredCorrect.lean | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 57cbdc738f..c52d1ec74b 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -1962,7 +1962,7 @@ private theorem stmtsToBlocks_invariant -- Sub-computations: rest, gen "ite", tss, fss, optional gen "$__nondet_ite$", -- flushCmds (with condGoto transfer). The output is -- accumBlocks ++ tbs ++ fbs ++ bsNext. - simp only [stmtsToBlocks, bind, StateT.bind, pure, StateT.pure] at h_gen + simp only [stmtsToBlocks, bind, StateT.bind, pure] at h_gen -- Decompose monadic chain generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest @@ -5927,7 +5927,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (h_step_b_to_f.subset (h_step_le_to_b.subset (h_step_r_to_le.subset h_in_r)))) exact h_preserve_rest x h_x_fresh_loop h_nil_not h_x_not_rest h_guard_rest | .block label body md :: rest => - simp only [stmtsToBlocks, bind, StateT.bind, pure, StateT.pure] at h_gen + simp only [stmtsToBlocks, bind, StateT.bind, pure] at h_gen -- Decompose the monadic chain generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest @@ -6980,7 +6980,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has intro x h_σ_x h_x_not_accum _ _ exact h_preserve x h_σ_x h_x_not_accum | .block label' body md :: rest => - simp only [stmtsToBlocks, bind, StateT.bind, pure, StateT.pure] at h_gen + simp only [stmtsToBlocks, bind, StateT.bind, pure] at h_gen -- Decompose the monadic chain generalize h_rest_eq : stmtsToBlocks k rest exitConts [] gen = r_rest at h_gen obtain ⟨⟨kNext, bsNext⟩, gen_r⟩ := r_rest From 80554c1021a85469e89829544ff7a8f9d3238ade Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 02:38:48 -0700 Subject: [PATCH 14/33] =?UTF-8?q?simplify(1):=20unused-simp-singleton-appe?= =?UTF-8?q?nd=20=E2=80=94=20drop=20never-firing=20List.singleton=5Fappend?= =?UTF-8?q?=20simp=20arg=20(4=20sites)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Strata/Transform/StructuredToUnstructuredCorrect.lean | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index c52d1ec74b..d802c6e4fd 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -2609,7 +2609,7 @@ private theorem stmtsToBlocks_invariant have h_target : accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ ([] : List (String × DetBlock String (Cmd P) P)) ++ bsNext = accumBlocks ++ ((lentry, lentryBlk) :: (bbs ++ bsNext)) := by - simp [List.append_assoc, List.singleton_append] + simp [List.append_assoc] rw [h_target] have h1 : ((lentry, lentryBlk) :: ((bsNext ++ bbs) ++ accumBlocks)).Perm ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ bbs))) := @@ -2797,7 +2797,7 @@ private theorem stmtsToBlocks_invariant have h_target : accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ ([] : List (String × DetBlock String (Cmd P) P)) ++ bsNext = accumBlocks ++ ((lentry, lentryBlk) :: (bbs ++ bsNext)) := by - simp [List.append_assoc, List.singleton_append] + simp [List.append_assoc] rw [h_target] have h1 : ((lentry, lentryBlk) :: ((bsNext ++ bbs) ++ accumBlocks)).Perm ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ bbs))) := @@ -3081,7 +3081,7 @@ private theorem stmtsToBlocks_invariant have h_target : accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [decBlock] ++ bsNext = accumBlocks ++ ((lentry, lentryBlk) :: (bbs ++ [decBlock] ++ bsNext)) := by - simp [List.append_assoc, List.singleton_append] + simp [List.append_assoc] rw [h_target] have h1 : ((lentry, lentryBlk) :: ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks)).Perm ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ [decBlock] ++ bbs))) := @@ -3342,7 +3342,7 @@ private theorem stmtsToBlocks_invariant have h_target : accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ [decBlock] ++ bsNext = accumBlocks ++ ((lentry, lentryBlk) :: (bbs ++ [decBlock] ++ bsNext)) := by - simp [List.append_assoc, List.singleton_append] + simp [List.append_assoc] rw [h_target] have h1 : ((lentry, lentryBlk) :: ((bsNext ++ [decBlock] ++ bbs) ++ accumBlocks)).Perm ((lentry, lentryBlk) :: (accumBlocks ++ (bsNext ++ [decBlock] ++ bbs))) := From 706b9770113bdaa0ece7fa0c28e8fbfb11e68e99 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 02:48:57 -0700 Subject: [PATCH 15/33] =?UTF-8?q?simplify(2):=20dead-stmtsToCFG-exiting-cl?= =?UTF-8?q?uster=20=E2=80=94=20delete=20unused=20stmtsToCFG=5Fexiting=20+?= =?UTF-8?q?=20stmtsToBlocks=5Fsimulation=5Fexiting?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../StructuredToUnstructuredCorrect.lean | 41 ------------------- 1 file changed, 41 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index d802c6e4fd..0fec520bb9 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -8664,27 +8664,6 @@ decreasing_by end -/-- Variant of `stmtsToBlocks_simulation` for when the structured execution -"exits". Under the `exitsCoveredByBlocks` invariant such an execution is -impossible, so the conclusion holds vacuously. -/ -private theorem stmtsToBlocks_simulation_exiting {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVal P] [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] - (extendEval : ExtendEval P) - (ss : List (Stmt P (Cmd P))) - (entry : String) - (σ_base : SemanticStore P) - (hf_base : Bool) - (ρ₀ ρ' : Env P) (lbl : String) - (h_exits : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks [] ss) - (h_exit : StepStmtStar P (EvalCmd P) extendEval - (.stmts ss ρ₀) (.exiting lbl ρ')) - (cfg : CFG String (DetBlock String (Cmd P) P)) : - ∃ σ_final failed, StepDetCFGStar extendEval cfg - (.atBlock entry σ_base hf_base) - (.terminal σ_final failed) ∧ σ_final = ρ'.store := - absurd h_exit - (block_exitsCoveredByBlocks_noEscape (P := P) (EvalCmd P) extendEval ss h_exits ρ₀ lbl ρ') - /-! ## Top-level theorems -/ /-- Specification lemma: `stmtsToCFG` produces a CFG whose blocks come from @@ -8873,26 +8852,6 @@ theorem stmtsToCFG_terminal {P : PureExpr} [HasFvar P] [HasNot P] have h_end := end_block_terminal extendEval cfg lend σ_cfg ρ'.eval ρ'.hasFailure h_lend exact ⟨σ_cfg, StepDetCFGStar_trans h_sim h_end, h_agree⟩ -/-- If the structured program reaches an exiting state, the CFG also reaches - a corresponding terminal state (vacuously, since `exitsCoveredByBlocks` - rules out top-level `.exiting`). -/ -theorem stmtsToCFG_exiting {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVal P] [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] - (extendEval : ExtendEval P) - (ss : List (Stmt P (Cmd P))) - (ρ₀ ρ' : Env P) (lbl : String) - (h_exits : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks [] ss) - (h_exit : StepStmtStar P (EvalCmd P) extendEval - (.stmts ss ρ₀) (.exiting lbl ρ')) : - let cfg := stmtsToCFG ss - ∃ σ_final failed, - StepDetCFGStar extendEval cfg - (.atBlock cfg.entry ρ₀.store false) - (.terminal σ_final failed) ∧ - σ_final = ρ'.store := - stmtsToBlocks_simulation_exiting extendEval ss (stmtsToCFG ss).entry - ρ₀.store false ρ₀ ρ' lbl h_exits h_exit (stmtsToCFG ss) - /-! ## Main theorems -/ /-- `stmtsToCFG` is sound: any terminal state reachable from the structured From 3e69ca24eac1fc055e4cab5c2ecae415c4602eab Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 02:54:07 -0700 Subject: [PATCH 16/33] =?UTF-8?q?simplify(2):=20dead-have-h-x-not-then-555?= =?UTF-8?q?3=20=E2=80=94=20drop=20unused=20h=5Fx=5Fnot=5Fthen=20in=20ITE?= =?UTF-8?q?=20else=20store-preservation=20arm?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Strata/Transform/StructuredToUnstructuredCorrect.lean | 2 -- 1 file changed, 2 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 0fec520bb9..6ffc2046c9 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -5550,8 +5550,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] · exact StepDetCFGStar_trans (StepDetCFGStar_trans h_flush_sim h_else_step) h_rest_sim · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard - have h_x_not_then : x ∉ Block.initVars thenBranch := fun hx => - h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_left _ hx)) have h_x_not_else : x ∉ Block.initVars elseBranch := fun hx => h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_right _ hx)) have h_x_not_rest : x ∉ Block.initVars rest := fun hx => From 83bb96248471a2f1b59b365f566f4be1317e3896 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 03:01:32 -0700 Subject: [PATCH 17/33] =?UTF-8?q?simplify(2):=20dead-stmt-{noMeasureLoops-?= =?UTF-8?q?loop-measure,simpleShape-block-body,isCmd}=20=E2=80=94=20delete?= =?UTF-8?q?=203=20unused=20Stmt.lean=20members?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Strata/DL/Imperative/Stmt.lean | 24 ------------------------ 1 file changed, 24 deletions(-) diff --git a/Strata/DL/Imperative/Stmt.lean b/Strata/DL/Imperative/Stmt.lean index 440af248c0..4c6ca1dc0e 100644 --- a/Strata/DL/Imperative/Stmt.lean +++ b/Strata/DL/Imperative/Stmt.lean @@ -55,12 +55,6 @@ inductive Stmt (P : PureExpr) (Cmd : Type) : Type where /-- A block is simply an abbreviation for a list of commands. -/ @[expose] abbrev Block (P : PureExpr) (Cmd : Type) := List (Stmt P Cmd) -def Stmt.isCmd {P : PureExpr} {Cmd : Type} (s : Stmt P Cmd) : Bool := - match s with - | .cmd _ => true - | _ => false - - /-- Induction principle for `Stmt` -/ @@ -265,14 +259,6 @@ theorem Stmt.simpleShape_branch_else intro h exact h.2 -/-- The body of a `.block` is simple when the whole block-statement is. -/ -theorem Stmt.simpleShape_block_body - {label : String} {body : List (Stmt P (Cmd P))} {md : MetaData P} : - Stmt.simpleShape (.block label body md) = true → - Block.simpleShape body = true := by - simp only [Stmt.simpleShape] - intro h; exact h - /-- The body of a `.loop` is simple when the whole loop-statement is. -/ theorem Stmt.simpleShape_loop_body {g : ExprOrNondet P} {m : Option P.Expr} @@ -518,16 +504,6 @@ theorem Stmt.noMeasureLoops_block_body simp only [Stmt.noMeasureLoops] intro h; exact h -/-- A loop has no termination measure. -/ -theorem Stmt.noMeasureLoops_loop_measure - {g : ExprOrNondet P} {m : Option P.Expr} - {is : List (String × P.Expr)} {body : List (Stmt P (Cmd P))} - {md : MetaData P} : - Stmt.noMeasureLoops (.loop g m is body md) = true → - m = .none := by - simp only [Stmt.noMeasureLoops, Bool.and_eq_true, Option.isNone_iff_eq_none] - intro h; exact h.1 - /-- The recursive `noMeasureLoops` discharge for a loop's body. -/ theorem Stmt.noMeasureLoops_loop_body_rec {g : ExprOrNondet P} {m : Option P.Expr} From 6c3e42afe72e71c78bfb16368c8b08211bb9ae80 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 03:26:41 -0700 Subject: [PATCH 18/33] =?UTF-8?q?simplify(3):=20h-eval-loop-termmode=20?= =?UTF-8?q?=E2=80=94=20drop=20by/have/exact-this=20wrapper=20on=20terminal?= =?UTF-8?q?=20arm=20h=5Feval=5Floop?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Strata/Transform/StructuredToUnstructuredCorrect.lean | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 6ffc2046c9..cdedd55d6d 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -5852,12 +5852,11 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (h_rest_no_gen_suffix x (by simpa [Cmds.definedVars] using hx) s heq) h_in_b) exact h_inv_loop x h_keep (h_fresh_rest_inits_after x hx) -- ρ_loop_post.eval = ρ₀.eval (loop body has no funcDecls). - have h_eval_loop : ρ_loop_post.eval = ρ₀.eval := by - have := smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + have h_eval_loop : ρ_loop_post.eval = ρ₀.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval [.loop (.det guardExpr) none [] body md] ρ₀ ρ_loop_post (by simp [Block.noFuncDecl, Stmt.noFuncDecl, h_nofd_body]) (by simpa using h_loop_term) - exact this have hwfb_loop : WellFormedSemanticEvalBool ρ_loop_post.eval := h_eval_loop ▸ hwfb have hwfv_loop : WellFormedSemanticEvalVal ρ_loop_post.eval := h_eval_loop ▸ hwfv have hwf_def_loop : WellFormedSemanticEvalDef ρ_loop_post.eval := h_eval_loop ▸ hwf_def From ca1223878470371cd0f1149973c4a9c7c3bd2770 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 03:31:51 -0700 Subject: [PATCH 19/33] =?UTF-8?q?simplify(3):=20have-exact-this-2566=20?= =?UTF-8?q?=E2=80=94=20inline=20h=5Fshape=5Flentry=20to=20single=20term?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Strata/Transform/StructuredToUnstructuredCorrect.lean | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index cdedd55d6d..48412c2d36 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -2561,11 +2561,9 @@ private theorem stmtsToBlocks_invariant rcases h_inv_rest.fresh lentry h_bs with h_gr | h_user · exact h_lentry_notin_gen_r h_gr.1 · have h_shape := h_inv_rest.user_shape lentry h_user - have h_shape_lentry : - String.HasUnderscoreDigitSuffix lentry := by - have := StringGenState.hasUnderscoreDigitSuffix_of_mem_generated - (h_inv_le_step.wf_out) h_lentry_in_gen_le - exact this + have h_shape_lentry : String.HasUnderscoreDigitSuffix lentry := + StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + h_inv_le_step.wf_out h_lentry_in_gen_le exact h_shape h_shape_lentry · -- bbs: from h_inv_body.fresh rcases h_inv_body.fresh lentry h_bb with h_gb | h_user From 1a86b94a54e0b1ffcafc3013678b886a564188d9 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 03:41:08 -0700 Subject: [PATCH 20/33] =?UTF-8?q?simplify(4):=20unique-combined-ite-triple?= =?UTF-8?q?=20=E2=80=94=20merge=20then/else/rest=20projections=20into=20on?= =?UTF-8?q?e=203-way=20Nodup=20conjunction=20lemma?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../StructuredToUnstructuredCorrect.lean | 64 +++++++------------ 1 file changed, 24 insertions(+), 40 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 48412c2d36..c4a2f8cd15 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4101,43 +4101,25 @@ private theorem fresh_rest_inits_body_step {P : PureExpr} [HasIdent P] (StringGenState.not_mem_stringGens_of_not_hasUnderscoreDigitSuffix h_wf_b (h_rest_no_gen_suffix x (by simp [Cmds.definedVars]; exact hx) s heq))) -/-- Project the `thenBranch` slot's init-vars Nodup out of the .ite-arm - `h_unique_outer_inits`. Used for `h_unique_combined_then`. -/ -private theorem unique_combined_ite_then {P : PureExpr} [HasIdent P] +/-- Project all three slot init-vars `Nodup` facts (`thenBranch`, `elseBranch`, + `rest`) out of the .ite-arm `h_unique_outer_inits`. Components are consumed + via `.1` / `.2.1` / `.2.2` for `h_unique_combined_{then,else,rest}`. -/ +private theorem unique_combined_ite {P : PureExpr} [HasIdent P] {accum : List (Cmd P)} {thenBranch elseBranch rest : List (Stmt P (Cmd P))} (h_unique_outer_inits : (Cmds.definedVars accum.reverse ++ ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ Block.initVars rest)).Nodup) : - (Cmds.definedVars ([] : List (Cmd P)).reverse ++ Block.initVars thenBranch).Nodup := by - simp [Cmds.definedVars] - exact (List.nodup_append.mp - (List.nodup_append.mp (List.nodup_append.mp h_unique_outer_inits).2.1).1).1 - -/-- Project the `elseBranch` slot's init-vars Nodup out of the .ite-arm - `h_unique_outer_inits`. Used for `h_unique_combined_else`. -/ -private theorem unique_combined_ite_else {P : PureExpr} [HasIdent P] - {accum : List (Cmd P)} {thenBranch elseBranch rest : List (Stmt P (Cmd P))} - (h_unique_outer_inits : - (Cmds.definedVars accum.reverse ++ - ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ - Block.initVars rest)).Nodup) : - (Cmds.definedVars ([] : List (Cmd P)).reverse ++ Block.initVars elseBranch).Nodup := by - simp [Cmds.definedVars] - exact (List.nodup_append.mp - (List.nodup_append.mp (List.nodup_append.mp h_unique_outer_inits).2.1).1).2.1 - -/-- Project the `rest` slot's init-vars Nodup out of the .ite-arm - `h_unique_outer_inits`. Used for `h_unique_combined_rest` after .ite. -/ -private theorem unique_combined_ite_rest {P : PureExpr} [HasIdent P] - {accum : List (Cmd P)} {thenBranch elseBranch rest : List (Stmt P (Cmd P))} - (h_unique_outer_inits : - (Cmds.definedVars accum.reverse ++ - ((Block.initVars thenBranch ++ Block.initVars elseBranch) ++ - Block.initVars rest)).Nodup) : - (Cmds.definedVars ([] : List (Cmd P)).reverse ++ Block.initVars rest).Nodup := by - simp [Cmds.definedVars] - exact (List.nodup_append.mp (List.nodup_append.mp h_unique_outer_inits).2.1).2.1 + (Cmds.definedVars ([] : List (Cmd P)).reverse ++ Block.initVars thenBranch).Nodup + ∧ (Cmds.definedVars ([] : List (Cmd P)).reverse ++ Block.initVars elseBranch).Nodup + ∧ (Cmds.definedVars ([] : List (Cmd P)).reverse ++ Block.initVars rest).Nodup := by + simp only [Cmds.definedVars, List.reverse_nil, List.nil_append] + refine ⟨?_, ?_, ?_⟩ + · exact (List.nodup_append.mp + (List.nodup_append.mp (List.nodup_append.mp h_unique_outer_inits).2.1).1).1 + · exact (List.nodup_append.mp + (List.nodup_append.mp (List.nodup_append.mp h_unique_outer_inits).2.1).1).2.1 + · exact (List.nodup_append.mp (List.nodup_append.mp h_unique_outer_inits).2.1).2.1 /-- No-op-prepend bundle for the `.typeDecl` arm of `stmtsToBlocks_simulation`. -/ private theorem typeDecl_arm_combined_lemmas {P : PureExpr} @@ -5255,16 +5237,17 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars thenBranch, σ_cfg_after x = none := fun x hx => h_fresh_then_inits x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_ite := unique_combined_ite h_unique_outer_inits have h_unique_combined_then : (Cmds.definedVars [].reverse ++ Block.initVars thenBranch).Nodup := - unique_combined_ite_then h_unique_outer_inits + h_unique_combined_ite.1 have h_combined_else : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars elseBranch, σ_cfg_after x = none := fun x hx => h_fresh_else_inits x (by simpa [Cmds.definedVars] using hx) have h_unique_combined_else : (Cmds.definedVars [].reverse ++ Block.initVars elseBranch).Nodup := - unique_combined_ite_else h_unique_outer_inits + h_unique_combined_ite.2.1 -- Lookup helper for the condGoto helpers have h_lookup : ∀ lbl blk, (lbl, blk) ∈ cfg.blocks → cfg.blocks.lookup lbl = some blk := @@ -5408,7 +5391,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_fresh_rest_inits_branch x (by simpa [Cmds.definedVars] using hx) have h_unique_combined_rest : (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := - unique_combined_ite_rest h_unique_outer_inits + (unique_combined_ite h_unique_outer_inits).2.2 -- Recurse on rest. have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ₁.eval ρ₁.store [].reverse ρ₁.store false := EvalCmds.eval_cmds_none @@ -5519,7 +5502,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_fresh_rest_inits_branch x (by simpa [Cmds.definedVars] using hx) have h_unique_combined_rest : (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := - unique_combined_ite_rest h_unique_outer_inits + (unique_combined_ite h_unique_outer_inits).2.2 -- Recurse on rest. have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ₁.eval ρ₁.store [].reverse ρ₁.store false := EvalCmds.eval_cmds_none @@ -7861,16 +7844,17 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars thenBranch, σ_cfg_after x = none := fun x hx => h_fresh_then_inits x (by simpa [Cmds.definedVars] using hx) + have h_unique_combined_ite := unique_combined_ite h_unique_outer_inits have h_unique_combined_then : (Cmds.definedVars [].reverse ++ Block.initVars thenBranch).Nodup := - unique_combined_ite_then h_unique_outer_inits + h_unique_combined_ite.1 have h_combined_else : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars elseBranch, σ_cfg_after x = none := fun x hx => h_fresh_else_inits x (by simpa [Cmds.definedVars] using hx) have h_unique_combined_else : (Cmds.definedVars [].reverse ++ Block.initVars elseBranch).Nodup := - unique_combined_ite_else h_unique_outer_inits + h_unique_combined_ite.2.1 have h_lookup : ∀ lbl blk, (lbl, blk) ∈ cfg.blocks → cfg.blocks.lookup lbl = some blk := fun lbl blk h_mem => List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup lbl blk h_mem @@ -8113,7 +8097,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_fresh_rest_inits_branch x (by simpa [Cmds.definedVars] using hx) have h_unique_combined_rest : (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := - unique_combined_ite_rest h_unique_outer_inits + (unique_combined_ite h_unique_outer_inits).2.2 have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_mid.eval ρ_mid.store [].reverse ρ_mid.store false := EvalCmds.eval_cmds_none -- Lift `h_store_no_gens_upper` through the thenBranch sub-simulation @@ -8212,7 +8196,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_fresh_rest_inits_branch x (by simpa [Cmds.definedVars] using hx) have h_unique_combined_rest : (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := - unique_combined_ite_rest h_unique_outer_inits + (unique_combined_ite h_unique_outer_inits).2.2 have h_accum_nil_r : EvalCmds P (EvalCmd P) ρ_mid.eval ρ_mid.store [].reverse ρ_mid.store false := EvalCmds.eval_cmds_none -- Lift `h_store_no_gens_upper` through the elseBranch sub-simulation From d8c98ae4dc3abe3b587d5196b1013797ac2959be Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 03:48:46 -0700 Subject: [PATCH 21/33] =?UTF-8?q?simplify(4):=20fresh-body-vs-rest-inits-m?= =?UTF-8?q?irror=20=E2=80=94=20merge=20mirror=20pair=20into=20one=20conjun?= =?UTF-8?q?ction=20lemma=20fresh=5Finits=5Fafter=5Fstep=20(15=20call=20sit?= =?UTF-8?q?es)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../StructuredToUnstructuredCorrect.lean | 126 +++++++----------- 1 file changed, 51 insertions(+), 75 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index c4a2f8cd15..d20b168f4c 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4001,12 +4001,12 @@ private theorem inner_guard_step_r {P : PureExpr} [HasIdent P] | Or.inr h_not_in => Or.inr (fun h_in_r => h_not_in (h_gen_eq_f ▸ h_step_b_to_f.subset (h_step_r_to_b.subset h_in_r))) -/-- Freshness lift through `flushCmds` for `rest`'s init vars. - Discharges `σ_cfg_after x = none` for every `x ∈ Block.initVars rest`, - given the standard combined-Nodup, fresh-on-combined, and +/-- Freshness lift through `flushCmds` for both the `body` and `rest` slots' + init vars, given the standard combined-Nodup, fresh-on-combined, and `flushCmds`-preservation hypotheses, plus the 2-way `h_initvars_eq` shape. + The `.1` component covers `body`, `.2` covers `rest`. Used at every body/then/else paired site in `stmtsToBlocks_simulation`. -/ -private theorem fresh_rest_inits_after_step {P : PureExpr} [HasIdent P] +private theorem fresh_inits_after_step {P : PureExpr} [HasIdent P] {accum : List (Cmd P)} {head : Stmt P (Cmd P)} {body rest : List (Stmt P (Cmd P))} {σ_base σ_cfg_after : SemanticStore P} @@ -4019,50 +4019,26 @@ private theorem fresh_rest_inits_after_step {P : PureExpr} [HasIdent P] σ_base x = none) (h_preserve_flush : ∀ x : P.Ident, σ_base x = none → x ∉ Cmds.definedVars accum.reverse → σ_cfg_after x = none) : - ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := by - intro x hx - have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun h_in_accum => - (h_initvars_eq ▸ List.nodup_append.mp h_unique_combined).2.2 - x h_in_accum x (List.mem_append_right _ hx) rfl - have h_σ_base_x : σ_base x = none := by - apply h_fresh_combined - apply List.mem_append_right - rw [h_initvars_eq] - exact List.mem_append_right _ hx - exact h_preserve_flush x h_σ_base_x h_x_not_accum - -/-- Freshness lift through `flushCmds` for `body`'s init vars (mirror of - `fresh_rest_inits_after_step`, but for the left slot of the 2-way - `h_initvars_eq`). Discharges `σ_cfg_after x = none` for every - `x ∈ Block.initVars body`. -/ -private theorem fresh_body_inits_after_step {P : PureExpr} [HasIdent P] - {accum : List (Cmd P)} - {head : Stmt P (Cmd P)} {body rest : List (Stmt P (Cmd P))} - {σ_base σ_cfg_after : SemanticStore P} - (h_initvars_eq : Block.initVars (head :: rest) = - Block.initVars body ++ Block.initVars rest) - (h_unique_combined : - (Cmds.definedVars accum.reverse ++ Block.initVars (head :: rest)).Nodup) - (h_fresh_combined : - ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars (head :: rest), - σ_base x = none) - (h_preserve_flush : ∀ x : P.Ident, - σ_base x = none → x ∉ Cmds.definedVars accum.reverse → σ_cfg_after x = none) : - ∀ x ∈ Block.initVars body, σ_cfg_after x = none := by - intro x hx - have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun h_in_accum => - (h_initvars_eq ▸ List.nodup_append.mp h_unique_combined).2.2 - x h_in_accum x (List.mem_append_left _ hx) rfl - have h_σ_base_x : σ_base x = none := by - apply h_fresh_combined - apply List.mem_append_right - rw [h_initvars_eq] - exact List.mem_append_left _ hx - exact h_preserve_flush x h_σ_base_x h_x_not_accum + (∀ x ∈ Block.initVars body, σ_cfg_after x = none) + ∧ (∀ x ∈ Block.initVars rest, σ_cfg_after x = none) := by + -- Both slots share the same proof; `h_mem` selects the append side. + have lift : ∀ (seg : List (Stmt P (Cmd P))), + (∀ x, x ∈ Block.initVars seg → + x ∈ Block.initVars body ++ Block.initVars rest) → + ∀ x ∈ Block.initVars seg, σ_cfg_after x = none := by + intro seg h_mem x hx + have h_x_in : x ∈ Block.initVars (head :: rest) := h_initvars_eq ▸ h_mem x hx + have h_x_not_accum : x ∉ Cmds.definedVars accum.reverse := fun h_in_accum => + (List.nodup_append.mp h_unique_combined).2.2 x h_in_accum x h_x_in rfl + have h_σ_base_x : σ_base x = none := + h_fresh_combined x (List.mem_append_right _ h_x_in) + exact h_preserve_flush x h_σ_base_x h_x_not_accum + exact ⟨lift body (fun _ hx => List.mem_append_left _ hx), + lift rest (fun _ hx => List.mem_append_right _ hx)⟩ /-- Freshness lift through the body sub-simulation's `h_preserve_body` for `rest`'s init vars. Consumes the `_after` freshness from - `fresh_rest_inits_after_step`, plus `h_unique`, the 2-way `h_initvars_eq`, + `fresh_inits_after_step`, plus `h_unique`, the 2-way `h_initvars_eq`, `h_preserve_body` (5-premise form), `h_wf_b`, and the per-element no-gen-suffix discharge. Used at every body/then/else paired site in `stmtsToBlocks_simulation`. -/ @@ -6155,8 +6131,8 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var -- Freshness for rest's inits at σ_cfg_body. have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := - fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).2 have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b h_rest_no_gen_suffix h_fresh_rest_inits_after @@ -6227,8 +6203,8 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] simp [List.lookup] -- Freshness for body recursion. have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := - fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).1 have h_combined_body : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, σ_cfg_after x = none := @@ -6274,8 +6250,8 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var -- Freshness for rest's inits at σ_cfg_body. have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := - fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).2 have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b h_rest_no_gen_suffix h_fresh_rest_inits_after @@ -6383,8 +6359,8 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] rcases h_body_term_or_exit with h_body_term | h_body_exit_star · -- Body terminates with ρ_inner. have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := - fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).1 have h_combined_body : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, σ_cfg_after x = none := @@ -6419,8 +6395,8 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := - fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).2 have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b h_rest_no_gen_suffix h_fresh_rest_inits_after @@ -6479,8 +6455,8 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] ((some label, kNext) :: exitConts).lookup (some label) = some kNext := by simp [List.lookup] have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := - fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).1 have h_combined_body : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, σ_cfg_after x = none := @@ -6515,8 +6491,8 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := - fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).2 have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b h_rest_no_gen_suffix h_fresh_rest_inits_after @@ -7156,8 +7132,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has rw [h_beq]; exact h_label -- Freshness for body recursion at σ_cfg_after. have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := - fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).1 have h_combined_body : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, σ_cfg_after x = none := @@ -7202,8 +7178,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has obtain ⟨ρ_blk, h_body_or_match, h_rest_exit⟩ := h_caseB -- Freshness for body recursion at σ_cfg_after. have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := - fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).1 have h_combined_body : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, σ_cfg_after x = none := @@ -7246,8 +7222,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := - fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).2 have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b h_rest_no_gen_suffix h_fresh_rest_inits_after @@ -7328,8 +7304,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := - fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).2 have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b h_rest_no_gen_suffix h_fresh_rest_inits_after @@ -7438,8 +7414,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has rw [beq_eq_false_iff_ne]; intro h; exact h_label_ne h.symm rw [h_beq]; exact h_label have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := - fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).1 have h_combined_body : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, σ_cfg_after x = none := @@ -7479,8 +7455,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has exact h_preserve_body x h_σ_after_x h_nil_not h_x_not_body h_inner_guard_b · obtain ⟨ρ_blk, h_body_or_match, h_rest_exit⟩ := h_caseB have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := - fresh_body_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).1 have h_combined_body : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars body, σ_cfg_after x = none := @@ -7521,8 +7497,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := - fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).2 have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b h_rest_no_gen_suffix h_fresh_rest_inits_after @@ -7603,8 +7579,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_blk.eval := h_eval_blk ▸ hwf_congr have hwf_var₁ : WellFormedSemanticEvalVar ρ_blk.eval := h_eval_blk ▸ hwf_var have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := - fresh_rest_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined - h_preserve_flush + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).2 have h_fresh_rest_inits_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body h_wf_b h_rest_no_gen_suffix h_fresh_rest_inits_after From 661e901a394de0fb67a608d40cd9e0d42306d3eb Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 09:02:57 -0700 Subject: [PATCH 22/33] fix(ci): align goto metadata with infra base (no default arg) CI builds PR #1348 as a merge into its base htd/structured-to-unstructured-small-step-infra. The base removed the default `(md : MetaData P := .empty)` on DetTransferCmd.goto and updated flushCmds to pass `.goto k .empty` explicitly. This proof branch had stale copies that re-added the default and reverted flushCmds to bare `.goto k`, which built locally (default present) but fails in the CI merge (infra's no-default goto wins, leaving bare `.goto k` call sites ill-typed). Align with the infra base: - BasicBlock.lean: drop the `:= .empty` default on DetTransferCmd.goto - StructuredToUnstructured.lean: flushCmds emits `.goto k .empty` - StructuredToUnstructuredCorrect.lean: 2 flushCmds-lemma sites now write `DetTransferCmd.goto k .empty` explicitly Both infra-owned files now match origin/htd/structured-to-unstructured-small-step-infra exactly (zero diff). Clean full build green (489 jobs, StructuredToUnstructuredCorrect rebuilt from scratch in 308s); 0 sorries, 0 axioms; axiom footprint [propext, Classical.choice, Quot.sound] preserved. --- Strata/DL/Imperative/BasicBlock.lean | 2 +- Strata/Transform/StructuredToUnstructured.lean | 2 +- Strata/Transform/StructuredToUnstructuredCorrect.lean | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Strata/DL/Imperative/BasicBlock.lean b/Strata/DL/Imperative/BasicBlock.lean index debd34cda5..5ae37a9c65 100644 --- a/Strata/DL/Imperative/BasicBlock.lean +++ b/Strata/DL/Imperative/BasicBlock.lean @@ -39,7 +39,7 @@ inductive DetTransferCmd (Label : Type) (P : PureExpr) where model it instead using `condGoto`. By defining this function, we can easily create unconditional jumps, and future proof against the possibility of adding it as a constructor in the future. -/ -@[expose] def DetTransferCmd.goto [HasBool P] (l : Label) (md : MetaData P := .empty) : DetTransferCmd Label P := +@[expose] def DetTransferCmd.goto [HasBool P] (l : Label) (md : MetaData P) : DetTransferCmd Label P := condGoto HasBool.tt l l md /-- A `NondetTransfer` command terminates a non-deterministic basic block, diff --git a/Strata/Transform/StructuredToUnstructured.lean b/Strata/Transform/StructuredToUnstructured.lean index e751fc2b6c..ae567d37e7 100644 --- a/Strata/Transform/StructuredToUnstructured.lean +++ b/Strata/Transform/StructuredToUnstructured.lean @@ -43,7 +43,7 @@ def flushCmds pure (k, []) else let l ← StringGenState.gen pfx - let b := (l, { cmds := accum.reverse, transfer := .goto k }) + let b := (l, { cmds := accum.reverse, transfer := .goto k .empty }) pure (l, [b]) | some tr => let l ← StringGenState.gen pfx diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index d20b168f4c..eee7018646 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -3682,13 +3682,13 @@ private theorem flushCmds_simulation_agree {P : PureExpr} [HasFvar P] [HasNot P] h_unique_accum have h_mem : ((StringGenState.gen pfx gen).fst, - ({ cmds := accum.reverse, transfer := DetTransferCmd.goto k } + ({ cmds := accum.reverse, transfer := DetTransferCmd.goto k .empty } : DetBlock String (Cmd P) P)) ∈ cfg.blocks := h_cfg_blocks _ (List.Mem.head _) have h_cond_tt : ρ₀.eval σ_cfg_after HasBool.tt = .some HasBool.tt := eval_tt_is_tt ρ₀.eval σ_cfg_after hwfv have h_lkp : cfg.blocks.lookup (StringGenState.gen pfx gen).fst = - some { cmds := accum.reverse, transfer := DetTransferCmd.goto k } := + some { cmds := accum.reverse, transfer := DetTransferCmd.goto k .empty } := List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup _ _ h_mem -- `.goto k` ≡ `.condGoto tt k k .empty`; reuse `run_block_goto_true`. have h_lkp' : cfg.blocks.lookup (StringGenState.gen pfx gen).fst = From ab2097a495c9db6880e4f73587f0f65d7d986aaf Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 21:51:32 -0700 Subject: [PATCH 23/33] =?UTF-8?q?simplify(4):=20loop=5Fiterations=5Fdet-de?= =?UTF-8?q?ad-{h=5Fbody=5Fno=5Finits,hwfv=5Fpre,hwfvar=5Fpre}=20=E2=80=94?= =?UTF-8?q?=20drop=203=20unused=20binders=20+=20their=20positional=20args?= =?UTF-8?q?=20at=202=20call=20sites?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Strata/Transform/StructuredToUnstructuredCorrect.lean | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index eee7018646..3bca478b49 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -4536,7 +4536,6 @@ private theorem loop_iterations_det (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) (.terminal ρ_post_loop)) - (h_body_no_inits : Block.initVars body = []) (h_nofd_body : Block.noFuncDecl body = true) (h_body_sim_at : ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), @@ -4552,8 +4551,6 @@ private theorem loop_iterations_det StoreAgreement ρ_body.store σ_cfg_after_body ∧ storeInv σ_cfg_after_body) (hwfb_pre : WellFormedSemanticEvalBool ρ_pre.eval) - (hwfv_pre : WellFormedSemanticEvalVal ρ_pre.eval) - (hwfvar_pre : WellFormedSemanticEvalVar ρ_pre.eval) (hwf_def_pre : WellFormedSemanticEvalDef ρ_pre.eval) (hwfcongr_pre : WellFormedSemanticEvalExprCongr ρ_pre.eval) : ∃ σ_cfg_kNext, @@ -5787,8 +5784,8 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have ⟨σ_cfg_kNext, h_loop_run, h_agree_loop, h_inv_loop⟩ := InlineLoopHelpers.loop_iterations_det extendEval guardExpr body md ρ₀ ρ_loop_post cfg lentry kNext bl σ_cfg_after storeInv h_lentry_lkp h_agree_after h_inv_after - h_loop_stmt h_body_no_inits h_nofd_body h_body_sim_at - hwfb hwfv hwf_var hwf_def hwf_congr + h_loop_stmt h_nofd_body h_body_sim_at + hwfb hwf_def hwf_congr -- Recover store-no-gens and rest-freshness at σ_cfg_kNext from storeInv. have h_sng_loop : ∀ x : String, String.HasUnderscoreDigitSuffix x → x ∉ StringGenState.stringGens genUpperBound → @@ -8533,8 +8530,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have ⟨σ_cfg_kNext, h_loop_run, h_agree_loop, h_inv_loop⟩ := InlineLoopHelpers.loop_iterations_det extendEval guardExpr body md ρ₀ ρ_loop_post cfg lentry kNext bl σ_cfg_after storeInv h_lentry_lkp h_agree_after h_inv_after - h_loop_stmt h_body_no_inits h_nofd_body h_body_sim_at - hwfb hwfv hwf_var hwf_def hwf_congr + h_loop_stmt h_nofd_body h_body_sim_at + hwfb hwf_def hwf_congr have h_sng_loop : ∀ x : String, String.HasUnderscoreDigitSuffix x → x ∉ StringGenState.stringGens genUpperBound → σ_cfg_kNext (HasIdent.ident (P := P) x) = none := From 5b2a5ce2faa981eef977e38ed612197047d8ff37 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 10 Jun 2026 22:08:06 -0700 Subject: [PATCH 24/33] =?UTF-8?q?simplify(4):=20h-combined-no-gen-suffix-g?= =?UTF-8?q?et=20=E2=80=94=20drop=20dead=20getVars=20NoGenSuffix=20thread?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The _get NoGenSuffix carry was self-referential: every derivative (h_{then,else,rest,body}_no_gen_suffix_get) flowed only into another recursive/sibling/helper call's _get slot, and the real freshness consumers use the definedVars variant. Removed the binder from both mutual lemmas (stmtsToBlocks_simulation, _to_cont), the param + return conjunct from both arm helpers (cmd_arm_combined_lemmas, typeDecl_arm_combined_lemmas), and the two top-level callers (stmtsToCFG_terminal, structuredToUnstructured_sound), plus the now-dead h_getvars_eq rebracketing helpers. --- .../StructuredToUnstructuredCorrect.lean | 215 ++---------------- 1 file changed, 16 insertions(+), 199 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 3bca478b49..254f0ea6dd 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -3913,14 +3913,12 @@ private theorem cmd_arm_combined_lemmas {P : PureExpr} (h_fresh : ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars (.cmd c :: rest), σ_base x = none) (h_uniq : (Cmds.definedVars accum.reverse ++ Block.initVars (.cmd c :: rest)).Nodup) (h_no_d : NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ Block.initVars (.cmd c :: rest))) - (h_no_m : NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars (.cmd c :: rest))) - (h_no_g : NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ Block.getVars (.cmd c :: rest))) : + (h_no_m : NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars (.cmd c :: rest))) : Cmds.definedVars (accum.reverse ++ [c]) = Cmds.definedVars accum.reverse ++ Cmd.definedVars c ∧ (∀ x ∈ Cmds.definedVars (c :: accum).reverse ++ Block.initVars rest, σ_base x = none) ∧ (Cmds.definedVars (c :: accum).reverse ++ Block.initVars rest).Nodup ∧ (NoGenSuffix (P := P) (Cmds.definedVars (c :: accum).reverse ++ Block.initVars rest)) - ∧ (NoGenSuffix (P := P) (Cmds.modifiedVars (c :: accum).reverse ++ transformBlockModVars rest)) - ∧ (NoGenSuffix (P := P) (Cmds.getVars (c :: accum).reverse ++ Block.getVars rest)) := by + ∧ (NoGenSuffix (P := P) (Cmds.modifiedVars (c :: accum).reverse ++ transformBlockModVars rest)) := by have h_d_snoc : Cmds.definedVars (accum.reverse ++ [c]) = Cmds.definedVars accum.reverse ++ Cmd.definedVars c := by induction accum.reverse with @@ -3941,27 +3939,11 @@ private theorem cmd_arm_combined_lemmas {P : PureExpr} Cmds.modifiedVars accum.reverse ++ transformBlockModVars (.cmd c :: rest) := by rw [List.reverse_cons, h_m_snoc, transformBlockModVars_cons, transformStmtModVars_cmd, List.append_assoc] - have h_get_cons : ∀ (cd : Cmd P) (cs : List (Cmd P)), - Cmds.getVars (cd :: cs) = Cmd.getVars cd ++ Cmds.getVars cs := - fun _ _ => by rw [Cmds.getVars.eq_def] - have h_g_snoc : Cmds.getVars (accum.reverse ++ [c]) = - Cmds.getVars accum.reverse ++ Cmd.getVars c := by - induction accum.reverse with - | nil => simp [Cmds.getVars] - | cons hd tl ih => - rw [List.cons_append, h_get_cons hd (tl ++ [c]), h_get_cons hd tl, ih, List.append_assoc] - have h_g : Cmds.getVars (c :: accum).reverse ++ Block.getVars rest = - Cmds.getVars accum.reverse ++ Block.getVars (.cmd c :: rest) := by - rw [List.reverse_cons, h_g_snoc] - show Cmds.getVars accum.reverse ++ Cmd.getVars c ++ Block.getVars rest - = Cmds.getVars accum.reverse ++ (Cmd.getVars c ++ Block.getVars rest) - rw [List.append_assoc] exact ⟨h_d_snoc, fun x hx => h_fresh x (h_d ▸ hx), h_d ▸ h_uniq, fun x hx s heq => h_no_d x (h_d ▸ hx) s heq, - fun x hx s heq => h_no_m x (h_m ▸ hx) s heq, - fun x hx s heq => h_no_g x (h_g ▸ hx) s heq⟩ + fun x hx s heq => h_no_m x (h_m ▸ hx) s heq⟩ /-- Lift the outer guard `gen → gen'` to the inner guard `gen_r → gen_b`, given the GenStep chain `gen → gen_r` and `gen_b → gen_f = gen'`. @@ -4105,29 +4087,21 @@ private theorem typeDecl_arm_combined_lemmas {P : PureExpr} (h_fresh : ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars (.typeDecl tc md :: rest), σ_base x = none) (h_uniq : (Cmds.definedVars accum.reverse ++ Block.initVars (.typeDecl tc md :: rest)).Nodup) (h_no_d : NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ Block.initVars (.typeDecl tc md :: rest))) - (h_no_m : NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars (.typeDecl tc md :: rest))) - (h_no_g : NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ Block.getVars (.typeDecl tc md :: rest))) : + (h_no_m : NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars (.typeDecl tc md :: rest))) : (∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars rest, σ_base x = none) ∧ (Cmds.definedVars accum.reverse ++ Block.initVars rest).Nodup ∧ (NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ Block.initVars rest)) - ∧ (NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars rest)) - ∧ (NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ Block.getVars rest)) := by + ∧ (NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars rest)) := by have h_d : Cmds.definedVars accum.reverse ++ Block.initVars rest = Cmds.definedVars accum.reverse ++ Block.initVars (.typeDecl tc md :: rest) := by simp [Block.initVars, Stmt.initVars] have h_m : Cmds.modifiedVars accum.reverse ++ transformBlockModVars rest = Cmds.modifiedVars accum.reverse ++ transformBlockModVars (.typeDecl tc md :: rest) := by rw [transformBlockModVars_cons, transformStmtModVars_typeDecl, List.nil_append] - have h_g : Cmds.getVars accum.reverse ++ Block.getVars rest = - Cmds.getVars accum.reverse ++ Block.getVars (.typeDecl tc md :: rest) := by - show Cmds.getVars accum.reverse ++ Block.getVars rest = - Cmds.getVars accum.reverse ++ (Stmt.getVars (Stmt.typeDecl tc md) ++ Block.getVars rest) - rfl exact ⟨fun x hx => h_fresh x (h_d ▸ hx), h_d ▸ h_uniq, fun x hx s heq => h_no_d x (h_d ▸ hx) s heq, - fun x hx s heq => h_no_m x (h_m ▸ hx) s heq, - fun x hx s heq => h_no_g x (h_g ▸ hx) s heq⟩ + fun x hx s heq => h_no_m x (h_m ▸ hx) s heq⟩ /-! ### InlineLoopHelpers @@ -4903,8 +4877,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ Block.initVars ss)) (h_combined_no_gen_suffix_mod : NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars ss)) - (h_combined_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ Block.getVars ss)) (genUpperBound : StringGenState) (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) (h_store_no_gens_upper : ∀ x : String, @@ -4982,12 +4954,10 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (Block.noMeasureLoops_cons_iff.mp h_nml).2 -- Snoc/cons rebracketing facts shared between _simulation and _to_cont. have ⟨h_definedVars_snoc, h_fresh_combined', h_unique_combined', - h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', - h_combined_no_gen_suffix_get'⟩ := + h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod'⟩ := cmd_arm_combined_lemmas c accum rest σ_base h_fresh_combined h_unique_combined h_combined_no_gen_suffix h_combined_no_gen_suffix_mod - h_combined_no_gen_suffix_get have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := stmtsToBlocks_simulation extendEval k rest exitConts (c :: accum) gen gen' entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest @@ -4997,7 +4967,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_rest_star h_accum' h_agree_entry h_fresh_combined' h_unique_combined' h_hf' h_wf_gen h_combined_no_gen_suffix' h_combined_no_gen_suffix_mod' - h_combined_no_gen_suffix_get' genUpperBound h_outer_upper h_store_no_gens_upper cfg h_cfg_blocks h_cfg_nodup refine ⟨σ_cfg, h_step, h_agree, ?_⟩ @@ -5292,27 +5261,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun x hx s heq => h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq - -- Mirror of h_initvars_eq / no_gen_suffix discharges for getVars. - have h_getvars_eq : - Block.getVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md :: rest) = - (HasVarsPure.getVars e ++ Block.getVars thenBranch ++ Block.getVars elseBranch) ++ - Block.getVars rest := by - show Stmt.getVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md) ++ - Block.getVars rest = _ - rfl - have h_then_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars thenBranch) := fun x hx s heq => - h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_left _ (List.mem_append_left _ (List.mem_append_right _ - (by simpa [Cmds.getVars] using hx))))) s heq - have h_else_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars elseBranch) := fun x hx s heq => - h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.getVars] using hx)))) s heq - have h_rest_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := fun x hx s heq => - h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq rcases h_ite_inv with h_true | h_false · obtain ⟨h_then_term, h_cond_tt⟩ := h_true -- Step from accumEntry to tl via the lifted accum + condGoto. @@ -5335,7 +5283,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_then_term h_accum_nil_t h_agree_after h_combined_then h_unique_combined_then (by simp) h_wf_ite h_then_no_gen_suffix h_then_no_gen_suffix_mod - h_then_no_gen_suffix_get genUpperBound h_outer_upper_t h_store_no_gens_upper_after cfg h_cfg_tbs h_cfg_nodup -- Freshness of rest's inits at σ_branch. @@ -5386,7 +5333,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_rest_star h_accum_nil_r h_agree_then h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_t cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ @@ -5446,7 +5392,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_else_term h_accum_nil_f h_agree_after h_combined_else h_unique_combined_else (by simp) h_wf_t h_else_no_gen_suffix h_else_no_gen_suffix_mod - h_else_no_gen_suffix_get genUpperBound h_outer_upper_e h_store_no_gens_upper_after cfg h_cfg_fbs h_cfg_nodup -- Freshness of rest's inits at σ_branch. @@ -5497,7 +5442,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_rest_star h_accum_nil_r h_agree_else h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_e cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ @@ -5675,18 +5619,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (List.mem_append_right _ (by rw [transformBlockModVars_cons, transformStmtModVars_loop] exact List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hx))) s heq - have h_getvars_eq : - Block.getVars (Stmt.loop (.det guardExpr) none [] body md :: rest) = - (HasVarsPure.getVars guardExpr ++ Block.getVars body) ++ Block.getVars rest := by - show Stmt.getVars (Stmt.loop (.det guardExpr) none [] body md) ++ Block.getVars rest = _ - simp only [Stmt.getVars, ExprOrNondet.getVars, List.flatMap_nil, - List.append_nil] - have h_body_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars body) := - fun x hx s heq => h_combined_no_gen_suffix_get x - (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_left _ (List.mem_append_right _ - (by simpa [Cmds.getVars] using hx)))) s heq -- The store invariant threaded through the loop preserves freshness (relative -- to σ_cfg_after) for any var satisfying the body's gen-guard `P_keep`. Both -- rest's inits and the outer-call's fresh var satisfy `P_keep`. @@ -5755,7 +5687,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] ρ_iter ρ_body hwfb_iter hwfv_iter hwf_def_iter hwf_congr_iter hwf_var_iter h_body_run h_accum_nil h_agree_iter h_combined_body h_unique_combined_body h_hf_iter - h_wf_le h_body_no_gen_suffix h_body_no_gen_suffix_mod h_body_no_gen_suffix_get + h_wf_le h_body_no_gen_suffix h_body_no_gen_suffix_mod genUpperBound h_outer_upper_b h_sng_iter cfg h_cfg_bbs h_cfg_nodup refine ⟨σ_cfg_after_body, h_step_body, h_agree_body, ?_⟩ @@ -5831,12 +5763,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (List.mem_append_right _ (by rw [transformBlockModVars_cons, transformStmtModVars_loop] exact List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq - have h_rest_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := - fun x hx s heq => h_combined_no_gen_suffix_get x - (List.mem_append_right _ (by - show x ∈ Stmt.getVars (Stmt.loop (.det guardExpr) none [] body md) ++ Block.getVars rest - exact List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation extendEval k rest exitConts [] gen gen_r kNext bsRest h_rest_eq h_nofd_rest h_simple_rest h_unique_rest @@ -5845,7 +5771,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] ρ_loop_post ρ' hwfb_loop hwfv_loop hwf_def_loop hwf_congr_loop hwf_var_loop h_rest_term h_accum_nil_r h_agree_loop h_combined_rest h_unique_combined_rest h_hf_loop - h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod h_rest_no_gen_suffix_get + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod genUpperBound h_outer_upper_r h_sng_loop cfg h_cfg_bsRest h_cfg_nodup -- === STEP 9: Compose and discharge. === @@ -6000,20 +5926,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun x hx s heq => h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq - -- Mirror of h_initvars_eq / no_gen_suffix discharges for getVars. - have h_getvars_eq : - Block.getVars (Stmt.block label body md :: rest) = - Block.getVars body ++ Block.getVars rest := by - show Stmt.getVars (Stmt.block label body md) ++ Block.getVars rest = _ - rfl - have h_body_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars body) := fun x hx s heq => - h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_left _ (by simpa [Cmds.getVars] using hx))) s heq - have h_rest_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := fun x hx s heq => - h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq -- GenStep chains for WF and subset (block case). have h_step_b_to_f : StringGenState.GenStep gen_b gen_f := flushCmds_genStep _ _ _ _ _ _ _ _ h_flush_eq @@ -6109,7 +6021,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_body_term h_accum_nil h_agree_after h_combined_body h_unique_combined_body (by simp) h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod - h_body_no_gen_suffix_get genUpperBound h_outer_upper_b h_store_no_gens_upper_after cfg h_cfg_bbs h_cfg_nodup -- h_agree_body : StoreAgreement ρ_inner.store σ_cfg_body @@ -6164,7 +6075,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_rest_star h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_body cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ @@ -6229,7 +6139,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_body_exit_star h_accum_nil h_agree_after h_combined_body h_unique_combined_body (by simp) h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod - h_body_no_gen_suffix_get genUpperBound h_outer_upper_b h_store_no_gens_upper_after cfg h_cfg_bbs h_cfg_nodup -- Bridge structured-side projection to CFG. @@ -6282,7 +6191,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_rest_star h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_body cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ @@ -6377,7 +6285,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_body_term h_accum_nil h_agree_after h_combined_body h_unique_combined_body (by simp) h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod - h_body_no_gen_suffix_get genUpperBound h_outer_upper_b h_store_no_gens_upper_after cfg h_cfg_bbs h_cfg_nodup have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := @@ -6425,7 +6332,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_rest_star h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_body cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ @@ -6473,7 +6379,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_body_exit_star h_accum_nil h_agree_after h_combined_body h_unique_combined_body (by simp) h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod - h_body_no_gen_suffix_get genUpperBound h_outer_upper_b h_store_no_gens_upper_after cfg h_cfg_bbs h_cfg_nodup have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := @@ -6521,7 +6426,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_rest_star h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_body cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ @@ -6597,12 +6501,10 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have h_nml_rest : Block.noMeasureLoops rest = true := (Block.noMeasureLoops_cons_iff.mp h_nml).2 have ⟨h_fresh_combined', h_unique_combined', - h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', - h_combined_no_gen_suffix_get'⟩ := + h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod'⟩ := typeDecl_arm_combined_lemmas tc md accum rest σ_base h_fresh_combined h_unique_combined h_combined_no_gen_suffix h_combined_no_gen_suffix_mod - h_combined_no_gen_suffix_get have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := stmtsToBlocks_simulation extendEval k rest exitConts accum gen gen' entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest @@ -6612,7 +6514,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_rest_star h_accum h_agree_entry h_fresh_combined' h_unique_combined' h_hf h_wf_gen h_combined_no_gen_suffix' h_combined_no_gen_suffix_mod' - h_combined_no_gen_suffix_get' genUpperBound h_outer_upper h_store_no_gens_upper cfg h_cfg_blocks h_cfg_nodup refine ⟨σ_cfg, h_step, h_agree, ?_⟩ @@ -6680,8 +6581,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has NoGenSuffix (P := P) (Cmds.definedVars accum.reverse ++ Block.initVars ss)) (h_combined_no_gen_suffix_mod : NoGenSuffix (P := P) (Cmds.modifiedVars accum.reverse ++ transformBlockModVars ss)) - (h_combined_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars accum.reverse ++ Block.getVars ss)) (genUpperBound : StringGenState) (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) (h_store_no_gens_upper : ∀ x : String, @@ -6770,12 +6669,10 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (Block.noMeasureLoops_cons_iff.mp h_nml).2 -- Snoc/cons rebracketing facts shared between _simulation and _to_cont. have ⟨h_definedVars_snoc, h_fresh_combined', h_unique_combined', - h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', - h_combined_no_gen_suffix_get'⟩ := + h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod'⟩ := cmd_arm_combined_lemmas c accum rest σ_base h_fresh_combined h_unique_combined h_combined_no_gen_suffix h_combined_no_gen_suffix_mod - h_combined_no_gen_suffix_get have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts (c :: accum) gen gen' entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest @@ -6785,7 +6682,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_rest_exit h_accum' h_agree_entry h_fresh_combined' h_unique_combined' h_hf' h_wf_gen h_combined_no_gen_suffix' h_combined_no_gen_suffix_mod' - h_combined_no_gen_suffix_get' genUpperBound h_outer_upper h_store_no_gens_upper cfg h_cfg_blocks h_cfg_nodup refine ⟨σ_cfg, h_step, h_agree, ?_⟩ @@ -6853,12 +6749,10 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have h_nml_rest : Block.noMeasureLoops rest = true := (Block.noMeasureLoops_cons_iff.mp h_nml).2 have ⟨h_fresh_combined', h_unique_combined', - h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod', - h_combined_no_gen_suffix_get'⟩ := + h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod'⟩ := typeDecl_arm_combined_lemmas tc md accum rest σ_base h_fresh_combined h_unique_combined h_combined_no_gen_suffix h_combined_no_gen_suffix_mod - h_combined_no_gen_suffix_get have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts accum gen gen' entry blocks h_gen h_nofd_rest h_simple_rest h_unique_rest @@ -6868,7 +6762,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_rest_exit h_accum h_agree_entry h_fresh_combined' h_unique_combined' h_hf h_wf_gen h_combined_no_gen_suffix' h_combined_no_gen_suffix_mod' - h_combined_no_gen_suffix_get' genUpperBound h_outer_upper h_store_no_gens_upper cfg h_cfg_blocks h_cfg_nodup refine ⟨σ_cfg, h_step, h_agree, ?_⟩ @@ -7052,20 +6945,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun x hx s heq => h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq - -- Mirror of h_initvars_eq / no_gen_suffix discharges for getVars. - have h_getvars_eq : - Block.getVars (Stmt.block label' body md :: rest) = - Block.getVars body ++ Block.getVars rest := by - show Stmt.getVars (Stmt.block label' body md) ++ Block.getVars rest = _ - rfl - have h_body_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars body) := fun x hx s heq => - h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_left _ (by simpa [Cmds.getVars] using hx))) s heq - have h_rest_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := fun x hx s heq => - h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq -- GenStep chains for WF and subset (block case). have h_step_b_to_f : StringGenState.GenStep gen_b gen_f := flushCmds_genStep _ _ _ _ _ _ _ _ h_flush_eq @@ -7151,7 +7030,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_body_exit h_accum_nil h_agree_after h_combined_body h_unique_combined_body (by simp) h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod - h_body_no_gen_suffix_get genUpperBound h_outer_upper_b h_store_no_gens_upper_after cfg h_cfg_bbs h_cfg_nodup -- Bridge structured-side projection to CFG. @@ -7204,7 +7082,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_body_term h_accum_nil h_agree_after h_combined_body h_unique_combined_body h_hf_body h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod - h_body_no_gen_suffix_get genUpperBound h_outer_upper_b h_store_no_gens_upper_after cfg h_cfg_bbs h_cfg_nodup have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := @@ -7253,7 +7130,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_rest_exit h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_body cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ @@ -7286,7 +7162,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_body_match h_accum_nil h_agree_after h_combined_body h_unique_combined_body h_hf_body h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod - h_body_no_gen_suffix_get genUpperBound h_outer_upper_b h_store_no_gens_upper_after cfg h_cfg_bbs h_cfg_nodup have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := @@ -7335,7 +7210,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_rest_exit h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_body cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ @@ -7432,7 +7306,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_body_exit h_accum_nil h_agree_after h_combined_body h_unique_combined_body (by simp) h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod - h_body_no_gen_suffix_get genUpperBound h_outer_upper_b h_store_no_gens_upper_after cfg h_cfg_bbs h_cfg_nodup have h_agree_ρ' : StoreAgreement ρ'.store σ_cfg_body := @@ -7479,7 +7352,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_body_term h_accum_nil h_agree_after h_combined_body h_unique_combined_body h_hf_body h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod - h_body_no_gen_suffix_get genUpperBound h_outer_upper_b h_store_no_gens_upper_after cfg h_cfg_bbs h_cfg_nodup have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := @@ -7528,7 +7400,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_rest_exit h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_body cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ @@ -7561,7 +7432,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_body_match h_accum_nil h_agree_after h_combined_body h_unique_combined_body h_hf_body h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod - h_body_no_gen_suffix_get genUpperBound h_outer_upper_b h_store_no_gens_upper_after cfg h_cfg_bbs h_cfg_nodup have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := @@ -7610,7 +7480,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_rest_exit h_accum_nil_r h_agree_block_body h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_body cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg_rest, ?_, h_agree_rest, ?_⟩ @@ -7898,27 +7767,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has NoGenSuffix (P := P) (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun x hx s heq => h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq - -- Mirror of h_initvars_eq / no_gen_suffix discharges for getVars. - have h_getvars_eq : - Block.getVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md :: rest) = - (HasVarsPure.getVars e ++ Block.getVars thenBranch ++ Block.getVars elseBranch) ++ - Block.getVars rest := by - show Stmt.getVars (Stmt.ite (ExprOrNondet.det e) thenBranch elseBranch md) ++ - Block.getVars rest = _ - rfl - have h_then_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars thenBranch) := fun x hx s heq => - h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_left _ (List.mem_append_left _ (List.mem_append_right _ - (by simpa [Cmds.getVars] using hx))))) s heq - have h_else_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars elseBranch) := fun x hx s heq => - h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.getVars] using hx)))) s heq - have h_rest_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := fun x hx s heq => - h_combined_no_gen_suffix_get x (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq rcases h_decomp with h_caseA | h_caseB · -- Branch itself exits with `label`; rest does not run. rcases h_caseA with h_true | h_false @@ -7942,7 +7790,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_then_exit h_accum_nil_t h_agree_after h_combined_then h_unique_combined_then (by simp) h_wf_ite h_then_no_gen_suffix h_then_no_gen_suffix_mod - h_then_no_gen_suffix_get genUpperBound h_outer_upper_t h_store_no_gens_upper_after cfg h_cfg_tbs h_cfg_nodup refine ⟨σ_cfg_branch, ?_, h_agree_branch, ?_⟩ @@ -7980,7 +7827,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_else_exit h_accum_nil_f h_agree_after h_combined_else h_unique_combined_else (by simp) h_wf_t h_else_no_gen_suffix h_else_no_gen_suffix_mod - h_else_no_gen_suffix_get genUpperBound h_outer_upper_e h_store_no_gens_upper_after cfg h_cfg_fbs h_cfg_nodup refine ⟨σ_cfg_branch, ?_, h_agree_branch, ?_⟩ @@ -8042,7 +7888,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_then_term h_accum_nil_t h_agree_after h_combined_then h_unique_combined_then (by simp) h_wf_ite h_then_no_gen_suffix h_then_no_gen_suffix_mod - h_then_no_gen_suffix_get genUpperBound h_outer_upper_t h_store_no_gens_upper_after cfg h_cfg_tbs h_cfg_nodup -- Freshness of rest's inits at σ_branch. @@ -8091,7 +7936,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_rest_exit h_accum_nil_r h_agree_then h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_t cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ @@ -8142,7 +7986,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_else_term h_accum_nil_f h_agree_after h_combined_else h_unique_combined_else (by simp) h_wf_t h_else_no_gen_suffix h_else_no_gen_suffix_mod - h_else_no_gen_suffix_get genUpperBound h_outer_upper_e h_store_no_gens_upper_after cfg h_cfg_fbs h_cfg_nodup have h_fresh_rest_inits_branch : @@ -8190,7 +8033,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_rest_exit h_accum_nil_r h_agree_else h_combined_rest h_unique_combined_rest (by simp) h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod - h_rest_no_gen_suffix_get genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_e cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ @@ -8365,18 +8207,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (List.mem_append_right _ (by rw [transformBlockModVars_cons, transformStmtModVars_loop] exact List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hx))) s heq - have h_getvars_eq : - Block.getVars (Stmt.loop (.det guardExpr) none [] body md :: rest) = - (HasVarsPure.getVars guardExpr ++ Block.getVars body) ++ Block.getVars rest := by - show Stmt.getVars (Stmt.loop (.det guardExpr) none [] body md) ++ Block.getVars rest = _ - simp only [Stmt.getVars, ExprOrNondet.getVars, List.flatMap_nil, - List.append_nil] - have h_body_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars body) := - fun x hx s heq => h_combined_no_gen_suffix_get x - (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_left _ (List.mem_append_right _ - (by simpa [Cmds.getVars] using hx)))) s heq let P_keep : P.Ident → Prop := fun x => ∀ s : String, x = HasIdent.ident (P := P) s → s ∈ StringGenState.stringGens gen_le ∨ s ∉ StringGenState.stringGens gen_b @@ -8444,7 +8274,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has ρ_iter ρ_body hwfb_iter hwfv_iter hwf_def_iter hwf_congr_iter hwf_var_iter h_body_run h_accum_nil h_agree_iter h_combined_body h_unique_combined_body h_hf_iter - h_wf_le h_body_no_gen_suffix h_body_no_gen_suffix_mod h_body_no_gen_suffix_get + h_wf_le h_body_no_gen_suffix h_body_no_gen_suffix_mod genUpperBound h_outer_upper_b (h_sng_of_inv σ_cfg_iter h_inv_iter) cfg h_cfg_bbs h_cfg_nodup refine ⟨σ_cfg_after_body, h_step_body, h_agree_body, ?_⟩ @@ -8494,7 +8324,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has hwfb_iter hwfv_iter hwf_def_iter hwf_congr_iter hwf_var_iter h_body_exit h_accum_nil h_agree_iter h_combined_body h_unique_combined_body h_hf_iter - h_wf_le h_body_no_gen_suffix h_body_no_gen_suffix_mod h_body_no_gen_suffix_get + h_wf_le h_body_no_gen_suffix h_body_no_gen_suffix_mod genUpperBound h_outer_upper_b (h_sng_of_inv σ_cfg_iter h_inv_iter) cfg h_cfg_bbs h_cfg_nodup refine ⟨σ_cfg_after_body, h_step_body, h_agree_body, ?_⟩ @@ -8573,11 +8403,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (List.mem_append_right _ (by rw [transformBlockModVars_cons, transformStmtModVars_loop] exact List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq - have h_rest_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars rest) := - fun x hx s heq => h_combined_no_gen_suffix_get x - (List.mem_append_right _ (h_getvars_eq ▸ - List.mem_append_right _ (by simpa [Cmds.getVars] using hx))) s heq have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := stmtsToBlocks_simulation_to_cont extendEval k rest exitConts [] gen gen_r kNext bsRest h_rest_eq h_nofd_rest h_simple_rest h_unique_rest @@ -8587,7 +8412,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has hwfb_loop hwfv_loop hwf_def_loop hwf_congr_loop hwf_var_loop h_rest_exit h_accum_nil_r h_agree_loop h_combined_rest h_unique_combined_rest h_hf_loop - h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod h_rest_no_gen_suffix_get + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod genUpperBound h_outer_upper_r h_sng_loop cfg h_cfg_bsRest h_cfg_nodup refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ @@ -8748,7 +8573,6 @@ theorem stmtsToCFG_terminal {P : PureExpr} [HasFvar P] [HasNot P] (h_store_clean : ∀ ident : P.Ident, ρ₀.store ident = none) (h_input_no_gen_suffix : NoGenSuffix (P := P) (Block.initVars ss)) (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) (transformBlockModVars ss)) - (h_input_no_gen_suffix_get : NoGenSuffix (P := P) (Block.getVars ss)) (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) : let cfg := stmtsToCFG ss @@ -8783,11 +8607,6 @@ theorem stmtsToCFG_terminal {P : PureExpr} [HasFvar P] [HasNot P] intro x hx s heq simp [Cmds.modifiedVars] at hx exact h_input_no_gen_suffix_mod x hx s heq - have h_combined_no_gen_suffix_get : - NoGenSuffix (P := P) (Cmds.getVars [].reverse ++ Block.getVars ss) := by - intro x hx s heq - simp [Cmds.getVars] at hx - exact h_input_no_gen_suffix_get x hx s heq have h_store_no_gens_upper : ∀ x : String, String.HasUnderscoreDigitSuffix x → x ∉ StringGenState.stringGens gen' → @@ -8798,7 +8617,6 @@ theorem stmtsToCFG_terminal {P : PureExpr} [HasFvar P] [HasNot P] ρ₀.store ρ₀.store false false ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var h_term h_accum (StoreAgreement.refl _) h_fresh_combined h_unique_combined h_hf h_wf_gen h_combined_no_gen_suffix h_combined_no_gen_suffix_mod - h_combined_no_gen_suffix_get gen' (fun _ h => h) h_store_no_gens_upper cfg h_blocks h_nodup have h_end := end_block_terminal extendEval cfg lend σ_cfg ρ'.eval ρ'.hasFailure h_lend @@ -8837,7 +8655,6 @@ theorem structuredToUnstructured_sound {P : PureExpr} [HasFvar P] [HasNot P] (h_store_clean : ∀ ident : P.Ident, ρ₀.store ident = none) (h_input_no_gen_suffix : NoGenSuffix (P := P) (Block.initVars ss)) (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) (transformBlockModVars ss)) - (h_input_no_gen_suffix_get : NoGenSuffix (P := P) (Block.getVars ss)) (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) : let cfg := stmtsToCFG ss @@ -8849,7 +8666,7 @@ theorem structuredToUnstructured_sound {P : PureExpr} [HasFvar P] [HasNot P] hf₀ h_nofd h_simple h_unique h_lbni h_lhni h_nml h_fresh_inits h_disj h_store_clean h_input_no_gen_suffix - h_input_no_gen_suffix_mod h_input_no_gen_suffix_get h_term + h_input_no_gen_suffix_mod h_term end StructuredToUnstructuredCorrect From 8d9ac2ce372a581066b9aacb675be4a611f345ff Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 11 Jun 2026 15:28:57 -0700 Subject: [PATCH 25/33] simplify(5): merge condGoto true/false helper pairs + bundle ite branch-shape projections Three build-verified consolidations in StructuredToUnstructuredCorrect.lean, net -69 LoC (8673 -> 8604), sorry-free, full build green. - flushCmds_condGoto_{true,false}_agree -> flushCmds_condGoto_agree (b : Bool): shared simp/injection/subst/eval-congruence prefix proved once, then cases b dispatches to run_block_goto_true/false; conclusion target (if b then tl else fl). 6 call sites pass true/false. - lentry_condGoto_{true,false} -> lentry_condGoto (b : Bool): same pattern, target (if b then bl else kNext); 3 call sites. - New ite_branch_shape helper bundles the 8 then/else projections (simpleShape / loopBodyNoInits / loopHasNoInvariants / noMeasureLoops) from the 4 head facts; replaces inline have-blocks at both .ite arms of the mutual simulation lemmas. --- .../StructuredToUnstructuredCorrect.lean | 203 ++++++------------ 1 file changed, 67 insertions(+), 136 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 254f0ea6dd..bfded37332 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -3476,12 +3476,15 @@ These variants take the CFG-side accumulated trace pre-lifted via `EvalCmds_under_agreement`, allowing the agreement gap (between structured and CFG entry stores) to be threaded through the simulation. -/ -/-- Variant of `flushCmds_condGoto_true` that operates under StoreAgreement: -the input accum trace is on the CFG side (lifted via `EvalCmds_under_agreement`) -and reaches `σ_cfg_after`, which agrees with `ρ₀.store`. -/ -private theorem flushCmds_condGoto_true_agree {P : PureExpr} [HasFvar P] [HasNot P] +/-- Variant of `flushCmds_condGoto_true`/`_false` that operates under +StoreAgreement: the input accum trace is on the CFG side (lifted via +`EvalCmds_under_agreement`) and reaches `σ_cfg_after`, which agrees with +`ρ₀.store`. The boolean `b` selects the taken branch (`tl` when `tt`, `fl` +when `ff`). -/ +private theorem flushCmds_condGoto_agree {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] (extendEval : ExtendEval P) + (b : Bool) (accum : List (Cmd P)) (e : P.Expr) (tl fl : String) (md : MetaData P) (l_ite : String) (gen_e gen_f : StringGenState) @@ -3496,76 +3499,33 @@ private theorem flushCmds_condGoto_true_agree {P : PureExpr} [HasFvar P] [HasNot (h_accum_cfg : EvalCmds P (EvalCmd P) ρ₀.eval σ_base accum.reverse σ_cfg_after hf_accum) (h_agree_after : StoreAgreement ρ₀.store σ_cfg_after) (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) - (h_cond : ρ₀.eval ρ₀.store e = .some HasBool.tt) + (h_cond : ρ₀.eval ρ₀.store e = .some (if b then HasBool.tt else HasBool.ff)) (cfg : CFG String (DetBlock String (Cmd P) P)) (h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks) (h_lookup : ∀ lbl blk, (lbl, blk) ∈ cfg.blocks → cfg.blocks.lookup lbl = some blk) : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) - (.atBlock tl σ_cfg_after ρ₀.hasFailure) := by + (.atBlock (if b then tl else fl) σ_cfg_after ρ₀.hasFailure) := by simp only [flushCmds, bind, StateT.bind, pure, StateT.pure, Id] at h_flush_eq injection h_flush_eq with h_pair h_gen_eq injection h_pair with h_entry_eq h_blks_eq subst h_entry_eq; subst h_blks_eq have h_def_e : isDefined ρ₀.store (HasVarsPure.getVars e) := - h_wf_def e HasBool.tt ρ₀.store h_cond + h_wf_def e _ ρ₀.store h_cond have h_pointwise : ∀ y ∈ HasVarsPure.getVars e, ρ₀.store y = σ_cfg_after y := store_agreement_pointwise_on_expr_vars ρ₀.store σ_cfg_after e h_agree_after h_def_e - have h_cond_cfg : ρ₀.eval σ_cfg_after e = .some HasBool.tt := by - exact h_cond ▸ (h_congr e ρ₀.store σ_cfg_after h_pointwise).symm + have h_cond_cfg : ρ₀.eval σ_cfg_after e = .some (if b then HasBool.tt else HasBool.ff) := + h_cond ▸ (h_congr e ρ₀.store σ_cfg_after h_pointwise).symm have h_mem := h_cfg_accum _ (List.Mem.head _) have h_lkp := h_lookup _ _ h_mem - have h_run := run_block_goto_true (extendEval := extendEval) (cfg := cfg) - (f_base := hf_base) h_lkp h_accum_cfg h_cond_cfg hwfb h_congr - -- (hf_base || hf_accum) = ρ₀.hasFailure via h_hf - rw [← h_hf] at h_run - exact h_run - -/-- Variant of `flushCmds_condGoto_false` that operates under StoreAgreement. -/ -private theorem flushCmds_condGoto_false_agree {P : PureExpr} [HasFvar P] [HasNot P] - [HasVarsPure P P.Expr] - (extendEval : ExtendEval P) - (accum : List (Cmd P)) - (e : P.Expr) (tl fl : String) (md : MetaData P) - (l_ite : String) (gen_e gen_f : StringGenState) - (accumEntry : String) (accumBlocks : DetBlocks String (Cmd P) P) - (h_flush_eq : flushCmds "ite$" accum - (some (DetTransferCmd.condGoto e tl fl md)) l_ite gen_e = ((accumEntry, accumBlocks), gen_f)) - (σ_base σ_cfg_after : SemanticStore P) (hf_base hf_accum : Bool) - (ρ₀ : Env P) - (hwfb : WellFormedSemanticEvalBool ρ₀.eval) - (h_wf_def : WellFormedSemanticEvalDef ρ₀.eval) - (h_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) - (h_accum_cfg : EvalCmds P (EvalCmd P) ρ₀.eval σ_base accum.reverse σ_cfg_after hf_accum) - (h_agree_after : StoreAgreement ρ₀.store σ_cfg_after) - (h_hf : ρ₀.hasFailure = (hf_base || hf_accum)) - (h_cond : ρ₀.eval ρ₀.store e = .some HasBool.ff) - (cfg : CFG String (DetBlock String (Cmd P) P)) - (h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks) - (h_lookup : ∀ lbl blk, (lbl, blk) ∈ cfg.blocks → - cfg.blocks.lookup lbl = some blk) : - StepDetCFGStar extendEval cfg - (.atBlock accumEntry σ_base hf_base) - (.atBlock fl σ_cfg_after ρ₀.hasFailure) := by - simp only [flushCmds, bind, StateT.bind, pure, StateT.pure, Id] at h_flush_eq - injection h_flush_eq with h_pair h_gen_eq - injection h_pair with h_entry_eq h_blks_eq - subst h_entry_eq; subst h_blks_eq - have h_def_e : isDefined ρ₀.store (HasVarsPure.getVars e) := - h_wf_def e HasBool.ff ρ₀.store h_cond - have h_pointwise : - ∀ y ∈ HasVarsPure.getVars e, ρ₀.store y = σ_cfg_after y := - store_agreement_pointwise_on_expr_vars ρ₀.store σ_cfg_after e h_agree_after h_def_e - have h_cond_cfg : ρ₀.eval σ_cfg_after e = .some HasBool.ff := by - exact h_cond ▸ (h_congr e ρ₀.store σ_cfg_after h_pointwise).symm - have h_mem := h_cfg_accum _ (List.Mem.head _) - have h_lkp := h_lookup _ _ h_mem - have h_run := run_block_goto_false (extendEval := extendEval) (cfg := cfg) - (f_base := hf_base) h_lkp h_accum_cfg h_cond_cfg hwfb h_congr - rw [← h_hf] at h_run - exact h_run + rw [h_hf] + cases b with + | true => exact run_block_goto_true (extendEval := extendEval) (cfg := cfg) + (f_base := hf_base) h_lkp h_accum_cfg h_cond_cfg hwfb h_congr + | false => exact run_block_goto_false (extendEval := extendEval) (cfg := cfg) + (f_base := hf_base) h_lkp h_accum_cfg h_cond_cfg hwfb h_congr /-! ## Block.uniqueInits projection helpers `Block.uniqueInits ss` is a Nodup property of the cumulative `Block.initVars ss` @@ -4339,38 +4299,15 @@ theorem loop_det_decompose_h_gen gen_r, gen_le, gen_b, gen_f, h_rest_eq, h_le_eq, h_body_eq, h_flush_eq, h_gen_eq, h_entry_eq, h_blocks_eq⟩ -/-- Run the (empty-cmds) loop-entry `condGoto` to its true branch: from -`.atBlock lentry σ hf` to `.atBlock bl σ hf`. Bridges the structured guard -`ρ.eval ρ.store g = tt` to the CFG store via `StoreAgreement` + congruence. -/ -private theorem lentry_condGoto_true {P : PureExpr} [HasFvar P] [HasNot P] - [HasVarsPure P P.Expr] - (extendEval : ExtendEval P) - (cfg : CFG String (DetBlock String (Cmd P) P)) - (lentry bl kNext : String) (md : MetaData P) (g : P.Expr) - (δ : SemanticEval P) (σ_struct σ_cfg : SemanticStore P) (hf : Bool) - (h_lkp : cfg.blocks.lookup lentry = some ⟨[], .condGoto g bl kNext md⟩) - (h_agree : StoreAgreement σ_struct σ_cfg) - (hwfb : WellFormedSemanticEvalBool δ) - (h_wf_def : WellFormedSemanticEvalDef δ) - (h_congr : WellFormedSemanticEvalExprCongr δ) - (h_cond : δ σ_struct g = .some HasBool.tt) : - StepDetCFGStar extendEval cfg - (.atBlock lentry σ_cfg hf) (.atBlock bl σ_cfg hf) := by - have h_def_g : isDefined σ_struct (HasVarsPure.getVars g) := - h_wf_def g HasBool.tt σ_struct h_cond - have h_pointwise : ∀ y ∈ HasVarsPure.getVars g, σ_struct y = σ_cfg y := - store_agreement_pointwise_on_expr_vars σ_struct σ_cfg g h_agree h_def_g - have h_cond_cfg : δ σ_cfg g = .some HasBool.tt := - h_cond ▸ (h_congr g σ_struct σ_cfg h_pointwise).symm - have h_run := run_block_goto_true (extendEval := extendEval) (cfg := cfg) - (f_base := hf) h_lkp (EvalCmds.eval_cmds_none) h_cond_cfg hwfb h_congr - simpa using h_run - -/-- Run the (empty-cmds) loop-entry `condGoto` to its false branch: from -`.atBlock lentry σ hf` to `.atBlock kNext σ hf`. -/ -private theorem lentry_condGoto_false {P : PureExpr} [HasFvar P] [HasNot P] +/-- Run the (empty-cmds) loop-entry `condGoto` to the branch selected by `b`: +from `.atBlock lentry σ hf` to `.atBlock bl σ hf` (when `b = true`) or +`.atBlock kNext σ hf` (when `b = false`). Bridges the structured guard +`ρ.eval ρ.store g = (if b then tt else ff)` to the CFG store via +`StoreAgreement` + congruence. -/ +private theorem lentry_condGoto {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] (extendEval : ExtendEval P) + (b : Bool) (cfg : CFG String (DetBlock String (Cmd P) P)) (lentry bl kNext : String) (md : MetaData P) (g : P.Expr) (δ : SemanticEval P) (σ_struct σ_cfg : SemanticStore P) (hf : Bool) @@ -4379,18 +4316,20 @@ private theorem lentry_condGoto_false {P : PureExpr} [HasFvar P] [HasNot P] (hwfb : WellFormedSemanticEvalBool δ) (h_wf_def : WellFormedSemanticEvalDef δ) (h_congr : WellFormedSemanticEvalExprCongr δ) - (h_cond : δ σ_struct g = .some HasBool.ff) : + (h_cond : δ σ_struct g = .some (if b then HasBool.tt else HasBool.ff)) : StepDetCFGStar extendEval cfg - (.atBlock lentry σ_cfg hf) (.atBlock kNext σ_cfg hf) := by + (.atBlock lentry σ_cfg hf) (.atBlock (if b then bl else kNext) σ_cfg hf) := by have h_def_g : isDefined σ_struct (HasVarsPure.getVars g) := - h_wf_def g HasBool.ff σ_struct h_cond + h_wf_def g _ σ_struct h_cond have h_pointwise : ∀ y ∈ HasVarsPure.getVars g, σ_struct y = σ_cfg y := store_agreement_pointwise_on_expr_vars σ_struct σ_cfg g h_agree h_def_g - have h_cond_cfg : δ σ_cfg g = .some HasBool.ff := + have h_cond_cfg : δ σ_cfg g = .some (if b then HasBool.tt else HasBool.ff) := h_cond ▸ (h_congr g σ_struct σ_cfg h_pointwise).symm - have h_run := run_block_goto_false (extendEval := extendEval) (cfg := cfg) - (f_base := hf) h_lkp (EvalCmds.eval_cmds_none) h_cond_cfg hwfb h_congr - simpa using h_run + cases b with + | true => simpa using run_block_goto_true (extendEval := extendEval) (cfg := cfg) + (f_base := hf) h_lkp (EvalCmds.eval_cmds_none) h_cond_cfg hwfb h_congr + | false => simpa using run_block_goto_false (extendEval := extendEval) (cfg := cfg) + (f_base := hf) h_lkp (EvalCmds.eval_cmds_none) h_cond_cfg hwfb h_congr /-- Peel one iteration off a det loop's body+continuation derivation. Given the `step_loop_enter` continuation `.seq (.block .none ρ_pre.store (.stmts body @@ -4583,7 +4522,7 @@ private theorem loop_iterations_det simpa using this subst hρ_eq refine ⟨σ_cfg_pre', ?_, h_agree', h_inv'⟩ - exact lentry_condGoto_false extendEval cfg lentry bl kNext md g + exact lentry_condGoto extendEval false cfg lentry bl kNext md g ρ_post'.eval ρ_post'.store σ_cfg_pre' ρ_post'.hasFailure h_lentry_lkp h_agree' hwfb' hwf_def' hwfcongr' hg_false | .step _ _ _ (@StepStmt.step_loop_enter _ _ _ _ _ _ _ _ _ _ _ _ @@ -4609,7 +4548,7 @@ private theorem loop_iterations_det have h_step_enter : StepDetCFGStar extendEval cfg (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) (.atBlock bl σ_cfg_pre' ρ_pre'.hasFailure) := - lentry_condGoto_true extendEval cfg lentry bl kNext md g + lentry_condGoto extendEval true cfg lentry bl kNext md g ρ_pre'.eval ρ_pre'.store σ_cfg_pre' ρ_pre'.hasFailure h_lentry_lkp h_agree' hwfb' hwf_def' hwfcongr' hg_true -- CFG step 2: bl → lentry (body sim). @@ -4763,7 +4702,7 @@ private theorem loop_iterations_to_cont_det have h_step_enter : StepDetCFGStar extendEval cfg (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) (.atBlock bl σ_cfg_pre' ρ_pre'.hasFailure) := - lentry_condGoto_true extendEval cfg lentry bl kNext md g + lentry_condGoto extendEval true cfg lentry bl kNext md g ρ_pre'.eval ρ_pre'.store σ_cfg_pre' ρ_pre'.hasFailure h_lentry_lkp h_agree' hwfb' hwf_def' hwfcongr' hg_true rcases peel_off_one_iteration_to_cont_det extendEval g body md ρ_pre' ρ_post' label hrest with @@ -4814,6 +4753,24 @@ private theorem loop_iterations_to_cont_det end InlineLoopHelpers +/-- Project the four shape predicates (`simpleShape`, `loopBodyNoInits`, +`loopHasNoInvariants`, `noMeasureLoops`) of an `.ite (.det e)` statement down to +its `then`/`else` branches, given each predicate's head fact. -/ +private theorem ite_branch_shape {P : PureExpr} + {e : P.Expr} {thenBranch elseBranch : List (Stmt P (Cmd P))} {md : MetaData P} + (h_simple_head : Stmt.simpleShape (.ite (.det e) thenBranch elseBranch md) = true) + (h_lbni_head : Stmt.loopBodyNoInits (.ite (.det e) thenBranch elseBranch md) = true) + (h_lhni_head : Stmt.loopHasNoInvariants (.ite (.det e) thenBranch elseBranch md) = true) + (h_nml_head : Stmt.noMeasureLoops (.ite (.det e) thenBranch elseBranch md) = true) : + Block.simpleShape thenBranch = true ∧ Block.simpleShape elseBranch = true ∧ + Block.loopBodyNoInits thenBranch = true ∧ Block.loopBodyNoInits elseBranch = true ∧ + Block.loopHasNoInvariants thenBranch = true ∧ Block.loopHasNoInvariants elseBranch = true ∧ + Block.noMeasureLoops thenBranch = true ∧ Block.noMeasureLoops elseBranch = true := + ⟨Stmt.simpleShape_branch_then h_simple_head, Stmt.simpleShape_branch_else h_simple_head, + Stmt.loopBodyNoInits_branch_then h_lbni_head, Stmt.loopBodyNoInits_branch_else h_lbni_head, + Stmt.loopHasNoInvariants_branch_then h_lhni_head, Stmt.loopHasNoInvariants_branch_else h_lhni_head, + Stmt.noMeasureLoops_branch_then h_nml_head, Stmt.noMeasureLoops_branch_else h_nml_head⟩ + set_option maxHeartbeats 12800000 in set_option maxRecDepth 4096 in mutual @@ -5071,35 +5028,22 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] (Block.simpleShape_cons_iff.mp h_simple).1 have h_simple_rest : Block.simpleShape rest = true := (Block.simpleShape_cons_iff.mp h_simple).2 - have h_simple_then : Block.simpleShape thenBranch = true := - Stmt.simpleShape_branch_then h_simple_head - have h_simple_else : Block.simpleShape elseBranch = true := - Stmt.simpleShape_branch_else h_simple_head -- Extract loopBodyNoInits / loopHasNoInvariants / noMeasureLoops for sub-blocks. have h_lbni_head : Stmt.loopBodyNoInits (.ite (.det e) thenBranch elseBranch md) = true := (Block.loopBodyNoInits_cons_iff.mp h_lbni).1 have h_lbni_rest : Block.loopBodyNoInits rest = true := (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 - have h_lbni_then : Block.loopBodyNoInits thenBranch = true := - Stmt.loopBodyNoInits_branch_then h_lbni_head - have h_lbni_else : Block.loopBodyNoInits elseBranch = true := - Stmt.loopBodyNoInits_branch_else h_lbni_head have h_lhni_head : Stmt.loopHasNoInvariants (.ite (.det e) thenBranch elseBranch md) = true := (Block.loopHasNoInvariants_cons_iff.mp h_lhni).1 have h_lhni_rest : Block.loopHasNoInvariants rest = true := (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 - have h_lhni_then : Block.loopHasNoInvariants thenBranch = true := - Stmt.loopHasNoInvariants_branch_then h_lhni_head - have h_lhni_else : Block.loopHasNoInvariants elseBranch = true := - Stmt.loopHasNoInvariants_branch_else h_lhni_head have h_nml_head : Stmt.noMeasureLoops (.ite (.det e) thenBranch elseBranch md) = true := (Block.noMeasureLoops_cons_iff.mp h_nml).1 have h_nml_rest : Block.noMeasureLoops rest = true := (Block.noMeasureLoops_cons_iff.mp h_nml).2 - have h_nml_then : Block.noMeasureLoops thenBranch = true := - Stmt.noMeasureLoops_branch_then h_nml_head - have h_nml_else : Block.noMeasureLoops elseBranch = true := - Stmt.noMeasureLoops_branch_else h_nml_head + obtain ⟨h_simple_then, h_simple_else, h_lbni_then, h_lbni_else, + h_lhni_then, h_lhni_else, h_nml_then, h_nml_else⟩ := + ite_branch_shape h_simple_head h_lbni_head h_lhni_head h_nml_head -- Eval well-formedness preservation through ite branch have h_eval_eq : ρ₁.eval = ρ₀.eval := by rcases h_ite_inv with h | h @@ -5267,7 +5211,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) (.atBlock tl σ_cfg_after ρ₀.hasFailure) := - flushCmds_condGoto_true_agree extendEval accum e tl fl md l_ite gen_e gen_f + flushCmds_condGoto_agree extendEval true accum e tl fl md l_ite gen_e gen_f accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_tt cfg h_cfg_accum h_lookup @@ -5376,7 +5320,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) (.atBlock fl σ_cfg_after ρ₀.hasFailure) := - flushCmds_condGoto_false_agree extendEval accum e tl fl md l_ite gen_e gen_f + flushCmds_condGoto_agree extendEval false accum e tl fl md l_ite gen_e gen_f accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_ff cfg h_cfg_accum h_lookup @@ -7593,35 +7537,22 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (Block.simpleShape_cons_iff.mp h_simple).1 have h_simple_rest : Block.simpleShape rest = true := (Block.simpleShape_cons_iff.mp h_simple).2 - have h_simple_then : Block.simpleShape thenBranch = true := - Stmt.simpleShape_branch_then h_simple_head - have h_simple_else : Block.simpleShape elseBranch = true := - Stmt.simpleShape_branch_else h_simple_head -- loopBodyNoInits/loopHasNoInvariants/noMeasureLoops projections. have h_lbni_head : Stmt.loopBodyNoInits (.ite (.det e) thenBranch elseBranch md) = true := (Block.loopBodyNoInits_cons_iff.mp h_lbni).1 have h_lbni_rest : Block.loopBodyNoInits rest = true := (Block.loopBodyNoInits_cons_iff.mp h_lbni).2 - have h_lbni_then : Block.loopBodyNoInits thenBranch = true := - Stmt.loopBodyNoInits_branch_then h_lbni_head - have h_lbni_else : Block.loopBodyNoInits elseBranch = true := - Stmt.loopBodyNoInits_branch_else h_lbni_head have h_lhni_head : Stmt.loopHasNoInvariants (.ite (.det e) thenBranch elseBranch md) = true := (Block.loopHasNoInvariants_cons_iff.mp h_lhni).1 have h_lhni_rest : Block.loopHasNoInvariants rest = true := (Block.loopHasNoInvariants_cons_iff.mp h_lhni).2 - have h_lhni_then : Block.loopHasNoInvariants thenBranch = true := - Stmt.loopHasNoInvariants_branch_then h_lhni_head - have h_lhni_else : Block.loopHasNoInvariants elseBranch = true := - Stmt.loopHasNoInvariants_branch_else h_lhni_head have h_nml_head : Stmt.noMeasureLoops (.ite (.det e) thenBranch elseBranch md) = true := (Block.noMeasureLoops_cons_iff.mp h_nml).1 have h_nml_rest : Block.noMeasureLoops rest = true := (Block.noMeasureLoops_cons_iff.mp h_nml).2 - have h_nml_then : Block.noMeasureLoops thenBranch = true := - Stmt.noMeasureLoops_branch_then h_nml_head - have h_nml_else : Block.noMeasureLoops elseBranch = true := - Stmt.noMeasureLoops_branch_else h_nml_head + obtain ⟨h_simple_then, h_simple_else, h_lbni_then, h_lbni_else, + h_lhni_then, h_lhni_else, h_nml_then, h_nml_else⟩ := + ite_branch_shape h_simple_head h_lbni_head h_lhni_head h_nml_head have h_unique_then : Block.uniqueInits thenBranch := Block.uniqueInits.ite_then h_unique have h_unique_else : Block.uniqueInits elseBranch := @@ -7774,7 +7705,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) (.atBlock tl σ_cfg_after ρ₀.hasFailure) := - flushCmds_condGoto_true_agree extendEval accum e tl fl md l_ite gen_e gen_f + flushCmds_condGoto_agree extendEval true accum e tl fl md l_ite gen_e gen_f accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_tt cfg h_cfg_accum h_lookup @@ -7812,7 +7743,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) (.atBlock fl σ_cfg_after ρ₀.hasFailure) := - flushCmds_condGoto_false_agree extendEval accum e tl fl md l_ite gen_e gen_f + flushCmds_condGoto_agree extendEval false accum e tl fl md l_ite gen_e gen_f accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_ff cfg h_cfg_accum h_lookup @@ -7873,7 +7804,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) (.atBlock tl σ_cfg_after ρ₀.hasFailure) := - flushCmds_condGoto_true_agree extendEval accum e tl fl md l_ite gen_e gen_f + flushCmds_condGoto_agree extendEval true accum e tl fl md l_ite gen_e gen_f accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_tt cfg h_cfg_accum h_lookup @@ -7971,7 +7902,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) (.atBlock fl σ_cfg_after ρ₀.hasFailure) := - flushCmds_condGoto_false_agree extendEval accum e tl fl md l_ite gen_e gen_f + flushCmds_condGoto_agree extendEval false accum e tl fl md l_ite gen_e gen_f accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_ff cfg h_cfg_accum h_lookup From 64c2e00d89047d951579c2dd0e5cd7cb210568c0 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 11 Jun 2026 16:03:44 -0700 Subject: [PATCH 26/33] =?UTF-8?q?simplify(6):=20extract=20invMapM=5FgenSte?= =?UTF-8?q?p=20(dedup=204=20loop-arm=20sites)=20+=20golf=20heval=5Feq=5Fc?= =?UTF-8?q?=20rewrites=20to=20=E2=96=B8?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two build-verified cleanups in StructuredToUnstructuredCorrect.lean, net -16 LoC (8604 -> 8588), sorry-free, full build green. - New private invMapM_genStep: the GenStep obligation for the invariant-assert is.mapM was re-proved 4x across the .loop arm's none/some x det/nondet branches (twice in stmtsToBlocks_genStep, twice in stmtsToBlocks_invariant). It is a fully general fact (quantified over is/gen_b/gen_i/invCmds, built on mapM_genStep, no gen-state threading), so it unified at all 4 sites cleanly. -14 LoC. - Collapsed the remaining `by rw [heval_eq_c]; exact h` WF-lift sites to term-mode `heval_eq_c ▸ h`. -2 LoC. Deeper .loop-arm factoring (the GenInv.trans chains and lentry-freshness blocks) was surveyed and deliberately NOT extracted: those branches share shape but thread distinct gen-state names and carry branch-specific commands, so a parameterized helper pays back what hoisting saves. Confirmed Delta-approx-0 for that region. --- .../StructuredToUnstructuredCorrect.lean | 104 ++++++++---------- 1 file changed, 44 insertions(+), 60 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index bfded37332..1e26986307 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -1409,6 +1409,32 @@ private theorem flushCmds_genStep {P : PureExpr} [HasBool P] rw [this] exact StringGenState.GenStep.of_gen pfx gen +/-- The invariant-assert generating `mapM` in the loop arm only ever calls +`StringGenState.gen "inv$"` (for empty source labels) or no generator at all, +so it produces a `GenStep` from its input to its output state. Shared by both +`stmtsToBlocks_genStep` and `stmtsToBlocks_invariant` across the none/some +measure branches. -/ +private theorem invMapM_genStep {P : PureExpr} [HasPassiveCmds P (Cmd P)] + (is : List (String × P.Expr)) (gen_b gen_i : StringGenState) (invCmds : List (Cmd P)) + (h_inv_def : + ((is.mapM (fun (srcLabel, i) => do + let assertLabel ← + if srcLabel.isEmpty then StringGenState.gen "inv$" + else pure srcLabel + pure (HasPassiveCmds.assert (P := P) (CmdT := Cmd P) assertLabel i synthesizedMd))) + : LabelGen.StringGenM (List (Cmd P))) gen_b = (invCmds, gen_i)) : + StringGenState.GenStep gen_b gen_i := by + apply mapM_genStep _ _ is gen_b gen_i invCmds h_inv_def + intro a g g' b h_step + obtain ⟨srcLabel, i⟩ := a + by_cases h_empty : srcLabel.isEmpty + · simp only [h_empty, if_true, bind, StateT.bind, pure, StateT.pure] at h_step + have h_g_eq : g' = (StringGenState.gen "inv$" g).2 := (Prod.mk.inj h_step).2.symm + rw [h_g_eq]; exact StringGenState.GenStep.of_gen "inv$" g + · simp only [h_empty, bind, pure] at h_step + have h_g_eq : g' = g := (Prod.mk.inj h_step).2.symm + rw [h_g_eq]; exact StringGenState.GenStep.refl g + /-- A weaker invariant for `stmtsToBlocks`: just the `GenStep` part (WF preservation + monotone label list). This holds without any disjointness assumption and is used to bootstrap the full invariant. -/ @@ -1556,19 +1582,8 @@ private theorem stmtsToBlocks_genStep : LabelGen.StringGenM (List (Cmd P))) gen_b = r_inv at h_gen obtain ⟨invCmds, gen_i⟩ := r_inv have h_step_body := stmtsToBlocks_genStep lentry bss _ [] gen_le gen_b bl bbs h_body_eq - have h_step_inv : StringGenState.GenStep gen_b gen_i := by - apply mapM_genStep _ _ is gen_b gen_i invCmds h_inv_def - intro a g g' b h_step - obtain ⟨srcLabel, i⟩ := a - by_cases h_empty : srcLabel.isEmpty - · simp only [h_empty, if_true, bind, StateT.bind, pure, StateT.pure] at h_step - have h_g_eq : g' = (StringGenState.gen "inv$" g).2 := (Prod.mk.inj h_step).2.symm - rw [h_g_eq] - exact StringGenState.GenStep.of_gen "inv$" g - · simp only [h_empty, bind, pure] at h_step - have h_g_eq : g' = g := (Prod.mk.inj h_step).2.symm - rw [h_g_eq] - exact StringGenState.GenStep.refl g + have h_step_inv : StringGenState.GenStep gen_b gen_i := + invMapM_genStep is gen_b gen_i invCmds h_inv_def have h_step_prefix : StringGenState.GenStep gen gen_i := ((h_step_rest.trans h_step_le).trans h_step_body).trans h_step_inv cases c with @@ -1628,19 +1643,8 @@ private theorem stmtsToBlocks_genStep : LabelGen.StringGenM (List (Cmd P))) gen_b = r_inv at h_gen obtain ⟨invCmds, gen_i⟩ := r_inv have h_step_body := stmtsToBlocks_genStep ldec bss _ [] gen_ldec gen_b bl bbs h_body_eq - have h_step_inv : StringGenState.GenStep gen_b gen_i := by - apply mapM_genStep _ _ is gen_b gen_i invCmds h_inv_def - intro a g g' b h_step - obtain ⟨srcLabel, i⟩ := a - by_cases h_empty : srcLabel.isEmpty - · simp only [h_empty, if_true, bind, StateT.bind, pure, StateT.pure] at h_step - have h_g_eq : g' = (StringGenState.gen "inv$" g).2 := (Prod.mk.inj h_step).2.symm - rw [h_g_eq] - exact StringGenState.GenStep.of_gen "inv$" g - · simp only [h_empty, bind, pure] at h_step - have h_g_eq : g' = g := (Prod.mk.inj h_step).2.symm - rw [h_g_eq] - exact StringGenState.GenStep.refl g + have h_step_inv : StringGenState.GenStep gen_b gen_i := + invMapM_genStep is gen_b gen_i invCmds h_inv_def have h_step_prefix : StringGenState.GenStep gen gen_i := ((((h_step_rest.trans h_step_le).trans h_step_ml).trans h_step_ldec).trans h_step_body).trans h_step_inv @@ -2395,17 +2399,8 @@ private theorem stmtsToBlocks_invariant obtain ⟨invCmds, gen_i⟩ := r_inv simp only at h_gen have h_step_body := stmtsToBlocks_genStep lentry bss _ [] gen_le gen_b bl bbs h_body_eq - have h_step_inv : StringGenState.GenStep gen_b gen_i := by - apply mapM_genStep _ _ is gen_b gen_i invCmds h_inv_def - intro a g g' b' h_step - obtain ⟨srcLabel, i⟩ := a - by_cases h_empty : srcLabel.isEmpty - · simp only [h_empty, if_true, bind, StateT.bind, pure, StateT.pure] at h_step - have h_g_eq : g' = (StringGenState.gen "inv$" g).2 := (Prod.mk.inj h_step).2.symm - rw [h_g_eq]; exact StringGenState.GenStep.of_gen "inv$" g - · simp only [h_empty, bind, pure] at h_step - have h_g_eq : g' = g := (Prod.mk.inj h_step).2.symm - rw [h_g_eq]; exact StringGenState.GenStep.refl g + have h_step_inv : StringGenState.GenStep gen_b gen_i := + invMapM_genStep is gen_b gen_i invCmds h_inv_def cases h_c : c with | det e => rw [h_c] at h_gen @@ -2852,17 +2847,8 @@ private theorem stmtsToBlocks_invariant obtain ⟨invCmds, gen_i⟩ := r_inv simp only at h_gen have h_step_body := stmtsToBlocks_genStep ldec bss _ [] gen_ldec gen_b bl bbs h_body_eq - have h_step_inv : StringGenState.GenStep gen_b gen_i := by - apply mapM_genStep _ _ is gen_b gen_i invCmds h_inv_def - intro a g g' b' h_step - obtain ⟨srcLabel, i⟩ := a - by_cases h_empty : srcLabel.isEmpty - · simp only [h_empty, if_true, bind, StateT.bind, pure, StateT.pure] at h_step - have h_g_eq : g' = (StringGenState.gen "inv$" g).2 := (Prod.mk.inj h_step).2.symm - rw [h_g_eq]; exact StringGenState.GenStep.of_gen "inv$" g - · simp only [h_empty, bind, pure] at h_step - have h_g_eq : g' = g := (Prod.mk.inj h_step).2.symm - rw [h_g_eq]; exact StringGenState.GenStep.refl g + have h_step_inv : StringGenState.GenStep gen_b gen_i := + invMapM_genStep is gen_b gen_i invCmds h_inv_def cases h_c : c with | det e => rw [h_c] at h_gen @@ -4892,12 +4878,11 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] h_accum heval_c have h_hf' : ρ₁.hasFailure = (hf_base || (hf_accum || failed_c)) := by rw [hfail_c, h_hf, Bool.or_assoc] - have hwfb' : WellFormedSemanticEvalBool ρ₁.eval := by rw [heval_eq_c]; exact hwfb - have hwfv' : WellFormedSemanticEvalVal ρ₁.eval := by rw [heval_eq_c]; exact hwfv - have hwf_def' : WellFormedSemanticEvalDef ρ₁.eval := by rw [heval_eq_c]; exact hwf_def - have hwf_congr' : WellFormedSemanticEvalExprCongr ρ₁.eval := by - rw [heval_eq_c]; exact hwf_congr - have hwf_var' : WellFormedSemanticEvalVar ρ₁.eval := by rw [heval_eq_c]; exact hwf_var + have hwfb' : WellFormedSemanticEvalBool ρ₁.eval := heval_eq_c ▸ hwfb + have hwfv' : WellFormedSemanticEvalVal ρ₁.eval := heval_eq_c ▸ hwfv + have hwf_def' : WellFormedSemanticEvalDef ρ₁.eval := heval_eq_c ▸ hwf_def + have hwf_congr' : WellFormedSemanticEvalExprCongr ρ₁.eval := heval_eq_c ▸ hwf_congr + have hwf_var' : WellFormedSemanticEvalVar ρ₁.eval := heval_eq_c ▸ hwf_var have h_nofd_rest : Block.noFuncDecl rest = true := by simp [Block.noFuncDecl] at h_nofd; exact h_nofd.2 have h_simple_rest : Block.simpleShape rest = true := @@ -6594,12 +6579,11 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_accum heval_c have h_hf' : ρ₁.hasFailure = (hf_base || (hf_accum || failed_c)) := by rw [hfail_c, h_hf, Bool.or_assoc] - have hwfb' : WellFormedSemanticEvalBool ρ₁.eval := by rw [heval_eq_c]; exact hwfb - have hwfv' : WellFormedSemanticEvalVal ρ₁.eval := by rw [heval_eq_c]; exact hwfv - have hwf_def' : WellFormedSemanticEvalDef ρ₁.eval := by rw [heval_eq_c]; exact hwf_def - have hwf_congr' : WellFormedSemanticEvalExprCongr ρ₁.eval := by - rw [heval_eq_c]; exact hwf_congr - have hwf_var' : WellFormedSemanticEvalVar ρ₁.eval := by rw [heval_eq_c]; exact hwf_var + have hwfb' : WellFormedSemanticEvalBool ρ₁.eval := heval_eq_c ▸ hwfb + have hwfv' : WellFormedSemanticEvalVal ρ₁.eval := heval_eq_c ▸ hwfv + have hwf_def' : WellFormedSemanticEvalDef ρ₁.eval := heval_eq_c ▸ hwf_def + have hwf_congr' : WellFormedSemanticEvalExprCongr ρ₁.eval := heval_eq_c ▸ hwf_congr + have hwf_var' : WellFormedSemanticEvalVar ρ₁.eval := heval_eq_c ▸ hwf_var have h_nofd_rest : Block.noFuncDecl rest = true := by simp [Block.noFuncDecl] at h_nofd; exact h_nofd.2 have h_simple_rest : Block.simpleShape rest = true := From 64c7be714362acd596f64bc516e8d58a4bdc37b2 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 11 Jun 2026 16:40:58 -0700 Subject: [PATCH 27/33] docs: fix stale comments (merged-lemma refs, required-md notation, drifted count) --- .../StructuredToUnstructuredCorrect.lean | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 1e26986307..f6d2127f27 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -74,7 +74,7 @@ theorem StepDetCFGStar_trans {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [ /-- `NoGenSuffix xs` says every ident in `xs` was supplied by user source — i.e. is `HasIdent.ident s` only for strings `s` that are *not* of the underscore-digit-suffix gen shape. Abbreviates a 1-line predicate that -appears verbatim ~89 times in the proofs below. -/ +appears throughout the proofs below. -/ @[expose] abbrev NoGenSuffix {P : PureExpr} [HasIdent P] (xs : List P.Ident) : Prop := ∀ x ∈ xs, ∀ s : String, @@ -221,8 +221,6 @@ theorem run_block_finish {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P. (ReflTrans_Transitive _ _ _ _ h_chain (ReflTrans.step _ _ _ h_finish (ReflTrans.refl _))) -/-! ## Temporary -/ - theorem stmts_nil_terminal {P : PureExpr} [HasBool P] [HasNot P] {CmdT : Type} (EvalCmdR : EvalCmdParam P CmdT) @@ -3456,17 +3454,16 @@ private theorem StepStmtStar_wfv_preserved {P : PureExpr} [HasFvar P] [HasBool P rw [h_eval_eq] exact hwfv -/-! ## Agreement-based variants of flushCmds_condGoto_* +/-! ## Agreement-based condGoto flushing -These variants take the CFG-side accumulated trace pre-lifted via +This lemma takes the CFG-side accumulated trace pre-lifted via `EvalCmds_under_agreement`, allowing the agreement gap (between structured and CFG entry stores) to be threaded through the simulation. -/ -/-- Variant of `flushCmds_condGoto_true`/`_false` that operates under -StoreAgreement: the input accum trace is on the CFG side (lifted via -`EvalCmds_under_agreement`) and reaches `σ_cfg_after`, which agrees with -`ρ₀.store`. The boolean `b` selects the taken branch (`tl` when `tt`, `fl` -when `ff`). -/ +/-- Runs the flushed `condGoto` block under StoreAgreement: the input accum +trace is on the CFG side (lifted via `EvalCmds_under_agreement`) and reaches +`σ_cfg_after`, which agrees with `ρ₀.store`. The boolean `b` selects the taken +branch (`tl` when `tt`, `fl` when `ff`). -/ private theorem flushCmds_condGoto_agree {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] (extendEval : ExtendEval P) @@ -3636,7 +3633,7 @@ private theorem flushCmds_simulation_agree {P : PureExpr} [HasFvar P] [HasNot P] have h_lkp : cfg.blocks.lookup (StringGenState.gen pfx gen).fst = some { cmds := accum.reverse, transfer := DetTransferCmd.goto k .empty } := List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup _ _ h_mem - -- `.goto k` ≡ `.condGoto tt k k .empty`; reuse `run_block_goto_true`. + -- `.goto k .empty` ≡ `.condGoto tt k k .empty`; reuse `run_block_goto_true`. have h_lkp' : cfg.blocks.lookup (StringGenState.gen pfx gen).fst = some { cmds := accum.reverse, transfer := DetTransferCmd.condGoto HasBool.tt k k .empty } := h_lkp From d93789ef748f02692f71514240f1f212437ea129 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 11 Jun 2026 20:15:17 -0700 Subject: [PATCH 28/33] hygiene: tighten maxRecDepth, drop dead linter suppressions + unused imports + vestigial attributes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Build-verified compiler-directive cleanup in StructuredToUnstructuredCorrect.lean, -6 lines, build green, no new warnings, no build-time regression. Kept (8 probes, each individually build-gated): - maxRecDepth 4096 -> 1024 (still 2x the 512 default; the mutual block needs above-default but not 8x). - Removed 2 `set_option linter.unusedVariables false` suppressions (on loop_iterations_det / _to_cont_det) — the earlier dead-binder cleanup made them vestigial; no unused-variable warning resurfaces. - import all Strata.DL.Imperative.BasicBlock -> plain import (the `all` body-exposure was unused). - Dropped public import Strata.DL.Imperative.CmdSemanticsProps (no referenced names). - Dropped public import Strata.Transform.Specification (SpecificationProps re-exports the namespace transitively). - Removed vestigial @[simp] on the StepDetCFGStar abbrev and @[expose] on the NoGenSuffix abbrev (abbrevs are already reducible). Confirmed load-bearing and left in place (probe went RED): - maxHeartbeats 12800000 — genuinely required; RED at both 400000 and 1600000 (whnf timeout, multiple independent hotspots), not vestigial. - import all Strata.DL.Util.Relations — needed for ReflTransT.len exposed-body simp lemmas. - import Strata.Transform.SpecificationProps — the `open ... Specification` depends on it. - @[expose] on transformStmtModVars / transformBlockModVars / Block.userBlockLabels / Block.userLabelsDisjoint — in-file rfl/unfold/show proofs rely on the exposed bodies. --- Strata/Transform/StructuredToUnstructuredCorrect.lean | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index f6d2127f27..06117d9722 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -7,15 +7,13 @@ module public import Strata.DL.Imperative.StmtSemantics public import Strata.DL.Imperative.StmtSemanticsProps -public import Strata.DL.Imperative.CmdSemanticsProps public import Strata.DL.Imperative.CFGSemantics public import Strata.DL.Imperative.KleeneSemanticsProps public import Strata.Transform.StructuredToUnstructured -public import Strata.Transform.Specification public import Strata.Transform.SpecificationProps public import Strata.DL.Util.StringGen public import Strata.Languages.Core.StatementSemantics -import all Strata.DL.Imperative.BasicBlock +import Strata.DL.Imperative.BasicBlock import all Strata.DL.Imperative.Cmd import all Strata.DL.Util.Relations @@ -56,7 +54,6 @@ namespace StructuredToUnstructuredCorrect open Imperative Specification /-! ## Abbreviations -/ -@[simp] abbrev StepDetCFGStar {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] (extendEval : ExtendEval P) (cfg : CFG String (DetBlock String (Cmd P) P)) := @@ -75,7 +72,7 @@ theorem StepDetCFGStar_trans {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [ i.e. is `HasIdent.ident s` only for strings `s` that are *not* of the underscore-digit-suffix gen shape. Abbreviates a 1-line predicate that appears throughout the proofs below. -/ -@[expose] abbrev NoGenSuffix {P : PureExpr} [HasIdent P] +abbrev NoGenSuffix {P : PureExpr} [HasIdent P] (xs : List P.Ident) : Prop := ∀ x ∈ xs, ∀ s : String, x = HasIdent.ident (P := P) s → ¬ String.HasUnderscoreDigitSuffix s @@ -4406,7 +4403,6 @@ private theorem peel_off_one_iteration_to_cont_det {P : PureExpr} [HasFvar P] [H match hr2 with | .step _ _ _ h _ => exact nomatch h -set_option linter.unusedVariables false in /-- Iterate the deterministic loop until termination (small-step). Inducts on the structured-loop derivation length; each iteration consumes a `step_loop_enter` prefix of `h_term`, leaving a strictly shorter tail. @@ -4569,7 +4565,6 @@ private theorem loop_iterations_det rw [h_hf_block] at h_run_recurse exact StepDetCFGStar_trans (StepDetCFGStar_trans h_step_enter h_step_body) h_run_recurse -set_option linter.unusedVariables false in /-- `_to_cont` iteration helper for the det loop: the loop runs some number of terminating iterations, then on some iteration the body exits with `label`, propagating out of the surrounding `.block .none` and hence out of the loop. @@ -4755,7 +4750,7 @@ private theorem ite_branch_shape {P : PureExpr} Stmt.noMeasureLoops_branch_then h_nml_head, Stmt.noMeasureLoops_branch_else h_nml_head⟩ set_option maxHeartbeats 12800000 in -set_option maxRecDepth 4096 in +set_option maxRecDepth 1024 in mutual /-- The central simulation lemma, written in a StoreAgreement-based shape. From b85c4801b20ea2a3dd9567342f511d4792908967 Mon Sep 17 00:00:00 2001 From: Shilpi Goel Date: Fri, 12 Jun 2026 10:00:26 -0700 Subject: [PATCH 29/33] Merge main into main2 (2026-06-11) (#1363) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ## Summary - Periodic merge of `main` into `main2` to keep main2 up to date with core improvements - 46 new commits from main since PR #1346 (mostly repo-removal PRs: #1339, #1351, #1343, #1329, #1334, plus code changes) - All conflicts resolved by keeping main2's versions (sub-repos stay local, no module migration, preserves main2-only features like Procedure.Body sum type, transparent procs, array axiomatization) - Fixed duplicate StrataDDM git entries that auto-merged into `docs/api/lake-manifest.json` and `docs/verso/lake-manifest.json` --------- Co-authored-by: Aaron Tomb Co-authored-by: Michael Tautschnig Co-authored-by: Kiro Co-authored-by: Juneyoung Lee <136006969+aqjune-aws@users.noreply.github.com> Co-authored-by: keyboardDrummer-bot Co-authored-by: Mikaël Mayer Co-authored-by: thanhnguyen-aws Co-authored-by: Fabio Madge Co-authored-by: Joe Hendrix Co-authored-by: Claude Opus 4.6 Co-authored-by: June Lee Co-authored-by: David Deng Co-authored-by: David Deng Co-authored-by: Copilot Autofix powered by AI <175728472+Copilot@users.noreply.github.com> Co-authored-by: Mikael Mayer Co-authored-by: Remy Willems Co-authored-by: keyboardDrummer-bot Co-authored-by: Sagar Joshi <72283186+sagjoshi@users.noreply.github.com> --- .kiro/steering/structure.md | 6 +- README.md | 29 +--- Scripts/JavaGenTestData.lean | 79 +++++++++++ Scripts/LaurelToCBMC.lean | 134 ++++++++++++++++++ .../CBMC/GOTO/test_property_summary_e2e.sh | 3 +- .../Backends/CBMC/cbmc-string-support.patch | 61 ++++++++ .../Languages/Laurel/run_laurel_cbmc_tests.sh | 7 +- 7 files changed, 286 insertions(+), 33 deletions(-) create mode 100644 Scripts/JavaGenTestData.lean create mode 100644 Scripts/LaurelToCBMC.lean create mode 100644 StrataTest/Backends/CBMC/cbmc-string-support.patch diff --git a/.kiro/steering/structure.md b/.kiro/steering/structure.md index 4445fa325b..e29800ee73 100644 --- a/.kiro/steering/structure.md +++ b/.kiro/steering/structure.md @@ -15,8 +15,6 @@ Strata is a Lean4 verification framework using **dialects** as composable langua - `Strata/` - Core implementation (DDM, dialects, languages, transforms, backends) - `StrataTest/` - Unit tests (mirrors Strata/ structure) - `Examples/` - Sample programs (`.st` files, naming: `..st`) -- `Tools/` - External tools (BoogieToStrata, Python utilities) -- `vcs/` - Generated SMT2 verification conditions ### Core Components @@ -34,9 +32,7 @@ Strata is a Lean4 verification framework using **dialects** as composable langua - `Core/` - Primary verification language (procedures, contracts, VCG, SMT encoding) - `C_Simp/` - Simplified C-like language - `Dyn/` - Dynamic language example -- `Laurel/` - A common representation for front-end languages like Java, Python and JavaScript. -Translated to Core. -- `Python/` - The well-known Python language +- `Laurel/` - A common representation for front-end languages like Java, Python and JavaScript. Translated to Core. **`Strata/Transform/`** - Program Transformations - Each transformation has implementation + optional correctness proof (`*Correct.lean`) diff --git a/README.md b/README.md index e39b1ebd6d..3102b9c54d 100644 --- a/README.md +++ b/README.md @@ -28,13 +28,10 @@ changes!** (`cvc5` and `z3`). See [Installing dependencies → SMT Solvers](#smt-solvers) below. -3. **Python 3.11+**: required for Python-related tests and the `strata` - Python tooling. See [Installing dependencies → Python](#python) below. - -4. **Java JDK (11 or later)**: required for Java code generation tests. +3. **Java JDK (11 or later)**: required for Java code generation tests. See [Installing dependencies → Java](#java-for-code-generation-tests) below. -5. **ion-java jar (1.11.11)**: required for the Java/Ion integration test. +4. **ion-java jar (1.11.11)**: required for the Java/Ion integration test. See [Installing dependencies → Java](#java-for-code-generation-tests) below. ### Installing dependencies @@ -54,18 +51,6 @@ cp /path/to/cvc5 /path/to/z3 ~/.local/bin/ # or: sudo cp /path/to/cvc5 /path/to/z3 /usr/local/bin/ ``` -#### Python - -Python 3.11 or later is required. Install the `strata` Python package inside a -virtual environment (recommended; avoids PEP 668's `externally-managed-environment` -error on Debian/Ubuntu 23.04+): - -```bash -python3 -m venv .venv -source .venv/bin/activate -pip install ./Tools/Python -``` - #### Java (for code generation tests) A JDK (11+) providing `javac` must be on your `PATH`. For running the @@ -81,7 +66,6 @@ wget -q -O StrataTestExtra/Languages/Java/testdata/ion-java-1.11.11.jar \ ```bash cvc5 --version # should print version info z3 --version # should print version info -python3 --version # should be 3.11+ ``` ## Build @@ -111,13 +95,10 @@ Two kinds of tests coexist in this repo: These accept prefix filters: ```bash -# Run all extra tests except Python (which requires the Python package) -lake test -- --exclude Languages.Python - -# Run only Python extra tests (requires `pip install ./Tools/Python`) -lake test -- Languages.Python +# Run all extra tests except those in the Imperative namespace +lake test -- --exclude DL.Imperative -# Run all extra tests (Python tests will fail without the Python package above) +# Run all extra tests lake test ``` diff --git a/Scripts/JavaGenTestData.lean b/Scripts/JavaGenTestData.lean new file mode 100644 index 0000000000..00a2e890dc --- /dev/null +++ b/Scripts/JavaGenTestData.lean @@ -0,0 +1,79 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +import StrataDDM + +/-! +# Java test data generation helper + +Usage: + lake env lean --run Scripts/JavaGenTestData.lean javaGen + lake env lean --run Scripts/JavaGenTestData.lean print --include + +Note: Unlike the former CLI `javaGen` command, this script only loads dialects +from files — it does not support referencing preloaded dialect names directly. +This is sufficient for the testdata regeneration workflow. +-/ + +open StrataDDM + +def javaGen (dialectPath packageName outputDir : String) : IO Unit := do + let fm ← mkDialectFileMap + let d ← readStrataDialectFile fm dialectPath + match StrataDDM.Java.generateDialect d packageName with + | .ok files => + StrataDDM.Java.writeJavaFiles outputDir packageName files + IO.println s!"Generated Java files for {d.name} in {outputDir}/{StrataDDM.Java.packageToPath packageName}" + | .error msg => + IO.eprintln s!"Error generating Java: {msg}" + IO.Process.exit 1 + +def printFile (includeDirs : List String) (file : String) : IO Unit := do + let fm ← mkDialectFileMap + let mut fm := fm + for dir in includeDirs do + match ← fm.addSearchPath dir |>.toBaseIO with + | .error msg => + IO.eprintln msg + IO.Process.exit 1 + | .ok fm' => fm := fm' + let ld ← fm.getLoaded + if mem : file ∈ ld.dialects then + IO.print <| ld.dialects.format file mem + return + match ← readStrataFile fm file with + | .dialect d => + let ld ← fm.getLoaded + if mem : d.name ∈ ld.dialects then + IO.print <| ld.dialects.format d.name mem + else + IO.eprintln "Internal error reading file." + IO.Process.exit 1 + | .program pgm => + IO.print <| toString pgm + +private def parseIncludeArgs (args : List String) : List String × List String := + go args [] +where + go : List String → List String → List String × List String + | "--include" :: dir :: rest, includes => go rest (dir :: includes) + | other, includes => (includes.reverse, other) + +def main (args : List String) : IO Unit := do + match args with + | "javaGen" :: dialectPath :: packageName :: outputDir :: _ => + javaGen dialectPath packageName outputDir + | "print" :: rest => + let (includeDirs, fileArgs) := parseIncludeArgs rest + match fileArgs with + | [file] => printFile includeDirs file + | _ => + IO.eprintln "Usage: ... print [--include ]... " + IO.Process.exit 1 + | _ => + IO.eprintln "Usage:" + IO.eprintln " lake env lean --run Scripts/JavaGenTestData.lean javaGen " + IO.eprintln " lake env lean --run Scripts/JavaGenTestData.lean print [--include ]... " + IO.Process.exit 1 diff --git a/Scripts/LaurelToCBMC.lean b/Scripts/LaurelToCBMC.lean new file mode 100644 index 0000000000..61388af488 --- /dev/null +++ b/Scripts/LaurelToCBMC.lean @@ -0,0 +1,134 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +import Strata.Backends.CBMC.GOTO.CoreToGOTOPipeline +import Strata.Languages.Laurel + +/-! # LaurelToCBMC + +Script that replaces `laurel_to_cbmc.sh`. Translates a Laurel `.lr.st` source +file through the full Strata pipeline to CBMC verification: + +1. Parse Laurel source → Laurel AST +2. Translate Laurel → Core +3. Inline procedures, type-check, generate CProver GOTO JSON +4. Invoke `symtab2gb` to produce a GOTO binary +5. Invoke `goto-cc` to add C scaffolding +6. Invoke `goto-instrument --dfcc` for contract instrumentation +7. Invoke `cbmc` for bounded model checking + +Usage: + lake env lean --run Scripts/LaurelToCBMC.lean + +Environment variables: + CBMC - path to cbmc binary (default: cbmc) + GOTO_CC - path to goto-cc binary (default: goto-cc) + GOTO_INSTRUMENT - path to goto-instrument binary (default: goto-instrument) +-/ + +open Strata + +/-- Strip well-known Strata file suffixes from a file path's basename. -/ +private def deriveBaseName (file : String) : String := + let name := System.FilePath.fileName file |>.getD file + let suffixes := [".lr.st", ".laurel.st", ".st"] + match suffixes.find? (name.endsWith ·) with + | some sfx => (name.dropEnd sfx.length).toString + | none => name + +/-- Read an environment variable, returning a default if unset or empty. -/ +private def getEnvOrDefault (var : String) (default : String) : IO String := do + match ← IO.getEnv var with + | some v => if v.isEmpty then pure default else pure v + | none => pure default + +/-- Run an external process. Prints stdout/stderr to the caller's streams and + returns the exit code. -/ +private def runProcess (step : String) (cmd : String) (args : Array String) : IO UInt32 := do + let proc ← IO.Process.spawn { + cmd := cmd + args := args + stdout := .inherit + stderr := .inherit + stdin := .inherit + } + let exitCode ← proc.wait + if exitCode != 0 then + IO.eprintln s!"Error: {step} failed (exit code {exitCode})" + return exitCode + +/-- The Laurel-to-GOTO translation pipeline. Parses a Laurel source file, + translates to Core, inlines procedures, type-checks, and emits CProver GOTO + JSON files (`.symtab.json` and `.goto.json`) in the + given output directory. -/ +private def laurelAnalyzeToGoto (path : System.FilePath) (outputDir : System.FilePath) + (baseName : String) : IO Unit := do + let content ← IO.FS.readFile path + let laurelProgram ← Strata.parseLaurelText path content + match ← Strata.Laurel.translate {} laurelProgram with + | (none, diags) => + throw (IO.userError s!"Core translation errors: {diags.map (·.message)}") + | (some coreProgram, _) => + -- Use the output directory as a prefix so files land in tmpDir + let outputBaseName := (outputDir / baseName).toString + match ← Strata.inlineCoreToGotoFiles coreProgram outputBaseName + (sourceText := some content) |>.toBaseIO with + | .ok () => pure () + | .error msg => throw (IO.userError msg) + +def main (args : List String) : IO UInt32 := do + match args with + | [file] => + unless file.endsWith ".lr.st" || file.endsWith ".laurel.st" do + IO.eprintln s!"Error: expected a .lr.st file, got: {file}" + return 1 + let path : System.FilePath := file + unless ← path.pathExists do + IO.eprintln s!"Error: file not found: {file}" + return 1 + let baseName := deriveBaseName file + + -- Use a temporary directory for intermediate files (cleaned up automatically) + IO.FS.withTempDir fun tmpDir => do + + -- Step 1: Laurel → GOTO JSON (in tmp dir) + let result ← (laurelAnalyzeToGoto path tmpDir baseName).toBaseIO + match result with + | .error e => + IO.eprintln s!"Error: {e}" + return 1 + | .ok () => pure () + + let symTabFile := (tmpDir / s!"{baseName}.symtab.json").toString + let gotoFile := (tmpDir / s!"{baseName}.goto.json").toString + let gbFile := (tmpDir / s!"{baseName}.gb").toString + let ccGbFile := (tmpDir / s!"{baseName}_cc.gb").toString + let dfccGbFile := (tmpDir / s!"{baseName}_dfcc.gb").toString + + -- Step 2: symtab2gb + let rc ← runProcess "symtab2gb" "symtab2gb" + #[symTabFile, "--goto-functions", gotoFile, "--out", gbFile] + if rc != 0 then return rc + + -- Step 3: goto-cc (add C scaffolding) + let gotoCC ← getEnvOrDefault "GOTO_CC" "goto-cc" + let rc ← runProcess "goto-cc" gotoCC + #["--function", "main", "-o", ccGbFile, gbFile] + if rc != 0 then return rc + + -- Step 4: goto-instrument --dfcc + let gotoInstrument ← getEnvOrDefault "GOTO_INSTRUMENT" "goto-instrument" + let rc ← runProcess "goto-instrument --dfcc" gotoInstrument + #["--dfcc", "main", ccGbFile, dfccGbFile] + if rc != 0 then return rc + + -- Step 5: cbmc verification + let cbmc ← getEnvOrDefault "CBMC" "cbmc" + runProcess "cbmc" cbmc + #[dfccGbFile, "--function", "main", "--z3", "--verbosity", "9"] + + | _ => + IO.eprintln "Usage: LaurelToCBMC " + return 1 diff --git a/StrataTest/Backends/CBMC/GOTO/test_property_summary_e2e.sh b/StrataTest/Backends/CBMC/GOTO/test_property_summary_e2e.sh index 47b1871cdc..cfd20dceda 100755 --- a/StrataTest/Backends/CBMC/GOTO/test_property_summary_e2e.sh +++ b/StrataTest/Backends/CBMC/GOTO/test_property_summary_e2e.sh @@ -8,7 +8,6 @@ set -eo pipefail SCRIPT_DIR="$(cd "$(dirname "$0")" && pwd)" PROJECT_ROOT="$(cd "$SCRIPT_DIR/../../../.." && pwd)" -LAUREL_TO_CBMC="$PROJECT_ROOT/StrataTest/Languages/Laurel/laurel_to_cbmc.sh" WORK=$(mktemp -d) trap 'rm -rf "$WORK"' EXIT @@ -26,7 +25,7 @@ procedure main() LAUREL # Run the full pipeline (strata → symtab2gb → goto-cc → goto-instrument → cbmc) -cbmc_out=$("$LAUREL_TO_CBMC" "$WORK/test.lr.st" 2>&1 || true) +cbmc_out=$(lake -d "$PROJECT_ROOT" env lean --run "$PROJECT_ROOT/Scripts/LaurelToCBMC.lean" "$WORK/test.lr.st" 2>&1 || true) # Verify CBMC output contains property summaries for summary in "addition equals eight" "difference equals two"; do diff --git a/StrataTest/Backends/CBMC/cbmc-string-support.patch b/StrataTest/Backends/CBMC/cbmc-string-support.patch new file mode 100644 index 0000000000..225f336438 --- /dev/null +++ b/StrataTest/Backends/CBMC/cbmc-string-support.patch @@ -0,0 +1,61 @@ +diff --git a/src/solvers/smt2/smt2_conv.cpp b/src/solvers/smt2/smt2_conv.cpp +index e00becc56e..43bd7888d3 100644 +--- a/src/solvers/smt2/smt2_conv.cpp ++++ b/src/solvers/smt2/smt2_conv.cpp +@@ -2707,8 +2707,24 @@ void smt2_convt::convert_expr(const exprt &expr) + else if(expr.id() == ID_function_application) + { + const auto &function_application_expr = to_function_application_expr(expr); ++ ++ // Check for string operations by looking at the function symbol name ++ std::string fn_name; ++ if(function_application_expr.function().id() == ID_symbol) ++ fn_name = id2string( ++ to_symbol_expr(function_application_expr.function()).get_identifier()); ++ ++ if(fn_name == "Str.Concat" && ++ function_application_expr.arguments().size() == 2) ++ { ++ out << "(str.++ "; ++ convert_expr(function_application_expr.arguments()[0]); ++ out << ' '; ++ convert_expr(function_application_expr.arguments()[1]); ++ out << ')'; ++ } + // do not use parentheses if there function is a constant +- if(function_application_expr.arguments().empty()) ++ else if(function_application_expr.arguments().empty()) + { + convert_expr(function_application_expr.function()); + } +@@ -3763,6 +3779,21 @@ void smt2_convt::convert_constant(const constant_exprt &expr) + out << "(_ bv" << (value_int - range_type.get_from()) << " " << width + << ")"; + } ++ else if(expr_type.id()==ID_string) ++ { ++ const std::string &value = id2string(expr.get_value()); ++ out << "\""; ++ for(char c : value) ++ { ++ if(c == '"') ++ out << "\"\""; ++ else if(c == '\\') ++ out << "\\\\"; ++ else ++ out << c; ++ } ++ out << "\""; ++ } + else + UNEXPECTEDCASE("unknown constant: "+expr_type.id_string()); + } +@@ -5991,6 +6022,8 @@ void smt2_convt::convert_type(const typet &type) + UNEXPECTEDCASE("unsuppored range type"); + out << "(_ BitVec " << address_bits(size) << ")"; + } ++ else if(type.id()==ID_string) ++ out << "String"; + else + { + UNEXPECTEDCASE("unsupported type: "+type.id_string()); diff --git a/StrataTest/Languages/Laurel/run_laurel_cbmc_tests.sh b/StrataTest/Languages/Laurel/run_laurel_cbmc_tests.sh index fd700d2a43..8ca1b74b17 100755 --- a/StrataTest/Languages/Laurel/run_laurel_cbmc_tests.sh +++ b/StrataTest/Languages/Laurel/run_laurel_cbmc_tests.sh @@ -8,12 +8,15 @@ # appears in CBMC output with the correct status. # # Environment variables: -# CBMC - path to cbmc binary (default: cbmc) +# CBMC - path to cbmc binary (default: cbmc) +# GOTO_CC - path to goto-cc binary (default: goto-cc) +# GOTO_INSTRUMENT - path to goto-instrument binary (default: goto-instrument) set -o pipefail SCRIPT_DIR="$(cd "$(dirname "$0")" && pwd)" TESTS_DIR="$SCRIPT_DIR/tests" +PROJECT_ROOT="$(cd "$SCRIPT_DIR/../../.." && pwd)" EXPECTED="$TESTS_DIR/cbmc_expected.txt" passed=0 @@ -40,7 +43,7 @@ for lr_file in "$TESTS_DIR"/*.lr.st; do fi # Run the pipeline - output=$("$SCRIPT_DIR/laurel_to_cbmc.sh" "$lr_file" 2>&1) + output=$(lake -d "$PROJECT_ROOT" env lean --run "$PROJECT_ROOT/Scripts/LaurelToCBMC.lean" "$lr_file" 2>&1) if [ $? -ne 0 ] && ! echo "$output" | grep -q "VERIFICATION"; then echo "ERR: $bn (pipeline error)" echo "$output" | tail -3 From 84af4ca63453a265a65e939e343ba7071edb9f02 Mon Sep 17 00:00:00 2001 From: David Deng Date: Fri, 12 Jun 2026 10:55:45 -0700 Subject: [PATCH 30/33] wip(reconcile #1347): mechanical binder/op migration of StructuredToUnstructuredCorrect MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit HasNot->HasBoolOps, HasVarsPure(P.Expr)->HasFvars, HasBoolVal dropped (folded into HasBool), HasIntOrder->HasInt+HasIntOps; op-calls HasNot.not->HasBoolOps.not, HasVarsPure.getVars->HasFvars.getFvars, HasIntOrder.{eq,lt,zero,intTy}->HasIntOps/HasInt. Binder ordering: HasFvars before HasInt (HasInt prereq); dropped redundant explicit [HasVal P] where HasBool/HasBoolOps provide it (resolved HasVal instance-diamond); added [HasOps P] per migrated hierarchy. All binder/synthesize/invalid-binder errors cleared. REMAINING (24, NOT mechanical): semantic changes flagged by the reconcile spec for owner input — 4-arg Config.block (.block now takes e_parent eval snapshot), WellFormedSemanticEvalVal instance-path mismatch from HasBool-extends-HasVal restructuring, moved SemanticEval.stmts constant. Sorry-free preserved (0). --- .../StructuredToUnstructuredCorrect.lean | 194 +++++++++--------- 1 file changed, 97 insertions(+), 97 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 06117d9722..493d258cd8 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -54,12 +54,12 @@ namespace StructuredToUnstructuredCorrect open Imperative Specification /-! ## Abbreviations -/ -abbrev StepDetCFGStar {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] +abbrev StepDetCFGStar {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] (extendEval : ExtendEval P) (cfg : CFG String (DetBlock String (Cmd P) P)) := @StepCFGStar String (Cmd P) _ P (EvalCmd P) extendEval _ _ cfg -theorem StepDetCFGStar_trans {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] +theorem StepDetCFGStar_trans {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] {extendEval : ExtendEval P} {cfg : CFG String (DetBlock String (Cmd P) P)} {a b c : CFGConfig String (Cmd P) P} @@ -99,7 +99,7 @@ inductive EvalCmds /-- Bridge: lift an `EvalCmds` derivation for the command list `cs` into a chain of `StepCFG.step_cmd` steps inside `.inBlock`, threading the residual list and accumulating failure on the right via `||`. -/ -theorem EvalCmds_to_StepCFG_chain {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] +theorem EvalCmds_to_StepCFG_chain {P : PureExpr} [HasFvar P] [HasBoolOps P] [HasFvars P] {extendEval : ExtendEval P} {cfg : CFG String (DetBlock String (Cmd P) P)} {δ : SemanticEval P} {σ σ' : SemanticStore P} @@ -133,7 +133,7 @@ theorem EvalCmds_to_StepCFG_chain {P : PureExpr} [HasFvar P] [HasNot P] [HasVars /-- Run a deterministic block from `.atBlock t` to `.atBlock tlbl` via the true branch of a `condGoto`: fetch + chain + goto_true. -/ -theorem run_block_goto_true {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] +theorem run_block_goto_true {P : PureExpr} [HasFvar P] [HasBoolOps P] [HasFvars P] {extendEval : ExtendEval P} {cfg : CFG String (DetBlock String (Cmd P) P)} {δ : SemanticEval P} {σ σ' : SemanticStore P} @@ -163,7 +163,7 @@ theorem run_block_goto_true {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P /-- Run a deterministic block from `.atBlock t` to `.atBlock elbl` via the false branch of a `condGoto`: fetch + chain + goto_false. -/ -theorem run_block_goto_false {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] +theorem run_block_goto_false {P : PureExpr} [HasFvar P] [HasBoolOps P] [HasFvars P] {extendEval : ExtendEval P} {cfg : CFG String (DetBlock String (Cmd P) P)} {δ : SemanticEval P} {σ σ' : SemanticStore P} @@ -193,7 +193,7 @@ theorem run_block_goto_false {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure /-- Run a deterministic block from `.atBlock t` to `.terminal`: fetch + chain + finish. -/ -theorem run_block_finish {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] +theorem run_block_finish {P : PureExpr} [HasFvar P] [HasBoolOps P] [HasFvars P] {extendEval : ExtendEval P} {cfg : CFG String (DetBlock String (Cmd P) P)} {δ : SemanticEval P} {σ σ' : SemanticStore P} @@ -218,7 +218,7 @@ theorem run_block_finish {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P. (ReflTrans_Transitive _ _ _ _ h_chain (ReflTrans.step _ _ _ h_finish (ReflTrans.refl _))) -theorem stmts_nil_terminal {P : PureExpr} [HasBool P] [HasNot P] +theorem stmts_nil_terminal {P : PureExpr} [HasBool P] [HasBoolOps P] {CmdT : Type} (EvalCmdR : EvalCmdParam P CmdT) (extendEval : ExtendEval P) @@ -233,7 +233,7 @@ theorem stmts_nil_terminal {P : PureExpr} [HasBool P] [HasNot P] · rename_i h₁ _ cases h₁ -theorem EvalCmds_snoc {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] +theorem EvalCmds_snoc {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] (δ : SemanticEval P) (σ σ' σ'' : SemanticStore P) (cs : List (Cmd P)) (c : Cmd P) (f₁ f₂ : Bool) (h₁ : EvalCmds P (@EvalCmd P _ _ _ _) δ σ cs σ' f₁) @@ -253,7 +253,7 @@ theorem EvalCmds_snoc {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVars rw [Bool.or_assoc] exact EvalCmds.eval_cmds_some hcmd (ih _ _ hrest) -theorem EvalCmds_inv {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] +theorem EvalCmds_inv {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] (δ : SemanticEval P) (σ σ' : SemanticStore P) (f : Bool) (h : EvalCmds P (@EvalCmd P _ _ _ _) δ σ [] σ' f) : σ = σ' ∧ f = false := by @@ -276,11 +276,11 @@ constructor cannot fire). At the higher-level chained version /-- Pointwise equality of two stores on the variables of a single expression follows from `StoreAgreement` plus `isDefined` of those variables. -/ private theorem store_agreement_pointwise_on_expr_vars - {P : PureExpr} [HasVarsPure P P.Expr] + {P : PureExpr} [HasFvars P] (σ_struct σ_cfg : SemanticStore P) (e : P.Expr) (h_agree : StoreAgreement σ_struct σ_cfg) - (h_def : isDefined σ_struct (HasVarsPure.getVars e)) : - ∀ x ∈ HasVarsPure.getVars e, σ_struct x = σ_cfg x := by + (h_def : isDefined σ_struct (HasFvars.getFvars e)) : + ∀ x ∈ HasFvars.getFvars e, σ_struct x = σ_cfg x := by intro x hx have h_def_x : isDefined σ_struct [x] := by intro v hv @@ -352,7 +352,7 @@ private theorem transformStmtModVars_loop {P : PureExpr} /-- Single-command agreement-preservation. -/ private theorem EvalCmd_under_agreement {P : PureExpr} - [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] [DecidableEq P.Ident] (δ : SemanticEval P) (σ_struct₀ σ_cfg₀ : SemanticStore P) (c : Cmd P) (σ_struct₁ : SemanticStore P) (failed : Bool) (h_agree : StoreAgreement σ_struct₀ σ_cfg₀) @@ -368,10 +368,10 @@ private theorem EvalCmd_under_agreement {P : PureExpr} -- rename_i introduces in order: ty, md, x, v, e rename_i ty md x v e -- Need δ σ_cfg₀ e = some v. Use congr + agreement on e's vars. - have h_def_e : isDefined σ_struct₀ (HasVarsPure.getVars e) := + have h_def_e : isDefined σ_struct₀ (HasFvars.getFvars e) := h_wf_def e v σ_struct₀ heval have h_pointwise : - ∀ y ∈ HasVarsPure.getVars e, σ_struct₀ y = σ_cfg₀ y := + ∀ y ∈ HasFvars.getFvars e, σ_struct₀ y = σ_cfg₀ y := store_agreement_pointwise_on_expr_vars σ_struct₀ σ_cfg₀ e h_agree h_def_e have h_eval_cfg : δ σ_cfg₀ e = .some v := by rw [← heval]; exact (h_congr e σ_struct₀ σ_cfg₀ h_pointwise).symm @@ -451,10 +451,10 @@ private theorem EvalCmd_under_agreement {P : PureExpr} exact h_agree y h_def_y' | eval_set heval hupdate hwfvar hwfcongr => rename_i md x v e - have h_def_e : isDefined σ_struct₀ (HasVarsPure.getVars e) := + have h_def_e : isDefined σ_struct₀ (HasFvars.getFvars e) := h_wf_def e v σ_struct₀ heval have h_pointwise : - ∀ y ∈ HasVarsPure.getVars e, σ_struct₀ y = σ_cfg₀ y := + ∀ y ∈ HasFvars.getFvars e, σ_struct₀ y = σ_cfg₀ y := store_agreement_pointwise_on_expr_vars σ_struct₀ σ_cfg₀ e h_agree h_def_e have h_eval_cfg : δ σ_cfg₀ e = .some v := by rw [← heval]; exact (h_congr e σ_struct₀ σ_cfg₀ h_pointwise).symm @@ -538,30 +538,30 @@ private theorem EvalCmd_under_agreement {P : PureExpr} exact h_agree y h_def_y' | eval_assert_pass hcond hwfb hwfcongr => rename_i l md e - have h_def_e : isDefined σ_struct₀ (HasVarsPure.getVars e) := + have h_def_e : isDefined σ_struct₀ (HasFvars.getFvars e) := h_wf_def e HasBool.tt σ_struct₀ hcond have h_pointwise : - ∀ y ∈ HasVarsPure.getVars e, σ_struct₀ y = σ_cfg₀ y := + ∀ y ∈ HasFvars.getFvars e, σ_struct₀ y = σ_cfg₀ y := store_agreement_pointwise_on_expr_vars σ_struct₀ σ_cfg₀ e h_agree h_def_e have h_eval_cfg : δ σ_cfg₀ e = .some HasBool.tt := by rw [← hcond]; exact (h_congr e σ_struct₀ σ_cfg₀ h_pointwise).symm exact ⟨σ_cfg₀, EvalCmd.eval_assert_pass h_eval_cfg hwfb hwfcongr, h_agree⟩ | eval_assert_fail hcond hwfb hwfcongr => rename_i l md e - have h_def_e : isDefined σ_struct₀ (HasVarsPure.getVars e) := + have h_def_e : isDefined σ_struct₀ (HasFvars.getFvars e) := h_wf_def e HasBool.ff σ_struct₀ hcond have h_pointwise : - ∀ y ∈ HasVarsPure.getVars e, σ_struct₀ y = σ_cfg₀ y := + ∀ y ∈ HasFvars.getFvars e, σ_struct₀ y = σ_cfg₀ y := store_agreement_pointwise_on_expr_vars σ_struct₀ σ_cfg₀ e h_agree h_def_e have h_eval_cfg : δ σ_cfg₀ e = .some HasBool.ff := by rw [← hcond]; exact (h_congr e σ_struct₀ σ_cfg₀ h_pointwise).symm exact ⟨σ_cfg₀, EvalCmd.eval_assert_fail h_eval_cfg hwfb hwfcongr, h_agree⟩ | eval_assume hcond hwfb hwfcongr => rename_i l md e - have h_def_e : isDefined σ_struct₀ (HasVarsPure.getVars e) := + have h_def_e : isDefined σ_struct₀ (HasFvars.getFvars e) := h_wf_def e HasBool.tt σ_struct₀ hcond have h_pointwise : - ∀ y ∈ HasVarsPure.getVars e, σ_struct₀ y = σ_cfg₀ y := + ∀ y ∈ HasFvars.getFvars e, σ_struct₀ y = σ_cfg₀ y := store_agreement_pointwise_on_expr_vars σ_struct₀ σ_cfg₀ e h_agree h_def_e have h_eval_cfg : δ σ_cfg₀ e = .some HasBool.tt := by rw [← hcond]; exact (h_congr e σ_struct₀ σ_cfg₀ h_pointwise).symm @@ -574,7 +574,7 @@ private theorem EvalCmd_under_agreement {P : PureExpr} `c` either doesn't touch x, or modifies x via `set` (which requires `σ x = some _`, contradicting `σ x = none`). -/ private theorem agreement_helper_unchanged_at_x {P : PureExpr} - [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] [DecidableEq P.Ident] {δ : SemanticEval P} {σ σ' : SemanticStore P} {c : Cmd P} {failed : Bool} {x : P.Ident} (h_eval : @EvalCmd P _ _ _ _ δ σ c σ' failed) @@ -639,7 +639,7 @@ private theorem agreement_helper_unchanged_at_x {P : PureExpr} takes σ to σ' over a list `cmds`, and `x` is not in `cmds.definedVars`, and `σ x = none`, then `σ' x = none`. By induction on `EvalCmds`. -/ private theorem agreement_helper_unchanged_at_x_multi {P : PureExpr} - [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] [DecidableEq P.Ident] {δ : SemanticEval P} {σ σ' : SemanticStore P} {cmds : List (Cmd P)} {failed : Bool} {x : P.Ident} (h_eval : EvalCmds P (@EvalCmd P _ _ _ _) δ σ cmds σ' failed) @@ -669,7 +669,7 @@ private theorem agreement_helper_unchanged_at_x_multi {P : PureExpr} /-- Multi-command agreement-preservation, by induction on `cs`. -/ private theorem EvalCmds_under_agreement {P : PureExpr} - [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] [DecidableEq P.Ident] (δ : SemanticEval P) (cs : List (Cmd P)) (h_wf_def : WellFormedSemanticEvalDef δ) @@ -729,7 +729,7 @@ private theorem EvalCmds_under_agreement {P : PureExpr} h_unique_tail exact ⟨σ_cfg_end, EvalCmds.eval_cmds_some h_cmd_cfg h_rest_cfg, h_agree_end⟩ -theorem single_cmd_eval {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] +theorem single_cmd_eval {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] (extendEval : ExtendEval P) (c : Cmd P) (ρ₀ ρ₁ : Env P) (h : StepStmtStar P (@EvalCmd P _ _ _ _) extendEval @@ -1434,7 +1434,7 @@ private theorem invMapM_genStep {P : PureExpr} [HasPassiveCmds P (Cmd P)] (WF preservation + monotone label list). This holds without any disjointness assumption and is used to bootstrap the full invariant. -/ private theorem stmtsToBlocks_genStep - {P : PureExpr} [HasBool P] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] + {P : PureExpr} [HasBool P] [HasIdent P] [HasFvar P] [HasFvars P] [HasInt P] [HasIntOps P] [HasBoolOps P] (k : String) (ss : List (Stmt P (Cmd P))) (exitConts : List (Option String × String)) (accum : List (Cmd P)) @@ -1688,7 +1688,7 @@ We require `userLabelsDisjoint`: user-provided block labels (from `Stmt.block l ...`) must not collide with any generated label in the final state. Without this, the `block` case can produce duplicate keys. -/ private theorem stmtsToBlocks_invariant - {P : PureExpr} [HasBool P] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] + {P : PureExpr} [HasBool P] [HasIdent P] [HasFvar P] [HasFvars P] [HasInt P] [HasIntOps P] [HasBoolOps P] (k : String) (ss : List (Stmt P (Cmd P))) (exitConts : List (Option String × String)) (accum : List (Cmd P)) @@ -2858,16 +2858,16 @@ private theorem stmtsToBlocks_invariant let mIdent := HasIdent.ident (P := P) mLabel let mOldExpr := HasFvar.mkFvar (P := P) mIdent let initCmd : Cmd P := - HasInit.init mIdent HasIntOrder.intTy ExprOrNondet.nondet synthesizedMd + HasInit.init mIdent HasInt.intTy ExprOrNondet.nondet synthesizedMd let assumeCmd : Cmd P := HasPassiveCmds.assume s!"assume_{mLabel}" - (HasIntOrder.eq mOldExpr mExpr) synthesizedMd + (HasIntOps.eq mOldExpr mExpr) synthesizedMd let lbCmd : Cmd P := HasPassiveCmds.assert s!"measure_lb_{mLabel}" - (HasNot.not (HasIntOrder.lt mOldExpr HasIntOrder.zero)) synthesizedMd + (HasBoolOps.not (HasIntOps.lt mOldExpr HasInt.zero)) synthesizedMd let decCmd : Cmd P := HasPassiveCmds.assert s!"measure_decrease_{mLabel}" - (HasIntOrder.lt mExpr mOldExpr) synthesizedMd + (HasIntOps.lt mExpr mOldExpr) synthesizedMd let measureCmds : List (Cmd P) := [initCmd, assumeCmd, lbCmd] let decBlock : String × DetBlock String (Cmd P) P := (ldec, { cmds := [decCmd], transfer := DetTransferCmd.goto lentry synthesizedMd }) @@ -3112,16 +3112,16 @@ private theorem stmtsToBlocks_invariant let mIdent := HasIdent.ident (P := P) mLabel let mOldExpr := HasFvar.mkFvar (P := P) mIdent let initCmd : Cmd P := - HasInit.init mIdent HasIntOrder.intTy ExprOrNondet.nondet synthesizedMd + HasInit.init mIdent HasInt.intTy ExprOrNondet.nondet synthesizedMd let assumeCmd : Cmd P := HasPassiveCmds.assume s!"assume_{mLabel}" - (HasIntOrder.eq mOldExpr mExpr) synthesizedMd + (HasIntOps.eq mOldExpr mExpr) synthesizedMd let lbCmd : Cmd P := HasPassiveCmds.assert s!"measure_lb_{mLabel}" - (HasNot.not (HasIntOrder.lt mOldExpr HasIntOrder.zero)) synthesizedMd + (HasBoolOps.not (HasIntOps.lt mOldExpr HasInt.zero)) synthesizedMd let decCmd : Cmd P := HasPassiveCmds.assert s!"measure_decrease_{mLabel}" - (HasIntOrder.lt mExpr mOldExpr) synthesizedMd + (HasIntOps.lt mExpr mOldExpr) synthesizedMd let measureCmds : List (Cmd P) := [initCmd, assumeCmd, lbCmd] let decBlock : String × DetBlock String (Cmd P) P := (ldec, { cmds := [decCmd], transfer := DetTransferCmd.goto lentry synthesizedMd }) @@ -3367,7 +3367,7 @@ Reduces to `stmtsToBlocks_invariant`: the final block label `lend` is generated *before* the `stmtsToBlocks` call, so it is in `gen0.gens`. The invariant says the inner blocks' labels are NOT in `gen0.gens`, so `lend` is disjoint from them. -/ private theorem stmtsToCFG_nodup_keys {P : PureExpr} - [HasBool P] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] + [HasBool P] [HasIdent P] [HasFvar P] [HasFvars P] [HasInt P] [HasIntOps P] [HasBoolOps P] (ss : List (Stmt P (Cmd P))) (h_disj : ∀ gen', Block.userLabelsDisjoint ss gen') : ((stmtsToCFG ss).blocks.map Prod.fst).Nodup := by @@ -3424,8 +3424,8 @@ private theorem stmtsToCFG_nodup_keys {P : PureExpr} /-- Evaluator well-formedness (Bool) is preserved by structured execution when no `funcDecl` statements are executed (i.e., the evaluator doesn't change). This holds because only `step_funcDecl` modifies `eval`. -/ -private theorem StepStmtStar_wfb_preserved {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] +private theorem StepStmtStar_wfb_preserved {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] + [HasIdent P] [HasFvars P] [HasOps P] [HasInt P] [HasIntOps P] (extendEval : ExtendEval P) (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) (h : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) @@ -3438,8 +3438,8 @@ private theorem StepStmtStar_wfb_preserved {P : PureExpr} [HasFvar P] [HasBool P exact hwfb /-- Same as above but for `WellFormedSemanticEvalVal`. -/ -private theorem StepStmtStar_wfv_preserved {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] +private theorem StepStmtStar_wfv_preserved {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] + [HasIdent P] [HasFvars P] [HasOps P] [HasInt P] [HasIntOps P] (extendEval : ExtendEval P) (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) (h : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) @@ -3461,8 +3461,8 @@ CFG entry stores) to be threaded through the simulation. -/ trace is on the CFG side (lifted via `EvalCmds_under_agreement`) and reaches `σ_cfg_after`, which agrees with `ρ₀.store`. The boolean `b` selects the taken branch (`tl` when `tt`, `fl` when `ff`). -/ -private theorem flushCmds_condGoto_agree {P : PureExpr} [HasFvar P] [HasNot P] - [HasVarsPure P P.Expr] +private theorem flushCmds_condGoto_agree {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasFvars P] (extendEval : ExtendEval P) (b : Bool) (accum : List (Cmd P)) @@ -3491,10 +3491,10 @@ private theorem flushCmds_condGoto_agree {P : PureExpr} [HasFvar P] [HasNot P] injection h_flush_eq with h_pair h_gen_eq injection h_pair with h_entry_eq h_blks_eq subst h_entry_eq; subst h_blks_eq - have h_def_e : isDefined ρ₀.store (HasVarsPure.getVars e) := + have h_def_e : isDefined ρ₀.store (HasFvars.getFvars e) := h_wf_def e _ ρ₀.store h_cond have h_pointwise : - ∀ y ∈ HasVarsPure.getVars e, ρ₀.store y = σ_cfg_after y := + ∀ y ∈ HasFvars.getFvars e, ρ₀.store y = σ_cfg_after y := store_agreement_pointwise_on_expr_vars ρ₀.store σ_cfg_after e h_agree_after h_def_e have h_cond_cfg : ρ₀.eval σ_cfg_after e = .some (if b then HasBool.tt else HasBool.ff) := h_cond ▸ (h_congr e ρ₀.store σ_cfg_after h_pointwise).symm @@ -3566,8 +3566,8 @@ entry label to the continuation `k` (or the resolved exit target). -/ /-- Simulation lemma operating under StoreAgreement: the input accum trace runs from `σ_struct_base` (struct side) to `ρ₀.store` (struct side), and `StoreAgreement σ_struct_base σ_base` holds at the entry. -/ -private theorem flushCmds_simulation_agree {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] +private theorem flushCmds_simulation_agree {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasVal P] [HasFvars P] [DecidableEq P.Ident] (extendEval : ExtendEval P) (pfx : String) (k : String) @@ -3646,8 +3646,8 @@ where the transfer is provided as `.some (.goto bk md)` (used in the `.exit` constructor of `stmtsToBlocks`). The block always materializes a single fresh block (regardless of whether `accum` is empty), since the transfer is explicit. -/ -private theorem flushCmds_goto_simulation_agree {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] +private theorem flushCmds_goto_simulation_agree {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasVal P] [HasFvars P] [DecidableEq P.Ident] (extendEval : ExtendEval P) (pfx : String) (accum : List (Cmd P)) (md : MetaData P) (bk : String) (gen gen' : StringGenState) @@ -3710,7 +3710,7 @@ private theorem flushCmds_goto_simulation_agree {P : PureExpr} [HasFvar P] [HasN `label'` differs from `lbl` (since the propagation rule `step_block_exit_mismatch` requires `.some label' ≠ .some lbl`). -/ private theorem block_some_reaches_exiting {P : PureExpr} {CmdT : Type} - [HasBool P] [HasNot P] + [HasBool P] [HasBoolOps P] {EvalCmd : EvalCmdParam P CmdT} {extendEval : ExtendEval P} {inner : Config P CmdT} {label' : String} {σ_parent : SemanticStore P} {lbl : String} {ρ' : Env P} @@ -3754,7 +3754,7 @@ accum-defined variable has a digit-suffixed shape to argue that `ident s ∉ Cmds.definedVars accum.reverse`, then invokes `agreement_helper_unchanged_at_x_multi`. -/ private theorem store_no_gens_lift_after_accum {P : PureExpr} - [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [HasIdent P] [DecidableEq P.Ident] + [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] [HasIdent P] [DecidableEq P.Ident] {δ : SemanticEval P} {σ_base σ_cfg_after : SemanticStore P} {accum : List (Cmd P)} {failed : Bool} (h_accum_cfg : EvalCmds P (@EvalCmd P _ _ _ _) δ σ_base accum.reverse σ_cfg_after failed) @@ -3847,7 +3847,7 @@ private theorem store_no_gens_upper_lift_through_subsim {P : PureExpr} /-- Snoc/cons rebracketing bundle for the `.cmd c :: rest` arm of `stmtsToBlocks_simulation`. -/ private theorem cmd_arm_combined_lemmas {P : PureExpr} - [HasIdent P] [HasVarsPure P P.Expr] + [HasIdent P] [HasFvars P] (c : Cmd P) (accum : List (Cmd P)) (rest : List (Stmt P (Cmd P))) (σ_base : SemanticStore P) (h_fresh : ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars (.cmd c :: rest), σ_base x = none) @@ -4021,7 +4021,7 @@ private theorem unique_combined_ite {P : PureExpr} [HasIdent P] /-- No-op-prepend bundle for the `.typeDecl` arm of `stmtsToBlocks_simulation`. -/ private theorem typeDecl_arm_combined_lemmas {P : PureExpr} - [HasIdent P] [HasVarsPure P P.Expr] + [HasIdent P] [HasFvars P] (tc : TypeConstructor) (md : MetaData P) (accum : List (Cmd P)) (rest : List (Stmt P (Cmd P))) (σ_base : SemanticStore P) (h_fresh : ∀ x ∈ Cmds.definedVars accum.reverse ++ Block.initVars (.typeDecl tc md :: rest), σ_base x = none) @@ -4063,8 +4063,8 @@ derivation length. They are re-declared here (verbatim ports of the `private` versions in `DetToKleeneCorrect.lean` and the smoke-test) because the upstream ones are `private`. -/ -private theorem seqT_reaches_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVarsPure P P.Expr] +private theorem seqT_reaches_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] + [HasFvars P] (extendEval : ExtendEval P) {inner : Config P (Cmd P)} {ss : List (Stmt P (Cmd P))} {ρ' : Env P} (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.seq inner ss) (.terminal ρ')) : @@ -4081,8 +4081,8 @@ private theorem seqT_reaches_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [H match hrest with | .step _ _ _ h _ => exact nomatch h -private theorem stmtsT_cons_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVarsPure P P.Expr] +private theorem stmtsT_cons_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] + [HasFvars P] (extendEval : ExtendEval P) {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} {ρ₀ ρ' : Env P} (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmts (s :: rest) ρ₀) (.terminal ρ')) : @@ -4094,8 +4094,8 @@ private theorem stmtsT_cons_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [Ha have ⟨ρ₁, h1, h2, hlen⟩ := seqT_reaches_terminal' extendEval hrest exact ⟨ρ₁, h1, h2, by simp [ReflTransT.len]; omega⟩ -private theorem seqT_reaches_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVarsPure P P.Expr] +private theorem seqT_reaches_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] + [HasFvars P] (extendEval : ExtendEval P) {inner : Config P (Cmd P)} {ss : List (Stmt P (Cmd P))} {label : String} {ρ' : Env P} @@ -4122,8 +4122,8 @@ private theorem seqT_reaches_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [Ha | .refl _ => exact .inl ⟨.refl _, by show 0 < 1; omega⟩ | .step _ _ _ h _ => exact nomatch h -private theorem stmtsT_cons_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVarsPure P P.Expr] +private theorem stmtsT_cons_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] + [HasFvars P] (extendEval : ExtendEval P) {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} {ρ₀ : Env P} {label : String} {ρ' : Env P} @@ -4146,8 +4146,8 @@ private theorem stmtsT_cons_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [Has | .inr ⟨ρ₁, h1, h2, hlen⟩ => exact .inr ⟨ρ₁, h1, h2, by simp [ReflTransT.len]; omega⟩ -private theorem blockT_none_reaches_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVarsPure P P.Expr] +private theorem blockT_none_reaches_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] + [HasFvars P] (extendEval : ExtendEval P) {inner : Config P (Cmd P)} {σ_parent : SemanticStore P} {ρ' : Env P} (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) @@ -4168,8 +4168,8 @@ private theorem blockT_none_reaches_terminal' {P : PureExpr} [HasFvar P] [HasBoo match hrest with | .step _ _ _ h _ => exact nomatch h -private theorem blockT_none_reaches_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVarsPure P P.Expr] +private theorem blockT_none_reaches_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] + [HasFvars P] (extendEval : ExtendEval P) {inner : Config P (Cmd P)} {σ_parent : SemanticStore P} {label : String} {ρ' : Env P} @@ -4204,8 +4204,8 @@ preconditions: `measureCmds = []`, `decreaseBlocks = []`, `invCmds = []`, `accumBlocks ++ [(lentry, lentryBlk)] ++ bbs ++ bsRest` where `bsRest`'s entry label is `kNext`. -/ theorem loop_det_decompose_h_gen - {P : PureExpr} [HasFvar P] [HasNot P] [HasVal P] [HasBoolVal P] - [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasIdent P] [HasFvars P] [HasOps P] [HasInt P] [HasIntOps P] [DecidableEq P.Ident] [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] [LawfulHasIntOrder P] [LawfulHasNot P] (k : String) (gen gen' : StringGenState) @@ -4284,8 +4284,8 @@ from `.atBlock lentry σ hf` to `.atBlock bl σ hf` (when `b = true`) or `.atBlock kNext σ hf` (when `b = false`). Bridges the structured guard `ρ.eval ρ.store g = (if b then tt else ff)` to the CFG store via `StoreAgreement` + congruence. -/ -private theorem lentry_condGoto {P : PureExpr} [HasFvar P] [HasNot P] - [HasVarsPure P P.Expr] +private theorem lentry_condGoto {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasFvars P] (extendEval : ExtendEval P) (b : Bool) (cfg : CFG String (DetBlock String (Cmd P) P)) @@ -4299,9 +4299,9 @@ private theorem lentry_condGoto {P : PureExpr} [HasFvar P] [HasNot P] (h_cond : δ σ_struct g = .some (if b then HasBool.tt else HasBool.ff)) : StepDetCFGStar extendEval cfg (.atBlock lentry σ_cfg hf) (.atBlock (if b then bl else kNext) σ_cfg hf) := by - have h_def_g : isDefined σ_struct (HasVarsPure.getVars g) := + have h_def_g : isDefined σ_struct (HasFvars.getFvars g) := h_wf_def g _ σ_struct h_cond - have h_pointwise : ∀ y ∈ HasVarsPure.getVars g, σ_struct y = σ_cfg y := + have h_pointwise : ∀ y ∈ HasFvars.getFvars g, σ_struct y = σ_cfg y := store_agreement_pointwise_on_expr_vars σ_struct σ_cfg g h_agree h_def_g have h_cond_cfg : δ σ_cfg g = .some (if b then HasBool.tt else HasBool.ff) := h_cond ▸ (h_congr g σ_struct σ_cfg h_pointwise).symm @@ -4318,8 +4318,8 @@ run reaches `.terminal ρ_inner`; the block projection produces `ρ_block`; and the next loop iteration's `.stmt loop ρ_block` derivation reaches the same terminal with strictly smaller length. Specialized to `inv = []`, `m = none`, and `ρ_body_init = ρ_pre` (the `|| false` collapse). -/ -private theorem peel_off_one_iteration_det {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasVarsPure P P.Expr] +private theorem peel_off_one_iteration_det {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] + [HasVal P] [HasFvars P] (extendEval : ExtendEval P) (g : P.Expr) (body : List (Stmt P (Cmd P))) (md : MetaData P) (ρ_pre ρ_post_loop : Env P) @@ -4358,8 +4358,8 @@ private theorem peel_off_one_iteration_det {P : PureExpr} [HasFvar P] [HasBool P reaches `.exiting label`, decompose into a `Sum`: either this iteration's body exits (caseA), or this iteration terminates and the next loop iteration exits (caseB, with strictly smaller derivation length). -/ -private theorem peel_off_one_iteration_to_cont_det {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasVarsPure P P.Expr] +private theorem peel_off_one_iteration_to_cont_det {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] + [HasVal P] [HasFvars P] (extendEval : ExtendEval P) (g : P.Expr) (body : List (Stmt P (Cmd P))) (md : MetaData P) (ρ_pre ρ_post_loop : Env P) (label : String) @@ -4410,9 +4410,9 @@ Base case: `step_loop_exit` (guard false), where lentry's condGoto picks `kNext`. The CFG side of each iteration is `lentry →(cond true) bl →(body sim) lentry`; the failure flag tracks `ρ_pre'.hasFailure` per iteration. -/ private theorem loop_iterations_det - {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasIdent P] [HasFvars P] [HasOps P] [HasInt P] [HasIntOps P] + [DecidableEq P.Ident] [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] [LawfulHasIntOrder P] [LawfulHasNot P] (extendEval : ExtendEval P) @@ -4572,9 +4572,9 @@ The CFG side runs `lentry →(true) bl →(body terminal sim) lentry` for each completed iteration, then `lentry →(true) bl →(body _to_cont sim) bk_target` for the exiting iteration. -/ private theorem loop_iterations_to_cont_det - {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasIdent P] [HasFvars P] [HasOps P] [HasInt P] [HasIntOps P] + [DecidableEq P.Ident] [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] [LawfulHasIntOrder P] [LawfulHasNot P] (extendEval : ExtendEval P) @@ -4771,9 +4771,9 @@ The conclusion adds a freshness-preservation conjunct: if `σ_base x = none` and `x` is not in either accum's defs or `ss`'s inits, then the CFG-side `σ_cfg x = none`. This propagates freshness through CFG transitions into the recursive call on the rest of the program. -/ -private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] +private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasIdent P] [HasFvars P] [HasOps P] [HasInt P] [HasIntOps P] + [DecidableEq P.Ident] [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] [LawfulHasIntOrder P] [LawfulHasNot P] (extendEval : ExtendEval P) @@ -6458,9 +6458,9 @@ Same accum/agreement/freshness preconditions as `stmtsToBlocks_simulation`. Used by `.block` simulation when the body exits with the block's matching label: body's exitConts contains `(some label, kNext) :: outerExitConts`, so the body's exit resolves to a goto to `kNext`. -/ -private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] +private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasIdent P] [HasFvars P] [HasOps P] [HasInt P] [HasIntOps P] + [DecidableEq P.Ident] [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] [LawfulHasIntOrder P] [LawfulHasNot P] (extendEval : ExtendEval P) @@ -8353,9 +8353,9 @@ end /-- Specification lemma: `stmtsToCFG` produces a CFG whose blocks come from `stmtsToBlocks` plus a terminal block, and whose entry matches. Specialized to `CmdT = Cmd P` so we can use `stmtsToBlocks_invariant` -(which depends on the `[HasNot P]` instance present on `Cmd P`). -/ +(which depends on the `[HasBoolOps P]` instance present on `Cmd P`). -/ theorem stmtsToCFG_stmtsToBlocks_spec {P : PureExpr} - [HasBool P] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] + [HasBool P] [HasIdent P] [HasFvar P] [HasFvars P] [HasInt P] [HasIntOps P] [HasBoolOps P] (ss : List (Stmt P (Cmd P))) (h_disj : ∀ gen', Block.userLabelsDisjoint ss gen') : ∃ (lend : String) (gen gen' : StringGenState) @@ -8432,7 +8432,7 @@ theorem stmtsToCFG_stmtsToBlocks_spec {P : PureExpr} simp [List.lookup, Option.or] rfl -private theorem end_block_terminal {P : PureExpr} [HasFvar P] [HasNot P] [HasVarsPure P P.Expr] +private theorem end_block_terminal {P : PureExpr} [HasFvar P] [HasBoolOps P] [HasFvars P] (extendEval : ExtendEval P) (cfg : CFG String (DetBlock String (Cmd P) P)) (lend : String) (σ : SemanticStore P) (δ : SemanticEval P) (failed : Bool) @@ -8455,9 +8455,9 @@ private theorem end_block_terminal {P : PureExpr} [HasFvar P] [HasNot P] [HasVar The CFG end-store agrees with the structured end-store on every defined variable (`StoreAgreement`); they may differ only on variables introduced by inner scopes (e.g. `.block`'s local frames). -/ -theorem stmtsToCFG_terminal {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] +theorem stmtsToCFG_terminal {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasIdent P] [HasFvars P] [HasOps P] [HasInt P] [HasIntOps P] + [DecidableEq P.Ident] [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] [LawfulHasIntOrder P] [LawfulHasNot P] (extendEval : ExtendEval P) @@ -8537,9 +8537,9 @@ theorem stmtsToCFG_terminal {P : PureExpr} [HasFvar P] [HasNot P] Since CFGs have no "exiting" configs (exits are compiled to jumps), the exiting case is ruled out by the `h_exits` precondition. -/ -theorem structuredToUnstructured_sound {P : PureExpr} [HasFvar P] [HasNot P] - [HasVal P] [HasBoolVal P] [HasIdent P] [HasIntOrder P] - [HasVarsPure P P.Expr] [DecidableEq P.Ident] +theorem structuredToUnstructured_sound {P : PureExpr} [HasFvar P] [HasBoolOps P] + [HasIdent P] [HasFvars P] [HasOps P] [HasInt P] [HasIntOps P] + [DecidableEq P.Ident] [LawfulHasFvar P] [LawfulHasBool P] [LawfulHasIdent P] [LawfulHasIntOrder P] [LawfulHasNot P] (extendEval : ExtendEval P) From 1c9da9ad77d4f4cb42923e3426a76df0c4ceabc5 Mon Sep 17 00:00:00 2001 From: David Deng Date: Sun, 14 Jun 2026 13:58:23 -0700 Subject: [PATCH 31/33] fix(#1348): HasVal-diamond binders + e_parent in blockT_none/block_some inversion helpers --- .../StructuredToUnstructuredCorrect.lean | 38 +++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 493d258cd8..c6bdbcd1b7 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -3567,7 +3567,7 @@ entry label to the continuation `k` (or the resolved exit target). -/ runs from `σ_struct_base` (struct side) to `ρ₀.store` (struct side), and `StoreAgreement σ_struct_base σ_base` holds at the entry. -/ private theorem flushCmds_simulation_agree {P : PureExpr} [HasFvar P] [HasBoolOps P] - [HasVal P] [HasFvars P] [DecidableEq P.Ident] + [HasFvars P] [DecidableEq P.Ident] (extendEval : ExtendEval P) (pfx : String) (k : String) @@ -3647,7 +3647,7 @@ constructor of `stmtsToBlocks`). The block always materializes a single fresh block (regardless of whether `accum` is empty), since the transfer is explicit. -/ private theorem flushCmds_goto_simulation_agree {P : PureExpr} [HasFvar P] [HasBoolOps P] - [HasVal P] [HasFvars P] [DecidableEq P.Ident] + [HasFvars P] [DecidableEq P.Ident] (extendEval : ExtendEval P) (pfx : String) (accum : List (Cmd P)) (md : MetaData P) (bk : String) (gen gen' : StringGenState) @@ -3713,18 +3713,18 @@ private theorem block_some_reaches_exiting {P : PureExpr} {CmdT : Type} [HasBool P] [HasBoolOps P] {EvalCmd : EvalCmdParam P CmdT} {extendEval : ExtendEval P} {inner : Config P CmdT} {label' : String} {σ_parent : SemanticStore P} - {lbl : String} {ρ' : Env P} + {e_parent : SemanticEval P} {lbl : String} {ρ' : Env P} (hstar : StepStmtStar P EvalCmd extendEval - (.block (.some label') σ_parent inner) (.exiting lbl ρ')) : + (.block (.some label') σ_parent e_parent inner) (.exiting lbl ρ')) : label' ≠ lbl ∧ ∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ_inner) ∧ - ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } := by + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store, eval := e_parent } := by suffices ∀ src tgt, StepStmtStar P EvalCmd extendEval src tgt → - ∀ inner lbl ρ', src = .block (.some label') σ_parent inner → + ∀ inner lbl ρ', src = .block (.some label') σ_parent e_parent inner → tgt = .exiting lbl ρ' → label' ≠ lbl ∧ ∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ_inner) ∧ - ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } from + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store, eval := e_parent } from this _ _ hstar _ _ _ rfl rfl intro src tgt hstar_g induction hstar_g with @@ -4149,14 +4149,14 @@ private theorem stmtsT_cons_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [Has private theorem blockT_none_reaches_terminal' {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] (extendEval : ExtendEval P) - {inner : Config P (Cmd P)} {σ_parent : SemanticStore P} {ρ' : Env P} + {inner : Config P (Cmd P)} {σ_parent : SemanticStore P} {e_parent : SemanticEval P} {ρ' : Env P} (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) - (.block .none σ_parent inner) (.terminal ρ')) : + (.block .none σ_parent e_parent inner) (.terminal ρ')) : ∃ (ρ_inner : Env P) (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.terminal ρ_inner)), - ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store, eval := e_parent } ∧ h.len < hstar.len := by match hstar with - | .step _ (.block _ _ inner₁) _ (.step_block_body h) hrest => + | .step _ (.block _ _ _ inner₁) _ (.step_block_body h) hrest => have ⟨ρ_inner, hterm, heq, hlen⟩ := blockT_none_reaches_terminal' extendEval hrest exact ⟨ρ_inner, .step _ _ _ h hterm, heq, by simp [ReflTransT.len]; omega⟩ | .step _ _ _ .step_block_done hrest => @@ -4171,16 +4171,16 @@ private theorem blockT_none_reaches_terminal' {P : PureExpr} [HasFvar P] [HasBoo private theorem blockT_none_reaches_exiting' {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] [HasFvars P] (extendEval : ExtendEval P) - {inner : Config P (Cmd P)} {σ_parent : SemanticStore P} + {inner : Config P (Cmd P)} {σ_parent : SemanticStore P} {e_parent : SemanticEval P} {label : String} {ρ' : Env P} (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) - (.block .none σ_parent inner) (.exiting label ρ')) : + (.block .none σ_parent e_parent inner) (.exiting label ρ')) : ∃ (ρ_inner : Env P) (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.exiting label ρ_inner)), - ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store, eval := e_parent } ∧ h.len < hstar.len := by match hstar with - | .step _ (.block _ _ inner₁) _ (.step_block_body h) hrest => + | .step _ (.block _ _ _ inner₁) _ (.step_block_body h) hrest => have ⟨ρ_inner, hexit, heq, hlen⟩ := blockT_none_reaches_exiting' extendEval hrest exact ⟨ρ_inner, .step _ _ _ h hexit, heq, by simp [ReflTransT.len]; omega⟩ | .step _ _ _ .step_block_done hrest => @@ -4319,12 +4319,12 @@ the next loop iteration's `.stmt loop ρ_block` derivation reaches the same terminal with strictly smaller length. Specialized to `inv = []`, `m = none`, and `ρ_body_init = ρ_pre` (the `|| false` collapse). -/ private theorem peel_off_one_iteration_det {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] - [HasVal P] [HasFvars P] + [HasFvars P] (extendEval : ExtendEval P) (g : P.Expr) (body : List (Stmt P (Cmd P))) (md : MetaData P) (ρ_pre ρ_post_loop : Env P) (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) - (.seq (.block .none ρ_pre.store + (.seq (.block .none ρ_pre.store ρ_pre.eval (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false })) [.loop (.det g) none [] body md]) (.terminal ρ_post_loop)) : @@ -4359,12 +4359,12 @@ reaches `.exiting label`, decompose into a `Sum`: either this iteration's body exits (caseA), or this iteration terminates and the next loop iteration exits (caseB, with strictly smaller derivation length). -/ private theorem peel_off_one_iteration_to_cont_det {P : PureExpr} [HasFvar P] [HasBool P] [HasBoolOps P] - [HasVal P] [HasFvars P] + [HasFvars P] (extendEval : ExtendEval P) (g : P.Expr) (body : List (Stmt P (Cmd P))) (md : MetaData P) (ρ_pre ρ_post_loop : Env P) (label : String) (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) - (.seq (.block .none ρ_pre.store + (.seq (.block .none ρ_pre.store ρ_pre.eval (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false })) [.loop (.det g) none [] body md]) (.exiting label ρ_post_loop)) : From 4f0c6ba61d4d06f9fe5fc3944bbcdd025ae2e6d0 Mon Sep 17 00:00:00 2001 From: David Deng Date: Sun, 14 Jun 2026 14:14:01 -0700 Subject: [PATCH 32/33] fix(#1348): restructure ite arm for block-wrapped branches + e_parent in peel/block-AST inversions --- Strata/DL/Imperative/StmtSemantics.lean | 5 +- .../StructuredToUnstructuredCorrect.lean | 116 ++++++++++++------ 2 files changed, 82 insertions(+), 39 deletions(-) diff --git a/Strata/DL/Imperative/StmtSemantics.lean b/Strata/DL/Imperative/StmtSemantics.lean index 7f55487dda..b1a3dfec0f 100644 --- a/Strata/DL/Imperative/StmtSemantics.lean +++ b/Strata/DL/Imperative/StmtSemantics.lean @@ -232,9 +232,10 @@ projection of the inner env's store, and an agreement between the inner store and a CFG store, derive agreement between the outer store and the CFG store. -/ theorem StoreAgreement.through_projectStore {P : PureExpr} {σ_parent : SemanticStore P} - {ρ_inner ρ_blk : Env P} + {ρ_inner ρ_blk : Env P} {e_parent : SemanticEval P} {σ_cfg : SemanticStore P} - (h_ρ_blk_eq : ρ_blk = { ρ_inner with store := projectStore σ_parent ρ_inner.store }) + (h_ρ_blk_eq : ρ_blk = + { ρ_inner with store := projectStore σ_parent ρ_inner.store, eval := e_parent }) (h_agree_body : StoreAgreement ρ_inner.store σ_cfg) : StoreAgreement ρ_blk.store σ_cfg := by rw [h_ρ_blk_eq] diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index c6bdbcd1b7..406be7eb9b 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -3747,6 +3747,42 @@ private theorem block_some_reaches_exiting {P : PureExpr} {CmdT : Type} | step_block_done | step_block_exit_match => subst htgt; cases hrest with | step _ _ _ h _ => cases h +/-- Inversion of a `.none`-labelled block reaching terminal (`StepStmtStar` +variant). An anonymous block (the wrapper introduced by `ite`/loop bodies) +never catches an exit (`step_block_exit_match` requires `.some`), so the only +way it reaches `.terminal` is via its inner body terminating; the resulting +store is projected and the evaluator restored to `e_parent`. -/ +private theorem block_none_reaches_terminal {P : PureExpr} {CmdT : Type} + [HasBool P] [HasBoolOps P] + {EvalCmd : EvalCmdParam P CmdT} {extendEval : ExtendEval P} + {inner : Config P CmdT} {σ_parent : SemanticStore P} + {e_parent : SemanticEval P} {ρ' : Env P} + (hstar : StepStmtStar P EvalCmd extendEval + (.block .none σ_parent e_parent inner) (.terminal ρ')) : + ∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.terminal ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store, eval := e_parent } := by + suffices h_gen : ∀ src tgt, StepStmtStar P EvalCmd extendEval src tgt → + ∀ inner ρ', src = .block .none σ_parent e_parent inner → tgt = .terminal ρ' → + ∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.terminal ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store, eval := e_parent } from + h_gen _ _ hstar _ _ rfl rfl + intro src tgt hstar_g + induction hstar_g with + | refl => intro _ _ hsrc htgt; subst hsrc; cases htgt + | step _ mid _ hstep hrest ih => + intro inner ρ' hsrc htgt; subst hsrc + cases hstep with + | step_block_body h => + have ⟨ρ_inner, hterm, heq⟩ := ih _ _ rfl htgt + exact ⟨ρ_inner, .step _ _ _ h hterm, heq⟩ + | step_block_done => + subst htgt; cases hrest with + | refl => exact ⟨_, .refl _, rfl⟩ + | step _ _ _ h _ => cases h + | step_block_exit_match heq => exact nomatch heq + | step_block_exit_mismatch => + subst htgt; cases hrest with | step _ _ _ h _ => cases h + /-- Helper for cascading the `h_store_no_gens` precondition from `σ_base` to `σ_cfg_after = (lifted accum)` after running accum on the CFG side. Uses the digit-suffix property of `s` together with the assumption that no @@ -4332,7 +4368,7 @@ private theorem peel_off_one_iteration_det {P : PureExpr} [HasFvar P] [HasBool P StepStmtStar P (EvalCmd P) extendEval (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false }) (.terminal ρ_inner) ∧ - ρ_block = { ρ_inner with store := projectStore ρ_pre.store ρ_inner.store } ∧ + ρ_block = ({ ρ_inner with store := projectStore ρ_pre.store ρ_inner.store, eval := ρ_pre.eval } : Env P) ∧ ∃ (h_inner_T : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt (Stmt.loop (.det g) none [] body md) ρ_block) (.terminal ρ_post_loop)), @@ -4373,12 +4409,12 @@ private theorem peel_off_one_iteration_to_cont_det {P : PureExpr} [HasFvar P] [H (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false }) (.exiting label ρ_body_exit) ∧ ρ_post_loop = { ρ_body_exit with - store := projectStore ρ_pre.store ρ_body_exit.store }) ∨ + store := projectStore ρ_pre.store ρ_body_exit.store, eval := ρ_pre.eval }) ∨ (∃ (ρ_inner : Env P) (ρ_block : Env P), StepStmtStar P (EvalCmd P) extendEval (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false }) (.terminal ρ_inner) ∧ - ρ_block = { ρ_inner with store := projectStore ρ_pre.store ρ_inner.store } ∧ + ρ_block = ({ ρ_inner with store := projectStore ρ_pre.store ρ_inner.store, eval := ρ_pre.eval } : Env P) ∧ ∃ (h_inner_T : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt (Stmt.loop (.det g) none [] body md) ρ_block) (.exiting label ρ_post_loop)), @@ -4540,10 +4576,6 @@ private theorem loop_iterations_det have h_hf_block : ρ_block.hasFailure = ρ_inner.hasFailure := by rw [hρ_block_eq] have hρ_block_eval : ρ_block.eval = ρ_pre'.eval := by rw [hρ_block_eq] - show ρ_inner.eval = ρ_pre'.eval - have := smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval body - ρ_pre' ρ_inner h_nofd_body h_body_struct - rw [this] have h_eval_eq_block : ρ_block.eval = ρ_pre.eval := by rw [hρ_block_eval]; exact h_eval_eq have hwfb_block : WellFormedSemanticEvalBool ρ_block.eval := by @@ -4707,10 +4739,6 @@ private theorem loop_iterations_to_cont_det have h_hf_block : ρ_block.hasFailure = ρ_inner.hasFailure := by rw [hρ_block_eq] have hρ_block_eval : ρ_block.eval = ρ_pre'.eval := by rw [hρ_block_eq] - show ρ_inner.eval = ρ_pre'.eval - have := smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval body - ρ_pre' ρ_inner h_nofd_body h_body_struct - rw [this] have h_eval_eq_block : ρ_block.eval = ρ_pre.eval := by rw [hρ_block_eval]; exact h_eval_eq have hwfb_block : WellFormedSemanticEvalBool ρ_block.eval := by @@ -4959,11 +4987,16 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps [.ite (.det e) thenBranch elseBranch md] rest ρ₀ ρ' (by simp at h_term ⊢; exact h_term) -- Invert: the ite steps to either then-branch or else-branch - have h_ite_inv : (StepStmtStar P (EvalCmd P) extendEval - (.stmts thenBranch ρ₀) (.terminal ρ₁) ∧ + -- Each branch is now wrapped in a `.block .none ρ₀.store ρ₀.eval (.stmts _ ρ₀)` + -- (scoping); invert the block to recover the raw branch terminal `ρ_inner` + -- together with the projection equation for `ρ₁`. + have h_ite_inv : (∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts thenBranch ρ₀) (.terminal ρ_inner) ∧ + ρ₁ = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval } ∧ ρ₀.eval ρ₀.store e = .some HasBool.tt) ∨ - (StepStmtStar P (EvalCmd P) extendEval - (.stmts elseBranch ρ₀) (.terminal ρ₁) ∧ + (∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts elseBranch ρ₀) (.terminal ρ_inner) ∧ + ρ₁ = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval } ∧ ρ₀.eval ρ₀.store e = .some HasBool.ff) := by cases h_ite_star with | step _ _ _ hstep1 hrest1 => @@ -4977,9 +5010,14 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps | step _ _ _ hstep2 hrest2 => cases hstep2 with | step_ite_true h_eval_tt _ => - exact Or.inl ⟨hrest2, h_eval_tt⟩ + -- `hrest2 : .block .none ρ₀.store ρ₀.eval (.stmts thenBranch ρ₀) → .terminal ρ₁` + have ⟨ρ_inner, h_term, h_eq⟩ := + block_none_reaches_terminal (P := P) (EvalCmd := EvalCmd P) hrest2 + exact Or.inl ⟨ρ_inner, h_term, h_eq, h_eval_tt⟩ | step_ite_false h_eval_ff _ => - exact Or.inr ⟨hrest2, h_eval_ff⟩ + have ⟨ρ_inner, h_term, h_eq⟩ := + block_none_reaches_terminal (P := P) (EvalCmd := EvalCmd P) hrest2 + exact Or.inr ⟨ρ_inner, h_term, h_eq, h_eval_ff⟩ -- Block membership: distribute h_cfg_blocks over concatenated blocks subst h_blocks have h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks := fun b hb => @@ -5021,13 +5059,10 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps obtain ⟨h_simple_then, h_simple_else, h_lbni_then, h_lbni_else, h_lhni_then, h_lhni_else, h_nml_then, h_nml_else⟩ := ite_branch_shape h_simple_head h_lbni_head h_lhni_head h_nml_head - -- Eval well-formedness preservation through ite branch + -- Eval well-formedness preservation through ite branch: the branch's block + -- wrapper restores `ρ₀.eval` on exit, so `ρ₁.eval = ρ₀.eval` directly. have h_eval_eq : ρ₁.eval = ρ₀.eval := by - rcases h_ite_inv with h | h - · exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval - thenBranch ρ₀ ρ₁ h_nofd_then h.1 - · exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval - elseBranch ρ₀ ρ₁ h_nofd_else h.1 + rcases h_ite_inv with ⟨_, _, h_eq, _⟩ | ⟨_, _, h_eq, _⟩ <;> rw [h_eq] have hwfb₁ : WellFormedSemanticEvalBool ρ₁.eval := h_eval_eq ▸ hwfb have hwfv₁ : WellFormedSemanticEvalVal ρ₁.eval := h_eval_eq ▸ hwfv have hwf_def₁ : WellFormedSemanticEvalDef ρ₁.eval := h_eval_eq ▸ hwf_def @@ -5183,7 +5218,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps h_combined_no_gen_suffix_mod x (List.mem_append_right _ (h_modvars_eq ▸ List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hx))) s heq rcases h_ite_inv with h_true | h_false - · obtain ⟨h_then_term, h_cond_tt⟩ := h_true + · obtain ⟨ρ_then_inner, h_then_term, h_ρ₁_eq, h_cond_tt⟩ := h_true -- Step from accumEntry to tl via the lifted accum + condGoto. have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) @@ -5192,20 +5227,24 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_tt cfg h_cfg_accum h_lookup - -- Recurse on thenBranch. + -- Recurse on thenBranch (terminating at the raw inner env `ρ_then_inner`). have h_accum_nil_t : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := EvalCmds.eval_cmds_none - have ⟨σ_branch, h_then_step, h_agree_then, h_preserve_then⟩ := + have ⟨σ_branch, h_then_step, h_agree_then_inner, h_preserve_then⟩ := stmtsToBlocks_simulation extendEval kNext thenBranch exitConts [] gen_ite gen_t tl tbs h_then_eq h_nofd_then h_simple_then h_unique_then h_lbni_then h_lhni_then h_nml_then ρ₀.store σ_cfg_after ρ₀.hasFailure false - ρ₀ ρ₁ hwfb hwfv hwf_def hwf_congr hwf_var + ρ₀ ρ_then_inner hwfb hwfv hwf_def hwf_congr hwf_var h_then_term h_accum_nil_t h_agree_after h_combined_then h_unique_combined_then (by simp) h_wf_ite h_then_no_gen_suffix h_then_no_gen_suffix_mod genUpperBound h_outer_upper_t h_store_no_gens_upper_after cfg h_cfg_tbs h_cfg_nodup + -- Bridge the raw-inner store agreement through the block projection + -- to the post-ite env `ρ₁`. + have h_agree_then : StoreAgreement ρ₁.store σ_branch := + StoreAgreement.through_projectStore h_ρ₁_eq h_agree_then_inner -- Freshness of rest's inits at σ_branch. have h_fresh_rest_inits_branch : ∀ x ∈ Block.initVars rest, σ_branch x = none := by @@ -5292,7 +5331,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps have h_σ_branch_x : σ_branch x = none := h_preserve_then x h_σ_after_x h_nil_not h_x_not_then h_inner_guard_t exact h_preserve_rest x h_σ_branch_x h_nil_not h_x_not_rest h_inner_guard_r - · obtain ⟨h_else_term, h_cond_ff⟩ := h_false + · obtain ⟨ρ_else_inner, h_else_term, h_ρ₁_eq, h_cond_ff⟩ := h_false -- Step from accumEntry to fl via the lifted accum + condGoto. have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) @@ -5301,20 +5340,24 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_ff cfg h_cfg_accum h_lookup - -- Recurse on elseBranch. + -- Recurse on elseBranch (terminating at the raw inner env `ρ_else_inner`). have h_accum_nil_f : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := EvalCmds.eval_cmds_none - have ⟨σ_branch, h_else_step, h_agree_else, h_preserve_else⟩ := + have ⟨σ_branch, h_else_step, h_agree_else_inner, h_preserve_else⟩ := stmtsToBlocks_simulation extendEval kNext elseBranch exitConts [] gen_t gen_e fl fbs h_else_eq h_nofd_else h_simple_else h_unique_else h_lbni_else h_lhni_else h_nml_else ρ₀.store σ_cfg_after ρ₀.hasFailure false - ρ₀ ρ₁ hwfb hwfv hwf_def hwf_congr hwf_var + ρ₀ ρ_else_inner hwfb hwfv hwf_def hwf_congr hwf_var h_else_term h_accum_nil_f h_agree_after h_combined_else h_unique_combined_else (by simp) h_wf_t h_else_no_gen_suffix h_else_no_gen_suffix_mod genUpperBound h_outer_upper_e h_store_no_gens_upper_after cfg h_cfg_fbs h_cfg_nodup + -- Bridge the raw-inner store agreement through the block projection + -- to the post-ite env `ρ₁`. + have h_agree_else : StoreAgreement ρ₁.store σ_branch := + StoreAgreement.through_projectStore h_ρ₁_eq h_agree_else_inner -- Freshness of rest's inits at σ_branch. have h_fresh_rest_inits_branch : ∀ x ∈ Block.initVars rest, σ_branch x = none := by @@ -5753,10 +5796,10 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps have h_block_inv : (∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ_inner) ∧ - ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store }) ∨ + ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval }) ∨ (∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.exiting label ρ_inner) ∧ - ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store }) := by + ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval }) := by cases h_block_star with | step _ _ _ hstep1 hrest1 => cases hstep1 with @@ -5776,7 +5819,7 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps (.stmts body ρ₀) (.terminal ρ_inner) ∨ StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.exiting label ρ_inner)) ∧ - ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store } := by + ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval } := by rcases h_block_inv with h | h · obtain ⟨ρ_i, hterm, heq⟩ := h exact ⟨ρ_i, Or.inl hterm, heq⟩ @@ -5948,11 +5991,10 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps -- Bridge structured-side projection to CFG. have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body - -- Eval well-formedness preservation through body. + -- Eval well-formedness preservation through body: the block wrapper + -- restores `ρ₀.eval` on exit, so this holds directly from `h_ρ_blk_eq`. have h_eval_blk : ρ_blk.eval = ρ₀.eval := by rw [h_ρ_blk_eq] - exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval - body ρ₀ ρ_inner h_nofd_body h_body_term have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def From b4f52a8a38c7c68e91936108f0a01cce21154c04 Mon Sep 17 00:00:00 2001 From: David Deng Date: Sun, 14 Jun 2026 14:25:40 -0700 Subject: [PATCH 33/33] fix(#1348): restructure _to_cont ite arm + loop-arm block inversions for e_parent projection; add block_none inversion helpers --- .../StructuredToUnstructuredCorrect.lean | 183 +++++++++++------- 1 file changed, 117 insertions(+), 66 deletions(-) diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean index 406be7eb9b..9f5ea4dffc 100644 --- a/Strata/Transform/StructuredToUnstructuredCorrect.lean +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -3783,6 +3783,41 @@ private theorem block_none_reaches_terminal {P : PureExpr} {CmdT : Type} | step_block_exit_mismatch => subst htgt; cases hrest with | step _ _ _ h _ => cases h +/-- Inversion of a `.none`-labelled block reaching `.exiting lbl` (`StepStmtStar` +variant). An anonymous block never matches an exit label, so it always +propagates the inner exit unchanged (same label `lbl`); the resulting store is +projected and the evaluator restored to `e_parent`. -/ +private theorem block_none_reaches_exiting {P : PureExpr} {CmdT : Type} + [HasBool P] [HasBoolOps P] + {EvalCmd : EvalCmdParam P CmdT} {extendEval : ExtendEval P} + {inner : Config P CmdT} {σ_parent : SemanticStore P} + {e_parent : SemanticEval P} {lbl : String} {ρ' : Env P} + (hstar : StepStmtStar P EvalCmd extendEval + (.block .none σ_parent e_parent inner) (.exiting lbl ρ')) : + ∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store, eval := e_parent } := by + suffices h_gen : ∀ src tgt, StepStmtStar P EvalCmd extendEval src tgt → + ∀ inner lbl ρ', src = .block .none σ_parent e_parent inner → tgt = .exiting lbl ρ' → + ∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store, eval := e_parent } from + h_gen _ _ hstar _ _ _ rfl rfl + intro src tgt hstar_g + induction hstar_g with + | refl => intro _ _ _ hsrc htgt; subst hsrc; cases htgt + | step _ mid _ hstep hrest ih => + intro inner lbl ρ' hsrc htgt; subst hsrc + cases hstep with + | step_block_body h => + have ⟨ρ_inner, hexit, heq⟩ := ih _ _ _ rfl htgt + exact ⟨ρ_inner, .step _ _ _ h hexit, heq⟩ + | step_block_exit_mismatch hne => + subst htgt; cases hrest with + | refl => exact ⟨_, .refl _, rfl⟩ + | step _ _ _ h _ => cases h + | step_block_done => + subst htgt; cases hrest with | step _ _ _ h _ => cases h + | step_block_exit_match heq => exact nomatch heq + /-- Helper for cascading the `h_store_no_gens` precondition from `σ_base` to `σ_cfg_after = (lifted accum)` after running accum on the CFG side. Uses the digit-suffix property of `s` together with the assumption that no @@ -4464,7 +4499,7 @@ private theorem loop_iterations_det (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) (.terminal ρ_post_loop)) - (h_nofd_body : Block.noFuncDecl body = true) + (_h_nofd_body : Block.noFuncDecl body = true) (h_body_sim_at : ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), ρ_iter.eval = ρ_pre.eval → @@ -4622,7 +4657,7 @@ private theorem loop_iterations_to_cont_det (h_exit : StepStmtStar P (EvalCmd P) extendEval (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) (.exiting label ρ_post_loop)) - (h_nofd_body : Block.noFuncDecl body = true) + (_h_nofd_body : Block.noFuncDecl body = true) (h_body_sim_at : ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), ρ_iter.eval = ρ_pre.eval → @@ -5295,8 +5330,12 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_t cfg h_cfg_rest h_cfg_nodup + -- The then-branch terminal flag `ρ_then_inner.hasFailure` equals `ρ₁.hasFailure` + -- (the block projection only touches store/eval), so the CFG chains compose. + have h_hf_then : ρ₁.hasFailure = ρ_then_inner.hasFailure := by rw [h_ρ₁_eq] refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ - · exact StepDetCFGStar_trans + · rw [h_hf_then] at h_rest_sim + exact StepDetCFGStar_trans (StepDetCFGStar_trans h_flush_sim h_then_step) h_rest_sim · -- Freshness preservation for the outer call. intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard @@ -5408,8 +5447,10 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_e cfg h_cfg_rest h_cfg_nodup + have h_hf_else : ρ₁.hasFailure = ρ_else_inner.hasFailure := by rw [h_ρ₁_eq] refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ - · exact StepDetCFGStar_trans + · rw [h_hf_else] at h_rest_sim + exact StepDetCFGStar_trans (StepDetCFGStar_trans h_flush_sim h_else_step) h_rest_sim · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard have h_x_not_else : x ∉ Block.initVars elseBranch := fun hx => @@ -6107,11 +6148,9 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps -- Bridge structured-side projection to CFG. have h_agree_block_body : StoreAgreement ρ_blk.store σ_cfg_body := StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body - -- Eval well-formedness preservation through body (to .exiting). + -- Eval well-formedness preservation through body (block restores ρ₀.eval). have h_eval_blk : ρ_blk.eval = ρ₀.eval := by rw [h_ρ_blk_eq] - exact smallStep_noFuncDecl_preserves_eval_block_exiting P (EvalCmd P) extendEval - body ρ₀ ρ_inner label h_nofd_body h_body_exit_star have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def @@ -6254,8 +6293,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body have h_eval_blk : ρ_blk.eval = ρ₀.eval := by rw [h_ρ_blk_eq] - exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval - body ρ₀ ρ_inner h_nofd_body h_body_term have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def @@ -6348,8 +6385,6 @@ private theorem stmtsToBlocks_simulation {P : PureExpr} [HasFvar P] [HasBoolOps StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body have h_eval_blk : ρ_blk.eval = ρ₀.eval := by rw [h_ρ_blk_eq] - exact smallStep_noFuncDecl_preserves_eval_block_exiting P (EvalCmd P) extendEval - body ρ₀ ρ_inner label h_nofd_body h_body_exit_star have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def @@ -6810,14 +6845,14 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has (label' ≠ label ∧ ∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.exiting label ρ_inner) ∧ - ρ' = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store }) ∨ + ρ' = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval }) ∨ -- (B): block terminates then rest exits. (∃ ρ_blk, ((∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ_inner) ∧ - ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store }) ∨ + ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval }) ∨ (∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.exiting label' ρ_inner) ∧ - ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store })) ∧ + ρ_blk = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval })) ∧ StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ_blk) (.exiting label ρ')) := by cases h_exit with | step _ _ _ hstep1 hrest1 => @@ -7050,8 +7085,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body have h_eval_blk : ρ_blk.eval = ρ₀.eval := by rw [h_ρ_blk_eq] - exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval - body ρ₀ ρ_inner h_nofd_body h_body_term have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def @@ -7130,8 +7163,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body have h_eval_blk : ρ_blk.eval = ρ₀.eval := by rw [h_ρ_blk_eq] - exact smallStep_noFuncDecl_preserves_eval_block_exiting P (EvalCmd P) extendEval - body ρ₀ ρ_inner label' h_nofd_body h_body_match have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def @@ -7320,8 +7351,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body have h_eval_blk : ρ_blk.eval = ρ₀.eval := by rw [h_ρ_blk_eq] - exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval - body ρ₀ ρ_inner h_nofd_body h_body_term have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def @@ -7400,8 +7429,6 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has StoreAgreement.through_projectStore h_ρ_blk_eq h_agree_body have h_eval_blk : ρ_blk.eval = ρ₀.eval := by rw [h_ρ_blk_eq] - exact smallStep_noFuncDecl_preserves_eval_block_exiting P (EvalCmd P) extendEval - body ρ₀ ρ_inner label' h_nofd_body h_body_match have hwfb₁ : WellFormedSemanticEvalBool ρ_blk.eval := h_eval_blk ▸ hwfb have hwfv₁ : WellFormedSemanticEvalVal ρ_blk.eval := h_eval_blk ▸ hwfv have hwf_def₁ : WellFormedSemanticEvalDef ρ_blk.eval := h_eval_blk ▸ hwf_def @@ -7490,21 +7517,28 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has -- Two outer cases via seq_reaches_exiting: -- (caseA) inner `.stmt (.ite ..) ρ₀` already exits with `label`; rest doesn't run. -- (caseB) inner terminates at ρ_mid, then rest exits. + -- Each branch is wrapped in a `.block .none ρ₀.store ρ₀.eval (.stmts _ ρ₀)` + -- (scoping); invert the block to recover the raw branch result `ρ_inner` + -- together with the projection equation. have h_decomp : -- caseA: branch itself exits with `label`. Either thenBranch (cond=tt) or elseBranch (cond=ff). - ((StepStmtStar P (EvalCmd P) extendEval - (.stmts thenBranch ρ₀) (.exiting label ρ') ∧ + ((∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts thenBranch ρ₀) (.exiting label ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval } ∧ ρ₀.eval ρ₀.store e = .some HasBool.tt) ∨ - (StepStmtStar P (EvalCmd P) extendEval - (.stmts elseBranch ρ₀) (.exiting label ρ') ∧ + (∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts elseBranch ρ₀) (.exiting label ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval } ∧ ρ₀.eval ρ₀.store e = .some HasBool.ff)) ∨ - -- caseB: branch terminates at ρ_mid, rest exits with `label`. + -- caseB: branch terminates at ρ_mid (= projected ρ_inner), rest exits with `label`. (∃ ρ_mid, - ((StepStmtStar P (EvalCmd P) extendEval - (.stmts thenBranch ρ₀) (.terminal ρ_mid) ∧ + ((∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts thenBranch ρ₀) (.terminal ρ_inner) ∧ + ρ_mid = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval } ∧ ρ₀.eval ρ₀.store e = .some HasBool.tt) ∨ - (StepStmtStar P (EvalCmd P) extendEval - (.stmts elseBranch ρ₀) (.terminal ρ_mid) ∧ + (∃ ρ_inner, StepStmtStar P (EvalCmd P) extendEval + (.stmts elseBranch ρ₀) (.terminal ρ_inner) ∧ + ρ_mid = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store, eval := ρ₀.eval } ∧ ρ₀.eval ρ₀.store e = .some HasBool.ff)) ∧ StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ_mid) (.exiting label ρ')) := by cases h_exit with @@ -7518,18 +7552,26 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has | step _ _ _ hstep2 hrest2 => cases hstep2 with | step_ite_true h_eval_tt _ => - exact Or.inl (Or.inl ⟨hrest2, h_eval_tt⟩) + have ⟨ρ_inner, h_exit', h_eq⟩ := + block_none_reaches_exiting (P := P) (EvalCmd := EvalCmd P) hrest2 + exact Or.inl (Or.inl ⟨ρ_inner, h_exit', h_eq, h_eval_tt⟩) | step_ite_false h_eval_ff _ => - exact Or.inl (Or.inr ⟨hrest2, h_eval_ff⟩) + have ⟨ρ_inner, h_exit', h_eq⟩ := + block_none_reaches_exiting (P := P) (EvalCmd := EvalCmd P) hrest2 + exact Or.inl (Or.inr ⟨ρ_inner, h_exit', h_eq, h_eval_ff⟩) · obtain ⟨ρ_mid_outer, h_inner_term, h_rest_exit⟩ := h_term_exit -- inner = .stmt (.ite ..) ρ₀ → .terminal ρ_mid_outer cases h_inner_term with | step _ _ _ hstep2 hrest2 => cases hstep2 with | step_ite_true h_eval_tt _ => - exact Or.inr ⟨ρ_mid_outer, Or.inl ⟨hrest2, h_eval_tt⟩, h_rest_exit⟩ + have ⟨ρ_inner, h_term', h_eq⟩ := + block_none_reaches_terminal (P := P) (EvalCmd := EvalCmd P) hrest2 + exact Or.inr ⟨ρ_mid_outer, Or.inl ⟨ρ_inner, h_term', h_eq, h_eval_tt⟩, h_rest_exit⟩ | step_ite_false h_eval_ff _ => - exact Or.inr ⟨ρ_mid_outer, Or.inr ⟨hrest2, h_eval_ff⟩, h_rest_exit⟩ + have ⟨ρ_inner, h_term', h_eq⟩ := + block_none_reaches_terminal (P := P) (EvalCmd := EvalCmd P) hrest2 + exact Or.inr ⟨ρ_mid_outer, Or.inr ⟨ρ_inner, h_term', h_eq, h_eval_ff⟩, h_rest_exit⟩ -- Block membership: distribute h_cfg_blocks over concatenated blocks. subst h_blocks have h_cfg_accum : ∀ b ∈ accumBlocks, b ∈ cfg.blocks := fun b hb => @@ -7719,7 +7761,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has rcases h_decomp with h_caseA | h_caseB · -- Branch itself exits with `label`; rest does not run. rcases h_caseA with h_true | h_false - · obtain ⟨h_then_exit, h_cond_tt⟩ := h_true + · obtain ⟨ρ_then_inner, h_then_exit, h_ρ'_eq, h_cond_tt⟩ := h_true have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) (.atBlock tl σ_cfg_after ρ₀.hasFailure) := @@ -7727,22 +7769,26 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has accumEntry accumBlocks h_flush_eq σ_base σ_cfg_after hf_base hf_accum ρ₀ hwfb hwf_def hwf_congr h_accum_cfg h_agree_after h_hf h_cond_tt cfg h_cfg_accum h_lookup - -- Recurse on thenBranch with _to_cont (target = bk_target). + -- Recurse on thenBranch with _to_cont (exiting at the raw inner env). have h_accum_nil_t : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := EvalCmds.eval_cmds_none - have ⟨σ_cfg_branch, h_then_step, h_agree_branch, h_preserve_branch⟩ := + have ⟨σ_cfg_branch, h_then_step, h_agree_branch_inner, h_preserve_branch⟩ := stmtsToBlocks_simulation_to_cont extendEval kNext thenBranch exitConts [] gen_ite gen_t tl tbs h_then_eq h_nofd_then h_simple_then h_unique_then h_lbni_then h_lhni_then h_nml_then ρ₀.store σ_cfg_after ρ₀.hasFailure false - ρ₀ ρ' label bk_target h_label hwfb hwfv hwf_def hwf_congr hwf_var + ρ₀ ρ_then_inner label bk_target h_label hwfb hwfv hwf_def hwf_congr hwf_var h_then_exit h_accum_nil_t h_agree_after h_combined_then h_unique_combined_then (by simp) h_wf_ite h_then_no_gen_suffix h_then_no_gen_suffix_mod genUpperBound h_outer_upper_t h_store_no_gens_upper_after cfg h_cfg_tbs h_cfg_nodup + -- Bridge the raw-inner store agreement through the block projection to `ρ'`. + have h_agree_branch : StoreAgreement ρ'.store σ_cfg_branch := + StoreAgreement.through_projectStore h_ρ'_eq h_agree_branch_inner + have h_hf_then : ρ'.hasFailure = ρ_then_inner.hasFailure := by rw [h_ρ'_eq] refine ⟨σ_cfg_branch, ?_, h_agree_branch, ?_⟩ - · exact StepDetCFGStar_trans h_flush_sim h_then_step + · rw [h_hf_then]; exact StepDetCFGStar_trans h_flush_sim h_then_step · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard have h_x_not_then : x ∉ Block.initVars thenBranch := fun hx => h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_left _ hx)) @@ -7757,7 +7803,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has | Or.inr h_not_in => Or.inr (fun h_in_t => h_not_in (h_gen_eq_f ▸ h_step_e_to_f.subset (h_step_t_to_e.subset h_in_t))) exact h_preserve_branch x h_σ_after_x h_nil_not h_x_not_then h_inner_guard_t - · obtain ⟨h_else_exit, h_cond_ff⟩ := h_false + · obtain ⟨ρ_else_inner, h_else_exit, h_ρ'_eq, h_cond_ff⟩ := h_false have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) (.atBlock fl σ_cfg_after ρ₀.hasFailure) := @@ -7767,19 +7813,23 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_cfg_accum h_lookup have h_accum_nil_f : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := EvalCmds.eval_cmds_none - have ⟨σ_cfg_branch, h_else_step, h_agree_branch, h_preserve_branch⟩ := + have ⟨σ_cfg_branch, h_else_step, h_agree_branch_inner, h_preserve_branch⟩ := stmtsToBlocks_simulation_to_cont extendEval kNext elseBranch exitConts [] gen_t gen_e fl fbs h_else_eq h_nofd_else h_simple_else h_unique_else h_lbni_else h_lhni_else h_nml_else ρ₀.store σ_cfg_after ρ₀.hasFailure false - ρ₀ ρ' label bk_target h_label hwfb hwfv hwf_def hwf_congr hwf_var + ρ₀ ρ_else_inner label bk_target h_label hwfb hwfv hwf_def hwf_congr hwf_var h_else_exit h_accum_nil_f h_agree_after h_combined_else h_unique_combined_else (by simp) h_wf_t h_else_no_gen_suffix h_else_no_gen_suffix_mod genUpperBound h_outer_upper_e h_store_no_gens_upper_after cfg h_cfg_fbs h_cfg_nodup + -- Bridge the raw-inner store agreement through the block projection to `ρ'`. + have h_agree_branch : StoreAgreement ρ'.store σ_cfg_branch := + StoreAgreement.through_projectStore h_ρ'_eq h_agree_branch_inner + have h_hf_else : ρ'.hasFailure = ρ_else_inner.hasFailure := by rw [h_ρ'_eq] refine ⟨σ_cfg_branch, ?_, h_agree_branch, ?_⟩ - · exact StepDetCFGStar_trans h_flush_sim h_else_step + · rw [h_hf_else]; exact StepDetCFGStar_trans h_flush_sim h_else_step · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard have h_x_not_else : x ∉ Block.initVars elseBranch := fun hx => h_x_not_inits (h_initvars_eq ▸ List.mem_append_left _ (List.mem_append_right _ hx)) @@ -7796,21 +7846,12 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has exact h_preserve_branch x h_σ_after_x h_nil_not h_x_not_else h_inner_guard_e · -- Branch terminates at ρ_mid, then rest exits with `label`. obtain ⟨ρ_mid, h_branch_term_or, h_rest_exit⟩ := h_caseB - -- Eval well-formedness preservation through the branch (terminal). - have hwfb₁ : WellFormedSemanticEvalBool ρ_mid.eval := by - exact h_branch_term_or.elim - (fun h => StepStmtStar_wfb_preserved extendEval thenBranch ρ₀ ρ_mid h.1 h_nofd_then hwfb) - (fun h => StepStmtStar_wfb_preserved extendEval elseBranch ρ₀ ρ_mid h.1 h_nofd_else hwfb) - have hwfv₁ : WellFormedSemanticEvalVal ρ_mid.eval := by - exact h_branch_term_or.elim - (fun h => StepStmtStar_wfv_preserved extendEval thenBranch ρ₀ ρ_mid h.1 h_nofd_then hwfv) - (fun h => StepStmtStar_wfv_preserved extendEval elseBranch ρ₀ ρ_mid h.1 h_nofd_else hwfv) + -- Eval well-formedness preservation through the branch: the block wrapper + -- restores `ρ₀.eval`, so `ρ_mid.eval = ρ₀.eval` directly from the projection. have h_eval_eq : ρ_mid.eval = ρ₀.eval := by - rcases h_branch_term_or with h | h - · exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval - thenBranch ρ₀ ρ_mid h_nofd_then h.1 - · exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval - elseBranch ρ₀ ρ_mid h_nofd_else h.1 + rcases h_branch_term_or with ⟨_, _, h_eq, _⟩ | ⟨_, _, h_eq, _⟩ <;> rw [h_eq] + have hwfb₁ : WellFormedSemanticEvalBool ρ_mid.eval := h_eval_eq ▸ hwfb + have hwfv₁ : WellFormedSemanticEvalVal ρ_mid.eval := h_eval_eq ▸ hwfv have hwf_def₁ : WellFormedSemanticEvalDef ρ_mid.eval := by rw [h_eval_eq]; exact hwf_def have hwf_congr₁ : WellFormedSemanticEvalExprCongr ρ_mid.eval := by @@ -7818,7 +7859,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have hwf_var₁ : WellFormedSemanticEvalVar ρ_mid.eval := by rw [h_eval_eq]; exact hwf_var rcases h_branch_term_or with h_true | h_false - · obtain ⟨h_then_term, h_cond_tt⟩ := h_true + · obtain ⟨ρ_then_inner, h_then_term, h_ρmid_eq, h_cond_tt⟩ := h_true have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) (.atBlock tl σ_cfg_after ρ₀.hasFailure) := @@ -7828,17 +7869,21 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_cfg_accum h_lookup have h_accum_nil_t : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := EvalCmds.eval_cmds_none - have ⟨σ_branch, h_then_step, h_agree_then, h_preserve_then⟩ := + have ⟨σ_branch, h_then_step, h_agree_then_inner, h_preserve_then⟩ := stmtsToBlocks_simulation extendEval kNext thenBranch exitConts [] gen_ite gen_t tl tbs h_then_eq h_nofd_then h_simple_then h_unique_then h_lbni_then h_lhni_then h_nml_then ρ₀.store σ_cfg_after ρ₀.hasFailure false - ρ₀ ρ_mid hwfb hwfv hwf_def hwf_congr hwf_var + ρ₀ ρ_then_inner hwfb hwfv hwf_def hwf_congr hwf_var h_then_term h_accum_nil_t h_agree_after h_combined_then h_unique_combined_then (by simp) h_wf_ite h_then_no_gen_suffix h_then_no_gen_suffix_mod genUpperBound h_outer_upper_t h_store_no_gens_upper_after cfg h_cfg_tbs h_cfg_nodup + -- Bridge the raw-inner store agreement through the block projection to `ρ_mid`. + have h_agree_then : StoreAgreement ρ_mid.store σ_branch := + StoreAgreement.through_projectStore h_ρmid_eq h_agree_then_inner + have h_hf_then : ρ_mid.hasFailure = ρ_then_inner.hasFailure := by rw [h_ρmid_eq] -- Freshness of rest's inits at σ_branch. have h_fresh_rest_inits_branch : ∀ x ∈ Block.initVars rest, σ_branch x = none := by @@ -7888,7 +7933,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_t cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ - · exact StepDetCFGStar_trans + · rw [h_hf_then] at h_rest_sim + exact StepDetCFGStar_trans (StepDetCFGStar_trans h_flush_sim h_then_step) h_rest_sim · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard have h_x_not_then : x ∉ Block.initVars thenBranch := fun hx => @@ -7916,7 +7962,7 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has have h_σ_branch_x : σ_branch x = none := h_preserve_then x h_σ_after_x h_nil_not h_x_not_then h_inner_guard_t exact h_preserve_rest x h_σ_branch_x h_nil_not h_x_not_rest h_inner_guard_r - · obtain ⟨h_else_term, h_cond_ff⟩ := h_false + · obtain ⟨ρ_else_inner, h_else_term, h_ρmid_eq, h_cond_ff⟩ := h_false have h_flush_sim : StepDetCFGStar extendEval cfg (.atBlock accumEntry σ_base hf_base) (.atBlock fl σ_cfg_after ρ₀.hasFailure) := @@ -7926,17 +7972,21 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has h_cfg_accum h_lookup have h_accum_nil_f : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := EvalCmds.eval_cmds_none - have ⟨σ_branch, h_else_step, h_agree_else, h_preserve_else⟩ := + have ⟨σ_branch, h_else_step, h_agree_else_inner, h_preserve_else⟩ := stmtsToBlocks_simulation extendEval kNext elseBranch exitConts [] gen_t gen_e fl fbs h_else_eq h_nofd_else h_simple_else h_unique_else h_lbni_else h_lhni_else h_nml_else ρ₀.store σ_cfg_after ρ₀.hasFailure false - ρ₀ ρ_mid hwfb hwfv hwf_def hwf_congr hwf_var + ρ₀ ρ_else_inner hwfb hwfv hwf_def hwf_congr hwf_var h_else_term h_accum_nil_f h_agree_after h_combined_else h_unique_combined_else (by simp) h_wf_t h_else_no_gen_suffix h_else_no_gen_suffix_mod genUpperBound h_outer_upper_e h_store_no_gens_upper_after cfg h_cfg_fbs h_cfg_nodup + -- Bridge the raw-inner store agreement through the block projection to `ρ_mid`. + have h_agree_else : StoreAgreement ρ_mid.store σ_branch := + StoreAgreement.through_projectStore h_ρmid_eq h_agree_else_inner + have h_hf_else : ρ_mid.hasFailure = ρ_else_inner.hasFailure := by rw [h_ρmid_eq] have h_fresh_rest_inits_branch : ∀ x ∈ Block.initVars rest, σ_branch x = none := by intro x hx @@ -7985,7 +8035,8 @@ private theorem stmtsToBlocks_simulation_to_cont {P : PureExpr} [HasFvar P] [Has genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_e cfg h_cfg_rest h_cfg_nodup refine ⟨σ_cfg, ?_, h_agree_rest, ?_⟩ - · exact StepDetCFGStar_trans + · rw [h_hf_else] at h_rest_sim + exact StepDetCFGStar_trans (StepDetCFGStar_trans h_flush_sim h_else_step) h_rest_sim · intro x h_σ_x h_x_not_accum h_x_not_inits h_outer_guard have h_x_not_else : x ∉ Block.initVars elseBranch := fun hx =>