diff --git a/README.md b/README.md index 1c5b84989e..7f0c69e097 100644 --- a/README.md +++ b/README.md @@ -72,7 +72,7 @@ A JDK (11+) providing `javac` must be on your `PATH`. For running the Java/Ion integration test, download the ion-java jar: ```bash -wget -q -O StrataTestExtra/Languages/Java/testdata/ion-java-1.11.11.jar \ +wget -q -O StrataTestExtra/DDM/Integration/Java/testdata/ion-java-1.11.11.jar \ https://github.com/amazon-ion/ion-java/releases/download/v1.11.11/ion-java-1.11.11.jar ``` diff --git a/Strata.lean b/Strata.lean index 5457e4d54a..372404e30a 100644 --- a/Strata.lean +++ b/Strata.lean @@ -31,9 +31,12 @@ import Strata.Languages.Laurel.LaurelCompilationPipeline /- Code Transforms -/ import Strata.Transform.CallElimCorrect +import Strata.Transform.CanFailPreservation import Strata.Transform.CoreSpecification import Strata.Transform.DetToKleeneCorrect +import Strata.Transform.PipelineBridge import Strata.Transform.ProcBodyVerifyCorrect +import Strata.Transform.StructuredToUnstructuredCorrect /- Strata Languages — additional -/ import Strata.Languages.B3 @@ -59,6 +62,7 @@ import Strata.DL.SMT.FactoryCorrect import Strata.DL.SMT.Translate /- Code Transforms — additional -/ +import Strata.Transform.GenSuffix import Strata.Transform.StructuredToUnstructured /- Other -/ diff --git a/Strata/DL/Imperative/BasicBlock.lean b/Strata/DL/Imperative/BasicBlock.lean index 564652f1dc..f22a4ce48f 100644 --- a/Strata/DL/Imperative/BasicBlock.lean +++ b/Strata/DL/Imperative/BasicBlock.lean @@ -30,17 +30,22 @@ where `n` is the total number of blocks in the graph. where execution should proceed next, if anywhere. -/ inductive DetTransferCmd (Label : Type) (P : PureExpr) where /-- Transfer to `lt` if `p` is true, or `lf` is `p` is false. -/ - | condGoto (p : P.Expr) (lt lf : Label) (md : MetaData P := .empty) + | condGoto (p : P.Expr) (lt lf : Label) (md : MetaData P) /-- Stop execution of the current unstructured program. If in a procedure body, this can be interpreted as returning to the caller. -/ - | finish (md : MetaData P := .empty) + | finish (md : MetaData P) + /-- Escape the current unstructured program by an uncaught structured exit + to `lbl`. Unlike `finish` (a normal return), this records that control + left the program via an exit that no enclosing block caught, preserving + the escaping label so the outcome kind is observable on the target side. -/ + | exitTo (lbl : Label) (md : MetaData P) /-- For the moment, we don't have an unconditional jump in the language, and 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. -/ -def DetTransferCmd.goto [HasBool P] (l : Label) : DetTransferCmd Label P := - condGoto HasBool.tt l l +@[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, indicating the list of possible blocks where execution could proceed next, if @@ -48,7 +53,7 @@ anywhere. -/ inductive NondetTransferCmd (Label : Type) (P : PureExpr) where /-- Transfer to any one of a list of labels, non-deterministically. `goto` with no labels is equivalent to `finish` in `DetTransferCmd` -/ - | goto (ls : List Label) (md : MetaData P := .empty) + | goto (ls : List Label) (md : MetaData P) deriving Inhabited def NondetTransferCmd.targets : NondetTransferCmd Label P → List Label @@ -79,6 +84,27 @@ structure CFG (Label Block : Type) where -------- +/-- Strip metadata from a deterministic transfer command. -/ +def DetTransferCmd.stripMetaData : DetTransferCmd Label P → DetTransferCmd Label P + | .condGoto p lt lf _ => .condGoto p lt lf .empty + | .finish _ => .finish .empty + | .exitTo lbl _ => .exitTo lbl .empty + +/-- Strip metadata from a non-deterministic transfer command. -/ +def NondetTransferCmd.stripMetaData : NondetTransferCmd Label P → NondetTransferCmd Label P + | .goto ls _ => .goto ls .empty + +/-- Strip transfer metadata from a deterministic basic block. -/ +def DetBlock.stripMetaData (blk : DetBlock Label Cmd P) : DetBlock Label Cmd P := + { blk with transfer := blk.transfer.stripMetaData } + +/-- Strip transfer metadata from all blocks in a deterministic CFG. -/ +def CFG.stripDetMetaData (cfg : CFG Label (DetBlock Label Cmd P)) : + CFG Label (DetBlock Label Cmd P) := + { cfg with blocks := cfg.blocks.map fun (lbl, blk) => (lbl, blk.stripMetaData) } + +-------- + open Std (ToFormat Format format) def formatDetTransferCmd (P : PureExpr) (c : DetTransferCmd Label P) @@ -86,6 +112,7 @@ def formatDetTransferCmd (P : PureExpr) (c : DetTransferCmd Label P) match c with | .condGoto c lt lf md => f!"{md}condGoto {c} {lt} {lf}" | .finish md => f!"{md}finish" + | .exitTo lbl md => f!"{md}exitTo {lbl}" def formatNondetTransferCmd (P : PureExpr) (c : NondetTransferCmd Label P) [ToFormat Label] [ToFormat P.Ident] [ToFormat P.Expr] [ToFormat P.Ty] : Format := diff --git a/Strata/DL/Imperative/CFGSemantics.lean b/Strata/DL/Imperative/CFGSemantics.lean index 9ddd57722e..15d499206b 100644 --- a/Strata/DL/Imperative/CFGSemantics.lean +++ b/Strata/DL/Imperative/CFGSemantics.lean @@ -17,125 +17,200 @@ namespace Imperative /-! ## Small-Step operational semantics for control-flow graphs This module defines small-step operational semantics for the Imperative -dialect's control-flow graph representation. +dialect's control-flow graph representation, in a *per-command* style: +each step either fetches a block at a label, runs a single command from +the residual list, or fires the block transfer. -/ -inductive EvalCmds - {CmdT : Type} - (P : PureExpr) - (EvalCmd : EvalCmdParam P CmdT) : - SemanticEval P → SemanticStore P → List CmdT → SemanticStore P → Bool → Prop where - | eval_cmds_none : - EvalCmds P EvalCmd δ σ [] σ false - | eval_cmds_some : - EvalCmd δ σ c σ' failed → - EvalCmds P EvalCmd δ σ' cs σ'' failed' → - EvalCmds P EvalCmd δ σ (c :: cs) σ'' (failed || failed') - /-- -Configuration for small-step semantics, representing the current execution -state. A configuration consists of a store and a failure indication flag paired -with either: - -- The next block to execute -- An indication that the program that has finished executing --/ -inductive CFGConfig (l : Type) (P : PureExpr): Type where - /-- The label to execute next. -/ - | cont : l → SemanticStore P → Bool → CFGConfig l P - /-- A terminal configuration, indicating that execution has finished. -/ - | terminal : SemanticStore P → Bool → CFGConfig l P - -/-- Small-step operational semantics for deterministic basic blocks. Each case -first evaluates the commands in the block. A block ending in `.condGoto` results -in a configuration pointing to the true or false label, depending on the -evaluation of the condition. A block ending in `.finish` results in a terminal -configuration. -/ -inductive EvalDetBlock - {CmdT : Type} - (P : PureExpr) - (EvalCmd : EvalCmdParam P CmdT) - (extendEval : ExtendEval P) - [HasNot P] : - SemanticStore P → DetBlock l CmdT P → CFGConfig l P → Prop where - - | step_goto_true : - EvalCmds P EvalCmd δ σ cs σ' failed → - δ σ c = .some HasBool.tt → - WellFormedSemanticEvalBool δ → - EvalDetBlock P EvalCmd extendEval - σ ⟨ cs, .condGoto c t e _ ⟩ (.cont t σ' failed) - - | step_goto_false : - EvalCmds P EvalCmd δ σ cs σ' failed → - δ σ c = .some HasBool.ff → - WellFormedSemanticEvalBool δ → - EvalDetBlock P EvalCmd extendEval - σ ⟨ cs, .condGoto c t e _ ⟩ (.cont e σ' failed) - - | step_terminal : - EvalCmds P EvalCmd δ σ cs σ' failed → - EvalDetBlock P EvalCmd extendEval - σ ⟨ cs, .finish _ ⟩ (.terminal σ' failed) +Configuration for small-step semantics. A configuration is one of: -/-- -Small-step operational semantics for non-deterministic basic blocks. Each case -first evaluates the commands in the block. A block ending in `.goto` with no -labels results in a terminal configuration. A block ending in `.goto` with a -non-empty list of labels results in a configuration pointing to a -non-deterministic choice of one of the labels. --/ -inductive EvalNondetBlock - {CmdT : Type} - (P : PureExpr) - (EvalCmd : EvalCmdParam P CmdT) - (extendEval : ExtendEval P) - [HasNot P] : - SemanticStore P → NondetBlock l CmdT P → CFGConfig l P → Prop where - - | step_goto_none : - EvalCmds P EvalCmd δ σ cs σ' failed → - EvalNondetBlock P EvalCmd extendEval - σ ⟨ cs, .goto [] _ ⟩ (.terminal σ' failed) - - | step_goto_some : - EvalCmds P EvalCmd δ σ cs σ' failed → - lt ∈ ls → - EvalNondetBlock P EvalCmd extendEval - σ ⟨ cs, .goto ls _ ⟩ (.cont lt σ' failed) +- `.atBlock t σ f` — about to fetch the block at label `t`. +- `.inBlock t cs tr σ f` — partway through a block: `cs` are the residual + commands that still need to execute, `tr` is the block's transfer. +- `.terminal σ f` — execution has finished normally. +- `.exiting l σ f` — execution escaped via an uncaught exit to label `l`. -/-- -Monotonically update the `failure` flag in a `CFGConfig`. It will be set to -`true` if the provided Boolean is `true`. +The configuration is parameterised by the command type `CmdT` so that the +mid-block residual command list and the block's transfer have the right +type at the level of the configuration. -/ -def updateFailure : CFGConfig l P → Bool → CFGConfig l P -| .cont t σ failed, failed' => .cont t σ (failed || failed') -| .terminal σ failed, failed' => .terminal σ (failed || failed') +inductive CFGConfig (l CmdT : Type) (P : PureExpr) : Type where + /-- Fetch-and-start: about to look up label `l` in the CFG. -/ + | atBlock : l → SemanticStore P → Bool → CFGConfig l CmdT P + /-- Mid-block: residual commands `cs` and the block's transfer `tr` + survive, with the running store and failure flag. -/ + | inBlock : l → List CmdT → DetTransferCmd l P → SemanticStore P → Bool + → CFGConfig l CmdT P + /-- Halt. -/ + | terminal : SemanticStore P → Bool → CFGConfig l CmdT P + /-- Escape via an uncaught structured exit to label `l`. A top-level + outcome, like `terminal`, but tagged with the escaping label so that + the outcome kind (normal halt vs. escaping exit) is observable. -/ + | exiting : l → SemanticStore P → Bool → CFGConfig l CmdT P + +/-- Monotonically update the `failure` flag in a `CFGConfig`. It will be set +to `true` if the provided Boolean is `true`. -/ +@[expose] def updateFailure {l CmdT : Type} {P : PureExpr} : + CFGConfig l CmdT P → Bool → CFGConfig l CmdT P +| .atBlock t σ failed, failed' => .atBlock t σ (failed || failed') +| .inBlock t cs tr σ failed, failed' => .inBlock t cs tr σ (failed || failed') +| .terminal σ failed, failed' => .terminal σ (failed || failed') +| .exiting l σ failed, failed' => .exiting l σ (failed || failed') + +/-- Project the running store from a `CFGConfig`. -/ +@[expose] def CFGConfig.getStore {l CmdT : Type} {P : PureExpr} : + CFGConfig l CmdT P → SemanticStore P +| .atBlock _ σ _ => σ +| .inBlock _ _ _ σ _ => σ +| .terminal σ _ => σ +| .exiting _ σ _ => σ + +/-- Project the failure flag from a `CFGConfig`. -/ +@[expose] def CFGConfig.getFailure {l CmdT : Type} {P : PureExpr} : + CFGConfig l CmdT P → Bool +| .atBlock _ _ f => f +| .inBlock _ _ _ _ f => f +| .terminal _ f => f +| .exiting _ _ f => f /-- -Operational semantics to step between two configurations of a control-flow -graph, evaluating a single block using the provided relation. +Per-command small-step operational semantics for a deterministic CFG. + +There are five constructors: + +* `fetch`: from `.atBlock t`, look up the block at label `t` and unfold to + `.inBlock t b.cmds b.transfer`. +* `step_cmd`: from `.inBlock t (c :: cs) tr`, evaluate the head command via + `EvalCmd` and step to `.inBlock t cs tr`. +* `goto_true` / `goto_false`: from `.inBlock t [] (.condGoto c tlbl elbl _)`, + evaluate the condition and jump to `.atBlock tlbl` or `.atBlock elbl`. +* `finish`: from `.inBlock t [] (.finish _)`, halt at `.terminal`. +* `exitTo`: from `.inBlock t [] (.exitTo lbl _)`, escape at `.exiting lbl`. + +Note: the unconditional `.goto k` transfer is the special case +`condGoto HasBool.tt k k _` (definitionally equal); we therefore do not need +a separate `goto` constructor here — proofs rewrite `.goto k` as +`.condGoto HasBool.tt k k _` and use `goto_true`. -/ inductive StepCFG - {Blk l CmdT : Type} - [BEq l] - (P : PureExpr) - (EvalBlock : SemanticStore P → Blk → CFGConfig l P → Prop) : - CFG l Blk → CFGConfig l P → CFGConfig l P → Prop where - | eval_next : - List.lookup t cfg.blocks = .some b → - EvalBlock σ b config → - StepCFG P EvalBlock cfg (.cont t σ failed) (updateFailure config failed) + {l CmdT : Type} [BEq l] (P : PureExpr) + (EvalCmd : EvalCmdParam P CmdT) + (extendEval : ExtendEval P) + [HasNot P] [HasVarsPure P P.Expr] : + CFG l (DetBlock l CmdT P) → CFGConfig l CmdT P → CFGConfig l CmdT P → Prop where + /-- Fetch: turn `.atBlock t` into `.inBlock t b.cmds b.transfer`. -/ + | fetch : + List.lookup t cfg.blocks = .some b → + StepCFG P EvalCmd extendEval cfg + (.atBlock t σ f) + (.inBlock t b.cmds b.transfer σ f) + /-- Run one command from the residual list. -/ + | step_cmd : + EvalCmd δ σ c σ' f' → + StepCFG P EvalCmd extendEval cfg + (.inBlock t (c :: cs) tr σ f) + (.inBlock t cs tr σ' (f || f')) + /-- Empty residual + true branch: jump to `.atBlock` of the true label. -/ + | goto_true : + δ σ c = .some HasBool.tt → + WellFormedSemanticEvalBool δ → + WellFormedSemanticEvalExprCongr δ → + StepCFG P EvalCmd extendEval cfg + (.inBlock t [] (.condGoto c tlbl elbl md) σ f) + (.atBlock tlbl σ f) + | goto_false : + δ σ c = .some HasBool.ff → + WellFormedSemanticEvalBool δ → + WellFormedSemanticEvalExprCongr δ → + StepCFG P EvalCmd extendEval cfg + (.inBlock t [] (.condGoto c tlbl elbl md) σ f) + (.atBlock elbl σ f) + | finish : + StepCFG P EvalCmd extendEval cfg + (.inBlock t [] (.finish md) σ f) + (.terminal σ f) + /-- Empty residual + uncaught exit: escape at `.exiting lbl`. -/ + | exitTo : + StepCFG P EvalCmd extendEval cfg + (.inBlock t [] (.exitTo lbl md) σ f) + (.exiting lbl σ f) /-- -Operational semantics to evaluate an arbitrary number of blocks in a -control-flow graph in sequence. The reflexive, transitive closure of `StepCFG`. +Operational semantics to evaluate an arbitrary number of CFG steps in +sequence — the reflexive, transitive closure of `StepCFG`. -/ +@[expose] def StepCFGStar - {Blk l CmdT : Type} - [BEq l] - (P : PureExpr) - (EvalBlock : SemanticStore P → Blk → CFGConfig l P → Prop) - (cfg : CFG l Blk) : - CFGConfig l P → CFGConfig l P → Prop := - ReflTrans (@StepCFG Blk l CmdT _ P EvalBlock cfg) + {l CmdT : Type} + [BEq l] + (P : PureExpr) + (EvalCmd : EvalCmdParam P CmdT) + (extendEval : ExtendEval P) + [HasNot P] [HasVarsPure P P.Expr] + (cfg : CFG l (DetBlock l CmdT P)) : + CFGConfig l CmdT P → CFGConfig l CmdT P → Prop := + ReflTrans (StepCFG P EvalCmd extendEval cfg) + +/-! ## Stuck configurations and the deterministic transfer fragment + +The two top-level outcomes — `.terminal` (normal halt) and `.exiting` +(escaping exit) — are *stuck*: no `StepCFG` rule applies to them. This is what +lets a forward-simulation refinement know that, once a CFG run reaches one of +these halts, it stays there, so the run's *outcome kind* (normal halt vs. +escaping exit) is final and observable. + +A note on determinism. `StepCFG` is **not** a deterministic relation, even when +the abstract command evaluator `EvalCmd` is functional: the `step_cmd`, +`goto_true`, and `goto_false` rules each bind a *fresh* semantic evaluator `δ` +that the configuration does not pin down. Two derivations from the same config +can therefore use *different* evaluators (one with `δ σ c = tt`, another with +`δ' σ c = ff`) and reach genuinely different successors. Consequently a +"terminal-vs-exiting halt exclusion" stated purely over `StepCFGStar` is **not** +a theorem of these semantics — the exclusion that a dual (terminal-or-exiting) +soundness result needs comes from the *source* execution being deterministic in +its outcome kind (the structured run either terminates or exits, not both), +threaded through the forward simulation; it is not recovered at the CFG level. +The reusable, unconditionally-true facts at this level are the stuckness of the +two halt configurations, which is what follows. -/ + +section Stuck + +variable {l CmdT : Type} [BEq l] {P : PureExpr} + {EvalCmd : EvalCmdParam P CmdT} {extendEval : ExtendEval P} + [HasNot P] [HasVarsPure P P.Expr] + {cfg : CFG l (DetBlock l CmdT P)} + +/-- A `.terminal` configuration is stuck: no `StepCFG` rule applies to it. -/ +theorem StepCFG.terminal_stuck {σ : SemanticStore P} {f : Bool} + {d : CFGConfig l CmdT P} : + ¬ StepCFG P EvalCmd extendEval cfg (.terminal σ f) d := by + intro h; cases h + +/-- An `.exiting` configuration is stuck: no `StepCFG` rule applies to it. -/ +theorem StepCFG.exiting_stuck {t : l} {σ : SemanticStore P} {f : Bool} + {d : CFGConfig l CmdT P} : + ¬ StepCFG P EvalCmd extendEval cfg (.exiting t σ f) d := by + intro h; cases h + +/-- A `StepCFGStar` run that starts at a `.terminal` configuration ends at the +same `.terminal` configuration: a stuck start cannot move. -/ +theorem StepCFGStar.from_terminal {σ : SemanticStore P} {f : Bool} + {d : CFGConfig l CmdT P} + (h : StepCFGStar P EvalCmd extendEval cfg (.terminal σ f) d) : + d = .terminal σ f := by + cases h with + | refl => rfl + | step _ _ _ hstep _ => exact absurd hstep StepCFG.terminal_stuck + +/-- A `StepCFGStar` run that starts at an `.exiting` configuration ends at the +same `.exiting` configuration: a stuck start cannot move. -/ +theorem StepCFGStar.from_exiting {t : l} {σ : SemanticStore P} {f : Bool} + {d : CFGConfig l CmdT P} + (h : StepCFGStar P EvalCmd extendEval cfg (.exiting t σ f) d) : + d = .exiting t σ f := by + cases h with + | refl => rfl + | step _ _ _ hstep _ => exact absurd hstep StepCFG.exiting_stuck + +end Stuck diff --git a/Strata/DL/Imperative/CFGToCProverGOTO.lean b/Strata/DL/Imperative/CFGToCProverGOTO.lean index 4faeb5f1db..8802084da3 100644 --- a/Strata/DL/Imperative/CFGToCProverGOTO.lean +++ b/Strata/DL/Imperative/CFGToCProverGOTO.lean @@ -29,27 +29,9 @@ of any particular backend. ## Gaps relative to the direct `Stmt.toGotoInstructions` path -The following features are not yet supported via the CFG path, and would need -to be addressed before it can fully replace the direct path: - -- **Source locations on control flow**: `DetTransferCmd` already carries a - `MetaData` field, but `StructuredToUnstructured.stmtsToBlocks` currently - passes `MetaData.empty` when constructing transfer commands (the metadata - from `ite`/`loop`/`block`/`exit` statements is discarded as `_md`). - Once `stmtsToBlocks` propagates the metadata, this module will pick it up - automatically via `metadataToSourceLoc`. -- **Loop contracts**: The direct path emits `#spec_loop_invariant` and - `#spec_decreases` as named sub-expressions on the backward-edge GOTO - instruction (recognized by CBMC's DFCC). In the CFG, invariants are lowered - to plain `assert` commands and measures are discarded entirely. - To fix: `StructuredToUnstructured.stmtsToBlocks` (the `.loop` case) would - need to preserve invariants and measures in the `DetTransferCmd` (or in a - side channel), and this module would need to emit them as named - sub-expressions on the backward-edge GOTO, mirroring the logic in the - `.loop` case of `Stmt.toGotoInstructions` in `ToCProverGOTO.lean`. - **`Core.CmdExt.call`**: This translation handles `Imperative.Cmd` only. - Core procedure calls (`CmdExt.call`) would need a command translator - analogous to `coreStmtsToGoto` in `CoreToGOTOPipeline.lean`. + Core procedure calls (`CmdExt.call`) are handled by the Core-specific + wrapper `coreCFGToGotoTransform` in `CoreCFGToGOTOPipeline.lean`. -/ namespace Imperative @@ -92,49 +74,69 @@ def detCFGToGotoTransform {P} [G : ToGoto P] [BEq P.Ident] -- Pending GOTO patches: (instruction array index, target label) let mut pendingPatches : Array (Nat × String) := #[] let mut labelMap : Std.HashMap String Nat := {} + -- Loop contract metadata: maps loop entry labels to their contract metadata. + -- Used in the second pass to annotate backward-edge GOTOs. + let mut loopContracts : Std.HashMap String (MetaData P) := {} for (label, block) in cfg.blocks do -- Record this block's entry location labelMap := labelMap.insert label trans.nextLoc - -- Emit a LOCATION marker for the block - -- NOTE(source-locations): `DetTransferCmd` already carries a `MetaData` - -- field, but `StructuredToUnstructured.stmtsToBlocks` currently fills it - -- with `MetaData.empty`. Once `stmtsToBlocks` propagates the metadata - -- from `ite`/`loop`/`block`/`exit` statements, use `metadataToSourceLoc` - -- here (see `Stmt.toGotoInstructions` in ToCProverGOTO.lean for the - -- pattern). let srcLoc : SourceLocation := { SourceLocation.nil with function := functionName } trans := emitLabel label srcLoc trans -- Translate each command via the existing Cmd-to-GOTO mapping. - -- NOTE: This only handles `Imperative.Cmd`. To support `Core.CmdExt.call`, - -- either: - -- (a) generalize this function over the command type and accept a - -- command translator as a parameter, or - -- (b) create a Core-specific wrapper (like `coreStmtsToGoto` in - -- `CoreToGOTOPipeline.lean`) that pattern-matches on `CmdExt` and - -- emits `FUNCTION_CALL` instructions for `.call`, delegating `.cmd` - -- to `Cmd.toGotoInstructions`. for cmd in block.cmds do trans ← Cmd.toGotoInstructions trans.T functionName cmd trans -- Translate the transfer command match block.transfer with - | .condGoto cond lt lf _md => + | .condGoto cond lt lf md => + let transferSrcLoc := metadataToSourceLoc md functionName trans.sourceText let cond_expr ← G.toGotoExpr cond + -- Record loop contracts if present (invariants and/or decreases on this + -- transfer indicate a loop entry block). + let hasLoopContract := md.any fun elem => + elem.fld == MetaData.specLoopInvariant || elem.fld == MetaData.specDecreases + if hasLoopContract then + loopContracts := loopContracts.insert label md -- Emit: GOTO [!cond] lf - let (trans', falseIdx) := emitCondGoto (Expr.not cond_expr) srcLoc trans + let (trans', falseIdx) := emitCondGoto (Expr.not cond_expr) transferSrcLoc trans trans := trans' pendingPatches := pendingPatches.push (falseIdx, lf) -- Emit: GOTO lt (unconditional) - let (trans', trueIdx) := emitUncondGoto srcLoc trans + let (trans', trueIdx) := emitUncondGoto transferSrcLoc trans trans := trans' pendingPatches := pendingPatches.push (trueIdx, lt) | .finish _md => -- No instruction needed; the caller appends END_FUNCTION pure () - -- Second pass: resolve all pending labels, then patch in one call + | .exitTo _lbl _md => + -- An uncaught structured exit. Faithful GOTO lowering of an escaping + -- exit is deferred; for now emit no instruction (the caller appends + -- END_FUNCTION), keeping this backend total. + pure () + -- Second pass: resolve all pending labels and annotate backward-edge GOTOs + -- with loop contracts when the target is a loop entry block. let mut resolvedPatches : List (Nat × Nat) := [] for (idx, label) in pendingPatches do match labelMap[label]? with - | some targetLoc => resolvedPatches := (idx, targetLoc) :: resolvedPatches + | some targetLoc => + resolvedPatches := (idx, targetLoc) :: resolvedPatches + -- If this GOTO targets a loop entry with contracts, annotate its guard. + if let some md := loopContracts[label]? then + let instLoc := trans.instructions[idx]!.locationNum + -- Only annotate backward edges (target location <= source location). + if targetLoc ≤ instLoc then + let mut guard := trans.instructions[idx]!.guard + for elem in md do + if elem.fld == MetaData.specLoopInvariant then + if let .expr e := elem.value then + let gotoExpr ← G.toGotoExpr e + guard := guard.setNamedField "#spec_loop_invariant" gotoExpr + if elem.fld == MetaData.specDecreases then + if let .expr e := elem.value then + let gotoExpr ← G.toGotoExpr e + guard := guard.setNamedField "#spec_decreases" gotoExpr + trans := { trans with + instructions := trans.instructions.set! idx + { trans.instructions[idx]! with guard := guard } } | none => throw f!"[detCFGToGotoTransform] Unresolved label '{label}' referenced \ by GOTO at instruction index {idx}." diff --git a/Strata/DL/Imperative/Cmd.lean b/Strata/DL/Imperative/Cmd.lean index ac443016d2..c657c50d1c 100644 --- a/Strata/DL/Imperative/Cmd.lean +++ b/Strata/DL/Imperative/Cmd.lean @@ -108,7 +108,7 @@ instance : HasInit P (Cmd P) where --------------------------------------------------------------------- /-- Get all variables accessed by an `ExprOrNondet`. -/ -def ExprOrNondet.getVars [HasVarsPure P P.Expr] (e : ExprOrNondet P) : List P.Ident := +@[expose] def ExprOrNondet.getVars [HasVarsPure P P.Expr] (e : ExprOrNondet P) : List P.Ident := match e with | .det e => HasVarsPure.getVars e | .nondet => [] diff --git a/Strata/DL/Imperative/CmdSemantics.lean b/Strata/DL/Imperative/CmdSemantics.lean index 0dfd8655a0..b0e71db857 100644 --- a/Strata/DL/Imperative/CmdSemantics.lean +++ b/Strata/DL/Imperative/CmdSemantics.lean @@ -47,6 +47,36 @@ when the command signals a failure. def isNotDefined {P : PureExpr} (σ : SemanticStore P) (vs : List P.Ident) : Prop := ∀ v, v ∈ vs → σ v = none +/-- The store `σ_cfg` contains everything `σ_struct` contains, with matching +values. `σ_cfg` may have additional entries that `σ_struct` does not. + +Equivalently: for every variable defined in `σ_struct` (in the sense of +`isDefined`), `σ_cfg` assigns the same value at that variable. -/ +@[expose] def StoreAgreement {P : PureExpr} + (σ_struct σ_cfg : SemanticStore P) : Prop := + ∀ x, isDefined σ_struct [x] → σ_struct x = σ_cfg x + +theorem StoreAgreement.refl {P : PureExpr} (σ : SemanticStore P) : + StoreAgreement σ σ := + fun _ _ => rfl + +theorem StoreAgreement.trans {P : PureExpr} {σ₁ σ₂ σ₃ : SemanticStore P} + (h₁ : StoreAgreement σ₁ σ₂) (h₂ : StoreAgreement σ₂ σ₃) : + StoreAgreement σ₁ σ₃ := by + intro x h_def₁ + -- σ₁ x = σ₂ x from h₁; need σ₂ x = σ₃ x from h₂, which needs isDefined σ₂ [x]. + have h12 : σ₁ x = σ₂ x := h₁ x h_def₁ + have h_def₂ : isDefined σ₂ [x] := by + intro v hv + rw [List.mem_singleton] at hv + -- hv : v = x; rewrite goal to be about x + rw [hv] + have h := h_def₁ x (List.mem_singleton.mpr rfl) + -- h : (σ₁ x).isSome = true; rewrite via h12 + rw [← h12]; exact h + have h23 : σ₂ x = σ₃ x := h₂ x h_def₂ + exact h12.trans h23 + -- Can make this more generic by supplying a predicate function -- (SemanticStore P) → P.Ident → Bool -- determining whether each variable in the store is valid @@ -107,6 +137,11 @@ def WellFormedSemanticEvalVal {P : PureExpr} [HasVal P] @[expose] def WellFormedSemanticEvalExprCongr {P : PureExpr} [HasVarsPure P P.Expr] (δ : SemanticEval P) : Prop := ∀ e σ σ', (∀ x ∈ HasVarsPure.getVars e, σ x = σ' x) → δ σ e = δ σ' e +/-- A successful evaluation implies all the read-vars are defined. -/ +@[expose] def WellFormedSemanticEvalDef {P : PureExpr} [HasVarsPure P P.Expr] + (δ : SemanticEval P) : Prop := + ∀ e v σ, δ σ e = some v → isDefined σ (HasVarsPure.getVars e) + /-- Abstract variable update. @@ -149,13 +184,14 @@ sets it to `true`; all other constructors report `false`. The failure flag is accumulated in `Env.hasFailure` by the statement semantics (`EvalStmt`). -/ -inductive EvalCmd [HasFvar P] [HasBool P] [HasNot P] : +inductive EvalCmd [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] : SemanticEval P → SemanticStore P → Cmd P → SemanticStore P → Bool → Prop where /-- If `e` evaluates to a value `v`, initialize `x` according to `InitState`. -/ | eval_init : δ σ e = .some v → InitState P σ x v σ' → WellFormedSemanticEvalVar δ → + WellFormedSemanticEvalExprCongr δ → --- EvalCmd δ σ (.init x _ (.det e) _) σ' false @@ -171,6 +207,7 @@ inductive EvalCmd [HasFvar P] [HasBool P] [HasNot P] : δ σ e = .some v → UpdateState P σ x v σ' → WellFormedSemanticEvalVar δ → + WellFormedSemanticEvalExprCongr δ → ---- EvalCmd δ σ (.set x (.det e) _) σ' false @@ -185,6 +222,7 @@ inductive EvalCmd [HasFvar P] [HasBool P] [HasNot P] : | eval_assert_pass : δ σ e = .some HasBool.tt → WellFormedSemanticEvalBool δ → + WellFormedSemanticEvalExprCongr δ → ---- EvalCmd δ σ (.assert _ e _) σ false @@ -194,6 +232,7 @@ inductive EvalCmd [HasFvar P] [HasBool P] [HasNot P] : | eval_assert_fail : δ σ e = .some HasBool.ff → WellFormedSemanticEvalBool δ → + WellFormedSemanticEvalExprCongr δ → ---- EvalCmd δ σ (.assert _ e _) σ true @@ -201,6 +240,7 @@ inductive EvalCmd [HasFvar P] [HasBool P] [HasNot P] : | eval_assume : δ σ e = .some HasBool.tt → WellFormedSemanticEvalBool δ → + WellFormedSemanticEvalExprCongr δ → ---- EvalCmd δ σ (.assume _ e _) σ false @@ -210,6 +250,57 @@ inductive EvalCmd [HasFvar P] [HasBool P] [HasNot P] : ---- EvalCmd δ σ (.cover _ e _) σ false +--------------------------------------------------------------------- + +/-\! ### substFvar commutation (ported; used by LoopInitHoist*). -/ + +/-- A semantic evaluator commutes with single-variable renaming. + +For every expression `e`, source variable `y`, fresh target `y'`, and stores +`σ σ'` such that +* `σ` and `σ'` agree away from `y` (`∀ x ≠ y, σ x = σ' x`), and +* `σ' y'` carries `y`'s value in `σ` (`σ y = σ' y'`), + +evaluating `e` in `σ` equals evaluating the renamed expression +`substFvar e y (mkFvar y')` in `σ'`. + +This is the abstract analogue of `Lambda.LExpr.substFvarCorrect`, stated for an +arbitrary `PureExpr`. It travels as a hypothesis exactly like +`WellFormedSemanticEvalExprCongr`. -/ +@[expose] def WellFormedSemanticEvalSubstFvar {P : PureExpr} + [HasSubstFvar P] [HasFvar P] (δ : SemanticEval P) : Prop := + ∀ (e : P.Expr) (y y' : P.Ident) (σ σ' : SemanticStore P), + (∀ x, x ≠ y → σ x = σ' x) → + σ y = σ' y' → + δ σ e = δ σ' (HasSubstFvar.substFvar e y (HasFvar.mkFvar y')) + +/-- A `LawfulHasSubstFvar` instance bundles, for a `PureExpr` whose `substFvar` +descends naively under binders, the well-formedness witnesses needed by the +fresh-name hoist soundness proof: the *structural* substitution-commutation +fact for any *suitably* well-formed evaluator. + +Because the concrete commutation proof needs a structural (per-constructor) +congruence on `δ` that is **not** generically expressible at the `PureExpr` +level (it must mention `δ`'s expression constructors — quantifiers, application, +etc.), this class does not attempt to *derive* commutation from the generic +`WellFormed*` predicates (which is provably impossible — see the module note +above). Instead the soundness travels as the explicit predicate +`WellFormedSemanticEvalSubstFvar` (just like `WellFormedSemanticEvalExprCongr`), +established for the concrete evaluator by +`Strata/Transform/CallElimCorrect.lean`. -/ +class LawfulHasSubstFvar (P : PureExpr) [HasSubstFvar P] [HasFvar P] + [HasVarsPure P P.Expr] where + /-- `substFvar` of a free variable by another free variable does not change + the *read set* except by the rename: every variable read by the renamed + expression is either read by the original or is the new name `y'`. (This is + the structural fact `Lambda.LExpr` satisfies via `getVarsSubstCreateFvar`; it + is `δ`-independent and therefore *is* generically usable, e.g. to discharge + `WellFormedSemanticEvalDef` side-goals in the hoist proof.) -/ + substFvar_getVars_subset : ∀ (e : P.Expr) (y y' : P.Ident) (v : P.Ident), + v ∈ HasVarsPure.getVars (HasSubstFvar.substFvar e y (HasFvar.mkFvar y')) → + v ∈ HasVarsPure.getVars e ∨ v = y' + + end section end -- public section diff --git a/Strata/DL/Imperative/CmdSemanticsProps.lean b/Strata/DL/Imperative/CmdSemanticsProps.lean index fe4a44b222..a05f9e61dc 100644 --- a/Strata/DL/Imperative/CmdSemanticsProps.lean +++ b/Strata/DL/Imperative/CmdSemanticsProps.lean @@ -254,7 +254,7 @@ theorem InitStateUniqueResult /-! ### Assert / set commutation -/ theorem eval_assert_store_cst - [HasFvar P] [HasBool P] [HasNot P]: + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr]: EvalCmd P δ σ (.assert l e md) σ' f → σ = σ' := by intros Heval; cases Heval with | eval_assert_pass _ => rfl @@ -336,7 +336,7 @@ theorem semantic_eval_eq_of_eval_cmd_set_unrelated_var exact Hwf this theorem eval_cmd_set_comm' - [HasVarsImp P (List (Stmt P (Cmd P)))] [HasVarsImp P (Cmd P)] + [HasVarsImp P (List (Stmt P (Cmd P)))] [HasVarsImp P (Cmd P)] [HasVarsPure P P.Expr] [HasFvar P] [HasVal P] [HasBool P] [HasNot P] [DecidableEq P.Ident] : ¬ x1 = x2 → δ σ v1 = δ σ2 v1 → @@ -347,10 +347,10 @@ theorem eval_cmd_set_comm' EvalCmd P δ σ2 (Cmd.set x1 (.det v1) md1') σ'' f4 → σ' = σ'' := by intro Hneq Heq1 Heq2 Hs1 Hs2 Hs3 Hs4 - cases Hs1 with | eval_set _ Hu1 _ => - cases Hs2 with | eval_set _ Hu2 _ => - cases Hs3 with | eval_set _ Hu3 _ => - cases Hs4 with | eval_set _ Hu4 _ => + cases Hs1 with | eval_set _ Hu1 _ _ => + cases Hs2 with | eval_set _ Hu2 _ _ => + cases Hs3 with | eval_set _ Hu3 _ _ => + cases Hs4 with | eval_set _ Hu4 _ _ => simp_all exact UpdateStateComm Hneq Hu1 Hu2 Hu3 Hu4 diff --git a/Strata/DL/Imperative/HasVars.lean b/Strata/DL/Imperative/HasVars.lean index 5cc92a66c8..33593d4de5 100644 --- a/Strata/DL/Imperative/HasVars.lean +++ b/Strata/DL/Imperative/HasVars.lean @@ -48,5 +48,49 @@ class HasVarsTrans @[expose] abbrev HasVarsProcTrans (P : PureExpr) (PT : Type) := HasVarsTrans P PT PT +--------------------------------------------------------------------- + +/-! # Lawful Typeclasses + +These typeclasses bundle the algebraic laws that the various `Has*` typeclasses +on `PureExpr` are expected to satisfy with respect to free-variable computation. +They allow downstream proofs (e.g., the `stmtsToCFG` correctness proof) to +consume the laws as instance arguments rather than as explicit hypotheses. +-/ + +/-- Lawfulness of `HasFvar`: the round-trip `getFvar (mkFvar x) = some x`, + and the variable list of an `mkFvar x` expression is a subset of `[x]`. -/ +class LawfulHasFvar (P : PureExpr) [HasFvar P] [HasVarsPure P P.Expr] where + getFvar_mkFvar : ∀ x : P.Ident, + HasFvar.getFvar (HasFvar.mkFvar (P := P) x) = some x + mkFvar_getVars : ∀ x : P.Ident, + HasVarsPure.getVars (HasFvar.mkFvar (P := P) x) ⊆ [x] + +/-- Lawfulness of `HasBool`: `tt` has no free variables. -/ +class LawfulHasBool (P : PureExpr) [HasBool P] [HasVarsPure P P.Expr] where + tt_getVars : HasVarsPure.getVars (P := P) (HasBool.tt : P.Expr) = [] + +/-- Lawfulness of `HasIdent`: the canonical identifier-injection is injective. -/ +class LawfulHasIdent (P : PureExpr) [HasIdent P] where + ident_inj : Function.Injective (HasIdent.ident (P := P)) + +/-- Lawfulness of `HasIntOrder`: variable lists of compound integer-order + expressions are bounded above by their argument variable lists, and the + canonical `zero` constant has no free variables. -/ +class LawfulHasIntOrder (P : PureExpr) [HasIntOrder P] [HasVarsPure P P.Expr] where + eq_getVars : ∀ a b : P.Expr, + HasVarsPure.getVars (P := P) (HasIntOrder.eq a b) + ⊆ HasVarsPure.getVars (P := P) a ++ HasVarsPure.getVars (P := P) b + lt_getVars : ∀ a b : P.Expr, + HasVarsPure.getVars (P := P) (HasIntOrder.lt a b) + ⊆ HasVarsPure.getVars (P := P) a ++ HasVarsPure.getVars (P := P) b + zero_getVars : HasVarsPure.getVars (P := P) (HasIntOrder.zero : P.Expr) = [] + +/-- Lawfulness of `HasNot`: the variable list of a negation is bounded above + by the variable list of its argument. -/ +class LawfulHasNot (P : PureExpr) [HasNot P] [HasVarsPure P P.Expr] where + not_getVars : ∀ a : P.Expr, + HasVarsPure.getVars (P := P) (HasNot.not a) ⊆ HasVarsPure.getVars (P := P) a + end -- public section end Imperative diff --git a/Strata/DL/Imperative/KleeneSemanticsProps.lean b/Strata/DL/Imperative/KleeneSemanticsProps.lean index 11b8b1a667..f09453ec0c 100644 --- a/Strata/DL/Imperative/KleeneSemanticsProps.lean +++ b/Strata/DL/Imperative/KleeneSemanticsProps.lean @@ -19,6 +19,7 @@ namespace Imperative public section variable {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasVarsPure P P.Expr] /-! ## Env helpers -/ @@ -81,13 +82,14 @@ omit [HasVal P] [HasBoolVal P] in theorem kleene_assume_terminal {label : String} {expr : P.Expr} {md : MetaData P} {ρ₀ : Env P} (hcond : ρ₀.eval ρ₀.store expr = some HasBool.tt) - (hwfb : WellFormedSemanticEvalBool ρ₀.eval) : + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfc : WellFormedSemanticEvalExprCongr ρ₀.eval) : StepKleeneStar P (EvalCmd P) (.stmt (.cmd (.assume label expr md)) ρ₀) (.terminal ρ₀) := by have raw : StepKleeneStar P (EvalCmd P) (.stmt (.cmd (.assume label expr md)) ρ₀) (.terminal { ρ₀ with store := ρ₀.store, hasFailure := ρ₀.hasFailure || false }) := - .step _ _ _ (.step_cmd (EvalCmd.eval_assume hcond hwfb)) (.refl _) + .step _ _ _ (.step_cmd (EvalCmd.eval_assume hcond hwfb hwfc)) (.refl _) rwa [assume_env_eq] at raw end -- public section diff --git a/Strata/DL/Imperative/MetaData.lean b/Strata/DL/Imperative/MetaData.lean index 21a1db7857..d46484241d 100644 --- a/Strata/DL/Imperative/MetaData.lean +++ b/Strata/DL/Imperative/MetaData.lean @@ -330,6 +330,14 @@ def MetaData.getPropertyType {P : PureExpr} [BEq P.Ident] (md : MetaData P) : Op | _ => none | none => none +/-- Metadata field for a loop invariant expression preserved during structured-to-CFG + lowering. Multiple entries may appear when a loop has multiple invariants. -/ +def MetaData.specLoopInvariant : MetaDataElem.Field P := .label "#spec_loop_invariant" + +/-- Metadata field for a loop decreases (measure) expression preserved during + structured-to-CFG lowering. -/ +def MetaData.specDecreases : MetaDataElem.Field P := .label "#spec_decreases" + /-- Metadata field for property summaries attached to assert/requires/ensures clauses. -/ def MetaData.propertySummary : MetaDataElem.Field P := .label "propertySummary" diff --git a/Strata/DL/Imperative/Stmt.lean b/Strata/DL/Imperative/Stmt.lean index d161cb5794..8310751f6a 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` -/ @@ -159,6 +153,400 @@ end --------------------------------------------------------------------- +/-! ### UniqueInits + +Collect the names of every variable initialized by an `init` command anywhere +in a statement (across all nesting levels). The companion predicate +`Block.uniqueInits` asserts that the resulting list is `Nodup`, ruling out +the edge case where a name is projected away by `step_block_done` and then +reinitialized — a pattern the unstructured CFG cannot replicate because its +flat namespace has no projection. +-/ + +mutual +/-- Collect every variable initialized by an `init` command in a statement. -/ +@[expose] def Stmt.initVars (s : Stmt P (Cmd P)) : List P.Ident := + match s with + | .cmd (.init x _ _ _) => [x] + | .cmd _ => [] + | .block _ bss _ => Block.initVars bss + | .ite _ tss ess _ => Block.initVars tss ++ Block.initVars ess + | .loop _ _ _ bss _ => Block.initVars bss + | .exit _ _ => [] + | .funcDecl _ _ => [] + | .typeDecl _ _ => [] + termination_by (Stmt.sizeOf s) + +/-- Collect every variable initialized by an `init` command in a block. -/ +@[expose] def Block.initVars (ss : List (Stmt P (Cmd P))) : List P.Ident := + match ss with + | [] => [] + | s :: rest => Stmt.initVars s ++ Block.initVars rest + termination_by (Block.sizeOf ss) +end + +/-- Every `init` in the program (across all nesting levels) names a unique +variable. The flat-namespace CFG can simulate the structured semantics only +when this holds — without uniqueness, structured `step_block_done` can +project a name away that the structured semantics later reinitializes, a +pattern the CFG cannot replicate. -/ +@[expose] def Block.uniqueInits (ss : List (Stmt P (Cmd P))) : Prop := + (Block.initVars ss).Nodup + +--------------------------------------------------------------------- + +/-! ### SimpleShape + +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 + 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. +-/ + +mutual +/-- Returns true if the statement satisfies the simple-shape restriction. -/ +@[expose] def Stmt.simpleShape (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd _ => true + | .block _ bss _ => Block.simpleShape bss + | .ite (.det _) tss ess _ => Block.simpleShape tss && Block.simpleShape ess + | .ite .nondet _ _ _ => false + | .loop guard _ _ bss _ => + (match guard with | .det _ => true | .nondet => false) && Block.simpleShape bss + | .exit _ _ => true + | .funcDecl _ _ => true + | .typeDecl _ _ => true + termination_by (Stmt.sizeOf s) + +/-- Returns true if the block satisfies the simple-shape restriction. -/ +@[expose] def Block.simpleShape (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => true + | s :: srest => Stmt.simpleShape s && Block.simpleShape srest + termination_by (Block.sizeOf ss) +end + +/-- `Block.simpleShape` on `s :: rest` decomposes to the conjunction. -/ +theorem Block.simpleShape_cons_iff + {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} : + Block.simpleShape (s :: rest) = true ↔ + Stmt.simpleShape s = true ∧ Block.simpleShape rest = true := by + simp only [Block.simpleShape, Bool.and_eq_true] + +/-- The then-branch of an `.ite (.det _)` is simple when the whole ite is. -/ +theorem Stmt.simpleShape_branch_then + {g : P.Expr} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.simpleShape (.ite (.det g) tss ess md) = true → + Block.simpleShape tss = true := by + simp only [Stmt.simpleShape, Bool.and_eq_true] + intro h + exact h.1 + +/-- The else-branch of an `.ite (.det _)` is simple when the whole ite is. -/ +theorem Stmt.simpleShape_branch_else + {g : P.Expr} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} : + Stmt.simpleShape (.ite (.det g) tss ess md) = true → + Block.simpleShape ess = true := by + simp only [Stmt.simpleShape, Bool.and_eq_true] + intro h + exact h.2 + +/-- 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 + 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 + +--------------------------------------------------------------------- + +/-! ### 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 + +/-- 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 + +A boolean predicate asserting that a statement (or block) contains no +`.block` constructor anywhere in its tree. Used by the structured-to-CFG +correctness proof to identify subprograms whose CFG end-store is exactly +the structured end-store (no projection occurs). +-/ + +mutual +/-- Returns true if the statement contains no `.block` constructor. -/ +@[expose] def Stmt.noBlocks (s : Stmt P C) : Bool := + match s with + | .cmd _ => true + | .block _ _ _ => false + | .ite _ tss ess _ => Block.noBlocks tss && Block.noBlocks ess + | .loop _ _ _ bss _ => Block.noBlocks bss + | .exit _ _ => true + | .funcDecl _ _ => true + | .typeDecl _ _ => true + termination_by (Stmt.sizeOf s) + +/-- Returns true if the block contains no `.block` constructor. -/ +@[expose] def Block.noBlocks (ss : Block P C) : Bool := + match ss with + | [] => true + | s :: srest => Stmt.noBlocks s && Block.noBlocks srest + termination_by (Block.sizeOf ss) +end + +--------------------------------------------------------------------- + /-! ### MapExpr Apply a function to all expressions in a statement's structural positions @@ -232,12 +620,16 @@ end mutual /-- Get all variables accessed by `s`. -/ -def Stmt.getVars [HasVarsPure P P.Expr] [HasVarsPure P C] (s : Stmt P C) : List P.Ident := +@[expose] def Stmt.getVars [HasVarsPure P P.Expr] [HasVarsPure P C] (s : Stmt P C) : List P.Ident := match s with | .cmd cmd => HasVarsPure.getVars cmd | .block _ bss _ => Block.getVars bss | .ite cond tbss ebss _ => cond.getVars ++ Block.getVars tbss ++ Block.getVars ebss - | .loop guard _ _ bss _ => guard.getVars ++ Block.getVars bss + | .loop guard measure invariants bss _ => + guard.getVars ++ + (invariants.flatMap (fun p => HasVarsPure.getVars p.snd)) ++ + (match measure with | none => [] | some m => HasVarsPure.getVars m) ++ + Block.getVars bss | .exit _ _ => [] | .funcDecl decl _ => -- Get free variables from function body, excluding formal parameters @@ -249,7 +641,7 @@ def Stmt.getVars [HasVarsPure P P.Expr] [HasVarsPure P C] (s : Stmt P C) : List bodyVars.filter (fun v => formals.all (fun f => ¬(P.EqIdent v f).decide)) | .typeDecl _ _ => [] -- Type declarations don't reference variables -def Block.getVars [HasVarsPure P P.Expr] [HasVarsPure P C] (ss : Block P C) : List P.Ident := +@[expose] def Block.getVars [HasVarsPure P P.Expr] [HasVarsPure P C] (ss : Block P C) : List P.Ident := match ss with | [] => [] | s :: srest => Stmt.getVars s ++ Block.getVars srest @@ -265,7 +657,7 @@ instance (P : PureExpr) [HasVarsPure P P.Expr] [HasVarsPure P C] mutual /-- Get all variables defined by the statement `s`. -/ -def Stmt.definedVars [HasVarsImp P C] (s : Stmt P C) : List P.Ident := +@[expose] def Stmt.definedVars [HasVarsImp P C] (s : Stmt P C) : List P.Ident := match s with | .cmd cmd => HasVarsImp.definedVars cmd | .block _ bss _ => Block.definedVars bss @@ -275,7 +667,7 @@ def Stmt.definedVars [HasVarsImp P C] (s : Stmt P C) : List P.Ident := | .typeDecl _ _ => [] -- Type declarations don't define variables | _ => [] -def Block.definedVars [HasVarsImp P C] (ss : Block P C) : List P.Ident := +@[expose] def Block.definedVars [HasVarsImp P C] (ss : Block P C) : List P.Ident := match ss with | [] => [] | s :: srest => Stmt.definedVars s ++ Block.definedVars srest @@ -283,7 +675,7 @@ end mutual /-- Get all variables modified by the statement `s`. -/ -def Stmt.modifiedVars [HasVarsImp P C] (s : Stmt P C) : List P.Ident := +@[expose] def Stmt.modifiedVars [HasVarsImp P C] (s : Stmt P C) : List P.Ident := match s with | .cmd cmd => HasVarsImp.modifiedVars cmd | .exit _ _ => [] @@ -293,7 +685,7 @@ def Stmt.modifiedVars [HasVarsImp P C] (s : Stmt P C) : List P.Ident := | .funcDecl _ _ => [] -- Function declarations don't modify variables | .typeDecl _ _ => [] -- Type declarations don't modify variables -def Block.modifiedVars [HasVarsImp P C] (ss : Block P C) : List P.Ident := +@[expose] def Block.modifiedVars [HasVarsImp P C] (ss : Block P C) : List P.Ident := match ss with | [] => [] | s :: srest => Stmt.modifiedVars s ++ Block.modifiedVars srest @@ -303,13 +695,13 @@ mutual /-- Get all variables modified/defined by the statement `s`. Note that we need a separate function because order matters here for sub-blocks -/ -def Stmt.modifiedOrDefinedVars [HasVarsImp P C] (s : Stmt P C) : List P.Ident := +@[expose] def Stmt.modifiedOrDefinedVars [HasVarsImp P C] (s : Stmt P C) : List P.Ident := match s with | .block _ bss _ => Block.modifiedOrDefinedVars bss | .ite _ tbss ebss _ => Block.modifiedOrDefinedVars tbss ++ Block.modifiedOrDefinedVars ebss | _ => Stmt.definedVars s ++ Stmt.modifiedVars s -def Block.modifiedOrDefinedVars [HasVarsImp P C] (ss : Block P C) : List P.Ident := +@[expose] def Block.modifiedOrDefinedVars [HasVarsImp P C] (ss : Block P C) : List P.Ident := match ss with | [] => [] | s :: srest => Stmt.modifiedOrDefinedVars s ++ Block.modifiedOrDefinedVars srest @@ -317,11 +709,11 @@ end mutual /-- Get all variables touched (modified, defined, or read) by the statement `s`. -/ -def Stmt.touchedVars [HasVarsImp P C] [HasVarsPure P P.Expr] [HasVarsPure P C] +@[expose] def Stmt.touchedVars [HasVarsImp P C] [HasVarsPure P P.Expr] [HasVarsPure P C] (s : Stmt P C) : List P.Ident := Stmt.modifiedOrDefinedVars s ++ Stmt.getVars s -def Block.touchedVars [HasVarsImp P C] [HasVarsPure P P.Expr] [HasVarsPure P C] +@[expose] def Block.touchedVars [HasVarsImp P C] [HasVarsPure P P.Expr] [HasVarsPure P C] (ss : Block P C) : List P.Ident := Block.modifiedOrDefinedVars ss ++ Block.getVars ss end @@ -413,5 +805,402 @@ where --------------------------------------------------------------------- +--------------------------------------------------------------------- +-- Loop-init-hoisting additive helpers (ported; used by LoopInitHoist*). +--------------------------------------------------------------------- + +def Stmt.isCmd {P : PureExpr} {Cmd : Type} (s : Stmt P Cmd) : Bool := + match s with + | .cmd _ => true + | _ => false + +/-! #### Decomposition helpers for `initVars` + +`Block.initVars`/`Stmt.initVars` are fully transitive: they recurse through +`.block`/`.ite`/`.loop` bodies and enumerate EVERY `.init` declaration at +every nesting depth (see the mutual definitions above). The lemmas below are +all definitional unfoldings (`rfl`) but stated as named lemmas so proofs can +`rw` against them without unfolding the whole mutual block. -/ + +/-- Cons-decomposition of `Block.initVars`. -/ +@[simp] theorem Block.initVars_cons {P : PureExpr} + (s : Stmt P (Cmd P)) (ss : List (Stmt P (Cmd P))) : + Block.initVars (s :: ss) = + Stmt.initVars s ++ Block.initVars ss := by + simp [Block.initVars] + +/-- `Stmt.initVars` on `.loop` is its body's deep init list. -/ +@[simp] theorem Stmt.initVars_loop {P : PureExpr} + (g : ExprOrNondet P) (m : Option P.Expr) + (inv : List (String × P.Expr)) + (body : List (Stmt P (Cmd P))) (md : MetaData P) : + Stmt.initVars (.loop g m inv body md) = + Block.initVars body := by + simp [Stmt.initVars] + +/-- `Stmt.initVars` on `.block` is its body's deep init list. -/ +@[simp] theorem Stmt.initVars_block {P : PureExpr} + (lbl : String) (ss : List (Stmt P (Cmd P))) (md : MetaData P) : + Stmt.initVars (.block lbl ss md) = + Block.initVars ss := by + simp [Stmt.initVars] + +/-- `Stmt.initVars` on `.ite` is the concatenation of both branches' deep +init lists. -/ +@[simp] theorem Stmt.initVars_ite {P : PureExpr} + (c : ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) + (md : MetaData P) : + Stmt.initVars (.ite c tss ess md) = + Block.initVars tss ++ Block.initVars ess := by + simp [Stmt.initVars] + +/-\! ### NoInitsAnywhere -/ + +mutual +/-- Returns true if the statement contains no `.init` command anywhere. -/ +@[expose] def Stmt.noInitsAnywhere (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd (.init _ _ _ _) => false + | .cmd _ => true + | .block _ bss _ => Block.noInitsAnywhere bss + | .ite _ tss ess _ => Block.noInitsAnywhere tss && Block.noInitsAnywhere ess + | .loop _ _ _ bss _ => Block.noInitsAnywhere bss + | .exit _ _ => true + | .funcDecl _ _ => true + | .typeDecl _ _ => true + termination_by (Stmt.sizeOf s) + +/-- Returns true if the block contains no `.init` command anywhere. -/ +@[expose] def Block.noInitsAnywhere (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => true + | s :: srest => Stmt.noInitsAnywhere s && Block.noInitsAnywhere srest + termination_by (Block.sizeOf ss) +end + +/-! ### IsInitCmd helper -/ + +/-- Helper: a statement is `.cmd (.init ...)`. Useful for the hoisting +pass's per-statement classification (`liftInitsInLoopBody`). -/ +@[expose] def Stmt.isInitCmd (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd (.init _ _ _ _) => true + | _ => false + +/-! ### ContainsNondetLoop / ContainsFuncDecl + +Boolean predicates flagging features that the hoisting pass cannot +admit: the trace-inversion swap lemma `stmt_init_commute_terminates_det` +relies on the deterministic fragment of `StepStmt`. Programs containing +`.loop _ .nondet ...` or `.funcDecl ...` would need additional API +(`WFCongr` for nondet loops; `WellFormedExtendEval` for funcDecl) to +support the swap. We exclude them at the predicate level. + +`Strata/Transform/HoistSmokeArchive/StmtInitCommute.lean` contains the +smoke that established this scope decision. +-/ + +mutual +/-- Returns true if the statement contains a `.loop _ .nondet ...` somewhere. -/ +@[expose] def Stmt.containsNondetLoop (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd _ => false + | .block _ bss _ => Block.containsNondetLoop bss + | .ite _ tss ess _ => Block.containsNondetLoop tss || Block.containsNondetLoop ess + | .loop guard _ _ bss _ => + match guard with + | .nondet => true + | .det _ => Block.containsNondetLoop bss + | .exit _ _ => false + | .funcDecl _ _ => false + | .typeDecl _ _ => false + termination_by (Stmt.sizeOf s) + +/-- Returns true if any statement in `ss` contains a nondet loop. -/ +@[expose] def Block.containsNondetLoop (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => false + | s :: srest => + Stmt.containsNondetLoop s || Block.containsNondetLoop srest + termination_by (Block.sizeOf ss) +end + +mutual +/-- Returns true if the statement contains a `.funcDecl ...` somewhere. -/ +@[expose] def Stmt.containsFuncDecl (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd _ => false + | .block _ bss _ => Block.containsFuncDecl bss + | .ite _ tss ess _ => Block.containsFuncDecl tss || Block.containsFuncDecl ess + | .loop _ _ _ bss _ => Block.containsFuncDecl bss + | .exit _ _ => false + | .funcDecl _ _ => true + | .typeDecl _ _ => false + termination_by (Stmt.sizeOf s) + +/-- Returns true if any statement in `ss` contains a funcDecl. -/ +@[expose] def Block.containsFuncDecl (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => false + | s :: srest => + Stmt.containsFuncDecl s || Block.containsFuncDecl srest + termination_by (Block.sizeOf ss) +end + +theorem block_exitsCoveredByBlocks_append + {P : PureExpr} {CmdT : Type} + (labels : List String) (ss₁ ss₂ : List (Stmt P CmdT)) + (h₁ : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss₁) + (h₂ : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss₂) : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels (ss₁ ++ ss₂) := by + induction ss₁ with + | nil => exact h₂ + | cons s ss ih => exact ⟨h₁.1, ih h₁.2⟩ + +/-- `exitsCoveredByBlocks` is monotone in the label list: more covering labels + can only help. -/ +theorem exitsCoveredByBlocks_weaken + {P : PureExpr} {CmdT : Type} + (labels₁ labels₂ : List String) + (hsub : ∀ l, l ∈ labels₁ → l ∈ labels₂) : + (∀ (s : Stmt P CmdT), + s.exitsCoveredByBlocks labels₁ → s.exitsCoveredByBlocks labels₂) ∧ + (∀ (ss : List (Stmt P CmdT)), + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels₁ ss → + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels₂ ss) := by + suffices hstmt : ∀ (s : Stmt P CmdT), + ∀ labels₁ labels₂, (∀ l, l ∈ labels₁ → l ∈ labels₂) → + s.exitsCoveredByBlocks labels₁ → s.exitsCoveredByBlocks labels₂ by + constructor + · exact fun s => hstmt s labels₁ labels₂ hsub + · intro ss + induction ss with + | nil => intros; trivial + | cons s ss ih => + exact fun h => ⟨hstmt s _ _ hsub h.1, ih h.2⟩ + intro s + induction s using Stmt.rec (motive_2 := fun ss => + ∀ labels₁ labels₂, (∀ l, l ∈ labels₁ → l ∈ labels₂) → + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels₁ ss → + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels₂ ss) with + | cmd _ => intros; trivial + | block l ss _ ih => + intro labels₁ labels₂ hsub h + show Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks (l :: labels₂) ss + exact ih (l :: labels₁) (l :: labels₂) + (fun x hx => by cases hx with + | head => exact .head _ + | tail _ hm => exact .tail _ (hsub x hm)) + h + | ite _ tss ess _ ih_t ih_e => + intro labels₁ labels₂ hsub h + exact ⟨ih_t labels₁ labels₂ hsub h.1, ih_e labels₁ labels₂ hsub h.2⟩ + | loop _ _ _ body _ ih => + intro labels₁ labels₂ hsub h + exact ih labels₁ labels₂ hsub h + | exit l _ => + intro labels₁ labels₂ hsub h + exact hsub l h + | funcDecl _ _ => intros; trivial + | typeDecl _ _ => intros; trivial + | nil => intros; trivial + | cons s ss ih_s ih_ss => + rename_i labels₁ labels₂ hsub h + exact ⟨ih_s labels₁ labels₂ hsub h.1, ih_ss labels₁ labels₂ hsub h.2⟩ + +/-- If every statement in a list is a `.cmd`, then `exitsCoveredByBlocks` holds + for any labels (since `.cmd` has no exit statements). -/ +theorem all_cmd_exitsCoveredByBlocks + {P : PureExpr} {CmdT : Type} + (labels : List String) (ss : List (Stmt P CmdT)) + (h : ∀ s ∈ ss, ∃ c, s = Stmt.cmd c) : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss := by + induction ss with + | nil => trivial + | cons hd tl ih => + constructor + · obtain ⟨c, hc⟩ := h hd (.head _) + subst hc; exact True.intro + · exact ih (fun s hs => h s (.tail _ hs)) + +/-! ### substIdent — single-identifier renaming through statements + +`substIdent y y'` renames every occurrence of the identifier `y` to `y'` +throughout a command / statement / block. It rewrites: + +* the *value* positions (every `P.Expr` payload — `init`/`set` rhs, the + `assert`/`assume`/`cover` condition, the `ite` guard, the `loop` guard, + invariants and measure) using `HasSubstFvar.substFvar e y (HasFvar.mkFvar y')`, + which replaces the *free variable* `y` by the free variable `y'`; and +* the *binding* positions (the `init`/`set` lhs name) by the literal + rewrite `if name = y then y' else name`. + +It recurses structurally into `.block` / `.ite` / `.loop` bodies (no +alpha-renaming: the renaming descends naively under the expression-level +binders inside `substFvar`, which is sound by capture-freedom-by-construction +when `y'` is a fresh generated name — see the soundness development in +`LawfulHasSubstFvar`). + +This is the structural half of Phase 8 Option E's fresh-name hoist: the source +pass renames a hoisted init's variable `y` to a fresh `y'` and emits an outer +havoc on `y'`; `substIdent` performs that rename on the body. -/ + +variable {P : PureExpr} + +/-- Rename a single free variable inside an `ExprOrNondet`. -/ +@[expose] def ExprOrNondet.substIdent [HasSubstFvar P] [HasFvar P] + (y y' : P.Ident) (e : ExprOrNondet P) : ExprOrNondet P := + match e with + | .det e => .det (HasSubstFvar.substFvar e y (HasFvar.mkFvar y')) + | .nondet => .nondet + +/-- Rename a single identifier `y → y'` inside a command. Rewrites both the +value positions (via `substFvar`) and the binding positions (init/set lhs). -/ +@[expose] def Cmd.substIdent [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (c : Cmd P) : Cmd P := + match c with + | .init name ty e md => + .init (if name = y then y' else name) ty (e.substIdent y y') md + | .set name e md => + .set (if name = y then y' else name) (e.substIdent y y') md + | .assert label b md => + .assert label (HasSubstFvar.substFvar b y (HasFvar.mkFvar y')) md + | .assume label b md => + .assume label (HasSubstFvar.substFvar b y (HasFvar.mkFvar y')) md + | .cover label b md => + .cover label (HasSubstFvar.substFvar b y (HasFvar.mkFvar y')) md + +mutual +/-- Rename a single identifier `y → y'` throughout a statement, recursing into +sub-blocks. -/ +@[expose] def Stmt.substIdent [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (s : Stmt P (Cmd P)) : Stmt P (Cmd P) := + match s with + | .cmd c => .cmd (c.substIdent y y') + | .block label b md => .block label (Block.substIdent y y' b) md + | .ite cond thenb elseb md => + .ite (cond.substIdent y y') + (Block.substIdent y y' thenb) (Block.substIdent y y' elseb) md + | .loop guard measure invariants body md => + .loop (guard.substIdent y y') + (measure.map (fun m => HasSubstFvar.substFvar m y (HasFvar.mkFvar y'))) + (invariants.map (fun p => (p.1, HasSubstFvar.substFvar p.2 y (HasFvar.mkFvar y')))) + (Block.substIdent y y' body) md + | .exit label md => .exit label md + | .funcDecl decl md => .funcDecl decl md + | .typeDecl tc md => .typeDecl tc md + termination_by (Stmt.sizeOf s) + +/-- Rename a single identifier `y → y'` throughout a block. -/ +@[expose] def Block.substIdent [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (ss : Block P (Cmd P)) : Block P (Cmd P) := + match ss with + | [] => [] + | s :: rest => Stmt.substIdent y y' s :: Block.substIdent y y' rest + termination_by (Block.sizeOf ss) +end + +/-! #### Simp lemmas for `substIdent` + +These give `substIdent`'s definitional equations as `@[simp]` rewrites so that +proofs can unfold the structural recursion without `unfold`/`with_unfolding_all`. -/ + +@[simp] theorem ExprOrNondet.substIdent_det [HasSubstFvar P] [HasFvar P] + (y y' : P.Ident) (e : P.Expr) : + (ExprOrNondet.det e).substIdent y y' + = .det (HasSubstFvar.substFvar e y (HasFvar.mkFvar y')) := rfl + +@[simp] theorem ExprOrNondet.substIdent_nondet [HasSubstFvar P] [HasFvar P] + (y y' : P.Ident) : + (ExprOrNondet.nondet (P := P)).substIdent y y' = .nondet := rfl + +@[simp] theorem Cmd.substIdent_init [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' name : P.Ident) (ty : P.Ty) (e : ExprOrNondet P) (md : MetaData P) : + (Cmd.init name ty e md).substIdent y y' + = .init (if name = y then y' else name) ty (e.substIdent y y') md := rfl + +@[simp] theorem Cmd.substIdent_set [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' name : P.Ident) (e : ExprOrNondet P) (md : MetaData P) : + (Cmd.set name e md).substIdent y y' + = .set (if name = y then y' else name) (e.substIdent y y') md := rfl + +@[simp] theorem Cmd.substIdent_assert [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (label : String) (b : P.Expr) (md : MetaData P) : + (Cmd.assert label b md).substIdent y y' + = .assert label (HasSubstFvar.substFvar b y (HasFvar.mkFvar y')) md := rfl + +@[simp] theorem Cmd.substIdent_assume [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (label : String) (b : P.Expr) (md : MetaData P) : + (Cmd.assume label b md).substIdent y y' + = .assume label (HasSubstFvar.substFvar b y (HasFvar.mkFvar y')) md := rfl + +@[simp] theorem Cmd.substIdent_cover [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (label : String) (b : P.Expr) (md : MetaData P) : + (Cmd.cover label b md).substIdent y y' + = .cover label (HasSubstFvar.substFvar b y (HasFvar.mkFvar y')) md := rfl + +@[simp] theorem Stmt.substIdent_cmd [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (c : Cmd P) : + (Stmt.cmd c).substIdent y y' = .cmd (c.substIdent y y') := by + rw [Stmt.substIdent] + +@[simp] theorem Stmt.substIdent_block [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (label : String) (b : Block P (Cmd P)) (md : MetaData P) : + (Stmt.block label b md).substIdent y y' = .block label (Block.substIdent y y' b) md := by + rw [Stmt.substIdent] + +@[simp] theorem Stmt.substIdent_ite [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (cond : ExprOrNondet P) (thenb elseb : Block P (Cmd P)) (md : MetaData P) : + (Stmt.ite cond thenb elseb md).substIdent y y' + = .ite (cond.substIdent y y') + (Block.substIdent y y' thenb) (Block.substIdent y y' elseb) md := by + rw [Stmt.substIdent] + +@[simp] theorem Stmt.substIdent_loop [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (guard : ExprOrNondet P) (measure : Option P.Expr) + (invariants : List (String × P.Expr)) (body : Block P (Cmd P)) (md : MetaData P) : + (Stmt.loop guard measure invariants body md).substIdent y y' + = .loop (guard.substIdent y y') + (measure.map (fun m => HasSubstFvar.substFvar m y (HasFvar.mkFvar y'))) + (invariants.map (fun p => (p.1, HasSubstFvar.substFvar p.2 y (HasFvar.mkFvar y')))) + (Block.substIdent y y' body) md := by + rw [Stmt.substIdent] + +@[simp] theorem Stmt.substIdent_exit [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (label : String) (md : MetaData P) : + (Stmt.exit label md : Stmt P (Cmd P)).substIdent y y' = .exit label md := by + rw [Stmt.substIdent] + +@[simp] theorem Stmt.substIdent_funcDecl [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (decl : PureFunc P) (md : MetaData P) : + (Stmt.funcDecl decl md : Stmt P (Cmd P)).substIdent y y' = .funcDecl decl md := by + rw [Stmt.substIdent] + +@[simp] theorem Stmt.substIdent_typeDecl [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (tc : TypeConstructor) (md : MetaData P) : + (Stmt.typeDecl tc md : Stmt P (Cmd P)).substIdent y y' = .typeDecl tc md := by + rw [Stmt.substIdent] + +@[simp] theorem Block.substIdent_nil [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) : + Block.substIdent y y' ([] : Block P (Cmd P)) = [] := by + rw [Block.substIdent] + +@[simp] theorem Block.substIdent_cons [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (s : Stmt P (Cmd P)) (rest : Block P (Cmd P)) : + Block.substIdent y y' (s :: rest) + = Stmt.substIdent y y' s :: Block.substIdent y y' rest := by + rw [Block.substIdent] + +@[simp] theorem Block.substIdent_append [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (ss₁ ss₂ : Block P (Cmd P)) : + Block.substIdent y y' (ss₁ ++ ss₂) + = Block.substIdent y y' ss₁ ++ Block.substIdent y y' ss₂ := by + induction ss₁ with + | nil => simp + | cons s rest ih => simp [ih] + + + end -- public section end Imperative diff --git a/Strata/DL/Imperative/StmtSemantics.lean b/Strata/DL/Imperative/StmtSemantics.lean index fbce70464d..e1ac96e553 100644 --- a/Strata/DL/Imperative/StmtSemantics.lean +++ b/Strata/DL/Imperative/StmtSemantics.lean @@ -32,9 +32,39 @@ structure Env (P : PureExpr) where /-- Cumulative failure flag — `true` once any command has signalled failure. -/ hasFailure : Bool := false +/-- Environment-level lift of `StoreAgreement`: two environments agree when their +stores do. This is the relation an output-side simulation that tracks store +agreement (rather than store equality) would carry on environments, ignoring the +evaluator and failure flag. It inherits `StoreAgreement`'s preorder structure. -/ +@[expose] def StoreAgreementEnv {P : PureExpr} (a b : Env P) : Prop := + StoreAgreement a.store b.store + +/-- `StoreAgreementEnv` is reflexive (from `StoreAgreement.refl`). -/ +theorem StoreAgreementEnv.refl {P : PureExpr} (e : Env P) : + StoreAgreementEnv e e := + StoreAgreement.refl e.store + +/-- `StoreAgreementEnv` is transitive (from `StoreAgreement.trans`). -/ +theorem StoreAgreementEnv.trans {P : PureExpr} {a b c : Env P} + (h₁ : StoreAgreementEnv a b) (h₂ : StoreAgreementEnv b c) : + StoreAgreementEnv a c := + StoreAgreement.trans h₁ h₂ + /-- Type of a function that extends the semantic evaluator with a new function definition. -/ @[expose] abbrev ExtendEval (P : PureExpr) := SemanticEval P → SemanticStore P → PureFunc P → SemanticEval P +/-- `NoGenStore Q ρ` says the environment `ρ` leaves every `Q`-kind slot +undefined: for each string `s` satisfying the label-kind predicate `Q` (the +kind of label a pass mints), `ρ`'s store maps `HasIdent.ident s` to `none`. + +This is the store-level analogue of the syntactic `NoGenSuffix` freshness +condition: it captures the "minted names start undefined" precondition shared +by the pipeline passes, parameterised by the kind each pass mints so a single +initial store can satisfy several passes' obligations at disjoint kinds. -/ +@[expose] abbrev NoGenStore {P : PureExpr} [HasIdent P] + (Q : String → Prop) (ρ : Env P) : Prop := + ∀ s : String, Q s → ρ.store (HasIdent.ident (P := P) s) = none + /-! ## Small-Step Operational Semantics for Statements This module defines small-step operational semantics for the Imperative @@ -167,6 +197,40 @@ def Config.noFuncDecl : Config P CmdT → Prop @[expose] def projectStore (σ_parent σ_inner : SemanticStore P) : SemanticStore P := fun x => if (σ_parent x).isSome then σ_inner x else none +/-- The projected inner store agrees with the unprojected inner store on +`σ_parent`'s domain. Variables present in the parent are unchanged by +projection; variables absent from the parent become `none` in the projection, +but those don't satisfy `isDefined (projectStore _ _) [x]`, so +`StoreAgreement` doesn't constrain them. -/ +theorem StoreAgreement.of_projectStore {P : PureExpr} + (σ_parent σ_inner : SemanticStore P) : + StoreAgreement (projectStore σ_parent σ_inner) σ_inner := by + intro x h_def + -- h_def : isDefined (projectStore σ_parent σ_inner) [x] + -- Goal: projectStore σ_parent σ_inner x = σ_inner x + have h := h_def x (List.mem_singleton.mpr rfl) + unfold projectStore at h ⊢ + -- h : (if (σ_parent x).isSome then σ_inner x else none).isSome = true + -- Goal : (if (σ_parent x).isSome then σ_inner x else none) = σ_inner x + by_cases hp : (σ_parent x).isSome + · simp [hp] + · simp [hp] at h + +/-- Bundle `StoreAgreement.of_projectStore` with `.trans` and a `ρ_blk` rewrite, +the four-line idiom that recurs after every `.block`-step in the simulation +proofs. Given a record-update equality showing the outer env's store is the +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} + {σ_cfg : SemanticStore P} + (h_ρ_blk_eq : ρ_blk = { ρ_inner with store := projectStore σ_parent ρ_inner.store }) + (h_agree_body : StoreAgreement ρ_inner.store σ_cfg) : + StoreAgreement ρ_blk.store σ_cfg := by + rw [h_ρ_blk_eq] + exact StoreAgreement.trans (StoreAgreement.of_projectStore _ _) h_agree_body + /-! ## Single-step relation -/ section diff --git a/Strata/DL/Imperative/StmtSemanticsProps.lean b/Strata/DL/Imperative/StmtSemanticsProps.lean index 4cf034463a..7d5433341a 100644 --- a/Strata/DL/Imperative/StmtSemanticsProps.lean +++ b/Strata/DL/Imperative/StmtSemanticsProps.lean @@ -11,6 +11,7 @@ public import Strata.DL.Imperative.CmdSemanticsProps import all Strata.DL.Imperative.CmdSemanticsProps import all Strata.DL.Imperative.Cmd public import Strata.DL.Util.Relations +import all Strata.DL.Util.Relations --------------------------------------------------------------------- @@ -203,6 +204,55 @@ theorem block_reaches_terminal | step_block_exit_mismatch => subst htgt; cases hrest with | step _ _ _ h _ => cases h +/-- Stronger inversion of `.block (.some label) σ_parent inner → .terminal`: + when the block has an explicit label, the second disjunct (exit-match) + constrains the inner exit-label to equal the block's label. This is + needed for downstream simulation lemmas that look up the exit's + continuation in `exitConts` keyed by the matching label. -/ +theorem block_some_reaches_terminal + {inner : Config P CmdT} {label : String} {σ_parent : SemanticStore P} {ρ' : Env P} + (hstar : StepStmtStar P EvalCmd extendEval + (.block (.some label) σ_parent inner) (.terminal ρ')) : + (∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.terminal ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store }) ∨ + (∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting label ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store }) := by + -- Same structure as block_reaches_terminal, but specialized to .some label. + -- At step_block_exit_match, the rule's `l` is unified with `label` (because + -- the rule premise `.some label = .some l` forces this). + suffices ∀ src tgt, StepStmtStar P EvalCmd extendEval src tgt → + ∀ inner ρ', src = .block (.some label) σ_parent inner → tgt = .terminal ρ' → + (∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.terminal ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store }) ∨ + (∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting label ρ_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 ρ' hsrc htgt; subst hsrc + cases hstep with + | step_block_body h => + match ih _ _ rfl htgt with + | .inl ⟨ρ_inner, hterm, heq⟩ => exact .inl ⟨ρ_inner, .step _ _ _ h hterm, heq⟩ + | .inr ⟨ρ_inner, hexit, heq⟩ => exact .inr ⟨ρ_inner, .step _ _ _ h hexit, heq⟩ + | step_block_done => + subst htgt; cases hrest with + | refl => exact .inl ⟨_, .refl _, rfl⟩ + | step _ _ _ h _ => cases h + | step_block_exit_match heq => + -- heq : .some label = .some l (where l is implicit and must equal label) + -- The constructor's premise unifies l with label via injection on heq. + -- After unification, the inner config is .exiting label _. + injection heq with h_eq + subst h_eq + subst htgt; cases hrest with + | refl => exact .inr ⟨_, .refl _, rfl⟩ + | step _ _ _ h _ => cases h + | step_block_exit_mismatch => + subst htgt; cases hrest with | step _ _ _ h _ => cases h + /-- Invert a block execution reaching exiting: the inner must have exited with a label that didn't match the block. The env is projected. -/ theorem block_reaches_exiting @@ -231,6 +281,39 @@ theorem block_reaches_exiting | step_block_done | step_block_exit_match => subst htgt; cases hrest with | step _ _ _ h _ => cases h +/-- Strengthened block-exit inversion: a `.block l σ_parent inner` reaching +`.exiting lbl ρ'` must have had its inner body exit with the *same* label `lbl` +(the mismatch rule propagates the label unchanged), and that label does *not* +match the block's own label `l` (otherwise it would have been caught, +terminating the block). The env is projected through the parent store. -/ +theorem block_reaches_exiting_strong + {inner : Config P CmdT} {l : Option String} {σ_parent : SemanticStore P} {lbl : String} {ρ' : Env P} + (hstar : StepStmtStar P EvalCmd extendEval (.block l σ_parent inner) (.exiting lbl ρ')) : + ∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ_inner) ∧ + l ≠ .some lbl ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } := by + suffices ∀ src tgt, StepStmtStar P EvalCmd extendEval src tgt → + ∀ inner lbl ρ', src = .block l σ_parent inner → tgt = .exiting lbl ρ' → + ∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ_inner) ∧ + l ≠ .some lbl ∧ + ρ' = { ρ_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 => + obtain ⟨ρ_inner, hexit, hne, heq⟩ := ih _ _ _ rfl htgt + exact ⟨ρ_inner, .step _ _ _ h hexit, hne, heq⟩ + | step_block_exit_mismatch hne => + subst htgt; cases hrest with + | refl => exact ⟨_, .refl _, hne, rfl⟩ + | step _ _ _ h _ => cases h + | step_block_done | step_block_exit_match => + subst htgt; cases hrest with | step _ _ _ h _ => cases h + /-! ## Trace construction helpers -/ /-- Entering a block: a single step from `.stmt (.block l body md) ρ` @@ -262,6 +345,39 @@ theorem stmts_prefix_terminal_append exact ReflTrans_Transitive _ _ _ _ (stmts_cons_step P EvalCmd extendEval s (rest ++ sfx) ρ ρ₁ h_s) (ih ρ₁ h_r) +/-- If a prefix of a statement list exits, the full list exits at the + same label/env (the suffix is never reached). -/ +theorem stmts_prefix_exiting_append + (pfx sfx : List (Stmt P CmdT)) (ρ ρ' : Env P) (lbl : String) + (h : StepStmtStar P EvalCmd extendEval (.stmts pfx ρ) (.exiting lbl ρ')) : + StepStmtStar P EvalCmd extendEval (.stmts (pfx ++ sfx) ρ) (.exiting lbl ρ') := by + induction pfx generalizing ρ with + | nil => + -- `.stmts [] ρ` can only step to `.terminal ρ`, never to `.exiting`. + exfalso + cases h with + | step _ _ _ h_step h_rest => cases h_step with + | step_stmts_nil => cases h_rest with + | step _ _ _ h_bad _ => cases h_bad + | cons s rest ih => + cases h with + | step _ _ _ h_step h_rest => cases h_step with + | step_stmts_cons => + match seq_reaches_exiting P EvalCmd extendEval h_rest with + | .inl h_inner_exit => + -- Head `.stmt s ρ ⟶* .exiting lbl ρ'`; lift to `.stmts (s :: (rest ++ sfx)) ρ`. + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + have h_seq := seq_inner_star (P := P) EvalCmd extendEval _ _ + (rest ++ sfx) h_inner_exit + exact ReflTrans_Transitive _ _ _ _ h_seq + (.step _ _ _ StepStmt.step_seq_exit (.refl _)) + | .inr ⟨ρ_mid, h_s_term, h_rest_exit⟩ => + -- Head terminates; recurse on rest. + refine ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P EvalCmd extendEval s (rest ++ sfx) ρ ρ_mid h_s_term) + ?_ + exact ih ρ_mid h_rest_exit + /-- Decompose a terminating execution of `ss₁ ++ ss₂` into a terminating execution of `ss₁` followed by a terminating execution of `ss₂`. -/ theorem stmts_append_terminates @@ -713,6 +829,44 @@ theorem block_noFuncDecl_preserves_eval ρ'.eval = ρ.eval := smallStep_noFuncDecl_preserves_eval_block P EvalCmd extendEval ss ρ ρ' hnofd hterm +/-- When a block has no function declarations, small-step execution + preserves the evaluator (variant for `.exiting` target). -/ +theorem smallStep_noFuncDecl_preserves_eval_block_exiting + (bss : List (Stmt P CmdT)) (ρ ρ' : Env P) (lbl : String) + (hnofd : Block.noFuncDecl bss = true) + (hstar : StepStmtStar P EvalCmd extendEval (.stmts bss ρ) (.exiting lbl ρ')) : + ρ'.eval = ρ.eval := by + suffices ∀ c₁ c₂, + Config.noFuncDecl c₁ → + StepStmtStar P EvalCmd extendEval c₁ c₂ → + c₂.getEnv.eval = c₁.getEnv.eval by + exact this _ _ (show Config.noFuncDecl (.stmts bss ρ) from hnofd) hstar + intro c₁ c₂ hnofd_c hstar_c + induction hstar_c with + | refl => rfl + | step _ mid _ hstep _ ih => + have ⟨heq, hnofd_mid⟩ := step_preserves_eval_noFuncDecl P EvalCmd extendEval _ _ hstep hnofd_c + rw [ih hnofd_mid, heq] + +/-- When a statement has no function declarations, small-step execution + preserves the evaluator (variant for `.exiting` target). -/ +theorem smallStep_noFuncDecl_preserves_eval_exiting + (s : Stmt P CmdT) (ρ ρ' : Env P) (lbl : String) + (hnofd : Stmt.noFuncDecl s = true) + (hstar : StepStmtStar P EvalCmd extendEval (.stmt s ρ) (.exiting lbl ρ')) : + ρ'.eval = ρ.eval := by + suffices ∀ c₁ c₂, + Config.noFuncDecl c₁ → + StepStmtStar P EvalCmd extendEval c₁ c₂ → + c₂.getEnv.eval = c₁.getEnv.eval by + exact this _ _ (show Config.noFuncDecl (.stmt s ρ) from hnofd) hstar + intro c₁ c₂ hnofd_c hstar_c + induction hstar_c with + | refl => rfl + | step _ mid _ hstep _ ih => + have ⟨heq, hnofd_mid⟩ := step_preserves_eval_noFuncDecl P EvalCmd extendEval _ _ hstep hnofd_c + rw [ih hnofd_mid, heq] + /-! ### hasFailure monotonicity and irrelevance `hasFailure` is never consulted by any `StepStmt` premise, @@ -789,6 +943,274 @@ theorem StepStmtStar_hasFailure_monotone | refl => exact hf | step _ _ _ hstep _ ih => exact ih (step_hasFailure_monotone P EvalCmd extendEval hstep hf) +/-! ### Failing-config source-semantics decomposition helpers + +These are the `_to_fail` siblings of the terminal/exiting `ReflTransT` +decomposition helpers. They peel a multi-step run that reaches a *failing* +configuration (`getEnv.hasFailure = true`) — possibly an intermediate one on a +run that never terminates — into the constituent piece that already fails, +exposing a length bound where the recursion needs one. Because failure is +monotone (`StepStmtStar_hasFailure_monotone`: `updateFailure` only OR-s the flag +in), a failing config is always reached in finitely many steps, so these split +along the same constructor structure as the terminal helpers. + +They are pure source-semantics facts (`StepStmt`/`ReflTransT`/`Config.getEnv`, +independent of any program transform), so every structured pass that needs to +transport a failing configuration reuses them. -/ + +/-- A `ReflTransT` run starting at a stuck `.terminal ρ` stays at `.terminal ρ`. -/ +theorem reflTransT_from_terminal {ρ : Env P} {c : Config P CmdT} + (h : ReflTransT (StepStmt P EvalCmd extendEval) (.terminal ρ) c) : c = .terminal ρ := by + match h with + | .refl _ => rfl + | .step _ _ _ hstep _ => exact nomatch hstep + +/-- A `ReflTransT` run starting at a stuck `.exiting l ρ` stays at `.exiting l ρ`. -/ +theorem reflTransT_from_exiting {l : String} {ρ : Env P} {c : Config P CmdT} + (h : ReflTransT (StepStmt P EvalCmd extendEval) (.exiting l ρ) c) : c = .exiting l ρ := by + match h with + | .refl _ => rfl + | .step _ _ _ hstep _ => exact nomatch hstep + +/-- Failing-config inversion for a `.seq inner ss` frame. Either the failure is +inside `inner` (it reaches a failing config), or `inner` terminates at `ρ₁` and the +continuation `.stmts ss ρ₁` reaches a failing config — with strictly decreasing +derivation length in the second case (the seq prefix is consumed). -/ +theorem seqT_reaches_failing' + {inner : Config P CmdT} {ss : List (Stmt P CmdT)} {c : Config P CmdT} + (hstar : ReflTransT (StepStmt P EvalCmd extendEval) (.seq inner ss) c) + (hc : c.getEnv.hasFailure = true) : + (∃ d, ∃ (h : ReflTransT (StepStmt P EvalCmd extendEval) inner d), + d.getEnv.hasFailure = true ∧ h.len ≤ hstar.len) ∨ + (∃ (ρ₁ : Env P), ∃ d, + ∃ (h1 : ReflTransT (StepStmt P EvalCmd extendEval) inner (.terminal ρ₁)), + ∃ (h2 : ReflTransT (StepStmt P EvalCmd extendEval) (.stmts ss ρ₁) d), + d.getEnv.hasFailure = true ∧ h1.len + h2.len < hstar.len) := by + suffices H : ∀ n (inn : Config P CmdT) + (h : ReflTransT (StepStmt P EvalCmd extendEval) (.seq inn ss) c), + h.len ≤ n → c.getEnv.hasFailure = true → + (∃ d, ∃ (h' : ReflTransT (StepStmt P EvalCmd extendEval) inn d), + d.getEnv.hasFailure = true ∧ h'.len ≤ h.len) ∨ + (∃ (ρ₁ : Env P), ∃ d, + ∃ (h1 : ReflTransT (StepStmt P EvalCmd extendEval) inn (.terminal ρ₁)), + ∃ (h2 : ReflTransT (StepStmt P EvalCmd extendEval) (.stmts ss ρ₁) d), + d.getEnv.hasFailure = true ∧ h1.len + h2.len < h.len) by + exact H hstar.len inner hstar (Nat.le_refl _) hc + intro n + induction n with + | zero => + intro inn h hlen hc' + match h, hlen with + | .refl _, _ => left; exact ⟨inn, .refl _, hc', by simp [ReflTransT.len]⟩ + | .step _ _ _ _ _, hl => simp [ReflTransT.len] at hl + | succ n ih => + intro inn h hlen hc' + match h, hlen with + | .refl _, _ => left; exact ⟨inn, .refl _, hc', by simp [ReflTransT.len]⟩ + | .step _ (.seq inner₁ _) _ (.step_seq_inner h_inner_step) hrest, hl => + have hlen' : hrest.len ≤ n := by simp [ReflTransT.len] at hl; omega + rcases ih inner₁ hrest hlen' hc' with hA | hB + · obtain ⟨d, h', hd, hlen''⟩ := hA + exact .inl ⟨d, .step _ _ _ h_inner_step h', hd, by simp [ReflTransT.len]; omega⟩ + · obtain ⟨ρ₁, d, h1, h2, hd, hlen''⟩ := hB + exact .inr ⟨ρ₁, d, .step _ _ _ h_inner_step h1, h2, hd, by simp [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_seq_done hrest, hl => + rename_i ρ' + exact .inr ⟨ρ', _, .refl _, hrest, hc', by simp [ReflTransT.len]⟩ + | .step _ _ _ .step_seq_exit hrest, hl => + rename_i label ρ' + left + refine ⟨.exiting label ρ', .refl _, ?_, by simp [ReflTransT.len]⟩ + match hrest with + | .refl _ => exact hc' + | .step _ _ _ h' _ => exact nomatch h' + +/-- Failing-config inversion for a `.block .none σ_parent inner` frame: the failure +is inside the block body (`inner` reaches a failing config), with derivation length +bounded by the original. The block-done / exit-propagation cases reduce to the inner +body's already-reached failing endpoint. -/ +theorem blockT_none_reaches_failing' + {inner : Config P CmdT} {σ_parent : SemanticStore P} {c : Config P CmdT} + (hstar : ReflTransT (StepStmt P EvalCmd extendEval) (.block .none σ_parent inner) c) + (hc : c.getEnv.hasFailure = true) : + ∃ d, ∃ (h : ReflTransT (StepStmt P EvalCmd extendEval) inner d), + d.getEnv.hasFailure = true ∧ h.len ≤ hstar.len := by + suffices H : ∀ n (σ_p : SemanticStore P) (inn : Config P CmdT) + (h : ReflTransT (StepStmt P EvalCmd extendEval) (.block .none σ_p inn) c), + h.len ≤ n → c.getEnv.hasFailure = true → + ∃ d, ∃ (h' : ReflTransT (StepStmt P EvalCmd extendEval) inn d), + d.getEnv.hasFailure = true ∧ h'.len ≤ h.len by + exact H hstar.len σ_parent inner hstar (Nat.le_refl _) hc + intro n + induction n with + | zero => + intro σ_p inn h hlen hc' + match h, hlen with + | .refl _, _ => exact ⟨inn, .refl _, hc', by simp [ReflTransT.len]⟩ + | .step _ _ _ _ _, hl => simp [ReflTransT.len] at hl + | succ n ih => + intro σ_p inn h hlen hc' + match h, hlen with + | .refl _, _ => exact ⟨inn, .refl _, hc', by simp [ReflTransT.len]⟩ + | .step _ (.block _ _ inner₁) _ (.step_block_body h_inner_step) hrest, hl => + have hlen' : hrest.len ≤ n := by simp [ReflTransT.len] at hl; omega + have ⟨d, h', hd, hlen''⟩ := ih σ_p inner₁ hrest hlen' hc' + exact ⟨d, .step _ _ _ h_inner_step h', hd, by simp [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_block_done hrest, hl => + have hz := reflTransT_from_terminal P EvalCmd extendEval hrest + refine ⟨_, .refl _, ?_, by simp [ReflTransT.len]⟩ + rw [hz] at hc' + simpa [Config.getEnv] using hc' + | .step _ _ _ (.step_block_exit_match heq) hrest, hl => exact (nomatch heq) + | .step _ _ _ (.step_block_exit_mismatch hne) hrest, hl => + have hz := reflTransT_from_exiting P EvalCmd extendEval hrest + refine ⟨_, .refl _, ?_, by simp [ReflTransT.len]⟩ + rw [hz] at hc' + simpa [Config.getEnv] using hc' + +/-- Failing-config inversion for a general `.block l σ_parent inner` frame (any +label, `.none` or `.some`): the failure is inside the block body, so `inner` +reaches a failing config. The block-done / exit-match cases reduce to the inner +body's already-reached failing endpoint (a matched exit terminates the block at a +projected env whose failure flag is the inner exiting env's); the exit-mismatch +case propagates the inner exiting env unchanged. Prop-level (no length bound) +since the `.block` arm only needs the recursive body's failing reach, not a +decreasing measure. -/ +theorem block_reaches_failing' + {l : Option String} {inner : Config P CmdT} {σ_parent : SemanticStore P} + {c : Config P CmdT} + (hstar : StepStmtStar P EvalCmd extendEval (.block l σ_parent inner) c) + (hc : c.getEnv.hasFailure = true) : + ∃ d, StepStmtStar P EvalCmd extendEval inner d ∧ d.getEnv.hasFailure = true := by + suffices H : ∀ src tgt, StepStmtStar P EvalCmd extendEval src tgt → + ∀ (lp : Option String) (σ_p : SemanticStore P) (inn : Config P CmdT), + src = .block lp σ_p inn → tgt.getEnv.hasFailure = true → + ∃ d, StepStmtStar P EvalCmd extendEval inn d ∧ d.getEnv.hasFailure = true by + exact H _ _ hstar l σ_parent inner rfl hc + intro src tgt hstar_g + induction hstar_g with + | refl => + intro lp σ_p inn hsrc hc' + subst hsrc + exact ⟨inn, .refl _, by simpa [Config.getEnv] using hc'⟩ + | step _ mid _ hstep hrest ih => + intro lp σ_p inn hsrc hc' + subst hsrc + cases hstep with + | step_block_body h_inner_step => + rename_i inner₁ + have ⟨d, h', hd⟩ := ih _ _ _ rfl hc' + exact ⟨d, .step _ _ _ h_inner_step h', hd⟩ + | step_block_done => + have hz := reflTransT_from_terminal P EvalCmd extendEval (reflTrans_to_T hrest) + rw [hz] at hc' + exact ⟨_, .refl _, by simpa [Config.getEnv] using hc'⟩ + | step_block_exit_match heq => + have hz := reflTransT_from_terminal P EvalCmd extendEval (reflTrans_to_T hrest) + rw [hz] at hc' + exact ⟨_, .refl _, by simpa [Config.getEnv] using hc'⟩ + | step_block_exit_mismatch hne => + have hz := reflTransT_from_exiting P EvalCmd extendEval (reflTrans_to_T hrest) + rw [hz] at hc' + exact ⟨_, .refl _, by simpa [Config.getEnv] using hc'⟩ + +/-- Singleton-list peel for the failing case: from `.stmts [s] ρ₀ ⟶* c` (failing), +recover `.stmt s ρ₀ ⟶* d` reaching a failing config of no-greater length. Used to +recurse one loop iteration on the residual `[.loop ...]` singleton. -/ +theorem stmts_singleton_reaches_failing' + {s : Stmt P CmdT} {ρ₀ : Env P} {c : Config P CmdT} + (hstar : ReflTransT (StepStmt P EvalCmd extendEval) (.stmts [s] ρ₀) c) + (hc : c.getEnv.hasFailure = true) : + ∃ d, ∃ (h : ReflTransT (StepStmt P EvalCmd extendEval) (.stmt s ρ₀) d), + d.getEnv.hasFailure = true ∧ h.len ≤ hstar.len := by + match hstar with + | .refl _ => + exact ⟨.stmt s ρ₀, .refl _, hc, by simp [ReflTransT.len]⟩ + | .step _ _ _ .step_stmts_cons hrest => + rcases seqT_reaches_failing' P EvalCmd extendEval hrest hc with hA | hB + · obtain ⟨d, h, hd, hlen⟩ := hA + exact ⟨d, h, hd, by simp [ReflTransT.len]; omega⟩ + · obtain ⟨ρ₁, d, h1, h2, hd, hlen⟩ := hB + refine ⟨.terminal ρ₁, h1, ?_, by simp [ReflTransT.len]; omega⟩ + have hρ₁ : ρ₁.hasFailure = true := by + have : d.getEnv = ρ₁ := by + match h2 with + | .refl _ => rfl + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h' _ => exact nomatch h' + rw [this] at hd + exact hd + simpa [Config.getEnv] using hρ₁ + +/-- Cons-list peel for the failing case: from `.stmts (s :: rest) ρ₀ ⟶* c` (failing), +either the head statement `.stmt s ρ₀` already reaches a failing config, or it +terminates at `ρ₁` and `.stmts rest ρ₁` reaches a failing config. This is the +generic decomposition shared by every cons-arm of a structured `_to_fail` +simulation: the head's failing-reach routes into the head-specific discharge, the +terminate-then-rest case recurses on `rest`. -/ +theorem stmts_cons_reaches_failing' + {s : Stmt P CmdT} {rest : List (Stmt P CmdT)} {ρ₀ : Env P} {c : Config P CmdT} + (hstar : ReflTransT (StepStmt P EvalCmd extendEval) (.stmts (s :: rest) ρ₀) c) + (hc : c.getEnv.hasFailure = true) : + (∃ d, StepStmtStar P EvalCmd extendEval (.stmt s ρ₀) d ∧ + d.getEnv.hasFailure = true) ∨ + (∃ (ρ₁ : Env P), ∃ d, + StepStmtStar P EvalCmd extendEval (.stmt s ρ₀) (.terminal ρ₁) ∧ + StepStmtStar P EvalCmd extendEval (.stmts rest ρ₁) d ∧ + d.getEnv.hasFailure = true) := by + match hstar with + | .refl _ => + exact .inl ⟨.stmt s ρ₀, .refl _, by simpa [Config.getEnv] using hc⟩ + | .step _ _ _ .step_stmts_cons hrest => + rcases seqT_reaches_failing' P EvalCmd extendEval hrest hc with hA | hB + · obtain ⟨d, h, hd, _⟩ := hA + exact .inl ⟨d, reflTransT_to_prop h, hd⟩ + · obtain ⟨ρ₁, d, h1, h2, hd, _⟩ := hB + exact .inr ⟨ρ₁, d, reflTransT_to_prop h1, reflTransT_to_prop h2, hd⟩ + +/-- If a prefix of a statement list reaches a *failing* configuration, the full + list reaches a failing configuration (the failure cannot be undone, so the + suffix never clears it — and if the prefix terminates first, the suffix + inherits the prefix's set flag). This is the failing-config analogue of + `stmts_prefix_terminal_append` / `stmts_prefix_exiting_append`, used to lift a + failing rewritten loop body into `body ++ [havoc]`. -/ +theorem stmts_prefix_failing_append + (pfx sfx : List (Stmt P CmdT)) (ρ : Env P) (c : Config P CmdT) + (h : StepStmtStar P EvalCmd extendEval (.stmts pfx ρ) c) + (hc : c.getEnv.hasFailure = true) : + ∃ c', StepStmtStar P EvalCmd extendEval (.stmts (pfx ++ sfx) ρ) c' + ∧ c'.getEnv.hasFailure = true := by + induction pfx generalizing ρ c with + | nil => + -- `.stmts [] ρ` reaches only `.terminal ρ`; failing forces `ρ.hasFailure = true`. + have h_c_env : c.getEnv = ρ := by + cases h with + | refl => rfl + | step _ _ _ h_step h_rest => + cases h_step with + | step_stmts_nil => + have := reflTransT_from_terminal P EvalCmd extendEval (reflTrans_to_T h_rest) + rw [this]; rfl + have hρ : ρ.hasFailure = true := by rw [h_c_env] at hc; simpa [Config.getEnv] using hc + -- The empty suffix-prepended list `.stmts ([] ++ sfx) ρ = .stmts sfx ρ` starts at ρ failing. + refine ⟨Config.stmts sfx ρ, ?_, by simpa [Config.getEnv] using hρ⟩ + simpa using ReflTrans.refl (Config.stmts ([] ++ sfx) ρ) + | cons s rest ih => + rcases stmts_cons_reaches_failing' P EvalCmd extendEval (reflTrans_to_T h) hc with + ⟨d, h_head, hd⟩ | ⟨ρ₁, d, h_head_term, h_rest_run, hd⟩ + · -- Head already fails: lift the head's failing run into `.stmts (s :: (rest ++ sfx))`, + -- wrapping the residual as `.seq d _` to keep its failure flag. + refine ⟨.seq d (rest ++ sfx), + .step _ _ _ StepStmt.step_stmts_cons + (seq_inner_star P EvalCmd extendEval _ _ _ h_head), ?_⟩ + simpa [Config.getEnv] using hd + · -- Head terminates at ρ₁; recurse on `rest` from ρ₁. + obtain ⟨c', h_rest_full, hc'⟩ := ih ρ₁ d h_rest_run hd + exact ⟨c', ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P EvalCmd extendEval s (rest ++ sfx) ρ ρ₁ h_head_term) h_rest_full, hc'⟩ + theorem EvalStmtSmall_hasFailure_irrel {ρ ρ' : Env P} {s : Stmt P CmdT} : EvalStmtSmall P EvalCmd extendEval ρ s ρ' → @@ -824,10 +1246,10 @@ end -- section section -variable (P : PureExpr) [HasFvar P] [HasBool P] [HasNot P] +variable (P : PureExpr) [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] variable (extendEval : ExtendEval P) -omit [HasFvar P] [HasBool P] [HasNot P] in +omit [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] in /-- If a config has no matching assert, then `isAtAssert` doesn't match. -/ private theorem noMatchingAssert_not_isAtAssert (cfg : Config P (Cmd P)) (label : String) (expr : P.Expr) @@ -939,7 +1361,7 @@ theorem noMatchingAssert_implies_no_reachable_assert induction hstar_c with | refl => exact hno_c | step _ _ _ hstep _ ih => - exact ih (@step_preserves_noMatchingAssert P _ _ _ extendEval _ _ _ hstep hno_c) + exact ih (@step_preserves_noMatchingAssert P _ _ _ _ extendEval _ _ _ hstep hno_c) /-! ## isAtAssert inversion lemmas -/ @@ -1160,7 +1582,7 @@ theorem allAssertsValid_preserves_noFailure (isAtAssert P) (fun hcmd => by cases hcmd with - | eval_assert_fail hff _ => exact ⟨⟨_, _⟩, ⟨rfl, rfl⟩, hff⟩) + | eval_assert_fail hff _ _ => exact ⟨⟨_, _⟩, ⟨rfl, rfl⟩, hff⟩) (fun hmem => hmem) (fun h => h) (fun h => h) @@ -1172,7 +1594,7 @@ section AssertSetProps /-! ### Assert command properties (statement-level) -/ -variable {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] +variable {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] variable {extendEval : ExtendEval P} theorem eval_stmt_assert_store_cst : @@ -1225,10 +1647,10 @@ theorem eval_stmt_assert_eq_of_pure_expr_eq : cases hrest with | refl => cases hcmd with - | eval_assert_pass htt _ => - exact .step _ _ _ (.step_cmd (EvalCmd.eval_assert_pass htt Hwf)) (.refl _) - | eval_assert_fail hne _ => - exact .step _ _ _ (.step_cmd (EvalCmd.eval_assert_fail hne Hwf)) (.refl _) + | eval_assert_pass htt _ hcongr => + exact .step _ _ _ (.step_cmd (EvalCmd.eval_assert_pass htt Hwf hcongr)) (.refl _) + | eval_assert_fail hne _ hcongr => + exact .step _ _ _ (.step_cmd (EvalCmd.eval_assert_fail hne Hwf hcongr)) (.refl _) | step _ _ _ hstep _ => exact absurd hstep (by intro h; cases h) ) @@ -1289,27 +1711,27 @@ theorem assert_elim : match htail2 with | .step _ _ _ .step_stmts_nil (.refl _) => cases hcmd1 with - | eval_assert_pass h1 _ => + | eval_assert_pass h1 _ hcongr => cases hcmd2 with - | eval_assert_pass _ _ => + | eval_assert_pass _ _ _ => apply ReflTrans.step _ _ _ .step_stmts_cons - apply ReflTrans.step _ _ _ (.step_seq_inner (.step_cmd (EvalCmd.eval_assert_pass h1 Hwf))) + apply ReflTrans.step _ _ _ (.step_seq_inner (.step_cmd (EvalCmd.eval_assert_pass h1 Hwf hcongr))) apply ReflTrans.step _ _ _ .step_seq_done apply ReflTrans.step _ _ _ .step_stmts_nil simp_all [Bool.or_false]; exact .refl _ - | eval_assert_fail h2 _ => + | eval_assert_fail h2 _ _ => simp at h2 exact absurd (h1.symm.trans h2) (by exact fun h => HasBool.tt_is_not_ff (Option.some.inj h)) - | eval_assert_fail h1 _ => + | eval_assert_fail h1 _ hcongr => cases hcmd2 with - | eval_assert_pass h2 _ => + | eval_assert_pass h2 _ _ => simp at h2 exact absurd (h2.symm.trans h1) (by exact fun h => HasBool.tt_is_not_ff (Option.some.inj h)) - | eval_assert_fail _ _ => + | eval_assert_fail _ _ _ => apply ReflTrans.step _ _ _ .step_stmts_cons - apply ReflTrans.step _ _ _ (.step_seq_inner (.step_cmd (EvalCmd.eval_assert_fail h1 Hwf))) + apply ReflTrans.step _ _ _ (.step_seq_inner (.step_cmd (EvalCmd.eval_assert_fail h1 Hwf hcongr))) apply ReflTrans.step _ _ _ .step_seq_done apply ReflTrans.step _ _ _ .step_stmts_nil simp_all [Bool.or_true]; exact .refl _ diff --git a/Strata/DL/Util/Relations.lean b/Strata/DL/Util/Relations.lean index 8eea05a11d..b578af8073 100644 --- a/Strata/DL/Util/Relations.lean +++ b/Strata/DL/Util/Relations.lean @@ -9,9 +9,38 @@ public section section Relation @[expose] def Relation (A: Type) := A → A → Prop -def Reflexive (r: Relation A) : Prop := ∀ x, r x x +@[expose] def Reflexive (r: Relation A) : Prop := ∀ x, r x x abbrev Transitive (r: Relation A) : Prop := ∀ x y z, r x y → r y z → r x z +/-- Composition of two relations: `RComp R₁ R₂ a c` holds when some intermediate + `b` has `R₁ a b` and `R₂ b c`. Read left-to-right: "first `R₁`, then `R₂`". + + The scoped notation `R₁ ∘ R₂` is available via `open scoped Relations`. -/ +@[expose] def RComp {A : Type} (R₁ R₂ : Relation A) : Relation A := + fun a c => ∃ b, R₁ a b ∧ R₂ b c + +namespace Relations +/- Scoped infix `∘` for relation composition (`RComp`). Enable with + `open scoped Relations`. Distinct from `Function.comp`'s `∘` by being + scoped, so it does not globally shadow function composition. -/ +scoped infixr:90 " ∘ " => RComp +end Relations + +/-- `RComp R₁ R₂` reduces to `R` when `R` is transitive and `R₁, R₂ ⊆ R`. -/ +theorem RComp.collapse {A : Type} {R₁ R₂ R : Relation A} {a c : A} + (htrans : Transitive R) + (h₁ : ∀ x y, R₁ x y → R x y) (h₂ : ∀ x y, R₂ x y → R x y) + (h : RComp R₁ R₂ a c) : R a c := by + obtain ⟨b, hr₁, hr₂⟩ := h + exact htrans _ _ _ (h₁ _ _ hr₁) (h₂ _ _ hr₂) + +/-- `RComp` is monotone in both arguments. -/ +theorem RComp.mono {A : Type} {R₁ R₁' R₂ R₂' : Relation A} + (h₁ : ∀ x y, R₁ x y → R₁' x y) (h₂ : ∀ x y, R₂ x y → R₂' x y) + {a c : A} (h : RComp R₁ R₂ a c) : RComp R₁' R₂' a c := by + obtain ⟨b, hr₁, hr₂⟩ := h + exact ⟨b, h₁ _ _ hr₁, h₂ _ _ hr₂⟩ + inductive ReflTrans {A: Type} (r: Relation A) : Relation A where | refl : ∀ x, ReflTrans r x x | step: ∀ x y z, r x y → ReflTrans r y z → ReflTrans r x z diff --git a/Strata/DL/Util/StringGen.lean b/Strata/DL/Util/StringGen.lean index 214244eee1..6dd303444e 100644 --- a/Strata/DL/Util/StringGen.lean +++ b/Strata/DL/Util/StringGen.lean @@ -20,8 +20,7 @@ public section -/ /-- `s.IsSuffix t` checks if the string `s` is a suffix of the string `t`. -from mathlib https://github.com/leanprover-community/mathlib4/blob/f3c56c29d5c787d62f66c207e097a159ff66318a/Mathlib/Data/String/Defs.lean#L37-L39 --/ +Mirrors mathlib's `String.IsSuffix`. -/ abbrev String.IsSuffix (s1 s2 : String) : Prop := List.IsSuffix s1.toList s2.toList local infixl:50 " <:+ " => String.IsSuffix @@ -42,6 +41,7 @@ def StringGenState.emp : StringGenState := { cs := .emp, generated := [] } followed by an underscore (`_`), followed by a unique number given by its underlying counter `σ.cs`. -/ +@[expose] def StringGenState.gen (pf : String) (σ : StringGenState) : String × StringGenState := let (counter, cs) := Counter.genCounter σ.cs let newString : String := (pf ++ "_" ++ toString counter) @@ -55,19 +55,6 @@ def StringGenState.WF (σ : StringGenState) ∀ c s, (c,s) ∈ σ.generated → String.IsSuffix ("_" ++ toString c) s -theorem String.append_eq_suffix (as bs bs' : String): - (as ++ bs = as ++ bs') → bs = bs' := by - intros Heq - by_cases bs = bs' <;> simp_all - -theorem String.append_eq_prefix (as as' bs : String): - (as ++ bs = as' ++ bs) → as = as' := by - intros Heq - by_cases as = as' <;> simp_all - -theorem List.reverse_injective : - List.reverse l₁ = List.reverse l₂ → l₁ = l₂ := List.reverse_inj.mp - theorem StringGenState.contains : StringGenState.gen pf σ = (s, σ') → s ∈ σ'.generated.unzip.2 := by @@ -291,4 +278,240 @@ theorem StringGenState.WFMono : simp only [H.right, H.left, String.IsSuffix, String.toList_append, List.append_assoc] apply List.suffix_append · apply Hwf.right.right.right <;> assumption + +/-! ## Convenience helpers for the list of generated string labels -/ + +/-- The empty generator state is well-formed. -/ +theorem StringGenState.wf_emp : StringGenState.WF StringGenState.emp := by + simp [StringGenState.WF, Counter.WF] + +/-- Convenience: the list of generated string labels in a `StringGenState`. -/ +def StringGenState.stringGens (σ : StringGenState) : List String := + σ.generated.unzip.2 + +/-- The empty generator state has produced no labels. -/ +@[simp] theorem StringGenState.stringGens_emp : + StringGenState.stringGens StringGenState.emp = [] := by + simp [StringGenState.stringGens, StringGenState.emp] + +/-- No string is among the empty generator state's produced labels. -/ +theorem StringGenState.not_mem_stringGens_emp (s : String) : + s ∉ StringGenState.stringGens StringGenState.emp := by + rw [StringGenState.stringGens_emp]; exact List.not_mem_nil + +/-- After generating, the new state's labels list is the new label cons'd onto the old. -/ +theorem StringGenState.stringGens_gen + (pf : String) (σ : StringGenState) : + StringGenState.stringGens (StringGenState.gen pf σ).2 + = (StringGenState.gen pf σ).1 :: StringGenState.stringGens σ := by + simp [StringGenState.gen, StringGenState.stringGens] + +/-- The freshly generated label is not in the old state's labels list, given WF. -/ +theorem StringGenState.stringGens_gen_not_in + (pf : String) (σ : StringGenState) (hwf : StringGenState.WF σ) : + (StringGenState.gen pf σ).1 ∉ StringGenState.stringGens σ := by + intro h_in + have hwf' : StringGenState.WF (StringGenState.gen pf σ).2 := + StringGenState.WFMono hwf rfl + have h_gens_eq : StringGenState.stringGens (StringGenState.gen pf σ).2 + = (StringGenState.gen pf σ).1 :: StringGenState.stringGens σ := + StringGenState.stringGens_gen pf σ + have h_nodup : (StringGenState.stringGens (StringGenState.gen pf σ).2).Nodup := by + simp only [StringGenState.WF] at hwf' + exact hwf'.2.2.1 + rw [h_gens_eq] at h_nodup + rw [List.nodup_cons] at h_nodup + exact h_nodup.1 h_in + +/-! ## Shape predicates: distinguishing user labels from generated labels + +Every label produced by `StringGenState.gen pf σ` has the form +`pf ++ "_" ++ toString n` for some natural number `n`. This means user-provided +labels can be guaranteed disjoint from generator output by demonstrating that +they do *not* match this suffix shape, or that they have a non-overlapping +prefix in front of the trailing `_`. + +The lemmas below provide the building blocks for proving such disjointness. +The most useful one for client code is `gen_ne_of_not_hasUnderscoreDigitSuffix`: +a string without the `_` suffix shape can never be the output +of `gen`. -/ + +/-- A string has the shape `_` as a (non-empty) suffix. Equivalently, +its last `_` is followed only by digit characters (and there is at least one). +This is exactly the shape a label generated by `gen` always has. -/ +def String.HasUnderscoreDigitSuffix (s : String) : Prop := + ∃ pf n, s = pf ++ "_" ++ toString (n : Nat) + +/-- The label produced by `gen` has the form `pf ++ "_" ++ toString n`. -/ +theorem StringGenState.gen_eq (pf : String) (σ : StringGenState) : + (StringGenState.gen pf σ).1 = pf ++ "_" ++ toString σ.cs.counter := by + simp [StringGenState.gen, Counter.genCounter] + +/-- Every label produced by `gen` has the `_` suffix shape. -/ +theorem StringGenState.gen_hasUnderscoreDigitSuffix + (pf : String) (σ : StringGenState) : + String.HasUnderscoreDigitSuffix (StringGenState.gen pf σ).1 := by + refine ⟨pf, σ.cs.counter, ?_⟩ + exact StringGenState.gen_eq pf σ + +/-- Every label inside a WF `StringGenState`'s `generated` list has the +`_` suffix shape. -/ +theorem StringGenState.hasUnderscoreDigitSuffix_of_mem_generated + {σ : StringGenState} (hwf : StringGenState.WF σ) + {s : String} (hs : s ∈ σ.stringGens) : + String.HasUnderscoreDigitSuffix s := by + simp only [StringGenState.stringGens, List.unzip_snd, List.mem_map] at hs + obtain ⟨⟨c, s'⟩, h_mem, h_eq⟩ := hs + subst h_eq + have hsuf : ("_" ++ toString c).IsSuffix s' := hwf.2.2.2 c s' h_mem + obtain ⟨t_chars, h_t⟩ := hsuf + refine ⟨String.ofList t_chars, c, ?_⟩ + apply String.toList_inj.mp + simp only [String.toList_append, under_toList, String.toList_ofList] + rw [← h_t, String.toList_append, under_toList] + simp [List.append_assoc] + +/-- If a string does not have the `_` suffix shape, it cannot have been +produced by `gen`. -/ +theorem StringGenState.gen_ne_of_not_hasUnderscoreDigitSuffix + (pf : String) (σ : StringGenState) (s : String) + (h : ¬ String.HasUnderscoreDigitSuffix s) : + s ≠ (StringGenState.gen pf σ).1 := by + intro h_eq + apply h + rw [h_eq] + exact StringGenState.gen_hasUnderscoreDigitSuffix pf σ + +/-- If a string does not have the `_` suffix shape, it cannot appear +in the `stringGens` list of any WF `StringGenState`. -/ +theorem StringGenState.not_mem_stringGens_of_not_hasUnderscoreDigitSuffix + {σ : StringGenState} (hwf : StringGenState.WF σ) + {s : String} (h : ¬ String.HasUnderscoreDigitSuffix s) : + s ∉ σ.stringGens := by + intro h_in + exact h (StringGenState.hasUnderscoreDigitSuffix_of_mem_generated hwf h_in) + +/-- Two `gen` calls with different prefixes produce different labels, given +WF: the suffix `_` matches but the prefix preceding the *last* `_` +must coincide; together with `WF` ensuring no `_` appears in the digit suffix, +the prefixes themselves must be equal. -/ +theorem StringGenState.gen_inj_of_pf_eq + {pf₁ pf₂ : String} {σ₁ σ₂ : StringGenState} + (h : (StringGenState.gen pf₁ σ₁).1 = (StringGenState.gen pf₂ σ₂).1) : + pf₁ ++ "_" ++ toString σ₁.cs.counter = pf₂ ++ "_" ++ toString σ₂.cs.counter := by + rw [StringGenState.gen_eq, StringGenState.gen_eq] at h + exact h + +/-- A string with prefix `pf` followed by `_` is generated only if its +suffix-counter portion's prefix matches. Combined with the `Nat_eq_of_StringGen_suffix` +machinery: if a user label `pf' ++ rest` does not have the `_` shape, +it cannot equal any `gen pf σ`. -/ +theorem StringGenState.gen_ne_of_user_label_no_digit_suffix + {pf : String} {σ : StringGenState} {s : String} + (h : ¬ String.HasUnderscoreDigitSuffix s) : + s ≠ (StringGenState.gen pf σ).1 := + StringGenState.gen_ne_of_not_hasUnderscoreDigitSuffix pf σ s h + +/-! ## GenStep: well-formed monotone transitions of a `StringGenState` + +A `GenStep gen gen'` witnesses that `gen` transitioned to `gen'` via some +sequence of `gen` operations: well-formedness is preserved and the set of +generated labels only grows. Useful as a reusable abstraction for any +monadic computation in `StringGenM`. -/ + +/-- A "generator step": a transition from `gen` to `gen'` that preserves +well-formedness and only adds new labels (never removes them). -/ +structure StringGenState.GenStep (gen gen' : StringGenState) : Prop where + wf_mono : StringGenState.WF gen → StringGenState.WF gen' + subset : StringGenState.stringGens gen ⊆ StringGenState.stringGens gen' + +namespace StringGenState.GenStep + +/-- Identity transition. -/ +theorem refl (gen : StringGenState) : GenStep gen gen := + ⟨id, fun _ h => h⟩ + +/-- Composition of transitions. -/ +theorem trans {gen gen_mid gen' : StringGenState} + (h₁ : GenStep gen gen_mid) (h₂ : GenStep gen_mid gen') : + GenStep gen gen' := + ⟨h₂.wf_mono ∘ h₁.wf_mono, fun _ hx => h₂.subset (h₁.subset hx)⟩ + +/-- A single `gen` call is a `GenStep`. -/ +theorem of_gen (pf : String) (σ : StringGenState) : + GenStep σ (StringGenState.gen pf σ).2 := by + refine ⟨?_, ?_⟩ + · intro hwf; exact StringGenState.WFMono hwf rfl + · intro x hx + rw [StringGenState.stringGens_gen] + exact List.mem_cons.mpr (Or.inr hx) + +end StringGenState.GenStep + +/-! ## Kind-contract: per-prefix membership witnesses + +The shape predicate `HasUnderscoreDigitSuffix` answers "could this label have +come from *some* generator". For composing several generators that each mint +under their own prefix, we need a finer, per-prefix contract: a label `s` was +minted under prefix `pf` exactly when `pf ++ "_"` is a prefix of `s`, which +`HasGenPrefix` captures. -/ + +/-- `pf` is a *generator prefix* of `s`: the literal `pf ++ "_"` is a prefix of +`s`. Every label produced by `gen pf σ` satisfies `HasGenPrefix pf`. -/ +@[expose] +def String.HasGenPrefix (pf s : String) : Prop := + (pf ++ "_").toList.isPrefixOf s.toList = true + +/-- The label produced by `gen pf σ` carries `pf` as a generator prefix. -/ +theorem StringGenState.gen_hasGenPrefix (pf : String) (σ : StringGenState) : + String.HasGenPrefix pf (StringGenState.gen pf σ).1 := by + unfold String.HasGenPrefix + rw [gen_eq, List.isPrefixOf_iff_prefix] + refine ⟨(toString σ.cs.counter).toList, ?_⟩ + simp [String.toList_append, List.append_assoc] + +/-! ## Membership tracking: `AllMem` + +A prefix-only contract is too weak to certify a *foreign-label* obligation +against a predicate that — like the structured-to-unstructured label *kind* — +pins the label to a concrete `gen`-output equality (a non-generated string +sharing a prefix would slip past a prefix check). + +`AllMem R σ` is the stronger invariant: *every produced label satisfies `R` +itself*. At each `gen pf` step the newly produced label is literally +`(gen pf σ).1`, so the step preserves `AllMem R` as soon as `R` holds of every +`gen`-output under that prefix — exactly the per-prefix mint witnesses a pass +already establishes. The foreign discharge is then plain contraposition. -/ + +/-- `AllMem R σ`: every label produced so far satisfies `R`. -/ +@[expose] +def StringGenState.AllMem (R : String → Prop) (σ : StringGenState) : Prop := + ∀ s ∈ stringGens σ, R s + +/-- The empty generator state vacuously satisfies any `AllMem`. -/ +theorem StringGenState.allMem_emp (R : String → Prop) : + StringGenState.AllMem R StringGenState.emp := by + intro s hs + rw [stringGens_emp] at hs + exact absurd hs (List.not_mem_nil) + +/-- `AllMem` is preserved by a `gen pf` step whose newly produced label satisfies +`R`. -/ +theorem StringGenState.allMem_gen (R : String → Prop) (pf : String) + (σ : StringGenState) (h : StringGenState.AllMem R σ) + (hnew : R (StringGenState.gen pf σ).1) : + StringGenState.AllMem R (StringGenState.gen pf σ).2 := by + intro s hs + rw [stringGens_gen, List.mem_cons] at hs + rcases hs with hnew' | hold + · exact hnew' ▸ hnew + · exact h s hold + +/-- THE BRIDGE: a label `s` that fails `R` cannot appear in a state satisfying +`AllMem R`. Plain contraposition — no generator-shape reasoning needed. -/ +theorem StringGenState.not_mem_stringGens_of_not_allMem {R : String → Prop} + {σ : StringGenState} {s : String} + (hall : StringGenState.AllMem R σ) (hns : ¬ R s) : + s ∉ stringGens σ := fun h_in => hns (hall s h_in) + end diff --git a/Strata/Languages/Core/Statement.lean b/Strata/Languages/Core/Statement.lean index be30b7d37d..703fb6fb8e 100644 --- a/Strata/Languages/Core/Statement.lean +++ b/Strata/Languages/Core/Statement.lean @@ -7,6 +7,7 @@ module public import Strata.Languages.Core.Expressions public import Strata.DL.Imperative.Stmt +public import Strata.DL.Util.StringGen import Std.Tactic.BVDecide.Normalize.Prop namespace Core @@ -516,3 +517,101 @@ def Statements.collectExprs end end Core + +namespace Imperative + +public section + +/-- 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. + +The command type `C` is left abstract: `userBlockLabels` never inspects a +command, so this applies uniformly to the pipeline's `Imperative.Cmd`-bodied +statement lists and to extended command types (e.g. Core's `CmdExt`). -/ +@[expose] def Block.userBlockLabels {P : PureExpr} {C : Type} : + List (Stmt P C) → List String + | [] => [] + | s :: rest => stmtUserBlockLabels s ++ Block.userBlockLabels rest +where + stmtUserBlockLabels : Stmt P C → 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} {C : Type} + (l : String) (bss : List (Stmt P C)) (md : MetaData P) + (rest : List (Stmt P C)) : + 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 : Type} + (c : Imperative.ExprOrNondet P) (tss ess : List (Stmt P C)) + (md : MetaData P) (rest : List (Stmt P C)) : + 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 : Type} + (c : Imperative.ExprOrNondet P) (m : Option P.Expr) + (is : List (String × P.Expr)) (bss : List (Stmt P C)) + (md : MetaData P) (rest : List (Stmt P C)) : + 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 : Type} + (c : C) (rest : List (Stmt P C)) : + Block.userBlockLabels (.cmd c :: rest) = Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +theorem Block.userBlockLabels_funcDecl_cons {P : PureExpr} {C : Type} + (decl : Imperative.PureFunc P) (md : MetaData P) + (rest : List (Stmt P C)) : + Block.userBlockLabels (.funcDecl decl md :: rest) = + Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +theorem Block.userBlockLabels_typeDecl_cons {P : PureExpr} {C : Type} + (tc : TypeConstructor) (md : MetaData P) + (rest : List (Stmt P C)) : + Block.userBlockLabels (.typeDecl tc md :: rest) = + Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +theorem Block.userBlockLabels_exit_cons {P : PureExpr} {C : Type} + (l : String) (md : MetaData P) (rest : List (Stmt P C)) : + Block.userBlockLabels (.exit l md :: rest) = + Block.userBlockLabels rest := by + show Block.userBlockLabels.stmtUserBlockLabels _ ++ _ = _ + rfl + +/-- The gen-free core of `userLabelsDisjoint`: user-provided block labels are +shape-free (do not have the `_` generator suffix) and pairwise distinct. + +This is the structured-program well-formedness condition on user block labels: +the shape-free conjunct prevents minted-vs-user label collisions, and the +`Nodup` conjunct prevents user-vs-user duplicate CFG block keys. The full +`userLabelsDisjoint` (which additionally quantifies over generator states) is +*derivable* from this together with well-formedness of the generator: a +shape-free label is never in the `stringGens` of any WF state. + +The command type `C` is abstract for the same reason as `userBlockLabels`. -/ +@[expose] def Block.userLabelsShapeNodup {P : PureExpr} {C : Type} + (ss : List (Stmt P C)) : Prop := + (∀ l ∈ Block.userBlockLabels ss, ¬ String.HasUnderscoreDigitSuffix l) ∧ + (Block.userBlockLabels ss).Nodup + +end -- public section +end Imperative diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 3dae95242c..e312f5277f 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -9,6 +9,10 @@ public import Strata.DL.Imperative.StmtSemantics public import Strata.Languages.Core.Procedure public import Strata.Languages.Core.Factory import Std.Tactic.BVDecide.Normalize.Prop +import all Strata.DL.Lambda.IntBoolFactory +import all Strata.DL.Lambda.Factory +import all Strata.DL.Lambda.FactoryWF +import all Strata.Languages.Core.Factory --------------------------------------------------------------------- @@ -63,6 +67,84 @@ instance : HasNot Core.Expression where | Core.false => Core.true | e => Lambda.LExpr.app () (Lambda.boolNotFunc (T:=CoreLParams)).opExpr e +/-! ### Lawful instances for `Core.Expression` + +These witness that `Core.Expression`'s `Has*` instances satisfy the algebraic +laws expected by downstream proofs (e.g., the `stmtsToCFG` correctness proof). -/ + +instance : LawfulHasFvar Core.Expression where + getFvar_mkFvar := fun _ => rfl + mkFvar_getVars := fun _ => by + -- mkFvar x = .fvar () x none, getVars = [x] ⊆ [x] + simp [HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] + +instance : LawfulHasBool Core.Expression where + -- HasBool.tt = Core.true = .boolConst () true = .const _ _, getVars = [] + tt_getVars := rfl + +instance : LawfulHasIdent Core.Expression where + ident_inj := by + intro a b h + -- HasIdent.ident s = ⟨s, ()⟩ : Identifier Unit + -- Identifier is a structure with field `name : String`, so injectivity is by `cases` + cases h + rfl + +instance : LawfulHasIntOrder Core.Expression where + -- HasIntOrder.eq a b = .eq () a b. getVars (.eq _ a b) = getVars a ++ getVars b. + eq_getVars := fun _ _ => by + simp [HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] + -- HasIntOrder.lt a b = .app () (.app () intLtOp a) b. getVars expands and + -- getVars intLtOp = [] (it's an .op node), giving getVars a ++ getVars b. + lt_getVars := fun a b => by + show HasVarsPure.getVars + (Lambda.LExpr.app () (Lambda.LExpr.app () Core.intLtOp a) b) + ⊆ HasVarsPure.getVars a ++ HasVarsPure.getVars b + change Lambda.LExpr.LExpr.getVars _ + ⊆ Lambda.LExpr.LExpr.getVars a ++ Lambda.LExpr.LExpr.getVars b + rw [Lambda.LExpr.LExpr.getVars, Lambda.LExpr.LExpr.getVars] + have h_op : Lambda.LExpr.LExpr.getVars Core.intLtOp = [] := by + simp [Core.intLtOp, Lambda.WFLFunc.opExpr, Lambda.LFunc.opExpr, + Lambda.intLtFunc, Lambda.binaryOp, + Lambda.LExpr.LExpr.getVars] + rw [h_op, List.nil_append] + exact List.Subset.refl _ + -- HasIntOrder.zero = .intConst () 0 = .const _ _, getVars = [] + zero_getVars := rfl + +instance : LawfulHasNot Core.Expression where + not_getVars := fun a => by + -- Case-split on the structure of `a` to handle the three branches of `not`. + -- For Core.true/Core.false branches, the result is the dual constant + -- (getVars = []) and the input also has getVars = [], so subset is vacuous. + -- For the general branch, `not e = .app () boolNotFunc.opExpr e`, and + -- getVars expands as getVars boolNotFunc.opExpr ++ getVars e = [] ++ getVars e. + show HasVarsPure.getVars (HasNot.not a) ⊆ HasVarsPure.getVars a + unfold HasNot.not instHasNotExpression + simp only + split + · -- not Core.true = Core.false: getVars Core.false = [] ⊆ getVars Core.true + simp [HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] + · -- not Core.false = Core.true: symmetric + simp [HasVarsPure.getVars, Lambda.LExpr.LExpr.getVars] + · -- not e = .app () boolNotFunc.opExpr e + -- getVars (.app _ x y) = getVars x ++ getVars y + -- boolNotFunc.opExpr is .op _ _ _ so getVars = [] + show HasVarsPure.getVars + (Lambda.LExpr.app () (Lambda.boolNotFunc (T:=CoreLParams)).opExpr a) + ⊆ HasVarsPure.getVars a + change Lambda.LExpr.LExpr.getVars _ ⊆ Lambda.LExpr.LExpr.getVars a + rw [Lambda.LExpr.LExpr.getVars] + -- Now: getVars boolNotFunc.opExpr ++ getVars a ⊆ getVars a. + -- It suffices to show getVars boolNotFunc.opExpr = []. + have h_op : Lambda.LExpr.LExpr.getVars + (Lambda.boolNotFunc (T := CoreLParams)).opExpr = [] := by + simp [Lambda.WFLFunc.opExpr, Lambda.LFunc.opExpr, + Lambda.boolNotFunc, Lambda.unaryOp, + Lambda.LExpr.LExpr.getVars] + rw [h_op, List.nil_append] + exact List.Subset.refl _ + @[expose] abbrev CoreEval := SemanticEval Expression @[expose] abbrev CoreStore := SemanticStore Expression diff --git a/Strata/Languages/Core/StatementSemanticsProps.lean b/Strata/Languages/Core/StatementSemanticsProps.lean index 31c6ff441a..5be6714bf4 100644 --- a/Strata/Languages/Core/StatementSemanticsProps.lean +++ b/Strata/Languages/Core/StatementSemanticsProps.lean @@ -1757,18 +1757,19 @@ theorem EvalCmdDefMonotone' : next Hup => exact UpdateStateDefMonotone Hdef Hup theorem EvalCmdTouch - [HasVal P] [HasFvar P] [HasBool P] [HasBoolVal P] [HasNot P] : + [HasVal P] [HasFvar P] [HasBool P] [HasBoolVal P] [HasNot P] + [HasVarsPure P P.Expr] : EvalCmd P δ σ c σ' f → TouchVars σ (HasVarsImp.modifiedOrDefinedVars c) σ' := by intro Heval induction Heval <;> simp [HasVarsImp.modifiedOrDefinedVars, Cmd.definedVars, Cmd.modifiedVars] - case eval_init x' δ σ x v σ' σ₀ e Hsm Hup Hwf => + case eval_init x' δ σ x v σ' σ₀ e Hsm Hup Hwf Hcongr => apply TouchVars.init_some Hup constructor case eval_init_unconstrained x' δ σ x v σ' σ₀ Hup Hwf => apply TouchVars.init_some Hup constructor - case eval_set δ σ x v σ' σ₀ e Hsm Hup Hwf => + case eval_set δ σ x v σ' σ₀ e Hsm Hup Hwf Hcongr => exact TouchVars.update_some Hup TouchVars.none case eval_set_nondet x v σ' σ₀ e Hsm Hup Hwf => exact TouchVars.update_some Hup TouchVars.none diff --git a/Strata/Languages/Core/WF.lean b/Strata/Languages/Core/WF.lean index dc8fc161d2..37e7c7a368 100644 --- a/Strata/Languages/Core/WF.lean +++ b/Strata/Languages/Core/WF.lean @@ -146,6 +146,20 @@ structure WFProcedureProp (p : Program) (d : Procedure) : Prop where wfspec : WFSpecProp p d.spec d -- There is no exit statement that cannot be caught by any block in the procedure. bodyExitsCovered : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks [] d.body + -- User-provided block labels are shape-free (no generator `_` suffix) + -- and pairwise distinct, so they neither collide with minted CFG labels nor + -- with each other when the body is lowered to an unstructured CFG. + userLabelsWF : Block.userLabelsShapeNodup d.body + +/-- A well-formed procedure body satisfies the user-label shape+Nodup condition. +A trivial projection of the `userLabelsWF` field; the point is that the +well-formedness bundle now *carries* this source-body condition, so a caller can +project it from procedure well-formedness rather than assume it standalone. -/ +theorem WFProcedureProp.userLabelsShapeNodup_body + {p : Program} {d : Procedure} (h : WFProcedureProp p d) : + Block.userLabelsShapeNodup d.body := + h.userLabelsWF + structure WFFunctionProp (p : Program) (f : Function) : Prop where structure WFRecFuncBlockProp (p : Program) (fs : List Function) : Prop where diff --git a/Strata/Transform/CanFailPreservation.lean b/Strata/Transform/CanFailPreservation.lean new file mode 100644 index 0000000000..86c55f95d9 --- /dev/null +++ b/Strata/Transform/CanFailPreservation.lean @@ -0,0 +1,420 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.Transform.PipelineBridge +public import Strata.DL.Imperative.StmtSemanticsProps + +public section + +namespace Imperative + +open Imperative.Specification +open Imperative.Specification.Transform +open StructuredToUnstructuredCorrect (StepDetCFGStar) + +/-! # `CanFail` preservation through the structured-to-unstructured pipeline + +`CanFail L s ρ₀` says that *some* reachable configuration of `s` under language `L` +has its cumulative `hasFailure` flag set: + + `∃ cfg, (L.getEnv cfg).hasFailure = true ∧ L.star (L.stmtCfg s ρ₀) cfg`. + +The reachable `cfg` may be an *intermediate* configuration — the run is not required +to have reached a terminal or exiting endpoint. This is the one genuinely net-new +obligation a refinement that tracks "can the source fail?" would add on top of the +existing terminal/exiting `Overapproximates` story. + +## What is proven here (`canFail_preserved_when_outcome`) + +If the source's failing configuration lies on a run that *does* reach a terminal or +exiting endpoint, `CanFail` is preserved through `pipeline = stmtsToCFG ∘ hoist ∘ +nondetElim`. The proof is a real composition: + + 1. *Source monotonicity* (`StepStmtStar_hasFailure_monotone`) lifts the + intermediate `hasFailure = true` to the endpoint's flag, since the source + step semantics only ever OR-s failure in and never clears it. + 2. The dual `pipeline_sound` transports that endpoint to a matching CFG endpoint + (terminal or exiting) carrying the *same* failure flag. Either output disjunct + suffices: both yield a reachable CFG configuration with `getFailure = true`, so + no target-IR determinism principle is needed to select the disjunct. + +## What is NOT proven (and why) — the diverging-run obstruction + +The *unconditional* statement `CanFail (source) → CanFail (target)` is **not** a +corollary of the pipeline's correctness theorems. Those theorems are forward +simulations keyed on a terminal or exiting *endpoint*: each `_sound_kind` / +`_sound_kind_exit` lemma consumes a source run reaching `.terminal ρ'` / `.exiting +lbl ρ'` and produces the matching CFG endpoint. None of them says anything about an +intermediate configuration that a non-terminating run passes through. + +A failing configuration need not lie on such a run. Consider `assert false` +followed by a non-terminating loop, or any failing configuration that then gets +stuck on a guard that does not evaluate to a boolean. The source records the +failure, but the run never reaches `.terminal`/`.exiting`, so there is no endpoint to +feed the simulation lemmas. Discharging the `h_outcome` hypothesis below +unconditionally would amount to a source-side progress/termination principle, which +this development does not carry (partial-correctness only). + +Closing the unconditional statement would therefore require a *new* per-pass +forward simulation that maps an arbitrary intermediate (possibly non-terminal) +failing source configuration to a reachable failing CFG configuration — strictly +more than the endpoint lemmas supply. The conditional theorem captures exactly the +fragment the existing machinery proves. -/ + +/-! ## CFG-side `hasFailure` monotonicity + +`updateFailure` only ever OR-s the failure flag in, so the projected `getFailure` of +a `CFGConfig` is monotone along any `StepCFG` run. (Stated fully generically.) -/ + +/-- A single `StepCFG` step preserves a set failure flag. -/ +theorem stepCFG_getFailure_monotone {P : PureExpr} {l CmdT : Type} [BEq l] + {EvalCmd : EvalCmdParam P CmdT} {extendEval : ExtendEval P} + [HasNot P] [HasVarsPure P P.Expr] + {cfg : CFG l (DetBlock l CmdT P)} {c c' : CFGConfig l CmdT P} + (hstep : StepCFG P EvalCmd extendEval cfg c c') + (hf : c.getFailure = true) : c'.getFailure = true := by + cases hstep with + | fetch _ => simpa [CFGConfig.getFailure] using hf + | step_cmd _ => simp [CFGConfig.getFailure]; left; simpa [CFGConfig.getFailure] using hf + | goto_true _ _ _ => simpa [CFGConfig.getFailure] using hf + | goto_false _ _ _ => simpa [CFGConfig.getFailure] using hf + | finish => simpa [CFGConfig.getFailure] using hf + | exitTo => simpa [CFGConfig.getFailure] using hf + +/-- A `StepCFGStar` run preserves a set failure flag. -/ +theorem stepCFGStar_getFailure_monotone {P : PureExpr} {l CmdT : Type} [BEq l] + {EvalCmd : EvalCmdParam P CmdT} {extendEval : ExtendEval P} + [HasNot P] [HasVarsPure P P.Expr] + {cfg : CFG l (DetBlock l CmdT P)} {c c' : CFGConfig l CmdT P} + (hstar : StepCFGStar P EvalCmd extendEval cfg c c') + (hf : c.getFailure = true) : c'.getFailure = true := by + induction hstar with + | refl => exact hf + | step _ _ _ hstep _ ih => exact ih (stepCFG_getFailure_monotone hstep hf) + +variable {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] + [HasSubstFvar P] [LawfulHasSubstFvar P] + +/-- **Endpoint core.** Given a failing source configuration `c` that is reachable +from `.stmts ss ρ₀`, together with an endpoint witness (the continuation from `c` +reaches `.terminal ρ'` or `.exiting lbl ρ'`), produce a reachable *failing* CFG +configuration of `pipeline ss`. + +Source monotonicity carries `c`'s failure to the endpoint `ρ'`; the dual +`pipeline_sound` then transports that endpoint to a matching CFG endpoint with the +same failure flag. Either output disjunct of `pipeline_sound` works — both expose a +configuration whose `getFailure` is `ρ'.hasFailure = true`. -/ +theorem canFail_target_of_source_endpoint + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) (c : Config P (Cmd P)) + (hpre : PipelinePre extendEval ss ρ₀) + (h_reach_c : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) c) + (h_c_fail : c.getEnv.hasFailure = true) + (h_endpoint : + (∃ ρ'', StepStmtStar P (EvalCmd P) extendEval c (.terminal ρ'') ∧ ρ'' = ρ') + ∨ (∃ lbl ρ'', StepStmtStar P (EvalCmd P) extendEval c (.exiting lbl ρ'') ∧ ρ'' = ρ')) : + ∃ d : CFGConfig String (Cmd P) P, + d.getFailure = true ∧ + StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry ρ₀.store ρ₀.hasFailure) d := by + have h_run_disj : + StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ') + ∨ ∃ lbl, StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.exiting lbl ρ') := by + rcases h_endpoint with ⟨ρ'', h_to, rfl⟩ | ⟨lbl, ρ'', h_to, rfl⟩ + · exact Or.inl (ReflTrans_Transitive _ _ _ _ h_reach_c h_to) + · exact Or.inr ⟨lbl, ReflTrans_Transitive _ _ _ _ h_reach_c h_to⟩ + have h_ρ'_fail : ρ'.hasFailure = true := by + rcases h_endpoint with ⟨ρ'', h_to, rfl⟩ | ⟨lbl, ρ'', h_to, rfl⟩ <;> + · have := StepStmtStar_hasFailure_monotone (P := P) (EvalCmd := EvalCmd P) + (extendEval := extendEval) h_to h_c_fail + simpa [Config.getEnv] using this + rcases pipeline_sound extendEval ss ρ₀ ρ' + hpre.hwfb hpre.hwfv hpre.hwfvar' hpre.hwfcongr' hpre.hwfsubst' hpre.hwfdef' + hpre.h_store_inits hpre.h_store_mints_ndelim hpre.h_store_mints_hoist + hpre.h_store_mints_s2u hpre.h_nofd hpre.h_lhni hpre.h_nml + hpre.h_unique hpre.h_fresh hpre.h_disj hpre.h_ndelim_writes hpre.h_ndelim_exprs + hpre.h_hoist_exprs hpre.h_disj_initVars hpre.h_disj_modVars h_run_disj with + ⟨σ_cfg, h_run, _⟩ | ⟨lbl, σ_cfg, h_run, _⟩ + · exact ⟨.terminal σ_cfg ρ'.hasFailure, by simpa [CFGConfig.getFailure] using h_ρ'_fail, h_run⟩ + · exact ⟨.exiting lbl σ_cfg ρ'.hasFailure, by simpa [CFGConfig.getFailure] using h_ρ'_fail, h_run⟩ + +/-- **`CanFail` preservation (conditional on a source endpoint).** If `ss` can fail +from `ρ₀` and *every* failing reachable source configuration lies on a run that +reaches a terminal or exiting endpoint (`h_outcome`), then `pipeline ss` can fail +from `ρ₀` under the CFG language. + +The `h_outcome` hypothesis is the exact fragment the pipeline's endpoint correctness +theorems can serve. It is *not* dischargeable unconditionally: a failing +configuration on a non-terminating (or stuck) run has no endpoint, and the endpoint +simulation lemmas say nothing about such an intermediate configuration. See the +module header for the full obstruction. -/ +theorem canFail_preserved_when_outcome + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ : Env P) + (hpre : PipelinePre extendEval ss ρ₀) + (h_src : CanFail (Lang.imperativeBlock (EvalCmd P) extendEval (isAtAssert P)) ss ρ₀) + (h_outcome : ∀ c : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) c → + c.getEnv.hasFailure = true → + (∃ ρ', StepStmtStar P (EvalCmd P) extendEval c (.terminal ρ')) + ∨ (∃ lbl ρ', StepStmtStar P (EvalCmd P) extendEval c (.exiting lbl ρ'))) : + CanFail (Lang.cfg extendEval) (pipeline ss) ρ₀ := by + obtain ⟨c, h_c_fail, h_reach_c⟩ := h_src + rcases h_outcome c h_reach_c h_c_fail with ⟨ρ', h_to_term⟩ | ⟨lbl, ρ', h_to_exit⟩ + · obtain ⟨d, hd_fail, hd_run⟩ := + canFail_target_of_source_endpoint extendEval ss ρ₀ ρ' c hpre h_reach_c h_c_fail + (Or.inl ⟨ρ', h_to_term, rfl⟩) + exact ⟨(⟨"", []⟩, d), by simpa [Lang.cfg, CFGConfig.getFailure] using hd_fail, + by simpa [Lang.cfg] using hd_run⟩ + · obtain ⟨d, hd_fail, hd_run⟩ := + canFail_target_of_source_endpoint extendEval ss ρ₀ ρ' c hpre h_reach_c h_c_fail + (Or.inr ⟨lbl, ρ', h_to_exit, rfl⟩) + exact ⟨(⟨"", []⟩, d), by simpa [Lang.cfg, CFGConfig.getFailure] using hd_fail, + by simpa [Lang.cfg] using hd_run⟩ + +/-! ## Unconditional `CanFail` preservation + +The conditional theorem above needs `h_outcome`: every failing source config must +lie on a run reaching a terminal/exiting endpoint. That hypothesis is the price +of the *endpoint*-keyed pipeline simulations. The per-pass failing-config +siblings remove the endpoint demand: `nondetElim_to_fail` / +`hoistLoopPrefixInits_to_fail_kind` for the structured passes (composed into the +structured-pass failing bridge by `structuredPassFailingBridge_holds`) and +`stmtsToBlocks_simulation_to_fail` for the final pass. Combined into +`pipeline_to_fail`, `CanFail` is preserved with NO `h_outcome` and NO extra +hypothesis — the failing run may diverge or get stuck after the failure, and the +bridge is discharged from the `PipelinePre`-derivable structured-pass +preconditions. -/ + +/-- **Unconditional `CanFail` preservation.** +If `ss` can fail from a clean initial environment `ρ₀` (`ρ₀.hasFailure = false`), +then `pipeline ss` can fail from `ρ₀` under the CFG language. No source endpoint +hypothesis and no structured-pass bridge hypothesis: the bridge is discharged from +`PipelinePre` inside `pipeline_to_fail`. + +The proof runs `pipeline_to_fail` at `σ_ext := ρ₀.store` (the identity +overapproximation: `StoreAgreement` is reflexive and the `σ_ext`-freshness side +conditions are the `ρ₀`-store freshness facts already bundled in +`PipelinePre`). -/ +theorem canFail_pipeline + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ : Env P) + (hpre : PipelinePre extendEval ss ρ₀) + (h_ρ₀_nofail : ρ₀.hasFailure = false) + (h_src : CanFail (Lang.imperativeBlock (EvalCmd P) extendEval (isAtAssert P)) ss ρ₀) : + CanFail (Lang.cfg extendEval) (pipeline ss) ρ₀ := by + obtain ⟨c, h_c_fail, h_reach_c⟩ := h_src + obtain ⟨d, hd_run, hd_fail⟩ := + pipeline_to_fail extendEval ss ρ₀ c ρ₀.store h_ρ₀_nofail + hpre.hwfb hpre.hwfv hpre.hwfvar' hpre.hwfcongr' hpre.hwfsubst' hpre.hwfdef' + hpre.h_store_inits hpre.h_store_mints_ndelim hpre.h_store_mints_hoist + (StoreAgreement.refl _) hpre.h_store_inits + hpre.h_store_mints_ndelim hpre.h_store_mints_hoist hpre.h_store_mints_s2u + hpre.h_nofd hpre.h_lhni hpre.h_nml hpre.h_unique hpre.h_fresh hpre.h_disj + hpre.h_ndelim_writes hpre.h_ndelim_exprs hpre.h_hoist_exprs + hpre.h_disj_initVars hpre.h_disj_modVars + (by simpa [Lang.imperativeBlock] using h_reach_c) + (by simpa [Lang.imperativeBlock] using h_c_fail) + -- `pipeline_to_fail` starts the CFG at `.atBlock _ ρ₀.store ρ₀.hasFailure`, + -- which is exactly `Lang.cfg.stmtCfg (pipeline ss) ρ₀`. + exact ⟨(⟨"", []⟩, d), by simpa [Lang.cfg, CFGConfig.getFailure] using hd_fail, + by simpa [Lang.cfg] using hd_run⟩ + +/-! ## Phase 4 — the up-to-relation overapproximation instance + +`pipeline_overapproximates_upto` packages the pipeline's correctness as a single +`OverapproximatesUptoWhen` instance, relating source and target *whole +environments* by `PipelineEnvRel` (env-lifted store agreement, source on the +left, with matching failure flag and evaluator). + +### The single-relation tension, and how `pre` resolves it + +`OverapproximatesUptoWhen` uses *one* relation `R` for both the input (as a +hypothesis: `R ρ₀ ρ₀'`) and the output (under an existential: `R ρ' ρ''`). These +pull in opposite directions for a variable-*introducing* pipeline: + +* the **output** `R ρ' ρ''` must *allow extra variables* — the CFG terminal store + `σ_cfg` binds the pipeline-minted names that the source store `ρ'.store` never + defines — so `R` can be no stronger than `StoreAgreement` (source on the left); +* but the target-side compositional theorems run from `ρ₀'` and need, on + `ρ₀'.store`, that the source `initVars` and the three minted kinds are + *undefined* — a *freshness* fact that `StoreAgreement ρ₀.store ρ₀'.store` (which + constrains only the variables `ρ₀.store` *defines*) cannot supply. + +A single `R` strong enough for the input freshness would forbid exactly the extra +output variables the pipeline produces. So the input freshness on `ρ₀'` cannot +come from `R`; it is instead supplied — together with the structured-pass failing +bridge — through the statement-only `pre`, which asserts `PipelinePre` (whose +store-freshness fields pin `ρ₀'.store`) at every clean candidate initial env. +`R` is then free to be the natural output-side `StoreAgreement`. + +### Conjuncts + +* **terminal/exiting** — from `pipeline_sound_terminal_compositional` / + `pipeline_sound_exiting_compositional`, run from `ρ₀'`, with the `ρ₀'`-store + freshness drawn from the `pre`-supplied `PipelinePre ρ₀'`. +* **CanFail** — from `canFail_pipeline`, run from `ρ₀'` (or, when `ρ₀'` already + fails, witnessed by the failing start config directly). The structured-pass + failing bridge is discharged from `PipelinePre` inside `pipeline_to_fail`. +* **target `initEnvWF`** — trivial, since `Lang.cfg.initEnvWF = fun _ _ _ => True`. +-/ + +/-- The environment relation `pipeline_overapproximates_upto` runs at: +env-lifted store agreement (source on the left, the natural output-side relation +that *allows the extra variables* the pipeline introduces) with matching failure +flag and evaluator. Reflexive, so the diagonal `ρ₀ = ρ₀'` is included and the +instance specialises to identity-input pipeline soundness. -/ +@[expose] def PipelineEnvRel (ρ₀ ρ₀' : Env P) : Prop := + StoreAgreement ρ₀.store ρ₀'.store + ∧ ρ₀.hasFailure = ρ₀'.hasFailure + ∧ ρ₀'.eval = ρ₀.eval + +omit [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] [HasSubstFvar P] + [LawfulHasSubstFvar P] in +theorem PipelineEnvRel.refl (ρ₀ : Env P) : PipelineEnvRel ρ₀ ρ₀ := + ⟨StoreAgreement.refl _, rfl, rfl⟩ + +omit [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] [HasSubstFvar P] + [LawfulHasSubstFvar P] in +/-- `PipelineEnvRel` is transitive: store agreement chains via `StoreAgreement.trans`, +the failure flags and evaluators by equality transitivity (the evaluator conjunct is +oriented right-to-left, `ρ₀'.eval = ρ₀.eval`, so it composes in the reverse order). +Together with `PipelineEnvRel.refl` this makes `PipelineEnvRel` a preorder, which is +exactly the input to `OverapproximatesUptoWhen.comp_preorder` for chaining the +overapproximation instance with another pass relating environments by the same +relation. -/ +theorem PipelineEnvRel.trans {ρ₁ ρ₂ ρ₃ : Env P} + (h₁ : PipelineEnvRel ρ₁ ρ₂) (h₂ : PipelineEnvRel ρ₂ ρ₃) : + PipelineEnvRel ρ₁ ρ₃ := + ⟨StoreAgreement.trans h₁.1 h₂.1, h₁.2.1.trans h₂.2.1, h₂.2.2.trans h₁.2.2⟩ + +/-- **Phase 4: pipeline overapproximation up to `PipelineEnvRel` (unconditional).** +`fun ss => some (pipeline ss)` overapproximates the source statement-list language +by the unstructured CFG language *up to* `PipelineEnvRel`. + +Because the single relation `R` cannot simultaneously carry the input freshness +and permit the output's extra variables (see the section header), the per-`ρ₀'` +`PipelinePre` is threaded through the statement-only `pre`, instantiated at the +actual `R`-related target env. The structured-pass failing bridge is no longer a +standing obligation: it is discharged from `PipelinePre` inside `pipeline_to_fail` +(via `structuredPassFailingBridge_holds`), so every conjunct — the +terminal/exiting compositional simulations and the `CanFail` assembly — is fully +proven from `PipelinePre` alone. -/ +theorem pipeline_overapproximates_upto (extendEval : ExtendEval P) : + Specification.Transform.OverapproximatesUptoWhen + (PipelineEnvRel (P := P)) + (Lang.imperativeBlockSrc extendEval) + (Lang.cfg extendEval) + (fun ss => some (pipeline ss)) + (fun ss => ∀ ρ : Env P, PipelinePre extendEval ss ρ) + () () := by + intro ss cfg ht hpre_all ρ₀ ρ₀' hR _hwf + simp only [Option.some.injEq] at ht + subst ht + obtain ⟨hR_agree, hR_hf, hR_eval⟩ := hR + -- `pre` supplies `PipelinePre` (hence the store-freshness) at the target env ρ₀'. + have hpre' : PipelinePre extendEval ss ρ₀' := hpre_all ρ₀' + -- σ_ext-freshness on ρ₀'.store, directly from `PipelinePre ρ₀'`. + have h_inits_ext : ∀ x ∈ Block.initVars ss, ρ₀'.store x = none := hpre'.h_store_inits + have h_ndelim_ext : ∀ s : String, ndelimKind s → + ρ₀'.store (HasIdent.ident (P := P) s) = none := hpre'.h_store_mints_ndelim + have h_hoist_ext : ∀ s : String, hoistKind s → + ρ₀'.store (HasIdent.ident (P := P) s) = none := hpre'.h_store_mints_hoist + have h_s2u_ext : ∀ s : String, StructuredToUnstructuredCorrect.s2uKind s → + ρ₀'.store (HasIdent.ident (P := P) s) = none := hpre'.h_store_mints_s2u + -- The structured passes run from ρ₀; use the source-side preconditions for ρ₀. + have hpre : PipelinePre extendEval ss ρ₀ := hpre_all ρ₀ + refine ⟨fun ρ' => ⟨fun hstar => ?_, fun lbl hstar => ?_⟩, ?_, ?_⟩ + · -- ===== TERMINAL ARM ===== + have h_term : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ') := by + simpa [Lang.imperativeBlockSrc, Lang.imperativeBlock] using hstar + obtain ⟨σ_cfg, h_run, h_agree⟩ := + pipeline_sound_terminal_compositional extendEval ss ρ₀ ρ' ρ₀'.store + hpre.hwfb hpre.hwfv hpre.hwfvar' hpre.hwfcongr' hpre.hwfsubst' hpre.hwfdef' + hpre.h_store_inits hpre.h_store_mints_ndelim hpre.h_store_mints_hoist + hR_agree h_inits_ext h_ndelim_ext h_hoist_ext h_s2u_ext + hpre.h_nofd hpre.h_lhni hpre.h_nml hpre.h_unique hpre.h_fresh hpre.h_disj + hpre.h_ndelim_writes hpre.h_ndelim_exprs hpre.h_hoist_exprs + hpre.h_disj_initVars hpre.h_disj_modVars h_term + refine ⟨{ store := σ_cfg, eval := ρ'.eval, hasFailure := ρ'.hasFailure }, ?_, ?_⟩ + · exact ⟨h_agree, rfl, rfl⟩ + · -- target run: `Lang.cfg.star`/`.stmtCfg`/`.terminalCfg` are an `abbrev`, hence + -- defeq to `StepDetCFGStar`/`.atBlock _ ρ₀'.store ρ₀'.hasFailure`/`.terminal _`. + -- `change` exposes that reduced shape so the failure flag `ρ₀'.hasFailure` can be + -- rewritten to `h_run`'s `ρ₀.hasFailure` via `hR_hf`. + change StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry ρ₀'.store ρ₀'.hasFailure) _ + rw [← hR_hf] + exact h_run + · -- ===== EXITING ARM ===== + have h_exit : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.exiting lbl ρ') := by + simpa [Lang.imperativeBlockSrc, Lang.imperativeBlock] using hstar + obtain ⟨σ_cfg, h_run, h_agree⟩ := + pipeline_sound_exiting_compositional extendEval ss ρ₀ ρ' ρ₀'.store + hpre.hwfb hpre.hwfv hpre.hwfvar' hpre.hwfcongr' hpre.hwfsubst' hpre.hwfdef' + hpre.h_store_inits hpre.h_store_mints_ndelim hpre.h_store_mints_hoist + hR_agree h_inits_ext h_ndelim_ext h_hoist_ext h_s2u_ext + hpre.h_nofd hpre.h_lhni hpre.h_nml hpre.h_unique hpre.h_fresh hpre.h_disj + hpre.h_ndelim_writes hpre.h_ndelim_exprs hpre.h_hoist_exprs + hpre.h_disj_initVars hpre.h_disj_modVars lbl h_exit + refine ⟨{ store := σ_cfg, eval := ρ'.eval, hasFailure := ρ'.hasFailure }, ?_, ?_⟩ + · exact ⟨h_agree, rfl, rfl⟩ + · -- As in the terminal arm, `change` exposes the `abbrev`-reduced run shape so the + -- start failure flag `ρ₀'.hasFailure` can be rewritten to `h_run`'s `ρ₀.hasFailure`. + change StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry ρ₀'.store ρ₀'.hasFailure) _ + rw [← hR_hf] + exact h_run + · -- ===== CanFail ARM (CanFail L₁ ss ρ₀ → CanFail L₂ (pipeline ss) ρ₀') ===== + -- Source failing run is from ρ₀; target must fail from ρ₀'. This is exactly + -- the `pipeline_to_fail` shape (structured passes from ρ₀, S2U from + -- σ_ext := ρ₀'.store), with the structured-pass bridge taken at ρ₀. + intro h_src + by_cases h_ρ₀_fail : ρ₀.hasFailure = true + · -- ρ₀ already failing ⟹ (hf-eq) ρ₀' failing: the CFG start config from + -- ρ₀'.store is itself failing, reachable by the reflexive run. + have h_ρ₀'_fail : ρ₀'.hasFailure = true := hR_hf ▸ h_ρ₀_fail + refine ⟨(⟨"", []⟩, .atBlock (pipeline ss).entry ρ₀'.store ρ₀'.hasFailure), + by simpa [Lang.cfg, CFGConfig.getFailure] using h_ρ₀'_fail, ?_⟩ + -- The start and target CFG configs coincide (defeq via the `Lang.cfg` abbrev), so + -- the reflexive run closes the goal directly. + exact ReflTrans.refl _ + · -- ρ₀ clean: run `pipeline_to_fail` from ρ₀ with σ_ext := ρ₀'.store. The + -- structured-pass failing bridge is discharged inside `pipeline_to_fail`. + have h_ρ₀_nofail : ρ₀.hasFailure = false := by simpa using h_ρ₀_fail + -- Source failing config + run from ρ₀ (`CanFail` reads star/getEnv/stmtCfg, + -- shared by `imperativeBlockSrc`). + obtain ⟨cfg_s, h_cfg_fail, h_cfg_reach⟩ := h_src + have h_reach : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) cfg_s := by + simpa [Lang.imperativeBlockSrc, Lang.imperativeBlock] using h_cfg_reach + have h_fail : cfg_s.getEnv.hasFailure = true := by + simpa [Lang.imperativeBlockSrc, Lang.imperativeBlock] using h_cfg_fail + obtain ⟨d, hd_run, hd_fail⟩ := + pipeline_to_fail extendEval ss ρ₀ cfg_s ρ₀'.store h_ρ₀_nofail + hpre.hwfb hpre.hwfv hpre.hwfvar' hpre.hwfcongr' hpre.hwfsubst' hpre.hwfdef' + hpre.h_store_inits hpre.h_store_mints_ndelim hpre.h_store_mints_hoist + hR_agree h_inits_ext h_ndelim_ext h_hoist_ext h_s2u_ext + hpre.h_nofd hpre.h_lhni hpre.h_nml hpre.h_unique hpre.h_fresh hpre.h_disj + hpre.h_ndelim_writes hpre.h_ndelim_exprs hpre.h_hoist_exprs + hpre.h_disj_initVars hpre.h_disj_modVars h_reach h_fail + -- `pipeline_to_fail` starts at `.atBlock _ ρ₀'.store ρ₀.hasFailure`; the CFG + -- language's `stmtCfg (pipeline ss) ρ₀'` starts at `ρ₀'.hasFailure`. Match + -- the start flag via the relation's `ρ₀.hasFailure = ρ₀'.hasFailure`. + rw [hR_hf] at hd_run + exact ⟨(⟨"", []⟩, d), by simpa [Lang.cfg, CFGConfig.getFailure] using hd_fail, + by simpa [Lang.cfg] using hd_run⟩ + · -- ===== target initEnvWF conjunct: `Lang.cfg.initEnvWF = fun _ _ _ => True` ===== + trivial + + +end Imperative diff --git a/Strata/Transform/DetToKleeneCorrect.lean b/Strata/Transform/DetToKleeneCorrect.lean index c4c3ba0d0d..4d83c530d3 100644 --- a/Strata/Transform/DetToKleeneCorrect.lean +++ b/Strata/Transform/DetToKleeneCorrect.lean @@ -30,7 +30,7 @@ public section open Imperative Specification -variable {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] +variable {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasVarsPure P P.Expr] /-! ## Lang instances -/ @@ -52,6 +52,8 @@ abbrev Lang.kleene : Lang P where exitingCfg := fun _ ρ => .terminal ρ isAtAssert := isAtKleeneAssert getEnv := KleeneConfig.getEnv + InitEnvWFParamsTy := Unit + initEnvWF := fun _ _ _ => True /-! ## Transform-success helpers: extract sub-transform results -/ @@ -240,7 +242,7 @@ where /-! ## ReflTransT decomposition helpers -/ omit [HasVal P] [HasBoolVal P] in -private theorem seqT_reaches_terminal +theorem seqT_reaches_terminal (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 ρ')) : @@ -257,7 +259,7 @@ private theorem seqT_reaches_terminal | .step _ _ _ h _ => exact nomatch h omit [HasVal P] [HasBoolVal P] in -private theorem stmtsT_cons_terminal +theorem stmtsT_cons_terminal (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 ρ')) : @@ -272,7 +274,7 @@ private theorem stmtsT_cons_terminal omit [HasVal P] [HasBoolVal P] in /-- Invert a block execution reaching terminal when the inner config cannot exit: the inner reaches terminal with a strictly shorter derivation. -/ -private theorem blockT_reaches_terminal_noExit +theorem blockT_reaches_terminal_noExit (extendEval : ExtendEval P) {inner : Config P (Cmd P)} {l : Option String} {σ_parent : SemanticStore P} {ρ' : Env P} (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.block l σ_parent inner) (.terminal ρ')) @@ -356,12 +358,14 @@ private def loop_sim (b : KleeneStmt P (Cmd P)) (sim_body : ∀ ρ₀ ρ', WellFormedSemanticEvalBool ρ₀.eval → WellFormedSemanticEvalVal ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ') → StepKleeneStar P (EvalCmd P) (.stmt b ρ₀) (.terminal ρ')) (hcov : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks (P := P) (CmdT := Cmd P) [] body) (hnofd_body : Block.noFuncDecl body = true) (ρ₀ ρ' : Env P) (n : Nat) (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfcongr : WellFormedSemanticEvalExprCongr ρ₀.eval) (hstarT : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt (.loop (.det g) m ([] : List (String × P.Expr)) body md) ρ₀) (.terminal ρ')) (hlen : hstarT.len ≤ n) : @@ -416,22 +420,27 @@ private def loop_sim -- h_loop_T_T : .stmt (.loop ...) ρ_block →*T .terminal ρ' have h_assume : StepKleeneStar P (EvalCmd P) (.stmt (.cmd (.assume "guard" g md)) ρ₀) (.terminal ρ₀) := - kleene_assume_terminal hg hwfb + kleene_assume_terminal hg hwfb hwfcongr have hterm_body_eq : StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ_inner) := hρ₀_eq ▸ reflTransT_to_prop h_inner_term have h_sim_body : StepKleeneStar P (EvalCmd P) (.stmt b ρ₀) (.terminal ρ_inner) := - sim_body ρ₀ ρ_inner hwfb hwfv hterm_body_eq + sim_body ρ₀ ρ_inner hwfb hwfv hwfcongr hterm_body_eq have h_kleene_assume_b : StepKleeneStar P (EvalCmd P) (.stmt (.seq (.cmd (.assume "guard" g md)) b) ρ₀) (.terminal ρ_inner) := kleene_seq_terminal _ b ρ₀ ρ₀ ρ_inner h_assume h_sim_body + have heval_eq : ρ_inner.eval = ρ₀.eval := + block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ₀ ρ_inner hnofd_body hterm_body_eq have hwfv_inner : WellFormedSemanticEvalVal ρ_inner.eval := by - have := block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ₀ ρ_inner hnofd_body hterm_body_eq - rw [this]; exact hwfv + rw [heval_eq]; exact hwfv + have hwfcongr_inner : WellFormedSemanticEvalExprCongr ρ_inner.eval := by + rw [heval_eq]; exact hwfcongr have hwfv_block : WellFormedSemanticEvalVal ρ_block.eval := by rw [heq_ρ_block]; exact hwfv_inner + have hwfcongr_block : WellFormedSemanticEvalExprCongr ρ_block.eval := by + rw [heq_ρ_block]; exact hwfcongr_inner have h_kleene_loop : StepKleeneStar P (EvalCmd P) (.stmt (.loop (.seq (.cmd (.assume "guard" g md)) b)) ρ_block) (.terminal _) := - ih ρ_block _ hwfv_block h_loop_T_T (by simp [ReflTransT.len] at hlen; omega) + ih ρ_block _ hwfv_block hwfcongr_block h_loop_T_T (by simp [ReflTransT.len] at hlen; omega) -- Build Kleene execution: step_loop_step → .seq (.block ρ₀.store (.stmt (assume; b) ρ₀)) (.loop ...) -- Then use seq+block to reach (.terminal ρ_block) via h_kleene_assume_b + project. have heq_ρ_block_full : ρ_block = @@ -463,6 +472,7 @@ private def loop_sim_kleene (b : KleeneStmt P (Cmd P)) (sim_body : ∀ ρ₀ ρ', WellFormedSemanticEvalBool ρ₀.eval → WellFormedSemanticEvalVal ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ') → StepKleeneStar P (EvalCmd P) (.stmt b ρ₀) (.terminal ρ')) (hcov : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks (P := P) (CmdT := Cmd P) [] body) @@ -470,6 +480,7 @@ private def loop_sim_kleene (ρ₀ ρ' : Env P) (n : Nat) (hwfb : WellFormedSemanticEvalBool ρ₀.eval) (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfcongr : WellFormedSemanticEvalExprCongr ρ₀.eval) (hstarT : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt (.loop .nondet m ([] : List (String × P.Expr)) body md) ρ₀) (.terminal ρ')) (hlen : hstarT.len ≤ n) : @@ -517,20 +528,24 @@ private def loop_sim_kleene have hterm_body_eq : StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ_inner) := hρ₀_eq ▸ reflTransT_to_prop h_inner_term have h_sim_body : StepKleeneStar P (EvalCmd P) (.stmt b ρ₀) (.terminal ρ_inner) := - sim_body ρ₀ ρ_inner hwfb hwfv hterm_body_eq + sim_body ρ₀ ρ_inner hwfb hwfv hwfcongr hterm_body_eq + have heval_eq : ρ_inner.eval = ρ₀.eval := + block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ₀ ρ_inner hnofd_body hterm_body_eq have hwfv_inner : WellFormedSemanticEvalVal ρ_inner.eval := by - have := block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ₀ ρ_inner hnofd_body hterm_body_eq - rw [this]; exact hwfv + rw [heval_eq]; exact hwfv have hwfb_inner : WellFormedSemanticEvalBool ρ_inner.eval := by - have := block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ₀ ρ_inner hnofd_body hterm_body_eq - rw [this]; exact hwfb + rw [heval_eq]; exact hwfb + have hwfcongr_inner : WellFormedSemanticEvalExprCongr ρ_inner.eval := by + rw [heval_eq]; exact hwfcongr have hwfv_block : WellFormedSemanticEvalVal ρ_block.eval := by rw [heq_ρ_block]; exact hwfv_inner have hwfb_block : WellFormedSemanticEvalBool ρ_block.eval := by rw [heq_ρ_block]; exact hwfb_inner + have hwfcongr_block : WellFormedSemanticEvalExprCongr ρ_block.eval := by + rw [heq_ρ_block]; exact hwfcongr_inner have h_kleene_loop : StepKleeneStar P (EvalCmd P) (.stmt (.loop b) ρ_block) (.terminal _) := - ih ρ_block _ hwfb_block hwfv_block h_loop_T_T (by simp [ReflTransT.len] at hlen; omega) + ih ρ_block _ hwfb_block hwfv_block hwfcongr_block h_loop_T_T (by simp [ReflTransT.len] at hlen; omega) have heq_ρ_block_full : ρ_block = { ρ_inner with store := projectStore ρ₀.store ρ_inner.store } := by have : ρ₀'.store = ρ₀.store := by rw [hρ₀_eq] @@ -558,6 +573,7 @@ private theorem simulation st.sizeOf ≤ sz → StmtToKleeneStmt st = some ns → ∀ (ρ₀ ρ' : Env P), WellFormedSemanticEvalBool ρ₀.eval → WellFormedSemanticEvalVal ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → StepStmtStar P (EvalCmd P) extendEval (.stmt st ρ₀) (.terminal ρ') → StepKleeneStar P (EvalCmd P) (.stmt ns ρ₀) (.terminal ρ')) ∧ @@ -565,16 +581,17 @@ private theorem simulation Block.sizeOf bss ≤ sz → BlockToKleeneStmt bss = some ns → ∀ (ρ₀ ρ' : Env P), WellFormedSemanticEvalBool ρ₀.eval → WellFormedSemanticEvalVal ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → StepStmtStar P (EvalCmd P) extendEval (.stmts bss ρ₀) (.terminal ρ') → StepKleeneStar P (EvalCmd P) (.stmt ns ρ₀) (.terminal ρ')) := by induction sz with | zero => constructor - · intro st ns hsz ht ρ₀ ρ' _ _ hstar + · intro st ns hsz ht ρ₀ ρ' _ _ _ hstar match st with | .cmd _ | .block .. | .ite .. | .loop .. | .exit .. | .funcDecl .. | .typeDecl .. => simp_all [Stmt.sizeOf] - · intro bss ns hsz ht ρ₀ ρ' hwfb hwfv hstar + · intro bss ns hsz ht ρ₀ ρ' hwfb hwfv hwfcongr hstar match bss with | [] => simp [BlockToKleeneStmt.eq_1] at ht; subst ht @@ -584,7 +601,7 @@ private theorem simulation cases r1 with | refl => exact .step _ _ _ - (.step_cmd (EvalCmd.eval_assert_pass (eval_tt_is_tt ρ₀.eval ρ₀.store hwfv) hwfb)) + (.step_cmd (EvalCmd.eval_assert_pass (eval_tt_is_tt ρ₀.eval ρ₀.store hwfv) hwfb hwfcongr)) (by rw [assume_env_eq]; exact .refl _) | step _ _ _ h _ => exact nomatch h | s :: _ => simp_all [Block.sizeOf] @@ -592,7 +609,7 @@ private theorem simulation constructor -- ═══ Statement case ═══ - · intro st ns hsz ht ρ₀ ρ' hwfb hwfv hstar + · intro st ns hsz ht ρ₀ ρ' hwfb hwfv hwfcongr hstar match st with | .cmd c => simp [StmtToKleeneStmt.eq_1] at ht; subst ht @@ -618,7 +635,7 @@ private theorem simulation subst heq_ρ' exact .step _ _ _ .step_block (kleene_block_terminal ρ₀.store _ ρ_inner - (ih.2 bss b hsz_bss hb ρ₀ ρ_inner hwfb hwfv hterm)) + (ih.2 bss b hsz_bss hb ρ₀ ρ_inner hwfb hwfv hwfcongr hterm)) | .inr ⟨lbl, ρ_inner, hexit, _⟩ => exact absurd hexit (block_exitsCoveredByBlocks_noEscape P (EvalCmd P) extendEval bss (stmtToKleene_some_exitsCovered.blockHelper [] bss b hb) ρ₀ lbl ρ_inner) @@ -633,15 +650,15 @@ private theorem simulation | step_ite_true hcond hwfb => have : Block.sizeOf tss ≤ n := by simp_all [Stmt.sizeOf]; omega - have hnd := ih.2 tss t this ht_tss ρ₀ ρ' hwfb hwfv r1 - have h_assume := kleene_assume_terminal (label := "true_cond") (md := md) hcond hwfb + have hnd := ih.2 tss t this ht_tss ρ₀ ρ' hwfb hwfv hwfcongr r1 + have h_assume := kleene_assume_terminal (label := "true_cond") (md := md) hcond hwfb hwfcongr exact .step _ _ _ .step_choice_left (kleene_seq_terminal _ t ρ₀ ρ₀ ρ' h_assume hnd) | step_ite_false hcond hwfb => have : Block.sizeOf ess ≤ n := by simp_all [Stmt.sizeOf]; omega - have hnd := ih.2 ess e this ht_ess ρ₀ ρ' hwfb hwfv r1 - have h_assume := kleene_assume_terminal (label := "false_cond") (md := md) ((hwfb ρ₀.store c).2.mp hcond) hwfb + have hnd := ih.2 ess e this ht_ess ρ₀ ρ' hwfb hwfv hwfcongr r1 + have h_assume := kleene_assume_terminal (label := "false_cond") (md := md) ((hwfb ρ₀.store c).2.mp hcond) hwfb hwfcongr exact .step _ _ _ .step_choice_right (kleene_seq_terminal _ e ρ₀ ρ₀ ρ' h_assume hnd) | .nondet => @@ -653,12 +670,12 @@ private theorem simulation have : Block.sizeOf tss ≤ n := by simp_all [Stmt.sizeOf]; omega exact .step _ _ _ .step_choice_left - (ih.2 tss t this ht_tss ρ₀ ρ' hwfb hwfv r1) + (ih.2 tss t this ht_tss ρ₀ ρ' hwfb hwfv hwfcongr r1) | step_ite_nondet_false => have : Block.sizeOf ess ≤ n := by simp_all [Stmt.sizeOf]; omega exact .step _ _ _ .step_choice_right - (ih.2 ess e this ht_ess ρ₀ ρ' hwfb hwfv r1) + (ih.2 ess e this ht_ess ρ₀ ρ' hwfb hwfv hwfcongr r1) | .loop guard m' inv body md => match guard with @@ -670,14 +687,15 @@ private theorem simulation simp_all [Stmt.sizeOf]; omega have sim_body : ∀ ρ₀ ρ', WellFormedSemanticEvalBool ρ₀.eval → WellFormedSemanticEvalVal ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ') → StepKleeneStar P (EvalCmd P) (.stmt b ρ₀) (.terminal ρ') := - fun ρ₀ ρ' hwfb' hwfv' h => ih.2 body b hsz_body hb ρ₀ ρ' hwfb' hwfv' h + fun ρ₀ ρ' hwfb' hwfv' hwfcongr' h => ih.2 body b hsz_body hb ρ₀ ρ' hwfb' hwfv' hwfcongr' h have hcov := stmtToKleene_some_exitsCovered.blockHelper [] body b hb have hnofd_body : Block.noFuncDecl body = true := stmtToKleene_some_noFuncDecl.blockHelper body b hb have hstarT := reflTrans_to_T hstar - exact loop_sim extendEval g m' body md b sim_body hcov hnofd_body ρ₀ ρ' hstarT.len hwfv + exact loop_sim extendEval g m' body md b sim_body hcov hnofd_body ρ₀ ρ' hstarT.len hwfv hwfcongr hstarT (Nat.le_refl _) | .nondet => have ⟨hinv_empty, b, hb, hns⟩ := loop_transform_some_nondet m' inv body md ns ht @@ -687,22 +705,23 @@ private theorem simulation simp_all [Stmt.sizeOf]; omega have sim_body : ∀ ρ₀ ρ', WellFormedSemanticEvalBool ρ₀.eval → WellFormedSemanticEvalVal ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ') → StepKleeneStar P (EvalCmd P) (.stmt b ρ₀) (.terminal ρ') := - fun ρ₀ ρ' hwfb' hwfv' h => ih.2 body b hsz_body hb ρ₀ ρ' hwfb' hwfv' h + fun ρ₀ ρ' hwfb' hwfv' hwfcongr' h => ih.2 body b hsz_body hb ρ₀ ρ' hwfb' hwfv' hwfcongr' h have hcov := stmtToKleene_some_exitsCovered.blockHelper [] body b hb have hnofd_body : Block.noFuncDecl body = true := stmtToKleene_some_noFuncDecl.blockHelper body b hb have hstarT := reflTrans_to_T hstar exact loop_sim_kleene extendEval m' body md b sim_body hcov hnofd_body ρ₀ ρ' - hstarT.len hwfb hwfv hstarT (Nat.le_refl _) + hstarT.len hwfb hwfv hwfcongr hstarT (Nat.le_refl _) | .typeDecl _ _ => simp [StmtToKleeneStmt.eq_5] at ht | .exit _ _ => simp [StmtToKleeneStmt.eq_6] at ht | .funcDecl _ _ => simp [StmtToKleeneStmt.eq_7] at ht -- ═══ Block case ═══ - · intro bss ns hsz ht ρ₀ ρ' hwfb hwfv hstar + · intro bss ns hsz ht ρ₀ ρ' hwfb hwfv hwfcongr hstar match bss with | [] => simp [BlockToKleeneStmt.eq_1] at ht; subst ht @@ -712,7 +731,7 @@ private theorem simulation cases r1 with | refl => exact .step _ _ _ - (.step_cmd (EvalCmd.eval_assert_pass (eval_tt_is_tt ρ₀.eval ρ₀.store hwfv) hwfb)) + (.step_cmd (EvalCmd.eval_assert_pass (eval_tt_is_tt ρ₀.eval ρ₀.store hwfv) hwfb hwfcongr)) (by rw [assume_env_eq]; exact .refl _) | step _ _ _ h _ => exact nomatch h @@ -732,9 +751,10 @@ private theorem simulation s ρ₀ ρ₁ hnofd hterm_s have hwfb₁ : WellFormedSemanticEvalBool ρ₁.eval := heval_eq ▸ hwfb have hwfv₁ : WellFormedSemanticEvalVal ρ₁.eval := heval_eq ▸ hwfv + have hwfcongr₁ : WellFormedSemanticEvalExprCongr ρ₁.eval := heval_eq ▸ hwfcongr exact kleene_seq_terminal s' rest' ρ₀ ρ₁ ρ' - (ih.1 s s' hsz_s hs ρ₀ ρ₁ hwfb hwfv hterm_s) - (ih.2 rest rest' hsz_r hr ρ₁ ρ' hwfb₁ hwfv₁ hterm_rest) + (ih.1 s s' hsz_s hs ρ₀ ρ₁ hwfb hwfv hwfcongr hterm_s) + (ih.2 rest rest' hsz_r hr ρ₁ ρ' hwfb₁ hwfv₁ hwfcongr₁ hterm_rest) /-- If det stmt reaches terminal, Kleene transform reaches terminal. -/ theorem stmtToKleene_terminal @@ -744,9 +764,10 @@ theorem stmtToKleene_terminal (ρ₀ ρ' : Env P) (hwfb : WellFormedSemanticEvalBool ρ₀.eval) (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfcongr : WellFormedSemanticEvalExprCongr ρ₀.eval) (hstar : StepStmtStar P (EvalCmd P) extendEval (.stmt st ρ₀) (.terminal ρ')) : StepKleeneStar P (EvalCmd P) (.stmt ns ρ₀) (.terminal ρ') := - (simulation extendEval st.sizeOf).1 st ns (Nat.le_refl _) ht ρ₀ ρ' hwfb hwfv hstar + (simulation extendEval st.sizeOf).1 st ns (Nat.le_refl _) ht ρ₀ ρ' hwfb hwfv hwfcongr hstar /-- If det block reaches terminal, Kleene transform reaches terminal. -/ theorem blockToKleene_terminal @@ -756,9 +777,10 @@ theorem blockToKleene_terminal (ρ₀ ρ' : Env P) (hwfb : WellFormedSemanticEvalBool ρ₀.eval) (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfcongr : WellFormedSemanticEvalExprCongr ρ₀.eval) (hstar : StepStmtStar P (EvalCmd P) extendEval (.stmts bss ρ₀) (.terminal ρ')) : StepKleeneStar P (EvalCmd P) (.stmt ns ρ₀) (.terminal ρ') := - (simulation extendEval (Block.sizeOf bss)).2 bss ns (Nat.le_refl _) ht ρ₀ ρ' hwfb hwfv hstar + (simulation extendEval (Block.sizeOf bss)).2 bss ns (Nat.le_refl _) ht ρ₀ ρ' hwfb hwfv hwfcongr hstar /-! ## Main theorem -/ @@ -771,9 +793,9 @@ theorem detToKleene_overapproximates (extendEval : ExtendEval P) : Transform.Overapproximates (Lang.det extendEval) (Lang.kleene (P := P)) (StmtToKleeneStmt (P := P)) := by - intro st ns ht ρ₀ ρ' hwfb hwfv + intro st ns ht ρ₀ ρ' hwfb hwfv hwfcongr refine ⟨?_, ?_⟩ - · exact stmtToKleene_terminal extendEval st ns ht ρ₀ ρ' hwfb hwfv + · exact stmtToKleene_terminal extendEval st ns ht ρ₀ ρ' hwfb hwfv hwfcongr · intro lbl hstar exact absurd hstar (exitsCoveredByBlocks_noEscape P (EvalCmd P) extendEval st (stmtToKleene_some_exitsCovered [] st ns ht) ρ₀ lbl ρ') diff --git a/Strata/Transform/GenSuffix.lean b/Strata/Transform/GenSuffix.lean new file mode 100644 index 0000000000..4d71c041a8 --- /dev/null +++ b/Strata/Transform/GenSuffix.lean @@ -0,0 +1,35 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.PureExpr + +public section + +namespace Strata.Transform.GenSuffix + +open Imperative + +/-- `NoGenSuffix Q xs` says no name `xs` carries is the image of a `Q`-kind +string — equivalently, every ident in `xs` was supplied by user source. Stated +*kind-first*: for every string `s` satisfying the label-kind predicate `Q` (the +kind of label this pass mints), `HasIdent.ident s` is absent from `xs`. +Instantiating `Q := HasUnderscoreDigitSuffix` recovers the blanket "no statement +writes a gen-shaped variable" condition; a per-kind `Q` lets a composition +partner satisfy the obligation by minting under a disjoint prefix. + +The kind-first shape matches the leaf of `exprsShapeFree` and the consumer +freshness obligations downstream, so the threaded facts feed those consumers by +definitional unfolding. + +Lives in a low base module so multiple correctness passes can reuse it without +pulling in any heavy transform closure. -/ +abbrev NoGenSuffix {P : PureExpr} [HasIdent P] + (Q : String → Prop) + (xs : List P.Ident) : Prop := + ∀ s : String, Q s → HasIdent.ident (P := P) s ∉ xs + +end Strata.Transform.GenSuffix diff --git a/Strata/Transform/LoopInitHoist.lean b/Strata/Transform/LoopInitHoist.lean new file mode 100644 index 0000000000..1478850e1e --- /dev/null +++ b/Strata/Transform/LoopInitHoist.lean @@ -0,0 +1,2493 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.DL.Util.LabelGen + +public section + +namespace Imperative + +open LabelGen (StringGenM) + +/-! # `hoistLoopPrefixInits` — structured-to-structured pass (Option E) + +A pass that transforms a `List (Stmt P (Cmd P))` so that every `.loop` body +contains no `.init` commands at any nesting level. Concretely, the output +satisfies `Block.loopBodyNoInits = true`. + +**Option E (fresh names + substitution, sibling placement, NO wrapper).** + +Strategy (post-order traversal): at every `.loop _ _ _ body _`, recurse into +`body` first (so nested loops are already hoist-processed), then call +`liftInitsInLoopBodyM` to walk the body and collect every `.init` reachable +through `.block` and `.ite` substructures (but not into nested loops, which +are already processed). For each collected init `init y ty rhs md`: + +* a *fresh* name `y'` is allocated from a `StringGenState` via + `StringGenState.gen` (injected into `P.Ident` by `HasIdent.ident`); +* a prelude havoc `init y' ty .nondet md` is emitted as a SIBLING placed + *before* the rewritten loop (no wrapper block — the wrapper was eliminated + by design: fresh names are hoist-only and excluded from the conclusion's + frame, so no `projectStore`-strip is needed); and +* the loop body is rewritten by `substIdent y y'` so that every occurrence of + `y` (including the lifted init's own `set` and any sibling references) now + reads/writes the fresh `y'`. + +Because the fresh names are produced by a single monotone `StringGenState`, +they are globally unique (`StringGenState.GenStep.subset`); in particular each +`y'` is disjoint from every source name and from every other generated name. + +The pass is therefore monadic in `StringGenM = StateM StringGenState`. The +pure top-level wrapper `Block.hoistLoopPrefixInits` runs the monadic pass from +the empty state and discards the final state. + +The transformation is purely structural — the preservation/postcondition +theorems are Phase 8's job (deferred under Option E: the previous same-name +postcondition proofs were stated against the old pure pass shape and are +re-derived against the monadic fresh-name pass in a later phase). This file +keeps only the pass definitions plus the shape-independent helper lemmas and +structural predicates (`allLoopBodiesInitFree`, `loopMeasureNone`) consumed by +the downstream proof files. +-/ + +/-- The fixed prefix used when allocating fresh hoist names. Uniqueness comes +from the underlying `StringGenState` counter, not from the prefix; the prefix +only makes generated names human-recognisable. -/ +@[expose] def hoistFreshPrefix : String := "_hoist" + +mutual +/-- Walk a loop body, collecting every init at any depth. For each init +`init y ty rhs md` a fresh name `y'` is generated; the prelude havoc +`init y' ty .nondet md` is harvested and the rename pair `(y, y')` recorded. +Does NOT recurse into nested `.loop` substructures (those are already +hoist-processed in post-order, so their bodies are init-free). + +Returns a triple `(havocs, renames, body')`: +* `havocs` is the list of prelude commands `init y' ty .nondet md` (fresh lhs), +* `renames` is the list of `(y, y')` rename pairs to be applied to the body, +* `body'` is `s` with each lifted init rewritten as `Cmd.set y rhs md` (the + *original* name `y`; the rename to `y'` is applied uniformly by the caller + via `applyRenames`, so that sibling references to `y` are renamed too). + +The computation threads a `StringGenState` (so it lives in `StringGenM`). -/ +@[expose] def Stmt.liftInitsInLoopBodyM {P : PureExpr} [HasIdent P] + (s : Stmt P (Cmd P)) : + StringGenM (List (Cmd P) × List (P.Ident × P.Ident) × List (Stmt P (Cmd P))) := + match s with + | .cmd (.init y ty rhs md) => fun σ => + let (fresh, σ') := StringGenState.gen hoistFreshPrefix σ + let y' := HasIdent.ident fresh + (([.init y' ty .nondet md], [(y, y')], [.cmd (.set y rhs md)]), σ') + | .cmd c => fun σ => (([], [], [.cmd c]), σ) + | .block lbl bss md => fun σ => + let ((hs, rn, bss'), σ') := Block.liftInitsInLoopBodyM bss σ + ((hs, rn, [.block lbl bss' md]), σ') + | .ite g tss ess md => fun σ => + let ((ths, trn, tss'), σ₁) := Block.liftInitsInLoopBodyM tss σ + let ((ehs, ern, ess'), σ₂) := Block.liftInitsInLoopBodyM ess σ₁ + ((ths ++ ehs, trn ++ ern, [.ite g tss' ess' md]), σ₂) + | .loop g m inv body md => fun σ => (([], [], [.loop g m inv body md]), σ) + | .exit lbl md => fun σ => (([], [], [.exit lbl md]), σ) + | .funcDecl d md => fun σ => (([], [], [.funcDecl d md]), σ) + | .typeDecl t md => fun σ => (([], [], [.typeDecl t md]), σ) + termination_by sizeOf s + +/-- Apply `Stmt.liftInitsInLoopBodyM` to every statement in the block, +threading the `StringGenState` and concatenating the harvested havocs, +rename pairs, and rewritten residuals. -/ +@[expose] def Block.liftInitsInLoopBodyM {P : PureExpr} [HasIdent P] + (ss : List (Stmt P (Cmd P))) : + StringGenM (List (Cmd P) × List (P.Ident × P.Ident) × List (Stmt P (Cmd P))) := + match ss with + | [] => fun σ => (([], [], []), σ) + | s :: rest => fun σ => + let ((hs_s, rn_s, ss_s), σ₁) := Stmt.liftInitsInLoopBodyM s σ + let ((hs_r, rn_r, ss_r), σ₂) := Block.liftInitsInLoopBodyM rest σ₁ + ((hs_s ++ hs_r, rn_s ++ rn_r, ss_s ++ ss_r), σ₂) + termination_by sizeOf ss +end + +/-! ## Pure surface wrapper (old pair shape) + +The Option-E pass is monadic and returns a TRIPLE +`(havocs, renames, residual)` inside `StringGenM`. Much downstream +structural reasoning only consumes the RESIDUAL (`.snd` in the old API) +and/or the harvested havoc prelude (`.fst` in the old API), and is agnostic +to the rename-pair component and to the concrete fresh names that the +generator produced. For those shape-only sites we expose a pure projection +`Stmt/Block.liftInitsInLoopBody` that recovers the old pair shape +`(havocs, residual)` by running the monadic pass from a FIXED initial state +(`StringGenState.emp`) and dropping the rename-pair component. + +CAUTION: the `.fst` havocs are the FRESH-name havocs (`init y' ty .nondet md` +with `y'` generated from the empty state); they are NOT the source names, so +any lemma that asserts the havoc lhs lies in the source `initVars` is FALSE +under Option E and must be reformulated (output inits are fresh names, by +design). The `.snd` residual is independent of the start state (only the +fresh `.fst` names depend on it), so every shape-only postcondition over the +residual ports through the wrapper unchanged. -/ + +/-- Pure surface projection of `Stmt.liftInitsInLoopBodyM`: run from the empty +generator state and keep the `(havocs, residual)` pair (dropping the +rename-pair component). See the caution above on fresh `.fst` names. -/ +@[expose] def Stmt.liftInitsInLoopBody {P : PureExpr} [HasIdent P] + (s : Stmt P (Cmd P)) : List (Cmd P) × List (Stmt P (Cmd P)) := + let r := (Stmt.liftInitsInLoopBodyM s StringGenState.emp).1 + (r.1, r.2.2) + +/-- Pure surface projection of `Block.liftInitsInLoopBodyM`: run from the +empty generator state and keep the `(havocs, residual)` pair. -/ +@[expose] def Block.liftInitsInLoopBody {P : PureExpr} [HasIdent P] + (ss : List (Stmt P (Cmd P))) : List (Cmd P) × List (Stmt P (Cmd P)) := + let r := (Block.liftInitsInLoopBodyM ss StringGenState.emp).1 + (r.1, r.2.2) + +/-- Fold a list of `(y, y')` rename pairs over a block via `Block.substIdent`. +Because every `y'` is a fresh generated name distinct from all the `y`s and +from each other, the renames are independent of application order. -/ +@[expose] def Block.applyRenames {P : PureExpr} + [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + List (Stmt P (Cmd P)) := + renames.foldl (fun acc p => Block.substIdent p.1 p.2 acc) ss + +mutual +/-- Top-level pass (monadic): post-order traversal threading a +`StringGenState`. For a `.loop`, recurse into the body first (so nested loops +are hoist-processed), then call `Block.liftInitsInLoopBodyM` on the +post-processed body to collect this loop's body inits with fresh names. The +fresh havocs are emitted as SIBLING commands *before* the rewritten loop, and +the body is renamed via `Block.applyRenames` so it reads/writes the fresh +names. For `.block` and `.ite`, recurse structurally. Other statements are +identity (returned as a singleton list). -/ +@[expose] def Stmt.hoistLoopPrefixInitsM {P : PureExpr} + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) : StringGenM (List (Stmt P (Cmd P))) := + match s with + | .cmd c => fun σ => ([.cmd c], σ) + | .block lbl bss md => fun σ => + let (bss', σ') := Block.hoistLoopPrefixInitsM bss σ + ([.block lbl bss' md], σ') + | .ite g tss ess md => fun σ => + let (tss', σ₁) := Block.hoistLoopPrefixInitsM tss σ + let (ess', σ₂) := Block.hoistLoopPrefixInitsM ess σ₁ + ([.ite g tss' ess' md], σ₂) + | .loop g m inv body md => fun σ => + let (body₁, σ₁) := Block.hoistLoopPrefixInitsM body σ + let ((havocs, renames, body₂), σ₂) := Block.liftInitsInLoopBodyM body₁ σ₁ + let body₃ := Block.applyRenames renames body₂ + (havocs.map Stmt.cmd ++ [.loop g m inv body₃ md], σ₂) + | .exit lbl md => fun σ => ([.exit lbl md], σ) + | .funcDecl d md => fun σ => ([.funcDecl d md], σ) + | .typeDecl t md => fun σ => ([.typeDecl t md], σ) + termination_by sizeOf s + +/-- Apply `Stmt.hoistLoopPrefixInitsM` to each statement of the block, +threading the `StringGenState` and concatenating the resulting lists. -/ +@[expose] def Block.hoistLoopPrefixInitsM {P : PureExpr} + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) : StringGenM (List (Stmt P (Cmd P))) := + match ss with + | [] => fun σ => ([], σ) + | s :: rest => fun σ => + let (ss_s, σ₁) := Stmt.hoistLoopPrefixInitsM s σ + let (ss_r, σ₂) := Block.hoistLoopPrefixInitsM rest σ₁ + (ss_s ++ ss_r, σ₂) + termination_by sizeOf ss +end + +/-- Pure top-level wrapper: run the monadic fresh-name pass from the empty +`StringGenState` and discard the final state. -/ +@[expose] def Block.hoistLoopPrefixInits {P : PureExpr} + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) : List (Stmt P (Cmd P)) := + (Block.hoistLoopPrefixInitsM ss StringGenState.emp).1 + +/-- Pure statement-level wrapper: run the monadic fresh-name pass from the +empty `StringGenState` and discard the final state. -/ +@[expose] def Stmt.hoistLoopPrefixInits {P : PureExpr} + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) : List (Stmt P (Cmd P)) := + (Stmt.hoistLoopPrefixInitsM s StringGenState.emp).1 + +/-! ## Shape-independent helper lemmas + +These distribute the structural Bool walkers over `++` and assert their +triviality on `.cmd`-only prelude lists. They do not mention the hoist pass +itself, so they survive the Option E pass rewrite unchanged and are consumed +by the downstream proof files. -/ + +/-- Concatenation distributes over `Block.initVars`. -/ +private theorem Block.initVars_append {P : PureExpr} + (xs ys : List (Stmt P (Cmd P))) : + Block.initVars (xs ++ ys) = Block.initVars xs ++ Block.initVars ys := by + induction xs with + | nil => simp [Block.initVars] + | cons x rest ih => + simp [ih, List.append_assoc] + +/-! ## Phase 8 §E5 (Option A): strengthened structural predicate + +`Block.allLoopBodiesInitFree` mirrors `Block.loopBodyNoInits` but uses +`Block.noInitsAnywhere` at the `.loop` arm instead of just +`(Block.initVars _).isEmpty`, capturing that every `.loop` body contains no +`.init` commands at ANY nesting depth (including inside `.block` and `.ite` +substructures of the loop body). The postcondition that the pass output +satisfies this predicate is deferred (re-derived against the monadic +fresh-name pass in a later phase). -/ + +mutual +/-- Returns true if every `.loop` body in `s` contains no `.init` commands +at any nesting depth. Recurses through `.ite`, `.block`, and `.loop` to +enforce the restriction at every loop nesting level. -/ +@[expose] def Stmt.allLoopBodiesInitFree {P : PureExpr} + (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd _ => true + | .block _ bss _ => Block.allLoopBodiesInitFree bss + | .ite _ tss ess _ => + Block.allLoopBodiesInitFree tss && Block.allLoopBodiesInitFree ess + | .loop _ _ _ bss _ => + Block.noInitsAnywhere bss && Block.allLoopBodiesInitFree bss + | .exit _ _ => true + | .funcDecl _ _ => true + | .typeDecl _ _ => true + termination_by sizeOf s + +/-- Returns true if every `.loop` body in `ss` contains no `.init` commands +at any nesting depth. -/ +@[expose] def Block.allLoopBodiesInitFree {P : PureExpr} + (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => true + | s :: srest => + Stmt.allLoopBodiesInitFree s && Block.allLoopBodiesInitFree srest + termination_by sizeOf ss +end + +/-- Concatenation distributes over `Block.allLoopBodiesInitFree`. -/ +private theorem Block.allLoopBodiesInitFree_append {P : PureExpr} + (xs ys : List (Stmt P (Cmd P))) : + Block.allLoopBodiesInitFree (xs ++ ys) = + (Block.allLoopBodiesInitFree xs && Block.allLoopBodiesInitFree ys) := by + induction xs with + | nil => simp [Block.allLoopBodiesInitFree] + | cons x rest ih => + simp [Block.allLoopBodiesInitFree, ih, Bool.and_assoc] + +/-- Concatenation distributes over `Block.noInitsAnywhere`. -/ +private theorem Block.noInitsAnywhere_append {P : PureExpr} + (xs ys : List (Stmt P (Cmd P))) : + Block.noInitsAnywhere (xs ++ ys) = + (Block.noInitsAnywhere xs && Block.noInitsAnywhere ys) := by + induction xs with + | nil => simp [Block.noInitsAnywhere] + | cons x rest ih => + simp [Block.noInitsAnywhere, ih, Bool.and_assoc] + +/-- A list of non-init `.cmd`s contributes trivially to +`Block.allLoopBodiesInitFree`. -/ +private theorem Block.allLoopBodiesInitFree_map_cmd {P : PureExpr} + (cs : List (Cmd P)) : + Block.allLoopBodiesInitFree (cs.map Stmt.cmd) = true := by + induction cs with + | nil => simp [Block.allLoopBodiesInitFree] + | cons c rest ih => + simp [List.map_cons, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree, ih] + +/-! ## Phase 8 §B: `loopMeasureNone` predicate + +A boolean walker that asserts `m.isNone` at every `.loop` node and recurses +through every structural substructure (`.block`, `.ite`, `.loop` body). +Programs carrying explicit termination measures are out of scope for the +hoisting pass's correctness statement until measure-aware variants land in +Phase 9. -/ + +mutual +/-- Returns true if every `.loop` in `s` (and any nested loop) has +`measure = none`. -/ +@[expose] def Stmt.loopMeasureNone {P : PureExpr} (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd _ => true + | .block _ bss _ => Block.loopMeasureNone bss + | .ite _ tss ess _ => Block.loopMeasureNone tss && Block.loopMeasureNone ess + | .loop _ m _ bss _ => m.isNone && Block.loopMeasureNone bss + | .exit _ _ => true + | .funcDecl _ _ => true + | .typeDecl _ _ => true + termination_by sizeOf s + +/-- Returns true if every `.loop` in `ss` (and any nested loops) has +`measure = none`. -/ +@[expose] def Block.loopMeasureNone {P : PureExpr} + (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => true + | s :: srest => Stmt.loopMeasureNone s && Block.loopMeasureNone srest + termination_by sizeOf ss +end + +/-- `Block.loopMeasureNone` distributes over `++`. -/ +private theorem Block.loopMeasureNone_append {P : PureExpr} + (xs ys : List (Stmt P (Cmd P))) : + Block.loopMeasureNone (xs ++ ys) = + (Block.loopMeasureNone xs && Block.loopMeasureNone ys) := by + induction xs with + | nil => simp [Block.loopMeasureNone] + | cons x rest ih => + simp [Block.loopMeasureNone, ih, Bool.and_assoc] + +/-- A list of `.cmd`s trivially has `loopMeasureNone = true`. -/ +private theorem Block.loopMeasureNone_map_cmd {P : PureExpr} + (cs : List (Cmd P)) : + Block.loopMeasureNone (cs.map Stmt.cmd) = true := by + induction cs with + | nil => simp [Block.loopMeasureNone] + | cons c rest ih => + simp [List.map_cons, Block.loopMeasureNone, Stmt.loopMeasureNone, ih] + +/-- `Block.simpleShape` distributes over `++`. -/ +private theorem Block.simpleShape_append {P : PureExpr} + (xs ys : List (Stmt P (Cmd P))) : + Block.simpleShape (xs ++ ys) = + (Block.simpleShape xs && Block.simpleShape ys) := by + induction xs with + | nil => simp [Block.simpleShape] + | cons x rest ih => + simp [Block.simpleShape, ih, Bool.and_assoc] + +/-- A list of `.cmd`s trivially has `simpleShape = true`. -/ +private theorem Block.simpleShape_map_cmd {P : PureExpr} + (cs : List (Cmd P)) : + Block.simpleShape (cs.map Stmt.cmd) = true := by + induction cs with + | nil => simp [Block.simpleShape] + | cons c rest ih => + simp [List.map_cons, Block.simpleShape, Stmt.simpleShape, ih] + +/-- `Block.containsNondetLoop` distributes over `++`. -/ +private theorem Block.containsNondetLoop_append {P : PureExpr} + (xs ys : List (Stmt P (Cmd P))) : + Block.containsNondetLoop (xs ++ ys) = + (Block.containsNondetLoop xs || Block.containsNondetLoop ys) := by + induction xs with + | nil => simp [Block.containsNondetLoop] + | cons x rest ih => simp [Block.containsNondetLoop, ih, Bool.or_assoc] + +/-- A list of `.cmd`s never contains a nondet loop. -/ +private theorem Block.containsNondetLoop_map_cmd {P : PureExpr} + (cs : List (Cmd P)) : + Block.containsNondetLoop (cs.map Stmt.cmd) = false := by + induction cs with + | nil => simp [Block.containsNondetLoop] + | cons c rest ih => + simp [List.map_cons, Block.containsNondetLoop, Stmt.containsNondetLoop, ih] + +/-- `Block.containsFuncDecl` distributes over `++`. -/ +private theorem Block.containsFuncDecl_append {P : PureExpr} + (xs ys : List (Stmt P (Cmd P))) : + Block.containsFuncDecl (xs ++ ys) = + (Block.containsFuncDecl xs || Block.containsFuncDecl ys) := by + induction xs with + | nil => simp [Block.containsFuncDecl] + | cons x rest ih => simp [Block.containsFuncDecl, ih, Bool.or_assoc] + +/-- A list of `.cmd`s never contains a funcDecl. -/ +private theorem Block.containsFuncDecl_map_cmd {P : PureExpr} + (cs : List (Cmd P)) : + Block.containsFuncDecl (cs.map Stmt.cmd) = false := by + induction cs with + | nil => simp [Block.containsFuncDecl] + | cons c rest ih => + simp [List.map_cons, Block.containsFuncDecl, Stmt.containsFuncDecl, ih] + +/-- `Block.loopHasNoInvariants` distributes over `++`. -/ +private theorem Block.loopHasNoInvariants_append {P : PureExpr} + (xs ys : List (Stmt P (Cmd P))) : + Block.loopHasNoInvariants (xs ++ ys) = + (Block.loopHasNoInvariants xs && Block.loopHasNoInvariants ys) := by + induction xs with + | nil => simp [Block.loopHasNoInvariants] + | cons x rest ih => simp [Block.loopHasNoInvariants, ih, Bool.and_assoc] + +/-- A list of `.cmd`s trivially has `loopHasNoInvariants = true`. -/ +private theorem Block.loopHasNoInvariants_map_cmd {P : PureExpr} + (cs : List (Cmd P)) : + Block.loopHasNoInvariants (cs.map Stmt.cmd : List (Stmt P (Cmd P))) = true := by + induction cs with + | nil => simp [Block.loopHasNoInvariants] + | cons c rest ih => + simp [List.map_cons, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, ih] + +/-! ## `substIdent` / `applyRenames` preserve the structural Bool predicates + +`Block.substIdent y y'` only renames identifiers; it never changes the +statement TREE shape (`.cmd`/`.block`/`.ite`/`.loop` stay put, `.init` stays +`.init` and `.set` stays `.set`). Consequently every structural Bool walker +that inspects only the tree shape (`loopBodyNoInits`, `noInitsAnywhere`, +`allLoopBodiesInitFree`, `loopMeasureNone`) is invariant under a rename, and +hence under `Block.applyRenames` (a fold of renames). `Block.initVars` is the +one walker that *does* track names: a rename preserves its LENGTH (each +`.init` lhs maps to exactly one new name), which is enough to preserve the +`(Block.initVars _).isEmpty` test used inside `loopBodyNoInits`. -/ + +section SubstIdentPreserves +variable {P : PureExpr} + +mutual +/-- `Stmt.substIdent` preserves the LENGTH of `initVars` (a rename maps each +`.init` lhs to exactly one new name). -/ +theorem Stmt.substIdent_initVars_length [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (s : Stmt P (Cmd P)) : + (Stmt.initVars (Stmt.substIdent y y' s)).length = (Stmt.initVars s).length := by + match s with + | .cmd c => cases c <;> simp [Cmd.substIdent, Stmt.initVars] + | .block lbl bss md => + simp only [Stmt.substIdent_block, Stmt.initVars_block] + exact Block.substIdent_initVars_length y y' bss + | .ite g tss ess md => + simp only [Stmt.substIdent_ite, Stmt.initVars_ite, List.length_append] + rw [Block.substIdent_initVars_length y y' tss, + Block.substIdent_initVars_length y y' ess] + | .loop g m inv bss md => + simp only [Stmt.substIdent_loop, Stmt.initVars_loop] + exact Block.substIdent_initVars_length y y' bss + | .exit lbl md => simp [Stmt.initVars] + | .funcDecl d md => simp [Stmt.initVars] + | .typeDecl t md => simp [Stmt.initVars] + termination_by sizeOf s + +theorem Block.substIdent_initVars_length [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) : + (Block.initVars (Block.substIdent y y' ss)).length = (Block.initVars ss).length := by + match ss with + | [] => simp [Block.initVars] + | s :: rest => + simp only [Block.substIdent, Block.initVars_cons, List.length_append] + rw [Stmt.substIdent_initVars_length y y' s, + Block.substIdent_initVars_length y y' rest] + termination_by sizeOf ss +end + +/-- `isEmpty` of `initVars` is invariant under a rename (via length). -/ +theorem Block.substIdent_initVars_isEmpty [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) : + (Block.initVars (Block.substIdent y y' ss)).isEmpty + = (Block.initVars ss).isEmpty := by + have hlen := Block.substIdent_initVars_length y y' ss + cases h₁ : Block.initVars (Block.substIdent y y' ss) <;> + cases h₂ : Block.initVars ss <;> + simp_all [List.isEmpty] + +mutual +/-- `Stmt.substIdent` preserves `noInitsAnywhere`. -/ +theorem Stmt.substIdent_noInitsAnywhere [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (s : Stmt P (Cmd P)) : + Stmt.noInitsAnywhere (Stmt.substIdent y y' s) = Stmt.noInitsAnywhere s := by + match s with + | .cmd c => cases c <;> simp [Cmd.substIdent, Stmt.noInitsAnywhere] + | .block lbl bss md => + simp only [Stmt.substIdent_block, Stmt.noInitsAnywhere] + exact Block.substIdent_noInitsAnywhere y y' bss + | .ite g tss ess md => + simp only [Stmt.substIdent_ite, Stmt.noInitsAnywhere] + rw [Block.substIdent_noInitsAnywhere y y' tss, + Block.substIdent_noInitsAnywhere y y' ess] + | .loop g m inv bss md => + simp only [Stmt.substIdent_loop, Stmt.noInitsAnywhere] + exact Block.substIdent_noInitsAnywhere y y' bss + | .exit lbl md => simp [Stmt.noInitsAnywhere] + | .funcDecl d md => simp [Stmt.noInitsAnywhere] + | .typeDecl t md => simp [Stmt.noInitsAnywhere] + termination_by sizeOf s + +theorem Block.substIdent_noInitsAnywhere [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) : + Block.noInitsAnywhere (Block.substIdent y y' ss) = Block.noInitsAnywhere ss := by + match ss with + | [] => simp [Block.noInitsAnywhere] + | s :: rest => + simp only [Block.substIdent, Block.noInitsAnywhere] + rw [Stmt.substIdent_noInitsAnywhere y y' s, + Block.substIdent_noInitsAnywhere y y' rest] + termination_by sizeOf ss +end + +mutual +/-- `Stmt.substIdent` preserves `allLoopBodiesInitFree`. -/ +theorem Stmt.substIdent_allLoopBodiesInitFree [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (s : Stmt P (Cmd P)) : + Stmt.allLoopBodiesInitFree (Stmt.substIdent y y' s) + = Stmt.allLoopBodiesInitFree s := by + match s with + | .cmd c => cases c <;> simp [Cmd.substIdent, Stmt.allLoopBodiesInitFree] + | .block lbl bss md => + simp only [Stmt.substIdent_block, Stmt.allLoopBodiesInitFree] + exact Block.substIdent_allLoopBodiesInitFree y y' bss + | .ite g tss ess md => + simp only [Stmt.substIdent_ite, Stmt.allLoopBodiesInitFree] + rw [Block.substIdent_allLoopBodiesInitFree y y' tss, + Block.substIdent_allLoopBodiesInitFree y y' ess] + | .loop g m inv bss md => + simp only [Stmt.substIdent_loop, Stmt.allLoopBodiesInitFree] + rw [Block.substIdent_noInitsAnywhere y y' bss, + Block.substIdent_allLoopBodiesInitFree y y' bss] + | .exit lbl md => simp [Stmt.allLoopBodiesInitFree] + | .funcDecl d md => simp [Stmt.allLoopBodiesInitFree] + | .typeDecl t md => simp [Stmt.allLoopBodiesInitFree] + termination_by sizeOf s + +theorem Block.substIdent_allLoopBodiesInitFree [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) : + Block.allLoopBodiesInitFree (Block.substIdent y y' ss) + = Block.allLoopBodiesInitFree ss := by + match ss with + | [] => simp [Block.allLoopBodiesInitFree] + | s :: rest => + simp only [Block.substIdent, Block.allLoopBodiesInitFree] + rw [Stmt.substIdent_allLoopBodiesInitFree y y' s, + Block.substIdent_allLoopBodiesInitFree y y' rest] + termination_by sizeOf ss +end + +mutual +/-- `Stmt.substIdent` preserves `loopMeasureNone` (a rename maps `m` via +`Option.map`, so `m.isNone` is unchanged). -/ +theorem Stmt.substIdent_loopMeasureNone [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (s : Stmt P (Cmd P)) : + Stmt.loopMeasureNone (Stmt.substIdent y y' s) = Stmt.loopMeasureNone s := by + match s with + | .cmd c => cases c <;> simp [Cmd.substIdent, Stmt.loopMeasureNone] + | .block lbl bss md => + simp only [Stmt.substIdent_block, Stmt.loopMeasureNone] + exact Block.substIdent_loopMeasureNone y y' bss + | .ite g tss ess md => + simp only [Stmt.substIdent_ite, Stmt.loopMeasureNone] + rw [Block.substIdent_loopMeasureNone y y' tss, + Block.substIdent_loopMeasureNone y y' ess] + | .loop g m inv bss md => + simp only [Stmt.substIdent_loop, Stmt.loopMeasureNone, Option.isNone_map] + rw [Block.substIdent_loopMeasureNone y y' bss] + | .exit lbl md => simp [Stmt.loopMeasureNone] + | .funcDecl d md => simp [Stmt.loopMeasureNone] + | .typeDecl t md => simp [Stmt.loopMeasureNone] + termination_by sizeOf s + +theorem Block.substIdent_loopMeasureNone [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) : + Block.loopMeasureNone (Block.substIdent y y' ss) = Block.loopMeasureNone ss := by + match ss with + | [] => simp [Block.loopMeasureNone] + | s :: rest => + simp only [Block.substIdent, Block.loopMeasureNone] + rw [Stmt.substIdent_loopMeasureNone y y' s, + Block.substIdent_loopMeasureNone y y' rest] + termination_by sizeOf ss +end + +/-! ### Lift `substIdent`-invariance through `applyRenames` (a fold of renames) -/ + +/-- `Block.applyRenames` preserves `noInitsAnywhere`. -/ +theorem Block.applyRenames_noInitsAnywhere [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + Block.noInitsAnywhere (Block.applyRenames renames ss) + = Block.noInitsAnywhere ss := by + unfold Block.applyRenames + induction renames generalizing ss with + | nil => simp + | cons p rest ih => + simp only [List.foldl_cons] + rw [ih (Block.substIdent p.1 p.2 ss), Block.substIdent_noInitsAnywhere] + +/-- `Block.applyRenames` preserves `allLoopBodiesInitFree`. -/ +theorem Block.applyRenames_allLoopBodiesInitFree [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + Block.allLoopBodiesInitFree (Block.applyRenames renames ss) + = Block.allLoopBodiesInitFree ss := by + unfold Block.applyRenames + induction renames generalizing ss with + | nil => simp + | cons p rest ih => + simp only [List.foldl_cons] + rw [ih (Block.substIdent p.1 p.2 ss), Block.substIdent_allLoopBodiesInitFree] + +/-- `Block.applyRenames` preserves `loopMeasureNone`. -/ +theorem Block.applyRenames_loopMeasureNone [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + Block.loopMeasureNone (Block.applyRenames renames ss) + = Block.loopMeasureNone ss := by + unfold Block.applyRenames + induction renames generalizing ss with + | nil => simp + | cons p rest ih => + simp only [List.foldl_cons] + rw [ih (Block.substIdent p.1 p.2 ss), Block.substIdent_loopMeasureNone] + +/-! ### `substIdent` / `applyRenames` preserve `simpleShape` + +`simpleShape` is a shape-only walker: it only inspects whether a guard is +`.det`/`.nondet`. A rename maps a `.det e` guard to `.det (substFvar …)` — +still `.det` — and recurses structurally, so the shape characteristic is +unchanged. These mirror the `loopMeasureNone` preservation chain above and +feed the `simpleShape`-preservation of the whole hoisting pass. -/ + +mutual +/-- `Stmt.substIdent` preserves `simpleShape`. -/ +theorem Stmt.substIdent_simpleShape [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (s : Stmt P (Cmd P)) : + Stmt.simpleShape (Stmt.substIdent y y' s) = Stmt.simpleShape s := by + match s with + | .cmd c => cases c <;> simp [Cmd.substIdent, Stmt.simpleShape] + | .block lbl bss md => + simp only [Stmt.substIdent_block, Stmt.simpleShape] + exact Block.substIdent_simpleShape y y' bss + | .ite (.det e) tss ess md => + simp only [Stmt.substIdent_ite, ExprOrNondet.substIdent_det, Stmt.simpleShape] + rw [Block.substIdent_simpleShape y y' tss, + Block.substIdent_simpleShape y y' ess] + | .ite .nondet tss ess md => + simp only [Stmt.substIdent_ite, ExprOrNondet.substIdent_nondet, Stmt.simpleShape] + | .loop (.det e) m inv bss md => + simp only [Stmt.substIdent_loop, ExprOrNondet.substIdent_det, Stmt.simpleShape] + rw [Block.substIdent_simpleShape y y' bss] + | .loop .nondet m inv bss md => + simp only [Stmt.substIdent_loop, ExprOrNondet.substIdent_nondet, Stmt.simpleShape] + rw [Block.substIdent_simpleShape y y' bss] + | .exit lbl md => simp [Stmt.simpleShape] + | .funcDecl d md => simp [Stmt.simpleShape] + | .typeDecl t md => simp [Stmt.simpleShape] + termination_by sizeOf s + +theorem Block.substIdent_simpleShape [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) : + Block.simpleShape (Block.substIdent y y' ss) = Block.simpleShape ss := by + match ss with + | [] => simp [Block.simpleShape] + | s :: rest => + simp only [Block.substIdent, Block.simpleShape] + rw [Stmt.substIdent_simpleShape y y' s, + Block.substIdent_simpleShape y y' rest] + termination_by sizeOf ss +end + +/-- `Block.applyRenames` preserves `simpleShape`. -/ +theorem Block.applyRenames_simpleShape [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + Block.simpleShape (Block.applyRenames renames ss) + = Block.simpleShape ss := by + unfold Block.applyRenames + induction renames generalizing ss with + | nil => simp + | cons p rest ih => + simp only [List.foldl_cons] + rw [ih (Block.substIdent p.1 p.2 ss), Block.substIdent_simpleShape] + +/-! ### `substIdent` / `applyRenames` preserve `containsNondetLoop`, +`containsFuncDecl`, `loopHasNoInvariants` + +All three are shape-only walkers. A rename keeps a `.loop` guard's `.det`/ +`.nondet` shape (`containsNondetLoop`), keeps `.funcDecl` constructors +(`containsFuncDecl`), and maps a loop's invariant list by `.map`, preserving +its length and hence `inv.isEmpty` (`loopHasNoInvariants`). -/ + +mutual +theorem Stmt.substIdent_containsNondetLoop [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (s : Stmt P (Cmd P)) : + Stmt.containsNondetLoop (Stmt.substIdent y y' s) = Stmt.containsNondetLoop s := by + match s with + | .cmd c => cases c <;> simp [Cmd.substIdent, Stmt.containsNondetLoop] + | .block lbl bss md => + simp only [Stmt.substIdent_block, Stmt.containsNondetLoop] + exact Block.substIdent_containsNondetLoop y y' bss + | .ite g tss ess md => + simp only [Stmt.substIdent_ite, Stmt.containsNondetLoop] + rw [Block.substIdent_containsNondetLoop y y' tss, + Block.substIdent_containsNondetLoop y y' ess] + | .loop g m inv bss md => + cases g <;> + simp [Stmt.substIdent_loop, Stmt.containsNondetLoop, ExprOrNondet.substIdent, + Block.substIdent_containsNondetLoop y y' bss] + | .exit lbl md => simp [Stmt.containsNondetLoop] + | .funcDecl d md => simp [Stmt.containsNondetLoop] + | .typeDecl t md => simp [Stmt.containsNondetLoop] + termination_by sizeOf s + +theorem Block.substIdent_containsNondetLoop [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) : + Block.containsNondetLoop (Block.substIdent y y' ss) = Block.containsNondetLoop ss := by + match ss with + | [] => simp [Block.containsNondetLoop] + | s :: rest => + simp only [Block.substIdent, Block.containsNondetLoop] + rw [Stmt.substIdent_containsNondetLoop y y' s, + Block.substIdent_containsNondetLoop y y' rest] + termination_by sizeOf ss +end + +mutual +theorem Stmt.substIdent_containsFuncDecl [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (s : Stmt P (Cmd P)) : + Stmt.containsFuncDecl (Stmt.substIdent y y' s) = Stmt.containsFuncDecl s := by + match s with + | .cmd c => cases c <;> simp [Cmd.substIdent, Stmt.containsFuncDecl] + | .block lbl bss md => + simp only [Stmt.substIdent_block, Stmt.containsFuncDecl] + exact Block.substIdent_containsFuncDecl y y' bss + | .ite g tss ess md => + simp only [Stmt.substIdent_ite, Stmt.containsFuncDecl] + rw [Block.substIdent_containsFuncDecl y y' tss, + Block.substIdent_containsFuncDecl y y' ess] + | .loop g m inv bss md => + simp only [Stmt.substIdent_loop, Stmt.containsFuncDecl] + exact Block.substIdent_containsFuncDecl y y' bss + | .exit lbl md => simp [Stmt.containsFuncDecl] + | .funcDecl d md => simp [Stmt.containsFuncDecl] + | .typeDecl t md => simp [Stmt.containsFuncDecl] + termination_by sizeOf s + +theorem Block.substIdent_containsFuncDecl [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) : + Block.containsFuncDecl (Block.substIdent y y' ss) = Block.containsFuncDecl ss := by + match ss with + | [] => simp [Block.containsFuncDecl] + | s :: rest => + simp only [Block.substIdent, Block.containsFuncDecl] + rw [Stmt.substIdent_containsFuncDecl y y' s, + Block.substIdent_containsFuncDecl y y' rest] + termination_by sizeOf ss +end + +mutual +theorem Stmt.substIdent_loopHasNoInvariants [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (s : Stmt P (Cmd P)) : + Stmt.loopHasNoInvariants (Stmt.substIdent y y' s) = Stmt.loopHasNoInvariants s := by + match s with + | .cmd c => cases c <;> simp [Cmd.substIdent, Stmt.loopHasNoInvariants] + | .block lbl bss md => + simp only [Stmt.substIdent_block, Stmt.loopHasNoInvariants] + exact Block.substIdent_loopHasNoInvariants y y' bss + | .ite g tss ess md => + simp only [Stmt.substIdent_ite, Stmt.loopHasNoInvariants] + rw [Block.substIdent_loopHasNoInvariants y y' tss, + Block.substIdent_loopHasNoInvariants y y' ess] + | .loop g m inv bss md => + simp only [Stmt.substIdent_loop, Stmt.loopHasNoInvariants, List.isEmpty_map] + rw [Block.substIdent_loopHasNoInvariants y y' bss] + | .exit lbl md => simp [Stmt.loopHasNoInvariants] + | .funcDecl d md => simp [Stmt.loopHasNoInvariants] + | .typeDecl t md => simp [Stmt.loopHasNoInvariants] + termination_by sizeOf s + +theorem Block.substIdent_loopHasNoInvariants [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) : + Block.loopHasNoInvariants (Block.substIdent y y' ss) = Block.loopHasNoInvariants ss := by + match ss with + | [] => simp [Block.loopHasNoInvariants] + | s :: rest => + simp only [Block.substIdent, Block.loopHasNoInvariants] + rw [Stmt.substIdent_loopHasNoInvariants y y' s, + Block.substIdent_loopHasNoInvariants y y' rest] + termination_by sizeOf ss +end + +/-- `Block.applyRenames` preserves `containsNondetLoop`. -/ +theorem Block.applyRenames_containsNondetLoop [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + Block.containsNondetLoop (Block.applyRenames renames ss) + = Block.containsNondetLoop ss := by + unfold Block.applyRenames + induction renames generalizing ss with + | nil => simp + | cons p rest ih => + simp only [List.foldl_cons] + rw [ih (Block.substIdent p.1 p.2 ss), Block.substIdent_containsNondetLoop] + +/-- `Block.applyRenames` preserves `containsFuncDecl`. -/ +theorem Block.applyRenames_containsFuncDecl [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + Block.containsFuncDecl (Block.applyRenames renames ss) + = Block.containsFuncDecl ss := by + unfold Block.applyRenames + induction renames generalizing ss with + | nil => simp + | cons p rest ih => + simp only [List.foldl_cons] + rw [ih (Block.substIdent p.1 p.2 ss), Block.substIdent_containsFuncDecl] + +/-- `Block.applyRenames` preserves `loopHasNoInvariants`. -/ +theorem Block.applyRenames_loopHasNoInvariants [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + Block.loopHasNoInvariants (Block.applyRenames renames ss) + = Block.loopHasNoInvariants ss := by + unfold Block.applyRenames + induction renames generalizing ss with + | nil => simp + | cons p rest ih => + simp only [List.foldl_cons] + rw [ih (Block.substIdent p.1 p.2 ss), Block.substIdent_loopHasNoInvariants] + +end SubstIdentPreserves + +/-! ## Structural postconditions of the monadic fresh-name pass + +The three structural Bool walkers (`allLoopBodiesInitFree`, `loopBodyNoInits`, +`loopMeasureNone`) are reproven against the monadic pass shape. The residual +projection `(... σ).1.2.2` of `liftInitsInLoopBodyM` plays the role of the old +`.snd`; the harvested havoc prelude `(... σ).1.1` is a list of `.cmd .init` +commands (handled by the `_map_cmd` helper lemmas); the rename list +`(... σ).1.2.1` only matters for the final `applyRenames` step, which is +invariant for every structural Bool walker (see `SubstIdentPreserves`). + +Because none of these walkers inspect identifier *names* (only the tree +shape), every lemma generalises over the threaded `StringGenState σ`. -/ + +section MonadicPostconds +variable {P : PureExpr} + +/-! ### Residual-projection (`.1.2.2`) equations for the lift + +The monadic `liftInitsInLoopBodyM` arms destructure the recursive call with a +`let ((hs, rn, ss'), σ') := …` pattern; the projections below extract the +residual `.1.2.2` per-constructor so the structural proofs can `rw` against +the recursive residual without unfolding the whole `let`. -/ + +private theorem Stmt.liftInitsInLoopBodyM_block_residual [HasIdent P] + (lbl : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) : + (Stmt.liftInitsInLoopBodyM (.block lbl bss md) σ).1.2.2 = + [Stmt.block lbl (Block.liftInitsInLoopBodyM bss σ).1.2.2 md] := by + rw [Stmt.liftInitsInLoopBodyM] + rcases h : Block.liftInitsInLoopBodyM bss σ with ⟨⟨hs, rn, bss'⟩, σ'⟩ + simp only [h] + +private theorem Stmt.liftInitsInLoopBodyM_ite_residual [HasIdent P] + (g : ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) : + (Stmt.liftInitsInLoopBodyM (.ite g tss ess md) σ).1.2.2 = + [Stmt.ite g (Block.liftInitsInLoopBodyM tss σ).1.2.2 + (Block.liftInitsInLoopBodyM ess + (Block.liftInitsInLoopBodyM tss σ).2).1.2.2 md] := by + rw [Stmt.liftInitsInLoopBodyM] + rcases h₁ : Block.liftInitsInLoopBodyM tss σ with ⟨⟨ths, trn, tss'⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM ess σ₁ with ⟨⟨ehs, ern, ess'⟩, σ₂⟩ + simp only [h₁, h₂] + +private theorem Block.liftInitsInLoopBodyM_cons_residual [HasIdent P] + (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) (σ : StringGenState) : + (Block.liftInitsInLoopBodyM (s :: rest) σ).1.2.2 = + (Stmt.liftInitsInLoopBodyM s σ).1.2.2 ++ + (Block.liftInitsInLoopBodyM rest (Stmt.liftInitsInLoopBodyM s σ).2).1.2.2 := by + rw [Block.liftInitsInLoopBodyM] + rcases h₁ : Stmt.liftInitsInLoopBodyM s σ with ⟨⟨hs_s, rn_s, ss_s⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM rest σ₁ with ⟨⟨hs_r, rn_r, ss_r⟩, σ₂⟩ + simp only [h₁, h₂] + +/-! ### State-independence of the residual + +The residual component (`.1.2.2`) of the monadic lift only ever rewrites +`init` to `set` (same name) and recurses structurally; it never reads the +generator state (only the FRESH `.fst` havoc names do). Hence the residual is +independent of the start state, and in particular equals the residual run +from `StringGenState.emp` — i.e. `(liftInitsInLoopBody _).snd`. This is the +bridge that lets every shape-only postcondition the pass proves over +`(... σ).1.2.2` port to the pure wrapper. -/ + +mutual +/-- The residual of `Stmt.liftInitsInLoopBodyM s σ` is independent of `σ`. -/ +private theorem Stmt.liftInitsInLoopBodyM_snd_state_indep [HasIdent P] + (s : Stmt P (Cmd P)) (σ σ' : StringGenState) : + (Stmt.liftInitsInLoopBodyM s σ).1.2.2 = + (Stmt.liftInitsInLoopBodyM s σ').1.2.2 := by + match s with + | .cmd c => + cases c <;> simp [Stmt.liftInitsInLoopBodyM] + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM_block_residual, + Stmt.liftInitsInLoopBodyM_block_residual] + rw [Block.liftInitsInLoopBodyM_snd_state_indep bss σ σ'] + | .ite g tss ess md => + rw [Stmt.liftInitsInLoopBodyM_ite_residual, + Stmt.liftInitsInLoopBodyM_ite_residual] + rw [Block.liftInitsInLoopBodyM_snd_state_indep tss σ σ', + Block.liftInitsInLoopBodyM_snd_state_indep ess _ _] + | .loop g m inv body md => + simp [Stmt.liftInitsInLoopBodyM] + | .exit lbl md => + simp [Stmt.liftInitsInLoopBodyM] + | .funcDecl d md => + simp [Stmt.liftInitsInLoopBodyM] + | .typeDecl t md => + simp [Stmt.liftInitsInLoopBodyM] + termination_by sizeOf s + +/-- The residual of `Block.liftInitsInLoopBodyM ss σ` is independent of `σ`. -/ +private theorem Block.liftInitsInLoopBodyM_snd_state_indep [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ σ' : StringGenState) : + (Block.liftInitsInLoopBodyM ss σ).1.2.2 = + (Block.liftInitsInLoopBodyM ss σ').1.2.2 := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM] + | s :: rest => + rw [Block.liftInitsInLoopBodyM_cons_residual, + Block.liftInitsInLoopBodyM_cons_residual] + rw [Stmt.liftInitsInLoopBodyM_snd_state_indep s σ σ', + Block.liftInitsInLoopBodyM_snd_state_indep rest _ _] + termination_by sizeOf ss +end + +/-- The pure wrapper's residual equals the monadic residual at any state. -/ +theorem Stmt.liftInitsInLoopBody_snd_eq [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + (Stmt.liftInitsInLoopBody s).snd = (Stmt.liftInitsInLoopBodyM s σ).1.2.2 := by + rw [Stmt.liftInitsInLoopBody] + exact Stmt.liftInitsInLoopBodyM_snd_state_indep s StringGenState.emp σ + +/-- The pure wrapper's residual equals the monadic residual at any state. -/ +theorem Block.liftInitsInLoopBody_snd_eq [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + (Block.liftInitsInLoopBody ss).snd = (Block.liftInitsInLoopBodyM ss σ).1.2.2 := by + rw [Block.liftInitsInLoopBody] + exact Block.liftInitsInLoopBodyM_snd_state_indep ss StringGenState.emp σ + +/-! ### Identity of the lift output when `initVars = []` + +When the input has no `init` anywhere shallowly (`Stmt.initVars`/`Block.initVars += []`), the fresh-name generator never fires: the harvested havoc prelude is +empty (`.1.1 = []`), the rename list is empty (`.1.2.1 = []`), and the residual +is the input verbatim (`.1.2.2 = [s]` / `= ss`). Because no fresh name is ever +generated, the whole `.1` triple is independent of `σ`. This is a shape-only +fact (it never inspects names) and ports the pure-wrapper `_no_inits` lemma in +`LoopInitHoistRewrite.lean`. -/ + +/-! #### Harvest-projection (`.1.1`) equations for the lift + +Companion to the residual (`.1.2.2`) equations above: these extract the +harvested havoc prelude `.1.1` per-constructor so the `_no_inits` `.1.1 = []` +proofs can `rw` against the recursive sub-harvests without unfolding the `let`. -/ + +private theorem Stmt.liftInitsInLoopBodyM_block_harvest [HasIdent P] + (lbl : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) : + (Stmt.liftInitsInLoopBodyM (.block lbl bss md) σ).1.1 = + (Block.liftInitsInLoopBodyM bss σ).1.1 := by + rw [Stmt.liftInitsInLoopBodyM] + rcases h : Block.liftInitsInLoopBodyM bss σ with ⟨⟨hs, rn, bss'⟩, σ'⟩ + simp only [h] + +private theorem Stmt.liftInitsInLoopBodyM_ite_harvest [HasIdent P] + (g : ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) : + (Stmt.liftInitsInLoopBodyM (.ite g tss ess md) σ).1.1 = + (Block.liftInitsInLoopBodyM tss σ).1.1 ++ + (Block.liftInitsInLoopBodyM ess + (Block.liftInitsInLoopBodyM tss σ).2).1.1 := by + rw [Stmt.liftInitsInLoopBodyM] + rcases h₁ : Block.liftInitsInLoopBodyM tss σ with ⟨⟨ths, trn, tss'⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM ess σ₁ with ⟨⟨ehs, ern, ess'⟩, σ₂⟩ + simp only [h₁, h₂] + +private theorem Block.liftInitsInLoopBodyM_cons_harvest [HasIdent P] + (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) (σ : StringGenState) : + (Block.liftInitsInLoopBodyM (s :: rest) σ).1.1 = + (Stmt.liftInitsInLoopBodyM s σ).1.1 ++ + (Block.liftInitsInLoopBodyM rest (Stmt.liftInitsInLoopBodyM s σ).2).1.1 := by + rw [Block.liftInitsInLoopBodyM] + rcases h₁ : Stmt.liftInitsInLoopBodyM s σ with ⟨⟨hs_s, rn_s, ss_s⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM rest σ₁ with ⟨⟨hs_r, rn_r, ss_r⟩, σ₂⟩ + simp only [h₁, h₂] + +/-! #### `_no_inits`: harvest is empty and residual is the identity + +Under `initVars = []` the harvest (`.1.1`) is empty and the residual +(`.1.2.2`) is the input verbatim. Both facts are shape-only (no name is read), +so they hold at any `σ` and port to the pure wrapper. -/ + +mutual +/-- Under `Stmt.initVars s = []`, the harvested havoc prelude is empty. -/ +private theorem Stmt.liftInitsInLoopBodyM_fst_no_inits [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) + (h_iv : Stmt.initVars s = []) : + (Stmt.liftInitsInLoopBodyM s σ).1.1 = [] := by + match s with + | .cmd c => + cases c with + | init x ty rhs md => simp [Stmt.initVars] at h_iv + | set x rhs md => simp [Stmt.liftInitsInLoopBodyM] + | assert l e md => simp [Stmt.liftInitsInLoopBodyM] + | assume l e md => simp [Stmt.liftInitsInLoopBodyM] + | cover l e md => simp [Stmt.liftInitsInLoopBodyM] + | .block lbl bss md => + have h_bss : Block.initVars bss = [] := by simpa [Stmt.initVars] using h_iv + rw [Stmt.liftInitsInLoopBodyM_block_harvest, + Block.liftInitsInLoopBodyM_fst_no_inits bss σ h_bss] + | .ite g tss ess md => + have h_split : Block.initVars tss = [] ∧ Block.initVars ess = [] := by + have htot : Block.initVars tss ++ Block.initVars ess = [] := by + simpa [Stmt.initVars] using h_iv + exact List.append_eq_nil_iff.mp htot + rw [Stmt.liftInitsInLoopBodyM_ite_harvest, + Block.liftInitsInLoopBodyM_fst_no_inits tss σ h_split.1, + Block.liftInitsInLoopBodyM_fst_no_inits ess _ h_split.2, + List.append_nil] + | .loop g m inv body md => simp [Stmt.liftInitsInLoopBodyM] + | .exit lbl md => simp [Stmt.liftInitsInLoopBodyM] + | .funcDecl d md => simp [Stmt.liftInitsInLoopBodyM] + | .typeDecl t md => simp [Stmt.liftInitsInLoopBodyM] + termination_by sizeOf s + +/-- Under `Block.initVars ss = []`, the harvested havoc prelude is empty. -/ +private theorem Block.liftInitsInLoopBodyM_fst_no_inits [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_iv : Block.initVars ss = []) : + (Block.liftInitsInLoopBodyM ss σ).1.1 = [] := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM] + | s :: rest => + have h_split : Stmt.initVars s = [] ∧ Block.initVars rest = [] := by + have htot : Stmt.initVars s ++ Block.initVars rest = [] := by + simpa [Block.initVars] using h_iv + exact List.append_eq_nil_iff.mp htot + rw [Block.liftInitsInLoopBodyM_cons_harvest, + Stmt.liftInitsInLoopBodyM_fst_no_inits s σ h_split.1, + Block.liftInitsInLoopBodyM_fst_no_inits rest _ h_split.2, + List.append_nil] + termination_by sizeOf ss +end + +mutual +/-- Under `Stmt.initVars s = []`, the residual is `s` unchanged. -/ +private theorem Stmt.liftInitsInLoopBodyM_snd_no_inits [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) + (h_iv : Stmt.initVars s = []) : + (Stmt.liftInitsInLoopBodyM s σ).1.2.2 = [s] := by + match s with + | .cmd c => + cases c with + | init x ty rhs md => simp [Stmt.initVars] at h_iv + | set x rhs md => simp [Stmt.liftInitsInLoopBodyM] + | assert l e md => simp [Stmt.liftInitsInLoopBodyM] + | assume l e md => simp [Stmt.liftInitsInLoopBodyM] + | cover l e md => simp [Stmt.liftInitsInLoopBodyM] + | .block lbl bss md => + have h_bss : Block.initVars bss = [] := by simpa [Stmt.initVars] using h_iv + rw [Stmt.liftInitsInLoopBodyM_block_residual, + Block.liftInitsInLoopBodyM_snd_no_inits bss σ h_bss] + | .ite g tss ess md => + have h_split : Block.initVars tss = [] ∧ Block.initVars ess = [] := by + have htot : Block.initVars tss ++ Block.initVars ess = [] := by + simpa [Stmt.initVars] using h_iv + exact List.append_eq_nil_iff.mp htot + rw [Stmt.liftInitsInLoopBodyM_ite_residual, + Block.liftInitsInLoopBodyM_snd_no_inits tss σ h_split.1, + Block.liftInitsInLoopBodyM_snd_no_inits ess _ h_split.2] + | .loop g m inv body md => simp [Stmt.liftInitsInLoopBodyM] + | .exit lbl md => simp [Stmt.liftInitsInLoopBodyM] + | .funcDecl d md => simp [Stmt.liftInitsInLoopBodyM] + | .typeDecl t md => simp [Stmt.liftInitsInLoopBodyM] + termination_by sizeOf s + +/-- Under `Block.initVars ss = []`, the residual is `ss` unchanged. -/ +private theorem Block.liftInitsInLoopBodyM_snd_no_inits [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_iv : Block.initVars ss = []) : + (Block.liftInitsInLoopBodyM ss σ).1.2.2 = ss := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM] + | s :: rest => + have h_split : Stmt.initVars s = [] ∧ Block.initVars rest = [] := by + have htot : Stmt.initVars s ++ Block.initVars rest = [] := by + simpa [Block.initVars] using h_iv + exact List.append_eq_nil_iff.mp htot + rw [Block.liftInitsInLoopBodyM_cons_residual, + Stmt.liftInitsInLoopBodyM_snd_no_inits s σ h_split.1, + Block.liftInitsInLoopBodyM_snd_no_inits rest _ h_split.2, + List.singleton_append] + termination_by sizeOf ss +end + +/-- Pure-wrapper identity of `Stmt.liftInitsInLoopBody` when `initVars = []`. -/ +theorem Stmt.liftInitsInLoopBody_no_inits_eq [HasIdent P] + (s : Stmt P (Cmd P)) (h_iv : Stmt.initVars s = []) : + Stmt.liftInitsInLoopBody s = ([], [s]) := by + rw [Stmt.liftInitsInLoopBody] + rw [Stmt.liftInitsInLoopBodyM_fst_no_inits s StringGenState.emp h_iv, + Stmt.liftInitsInLoopBodyM_snd_no_inits s StringGenState.emp h_iv] + +/-- Pure-wrapper identity of `Block.liftInitsInLoopBody` when `initVars = []`. -/ +theorem Block.liftInitsInLoopBody_no_inits_eq [HasIdent P] + (ss : List (Stmt P (Cmd P))) (h_iv : Block.initVars ss = []) : + Block.liftInitsInLoopBody ss = ([], ss) := by + rw [Block.liftInitsInLoopBody] + rw [Block.liftInitsInLoopBodyM_fst_no_inits ss StringGenState.emp h_iv, + Block.liftInitsInLoopBodyM_snd_no_inits ss StringGenState.emp h_iv] + +/-! ### Per-constructor residual (`.snd`) reduction of the pure wrapper + +`liftInitsInLoopBody` is now a projection of the monadic pass, so the old +`simp only [Stmt.liftInitsInLoopBody]` unfold no longer reduces `.snd` to the +constructor shape. These name-agnostic equations re-expose the per-constructor +residual shape on the wrapper, so the shape-only `_snd_*` postcondition proofs +(`namesFreshInExprs`, `namesFreshInRhsExprs`, `initVars_subset`, …) in +`LoopInitHoistRewrite.lean` / `LoopInitHoistFreshness.lean` can drive the +structural recursion exactly as before — just `rw`/`simp` with these instead +of the old definitional unfold. The init→set conversion is name-preserving +(original `x` retained in the residual), which is why these are independent of +the fresh names harvested into `.fst`. -/ + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_cmd_init [HasIdent P] + (x : P.Ident) (ty : P.Ty) (rhs : ExprOrNondet P) (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.cmd (.init x ty rhs md))).snd = + [.cmd (.set x rhs md)] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp] + simp [Stmt.liftInitsInLoopBodyM] + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_cmd_set [HasIdent P] + (x : P.Ident) (rhs : ExprOrNondet P) (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.cmd (.set x rhs md))).snd = + [.cmd (.set x rhs md)] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp] + simp [Stmt.liftInitsInLoopBodyM] + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_cmd_assert [HasIdent P] + (l : String) (e : P.Expr) (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.cmd (.assert l e md))).snd = + [.cmd (.assert l e md)] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp] + simp [Stmt.liftInitsInLoopBodyM] + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_cmd_assume [HasIdent P] + (l : String) (e : P.Expr) (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.cmd (.assume l e md))).snd = + [.cmd (.assume l e md)] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp] + simp [Stmt.liftInitsInLoopBodyM] + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_cmd_cover [HasIdent P] + (l : String) (e : P.Expr) (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.cmd (.cover l e md))).snd = + [.cmd (.cover l e md)] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp] + simp [Stmt.liftInitsInLoopBodyM] + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_block [HasIdent P] + (lbl : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.block lbl bss md)).snd = + [.block lbl (Block.liftInitsInLoopBody bss).snd md] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp, + Stmt.liftInitsInLoopBodyM_block_residual, + ← Block.liftInitsInLoopBody_snd_eq bss StringGenState.emp] + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_ite [HasIdent P] + (g : ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.ite g tss ess md)).snd = + [.ite g (Block.liftInitsInLoopBody tss).snd + (Block.liftInitsInLoopBody ess).snd md] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp, + Stmt.liftInitsInLoopBodyM_ite_residual] + rw [← Block.liftInitsInLoopBody_snd_eq tss StringGenState.emp, + ← Block.liftInitsInLoopBody_snd_eq ess + (Block.liftInitsInLoopBodyM tss StringGenState.emp).2] + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_loop [HasIdent P] + (g : ExprOrNondet P) (m : Option P.Expr) + (inv : List (String × P.Expr)) (body : List (Stmt P (Cmd P))) + (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.loop g m inv body md)).snd = + [.loop g m inv body md] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp] + simp [Stmt.liftInitsInLoopBodyM] + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_exit [HasIdent P] + (lbl : String) (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.exit lbl md)).snd = [.exit lbl md] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp] + simp [Stmt.liftInitsInLoopBodyM] + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_funcDecl [HasIdent P] + (d : PureFunc P) (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.funcDecl d md)).snd = [.funcDecl d md] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp] + simp [Stmt.liftInitsInLoopBodyM] + +@[simp] theorem Stmt.liftInitsInLoopBody_snd_typeDecl [HasIdent P] + (t : TypeConstructor) (md : MetaData P) : + (Stmt.liftInitsInLoopBody (.typeDecl t md)).snd = [.typeDecl t md] := by + rw [Stmt.liftInitsInLoopBody_snd_eq _ StringGenState.emp] + simp [Stmt.liftInitsInLoopBodyM] + +@[simp] theorem Block.liftInitsInLoopBody_snd_nil [HasIdent P] : + (Block.liftInitsInLoopBody ([] : List (Stmt P (Cmd P)))).snd = [] := by + rw [Block.liftInitsInLoopBody_snd_eq _ StringGenState.emp] + simp [Block.liftInitsInLoopBodyM] + +@[simp] theorem Block.liftInitsInLoopBody_snd_cons [HasIdent P] + (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) : + (Block.liftInitsInLoopBody (s :: rest)).snd = + (Stmt.liftInitsInLoopBody s).snd ++ (Block.liftInitsInLoopBody rest).snd := by + rw [Block.liftInitsInLoopBody_snd_eq _ StringGenState.emp, + Block.liftInitsInLoopBodyM_cons_residual, + ← Stmt.liftInitsInLoopBody_snd_eq s StringGenState.emp, + ← Block.liftInitsInLoopBody_snd_eq rest + (Stmt.liftInitsInLoopBodyM s StringGenState.emp).2] + +/-! ### `allLoopBodiesInitFree` is preserved by the lift residual -/ + +mutual +/-- The residual of `Stmt.liftInitsInLoopBodyM s` has the same +`allLoopBodiesInitFree` as `s` (the lift never touches loop bodies, and turns +inits into sets which carry no loop). -/ +private theorem Stmt.liftInitsInLoopBodyM_snd_allLoopBodiesInitFree [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.allLoopBodiesInitFree (Stmt.liftInitsInLoopBodyM s σ).1.2.2 = + Stmt.allLoopBodiesInitFree s := by + match s with + | .cmd c => + cases c <;> + simp [Stmt.liftInitsInLoopBodyM, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree] + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM_block_residual] + simp only [Block.allLoopBodiesInitFree, Stmt.allLoopBodiesInitFree, Bool.and_true] + exact Block.liftInitsInLoopBodyM_snd_allLoopBodiesInitFree bss σ + | .ite g tss ess md => + rw [Stmt.liftInitsInLoopBodyM_ite_residual] + simp only [Block.allLoopBodiesInitFree, Stmt.allLoopBodiesInitFree, Bool.and_true] + rw [Block.liftInitsInLoopBodyM_snd_allLoopBodiesInitFree tss σ, + Block.liftInitsInLoopBodyM_snd_allLoopBodiesInitFree ess _] + | .loop g m inv body md => + simp [Stmt.liftInitsInLoopBodyM, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree] + | .exit lbl md => + simp [Stmt.liftInitsInLoopBodyM, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree] + | .funcDecl d md => + simp [Stmt.liftInitsInLoopBodyM, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree] + | .typeDecl t md => + simp [Stmt.liftInitsInLoopBodyM, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree] + termination_by sizeOf s + +private theorem Block.liftInitsInLoopBodyM_snd_allLoopBodiesInitFree [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.allLoopBodiesInitFree (Block.liftInitsInLoopBodyM ss σ).1.2.2 = + Block.allLoopBodiesInitFree ss := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM, Block.allLoopBodiesInitFree] + | s :: rest => + rw [Block.liftInitsInLoopBodyM_cons_residual, + Block.allLoopBodiesInitFree_append] + simp only [Block.allLoopBodiesInitFree] + rw [Stmt.liftInitsInLoopBodyM_snd_allLoopBodiesInitFree s σ, + Block.liftInitsInLoopBodyM_snd_allLoopBodiesInitFree rest _] + termination_by sizeOf ss +end + +/-! ### `noInitsAnywhere` of the lift residual (under the input precondition) -/ + +mutual +/-- Under `Stmt.allLoopBodiesInitFree s`, the residual of +`Stmt.liftInitsInLoopBodyM s` has no inits anywhere: every init was lifted to +a fresh prelude havoc (harvested in `.1.1`), and the precondition guarantees +nested loops were already init-free. -/ +private theorem Stmt.liftInitsInLoopBodyM_snd_noInitsAnywhere [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) + (h : Stmt.allLoopBodiesInitFree s = true) : + Block.noInitsAnywhere (Stmt.liftInitsInLoopBodyM s σ).1.2.2 = true := by + match s with + | .cmd c => + cases c <;> + simp [Stmt.liftInitsInLoopBodyM, Block.noInitsAnywhere, + Stmt.noInitsAnywhere] + | .block lbl bss md => + have h_bss : Block.allLoopBodiesInitFree bss = true := by + rw [Stmt.allLoopBodiesInitFree] at h; exact h + rw [Stmt.liftInitsInLoopBodyM_block_residual] + simp only [Block.noInitsAnywhere, Stmt.noInitsAnywhere, Bool.and_true] + exact Block.liftInitsInLoopBodyM_snd_noInitsAnywhere bss σ h_bss + | .ite g tss ess md => + have h_branches : Block.allLoopBodiesInitFree tss = true ∧ + Block.allLoopBodiesInitFree ess = true := by + rw [Stmt.allLoopBodiesInitFree, Bool.and_eq_true] at h; exact h + rw [Stmt.liftInitsInLoopBodyM_ite_residual] + simp only [Block.noInitsAnywhere, Stmt.noInitsAnywhere, Bool.and_true, + Block.liftInitsInLoopBodyM_snd_noInitsAnywhere tss σ h_branches.1, + Block.liftInitsInLoopBodyM_snd_noInitsAnywhere ess _ h_branches.2] + | .loop g m inv body md => + have h_body_nia : Block.noInitsAnywhere body = true := by + rw [Stmt.allLoopBodiesInitFree, Bool.and_eq_true] at h; exact h.1 + simp [Stmt.liftInitsInLoopBodyM, Block.noInitsAnywhere, + Stmt.noInitsAnywhere, h_body_nia] + | .exit lbl md => + simp [Stmt.liftInitsInLoopBodyM, Block.noInitsAnywhere, Stmt.noInitsAnywhere] + | .funcDecl d md => + simp [Stmt.liftInitsInLoopBodyM, Block.noInitsAnywhere, Stmt.noInitsAnywhere] + | .typeDecl t md => + simp [Stmt.liftInitsInLoopBodyM, Block.noInitsAnywhere, Stmt.noInitsAnywhere] + termination_by sizeOf s + +private theorem Block.liftInitsInLoopBodyM_snd_noInitsAnywhere [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h : Block.allLoopBodiesInitFree ss = true) : + Block.noInitsAnywhere (Block.liftInitsInLoopBodyM ss σ).1.2.2 = true := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM, Block.noInitsAnywhere] + | s :: rest => + rw [Block.allLoopBodiesInitFree, Bool.and_eq_true] at h + rw [Block.liftInitsInLoopBodyM_cons_residual, Block.noInitsAnywhere_append] + simp only [Stmt.liftInitsInLoopBodyM_snd_noInitsAnywhere s σ h.1, + Block.liftInitsInLoopBodyM_snd_noInitsAnywhere rest _ h.2, + Bool.and_true] + termination_by sizeOf ss +end + +/-! ### Output-projection (`.1`) equations for the top-level pass + +Like the lift, the `hoistLoopPrefixInitsM` arms destructure recursive calls +with `let … := …` patterns. These per-constructor projections of the output +list `.1` let the postcondition proofs `rw` directly against the recursive +sub-outputs. The `.loop` arm is the interesting one: the output is the fresh +havoc prelude (mapped to `.cmd`) followed by the rewritten loop, where the +body has been renamed by `Block.applyRenames`. -/ + +private theorem Stmt.hoistLoopPrefixInitsM_block_out [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (lbl : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) : + (Stmt.hoistLoopPrefixInitsM (.block lbl bss md) σ).1 = + [Stmt.block lbl (Block.hoistLoopPrefixInitsM bss σ).1 md] := by + rw [Stmt.hoistLoopPrefixInitsM] + rcases h : Block.hoistLoopPrefixInitsM bss σ with ⟨bss', σ'⟩ + simp only [h] + +private theorem Stmt.hoistLoopPrefixInitsM_ite_out [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (g : ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) : + (Stmt.hoistLoopPrefixInitsM (.ite g tss ess md) σ).1 = + [Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess + (Block.hoistLoopPrefixInitsM tss σ).2).1 md] := by + rw [Stmt.hoistLoopPrefixInitsM] + rcases h₁ : Block.hoistLoopPrefixInitsM tss σ with ⟨tss', σ₁⟩ + rcases h₂ : Block.hoistLoopPrefixInitsM ess σ₁ with ⟨ess', σ₂⟩ + simp only [h₁, h₂] + +/-- The `.loop` arm output: the fresh havoc prelude followed by the loop whose +body is the lift residual after `applyRenames`. Here `body₁` is the +post-order-processed body, `σ₁` the state after, and `lifted` the lift of +`body₁` from `σ₁`. -/ +private theorem Stmt.hoistLoopPrefixInitsM_loop_out [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (g : ExprOrNondet P) (m : Option P.Expr) + (inv : List (String × P.Expr)) (body : List (Stmt P (Cmd P))) + (md : MetaData P) (σ : StringGenState) : + (Stmt.hoistLoopPrefixInitsM (.loop g m inv body md) σ).1 = + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.1.map Stmt.cmd ++ + [Stmt.loop g m inv + (Block.applyRenames + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) md] := by + rw [Stmt.hoistLoopPrefixInitsM] + rcases h₁ : Block.hoistLoopPrefixInitsM body σ with ⟨body₁, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM body₁ σ₁ with ⟨⟨havocs, renames, body₂⟩, σ₂⟩ + simp only [h₁, h₂] + +private theorem Block.hoistLoopPrefixInitsM_cons_out [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) (σ : StringGenState) : + (Block.hoistLoopPrefixInitsM (s :: rest) σ).1 = + (Stmt.hoistLoopPrefixInitsM s σ).1 ++ + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).1 := by + rw [Block.hoistLoopPrefixInitsM] + rcases h₁ : Stmt.hoistLoopPrefixInitsM s σ with ⟨ss_s, σ₁⟩ + rcases h₂ : Block.hoistLoopPrefixInitsM rest σ₁ with ⟨ss_r, σ₂⟩ + simp only [h₁, h₂] + +/-! ### Generator-state monotonicity of the pass (`GenStep`) + +The pass threads a single monotone `StringGenState`; the only place it draws a +fresh name is `liftInitsInLoopBodyM`'s `.init` arm, which calls +`StringGenState.gen`. Hence the final state of every monadic walker is a +`StringGenState.GenStep` from its input: well-formedness is preserved and the +set of produced labels only grows (never shrinks). The proof mirrors the pass +recursion exactly, composing per-substructure steps via `GenStep.trans` and +discharging the `.init` leaf via `GenStep.of_gen`. This is the monotonicity +backbone that lets the §E mutual re-establish its generator-state +preconditions at the advanced state in the `cons`/`.ite`/`.loop` arms. -/ + +open StringGenState (GenStep) in +mutual +/-- The lift's final generator state is a `GenStep` from its input. -/ +theorem Stmt.liftInitsInLoopBodyM_genStep [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + GenStep σ (Stmt.liftInitsInLoopBodyM s σ).2 := by + match s with + | .cmd c => + cases c with + | init x ty rhs md => + rw [Stmt.liftInitsInLoopBodyM] + exact StringGenState.GenStep.of_gen hoistFreshPrefix σ + | set x rhs md => simp only [Stmt.liftInitsInLoopBodyM]; exact GenStep.refl σ + | assert l e md => simp only [Stmt.liftInitsInLoopBodyM]; exact GenStep.refl σ + | assume l e md => simp only [Stmt.liftInitsInLoopBodyM]; exact GenStep.refl σ + | cover l e md => simp only [Stmt.liftInitsInLoopBodyM]; exact GenStep.refl σ + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM] + rcases h : Block.liftInitsInLoopBodyM bss σ with ⟨⟨hs, rn, bss'⟩, σ'⟩ + simp only [h] + have := Block.liftInitsInLoopBodyM_genStep bss σ + rw [h] at this; exact this + | .ite g tss ess md => + rw [Stmt.liftInitsInLoopBodyM] + rcases h₁ : Block.liftInitsInLoopBodyM tss σ with ⟨⟨ths, trn, tss'⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM ess σ₁ with ⟨⟨ehs, ern, ess'⟩, σ₂⟩ + simp only [h₁, h₂] + have hstep1 := Block.liftInitsInLoopBodyM_genStep tss σ + rw [h₁] at hstep1 + have hstep2 := Block.liftInitsInLoopBodyM_genStep ess σ₁ + rw [h₂] at hstep2 + exact hstep1.trans hstep2 + | .loop g m inv body md => rw [Stmt.liftInitsInLoopBodyM]; exact GenStep.refl σ + | .exit lbl md => rw [Stmt.liftInitsInLoopBodyM]; exact GenStep.refl σ + | .funcDecl d md => rw [Stmt.liftInitsInLoopBodyM]; exact GenStep.refl σ + | .typeDecl t md => rw [Stmt.liftInitsInLoopBodyM]; exact GenStep.refl σ + termination_by sizeOf s + +/-- The block-level lift's final generator state is a `GenStep` from its input. -/ +theorem Block.liftInitsInLoopBodyM_genStep [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + GenStep σ (Block.liftInitsInLoopBodyM ss σ).2 := by + match ss with + | [] => rw [Block.liftInitsInLoopBodyM]; exact GenStep.refl σ + | s :: rest => + rw [Block.liftInitsInLoopBodyM] + rcases h₁ : Stmt.liftInitsInLoopBodyM s σ with ⟨⟨hs_s, rn_s, ss_s⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM rest σ₁ with ⟨⟨hs_r, rn_r, ss_r⟩, σ₂⟩ + simp only [h₁, h₂] + have hstep1 := Stmt.liftInitsInLoopBodyM_genStep s σ + rw [h₁] at hstep1 + have hstep2 := Block.liftInitsInLoopBodyM_genStep rest σ₁ + rw [h₂] at hstep2 + exact hstep1.trans hstep2 + termination_by sizeOf ss +end + +/-! ### The lift's freshly-minted labels carry the hoist mint kind `Q`. + +Every label the lift adds to the generator state is minted by `gen +hoistFreshPrefix` (the lift's only generator call, at each `.init`), so it lies +in the image of the mint witness `hQmint`. This is the building block that lets +the source-kind-freedom hypothesis (`∀ str, Q str → …`) discharge the +generator-step threading of the σ-membership freshness invariant: a label the +lift adds over `σ` is `Q`-kind, hence the kind-free source names avoid it. -/ + +open StringGenState (GenStep) in +mutual +/-- Every label the statement lift adds over `σ` carries the mint kind `Q`. -/ +theorem Stmt.liftInitsInLoopBodyM_genStep_delta_Q [HasIdent P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (s : Stmt P (Cmd P)) (σ : StringGenState) : + ∀ str ∈ StringGenState.stringGens (Stmt.liftInitsInLoopBodyM s σ).2, + str ∉ StringGenState.stringGens σ → Q str := by + match s with + | .cmd c => + cases c with + | init x ty rhs md => + intro str h_in h_nin + rw [Stmt.liftInitsInLoopBodyM] at h_in + rw [StringGenState.stringGens_gen, List.mem_cons] at h_in + rcases h_in with h_new | h_old + · subst h_new; exact hQmint σ + · exact absurd h_old h_nin + | set x rhs md => + intro str h_in h_nin + simp only [Stmt.liftInitsInLoopBodyM] at h_in; exact absurd h_in h_nin + | assert l e md => + intro str h_in h_nin + simp only [Stmt.liftInitsInLoopBodyM] at h_in; exact absurd h_in h_nin + | assume l e md => + intro str h_in h_nin + simp only [Stmt.liftInitsInLoopBodyM] at h_in; exact absurd h_in h_nin + | cover l e md => + intro str h_in h_nin + simp only [Stmt.liftInitsInLoopBodyM] at h_in; exact absurd h_in h_nin + | .block lbl bss md => + intro str h_in h_nin + have h_state : (Stmt.liftInitsInLoopBodyM (.block lbl bss md) σ).2 + = (Block.liftInitsInLoopBodyM bss σ).2 := by + rw [Stmt.liftInitsInLoopBodyM] + rcases h : Block.liftInitsInLoopBodyM bss σ with ⟨⟨hs, rn, bss'⟩, σ'⟩ + simp only [h] + rw [h_state] at h_in + exact Block.liftInitsInLoopBodyM_genStep_delta_Q hQmint bss σ str h_in h_nin + | .ite g tss ess md => + intro str h_in h_nin + have h_state : (Stmt.liftInitsInLoopBodyM (.ite g tss ess md) σ).2 + = (Block.liftInitsInLoopBodyM ess (Block.liftInitsInLoopBodyM tss σ).2).2 := by + rw [Stmt.liftInitsInLoopBodyM] + rcases h₁ : Block.liftInitsInLoopBodyM tss σ with ⟨⟨ths, trn, tss'⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM ess σ₁ with ⟨⟨ehs, ern, ess'⟩, σ₂⟩ + simp only [h₁, h₂] + rw [h_state] at h_in + by_cases h_mid : str ∈ StringGenState.stringGens (Block.liftInitsInLoopBodyM tss σ).2 + · exact Block.liftInitsInLoopBodyM_genStep_delta_Q hQmint tss σ str h_mid h_nin + · exact Block.liftInitsInLoopBodyM_genStep_delta_Q hQmint ess + (Block.liftInitsInLoopBodyM tss σ).2 str h_in h_mid + | .loop g m inv body md => + intro str h_in h_nin + simp only [Stmt.liftInitsInLoopBodyM] at h_in; exact absurd h_in h_nin + | .exit lbl md => + intro str h_in h_nin + simp only [Stmt.liftInitsInLoopBodyM] at h_in; exact absurd h_in h_nin + | .funcDecl d md => + intro str h_in h_nin + simp only [Stmt.liftInitsInLoopBodyM] at h_in; exact absurd h_in h_nin + | .typeDecl t md => + intro str h_in h_nin + simp only [Stmt.liftInitsInLoopBodyM] at h_in; exact absurd h_in h_nin + termination_by sizeOf s + +/-- Every label the block lift adds over `σ` carries the mint kind `Q`. -/ +theorem Block.liftInitsInLoopBodyM_genStep_delta_Q [HasIdent P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + ∀ str ∈ StringGenState.stringGens (Block.liftInitsInLoopBodyM ss σ).2, + str ∉ StringGenState.stringGens σ → Q str := by + match ss with + | [] => + intro str h_in h_nin + rw [Block.liftInitsInLoopBodyM] at h_in; exact absurd h_in h_nin + | s :: rest => + intro str h_in h_nin + have h_state : (Block.liftInitsInLoopBodyM (s :: rest) σ).2 + = (Block.liftInitsInLoopBodyM rest (Stmt.liftInitsInLoopBodyM s σ).2).2 := by + rw [Block.liftInitsInLoopBodyM] + rcases h₁ : Stmt.liftInitsInLoopBodyM s σ with ⟨⟨hs_s, rn_s, ss_s⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM rest σ₁ with ⟨⟨hs_r, rn_r, ss_r⟩, σ₂⟩ + simp only [h₁, h₂] + rw [h_state] at h_in + by_cases h_mid : str ∈ StringGenState.stringGens (Stmt.liftInitsInLoopBodyM s σ).2 + · exact Stmt.liftInitsInLoopBodyM_genStep_delta_Q hQmint s σ str h_mid h_nin + · exact Block.liftInitsInLoopBodyM_genStep_delta_Q hQmint rest + (Stmt.liftInitsInLoopBodyM s σ).2 str h_in h_mid + termination_by sizeOf ss +end + +open StringGenState (GenStep) in +mutual +/-- The pass's final generator state is a `GenStep` from its input. -/ +theorem Stmt.hoistLoopPrefixInitsM_genStep [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + GenStep σ (Stmt.hoistLoopPrefixInitsM s σ).2 := by + match s with + | .cmd c => rw [Stmt.hoistLoopPrefixInitsM]; exact GenStep.refl σ + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM] + rcases h : Block.hoistLoopPrefixInitsM bss σ with ⟨bss', σ'⟩ + simp only [h] + have := Block.hoistLoopPrefixInitsM_genStep bss σ + rw [h] at this; exact this + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM] + rcases h₁ : Block.hoistLoopPrefixInitsM tss σ with ⟨tss', σ₁⟩ + rcases h₂ : Block.hoistLoopPrefixInitsM ess σ₁ with ⟨ess', σ₂⟩ + simp only [h₁, h₂] + have hstep1 := Block.hoistLoopPrefixInitsM_genStep tss σ + rw [h₁] at hstep1 + have hstep2 := Block.hoistLoopPrefixInitsM_genStep ess σ₁ + rw [h₂] at hstep2 + exact hstep1.trans hstep2 + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM] + rcases h₁ : Block.hoistLoopPrefixInitsM body σ with ⟨body₁, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM body₁ σ₁ with ⟨⟨havocs, renames, body₂⟩, σ₂⟩ + simp only [h₁, h₂] + have hstep1 := Block.hoistLoopPrefixInitsM_genStep body σ + rw [h₁] at hstep1 + have hstep2 := Block.liftInitsInLoopBodyM_genStep body₁ σ₁ + rw [h₂] at hstep2 + exact hstep1.trans hstep2 + | .exit lbl md => rw [Stmt.hoistLoopPrefixInitsM]; exact GenStep.refl σ + | .funcDecl d md => rw [Stmt.hoistLoopPrefixInitsM]; exact GenStep.refl σ + | .typeDecl t md => rw [Stmt.hoistLoopPrefixInitsM]; exact GenStep.refl σ + termination_by sizeOf s + +/-- The block-level pass's final generator state is a `GenStep` from its +input. -/ +theorem Block.hoistLoopPrefixInitsM_genStep [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + GenStep σ (Block.hoistLoopPrefixInitsM ss σ).2 := by + match ss with + | [] => rw [Block.hoistLoopPrefixInitsM]; exact GenStep.refl σ + | s :: rest => + rw [Block.hoistLoopPrefixInitsM] + rcases h₁ : Stmt.hoistLoopPrefixInitsM s σ with ⟨ss_s, σ₁⟩ + rcases h₂ : Block.hoistLoopPrefixInitsM rest σ₁ with ⟨ss_r, σ₂⟩ + simp only [h₁, h₂] + have hstep1 := Stmt.hoistLoopPrefixInitsM_genStep s σ + rw [h₁] at hstep1 + have hstep2 := Block.hoistLoopPrefixInitsM_genStep rest σ₁ + rw [h₂] at hstep2 + exact hstep1.trans hstep2 + termination_by sizeOf ss +end + +/-! ### The post-order pass's freshly-minted labels carry the mint kind `Q`. + +Every label `hoistLoopPrefixInitsM` adds to the generator state is minted by +`gen hoistFreshPrefix` — either by the post-order recursion or by the nested +`liftInitsInLoopBodyM` of a `.loop` body — so it lies in the image of the mint +witness `hQmint`. This is the pass-level companion of +`liftInitsInLoopBodyM_genStep_delta_Q`, and it is what lets the source +kind-freedom hypothesis discharge the generator-step threading of the +σ-membership freshness invariant in the §E `.cons`/`.ite` arms. -/ + +open StringGenState (GenStep) in +mutual +/-- Every label the statement pass adds over `σ` carries the mint kind `Q`. -/ +theorem Stmt.hoistLoopPrefixInitsM_genStep_delta_Q [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (s : Stmt P (Cmd P)) (σ : StringGenState) : + ∀ str ∈ StringGenState.stringGens (Stmt.hoistLoopPrefixInitsM s σ).2, + str ∉ StringGenState.stringGens σ → Q str := by + match s with + | .cmd c => + intro str h_in h_nin + rw [Stmt.hoistLoopPrefixInitsM] at h_in; exact absurd h_in h_nin + | .block lbl bss md => + intro str h_in h_nin + have h_state : (Stmt.hoistLoopPrefixInitsM (.block lbl bss md) σ).2 + = (Block.hoistLoopPrefixInitsM bss σ).2 := by + rw [Stmt.hoistLoopPrefixInitsM] + rcases h : Block.hoistLoopPrefixInitsM bss σ with ⟨bss', σ'⟩ + simp only [h] + rw [h_state] at h_in + exact Block.hoistLoopPrefixInitsM_genStep_delta_Q hQmint bss σ str h_in h_nin + | .ite g tss ess md => + intro str h_in h_nin + have h_state : (Stmt.hoistLoopPrefixInitsM (.ite g tss ess md) σ).2 + = (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).2 := by + rw [Stmt.hoistLoopPrefixInitsM] + rcases h₁ : Block.hoistLoopPrefixInitsM tss σ with ⟨tss', σ₁⟩ + rcases h₂ : Block.hoistLoopPrefixInitsM ess σ₁ with ⟨ess', σ₂⟩ + simp only [h₁, h₂] + rw [h_state] at h_in + by_cases h_mid : str ∈ StringGenState.stringGens (Block.hoistLoopPrefixInitsM tss σ).2 + · exact Block.hoistLoopPrefixInitsM_genStep_delta_Q hQmint tss σ str h_mid h_nin + · exact Block.hoistLoopPrefixInitsM_genStep_delta_Q hQmint ess + (Block.hoistLoopPrefixInitsM tss σ).2 str h_in h_mid + | .loop g m inv body md => + intro str h_in h_nin + -- output state = lift (post-order body₁) σ₁, where σ₁ = post-order body state. + have h_state : (Stmt.hoistLoopPrefixInitsM (.loop g m inv body md) σ).2 + = (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).2 := by + rw [Stmt.hoistLoopPrefixInitsM] + rcases h₁ : Block.hoistLoopPrefixInitsM body σ with ⟨body₁, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM body₁ σ₁ with ⟨⟨havocs, renames, body₂⟩, σ₂⟩ + simp only [h₁, h₂] + rw [h_state] at h_in + by_cases h_mid : str ∈ StringGenState.stringGens (Block.hoistLoopPrefixInitsM body σ).2 + · exact Block.hoistLoopPrefixInitsM_genStep_delta_Q hQmint body σ str h_mid h_nin + · exact Block.liftInitsInLoopBodyM_genStep_delta_Q hQmint + (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 + str h_in h_mid + | .exit lbl md => + intro str h_in h_nin + rw [Stmt.hoistLoopPrefixInitsM] at h_in; exact absurd h_in h_nin + | .funcDecl d md => + intro str h_in h_nin + rw [Stmt.hoistLoopPrefixInitsM] at h_in; exact absurd h_in h_nin + | .typeDecl t md => + intro str h_in h_nin + rw [Stmt.hoistLoopPrefixInitsM] at h_in; exact absurd h_in h_nin + termination_by sizeOf s + +/-- Every label the block pass adds over `σ` carries the mint kind `Q`. -/ +theorem Block.hoistLoopPrefixInitsM_genStep_delta_Q [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + ∀ str ∈ StringGenState.stringGens (Block.hoistLoopPrefixInitsM ss σ).2, + str ∉ StringGenState.stringGens σ → Q str := by + match ss with + | [] => + intro str h_in h_nin + rw [Block.hoistLoopPrefixInitsM] at h_in; exact absurd h_in h_nin + | s :: rest => + intro str h_in h_nin + have h_state : (Block.hoistLoopPrefixInitsM (s :: rest) σ).2 + = (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).2 := by + rw [Block.hoistLoopPrefixInitsM] + rcases h₁ : Stmt.hoistLoopPrefixInitsM s σ with ⟨ss_s, σ₁⟩ + rcases h₂ : Block.hoistLoopPrefixInitsM rest σ₁ with ⟨ss_r, σ₂⟩ + simp only [h₁, h₂] + rw [h_state] at h_in + by_cases h_mid : str ∈ StringGenState.stringGens (Stmt.hoistLoopPrefixInitsM s σ).2 + · exact Stmt.hoistLoopPrefixInitsM_genStep_delta_Q hQmint s σ str h_mid h_nin + · exact Block.hoistLoopPrefixInitsM_genStep_delta_Q hQmint rest + (Stmt.hoistLoopPrefixInitsM s σ).2 str h_in h_mid + termination_by sizeOf ss +end + +/-! ### Fresh-from-generator-state disjointness, and its threading + +Every label a `GenStep` adds is suffix-shaped (`_`, the shape every +`StringGenState.gen` output carries). A source/user identifier that — viewed as +a string — lacks that suffix shape can therefore never coincide with a label +the generator added. This is the building block that discharges the §E +mutual's "the new fresh names are disjoint from the source names" obligation +from generator monotonicity alone. -/ + +/-- The §E fresh-from-σ precondition shape: every label already produced by +`σ`, injected into `P.Ident`, is disjoint from the source frame names `A`, +extra names `B`, and `.init` LHS names `ivs`. -/ +def SrcNamesFreshFromGen [HasIdent P] (A B ivs : List P.Ident) (σ : StringGenState) : Prop := + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ ivs + +/-- Kind-aware threading of the fresh-from-σ precondition across a `GenStep`. +The caller supplies `h_delta` recording that every newly-added label carries a +client kind `Q` (for the hoist pass, via `…_genStep_delta_Q` + the mint witness +`hQmint`). It then needs only the `Q`-restricted source kind-freedom +`h_src_shapefree`, so a composition partner is never forced to keep *every* +generator-shaped name fresh — only labels of its own kind. -/ +theorem SrcNamesFreshFromGen.genStep_of_delta [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] {Q : String → Prop} + {A B ivs : List P.Ident} {σ σ' : StringGenState} + (h_delta : ∀ str ∈ StringGenState.stringGens σ', + str ∉ StringGenState.stringGens σ → Q str) + (h_src_shapefree : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ ivs) + (h_fresh : SrcNamesFreshFromGen (P := P) A B ivs σ) : + SrcNamesFreshFromGen (P := P) A B ivs σ' := by + intro str h_mem + by_cases h_in_σ : str ∈ StringGenState.stringGens σ + · exact h_fresh str h_in_σ + · exact h_src_shapefree str (h_delta str h_mem h_in_σ) + +/-! ### Top-level `allLoopBodiesInitFree` postcondition (monadic + pure) -/ + +mutual +/-- The output of `Stmt.hoistLoopPrefixInitsM s σ` satisfies +`allLoopBodiesInitFree`. -/ +private theorem Stmt.hoistLoopPrefixInitsM_allLoopBodiesInitFree [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.allLoopBodiesInitFree (Stmt.hoistLoopPrefixInitsM s σ).1 = true := by + match s with + | .cmd c => + simp [Stmt.hoistLoopPrefixInitsM, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree] + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM_block_out] + simp only [Block.allLoopBodiesInitFree, Stmt.allLoopBodiesInitFree, Bool.and_true] + exact Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree bss σ + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM_ite_out] + simp only [Block.allLoopBodiesInitFree, Stmt.allLoopBodiesInitFree, Bool.and_true, + Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree tss σ, + Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree ess _] + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM_loop_out] + -- the post-order-processed body and the state after it + have h_body₁_albif : + Block.allLoopBodiesInitFree (Block.hoistLoopPrefixInitsM body σ).1 = true := + Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree body σ + have h_body₂_albif : + Block.allLoopBodiesInitFree + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 = true := by + rw [Block.liftInitsInLoopBodyM_snd_allLoopBodiesInitFree]; exact h_body₁_albif + have h_body₂_nia : + Block.noInitsAnywhere + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 = true := + Block.liftInitsInLoopBodyM_snd_noInitsAnywhere _ _ h_body₁_albif + rw [Block.allLoopBodiesInitFree_append] + simp only [Block.allLoopBodiesInitFree_map_cmd, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree, Bool.true_and, Bool.and_true] + rw [Block.applyRenames_noInitsAnywhere, Block.applyRenames_allLoopBodiesInitFree] + exact Bool.and_eq_true _ _ |>.mpr ⟨h_body₂_nia, h_body₂_albif⟩ + | .exit lbl md => + simp [Stmt.hoistLoopPrefixInitsM, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree] + | .funcDecl d md => + simp [Stmt.hoistLoopPrefixInitsM, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree] + | .typeDecl t md => + simp [Stmt.hoistLoopPrefixInitsM, Block.allLoopBodiesInitFree, + Stmt.allLoopBodiesInitFree] + termination_by sizeOf s + +private theorem Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.allLoopBodiesInitFree (Block.hoistLoopPrefixInitsM ss σ).1 = true := by + match ss with + | [] => simp [Block.hoistLoopPrefixInitsM, Block.allLoopBodiesInitFree] + | s :: rest => + rw [Block.hoistLoopPrefixInitsM_cons_out, Block.allLoopBodiesInitFree_append] + simp only [Stmt.hoistLoopPrefixInitsM_allLoopBodiesInitFree s σ, + Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree rest _, Bool.and_true] + termination_by sizeOf ss +end + +/-- Top-level Phase 8 §E5 (Option A) structural postcondition (monadic +fresh-name pass): `Block.hoistLoopPrefixInits` produces a block where every +`.loop` body contains no `.init` commands at any nesting depth. -/ +theorem Block.hoistLoopPrefixInits_allLoopBodiesInitFree [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) : + Block.allLoopBodiesInitFree (Block.hoistLoopPrefixInits ss) = true := + Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree ss StringGenState.emp + +/-! ### Bridge: `allLoopBodiesInitFree` implies `loopBodyNoInits` + +`allLoopBodiesInitFree` is strictly stronger: at the `.loop` arm it requires +`noInitsAnywhere body` (no inits in the body at any depth), which entails +`(Block.initVars body).isEmpty` (the predicate `loopBodyNoInits` requires). +This lets us derive the original `loopBodyNoInits` postcondition from the +already-proven `allLoopBodiesInitFree` one. The bridges do not depend on the +pass at all (pure facts about the structural predicates). -/ + +mutual +/-- No inits anywhere ⇒ the deep `initVars` list is empty (`= []`). -/ +private theorem Stmt.initVars_eq_nil_of_noInitsAnywhere + (s : Stmt P (Cmd P)) (h : Stmt.noInitsAnywhere s = true) : + Stmt.initVars s = [] := by + match s with + | .cmd c => + cases c <;> simp_all [Stmt.noInitsAnywhere, Stmt.initVars] + | .block lbl bss md => + rw [Stmt.noInitsAnywhere] at h + simp only [Stmt.initVars_block] + exact Block.initVars_eq_nil_of_noInitsAnywhere bss h + | .ite g tss ess md => + rw [Stmt.noInitsAnywhere, Bool.and_eq_true] at h + simp only [Stmt.initVars_ite] + rw [Block.initVars_eq_nil_of_noInitsAnywhere tss h.1, + Block.initVars_eq_nil_of_noInitsAnywhere ess h.2, List.append_nil] + | .loop g m inv bss md => + rw [Stmt.noInitsAnywhere] at h + simp only [Stmt.initVars_loop] + exact Block.initVars_eq_nil_of_noInitsAnywhere bss h + | .exit lbl md => simp [Stmt.initVars] + | .funcDecl d md => simp [Stmt.initVars] + | .typeDecl t md => simp [Stmt.initVars] + termination_by sizeOf s + +private theorem Block.initVars_eq_nil_of_noInitsAnywhere + (ss : List (Stmt P (Cmd P))) (h : Block.noInitsAnywhere ss = true) : + Block.initVars ss = [] := by + match ss with + | [] => simp [Block.initVars] + | s :: rest => + rw [Block.noInitsAnywhere, Bool.and_eq_true] at h + simp only [Block.initVars_cons] + rw [Stmt.initVars_eq_nil_of_noInitsAnywhere s h.1, + Block.initVars_eq_nil_of_noInitsAnywhere rest h.2, List.append_nil] + termination_by sizeOf ss +end + +mutual +private theorem Stmt.loopBodyNoInits_of_allLoopBodiesInitFree + (s : Stmt P (Cmd P)) (h : Stmt.allLoopBodiesInitFree s = true) : + Stmt.loopBodyNoInits s = true := by + match s with + | .cmd c => simp [Stmt.loopBodyNoInits] + | .block lbl bss md => + rw [Stmt.allLoopBodiesInitFree] at h + simp only [Stmt.loopBodyNoInits] + exact Block.loopBodyNoInits_of_allLoopBodiesInitFree bss h + | .ite g tss ess md => + rw [Stmt.allLoopBodiesInitFree, Bool.and_eq_true] at h + simp only [Stmt.loopBodyNoInits, + Block.loopBodyNoInits_of_allLoopBodiesInitFree tss h.1, + Block.loopBodyNoInits_of_allLoopBodiesInitFree ess h.2, Bool.and_true] + | .loop g m inv bss md => + rw [Stmt.allLoopBodiesInitFree, Bool.and_eq_true] at h + simp only [Stmt.loopBodyNoInits, + Block.loopBodyNoInits_of_allLoopBodiesInitFree bss h.2, + Block.initVars_eq_nil_of_noInitsAnywhere bss h.1, + List.isEmpty_nil, Bool.and_true] + | .exit lbl md => simp [Stmt.loopBodyNoInits] + | .funcDecl d md => simp [Stmt.loopBodyNoInits] + | .typeDecl t md => simp [Stmt.loopBodyNoInits] + termination_by sizeOf s + +private theorem Block.loopBodyNoInits_of_allLoopBodiesInitFree + (ss : List (Stmt P (Cmd P))) (h : Block.allLoopBodiesInitFree ss = true) : + Block.loopBodyNoInits ss = true := by + match ss with + | [] => simp [Block.loopBodyNoInits] + | s :: rest => + rw [Block.allLoopBodiesInitFree, Bool.and_eq_true] at h + simp only [Block.loopBodyNoInits, + Stmt.loopBodyNoInits_of_allLoopBodiesInitFree s h.1, + Block.loopBodyNoInits_of_allLoopBodiesInitFree rest h.2, Bool.and_true] + termination_by sizeOf ss +end + +/-- The original Phase 8 §E structural postcondition: the output of the +hoisting pass has `loopBodyNoInits = true` (every `.loop` body is init-free at +the top level). Derived from the stronger `allLoopBodiesInitFree`. -/ +theorem hoistLoopPrefixInits_satisfies_loopBodyNoInits [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) : + Block.loopBodyNoInits (Block.hoistLoopPrefixInits ss) = true := + Block.loopBodyNoInits_of_allLoopBodiesInitFree _ + (Block.hoistLoopPrefixInits_allLoopBodiesInitFree ss) + +/-! ### `loopMeasureNone` is preserved by the pass + +The lift never changes any loop's `measure` slot (it does not recurse into +loops); `applyRenames` maps measures by `Option.map` so `m.isNone` is +unchanged (`Block.applyRenames_loopMeasureNone`); the fresh havoc prelude is +all `.cmd`s. Hence the whole pass preserves `loopMeasureNone`. -/ + +mutual +private theorem Stmt.liftInitsInLoopBodyM_snd_loopMeasureNone [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.loopMeasureNone (Stmt.liftInitsInLoopBodyM s σ).1.2.2 = + Stmt.loopMeasureNone s := by + match s with + | .cmd c => + cases c <;> + simp [Stmt.liftInitsInLoopBodyM, Block.loopMeasureNone, Stmt.loopMeasureNone] + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM_block_residual] + simp only [Block.loopMeasureNone, Stmt.loopMeasureNone, Bool.and_true] + exact Block.liftInitsInLoopBodyM_snd_loopMeasureNone bss σ + | .ite g tss ess md => + rw [Stmt.liftInitsInLoopBodyM_ite_residual] + simp only [Block.loopMeasureNone, Stmt.loopMeasureNone, Bool.and_true, + Block.liftInitsInLoopBodyM_snd_loopMeasureNone tss σ, + Block.liftInitsInLoopBodyM_snd_loopMeasureNone ess _] + | .loop g m inv body md => + simp [Stmt.liftInitsInLoopBodyM, Block.loopMeasureNone, Stmt.loopMeasureNone] + | .exit lbl md => + simp [Stmt.liftInitsInLoopBodyM, Block.loopMeasureNone, Stmt.loopMeasureNone] + | .funcDecl d md => + simp [Stmt.liftInitsInLoopBodyM, Block.loopMeasureNone, Stmt.loopMeasureNone] + | .typeDecl t md => + simp [Stmt.liftInitsInLoopBodyM, Block.loopMeasureNone, Stmt.loopMeasureNone] + termination_by sizeOf s + +private theorem Block.liftInitsInLoopBodyM_snd_loopMeasureNone [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.loopMeasureNone (Block.liftInitsInLoopBodyM ss σ).1.2.2 = + Block.loopMeasureNone ss := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM, Block.loopMeasureNone] + | s :: rest => + rw [Block.liftInitsInLoopBodyM_cons_residual, Block.loopMeasureNone_append, + Stmt.liftInitsInLoopBodyM_snd_loopMeasureNone s σ, + Block.liftInitsInLoopBodyM_snd_loopMeasureNone rest _, Block.loopMeasureNone] + termination_by sizeOf ss +end + +mutual +private theorem Stmt.hoistLoopPrefixInitsM_loopMeasureNone [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.loopMeasureNone (Stmt.hoistLoopPrefixInitsM s σ).1 = + Stmt.loopMeasureNone s := by + match s with + | .cmd c => + simp [Stmt.hoistLoopPrefixInitsM, Block.loopMeasureNone, Stmt.loopMeasureNone] + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM_block_out] + simp only [Block.loopMeasureNone, Stmt.loopMeasureNone, Bool.and_true] + exact Block.hoistLoopPrefixInitsM_loopMeasureNone bss σ + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM_ite_out] + simp only [Block.loopMeasureNone, Stmt.loopMeasureNone, Bool.and_true, + Block.hoistLoopPrefixInitsM_loopMeasureNone tss σ, + Block.hoistLoopPrefixInitsM_loopMeasureNone ess _] + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM_loop_out] + have h_body_mn : + Block.loopMeasureNone (Block.hoistLoopPrefixInitsM body σ).1 = + Block.loopMeasureNone body := + Block.hoistLoopPrefixInitsM_loopMeasureNone body σ + have h_lift_mn : + Block.loopMeasureNone + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 = + Block.loopMeasureNone body := by + rw [Block.liftInitsInLoopBodyM_snd_loopMeasureNone]; exact h_body_mn + rw [Block.loopMeasureNone_append] + simp only [Block.loopMeasureNone_map_cmd, Block.loopMeasureNone, + Stmt.loopMeasureNone, Bool.true_and, Bool.and_true] + rw [Block.applyRenames_loopMeasureNone, h_lift_mn] + | .exit lbl md => + simp [Stmt.hoistLoopPrefixInitsM, Block.loopMeasureNone, Stmt.loopMeasureNone] + | .funcDecl d md => + simp [Stmt.hoistLoopPrefixInitsM, Block.loopMeasureNone, Stmt.loopMeasureNone] + | .typeDecl t md => + simp [Stmt.hoistLoopPrefixInitsM, Block.loopMeasureNone, Stmt.loopMeasureNone] + termination_by sizeOf s + +private theorem Block.hoistLoopPrefixInitsM_loopMeasureNone [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.loopMeasureNone (Block.hoistLoopPrefixInitsM ss σ).1 = + Block.loopMeasureNone ss := by + match ss with + | [] => simp [Block.hoistLoopPrefixInitsM, Block.loopMeasureNone] + | s :: rest => + rw [Block.hoistLoopPrefixInitsM_cons_out, Block.loopMeasureNone_append, + Stmt.hoistLoopPrefixInitsM_loopMeasureNone s σ, + Block.hoistLoopPrefixInitsM_loopMeasureNone rest _, Block.loopMeasureNone] + termination_by sizeOf ss +end + +/-- Top-level Phase 8 §B preservation (monadic fresh-name pass): +`Block.hoistLoopPrefixInits` preserves `Block.loopMeasureNone`. -/ +theorem Block.hoistLoopPrefixInits_preserves_loopMeasureNone [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) + (h : Block.loopMeasureNone ss = true) : + Block.loopMeasureNone (Block.hoistLoopPrefixInits ss) = true := by + rw [Block.hoistLoopPrefixInits, Block.hoistLoopPrefixInitsM_loopMeasureNone] + exact h + +/-! ### `simpleShape` is preserved by the pass + +`simpleShape` is shape-only. The lift leaves every `.loop` untouched (it does +not recurse into loops) and emits `.cmd (.set …)` residuals for hoisted inits +(`simpleShape = true`); `applyRenames` keeps a `.det e` guard `.det` +(`Block.applyRenames_simpleShape`); the fresh havoc prelude is all `.cmd`s. +Hence the whole pass preserves `simpleShape`. Mirrors the `loopMeasureNone` +chain above. -/ + +mutual +private theorem Stmt.liftInitsInLoopBodyM_snd_simpleShape [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.simpleShape (Stmt.liftInitsInLoopBodyM s σ).1.2.2 = + Stmt.simpleShape s := by + match s with + | .cmd c => + cases c <;> + simp [Stmt.liftInitsInLoopBodyM, Block.simpleShape, Stmt.simpleShape] + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM_block_residual] + simp only [Block.simpleShape, Stmt.simpleShape, Bool.and_true] + exact Block.liftInitsInLoopBodyM_snd_simpleShape bss σ + | .ite g tss ess md => + rw [Stmt.liftInitsInLoopBodyM_ite_residual] + cases g with + | det e => + simp only [Block.simpleShape, Stmt.simpleShape, Bool.and_true, + Block.liftInitsInLoopBodyM_snd_simpleShape tss σ, + Block.liftInitsInLoopBodyM_snd_simpleShape ess _] + | nondet => + simp only [Block.simpleShape, Stmt.simpleShape, Bool.and_true] + | .loop g m inv body md => + simp [Stmt.liftInitsInLoopBodyM, Block.simpleShape] + | .exit lbl md => + simp [Stmt.liftInitsInLoopBodyM, Block.simpleShape, Stmt.simpleShape] + | .funcDecl d md => + simp [Stmt.liftInitsInLoopBodyM, Block.simpleShape, Stmt.simpleShape] + | .typeDecl t md => + simp [Stmt.liftInitsInLoopBodyM, Block.simpleShape, Stmt.simpleShape] + termination_by sizeOf s + +private theorem Block.liftInitsInLoopBodyM_snd_simpleShape [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.simpleShape (Block.liftInitsInLoopBodyM ss σ).1.2.2 = + Block.simpleShape ss := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM, Block.simpleShape] + | s :: rest => + rw [Block.liftInitsInLoopBodyM_cons_residual, Block.simpleShape_append, + Stmt.liftInitsInLoopBodyM_snd_simpleShape s σ, + Block.liftInitsInLoopBodyM_snd_simpleShape rest _, Block.simpleShape] + termination_by sizeOf ss +end + +mutual +private theorem Stmt.hoistLoopPrefixInitsM_simpleShape [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.simpleShape (Stmt.hoistLoopPrefixInitsM s σ).1 = + Stmt.simpleShape s := by + match s with + | .cmd c => + simp [Stmt.hoistLoopPrefixInitsM, Block.simpleShape, Stmt.simpleShape] + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM_block_out] + simp only [Block.simpleShape, Stmt.simpleShape, Bool.and_true] + exact Block.hoistLoopPrefixInitsM_simpleShape bss σ + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM_ite_out] + cases g with + | det e => + simp only [Block.simpleShape, Stmt.simpleShape, Bool.and_true, + Block.hoistLoopPrefixInitsM_simpleShape tss σ, + Block.hoistLoopPrefixInitsM_simpleShape ess _] + | nondet => + simp only [Block.simpleShape, Stmt.simpleShape, Bool.and_true] + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM_loop_out] + have h_body_ss : + Block.simpleShape (Block.hoistLoopPrefixInitsM body σ).1 = + Block.simpleShape body := + Block.hoistLoopPrefixInitsM_simpleShape body σ + have h_lift_ss : + Block.simpleShape + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 = + Block.simpleShape body := by + rw [Block.liftInitsInLoopBodyM_snd_simpleShape]; exact h_body_ss + have h_body₃_ss : + Block.simpleShape + (Block.applyRenames + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) = + Block.simpleShape body := by + rw [Block.applyRenames_simpleShape]; exact h_lift_ss + rw [Block.simpleShape_append] + cases g with + | det e => + simp only [Block.simpleShape_map_cmd, Block.simpleShape, + Stmt.simpleShape, Bool.true_and, Bool.and_true, h_body₃_ss] + | nondet => + simp only [Block.simpleShape_map_cmd, Block.simpleShape, + Stmt.simpleShape, Bool.true_and, Bool.and_true, h_body₃_ss] + | .exit lbl md => + simp [Stmt.hoistLoopPrefixInitsM, Block.simpleShape, Stmt.simpleShape] + | .funcDecl d md => + simp [Stmt.hoistLoopPrefixInitsM, Block.simpleShape, Stmt.simpleShape] + | .typeDecl t md => + simp [Stmt.hoistLoopPrefixInitsM, Block.simpleShape, Stmt.simpleShape] + termination_by sizeOf s + +private theorem Block.hoistLoopPrefixInitsM_simpleShape [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.simpleShape (Block.hoistLoopPrefixInitsM ss σ).1 = + Block.simpleShape ss := by + match ss with + | [] => simp [Block.hoistLoopPrefixInitsM, Block.simpleShape] + | s :: rest => + rw [Block.hoistLoopPrefixInitsM_cons_out, Block.simpleShape_append, + Stmt.hoistLoopPrefixInitsM_simpleShape s σ, + Block.hoistLoopPrefixInitsM_simpleShape rest _, Block.simpleShape] + termination_by sizeOf ss +end + +/-- Top-level: `Block.hoistLoopPrefixInits` preserves `Block.simpleShape`. -/ +theorem Block.hoistLoopPrefixInits_preserves_simpleShape [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) + (h : Block.simpleShape ss = true) : + Block.simpleShape (Block.hoistLoopPrefixInits ss) = true := by + rw [Block.hoistLoopPrefixInits, Block.hoistLoopPrefixInitsM_simpleShape] + exact h + +/-! ### `containsNondetLoop` / `containsFuncDecl` are preserved by the pass + +Both are shape-only walkers; the lift never recurses into loops and emits only +`.cmd .init` havocs (no nondet loop, no funcDecl); `applyRenames` preserves +both walkers. So the whole pass preserves them in value. -/ + +mutual +private theorem Stmt.liftInitsInLoopBodyM_snd_containsNondetLoop [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.containsNondetLoop (Stmt.liftInitsInLoopBodyM s σ).1.2.2 = + Stmt.containsNondetLoop s := by + match s with + | .cmd c => + cases c <;> + simp [Stmt.liftInitsInLoopBodyM, Block.containsNondetLoop, Stmt.containsNondetLoop] + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM_block_residual] + simp only [Block.containsNondetLoop, Stmt.containsNondetLoop, Bool.or_false] + exact Block.liftInitsInLoopBodyM_snd_containsNondetLoop bss σ + | .ite g tss ess md => + rw [Stmt.liftInitsInLoopBodyM_ite_residual] + simp only [Block.containsNondetLoop, Stmt.containsNondetLoop, Bool.or_false, + Block.liftInitsInLoopBodyM_snd_containsNondetLoop tss σ, + Block.liftInitsInLoopBodyM_snd_containsNondetLoop ess _] + | .loop g m inv body md => + cases g <;> + simp [Stmt.liftInitsInLoopBodyM, Block.containsNondetLoop, Stmt.containsNondetLoop] + | .exit lbl md => + simp [Stmt.liftInitsInLoopBodyM, Block.containsNondetLoop, Stmt.containsNondetLoop] + | .funcDecl d md => + simp [Stmt.liftInitsInLoopBodyM, Block.containsNondetLoop, Stmt.containsNondetLoop] + | .typeDecl t md => + simp [Stmt.liftInitsInLoopBodyM, Block.containsNondetLoop, Stmt.containsNondetLoop] + termination_by sizeOf s + +private theorem Block.liftInitsInLoopBodyM_snd_containsNondetLoop [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.containsNondetLoop (Block.liftInitsInLoopBodyM ss σ).1.2.2 = + Block.containsNondetLoop ss := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM, Block.containsNondetLoop] + | s :: rest => + rw [Block.liftInitsInLoopBodyM_cons_residual, Block.containsNondetLoop_append, + Stmt.liftInitsInLoopBodyM_snd_containsNondetLoop s σ, + Block.liftInitsInLoopBodyM_snd_containsNondetLoop rest _, Block.containsNondetLoop] + termination_by sizeOf ss +end + +mutual +private theorem Stmt.hoistLoopPrefixInitsM_containsNondetLoop [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.containsNondetLoop (Stmt.hoistLoopPrefixInitsM s σ).1 = + Stmt.containsNondetLoop s := by + match s with + | .cmd c => + simp [Stmt.hoistLoopPrefixInitsM, Block.containsNondetLoop, Stmt.containsNondetLoop] + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM_block_out] + simp only [Block.containsNondetLoop, Stmt.containsNondetLoop, Bool.or_false] + exact Block.hoistLoopPrefixInitsM_containsNondetLoop bss σ + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM_ite_out] + simp only [Block.containsNondetLoop, Stmt.containsNondetLoop, Bool.or_false, + Block.hoistLoopPrefixInitsM_containsNondetLoop tss σ, + Block.hoistLoopPrefixInitsM_containsNondetLoop ess _] + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM_loop_out] + have h_body : + Block.containsNondetLoop (Block.hoistLoopPrefixInitsM body σ).1 = + Block.containsNondetLoop body := + Block.hoistLoopPrefixInitsM_containsNondetLoop body σ + have h_lift : + Block.containsNondetLoop + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 = + Block.containsNondetLoop body := by + rw [Block.liftInitsInLoopBodyM_snd_containsNondetLoop]; exact h_body + rw [Block.containsNondetLoop_append] + simp only [Block.containsNondetLoop_map_cmd, Block.containsNondetLoop, + Bool.false_or, Bool.or_false] + cases g <;> + simp only [Stmt.containsNondetLoop, Block.applyRenames_containsNondetLoop, h_lift] + | .exit lbl md => + simp [Stmt.hoistLoopPrefixInitsM, Block.containsNondetLoop, Stmt.containsNondetLoop] + | .funcDecl d md => + simp [Stmt.hoistLoopPrefixInitsM, Block.containsNondetLoop, Stmt.containsNondetLoop] + | .typeDecl t md => + simp [Stmt.hoistLoopPrefixInitsM, Block.containsNondetLoop, Stmt.containsNondetLoop] + termination_by sizeOf s + +private theorem Block.hoistLoopPrefixInitsM_containsNondetLoop [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.containsNondetLoop (Block.hoistLoopPrefixInitsM ss σ).1 = + Block.containsNondetLoop ss := by + match ss with + | [] => simp [Block.hoistLoopPrefixInitsM, Block.containsNondetLoop] + | s :: rest => + rw [Block.hoistLoopPrefixInitsM_cons_out, Block.containsNondetLoop_append, + Stmt.hoistLoopPrefixInitsM_containsNondetLoop s σ, + Block.hoistLoopPrefixInitsM_containsNondetLoop rest _, Block.containsNondetLoop] + termination_by sizeOf ss +end + +/-- The pass preserves `containsNondetLoop` in value. -/ +theorem Block.hoistLoopPrefixInits_containsNondetLoop_eq [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) : + Block.containsNondetLoop (Block.hoistLoopPrefixInits ss) = + Block.containsNondetLoop ss := by + rw [Block.hoistLoopPrefixInits, Block.hoistLoopPrefixInitsM_containsNondetLoop] + +mutual +private theorem Stmt.liftInitsInLoopBodyM_snd_containsFuncDecl [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.containsFuncDecl (Stmt.liftInitsInLoopBodyM s σ).1.2.2 = + Stmt.containsFuncDecl s := by + match s with + | .cmd c => + cases c <;> + simp [Stmt.liftInitsInLoopBodyM, Block.containsFuncDecl, Stmt.containsFuncDecl] + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM_block_residual] + simp only [Block.containsFuncDecl, Stmt.containsFuncDecl, Bool.or_false] + exact Block.liftInitsInLoopBodyM_snd_containsFuncDecl bss σ + | .ite g tss ess md => + rw [Stmt.liftInitsInLoopBodyM_ite_residual] + simp only [Block.containsFuncDecl, Stmt.containsFuncDecl, Bool.or_false, + Block.liftInitsInLoopBodyM_snd_containsFuncDecl tss σ, + Block.liftInitsInLoopBodyM_snd_containsFuncDecl ess _] + | .loop g m inv body md => + simp [Stmt.liftInitsInLoopBodyM, Block.containsFuncDecl, Stmt.containsFuncDecl] + | .exit lbl md => + simp [Stmt.liftInitsInLoopBodyM, Block.containsFuncDecl, Stmt.containsFuncDecl] + | .funcDecl d md => + simp [Stmt.liftInitsInLoopBodyM, Block.containsFuncDecl, Stmt.containsFuncDecl] + | .typeDecl t md => + simp [Stmt.liftInitsInLoopBodyM, Block.containsFuncDecl, Stmt.containsFuncDecl] + termination_by sizeOf s + +private theorem Block.liftInitsInLoopBodyM_snd_containsFuncDecl [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.containsFuncDecl (Block.liftInitsInLoopBodyM ss σ).1.2.2 = + Block.containsFuncDecl ss := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM, Block.containsFuncDecl] + | s :: rest => + rw [Block.liftInitsInLoopBodyM_cons_residual, Block.containsFuncDecl_append, + Stmt.liftInitsInLoopBodyM_snd_containsFuncDecl s σ, + Block.liftInitsInLoopBodyM_snd_containsFuncDecl rest _, Block.containsFuncDecl] + termination_by sizeOf ss +end + +mutual +private theorem Stmt.hoistLoopPrefixInitsM_containsFuncDecl [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.containsFuncDecl (Stmt.hoistLoopPrefixInitsM s σ).1 = + Stmt.containsFuncDecl s := by + match s with + | .cmd c => + simp [Stmt.hoistLoopPrefixInitsM, Block.containsFuncDecl, Stmt.containsFuncDecl] + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM_block_out] + simp only [Block.containsFuncDecl, Stmt.containsFuncDecl, Bool.or_false] + exact Block.hoistLoopPrefixInitsM_containsFuncDecl bss σ + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM_ite_out] + simp only [Block.containsFuncDecl, Stmt.containsFuncDecl, Bool.or_false, + Block.hoistLoopPrefixInitsM_containsFuncDecl tss σ, + Block.hoistLoopPrefixInitsM_containsFuncDecl ess _] + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM_loop_out] + have h_body : + Block.containsFuncDecl (Block.hoistLoopPrefixInitsM body σ).1 = + Block.containsFuncDecl body := + Block.hoistLoopPrefixInitsM_containsFuncDecl body σ + have h_lift : + Block.containsFuncDecl + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 = + Block.containsFuncDecl body := by + rw [Block.liftInitsInLoopBodyM_snd_containsFuncDecl]; exact h_body + rw [Block.containsFuncDecl_append] + simp only [Block.containsFuncDecl_map_cmd, Block.containsFuncDecl, + Stmt.containsFuncDecl, Bool.false_or, Bool.or_false] + rw [Block.applyRenames_containsFuncDecl, h_lift] + | .exit lbl md => + simp [Stmt.hoistLoopPrefixInitsM, Block.containsFuncDecl, Stmt.containsFuncDecl] + | .funcDecl d md => + simp [Stmt.hoistLoopPrefixInitsM, Block.containsFuncDecl, Stmt.containsFuncDecl] + | .typeDecl t md => + simp [Stmt.hoistLoopPrefixInitsM, Block.containsFuncDecl, Stmt.containsFuncDecl] + termination_by sizeOf s + +private theorem Block.hoistLoopPrefixInitsM_containsFuncDecl [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.containsFuncDecl (Block.hoistLoopPrefixInitsM ss σ).1 = + Block.containsFuncDecl ss := by + match ss with + | [] => simp [Block.hoistLoopPrefixInitsM, Block.containsFuncDecl] + | s :: rest => + rw [Block.hoistLoopPrefixInitsM_cons_out, Block.containsFuncDecl_append, + Stmt.hoistLoopPrefixInitsM_containsFuncDecl s σ, + Block.hoistLoopPrefixInitsM_containsFuncDecl rest _, Block.containsFuncDecl] + termination_by sizeOf ss +end + +/-- The pass preserves `containsFuncDecl` in value. -/ +theorem Block.hoistLoopPrefixInits_containsFuncDecl_eq [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) : + Block.containsFuncDecl (Block.hoistLoopPrefixInits ss) = + Block.containsFuncDecl ss := by + rw [Block.hoistLoopPrefixInits, Block.hoistLoopPrefixInitsM_containsFuncDecl] + +/-! ### `loopHasNoInvariants` is preserved by the pass -/ + +mutual +private theorem Stmt.liftInitsInLoopBodyM_snd_loopHasNoInvariants [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.loopHasNoInvariants (Stmt.liftInitsInLoopBodyM s σ).1.2.2 = + Stmt.loopHasNoInvariants s := by + match s with + | .cmd c => + cases c <;> + simp [Stmt.liftInitsInLoopBodyM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM_block_residual] + simp only [Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, Bool.and_true] + exact Block.liftInitsInLoopBodyM_snd_loopHasNoInvariants bss σ + | .ite g tss ess md => + rw [Stmt.liftInitsInLoopBodyM_ite_residual] + simp only [Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, Bool.and_true, + Block.liftInitsInLoopBodyM_snd_loopHasNoInvariants tss σ, + Block.liftInitsInLoopBodyM_snd_loopHasNoInvariants ess _] + | .loop g m inv body md => + simp [Stmt.liftInitsInLoopBodyM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + | .exit lbl md => + simp [Stmt.liftInitsInLoopBodyM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + | .funcDecl d md => + simp [Stmt.liftInitsInLoopBodyM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + | .typeDecl t md => + simp [Stmt.liftInitsInLoopBodyM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + termination_by sizeOf s + +private theorem Block.liftInitsInLoopBodyM_snd_loopHasNoInvariants [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.loopHasNoInvariants (Block.liftInitsInLoopBodyM ss σ).1.2.2 = + Block.loopHasNoInvariants ss := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM, Block.loopHasNoInvariants] + | s :: rest => + rw [Block.liftInitsInLoopBodyM_cons_residual, Block.loopHasNoInvariants_append, + Stmt.liftInitsInLoopBodyM_snd_loopHasNoInvariants s σ, + Block.liftInitsInLoopBodyM_snd_loopHasNoInvariants rest _, Block.loopHasNoInvariants] + termination_by sizeOf ss +end + +mutual +private theorem Stmt.hoistLoopPrefixInitsM_loopHasNoInvariants [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.loopHasNoInvariants (Stmt.hoistLoopPrefixInitsM s σ).1 = + Stmt.loopHasNoInvariants s := by + match s with + | .cmd c => + simp [Stmt.hoistLoopPrefixInitsM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM_block_out] + simp only [Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, Bool.and_true] + exact Block.hoistLoopPrefixInitsM_loopHasNoInvariants bss σ + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM_ite_out] + simp only [Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, Bool.and_true, + Block.hoistLoopPrefixInitsM_loopHasNoInvariants tss σ, + Block.hoistLoopPrefixInitsM_loopHasNoInvariants ess _] + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM_loop_out] + have h_body : + Block.loopHasNoInvariants (Block.hoistLoopPrefixInitsM body σ).1 = + Block.loopHasNoInvariants body := + Block.hoistLoopPrefixInitsM_loopHasNoInvariants body σ + have h_lift : + Block.loopHasNoInvariants + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 = + Block.loopHasNoInvariants body := by + rw [Block.liftInitsInLoopBodyM_snd_loopHasNoInvariants]; exact h_body + rw [Block.loopHasNoInvariants_append] + simp only [Block.loopHasNoInvariants_map_cmd, Block.loopHasNoInvariants, + Stmt.loopHasNoInvariants, Bool.true_and, Bool.and_true] + rw [Block.applyRenames_loopHasNoInvariants, h_lift] + | .exit lbl md => + simp [Stmt.hoistLoopPrefixInitsM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + | .funcDecl d md => + simp [Stmt.hoistLoopPrefixInitsM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + | .typeDecl t md => + simp [Stmt.hoistLoopPrefixInitsM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + termination_by sizeOf s + +private theorem Block.hoistLoopPrefixInitsM_loopHasNoInvariants [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.loopHasNoInvariants (Block.hoistLoopPrefixInitsM ss σ).1 = + Block.loopHasNoInvariants ss := by + match ss with + | [] => simp [Block.hoistLoopPrefixInitsM, Block.loopHasNoInvariants] + | s :: rest => + rw [Block.hoistLoopPrefixInitsM_cons_out, Block.loopHasNoInvariants_append, + Stmt.hoistLoopPrefixInitsM_loopHasNoInvariants s σ, + Block.hoistLoopPrefixInitsM_loopHasNoInvariants rest _, Block.loopHasNoInvariants] + termination_by sizeOf ss +end + +/-- The pass preserves `loopHasNoInvariants` in value. -/ +theorem Block.hoistLoopPrefixInits_loopHasNoInvariants_eq [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) : + Block.loopHasNoInvariants (Block.hoistLoopPrefixInits ss) = + Block.loopHasNoInvariants ss := by + rw [Block.hoistLoopPrefixInits, Block.hoistLoopPrefixInitsM_loopHasNoInvariants] + +end MonadicPostconds + +end Imperative diff --git a/Strata/Transform/LoopInitHoistBodyTransport.lean b/Strata/Transform/LoopInitHoistBodyTransport.lean new file mode 100644 index 0000000000..b2c765f6ee --- /dev/null +++ b/Strata/Transform/LoopInitHoistBodyTransport.lean @@ -0,0 +1,1207 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.DL.Imperative.StmtSemantics +public import Strata.DL.Imperative.CmdSemantics +public import Strata.Transform.LoopInitHoist +public import Strata.Transform.LoopInitHoistContains +public import Strata.Transform.LoopInitHoistFreshness +public import Strata.Transform.LoopInitHoistRewrite +public import Strata.Transform.LoopInitHoistInfra +public import Strata.Transform.LoopInitHoistLoopDriver +public import Strata.Transform.LoopInitHoistStepBProvider +public import Strata.Transform.LoopInitHoistKeystone + +import all Strata.DL.Imperative.Stmt +import all Strata.DL.Imperative.Cmd +import all Strata.Transform.LoopInitHoist +import all Strata.Transform.LoopInitHoistContains +import all Strata.Transform.LoopInitHoistFreshness +import all Strata.Transform.LoopInitHoistRewrite +import all Strata.Transform.LoopInitHoistInfra + +public section + +namespace Imperative +namespace LoopInitHoistBodyTransport + +/-! +# Body transport for the loop-init hoist pass (Option E). + +This module provides the general per-iteration *body transport* the loop-init +hoist correctness proof consumes for a renamed-and-lifted loop body. + +When the pass processes a `.loop`, it (post-order) first hoist-processes the body +to `body₁`, then `Block.liftInitsInLoopBodyM body₁` harvests the prefix inits into +prelude havocs, rewrites each lifted `init y ty rhs md` to `set y rhs md` in +`body₂`, and records a rename `(y, y')`. Finally `body₃ = Block.applyRenames +renames body₂` renames every recorded source name `y` to its fresh hoist target +`y'`. The per-iteration *body simulation* needed by the loop driver relates the +source body `body₁` to the renamed-lifted body `body₃`. + +The correspondence between `body₁` and `body₃` is captured by the inductive +relation `BodyTransport A B subst body_src body_h`: a per-statement rewrite where +* a lifted `init` becomes a renamed `set` (`set_both_in_subst` transport), +* an `assert`/`assume`/`cover` predicate is renamed by `substFvarMany`, +* a `.block` is rewritten recursively and re-projected on exit, +* a `.ite` keeps its guard (it reads no renamed name) and rewrites both branches, +* a nested `.loop` keeps measure/invariants empty and has its guard renamed to + `substFvarMany g subst` and its body rewritten recursively. + +`Block.bodyTransport` then turns a `BodyTransport` derivation into the +eval-carrying SUM-TYPED body simulation `BodySimES A B subst body_src body_h` (the +loop driver's sum-typed `body_sim` slot). The proof is by +induction on the `BodyTransport` derivation; the nested-loop arm feeds the +inductive hypothesis on the inner body into the renamed-guard loop driver. +-/ + +open StructuredToUnstructuredCorrect (extendStoreOne extendStoreOne_self extendStoreOne_other) +open OptEStepBProvider (StmtSimE + BodySimES StmtSimES bodySimES_cons bodySimES_nil bodySimES_to_bodySimSum + stmtSimE_to_stmtSimES_of_noExit cmd_stmt_no_exit exit_stmtSimES + block_stmtSimES ite_stmtSimES ite_nondet_stmtSimES nestedLoop_stmtSimES + BodySimFail StmtSimFail bodySimFail_nil bodySimFail_cons + cmd_stmtSimFail typeDecl_stmtSimFail exit_stmtSimFail + ite_stmtSimFail ite_nondet_stmtSimFail block_stmtSimFail nestedLoop_stmtSimFail) + +variable {P : PureExpr} + +/-! ## Local inversion / forward helpers. + +The general inversion/forward step lemmas live `private` in the infra modules; we +re-derive the few we need against `EvalCmd` so they are usable in this module. -/ + +/-- Invert `.stmt (.cmd c) ρ ⟶* .terminal ρ'` into the `EvalCmd` evidence. -/ +private theorem stmt_cmd_terminal_inv' [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {c : Cmd P} {ρ ρ' : Env P} + (h : StepStmtStar P (EvalCmd P) extendEval (.stmt (.cmd c) ρ) (.terminal ρ')) : + ∃ σ' hf, EvalCmd P ρ.eval ρ.store c σ' hf ∧ + ρ' = { ρ with store := σ', hasFailure := ρ.hasFailure || hf } := by + cases h with + | step _ _ _ h1 hr1 => + cases h1 with + | step_cmd h_eval => + cases hr1 with + | refl => exact ⟨_, _, h_eval, rfl⟩ + | step _ _ _ hd _ => exact nomatch hd + +/-- Forward: a single command whose `EvalCmd` holds steps to `.terminal`. -/ +private theorem stmt_cmd_step_forward' [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {c : Cmd P} {ρ : Env P} {σ' : SemanticStore P} {hf : Bool} + (h : EvalCmd P ρ.eval ρ.store c σ' hf) : + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd c) ρ) + (.terminal { ρ with store := σ', hasFailure := ρ.hasFailure || hf }) := + .step _ _ _ (.step_cmd h) (.refl _) + +/-- Invert a `.typeDecl` run to terminal: it is a runtime no-op (env unchanged). -/ +private theorem typeDecl_terminal_inv' [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {tc : TypeConstructor} {md : MetaData P} {ρ ρ' : Env P} + (h : StepStmtStar P (EvalCmd P) extendEval (.stmt (.typeDecl tc md) ρ) (.terminal ρ')) : + ρ' = ρ := by + cases h with + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | refl => rfl + | step _ _ _ hd _ => exact nomatch hd + +/-- Forward: a `.typeDecl` steps to `.terminal` with the env unchanged. -/ +private theorem typeDecl_step_forward' [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {tc : TypeConstructor} {md : MetaData P} {ρ : Env P} : + StepStmtStar P (EvalCmd P) extendEval (.stmt (.typeDecl tc md) ρ) (.terminal ρ) := + .step _ _ _ .step_typeDecl (.refl _) + +/-- A single `.typeDecl` statement never reaches `.exiting` (it steps to `.terminal` +via `step_typeDecl` and is then stuck). -/ +private theorem typeDecl_stmt_no_exit [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + (tc : TypeConstructor) (md : MetaData P) : + ∀ (ρ : Env P) (l : String) (ρe : Env P), + ¬ StepStmtStar P (EvalCmd P) extendEval (.stmt (.typeDecl tc md) ρ) (.exiting l ρe) := by + intro ρ l ρe h + cases h with + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | step _ _ _ hd _ => exact nomatch hd + +/-- Condition transport across the multi-pair `HoistInv`, re-derived from the +public `substFvarMany_eval_tweak`. -/ +private theorem cond_transport' [HasFvar P] [HasSubstFvar P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {δ : SemanticEval P} {e : P.Expr} {σ_s σ_h : SemanticStore P} + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_B_fresh : ∀ x ∈ B, x ∉ HasVarsPure.getVars e) + (h_hinv : HoistInv (P := P) A B subst σ_s σ_h) + (h_read_def : ∀ x ∈ HasVarsPure.getVars e, σ_s x ≠ none) + (h_wfcongr : WellFormedSemanticEvalExprCongr δ) + (h_wfsubst : WellFormedSemanticEvalSubstFvar δ) : + δ σ_s e = δ σ_h (substFvarMany e subst) := by + classical + have h_congr : δ σ_s e = δ (fun x => σ_h (renameLookup subst x)) e := by + apply h_wfcongr e σ_s (fun x => σ_h (renameLookup subst x)) + intro x hx + -- A read var `x` is either a rename SOURCE (in `subst.fst`) — handled by the + -- guarded pairing (read ⇒ defined ⇒ the pairing antecedent holds) — or it is + -- outside the rename and `A`/`B`-frame, handled by the guarded frame. + by_cases hx_src : x ∈ subst.map Prod.fst + · obtain ⟨⟨a, b⟩, hb_pair, hxa⟩ := List.mem_map.mp hx_src + simp only at hxa + subst a + rw [renameLookup_mem subst h_src_nodup hb_pair] + exact (h_hinv.2 x b hb_pair (h_read_def x hx)).2 + · have hx_notin_A : x ∉ A := fun hA => hx_src (h_A_subst_fst x hA) + have hx_notin_B : x ∉ B := fun hB => h_B_fresh x hB hx + rw [renameLookup_notin subst x hx_src] + -- Guarded frame: read var `x` is defined in `σ_s` by `h_read_def`. + exact h_hinv.1 x hx_notin_A hx_notin_B (h_read_def x hx) + rw [h_congr] + exact substFvarMany_eval_tweak δ subst h_src_nodup h_disjoint h_tgt_nodup h_wfsubst + +/-! ## The body-transport correspondence relation. + +`BodyTransport A B subst body_src body_h` relates a source body (post Step A) to +its renamed-lifted image, per statement. This is the exact correspondence that +`Block.applyRenames (substOf' entries) (Block.liftInitsInLoopBodyM body_src).2.2` +produces: lifted inits become renamed sets, expressions are `substFvarMany`-renamed, +nested loops have their guard renamed and body recursively transported. -/ +inductive BodyTransport [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) : + List (Stmt P (Cmd P)) → List (Stmt P (Cmd P)) → Prop where + | nil : BodyTransport A B subst [] [] + | init_set {a b : P.Ident} {τ : P.Ty} {rhs : P.Expr} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_pair : (a, b) ∈ subst) (h_a_in_A : a ∈ A) (h_b_in_B : b ∈ B) + (h_unique_a : ∀ a' b', (a', b') ∈ subst → a' = a → b' = b) + (h_unique_b : ∀ a' b', (a', b') ∈ subst → b' = b → a' = a) + (h_B_fresh_rhs : ∀ x ∈ B, x ∉ HasVarsPure.getVars rhs) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.cmd (.init a τ (.det rhs) md) :: body_src) + (.cmd (.set b (.det (substFvarMany rhs subst)) md) :: body_h) + -- A nondet-rhs `init` is lifted exactly like a det one: the lift harvests a + -- fresh-name havoc + rename `(a, b)` and rewrites the source statement to a + -- `set a .nondet`, which `applyRenames` renames to `set b .nondet`. The source + -- nondet-init `InitState`s `a` (undef → arbitrary `v`); the hoist nondet-set + -- `UpdateState`s `b` (def → the SAME `v`) — `set_both_in_subst` transport. + | init_nondet {a b : P.Ident} {τ : P.Ty} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_pair : (a, b) ∈ subst) (h_a_in_A : a ∈ A) (h_b_in_B : b ∈ B) + (h_unique_a : ∀ a' b', (a', b') ∈ subst → a' = a → b' = b) + (h_unique_b : ∀ a' b', (a', b') ∈ subst → b' = b → a' = a) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.cmd (.init a τ .nondet md) :: body_src) + (.cmd (.set b .nondet md) :: body_h) + -- A `.set` whose LHS `a` is a rename SOURCE (`a ∈ A`, `(a, b) ∈ subst`). When a + -- loop body BOTH declares (`init a`) AND later sets (`set a`) the same var, the + -- lift hoists the declaration and renames the source `a → b` consistently in BOTH + -- the lifted-init and the later `.set` (`applyRenames` renames `.set a → .set b`, + -- identical to the `.init` site). So the later `.set a` becomes `.set b` on the + -- hoist side, with its `.det` rhs `substFvarMany`-renamed. The source `UpdateState`s + -- `a` (def → `v`); the hoist `UpdateState`s `b` (def → the SAME `v`) — + -- `set_both_in_subst` transport (the SAME transport `init_set` uses for its set side). + | set_renamed {a b : P.Ident} {rhs : P.Expr} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_pair : (a, b) ∈ subst) (h_a_in_A : a ∈ A) (h_b_in_B : b ∈ B) + (h_unique_a : ∀ a' b', (a', b') ∈ subst → a' = a → b' = b) + (h_unique_b : ∀ a' b', (a', b') ∈ subst → b' = b → a' = a) + (h_B_fresh_rhs : ∀ x ∈ B, x ∉ HasVarsPure.getVars rhs) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.cmd (.set a (.det rhs) md) :: body_src) + (.cmd (.set b (.det (substFvarMany rhs subst)) md) :: body_h) + -- A nondet-rhs `.set` whose LHS `a` is a rename source, renamed `a → b` exactly + -- like the det case (`applyRenames` renames `.set a .nondet → .set b .nondet`). The + -- source `InitState`-free nondet set chooses `v`; the hoist nondet-set replays the + -- SAME `v` into `b` — `set_both_in_subst` transport. + | set_renamed_nondet {a b : P.Ident} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_pair : (a, b) ∈ subst) (h_a_in_A : a ∈ A) (h_b_in_B : b ∈ B) + (h_unique_a : ∀ a' b', (a', b') ∈ subst → a' = a → b' = b) + (h_unique_b : ∀ a' b', (a', b') ∈ subst → b' = b → a' = a) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.cmd (.set a .nondet md) :: body_src) + (.cmd (.set b .nondet md) :: body_h) + -- A genuine `.set` (NOT from init lifting, NOT a rename source) is passed through by + -- the lift (no entry, no rename of its name because its name `∈ modifiedVars` hence + -- `∉ A` and the subst sources lie in `A`). Its `.det` rhs is `substFvarMany`-renamed. + -- The source `UpdateState`s `name` (def → `v`); the hoist `UpdateState`s the SAME + -- `name` (def → `v`) — `extend_both_outside_subst` transport (`name ∉ A ∪ B`). + | set {name : P.Ident} {rhs : P.Expr} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_name_notin_A : name ∉ A) (h_name_notin_B : name ∉ B) + (h_B_fresh_rhs : ∀ x ∈ B, x ∉ HasVarsPure.getVars rhs) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.cmd (.set name (.det rhs) md) :: body_src) + (.cmd (.set name (.det (substFvarMany rhs subst)) md) :: body_h) + -- A genuine nondet-rhs `.set` is passed through identically (name unchanged, + -- `.nondet` rhs fixed by `substFvarMany`). `extend_both_outside_subst` transport. + | set_nondet {name : P.Ident} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_name_notin_A : name ∉ A) (h_name_notin_B : name ∉ B) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.cmd (.set name .nondet md) :: body_src) + (.cmd (.set name .nondet md) :: body_h) + | assert {lbl : String} {e : P.Expr} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_B_fresh_e : ∀ x ∈ B, x ∉ HasVarsPure.getVars e) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.cmd (.assert lbl e md) :: body_src) + (.cmd (.assert lbl (substFvarMany e subst) md) :: body_h) + | assume {lbl : String} {e : P.Expr} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_B_fresh_e : ∀ x ∈ B, x ∉ HasVarsPure.getVars e) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.cmd (.assume lbl e md) :: body_src) + (.cmd (.assume lbl (substFvarMany e subst) md) :: body_h) + | cover {lbl : String} {e : P.Expr} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.cmd (.cover lbl e md) :: body_src) + (.cmd (.cover lbl (substFvarMany e subst) md) :: body_h) + -- A `.typeDecl` is a runtime no-op, left unchanged by the rename (`substIdent` + -- fixes it); the source and hoist both step to terminal with the same env. + | typeDecl {tc : TypeConstructor} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.typeDecl tc md :: body_src) + (.typeDecl tc md :: body_h) + | block {lbl : String} {md : MetaData P} + {inner_src inner_h body_src body_h : List (Stmt P (Cmd P))} + (h_inner : BodyTransport A B subst inner_src inner_h) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.block lbl inner_src md :: body_src) + (.block lbl inner_h md :: body_h) + -- `.ite`: guard RENAMED to `substFvarMany g subst` (the pass `applyRenames`- + -- substitutes it). The renamed guard reads no renamed name (every var of `g` + -- is `A`/`B`-fresh), so it evaluates as the original `g` under `HoistInv`. + | ite {g : P.Expr} {md : MetaData P} + {tss_src tss_h ess_src ess_h body_src body_h : List (Stmt P (Cmd P))} + (h_B_fresh_g : ∀ x ∈ B, x ∉ HasVarsPure.getVars g) + (h_then : BodyTransport A B subst tss_src tss_h) + (h_else : BodyTransport A B subst ess_src ess_h) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.ite (.det g) tss_src ess_src md :: body_src) + (.ite (.det (substFvarMany g subst)) tss_h ess_h md :: body_h) + -- A nondet-guard `.ite` is passed through (guard `.nondet` fixed by the rename); + -- the source's nondet branch selection is replayed verbatim by the hoist. + | ite_nondet {md : MetaData P} + {tss_src tss_h ess_src ess_h body_src body_h : List (Stmt P (Cmd P))} + (h_then : BodyTransport A B subst tss_src tss_h) + (h_else : BodyTransport A B subst ess_src ess_h) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.ite .nondet tss_src ess_src md :: body_src) + (.ite .nondet tss_h ess_h md :: body_h) + -- Nested loop: measure/invariants empty (the pass requires it); guard RENAMED to + -- `substFvarMany g subst`; body recursively transported. + | loop {g : P.Expr} {md : MetaData P} + {lbody_src lbody_h body_src body_h : List (Stmt P (Cmd P))} + (h_B_fresh_g : ∀ x ∈ B, x ∉ HasVarsPure.getVars g) + (h_lbody : BodyTransport A B subst lbody_src lbody_h) + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.loop (.det g) none [] lbody_src md :: body_src) + (.loop (.det (substFvarMany g subst)) none [] lbody_h md :: body_h) + -- An `.exit lbl md` is left literally unchanged by the rename (`substIdent_exit` + -- fixes it). Its body run reaches `.exiting lbl` (the break pattern), which the + -- hoist `.exit` replays at the SAME label. The exiting clause of the sum-typed + -- body sim copies the body-entry invariant unchanged. + | exit {lbl : String} {md : MetaData P} + {body_src body_h : List (Stmt P (Cmd P))} + (h_rest : BodyTransport A B subst body_src body_h) : + BodyTransport A B subst + (.exit lbl md :: body_src) + (.exit lbl md :: body_h) + +/-! ## Structural facts about `BodyTransport` source/hoist bodies. + +`BodyTransport`-related bodies are `noFuncDecl` (no `.funcDecl` constructor) and +never reach a labeled `.exiting` (no top-level `.exit` constructor). -/ + +/-- A `BodyTransport` source body contains no `.funcDecl`. -/ +theorem BodyTransport.noFuncDecl_src [HasFvar P] [HasSubstFvar P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {body_src body_h : List (Stmt P (Cmd P))} + (hrw : BodyTransport (P := P) A B subst body_src body_h) : + Block.noFuncDecl body_src = true := by + induction hrw with + | nil => simp [Block.noFuncDecl] + | init_set _ _ _ _ _ _ _ ih | assert _ _ ih | assume _ _ ih | cover _ ih + | init_nondet _ _ _ _ _ _ ih | set _ _ _ _ ih | set_nondet _ _ _ ih | typeDecl _ ih + | set_renamed _ _ _ _ _ _ _ ih | set_renamed_nondet _ _ _ _ _ _ ih | exit _ ih => + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.true_and]; exact ih + | block _ _ ih_inner ih_rest => + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_eq_true] + exact ⟨by simpa [Block.noFuncDecl] using ih_inner, ih_rest⟩ + | ite _ _ _ _ ih_then ih_else ih_rest => + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_eq_true] + exact ⟨⟨by simpa [Block.noFuncDecl] using ih_then, + by simpa [Block.noFuncDecl] using ih_else⟩, ih_rest⟩ + | ite_nondet _ _ _ ih_then ih_else ih_rest => + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_eq_true] + exact ⟨⟨by simpa [Block.noFuncDecl] using ih_then, + by simpa [Block.noFuncDecl] using ih_else⟩, ih_rest⟩ + | loop _ _ _ ih_lbody ih_rest => + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_eq_true] + exact ⟨by simpa [Block.noFuncDecl] using ih_lbody, ih_rest⟩ + +/-- A `BodyTransport` hoist body contains no `.funcDecl`. -/ +theorem BodyTransport.noFuncDecl_h [HasFvar P] [HasSubstFvar P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {body_src body_h : List (Stmt P (Cmd P))} + (hrw : BodyTransport (P := P) A B subst body_src body_h) : + Block.noFuncDecl body_h = true := by + induction hrw with + | nil => simp [Block.noFuncDecl] + | init_set _ _ _ _ _ _ _ ih | assert _ _ ih | assume _ _ ih | cover _ ih + | init_nondet _ _ _ _ _ _ ih | set _ _ _ _ ih | set_nondet _ _ _ ih | typeDecl _ ih + | set_renamed _ _ _ _ _ _ _ ih | set_renamed_nondet _ _ _ _ _ _ ih | exit _ ih => + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.true_and]; exact ih + | block _ _ ih_inner ih_rest => + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_eq_true] + exact ⟨by simpa [Block.noFuncDecl] using ih_inner, ih_rest⟩ + | ite _ _ _ _ ih_then ih_else ih_rest => + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_eq_true] + exact ⟨⟨by simpa [Block.noFuncDecl] using ih_then, + by simpa [Block.noFuncDecl] using ih_else⟩, ih_rest⟩ + | ite_nondet _ _ _ ih_then ih_else ih_rest => + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_eq_true] + exact ⟨⟨by simpa [Block.noFuncDecl] using ih_then, + by simpa [Block.noFuncDecl] using ih_else⟩, ih_rest⟩ + | loop _ _ _ ih_lbody ih_rest => + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_eq_true] + exact ⟨by simpa [Block.noFuncDecl] using ih_lbody, ih_rest⟩ + +/-! ## Singleton-body `BodySimES` → `StmtSimES`. + +A `BodySimES A B subst [s] [s']` is exactly a `StmtSimES A B subst s s'`: a +`.stmts [s] ρ` run reaches a terminal/exiting config iff the corresponding +`.stmt s ρ` run does (the singleton-list wrapper steps `step_stmts_cons` / +`step_seq_done` / `step_stmts_nil` around the single statement, and back). The +`_to_fail` induction uses this to recover each arm's head `StmtSimES` (needed by +`bodySimFail_cons`'s head-terminates case) by running `Block.bodyTransport` on the +singleton head transport. -/ +theorem bodySimES_singleton_to_stmtSimES [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} {s s' : Stmt P (Cmd P)} + (h : BodySimES (extendEval := extendEval) A B subst [s] [s']) : + StmtSimES (extendEval := extendEval) A B subst s s' := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd + obtain ⟨h_term, h_exit⟩ := h ρ_s ρ_h h_hinv h_eval h_hf h_bnd + refine ⟨?_, ?_⟩ + · -- terminal: lift `.stmt s ρ_s → .terminal ρ_s'` to `.stmts [s] ρ_s → .terminal`, + -- apply the singleton body's terminal clause, then peel the hoist `.stmts [s']` run. + intro ρ_s' h_run + have h_stmts : StepStmtStar P (EvalCmd P) extendEval (.stmts [s] ρ_s) (.terminal ρ_s') := + .step _ _ _ StepStmt.step_stmts_cons + (ReflTrans_Transitive _ _ _ _ (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_run) + (.step _ _ _ StepStmt.step_seq_done + (.step _ _ _ StepStmt.step_stmts_nil (.refl _)))) + obtain ⟨ρ_h', h_h_run, h_hinv', h_hf', h_bnd', h_eval'⟩ := h_term ρ_s' h_stmts + refine ⟨ρ_h', ?_, h_hinv', h_hf', h_bnd', h_eval'⟩ + -- peel `.stmts [s'] ρ_h → .terminal ρ_h'` back to `.stmt s' ρ_h → .terminal ρ_h'`. + obtain ⟨ρ_mid, h_head, h_nil⟩ := stmts_cons_terminal_inv (extendEval := extendEval) h_h_run + have : ρ_mid = ρ_h' := by + cases h_nil with + | step _ _ _ hd hr => cases hd; cases hr with + | refl => rfl + | step _ _ _ hd' _ => exact nomatch hd' + rw [this] at h_head; exact h_head + · intro l ρ_s' h_run + have h_stmts : StepStmtStar P (EvalCmd P) extendEval (.stmts [s] ρ_s) (.exiting l ρ_s') := + .step _ _ _ StepStmt.step_stmts_cons + (ReflTrans_Transitive _ _ _ _ (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_run) + (.step _ _ _ StepStmt.step_seq_exit (.refl _))) + obtain ⟨ρ_h', h_h_run, h_hinv', h_hf', h_bnd', h_eval'⟩ := h_exit l ρ_s' h_stmts + refine ⟨ρ_h', ?_, h_hinv', h_hf', h_bnd', h_eval'⟩ + -- peel `.stmts [s'] ρ_h → .exiting l ρ_h'` back to `.stmt s' ρ_h → .exiting l ρ_h'`. + cases h_h_run with + | step _ _ _ hd hr => + cases hd + rcases seq_reaches_exiting P (EvalCmd P) extendEval hr with + h_head | ⟨ρ_mid, _, h_tail⟩ + · exact h_head + · -- the tail `.stmts [] ρ_mid` cannot reach `.exiting`. + exact absurd h_tail (by + intro h; cases h with + | step _ _ _ hd2 hr2 => cases hd2; cases hr2 with + | step _ _ _ hd3 _ => exact nomatch hd3) + +/-! ## The body transport: `BodyTransport` derivation → `BodySimES`. + +By induction on the `BodyTransport` derivation. Each arm fires the per-statement +hoist replay (renamed set/predicate, recursive block/ite, renamed nested loop) and +sequences via the SUM-TYPED cons-shaped tail IH (`bodySimES_cons`). Each `.cmd` +arm produces a terminal-only `StmtSimE` (a command never `.exiting`s) which lifts +to a `StmtSimES` for free via `stmtSimE_to_stmtSimES_of_noExit`; the `.block` / +`.ite` / nested-`.loop` arms feed their sum-typed inner IH into the banked +`block_stmtSimES` / `ite_stmtSimES` / `nestedLoop_stmtSimES` arms; the new `.exit` +base case is `exit_stmtSimES`. -/ +theorem Block.bodyTransport [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {body_src body_h : List (Stmt P (Cmd P))} + (hrw : BodyTransport (P := P) A B subst body_src body_h) + (h_subst_fst_A : ∀ a ∈ subst.map Prod.fst, a ∈ A) + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_subst_snd_B : ∀ b ∈ subst.map Prod.snd, b ∈ B) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + BodySimES (extendEval := extendEval) A B subst body_src body_h := by + classical + induction hrw with + | nil => exact bodySimES_nil A B subst + | @init_set a b τ rhs md body_src body_h h_pair h_a_in_A h_b_in_B + h_unique_a h_unique_b h_B_fresh_rhs _ ih => + refine bodySimES_cons (stmtSimE_to_stmtSimES_of_noExit (cmd_stmt_no_exit _) ?_) ih + -- head StmtSimE: init a → set b. + unfold OptEStepBProvider.StmtSimE + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + obtain ⟨σ_a, hf_a, h_init_eval, h_ρ_a_eq⟩ := stmt_cmd_terminal_inv' h_run + obtain ⟨v, h_rhs_src, h_initstate, _wfv, _wfc⟩ : + ∃ v, ρ_s.eval ρ_s.store rhs = .some v ∧ + InitState P ρ_s.store a v σ_a ∧ + WellFormedSemanticEvalVar ρ_s.eval ∧ + WellFormedSemanticEvalExprCongr ρ_s.eval := by + cases h_init_eval with + | eval_init h_eval h_is h_wfv h_wfc => exact ⟨_, h_eval, h_is, h_wfv, h_wfc⟩ + obtain ⟨h_is_a_none, h_is_a_some, h_is_other⟩ := h_initstate + have h_hf_a : hf_a = false := by cases h_init_eval with | eval_init _ _ _ _ => rfl + subst h_hf_a + subst h_ρ_a_eq + have h_rhs_hoist : + ρ_h.eval ρ_h.store (substFvarMany rhs subst) = .some v := by + have h := cond_transport' (δ := ρ_s.eval) (e := rhs) + (σ_s := ρ_s.store) (σ_h := ρ_h.store) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup + h_B_fresh_rhs h_hinv + (read_vars_def_of_eval (h_wfdef ρ_s) h_rhs_src) + (h_wfcongr ρ_s) (h_wfsubst ρ_s) + rw [← h_eval, ← h]; exact h_rhs_src + obtain ⟨v_old, h_b_old⟩ := Option.ne_none_iff_exists'.mp (h_bnd b h_b_in_B) + have h_update : UpdateState P ρ_h.store b v (extendStoreOne ρ_h.store b v) := + .update h_b_old (extendStoreOne_self ρ_h.store b v) + (fun z hz => extendStoreOne_other ρ_h.store b v z (fun h => hz h.symm)) + have h_set_eval : EvalCmd P ρ_h.eval ρ_h.store + (.set b (.det (substFvarMany rhs subst)) md) + (extendStoreOne ρ_h.store b v) false := + .eval_set h_rhs_hoist h_update (h_wfvar ρ_h) (h_wfcongr ρ_h) + have h_σa_ext : σ_a = extendStoreOne ρ_s.store a v := by + funext z + by_cases hza : z = a + · subst z + have e1 : σ_a a = some v := h_is_a_some + have e2 : extendStoreOne ρ_s.store a v a = some v := extendStoreOne_self ρ_s.store a v + rw [e1, e2] + · have e1 : σ_a z = ρ_s.store z := h_is_other z (fun h => hza h.symm) + have e2 : extendStoreOne ρ_s.store a v z = ρ_s.store z := + extendStoreOne_other ρ_s.store a v z hza + rw [e1, e2] + have h_hinv_mid : HoistInv (P := P) A B subst + σ_a (extendStoreOne ρ_h.store b v) := by + rw [h_σa_ext] + exact HoistInv.set_both_in_subst (a := a) (b := b) (v := v) + h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b h_hinv + obtain ⟨ρ_h', h_ρ_h'⟩ : ∃ em : Env P, + em = { ρ_h with store := extendStoreOne ρ_h.store b v, hasFailure := ρ_h.hasFailure || false } := ⟨_, rfl⟩ + have h_store' : ρ_h'.store = extendStoreOne ρ_h.store b v := congrArg (·.store) h_ρ_h' + have h_eval' : ρ_h'.eval = ρ_h.eval := congrArg (·.eval) h_ρ_h' + have h_hf' : ρ_h'.hasFailure = (ρ_h.hasFailure || false) := congrArg (·.hasFailure) h_ρ_h' + refine ⟨ρ_h', ?_, ?_, ?_, ?_, ?_⟩ + · rw [h_ρ_h']; exact stmt_cmd_step_forward' h_set_eval + · rw [h_store']; exact h_hinv_mid + · rw [h_hf']; simp only [Bool.or_false]; exact h_hf + · intro b' hb' + rw [h_store'] + by_cases hb'b : b' = b + · subst hb'b + have e : extendStoreOne ρ_h.store b' v b' = some v := extendStoreOne_self ρ_h.store b' v + rw [e]; exact Option.some_ne_none v + · have e : extendStoreOne ρ_h.store b v b' = ρ_h.store b' := + extendStoreOne_other ρ_h.store b v b' hb'b + rw [e]; exact h_bnd b' hb' + · rw [h_eval']; exact h_eval + | @init_nondet a b τ md body_src body_h h_pair h_a_in_A h_b_in_B + h_unique_a h_unique_b _ ih => + refine bodySimES_cons (stmtSimE_to_stmtSimES_of_noExit (cmd_stmt_no_exit _) ?_) ih + -- head StmtSimE: nondet init a → nondet set b (replays the SAME chosen value). + unfold OptEStepBProvider.StmtSimE + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + obtain ⟨σ_a, hf_a, h_init_eval, h_ρ_a_eq⟩ := stmt_cmd_terminal_inv' h_run + obtain ⟨v, h_initstate, _wfv⟩ : + ∃ v, InitState P ρ_s.store a v σ_a ∧ WellFormedSemanticEvalVar ρ_s.eval := by + cases h_init_eval with + | eval_init_unconstrained h_is h_wfv => exact ⟨_, h_is, h_wfv⟩ + obtain ⟨h_is_a_none, h_is_a_some, h_is_other⟩ := h_initstate + have h_hf_a : hf_a = false := by cases h_init_eval with | eval_init_unconstrained _ _ => rfl + subst h_hf_a + subst h_ρ_a_eq + obtain ⟨v_old, h_b_old⟩ := Option.ne_none_iff_exists'.mp (h_bnd b h_b_in_B) + have h_update : UpdateState P ρ_h.store b v (extendStoreOne ρ_h.store b v) := + .update h_b_old (extendStoreOne_self ρ_h.store b v) + (fun z hz => extendStoreOne_other ρ_h.store b v z (fun h => hz h.symm)) + have h_set_eval : EvalCmd P ρ_h.eval ρ_h.store + (.set b .nondet md) (extendStoreOne ρ_h.store b v) false := + .eval_set_nondet h_update (h_wfvar ρ_h) + have h_σa_ext : σ_a = extendStoreOne ρ_s.store a v := by + funext z + by_cases hza : z = a + · subst z + have e1 : σ_a a = some v := h_is_a_some + have e2 : extendStoreOne ρ_s.store a v a = some v := extendStoreOne_self ρ_s.store a v + rw [e1, e2] + · have e1 : σ_a z = ρ_s.store z := h_is_other z (fun h => hza h.symm) + have e2 : extendStoreOne ρ_s.store a v z = ρ_s.store z := + extendStoreOne_other ρ_s.store a v z hza + rw [e1, e2] + have h_hinv_mid : HoistInv (P := P) A B subst + σ_a (extendStoreOne ρ_h.store b v) := by + rw [h_σa_ext] + exact HoistInv.set_both_in_subst (a := a) (b := b) (v := v) + h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b h_hinv + obtain ⟨ρ_h', h_ρ_h'⟩ : ∃ em : Env P, + em = { ρ_h with store := extendStoreOne ρ_h.store b v, hasFailure := ρ_h.hasFailure || false } := ⟨_, rfl⟩ + have h_store' : ρ_h'.store = extendStoreOne ρ_h.store b v := congrArg (·.store) h_ρ_h' + have h_eval' : ρ_h'.eval = ρ_h.eval := congrArg (·.eval) h_ρ_h' + have h_hf' : ρ_h'.hasFailure = (ρ_h.hasFailure || false) := congrArg (·.hasFailure) h_ρ_h' + refine ⟨ρ_h', ?_, ?_, ?_, ?_, ?_⟩ + · rw [h_ρ_h']; exact stmt_cmd_step_forward' h_set_eval + · rw [h_store']; exact h_hinv_mid + · rw [h_hf']; simp only [Bool.or_false]; exact h_hf + · intro b' hb' + rw [h_store'] + by_cases hb'b : b' = b + · subst hb'b + have e : extendStoreOne ρ_h.store b' v b' = some v := extendStoreOne_self ρ_h.store b' v + rw [e]; exact Option.some_ne_none v + · have e : extendStoreOne ρ_h.store b v b' = ρ_h.store b' := + extendStoreOne_other ρ_h.store b v b' hb'b + rw [e]; exact h_bnd b' hb' + · rw [h_eval']; exact h_eval + | @set_renamed a b rhs md body_src body_h h_pair h_a_in_A h_b_in_B + h_unique_a h_unique_b h_B_fresh_rhs _ ih => + refine bodySimES_cons (stmtSimE_to_stmtSimES_of_noExit (cmd_stmt_no_exit _) ?_) ih + -- head StmtSimE: set a (.det rhs) → set b (.det (substFvarMany rhs subst)). + -- The LHS `a` is a rename SOURCE, renamed to its target `b`. The source updates + -- slot `a` (def → `v`); the hoist updates slot `b` (def → the SAME `v`) — exactly + -- the `set_both_in_subst` transport that `init_set` uses for its hoist set side. + unfold OptEStepBProvider.StmtSimE + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + obtain ⟨σ_a, hf_a, h_set_eval_src, h_ρ_a_eq⟩ := stmt_cmd_terminal_inv' h_run + obtain ⟨v, v_old, h_rhs_src, h_us_a_some_old, h_us_a_some, h_us_other⟩ : + ∃ v v_old, ρ_s.eval ρ_s.store rhs = .some v ∧ + ρ_s.store a = .some v_old ∧ σ_a a = .some v ∧ + (∀ y, a ≠ y → σ_a y = ρ_s.store y) := by + cases h_set_eval_src with + | eval_set h_eval h_us h_wfv h_wfc => + cases h_us with + | update h1 h2 h3 => exact ⟨_, _, h_eval, h1, h2, h3⟩ + have h_hf_a : hf_a = false := by cases h_set_eval_src with | eval_set _ _ _ _ => rfl + subst h_hf_a + subst h_ρ_a_eq + have h_rhs_hoist : + ρ_h.eval ρ_h.store (substFvarMany rhs subst) = .some v := by + have h := cond_transport' (δ := ρ_s.eval) (e := rhs) + (σ_s := ρ_s.store) (σ_h := ρ_h.store) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup + h_B_fresh_rhs h_hinv + (read_vars_def_of_eval (h_wfdef ρ_s) h_rhs_src) + (h_wfcongr ρ_s) (h_wfsubst ρ_s) + rw [← h_eval, ← h]; exact h_rhs_src + obtain ⟨v_old_b, h_b_old⟩ := Option.ne_none_iff_exists'.mp (h_bnd b h_b_in_B) + have h_update : UpdateState P ρ_h.store b v (extendStoreOne ρ_h.store b v) := + .update h_b_old (extendStoreOne_self ρ_h.store b v) + (fun z hz => extendStoreOne_other ρ_h.store b v z (fun h => hz h.symm)) + have h_set_eval : EvalCmd P ρ_h.eval ρ_h.store + (.set b (.det (substFvarMany rhs subst)) md) + (extendStoreOne ρ_h.store b v) false := + .eval_set h_rhs_hoist h_update (h_wfvar ρ_h) (h_wfcongr ρ_h) + have h_σa_ext : σ_a = extendStoreOne ρ_s.store a v := by + funext z + by_cases hza : z = a + · subst z + have e1 : σ_a a = some v := h_us_a_some + have e2 : extendStoreOne ρ_s.store a v a = some v := extendStoreOne_self ρ_s.store a v + rw [e1, e2] + · have e1 : σ_a z = ρ_s.store z := h_us_other z (fun h => hza h.symm) + have e2 : extendStoreOne ρ_s.store a v z = ρ_s.store z := + extendStoreOne_other ρ_s.store a v z hza + rw [e1, e2] + have h_hinv_mid : HoistInv (P := P) A B subst + σ_a (extendStoreOne ρ_h.store b v) := by + rw [h_σa_ext] + exact HoistInv.set_both_in_subst (a := a) (b := b) (v := v) + h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b h_hinv + obtain ⟨ρ_h', h_ρ_h'⟩ : ∃ em : Env P, + em = { ρ_h with store := extendStoreOne ρ_h.store b v, hasFailure := ρ_h.hasFailure || false } := ⟨_, rfl⟩ + have h_store' : ρ_h'.store = extendStoreOne ρ_h.store b v := congrArg (·.store) h_ρ_h' + have h_eval' : ρ_h'.eval = ρ_h.eval := congrArg (·.eval) h_ρ_h' + have h_hf' : ρ_h'.hasFailure = (ρ_h.hasFailure || false) := congrArg (·.hasFailure) h_ρ_h' + refine ⟨ρ_h', ?_, ?_, ?_, ?_, ?_⟩ + · rw [h_ρ_h']; exact stmt_cmd_step_forward' h_set_eval + · rw [h_store']; exact h_hinv_mid + · rw [h_hf']; simp only [Bool.or_false]; exact h_hf + · intro b' hb' + rw [h_store'] + by_cases hb'b : b' = b + · subst hb'b + have e : extendStoreOne ρ_h.store b' v b' = some v := extendStoreOne_self ρ_h.store b' v + rw [e]; exact Option.some_ne_none v + · have e : extendStoreOne ρ_h.store b v b' = ρ_h.store b' := + extendStoreOne_other ρ_h.store b v b' hb'b + rw [e]; exact h_bnd b' hb' + · rw [h_eval']; exact h_eval + | @set_renamed_nondet a b md body_src body_h h_pair h_a_in_A h_b_in_B + h_unique_a h_unique_b _ ih => + refine bodySimES_cons (stmtSimE_to_stmtSimES_of_noExit (cmd_stmt_no_exit _) ?_) ih + -- head StmtSimE: nondet set a → nondet set b (replays the SAME chosen value). + -- The LHS `a` is a rename source, renamed to `b`; `set_both_in_subst` transport. + unfold OptEStepBProvider.StmtSimE + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + obtain ⟨σ_a, hf_a, h_set_eval_src, h_ρ_a_eq⟩ := stmt_cmd_terminal_inv' h_run + obtain ⟨v, v_old, h_us_a_some_old, h_us_a_some, h_us_other⟩ : + ∃ v v_old, ρ_s.store a = .some v_old ∧ σ_a a = .some v ∧ + (∀ y, a ≠ y → σ_a y = ρ_s.store y) := by + cases h_set_eval_src with + | eval_set_nondet h_us h_wfv => + cases h_us with + | update h1 h2 h3 => exact ⟨_, _, h1, h2, h3⟩ + have h_hf_a : hf_a = false := by cases h_set_eval_src with | eval_set_nondet _ _ => rfl + subst h_hf_a + subst h_ρ_a_eq + obtain ⟨v_old_b, h_b_old⟩ := Option.ne_none_iff_exists'.mp (h_bnd b h_b_in_B) + have h_update : UpdateState P ρ_h.store b v (extendStoreOne ρ_h.store b v) := + .update h_b_old (extendStoreOne_self ρ_h.store b v) + (fun z hz => extendStoreOne_other ρ_h.store b v z (fun h => hz h.symm)) + have h_set_eval : EvalCmd P ρ_h.eval ρ_h.store + (.set b .nondet md) (extendStoreOne ρ_h.store b v) false := + .eval_set_nondet h_update (h_wfvar ρ_h) + have h_σa_ext : σ_a = extendStoreOne ρ_s.store a v := by + funext z + by_cases hza : z = a + · subst z + have e1 : σ_a a = some v := h_us_a_some + have e2 : extendStoreOne ρ_s.store a v a = some v := extendStoreOne_self ρ_s.store a v + rw [e1, e2] + · have e1 : σ_a z = ρ_s.store z := h_us_other z (fun h => hza h.symm) + have e2 : extendStoreOne ρ_s.store a v z = ρ_s.store z := + extendStoreOne_other ρ_s.store a v z hza + rw [e1, e2] + have h_hinv_mid : HoistInv (P := P) A B subst + σ_a (extendStoreOne ρ_h.store b v) := by + rw [h_σa_ext] + exact HoistInv.set_both_in_subst (a := a) (b := b) (v := v) + h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b h_hinv + obtain ⟨ρ_h', h_ρ_h'⟩ : ∃ em : Env P, + em = { ρ_h with store := extendStoreOne ρ_h.store b v, hasFailure := ρ_h.hasFailure || false } := ⟨_, rfl⟩ + have h_store' : ρ_h'.store = extendStoreOne ρ_h.store b v := congrArg (·.store) h_ρ_h' + have h_eval' : ρ_h'.eval = ρ_h.eval := congrArg (·.eval) h_ρ_h' + have h_hf' : ρ_h'.hasFailure = (ρ_h.hasFailure || false) := congrArg (·.hasFailure) h_ρ_h' + refine ⟨ρ_h', ?_, ?_, ?_, ?_, ?_⟩ + · rw [h_ρ_h']; exact stmt_cmd_step_forward' h_set_eval + · rw [h_store']; exact h_hinv_mid + · rw [h_hf']; simp only [Bool.or_false]; exact h_hf + · intro b' hb' + rw [h_store'] + by_cases hb'b : b' = b + · subst hb'b + have e : extendStoreOne ρ_h.store b' v b' = some v := extendStoreOne_self ρ_h.store b' v + rw [e]; exact Option.some_ne_none v + · have e : extendStoreOne ρ_h.store b v b' = ρ_h.store b' := + extendStoreOne_other ρ_h.store b v b' hb'b + rw [e]; exact h_bnd b' hb' + · rw [h_eval']; exact h_eval + | @set name rhs md body_src body_h h_name_notin_A h_name_notin_B + h_B_fresh_rhs _ ih => + refine bodySimES_cons (stmtSimE_to_stmtSimES_of_noExit (cmd_stmt_no_exit _) ?_) ih + -- head StmtSimE: set name (.det rhs) → set name (.det (substFvarMany rhs subst)). + -- The name is UNCHANGED (it is `∉ A`, and the subst sources lie in `A`), so both + -- sides update the SAME slot, off the subst frame — `extend_both_outside_subst`. + unfold OptEStepBProvider.StmtSimE + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + obtain ⟨σ_a, hf_a, h_set_eval_src, h_ρ_a_eq⟩ := stmt_cmd_terminal_inv' h_run + obtain ⟨v, v_old, h_rhs_src, h_us_name_some_old, h_us_name_some, h_us_other⟩ : + ∃ v v_old, ρ_s.eval ρ_s.store rhs = .some v ∧ + ρ_s.store name = .some v_old ∧ σ_a name = .some v ∧ + (∀ y, name ≠ y → σ_a y = ρ_s.store y) := by + cases h_set_eval_src with + | eval_set h_eval h_us h_wfv h_wfc => + cases h_us with + | update h1 h2 h3 => exact ⟨_, _, h_eval, h1, h2, h3⟩ + have h_hf_a : hf_a = false := by cases h_set_eval_src with | eval_set _ _ _ _ => rfl + subst h_hf_a + subst h_ρ_a_eq + have h_rhs_hoist : + ρ_h.eval ρ_h.store (substFvarMany rhs subst) = .some v := by + have h := cond_transport' (δ := ρ_s.eval) (e := rhs) + (σ_s := ρ_s.store) (σ_h := ρ_h.store) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup + h_B_fresh_rhs h_hinv + (read_vars_def_of_eval (h_wfdef ρ_s) h_rhs_src) + (h_wfcongr ρ_s) (h_wfsubst ρ_s) + rw [← h_eval, ← h]; exact h_rhs_src + -- name is bound on the hoist side (it equals the source slot, which is `some`). + -- The frame read needs `name` defined in the source: it IS (`set` updates a + -- previously-bound slot, so `ρ_s.store name = some v_old`). + have h_name_src_ne : ρ_s.store name ≠ none := by rw [h_us_name_some_old]; exact Option.some_ne_none v_old + have h_name_src_eq_hoist : ρ_s.store name = ρ_h.store name := + h_hinv.1 name h_name_notin_A h_name_notin_B h_name_src_ne + have h_name_hoist_some : ρ_h.store name = some v_old := by + rw [← h_name_src_eq_hoist]; exact h_us_name_some_old + have h_update : UpdateState P ρ_h.store name v (extendStoreOne ρ_h.store name v) := + .update h_name_hoist_some (extendStoreOne_self ρ_h.store name v) + (fun z hz => extendStoreOne_other ρ_h.store name v z (fun h => hz h.symm)) + have h_set_eval : EvalCmd P ρ_h.eval ρ_h.store + (.set name (.det (substFvarMany rhs subst)) md) + (extendStoreOne ρ_h.store name v) false := + .eval_set h_rhs_hoist h_update (h_wfvar ρ_h) (h_wfcongr ρ_h) + have h_σa_ext : σ_a = extendStoreOne ρ_s.store name v := by + funext z + by_cases hzn : z = name + · subst z + have e1 : σ_a name = some v := h_us_name_some + have e2 : extendStoreOne ρ_s.store name v name = some v := extendStoreOne_self ρ_s.store name v + rw [e1, e2] + · have e1 : σ_a z = ρ_s.store z := h_us_other z (fun h => hzn h.symm) + have e2 : extendStoreOne ρ_s.store name v z = ρ_s.store z := + extendStoreOne_other ρ_s.store name v z hzn + rw [e1, e2] + have h_hinv_mid : HoistInv (P := P) A B subst + σ_a (extendStoreOne ρ_h.store name v) := by + rw [h_σa_ext] + exact HoistInv.extend_both_outside_subst (x := name) (v := v) + h_name_notin_A h_name_notin_B + (fun a' b' hp => ⟨h_subst_fst_A a' (List.mem_map.mpr ⟨(a', b'), hp, rfl⟩), + h_subst_snd_B b' (List.mem_map.mpr ⟨(a', b'), hp, rfl⟩)⟩) + h_hinv + obtain ⟨ρ_h', h_ρ_h'⟩ : ∃ em : Env P, + em = { ρ_h with store := extendStoreOne ρ_h.store name v, hasFailure := ρ_h.hasFailure || false } := ⟨_, rfl⟩ + have h_store' : ρ_h'.store = extendStoreOne ρ_h.store name v := congrArg (·.store) h_ρ_h' + have h_eval' : ρ_h'.eval = ρ_h.eval := congrArg (·.eval) h_ρ_h' + have h_hf' : ρ_h'.hasFailure = (ρ_h.hasFailure || false) := congrArg (·.hasFailure) h_ρ_h' + refine ⟨ρ_h', ?_, ?_, ?_, ?_, ?_⟩ + · rw [h_ρ_h']; exact stmt_cmd_step_forward' h_set_eval + · rw [h_store']; exact h_hinv_mid + · rw [h_hf']; simp only [Bool.or_false]; exact h_hf + · intro b' hb' + rw [h_store'] + by_cases hb'n : b' = name + · subst hb'n + have e : extendStoreOne ρ_h.store b' v b' = some v := extendStoreOne_self ρ_h.store b' v + rw [e]; exact Option.some_ne_none v + · have e : extendStoreOne ρ_h.store name v b' = ρ_h.store b' := + extendStoreOne_other ρ_h.store name v b' hb'n + rw [e]; exact h_bnd b' hb' + · rw [h_eval']; exact h_eval + | @set_nondet name md body_src body_h h_name_notin_A h_name_notin_B _ ih => + refine bodySimES_cons (stmtSimE_to_stmtSimES_of_noExit (cmd_stmt_no_exit _) ?_) ih + -- head StmtSimE: nondet set name → nondet set name (same slot, off the frame). + unfold OptEStepBProvider.StmtSimE + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + obtain ⟨σ_a, hf_a, h_set_eval_src, h_ρ_a_eq⟩ := stmt_cmd_terminal_inv' h_run + obtain ⟨v, v_old, h_us_name_some_old, h_us_name_some, h_us_other⟩ : + ∃ v v_old, ρ_s.store name = .some v_old ∧ σ_a name = .some v ∧ + (∀ y, name ≠ y → σ_a y = ρ_s.store y) := by + cases h_set_eval_src with + | eval_set_nondet h_us h_wfv => + cases h_us with + | update h1 h2 h3 => exact ⟨_, _, h1, h2, h3⟩ + have h_hf_a : hf_a = false := by cases h_set_eval_src with | eval_set_nondet _ _ => rfl + subst h_hf_a + subst h_ρ_a_eq + have h_name_src_ne : ρ_s.store name ≠ none := by rw [h_us_name_some_old]; exact Option.some_ne_none v_old + have h_name_src_eq_hoist : ρ_s.store name = ρ_h.store name := + h_hinv.1 name h_name_notin_A h_name_notin_B h_name_src_ne + have h_name_hoist_some : ρ_h.store name = some v_old := by + rw [← h_name_src_eq_hoist]; exact h_us_name_some_old + have h_update : UpdateState P ρ_h.store name v (extendStoreOne ρ_h.store name v) := + .update h_name_hoist_some (extendStoreOne_self ρ_h.store name v) + (fun z hz => extendStoreOne_other ρ_h.store name v z (fun h => hz h.symm)) + have h_set_eval : EvalCmd P ρ_h.eval ρ_h.store + (.set name .nondet md) (extendStoreOne ρ_h.store name v) false := + .eval_set_nondet h_update (h_wfvar ρ_h) + have h_σa_ext : σ_a = extendStoreOne ρ_s.store name v := by + funext z + by_cases hzn : z = name + · subst z + have e1 : σ_a name = some v := h_us_name_some + have e2 : extendStoreOne ρ_s.store name v name = some v := extendStoreOne_self ρ_s.store name v + rw [e1, e2] + · have e1 : σ_a z = ρ_s.store z := h_us_other z (fun h => hzn h.symm) + have e2 : extendStoreOne ρ_s.store name v z = ρ_s.store z := + extendStoreOne_other ρ_s.store name v z hzn + rw [e1, e2] + have h_hinv_mid : HoistInv (P := P) A B subst + σ_a (extendStoreOne ρ_h.store name v) := by + rw [h_σa_ext] + exact HoistInv.extend_both_outside_subst (x := name) (v := v) + h_name_notin_A h_name_notin_B + (fun a' b' hp => ⟨h_subst_fst_A a' (List.mem_map.mpr ⟨(a', b'), hp, rfl⟩), + h_subst_snd_B b' (List.mem_map.mpr ⟨(a', b'), hp, rfl⟩)⟩) + h_hinv + obtain ⟨ρ_h', h_ρ_h'⟩ : ∃ em : Env P, + em = { ρ_h with store := extendStoreOne ρ_h.store name v, hasFailure := ρ_h.hasFailure || false } := ⟨_, rfl⟩ + have h_store' : ρ_h'.store = extendStoreOne ρ_h.store name v := congrArg (·.store) h_ρ_h' + have h_eval' : ρ_h'.eval = ρ_h.eval := congrArg (·.eval) h_ρ_h' + have h_hf' : ρ_h'.hasFailure = (ρ_h.hasFailure || false) := congrArg (·.hasFailure) h_ρ_h' + refine ⟨ρ_h', ?_, ?_, ?_, ?_, ?_⟩ + · rw [h_ρ_h']; exact stmt_cmd_step_forward' h_set_eval + · rw [h_store']; exact h_hinv_mid + · rw [h_hf']; simp only [Bool.or_false]; exact h_hf + · intro b' hb' + rw [h_store'] + by_cases hb'n : b' = name + · subst hb'n + have e : extendStoreOne ρ_h.store b' v b' = some v := extendStoreOne_self ρ_h.store b' v + rw [e]; exact Option.some_ne_none v + · have e : extendStoreOne ρ_h.store name v b' = ρ_h.store b' := + extendStoreOne_other ρ_h.store name v b' hb'n + rw [e]; exact h_bnd b' hb' + · rw [h_eval']; exact h_eval + | @assert lbl e md body_src body_h h_B_fresh_e _ ih => + refine bodySimES_cons (stmtSimE_to_stmtSimES_of_noExit (cmd_stmt_no_exit _) ?_) ih + unfold OptEStepBProvider.StmtSimE + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + obtain ⟨σ_a, hf_a, h_head_eval, h_ρ_a_eq⟩ := stmt_cmd_terminal_inv' h_run + have h_store_eq : σ_a = ρ_s.store := by + cases h_head_eval with + | eval_assert_pass _ _ _ => rfl + | eval_assert_fail _ _ _ => rfl + have h_e_some : ∃ w, ρ_s.eval ρ_s.store e = some w := by + cases h_head_eval with + | eval_assert_pass h_tt _ _ => exact ⟨_, h_tt⟩ + | eval_assert_fail h_ff _ _ => exact ⟨_, h_ff⟩ + have h_cond : ρ_s.eval ρ_s.store e = + ρ_h.eval ρ_h.store (substFvarMany e subst) := by + rw [← h_eval] + obtain ⟨w, h_e_w⟩ := h_e_some + exact cond_transport' (δ := ρ_s.eval) (e := e) (σ_s := ρ_s.store) (σ_h := ρ_h.store) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup + h_B_fresh_e h_hinv + (read_vars_def_of_eval (h_wfdef ρ_s) h_e_w) + (h_wfcongr ρ_s) (h_wfsubst ρ_s) + have h_assert_hoist : EvalCmd P ρ_h.eval ρ_h.store + (.assert lbl (substFvarMany e subst) md) ρ_h.store hf_a := by + cases h_head_eval with + | eval_assert_pass h_tt h_wfb _ => + exact .eval_assert_pass (by rw [← h_cond]; exact h_tt) (h_eval ▸ h_wfb) (h_wfcongr ρ_h) + | eval_assert_fail h_ff h_wfb _ => + exact .eval_assert_fail (by rw [← h_cond]; exact h_ff) (h_eval ▸ h_wfb) (h_wfcongr ρ_h) + subst h_ρ_a_eq + obtain ⟨ρ_h', h_ρ_h'⟩ : ∃ em : Env P, + em = { ρ_h with store := ρ_h.store, hasFailure := ρ_h.hasFailure || hf_a } := ⟨_, rfl⟩ + have h_store' : ρ_h'.store = ρ_h.store := congrArg (·.store) h_ρ_h' + have h_eval' : ρ_h'.eval = ρ_h.eval := congrArg (·.eval) h_ρ_h' + have h_hf' : ρ_h'.hasFailure = (ρ_h.hasFailure || hf_a) := congrArg (·.hasFailure) h_ρ_h' + refine ⟨ρ_h', ?_, ?_, ?_, ?_, ?_⟩ + · rw [h_ρ_h']; exact stmt_cmd_step_forward' h_assert_hoist + · rw [h_store', h_store_eq]; exact h_hinv + · rw [h_hf']; rw [h_hf] + · intro b' hb'; rw [h_store']; exact h_bnd b' hb' + · rw [h_eval']; exact h_eval + | @assume lbl e md body_src body_h h_B_fresh_e _ ih => + refine bodySimES_cons (stmtSimE_to_stmtSimES_of_noExit (cmd_stmt_no_exit _) ?_) ih + unfold OptEStepBProvider.StmtSimE + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + obtain ⟨σ_a, hf_a, h_head_eval, h_ρ_a_eq⟩ := stmt_cmd_terminal_inv' h_run + have h_store_eq : σ_a = ρ_s.store := by cases h_head_eval with | eval_assume _ _ _ => rfl + have h_hf_a : hf_a = false := by cases h_head_eval with | eval_assume _ _ _ => rfl + have h_e_some : ∃ w, ρ_s.eval ρ_s.store e = some w := by + cases h_head_eval with | eval_assume h_tt _ _ => exact ⟨_, h_tt⟩ + have h_cond : ρ_s.eval ρ_s.store e = + ρ_h.eval ρ_h.store (substFvarMany e subst) := by + rw [← h_eval] + obtain ⟨w, h_e_w⟩ := h_e_some + exact cond_transport' (δ := ρ_s.eval) (e := e) (σ_s := ρ_s.store) (σ_h := ρ_h.store) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup + h_B_fresh_e h_hinv + (read_vars_def_of_eval (h_wfdef ρ_s) h_e_w) + (h_wfcongr ρ_s) (h_wfsubst ρ_s) + have h_assume_hoist : EvalCmd P ρ_h.eval ρ_h.store + (.assume lbl (substFvarMany e subst) md) ρ_h.store false := by + cases h_head_eval with + | eval_assume h_tt h_wfb _ => + exact .eval_assume (by rw [← h_cond]; exact h_tt) (h_eval ▸ h_wfb) (h_wfcongr ρ_h) + subst h_hf_a + subst h_ρ_a_eq + obtain ⟨ρ_h', h_ρ_h'⟩ : ∃ em : Env P, + em = { ρ_h with store := ρ_h.store, hasFailure := ρ_h.hasFailure || false } := ⟨_, rfl⟩ + have h_store' : ρ_h'.store = ρ_h.store := congrArg (·.store) h_ρ_h' + have h_eval' : ρ_h'.eval = ρ_h.eval := congrArg (·.eval) h_ρ_h' + have h_hf' : ρ_h'.hasFailure = (ρ_h.hasFailure || false) := congrArg (·.hasFailure) h_ρ_h' + refine ⟨ρ_h', ?_, ?_, ?_, ?_, ?_⟩ + · rw [h_ρ_h']; exact stmt_cmd_step_forward' h_assume_hoist + · rw [h_store', h_store_eq]; exact h_hinv + · rw [h_hf']; simp only [Bool.or_false]; exact h_hf + · intro b' hb'; rw [h_store']; exact h_bnd b' hb' + · rw [h_eval']; exact h_eval + | @cover lbl e md body_src body_h _ ih => + refine bodySimES_cons (stmtSimE_to_stmtSimES_of_noExit (cmd_stmt_no_exit _) ?_) ih + unfold OptEStepBProvider.StmtSimE + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + obtain ⟨σ_a, hf_a, h_head_eval, h_ρ_a_eq⟩ := stmt_cmd_terminal_inv' h_run + have h_store_eq : σ_a = ρ_s.store := by cases h_head_eval with | eval_cover _ => rfl + have h_hf_a : hf_a = false := by cases h_head_eval with | eval_cover _ => rfl + have h_cover_hoist : EvalCmd P ρ_h.eval ρ_h.store + (.cover lbl (substFvarMany e subst) md) ρ_h.store false := by + cases h_head_eval with + | eval_cover h_wfb => exact .eval_cover (h_eval ▸ h_wfb) + subst h_hf_a + subst h_ρ_a_eq + obtain ⟨ρ_h', h_ρ_h'⟩ : ∃ em : Env P, + em = { ρ_h with store := ρ_h.store, hasFailure := ρ_h.hasFailure || false } := ⟨_, rfl⟩ + have h_store' : ρ_h'.store = ρ_h.store := congrArg (·.store) h_ρ_h' + have h_eval' : ρ_h'.eval = ρ_h.eval := congrArg (·.eval) h_ρ_h' + have h_hf' : ρ_h'.hasFailure = (ρ_h.hasFailure || false) := congrArg (·.hasFailure) h_ρ_h' + refine ⟨ρ_h', ?_, ?_, ?_, ?_, ?_⟩ + · rw [h_ρ_h']; exact stmt_cmd_step_forward' h_cover_hoist + · rw [h_store', h_store_eq]; exact h_hinv + · rw [h_hf']; simp only [Bool.or_false]; exact h_hf + · intro b' hb'; rw [h_store']; exact h_bnd b' hb' + · rw [h_eval']; exact h_eval + | @typeDecl tc md body_src body_h _ ih => + refine bodySimES_cons (stmtSimE_to_stmtSimES_of_noExit (typeDecl_stmt_no_exit tc md) ?_) ih + -- head StmtSimE: a `.typeDecl` is a no-op on both sides (env unchanged). + unfold OptEStepBProvider.StmtSimE + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + have h_ρ_s'_eq : ρ_s' = ρ_s := typeDecl_terminal_inv' h_run + subst h_ρ_s'_eq + exact ⟨ρ_h, typeDecl_step_forward', h_hinv, h_hf, h_bnd, h_eval⟩ + | @block lbl md inner_src inner_h body_src body_h h_inner h_rest ih_inner ih_rest => + -- The inner body's SUM-TYPED sim feeds the banked `block_stmtSimES` (all three + -- block outcomes: inner-terminal, label-match catch, label-mismatch propagate). + exact bodySimES_cons (block_stmtSimES ih_inner) ih_rest + | @ite g md tss_src tss_h ess_src ess_h body_src body_h + h_B_fresh_g h_then h_else h_rest ih_then ih_else ih_rest => + -- The renamed guard `substFvarMany g subst` evaluates on `ρ_h` exactly as the + -- source guard `g` on `ρ_s` (it reads no renamed name) — the `cond_transport'` + -- fact, packaged for `ite_stmtSimES`. + have h_guard_eq : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∃ w, ρ_s.eval ρ_s.store g = some w) → + ρ_s.eval ρ_s.store g = ρ_h.eval ρ_h.store (substFvarMany g subst) := by + intro ρ_s ρ_h h_hinv h_eval ⟨w, h_g_w⟩ + have h := cond_transport' (δ := ρ_s.eval) (e := g) (σ_s := ρ_s.store) (σ_h := ρ_h.store) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup + h_B_fresh_g h_hinv + (read_vars_def_of_eval (h_wfdef ρ_s) h_g_w) + (h_wfcongr ρ_s) (h_wfsubst ρ_s) + rw [h, h_eval] + exact bodySimES_cons (ite_stmtSimES h_guard_eq ih_then ih_else) ih_rest + | @ite_nondet md tss_src tss_h ess_src ess_h body_src body_h + h_then h_else h_rest ih_then ih_else ih_rest => + -- A nondet `.ite` makes no guard test; the hoist replays the SAME branch choice. + exact bodySimES_cons (ite_nondet_stmtSimES ih_then ih_else) ih_rest + | @loop g md lbody_src lbody_h body_src body_h + h_B_fresh_g h_lbody h_rest ih_lbody ih_rest => + -- head StmtSimES for the renamed nested loop, via `nestedLoop_stmtSimES`; its + -- inner-body sim is the SUM-TYPED IH (`bodySimES_to_bodySimSum ih_lbody`). + have inner_sim : LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) A B subst + lbody_src lbody_h := bodySimES_to_bodySimSum ih_lbody + exact bodySimES_cons + (nestedLoop_stmtSimES (A := A) (B := B) (subst := subst) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup h_B_fresh_g + h_wfvar h_wfcongr h_wfsubst h_wfdef inner_sim + h_lbody.noFuncDecl_src h_lbody.noFuncDecl_h) + ih_rest + | @exit lbl md body_src body_h h_rest ih_rest => + -- A `.exit lbl md` is left literally unchanged by the rename; its base sim is + -- the banked `exit_stmtSimES`. + exact bodySimES_cons (exit_stmtSimES A B subst lbl md) ih_rest + +/-! ## The failing body transport: `BodyTransport` → `BodySimFail`. + +The `_to_fail` sibling of `Block.bodyTransport`, by the SAME induction on the +`BodyTransport` derivation but producing `BodySimFail` (a failing source-body run +is matched by a failing hoist-body run). Each arm sequences via `bodySimFail_cons`, +which needs the head's `StmtSimES` (for the case where the head terminates and the +TAIL fails) and the head's `StmtSimFail` (for the case where the head fails). + +The head `StmtSimES` per arm is recovered by running `Block.bodyTransport` on the +SINGLETON head transport (` args BodyTransport.nil`) and projecting via +`bodySimES_singleton_to_stmtSimES`. The head `StmtSimFail` is the matching per-kind +producer: atomic (`.cmd`/`.typeDecl`/`.exit`) lift from the head `StmtSimES`; the +`.block`/`.ite`/nested-`.loop` producers consume the inner body's `BodySimFail` (the +recursive IH), and the nested loop also consumes the inner `BodySimSum` +(`bodySimES_to_bodySimSum` of the inner `Block.bodyTransport`). -/ +theorem Block.bodyTransport_to_fail [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {body_src body_h : List (Stmt P (Cmd P))} + (hrw : BodyTransport (P := P) A B subst body_src body_h) + (h_subst_fst_A : ∀ a ∈ subst.map Prod.fst, a ∈ A) + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_subst_snd_B : ∀ b ∈ subst.map Prod.snd, b ∈ B) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + BodySimFail (extendEval := extendEval) A B subst body_src body_h := by + classical + -- Local abbreviation: the head `StmtSimES` from a singleton head transport. + have head_es : ∀ {s s' : Stmt P (Cmd P)}, + BodyTransport (P := P) A B subst [s] [s'] → + StmtSimES (extendEval := extendEval) A B subst s s' := fun hsingle => + bodySimES_singleton_to_stmtSimES + (Block.bodyTransport hsingle h_subst_fst_A h_A_subst_fst h_subst_snd_B + h_src_nodup h_disjoint h_tgt_nodup h_wfvar h_wfcongr h_wfsubst h_wfdef) + induction hrw with + | nil => exact bodySimFail_nil A B subst + | @init_set a b τ rhs md body_src body_h h_pair h_a_in_A h_b_in_B + h_unique_a h_unique_b h_B_fresh_rhs _ ih => + exact bodySimFail_cons + (head_es (.init_set h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b h_B_fresh_rhs .nil)) + (cmd_stmtSimFail + (head_es (.init_set h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b h_B_fresh_rhs .nil))) + ih + | @init_nondet a b τ md body_src body_h h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b _ ih => + exact bodySimFail_cons + (head_es (.init_nondet h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b .nil)) + (cmd_stmtSimFail + (head_es (.init_nondet h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b .nil))) + ih + | @set_renamed a b rhs md body_src body_h h_pair h_a_in_A h_b_in_B + h_unique_a h_unique_b h_B_fresh_rhs _ ih => + exact bodySimFail_cons + (head_es (.set_renamed h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b h_B_fresh_rhs .nil)) + (cmd_stmtSimFail + (head_es (.set_renamed h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b h_B_fresh_rhs .nil))) + ih + | @set_renamed_nondet a b md body_src body_h h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b _ ih => + exact bodySimFail_cons + (head_es (.set_renamed_nondet h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b .nil)) + (cmd_stmtSimFail + (head_es (.set_renamed_nondet h_pair h_a_in_A h_b_in_B h_unique_a h_unique_b .nil))) + ih + | @set name rhs md body_src body_h h_name_notin_A h_name_notin_B h_B_fresh_rhs _ ih => + exact bodySimFail_cons + (head_es (.set h_name_notin_A h_name_notin_B h_B_fresh_rhs .nil)) + (cmd_stmtSimFail (head_es (.set h_name_notin_A h_name_notin_B h_B_fresh_rhs .nil))) + ih + | @set_nondet name md body_src body_h h_name_notin_A h_name_notin_B _ ih => + exact bodySimFail_cons + (head_es (.set_nondet h_name_notin_A h_name_notin_B .nil)) + (cmd_stmtSimFail (head_es (.set_nondet h_name_notin_A h_name_notin_B .nil))) + ih + | @assert lbl e md body_src body_h h_B_fresh_e _ ih => + exact bodySimFail_cons + (head_es (.assert h_B_fresh_e .nil)) + (cmd_stmtSimFail (head_es (.assert h_B_fresh_e .nil))) + ih + | @assume lbl e md body_src body_h h_B_fresh_e _ ih => + exact bodySimFail_cons + (head_es (.assume h_B_fresh_e .nil)) + (cmd_stmtSimFail (head_es (.assume h_B_fresh_e .nil))) + ih + | @cover lbl e md body_src body_h _ ih => + exact bodySimFail_cons + (head_es (.cover .nil)) + (cmd_stmtSimFail (head_es (.cover .nil))) + ih + | @typeDecl tc md body_src body_h _ ih => + exact bodySimFail_cons + (head_es (.typeDecl .nil)) + (typeDecl_stmtSimFail (head_es (.typeDecl .nil))) + ih + | @block lbl md inner_src inner_h body_src body_h h_inner h_rest ih_inner ih_rest => + have inner_es : BodySimES (extendEval := extendEval) A B subst inner_src inner_h := + Block.bodyTransport h_inner h_subst_fst_A h_A_subst_fst h_subst_snd_B + h_src_nodup h_disjoint h_tgt_nodup h_wfvar h_wfcongr h_wfsubst h_wfdef + exact bodySimFail_cons + (block_stmtSimES inner_es) + (block_stmtSimFail ih_inner) + ih_rest + | @ite g md tss_src tss_h ess_src ess_h body_src body_h + h_B_fresh_g h_then h_else h_rest ih_then ih_else ih_rest => + have h_guard_eq : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∃ w, ρ_s.eval ρ_s.store g = some w) → + ρ_s.eval ρ_s.store g = ρ_h.eval ρ_h.store (substFvarMany g subst) := by + intro ρ_s ρ_h h_hinv h_eval ⟨w, h_g_w⟩ + have h := cond_transport' (δ := ρ_s.eval) (e := g) (σ_s := ρ_s.store) (σ_h := ρ_h.store) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup + h_B_fresh_g h_hinv + (read_vars_def_of_eval (h_wfdef ρ_s) h_g_w) + (h_wfcongr ρ_s) (h_wfsubst ρ_s) + rw [h, h_eval] + have then_es : BodySimES (extendEval := extendEval) A B subst tss_src tss_h := + Block.bodyTransport h_then h_subst_fst_A h_A_subst_fst h_subst_snd_B + h_src_nodup h_disjoint h_tgt_nodup h_wfvar h_wfcongr h_wfsubst h_wfdef + have else_es : BodySimES (extendEval := extendEval) A B subst ess_src ess_h := + Block.bodyTransport h_else h_subst_fst_A h_A_subst_fst h_subst_snd_B + h_src_nodup h_disjoint h_tgt_nodup h_wfvar h_wfcongr h_wfsubst h_wfdef + exact bodySimFail_cons + (ite_stmtSimES h_guard_eq then_es else_es) + (ite_stmtSimFail h_guard_eq ih_then ih_else) + ih_rest + | @ite_nondet md tss_src tss_h ess_src ess_h body_src body_h + h_then h_else h_rest ih_then ih_else ih_rest => + have then_es : BodySimES (extendEval := extendEval) A B subst tss_src tss_h := + Block.bodyTransport h_then h_subst_fst_A h_A_subst_fst h_subst_snd_B + h_src_nodup h_disjoint h_tgt_nodup h_wfvar h_wfcongr h_wfsubst h_wfdef + have else_es : BodySimES (extendEval := extendEval) A B subst ess_src ess_h := + Block.bodyTransport h_else h_subst_fst_A h_A_subst_fst h_subst_snd_B + h_src_nodup h_disjoint h_tgt_nodup h_wfvar h_wfcongr h_wfsubst h_wfdef + exact bodySimFail_cons + (ite_nondet_stmtSimES then_es else_es) + (ite_nondet_stmtSimFail ih_then ih_else) + ih_rest + | @loop g md lbody_src lbody_h body_src body_h + h_B_fresh_g h_lbody h_rest ih_lbody ih_rest => + have inner_es : BodySimES (extendEval := extendEval) A B subst lbody_src lbody_h := + Block.bodyTransport h_lbody h_subst_fst_A h_A_subst_fst h_subst_snd_B + h_src_nodup h_disjoint h_tgt_nodup h_wfvar h_wfcongr h_wfsubst h_wfdef + have inner_sim : LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) A B subst + lbody_src lbody_h := bodySimES_to_bodySimSum inner_es + exact bodySimFail_cons + (nestedLoop_stmtSimES (A := A) (B := B) (subst := subst) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup h_B_fresh_g + h_wfvar h_wfcongr h_wfsubst h_wfdef inner_sim + h_lbody.noFuncDecl_src h_lbody.noFuncDecl_h) + (nestedLoop_stmtSimFail (A := A) (B := B) (subst := subst) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup h_B_fresh_g + h_wfvar h_wfcongr h_wfsubst h_wfdef inner_sim ih_lbody + h_lbody.noFuncDecl_src h_lbody.noFuncDecl_h) + ih_rest + | @exit lbl md body_src body_h h_rest ih_rest => + exact bodySimFail_cons + (exit_stmtSimES A B subst lbl md) + (exit_stmtSimFail A B subst lbl md) + ih_rest + +end LoopInitHoistBodyTransport +end Imperative + +end -- public section diff --git a/Strata/Transform/LoopInitHoistContains.lean b/Strata/Transform/LoopInitHoistContains.lean new file mode 100644 index 0000000000..06f2250cbf --- /dev/null +++ b/Strata/Transform/LoopInitHoistContains.lean @@ -0,0 +1,43 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.Transform.LoopInitHoist + +import all Strata.DL.Imperative.Cmd +import all Strata.DL.Imperative.Stmt +import all Strata.Transform.LoopInitHoist + +public section + +namespace Imperative + +variable {P : PureExpr} + +/-! # `containsFuncDecl` preservation through the hoisting pass + +The hoisting pass `Block.hoistLoopPrefixInits` threads the "no funcDecl +anywhere" structural invariant through its recursion, gating the merged +correctness proof's `loop_preserves_struct`. The predicate is SHAPE-ONLY (it +inspects the statement tree, not variable names), so the fresh-name +substitution introduced by the monadic pass leaves it invariant. The +monadic-pass postcondition is proven in `LoopInitHoist.lean` +(`hoistLoopPrefixInits_containsFuncDecl_eq`); here we package the `= false` +preservation corollary consumed downstream. +-/ + +/-- `Block.hoistLoopPrefixInits` preserves the "no funcDecl anywhere" +invariant. -/ +theorem Block.hoistLoopPrefixInits_preserves_containsFuncDecl + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (body : List (Stmt P (Cmd P))) + (h : Block.containsFuncDecl body = false) : + Block.containsFuncDecl (Block.hoistLoopPrefixInits body) = false := by + rw [Block.hoistLoopPrefixInits_containsFuncDecl_eq]; exact h + +end Imperative diff --git a/Strata/Transform/LoopInitHoistCorrect.lean b/Strata/Transform/LoopInitHoistCorrect.lean new file mode 100644 index 0000000000..db759bd274 --- /dev/null +++ b/Strata/Transform/LoopInitHoistCorrect.lean @@ -0,0 +1,4921 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.DL.Imperative.StmtSemantics +public import Strata.DL.Imperative.CmdSemantics +public import Strata.Transform.LoopInitHoist +public import Strata.Transform.LoopInitHoistContains +public import Strata.Transform.LoopInitHoistFreshness +public import Strata.Transform.LoopInitHoistRewrite +public import Strata.Transform.LoopInitHoistInfra +public import Strata.Transform.DetToKleeneCorrect +public import Strata.Transform.LoopInitHoistLoopDriver +public import Strata.Transform.LoopInitHoistStepCProducer +public import Strata.Transform.LoopInitHoistLoopArmWF +public import Strata.Transform.LoopInitHoistBodyTransport + +import all Strata.DL.Imperative.Stmt +import all Strata.DL.Imperative.Cmd +import all Strata.Transform.LoopInitHoist +import all Strata.Transform.LoopInitHoistContains +import all Strata.Transform.LoopInitHoistFreshness +import all Strata.Transform.LoopInitHoistRewrite +import all Strata.Transform.LoopInitHoistInfra +import all Strata.Transform.LoopInitHoistLoopDriver +import all Strata.Transform.LoopInitHoistStepCProducer +import all Strata.Transform.LoopInitHoistLoopArmWF +import all Strata.Transform.LoopInitHoistBodyTransport + +public section + +namespace Imperative + +/-! # Phase 8 — `Block.hoistLoopPrefixInits` correctness + +This module exposes the top-level forward-simulation theorem for the +hoisting pass `Block.hoistLoopPrefixInits` (Strata/Transform/LoopInitHoist.lean): + +``` +hoistLoopPrefixInits_preserves : + StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ_src) (.terminal ρ_src') → + ∃ ρ_h', + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.hoistLoopPrefixInits ss) ρ_src) (.terminal ρ_h') ∧ + StoreAgreement ρ_src'.store ρ_h'.store ∧ + ρ_h'.hasFailure = ρ_src'.hasFailure +``` + +The store relation is `StoreAgreement` (semantics preservation *modulo +hoisted variables*), not exact pointwise equality: the hoisting pass lifts +loop-body inits to fresh targets defined only in the hoisted store, so the +hoisted store legitimately carries entries the source store never defines. +`StoreAgreement σ_src σ_h` constrains only source-defined variables, leaving +those fresh hoist targets (and projected loop-locals) correctly unconstrained. + +The proof is a mutual structural induction on the source block, dispatching +each `.loop` arm via `loop_preserves_struct` (LoopInitHoistInfra) after +running the hoisted prelude. + +## Status + +The top-level theorem `hoistLoopPrefixInits_preserves` is fully discharged +(sorry-free). It is a direct invocation of the §E Block-level mutual +forward-simulation lemma `Block.hoistLoopPrefixInits_preserves`, whose every +arm — `.cmd`, `.block`, `.ite`, `.loop`, `.exit`-free, … — is closed. The +`.loop` arm runs the hoisted prelude, applies the lift renaming simulation on +the post-order body, and reconciles the loop-entry stores at the union +`HoistInv`. Phase 10 composition can be wired against the signature directly. +-/ + +variable {P : PureExpr} + +/-! ## §D — Structural preservation re-exports (S2..S5) + +Four structural invariants are preserved by `Block.hoistLoopPrefixInits`: + +| Invariant | Source | Preservation lemma | +|---|---|---| +| `loopBodyNoInits` | this file | `Block.hoistLoopPrefixInits_satisfies_loopBodyNoInits` | +| `loopHasNoInvariants` | `Stmt.lean` | `Block.hoistLoopPrefixInits_preserves_loopHasNoInvariants` | +| `exitsCoveredByBlocks` | `Stmt.lean` | `Block.hoistLoopPrefixInits_preserves_exitsCoveredByBlocks` | +| `loopMeasureNone` | `LoopInitHoist.lean` (Step 2) | `Block.hoistLoopPrefixInits_preserves_loopMeasureNone` | + +S2 (`loopBodyNoInits`) is the postcondition the pass was originally written +for; we re-export the existing public theorem under the canonical Phase 8 +naming pattern. S5 (`loopMeasureNone`) was added in Phase 8 §B +(`LoopInitHoist.lean`). S3 and S4 require their own proofs because the pass +only converts `init` to `set` and rewrites loop bodies — neither operation +introduces new loop invariants or new exit statements outside enclosing +blocks. -/ + +/-- S2 re-export: `Block.hoistLoopPrefixInits` preserves the +`Block.loopBodyNoInits` postcondition (in the trivial sense — the output +*satisfies* it unconditionally). + +Phase 8 naming convention: `_preserves_` for predicates that +admit a precondition shape; `_satisfies_` for postconditions +that hold unconditionally on the pass output. -/ +theorem Block.hoistLoopPrefixInits_preserves_loopBodyNoInits + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) : + Block.loopBodyNoInits (Block.hoistLoopPrefixInits ss) = true := + hoistLoopPrefixInits_satisfies_loopBodyNoInits ss + +/-! ### S3 — `loopHasNoInvariants` is preserved + +The pass never introduces new `.loop` invariants. Each `.loop g m inv body md` +in the input becomes `havocs.map .cmd ++ [.loop g m inv body' md]` where +`havocs` are `.cmd (.init y ty .nondet md)` (no invariants), and `body'` is +the lifted body (which goes through `liftInitsInLoopBody`, which doesn't +recurse into nested `.loop`s and so leaves their invariants untouched). + +The value-equation `Block.hoistLoopPrefixInits_loopHasNoInvariants_eq` is +proven (monadic + pure-wrapper bridge) in `LoopInitHoist.lean`; this is the +public preservation re-export under the canonical Phase 8 naming. -/ +/-- S3 public preservation entry-point. -/ +theorem Block.hoistLoopPrefixInits_preserves_loopHasNoInvariants + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) + (h : Block.loopHasNoInvariants ss = true) : + Block.loopHasNoInvariants (Block.hoistLoopPrefixInits ss) = true := by + rw [Block.hoistLoopPrefixInits_loopHasNoInvariants_eq]; exact h + +/-! ### S4 — `exitsCoveredByBlocks` is preserved + +The pass converts `.cmd (.init ...)` to `.cmd (.init ... .nondet)` (no exits) +and rewrites `.loop g m inv body md` to `havocs ++ [.loop g m inv body' md]`, +where the only exits in the output come from the body. Per +`Stmt.exitsCoveredByBlocks`'s `.loop` arm, exits in `body` are checked +against `labels` directly (no enclosing block label is added by the loop), +and the lifted body is structurally a subset of the original body's +exit-bearing tree (init/set commands have no exits). So the predicate is +preserved (in the strong, predicate-equality sense). -/ + +section ExitsCovered + +private theorem Block.exitsCoveredByBlocks_of_map_cmd + (labels : List String) (cs : List (Cmd P)) : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels + (cs.map (@Stmt.cmd P (Cmd P))) := + all_cmd_exitsCoveredByBlocks labels _ + (fun s hs => by + simp only [List.mem_map] at hs + obtain ⟨c, _, hc⟩ := hs + exact ⟨c, hc.symm⟩) + +/-! `Block.substIdent` / `Block.applyRenames` rename identifiers only; they +never touch block labels or exit statements, so `exitsCoveredByBlocks` is +invariant under them. (Prop-valued analogue of the Bool walkers' +`SubstIdentPreserves` in `LoopInitHoist.lean`.) -/ + +mutual +private theorem Stmt.substIdent_exitsCoveredByBlocks [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (labels : List String) (s : Stmt P (Cmd P)) + (h : Stmt.exitsCoveredByBlocks labels s) : + Stmt.exitsCoveredByBlocks labels (Stmt.substIdent y y' s) := by + cases s with + | cmd c => simp only [Stmt.substIdent_cmd, Stmt.exitsCoveredByBlocks] + | block lbl bss md => + simp only [Stmt.substIdent_block] + show Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks (lbl :: labels) + (Block.substIdent y y' bss) + exact Block.substIdent_exitsCoveredByBlocks y y' (lbl :: labels) bss h + | ite g tss ess md => + simp only [Stmt.substIdent_ite] + exact ⟨Block.substIdent_exitsCoveredByBlocks y y' labels tss h.1, + Block.substIdent_exitsCoveredByBlocks y y' labels ess h.2⟩ + | loop g m inv body md => + simp only [Stmt.substIdent_loop] + show Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels + (Block.substIdent y y' body) + exact Block.substIdent_exitsCoveredByBlocks y y' labels body h + | exit lbl md => simpa only [Stmt.substIdent_exit, Stmt.exitsCoveredByBlocks] using h + | funcDecl d md => simp only [Stmt.substIdent_funcDecl, Stmt.exitsCoveredByBlocks] + | typeDecl t md => simp only [Stmt.substIdent_typeDecl, Stmt.exitsCoveredByBlocks] + termination_by sizeOf s + +private theorem Block.substIdent_exitsCoveredByBlocks [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (y y' : P.Ident) (labels : List String) (ss : List (Stmt P (Cmd P))) + (h : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss) : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels + (Block.substIdent y y' ss) := by + match ss with + | [] => simp [Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + | s :: rest => + simp only [Block.substIdent_cons] + exact ⟨Stmt.substIdent_exitsCoveredByBlocks y y' labels s h.1, + Block.substIdent_exitsCoveredByBlocks y y' labels rest h.2⟩ + termination_by sizeOf ss +end + +private theorem Block.applyRenames_exitsCoveredByBlocks [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (labels : List String) + (ss : List (Stmt P (Cmd P))) + (h : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss) : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels + (Block.applyRenames renames ss) := by + unfold Block.applyRenames + induction renames generalizing ss with + | nil => simpa using h + | cons p rest ih => + simp only [List.foldl_cons] + exact ih (Block.substIdent p.1 p.2 ss) + (Block.substIdent_exitsCoveredByBlocks p.1 p.2 labels ss h) + +/-! ### Lift residual preserves `exitsCoveredByBlocks` + +The `.snd` residual of the monadic lift is unfolded via the `@[simp]` +`Stmt.liftInitsInLoopBody_snd_*` / `Block.liftInitsInLoopBody_snd_*` residual +equations (LoopInitHoist.lean) — the old `simp [Stmt.liftInitsInLoopBody]` +unfold no longer fires under the monadic wrapper. -/ + +mutual +/-- `Stmt.liftInitsInLoopBody`'s residual block preserves +`Stmt.exitsCoveredByBlocks`. -/ +private theorem Stmt.liftInitsInLoopBody_snd_exitsCoveredByBlocks [HasIdent P] + (labels : List String) (s : Stmt P (Cmd P)) + (h : Stmt.exitsCoveredByBlocks labels s) : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels + (Stmt.liftInitsInLoopBody s).snd := by + cases s with + | cmd c => + cases c with + | init x ty rhs md => + simp [Stmt.liftInitsInLoopBody_snd_cmd_init, Stmt.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + | set _ _ _ => + simp [Stmt.liftInitsInLoopBody_snd_cmd_set, Stmt.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + | assert _ _ _ => + simp [Stmt.liftInitsInLoopBody_snd_cmd_assert, Stmt.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + | assume _ _ _ => + simp [Stmt.liftInitsInLoopBody_snd_cmd_assume, Stmt.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + | cover _ _ _ => + simp [Stmt.liftInitsInLoopBody_snd_cmd_cover, Stmt.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + | block lbl bss md => + simp only [Stmt.liftInitsInLoopBody_snd_block] + refine ⟨?_, trivial⟩ + show Stmt.exitsCoveredByBlocks labels + (Stmt.block lbl (Block.liftInitsInLoopBody bss).snd md) + have h_inner : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks (lbl :: labels) bss := h + exact Block.liftInitsInLoopBody_snd_exitsCoveredByBlocks (lbl :: labels) bss h_inner + | ite g tss ess md => + simp only [Stmt.liftInitsInLoopBody_snd_ite] + refine ⟨⟨?_, ?_⟩, trivial⟩ + · exact Block.liftInitsInLoopBody_snd_exitsCoveredByBlocks labels tss h.1 + · exact Block.liftInitsInLoopBody_snd_exitsCoveredByBlocks labels ess h.2 + | loop g m inv body md => + -- liftInitsInLoopBody does NOT recurse into .loop bodies; output is + -- `[.loop g m inv body md]` unchanged. + simp only [Stmt.liftInitsInLoopBody_snd_loop, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + exact ⟨h, trivial⟩ + | exit lbl md => + simp only [Stmt.liftInitsInLoopBody_snd_exit, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + exact ⟨h, trivial⟩ + | funcDecl d md => + simp [Stmt.liftInitsInLoopBody_snd_funcDecl, Stmt.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + | typeDecl t md => + simp [Stmt.liftInitsInLoopBody_snd_typeDecl, Stmt.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + termination_by sizeOf s + +/-- `Block.liftInitsInLoopBody`'s residual block preserves +`Block.exitsCoveredByBlocks`. -/ +private theorem Block.liftInitsInLoopBody_snd_exitsCoveredByBlocks [HasIdent P] + (labels : List String) (ss : List (Stmt P (Cmd P))) + (h : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss) : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels + (Block.liftInitsInLoopBody ss).snd := by + match ss with + | [] => + simp [Block.liftInitsInLoopBody_snd_nil, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + | s :: rest => + simp only [Block.liftInitsInLoopBody_snd_cons] + apply block_exitsCoveredByBlocks_append + · exact Stmt.liftInitsInLoopBody_snd_exitsCoveredByBlocks labels s h.1 + · exact Block.liftInitsInLoopBody_snd_exitsCoveredByBlocks labels rest h.2 + termination_by sizeOf ss +end + +/-! ### Hoist pass (monadic) preserves `exitsCoveredByBlocks` + +Proven against the monadic pass shape via the `hoistLoopPrefixInitsM_*_out` +residual equations (LoopInitHoist.lean), then bridged to the pure wrapper. The +`.loop` arm's output wraps the lift residual in `Block.applyRenames`, handled +by `Block.applyRenames_exitsCoveredByBlocks`. -/ + +mutual +/-- `Stmt.hoistLoopPrefixInitsM`'s output preserves `Stmt.exitsCoveredByBlocks`. -/ +private theorem Stmt.hoistLoopPrefixInitsM_exitsCoveredByBlocks [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (labels : List String) (s : Stmt P (Cmd P)) (σ : StringGenState) + (h : Stmt.exitsCoveredByBlocks labels s) : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels + (Stmt.hoistLoopPrefixInitsM s σ).1 := by + match s with + | .cmd c => + simp [Stmt.hoistLoopPrefixInitsM, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks] + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM_block_out] + refine ⟨?_, trivial⟩ + show Stmt.exitsCoveredByBlocks labels + (Stmt.block lbl (Block.hoistLoopPrefixInitsM bss σ).1 md) + have h_inner : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks (lbl :: labels) bss := h + exact Block.hoistLoopPrefixInitsM_exitsCoveredByBlocks (lbl :: labels) bss σ h_inner + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM_ite_out] + refine ⟨⟨?_, ?_⟩, trivial⟩ + · exact Block.hoistLoopPrefixInitsM_exitsCoveredByBlocks labels tss σ h.1 + · exact Block.hoistLoopPrefixInitsM_exitsCoveredByBlocks labels ess _ h.2 + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM_loop_out] + -- output: havocs.map .cmd ++ [.loop g m inv (applyRenames renames lifted.snd) md] + apply block_exitsCoveredByBlocks_append + · -- prelude havocs: each is .cmd, no exit possible. + apply Block.exitsCoveredByBlocks_of_map_cmd + · refine ⟨?_, trivial⟩ + show Stmt.exitsCoveredByBlocks labels + (Stmt.loop g m inv + (Block.applyRenames + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) md) + -- For .loop, exitsCoveredByBlocks unfolds to exitsCoveredByBlocks on body. + apply Block.applyRenames_exitsCoveredByBlocks + -- the lift residual `.1.2.2` equals the pure wrapper's `.snd`. + have h_body : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels body := h + have h_body_hoisted : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels + (Block.hoistLoopPrefixInitsM body σ).1 := + Block.hoistLoopPrefixInitsM_exitsCoveredByBlocks labels body σ h_body + have h_lift := + Block.liftInitsInLoopBody_snd_exitsCoveredByBlocks labels + (Block.hoistLoopPrefixInitsM body σ).1 h_body_hoisted + rwa [Block.liftInitsInLoopBody, + Block.liftInitsInLoopBodyM_snd_state_indep + (Block.hoistLoopPrefixInitsM body σ).1 StringGenState.emp + (Block.hoistLoopPrefixInitsM body σ).2] at h_lift + | .exit lbl md => + simp [Stmt.hoistLoopPrefixInitsM, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks] + exact h + | .funcDecl d md => + simp [Stmt.hoistLoopPrefixInitsM, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks] + | .typeDecl t md => + simp [Stmt.hoistLoopPrefixInitsM, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks, + Stmt.exitsCoveredByBlocks] + termination_by sizeOf s + +/-- `Block.hoistLoopPrefixInitsM`'s output preserves `Block.exitsCoveredByBlocks`. -/ +private theorem Block.hoistLoopPrefixInitsM_exitsCoveredByBlocks [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (labels : List String) (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss) : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels + (Block.hoistLoopPrefixInitsM ss σ).1 := by + match ss with + | [] => + simp [Block.hoistLoopPrefixInitsM, + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks] + | s :: rest => + rw [Block.hoistLoopPrefixInitsM_cons_out] + apply block_exitsCoveredByBlocks_append + · exact Stmt.hoistLoopPrefixInitsM_exitsCoveredByBlocks labels s σ h.1 + · exact Block.hoistLoopPrefixInitsM_exitsCoveredByBlocks labels rest _ h.2 + termination_by sizeOf ss +end + +/-- S4 public preservation entry-point (pure-wrapper bridge). -/ +theorem Block.hoistLoopPrefixInits_preserves_exitsCoveredByBlocks [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (labels : List String) (ss : List (Stmt P (Cmd P))) + (h : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss) : + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels + (Block.hoistLoopPrefixInits ss) := by + rw [Block.hoistLoopPrefixInits] + exact Block.hoistLoopPrefixInitsM_exitsCoveredByBlocks labels ss StringGenState.emp h + +end ExitsCovered + +/-! ### S5 — `loopMeasureNone` re-export + +Already proven in `LoopInitHoist.lean` (Phase 8 §B). Re-exported here for +symmetry under the canonical Phase 8 naming. -/ + +theorem Block.hoistLoopPrefixInits_preserves_loopMeasureNone' + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) + (h : Block.loopMeasureNone ss = true) : + Block.loopMeasureNone (Block.hoistLoopPrefixInits ss) = true := + Block.hoistLoopPrefixInits_preserves_loopMeasureNone ss h + +/-! ### §E undefinedness-frame helper infra + +Supporting lemmas for the `cons` arm of the §E Block sibling: the tail IH's +`h_hoist_undef` precondition (every `y ∈ Block.initVars rest` is undefined in +the *mid* source store) is re-established by transporting `store y = none` +across the terminating head run. This needs a config-level undefinedness +invariant `NoneAtY` preserved along the step relation, plus the bridge between +`containsFuncDecl = false` (the §E shape precondition) and the `definedVars = +initVars` / `noFuncDecl` facts the transport consumes. -/ + +/-- `UpdateState` preserves undefinedness: if `σ y = none`, then `σ' y = none` +(the target was already defined, so `y` cannot be the target). -/ +private theorem UpdateState_preserves_none + {σ σ' : SemanticStore P} {x : P.Ident} {v : P.Expr} {y : P.Ident} + (h_us : UpdateState P σ x v σ') (h_none : σ y = none) : + σ' y = none := by + cases h_us with + | update h_was _ h_other => + by_cases hxy : x = y + · subst hxy; rw [h_none] at h_was; exact absurd h_was (by simp) + · rw [h_other y hxy]; exact h_none + +/-- `InitState` preserves the slot of any `y ≠` the init target. -/ +private theorem InitState_preserves_none + {σ σ' : SemanticStore P} {x : P.Ident} {v : P.Expr} {y : P.Ident} + (h_is : InitState P σ x v σ') (h_ne : x ≠ y) : + σ' y = σ y := by + cases h_is with + | init _ _ h_other => exact h_other y h_ne + +-- Under no funcDecls, a statement's `definedVars` (init + funcname targets) +-- coincides with its `initVars` (init targets only): the only divergence is the +-- `.funcDecl` arm, excluded by `containsFuncDecl = false`. +mutual +private theorem Stmt.definedVars_eq_initVars_of_no_fd + (s : Stmt P (Cmd P)) (h : Stmt.containsFuncDecl s = false) : + Stmt.definedVars (P := P) (C := Cmd P) s = Stmt.initVars s := by + match s with + | .cmd c => + cases c <;> + simp only [Stmt.definedVars, Stmt.initVars, Cmd.definedVars, + HasVarsImp.definedVars] + | .block lbl bss md => + rw [Stmt.definedVars, Stmt.initVars, Stmt.containsFuncDecl] at * + exact Block.definedVars_eq_initVars_of_no_fd bss h + | .ite g tss ess md => + rw [Stmt.definedVars, Stmt.initVars, Stmt.containsFuncDecl, Bool.or_eq_false_iff] at * + rw [Block.definedVars_eq_initVars_of_no_fd tss h.1, + Block.definedVars_eq_initVars_of_no_fd ess h.2] + | .loop g m inv body md => + rw [Stmt.definedVars, Stmt.initVars, Stmt.containsFuncDecl] at * + exact Block.definedVars_eq_initVars_of_no_fd body h + | .exit lbl md => simp [Stmt.definedVars, Stmt.initVars] + | .funcDecl d md => rw [Stmt.containsFuncDecl] at h; exact absurd h (by simp) + | .typeDecl t md => simp [Stmt.definedVars, Stmt.initVars] + termination_by sizeOf s + +private theorem Block.definedVars_eq_initVars_of_no_fd + (ss : List (Stmt P (Cmd P))) (h : Block.containsFuncDecl ss = false) : + Block.definedVars (P := P) (C := Cmd P) ss = Block.initVars ss := by + match ss with + | [] => simp [Block.definedVars, Block.initVars] + | s :: rest => + rw [Block.definedVars, Block.initVars, Block.containsFuncDecl, Bool.or_eq_false_iff] at * + rw [Stmt.definedVars_eq_initVars_of_no_fd s h.1, + Block.definedVars_eq_initVars_of_no_fd rest h.2] + termination_by sizeOf ss +end + +/-- If `y ∉ Block.definedVars ss`, then `y ∉ Stmt.definedVars s` for `s ∈ ss`. -/ +private theorem all_not_mem_definedVars_of_block + {y : P.Ident} {ss : List (Stmt P (Cmd P))} + (h : y ∉ Block.definedVars (P := P) (C := Cmd P) ss) : + ∀ s ∈ ss, y ∉ Stmt.definedVars (P := P) (C := Cmd P) s := by + induction ss with + | nil => intro s hs; exact absurd hs (List.not_mem_nil) + | cons s rest ih => + rw [Block.definedVars] at h + intro s' hs' + rcases List.mem_cons.mp hs' with h_eq | h_in + · exact h_eq ▸ (fun hc => h (List.mem_append.mpr (Or.inl hc))) + · exact ih (fun hc => h (List.mem_append.mpr (Or.inr hc))) s' h_in + +/-- Config-level undefinedness invariant for `y`: every store reachable from +`cfg` maps `y` to `none`, and no pending statement INITs `y` (so the running +trace cannot define it; `set y` cannot fire either, as the target must already +be defined). -/ +@[expose] def NoneAtY (y : P.Ident) : Config P (Cmd P) → Prop + | .stmt s ρ => ρ.store y = none ∧ y ∉ Stmt.definedVars (P := P) (C := Cmd P) s + | .stmts ss ρ => ρ.store y = none ∧ ∀ s ∈ ss, y ∉ Stmt.definedVars (P := P) (C := Cmd P) s + | .terminal ρ => ρ.store y = none + | .exiting _ ρ => ρ.store y = none + | .block _ σ_parent inner => σ_parent y = none ∧ NoneAtY y inner + | .seq inner ss => NoneAtY y inner ∧ ∀ s ∈ ss, y ∉ Stmt.definedVars (P := P) (C := Cmd P) s + +open StructuredToUnstructuredCorrect in +/-- A single command preserves undefinedness of `y` when `y` is not the +command's init/set target. -/ +private theorem EvalCmd_preserves_none + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {δ : SemanticEval P} {σ σ' : SemanticStore P} {c : Cmd P} {hf : Bool} {y : P.Ident} + (h_none : σ y = none) + (h_not_def : y ∉ Cmd.definedVars c) + (h_eval : EvalCmd P δ σ c σ' hf) : + σ' y = none := by + simp only [Cmd.definedVars] at h_not_def + cases h_eval with + | eval_init _ h_is _ _ => + rw [InitState_preserves_none h_is (fun h => h_not_def (h ▸ List.mem_singleton.mpr rfl))] + exact h_none + | eval_init_unconstrained h_is _ => + rw [InitState_preserves_none h_is (fun h => h_not_def (h ▸ List.mem_singleton.mpr rfl))] + exact h_none + | eval_set _ h_us _ _ => exact UpdateState_preserves_none h_us h_none + | eval_set_nondet h_us _ => exact UpdateState_preserves_none h_us h_none + | eval_assert_pass _ _ _ => exact h_none + | eval_assert_fail _ _ _ => exact h_none + | eval_assume _ _ _ => exact h_none + | eval_cover _ => exact h_none + +/-- Single-step preservation of `NoneAtY`. -/ +private theorem NoneAtY_step + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] + [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {y : P.Ident} {cfg cfg' : Config P (Cmd P)} + (h_step : StepStmt P (EvalCmd P) extendEval cfg cfg') + (h_inv : NoneAtY (P := P) y cfg) : + NoneAtY (P := P) y cfg' := by + induction h_step with + | step_cmd h_eval => + obtain ⟨h_none, h_ndef⟩ := h_inv + refine EvalCmd_preserves_none h_none ?_ h_eval + simpa [Stmt.definedVars] using h_ndef + | step_block => + obtain ⟨h_none, h_ndef⟩ := h_inv + exact ⟨h_none, h_none, all_not_mem_definedVars_of_block (by simpa [Stmt.definedVars] using h_ndef)⟩ + | step_ite_true _ _ => + obtain ⟨h_none, h_ndef⟩ := h_inv + rw [Stmt.definedVars] at h_ndef + exact ⟨h_none, all_not_mem_definedVars_of_block (fun hc => h_ndef (List.mem_append.mpr (Or.inl hc)))⟩ + | step_ite_false _ _ => + obtain ⟨h_none, h_ndef⟩ := h_inv + rw [Stmt.definedVars] at h_ndef + exact ⟨h_none, all_not_mem_definedVars_of_block (fun hc => h_ndef (List.mem_append.mpr (Or.inr hc)))⟩ + | step_ite_nondet_true => + obtain ⟨h_none, h_ndef⟩ := h_inv + rw [Stmt.definedVars] at h_ndef + exact ⟨h_none, all_not_mem_definedVars_of_block (fun hc => h_ndef (List.mem_append.mpr (Or.inl hc)))⟩ + | step_ite_nondet_false => + obtain ⟨h_none, h_ndef⟩ := h_inv + rw [Stmt.definedVars] at h_ndef + exact ⟨h_none, all_not_mem_definedVars_of_block (fun hc => h_ndef (List.mem_append.mpr (Or.inr hc)))⟩ + | step_loop_enter _ _ _ _ => + obtain ⟨h_none, h_ndef⟩ := h_inv + rw [Stmt.definedVars] at h_ndef + refine ⟨⟨h_none, h_none, all_not_mem_definedVars_of_block h_ndef⟩, ?_⟩ + intro s hs + rcases List.mem_cons.mp hs with h_eq | h_in + · subst h_eq; rw [Stmt.definedVars]; exact h_ndef + · exact absurd h_in (List.not_mem_nil) + | step_loop_exit _ _ _ _ => + obtain ⟨h_none, _⟩ := h_inv; exact h_none + | step_loop_nondet_enter _ => + obtain ⟨h_none, h_ndef⟩ := h_inv + rw [Stmt.definedVars] at h_ndef + refine ⟨⟨h_none, h_none, all_not_mem_definedVars_of_block h_ndef⟩, ?_⟩ + intro s hs + rcases List.mem_cons.mp hs with h_eq | h_in + · subst h_eq; rw [Stmt.definedVars]; exact h_ndef + · exact absurd h_in (List.not_mem_nil) + | step_loop_nondet_exit _ => + obtain ⟨h_none, _⟩ := h_inv; exact h_none + | step_exit => + obtain ⟨h_none, _⟩ := h_inv; exact h_none + | step_funcDecl => + obtain ⟨h_none, _⟩ := h_inv; exact h_none + | step_typeDecl => + obtain ⟨h_none, _⟩ := h_inv; exact h_none + | step_stmts_nil => + obtain ⟨h_none, _⟩ := h_inv; exact h_none + | step_stmts_cons => + obtain ⟨h_none, h_ndef⟩ := h_inv + exact ⟨⟨h_none, h_ndef _ (List.mem_cons_self)⟩, + fun s' hs' => h_ndef s' (List.mem_cons_of_mem _ hs')⟩ + | step_seq_inner _ ih => + obtain ⟨h_inner_inv, h_ndef⟩ := h_inv + exact ⟨ih h_inner_inv, h_ndef⟩ + | step_seq_done => + obtain ⟨h_none, h_ndef⟩ := h_inv + exact ⟨h_none, h_ndef⟩ + | step_seq_exit => + obtain ⟨h_none, _⟩ := h_inv; exact h_none + | step_block_body _ ih => + obtain ⟨h_parent, h_inner_inv⟩ := h_inv + exact ⟨h_parent, ih h_inner_inv⟩ + | step_block_done => + obtain ⟨h_parent, _⟩ := h_inv + show projectStore _ _ y = none + unfold projectStore; rw [if_neg]; rw [h_parent]; simp + | step_block_exit_match _ => + obtain ⟨h_parent, _⟩ := h_inv + show projectStore _ _ y = none + unfold projectStore; rw [if_neg]; rw [h_parent]; simp + | step_block_exit_mismatch _ => + obtain ⟨h_parent, _⟩ := h_inv + show projectStore _ _ y = none + unfold projectStore; rw [if_neg]; rw [h_parent]; simp + +/-- Trace lift: `NoneAtY` is preserved along a multi-step run. -/ +private theorem NoneAtY_star + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] + [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {y : P.Ident} {cfg cfg' : Config P (Cmd P)} + (h_run : StepStmtStar P (EvalCmd P) extendEval cfg cfg') + (h_inv : NoneAtY (P := P) y cfg) : + NoneAtY (P := P) y cfg' := by + induction h_run with + | refl => exact h_inv + | step _ _ _ h_step _ ih => exact ih (NoneAtY_step h_step h_inv) + +/-- A terminating `.stmt s` run from `ρ` preserves `store y = none` for any +`y ∉ Stmt.definedVars s`. -/ +private theorem stmt_run_terminal_preserves_none + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] + [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {y : P.Ident} {s : Stmt P (Cmd P)} {ρ ρ' : Env P} + (h_none : ρ.store y = none) + (h_ndef : y ∉ Stmt.definedVars (P := P) (C := Cmd P) s) + (h_run : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (.terminal ρ')) : + ρ'.store y = none := + NoneAtY_star h_run ⟨h_none, h_ndef⟩ + +/-- A name `y` lying in some source statement-list's `Block.initVars` (and hence +shape-free and disjoint from `s`'s own inits) is NOT among the `Block.initVars` +of the residual `(Stmt.hoistLoopPrefixInitsM s σ).1`. Each residual init is +classified (`hoistLoopPrefixInitsM_initVars_classified`) as either an original +init of `s` (excluded since `y ∉ Stmt.initVars s`) or a freshly generated name +(excluded since `y` is shape-free). -/ +private theorem y_not_mem_residual_initVars + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] + [HasIntOrder P] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + [DecidableEq P.Ident] + {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {y : P.Ident} {s : Stmt P (Cmd P)} {σ : StringGenState} + (h_wf : StringGenState.WF σ) + (h_unique_s : (Stmt.initVars s).Nodup) + (h_shapefree_s : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s) + (h_y_not_src : y ∉ Stmt.initVars s) + (h_y_shapefree : ∀ str : String, y = HasIdent.ident str → + ¬ Q str) : + y ∉ Block.initVars (Stmt.hoistLoopPrefixInitsM s σ).1 := by + intro h_mem + have h_class := + (LoopInitHoistLoopArmWF.Stmt.hoistLoopPrefixInitsM_initVars_classified + hQmint s σ h_wf h_unique_s h_shapefree_s).1 y h_mem + rcases h_class with h_orig | ⟨str, h_y_eq, h_str_in, _, h_str_Q⟩ + · exact h_y_not_src h_orig + · -- `y = ident str` with `str` freshly minted (carrying kind `Q`), contradicting + -- `y`'s kind-freedom. + exact h_y_shapefree str h_y_eq h_str_Q + +/-- A terminating run of the residual block `(Stmt.hoistLoopPrefixInitsM s σ).1` +preserves `store y = none` when `y` is a shape-free source name disjoint from +`s`'s own inits (so `y` is touched by no residual init; `set` cannot fire on an +undefined slot). This is the hoist-side analogue of +`stmt_run_terminal_preserves_none` for the cons-arm tail, where the hoist store +evolves across the head residual run. -/ +private theorem residual_run_terminal_preserves_none + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] + [HasIntOrder P] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {y : P.Ident} {s : Stmt P (Cmd P)} {σ : StringGenState} {ρ ρ' : Env P} + (h_wf : StringGenState.WF σ) + (h_unique_s : (Stmt.initVars s).Nodup) + (h_shapefree_s : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s) + (h_no_fd : Stmt.containsFuncDecl s = false) + (h_y_not_src : y ∉ Stmt.initVars s) + (h_y_shapefree : ∀ str : String, y = HasIdent.ident str → + ¬ Q str) + (h_none : ρ.store y = none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.hoistLoopPrefixInitsM s σ).1 ρ) (.terminal ρ')) : + ρ'.store y = none := by + have h_residual_nofd : + Block.containsFuncDecl (Stmt.hoistLoopPrefixInitsM s σ).1 = false := by + rw [Stmt.hoistLoopPrefixInitsM_containsFuncDecl]; exact h_no_fd + have h_y_not_residual : y ∉ Block.initVars (Stmt.hoistLoopPrefixInitsM s σ).1 := + y_not_mem_residual_initVars hQmint h_wf h_unique_s h_shapefree_s h_y_not_src h_y_shapefree + have h_y_not_def : y ∉ Block.definedVars (Stmt.hoistLoopPrefixInitsM s σ).1 := by + rw [Block.definedVars_eq_initVars_of_no_fd _ h_residual_nofd]; exact h_y_not_residual + -- `NoneAtY (.stmts residual ρ)` needs per-statement non-membership; derive it + -- from `y ∉ Block.definedVars residual` via the `definedVars` cons/append shape. + have h_mem_block : ∀ (ss : List (Stmt P (Cmd P))) (s' : Stmt P (Cmd P)), + s' ∈ ss → y ∈ Stmt.definedVars (P := P) (C := Cmd P) s' → + y ∈ Block.definedVars (P := P) (C := Cmd P) ss := by + intro ss + induction ss with + | nil => intro s' hs' _; exact absurd hs' List.not_mem_nil + | cons hd tl ih => + intro s' hs' hc + rw [Block.definedVars] + rcases List.mem_cons.mp hs' with h_eq | h_in + · subst h_eq; exact List.mem_append.mpr (Or.inl hc) + · exact List.mem_append.mpr (Or.inr (ih s' h_in hc)) + have h_per_stmt : ∀ s' ∈ (Stmt.hoistLoopPrefixInitsM s σ).1, + y ∉ Stmt.definedVars (P := P) (C := Cmd P) s' := fun s' hs' hc => + h_y_not_def (h_mem_block (Stmt.hoistLoopPrefixInitsM s σ).1 s' hs' hc) + exact NoneAtY_star h_run ⟨h_none, h_per_stmt⟩ + +/-- A name `y` undefined at block entry and NOT among the block's `initVars` +(under `containsFuncDecl = false`, so `definedVars = initVars`) stays undefined +across a terminating block run. Used in the §E cons-tail mid-store discharge to +keep a suffix-shaped name `∉ stringGens σ₁` undefined past the head residual run +on the hoist side, where the head residual may itself contain generated `.init`s +(so the `definedVars = initVars`-based no-touch argument is the right tool). -/ +private theorem block_run_terminal_preserves_none_of_not_initVars + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] + [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {y : P.Ident} {bss : List (Stmt P (Cmd P))} {ρ ρ' : Env P} + (h_no_fd : Block.containsFuncDecl bss = false) + (h_y_not_init : y ∉ Block.initVars bss) + (h_none : ρ.store y = none) + (h_run : StepStmtStar P (EvalCmd P) extendEval (.stmts bss ρ) (.terminal ρ')) : + ρ'.store y = none := by + have h_y_not_def : y ∉ Block.definedVars bss := by + rw [Block.definedVars_eq_initVars_of_no_fd _ h_no_fd]; exact h_y_not_init + have h_mem_block : ∀ (ss : List (Stmt P (Cmd P))) (s' : Stmt P (Cmd P)), + s' ∈ ss → y ∈ Stmt.definedVars (P := P) (C := Cmd P) s' → + y ∈ Block.definedVars (P := P) (C := Cmd P) ss := by + intro ss + induction ss with + | nil => intro s' hs' _; exact absurd hs' List.not_mem_nil + | cons hd tl ih => + intro s' hs' hc + rw [Block.definedVars] + rcases List.mem_cons.mp hs' with h_eq | h_in + · subst h_eq; exact List.mem_append.mpr (Or.inl hc) + · exact List.mem_append.mpr (Or.inr (ih s' h_in hc)) + have h_per_stmt : ∀ s' ∈ bss, y ∉ Stmt.definedVars (P := P) (C := Cmd P) s' := + fun s' hs' hc => h_y_not_def (h_mem_block bss s' hs' hc) + exact NoneAtY_star h_run ⟨h_none, h_per_stmt⟩ + +-- `Stmt.containsFuncDecl s = false → Stmt.noFuncDecl s = true` (and the block +-- sibling). Bridges the §E precondition `h_no_fd` (stated via +-- `containsFuncDecl`) to the eval-preservation lemmas (stated via `noFuncDecl`). +mutual +private theorem Stmt.noFuncDecl_of_not_containsFuncDecl + (s : Stmt P (Cmd P)) (h : Stmt.containsFuncDecl s = false) : + Stmt.noFuncDecl s = true := by + match s with + | .cmd c => rw [Stmt.noFuncDecl] + | .block lbl bss md => + rw [Stmt.noFuncDecl] + rw [Stmt.containsFuncDecl] at h + exact Block.noFuncDecl_of_not_containsFuncDecl bss h + | .ite g tss ess md => + rw [Stmt.noFuncDecl] + rw [Stmt.containsFuncDecl, Bool.or_eq_false_iff] at h + rw [Bool.and_eq_true] + exact ⟨Block.noFuncDecl_of_not_containsFuncDecl tss h.1, + Block.noFuncDecl_of_not_containsFuncDecl ess h.2⟩ + | .loop g m inv body md => + rw [Stmt.noFuncDecl] + rw [Stmt.containsFuncDecl] at h + exact Block.noFuncDecl_of_not_containsFuncDecl body h + | .exit lbl md => rw [Stmt.noFuncDecl] + | .funcDecl d md => rw [Stmt.containsFuncDecl] at h; exact absurd h (by simp) + | .typeDecl t md => rw [Stmt.noFuncDecl] + termination_by sizeOf s + +private theorem Block.noFuncDecl_of_not_containsFuncDecl + (ss : List (Stmt P (Cmd P))) (h : Block.containsFuncDecl ss = false) : + Block.noFuncDecl ss = true := by + match ss with + | [] => rw [Block.noFuncDecl] + | s :: rest => + rw [Block.noFuncDecl] + rw [Block.containsFuncDecl, Bool.or_eq_false_iff] at h + rw [Bool.and_eq_true] + exact ⟨Stmt.noFuncDecl_of_not_containsFuncDecl s h.1, + Block.noFuncDecl_of_not_containsFuncDecl rest h.2⟩ + termination_by sizeOf ss +end + +/-- Inversion of a labeled block reaching `.exiting`: in addition to the inner +exit run and the projection (as in `block_reaches_exiting`), record that the +inner exit label does NOT match the block's label — the block only PROPAGATES a +mismatched exit (a matching exit would have been caught and terminated). This +mismatch fact is what the §E `.block` arm needs to replay `step_block_exit_mismatch` +on the hoisted side. -/ +private theorem block_some_reaches_exiting_ne + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {inner : Config P (Cmd P)} {label : String} {σ_parent : SemanticStore P} + {lbl : String} {ρ' : Env P} + (hstar : StepStmtStar P (EvalCmd P) extendEval + (.block (.some label) σ_parent inner) (.exiting lbl ρ')) : + ∃ lbl_inner ρ_inner, + StepStmtStar P (EvalCmd P) extendEval inner (.exiting lbl_inner ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } ∧ + lbl_inner = lbl ∧ (Option.some label : Option String) ≠ Option.some lbl := by + suffices ∀ src tgt, StepStmtStar P (EvalCmd P) extendEval src tgt → + ∀ inner lbl ρ', src = .block (.some label) σ_parent inner → tgt = .exiting lbl ρ' → + ∃ lbl_inner ρ_inner, + StepStmtStar P (EvalCmd P) extendEval inner (.exiting lbl_inner ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } ∧ + lbl_inner = lbl ∧ (Option.some label : Option String) ≠ Option.some lbl 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 => + obtain ⟨lbl_inner, ρ_inner, hexit, heq, hli, hne⟩ := ih _ _ _ rfl htgt + exact ⟨lbl_inner, ρ_inner, .step _ _ _ h hexit, heq, hli, hne⟩ + | step_block_exit_mismatch h_ne => + subst htgt; cases hrest with + | refl => exact ⟨_, _, .refl _, rfl, rfl, h_ne⟩ + | step _ _ _ h _ => cases h + | step_block_done | step_block_exit_match => + subst htgt; cases hrest with | step _ _ _ h _ => cases h + +/-! ### §E `.ite` guard-agreement helper + +The `.ite` arm must drive the hoisted `.ite` through the SAME branch the source +chose, which requires that the guard `g` evaluates identically on the two +`HoistInv`-related entry stores. This holds because the guard's variables are +fresh w.r.t. both `A` and `B` (the `namesFreshInExprs` preconditions), so they +lie OUTSIDE `A ∪ B`, where the two stores agree by `HoistInv` component (1); +expression-congruence (`h_wfcongr`) then transports the evaluation. -/ + +/-- Extract guard-variable disjointness from the `.ite` freshness precondition: +if `names` is fresh in `.ite (.det g) tss ess md`, then no guard variable is in +`names`. -/ +private theorem ite_guard_vars_not_mem + [HasVarsPure P P.Expr] + {names : List P.Ident} {g : P.Expr} + {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + (h : Block.namesFreshInExprs (P := P) names [.ite (.det g) tss ess md] = true) : + ∀ x ∈ HasVarsPure.getVars g, x ∉ names := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + Bool.and_eq_true, ExprOrNondet.getVars] at h + obtain ⟨⟨h_guard, _⟩, _⟩ := h + rw [List.all_eq_true] at h_guard + intro x hx_g hx_names + exact absurd (freshFromIdents_not_mem (h_guard x hx_names)) (fun h => h hx_g) + +/-- Guard agreement: the `.ite` guard evaluates identically on the two +`HoistInv`-related entry stores. -/ +private theorem ite_guard_agree + [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} {g : P.Expr} + {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + {ρ_src ρ_hoist : Env P} + (h_names_fresh : Block.namesFreshInExprs (P := P) A [.ite (.det g) tss ess md] = true) + (h_names_fresh_B : Block.namesFreshInExprs (P := P) B [.ite (.det g) tss ess md] = true) + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_read_def : ∀ x ∈ HasVarsPure.getVars g, ρ_src.store x ≠ none) + (h_eval_eq : ρ_src.eval = ρ_hoist.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) : + ρ_src.eval ρ_src.store g = ρ_hoist.eval ρ_hoist.store g := by + have h_notA := ite_guard_vars_not_mem (P := P) h_names_fresh + have h_notB := ite_guard_vars_not_mem (P := P) h_names_fresh_B + -- Stores agree on every guard variable (each is outside A ∪ B and source-defined). + have h_store_agree : ∀ x ∈ HasVarsPure.getVars g, ρ_src.store x = ρ_hoist.store x := by + intro x hx + exact h_hinv.1 x (h_notA x hx) (h_notB x hx) (h_read_def x hx) + rw [h_eval_eq] + exact (h_wfcongr ρ_hoist) g ρ_src.store ρ_hoist.store h_store_agree + +/-! ### §E `.cmd` arm closing kit + +The `.cmd c` arm of the §E Stmt-IH replays the SAME command `c` on the hoisted +side and shows the resulting stores stay `HoistInv`-related. The store +transport splits on the command shape: `.init`/`.set` whose target lies outside +`A ∪ B` move both stores by `extendStoreOne` and use +`HoistInv.extend_both_outside_subst`; `.assert`/`.assume`/`.cover` leave the +store fixed so `HoistInv` carries through unchanged. + +The disjointness of the `.set`/`.init` target from `A ∪ B` is exactly what the +two modified-variable preconditions `h_mod_disjoint_A`/`h_mod_disjoint_B` +supply: at `[.cmd (.set x ..)]` they reduce to `x ∉ A`/`x ∉ B`, ruling out the +otherwise-unsound case where a `.set` target coincides with a renamed-name set +side. These lemmas are factored out so the `.cmd` arm of the mutual is a single +application of `cmd_arm`. -/ + +open StructuredToUnstructuredCorrect in +/-- `InitState` to a function-level `extendStoreOne` equality. -/ +private theorem InitState_eq_extendStoreOne + [DecidableEq P.Ident] + {σ σ' : SemanticStore P} {y : P.Ident} {v : P.Expr} + (h_is : InitState P σ y v σ') : + σ' = extendStoreOne σ y v := by + cases h_is with + | init h_none h_some h_other => + funext z + by_cases hzy : z = y + · subst hzy; rw [h_some]; exact (extendStoreOne_self σ z v).symm + · rw [h_other z (fun h => hzy h.symm)] + exact (extendStoreOne_other σ y v z hzy).symm + +open StructuredToUnstructuredCorrect in +/-- `UpdateState` to a function-level `extendStoreOne` equality. -/ +private theorem UpdateState_eq_extendStoreOne + [DecidableEq P.Ident] + {σ σ' : SemanticStore P} {x : P.Ident} {v : P.Expr} + (h_us : UpdateState P σ x v σ') : + σ' = extendStoreOne σ x v := by + cases h_us with + | update h_was h_post h_other => + funext z + by_cases hzx : z = x + · subst hzx; rw [h_post]; exact (extendStoreOne_self σ z v).symm + · rw [h_other z (fun h => hzx h.symm)] + exact (extendStoreOne_other σ x v z hzx).symm + +/-- Invert a single `.stmt (.cmd c) ρ ⟶* .terminal ρ'` run into its `EvalCmd`. -/ +private theorem stmt_cmd_terminal_inv + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {c : Cmd P} {ρ ρ' : Env P} + (h : StepStmtStar P (EvalCmd P) extendEval (.stmt (.cmd c) ρ) (.terminal ρ')) : + ∃ σ' hf, EvalCmd P ρ.eval ρ.store c σ' hf ∧ + ρ' = { ρ with store := σ', hasFailure := ρ.hasFailure || hf } := by + cases h with + | step _ _ _ h1 hr1 => + cases h1 with + | step_cmd h_eval => + cases hr1 with + | refl => exact ⟨_, _, h_eval, rfl⟩ + | step _ _ _ hd _ => exact nomatch hd + +/-- The hoisted residual `.stmts [.cmd c] ρ ⟶* .terminal ρ'` given the EvalCmd. -/ +private theorem stmts_single_cmd_run + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {c : Cmd P} {ρ : Env P} {σ' : SemanticStore P} {hf : Bool} + (h_eval : EvalCmd P ρ.eval ρ.store c σ' hf) : + StepStmtStar P (EvalCmd P) extendEval (.stmts [.cmd c] ρ) + (.terminal { ρ with store := σ', hasFailure := ρ.hasFailure || hf }) := by + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner (StepStmt.step_cmd h_eval)) ?_ + refine ReflTrans.step _ _ _ StepStmt.step_seq_done ?_ + exact ReflTrans.step _ _ _ StepStmt.step_stmts_nil (ReflTrans.refl _) + +open StructuredToUnstructuredCorrect in +/-- Shared closing for the parallel single-target update sub-cases (`.init`, +`.set` outside the subst frame). The source store moves to +`extendStoreOne ρ_src.store y v`; the hoist replays the SAME command (target +`y ∉ A ∪ B`) and moves to `extendStoreOne ρ_hoist.store y v`. -/ +private theorem cmd_init_arm_close + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {c : Cmd P} {y : P.Ident} {v : P.Expr} + {ρ_src ρ_hoist : Env P} {σ' : SemanticStore P} + (h_y_notA : y ∉ A) (h_y_notB : y ∉ B) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_hf_eq : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_hoist_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_σ'_eq : σ' = extendStoreOne ρ_src.store y v) + (h_eval_cmd_hoist : + EvalCmd P ρ_hoist.eval ρ_hoist.store c (extendStoreOne ρ_hoist.store y v) false) : + ∃ ρ_h', ∃ cfg_hoist : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval (.stmts [.cmd c] ρ_hoist) cfg_hoist + ∧ ((∃ ρ_src' : Env P, + (.terminal { ρ_src with store := σ', hasFailure := ρ_src.hasFailure || false } + : Config P (Cmd P)) = .terminal ρ_src' ∧ cfg_hoist = .terminal ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none)) ∨ + (∃ lbl ρ_src', + (.terminal { ρ_src with store := σ', hasFailure := ρ_src.hasFailure || false } + : Config P (Cmd P)) = .exiting lbl ρ_src' ∧ cfg_hoist = .exiting lbl ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none))) := by + have h_hinv_post : + HoistInv (P := P) A B subst (extendStoreOne ρ_src.store y v) + (extendStoreOne ρ_hoist.store y v) := + HoistInv.extend_both_outside_subst h_y_notA h_y_notB h_subst_wf h_hinv + have h_run := stmts_single_cmd_run (extendEval := extendEval) h_eval_cmd_hoist + refine ⟨_, _, h_run, Or.inl ⟨_, rfl, rfl, ?_, ?_, ?_⟩⟩ + · show HoistInv (P := P) A B subst σ' (extendStoreOne ρ_hoist.store y v) + rw [h_σ'_eq]; exact h_hinv_post + · show (ρ_src.hasFailure || false) = (ρ_hoist.hasFailure || false) + rw [h_hf_eq] + · intro z hz + show extendStoreOne ρ_hoist.store y v z ≠ none + have hzy : z ≠ y := fun h => h_y_notB (h ▸ hz) + have he : extendStoreOne ρ_hoist.store y v z = ρ_hoist.store z := + extendStoreOne_other ρ_hoist.store y v z hzy + rw [he] + exact h_hoist_bound z hz + +/-- Shared closing for the store-fixed (`assert`/`assume`/`cover`) sub-cases. +The hoist replays the SAME command, leaving its store fixed; `HoistInv` carries +through unchanged. -/ +private theorem cmd_passive_arm_close + [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {c : Cmd P} {hf : Bool} + {ρ_src ρ_hoist : Env P} + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_hf_eq : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_hoist_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_eval_cmd_hoist : + EvalCmd P ρ_hoist.eval ρ_hoist.store c ρ_hoist.store hf) : + ∃ ρ_h', ∃ cfg_hoist : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval (.stmts [.cmd c] ρ_hoist) cfg_hoist + ∧ ((∃ ρ_src' : Env P, + (.terminal { ρ_src with store := ρ_src.store, hasFailure := ρ_src.hasFailure || hf } + : Config P (Cmd P)) = .terminal ρ_src' ∧ cfg_hoist = .terminal ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none)) ∨ + (∃ lbl ρ_src', + (.terminal { ρ_src with store := ρ_src.store, hasFailure := ρ_src.hasFailure || hf } + : Config P (Cmd P)) = .exiting lbl ρ_src' ∧ cfg_hoist = .exiting lbl ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none))) := by + have h_run := stmts_single_cmd_run (extendEval := extendEval) h_eval_cmd_hoist + refine ⟨_, _, h_run, Or.inl ⟨_, rfl, rfl, ?_, ?_, ?_⟩⟩ + · exact h_hinv + · show (ρ_src.hasFailure || hf) = (ρ_hoist.hasFailure || hf) + rw [h_hf_eq] + · intro z hz; exact h_hoist_bound z hz + +open StructuredToUnstructuredCorrect in +/-- The §E `.cmd c` arm obligation, isolated, with the two additional +disjointness preconditions `h_mod_disjoint_A`/`h_mod_disjoint_B` over +`Block.modifiedVars`. Closes ALL eight `EvalCmd` shapes sorry-free. -/ +private theorem cmd_arm + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] + [DecidableEq P.Ident] + {Q : String → Prop} + {extendEval : ExtendEval P} + (A B : List P.Ident) + (subst : List (P.Ident × P.Ident)) + (c : Cmd P) + (σ : StringGenState) + {ρ_src ρ_hoist : Env P} + {cfg_src : Config P (Cmd P)} + (h_names_fresh : Block.namesFreshInExprs A [.cmd c] = true) + (h_names_fresh_B : Block.namesFreshInExprs B [.cmd c] = true) + (h_lhs_disjoint : ∀ y ∈ Block.initVars [.cmd c], y ∉ A) + (h_extra_disjoint : ∀ y ∈ Block.initVars [.cmd c], y ∉ B) + (h_mod_disjoint_A : ∀ x ∈ Block.modifiedVars (P := P) (C := Cmd P) [.cmd c], x ∉ A) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars (P := P) (C := Cmd P) [.cmd c], x ∉ B) + (h_hoist_undef : ∀ y ∈ Block.initVars [.cmd c], ρ_src.store y = none) + (h_hoist_undef_h : ∀ y ∈ Block.initVars [.cmd c], ρ_hoist.store y = none) + (_h_src_store_shapefree : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_src.store (HasIdent.ident (P := P) str) = none) + (_h_hoist_store_shapefree : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_hoist.store (HasIdent.ident (P := P) str) = none) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval_eq : ρ_src.eval = ρ_hoist.eval) + (h_hf_eq : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_hoist_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd c) ρ_src) cfg_src) + (h_cfg_src : (∃ ρ_src' : Env P, cfg_src = .terminal ρ_src') ∨ + (∃ lbl ρ_src', cfg_src = .exiting lbl ρ_src')) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (_h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + ∃ ρ_h', ∃ cfg_hoist : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.hoistLoopPrefixInitsM (.cmd c) σ).1 ρ_hoist) cfg_hoist + ∧ ((∃ ρ_src' : Env P, + cfg_src = .terminal ρ_src' ∧ cfg_hoist = .terminal ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none)) ∨ + (∃ lbl ρ_src', + cfg_src = .exiting lbl ρ_src' ∧ cfg_hoist = .exiting lbl ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none))) := by + classical + -- Residual is the identity `[.cmd c]`. + have h_residual : (Stmt.hoistLoopPrefixInitsM (.cmd c) σ).1 = [.cmd c] := by + rw [Stmt.hoistLoopPrefixInitsM] + rw [h_residual] + -- The source run terminates (a single command never exits). + obtain ⟨ρ_src', h_term⟩ : ∃ ρ_src' : Env P, cfg_src = .terminal ρ_src' := by + rcases h_cfg_src with h | ⟨lbl, ρe, h_exit⟩ + · exact h + · subst h_exit + exact absurd h_run_src (by + intro h + cases h with + | step _ _ _ h1 hr1 => + cases h1 with + | step_cmd _ => cases hr1 with | step _ _ _ hd _ => exact nomatch hd) + subst h_term + -- Invert into the EvalCmd evidence. + obtain ⟨σ', hf, h_eval, h_ρsrc'⟩ := stmt_cmd_terminal_inv h_run_src + subst h_ρsrc' + -- Goal: produce ρ_h' and the terminal-disjunct witness for the hoist replay of c. + -- For every shape, the hoist replays the SAME command c. + cases c with + | init y ty rhs md => + -- definedVars (.init y) = [y]; Block.initVars [.cmd (.init y..)] = [y]. + have h_y_init : y ∈ Block.initVars (P := P) [.cmd (.init y ty rhs md)] := by + simp [Block.initVars, Stmt.initVars] + have h_y_notA : y ∉ A := h_lhs_disjoint y h_y_init + have h_y_notB : y ∉ B := h_extra_disjoint y h_y_init + have h_y_src_none : ρ_src.store y = none := h_hoist_undef y h_y_init + -- The hoist-side undefinedness now comes from the COMPANION invariant + -- `h_hoist_undef_h` (the guarded frame no longer carries the none⇒none route). + have h_y_hoist_none : ρ_hoist.store y = none := h_hoist_undef_h y h_y_init + -- The RHS-freshness facts for A and B (so rhs eval agrees across stores). + have h_rhs_freshA : ∀ z ∈ A, z ∉ ExprOrNondet.getVars (P := P) rhs := by + intro z hz + have h := h_names_fresh + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + List.all_eq_true] at h + exact freshFromIdents_not_mem (h z hz) + have h_rhs_freshB : ∀ z ∈ B, z ∉ ExprOrNondet.getVars (P := P) rhs := by + intro z hz + have h := h_names_fresh_B + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + List.all_eq_true] at h + exact freshFromIdents_not_mem (h z hz) + -- Stores agree on every source-DEFINED variable read by rhs (each is outside + -- A ∪ B); the guard `σ_src x ≠ none` is supplied by the caller from the RHS + -- evaluation success. + have h_rhs_agree : ∀ x ∈ ExprOrNondet.getVars (P := P) rhs, + ρ_src.store x ≠ none → ρ_src.store x = ρ_hoist.store x := by + intro x hx h_x_ne + refine h_hinv.1 x ?_ ?_ h_x_ne + · intro hxA; exact h_rhs_freshA x hxA hx + · intro hxB; exact h_rhs_freshB x hxB hx + -- Build the hoist init + the post HoistInv. The init target y ∉ A ∪ B, so + -- the parallel update at y uses `extend_both_outside_subst`. + cases h_eval with + | eval_init h_eval_src h_is_src h_wfvar_src h_wfcongr_src => + rename_i v e + -- rhs = .det e, getVars rhs = getVars e. The RHS evaluation succeeds + -- (`h_eval_src`), so every read var is source-defined — discharging the + -- guarded frame. + have h_e_read_def : ∀ x ∈ HasVarsPure.getVars e, ρ_src.store x ≠ none := + read_vars_def_of_eval (h_wfdef ρ_src) h_eval_src + have h_e_agree : ∀ x ∈ HasVarsPure.getVars e, ρ_src.store x = ρ_hoist.store x := by + intro x hx + exact h_rhs_agree x (by show x ∈ ExprOrNondet.getVars (.det e); exact hx) + (h_e_read_def x hx) + have h_eval_hoist : ρ_hoist.eval ρ_hoist.store e = .some v := by + have h_eq : ρ_hoist.eval ρ_src.store e = ρ_hoist.eval ρ_hoist.store e := + (h_wfcongr ρ_hoist) e ρ_src.store ρ_hoist.store h_e_agree + rw [← h_eq, ← h_eval_eq]; exact h_eval_src + -- σ' = extendStoreOne ρ_src.store y v (from InitState). + have h_σ'_eq : σ' = extendStoreOne ρ_src.store y v := InitState_eq_extendStoreOne h_is_src + -- Hoist InitState at y (ρ_hoist.store y = none). + have h_is_hoist : InitState P ρ_hoist.store y v (extendStoreOne ρ_hoist.store y v) := + InitState.init h_y_hoist_none (extendStoreOne_self ρ_hoist.store y v) + (fun z hz => extendStoreOne_other ρ_hoist.store y v z (fun h => hz h.symm)) + have h_wfvar_hoist : WellFormedSemanticEvalVar ρ_hoist.eval := h_wfvar ρ_hoist + have h_wfcongr_hoist : WellFormedSemanticEvalExprCongr ρ_hoist.eval := h_wfcongr ρ_hoist + have h_eval_cmd_hoist : + EvalCmd P ρ_hoist.eval ρ_hoist.store (.init y ty (.det e) md) + (extendStoreOne ρ_hoist.store y v) false := + EvalCmd.eval_init h_eval_hoist h_is_hoist h_wfvar_hoist h_wfcongr_hoist + exact cmd_init_arm_close (v := v) h_y_notA h_y_notB h_subst_wf h_hinv h_hf_eq h_hoist_bound + h_σ'_eq h_eval_cmd_hoist + | eval_init_unconstrained h_is_src h_wfvar_src => + rename_i v + have h_σ'_eq : σ' = extendStoreOne ρ_src.store y v := InitState_eq_extendStoreOne h_is_src + have h_is_hoist : InitState P ρ_hoist.store y v (extendStoreOne ρ_hoist.store y v) := + InitState.init h_y_hoist_none (extendStoreOne_self ρ_hoist.store y v) + (fun z hz => extendStoreOne_other ρ_hoist.store y v z (fun h => hz h.symm)) + have h_wfvar_hoist : WellFormedSemanticEvalVar ρ_hoist.eval := h_wfvar ρ_hoist + have h_eval_cmd_hoist : + EvalCmd P ρ_hoist.eval ρ_hoist.store (.init y ty .nondet md) + (extendStoreOne ρ_hoist.store y v) false := + EvalCmd.eval_init_unconstrained h_is_hoist h_wfvar_hoist + exact cmd_init_arm_close (v := v) h_y_notA h_y_notB h_subst_wf h_hinv h_hf_eq h_hoist_bound + h_σ'_eq h_eval_cmd_hoist + | set x rhs md => + -- The hoist replays `.set x`. `Cmd.modifiedVars (.set x ..) = [x]`, so the + -- two new disjointness hyps give `x ∉ A` and `x ∉ B` directly: the `.set` + -- target can never coincide with a renamed-name set side. + have h_x_mod : x ∈ Block.modifiedVars (P := P) (C := Cmd P) [.cmd (.set x rhs md)] := by + simp [Block.modifiedVars, Stmt.modifiedVars, HasVarsImp.modifiedVars, Cmd.modifiedVars] + have hxA : x ∉ A := h_mod_disjoint_A x h_x_mod + have hxB : x ∉ B := h_mod_disjoint_B x h_x_mod + -- rhs-freshness ⇒ eval agreement on source-DEFINED rhs vars (guard supplied + -- by the caller from the RHS evaluation success). + have h_rhs_agree : ∀ z ∈ ExprOrNondet.getVars (P := P) rhs, + ρ_src.store z ≠ none → ρ_src.store z = ρ_hoist.store z := by + intro z hz h_z_ne + refine h_hinv.1 z ?_ ?_ h_z_ne + · intro hzA + have h := h_names_fresh + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + List.all_eq_true] at h + exact freshFromIdents_not_mem (h z hzA) hz + · intro hzB + have h := h_names_fresh_B + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + List.all_eq_true] at h + exact freshFromIdents_not_mem (h z hzB) hz + cases h_eval with + | eval_set h_eval_src h_upd_src h_wfvar_src h_wfcongr_src => + rename_i v e + have h_e_read_def : ∀ z ∈ HasVarsPure.getVars (P := P) e, ρ_src.store z ≠ none := + read_vars_def_of_eval (h_wfdef ρ_src) h_eval_src + have h_e_agree : ∀ z ∈ HasVarsPure.getVars (P := P) e, + ρ_src.store z = ρ_hoist.store z := fun z hz => + h_rhs_agree z (by show z ∈ ExprOrNondet.getVars (.det e); exact hz) (h_e_read_def z hz) + have h_eval_hoist : ρ_hoist.eval ρ_hoist.store e = .some v := by + have h_eq : ρ_hoist.eval ρ_src.store e = ρ_hoist.eval ρ_hoist.store e := + (h_wfcongr ρ_hoist) e ρ_src.store ρ_hoist.store h_e_agree + rw [← h_eq, ← h_eval_eq]; exact h_eval_src + -- Build hoist UpdateState at x (defined: x was previously bound, so the + -- guarded frame at x is dischargeable). + have h_x_some_src : ∃ v_old, ρ_src.store x = some v_old := by + cases h_upd_src with | update h1 _ _ => exact ⟨_, h1⟩ + obtain ⟨v_old, h_x_some_src⟩ := h_x_some_src + have h_x_src_eq_hoist : ρ_src.store x = ρ_hoist.store x := + h_hinv.1 x hxA hxB (by rw [h_x_some_src]; exact Option.some_ne_none v_old) + have h_x_hoist_some : ρ_hoist.store x = some v_old := by + rw [← h_x_src_eq_hoist]; exact h_x_some_src + have h_upd_hoist : + UpdateState P ρ_hoist.store x v (extendStoreOne ρ_hoist.store x v) := + UpdateState.update h_x_hoist_some (extendStoreOne_self ρ_hoist.store x v) + (fun z hz => extendStoreOne_other ρ_hoist.store x v z (fun h => hz h.symm)) + have h_eval_cmd_hoist : + EvalCmd P ρ_hoist.eval ρ_hoist.store (.set x (.det e) md) + (extendStoreOne ρ_hoist.store x v) false := + EvalCmd.eval_set h_eval_hoist h_upd_hoist (h_wfvar ρ_hoist) (h_wfcongr ρ_hoist) + have h_σ'_eq : σ' = extendStoreOne ρ_src.store x v := + UpdateState_eq_extendStoreOne h_upd_src + exact cmd_init_arm_close (v := v) hxA hxB h_subst_wf h_hinv h_hf_eq h_hoist_bound + h_σ'_eq h_eval_cmd_hoist + | eval_set_nondet h_upd_src h_wfvar_src => + rename_i v + have h_x_some_src : ∃ v_old, ρ_src.store x = some v_old := by + cases h_upd_src with | update h1 _ _ => exact ⟨_, h1⟩ + obtain ⟨v_old, h_x_some_src⟩ := h_x_some_src + have h_x_src_eq_hoist : ρ_src.store x = ρ_hoist.store x := + h_hinv.1 x hxA hxB (by rw [h_x_some_src]; exact Option.some_ne_none v_old) + have h_x_hoist_some : ρ_hoist.store x = some v_old := by + rw [← h_x_src_eq_hoist]; exact h_x_some_src + have h_upd_hoist : + UpdateState P ρ_hoist.store x v (extendStoreOne ρ_hoist.store x v) := + UpdateState.update h_x_hoist_some (extendStoreOne_self ρ_hoist.store x v) + (fun z hz => extendStoreOne_other ρ_hoist.store x v z (fun h => hz h.symm)) + have h_eval_cmd_hoist : + EvalCmd P ρ_hoist.eval ρ_hoist.store (.set x .nondet md) + (extendStoreOne ρ_hoist.store x v) false := + EvalCmd.eval_set_nondet h_upd_hoist (h_wfvar ρ_hoist) + have h_σ'_eq : σ' = extendStoreOne ρ_src.store x v := + UpdateState_eq_extendStoreOne h_upd_src + exact cmd_init_arm_close (v := v) hxA hxB h_subst_wf h_hinv h_hf_eq h_hoist_bound + h_σ'_eq h_eval_cmd_hoist + | assert albl e md => + -- Condition vars are fresh from A and B (from h_names_fresh / _B), so the + -- guard evaluates identically on the HoistInv-related stores — at every + -- source-DEFINED read var (guard supplied from the condition eval success). + have h_e_agree : ∀ z ∈ HasVarsPure.getVars (P := P) e, + ρ_src.store z ≠ none → ρ_src.store z = ρ_hoist.store z := by + intro z hz h_z_ne + refine h_hinv.1 z ?_ ?_ h_z_ne + · intro hzA + have h := h_names_fresh + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + List.all_eq_true] at h + exact freshFromIdents_not_mem (h z hzA) hz + · intro hzB + have h := h_names_fresh_B + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + List.all_eq_true] at h + exact freshFromIdents_not_mem (h z hzB) hz + have h_guard_transport : ∀ w, ρ_src.eval ρ_src.store e = some w → + ρ_hoist.eval ρ_hoist.store e = ρ_src.eval ρ_src.store e := by + intro w h_e_w + have h_read_def := read_vars_def_of_eval (h_wfdef ρ_src) h_e_w + have h_agree : ∀ z ∈ HasVarsPure.getVars (P := P) e, ρ_src.store z = ρ_hoist.store z := + fun z hz => h_e_agree z hz (h_read_def z hz) + have h_eq : ρ_hoist.eval ρ_src.store e = ρ_hoist.eval ρ_hoist.store e := + (h_wfcongr ρ_hoist) e ρ_src.store ρ_hoist.store h_agree + rw [← h_eq, ← h_eval_eq] + cases h_eval with + | eval_assert_pass h_tt h_wfb h_wfc => + have h_eval_hoist : + EvalCmd P ρ_hoist.eval ρ_hoist.store (.assert albl e md) ρ_hoist.store false := + EvalCmd.eval_assert_pass (by rw [h_guard_transport _ h_tt]; exact h_tt) + (h_eval_eq ▸ h_wfb) (h_wfcongr ρ_hoist) + exact cmd_passive_arm_close h_hinv h_hf_eq h_hoist_bound h_eval_hoist + | eval_assert_fail h_ff h_wfb h_wfc => + have h_eval_hoist : + EvalCmd P ρ_hoist.eval ρ_hoist.store (.assert albl e md) ρ_hoist.store true := + EvalCmd.eval_assert_fail (by rw [h_guard_transport _ h_ff]; exact h_ff) + (h_eval_eq ▸ h_wfb) (h_wfcongr ρ_hoist) + exact cmd_passive_arm_close h_hinv h_hf_eq h_hoist_bound h_eval_hoist + | assume albl e md => + have h_e_agree : ∀ z ∈ HasVarsPure.getVars (P := P) e, + ρ_src.store z ≠ none → ρ_src.store z = ρ_hoist.store z := by + intro z hz h_z_ne + refine h_hinv.1 z ?_ ?_ h_z_ne + · intro hzA + have h := h_names_fresh + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + List.all_eq_true] at h + exact freshFromIdents_not_mem (h z hzA) hz + · intro hzB + have h := h_names_fresh_B + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + List.all_eq_true] at h + exact freshFromIdents_not_mem (h z hzB) hz + cases h_eval with + | eval_assume h_tt h_wfb h_wfc => + have h_read_def := read_vars_def_of_eval (h_wfdef ρ_src) h_tt + have h_agree : ∀ z ∈ HasVarsPure.getVars (P := P) e, ρ_src.store z = ρ_hoist.store z := + fun z hz => h_e_agree z hz (h_read_def z hz) + have h_guard_transport : ρ_hoist.eval ρ_hoist.store e = ρ_src.eval ρ_src.store e := by + have h_eq : ρ_hoist.eval ρ_src.store e = ρ_hoist.eval ρ_hoist.store e := + (h_wfcongr ρ_hoist) e ρ_src.store ρ_hoist.store h_agree + rw [← h_eq, ← h_eval_eq] + have h_eval_hoist : + EvalCmd P ρ_hoist.eval ρ_hoist.store (.assume albl e md) ρ_hoist.store false := + EvalCmd.eval_assume (by rw [h_guard_transport]; exact h_tt) + (h_eval_eq ▸ h_wfb) (h_wfcongr ρ_hoist) + exact cmd_passive_arm_close h_hinv h_hf_eq h_hoist_bound h_eval_hoist + | cover albl e md => + cases h_eval with + | eval_cover h_wfb => + have h_eval_hoist : + EvalCmd P ρ_hoist.eval ρ_hoist.store (.cover albl e md) ρ_hoist.store false := + EvalCmd.eval_cover (h_eval_eq ▸ h_wfb) + exact cmd_passive_arm_close h_hinv h_hf_eq h_hoist_bound h_eval_hoist + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 4000 in +mutual + +/-- §E Stmt-level forward simulation IH (sum-typed conclusion), stated over the +MONADIC pass `Stmt.hoistLoopPrefixInitsM` at an ARBITRARY input generator state +`σ`. + +For a single statement `s` with the front-end shape preconditions, every +source run `.stmt s ρ_src ⟶* cfg_src` whose final config is either +`.terminal ρ_src'` or `.exiting lbl ρ_src'` admits a matching hoisted run +`.stmts (Stmt.hoistLoopPrefixInitsM s σ).1 ρ_hoist ⟶* cfg_hoist` to a config +of the same shape (terminal or exiting with the same label), carrying +`HoistInv A B subst` and `hasFailure` agreement. + +Quantifying over `σ` (rather than fixing `σ = emp` via the pure wrapper) lets +the `cons`/`.ite` arms recurse: the tail/else IH instantiates at the ADVANCED +state `σ' = (Stmt.hoistLoopPrefixInitsM s σ).2`, where the monadic residual +genuinely lives. The pure wrapper `Stmt.hoistLoopPrefixInits s` is the +`σ = emp` specialization, so the top-level theorem instantiates this lemma at +`σ := StringGenState.emp`. + +`h_wf_σ` is the generator-state well-formedness carried through the threading; +`h_src_namesFreshFromσ` records that every generated label already present in +`σ` (and hence its corresponding identifier) is disjoint from the source +program's frame names `A`, extra names `B`, and `.init` LHS names. At +`σ = emp` the generated-labels list is empty, so this precondition is +vacuously true. + +Three further preconditions support the per-arm reproofs: +`h_names_fresh_B` is the `B`-side analogue of `h_names_fresh` — the extra +names `B` (the hoisted-prelude targets) are fresh in every guard and RHS +expression of the source statement, which the loop/conditional arms need to +transport guard evaluation across the `HoistInv`-related stores. +`h_src_shapefree` records that any source identifier with the generator's +`_` suffix shape is disjoint from `A`, `B`, and the `.init` LHS names; +this is the well-formedness assumption that front-end source names never +collide with the generator's freshly-minted naming scheme. `h_subst_wf` +records that every substitution pair `(a, b)` relates an `A`-name to a +`B`-name. + +The sum-typed conclusion is required by the `.block` arm: the body of +a labeled block can produce `.exiting lbl_inner` for `lbl_inner ≠ lbl`, +which propagates as `.exiting lbl_inner` at the outer block level. The +old terminal-only conclusion could not transport such body subtraces. -/ +private theorem Stmt.hoistLoopPrefixInits_preserves {Q : String → Prop} + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] + [HasIntOrder P] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + [DecidableEq P.Ident] + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {extendEval : ExtendEval P} + (A : List P.Ident) + (B : List P.Ident) + (subst : List (P.Ident × P.Ident)) + (s : Stmt P (Cmd P)) + (σ : StringGenState) + {ρ_src ρ_hoist : Env P} + {cfg_src : Config P (Cmd P)} + (h_no_nd : Stmt.containsNondetLoop s = false) + (h_no_fd : Stmt.containsFuncDecl s = false) + (h_no_inv : Stmt.loopHasNoInvariants s = true) + (h_no_measure : Stmt.loopMeasureNone s = true) + (h_exprs_shapefree : Block.exprsShapeFree (P := P) Q [s]) + (h_unique : Block.uniqueInits [s]) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) [s] = true) + (h_names_fresh : Block.namesFreshInExprs A [s] = true) + (h_names_fresh_B : Block.namesFreshInExprs B [s] = true) + (h_lhs_disjoint : ∀ y ∈ Block.initVars [s], y ∉ A) + (h_extra_disjoint : ∀ y ∈ Block.initVars [s], y ∉ B) + (h_mod_disjoint_A : ∀ x ∈ Block.modifiedVars [s], x ∉ A) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars [s], x ∉ B) + (h_hoist_undef : ∀ y ∈ Block.initVars [s], ρ_src.store y = none) + (h_hoist_undef_h : ∀ y ∈ Block.initVars [s], ρ_hoist.store y = none) + (h_src_store_shapefree : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_src.store (HasIdent.ident (P := P) str) = none) + (h_hoist_store_shapefree : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_hoist.store (HasIdent.ident (P := P) str) = none) + (h_wf_σ : StringGenState.WF σ) + (h_src_namesFreshFromσ : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars [s]) + (h_src_shapefree : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars [s] ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars [s]) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval_eq : ρ_src.eval = ρ_hoist.eval) + (h_hf_eq : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_hoist_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmt s ρ_src) cfg_src) + (h_cfg_src : (∃ ρ_src' : Env P, cfg_src = .terminal ρ_src') ∨ + (∃ lbl ρ_src', cfg_src = .exiting lbl ρ_src')) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + ∃ ρ_h', ∃ cfg_hoist : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.hoistLoopPrefixInitsM s σ).1 ρ_hoist) cfg_hoist + ∧ ((∃ ρ_src' : Env P, + cfg_src = .terminal ρ_src' ∧ cfg_hoist = .terminal ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none)) ∨ + (∃ lbl ρ_src', + cfg_src = .exiting lbl ρ_src' ∧ cfg_hoist = .exiting lbl ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none))) := by + classical + match h_match : s with + | .cmd c => + subst h_match + -- Identity residual `[.cmd c]`. A single command cannot exit, so the source + -- run terminates via one `EvalCmd`; the hoisted side replays the SAME command + -- and the resulting stores stay `HoistInv`-related. The store transport + -- splits on the command shape: `.init`/`.set` whose target lies outside the + -- substitution use `HoistInv.extend_both_outside_subst`; the remaining + -- `.assert`/`.assume`/`.cover` leave the store fixed. The `.set` target + -- cannot coincide with a substitution-pair side because the modified-variable + -- disjointness preconditions force it outside `A ∪ B`. All eight shapes are + -- discharged by the isolated `cmd_arm`. + exact cmd_arm A B subst c σ h_names_fresh h_names_fresh_B h_lhs_disjoint + h_extra_disjoint h_mod_disjoint_A h_mod_disjoint_B h_hoist_undef h_hoist_undef_h + h_src_store_shapefree h_hoist_store_shapefree + h_subst_wf + h_hinv h_eval_eq h_hf_eq h_hoist_bound h_run_src h_cfg_src h_wfvar h_wfcongr h_wfsubst h_wfdef + | .block lbl bss md => + subst h_match + -- === Decompose the §E preconditions for `[.block lbl bss md]` to `bss`. === + -- Every structural Bool walker on `.block` reduces to its body, and + -- `Block.initVars [.block lbl bss md] = Block.initVars bss`. + have h_iv_eq : Block.initVars [Stmt.block lbl bss md] = Block.initVars bss := by + simp only [Block.initVars, Stmt.initVars, List.append_nil] + have h_mod_eq : Block.modifiedVars [Stmt.block lbl bss md] = Block.modifiedVars bss := by + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil] + have h_nd_bss : Block.containsNondetLoop bss = false := by + simpa only [Block.containsNondetLoop, Stmt.containsNondetLoop, Bool.or_false] using h_no_nd + have h_fd_bss : Block.containsFuncDecl bss = false := by + simpa only [Block.containsFuncDecl, Stmt.containsFuncDecl, Bool.or_false] using h_no_fd + have h_inv_bss : Block.loopHasNoInvariants bss = true := by + simpa only [Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, Bool.and_true] using h_no_inv + have h_measure_bss : Block.loopMeasureNone bss = true := by + simpa only [Block.loopMeasureNone, Stmt.loopMeasureNone, Bool.and_true] using h_no_measure + have h_exprs_shapefree_bss : Block.exprsShapeFree (P := P) Q bss := by + have h := h_exprs_shapefree + simp only [Block.exprsShapeFree, Stmt.exprsShapeFree] at h + exact h.1 + have h_unique_bss : Block.uniqueInits bss := by + show (Block.initVars bss).Nodup + have : Block.uniqueInits [Stmt.block lbl bss md] = + (Block.initVars [Stmt.block lbl bss md]).Nodup := rfl + rw [this, h_iv_eq] at h_unique; exact h_unique + have h_fresh_bss : Block.hoistedNamesFreshInRhsAndGuards (P := P) bss = true := by + have h_fresh_unfold := h_fresh + unfold Block.hoistedNamesFreshInRhsAndGuards at h_fresh_unfold ⊢ + -- `namesFreshInRhsExprs (initVars [.block..]) [.block..] = namesFreshInRhsExprs (initVars bss) bss`. + have : Block.namesFreshInRhsExprs (Block.initVars [Stmt.block lbl bss md]) + [Stmt.block lbl bss md] = + Block.namesFreshInRhsExprs (Block.initVars bss) bss := by + simp only [Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, Bool.and_true, h_iv_eq] + rwa [this] at h_fresh_unfold + have h_names_fresh_bss : Block.namesFreshInExprs A bss = true := by + simpa only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true] using h_names_fresh + have h_names_fresh_B_bss : Block.namesFreshInExprs B bss = true := by + simpa only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true] using h_names_fresh_B + have h_lhs_disjoint_bss : ∀ y ∈ Block.initVars bss, y ∉ A := fun y hy => + h_lhs_disjoint y (h_iv_eq ▸ hy) + have h_extra_disjoint_bss : ∀ y ∈ Block.initVars bss, y ∉ B := fun y hy => + h_extra_disjoint y (h_iv_eq ▸ hy) + have h_mod_disjoint_A_bss : ∀ x ∈ Block.modifiedVars bss, x ∉ A := fun x hx => + h_mod_disjoint_A x (h_mod_eq ▸ hx) + have h_mod_disjoint_B_bss : ∀ x ∈ Block.modifiedVars bss, x ∉ B := fun x hx => + h_mod_disjoint_B x (h_mod_eq ▸ hx) + have h_hoist_undef_bss : ∀ y ∈ Block.initVars bss, ρ_src.store y = none := fun y hy => + h_hoist_undef y (h_iv_eq ▸ hy) + have h_hoist_undef_h_bss : ∀ y ∈ Block.initVars bss, ρ_hoist.store y = none := fun y hy => + h_hoist_undef_h y (h_iv_eq ▸ hy) + have h_src_fresh_bss : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars bss := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (h_iv_eq ▸ h)⟩ + have h_src_shapefree_bss : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars bss ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars bss := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (h_iv_eq ▸ h), fun h => hmv (h_mod_eq ▸ h)⟩ + -- === Rewrite the residual to the singleton hoisted `.block`. === + have h_block_out : + (Stmt.hoistLoopPrefixInitsM (.block lbl bss md) σ).1 = + [Stmt.block lbl (Block.hoistLoopPrefixInitsM bss σ).1 md] := + Stmt.hoistLoopPrefixInitsM_block_out lbl bss md σ + rw [h_block_out] + -- === Invert the SOURCE run: `.stmt (.block lbl bss md) ρ_src` enters the + -- block scope, runs `bss`, then projects on exit. === + cases h_run_src with + | refl => rcases h_cfg_src with ⟨_, h⟩ | ⟨_, _, h⟩ <;> exact nomatch h + | step _ _ _ h1 hr1 => + cases h1 + -- now `hr1 : .block (.some lbl) ρ_src.store (.stmts bss ρ_src) ⟶* cfg_src`. + rcases h_cfg_src with ⟨ρ_src', h_t⟩ | ⟨lbl_e, ρ_src', h_e⟩ + · -- TERMINAL: inner reaches terminal, or exits with matching label. + subst h_t + rcases block_some_reaches_terminal P (EvalCmd P) extendEval hr1 with + ⟨ρ_inner, h_inner_run, h_proj⟩ | ⟨ρ_inner, h_inner_run, h_proj⟩ + · -- inner terminates. + obtain ⟨ρ_h', cfg_hoist, h_body_hoist, h_outcome⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst bss σ + h_nd_bss h_fd_bss h_inv_bss h_measure_bss h_exprs_shapefree_bss h_unique_bss h_fresh_bss + h_names_fresh_bss h_names_fresh_B_bss h_lhs_disjoint_bss h_extra_disjoint_bss + h_mod_disjoint_A_bss h_mod_disjoint_B_bss + h_hoist_undef_bss h_hoist_undef_h_bss + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_bss h_src_shapefree_bss h_subst_wf h_hinv + h_eval_eq h_hf_eq h_hoist_bound h_inner_run (Or.inl ⟨ρ_inner, rfl⟩) + h_wfvar h_wfcongr h_wfsubst h_wfdef + obtain ⟨h_cfg_h_eq, h_hinv_inner, h_hf_inner, h_bound_inner⟩ : + cfg_hoist = .terminal ρ_h' ∧ + HoistInv (P := P) A B subst ρ_inner.store ρ_h'.store ∧ + ρ_inner.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) := by + rcases h_outcome with ⟨r, hr1', hr2, hr3, hr4, hr5⟩ | ⟨l, r, hr1', _, _, _, _⟩ + · have : r = ρ_inner := by simp only [Config.terminal.injEq] at hr1'; exact hr1'.symm + subst this; exact ⟨hr2, hr3, hr4, hr5⟩ + · exact absurd hr1' (by simp) + subst h_cfg_h_eq + subst h_proj + refine ⟨{ ρ_h' with store := projectStore ρ_hoist.store ρ_h'.store }, + .terminal { ρ_h' with store := projectStore ρ_hoist.store ρ_h'.store }, ?_, + Or.inl ⟨_, rfl, rfl, HoistInv.project_both h_hinv h_hinv_inner, h_hf_inner, ?_⟩⟩ + · -- drive the hoisted block: enter, run body, done. + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner StepStmt.step_block) ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ [] + (block_inner_star P (EvalCmd P) extendEval _ _ _ _ h_body_hoist)) ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner StepStmt.step_block_done) ?_ + refine ReflTrans.step _ _ _ StepStmt.step_seq_done ?_ + exact ReflTrans.step _ _ _ StepStmt.step_stmts_nil (.refl _) + · -- B-boundedness survives projection: each b ∈ B is in ρ_hoist.store + -- (h_hoist_bound) so the parent slot is `some`, hence projectStore keeps + -- the inner value, which is `some` by h_bound_inner. + intro y hy + show projectStore ρ_hoist.store ρ_h'.store y ≠ none + unfold projectStore + have h_parent_some : (ρ_hoist.store y).isSome := by + cases h : ρ_hoist.store y with + | none => exact absurd h (h_hoist_bound y hy) + | some _ => simp + rw [h_parent_some]; exact h_bound_inner y hy + · -- inner exits with the matching label `lbl`: block catches it, terminates. + obtain ⟨ρ_h', cfg_hoist, h_body_hoist, h_outcome⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst bss σ + h_nd_bss h_fd_bss h_inv_bss h_measure_bss h_exprs_shapefree_bss h_unique_bss h_fresh_bss + h_names_fresh_bss h_names_fresh_B_bss h_lhs_disjoint_bss h_extra_disjoint_bss + h_mod_disjoint_A_bss h_mod_disjoint_B_bss + h_hoist_undef_bss h_hoist_undef_h_bss + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_bss h_src_shapefree_bss h_subst_wf h_hinv + h_eval_eq h_hf_eq h_hoist_bound h_inner_run (Or.inr ⟨lbl, ρ_inner, rfl⟩) + h_wfvar h_wfcongr h_wfsubst h_wfdef + obtain ⟨h_cfg_h_eq, h_hinv_inner, h_hf_inner, h_bound_inner⟩ : + cfg_hoist = .exiting lbl ρ_h' ∧ + HoistInv (P := P) A B subst ρ_inner.store ρ_h'.store ∧ + ρ_inner.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) := by + rcases h_outcome with ⟨r, hr1', _, _, _, _⟩ | ⟨l, r, hr1', hr2, hr3, hr4, hr5⟩ + · exact absurd hr1'.symm (by simp) + · obtain ⟨hl, hr_eq⟩ : l = lbl ∧ r = ρ_inner := by + simp only [Config.exiting.injEq] at hr1'; exact ⟨hr1'.1.symm, hr1'.2.symm⟩ + subst hl; subst hr_eq; exact ⟨hr2, hr3, hr4, hr5⟩ + subst h_cfg_h_eq + subst h_proj + refine ⟨{ ρ_h' with store := projectStore ρ_hoist.store ρ_h'.store }, + .terminal { ρ_h' with store := projectStore ρ_hoist.store ρ_h'.store }, ?_, + Or.inl ⟨_, rfl, rfl, HoistInv.project_both h_hinv h_hinv_inner, h_hf_inner, ?_⟩⟩ + · refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner StepStmt.step_block) ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ [] + (block_inner_star P (EvalCmd P) extendEval _ _ _ _ h_body_hoist)) ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner (StepStmt.step_block_exit_match rfl)) ?_ + refine ReflTrans.step _ _ _ StepStmt.step_seq_done ?_ + exact ReflTrans.step _ _ _ StepStmt.step_stmts_nil (.refl _) + · intro y hy + show projectStore ρ_hoist.store ρ_h'.store y ≠ none + unfold projectStore + have h_parent_some : (ρ_hoist.store y).isSome := by + cases h : ρ_hoist.store y with + | none => exact absurd h (h_hoist_bound y hy) + | some _ => simp + rw [h_parent_some]; exact h_bound_inner y hy + · -- EXITING: inner exits with a NON-matching label, which propagates. + subst h_e + obtain ⟨lbl_inner, ρ_inner, h_inner_run, h_proj, h_li_eq, h_label_ne⟩ := + block_some_reaches_exiting_ne (extendEval := extendEval) hr1 + subst h_li_eq + obtain ⟨ρ_h', cfg_hoist, h_body_hoist, h_outcome⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst bss σ + h_nd_bss h_fd_bss h_inv_bss h_measure_bss h_exprs_shapefree_bss h_unique_bss h_fresh_bss + h_names_fresh_bss h_names_fresh_B_bss h_lhs_disjoint_bss h_extra_disjoint_bss + h_mod_disjoint_A_bss h_mod_disjoint_B_bss + h_hoist_undef_bss h_hoist_undef_h_bss + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_bss h_src_shapefree_bss h_subst_wf h_hinv + h_eval_eq h_hf_eq h_hoist_bound h_inner_run (Or.inr ⟨lbl_inner, ρ_inner, rfl⟩) + h_wfvar h_wfcongr h_wfsubst h_wfdef + obtain ⟨h_cfg_h_eq, h_hinv_inner, h_hf_inner, h_bound_inner⟩ : + cfg_hoist = .exiting lbl_inner ρ_h' ∧ + HoistInv (P := P) A B subst ρ_inner.store ρ_h'.store ∧ + ρ_inner.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) := by + rcases h_outcome with ⟨r, hr1', _, _, _, _⟩ | ⟨l, r, hr1', hr2, hr3, hr4, hr5⟩ + · exact absurd hr1'.symm (by simp) + · obtain ⟨hl, hr_eq⟩ : l = lbl_inner ∧ r = ρ_inner := by + simp only [Config.exiting.injEq] at hr1'; exact ⟨hr1'.1.symm, hr1'.2.symm⟩ + subst hl; subst hr_eq; exact ⟨hr2, hr3, hr4, hr5⟩ + subst h_cfg_h_eq + subst h_proj + refine ⟨{ ρ_h' with store := projectStore ρ_hoist.store ρ_h'.store }, + .exiting lbl_inner { ρ_h' with store := projectStore ρ_hoist.store ρ_h'.store }, ?_, + Or.inr ⟨lbl_inner, _, rfl, rfl, HoistInv.project_both h_hinv h_hinv_inner, h_hf_inner, ?_⟩⟩ + · refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner StepStmt.step_block) ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ [] + (block_inner_star P (EvalCmd P) extendEval _ _ _ _ h_body_hoist)) ?_ + refine ReflTrans.step _ _ _ + (StepStmt.step_seq_inner (StepStmt.step_block_exit_mismatch h_label_ne)) ?_ + exact ReflTrans.step _ _ _ StepStmt.step_seq_exit (.refl _) + · intro y hy + show projectStore ρ_hoist.store ρ_h'.store y ≠ none + unfold projectStore + have h_parent_some : (ρ_hoist.store y).isSome := by + cases h : ρ_hoist.store y with + | none => exact absurd h (h_hoist_bound y hy) + | some _ => simp + rw [h_parent_some]; exact h_bound_inner y hy + | .ite g tss ess md => + subst h_match + -- === Decompose the §E preconditions for `[.ite g tss ess md]` to the + -- branches `tss` (processed at σ) and `ess` (processed at σ1). === + have h_iv_split : Block.initVars [Stmt.ite g tss ess md] = + Block.initVars tss ++ Block.initVars ess := by + simp only [Block.initVars, Stmt.initVars, List.append_nil] + have h_mod_split : Block.modifiedVars [Stmt.ite g tss ess md] = + Block.modifiedVars tss ++ Block.modifiedVars ess := by + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil] + -- Bool preconds. + have h_nd_branches : Block.containsNondetLoop tss = false ∧ Block.containsNondetLoop ess = false := by + simp only [Stmt.containsNondetLoop, + Bool.or_eq_false_iff] at h_no_nd; exact h_no_nd + have h_fd_branches : Block.containsFuncDecl tss = false ∧ Block.containsFuncDecl ess = false := by + simp only [Stmt.containsFuncDecl, + Bool.or_eq_false_iff] at h_no_fd; exact h_no_fd + have h_inv_branches : Block.loopHasNoInvariants tss = true ∧ Block.loopHasNoInvariants ess = true := by + simp only [Stmt.loopHasNoInvariants, + Bool.and_eq_true] at h_no_inv; exact h_no_inv + have h_measure_branches : Block.loopMeasureNone tss = true ∧ Block.loopMeasureNone ess = true := by + simp only [Stmt.loopMeasureNone, + Bool.and_eq_true] at h_no_measure; exact h_no_measure + have h_exprs_shapefree_branches : + Block.exprsShapeFree (P := P) Q tss ∧ + Block.exprsShapeFree (P := P) Q ess := by + have h := h_exprs_shapefree + simp only [Block.exprsShapeFree, Stmt.exprsShapeFree] at h + exact ⟨h.1.2.1, h.1.2.2⟩ + -- uniqueInits: Nodup splits over the append. + have h_unique_full : (Block.initVars tss ++ Block.initVars ess).Nodup := by + have : Block.uniqueInits [Stmt.ite g tss ess md] = + (Block.initVars [Stmt.ite g tss ess md]).Nodup := rfl + rw [this, h_iv_split] at h_unique; exact h_unique + have h_unique_tss : Block.uniqueInits tss := (List.nodup_append.mp h_unique_full).1 + have h_unique_ess : Block.uniqueInits ess := (List.nodup_append.mp h_unique_full).2.1 + -- hoistedNamesFreshInRhsAndGuards: split into the two branches. + have h_fresh_unfold := h_fresh + unfold Block.hoistedNamesFreshInRhsAndGuards at h_fresh_unfold + -- namesFreshInRhsExprs over initVars [.ite ..]: split via subset + the ite arm + -- (the `.ite` guard read position is no longer checked, so no guard conjunct). + have h_sub_tss : (Block.initVars tss : List P.Ident) ⊆ Block.initVars [Stmt.ite g tss ess md] := by + rw [h_iv_split]; exact fun _ h => List.mem_append.mpr (Or.inl h) + have h_sub_ess : (Block.initVars ess : List P.Ident) ⊆ Block.initVars [Stmt.ite g tss ess md] := by + rw [h_iv_split]; exact fun _ h => List.mem_append.mpr (Or.inr h) + simp only [Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, Bool.and_true, + Bool.and_eq_true] at h_fresh_unfold + obtain ⟨h_nf_tss_iv, h_nf_ess_iv⟩ := h_fresh_unfold + have h_fresh_tss : Block.hoistedNamesFreshInRhsAndGuards (P := P) tss = true := by + unfold Block.hoistedNamesFreshInRhsAndGuards + exact Block.namesFreshInRhsExprs_subset h_sub_tss tss h_nf_tss_iv + have h_fresh_ess : Block.hoistedNamesFreshInRhsAndGuards (P := P) ess = true := by + unfold Block.hoistedNamesFreshInRhsAndGuards + exact Block.namesFreshInRhsExprs_subset h_sub_ess ess h_nf_ess_iv + -- namesFreshInExprs A / B split over the branches. + have h_names_fresh_A_split : + Block.namesFreshInExprs A tss = true ∧ Block.namesFreshInExprs A ess = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + Bool.and_eq_true] at h_names_fresh; exact ⟨h_names_fresh.1.2, h_names_fresh.2⟩ + have h_names_fresh_B_split : + Block.namesFreshInExprs B tss = true ∧ Block.namesFreshInExprs B ess = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + Bool.and_eq_true] at h_names_fresh_B; exact ⟨h_names_fresh_B.1.2, h_names_fresh_B.2⟩ + -- initVars-based disjointness / undef: split via initVars membership. + have h_lhs_disjoint_tss : ∀ y ∈ Block.initVars tss, y ∉ A := fun y hy => + h_lhs_disjoint y (h_sub_tss hy) + have h_lhs_disjoint_ess : ∀ y ∈ Block.initVars ess, y ∉ A := fun y hy => + h_lhs_disjoint y (h_sub_ess hy) + have h_extra_disjoint_tss : ∀ y ∈ Block.initVars tss, y ∉ B := fun y hy => + h_extra_disjoint y (h_sub_tss hy) + have h_extra_disjoint_ess : ∀ y ∈ Block.initVars ess, y ∉ B := fun y hy => + h_extra_disjoint y (h_sub_ess hy) + have h_mod_sub_tss : (Block.modifiedVars tss : List P.Ident) ⊆ + Block.modifiedVars [Stmt.ite g tss ess md] := by + rw [h_mod_split]; exact fun _ h => List.mem_append.mpr (Or.inl h) + have h_mod_sub_ess : (Block.modifiedVars ess : List P.Ident) ⊆ + Block.modifiedVars [Stmt.ite g tss ess md] := by + rw [h_mod_split]; exact fun _ h => List.mem_append.mpr (Or.inr h) + have h_mod_disjoint_A_tss : ∀ x ∈ Block.modifiedVars tss, x ∉ A := fun x hx => + h_mod_disjoint_A x (h_mod_sub_tss hx) + have h_mod_disjoint_A_ess : ∀ x ∈ Block.modifiedVars ess, x ∉ A := fun x hx => + h_mod_disjoint_A x (h_mod_sub_ess hx) + have h_mod_disjoint_B_tss : ∀ x ∈ Block.modifiedVars tss, x ∉ B := fun x hx => + h_mod_disjoint_B x (h_mod_sub_tss hx) + have h_mod_disjoint_B_ess : ∀ x ∈ Block.modifiedVars ess, x ∉ B := fun x hx => + h_mod_disjoint_B x (h_mod_sub_ess hx) + have h_hoist_undef_tss : ∀ y ∈ Block.initVars tss, ρ_src.store y = none := fun y hy => + h_hoist_undef y (h_sub_tss hy) + have h_hoist_undef_ess : ∀ y ∈ Block.initVars ess, ρ_src.store y = none := fun y hy => + h_hoist_undef y (h_sub_ess hy) + have h_hoist_undef_h_tss : ∀ y ∈ Block.initVars tss, ρ_hoist.store y = none := fun y hy => + h_hoist_undef_h y (h_sub_tss hy) + have h_hoist_undef_h_ess : ∀ y ∈ Block.initVars ess, ρ_hoist.store y = none := fun y hy => + h_hoist_undef_h y (h_sub_ess hy) + -- σ-freshness / shape-free restricted to each branch. + have h_src_fresh_tss : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars tss := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (h_sub_tss h)⟩ + have h_src_shapefree_tss : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars tss ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars tss := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (h_sub_tss h), fun h => hmv (h_mod_sub_tss h)⟩ + have h_src_shapefree_ess : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars ess ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars ess := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (h_sub_ess h), fun h => hmv (h_mod_sub_ess h)⟩ + -- GenStep facts: σ → σ1 = (Block.hoistLoopPrefixInitsM tss σ).2; WF of σ1. + have h_genStep_tss : StringGenState.GenStep σ (Block.hoistLoopPrefixInitsM tss σ).2 := + Block.hoistLoopPrefixInitsM_genStep tss σ + have h_wf_σ1 : StringGenState.WF (Block.hoistLoopPrefixInitsM tss σ).2 := + h_genStep_tss.wf_mono h_wf_σ + -- σ-freshness for ESS at σ1: thread via SrcNamesFreshFromGen.genStep_of_delta. + have h_src_fresh_ess_σ1 : + ∀ str ∈ StringGenState.stringGens (Block.hoistLoopPrefixInitsM tss σ).2, + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars ess := by + have h_fresh_σ_ess : SrcNamesFreshFromGen (P := P) A B (Block.initVars ess) σ := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (h_sub_ess h)⟩ + exact SrcNamesFreshFromGen.genStep_of_delta + (Block.hoistLoopPrefixInitsM_genStep_delta_Q hQmint tss σ) + (fun str hsuf => let ⟨a, b, c, _⟩ := h_src_shapefree_ess str hsuf; ⟨a, b, c⟩) h_fresh_σ_ess + -- Store-shapefree at σ1 for the ELSE branch. The else branch runs from the + -- SAME entry stores `ρ_src`/`ρ_hoist` (the `.ite` selects one branch), so the + -- store facts are unchanged; only the generator state index advances to σ1. + -- A suffix name `∉ stringGens σ1` is `∉ stringGens σ` by genStep monotonicity, + -- so the σ-version facts transfer. + have h_src_store_shapefree_σ1 : ∀ str : String, Q str → + str ∉ StringGenState.stringGens (Block.hoistLoopPrefixInitsM tss σ).2 → + ρ_src.store (HasIdent.ident (P := P) str) = none := fun str h_suf h_notσ1 => + h_src_store_shapefree str h_suf (fun h => h_notσ1 (h_genStep_tss.subset h)) + have h_hoist_store_shapefree_σ1 : ∀ str : String, Q str → + str ∉ StringGenState.stringGens (Block.hoistLoopPrefixInitsM tss σ).2 → + ρ_hoist.store (HasIdent.ident (P := P) str) = none := fun str h_suf h_notσ1 => + h_hoist_store_shapefree str h_suf (fun h => h_notσ1 (h_genStep_tss.subset h)) + -- === Rewrite the residual to the singleton hoisted `.ite`. === + have h_ite_out : + (Stmt.hoistLoopPrefixInitsM (.ite g tss ess md) σ).1 = + [Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess + (Block.hoistLoopPrefixInitsM tss σ).2).1 md] := + Stmt.hoistLoopPrefixInitsM_ite_out g tss ess md σ + rw [h_ite_out] + -- === Branch glue: given the single hoisted ite step into `branch_residual` + -- and the branch's §E outcome, drive the singleton `.ite` to completion. + -- `ite_stmt` is the hoisted `.ite` (then-residual at σ, else at σ1). === + have branch_glue : + ∀ (ite_stmt : Stmt P (Cmd P)) (branch_residual : List (Stmt P (Cmd P))) + {ρ_h' : Env P} {cfg_b cfg_hoist : Config P (Cmd P)}, + StepStmt P (EvalCmd P) extendEval + (.stmt ite_stmt ρ_hoist) + (.stmts branch_residual ρ_hoist) → + StepStmtStar P (EvalCmd P) extendEval (.stmts branch_residual ρ_hoist) cfg_hoist → + ((∃ r, cfg_b = .terminal r ∧ cfg_hoist = .terminal ρ_h' ∧ + HoistInv (P := P) A B subst r.store ρ_h'.store ∧ + r.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) ∨ + (∃ l r, cfg_b = .exiting l r ∧ cfg_hoist = .exiting l ρ_h' ∧ + HoistInv (P := P) A B subst r.store ρ_h'.store ∧ + r.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none))) → + ∃ ρ_h'2, ∃ cfg_hoist2 : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts [ite_stmt] ρ_hoist) cfg_hoist2 + ∧ ((∃ ρ_src' : Env P, cfg_b = .terminal ρ_src' ∧ cfg_hoist2 = .terminal ρ_h'2 ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'2.store ∧ + ρ_src'.hasFailure = ρ_h'2.hasFailure ∧ (∀ y ∈ B, ρ_h'2.store y ≠ none)) ∨ + (∃ lbl ρ_src', cfg_b = .exiting lbl ρ_src' ∧ cfg_hoist2 = .exiting lbl ρ_h'2 ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'2.store ∧ + ρ_src'.hasFailure = ρ_h'2.hasFailure ∧ (∀ y ∈ B, ρ_h'2.store y ≠ none))) := by + intro ite_stmt branch_residual ρ_h' cfg_b cfg_hoist h_step_hoist h_branch_hoist h_outcome + rcases h_outcome with ⟨r, hr1, hr2, hr3, hr4, hr5⟩ | ⟨l, r, hr1, hr2, hr3, hr4, hr5⟩ + · -- branch terminal. + subst hr2 + refine ⟨ρ_h', .terminal ρ_h', ?_, Or.inl ⟨r, hr1, rfl, hr3, hr4, hr5⟩⟩ + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner h_step_hoist) ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ [] h_branch_hoist) ?_ + refine ReflTrans.step _ _ _ StepStmt.step_seq_done ?_ + exact ReflTrans.step _ _ _ StepStmt.step_stmts_nil (.refl _) + · -- branch exiting. + subst hr2 + refine ⟨ρ_h', .exiting l ρ_h', ?_, Or.inr ⟨l, r, hr1, rfl, hr3, hr4, hr5⟩⟩ + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner h_step_hoist) ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ [] h_branch_hoist) ?_ + exact ReflTrans.step _ _ _ StepStmt.step_seq_exit (.refl _) + -- The hoisted `.ite` to drive (then-residual at σ, else-residual at σ1): + -- The §E conclusion shape for the singleton hoisted `.ite` (used as the + -- explicit return type of the per-branch drivers). + let IteGoal : Prop := + ∃ ρ_h', ∃ cfg_hoist : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts [Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 md] ρ_hoist) + cfg_hoist + ∧ ((∃ ρ_src' : Env P, cfg_src = .terminal ρ_src' ∧ cfg_hoist = .terminal ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) ∨ + (∃ lbl ρ_src', cfg_src = .exiting lbl ρ_src' ∧ cfg_hoist = .exiting lbl ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none))) + -- THEN-branch driver: recurse the §E Block-IH on `tss` at σ. + have run_then : + StepStmtStar P (EvalCmd P) extendEval (.stmts tss ρ_src) cfg_src → + StepStmt P (EvalCmd P) extendEval + (.stmt (Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 md) ρ_hoist) + (.stmts (Block.hoistLoopPrefixInitsM tss σ).1 ρ_hoist) → + IteGoal := by + intro hr1 h_step + obtain ⟨ρ_h', cfg_hoist, h_branch_hoist, h_outcome⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst tss σ + h_nd_branches.1 h_fd_branches.1 h_inv_branches.1 h_measure_branches.1 + h_exprs_shapefree_branches.1 + h_unique_tss h_fresh_tss h_names_fresh_A_split.1 h_names_fresh_B_split.1 + h_lhs_disjoint_tss h_extra_disjoint_tss h_mod_disjoint_A_tss h_mod_disjoint_B_tss + h_hoist_undef_tss h_hoist_undef_h_tss + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_tss h_src_shapefree_tss h_subst_wf h_hinv h_eval_eq h_hf_eq + h_hoist_bound hr1 h_cfg_src h_wfvar h_wfcongr h_wfsubst h_wfdef + exact branch_glue _ (Block.hoistLoopPrefixInitsM tss σ).1 h_step h_branch_hoist h_outcome + -- ELSE-branch driver: recurse the §E Block-IH on `ess` at σ1. + have run_else : + StepStmtStar P (EvalCmd P) extendEval (.stmts ess ρ_src) cfg_src → + StepStmt P (EvalCmd P) extendEval + (.stmt (Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 md) ρ_hoist) + (.stmts (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 ρ_hoist) → + IteGoal := by + intro hr1 h_step + obtain ⟨ρ_h', cfg_hoist, h_branch_hoist, h_outcome⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst ess (Block.hoistLoopPrefixInitsM tss σ).2 + h_nd_branches.2 h_fd_branches.2 h_inv_branches.2 h_measure_branches.2 + h_exprs_shapefree_branches.2 + h_unique_ess h_fresh_ess h_names_fresh_A_split.2 h_names_fresh_B_split.2 + h_lhs_disjoint_ess h_extra_disjoint_ess h_mod_disjoint_A_ess h_mod_disjoint_B_ess + h_hoist_undef_ess h_hoist_undef_h_ess + h_src_store_shapefree_σ1 h_hoist_store_shapefree_σ1 + h_wf_σ1 h_src_fresh_ess_σ1 h_src_shapefree_ess h_subst_wf h_hinv h_eval_eq h_hf_eq + h_hoist_bound hr1 h_cfg_src h_wfvar h_wfcongr h_wfsubst h_wfdef + exact branch_glue _ (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 + h_step h_branch_hoist h_outcome + -- === Invert the SOURCE run: `.stmt (.ite g tss ess md) ρ_src` takes one step + -- selecting a branch, then the branch runs. === + cases h_run_src with + | refl => rcases h_cfg_src with ⟨_, h⟩ | ⟨_, _, h⟩ <;> exact nomatch h + | step _ _ _ h1 hr1 => + cases h1 with + | step_ite_true h_eval h_wfb => + have h_guard := h_eval + rw [ite_guard_agree (subst := subst) (tss := tss) (ess := ess) (md := md) + h_names_fresh h_names_fresh_B h_hinv + (read_vars_def_of_eval (h_wfdef ρ_src) h_eval) h_eval_eq h_wfcongr] at h_guard + rw [h_eval_eq] at h_wfb + exact run_then hr1 (StepStmt.step_ite_true h_guard h_wfb) + | step_ite_false h_eval h_wfb => + have h_guard := h_eval + rw [ite_guard_agree (subst := subst) (tss := tss) (ess := ess) (md := md) + h_names_fresh h_names_fresh_B h_hinv + (read_vars_def_of_eval (h_wfdef ρ_src) h_eval) h_eval_eq h_wfcongr] at h_guard + rw [h_eval_eq] at h_wfb + exact run_else hr1 (StepStmt.step_ite_false h_guard h_wfb) + | step_ite_nondet_true => exact run_then hr1 StepStmt.step_ite_nondet_true + | step_ite_nondet_false => exact run_else hr1 StepStmt.step_ite_nondet_false + | .loop g m inv body md => + subst h_match + -- === A. Normalize the loop shape: g = .det g', m = none, inv = []. === + -- `loopMeasureNone` ⇒ `m = none`; `loopHasNoInvariants` ⇒ `inv = []`; + -- `containsNondetLoop = false` ⇒ guard is `.det g'`. + have h_no_measure_s : Stmt.loopMeasureNone (Stmt.loop g m inv body md) = true := by + simpa only [Block.loopMeasureNone, Bool.and_true] using h_no_measure + have h_no_inv_s : Stmt.loopHasNoInvariants (Stmt.loop g m inv body md) = true := by + simpa only [Block.loopHasNoInvariants, Bool.and_true] using h_no_inv + have h_no_nd_s : Stmt.containsNondetLoop (Stmt.loop g m inv body md) = false := by + simpa only [Block.containsNondetLoop, Bool.or_false] using h_no_nd + have h_m_none : m = none := by + rw [Stmt.loopMeasureNone, Bool.and_eq_true] at h_no_measure_s + exact Option.isNone_iff_eq_none.mp h_no_measure_s.1 + have h_inv_nil : inv = [] := by + rw [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h_no_inv_s + exact List.isEmpty_iff.mp h_no_inv_s.1 + subst h_m_none; subst h_inv_nil + have h_body_nd : ∃ g', g = ExprOrNondet.det g' ∧ Block.containsNondetLoop body = false := by + cases g with + | nondet => rw [Stmt.containsNondetLoop] at h_no_nd_s; exact absurd h_no_nd_s (by simp) + | det g' => refine ⟨g', rfl, ?_⟩; rw [Stmt.containsNondetLoop] at h_no_nd_s; exact h_no_nd_s + obtain ⟨g', rfl, h_nd_body⟩ := h_body_nd + -- === Carrier identities: initVars/modifiedVars of the singleton loop ARE body's. === + have h_iv_body : Block.initVars [Stmt.loop (.det g') none [] body md] = Block.initVars body := by + simp only [Block.initVars, Stmt.initVars, List.append_nil] + have h_mod_body : Block.modifiedVars [Stmt.loop (.det g') none [] body md] = Block.modifiedVars body := by + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil] + -- === Body-level §E preconditions, decomposed from the loop's. === + have h_fd_body : Block.containsFuncDecl body = false := by + have : Stmt.containsFuncDecl (Stmt.loop (.det g') none [] body md) = false := by + simpa only [Block.containsFuncDecl, Bool.or_false] using h_no_fd + rw [Stmt.containsFuncDecl] at this; exact this + have h_inv_body : Block.loopHasNoInvariants body = true := by + rw [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h_no_inv_s; exact h_no_inv_s.2 + have h_measure_body : Block.loopMeasureNone body = true := by + rw [Stmt.loopMeasureNone, Bool.and_eq_true] at h_no_measure_s; exact h_no_measure_s.2 + have h_exprs_shapefree_body : Block.exprsShapeFree (P := P) Q body := by + have h := h_exprs_shapefree + simp only [Block.exprsShapeFree, Stmt.exprsShapeFree] at h + exact h.1.2.2.2 + have h_unique_body : Block.uniqueInits body := by + show (Block.initVars body).Nodup; rw [← h_iv_body]; exact h_unique + have h_fresh_body : Block.hoistedNamesFreshInRhsAndGuards (P := P) body = true := by + have h := h_fresh + unfold Block.hoistedNamesFreshInRhsAndGuards at h ⊢ + rw [h_iv_body] at h + -- the `.loop` arm of `namesFreshInRhsExprs` recurses into the body only. + simp only [Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, + Bool.and_true] at h + exact h + have h_names_fresh_A_body : Block.namesFreshInExprs A body = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + Bool.and_eq_true] at h_names_fresh; exact h_names_fresh.2 + have h_names_fresh_B_body : Block.namesFreshInExprs B body = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + Bool.and_eq_true] at h_names_fresh_B; exact h_names_fresh_B.2 + -- guard `g'` freshness from A / B. + have freshFromIdents_notmem : ∀ {z : P.Ident} {vars : List P.Ident}, + freshFromIdents z vars = true → z ∉ vars := by + intro z vars h + unfold freshFromIdents at h + rw [List.all_eq_true] at h + intro hmem + have h_z := h z hmem + have h_eq : (P.EqIdent z z).decide = true := by simp + rw [h_eq] at h_z + exact absurd h_z (by decide) + have h_g_A_fresh : ∀ x ∈ A, x ∉ HasVarsPure.getVars g' := by + simp only [Block.namesFreshInExprs, Bool.and_true] at h_names_fresh + unfold Stmt.namesFreshInExprs at h_names_fresh + rw [Bool.and_eq_true, Bool.and_eq_true, Bool.and_eq_true] at h_names_fresh + obtain ⟨⟨⟨h_g, _⟩, _⟩, _⟩ := h_names_fresh + rw [List.all_eq_true] at h_g + intro x hx + have := h_g x hx + rw [ExprOrNondet.getVars] at this + exact freshFromIdents_notmem this + have h_g_B_fresh : ∀ x ∈ B, x ∉ HasVarsPure.getVars g' := by + simp only [Block.namesFreshInExprs, Bool.and_true] at h_names_fresh_B + unfold Stmt.namesFreshInExprs at h_names_fresh_B + rw [Bool.and_eq_true, Bool.and_eq_true, Bool.and_eq_true] at h_names_fresh_B + obtain ⟨⟨⟨h_g, _⟩, _⟩, _⟩ := h_names_fresh_B + rw [List.all_eq_true] at h_g + intro x hx + have := h_g x hx + rw [ExprOrNondet.getVars] at this + exact freshFromIdents_notmem this + -- initVars/modifiedVars-based disjointness + undef + σ-freshness for body. + have h_lhs_disjoint_body : ∀ y ∈ Block.initVars body, y ∉ A := fun y hy => + h_lhs_disjoint y (by rw [h_iv_body]; exact hy) + have h_extra_disjoint_body : ∀ y ∈ Block.initVars body, y ∉ B := fun y hy => + h_extra_disjoint y (by rw [h_iv_body]; exact hy) + have h_mod_disjoint_A_body : ∀ x ∈ Block.modifiedVars body, x ∉ A := fun x hx => + h_mod_disjoint_A x (by rw [h_mod_body]; exact hx) + have h_mod_disjoint_B_body : ∀ x ∈ Block.modifiedVars body, x ∉ B := fun x hx => + h_mod_disjoint_B x (by rw [h_mod_body]; exact hx) + have h_hoist_undef_body : ∀ y ∈ Block.initVars body, ρ_src.store y = none := fun y hy => + h_hoist_undef y (by rw [h_iv_body]; exact hy) + have h_hoist_undef_h_body : ∀ y ∈ Block.initVars body, ρ_hoist.store y = none := fun y hy => + h_hoist_undef_h y (by rw [h_iv_body]; exact hy) + have h_src_fresh_body : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars body := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_body]; exact h)⟩ + have h_src_shapefree_body : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars body ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars body := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_body]; exact h), + fun h => hmv (by rw [h_mod_body]; exact h)⟩ + -- === Loop output decomposition: havocs ++ [.loop g' none [] body₃ md]. === + -- body₁ = post-order hoist of body; σ₁ = its final gen state; E = harvest of + -- body₁ at σ₁; body₃ = applyRenames (substOf' E) body₂ where body₂ is the + -- lift residual. The output's renames equal substOf' E (entries_from_lift). + -- Abbreviations (no `set` tactic in this project): the post-order body, its + -- gen state, the harvest, and the rewritten loop body. + let body₁ : List (Stmt P (Cmd P)) := (Block.hoistLoopPrefixInitsM body σ).1 + let σ₁ : StringGenState := (Block.hoistLoopPrefixInitsM body σ).2 + let E : List (LoopInitHoistLoopDriver.Entry P) := + LoopInitHoistLoopDriver.Block.entriesOf body₁ σ₁ + let body₃ : List (Stmt P (Cmd P)) := + Block.applyRenames (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.1 + (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.2 + -- The hoisted loop residual. + have h_loop_out : + (Stmt.hoistLoopPrefixInitsM (Stmt.loop (.det g') none [] body md) σ).1 = + (Block.liftInitsInLoopBodyM body₁ σ₁).1.1.map Stmt.cmd ++ + [Stmt.loop (.det g') none [] body₃ md] := + Stmt.hoistLoopPrefixInitsM_loop_out (.det g') none [] body md σ + rw [h_loop_out] + -- The havocs (mapped to .cmd) equal havocStmts' E; renames equal substOf' E. + have h_harvest := LoopInitHoistLoopDriver.Block.lift_harvest_subst body₁ σ₁ + have h_havoc_eq : (Block.liftInitsInLoopBodyM body₁ σ₁).1.1.map Stmt.cmd = + LoopInitHoistLoopDriver.havocStmts' E := h_harvest.1 + have h_renames_eq : (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.1 = + LoopInitHoistLoopDriver.substOf' E := h_harvest.2 + rw [h_havoc_eq] + -- === Step A: the §E Block IH at the harvest `σ`, presented in the raw + -- ∀-shape `loop_arm_close` expects (both source- and hoist-side + -- `σ`-relative store-shape-freedom supplied directly per iteration). === + have stepA : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Block.initVars body, ρ_s.store y = none) → + (∀ y ∈ Block.initVars body, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) := by + intro ρ_s ρ_h h_hinv_i h_eval_i h_hf_i h_bnd_i h_Vs_i h_Vh_i h_src_sf_i h_hoist_sf_i ρ_s' h_run_i + obtain ⟨ρ_h', cfg_h, h_run_h, h_out⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst body σ + h_nd_body h_fd_body h_inv_body h_measure_body + h_exprs_shapefree_body h_unique_body h_fresh_body + h_names_fresh_A_body h_names_fresh_B_body + h_lhs_disjoint_body h_extra_disjoint_body h_mod_disjoint_A_body h_mod_disjoint_B_body + (fun y hy => h_Vs_i y hy) (fun y hy => h_Vh_i y hy) + h_src_sf_i h_hoist_sf_i + h_wf_σ h_src_fresh_body h_src_shapefree_body h_subst_wf h_hinv_i h_eval_i h_hf_i h_bnd_i + h_run_i (Or.inl ⟨ρ_s', rfl⟩) + h_wfvar h_wfcongr h_wfsubst h_wfdef + rcases h_out with ⟨r, hr1, hr2, hr3, hr4, hr5⟩ | ⟨l, r, hr1, _, _, _, _⟩ + · cases hr1; cases hr2 + exact ⟨ρ_h', h_run_h, hr3, hr4, hr5⟩ + · exact absurd hr1 (by rintro ⟨⟩) + -- === Step A (exiting): the §E Block IH at the harvest `σ`, presented in the + -- raw ∀-shape `loop_arm_close` expects for a body iteration that BREAKS + -- with a label. Same Block IH, dispatched with the `.exiting` `cfg_src` + -- disjunct; the `.terminal` output clause is impossible (`cfg_src` is + -- `.exiting`). A body `.exit` is admitted (no static no-exit guard is consumed). === + have stepA_exit : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Block.initVars body, ρ_s.store y = none) → + (∀ y ∈ Block.initVars body, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) := by + intro ρ_s ρ_h h_hinv_i h_eval_i h_hf_i h_bnd_i h_Vs_i h_Vh_i h_src_sf_i h_hoist_sf_i l ρ_s' h_run_i + obtain ⟨ρ_h', cfg_h, h_run_h, h_out⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst body σ + h_nd_body h_fd_body h_inv_body h_measure_body + h_exprs_shapefree_body h_unique_body h_fresh_body + h_names_fresh_A_body h_names_fresh_B_body + h_lhs_disjoint_body h_extra_disjoint_body h_mod_disjoint_A_body h_mod_disjoint_B_body + (fun y hy => h_Vs_i y hy) (fun y hy => h_Vh_i y hy) + h_src_sf_i h_hoist_sf_i + h_wf_σ h_src_fresh_body h_src_shapefree_body h_subst_wf h_hinv_i h_eval_i h_hf_i h_bnd_i + h_run_i (Or.inr ⟨l, ρ_s', rfl⟩) + h_wfvar h_wfcongr h_wfsubst h_wfdef + rcases h_out with ⟨r, hr1, _, _, _, _⟩ | ⟨l', r, hr1, hr2, hr3, hr4, hr5⟩ + · exact absurd hr1 (by rintro ⟨⟩) + · obtain ⟨hl_eq, hr_eq⟩ : l' = l ∧ r = ρ_s' := by + cases hr1; exact ⟨rfl, rfl⟩ + cases hl_eq; cases hr_eq; cases hr2 + exact ⟨ρ_h', h_run_h, hr3, hr4, hr5⟩ + -- === Step B: the lift renaming simulation at `body₁`'s own harvest carriers. === + have h_src_shapefree_body_iv : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars body := fun str h_suf => + (h_src_shapefree_body str h_suf).2.2.1 + -- Source-side modifiedVars-shape-freedom, projected from the threaded + -- 4-conjunct `h_src_shapefree_body`: a `Q`-kind string never names a + -- source set-target. + have h_mod_shapefree_body : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.modifiedVars body := fun str h_suf => + (h_src_shapefree_body str h_suf).2.2.2 + -- `targetsOf' E` are minted in the lift σ₁ → σ₂ (so ∉ stringGens σ₁) and are + -- `_`-suffix-shaped. `modifiedVars body₁` splits (by the post-order + -- pass's `modifiedVars` classification) into: ORIGINAL `.set` targets (members + -- of `modifiedVars body ++ initVars body`, suffix-free for a well-formed + -- source) and FRESH names from NESTED-loop init lifting (∈ stringGens σ₁). + -- Both classes are disjoint from the suffix-shaped, ∉-σ₁ targets. + have h_mod_disjoint_B1 : ∀ x ∈ Block.modifiedVars body₁, + x ∉ LoopInitHoistLoopDriver.targetsOf' E := + LoopInitHoistLoopArmWF.Block.modifiedVars_disjoint_targetsOf'_self hQmint body σ h_wf_σ + h_unique_body h_src_shapefree_body_iv h_mod_shapefree_body + -- `body₃` (arm-local) uses the lift's OWN renames `(lift body₁ σ₁).1.2.1`, + -- whereas `stepB_self_of_lift` produces `body₃` over `substOf' E`; the two + -- coincide by the harvest identity `h_renames_eq`. + have stepB : LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) + (LoopInitHoistLoopDriver.sourcesOf' E) (LoopInitHoistLoopDriver.targetsOf' E) + (LoopInitHoistLoopDriver.substOf' E) body₁ body₃ := by + have hB := + LoopInitHoistLoopArmWF.Block.stepB_self_of_lift hQmint (extendEval := extendEval) body σ h_wf_σ + h_nd_body h_fd_body h_inv_body h_measure_body h_unique_body + h_exprs_shapefree_body h_src_shapefree_body_iv h_mod_disjoint_B1 + h_wfvar h_wfcongr h_wfsubst h_wfdef + show LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) + (LoopInitHoistLoopDriver.sourcesOf' E) (LoopInitHoistLoopDriver.targetsOf' E) + (LoopInitHoistLoopDriver.substOf' E) body₁ + (Block.applyRenames (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.1 + (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.2) + rw [h_renames_eq] + exact hB + -- === Assemble the close. Abbreviations for the harvest carriers. === + have h_wf_σ₁ : StringGenState.WF σ₁ := + (Block.hoistLoopPrefixInitsM_genStep body σ).wf_mono h_wf_σ + -- Sources ⊆ initVars body₁; targets are `_`-suffixed and ∉ σ₁. + -- Source-side classification: each harvested source is ORIGINAL (∈ initVars + -- body) or FRESH (= ident str, `Q str`, ∈ σ₁ \ σ). + have h_src_class : ∀ a ∈ LoopInitHoistLoopDriver.sourcesOf' E, + (a ∈ Block.initVars body) ∨ + (∃ str : String, a = HasIdent.ident str ∧ Q str ∧ + str ∈ StringGenState.stringGens σ₁ ∧ str ∉ StringGenState.stringGens σ) := by + intro a ha + have h_a_in₁ : a ∈ Block.initVars body₁ := + LoopInitHoistLoopDriver.Block.sourcesOf_entriesOf_subset body₁ σ₁ a ha + have h_class := + (LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_initVars_classified hQmint body σ + h_wf_σ h_unique_body h_src_shapefree_body_iv).1 a h_a_in₁ + rcases h_class with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl h_o + · exact Or.inr ⟨str, he, hQ, hin, hnot⟩ + -- Each harvested target is `ident str` with `Q str` and ∉ σ₁ ⊇ σ. + have h_tgt_class : ∀ b ∈ LoopInitHoistLoopDriver.targetsOf' E, + ∃ str : String, b = HasIdent.ident str ∧ Q str ∧ + str ∉ StringGenState.stringGens σ₁ := by + intro b hb + obtain ⟨e, he_mem, he_eq⟩ := List.mem_map.mp hb + obtain ⟨str, h_b_eq, _, h_notσ₁⟩ := + (LoopInitHoistLoopArmWF.Block.entriesOf_targetGen body₁ σ₁ h_wf_σ₁).1 e he_mem + obtain ⟨str', h_eq', h_Q'⟩ := + LoopInitHoistLoopArmWF.Block.mem_targetsOf'_entriesOf_hasUnderscoreDigitSuffix + hQmint body₁ σ₁ hb + have h_b_eq' : b = HasIdent.ident str := he_eq.symm.trans h_b_eq + have h_id : (HasIdent.ident str' : P.Ident) = HasIdent.ident str := h_eq'.symm.trans h_b_eq' + have : str' = str := LawfulHasIdent.ident_inj h_id + exact ⟨str, h_b_eq', this ▸ h_Q', this ▸ h_notσ₁⟩ + -- Targets are undef at the source post-store (loop entry undef + no-exit). + -- Sources/targets disjoint from ambient A/B and from initVars body. + have h_As_notA : ∀ x ∈ LoopInitHoistLoopDriver.sourcesOf' E, x ∉ A := by + intro x hx + rcases h_src_class x hx with h_o | ⟨str, he, hsuf, _, _⟩ + · exact h_lhs_disjoint_body x h_o + · exact he ▸ (h_src_shapefree_body str hsuf).1 + have h_As_notB : ∀ x ∈ LoopInitHoistLoopDriver.sourcesOf' E, x ∉ B := by + intro x hx + rcases h_src_class x hx with h_o | ⟨str, he, hsuf, _, _⟩ + · exact h_extra_disjoint_body x h_o + · exact he ▸ (h_src_shapefree_body str hsuf).2.1 + have h_B_notAs : ∀ b ∈ B, b ∉ LoopInitHoistLoopDriver.sourcesOf' E := + fun b hb hmem => h_As_notB b hmem hb + have h_Bs_notB : ∀ b ∈ LoopInitHoistLoopDriver.targetsOf' E, b ∉ B := by + intro b hb + obtain ⟨str, he, hsuf, _⟩ := h_tgt_class b hb + exact he ▸ (h_src_shapefree_body str hsuf).2.1 + have h_B_notBs : ∀ b ∈ B, b ∉ LoopInitHoistLoopDriver.targetsOf' E := + fun b hb hmem => h_Bs_notB b hmem hb + have h_ss_wf : ∀ a b, (a, b) ∈ LoopInitHoistLoopDriver.substOf' E → + a ∈ LoopInitHoistLoopDriver.sourcesOf' E ∧ b ∈ LoopInitHoistLoopDriver.targetsOf' E := by + intro a b hab + obtain ⟨e, he, heq⟩ := List.mem_map.mp hab + cases heq + exact ⟨List.mem_map.mpr ⟨e, he, rfl⟩, List.mem_map.mpr ⟨e, he, rfl⟩⟩ + -- guard `g'` is shape-free: it never reads a `_`-suffixed ident. + have h_guard_sf : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ ExprOrNondet.getVars (ExprOrNondet.det g') := by + have h := h_exprs_shapefree + simp only [Block.exprsShapeFree, Stmt.exprsShapeFree] at h + exact h.1.1 + have h_guard_sf' : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ HasVarsPure.getVars g' := by + intro str h_suf + have := h_guard_sf str h_suf + rw [ExprOrNondet.getVars] at this; exact this + -- guard `g'` freshness from sources/targets. + -- Only the NON-`initVars body` sources need a static freshness witness; + -- `h_src_class` forces such a source into the FRESH (suffix-shaped) case, + -- discharged by guard shape-freedom. The `initVars body` sources are + -- handled inside the driver via the `Vs`-undef invariant: a body-init + -- name is undefined at every loop head, so an evaluating guard cannot + -- read it. + have h_g_As_minus_Vs_fresh : ∀ x ∈ LoopInitHoistLoopDriver.sourcesOf' E, + x ∉ Block.initVars body → x ∉ HasVarsPure.getVars g' := by + intro x hx hxVs + rcases h_src_class x hx with h_o | ⟨str, heq, hsuf, _, _⟩ + · exact absurd h_o hxVs + · exact heq ▸ h_guard_sf' str hsuf + have h_g_Bs_fresh : ∀ x ∈ LoopInitHoistLoopDriver.targetsOf' E, x ∉ HasVarsPure.getVars g' := by + intro x hx + obtain ⟨str, heq, hsuf, _⟩ := h_tgt_class x hx + exact heq ▸ h_guard_sf' str hsuf + -- `Vs := initVars body` disjoint from targets (program names vs suffix-shaped). + have h_Vs_notBs : ∀ y ∈ Block.initVars body, y ∉ LoopInitHoistLoopDriver.targetsOf' E := by + intro y hy hmem + obtain ⟨str, he, hsuf, _⟩ := h_tgt_class y hmem + exact (h_src_shapefree_body str hsuf).2.2.1 (he ▸ hy) + -- noFuncDecl facts. + have h_nofd_src : Block.noFuncDecl body = true := Block.noFuncDecl_of_not_containsFuncDecl body h_fd_body + have h_nofd_h : Block.noFuncDecl body₃ = true := by + show Block.noFuncDecl + (Block.applyRenames (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.1 + (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.2) = true + rw [h_renames_eq] + exact LoopInitHoistLoopArmWF.Block.stepB_noFuncDecl_h_of_lift hQmint body σ h_wf_σ + h_nd_body h_fd_body h_inv_body h_measure_body h_unique_body + h_exprs_shapefree_body h_src_shapefree_body_iv h_mod_disjoint_B1 + -- entry-undef of sources/targets at ρ_hoist (the harvest carriers are undef there). + have h_src_undef_h : ∀ e ∈ E, ρ_hoist.store e.1 = none := by + intro e he + have h_mem : e.1 ∈ LoopInitHoistLoopDriver.sourcesOf' E := List.mem_map.mpr ⟨e, he, rfl⟩ + rcases h_src_class e.1 h_mem with h_o | ⟨str, heq, hsuf, _, hnotσ⟩ + · exact h_hoist_undef_h_body e.1 h_o + · exact heq ▸ h_hoist_store_shapefree str hsuf hnotσ + have h_tgt_undef_h : ∀ e ∈ E, ρ_hoist.store e.2.1 = none := by + intro e he + have h_mem : e.2.1 ∈ LoopInitHoistLoopDriver.targetsOf' E := List.mem_map.mpr ⟨e, he, rfl⟩ + obtain ⟨str, heq, hsuf, hnotσ₁⟩ := h_tgt_class e.2.1 h_mem + exact heq ▸ h_hoist_store_shapefree str hsuf + (fun h => hnotσ₁ ((Block.hoistLoopPrefixInitsM_genStep body σ).subset h)) + -- source-store undef on the harvested sources (ORIGINAL ⇒ initVars body undef; + -- FRESH ⇒ suffix-shaped ∉ σ undef by the threaded store-shapefree). + have h_src_As_undef : ∀ a ∈ LoopInitHoistLoopDriver.sourcesOf' E, ρ_src.store a = none := by + intro a ha + rcases h_src_class a ha with h_o | ⟨str, he, hsuf, _, hnotσ⟩ + · exact h_hoist_undef_body a h_o + · exact he ▸ h_src_store_shapefree str hsuf hnotσ + -- post-store undef of sources/targets via `loopDet_preserves_none_terminal`. + -- No-exit-free: a `.terminal` source loop run keeps any loop-entry-undefined + -- carrier undefined (each iteration's `.none`-block projects undefined entries + -- back to `none`; an inner `.exiting` would propagate the loop to `.exiting`, + -- not `.terminal`). The source body need NOT be statically exit-free. + have h_post_src_none : ∀ (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g') none [] body md) ρ_src) (.terminal ρ_post) → + x ∈ LoopInitHoistLoopDriver.sourcesOf' E → ρ_post.store x = none := by + intro ρ_post x h_run hx + exact LoopInitHoistLoopDriver.loopDet_preserves_none_terminal (h_src_As_undef x hx) h_run + have h_post_tgt_none : ∀ (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g') none [] body md) ρ_src) (.terminal ρ_post) → + x ∈ LoopInitHoistLoopDriver.targetsOf' E → ρ_post.store x = none := by + intro ρ_post x h_run hx + refine LoopInitHoistLoopDriver.loopDet_preserves_none_terminal ?_ h_run + obtain ⟨str, he, hsuf, hnotσ₁⟩ := h_tgt_class x hx + exact he ▸ h_src_store_shapefree str hsuf + (fun h => hnotσ₁ ((Block.hoistLoopPrefixInitsM_genStep body σ).subset h)) + -- post-store undef of sources/targets on an EXITING source loop run. A body + -- `.exit` is ADMITTED: when some iteration breaks with a label, the loop reaches + -- `.exiting`. `loopDet_preserves_none_exiting` (no-exit-free) keeps any + -- loop-entry-undefined carrier undefined at the exit store — the same + -- per-iteration `projectStore` invariant, capped by the breaking iteration's + -- `.none`-block mismatch. These obligations feed the sum-typed driver's exit + -- branch, which now genuinely fires on a body `.exit`. + have h_post_src_none_exit : ∀ (lbl : String) (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g') none [] body md) ρ_src) (.exiting lbl ρ_post) → + x ∈ LoopInitHoistLoopDriver.sourcesOf' E → ρ_post.store x = none := by + intro lbl ρ_post x h_run hx + exact LoopInitHoistLoopDriver.loopDet_preserves_none_exiting (h_src_As_undef x hx) h_run + have h_post_tgt_none_exit : ∀ (lbl : String) (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g') none [] body md) ρ_src) (.exiting lbl ρ_post) → + x ∈ LoopInitHoistLoopDriver.targetsOf' E → ρ_post.store x = none := by + intro lbl ρ_post x h_run hx + refine LoopInitHoistLoopDriver.loopDet_preserves_none_exiting ?_ h_run + obtain ⟨str, he, hsuf, hnotσ₁⟩ := h_tgt_class x hx + exact he ▸ h_src_store_shapefree str hsuf + (fun h => hnotσ₁ ((Block.hoistLoopPrefixInitsM_genStep body σ).subset h)) + have h_tgt_nodup : (LoopInitHoistLoopDriver.targetsOf' E).Nodup := + (LoopInitHoistLoopArmWF.Block.entriesOf_targetGen body₁ σ₁ h_wf_σ₁).2 + -- σ_sf-relative source-store shape-freedom at ρ_src for the driver. + have h_arm_src_sf : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_src.store (HasIdent.ident (P := P) str) = none := + h_src_store_shapefree + have h_sf_notA : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → HasIdent.ident (P := P) str ∉ A := + fun str h_suf _ => (h_src_shapefree_body str h_suf).1 + have h_sf_notB : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → HasIdent.ident (P := P) str ∉ B := + fun str h_suf _ => (h_src_shapefree_body str h_suf).2.1 + exact LoopInitHoistLoopArmWF.loop_arm_close (σ_sf := σ) (Vs := Block.initVars body) + (entries := E) (body := body) (body₁ := body₁) (body₃ := body₃) (g := g') (md := md) + stepA stepA_exit stepB + h_hoist_undef_body h_hoist_undef_h_body h_arm_src_sf h_sf_notA h_sf_notB + h_lhs_disjoint_body h_extra_disjoint_body h_Vs_notBs + h_subst_wf h_ss_wf h_As_notA h_As_notB h_B_notAs h_B_notBs h_Bs_notB + h_g_A_fresh h_g_B_fresh h_g_As_minus_Vs_fresh h_g_Bs_fresh + h_src_As_undef h_nofd_src h_nofd_h h_tgt_nodup + h_src_undef_h h_tgt_undef_h h_post_src_none h_post_tgt_none + h_post_src_none_exit h_post_tgt_none_exit + h_wfvar h_wfcongr h_wfdef h_hinv h_eval_eq h_hf_eq h_hoist_bound h_run_src h_cfg_src + | .exit lbl md => + subst h_match + -- Identity residual `[.exit lbl md]`. Source `.stmt (.exit lbl md) ρ_src` steps + -- to `.exiting lbl ρ_src`; the hoisted identity does the same. + have h_residual : (Stmt.hoistLoopPrefixInitsM (.exit lbl md) σ).1 = [.exit lbl md] := by + rw [Stmt.hoistLoopPrefixInitsM] + rw [h_residual] + have h_cfg_eq : cfg_src = .exiting lbl ρ_src := by + cases h_run_src with + | refl => rcases h_cfg_src with ⟨_, h⟩ | ⟨_, _, h⟩ <;> exact nomatch h + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | refl => rfl + | step _ _ _ hd _ => exact nomatch hd + refine ⟨ρ_hoist, .exiting lbl ρ_hoist, ?_, + Or.inr ⟨lbl, ρ_src, h_cfg_eq, rfl, h_hinv, h_hf_eq, h_hoist_bound⟩⟩ + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner StepStmt.step_exit) ?_ + exact ReflTrans.step _ _ _ StepStmt.step_seq_exit (ReflTrans.refl _) + | .funcDecl d md => + subst h_match + -- Excluded by `h_no_fd`: `Stmt.containsFuncDecl (.funcDecl d md) = true`. + rw [Stmt.containsFuncDecl] at h_no_fd + exact absurd h_no_fd (by simp) + | .typeDecl t md => + subst h_match + -- Identity residual `[.typeDecl t md]`. A type decl steps to `.terminal ρ_src`. + have h_residual : (Stmt.hoistLoopPrefixInitsM (.typeDecl t md) σ).1 = [.typeDecl t md] := by + rw [Stmt.hoistLoopPrefixInitsM] + rw [h_residual] + have h_cfg_eq : cfg_src = .terminal ρ_src := by + cases h_run_src with + | refl => rcases h_cfg_src with ⟨_, h⟩ | ⟨_, _, h⟩ <;> exact nomatch h + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | refl => rfl + | step _ _ _ hd _ => exact nomatch hd + refine ⟨ρ_hoist, .terminal ρ_hoist, ?_, + Or.inl ⟨ρ_src, h_cfg_eq, rfl, h_hinv, h_hf_eq, h_hoist_bound⟩⟩ + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner StepStmt.step_typeDecl) ?_ + refine ReflTrans.step _ _ _ StepStmt.step_seq_done ?_ + exact ReflTrans.step _ _ _ StepStmt.step_stmts_nil (ReflTrans.refl _) + termination_by sizeOf s + decreasing_by all_goals (subst h_match; simp_wf; omega) + +/-- §E Block-level forward simulation IH (= S1 entry point, sum-typed), stated +over the MONADIC pass `Block.hoistLoopPrefixInitsM` at an ARBITRARY input +generator state `σ`. + +For a list of statements `ss`, every source run `.stmts ss ρ_src ⟶* cfg_src` +whose final config is either `.terminal ρ_src'` or `.exiting lbl ρ_src'` +admits a matching hoisted run `.stmts (Block.hoistLoopPrefixInitsM ss σ).1 +ρ_hoist ⟶* cfg_hoist` to a config of the same shape (terminal/exiting with +the same label) carrying `HoistInv A B subst` and `hasFailure` agreement. + +Quantifying over `σ` is what makes the `cons` arm recurse: the residual +`(Block.hoistLoopPrefixInitsM (s :: rest) σ).1` decomposes as +`(head-at-σ) ++ (tail-at-σ')` with `σ' = (Stmt.hoistLoopPrefixInitsM s σ).2`, +and the tail IH instantiates at `σ'` (not at `emp`). The pure wrapper +`Block.hoistLoopPrefixInits ss` is the `σ = emp` specialization, so the +top-level theorem instantiates this lemma at `σ := StringGenState.emp`. + +`h_wf_σ` carries the generator-state well-formedness; `h_src_namesFreshFromσ` +records that every generated label already present in `σ` (mapped through +`HasIdent.ident`) is disjoint from the source program's frame names `A`, extra +names `B`, and `.init` LHS names. At `σ = emp` the generated-labels list is +empty, so this precondition is vacuously true. + +`h_names_fresh_B` is the `B`-side analogue of `h_names_fresh`: the extra names +`B` are fresh in every guard and RHS expression of the block. `h_src_shapefree` +records that any source identifier carrying the generator's `_` suffix +shape is disjoint from `A`, `B`, and the `.init` LHS names (front-end source +names never collide with the generator's naming scheme). `h_subst_wf` records +that every substitution pair `(a, b)` relates an `A`-name to a `B`-name. -/ +private theorem Block.hoistLoopPrefixInits_preserves {Q : String → Prop} + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] + [HasIntOrder P] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + [DecidableEq P.Ident] + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {extendEval : ExtendEval P} + (A : List P.Ident) + (B : List P.Ident) + (subst : List (P.Ident × P.Ident)) + (ss : List (Stmt P (Cmd P))) + (σ : StringGenState) + {ρ_src ρ_hoist : Env P} + {cfg_src : Config P (Cmd P)} + (h_no_nd : Block.containsNondetLoop ss = false) + (h_no_fd : Block.containsFuncDecl ss = false) + (h_no_inv : Block.loopHasNoInvariants ss = true) + (h_no_measure : Block.loopMeasureNone ss = true) + (h_exprs_shapefree : Block.exprsShapeFree (P := P) Q ss) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_names_fresh : Block.namesFreshInExprs A ss = true) + (h_names_fresh_B : Block.namesFreshInExprs B ss = true) + (h_lhs_disjoint : ∀ y ∈ Block.initVars ss, y ∉ A) + (h_extra_disjoint : ∀ y ∈ Block.initVars ss, y ∉ B) + (h_mod_disjoint_A : ∀ x ∈ Block.modifiedVars ss, x ∉ A) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars ss, x ∉ B) + (h_hoist_undef : ∀ y ∈ Block.initVars ss, ρ_src.store y = none) + (h_hoist_undef_h : ∀ y ∈ Block.initVars ss, ρ_hoist.store y = none) + (h_src_store_shapefree : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_src.store (HasIdent.ident (P := P) str) = none) + (h_hoist_store_shapefree : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_hoist.store (HasIdent.ident (P := P) str) = none) + (h_wf_σ : StringGenState.WF σ) + (h_src_namesFreshFromσ : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars ss) + (h_src_shapefree : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars ss ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval_eq : ρ_src.eval = ρ_hoist.eval) + (h_hf_eq : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_hoist_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ_src) cfg_src) + (h_cfg_src : (∃ ρ_src' : Env P, cfg_src = .terminal ρ_src') ∨ + (∃ lbl ρ_src', cfg_src = .exiting lbl ρ_src')) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + ∃ ρ_h', ∃ cfg_hoist : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.hoistLoopPrefixInitsM ss σ).1 ρ_hoist) cfg_hoist + ∧ ((∃ ρ_src' : Env P, + cfg_src = .terminal ρ_src' ∧ cfg_hoist = .terminal ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none)) ∨ + (∃ lbl ρ_src', + cfg_src = .exiting lbl ρ_src' ∧ cfg_hoist = .exiting lbl ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none))) := by + classical + match h_match : ss with + | [] => + subst h_match + -- Empty block: `(...M [] σ).1 = []`. Source run `.stmts [] ρ_src ⟶* cfg_src` + -- can only reach `.terminal ρ_src`. Output `.stmts [] ρ_hoist ⟶ .terminal ρ_hoist`. + have h_cfg_eq : cfg_src = .terminal ρ_src := by + cases h_run_src with + | refl => + rcases h_cfg_src with ⟨_, h⟩ | ⟨_, _, h⟩ <;> exact nomatch h + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | refl => rfl + | step _ _ _ hd _ => exact nomatch hd + refine ⟨ρ_hoist, .terminal ρ_hoist, ?_, Or.inl ⟨ρ_src, h_cfg_eq, rfl, h_hinv, h_hf_eq, h_hoist_bound⟩⟩ + show StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.hoistLoopPrefixInitsM ([] : List (Stmt P (Cmd P))) σ).1 ρ_hoist) (.terminal ρ_hoist) + simp only [Block.hoistLoopPrefixInitsM] + exact ReflTrans.step _ _ _ StepStmt.step_stmts_nil (ReflTrans.refl _) + | s :: rest => + subst h_match + -- === Decompose the MONADIC residual: head-at-σ ++ tail-at-σ1. === + have h_cons_out : + (Block.hoistLoopPrefixInitsM (s :: rest) σ).1 = + (Stmt.hoistLoopPrefixInitsM s σ).1 ++ + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).1 := + Block.hoistLoopPrefixInitsM_cons_out s rest σ + -- === Boolean precondition decomposition: [s] / rest from s::rest. === + have h_split_list : (s :: rest : List (Stmt P (Cmd P))) = [s] ++ rest := rfl + have h_nd_s : Block.containsNondetLoop [s] = false ∧ Block.containsNondetLoop rest = false := by + rw [h_split_list, Block.containsNondetLoop_append, Bool.or_eq_false_iff] at h_no_nd + exact h_no_nd + have h_fd_s : Block.containsFuncDecl [s] = false ∧ Block.containsFuncDecl rest = false := by + rw [h_split_list, Block.containsFuncDecl_append, Bool.or_eq_false_iff] at h_no_fd + exact h_no_fd + have h_inv_s : Block.loopHasNoInvariants [s] = true ∧ Block.loopHasNoInvariants rest = true := by + rw [h_split_list, Block.loopHasNoInvariants_append, Bool.and_eq_true] at h_no_inv + exact h_no_inv + have h_measure_s : Block.loopMeasureNone [s] = true ∧ Block.loopMeasureNone rest = true := by + rw [h_split_list, Block.loopMeasureNone_append, Bool.and_eq_true] at h_no_measure + exact h_no_measure + have h_exprs_shapefree_s : + Block.exprsShapeFree (P := P) Q [s] ∧ + Block.exprsShapeFree (P := P) Q rest := by + -- `Block.exprsShapeFree (s :: rest) = Stmt.exprsShapeFree s ∧ Block.exprsShapeFree rest` + -- and `Block.exprsShapeFree [s] = Stmt.exprsShapeFree s ∧ True`. + have h := h_exprs_shapefree + simp only [Block.exprsShapeFree] at h ⊢ + exact ⟨⟨h.1, True.intro⟩, h.2⟩ + have h_iv_split : Block.initVars (s :: rest) = Block.initVars [s] ++ Block.initVars rest := by + rw [h_split_list, Block.initVars_append] + have h_mod_split : Block.modifiedVars (s :: rest) = + Block.modifiedVars [s] ++ Block.modifiedVars rest := by + simp only [Block.modifiedVars, List.append_nil] + have h_unique_full : (Block.initVars [s] ++ Block.initVars rest).Nodup := by + have : Block.uniqueInits (s :: rest) = (Block.initVars (s :: rest)).Nodup := rfl + rw [this, h_iv_split] at h_unique; exact h_unique + have h_unique_s : Block.uniqueInits [s] := by + show (Block.initVars [s]).Nodup + exact (List.nodup_append.mp h_unique_full).1 + have h_unique_rest : Block.uniqueInits rest := by + show (Block.initVars rest).Nodup + exact (List.nodup_append.mp h_unique_full).2.1 + have h_fresh_unfold := h_fresh + unfold Block.hoistedNamesFreshInRhsAndGuards at h_fresh_unfold + have h_nf_cons : + Block.namesFreshInRhsExprs (Block.initVars (s :: rest)) (s :: rest) = + (Stmt.namesFreshInRhsExprs (Block.initVars (s :: rest)) s && + Block.namesFreshInRhsExprs (Block.initVars (s :: rest)) rest) := by + rw [Block.namesFreshInRhsExprs] + rw [h_nf_cons, Bool.and_eq_true] at h_fresh_unfold + obtain ⟨h_nf_s_full, h_nf_rest_full⟩ := h_fresh_unfold + have h_sub_s : (Block.initVars [s] : List P.Ident) ⊆ Block.initVars (s :: rest) := by + rw [h_iv_split]; exact fun _ h => List.mem_append.mpr (Or.inl h) + have h_sub_rest : (Block.initVars rest : List P.Ident) ⊆ Block.initVars (s :: rest) := by + rw [h_iv_split]; exact fun _ h => List.mem_append.mpr (Or.inr h) + have h_nf_s_block : Block.namesFreshInRhsExprs (Block.initVars (s :: rest)) [s] = true := by + simp only [Block.namesFreshInRhsExprs, Bool.and_true]; exact h_nf_s_full + have h_fresh_s : Block.hoistedNamesFreshInRhsAndGuards (P := P) [s] = true := by + unfold Block.hoistedNamesFreshInRhsAndGuards + exact Block.namesFreshInRhsExprs_subset h_sub_s [s] h_nf_s_block + have h_fresh_rest : Block.hoistedNamesFreshInRhsAndGuards (P := P) rest = true := by + unfold Block.hoistedNamesFreshInRhsAndGuards + exact Block.namesFreshInRhsExprs_subset h_sub_rest rest h_nf_rest_full + have h_names_fresh_cons : + Block.namesFreshInExprs A (s :: rest) = + (Stmt.namesFreshInExprs A s && Block.namesFreshInExprs A rest) := by + rw [Block.namesFreshInExprs] + rw [h_names_fresh_cons, Bool.and_eq_true] at h_names_fresh + obtain ⟨h_names_fresh_s_stmt, h_names_fresh_rest⟩ := h_names_fresh + have h_names_fresh_s : Block.namesFreshInExprs A [s] = true := by + simp only [Block.namesFreshInExprs, Bool.and_true]; exact h_names_fresh_s_stmt + have h_names_fresh_B_cons : + Block.namesFreshInExprs B (s :: rest) = + (Stmt.namesFreshInExprs B s && Block.namesFreshInExprs B rest) := by + rw [Block.namesFreshInExprs] + rw [h_names_fresh_B_cons, Bool.and_eq_true] at h_names_fresh_B + obtain ⟨h_names_fresh_B_s_stmt, h_names_fresh_B_rest⟩ := h_names_fresh_B + have h_names_fresh_B_s : Block.namesFreshInExprs B [s] = true := by + simp only [Block.namesFreshInExprs, Bool.and_true]; exact h_names_fresh_B_s_stmt + have h_lhs_disjoint_s : ∀ y ∈ Block.initVars [s], y ∉ A := fun y hy => + h_lhs_disjoint y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl hy)) + have h_lhs_disjoint_rest : ∀ y ∈ Block.initVars rest, y ∉ A := fun y hy => + h_lhs_disjoint y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy)) + have h_extra_disjoint_s : ∀ y ∈ Block.initVars [s], y ∉ B := fun y hy => + h_extra_disjoint y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl hy)) + have h_extra_disjoint_rest : ∀ y ∈ Block.initVars rest, y ∉ B := fun y hy => + h_extra_disjoint y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy)) + have h_mod_disjoint_A_s : ∀ x ∈ Block.modifiedVars [s], x ∉ A := fun x hx => + h_mod_disjoint_A x (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inl hx)) + have h_mod_disjoint_A_rest : ∀ x ∈ Block.modifiedVars rest, x ∉ A := fun x hx => + h_mod_disjoint_A x (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inr hx)) + have h_mod_disjoint_B_s : ∀ x ∈ Block.modifiedVars [s], x ∉ B := fun x hx => + h_mod_disjoint_B x (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inl hx)) + have h_mod_disjoint_B_rest : ∀ x ∈ Block.modifiedVars rest, x ∉ B := fun x hx => + h_mod_disjoint_B x (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inr hx)) + have h_hoist_undef_s : ∀ y ∈ Block.initVars [s], ρ_src.store y = none := fun y hy => + h_hoist_undef y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl hy)) + have h_hoist_undef_h_s : ∀ y ∈ Block.initVars [s], ρ_hoist.store y = none := fun y hy => + h_hoist_undef_h y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl hy)) + have h_src_fresh_s : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars [s] := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl h))⟩ + have h_src_shapefree_s : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars [s] ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars [s] := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl h)), + fun h => hmv (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inl h))⟩ + have h_src_shapefree_rest : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars rest ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars rest := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr h)), + fun h => hmv (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inr h))⟩ + have h_genStep_head : StringGenState.GenStep σ (Stmt.hoistLoopPrefixInitsM s σ).2 := + Stmt.hoistLoopPrefixInitsM_genStep s σ + have h_wf_σ1 : StringGenState.WF (Stmt.hoistLoopPrefixInitsM s σ).2 := + h_genStep_head.wf_mono h_wf_σ + have h_src_fresh_σ1 : + SrcNamesFreshFromGen (P := P) A B (Block.initVars rest) + (Stmt.hoistLoopPrefixInitsM s σ).2 := by + have h_fresh_σ_rest : SrcNamesFreshFromGen (P := P) A B (Block.initVars rest) σ := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr h))⟩ + exact SrcNamesFreshFromGen.genStep_of_delta + (Stmt.hoistLoopPrefixInitsM_genStep_delta_Q hQmint s σ) + (fun str hsuf => let ⟨a, b, c, _⟩ := h_src_shapefree_rest str hsuf; ⟨a, b, c⟩) h_fresh_σ_rest + have h_src_fresh_rest : + ∀ str ∈ StringGenState.stringGens (Stmt.hoistLoopPrefixInitsM s σ).2, + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars rest := h_src_fresh_σ1 + -- === Split the SOURCE run into head + tail, dispatch on cfg_src. === + rw [h_cons_out] + rcases h_cfg_src with ⟨ρ_src', h_term⟩ | ⟨lbl, ρ_src', h_exit⟩ + · -- TERMINAL: cfg_src = .terminal ρ_src'. + subst h_term + have h_run_src' : StepStmtStar P (EvalCmd P) extendEval + (.stmts ([s] ++ rest) ρ_src) (.terminal ρ_src') := h_run_src + obtain ⟨ρ_s_mid, h_head_src, h_tail_src⟩ := + stmts_append_terminates P (EvalCmd P) extendEval [s] rest ρ_src ρ_src' h_run_src' + have h_head_stmt : StepStmtStar P (EvalCmd P) extendEval + (.stmt s ρ_src) (.terminal ρ_s_mid) := by + cases h_head_src with + | step _ _ _ h1 hr1 => + cases h1 + obtain ⟨ρ_m, h_s_term, h_nil⟩ := seq_reaches_terminal P (EvalCmd P) extendEval hr1 + cases h_nil with + | step _ _ _ h2 hr2 => + cases h2 + cases hr2 with + | refl => exact h_s_term + | step _ _ _ hd _ => exact nomatch hd + have h_nd_stmt : Stmt.containsNondetLoop s = false := by + rw [Block.containsNondetLoop, Bool.or_eq_false_iff] at h_nd_s; exact h_nd_s.1.1 + have h_fd_stmt : Stmt.containsFuncDecl s = false := by + rw [Block.containsFuncDecl, Bool.or_eq_false_iff] at h_fd_s; exact h_fd_s.1.1 + have h_inv_stmt : Stmt.loopHasNoInvariants s = true := by + rw [Block.loopHasNoInvariants, Bool.and_eq_true] at h_inv_s; exact h_inv_s.1.1 + have h_measure_stmt : Stmt.loopMeasureNone s = true := by + rw [Block.loopMeasureNone, Bool.and_eq_true] at h_measure_s; exact h_measure_s.1.1 + -- HEAD §E Stmt-IH at σ. + obtain ⟨ρ_h_mid, cfg_h_head, h_head_hoist, h_head_outcome⟩ := + Stmt.hoistLoopPrefixInits_preserves hQmint A B subst s σ + h_nd_stmt h_fd_stmt h_inv_stmt h_measure_stmt h_exprs_shapefree_s.1 h_unique_s h_fresh_s + h_names_fresh_s h_names_fresh_B_s h_lhs_disjoint_s h_extra_disjoint_s + h_mod_disjoint_A_s h_mod_disjoint_B_s h_hoist_undef_s h_hoist_undef_h_s + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_s h_src_shapefree_s h_subst_wf h_hinv h_eval_eq h_hf_eq h_hoist_bound + h_head_stmt (Or.inl ⟨ρ_s_mid, rfl⟩) h_wfvar h_wfcongr h_wfsubst h_wfdef + obtain ⟨h_cfg_h_eq, h_hinv_mid, h_hf_mid, h_bound_mid⟩ : + cfg_h_head = .terminal ρ_h_mid ∧ + HoistInv (P := P) A B subst ρ_s_mid.store ρ_h_mid.store ∧ + ρ_s_mid.hasFailure = ρ_h_mid.hasFailure ∧ (∀ y ∈ B, ρ_h_mid.store y ≠ none) := by + rcases h_head_outcome with ⟨r, hr1, hr2, hr3, hr4, hr5⟩ | ⟨l, r, hr1, _, _, _, _⟩ + · have hr_eq : r = ρ_s_mid := by + simp only [Config.terminal.injEq] at hr1; exact hr1.symm + subst hr_eq; exact ⟨hr2, hr3, hr4, hr5⟩ + · exact absurd hr1 (by simp) + subst h_cfg_h_eq + have h_src_s_nofd : Stmt.noFuncDecl s = true := + Stmt.noFuncDecl_of_not_containsFuncDecl s h_fd_stmt + have h_residual_nofd : + Block.noFuncDecl (Stmt.hoistLoopPrefixInitsM s σ).1 = true := by + apply Block.noFuncDecl_of_not_containsFuncDecl + rw [Stmt.hoistLoopPrefixInitsM_containsFuncDecl]; exact h_fd_stmt + have h_src_mid_eval : ρ_s_mid.eval = ρ_src.eval := + smallStep_noFuncDecl_preserves_eval P (EvalCmd P) extendEval s ρ_src ρ_s_mid + h_src_s_nofd h_head_stmt + have h_h_mid_eval : ρ_h_mid.eval = ρ_hoist.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + (Stmt.hoistLoopPrefixInitsM s σ).1 ρ_hoist ρ_h_mid h_residual_nofd h_head_hoist + have h_eval_mid : ρ_s_mid.eval = ρ_h_mid.eval := by + rw [h_src_mid_eval, h_h_mid_eval, h_eval_eq] + -- TAIL §E Block-IH at σ1. + obtain ⟨ρ_h_fin, cfg_hoist_tail, h_tail_hoist, h_tail_outcome⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst rest (Stmt.hoistLoopPrefixInitsM s σ).2 + h_nd_s.2 h_fd_s.2 h_inv_s.2 h_measure_s.2 h_exprs_shapefree_s.2 h_unique_rest h_fresh_rest + h_names_fresh_rest h_names_fresh_B_rest h_lhs_disjoint_rest h_extra_disjoint_rest + h_mod_disjoint_A_rest h_mod_disjoint_B_rest + (by + intro y hy + have h_y_src_none : ρ_src.store y = none := + h_hoist_undef y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy)) + have h_y_not_init_s : y ∉ Block.initVars [s] := fun hc => + (List.nodup_append.mp h_unique_full).2.2 y hc y hy rfl + have h_y_not_def_s : y ∉ Stmt.definedVars (P := P) (C := Cmd P) s := by + rw [Stmt.definedVars_eq_initVars_of_no_fd s h_fd_stmt] + intro hc + exact h_y_not_init_s (by simp only [Block.initVars, List.append_nil]; exact hc) + exact stmt_run_terminal_preserves_none h_y_src_none h_y_not_def_s h_head_stmt) + (by + -- Hoist-side tail undefinedness: the head residual run from `ρ_hoist` + -- to `ρ_h_mid` cannot touch any `y ∈ Block.initVars rest` because + -- such `y` is shape-free and disjoint from `s`'s inits, hence is not + -- among the residual's inits. + intro y hy + have h_y_h_none : ρ_hoist.store y = none := + h_hoist_undef_h y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy)) + have h_unique_s_stmt : (Stmt.initVars s).Nodup := by + have : (Block.initVars [s]).Nodup := h_unique_s + simpa only [Block.initVars, List.append_nil] using this + have h_shapefree_s_stmt : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s := by + intro str h_shape hc + exact (h_src_shapefree_s str h_shape).2.2.1 + (by simp only [Block.initVars, List.append_nil]; exact hc) + have h_y_not_src : y ∉ Stmt.initVars s := fun hc => + (List.nodup_append.mp h_unique_full).2.2 y + (by simp only [Block.initVars, List.append_nil]; exact hc) y hy rfl + have h_y_shapefree : ∀ str : String, y = HasIdent.ident str → + ¬ Q str := by + intro str h_y_eq h_shape + exact (h_src_shapefree str h_shape).2.2.1 + (h_y_eq ▸ (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy))) + exact residual_run_terminal_preserves_none hQmint h_wf_σ h_unique_s_stmt + h_shapefree_s_stmt h_fd_stmt h_y_not_src h_y_shapefree h_y_h_none h_head_hoist) + (by + -- Mid-store source store-shapefree (at σ1): a suffix-shaped name `z` with + -- `str ∉ stringGens σ1` is undefined in `ρ_src` (by `h_src_store_shapefree`, + -- since `str ∉ stringGens σ1 ⊇ stringGens σ`) and is not defined by `s` + -- (suffix-shaped names lie outside `s`'s inits, hence outside its defined + -- vars), so the head run from `ρ_src` to `ρ_s_mid` leaves `z` undefined. + intro str h_shape h_notσ1 + have h_notσ : str ∉ StringGenState.stringGens σ := + fun h => h_notσ1 (h_genStep_head.subset h) + have h_z_src_none : ρ_src.store (HasIdent.ident (P := P) str) = none := + h_src_store_shapefree str h_shape h_notσ + have h_z_not_def_s : + HasIdent.ident (P := P) str ∉ Stmt.definedVars (P := P) (C := Cmd P) s := by + rw [Stmt.definedVars_eq_initVars_of_no_fd s h_fd_stmt] + intro hc + exact (h_src_shapefree str h_shape).2.2.1 + (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl + (by simp only [Block.initVars, List.append_nil]; exact hc))) + exact stmt_run_terminal_preserves_none h_z_src_none h_z_not_def_s h_head_stmt) + (by + -- Mid-store hoist store-shapefree (at σ1): a suffix-shaped name `z = ident str` + -- with `str ∉ stringGens σ1` is undefined in `ρ_hoist` (by `h_hoist_store_shapefree`, + -- since `str ∉ stringGens σ1 ⊇ stringGens σ`). It is not among the head + -- residual's `initVars`: each is classified as an ORIGINAL init of `s` + -- (excluded — `z` is suffix-shaped, outside `s`'s inits) or a FRESH name + -- `str' ∈ stringGens σ1` (excluded — `ident str = ident str'` ⇒ `str = str' ∈ + -- stringGens σ1`, contradicting `str ∉ stringGens σ1`). So the head residual + -- run from `ρ_hoist` to `ρ_h_mid` leaves `z` undefined. + intro str h_shape h_notσ1 + have h_notσ : str ∉ StringGenState.stringGens σ := + fun h => h_notσ1 (h_genStep_head.subset h) + have h_z_h_none : ρ_hoist.store (HasIdent.ident (P := P) str) = none := + h_hoist_store_shapefree str h_shape h_notσ + have h_unique_s_stmt : (Stmt.initVars s).Nodup := by + have : (Block.initVars [s]).Nodup := h_unique_s + simpa only [Block.initVars, List.append_nil] using this + have h_shapefree_s_stmt : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s := by + intro str' h_shape' hc + exact (h_src_shapefree_s str' h_shape').2.2.1 + (by simp only [Block.initVars, List.append_nil]; exact hc) + have h_z_not_residual : + HasIdent.ident (P := P) str ∉ Block.initVars (Stmt.hoistLoopPrefixInitsM s σ).1 := by + intro h_mem + have h_class := + (LoopInitHoistLoopArmWF.Stmt.hoistLoopPrefixInitsM_initVars_classified + hQmint s σ h_wf_σ h_unique_s_stmt h_shapefree_s_stmt).1 _ h_mem + rcases h_class with h_orig | ⟨str', h_eq, h_str'_in, _, _⟩ + · exact h_shapefree_s_stmt str h_shape h_orig + · exact h_notσ1 ((LawfulHasIdent.ident_inj h_eq) ▸ h_str'_in) + have h_residual_contains_nofd : + Block.containsFuncDecl (Stmt.hoistLoopPrefixInitsM s σ).1 = false := by + rw [Stmt.hoistLoopPrefixInitsM_containsFuncDecl]; exact h_fd_stmt + exact block_run_terminal_preserves_none_of_not_initVars + h_residual_contains_nofd h_z_not_residual h_z_h_none h_head_hoist) + h_wf_σ1 h_src_fresh_rest h_src_shapefree_rest h_subst_wf h_hinv_mid h_eval_mid h_hf_mid h_bound_mid + h_tail_src (Or.inl ⟨ρ_src', rfl⟩) h_wfvar h_wfcongr h_wfsubst h_wfdef + -- === GLUE: chain the head residual run into the tail entry, then the tail. === + refine ⟨ρ_h_fin, cfg_hoist_tail, ?_, ?_⟩ + · refine ReflTrans_Transitive _ _ _ _ + (stmts_prefix_terminal_append P (EvalCmd P) extendEval + (Stmt.hoistLoopPrefixInitsM s σ).1 + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).1 + ρ_hoist ρ_h_mid h_head_hoist) ?_ + exact h_tail_hoist + · rcases h_tail_outcome with ⟨r, hr1, hr2, hr3, hr4, hr5⟩ | ⟨l, r, hr1, _, _, _, _⟩ + · exact Or.inl ⟨r, hr1, hr2, hr3, hr4, hr5⟩ + · exact absurd hr1 (by simp) + · -- EXITING: cfg_src = .exiting lbl ρ_src'. + subst h_exit + have h_nd_stmt : Stmt.containsNondetLoop s = false := by + rw [Block.containsNondetLoop, Bool.or_eq_false_iff] at h_nd_s; exact h_nd_s.1.1 + have h_fd_stmt : Stmt.containsFuncDecl s = false := by + rw [Block.containsFuncDecl, Bool.or_eq_false_iff] at h_fd_s; exact h_fd_s.1.1 + have h_inv_stmt : Stmt.loopHasNoInvariants s = true := by + rw [Block.loopHasNoInvariants, Bool.and_eq_true] at h_inv_s; exact h_inv_s.1.1 + have h_measure_stmt : Stmt.loopMeasureNone s = true := by + rw [Block.loopMeasureNone, Bool.and_eq_true] at h_measure_s; exact h_measure_s.1.1 + have h_residual_nofd : + Block.noFuncDecl (Stmt.hoistLoopPrefixInitsM s σ).1 = true := by + apply Block.noFuncDecl_of_not_containsFuncDecl + rw [Stmt.hoistLoopPrefixInitsM_containsFuncDecl]; exact h_fd_stmt + cases h_run_src with + | step _ _ _ h1 hr1 => + cases h1 + rcases seq_reaches_exiting P (EvalCmd P) extendEval hr1 with + h_head_exit | ⟨ρ_s_mid, h_head_term, h_tail_exit⟩ + · -- HEAD exits: tail never runs. + obtain ⟨ρ_h_fin, cfg_h_head, h_head_hoist, h_head_outcome⟩ := + Stmt.hoistLoopPrefixInits_preserves hQmint A B subst s σ + h_nd_stmt h_fd_stmt h_inv_stmt h_measure_stmt h_exprs_shapefree_s.1 h_unique_s h_fresh_s + h_names_fresh_s h_names_fresh_B_s h_lhs_disjoint_s h_extra_disjoint_s + h_mod_disjoint_A_s h_mod_disjoint_B_s h_hoist_undef_s h_hoist_undef_h_s + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_s h_src_shapefree_s h_subst_wf h_hinv h_eval_eq h_hf_eq h_hoist_bound + h_head_exit (Or.inr ⟨lbl, ρ_src', rfl⟩) h_wfvar h_wfcongr h_wfsubst h_wfdef + obtain ⟨h_cfg_h_eq, h_hinv_fin, h_hf_fin, h_bound_fin⟩ : + cfg_h_head = .exiting lbl ρ_h_fin ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h_fin.store ∧ + ρ_src'.hasFailure = ρ_h_fin.hasFailure ∧ (∀ y ∈ B, ρ_h_fin.store y ≠ none) := by + rcases h_head_outcome with ⟨r, hr1, _, _, _, _⟩ | ⟨l, r, hr1, hr2, hr3, hr4, hr5⟩ + · exact absurd hr1.symm (by simp) + · obtain ⟨hl, hr_eq⟩ : l = lbl ∧ r = ρ_src' := by + simp only [Config.exiting.injEq] at hr1; exact ⟨hr1.1.symm, hr1.2.symm⟩ + subst hl; subst hr_eq; exact ⟨hr2, hr3, hr4, hr5⟩ + subst h_cfg_h_eq + refine ⟨ρ_h_fin, .exiting lbl ρ_h_fin, ?_, Or.inr ⟨lbl, ρ_src', rfl, rfl, h_hinv_fin, h_hf_fin, h_bound_fin⟩⟩ + exact stmts_prefix_exiting_append P (EvalCmd P) extendEval + (Stmt.hoistLoopPrefixInitsM s σ).1 + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).1 + ρ_hoist ρ_h_fin lbl h_head_hoist + · -- HEAD terminates at ρ_s_mid, TAIL exits. + have h_head_stmt : StepStmtStar P (EvalCmd P) extendEval + (.stmt s ρ_src) (.terminal ρ_s_mid) := h_head_term + obtain ⟨ρ_h_mid, cfg_h_head, h_head_hoist, h_head_outcome⟩ := + Stmt.hoistLoopPrefixInits_preserves hQmint A B subst s σ + h_nd_stmt h_fd_stmt h_inv_stmt h_measure_stmt h_exprs_shapefree_s.1 h_unique_s h_fresh_s + h_names_fresh_s h_names_fresh_B_s h_lhs_disjoint_s h_extra_disjoint_s + h_mod_disjoint_A_s h_mod_disjoint_B_s h_hoist_undef_s h_hoist_undef_h_s + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_s h_src_shapefree_s h_subst_wf h_hinv h_eval_eq h_hf_eq h_hoist_bound + h_head_stmt (Or.inl ⟨ρ_s_mid, rfl⟩) h_wfvar h_wfcongr h_wfsubst h_wfdef + obtain ⟨h_cfg_h_eq, h_hinv_mid, h_hf_mid, h_bound_mid⟩ : + cfg_h_head = .terminal ρ_h_mid ∧ + HoistInv (P := P) A B subst ρ_s_mid.store ρ_h_mid.store ∧ + ρ_s_mid.hasFailure = ρ_h_mid.hasFailure ∧ (∀ y ∈ B, ρ_h_mid.store y ≠ none) := by + rcases h_head_outcome with ⟨r, hr1, hr2, hr3, hr4, hr5⟩ | ⟨l, r, hr1, _, _, _, _⟩ + · have hr_eq : r = ρ_s_mid := by + simp only [Config.terminal.injEq] at hr1; exact hr1.symm + subst hr_eq; exact ⟨hr2, hr3, hr4, hr5⟩ + · exact absurd hr1 (by simp) + subst h_cfg_h_eq + have h_src_s_nofd : Stmt.noFuncDecl s = true := + Stmt.noFuncDecl_of_not_containsFuncDecl s h_fd_stmt + have h_src_mid_eval : ρ_s_mid.eval = ρ_src.eval := + smallStep_noFuncDecl_preserves_eval P (EvalCmd P) extendEval s ρ_src ρ_s_mid + h_src_s_nofd h_head_stmt + have h_h_mid_eval : ρ_h_mid.eval = ρ_hoist.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + (Stmt.hoistLoopPrefixInitsM s σ).1 ρ_hoist ρ_h_mid h_residual_nofd h_head_hoist + have h_eval_mid : ρ_s_mid.eval = ρ_h_mid.eval := by + rw [h_src_mid_eval, h_h_mid_eval, h_eval_eq] + have h_hoist_undef_mid : ∀ y ∈ Block.initVars rest, ρ_s_mid.store y = none := by + intro y hy + have h_y_src_none : ρ_src.store y = none := + h_hoist_undef y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy)) + have h_y_not_init_s : y ∉ Block.initVars [s] := fun hc => + (List.nodup_append.mp h_unique_full).2.2 y hc y hy rfl + have h_y_not_def_s : y ∉ Stmt.definedVars (P := P) (C := Cmd P) s := by + rw [Stmt.definedVars_eq_initVars_of_no_fd s h_fd_stmt] + intro hc + exact h_y_not_init_s (by simp only [Block.initVars, List.append_nil]; exact hc) + exact stmt_run_terminal_preserves_none h_y_src_none h_y_not_def_s h_head_stmt + have h_hoist_undef_h_mid : ∀ y ∈ Block.initVars rest, ρ_h_mid.store y = none := by + intro y hy + have h_y_h_none : ρ_hoist.store y = none := + h_hoist_undef_h y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy)) + have h_unique_s_stmt : (Stmt.initVars s).Nodup := by + have : (Block.initVars [s]).Nodup := h_unique_s + simpa only [Block.initVars, List.append_nil] using this + have h_shapefree_s_stmt : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s := by + intro str h_shape hc + exact (h_src_shapefree_s str h_shape).2.2.1 + (by simp only [Block.initVars, List.append_nil]; exact hc) + have h_y_not_src : y ∉ Stmt.initVars s := fun hc => + (List.nodup_append.mp h_unique_full).2.2 y + (by simp only [Block.initVars, List.append_nil]; exact hc) y hy rfl + have h_y_shapefree : ∀ str : String, y = HasIdent.ident str → + ¬ Q str := by + intro str h_y_eq h_shape + exact (h_src_shapefree str h_shape).2.2.1 + (h_y_eq ▸ (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy))) + exact residual_run_terminal_preserves_none hQmint h_wf_σ h_unique_s_stmt + h_shapefree_s_stmt h_fd_stmt h_y_not_src h_y_shapefree h_y_h_none h_head_hoist + -- Mid-store store-shapefree (σ1-relative) for the tail: same derivation as the + -- terminal branch — the head run defines no `Q`-kind name `str ∉ stringGens σ1`. + have h_src_store_shapefree_mid : ∀ str : String, Q str → + str ∉ StringGenState.stringGens (Stmt.hoistLoopPrefixInitsM s σ).2 → + ρ_s_mid.store (HasIdent.ident (P := P) str) = none := by + intro str h_shape h_notσ1 + have h_notσ : str ∉ StringGenState.stringGens σ := + fun h => h_notσ1 (h_genStep_head.subset h) + have h_z_src_none : ρ_src.store (HasIdent.ident (P := P) str) = none := + h_src_store_shapefree str h_shape h_notσ + have h_z_not_def_s : + HasIdent.ident (P := P) str ∉ Stmt.definedVars (P := P) (C := Cmd P) s := by + rw [Stmt.definedVars_eq_initVars_of_no_fd s h_fd_stmt] + intro hc + exact (h_src_shapefree str h_shape).2.2.1 + (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl + (by simp only [Block.initVars, List.append_nil]; exact hc))) + exact stmt_run_terminal_preserves_none h_z_src_none h_z_not_def_s h_head_stmt + have h_hoist_store_shapefree_mid : ∀ str : String, Q str → + str ∉ StringGenState.stringGens (Stmt.hoistLoopPrefixInitsM s σ).2 → + ρ_h_mid.store (HasIdent.ident (P := P) str) = none := by + intro str h_shape h_notσ1 + have h_notσ : str ∉ StringGenState.stringGens σ := + fun h => h_notσ1 (h_genStep_head.subset h) + have h_z_h_none : ρ_hoist.store (HasIdent.ident (P := P) str) = none := + h_hoist_store_shapefree str h_shape h_notσ + have h_unique_s_stmt : (Stmt.initVars s).Nodup := by + have : (Block.initVars [s]).Nodup := h_unique_s + simpa only [Block.initVars, List.append_nil] using this + have h_shapefree_s_stmt : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s := by + intro str' h_shape' hc + exact (h_src_shapefree_s str' h_shape').2.2.1 + (by simp only [Block.initVars, List.append_nil]; exact hc) + have h_z_not_residual : + HasIdent.ident (P := P) str ∉ Block.initVars (Stmt.hoistLoopPrefixInitsM s σ).1 := by + intro h_mem + have h_class := + (LoopInitHoistLoopArmWF.Stmt.hoistLoopPrefixInitsM_initVars_classified + hQmint s σ h_wf_σ h_unique_s_stmt h_shapefree_s_stmt).1 _ h_mem + rcases h_class with h_orig | ⟨str', h_eq, h_str'_in, _, _⟩ + · exact h_shapefree_s_stmt str h_shape h_orig + · exact h_notσ1 ((LawfulHasIdent.ident_inj h_eq) ▸ h_str'_in) + have h_residual_contains_nofd : + Block.containsFuncDecl (Stmt.hoistLoopPrefixInitsM s σ).1 = false := by + rw [Stmt.hoistLoopPrefixInitsM_containsFuncDecl]; exact h_fd_stmt + exact block_run_terminal_preserves_none_of_not_initVars + h_residual_contains_nofd h_z_not_residual h_z_h_none h_head_hoist + obtain ⟨ρ_h_fin, cfg_hoist_tail, h_tail_hoist, h_tail_outcome⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst rest (Stmt.hoistLoopPrefixInitsM s σ).2 + h_nd_s.2 h_fd_s.2 h_inv_s.2 h_measure_s.2 h_exprs_shapefree_s.2 h_unique_rest h_fresh_rest + h_names_fresh_rest h_names_fresh_B_rest h_lhs_disjoint_rest h_extra_disjoint_rest + h_mod_disjoint_A_rest h_mod_disjoint_B_rest h_hoist_undef_mid h_hoist_undef_h_mid + h_src_store_shapefree_mid h_hoist_store_shapefree_mid + h_wf_σ1 h_src_fresh_rest h_src_shapefree_rest h_subst_wf h_hinv_mid h_eval_mid h_hf_mid h_bound_mid + h_tail_exit (Or.inr ⟨lbl, ρ_src', rfl⟩) h_wfvar h_wfcongr h_wfsubst h_wfdef + refine ⟨ρ_h_fin, cfg_hoist_tail, ?_, ?_⟩ + · refine ReflTrans_Transitive _ _ _ _ + (stmts_prefix_terminal_append P (EvalCmd P) extendEval + (Stmt.hoistLoopPrefixInitsM s σ).1 + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).1 + ρ_hoist ρ_h_mid h_head_hoist) ?_ + exact h_tail_hoist + · rcases h_tail_outcome with ⟨r, hr1, _, _, _, _⟩ | ⟨l, r, hr1, hr2, hr3, hr4, hr5⟩ + · exact absurd hr1.symm (by simp) + · exact Or.inr ⟨l, r, hr1, hr2, hr3, hr4, hr5⟩ + termination_by sizeOf ss + decreasing_by all_goals (subst h_match; simp_wf; omega) + +end + +/-\! ## Failing-config forward simulation (`hoistLoopPrefixInits_to_fail`) + +`Stmt.hoistLoopPrefixInits_preserves` / `Block.hoistLoopPrefixInits_preserves` +are *endpoint*-keyed: each consumes a source run reaching `.terminal` / `.exiting`. +A reachable *failing* configuration need not lie on such a run (an `assert` only +OR-s the cumulative `hasFailure` flag and continues, so a failing run may diverge +or get stuck afterwards). The `_to_fail` siblings below remove the endpoint +demand: a reachable failing source configuration of `ss` is matched by a reachable +failing configuration of `Block.hoistLoopPrefixInitsM ss σ` from the same +`HoistInv`-related start. + +The construction mirrors the endpoint mutual but keys on the *failing +configuration* as the halting condition. Each statement / loop iteration that +*completed before the failure* terminated, so the endpoint simulation applies to +it verbatim and re-establishes the invariant (the endpoint mutual +`Stmt`/`Block.hoistLoopPrefixInits_preserves` is reused for those); only the +single statement / iteration that *contains* the failure is transported by a bare +failing-config reach. The loop arm dispatches to the failing-target loop closer +`loop_arm_close_fail`, whose induction is on a `Nat` fuel bounding the SOURCE run +length (finite by failure monotonicity), never on the loop terminating. -/ + +set_option maxHeartbeats 1000000 in +set_option maxRecDepth 4000 in +mutual + +/-- §E Stmt-level FAILING-config simulation (the `_to_fail` analogue of +`Stmt.hoistLoopPrefixInits_preserves`): same front-end / generator preconditions, +but the source run reaches a *failing* config and the conclusion asserts the +hoisted residual reaches a failing config too (no terminal/exiting endpoint, no +re-established invariant). -/ +private theorem Stmt.hoistLoopPrefixInits_to_fail {Q : String → Prop} + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] + [HasIntOrder P] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + [DecidableEq P.Ident] + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {extendEval : ExtendEval P} + (A : List P.Ident) + (B : List P.Ident) + (subst : List (P.Ident × P.Ident)) + (s : Stmt P (Cmd P)) + (σ : StringGenState) + {ρ_src ρ_hoist : Env P} + {cfg_src : Config P (Cmd P)} + (h_no_nd : Stmt.containsNondetLoop s = false) + (h_no_fd : Stmt.containsFuncDecl s = false) + (h_no_inv : Stmt.loopHasNoInvariants s = true) + (h_no_measure : Stmt.loopMeasureNone s = true) + (h_exprs_shapefree : Block.exprsShapeFree (P := P) Q [s]) + (h_unique : Block.uniqueInits [s]) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) [s] = true) + (h_names_fresh : Block.namesFreshInExprs A [s] = true) + (h_names_fresh_B : Block.namesFreshInExprs B [s] = true) + (h_lhs_disjoint : ∀ y ∈ Block.initVars [s], y ∉ A) + (h_extra_disjoint : ∀ y ∈ Block.initVars [s], y ∉ B) + (h_mod_disjoint_A : ∀ x ∈ Block.modifiedVars [s], x ∉ A) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars [s], x ∉ B) + (h_hoist_undef : ∀ y ∈ Block.initVars [s], ρ_src.store y = none) + (h_hoist_undef_h : ∀ y ∈ Block.initVars [s], ρ_hoist.store y = none) + (h_src_store_shapefree : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_src.store (HasIdent.ident (P := P) str) = none) + (h_hoist_store_shapefree : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_hoist.store (HasIdent.ident (P := P) str) = none) + (h_wf_σ : StringGenState.WF σ) + (h_src_namesFreshFromσ : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars [s]) + (h_src_shapefree : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars [s] ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars [s]) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval_eq : ρ_src.eval = ρ_hoist.eval) + (h_hf_eq : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_hoist_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmt s ρ_src) cfg_src) + (h_c_fail : cfg_src.getEnv.hasFailure = true) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + ∃ d : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.hoistLoopPrefixInitsM s σ).1 ρ_hoist) d + ∧ d.getEnv.hasFailure = true := by + classical + -- Uniform handler for atomic statements (`.cmd` / `.exit` / `.typeDecl`): a + -- failing run is `refl` (start failing ⇒ hoist start fails by `h_hf_eq`) or a + -- single endpoint reach (terminal/exiting) carrying the failure — the endpoint + -- mutual `Stmt.hoistLoopPrefixInits_preserves` replays it to a hoist endpoint + -- of the same shape with the same `hasFailure` flag, which is therefore failing. + have atomic : (cfg_src = .stmt s ρ_src) ∨ + (∃ ρ', cfg_src = .terminal ρ') ∨ (∃ l ρ', cfg_src = .exiting l ρ') → + ∃ d : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.hoistLoopPrefixInitsM s σ).1 ρ_hoist) d + ∧ d.getEnv.hasFailure = true := by + rintro (h_refl | h_endpoint) + · refine ⟨.stmts (Stmt.hoistLoopPrefixInitsM s σ).1 ρ_hoist, .refl _, ?_⟩ + rw [h_refl] at h_c_fail + have : ρ_src.hasFailure = true := by simpa [Config.getEnv] using h_c_fail + simpa [Config.getEnv] using (h_hf_eq ▸ this) + · obtain ⟨ρ_h', cfg_hoist, h_run_h, h_out⟩ := + Stmt.hoistLoopPrefixInits_preserves hQmint A B subst s σ + h_no_nd h_no_fd h_no_inv h_no_measure h_exprs_shapefree h_unique h_fresh + h_names_fresh h_names_fresh_B h_lhs_disjoint h_extra_disjoint + h_mod_disjoint_A h_mod_disjoint_B h_hoist_undef h_hoist_undef_h + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_namesFreshFromσ h_src_shapefree h_subst_wf h_hinv + h_eval_eq h_hf_eq h_hoist_bound h_run_src + (by rcases h_endpoint with ⟨ρ', h⟩ | ⟨l, ρ', h⟩ + · exact Or.inl ⟨ρ', h⟩ + · exact Or.inr ⟨l, ρ', h⟩) + h_wfvar h_wfcongr h_wfsubst h_wfdef + refine ⟨cfg_hoist, h_run_h, ?_⟩ + rcases h_out with ⟨ρ_s', h_eq_src, h_eq_h, _, h_hf', _⟩ | ⟨l, ρ_s', h_eq_src, h_eq_h, _, h_hf', _⟩ + · rw [h_eq_src] at h_c_fail + have h_s_fail : ρ_s'.hasFailure = true := by simpa [Config.getEnv] using h_c_fail + rw [h_eq_h]; simpa [Config.getEnv] using (h_hf' ▸ h_s_fail) + · rw [h_eq_src] at h_c_fail + have h_s_fail : ρ_s'.hasFailure = true := by simpa [Config.getEnv] using h_c_fail + rw [h_eq_h]; simpa [Config.getEnv] using (h_hf' ▸ h_s_fail) + match h_match : s with + | .cmd c => + subst h_match + -- A `.cmd` run reaching a failing config is `refl` or a single step to terminal. + apply atomic + cases h_run_src with + | refl => exact Or.inl rfl + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | refl => exact Or.inr (Or.inl ⟨_, rfl⟩) + | step _ _ _ hd _ => exact nomatch hd + | .exit lbl md => + subst h_match + -- An `.exit` run reaching a failing config is `refl` or a single step to exiting. + apply atomic + cases h_run_src with + | refl => exact Or.inl rfl + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | refl => exact Or.inr (Or.inr ⟨_, _, rfl⟩) + | step _ _ _ hd _ => exact nomatch hd + | .typeDecl t md => + subst h_match + -- A `.typeDecl` run reaching a failing config is `refl` or a single step to terminal. + apply atomic + cases h_run_src with + | refl => exact Or.inl rfl + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | refl => exact Or.inr (Or.inl ⟨_, rfl⟩) + | step _ _ _ hd _ => exact nomatch hd + | .funcDecl d md => + subst h_match + rw [Stmt.containsFuncDecl] at h_no_fd + exact absurd h_no_fd (by simp) + | .block lbl bss md => + subst h_match + -- === Decompose the §E preconditions for `[.block lbl bss md]` to `bss`. === + -- Every structural Bool walker on `.block` reduces to its body, and + -- `Block.initVars [.block lbl bss md] = Block.initVars bss`. + have h_iv_eq : Block.initVars [Stmt.block lbl bss md] = Block.initVars bss := by + simp only [Block.initVars, Stmt.initVars, List.append_nil] + have h_mod_eq : Block.modifiedVars [Stmt.block lbl bss md] = Block.modifiedVars bss := by + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil] + have h_nd_bss : Block.containsNondetLoop bss = false := by + simpa only [Block.containsNondetLoop, Stmt.containsNondetLoop, Bool.or_false] using h_no_nd + have h_fd_bss : Block.containsFuncDecl bss = false := by + simpa only [Block.containsFuncDecl, Stmt.containsFuncDecl, Bool.or_false] using h_no_fd + have h_inv_bss : Block.loopHasNoInvariants bss = true := by + simpa only [Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, Bool.and_true] using h_no_inv + have h_measure_bss : Block.loopMeasureNone bss = true := by + simpa only [Block.loopMeasureNone, Stmt.loopMeasureNone, Bool.and_true] using h_no_measure + have h_exprs_shapefree_bss : Block.exprsShapeFree (P := P) Q bss := by + have h := h_exprs_shapefree + simp only [Block.exprsShapeFree, Stmt.exprsShapeFree] at h + exact h.1 + have h_unique_bss : Block.uniqueInits bss := by + show (Block.initVars bss).Nodup + have : Block.uniqueInits [Stmt.block lbl bss md] = + (Block.initVars [Stmt.block lbl bss md]).Nodup := rfl + rw [this, h_iv_eq] at h_unique; exact h_unique + have h_fresh_bss : Block.hoistedNamesFreshInRhsAndGuards (P := P) bss = true := by + have h_fresh_unfold := h_fresh + unfold Block.hoistedNamesFreshInRhsAndGuards at h_fresh_unfold ⊢ + -- `namesFreshInRhsExprs (initVars [.block..]) [.block..] = namesFreshInRhsExprs (initVars bss) bss`. + have : Block.namesFreshInRhsExprs (Block.initVars [Stmt.block lbl bss md]) + [Stmt.block lbl bss md] = + Block.namesFreshInRhsExprs (Block.initVars bss) bss := by + simp only [Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, Bool.and_true, h_iv_eq] + rwa [this] at h_fresh_unfold + have h_names_fresh_bss : Block.namesFreshInExprs A bss = true := by + simpa only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true] using h_names_fresh + have h_names_fresh_B_bss : Block.namesFreshInExprs B bss = true := by + simpa only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true] using h_names_fresh_B + have h_lhs_disjoint_bss : ∀ y ∈ Block.initVars bss, y ∉ A := fun y hy => + h_lhs_disjoint y (h_iv_eq ▸ hy) + have h_extra_disjoint_bss : ∀ y ∈ Block.initVars bss, y ∉ B := fun y hy => + h_extra_disjoint y (h_iv_eq ▸ hy) + have h_mod_disjoint_A_bss : ∀ x ∈ Block.modifiedVars bss, x ∉ A := fun x hx => + h_mod_disjoint_A x (h_mod_eq ▸ hx) + have h_mod_disjoint_B_bss : ∀ x ∈ Block.modifiedVars bss, x ∉ B := fun x hx => + h_mod_disjoint_B x (h_mod_eq ▸ hx) + have h_hoist_undef_bss : ∀ y ∈ Block.initVars bss, ρ_src.store y = none := fun y hy => + h_hoist_undef y (h_iv_eq ▸ hy) + have h_hoist_undef_h_bss : ∀ y ∈ Block.initVars bss, ρ_hoist.store y = none := fun y hy => + h_hoist_undef_h y (h_iv_eq ▸ hy) + have h_src_fresh_bss : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars bss := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (h_iv_eq ▸ h)⟩ + have h_src_shapefree_bss : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars bss ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars bss := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (h_iv_eq ▸ h), fun h => hmv (h_mod_eq ▸ h)⟩ + -- === Rewrite the residual to the singleton hoisted `.block`. === + have h_block_out : + (Stmt.hoistLoopPrefixInitsM (.block lbl bss md) σ).1 = + [Stmt.block lbl (Block.hoistLoopPrefixInitsM bss σ).1 md] := + Stmt.hoistLoopPrefixInitsM_block_out lbl bss md σ + rw [h_block_out] + -- A failing run of `.stmt (.block lbl bss md) ρ_src` is `refl` (start failing) + -- or steps `step_block` into the body block, whose failure + -- (`block_reaches_failing'`) is reached inside `.stmts bss`. Recurse on `bss` + -- and lift the failing hoist body run back into the hoisted block. + cases h_run_src with + | refl => + refine ⟨.stmts [Stmt.block lbl (Block.hoistLoopPrefixInitsM bss σ).1 md] ρ_hoist, .refl _, ?_⟩ + have : ρ_src.hasFailure = true := by simpa [Config.getEnv] using h_c_fail + simpa [Config.getEnv] using (h_hf_eq ▸ this) + | step _ _ _ h1 hr1 => + cases h1 + obtain ⟨d_inner, h_inner_run, hd_inner⟩ := + block_reaches_failing' P (EvalCmd P) extendEval hr1 h_c_fail + obtain ⟨d', h_body_h, hd'⟩ := + Block.hoistLoopPrefixInits_to_fail hQmint A B subst bss σ + h_nd_bss h_fd_bss h_inv_bss h_measure_bss h_exprs_shapefree_bss h_unique_bss h_fresh_bss + h_names_fresh_bss h_names_fresh_B_bss h_lhs_disjoint_bss h_extra_disjoint_bss + h_mod_disjoint_A_bss h_mod_disjoint_B_bss h_hoist_undef_bss h_hoist_undef_h_bss + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_bss h_src_shapefree_bss h_subst_wf h_hinv + h_eval_eq h_hf_eq h_hoist_bound h_inner_run hd_inner h_wfvar h_wfcongr h_wfsubst h_wfdef + refine ⟨.seq (.block (.some lbl) ρ_hoist.store d') [], ?_, by simpa [Config.getEnv] using hd'⟩ + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner StepStmt.step_block) ?_ + exact seq_inner_star P (EvalCmd P) extendEval _ _ [] + (block_inner_star P (EvalCmd P) extendEval _ _ (.some lbl) ρ_hoist.store h_body_h) + | .ite g tss ess md => + subst h_match + -- === Decompose the §E preconditions for `[.ite g tss ess md]` to the + -- branches `tss` (processed at σ) and `ess` (processed at σ1). === + have h_iv_split : Block.initVars [Stmt.ite g tss ess md] = + Block.initVars tss ++ Block.initVars ess := by + simp only [Block.initVars, Stmt.initVars, List.append_nil] + have h_mod_split : Block.modifiedVars [Stmt.ite g tss ess md] = + Block.modifiedVars tss ++ Block.modifiedVars ess := by + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil] + -- Bool preconds. + have h_nd_branches : Block.containsNondetLoop tss = false ∧ Block.containsNondetLoop ess = false := by + simp only [Stmt.containsNondetLoop, + Bool.or_eq_false_iff] at h_no_nd; exact h_no_nd + have h_fd_branches : Block.containsFuncDecl tss = false ∧ Block.containsFuncDecl ess = false := by + simp only [Stmt.containsFuncDecl, + Bool.or_eq_false_iff] at h_no_fd; exact h_no_fd + have h_inv_branches : Block.loopHasNoInvariants tss = true ∧ Block.loopHasNoInvariants ess = true := by + simp only [Stmt.loopHasNoInvariants, + Bool.and_eq_true] at h_no_inv; exact h_no_inv + have h_measure_branches : Block.loopMeasureNone tss = true ∧ Block.loopMeasureNone ess = true := by + simp only [Stmt.loopMeasureNone, + Bool.and_eq_true] at h_no_measure; exact h_no_measure + have h_exprs_shapefree_branches : + Block.exprsShapeFree (P := P) Q tss ∧ + Block.exprsShapeFree (P := P) Q ess := by + have h := h_exprs_shapefree + simp only [Block.exprsShapeFree, Stmt.exprsShapeFree] at h + exact ⟨h.1.2.1, h.1.2.2⟩ + -- uniqueInits: Nodup splits over the append. + have h_unique_full : (Block.initVars tss ++ Block.initVars ess).Nodup := by + have : Block.uniqueInits [Stmt.ite g tss ess md] = + (Block.initVars [Stmt.ite g tss ess md]).Nodup := rfl + rw [this, h_iv_split] at h_unique; exact h_unique + have h_unique_tss : Block.uniqueInits tss := (List.nodup_append.mp h_unique_full).1 + have h_unique_ess : Block.uniqueInits ess := (List.nodup_append.mp h_unique_full).2.1 + -- hoistedNamesFreshInRhsAndGuards: split into the two branches. + have h_fresh_unfold := h_fresh + unfold Block.hoistedNamesFreshInRhsAndGuards at h_fresh_unfold + -- namesFreshInRhsExprs over initVars [.ite ..]: split via subset + the ite arm + -- (the `.ite` guard read position is no longer checked, so no guard conjunct). + have h_sub_tss : (Block.initVars tss : List P.Ident) ⊆ Block.initVars [Stmt.ite g tss ess md] := by + rw [h_iv_split]; exact fun _ h => List.mem_append.mpr (Or.inl h) + have h_sub_ess : (Block.initVars ess : List P.Ident) ⊆ Block.initVars [Stmt.ite g tss ess md] := by + rw [h_iv_split]; exact fun _ h => List.mem_append.mpr (Or.inr h) + simp only [Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, Bool.and_true, + Bool.and_eq_true] at h_fresh_unfold + obtain ⟨h_nf_tss_iv, h_nf_ess_iv⟩ := h_fresh_unfold + have h_fresh_tss : Block.hoistedNamesFreshInRhsAndGuards (P := P) tss = true := by + unfold Block.hoistedNamesFreshInRhsAndGuards + exact Block.namesFreshInRhsExprs_subset h_sub_tss tss h_nf_tss_iv + have h_fresh_ess : Block.hoistedNamesFreshInRhsAndGuards (P := P) ess = true := by + unfold Block.hoistedNamesFreshInRhsAndGuards + exact Block.namesFreshInRhsExprs_subset h_sub_ess ess h_nf_ess_iv + -- namesFreshInExprs A / B split over the branches. + have h_names_fresh_A_split : + Block.namesFreshInExprs A tss = true ∧ Block.namesFreshInExprs A ess = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + Bool.and_eq_true] at h_names_fresh; exact ⟨h_names_fresh.1.2, h_names_fresh.2⟩ + have h_names_fresh_B_split : + Block.namesFreshInExprs B tss = true ∧ Block.namesFreshInExprs B ess = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + Bool.and_eq_true] at h_names_fresh_B; exact ⟨h_names_fresh_B.1.2, h_names_fresh_B.2⟩ + -- initVars-based disjointness / undef: split via initVars membership. + have h_lhs_disjoint_tss : ∀ y ∈ Block.initVars tss, y ∉ A := fun y hy => + h_lhs_disjoint y (h_sub_tss hy) + have h_lhs_disjoint_ess : ∀ y ∈ Block.initVars ess, y ∉ A := fun y hy => + h_lhs_disjoint y (h_sub_ess hy) + have h_extra_disjoint_tss : ∀ y ∈ Block.initVars tss, y ∉ B := fun y hy => + h_extra_disjoint y (h_sub_tss hy) + have h_extra_disjoint_ess : ∀ y ∈ Block.initVars ess, y ∉ B := fun y hy => + h_extra_disjoint y (h_sub_ess hy) + have h_mod_sub_tss : (Block.modifiedVars tss : List P.Ident) ⊆ + Block.modifiedVars [Stmt.ite g tss ess md] := by + rw [h_mod_split]; exact fun _ h => List.mem_append.mpr (Or.inl h) + have h_mod_sub_ess : (Block.modifiedVars ess : List P.Ident) ⊆ + Block.modifiedVars [Stmt.ite g tss ess md] := by + rw [h_mod_split]; exact fun _ h => List.mem_append.mpr (Or.inr h) + have h_mod_disjoint_A_tss : ∀ x ∈ Block.modifiedVars tss, x ∉ A := fun x hx => + h_mod_disjoint_A x (h_mod_sub_tss hx) + have h_mod_disjoint_A_ess : ∀ x ∈ Block.modifiedVars ess, x ∉ A := fun x hx => + h_mod_disjoint_A x (h_mod_sub_ess hx) + have h_mod_disjoint_B_tss : ∀ x ∈ Block.modifiedVars tss, x ∉ B := fun x hx => + h_mod_disjoint_B x (h_mod_sub_tss hx) + have h_mod_disjoint_B_ess : ∀ x ∈ Block.modifiedVars ess, x ∉ B := fun x hx => + h_mod_disjoint_B x (h_mod_sub_ess hx) + have h_hoist_undef_tss : ∀ y ∈ Block.initVars tss, ρ_src.store y = none := fun y hy => + h_hoist_undef y (h_sub_tss hy) + have h_hoist_undef_ess : ∀ y ∈ Block.initVars ess, ρ_src.store y = none := fun y hy => + h_hoist_undef y (h_sub_ess hy) + have h_hoist_undef_h_tss : ∀ y ∈ Block.initVars tss, ρ_hoist.store y = none := fun y hy => + h_hoist_undef_h y (h_sub_tss hy) + have h_hoist_undef_h_ess : ∀ y ∈ Block.initVars ess, ρ_hoist.store y = none := fun y hy => + h_hoist_undef_h y (h_sub_ess hy) + -- σ-freshness / shape-free restricted to each branch. + have h_src_fresh_tss : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars tss := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (h_sub_tss h)⟩ + have h_src_shapefree_tss : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars tss ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars tss := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (h_sub_tss h), fun h => hmv (h_mod_sub_tss h)⟩ + have h_src_shapefree_ess : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars ess ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars ess := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (h_sub_ess h), fun h => hmv (h_mod_sub_ess h)⟩ + -- GenStep facts: σ → σ1 = (Block.hoistLoopPrefixInitsM tss σ).2; WF of σ1. + have h_genStep_tss : StringGenState.GenStep σ (Block.hoistLoopPrefixInitsM tss σ).2 := + Block.hoistLoopPrefixInitsM_genStep tss σ + have h_wf_σ1 : StringGenState.WF (Block.hoistLoopPrefixInitsM tss σ).2 := + h_genStep_tss.wf_mono h_wf_σ + -- σ-freshness for ESS at σ1: thread via SrcNamesFreshFromGen.genStep_of_delta. + have h_src_fresh_ess_σ1 : + ∀ str ∈ StringGenState.stringGens (Block.hoistLoopPrefixInitsM tss σ).2, + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars ess := by + have h_fresh_σ_ess : SrcNamesFreshFromGen (P := P) A B (Block.initVars ess) σ := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (h_sub_ess h)⟩ + exact SrcNamesFreshFromGen.genStep_of_delta + (Block.hoistLoopPrefixInitsM_genStep_delta_Q hQmint tss σ) + (fun str hsuf => let ⟨a, b, c, _⟩ := h_src_shapefree_ess str hsuf; ⟨a, b, c⟩) h_fresh_σ_ess + -- Store-shapefree at σ1 for the ELSE branch. The else branch runs from the + -- SAME entry stores `ρ_src`/`ρ_hoist` (the `.ite` selects one branch), so the + -- store facts are unchanged; only the generator state index advances to σ1. + -- A suffix name `∉ stringGens σ1` is `∉ stringGens σ` by genStep monotonicity, + -- so the σ-version facts transfer. + have h_src_store_shapefree_σ1 : ∀ str : String, Q str → + str ∉ StringGenState.stringGens (Block.hoistLoopPrefixInitsM tss σ).2 → + ρ_src.store (HasIdent.ident (P := P) str) = none := fun str h_suf h_notσ1 => + h_src_store_shapefree str h_suf (fun h => h_notσ1 (h_genStep_tss.subset h)) + have h_hoist_store_shapefree_σ1 : ∀ str : String, Q str → + str ∉ StringGenState.stringGens (Block.hoistLoopPrefixInitsM tss σ).2 → + ρ_hoist.store (HasIdent.ident (P := P) str) = none := fun str h_suf h_notσ1 => + h_hoist_store_shapefree str h_suf (fun h => h_notσ1 (h_genStep_tss.subset h)) + -- === Rewrite the residual to the singleton hoisted `.ite`. === + have h_ite_out : + (Stmt.hoistLoopPrefixInitsM (.ite g tss ess md) σ).1 = + [Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess + (Block.hoistLoopPrefixInitsM tss σ).2).1 md] := + Stmt.hoistLoopPrefixInitsM_ite_out g tss ess md σ + rw [h_ite_out] + -- THEN-branch failing driver: recurse `Block.hoistLoopPrefixInits_to_fail` on + -- `tss` at σ, then lift through the single hoisted-ite branch-selection step. + have run_then_fail : + StepStmtStar P (EvalCmd P) extendEval (.stmts tss ρ_src) cfg_src → + StepStmt P (EvalCmd P) extendEval + (.stmt (Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 md) ρ_hoist) + (.stmts (Block.hoistLoopPrefixInitsM tss σ).1 ρ_hoist) → + ∃ d : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts [Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 md] ρ_hoist) d + ∧ d.getEnv.hasFailure = true := by + intro hr1 h_step + obtain ⟨d', h_branch_h, hd'⟩ := + Block.hoistLoopPrefixInits_to_fail hQmint A B subst tss σ + h_nd_branches.1 h_fd_branches.1 h_inv_branches.1 h_measure_branches.1 + h_exprs_shapefree_branches.1 + h_unique_tss h_fresh_tss h_names_fresh_A_split.1 h_names_fresh_B_split.1 + h_lhs_disjoint_tss h_extra_disjoint_tss h_mod_disjoint_A_tss h_mod_disjoint_B_tss + h_hoist_undef_tss h_hoist_undef_h_tss + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_tss h_src_shapefree_tss h_subst_wf h_hinv h_eval_eq h_hf_eq + h_hoist_bound hr1 h_c_fail h_wfvar h_wfcongr h_wfsubst h_wfdef + refine ⟨.seq d' [], ?_, by simpa [Config.getEnv] using hd'⟩ + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner h_step) ?_ + exact seq_inner_star P (EvalCmd P) extendEval _ _ [] h_branch_h + -- ELSE-branch failing driver: recurse on `ess` at σ1. + have run_else_fail : + StepStmtStar P (EvalCmd P) extendEval (.stmts ess ρ_src) cfg_src → + StepStmt P (EvalCmd P) extendEval + (.stmt (Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 md) ρ_hoist) + (.stmts (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 ρ_hoist) → + ∃ d : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts [Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 md] ρ_hoist) d + ∧ d.getEnv.hasFailure = true := by + intro hr1 h_step + obtain ⟨d', h_branch_h, hd'⟩ := + Block.hoistLoopPrefixInits_to_fail hQmint A B subst ess (Block.hoistLoopPrefixInitsM tss σ).2 + h_nd_branches.2 h_fd_branches.2 h_inv_branches.2 h_measure_branches.2 + h_exprs_shapefree_branches.2 + h_unique_ess h_fresh_ess h_names_fresh_A_split.2 h_names_fresh_B_split.2 + h_lhs_disjoint_ess h_extra_disjoint_ess h_mod_disjoint_A_ess h_mod_disjoint_B_ess + h_hoist_undef_ess h_hoist_undef_h_ess + h_src_store_shapefree_σ1 h_hoist_store_shapefree_σ1 + h_wf_σ1 h_src_fresh_ess_σ1 h_src_shapefree_ess h_subst_wf h_hinv h_eval_eq h_hf_eq + h_hoist_bound hr1 h_c_fail h_wfvar h_wfcongr h_wfsubst h_wfdef + refine ⟨.seq d' [], ?_, by simpa [Config.getEnv] using hd'⟩ + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner h_step) ?_ + exact seq_inner_star P (EvalCmd P) extendEval _ _ [] h_branch_h + -- Invert the source ite step (or `refl` start-failing). + cases h_run_src with + | refl => + refine ⟨.stmts [Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).1 md] ρ_hoist, .refl _, ?_⟩ + have : ρ_src.hasFailure = true := by simpa [Config.getEnv] using h_c_fail + simpa [Config.getEnv] using (h_hf_eq ▸ this) + | step _ _ _ h1 hr1 => + cases h1 with + | step_ite_true h_eval h_wfb => + have h_guard := h_eval + rw [ite_guard_agree (subst := subst) (tss := tss) (ess := ess) (md := md) + h_names_fresh h_names_fresh_B h_hinv + (read_vars_def_of_eval (h_wfdef ρ_src) h_eval) h_eval_eq h_wfcongr] at h_guard + rw [h_eval_eq] at h_wfb + exact run_then_fail hr1 (StepStmt.step_ite_true h_guard h_wfb) + | step_ite_false h_eval h_wfb => + have h_guard := h_eval + rw [ite_guard_agree (subst := subst) (tss := tss) (ess := ess) (md := md) + h_names_fresh h_names_fresh_B h_hinv + (read_vars_def_of_eval (h_wfdef ρ_src) h_eval) h_eval_eq h_wfcongr] at h_guard + rw [h_eval_eq] at h_wfb + exact run_else_fail hr1 (StepStmt.step_ite_false h_guard h_wfb) + | step_ite_nondet_true => exact run_then_fail hr1 StepStmt.step_ite_nondet_true + | step_ite_nondet_false => exact run_else_fail hr1 StepStmt.step_ite_nondet_false + | .loop g m inv body md => + subst h_match + -- === A. Normalize the loop shape: g = .det g', m = none, inv = []. === + -- `loopMeasureNone` ⇒ `m = none`; `loopHasNoInvariants` ⇒ `inv = []`; + -- `containsNondetLoop = false` ⇒ guard is `.det g'`. + have h_no_measure_s : Stmt.loopMeasureNone (Stmt.loop g m inv body md) = true := by + simpa only [Block.loopMeasureNone, Bool.and_true] using h_no_measure + have h_no_inv_s : Stmt.loopHasNoInvariants (Stmt.loop g m inv body md) = true := by + simpa only [Block.loopHasNoInvariants, Bool.and_true] using h_no_inv + have h_no_nd_s : Stmt.containsNondetLoop (Stmt.loop g m inv body md) = false := by + simpa only [Block.containsNondetLoop, Bool.or_false] using h_no_nd + have h_m_none : m = none := by + rw [Stmt.loopMeasureNone, Bool.and_eq_true] at h_no_measure_s + exact Option.isNone_iff_eq_none.mp h_no_measure_s.1 + have h_inv_nil : inv = [] := by + rw [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h_no_inv_s + exact List.isEmpty_iff.mp h_no_inv_s.1 + subst h_m_none; subst h_inv_nil + have h_body_nd : ∃ g', g = ExprOrNondet.det g' ∧ Block.containsNondetLoop body = false := by + cases g with + | nondet => rw [Stmt.containsNondetLoop] at h_no_nd_s; exact absurd h_no_nd_s (by simp) + | det g' => refine ⟨g', rfl, ?_⟩; rw [Stmt.containsNondetLoop] at h_no_nd_s; exact h_no_nd_s + obtain ⟨g', rfl, h_nd_body⟩ := h_body_nd + -- === Carrier identities: initVars/modifiedVars of the singleton loop ARE body's. === + have h_iv_body : Block.initVars [Stmt.loop (.det g') none [] body md] = Block.initVars body := by + simp only [Block.initVars, Stmt.initVars, List.append_nil] + have h_mod_body : Block.modifiedVars [Stmt.loop (.det g') none [] body md] = Block.modifiedVars body := by + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil] + -- === Body-level §E preconditions, decomposed from the loop's. === + have h_fd_body : Block.containsFuncDecl body = false := by + have : Stmt.containsFuncDecl (Stmt.loop (.det g') none [] body md) = false := by + simpa only [Block.containsFuncDecl, Bool.or_false] using h_no_fd + rw [Stmt.containsFuncDecl] at this; exact this + have h_inv_body : Block.loopHasNoInvariants body = true := by + rw [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h_no_inv_s; exact h_no_inv_s.2 + have h_measure_body : Block.loopMeasureNone body = true := by + rw [Stmt.loopMeasureNone, Bool.and_eq_true] at h_no_measure_s; exact h_no_measure_s.2 + have h_exprs_shapefree_body : Block.exprsShapeFree (P := P) Q body := by + have h := h_exprs_shapefree + simp only [Block.exprsShapeFree, Stmt.exprsShapeFree] at h + exact h.1.2.2.2 + have h_unique_body : Block.uniqueInits body := by + show (Block.initVars body).Nodup; rw [← h_iv_body]; exact h_unique + have h_fresh_body : Block.hoistedNamesFreshInRhsAndGuards (P := P) body = true := by + have h := h_fresh + unfold Block.hoistedNamesFreshInRhsAndGuards at h ⊢ + rw [h_iv_body] at h + -- the `.loop` arm of `namesFreshInRhsExprs` recurses into the body only. + simp only [Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, + Bool.and_true] at h + exact h + have h_names_fresh_A_body : Block.namesFreshInExprs A body = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + Bool.and_eq_true] at h_names_fresh; exact h_names_fresh.2 + have h_names_fresh_B_body : Block.namesFreshInExprs B body = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true, + Bool.and_eq_true] at h_names_fresh_B; exact h_names_fresh_B.2 + -- guard `g'` freshness from A / B. + have freshFromIdents_notmem : ∀ {z : P.Ident} {vars : List P.Ident}, + freshFromIdents z vars = true → z ∉ vars := by + intro z vars h + unfold freshFromIdents at h + rw [List.all_eq_true] at h + intro hmem + have h_z := h z hmem + have h_eq : (P.EqIdent z z).decide = true := by simp + rw [h_eq] at h_z + exact absurd h_z (by decide) + have h_g_A_fresh : ∀ x ∈ A, x ∉ HasVarsPure.getVars g' := by + simp only [Block.namesFreshInExprs, Bool.and_true] at h_names_fresh + unfold Stmt.namesFreshInExprs at h_names_fresh + rw [Bool.and_eq_true, Bool.and_eq_true, Bool.and_eq_true] at h_names_fresh + obtain ⟨⟨⟨h_g, _⟩, _⟩, _⟩ := h_names_fresh + rw [List.all_eq_true] at h_g + intro x hx + have := h_g x hx + rw [ExprOrNondet.getVars] at this + exact freshFromIdents_notmem this + have h_g_B_fresh : ∀ x ∈ B, x ∉ HasVarsPure.getVars g' := by + simp only [Block.namesFreshInExprs, Bool.and_true] at h_names_fresh_B + unfold Stmt.namesFreshInExprs at h_names_fresh_B + rw [Bool.and_eq_true, Bool.and_eq_true, Bool.and_eq_true] at h_names_fresh_B + obtain ⟨⟨⟨h_g, _⟩, _⟩, _⟩ := h_names_fresh_B + rw [List.all_eq_true] at h_g + intro x hx + have := h_g x hx + rw [ExprOrNondet.getVars] at this + exact freshFromIdents_notmem this + -- initVars/modifiedVars-based disjointness + undef + σ-freshness for body. + have h_lhs_disjoint_body : ∀ y ∈ Block.initVars body, y ∉ A := fun y hy => + h_lhs_disjoint y (by rw [h_iv_body]; exact hy) + have h_extra_disjoint_body : ∀ y ∈ Block.initVars body, y ∉ B := fun y hy => + h_extra_disjoint y (by rw [h_iv_body]; exact hy) + have h_mod_disjoint_A_body : ∀ x ∈ Block.modifiedVars body, x ∉ A := fun x hx => + h_mod_disjoint_A x (by rw [h_mod_body]; exact hx) + have h_mod_disjoint_B_body : ∀ x ∈ Block.modifiedVars body, x ∉ B := fun x hx => + h_mod_disjoint_B x (by rw [h_mod_body]; exact hx) + have h_hoist_undef_body : ∀ y ∈ Block.initVars body, ρ_src.store y = none := fun y hy => + h_hoist_undef y (by rw [h_iv_body]; exact hy) + have h_hoist_undef_h_body : ∀ y ∈ Block.initVars body, ρ_hoist.store y = none := fun y hy => + h_hoist_undef_h y (by rw [h_iv_body]; exact hy) + have h_src_fresh_body : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars body := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_body]; exact h)⟩ + have h_src_shapefree_body : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars body ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars body := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_body]; exact h), + fun h => hmv (by rw [h_mod_body]; exact h)⟩ + -- === Loop output decomposition: havocs ++ [.loop g' none [] body₃ md]. === + -- body₁ = post-order hoist of body; σ₁ = its final gen state; E = harvest of + -- body₁ at σ₁; body₃ = applyRenames (substOf' E) body₂ where body₂ is the + -- lift residual. The output's renames equal substOf' E (entries_from_lift). + -- Abbreviations (no `set` tactic in this project): the post-order body, its + -- gen state, the harvest, and the rewritten loop body. + let body₁ : List (Stmt P (Cmd P)) := (Block.hoistLoopPrefixInitsM body σ).1 + let σ₁ : StringGenState := (Block.hoistLoopPrefixInitsM body σ).2 + let E : List (LoopInitHoistLoopDriver.Entry P) := + LoopInitHoistLoopDriver.Block.entriesOf body₁ σ₁ + let body₃ : List (Stmt P (Cmd P)) := + Block.applyRenames (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.1 + (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.2 + -- The hoisted loop residual. + have h_loop_out : + (Stmt.hoistLoopPrefixInitsM (Stmt.loop (.det g') none [] body md) σ).1 = + (Block.liftInitsInLoopBodyM body₁ σ₁).1.1.map Stmt.cmd ++ + [Stmt.loop (.det g') none [] body₃ md] := + Stmt.hoistLoopPrefixInitsM_loop_out (.det g') none [] body md σ + rw [h_loop_out] + -- The havocs (mapped to .cmd) equal havocStmts' E; renames equal substOf' E. + have h_harvest := LoopInitHoistLoopDriver.Block.lift_harvest_subst body₁ σ₁ + have h_havoc_eq : (Block.liftInitsInLoopBodyM body₁ σ₁).1.1.map Stmt.cmd = + LoopInitHoistLoopDriver.havocStmts' E := h_harvest.1 + have h_renames_eq : (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.1 = + LoopInitHoistLoopDriver.substOf' E := h_harvest.2 + rw [h_havoc_eq] + -- === Step A: the §E Block IH at the harvest `σ`, presented in the raw + -- ∀-shape `loop_arm_close` expects (both source- and hoist-side + -- `σ`-relative store-shape-freedom supplied directly per iteration). === + have stepA : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Block.initVars body, ρ_s.store y = none) → + (∀ y ∈ Block.initVars body, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) := by + intro ρ_s ρ_h h_hinv_i h_eval_i h_hf_i h_bnd_i h_Vs_i h_Vh_i h_src_sf_i h_hoist_sf_i ρ_s' h_run_i + obtain ⟨ρ_h', cfg_h, h_run_h, h_out⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst body σ + h_nd_body h_fd_body h_inv_body h_measure_body + h_exprs_shapefree_body h_unique_body h_fresh_body + h_names_fresh_A_body h_names_fresh_B_body + h_lhs_disjoint_body h_extra_disjoint_body h_mod_disjoint_A_body h_mod_disjoint_B_body + (fun y hy => h_Vs_i y hy) (fun y hy => h_Vh_i y hy) + h_src_sf_i h_hoist_sf_i + h_wf_σ h_src_fresh_body h_src_shapefree_body h_subst_wf h_hinv_i h_eval_i h_hf_i h_bnd_i + h_run_i (Or.inl ⟨ρ_s', rfl⟩) + h_wfvar h_wfcongr h_wfsubst h_wfdef + rcases h_out with ⟨r, hr1, hr2, hr3, hr4, hr5⟩ | ⟨l, r, hr1, _, _, _, _⟩ + · cases hr1; cases hr2 + exact ⟨ρ_h', h_run_h, hr3, hr4, hr5⟩ + · exact absurd hr1 (by rintro ⟨⟩) + -- === Step A (exiting): the §E Block IH at the harvest `σ`, presented in the + -- raw ∀-shape `loop_arm_close` expects for a body iteration that BREAKS + -- with a label. Same Block IH, dispatched with the `.exiting` `cfg_src` + -- disjunct; the `.terminal` output clause is impossible (`cfg_src` is + -- `.exiting`). A body `.exit` is admitted (no static no-exit guard is consumed). === + have stepA_exit : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Block.initVars body, ρ_s.store y = none) → + (∀ y ∈ Block.initVars body, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) := by + intro ρ_s ρ_h h_hinv_i h_eval_i h_hf_i h_bnd_i h_Vs_i h_Vh_i h_src_sf_i h_hoist_sf_i l ρ_s' h_run_i + obtain ⟨ρ_h', cfg_h, h_run_h, h_out⟩ := + Block.hoistLoopPrefixInits_preserves hQmint A B subst body σ + h_nd_body h_fd_body h_inv_body h_measure_body + h_exprs_shapefree_body h_unique_body h_fresh_body + h_names_fresh_A_body h_names_fresh_B_body + h_lhs_disjoint_body h_extra_disjoint_body h_mod_disjoint_A_body h_mod_disjoint_B_body + (fun y hy => h_Vs_i y hy) (fun y hy => h_Vh_i y hy) + h_src_sf_i h_hoist_sf_i + h_wf_σ h_src_fresh_body h_src_shapefree_body h_subst_wf h_hinv_i h_eval_i h_hf_i h_bnd_i + h_run_i (Or.inr ⟨l, ρ_s', rfl⟩) + h_wfvar h_wfcongr h_wfsubst h_wfdef + rcases h_out with ⟨r, hr1, _, _, _, _⟩ | ⟨l', r, hr1, hr2, hr3, hr4, hr5⟩ + · exact absurd hr1 (by rintro ⟨⟩) + · obtain ⟨hl_eq, hr_eq⟩ : l' = l ∧ r = ρ_s' := by + cases hr1; exact ⟨rfl, rfl⟩ + cases hl_eq; cases hr_eq; cases hr2 + exact ⟨ρ_h', h_run_h, hr3, hr4, hr5⟩ + -- === Step B: the lift renaming simulation at `body₁`'s own harvest carriers. === + have h_src_shapefree_body_iv : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars body := fun str h_suf => + (h_src_shapefree_body str h_suf).2.2.1 + -- Source-side modifiedVars-shape-freedom, projected from the threaded + -- 4-conjunct `h_src_shapefree_body`: a `Q`-kind string never names a + -- source set-target. + have h_mod_shapefree_body : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.modifiedVars body := fun str h_suf => + (h_src_shapefree_body str h_suf).2.2.2 + -- `targetsOf' E` are minted in the lift σ₁ → σ₂ (so ∉ stringGens σ₁) and are + -- `_`-suffix-shaped. `modifiedVars body₁` splits (by the post-order + -- pass's `modifiedVars` classification) into: ORIGINAL `.set` targets (members + -- of `modifiedVars body ++ initVars body`, suffix-free for a well-formed + -- source) and FRESH names from NESTED-loop init lifting (∈ stringGens σ₁). + -- Both classes are disjoint from the suffix-shaped, ∉-σ₁ targets. + have h_mod_disjoint_B1 : ∀ x ∈ Block.modifiedVars body₁, + x ∉ LoopInitHoistLoopDriver.targetsOf' E := + LoopInitHoistLoopArmWF.Block.modifiedVars_disjoint_targetsOf'_self hQmint body σ h_wf_σ + h_unique_body h_src_shapefree_body_iv h_mod_shapefree_body + -- `body₃` (arm-local) uses the lift's OWN renames `(lift body₁ σ₁).1.2.1`, + -- whereas `stepB_self_of_lift` produces `body₃` over `substOf' E`; the two + -- coincide by the harvest identity `h_renames_eq`. + have stepB : LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) + (LoopInitHoistLoopDriver.sourcesOf' E) (LoopInitHoistLoopDriver.targetsOf' E) + (LoopInitHoistLoopDriver.substOf' E) body₁ body₃ := by + have hB := + LoopInitHoistLoopArmWF.Block.stepB_self_of_lift hQmint (extendEval := extendEval) body σ h_wf_σ + h_nd_body h_fd_body h_inv_body h_measure_body h_unique_body + h_exprs_shapefree_body h_src_shapefree_body_iv h_mod_disjoint_B1 + h_wfvar h_wfcongr h_wfsubst h_wfdef + show LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) + (LoopInitHoistLoopDriver.sourcesOf' E) (LoopInitHoistLoopDriver.targetsOf' E) + (LoopInitHoistLoopDriver.substOf' E) body₁ + (Block.applyRenames (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.1 + (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.2) + rw [h_renames_eq] + exact hB + -- === Assemble the close. Abbreviations for the harvest carriers. === + have h_wf_σ₁ : StringGenState.WF σ₁ := + (Block.hoistLoopPrefixInitsM_genStep body σ).wf_mono h_wf_σ + -- Sources ⊆ initVars body₁; targets are `_`-suffixed and ∉ σ₁. + -- Source-side classification: each harvested source is ORIGINAL (∈ initVars + -- body) or FRESH (= ident str, `Q str`, ∈ σ₁ \ σ). + have h_src_class : ∀ a ∈ LoopInitHoistLoopDriver.sourcesOf' E, + (a ∈ Block.initVars body) ∨ + (∃ str : String, a = HasIdent.ident str ∧ Q str ∧ + str ∈ StringGenState.stringGens σ₁ ∧ str ∉ StringGenState.stringGens σ) := by + intro a ha + have h_a_in₁ : a ∈ Block.initVars body₁ := + LoopInitHoistLoopDriver.Block.sourcesOf_entriesOf_subset body₁ σ₁ a ha + have h_class := + (LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_initVars_classified hQmint body σ + h_wf_σ h_unique_body h_src_shapefree_body_iv).1 a h_a_in₁ + rcases h_class with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl h_o + · exact Or.inr ⟨str, he, hQ, hin, hnot⟩ + -- Each harvested target is `ident str` with `Q str` and ∉ σ₁ ⊇ σ. + have h_tgt_class : ∀ b ∈ LoopInitHoistLoopDriver.targetsOf' E, + ∃ str : String, b = HasIdent.ident str ∧ Q str ∧ + str ∉ StringGenState.stringGens σ₁ := by + intro b hb + obtain ⟨e, he_mem, he_eq⟩ := List.mem_map.mp hb + obtain ⟨str, h_b_eq, _, h_notσ₁⟩ := + (LoopInitHoistLoopArmWF.Block.entriesOf_targetGen body₁ σ₁ h_wf_σ₁).1 e he_mem + obtain ⟨str', h_eq', h_Q'⟩ := + LoopInitHoistLoopArmWF.Block.mem_targetsOf'_entriesOf_hasUnderscoreDigitSuffix + hQmint body₁ σ₁ hb + have h_b_eq' : b = HasIdent.ident str := he_eq.symm.trans h_b_eq + have h_id : (HasIdent.ident str' : P.Ident) = HasIdent.ident str := h_eq'.symm.trans h_b_eq' + have : str' = str := LawfulHasIdent.ident_inj h_id + exact ⟨str, h_b_eq', this ▸ h_Q', this ▸ h_notσ₁⟩ + -- Targets are undef at the source post-store (loop entry undef + no-exit). + -- Sources/targets disjoint from ambient A/B and from initVars body. + have h_As_notA : ∀ x ∈ LoopInitHoistLoopDriver.sourcesOf' E, x ∉ A := by + intro x hx + rcases h_src_class x hx with h_o | ⟨str, he, hsuf, _, _⟩ + · exact h_lhs_disjoint_body x h_o + · exact he ▸ (h_src_shapefree_body str hsuf).1 + have h_As_notB : ∀ x ∈ LoopInitHoistLoopDriver.sourcesOf' E, x ∉ B := by + intro x hx + rcases h_src_class x hx with h_o | ⟨str, he, hsuf, _, _⟩ + · exact h_extra_disjoint_body x h_o + · exact he ▸ (h_src_shapefree_body str hsuf).2.1 + have h_B_notAs : ∀ b ∈ B, b ∉ LoopInitHoistLoopDriver.sourcesOf' E := + fun b hb hmem => h_As_notB b hmem hb + have h_Bs_notB : ∀ b ∈ LoopInitHoistLoopDriver.targetsOf' E, b ∉ B := by + intro b hb + obtain ⟨str, he, hsuf, _⟩ := h_tgt_class b hb + exact he ▸ (h_src_shapefree_body str hsuf).2.1 + have h_B_notBs : ∀ b ∈ B, b ∉ LoopInitHoistLoopDriver.targetsOf' E := + fun b hb hmem => h_Bs_notB b hmem hb + have h_ss_wf : ∀ a b, (a, b) ∈ LoopInitHoistLoopDriver.substOf' E → + a ∈ LoopInitHoistLoopDriver.sourcesOf' E ∧ b ∈ LoopInitHoistLoopDriver.targetsOf' E := by + intro a b hab + obtain ⟨e, he, heq⟩ := List.mem_map.mp hab + cases heq + exact ⟨List.mem_map.mpr ⟨e, he, rfl⟩, List.mem_map.mpr ⟨e, he, rfl⟩⟩ + -- guard `g'` is shape-free: it never reads a `_`-suffixed ident. + have h_guard_sf : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ ExprOrNondet.getVars (ExprOrNondet.det g') := by + have h := h_exprs_shapefree + simp only [Block.exprsShapeFree, Stmt.exprsShapeFree] at h + exact h.1.1 + have h_guard_sf' : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ HasVarsPure.getVars g' := by + intro str h_suf + have := h_guard_sf str h_suf + rw [ExprOrNondet.getVars] at this; exact this + -- guard `g'` freshness from sources/targets. + -- Only the NON-`initVars body` sources need a static freshness witness; + -- `h_src_class` forces such a source into the FRESH (suffix-shaped) case, + -- discharged by guard shape-freedom. The `initVars body` sources are + -- handled inside the driver via the `Vs`-undef invariant: a body-init + -- name is undefined at every loop head, so an evaluating guard cannot + -- read it. + have h_g_As_minus_Vs_fresh : ∀ x ∈ LoopInitHoistLoopDriver.sourcesOf' E, + x ∉ Block.initVars body → x ∉ HasVarsPure.getVars g' := by + intro x hx hxVs + rcases h_src_class x hx with h_o | ⟨str, heq, hsuf, _, _⟩ + · exact absurd h_o hxVs + · exact heq ▸ h_guard_sf' str hsuf + have h_g_Bs_fresh : ∀ x ∈ LoopInitHoistLoopDriver.targetsOf' E, x ∉ HasVarsPure.getVars g' := by + intro x hx + obtain ⟨str, heq, hsuf, _⟩ := h_tgt_class x hx + exact heq ▸ h_guard_sf' str hsuf + -- `Vs := initVars body` disjoint from targets (program names vs suffix-shaped). + have h_Vs_notBs : ∀ y ∈ Block.initVars body, y ∉ LoopInitHoistLoopDriver.targetsOf' E := by + intro y hy hmem + obtain ⟨str, he, hsuf, _⟩ := h_tgt_class y hmem + exact (h_src_shapefree_body str hsuf).2.2.1 (he ▸ hy) + -- noFuncDecl facts. + have h_nofd_src : Block.noFuncDecl body = true := Block.noFuncDecl_of_not_containsFuncDecl body h_fd_body + have h_nofd_h : Block.noFuncDecl body₃ = true := by + show Block.noFuncDecl + (Block.applyRenames (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.1 + (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.2) = true + rw [h_renames_eq] + exact LoopInitHoistLoopArmWF.Block.stepB_noFuncDecl_h_of_lift hQmint body σ h_wf_σ + h_nd_body h_fd_body h_inv_body h_measure_body h_unique_body + h_exprs_shapefree_body h_src_shapefree_body_iv h_mod_disjoint_B1 + -- entry-undef of sources/targets at ρ_hoist (the harvest carriers are undef there). + have h_src_undef_h : ∀ e ∈ E, ρ_hoist.store e.1 = none := by + intro e he + have h_mem : e.1 ∈ LoopInitHoistLoopDriver.sourcesOf' E := List.mem_map.mpr ⟨e, he, rfl⟩ + rcases h_src_class e.1 h_mem with h_o | ⟨str, heq, hsuf, _, hnotσ⟩ + · exact h_hoist_undef_h_body e.1 h_o + · exact heq ▸ h_hoist_store_shapefree str hsuf hnotσ + have h_tgt_undef_h : ∀ e ∈ E, ρ_hoist.store e.2.1 = none := by + intro e he + have h_mem : e.2.1 ∈ LoopInitHoistLoopDriver.targetsOf' E := List.mem_map.mpr ⟨e, he, rfl⟩ + obtain ⟨str, heq, hsuf, hnotσ₁⟩ := h_tgt_class e.2.1 h_mem + exact heq ▸ h_hoist_store_shapefree str hsuf + (fun h => hnotσ₁ ((Block.hoistLoopPrefixInitsM_genStep body σ).subset h)) + -- source-store undef on the harvested sources (ORIGINAL ⇒ initVars body undef; + -- FRESH ⇒ suffix-shaped ∉ σ undef by the threaded store-shapefree). + have h_src_As_undef : ∀ a ∈ LoopInitHoistLoopDriver.sourcesOf' E, ρ_src.store a = none := by + intro a ha + rcases h_src_class a ha with h_o | ⟨str, he, hsuf, _, hnotσ⟩ + · exact h_hoist_undef_body a h_o + · exact he ▸ h_src_store_shapefree str hsuf hnotσ + -- post-store undef of sources/targets via `loopDet_preserves_none_terminal`. + -- No-exit-free: a `.terminal` source loop run keeps any loop-entry-undefined + -- carrier undefined (each iteration's `.none`-block projects undefined entries + -- back to `none`; an inner `.exiting` would propagate the loop to `.exiting`, + -- not `.terminal`). The source body need NOT be statically exit-free. + have h_post_src_none : ∀ (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g') none [] body md) ρ_src) (.terminal ρ_post) → + x ∈ LoopInitHoistLoopDriver.sourcesOf' E → ρ_post.store x = none := by + intro ρ_post x h_run hx + exact LoopInitHoistLoopDriver.loopDet_preserves_none_terminal (h_src_As_undef x hx) h_run + have h_post_tgt_none : ∀ (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g') none [] body md) ρ_src) (.terminal ρ_post) → + x ∈ LoopInitHoistLoopDriver.targetsOf' E → ρ_post.store x = none := by + intro ρ_post x h_run hx + refine LoopInitHoistLoopDriver.loopDet_preserves_none_terminal ?_ h_run + obtain ⟨str, he, hsuf, hnotσ₁⟩ := h_tgt_class x hx + exact he ▸ h_src_store_shapefree str hsuf + (fun h => hnotσ₁ ((Block.hoistLoopPrefixInitsM_genStep body σ).subset h)) + -- post-store undef of sources/targets on an EXITING source loop run. A body + -- `.exit` is ADMITTED: when some iteration breaks with a label, the loop reaches + -- `.exiting`. `loopDet_preserves_none_exiting` (no-exit-free) keeps any + -- loop-entry-undefined carrier undefined at the exit store — the same + -- per-iteration `projectStore` invariant, capped by the breaking iteration's + -- `.none`-block mismatch. These obligations feed the sum-typed driver's exit + -- branch, which now genuinely fires on a body `.exit`. + have h_post_src_none_exit : ∀ (lbl : String) (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g') none [] body md) ρ_src) (.exiting lbl ρ_post) → + x ∈ LoopInitHoistLoopDriver.sourcesOf' E → ρ_post.store x = none := by + intro lbl ρ_post x h_run hx + exact LoopInitHoistLoopDriver.loopDet_preserves_none_exiting (h_src_As_undef x hx) h_run + have h_post_tgt_none_exit : ∀ (lbl : String) (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g') none [] body md) ρ_src) (.exiting lbl ρ_post) → + x ∈ LoopInitHoistLoopDriver.targetsOf' E → ρ_post.store x = none := by + intro lbl ρ_post x h_run hx + refine LoopInitHoistLoopDriver.loopDet_preserves_none_exiting ?_ h_run + obtain ⟨str, he, hsuf, hnotσ₁⟩ := h_tgt_class x hx + exact he ▸ h_src_store_shapefree str hsuf + (fun h => hnotσ₁ ((Block.hoistLoopPrefixInitsM_genStep body σ).subset h)) + have h_tgt_nodup : (LoopInitHoistLoopDriver.targetsOf' E).Nodup := + (LoopInitHoistLoopArmWF.Block.entriesOf_targetGen body₁ σ₁ h_wf_σ₁).2 + -- σ_sf-relative source-store shape-freedom at ρ_src for the driver. + have h_arm_src_sf : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_src.store (HasIdent.ident (P := P) str) = none := + h_src_store_shapefree + have h_sf_notA : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → HasIdent.ident (P := P) str ∉ A := + fun str h_suf _ => (h_src_shapefree_body str h_suf).1 + have h_sf_notB : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → HasIdent.ident (P := P) str ∉ B := + fun str h_suf _ => (h_src_shapefree_body str h_suf).2.1 + -- === FAILING Step A: the body §E `_to_fail` at the harvest `σ`, in the raw + -- ∀-shape `loop_arm_close_fail` expects (a failing body run is matched by + -- a failing `body₁` run). === + have stepA_fail : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Block.initVars body, ρ_s.store y = none) → + (∀ y ∈ Block.initVars body, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) d' + ∧ d'.getEnv.hasFailure = true := by + intro ρ_s ρ_h h_hinv_i h_eval_i h_hf_i h_bnd_i h_Vs_i h_Vh_i h_src_sf_i h_hoist_sf_i d h_run_i hd_i + exact Block.hoistLoopPrefixInits_to_fail hQmint A B subst body σ + h_nd_body h_fd_body h_inv_body h_measure_body + h_exprs_shapefree_body h_unique_body h_fresh_body + h_names_fresh_A_body h_names_fresh_B_body + h_lhs_disjoint_body h_extra_disjoint_body h_mod_disjoint_A_body h_mod_disjoint_B_body + (fun y hy => h_Vs_i y hy) (fun y hy => h_Vh_i y hy) + h_src_sf_i h_hoist_sf_i + h_wf_σ h_src_fresh_body h_src_shapefree_body h_subst_wf h_hinv_i h_eval_i h_hf_i h_bnd_i + h_run_i hd_i h_wfvar h_wfcongr h_wfsubst h_wfdef + -- === FAILING Step B: the lift renaming `_to_fail` at `body₁`'s harvest + -- carriers (a failing `body₁` run is matched by a failing `body₃` run). === + have stepB_fail : OptEStepBProvider.BodySimFail (extendEval := extendEval) + (LoopInitHoistLoopDriver.sourcesOf' E) (LoopInitHoistLoopDriver.targetsOf' E) + (LoopInitHoistLoopDriver.substOf' E) body₁ body₃ := by + have hB := + LoopInitHoistLoopArmWF.Block.stepB_self_of_lift_fail hQmint (extendEval := extendEval) body σ h_wf_σ + h_nd_body h_fd_body h_inv_body h_measure_body h_unique_body + h_exprs_shapefree_body h_src_shapefree_body_iv h_mod_disjoint_B1 + h_wfvar h_wfcongr h_wfsubst h_wfdef + show OptEStepBProvider.BodySimFail (extendEval := extendEval) + (LoopInitHoistLoopDriver.sourcesOf' E) (LoopInitHoistLoopDriver.targetsOf' E) + (LoopInitHoistLoopDriver.substOf' E) body₁ + (Block.applyRenames (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.1 + (Block.liftInitsInLoopBodyM body₁ σ₁).1.2.2) + rw [h_renames_eq] + exact hB + exact LoopInitHoistLoopArmWF.loop_arm_close_fail (σ_sf := σ) (Vs := Block.initVars body) + (entries := E) (body := body) (body₁ := body₁) (body₃ := body₃) (g := g') (md := md) + stepA stepA_exit stepA_fail stepB stepB_fail + h_hoist_undef_body h_hoist_undef_h_body h_arm_src_sf h_sf_notA h_sf_notB + h_lhs_disjoint_body h_extra_disjoint_body h_Vs_notBs + h_subst_wf h_ss_wf h_As_notA h_As_notB h_B_notAs h_B_notBs h_Bs_notB + h_g_A_fresh h_g_B_fresh h_g_As_minus_Vs_fresh h_g_Bs_fresh + h_src_As_undef h_nofd_src h_nofd_h h_tgt_nodup + h_src_undef_h h_tgt_undef_h + h_wfvar h_wfcongr h_wfdef h_hinv h_eval_eq h_hf_eq h_hoist_bound h_run_src h_c_fail + termination_by sizeOf s + decreasing_by all_goals (subst h_match; simp_wf; omega) + + +/-- §E Block-level FAILING-config simulation (the `_to_fail` analogue of +`Block.hoistLoopPrefixInits_preserves`): a reachable failing source configuration +of `ss` is matched by a reachable failing configuration of the hoisted residual, +running both from the same `HoistInv`-related start. -/ +private theorem Block.hoistLoopPrefixInits_to_fail {Q : String → Prop} + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] + [HasIntOrder P] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + [DecidableEq P.Ident] + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {extendEval : ExtendEval P} + (A : List P.Ident) + (B : List P.Ident) + (subst : List (P.Ident × P.Ident)) + (ss : List (Stmt P (Cmd P))) + (σ : StringGenState) + {ρ_src ρ_hoist : Env P} + {cfg_src : Config P (Cmd P)} + (h_no_nd : Block.containsNondetLoop ss = false) + (h_no_fd : Block.containsFuncDecl ss = false) + (h_no_inv : Block.loopHasNoInvariants ss = true) + (h_no_measure : Block.loopMeasureNone ss = true) + (h_exprs_shapefree : Block.exprsShapeFree (P := P) Q ss) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_names_fresh : Block.namesFreshInExprs A ss = true) + (h_names_fresh_B : Block.namesFreshInExprs B ss = true) + (h_lhs_disjoint : ∀ y ∈ Block.initVars ss, y ∉ A) + (h_extra_disjoint : ∀ y ∈ Block.initVars ss, y ∉ B) + (h_mod_disjoint_A : ∀ x ∈ Block.modifiedVars ss, x ∉ A) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars ss, x ∉ B) + (h_hoist_undef : ∀ y ∈ Block.initVars ss, ρ_src.store y = none) + (h_hoist_undef_h : ∀ y ∈ Block.initVars ss, ρ_hoist.store y = none) + (h_src_store_shapefree : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_src.store (HasIdent.ident (P := P) str) = none) + (h_hoist_store_shapefree : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ → ρ_hoist.store (HasIdent.ident (P := P) str) = none) + (h_wf_σ : StringGenState.WF σ) + (h_src_namesFreshFromσ : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars ss) + (h_src_shapefree : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars ss ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval_eq : ρ_src.eval = ρ_hoist.eval) + (h_hf_eq : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_hoist_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ_src) cfg_src) + (h_c_fail : cfg_src.getEnv.hasFailure = true) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + ∃ d : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.hoistLoopPrefixInitsM ss σ).1 ρ_hoist) d + ∧ d.getEnv.hasFailure = true := by + classical + match h_match : ss with + | [] => + subst h_match + -- Empty block: the only reachable config has env `ρ_src`; failing forces + -- `ρ_src.hasFailure = true`, so the hoist empty residual's start fails. + refine ⟨.stmts (Block.hoistLoopPrefixInitsM ([] : List (Stmt P (Cmd P))) σ).1 ρ_hoist, .refl _, ?_⟩ + have h_ρs_fail : ρ_src.hasFailure = true := by + cases h_run_src with + | refl => simpa [Config.getEnv] using h_c_fail + | step _ _ _ h1 hr1 => + cases h1 + have h_d_eq : cfg_src = .terminal ρ_src := by + cases hr1 with + | refl => rfl + | step _ _ _ hd _ => exact nomatch hd + rw [h_d_eq] at h_c_fail; simpa [Config.getEnv] using h_c_fail + simpa [Config.getEnv] using (h_hf_eq ▸ h_ρs_fail) + | s :: rest => + subst h_match + -- === Decompose the MONADIC residual: head-at-σ ++ tail-at-σ1. === + have h_cons_out : + (Block.hoistLoopPrefixInitsM (s :: rest) σ).1 = + (Stmt.hoistLoopPrefixInitsM s σ).1 ++ + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).1 := + Block.hoistLoopPrefixInitsM_cons_out s rest σ + -- === Boolean precondition decomposition: [s] / rest from s::rest. === + have h_split_list : (s :: rest : List (Stmt P (Cmd P))) = [s] ++ rest := rfl + have h_nd_s : Block.containsNondetLoop [s] = false ∧ Block.containsNondetLoop rest = false := by + rw [h_split_list, Block.containsNondetLoop_append, Bool.or_eq_false_iff] at h_no_nd + exact h_no_nd + have h_fd_s : Block.containsFuncDecl [s] = false ∧ Block.containsFuncDecl rest = false := by + rw [h_split_list, Block.containsFuncDecl_append, Bool.or_eq_false_iff] at h_no_fd + exact h_no_fd + have h_inv_s : Block.loopHasNoInvariants [s] = true ∧ Block.loopHasNoInvariants rest = true := by + rw [h_split_list, Block.loopHasNoInvariants_append, Bool.and_eq_true] at h_no_inv + exact h_no_inv + have h_measure_s : Block.loopMeasureNone [s] = true ∧ Block.loopMeasureNone rest = true := by + rw [h_split_list, Block.loopMeasureNone_append, Bool.and_eq_true] at h_no_measure + exact h_no_measure + have h_exprs_shapefree_s : + Block.exprsShapeFree (P := P) Q [s] ∧ + Block.exprsShapeFree (P := P) Q rest := by + -- `Block.exprsShapeFree (s :: rest) = Stmt.exprsShapeFree s ∧ Block.exprsShapeFree rest` + -- and `Block.exprsShapeFree [s] = Stmt.exprsShapeFree s ∧ True`. + have h := h_exprs_shapefree + simp only [Block.exprsShapeFree] at h ⊢ + exact ⟨⟨h.1, True.intro⟩, h.2⟩ + have h_iv_split : Block.initVars (s :: rest) = Block.initVars [s] ++ Block.initVars rest := by + rw [h_split_list, Block.initVars_append] + have h_mod_split : Block.modifiedVars (s :: rest) = + Block.modifiedVars [s] ++ Block.modifiedVars rest := by + simp only [Block.modifiedVars, List.append_nil] + have h_unique_full : (Block.initVars [s] ++ Block.initVars rest).Nodup := by + have : Block.uniqueInits (s :: rest) = (Block.initVars (s :: rest)).Nodup := rfl + rw [this, h_iv_split] at h_unique; exact h_unique + have h_unique_s : Block.uniqueInits [s] := by + show (Block.initVars [s]).Nodup + exact (List.nodup_append.mp h_unique_full).1 + have h_unique_rest : Block.uniqueInits rest := by + show (Block.initVars rest).Nodup + exact (List.nodup_append.mp h_unique_full).2.1 + have h_fresh_unfold := h_fresh + unfold Block.hoistedNamesFreshInRhsAndGuards at h_fresh_unfold + have h_nf_cons : + Block.namesFreshInRhsExprs (Block.initVars (s :: rest)) (s :: rest) = + (Stmt.namesFreshInRhsExprs (Block.initVars (s :: rest)) s && + Block.namesFreshInRhsExprs (Block.initVars (s :: rest)) rest) := by + rw [Block.namesFreshInRhsExprs] + rw [h_nf_cons, Bool.and_eq_true] at h_fresh_unfold + obtain ⟨h_nf_s_full, h_nf_rest_full⟩ := h_fresh_unfold + have h_sub_s : (Block.initVars [s] : List P.Ident) ⊆ Block.initVars (s :: rest) := by + rw [h_iv_split]; exact fun _ h => List.mem_append.mpr (Or.inl h) + have h_sub_rest : (Block.initVars rest : List P.Ident) ⊆ Block.initVars (s :: rest) := by + rw [h_iv_split]; exact fun _ h => List.mem_append.mpr (Or.inr h) + have h_nf_s_block : Block.namesFreshInRhsExprs (Block.initVars (s :: rest)) [s] = true := by + simp only [Block.namesFreshInRhsExprs, Bool.and_true]; exact h_nf_s_full + have h_fresh_s : Block.hoistedNamesFreshInRhsAndGuards (P := P) [s] = true := by + unfold Block.hoistedNamesFreshInRhsAndGuards + exact Block.namesFreshInRhsExprs_subset h_sub_s [s] h_nf_s_block + have h_fresh_rest : Block.hoistedNamesFreshInRhsAndGuards (P := P) rest = true := by + unfold Block.hoistedNamesFreshInRhsAndGuards + exact Block.namesFreshInRhsExprs_subset h_sub_rest rest h_nf_rest_full + have h_names_fresh_cons : + Block.namesFreshInExprs A (s :: rest) = + (Stmt.namesFreshInExprs A s && Block.namesFreshInExprs A rest) := by + rw [Block.namesFreshInExprs] + rw [h_names_fresh_cons, Bool.and_eq_true] at h_names_fresh + obtain ⟨h_names_fresh_s_stmt, h_names_fresh_rest⟩ := h_names_fresh + have h_names_fresh_s : Block.namesFreshInExprs A [s] = true := by + simp only [Block.namesFreshInExprs, Bool.and_true]; exact h_names_fresh_s_stmt + have h_names_fresh_B_cons : + Block.namesFreshInExprs B (s :: rest) = + (Stmt.namesFreshInExprs B s && Block.namesFreshInExprs B rest) := by + rw [Block.namesFreshInExprs] + rw [h_names_fresh_B_cons, Bool.and_eq_true] at h_names_fresh_B + obtain ⟨h_names_fresh_B_s_stmt, h_names_fresh_B_rest⟩ := h_names_fresh_B + have h_names_fresh_B_s : Block.namesFreshInExprs B [s] = true := by + simp only [Block.namesFreshInExprs, Bool.and_true]; exact h_names_fresh_B_s_stmt + have h_lhs_disjoint_s : ∀ y ∈ Block.initVars [s], y ∉ A := fun y hy => + h_lhs_disjoint y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl hy)) + have h_lhs_disjoint_rest : ∀ y ∈ Block.initVars rest, y ∉ A := fun y hy => + h_lhs_disjoint y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy)) + have h_extra_disjoint_s : ∀ y ∈ Block.initVars [s], y ∉ B := fun y hy => + h_extra_disjoint y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl hy)) + have h_extra_disjoint_rest : ∀ y ∈ Block.initVars rest, y ∉ B := fun y hy => + h_extra_disjoint y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy)) + have h_mod_disjoint_A_s : ∀ x ∈ Block.modifiedVars [s], x ∉ A := fun x hx => + h_mod_disjoint_A x (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inl hx)) + have h_mod_disjoint_A_rest : ∀ x ∈ Block.modifiedVars rest, x ∉ A := fun x hx => + h_mod_disjoint_A x (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inr hx)) + have h_mod_disjoint_B_s : ∀ x ∈ Block.modifiedVars [s], x ∉ B := fun x hx => + h_mod_disjoint_B x (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inl hx)) + have h_mod_disjoint_B_rest : ∀ x ∈ Block.modifiedVars rest, x ∉ B := fun x hx => + h_mod_disjoint_B x (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inr hx)) + have h_hoist_undef_s : ∀ y ∈ Block.initVars [s], ρ_src.store y = none := fun y hy => + h_hoist_undef y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl hy)) + have h_hoist_undef_h_s : ∀ y ∈ Block.initVars [s], ρ_hoist.store y = none := fun y hy => + h_hoist_undef_h y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl hy)) + have h_src_fresh_s : + ∀ str ∈ StringGenState.stringGens σ, + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars [s] := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl h))⟩ + have h_src_shapefree_s : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars [s] ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars [s] := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl h)), + fun h => hmv (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inl h))⟩ + have h_src_shapefree_rest : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars rest ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars rest := by + intro str hstr + obtain ⟨hA, hB, hiv, hmv⟩ := h_src_shapefree str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr h)), + fun h => hmv (by rw [h_mod_split]; exact List.mem_append.mpr (Or.inr h))⟩ + have h_genStep_head : StringGenState.GenStep σ (Stmt.hoistLoopPrefixInitsM s σ).2 := + Stmt.hoistLoopPrefixInitsM_genStep s σ + have h_wf_σ1 : StringGenState.WF (Stmt.hoistLoopPrefixInitsM s σ).2 := + h_genStep_head.wf_mono h_wf_σ + have h_src_fresh_σ1 : + SrcNamesFreshFromGen (P := P) A B (Block.initVars rest) + (Stmt.hoistLoopPrefixInitsM s σ).2 := by + have h_fresh_σ_rest : SrcNamesFreshFromGen (P := P) A B (Block.initVars rest) σ := by + intro str hstr + obtain ⟨hA, hB, hiv⟩ := h_src_namesFreshFromσ str hstr + exact ⟨hA, hB, fun h => hiv (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr h))⟩ + exact SrcNamesFreshFromGen.genStep_of_delta + (Stmt.hoistLoopPrefixInitsM_genStep_delta_Q hQmint s σ) + (fun str hsuf => let ⟨a, b, c, _⟩ := h_src_shapefree_rest str hsuf; ⟨a, b, c⟩) h_fresh_σ_rest + have h_src_fresh_rest : + ∀ str ∈ StringGenState.stringGens (Stmt.hoistLoopPrefixInitsM s σ).2, + HasIdent.ident (P := P) str ∉ A ∧ + HasIdent.ident (P := P) str ∉ B ∧ + HasIdent.ident (P := P) str ∉ Block.initVars rest := h_src_fresh_σ1 + -- === Split the SOURCE failing run: HEAD fails, or HEAD terminates + TAIL fails. === + rw [h_cons_out] + have h_nd_stmt : Stmt.containsNondetLoop s = false := by + rw [Block.containsNondetLoop, Bool.or_eq_false_iff] at h_nd_s; exact h_nd_s.1.1 + have h_fd_stmt : Stmt.containsFuncDecl s = false := by + rw [Block.containsFuncDecl, Bool.or_eq_false_iff] at h_fd_s; exact h_fd_s.1.1 + have h_inv_stmt : Stmt.loopHasNoInvariants s = true := by + rw [Block.loopHasNoInvariants, Bool.and_eq_true] at h_inv_s; exact h_inv_s.1.1 + have h_measure_stmt : Stmt.loopMeasureNone s = true := by + rw [Block.loopMeasureNone, Bool.and_eq_true] at h_measure_s; exact h_measure_s.1.1 + have h_residual_nofd : + Block.noFuncDecl (Stmt.hoistLoopPrefixInitsM s σ).1 = true := by + apply Block.noFuncDecl_of_not_containsFuncDecl + rw [Stmt.hoistLoopPrefixInitsM_containsFuncDecl]; exact h_fd_stmt + rcases stmts_cons_reaches_failing' P (EvalCmd P) extendEval (reflTrans_to_T h_run_src) h_c_fail with + ⟨d_head, h_head_run, hd_head⟩ | ⟨ρ_s_mid, d_tail, h_head_stmt, h_tail_run, hd_tail⟩ + · -- HEAD fails: recurse the Stmt-level `_to_fail` on the head, then lift the + -- failing head residual into the cons residual (`stmts_prefix_failing_append`). + obtain ⟨d', h_head_h, hd'⟩ := + Stmt.hoistLoopPrefixInits_to_fail hQmint A B subst s σ + h_nd_stmt h_fd_stmt h_inv_stmt h_measure_stmt h_exprs_shapefree_s.1 h_unique_s h_fresh_s + h_names_fresh_s h_names_fresh_B_s h_lhs_disjoint_s h_extra_disjoint_s + h_mod_disjoint_A_s h_mod_disjoint_B_s h_hoist_undef_s h_hoist_undef_h_s + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_s h_src_shapefree_s h_subst_wf h_hinv h_eval_eq h_hf_eq h_hoist_bound + h_head_run hd_head h_wfvar h_wfcongr h_wfsubst h_wfdef + exact stmts_prefix_failing_append P (EvalCmd P) extendEval + (Stmt.hoistLoopPrefixInitsM s σ).1 + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).1 + ρ_hoist d' h_head_h hd' + · -- HEAD terminates at `ρ_s_mid`, TAIL fails: run the head ENDPOINT sim to + -- re-establish the invariant at the hoist mid env, recurse the Block-level + -- `_to_fail` on the tail, then splice the (terminal) head residual run. + obtain ⟨ρ_h_mid, cfg_h_head, h_head_hoist, h_head_outcome⟩ := + Stmt.hoistLoopPrefixInits_preserves hQmint A B subst s σ + h_nd_stmt h_fd_stmt h_inv_stmt h_measure_stmt h_exprs_shapefree_s.1 h_unique_s h_fresh_s + h_names_fresh_s h_names_fresh_B_s h_lhs_disjoint_s h_extra_disjoint_s + h_mod_disjoint_A_s h_mod_disjoint_B_s h_hoist_undef_s h_hoist_undef_h_s + h_src_store_shapefree h_hoist_store_shapefree + h_wf_σ h_src_fresh_s h_src_shapefree_s h_subst_wf h_hinv h_eval_eq h_hf_eq h_hoist_bound + h_head_stmt (Or.inl ⟨ρ_s_mid, rfl⟩) h_wfvar h_wfcongr h_wfsubst h_wfdef + obtain ⟨h_cfg_h_eq, h_hinv_mid, h_hf_mid, h_bound_mid⟩ : + cfg_h_head = .terminal ρ_h_mid ∧ + HoistInv (P := P) A B subst ρ_s_mid.store ρ_h_mid.store ∧ + ρ_s_mid.hasFailure = ρ_h_mid.hasFailure ∧ (∀ y ∈ B, ρ_h_mid.store y ≠ none) := by + rcases h_head_outcome with ⟨r, hr1, hr2, hr3, hr4, hr5⟩ | ⟨l, r, hr1, _, _, _, _⟩ + · have hr_eq : r = ρ_s_mid := by + simp only [Config.terminal.injEq] at hr1; exact hr1.symm + subst hr_eq; exact ⟨hr2, hr3, hr4, hr5⟩ + · exact absurd hr1 (by simp) + subst h_cfg_h_eq + have h_src_s_nofd : Stmt.noFuncDecl s = true := + Stmt.noFuncDecl_of_not_containsFuncDecl s h_fd_stmt + have h_src_mid_eval : ρ_s_mid.eval = ρ_src.eval := + smallStep_noFuncDecl_preserves_eval P (EvalCmd P) extendEval s ρ_src ρ_s_mid + h_src_s_nofd h_head_stmt + have h_h_mid_eval : ρ_h_mid.eval = ρ_hoist.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + (Stmt.hoistLoopPrefixInitsM s σ).1 ρ_hoist ρ_h_mid h_residual_nofd h_head_hoist + have h_eval_mid : ρ_s_mid.eval = ρ_h_mid.eval := by + rw [h_src_mid_eval, h_h_mid_eval, h_eval_eq] + have h_hoist_undef_mid : ∀ y ∈ Block.initVars rest, ρ_s_mid.store y = none := by + intro y hy + have h_y_src_none : ρ_src.store y = none := + h_hoist_undef y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy)) + have h_y_not_init_s : y ∉ Block.initVars [s] := fun hc => + (List.nodup_append.mp h_unique_full).2.2 y hc y hy rfl + have h_y_not_def_s : y ∉ Stmt.definedVars (P := P) (C := Cmd P) s := by + rw [Stmt.definedVars_eq_initVars_of_no_fd s h_fd_stmt] + intro hc + exact h_y_not_init_s (by simp only [Block.initVars, List.append_nil]; exact hc) + exact stmt_run_terminal_preserves_none h_y_src_none h_y_not_def_s h_head_stmt + have h_hoist_undef_h_mid : ∀ y ∈ Block.initVars rest, ρ_h_mid.store y = none := by + intro y hy + have h_y_h_none : ρ_hoist.store y = none := + h_hoist_undef_h y (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy)) + have h_unique_s_stmt : (Stmt.initVars s).Nodup := by + have : (Block.initVars [s]).Nodup := h_unique_s + simpa only [Block.initVars, List.append_nil] using this + have h_shapefree_s_stmt : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s := by + intro str h_shape hc + exact (h_src_shapefree_s str h_shape).2.2.1 + (by simp only [Block.initVars, List.append_nil]; exact hc) + have h_y_not_src : y ∉ Stmt.initVars s := fun hc => + (List.nodup_append.mp h_unique_full).2.2 y + (by simp only [Block.initVars, List.append_nil]; exact hc) y hy rfl + have h_y_shapefree : ∀ str : String, y = HasIdent.ident str → + ¬ Q str := by + intro str h_y_eq h_shape + exact (h_src_shapefree str h_shape).2.2.1 + (h_y_eq ▸ (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inr hy))) + exact residual_run_terminal_preserves_none hQmint h_wf_σ h_unique_s_stmt + h_shapefree_s_stmt h_fd_stmt h_y_not_src h_y_shapefree h_y_h_none h_head_hoist + -- Mid-store store-shapefree (σ1-relative) for the tail: same derivation as the + -- terminal branch — the head run defines no `Q`-kind name `str ∉ stringGens σ1`. + have h_src_store_shapefree_mid : ∀ str : String, Q str → + str ∉ StringGenState.stringGens (Stmt.hoistLoopPrefixInitsM s σ).2 → + ρ_s_mid.store (HasIdent.ident (P := P) str) = none := by + intro str h_shape h_notσ1 + have h_notσ : str ∉ StringGenState.stringGens σ := + fun h => h_notσ1 (h_genStep_head.subset h) + have h_z_src_none : ρ_src.store (HasIdent.ident (P := P) str) = none := + h_src_store_shapefree str h_shape h_notσ + have h_z_not_def_s : + HasIdent.ident (P := P) str ∉ Stmt.definedVars (P := P) (C := Cmd P) s := by + rw [Stmt.definedVars_eq_initVars_of_no_fd s h_fd_stmt] + intro hc + exact (h_src_shapefree str h_shape).2.2.1 + (by rw [h_iv_split]; exact List.mem_append.mpr (Or.inl + (by simp only [Block.initVars, List.append_nil]; exact hc))) + exact stmt_run_terminal_preserves_none h_z_src_none h_z_not_def_s h_head_stmt + have h_hoist_store_shapefree_mid : ∀ str : String, Q str → + str ∉ StringGenState.stringGens (Stmt.hoistLoopPrefixInitsM s σ).2 → + ρ_h_mid.store (HasIdent.ident (P := P) str) = none := by + intro str h_shape h_notσ1 + have h_notσ : str ∉ StringGenState.stringGens σ := + fun h => h_notσ1 (h_genStep_head.subset h) + have h_z_h_none : ρ_hoist.store (HasIdent.ident (P := P) str) = none := + h_hoist_store_shapefree str h_shape h_notσ + have h_unique_s_stmt : (Stmt.initVars s).Nodup := by + have : (Block.initVars [s]).Nodup := h_unique_s + simpa only [Block.initVars, List.append_nil] using this + have h_shapefree_s_stmt : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s := by + intro str' h_shape' hc + exact (h_src_shapefree_s str' h_shape').2.2.1 + (by simp only [Block.initVars, List.append_nil]; exact hc) + have h_z_not_residual : + HasIdent.ident (P := P) str ∉ Block.initVars (Stmt.hoistLoopPrefixInitsM s σ).1 := by + intro h_mem + have h_class := + (LoopInitHoistLoopArmWF.Stmt.hoistLoopPrefixInitsM_initVars_classified + hQmint s σ h_wf_σ h_unique_s_stmt h_shapefree_s_stmt).1 _ h_mem + rcases h_class with h_orig | ⟨str', h_eq, h_str'_in, _, _⟩ + · exact h_shapefree_s_stmt str h_shape h_orig + · exact h_notσ1 ((LawfulHasIdent.ident_inj h_eq) ▸ h_str'_in) + have h_residual_contains_nofd : + Block.containsFuncDecl (Stmt.hoistLoopPrefixInitsM s σ).1 = false := by + rw [Stmt.hoistLoopPrefixInitsM_containsFuncDecl]; exact h_fd_stmt + exact block_run_terminal_preserves_none_of_not_initVars + h_residual_contains_nofd h_z_not_residual h_z_h_none h_head_hoist + obtain ⟨d', h_tail_h, hd'⟩ := + Block.hoistLoopPrefixInits_to_fail hQmint A B subst rest (Stmt.hoistLoopPrefixInitsM s σ).2 + h_nd_s.2 h_fd_s.2 h_inv_s.2 h_measure_s.2 h_exprs_shapefree_s.2 h_unique_rest h_fresh_rest + h_names_fresh_rest h_names_fresh_B_rest h_lhs_disjoint_rest h_extra_disjoint_rest + h_mod_disjoint_A_rest h_mod_disjoint_B_rest h_hoist_undef_mid h_hoist_undef_h_mid + h_src_store_shapefree_mid h_hoist_store_shapefree_mid + h_wf_σ1 h_src_fresh_rest h_src_shapefree_rest h_subst_wf h_hinv_mid h_eval_mid h_hf_mid h_bound_mid + h_tail_run hd_tail h_wfvar h_wfcongr h_wfsubst h_wfdef + refine ⟨d', ?_, hd'⟩ + exact ReflTrans_Transitive _ _ _ _ + (stmts_prefix_terminal_append P (EvalCmd P) extendEval + (Stmt.hoistLoopPrefixInitsM s σ).1 + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).1 + ρ_hoist ρ_h_mid h_head_hoist) h_tail_h + termination_by sizeOf ss + decreasing_by all_goals (subst h_match; simp_wf; omega) + +end + + +/-! ### The loop-init-hoist label *kind* + +`hoistLoopPrefixInits` mints labels under exactly one prefix, `hoistFreshPrefix` +(`"_hoist"`). `hoistKind s` is the precise predicate "`s` is a label this pass +could have minted": it carries the `hoistFreshPrefix` generator prefix and is +equal to some `gen` output. This is the per-kind `Q` to instantiate the +kind-generalized soundness at, replacing the blanket `HasUnderscoreDigitSuffix` +(which would overcommit a composition partner to keeping *every* gen-shaped name +fresh). -/ + +/-- A label that `hoistLoopPrefixInits` could have minted: it carries the +`hoistFreshPrefix` generator prefix and equals a corresponding `gen` output. -/ +@[expose] def hoistKind (s : String) : Prop := + ∃ sg, String.HasGenPrefix hoistFreshPrefix s + ∧ s = (StringGenState.gen hoistFreshPrefix sg).1 + +/-- The single prefix `hoistLoopPrefixInits` mints under lands inside +`hoistKind`: this is exactly the `hQmint` obligation at `Q := hoistKind`. -/ +theorem hoistKind_gen : + ∀ sg, hoistKind (StringGenState.gen hoistFreshPrefix sg).1 := + fun sg => ⟨sg, StringGenState.gen_hasGenPrefix hoistFreshPrefix sg, rfl⟩ + +/-- Kind-generalized soundness of the loop-init hoist: the pass is sound for any +source program whose `hoistKind`-labelled slots are undefined / unwritten — only +the labels *this* pass mints, not every gen-shaped name. This weaker entry +precondition is what lets a composition partner (one minting under a disjoint +prefix) satisfy it vacuously. Instantiating `Q := String.HasUnderscoreDigitSuffix` +recovers the blanket `hoistLoopPrefixInits_preserves`. -/ +theorem hoistLoopPrefixInits_preserves_kind {Q : String → Prop} + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] + [HasIntOrder P] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + [DecidableEq P.Ident] + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {extendEval : ExtendEval P} + (ss : List (Stmt P (Cmd P))) + {ρ_src ρ_src' : Env P} + (h_no_nd : Block.containsNondetLoop ss = false) + (h_no_fd : Block.containsFuncDecl ss = false) + (h_no_inv : Block.loopHasNoInvariants ss = true) + (h_no_measure : Block.loopMeasureNone ss = true) + (h_exprs_shapefree : Block.exprsShapeFree (P := P) Q ss) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_src_initVars_shapefree : + StructuredToUnstructuredCorrect.NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_src_modifiedVars_shapefree : + StructuredToUnstructuredCorrect.NoGenSuffix (P := P) Q (Block.modifiedVars ss)) + (h_hoist_undef : ∀ y ∈ Block.initVars ss, ρ_src.store y = none) + (h_src_store_shapefree : NoGenStore (P := P) Q ρ_src) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ_src) (.terminal ρ_src')) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + ∃ ρ_h', + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.hoistLoopPrefixInits ss) ρ_src) (.terminal ρ_h') + ∧ StoreAgreement ρ_src'.store ρ_h'.store + ∧ ρ_h'.hasFailure = ρ_src'.hasFailure := by + -- Discharge §F by invoking the widened §E Block sibling at `A := []`, `B := []`, + -- `subst := []`, `σ := emp`, with `ρ_hoist := ρ_src` (no hoisting at the + -- outermost call site). The σ-relative obligations collapse at `emp` (its + -- `stringGens` is empty) to the global front-end kind-freedom facts. + -- The §E Block sibling's separate `h_names_fresh A`/`h_names_fresh_B` slots take + -- the FULL `namesFreshInExprs` (where the guard clause is load-bearing) at the + -- hoist-accumulated names `A`/`B`; at the outermost call site `A = B = []`, so + -- they are vacuously true and need no input from `h_fresh`. + have h_names_fresh_nil : Block.namesFreshInExprs (P := P) [] ss = true := + Block.namesFreshInExprs_nil ss + have h_lhs_disjoint_nil : ∀ y ∈ Block.initVars (P := P) ss, y ∉ ([] : List P.Ident) := + fun _ _ => List.not_mem_nil + have h_mod_disjoint_nil : ∀ x ∈ Block.modifiedVars (P := P) (C := Cmd P) ss, x ∉ ([] : List P.Ident) := + fun _ _ => List.not_mem_nil + have h_hinv_refl : HoistInv (P := P) [] [] [] ρ_src.store ρ_src.store := + HoistInv.refl_id [] ρ_src.store + have h_hoist_bound_nil : ∀ y ∈ ([] : List P.Ident), ρ_src.store y ≠ none := + fun _ h => absurd h (List.not_mem_nil) + have h_wf_emp : StringGenState.WF StringGenState.emp := StringGenState.wf_emp + have h_src_fresh_emp : + ∀ str ∈ StringGenState.stringGens StringGenState.emp, + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ Block.initVars (P := P) ss := by + intro str h_str + exact absurd h_str (StringGenState.not_mem_stringGens_emp str) + have h_src_shapefree_F : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ Block.initVars (P := P) ss ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars (P := P) ss := + fun str h_shape => + ⟨List.not_mem_nil, List.not_mem_nil, + h_src_initVars_shapefree str h_shape, + h_src_modifiedVars_shapefree str h_shape⟩ + have h_subst_wf_nil : + ∀ a b : P.Ident, (a, b) ∈ ([] : List (P.Ident × P.Ident)) → a ∈ ([] : List P.Ident) ∧ b ∈ ([] : List P.Ident) := + fun _ _ h => absurd h List.not_mem_nil + have h_src_store_shapefree_emp : + ∀ str : String, Q str → + str ∉ StringGenState.stringGens StringGenState.emp → + ρ_src.store (HasIdent.ident (P := P) str) = none := + fun str h_shape _ => h_src_store_shapefree str h_shape + obtain ⟨ρ_h', cfg_hoist, h_run_h, h_disj⟩ := + Block.hoistLoopPrefixInits_preserves hQmint (extendEval := extendEval) [] [] [] ss + StringGenState.emp + h_no_nd h_no_fd h_no_inv h_no_measure h_exprs_shapefree h_unique h_fresh + h_names_fresh_nil h_names_fresh_nil h_lhs_disjoint_nil h_lhs_disjoint_nil + h_mod_disjoint_nil h_mod_disjoint_nil + h_hoist_undef h_hoist_undef h_src_store_shapefree_emp h_src_store_shapefree_emp + h_wf_emp h_src_fresh_emp h_src_shapefree_F h_subst_wf_nil + h_hinv_refl rfl rfl h_hoist_bound_nil + h_run_src (Or.inl ⟨ρ_src', rfl⟩) h_wfvar h_wfcongr h_wfsubst h_wfdef + rcases h_disj with + ⟨ρ_src'', h_eq_src, h_eq_hoist, h_hinv_final, h_hf_final, _⟩ + | ⟨_, _, h_eq_src_e, _⟩ + · cases h_eq_src + subst h_eq_hoist + exact ⟨ρ_h', h_run_h, HoistInv.to_storeAgreement_nil h_hinv_final, h_hf_final.symm⟩ + · exact absurd h_eq_src_e (by simp) + +/-- Escaping companion of `hoistLoopPrefixInits_preserves_kind`: surfaces the +banked exiting arm of the §E mutual. Every escaping source run of `ss` +(reaching `.exiting lbl ρ_src'`) admits a corresponding escaping hoisted run to +the *same* label with a pointwise-agreeing final store and the same `hasFailure` +flag. Identical to the terminal entry except it feeds the `.exiting` source-run +disjunct to `Block.hoistLoopPrefixInits_preserves` and reads its exiting arm. +The `NoGenStore`/`NoGenSuffix` preconditions unfold to the per-kind freshness +facts the §E mutual consumes. -/ +theorem hoistLoopPrefixInits_preserves_kind_exit {Q : String → Prop} + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] + [HasIntOrder P] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + [DecidableEq P.Ident] + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {extendEval : ExtendEval P} + (ss : List (Stmt P (Cmd P))) + {ρ_src ρ_src' : Env P} + (h_no_nd : Block.containsNondetLoop ss = false) + (h_no_fd : Block.containsFuncDecl ss = false) + (h_no_inv : Block.loopHasNoInvariants ss = true) + (h_no_measure : Block.loopMeasureNone ss = true) + (h_exprs_shapefree : Block.exprsShapeFree (P := P) Q ss) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_src_initVars_shapefree : + StructuredToUnstructuredCorrect.NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_src_modifiedVars_shapefree : + StructuredToUnstructuredCorrect.NoGenSuffix (P := P) Q (Block.modifiedVars ss)) + (h_hoist_undef : ∀ y ∈ Block.initVars ss, ρ_src.store y = none) + (h_src_store_shapefree : NoGenStore (P := P) Q ρ_src) + (lbl : String) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ_src) (.exiting lbl ρ_src')) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + ∃ ρ_h', + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.hoistLoopPrefixInits ss) ρ_src) (.exiting lbl ρ_h') + ∧ StoreAgreement ρ_src'.store ρ_h'.store + ∧ ρ_h'.hasFailure = ρ_src'.hasFailure := by + -- Discharge §F by invoking the widened §E Block sibling at `A := []`, `B := []`, + -- `subst := []`, `σ := emp`, with `ρ_hoist := ρ_src` (no hoisting at the + -- outermost call site). The σ-relative obligations collapse at `emp` (its + -- `stringGens` is empty) to the global front-end kind-freedom facts. + -- The §E Block sibling's separate `h_names_fresh A`/`h_names_fresh_B` slots take + -- the FULL `namesFreshInExprs` (where the guard clause is load-bearing) at the + -- hoist-accumulated names `A`/`B`; at the outermost call site `A = B = []`, so + -- they are vacuously true and need no input from `h_fresh`. + have h_names_fresh_nil : Block.namesFreshInExprs (P := P) [] ss = true := + Block.namesFreshInExprs_nil ss + have h_lhs_disjoint_nil : ∀ y ∈ Block.initVars (P := P) ss, y ∉ ([] : List P.Ident) := + fun _ _ => List.not_mem_nil + have h_mod_disjoint_nil : ∀ x ∈ Block.modifiedVars (P := P) (C := Cmd P) ss, x ∉ ([] : List P.Ident) := + fun _ _ => List.not_mem_nil + have h_hinv_refl : HoistInv (P := P) [] [] [] ρ_src.store ρ_src.store := + HoistInv.refl_id [] ρ_src.store + have h_hoist_bound_nil : ∀ y ∈ ([] : List P.Ident), ρ_src.store y ≠ none := + fun _ h => absurd h (List.not_mem_nil) + have h_wf_emp : StringGenState.WF StringGenState.emp := StringGenState.wf_emp + have h_src_fresh_emp : + ∀ str ∈ StringGenState.stringGens StringGenState.emp, + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ Block.initVars (P := P) ss := by + intro str h_str + exact absurd h_str (StringGenState.not_mem_stringGens_emp str) + have h_src_shapefree_F : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ Block.initVars (P := P) ss ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars (P := P) ss := + fun str h_shape => + ⟨List.not_mem_nil, List.not_mem_nil, + h_src_initVars_shapefree str h_shape, + h_src_modifiedVars_shapefree str h_shape⟩ + have h_subst_wf_nil : + ∀ a b : P.Ident, (a, b) ∈ ([] : List (P.Ident × P.Ident)) → a ∈ ([] : List P.Ident) ∧ b ∈ ([] : List P.Ident) := + fun _ _ h => absurd h List.not_mem_nil + have h_src_store_shapefree_emp : + ∀ str : String, Q str → + str ∉ StringGenState.stringGens StringGenState.emp → + ρ_src.store (HasIdent.ident (P := P) str) = none := + fun str h_shape _ => h_src_store_shapefree str h_shape + obtain ⟨ρ_h', cfg_hoist, h_run_h, h_disj⟩ := + Block.hoistLoopPrefixInits_preserves hQmint (extendEval := extendEval) [] [] [] ss + StringGenState.emp + h_no_nd h_no_fd h_no_inv h_no_measure h_exprs_shapefree h_unique h_fresh + h_names_fresh_nil h_names_fresh_nil h_lhs_disjoint_nil h_lhs_disjoint_nil + h_mod_disjoint_nil h_mod_disjoint_nil + h_hoist_undef h_hoist_undef h_src_store_shapefree_emp h_src_store_shapefree_emp + h_wf_emp h_src_fresh_emp h_src_shapefree_F h_subst_wf_nil + h_hinv_refl rfl rfl h_hoist_bound_nil + h_run_src (Or.inr ⟨lbl, ρ_src', rfl⟩) h_wfvar h_wfcongr h_wfsubst h_wfdef + rcases h_disj with + ⟨_, h_eq_src_t, _⟩ + | ⟨lbl', ρ_src'', h_eq_src, h_eq_hoist, h_hinv_final, h_hf_final, _⟩ + · exact absurd h_eq_src_t (by simp) + · -- .exiting lbl ρ_src' = .exiting lbl' ρ_src'' fixes lbl' = lbl and ρ_src'' = ρ_src'. + simp only [Config.exiting.injEq] at h_eq_src + obtain ⟨h_lbl_eq, h_env_eq⟩ := h_eq_src + subst h_lbl_eq; subst h_env_eq + subst h_eq_hoist + exact ⟨ρ_h', h_run_h, HoistInv.to_storeAgreement_nil h_hinv_final, h_hf_final.symm⟩ + +/-! ## §F — Top-level forward-simulation theorem + +Stated with full Phase 8 signature. The proof is a direct invocation of the +§E Block-level mutual sibling `Block.hoistLoopPrefixInits_preserves` at +`cfg_src := .terminal ρ_src'`. The §E mutual is fully discharged (every arm, +including `.loop`), so §F is unconditionally discharged. -/ + +/-- Phase 8 top-level theorem: `Block.hoistLoopPrefixInits` is a forward +simulation. Every terminating source run admits a corresponding terminating +hoisted run that produces a pointwise-equal final store and the same +`hasFailure` flag. + +Preconditions (front-end shape, all already enforced upstream of the +hoisting pass entry): +* `h_no_nd` — no `.loop _ .nondet ...` anywhere +* `h_no_fd` — no `.funcDecl ...` anywhere +* `h_no_inv` — no `.loop` carries a non-empty `invariants` list +* `h_no_measure` — no `.loop` carries an explicit termination measure +* `h_unique` — `.init` LHS uniqueness across the program +* `h_fresh` — hoisted names are fresh in every guard and RHS expression + they would be moved past +* `h_src_initVars_shapefree` — no `.init` LHS name is the image (under + `HasIdent.ident`) of a string carrying the generator's + `_` suffix shape. This is the legitimate front-end + well-formedness assumption that source identifiers never + collide with the freshly-minted names the hoisting pass's + string generator produces; it discharges the §E + `h_src_shapefree` obligation at the `A = B = []` entry. +* `h_src_modifiedVars_shapefree` — no `.set` LHS name (the source program's + modified vars) is the image of a suffix-shaped string. Same + front-end well-formedness class as `h_src_initVars_shapefree`: + a source `set _hoist_0 := …` would collide with a generated + loop-rename target and miscompile. Used by the `.loop` arm's + `modifiedVars body₁ ∩ targetsOf' E = ∅` obligation. +* `h_hoist_undef` — every name introduced by an `.init` (and therefore + eligible for hoisting) is unbound in `ρ_src`. This is + the runtime-shape precondition consumed by the §E + `.loop` arm via `prelude_execution`. + +Plus two semantic well-formedness preconditions for the underlying step +relation (matching the LoopInitHoistInfra convention): +* `h_wfvar` — every environment's `eval` respects variable extension +* `h_wfcongr` — every environment's `eval` respects congruence under + pointwise store equality. + +Conclusion: there exists a hoisted-side terminating run whose store agrees +with the source store on every source-defined variable (`StoreAgreement`, +i.e. semantics preservation modulo the freshly-hoisted variables) and which +carries the same `hasFailure` value. Exact pointwise equality does NOT hold +in general — the hoisting pass introduces fresh `_hoist`-suffixed targets +that are defined only in the hoisted store. + +**Status:** discharged via the §E Block-IH at `cfg_src := .terminal ρ_src'`, +projecting the terminal disjunct of the sum-typed conclusion. The §E mutual +is fully discharged (every arm, including `.loop`), so §F is unconditionally +discharged. -/ +theorem hoistLoopPrefixInits_preserves + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] + [HasIntOrder P] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + [DecidableEq P.Ident] + {extendEval : ExtendEval P} + (ss : List (Stmt P (Cmd P))) + {ρ_src ρ_src' : Env P} + (h_no_nd : Block.containsNondetLoop ss = false) + (h_no_fd : Block.containsFuncDecl ss = false) + (h_no_inv : Block.loopHasNoInvariants ss = true) + (h_no_measure : Block.loopMeasureNone ss = true) + (h_exprs_shapefree : Block.exprsShapeFree (P := P) String.HasUnderscoreDigitSuffix ss) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_src_initVars_shapefree : + ∀ str : String, String.HasUnderscoreDigitSuffix str → + HasIdent.ident (P := P) str ∉ Block.initVars ss) + (h_src_modifiedVars_shapefree : + ∀ str : String, String.HasUnderscoreDigitSuffix str → + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) + (h_hoist_undef : ∀ y ∈ Block.initVars ss, ρ_src.store y = none) + (h_src_store_shapefree : + NoGenStore (P := P) String.HasUnderscoreDigitSuffix ρ_src) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ_src) (.terminal ρ_src')) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + ∃ ρ_h', + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.hoistLoopPrefixInits ss) ρ_src) (.terminal ρ_h') + ∧ StoreAgreement ρ_src'.store ρ_h'.store + ∧ ρ_h'.hasFailure = ρ_src'.hasFailure := + -- The blanket statement is the `Q := String.HasUnderscoreDigitSuffix` + -- instance of the kind-generalized `hoistLoopPrefixInits_preserves_kind`: + -- the blanket "shape-free" hypotheses (no source name is the image of any + -- gen-suffix-shaped string) are exactly that lemma's per-kind hypotheses at + -- `Q := String.HasUnderscoreDigitSuffix`, and the mint witness `hQmint` is + -- `StringGenState.gen_hasUnderscoreDigitSuffix` (every minted name is + -- suffix-shaped). + hoistLoopPrefixInits_preserves_kind + (Q := String.HasUnderscoreDigitSuffix) + (fun sg => StringGenState.gen_hasUnderscoreDigitSuffix hoistFreshPrefix sg) + ss + h_no_nd h_no_fd h_no_inv h_no_measure h_exprs_shapefree h_unique h_fresh + h_src_initVars_shapefree + h_src_modifiedVars_shapefree + h_hoist_undef + h_src_store_shapefree h_run_src h_wfvar h_wfcongr h_wfsubst h_wfdef + +-- NOTE: the former `hoistLoopPrefixInits_preserves_funext` corollary (extensional +-- store equality `ρ_h'.store = ρ_src'.store`) is intentionally dropped: that +-- equality is FALSE for the hoisting pass, which introduces fresh hoist targets +-- defined only in the hoisted store. The sound relation is `StoreAgreement` +-- (preservation modulo hoisted variables), already concluded above. + +/-- Kind-generalized FAILING-config soundness of the loop-init hoist (the +`_to_fail` analogue of `hoistLoopPrefixInits_preserves_kind`): a reachable failing +source configuration of `ss` (no terminal/exiting endpoint required) is matched by +a reachable failing configuration of `Block.hoistLoopPrefixInits ss`, for any +source program whose `Q`-labelled slots are undefined / unwritten. Instantiating +the §F entry at `A := []`, `B := []`, `subst := []`, `σ := emp`, with the hoist +store starting at `ρ_src`. -/ +theorem hoistLoopPrefixInits_to_fail_kind {Q : String → Prop} + [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] + [HasIntOrder P] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + [DecidableEq P.Ident] + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {extendEval : ExtendEval P} + (ss : List (Stmt P (Cmd P))) + {ρ_src : Env P} {cfg_src : Config P (Cmd P)} + (h_no_nd : Block.containsNondetLoop ss = false) + (h_no_fd : Block.containsFuncDecl ss = false) + (h_no_inv : Block.loopHasNoInvariants ss = true) + (h_no_measure : Block.loopMeasureNone ss = true) + (h_exprs_shapefree : Block.exprsShapeFree (P := P) Q ss) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_src_initVars_shapefree : + StructuredToUnstructuredCorrect.NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_src_modifiedVars_shapefree : + StructuredToUnstructuredCorrect.NoGenSuffix (P := P) Q (Block.modifiedVars ss)) + (h_hoist_undef : ∀ y ∈ Block.initVars ss, ρ_src.store y = none) + (h_src_store_shapefree : NoGenStore (P := P) Q ρ_src) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ_src) cfg_src) + (h_c_fail : cfg_src.getEnv.hasFailure = true) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + ∃ d : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.hoistLoopPrefixInits ss) ρ_src) d + ∧ d.getEnv.hasFailure = true := by + have h_names_fresh_nil : Block.namesFreshInExprs (P := P) [] ss = true := + Block.namesFreshInExprs_nil ss + have h_lhs_disjoint_nil : ∀ y ∈ Block.initVars (P := P) ss, y ∉ ([] : List P.Ident) := + fun _ _ => List.not_mem_nil + have h_mod_disjoint_nil : ∀ x ∈ Block.modifiedVars (P := P) (C := Cmd P) ss, x ∉ ([] : List P.Ident) := + fun _ _ => List.not_mem_nil + have h_hinv_refl : HoistInv (P := P) [] [] [] ρ_src.store ρ_src.store := + HoistInv.refl_id [] ρ_src.store + have h_hoist_bound_nil : ∀ y ∈ ([] : List P.Ident), ρ_src.store y ≠ none := + fun _ h => absurd h (List.not_mem_nil) + have h_wf_emp : StringGenState.WF StringGenState.emp := StringGenState.wf_emp + have h_src_fresh_emp : + ∀ str ∈ StringGenState.stringGens StringGenState.emp, + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ Block.initVars (P := P) ss := by + intro str h_str + exact absurd h_str (StringGenState.not_mem_stringGens_emp str) + have h_src_shapefree_F : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ ([] : List P.Ident) ∧ + HasIdent.ident (P := P) str ∉ Block.initVars (P := P) ss ∧ + HasIdent.ident (P := P) str ∉ Block.modifiedVars (P := P) ss := + fun str h_shape => + ⟨List.not_mem_nil, List.not_mem_nil, + h_src_initVars_shapefree str h_shape, + h_src_modifiedVars_shapefree str h_shape⟩ + have h_subst_wf_nil : + ∀ a b : P.Ident, (a, b) ∈ ([] : List (P.Ident × P.Ident)) → a ∈ ([] : List P.Ident) ∧ b ∈ ([] : List P.Ident) := + fun _ _ h => absurd h List.not_mem_nil + have h_src_store_shapefree_emp : + ∀ str : String, Q str → + str ∉ StringGenState.stringGens StringGenState.emp → + ρ_src.store (HasIdent.ident (P := P) str) = none := + fun str h_shape _ => h_src_store_shapefree str h_shape + obtain ⟨d, h_run_h, hd⟩ := + Block.hoistLoopPrefixInits_to_fail hQmint (extendEval := extendEval) [] [] [] ss + StringGenState.emp + h_no_nd h_no_fd h_no_inv h_no_measure h_exprs_shapefree h_unique h_fresh + h_names_fresh_nil h_names_fresh_nil h_lhs_disjoint_nil h_lhs_disjoint_nil + h_mod_disjoint_nil h_mod_disjoint_nil + h_hoist_undef h_hoist_undef h_src_store_shapefree_emp h_src_store_shapefree_emp + h_wf_emp h_src_fresh_emp h_src_shapefree_F h_subst_wf_nil + h_hinv_refl rfl rfl h_hoist_bound_nil + h_run_src h_c_fail h_wfvar h_wfcongr h_wfsubst h_wfdef + exact ⟨d, h_run_h, hd⟩ + +end Imperative diff --git a/Strata/Transform/LoopInitHoistFreshness.lean b/Strata/Transform/LoopInitHoistFreshness.lean new file mode 100644 index 0000000000..13a965d7e6 --- /dev/null +++ b/Strata/Transform/LoopInitHoistFreshness.lean @@ -0,0 +1,151 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.Transform.LoopInitHoist +public import Strata.Transform.LoopInitHoistRewrite + +import all Strata.DL.Imperative.Cmd +import all Strata.DL.Imperative.Stmt +import all Strata.Transform.LoopInitHoist +import all Strata.Transform.LoopInitHoistRewrite + +public section + +namespace Imperative + +variable {P : PureExpr} + +/-! # `namesFreshInExprs` preservation through the `liftInitsInLoopBody` residual + +The residual (`.snd`) of the `liftInitsInLoopBody` pass preserves the +shape-only freshness predicate `Block.namesFreshInExprs names` without any +name-list change. + +The pass residual only: +* converts `.cmd (.init y ty rhs md)` → `.cmd (.set y rhs md)` (rhs unchanged), +* recurses into `.block` / `.ite` substructures. + +Both the `.init` and `.set` arms of `namesFreshInExprs` check +`freshFromIdents z (ExprOrNondet.getVars rhs)`, so the rewrite preserves the +freshness check verbatim. The proof is a mutual structural induction mirroring +the residual's recursion arms; `Block.namesFreshInExprs_append` factors out the +`++` distribution the `.loop` arm needs. +-/ + +/-! ## List-append distributivity helper (used inside the mutual block below). -/ + +/-- `Block.namesFreshInExprs` distributes over `++`. -/ +private theorem Block.namesFreshInExprs_append + [HasVarsPure P P.Expr] (names : List P.Ident) + (xs ys : List (Stmt P (Cmd P))) + (hx : Block.namesFreshInExprs names xs = true) + (hy : Block.namesFreshInExprs names ys = true) : + Block.namesFreshInExprs names (xs ++ ys) = true := by + induction xs with + | nil => simpa using hy + | cons x rest ih => + simp only [Block.namesFreshInExprs, Bool.and_eq_true] at hx + simp only [List.cons_append, Block.namesFreshInExprs, Bool.and_eq_true] + refine ⟨hx.1, ?_⟩ + exact ih hx.2 + +/-! ## Helper 1: `liftInitsInLoopBody.snd` preserves `namesFreshInExprs` +(no name-list change) + +`liftInitsInLoopBody` only rewrites `.cmd .init y ty rhs md` → +`.cmd .set y rhs md` (rhs unchanged). Both `init` and `set` arms of +`namesFreshInExprs` check `freshFromIdents z (ExprOrNondet.getVars rhs)`, +so the rewrite preserves the freshness check verbatim. Loops pass through +unchanged. -/ + +mutual + +private theorem Stmt.liftInitsInLoopBody_snd_namesFreshInExprs + [HasIdent P] [HasVarsPure P P.Expr] (names : List P.Ident) + (s : Stmt P (Cmd P)) + (h : Stmt.namesFreshInExprs names s = true) : + Block.namesFreshInExprs names (Stmt.liftInitsInLoopBody s).snd = true := by + cases s with + | cmd c => + cases c with + | init x ty rhs md => + -- Residual: [.cmd (.set x rhs md)]; both init and set arms of + -- `namesFreshInExprs` check freshFromIdents z (ExprOrNondet.getVars rhs), + -- so the freshness premise transfers verbatim (name-preserving rewrite). + simp only [Stmt.liftInitsInLoopBody_snd_cmd_init, Block.namesFreshInExprs, + Stmt.namesFreshInExprs, Bool.and_true] + simp only [Stmt.namesFreshInExprs] at h + exact h + | set _ _ _ | assert _ _ _ | assume _ _ _ | cover _ _ _ => + simp only [Stmt.liftInitsInLoopBody_snd_cmd_set, + Stmt.liftInitsInLoopBody_snd_cmd_assert, + Stmt.liftInitsInLoopBody_snd_cmd_assume, + Stmt.liftInitsInLoopBody_snd_cmd_cover, Block.namesFreshInExprs, + Stmt.namesFreshInExprs, Bool.and_true] + simp only [Stmt.namesFreshInExprs] at h + exact h + | block lbl bss md => + simp only [Stmt.liftInitsInLoopBody_snd_block, Block.namesFreshInExprs, + Stmt.namesFreshInExprs, Bool.and_true] + have h_bss : Block.namesFreshInExprs names bss = true := by + simp only [Stmt.namesFreshInExprs] at h; exact h + exact Block.liftInitsInLoopBody_snd_namesFreshInExprs names bss h_bss + | ite g tss ess md => + have h_parts : + names.all (fun z => freshFromIdents z (ExprOrNondet.getVars g)) = true ∧ + Block.namesFreshInExprs names tss = true ∧ + Block.namesFreshInExprs names ess = true := by + simp only [Stmt.namesFreshInExprs, Bool.and_eq_true] at h + exact ⟨h.1.1, h.1.2, h.2⟩ + have ih_t := + Block.liftInitsInLoopBody_snd_namesFreshInExprs names tss h_parts.2.1 + have ih_e := + Block.liftInitsInLoopBody_snd_namesFreshInExprs names ess h_parts.2.2 + simp only [Stmt.liftInitsInLoopBody_snd_ite, Block.namesFreshInExprs, + Stmt.namesFreshInExprs, Bool.and_true] + rw [Bool.and_eq_true, Bool.and_eq_true] + exact ⟨⟨h_parts.1, ih_t⟩, ih_e⟩ + | loop g m inv body md => + -- liftInitsInLoopBody passes loops through unchanged. + simp only [Stmt.liftInitsInLoopBody_snd_loop, Block.namesFreshInExprs, + Bool.and_true] + exact h + | exit lbl md => + simp only [Stmt.liftInitsInLoopBody_snd_exit, Block.namesFreshInExprs, + Stmt.namesFreshInExprs, Bool.and_self] + | funcDecl d md => + simp only [Stmt.liftInitsInLoopBody_snd_funcDecl, Block.namesFreshInExprs, + Stmt.namesFreshInExprs, Bool.and_self] + | typeDecl t md => + simp only [Stmt.liftInitsInLoopBody_snd_typeDecl, Block.namesFreshInExprs, + Stmt.namesFreshInExprs, Bool.and_self] + termination_by sizeOf s + +private theorem Block.liftInitsInLoopBody_snd_namesFreshInExprs + [HasIdent P] [HasVarsPure P P.Expr] (names : List P.Ident) + (ss : List (Stmt P (Cmd P))) + (h : Block.namesFreshInExprs names ss = true) : + Block.namesFreshInExprs names (Block.liftInitsInLoopBody ss).snd = true := by + match ss with + | [] => + simp only [Block.liftInitsInLoopBody_snd_nil, Block.namesFreshInExprs] + | s :: rest => + have h_s : Stmt.namesFreshInExprs names s = true := by + simp only [Block.namesFreshInExprs, Bool.and_eq_true] at h; exact h.1 + have h_rest : Block.namesFreshInExprs names rest = true := by + simp only [Block.namesFreshInExprs, Bool.and_eq_true] at h; exact h.2 + have ih_s := Stmt.liftInitsInLoopBody_snd_namesFreshInExprs names s h_s + have ih_rest := + Block.liftInitsInLoopBody_snd_namesFreshInExprs names rest h_rest + simp only [Block.liftInitsInLoopBody_snd_cons] + exact Block.namesFreshInExprs_append names _ _ ih_s ih_rest + termination_by sizeOf ss + +end +end Imperative diff --git a/Strata/Transform/LoopInitHoistInfra.lean b/Strata/Transform/LoopInitHoistInfra.lean new file mode 100644 index 0000000000..779706991f --- /dev/null +++ b/Strata/Transform/LoopInitHoistInfra.lean @@ -0,0 +1,535 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.StmtSemantics +public import Strata.DL.Imperative.CFGSemantics +public import Strata.Transform.StructuredToUnstructuredCorrect +public import Strata.Transform.LoopInitHoistRewrite +import all Strata.DL.Imperative.Cmd + +/-! # Loop-init hoisting: equivalence infrastructure + +This file collects the load-bearing equivalence lemmas used by the loop-init +hoisting correctness proof. The pass transforms a structured program so that +every `.loop` body satisfies `Block.initVars body = []`; the proofs in this +file justify the rewriting piecewise. + +The live infrastructure is: + +- `HoistInv` — the guarded forward-simulation store relation between the source + and hoisted runs (modulo the fresh hoisted variables), with its transports + (`refl_id`, `to_storeAgreement_nil`, `extend_both_outside_subst`, + `set_both_in_subst`, `project_both`, `add_vacuous_pairs`). +- `substFvarMany` / `renameLookup` — the simultaneous renaming the lift applies, + plus the expression-level transport `substFvarMany_eval_tweak`. +- `extendStoreMany`, `projectStore_undef_at`, `read_vars_def_of_eval`, + `stmts_cons_terminal_inv` — the store/run helpers the prelude and loop + drivers consume. +-/ + +public section + +namespace Imperative + +variable {P : PureExpr} + +/-! ## Store helper: `projectStore` reverts to `none` on parent-undefined keys -/ + +open StructuredToUnstructuredCorrect (EvalCmds) +private theorem projectStore_undef_at {P : PureExpr} + {σ_parent σ_inner : SemanticStore P} {x : P.Ident} + (h : σ_parent x = none) : + projectStore σ_parent σ_inner x = none := by + unfold projectStore + simp [h] + +/-- Guarded HoistInv invariant for the fresh-name hoist pass. + +Component (1) — FRAME: outside `A ∪ B`, stores agree pointwise. +Component (2) — GUARDED PAIRWISE: source-defined ⇒ hoist-defined-and-equal. + +The `σ_src a ≠ none` antecedent absorbs the timing asymmetry between +source's per-iteration `step_block_done` projection (which pops body-locals +to `none`) and hoist's outer-scope persistence (where the prelude havoc +keeps the renamed slot defined). When source pops, antecedent fails, +component (2) is vacuously preserved. -/ +@[expose] def HoistInv {P : PureExpr} + (A B : List P.Ident) + (subst : List (P.Ident × P.Ident)) + (σ_src σ_h : SemanticStore P) : Prop := + (∀ x : P.Ident, x ∉ A → x ∉ B → σ_src x ≠ none → σ_src x = σ_h x) + ∧ + (∀ a b : P.Ident, (a, b) ∈ subst → + σ_src a ≠ none → (σ_h b ≠ none ∧ σ_src a = σ_h b)) + +/-- Auxiliary: membership in `A.zip A` forces equality of the components. -/ +private theorem mem_zip_self_eq {P : PureExpr} + {A : List P.Ident} {a b : P.Ident} + (h : (a, b) ∈ A.zip A) : a = b := by + induction A with + | nil => simp [List.zip, List.zipWith] at h + | cons hd tl ih => + rw [List.zip, List.zipWith] at h + rcases List.mem_cons.mp h with h_eq | h_in + · cases h_eq; rfl + · exact ih h_in + +/-- Reflexivity (identity-subst form): when `subst = A.zip A` and `σ_src = σ_h`, +`HoistInv A A (A.zip A) σ σ` holds. The frame component is `rfl`; the +guarded pairwise reduces to `σ a ≠ none → σ a = σ a`. -/ +theorem HoistInv.refl_id {P : PureExpr} + (A : List P.Ident) (σ : SemanticStore P) : + HoistInv (P := P) A A (A.zip A) σ σ := by + refine ⟨fun _ _ _ _ => rfl, ?_⟩ + intro a b h_pair h_ne + have h_ab : a = b := mem_zip_self_eq h_pair + subst h_ab + exact ⟨h_ne, rfl⟩ + +/-- Forward-simulation bridge: `HoistInv A B subst σ_src σ_h` plus + (a) every `A`-var undefined in `σ_src`, + (b) every `B`-var undefined in `σ_src`, + (c) every source-side `subst` key lying in `A`, + yields `StoreAgreement σ_src σ_h` — the conventional source-on-left + forward-simulation store relation (CmdSemantics). + +The bridge constrains only source-defined variables: a variable `x` defined in +`σ_src` cannot be in `A` or `B` (both undefined there), so the unconditional +frame component (1) of `HoistInv` delivers `σ_src x = σ_h x` directly. The fresh +hoist carriers (`A`/`B`) and projected loop-locals stay correctly unconstrained. +The reverse direction is intentionally NOT claimed; `StoreAgreement` is strictly +weaker (it says nothing at undefined source vars), which is exactly why it is the +sound end-to-end conclusion. -/ +theorem HoistInv.to_storeAgreement {P : PureExpr} [DecidableEq P.Ident] + {A B : List P.Ident} + {subst : List (P.Ident × P.Ident)} + {σ_src σ_h : SemanticStore P} + (h : HoistInv (P := P) A B subst σ_src σ_h) + (h_A_undef : ∀ a ∈ A, σ_src a = none) + (h_B_undef : ∀ b ∈ B, σ_src b = none) + (_h_subst_src_in_A : ∀ a ∈ subst.map Prod.fst, a ∈ A) : + StoreAgreement σ_src σ_h := by + intro x h_def + have h_x_some : (σ_src x).isSome = true := h_def x (List.mem_singleton.mpr rfl) + have h_x_ne : σ_src x ≠ none := by + intro h_none; rw [h_none] at h_x_some; simp at h_x_some + have h_x_notA : x ∉ A := fun hxA => h_x_ne (h_A_undef x hxA) + have h_x_notB : x ∉ B := fun hxB => h_x_ne (h_B_undef x hxB) + exact h.1 x h_x_notA h_x_notB h_x_ne + +/-- §F-specialized bridge: at `A = B = subst = []` the side-premises are vacuous, +so `HoistInv [] [] [] σ_src σ_h → StoreAgreement σ_src σ_h` unconditionally. This +is exactly the step §F needs in place of the (false) `∀ x, σ_h x = σ_src x`. -/ +theorem HoistInv.to_storeAgreement_nil {P : PureExpr} [DecidableEq P.Ident] + {σ_src σ_h : SemanticStore P} + (h : HoistInv (P := P) [] [] [] σ_src σ_h) : + StoreAgreement σ_src σ_h := + HoistInv.to_storeAgreement h + (fun _ hc => absurd hc List.not_mem_nil) + (fun _ hc => absurd hc List.not_mem_nil) + (fun _ hc => absurd hc List.not_mem_nil) + +/-- Transport: parallel update at `x ∉ A ∪ B` preserves both components. + +Requires the well-formedness hypothesis that every `subst` pair has its +source side in `A` and hoist side in `B`. Combined with `x ∉ A` and +`x ∉ B`, this gives `a ≠ x ∧ b ≠ x` for every pair, so the extension +at `x` misses both sides of every pair. -/ +theorem HoistInv.extend_both_outside_subst {P : PureExpr} [DecidableEq P.Ident] + {A B : List P.Ident} + {subst : List (P.Ident × P.Ident)} + {σ_src σ_h : SemanticStore P} + {x : P.Ident} {v : P.Expr} + (h_x_notin_A : x ∉ A) (h_x_notin_B : x ∉ B) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h : HoistInv (P := P) A B subst σ_src σ_h) : + HoistInv (P := P) A B subst + (StructuredToUnstructuredCorrect.extendStoreOne σ_src x v) + (StructuredToUnstructuredCorrect.extendStoreOne σ_h x v) := by + refine ⟨?_, ?_⟩ + · intro y h_y_notin_A h_y_notin_B h_y_ne + by_cases hyx : y = x + · subst hyx + rw [StructuredToUnstructuredCorrect.extendStoreOne_self σ_src y v, + StructuredToUnstructuredCorrect.extendStoreOne_self σ_h y v] + · rw [StructuredToUnstructuredCorrect.extendStoreOne_other σ_src x v y hyx] at h_y_ne + rw [StructuredToUnstructuredCorrect.extendStoreOne_other σ_src x v y hyx, + StructuredToUnstructuredCorrect.extendStoreOne_other σ_h x v y hyx] + exact h.1 y h_y_notin_A h_y_notin_B h_y_ne + · intro a b h_pair h_src_ne + have h_wf := h_subst_wf a b h_pair + have h_a_in_A : a ∈ A := h_wf.1 + have h_b_in_B : b ∈ B := h_wf.2 + have hax : a ≠ x := fun heq => h_x_notin_A (heq ▸ h_a_in_A) + have hbx : b ≠ x := fun heq => h_x_notin_B (heq ▸ h_b_in_B) + rw [StructuredToUnstructuredCorrect.extendStoreOne_other σ_src x v a hax] at h_src_ne + have h_old := h.2 a b h_pair h_src_ne + rw [StructuredToUnstructuredCorrect.extendStoreOne_other σ_src x v a hax, + StructuredToUnstructuredCorrect.extendStoreOne_other σ_h x v b hbx] + exact h_old + +/-! ## Phase 8 Option F — Critical lemmas + +Load-bearing `HoistInv` transports: `extend_both_outside_subst` and +`set_both_in_subst` (parallel update at a non-carrier resp. a renamed slot), +`project_both` (body-exit projection), and `add_vacuous_pairs`. -/ + +/-- The body's parallel-update step. Source `init`s `a` (was undef, becomes +`some v`); hoist `set`s `b` (was defined, becomes `some v`). Antecedent of +component (2) flips from FALSE to TRUE; both clauses must hold post-update. -/ +theorem HoistInv.set_both_in_subst {P : PureExpr} [DecidableEq P.Ident] + {A B : List P.Ident} + {subst : List (P.Ident × P.Ident)} + {σ_src σ_h : SemanticStore P} + {a b : P.Ident} {v : P.Expr} + (h_pair : (a, b) ∈ subst) + (h_in_A : a ∈ A) (h_in_B : b ∈ B) + (h_unique_a : ∀ a' b', (a', b') ∈ subst → a' = a → b' = b) + (h_unique_b : ∀ a' b', (a', b') ∈ subst → b' = b → a' = a) + (h : HoistInv (P := P) A B subst σ_src σ_h) : + HoistInv (P := P) A B subst + (StructuredToUnstructuredCorrect.extendStoreOne σ_src a v) + (StructuredToUnstructuredCorrect.extendStoreOne σ_h b v) := by + refine ⟨?_, ?_⟩ + · -- Component 1: outside A ∪ B. Since a ∈ A and b ∈ B, neither extension + -- touches a key outside A ∪ B. + intro x h_x_notin_A h_x_notin_B h_x_ne + have hxa : x ≠ a := fun heq => h_x_notin_A (heq ▸ h_in_A) + have hxb : x ≠ b := fun heq => h_x_notin_B (heq ▸ h_in_B) + rw [StructuredToUnstructuredCorrect.extendStoreOne_other σ_src a v x hxa] at h_x_ne + rw [StructuredToUnstructuredCorrect.extendStoreOne_other σ_src a v x hxa, + StructuredToUnstructuredCorrect.extendStoreOne_other σ_h b v x hxb] + exact h.1 x h_x_notin_A h_x_notin_B h_x_ne + · -- Component 2: subst pair (a', b') with σ_src-ext a' ≠ none. + intro a' b' h_pair' h_src_ne + by_cases ha'a : a' = a + · -- Case a' = a: by uniqueness, b' = b. + have hb'b : b' = b := h_unique_a a' b' h_pair' ha'a + subst ha'a + subst hb'b + refine ⟨?_, ?_⟩ + · rw [StructuredToUnstructuredCorrect.extendStoreOne_self σ_h b' v] + intro h_eq; cases h_eq + · rw [StructuredToUnstructuredCorrect.extendStoreOne_self σ_src a' v, + StructuredToUnstructuredCorrect.extendStoreOne_self σ_h b' v] + · -- Case a' ≠ a: σ_src-ext a' = σ_src a'. + have h_src_ne' : σ_src a' ≠ none := by + rw [StructuredToUnstructuredCorrect.extendStoreOne_other σ_src a v a' ha'a] at h_src_ne + exact h_src_ne + have h_old := h.2 a' b' h_pair' h_src_ne' + have hb'b : b' ≠ b := by + intro heq + exact ha'a (h_unique_b a' b' h_pair' heq) + refine ⟨?_, ?_⟩ + · rw [StructuredToUnstructuredCorrect.extendStoreOne_other σ_h b v b' hb'b] + exact h_old.1 + · rw [StructuredToUnstructuredCorrect.extendStoreOne_other σ_src a v a' ha'a, + StructuredToUnstructuredCorrect.extendStoreOne_other σ_h b v b' hb'b] + exact h_old.2 + +/-- Both-sides projection: the body-exit `projectStore` operation applied +in parallel to source and hoist preserves `HoistInv`. This is the +HoistInv analog of `projectStore_iter_agree`. + +For the existing pass (where the source-side hoist names are NOT in +`Block.initVars` of the body, so component (2) at iteration boundaries +is preserved), the parent's HoistInv suffices to lift through the +projection: if `parent_src` and `parent_hoist` agree under HoistInv +and `inner_src` and `inner_hoist` agree under HoistInv, then the +projected pair also agrees under HoistInv. -/ +theorem HoistInv.project_both {P : PureExpr} [DecidableEq P.Ident] + {A B : List P.Ident} + {subst : List (P.Ident × P.Ident)} + {parent_src parent_hoist inner_src inner_hoist : SemanticStore P} + (h_parent : HoistInv (P := P) A B subst parent_src parent_hoist) + (h_inner : HoistInv (P := P) A B subst inner_src inner_hoist) : + HoistInv (P := P) A B subst + (projectStore parent_src inner_src) + (projectStore parent_hoist inner_hoist) := by + refine ⟨?_, ?_⟩ + · -- Component 1: outside A ∪ B, both projected stores agree. The guard + -- `h_x_ne` forces `(parent_src x).isSome` and `inner_src x ≠ none`, which + -- discharge the guards of `h_parent.1`/`h_inner.1`. + intro x h_x_notin_A h_x_notin_B h_x_ne + have h_parent_src_some : (parent_src x).isSome = true := by + unfold projectStore at h_x_ne + by_cases h : (parent_src x).isSome + · exact h + · simp [h] at h_x_ne + have h_parent_src_ne : parent_src x ≠ none := by + intro h; rw [h] at h_parent_src_some; simp at h_parent_src_some + have h_inner_src_ne : inner_src x ≠ none := by + intro h_eq; unfold projectStore at h_x_ne + rw [h_parent_src_some] at h_x_ne; simp at h_x_ne; exact h_x_ne h_eq + have h_parent_eq := h_parent.1 x h_x_notin_A h_x_notin_B h_parent_src_ne + have h_inner_eq := h_inner.1 x h_x_notin_A h_x_notin_B h_inner_src_ne + unfold projectStore + rw [h_parent_eq, h_inner_eq] + · -- Component 2: for (a, b) ∈ subst, projected_src a ≠ none implies + -- projected_hoist b ≠ none and they're equal. + intro a b h_pair h_src_ne + -- projectStore parent_src inner_src a = if (parent_src a).isSome then inner_src a else none + -- src_ne ⇒ (parent_src a).isSome ∧ inner_src a is some. + have h_parent_a_some : (parent_src a).isSome = true := by + unfold projectStore at h_src_ne + by_cases h : (parent_src a).isSome + · exact h + · simp [h] at h_src_ne + have h_inner_a_ne : inner_src a ≠ none := by + intro h_eq + unfold projectStore at h_src_ne + rw [h_parent_a_some] at h_src_ne + simp at h_src_ne + exact h_src_ne h_eq + -- From parent: parent_src a ≠ none ⇒ parent_hoist b ≠ none ∧ parent_src a = parent_hoist b. + have h_parent_a_ne : parent_src a ≠ none := by + intro h + rw [h] at h_parent_a_some + simp at h_parent_a_some + obtain ⟨h_parent_b_ne, h_parent_eq⟩ := h_parent.2 a b h_pair h_parent_a_ne + -- From inner: inner_src a ≠ none ⇒ inner_hoist b ≠ none ∧ inner_src a = inner_hoist b. + obtain ⟨h_inner_b_ne, h_inner_eq⟩ := h_inner.2 a b h_pair h_inner_a_ne + -- projected_hoist b = (if (parent_hoist b).isSome then inner_hoist b else none) = inner_hoist b. + have h_parent_b_some : (parent_hoist b).isSome = true := by + cases h : parent_hoist b with + | none => exact absurd h h_parent_b_ne + | some _ => rfl + refine ⟨?_, ?_⟩ + · unfold projectStore + rw [h_parent_b_some] + simp + exact h_inner_b_ne + · unfold projectStore + rw [h_parent_a_some, h_parent_b_some] + simp + exact h_inner_eq + +/-- Iterated single-variable `substFvar`: fold a list of `(y, y')` rename pairs +over an expression, applying the head first (matches `Block.applyRenames`'s fold +order on each expression position). -/ +@[expose] def substFvarMany {P : PureExpr} [HasSubstFvar P] [HasFvar P] + (e : P.Expr) (subst : List (P.Ident × P.Ident)) : P.Expr := + subst.foldl (fun acc p => HasSubstFvar.substFvar acc p.1 (HasFvar.mkFvar p.2)) e + +@[simp] theorem substFvarMany_nil {P : PureExpr} [HasSubstFvar P] [HasFvar P] + (e : P.Expr) : substFvarMany e ([] : List (P.Ident × P.Ident)) = e := rfl + +@[simp] theorem substFvarMany_cons {P : PureExpr} [HasSubstFvar P] [HasFvar P] + (e : P.Expr) (y y' : P.Ident) (rest : List (P.Ident × P.Ident)) : + substFvarMany e ((y, y') :: rest) + = substFvarMany (HasSubstFvar.substFvar e y (HasFvar.mkFvar y')) rest := rfl + +/-- Resolve a variable through the rename list: `a ↦ b` for the FIRST `(a,b) ∈ +subst`, else `x ↦ x`. -/ +@[expose] def renameLookup {P : PureExpr} [DecidableEq P.Ident] + (subst : List (P.Ident × P.Ident)) (x : P.Ident) : P.Ident := + match subst with + | [] => x + | (a, b) :: rest => if x = a then b else renameLookup rest x + +@[simp] theorem renameLookup_nil {P : PureExpr} [DecidableEq P.Ident] (x : P.Ident) : + renameLookup ([] : List (P.Ident × P.Ident)) x = x := rfl + +@[simp] theorem renameLookup_cons {P : PureExpr} [DecidableEq P.Ident] + (a b x : P.Ident) (rest : List (P.Ident × P.Ident)) : + renameLookup ((a, b) :: rest) x = if x = a then b else renameLookup rest x := rfl + +theorem renameLookup_notin {P : PureExpr} [DecidableEq P.Ident] + (subst : List (P.Ident × P.Ident)) (x : P.Ident) + (h : x ∉ subst.map Prod.fst) : renameLookup subst x = x := by + induction subst with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + simp only [renameLookup_cons] + have hxa : x ≠ a := by intro heq; subst heq; exact h (by simp) + rw [if_neg hxa] + exact ih (fun hmem => h (by simp [hmem])) + +/-- When the rename's sources are distinct and `(a, b) ∈ subst`, `renameLookup` +resolves `a` to its (unique) target `b`. -/ +theorem renameLookup_mem {P : PureExpr} [DecidableEq P.Ident] + (subst : List (P.Ident × P.Ident)) + (h_src_nodup : (subst.map Prod.fst).Nodup) + {a b : P.Ident} (h_pair : (a, b) ∈ subst) : renameLookup subst a = b := by + induction subst with + | nil => simp at h_pair + | cons hd tl ih => + rcases hd with ⟨a', b'⟩ + rcases List.mem_cons.mp h_pair with h_eq | h_in + · cases h_eq; simp + · have ha_a' : a ≠ a' := by + intro heq; subst heq + simp only [List.map_cons, List.nodup_cons] at h_src_nodup + exact h_src_nodup.1 (List.mem_map.mpr ⟨(a, b), h_in, rfl⟩) + simp only [renameLookup_cons, if_neg ha_a'] + exact ih (by simp only [List.map_cons, List.nodup_cons] at h_src_nodup; exact h_src_nodup.2) h_in + +/-- The iterated-substitution half: evaluating the renamed expression in `σ_h` +equals evaluating the ORIGINAL expression in the "renamed-lookup" store +`fun x => σ_h (renameLookup subst x)`. Proved by HEAD-peel induction on `subst`, +discharging each head pair by single-pair `WellFormedSemanticEvalSubstFvar`. -/ +theorem substFvarMany_eval_tweak {P : PureExpr} + [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (δ : SemanticEval P) + {e : P.Expr} {σ_h : SemanticStore P} + (subst : List (P.Ident × P.Ident)) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_wfsubst : WellFormedSemanticEvalSubstFvar δ) : + δ (fun x => σ_h (renameLookup subst x)) e = δ σ_h (substFvarMany e subst) := by + classical + induction subst generalizing e with + | nil => simp + | cons hd tl ih => + rcases hd with ⟨y, y'⟩ + have h_y'_notin_tl_fst : y' ∉ tl.map Prod.fst := by + intro hmem + have h_y'_tgt : y' ∈ (((y, y') :: tl).map Prod.snd) := by simp + exact h_disjoint y' (by simp [hmem]) h_y'_tgt + have h_step : + δ (fun x => σ_h (renameLookup ((y, y') :: tl) x)) e + = δ (fun x => σ_h (renameLookup tl x)) + (HasSubstFvar.substFvar e y (HasFvar.mkFvar y')) := by + apply h_wfsubst e y y' + · intro x hxy; simp only [renameLookup_cons, if_neg hxy] + · rw [renameLookup_notin tl y' h_y'_notin_tl_fst] + simp only [renameLookup_cons, if_true] + rw [h_step, substFvarMany_cons] + apply ih + · have := h_src_nodup; simp only [List.map_cons, List.nodup_cons] at this; exact this.2 + · intro a ha hb; exact h_disjoint a (by simp [ha]) (by simp [hb]) + · have := h_tgt_nodup; simp only [List.map_cons, List.nodup_cons] at this; exact this.2 + +/-- Add new VACUOUS subst pairs (and widen `B`), extending the hoist store at the +new targets with arbitrary values. This is the store-side core of the +prelude-havoc step: after the fresh prelude `init y'` havocs run, the augmented +`HoistInv A (B ++ B_new) (subst ++ subst_new)` holds between the (unchanged) +source store and the extended hoist store. + +The new pairs `subst_new` have all SOURCE keys undefined in `σ_src` +(`h_new_src_undef`) — component (2) is vacuous for them. `σ_h'` differs from +`σ_h` only on `B_new` (`h_extend`). Existing pairs keep their value because their +targets `b ∈ B` (`h_subst_tgt_in_B`) and `B` is disjoint from `B_new` +(`h_B_disjoint`). The frame widens because `A ∪ (B ++ B_new) ⊇ A ∪ B`. -/ +theorem HoistInv.add_vacuous_pairs {P : PureExpr} [DecidableEq P.Ident] + {A B B_new : List P.Ident} + {subst subst_new : List (P.Ident × P.Ident)} + {σ_src σ_h σ_h' : SemanticStore P} + (h_new_src_undef : ∀ a ∈ subst_new.map Prod.fst, σ_src a = none) + (h_subst_tgt_in_B : ∀ b ∈ subst.map Prod.snd, b ∈ B) + (h_extend : ∀ x, x ∉ B_new → σ_h' x = σ_h x) + (h_B_disjoint : ∀ b ∈ B, b ∉ B_new) + (h : HoistInv (P := P) A B subst σ_src σ_h) : + HoistInv (P := P) A (B ++ B_new) (subst ++ subst_new) σ_src σ_h' := by + refine ⟨?_, ?_⟩ + · intro x h_x_notin_A h_x_notin_BB h_x_ne + have h_x_notin_B : x ∉ B := fun hxB => h_x_notin_BB (List.mem_append.mpr (Or.inl hxB)) + have h_x_notin_Bnew : x ∉ B_new := fun hxBn => h_x_notin_BB (List.mem_append.mpr (Or.inr hxBn)) + rw [h_extend x h_x_notin_Bnew] + exact h.1 x h_x_notin_A h_x_notin_B h_x_ne + · intro a b h_pair h_src_ne + rcases List.mem_append.mp h_pair with h_old | h_new + · obtain ⟨h_b_ne, h_eq⟩ := h.2 a b h_old h_src_ne + have h_b_in_B : b ∈ B := h_subst_tgt_in_B b (List.mem_map.mpr ⟨(a, b), h_old, rfl⟩) + have h_b_notin_Bnew : b ∉ B_new := h_B_disjoint b h_b_in_B + rw [h_extend b h_b_notin_Bnew] + exact ⟨h_b_ne, h_eq⟩ + · exfalso + apply h_src_ne + exact h_new_src_undef a (List.mem_map.mpr ⟨(a, b), h_new, rfl⟩) + +/-! ## Phase 8 Option F — Evaluator transport for HoistInv + +Under the guarded frame, expression evaluation transports across `HoistInv` via +the multi-pair keystone `substFvarMany_eval_tweak`: a renamed expression +evaluates on the hoist store to the same value the source expression evaluates +to, because each read variable is either frame-agreed or paired by the subst. -/ + +/-! ### Single-pair substFvar congruence-bridge (reusable) + +`Block.applyRenames` for the fresh-name `.loop` arm rewrites every expression +position (renamed init RHS, the loop guard, assert/assume/cover conditions, and +all recursively nested body subexpressions) by a SINGLE rename pair `(y, y')` — +the per-iteration body simulation transports each such expression one rename at +a time. The transport principle for one pair is: + + `δ σ_src e = δ σ_h (substFvar e y (mkFvar y'))` + +under the `HoistInv`-style pairing facts at `(y, y')`. + +The subtlety (the reason this needs its own lemma rather than a direct appeal to +`WellFormedSemanticEvalSubstFvar`) is that `WellFormedSemanticEvalSubstFvar`'s +frame premise is `∀ x ≠ y, σ x = σ' x`, which **fails at `x = y'`**: the source +store `σ_src` and hoist store `σ_h` need not agree at the fresh target `y'` +(indeed `σ_src y' = none` body-locally while `σ_h y' = some _`). We therefore +compose `WellFormedSemanticEvalSubstFvar` with `WellFormedSemanticEvalExprCongr` +through a tweak store + + `σ_t x := if x = y then σ_h y' else σ_h x` + +so that (1) `σ_t` agrees with `σ_src` on `getVars e` (congruence swaps +`σ_src ⇝ σ_t`), and (2) `σ_t` agrees with `σ_h` away from `y` and carries +`σ_t y = σ_h y'` (substFvar applies with `σ := σ_t`, `σ' := σ_h`). + +This is the single-pair counterpart of the multi-pair keystone +`substFvarMany_eval_tweak`; it is exposed separately so the per-iteration body +simulation can call it uniformly on each rewritten expression position without +threading the rename-list well-formedness side conditions. -/ + +/-- A successful evaluation `δ σ e = some v` (under `WellFormedSemanticEvalDef`) +defines every read var of `e`: `σ x ≠ none` for `x ∈ getVars e`. This is the +read-var-definedness discharge the guarded-frame expression transports consume. -/ +theorem read_vars_def_of_eval {P : PureExpr} [HasVarsPure P P.Expr] + {δ : SemanticEval P} {σ : SemanticStore P} {e : P.Expr} {v : P.Expr} + (h_wfdef : WellFormedSemanticEvalDef δ) + (h_eval : δ σ e = some v) : + ∀ x ∈ HasVarsPure.getVars e, σ x ≠ none := by + intro x hx h_none + have h_some : (σ x).isSome = true := h_wfdef e v σ h_eval x hx + rw [h_none] at h_some; simp at h_some + +/-- Split `.stmts (s :: rest) ρ ⟶* .terminal ρ'` into head and tail runs. -/ +private theorem stmts_cons_terminal_inv + [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} + (h : StepStmtStar P (EvalCmd P) extendEval (.stmts (s :: rest) ρ) (.terminal ρ')) : + ∃ ρ_mid : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (.terminal ρ_mid) ∧ + StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ_mid) (.terminal ρ') := by + cases h with + | step _ _ _ h1 hr1 => cases h1; exact seq_reaches_terminal P (EvalCmd P) extendEval hr1 + +/-! ## `extendStoreMany`: store extended by a list of bindings + +Extend a store with a list of `(ident, value)` bindings, applied front-to-back +via `List.foldl` — matching the order in which a hoisted prelude +`[init y₀ ; init y₁ ; ...]` populates the entry store. Consumed by the loop +driver's prelude bridge. -/ + +/-- Extend a `SemanticStore` with a list of `(ident, value)` bindings, +applying the head binding first. Front of the list ends up "innermost". -/ +@[expose] def extendStoreMany {P : PureExpr} [DecidableEq P.Ident] + (σ : SemanticStore P) (bindings : List (P.Ident × P.Expr)) : + SemanticStore P := + bindings.foldl (fun σ p => + StructuredToUnstructuredCorrect.extendStoreOne σ p.1 p.2) σ + +@[simp] theorem extendStoreMany_nil {P : PureExpr} [DecidableEq P.Ident] + (σ : SemanticStore P) : + extendStoreMany σ [] = σ := rfl + +@[simp] theorem extendStoreMany_cons {P : PureExpr} [DecidableEq P.Ident] + (σ : SemanticStore P) (y : P.Ident) (v : P.Expr) + (rest : List (P.Ident × P.Expr)) : + extendStoreMany σ ((y, v) :: rest) + = extendStoreMany + (StructuredToUnstructuredCorrect.extendStoreOne σ y v) rest := rfl + +end Imperative \ No newline at end of file diff --git a/Strata/Transform/LoopInitHoistKeystone.lean b/Strata/Transform/LoopInitHoistKeystone.lean new file mode 100644 index 0000000000..8a8548d451 --- /dev/null +++ b/Strata/Transform/LoopInitHoistKeystone.lean @@ -0,0 +1,329 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT + + The `applyRenames` ↔ `substFvarMany` keystone. This file is load-bearing: it + is imported by `LoopInitHoistBodyTransport` and `LoopInitHoistStepCProducer` + (and transitively by the end-to-end theorem `hoistLoopPrefixInits_preserves`). + + It establishes that `Block.applyRenames` (the pass's iterated single-variable + `substIdent`, applied head-first) agrees with `substFvarMany` (the simultaneous + fold the transport machinery is stated over) under the freshness the lift + provides — the bridge that lets the producer rewrite a renamed body one + statement at a time. +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.DL.Imperative.StmtSemantics +public import Strata.DL.Imperative.CmdSemantics +public import Strata.Transform.LoopInitHoist +public import Strata.Transform.LoopInitHoistContains +public import Strata.Transform.LoopInitHoistFreshness +public import Strata.Transform.LoopInitHoistRewrite +public import Strata.Transform.LoopInitHoistInfra +public import Strata.Transform.LoopInitHoistLoopDriver + +import all Strata.DL.Imperative.Stmt +import all Strata.DL.Imperative.Cmd +import all Strata.Transform.LoopInitHoist +import all Strata.Transform.LoopInitHoistContains +import all Strata.Transform.LoopInitHoistFreshness +import all Strata.Transform.LoopInitHoistRewrite +import all Strata.Transform.LoopInitHoistInfra + +public section + +namespace Imperative +namespace OptEKeystone + +open StructuredToUnstructuredCorrect (extendStoreOne extendStoreOne_self extendStoreOne_other) + +variable {P : PureExpr} + +/-! ## Layer 1 — the EXPRESSION-level core. + +`Block.applyRenames` folds `Block.substIdent p.1 p.2` over the rename list, +head-first. On every EXPRESSION position, `substIdent` applies +`HasSubstFvar.substFvar e p.1 (HasFvar.mkFvar p.2)` for that one pair. So the +expression seen at a leaf after the whole `applyRenames` fold is precisely + + subst.foldl (fun acc p => HasSubstFvar.substFvar acc p.1 (HasFvar.mkFvar p.2)) e + +which is the DEFINITION of `substFvarMany e subst` (in `LoopInitHoistInfra`). + +THE KEY FINDING: the expression-level keystone is DEFINITIONALLY TRUE. There is +NO reconciliation gap between "iterated single-var" and "simultaneous" at the +syntactic level, because `substFvarMany` was DEFINED as the iterated single-var +fold — the "simultaneous" semantics live entirely inside the EVAL-level lemmas +(`substFvarMany_eval_tweak`/`_eval_transport`), which is where the freshness / +non-interference reasoning is discharged. So the syntactic keystone needs NO +freshness preconditions at all. -/ + +/-! ## Layer 2 — the STRUCTURAL DESCENT. + +The gate's REAL content (the part downstream `bodyTransport` actually needs) is +that the OUTER fold `Block.applyRenames subst body` — folding the WHOLE block +through `Block.substIdent` one pair at a time — equals descending the +PER-EXPRESSION simultaneous fold (`substFvarMany`) into the body, i.e. it lands +in exactly the renamed shapes the loop driver consumes: + + * a `.det` guard becomes `substFvarMany g subst` (driver: `loopDet_lift_renamedGuard_E` / `_TE`) + * an `assert`/`assume`/`cover` predicate becomes `substFvarMany b subst` + * an `init`/`set` name becomes its `renameLookup`-image and its rhs `substFvarMany`-renamed + * sub-blocks (`.block`/`.ite`/`.loop` body) are `applyRenames`-renamed recursively + +We prove the structural descent by induction on `subst`, peeling one pair at a +time and pushing it through `Block.substIdent`'s definitional equations. This is +the bridge between the one-pair-at-a-time `applyRenames` and the per-leaf +`substFvarMany` the transport lemmas speak. NO freshness is needed for the +SYNTACTIC descent either; the foldl simply commutes with the structural recursion. +-/ + +/-- `applyRenames` on `[]` is the identity. -/ +@[simp] public theorem applyRenames_nil [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] (ss : List (Stmt P (Cmd P))) : + Block.applyRenames ([] : List (P.Ident × P.Ident)) ss = ss := rfl + +/-- `applyRenames` head-peel: apply the head pair via `Block.substIdent`, then +the tail via `applyRenames`. -/ +public theorem applyRenames_cons [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (a b : P.Ident) (rest : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + Block.applyRenames ((a, b) :: rest) ss + = Block.applyRenames rest (Block.substIdent a b ss) := rfl + +/-- `applyRenames` of any rename list on the empty block is the empty block +(folding `Block.substIdent` over `[]` keeps `[]` at every step). -/ +@[simp] public theorem applyRenames_empty_block [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (subst : List (P.Ident × P.Ident)) : + Block.applyRenames subst ([] : List (Stmt P (Cmd P))) = [] := by + induction subst with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + rw [applyRenames_cons, Block.substIdent_nil] + exact ih + +/-- `applyRenames` distributes over `cons` of statements: the per-statement +single-var renames compose to a per-statement `applyRenames`. -/ +public theorem applyRenames_stmt_cons [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (subst : List (P.Ident × P.Ident)) (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) : + Block.applyRenames subst (s :: rest) + = (subst.foldl (fun acc p => Stmt.substIdent p.1 p.2 acc) s) + :: Block.applyRenames subst rest := by + induction subst generalizing s rest with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + rw [applyRenames_cons, Block.substIdent_cons] + rw [ih] + rfl + +/-- The per-statement iterated single-var fold (head-first) — the analogue of +`substFvarMany` at the `Stmt` level. This is what `applyRenames` applies to each +statement of the body (by `applyRenames_stmt_cons`). -/ +@[expose] def stmtSubstMany [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] (s : Stmt P (Cmd P)) (subst : List (P.Ident × P.Ident)) : + Stmt P (Cmd P) := + subst.foldl (fun acc p => Stmt.substIdent p.1 p.2 acc) s + +@[simp] public theorem stmtSubstMany_nil [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] (s : Stmt P (Cmd P)) : + stmtSubstMany s ([] : List (P.Ident × P.Ident)) = s := rfl + +@[simp] public theorem stmtSubstMany_cons [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (a b : P.Ident) (rest : List (P.Ident × P.Ident)) : + stmtSubstMany s ((a, b) :: rest) + = stmtSubstMany (Stmt.substIdent a b s) rest := rfl + +/-- `applyRenames` on a body = map `stmtSubstMany` over the statements. This is +the clean characterisation the cons-sequencer (`bodySimES_cons`) consumes: the +hoist body `applyRenames subst body` is the per-statement `stmtSubstMany`-image, +so `bodySimES_cons` can be driven head-statement at a time. -/ +public theorem applyRenames_eq_map_stmtSubstMany [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (subst : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + Block.applyRenames subst ss = ss.map (fun s => stmtSubstMany s subst) := by + induction ss with + | nil => simp + | cons s rest ih => + rw [applyRenames_stmt_cons, List.map_cons, ih] + rfl + +/-! ### The leaf-shape reconciliations — `stmtSubstMany` lands on driver shapes. + +For the loop-driver's guard slot the relevant fact is that the iterated fold on a +`.det` guard expression is `substFvarMany g subst`. We expose the key leaf +descents that show `stmtSubstMany` produces EXACTLY the `substFvarMany` / +`renameLookup` shapes the driver and the per-statement sims speak. -/ + +/-- A `.det` guard `ExprOrNondet` folds to the `substFvarMany` of its expression. +This is the guard the `loopDet_lift_renamedGuard_E` / `_TE` drivers expect: +`.det (substFvarMany g subst)`. -/ +public theorem exprOrNondet_substMany_det [HasFvar P] [HasSubstFvar P] + (g : P.Expr) (subst : List (P.Ident × P.Ident)) : + (subst.foldl (fun acc p => ExprOrNondet.substIdent p.1 p.2 acc) (ExprOrNondet.det g)) + = ExprOrNondet.det (substFvarMany g subst) := by + induction subst generalizing g with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + simp only [List.foldl_cons, ExprOrNondet.substIdent_det] + rw [ih] + rfl + +/-- `.nondet` is fixed by the fold. -/ +public theorem exprOrNondet_substMany_nondet [HasFvar P] [HasSubstFvar P] + (subst : List (P.Ident × P.Ident)) : + (subst.foldl (fun acc p => ExprOrNondet.substIdent p.1 p.2 acc) + (ExprOrNondet.nondet (P := P))) + = ExprOrNondet.nondet := by + induction subst with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + simp only [List.foldl_cons, ExprOrNondet.substIdent_nondet] + exact ih + +/-- A nested-loop statement folds to a loop whose `.det` guard is +`substFvarMany g subst` and whose body is `applyRenames subst body` — exactly the +shape `nestedLoop_stmtSimES` / `loopDet_lift_renamedGuard_E` / `_TE` consume. +(Measure-free, invariant-free loops, as the lifted form produces.) -/ +public theorem stmtSubstMany_loop_det [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (g : P.Expr) (body : List (Stmt P (Cmd P))) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) : + stmtSubstMany (Stmt.loop (.det g) none [] body md) subst + = Stmt.loop (.det (substFvarMany g subst)) none [] (Block.applyRenames subst body) md := by + induction subst generalizing g body with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + rw [stmtSubstMany_cons, Stmt.substIdent_loop] + -- reduce the head-pair rename on guard (.det), measure (none) and invariants ([]) + -- so the IH (stated for the `.det _ none [] _` shape) applies. + simp only [ExprOrNondet.substIdent_det, Option.map_none, List.map_nil] + rw [ih] + -- guard: substFvarMany of (substFvar g a (mkFvar b)) over tl = substFvarMany g ((a,b)::tl) + -- body: applyRenames tl (substIdent a b body) = applyRenames ((a,b)::tl) body + rw [applyRenames_cons] + rfl + +/-- An `assert` command folds to `substFvarMany` of its predicate. -/ +public theorem cmdSubstMany_assert [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (lbl : String) (e : P.Expr) (md : MetaData P) (subst : List (P.Ident × P.Ident)) : + (subst.foldl (fun acc p => Cmd.substIdent p.1 p.2 acc) (Cmd.assert lbl e md)) + = Cmd.assert lbl (substFvarMany e subst) md := by + induction subst generalizing e with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + simp only [List.foldl_cons, Cmd.substIdent_assert] + rw [ih] + rfl + +/-- An `init` command folds to: name renamed by `renameLookup`, rhs by the +per-`ExprOrNondet` fold. This shows the NAME-position iterated rename is exactly +`renameLookup` — the same resolver `substFvarMany_eval_tweak` uses — under target +freshness/distinctness. We state the SYNTACTIC fold here; the `renameLookup` +identification is the freshness-bearing fact, proved next. -/ +public theorem cmdSubstMany_init_name_fold [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (name : P.Ident) (ty : P.Ty) (e : ExprOrNondet P) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) : + (subst.foldl (fun acc p => Cmd.substIdent p.1 p.2 acc) (Cmd.init name ty e md)) + = Cmd.init + (subst.foldl (fun acc p => if acc = p.1 then p.2 else acc) name) + ty + (subst.foldl (fun acc p => ExprOrNondet.substIdent p.1 p.2 acc) e) + md := by + induction subst generalizing name e with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + simp only [List.foldl_cons, Cmd.substIdent_init] + rw [ih] + +/-! ### Freshness reconciliation for the NAME position. + +The init/set NAME position is renamed by an iterated `if name = aᵢ then bᵢ` +fold, head-first. Under the lift's well-formedness — targets `Nodup`, sources +disjoint from targets — this iterated name-fold collapses to `renameLookup subst +name`, the SAME single-pass resolver that `substFvarMany_eval_tweak` uses on the +store. This is the one place the freshness/uniqueness bundle is genuinely needed +at the SYNTACTIC level: without source-target disjointness a freshly-introduced +target could be re-renamed by a later pair. + +PRECONDITION ACTUALLY NEEDED (revealed by the proof): `h_disjoint` (sources +disjoint from targets) — exactly what the pass guarantees and what the driver +already threads. Source-nodup is NOT needed for the name-fold collapse (only for +`renameLookup_mem`, which the eval lemmas use separately). -/ + +/-- The iterated name-fold from a value `v` that is NOT a source of any pair is +the identity (no `if v = aᵢ` guard ever fires). -/ +public theorem name_fold_notin_id [DecidableEq P.Ident] + (subst : List (P.Ident × P.Ident)) (v : P.Ident) + (h : v ∉ subst.map Prod.fst) : + (subst.foldl (fun acc p => if acc = p.1 then p.2 else acc) v) = v := by + induction subst generalizing v with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a', b'⟩ + simp only [List.foldl_cons] + have hva' : v ≠ a' := fun heq => h (by simp [heq]) + rw [if_neg hva'] + exact ih v (fun hmem => h (by simp only [List.map_cons, List.mem_cons]; exact Or.inr hmem)) + +public theorem name_fold_eq_renameLookup [DecidableEq P.Ident] + (subst : List (P.Ident × P.Ident)) (name : P.Ident) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) : + (subst.foldl (fun acc p => if acc = p.1 then p.2 else acc) name) + = renameLookup subst name := by + induction subst generalizing name with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + simp only [List.foldl_cons, renameLookup_cons] + by_cases hna : name = a + · -- name = a: head renames it to b. The tail fold from b is identity because + -- b is a target (disjointness ⇒ b ∉ tl.fst), and renameLookup tl b = b too. + subst hna + rw [if_pos rfl, if_pos rfl] + have hb_notin_tl_fst : b ∉ tl.map Prod.fst := by + intro hmem + exact h_disjoint b (by simp [hmem]) (by simp) + exact name_fold_notin_id tl b hb_notin_tl_fst + · -- name ≠ a: head leaves name; recurse with tail-disjointness. + rw [if_neg hna, if_neg hna] + apply ih + intro a' ha' hb' + exact h_disjoint a' (by simp [ha']) (by simp [hb']) + +/-- Full `init` leaf reconciliation: under disjointness the fold lands exactly on +`renameLookup`-renamed name + (for a `.det` rhs) `substFvarMany`-renamed rhs. -/ +public theorem cmdSubstMany_init_det [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (name : P.Ident) (ty : P.Ty) (rhs : P.Expr) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) : + (subst.foldl (fun acc p => Cmd.substIdent p.1 p.2 acc) + (Cmd.init name ty (.det rhs) md)) + = Cmd.init (renameLookup subst name) ty (.det (substFvarMany rhs subst)) md := by + rw [cmdSubstMany_init_name_fold, name_fold_eq_renameLookup subst name h_disjoint, + exprOrNondet_substMany_det] + +/-! ## VERDICT (summary, machine-checked above). + +* The EXPRESSION-level keystone is DEFINITIONALLY TRUE: the fold `applyRenames` + applies to each expression position is `substFvarMany` by definition, with NO + preconditions. The "iterated vs simultaneous" reconciliation lives entirely in + the EVAL-level `substFvarMany_eval_*` lemmas, which already exist and carry the + freshness bundle. + +* The STRUCTURAL descent (`applyRenames_eq_map_stmtSubstMany`, + `stmtSubstMany_loop_det`, `cmdSubstMany_assert`, `exprOrNondet_substMany_det`) + is also SYNTACTIC and needs NO freshness — `applyRenames`'s outer fold commutes + with the structural recursion, landing on the exact `substFvarMany`-guard / + `applyRenames`-body shapes the loop driver consumes. + +* The ONLY freshness-bearing syntactic fact is the init/set NAME-position + collapse `name_fold_eq_renameLookup`, which needs PRECISELY `h_disjoint` + (sources disjoint from targets) — already threaded by the pass and driver. -/ + +end OptEKeystone +end Imperative diff --git a/Strata/Transform/LoopInitHoistLoopArmWF.lean b/Strata/Transform/LoopInitHoistLoopArmWF.lean new file mode 100644 index 0000000000..7840f36f0d --- /dev/null +++ b/Strata/Transform/LoopInitHoistLoopArmWF.lean @@ -0,0 +1,2766 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.Transform.LoopInitHoistLoopDriver +public import Strata.Transform.LoopInitHoistStepCProducer +public import Strata.Transform.LoopInitHoistContains + +import all Strata.DL.Imperative.Stmt +import all Strata.DL.Imperative.Cmd +import all Strata.Transform.LoopInitHoist +import all Strata.Transform.LoopInitHoistContains +import all Strata.Transform.LoopInitHoistLoopDriver +import all Strata.Transform.LoopInitHoistStepCProducer +import all Strata.Transform.LoopInitHoistFreshness + +public section + +namespace Imperative +namespace LoopInitHoistLoopArmWF + +open LoopInitHoistLoopDriver (Entry havocStmts' substOf' targetsOf' sourcesOf' + Stmt.entriesOf Block.entriesOf + Stmt.entriesOf_block Stmt.entriesOf_ite Block.entriesOf_cons + Block.sourcesOf_entriesOf_subset) +open LoopInitHoistStepCProducer (Block.transportShape Block.transportShape_of_arm_preconds) +open _root_.StringGenState (GenStep) + +variable {P : PureExpr} + +/-- `targetsOf'` distributes over list append (companion to the `substOf'`/ +`sourcesOf'`/`havocStmts'` append lemmas). -/ +theorem targetsOf'_append (xs ys : List (Entry P)) : + targetsOf' (xs ++ ys) = targetsOf' xs ++ targetsOf' ys := by + simp [targetsOf', List.map_append] + +/-! ## `namesFreshInExprs` is preserved by a single `substIdent` rename. + +`Block.substIdent y y'` renames every free occurrence of `y` to `y'` in the +value positions (rhs / guards / invariants / measure) and rewrites the binding +positions. The freshness check `namesFreshInExprs` only inspects the value +positions, so by the `LawfulHasSubstFvar.substFvar_getVars_subset` law (a +renamed expression's read-set is the original's plus possibly `y'`) every +`names`-element that was fresh in the original stays fresh after the rename, +PROVIDED the new name `y'` is not itself in `names` (otherwise the rename could +introduce `y'` where `y` appeared). -/ + +/-- `freshFromIdents z vars = true` iff `z ∉ vars`. -/ +private theorem freshFromIdents_eq_true_iff [DecidableEq P.Ident] + {z : P.Ident} {vars : List P.Ident} : + freshFromIdents z vars = true ↔ z ∉ vars := by + constructor + · intro h hmem + unfold freshFromIdents at h + rw [List.all_eq_true] at h + have h_z := h z hmem + have h_eq : (P.EqIdent z z).decide = true := by simp + rw [h_eq] at h_z + exact absurd h_z (by decide) + · intro h + unfold freshFromIdents + rw [List.all_eq_true] + intro v hmem + simp only [decide_eq_true_eq] + intro h_eq; subst h_eq; exact h hmem + +/-- The read-set transfer law as a `freshFromIdents` fact: if `z ≠ y'` is fresh +in `e`'s read-set, it stays fresh after substituting `y → y'`. -/ +private theorem freshFromIdents_substFvar [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + {z y y' : P.Ident} (e : P.Expr) + (h_ne : z ≠ y') + (h : freshFromIdents z (HasVarsPure.getVars e) = true) : + freshFromIdents z + (HasVarsPure.getVars (HasSubstFvar.substFvar e y (HasFvar.mkFvar y'))) = true := by + rw [freshFromIdents_eq_true_iff] at h ⊢ + intro hmem + rcases LawfulHasSubstFvar.substFvar_getVars_subset e y y' z hmem with h_orig | h_y' + · exact h h_orig + · exact h_ne h_y' + +/-- Same transfer law over `ExprOrNondet` (the `.nondet` case has empty +read-set, trivially preserved). -/ +private theorem freshFromIdents_exprOrNondet_substIdent [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + {z y y' : P.Ident} (e : ExprOrNondet P) + (h_ne : z ≠ y') + (h : freshFromIdents z (ExprOrNondet.getVars e) = true) : + freshFromIdents z (ExprOrNondet.getVars (e.substIdent y y')) = true := by + cases e with + | det e => exact freshFromIdents_substFvar e h_ne h + | nondet => simp only [ExprOrNondet.substIdent_nondet]; exact h + +mutual +/-- `Stmt.substIdent y y'` preserves `Stmt.namesFreshInExprs names` whenever +`y' ∉ names`. -/ +theorem Stmt.namesFreshInExprs_substIdent [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + (names : List P.Ident) (y y' : P.Ident) (s : Stmt P (Cmd P)) + (h_y'_not : y' ∉ names) + (h : Stmt.namesFreshInExprs names s = true) : + Stmt.namesFreshInExprs names (Stmt.substIdent y y' s) = true := by + cases s with + | cmd c => + cases c with + | init x ty rhs md => + simp only [Stmt.substIdent_cmd, Cmd.substIdent_init, Stmt.namesFreshInExprs, + List.all_eq_true] at h ⊢ + intro z hz + exact freshFromIdents_exprOrNondet_substIdent rhs (fun he => h_y'_not (he ▸ hz)) (h z hz) + | set x rhs md => + simp only [Stmt.substIdent_cmd, Cmd.substIdent_set, Stmt.namesFreshInExprs, + List.all_eq_true] at h ⊢ + intro z hz + exact freshFromIdents_exprOrNondet_substIdent rhs (fun he => h_y'_not (he ▸ hz)) (h z hz) + | assert l e md => + simp only [Stmt.substIdent_cmd, Cmd.substIdent_assert, Stmt.namesFreshInExprs, + List.all_eq_true] at h ⊢ + intro z hz + exact freshFromIdents_substFvar e (fun he => h_y'_not (he ▸ hz)) (h z hz) + | assume l e md => + simp only [Stmt.substIdent_cmd, Cmd.substIdent_assume, Stmt.namesFreshInExprs, + List.all_eq_true] at h ⊢ + intro z hz + exact freshFromIdents_substFvar e (fun he => h_y'_not (he ▸ hz)) (h z hz) + | cover l e md => + simp only [Stmt.substIdent_cmd, Cmd.substIdent_cover, Stmt.namesFreshInExprs, + List.all_eq_true] at h ⊢ + intro z hz + exact freshFromIdents_substFvar e (fun he => h_y'_not (he ▸ hz)) (h z hz) + | block lbl bss md => + simp only [Stmt.substIdent_block, Stmt.namesFreshInExprs] at h ⊢ + exact Block.namesFreshInExprs_substIdent names y y' bss h_y'_not h + | ite g tss ess md => + simp only [Stmt.substIdent_ite, Stmt.namesFreshInExprs, Bool.and_eq_true, + List.all_eq_true] at h ⊢ + obtain ⟨⟨h_g, h_t⟩, h_e⟩ := h + refine ⟨⟨?_, ?_⟩, ?_⟩ + · intro z hz + exact freshFromIdents_exprOrNondet_substIdent g (fun he => h_y'_not (he ▸ hz)) (h_g z hz) + · exact Block.namesFreshInExprs_substIdent names y y' tss h_y'_not h_t + · exact Block.namesFreshInExprs_substIdent names y y' ess h_y'_not h_e + | loop g m inv body md => + rw [Stmt.substIdent_loop] + unfold Stmt.namesFreshInExprs at h ⊢ + rw [Bool.and_eq_true, Bool.and_eq_true, Bool.and_eq_true] at h ⊢ + obtain ⟨⟨⟨h_g, h_m⟩, h_inv⟩, h_body⟩ := h + refine ⟨⟨⟨?_, ?_⟩, ?_⟩, ?_⟩ + · rw [List.all_eq_true] at h_g ⊢ + intro z hz + exact freshFromIdents_exprOrNondet_substIdent g (fun he => h_y'_not (he ▸ hz)) (h_g z hz) + · cases m with + | none => simp only [Option.map_none] + | some me => + simp only [Option.map_some] at h_m ⊢ + rw [List.all_eq_true] at h_m ⊢ + intro z hz + exact freshFromIdents_substFvar me (fun he => h_y'_not (he ▸ hz)) (h_m z hz) + · rw [List.all_eq_true] at h_inv ⊢ + intro p hp + simp only [List.mem_map] at hp + obtain ⟨p0, hp0_mem, hp0_eq⟩ := hp + subst hp0_eq + have h_p := h_inv p0 hp0_mem + rw [List.all_eq_true] at h_p ⊢ + intro z hz + exact freshFromIdents_substFvar p0.2 (fun he => h_y'_not (he ▸ hz)) (h_p z hz) + · exact Block.namesFreshInExprs_substIdent names y y' body h_y'_not h_body + | exit lbl md => + simp only [Stmt.substIdent_exit, Stmt.namesFreshInExprs] + | funcDecl d md => + simp only [Stmt.substIdent_funcDecl, Stmt.namesFreshInExprs] + | typeDecl t md => + simp only [Stmt.substIdent_typeDecl, Stmt.namesFreshInExprs] + termination_by sizeOf s + +/-- `Block.substIdent y y'` preserves `Block.namesFreshInExprs names` whenever +`y' ∉ names`. -/ +theorem Block.namesFreshInExprs_substIdent [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + (names : List P.Ident) (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) + (h_y'_not : y' ∉ names) + (h : Block.namesFreshInExprs names ss = true) : + Block.namesFreshInExprs names (Block.substIdent y y' ss) = true := by + match ss with + | [] => simp only [Block.substIdent_nil, Block.namesFreshInExprs] + | s :: rest => + simp only [Block.substIdent_cons, Block.namesFreshInExprs, Bool.and_eq_true] at h ⊢ + exact ⟨Stmt.namesFreshInExprs_substIdent names y y' s h_y'_not h.1, + Block.namesFreshInExprs_substIdent names y y' rest h_y'_not h.2⟩ + termination_by sizeOf ss +end + +/-- `Block.applyRenames` preserves `Block.namesFreshInExprs names` whenever +every rename TARGET (`renames.map Prod.snd`) is disjoint from `names`. The +sources may be in `names`; only the targets matter, because substitution can +only INTRODUCE the target (`y'`) into the value positions. -/ +theorem Block.namesFreshInExprs_applyRenames [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + (names : List P.Ident) (renames : List (P.Ident × P.Ident)) + (ss : List (Stmt P (Cmd P))) + (h_tgt_not : ∀ p ∈ renames, p.2 ∉ names) + (h : Block.namesFreshInExprs names ss = true) : + Block.namesFreshInExprs names (Block.applyRenames renames ss) = true := by + induction renames generalizing ss with + | nil => simpa only [Block.applyRenames] using h + | cons p rest ih => + rw [Block.applyRenames] + simp only [List.foldl_cons] + have h_step : Block.namesFreshInExprs names (Block.substIdent p.1 p.2 ss) = true := + Block.namesFreshInExprs_substIdent names p.1 p.2 ss + (h_tgt_not p (List.mem_cons_self ..)) h + have := ih (Block.substIdent p.1 p.2 ss) + (fun q hq => h_tgt_not q (List.mem_cons_of_mem _ hq)) h_step + rw [Block.applyRenames] at this + exact this + +/-- The MONADIC lift residual preserves `Block.namesFreshInExprs names` (no +name-list change). The residual only ever rewrites `init`→`set` (rhs +unchanged) and recurses structurally; freshness transfers verbatim. Bridged +from the pure-wrapper preservation via the state-independence of the residual +(`Block.liftInitsInLoopBody_snd_eq`). -/ +theorem Block.liftInitsInLoopBodyM_snd_namesFreshInExprs [HasIdent P] [HasVarsPure P P.Expr] + (names : List P.Ident) (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h : Block.namesFreshInExprs names ss = true) : + Block.namesFreshInExprs names (Block.liftInitsInLoopBodyM ss σ).1.2.2 = true := by + rw [← Block.liftInitsInLoopBody_snd_eq ss σ] + exact Block.liftInitsInLoopBody_snd_namesFreshInExprs names ss h + +/-! ## The harvest targets are generator-shaped (`_` suffix). + +Every entry harvested by `Stmt/Block.entriesOf` has a target ident +`e.2.1 = HasIdent.ident s` for a generator string `s` (it is the `.1` of a +`StringGenState.gen` call), so `s` always has the `_` suffix shape. This +lets us conclude that any name whose underlying string lacks that suffix is +disjoint from every rename TARGET the pass introduces — the precise condition +that `namesFreshInExprs_applyRenames` consumes. -/ + +mutual +/-- Every entry target harvested from a statement is a `Q`-kind ident, given the +mint witness `hQmint` that hoist's freshly minted names satisfy `Q`. +Instantiating `Q := String.HasUnderscoreDigitSuffix` with the `gen`-suffix +witness recovers the blanket "generator-suffixed" statement. -/ +theorem Stmt.entriesOf_target_suffix [HasIdent P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (s : Stmt P (Cmd P)) (σ : StringGenState) : + ∀ e ∈ Stmt.entriesOf s σ, + ∃ str : String, e.2.1 = HasIdent.ident str ∧ Q str := by + match s with + | .cmd c => + cases c with + | init y ty rhs md => + intro e he + rw [Stmt.entriesOf] at he + simp only [List.mem_singleton] at he + subst he + exact ⟨(StringGenState.gen hoistFreshPrefix σ).1, rfl, hQmint σ⟩ + | set x rhs md => intro e he; simp only [Stmt.entriesOf, List.not_mem_nil] at he + | assert l ex md => intro e he; simp only [Stmt.entriesOf, List.not_mem_nil] at he + | assume l ex md => intro e he; simp only [Stmt.entriesOf, List.not_mem_nil] at he + | cover l ex md => intro e he; simp only [Stmt.entriesOf, List.not_mem_nil] at he + | .block lbl bss md => + rw [Stmt.entriesOf]; exact Block.entriesOf_target_suffix hQmint bss σ + | .ite g tss ess md => + rw [Stmt.entriesOf, List.forall_mem_append] + exact ⟨Block.entriesOf_target_suffix hQmint tss σ, + Block.entriesOf_target_suffix hQmint ess (Block.liftInitsInLoopBodyM tss σ).2⟩ + | .loop g m inv body md => intro e he; simp only [Stmt.entriesOf, List.not_mem_nil] at he + | .exit lbl md => intro e he; simp only [Stmt.entriesOf, List.not_mem_nil] at he + | .funcDecl d md => intro e he; simp only [Stmt.entriesOf, List.not_mem_nil] at he + | .typeDecl t md => intro e he; simp only [Stmt.entriesOf, List.not_mem_nil] at he + termination_by sizeOf s + +/-- Every entry target harvested from a block is a `Q`-kind ident. -/ +theorem Block.entriesOf_target_suffix [HasIdent P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + ∀ e ∈ Block.entriesOf ss σ, + ∃ str : String, e.2.1 = HasIdent.ident str ∧ Q str := by + match ss with + | [] => intro e he; simp only [Block.entriesOf, List.not_mem_nil] at he + | s :: rest => + rw [Block.entriesOf, List.forall_mem_append] + exact ⟨Stmt.entriesOf_target_suffix hQmint s σ, + Block.entriesOf_target_suffix hQmint rest (Stmt.liftInitsInLoopBodyM s σ).2⟩ + termination_by sizeOf ss +end + +/-- The havoc prelude `havocStmts' E` is always fresh in any `names`: every +havoc cmd is `init target ty .nondet md` whose rhs has empty read-set. -/ +theorem namesFreshInExprs_havocStmts' [HasVarsPure P P.Expr] + (names : List P.Ident) (entries : List (Entry P)) : + Block.namesFreshInExprs names (havocStmts' entries) = true := by + induction entries with + | nil => rw [LoopInitHoistLoopDriver.havocStmts'_nil, Block.namesFreshInExprs] + | cons e rest ih => + rw [LoopInitHoistLoopDriver.havocStmts'_cons, Block.namesFreshInExprs, Bool.and_eq_true] + refine ⟨?_, ih⟩ + simp only [Stmt.namesFreshInExprs, ExprOrNondet.getVars, freshFromIdents, + List.all_nil, List.all_eq_true, implies_true] + +/-! +# Producer-precondition WF sub-lemmas for the §E `.loop` arm. + +The §E `.loop` arm feeds `Block.bodyTransport_of_lift` on the post-order body +`body₁ = (Block.hoistLoopPrefixInitsM body σ).1` with carriers +`A := sourcesOf' E`, `B := targetsOf' E`, `subst := substOf' E`, where +`E := Block.entriesOf body₁ σ₁` is the harvest of `body₁`'s prefix inits. + +This file proves the structural WF facts that producer needs as preconditions, +phrased over `E`. The hardest is `targetsOf' E` Nodup: the targets are the +fresh idents the generator produced along the harvest, and they are globally +distinct because each is generated at a distinct generator state and the +generator never repeats a label (`StringGenState` monotonicity + well-formed +uniqueness). +-/ + +/-! ## State-threading helpers for the lift. + +The harvest `Block.entriesOf` threads its generator state in lockstep with the +lift `Block.liftInitsInLoopBodyM`; these equalities expose the lift's final +state under `.block`/`.ite`/cons so the `entriesOf_targetGen` recursion can name +the intermediate states. -/ + +theorem Stmt.liftInitsInLoopBodyM_block_residual_state [HasIdent P] + (lbl : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) : + (Stmt.liftInitsInLoopBodyM (.block lbl bss md) σ).2 + = (Block.liftInitsInLoopBodyM bss σ).2 := by + rw [Stmt.liftInitsInLoopBodyM] + rcases h : Block.liftInitsInLoopBodyM bss σ with ⟨⟨hs, rn, bss'⟩, σ'⟩ + simp only [h] + +theorem Stmt.liftInitsInLoopBodyM_ite_residual_state [HasIdent P] + (g : ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) : + (Stmt.liftInitsInLoopBodyM (.ite g tss ess md) σ).2 + = (Block.liftInitsInLoopBodyM ess (Block.liftInitsInLoopBodyM tss σ).2).2 := by + rw [Stmt.liftInitsInLoopBodyM] + rcases h₁ : Block.liftInitsInLoopBodyM tss σ with ⟨⟨ths, trn, tss'⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM ess σ₁ with ⟨⟨ehs, ern, ess'⟩, σ₂⟩ + simp only [h₁, h₂] + +theorem Block.liftInitsInLoopBodyM_cons_residual_state [HasIdent P] + (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) (σ : StringGenState) : + (Block.liftInitsInLoopBodyM (s :: rest) σ).2 + = (Block.liftInitsInLoopBodyM rest (Stmt.liftInitsInLoopBodyM s σ).2).2 := by + rw [Block.liftInitsInLoopBodyM] + rcases h₁ : Stmt.liftInitsInLoopBodyM s σ with ⟨⟨hs_s, rn_s, ss_s⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM rest σ₁ with ⟨⟨hs_r, rn_r, ss_r⟩, σ₂⟩ + simp only [h₁, h₂] + +/-! ## The harvest targets are fresh generated names: distinct and captured. + +The master invariant: under `WF σ`, every entry harvested from `body` at `σ` +has a target ident `e.2.1 = HasIdent.ident s` for a generator STRING `s` that is +(a) NOT yet present in `σ`'s produced labels, and (b) ALREADY present in the +final state's labels of the lift. Together with monotonicity this yields +pairwise distinctness of the harvest's target strings, hence `Nodup`. -/ + +/-- Per-entry target fact: the target is `HasIdent.ident s` for a generator +string `s` fresh from the input state and captured in the lift's final state. -/ +def TargetGen [HasIdent P] (σ σ' : StringGenState) (e : Entry P) : Prop := + ∃ s : String, e.2.1 = HasIdent.ident s + ∧ s ∈ StringGenState.stringGens σ' + ∧ s ∉ StringGenState.stringGens σ + +mutual +/-- Every entry harvested from a single statement carries a `TargetGen` fact +between the input state and the lift's final state; and the targets are +`Nodup`. -/ +theorem Stmt.entriesOf_targetGen [HasIdent P] [LawfulHasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) (h_wf : StringGenState.WF σ) : + (∀ e ∈ Stmt.entriesOf s σ, TargetGen σ (Stmt.liftInitsInLoopBodyM s σ).2 e) + ∧ (targetsOf' (Stmt.entriesOf s σ)).Nodup := by + match s with + | .cmd c => + cases c with + | init y ty rhs md => + refine ⟨?_, ?_⟩ + · intro e he + rw [Stmt.entriesOf] at he + simp only [List.mem_singleton] at he + subst he + rw [Stmt.liftInitsInLoopBodyM] + refine ⟨(StringGenState.gen hoistFreshPrefix σ).1, rfl, ?_, ?_⟩ + · rw [StringGenState.stringGens_gen]; exact List.mem_cons_self .. + · exact StringGenState.stringGens_gen_not_in hoistFreshPrefix σ h_wf + · rw [Stmt.entriesOf] + simp [targetsOf'] + | set x rhs md => refine ⟨?_, ?_⟩ <;> simp [Stmt.entriesOf, targetsOf'] + | assert l e md => refine ⟨?_, ?_⟩ <;> simp [Stmt.entriesOf, targetsOf'] + | assume l e md => refine ⟨?_, ?_⟩ <;> simp [Stmt.entriesOf, targetsOf'] + | cover l e md => refine ⟨?_, ?_⟩ <;> simp [Stmt.entriesOf, targetsOf'] + | .block lbl bss md => + rw [Stmt.entriesOf, Stmt.liftInitsInLoopBodyM_block_residual_state] + exact Block.entriesOf_targetGen bss σ h_wf + | .ite g tss ess md => + rw [Stmt.entriesOf, Stmt.liftInitsInLoopBodyM_ite_residual_state] + have ih_t := Block.entriesOf_targetGen tss σ h_wf + have h_wf_σ₁ : StringGenState.WF (Block.liftInitsInLoopBodyM tss σ).2 := + (Block.liftInitsInLoopBodyM_genStep tss σ).wf_mono h_wf + have ih_e := Block.entriesOf_targetGen ess (Block.liftInitsInLoopBodyM tss σ).2 h_wf_σ₁ + have h_step_t : GenStep σ (Block.liftInitsInLoopBodyM tss σ).2 := + Block.liftInitsInLoopBodyM_genStep tss σ + have h_step_e : GenStep (Block.liftInitsInLoopBodyM tss σ).2 + (Block.liftInitsInLoopBodyM ess (Block.liftInitsInLoopBodyM tss σ).2).2 := + Block.liftInitsInLoopBodyM_genStep ess _ + refine ⟨?_, ?_⟩ + · intro e he + rw [List.mem_append] at he + rcases he with h | h + · obtain ⟨t, ht_eq, ht_in, ht_not⟩ := ih_t.1 e h + exact ⟨t, ht_eq, h_step_e.subset ht_in, ht_not⟩ + · obtain ⟨t, ht_eq, ht_in, ht_not⟩ := ih_e.1 e h + refine ⟨t, ht_eq, ht_in, ?_⟩ + intro h_in_σ; exact ht_not (h_step_t.subset h_in_σ) + · rw [targetsOf'_append, List.nodup_append] + refine ⟨ih_t.2, ih_e.2, ?_⟩ + intro x hx_t y hx_e h_eq + -- x is a then-target string captured in σ₁; y is an else-target fresh from σ₁. + obtain ⟨et, het_mem, het_eq⟩ := List.mem_map.mp hx_t + obtain ⟨ee, hee_mem, hee_eq⟩ := List.mem_map.mp hx_e + obtain ⟨st, hst_eq, hst_in, _⟩ := ih_t.1 et het_mem + obtain ⟨se, hse_eq, _, hse_not⟩ := ih_e.1 ee hee_mem + -- x = et.2.1 = ident st (captured in σ₁) and y = ee.2.1 = ident se (fresh from σ₁) + apply hse_not + have h_id : (HasIdent.ident st : P.Ident) = HasIdent.ident se := by + rw [← hst_eq, ← hse_eq, het_eq, hee_eq, h_eq] + have : st = se := LawfulHasIdent.ident_inj h_id + rw [← this]; exact hst_in + | .loop g m inv body md => + rw [Stmt.entriesOf]; refine ⟨by simp, by simp [targetsOf']⟩ + | .exit lbl md => rw [Stmt.entriesOf]; refine ⟨by simp, by simp [targetsOf']⟩ + | .funcDecl d md => rw [Stmt.entriesOf]; refine ⟨by simp, by simp [targetsOf']⟩ + | .typeDecl t md => rw [Stmt.entriesOf]; refine ⟨by simp, by simp [targetsOf']⟩ + termination_by sizeOf s + +theorem Block.entriesOf_targetGen [HasIdent P] [LawfulHasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) (h_wf : StringGenState.WF σ) : + (∀ e ∈ Block.entriesOf ss σ, TargetGen σ (Block.liftInitsInLoopBodyM ss σ).2 e) + ∧ (targetsOf' (Block.entriesOf ss σ)).Nodup := by + match ss with + | [] => + rw [Block.entriesOf]; refine ⟨by simp, by simp [targetsOf']⟩ + | s :: rest => + rw [Block.entriesOf, Block.liftInitsInLoopBodyM_cons_residual_state] + have ih_s := Stmt.entriesOf_targetGen s σ h_wf + have h_wf_σ₁ : StringGenState.WF (Stmt.liftInitsInLoopBodyM s σ).2 := + (Stmt.liftInitsInLoopBodyM_genStep s σ).wf_mono h_wf + have ih_r := Block.entriesOf_targetGen rest (Stmt.liftInitsInLoopBodyM s σ).2 h_wf_σ₁ + have h_step_s : GenStep σ (Stmt.liftInitsInLoopBodyM s σ).2 := + Stmt.liftInitsInLoopBodyM_genStep s σ + have h_step_r : GenStep (Stmt.liftInitsInLoopBodyM s σ).2 + (Block.liftInitsInLoopBodyM rest (Stmt.liftInitsInLoopBodyM s σ).2).2 := + Block.liftInitsInLoopBodyM_genStep rest _ + refine ⟨?_, ?_⟩ + · intro e he + rw [List.mem_append] at he + rcases he with h | h + · obtain ⟨t, ht_eq, ht_in, ht_not⟩ := ih_s.1 e h + exact ⟨t, ht_eq, h_step_r.subset ht_in, ht_not⟩ + · obtain ⟨t, ht_eq, ht_in, ht_not⟩ := ih_r.1 e h + refine ⟨t, ht_eq, ht_in, ?_⟩ + intro h_in_σ; exact ht_not (h_step_s.subset h_in_σ) + · rw [targetsOf'_append, List.nodup_append] + refine ⟨ih_s.2, ih_r.2, ?_⟩ + intro x hx_s y hx_r h_eq + obtain ⟨es, hes_mem, hes_eq⟩ := List.mem_map.mp hx_s + obtain ⟨er, her_mem, her_eq⟩ := List.mem_map.mp hx_r + obtain ⟨ss', hss_eq, hss_in, _⟩ := ih_s.1 es hes_mem + obtain ⟨sr, hsr_eq, _, hsr_not⟩ := ih_r.1 er her_mem + apply hsr_not + have h_id : (HasIdent.ident ss' : P.Ident) = HasIdent.ident sr := by + rw [← hss_eq, ← hsr_eq, hes_eq, her_eq, h_eq] + have : ss' = sr := LawfulHasIdent.ident_inj h_id + rw [← this]; exact hss_in + termination_by sizeOf ss +end + +/-! ## The lift rename targets are captured in the lift's output state. + +A WF-free companion to `entriesOf_targetGen`: every rename TARGET the monadic +lift produces is `HasIdent.ident s` for a generator string `s` that lies in the +lift's *output* `stringGens`. (No freshness/Nodup needed — just that each fresh +name is captured.) This is the half consumed by the gen-state freshness route +for the TARGETS carrier. -/ + +/-- The renames component of `Stmt.liftInitsInLoopBodyM (.block ..) σ` equals the +sub-block's renames. -/ +private theorem Stmt.liftInitsInLoopBodyM_block_renames [HasIdent P] + (lbl : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) (σ : StringGenState) : + (Stmt.liftInitsInLoopBodyM (.block lbl bss md) σ).1.2.1 + = (Block.liftInitsInLoopBodyM bss σ).1.2.1 := by + rw [Stmt.liftInitsInLoopBodyM] + rcases h : Block.liftInitsInLoopBodyM bss σ with ⟨⟨hs, rn, bss'⟩, σ'⟩ + simp only [h] + +/-- The renames component of `Stmt.liftInitsInLoopBodyM (.ite ..) σ` is the +concatenation of the two branches' renames. -/ +private theorem Stmt.liftInitsInLoopBodyM_ite_renames [HasIdent P] + (g : ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) : + (Stmt.liftInitsInLoopBodyM (.ite g tss ess md) σ).1.2.1 + = (Block.liftInitsInLoopBodyM tss σ).1.2.1 ++ + (Block.liftInitsInLoopBodyM ess (Block.liftInitsInLoopBodyM tss σ).2).1.2.1 := by + rw [Stmt.liftInitsInLoopBodyM] + rcases h₁ : Block.liftInitsInLoopBodyM tss σ with ⟨⟨ths, trn, tss'⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM ess σ₁ with ⟨⟨ehs, ern, ess'⟩, σ₂⟩ + simp only [h₁, h₂] + +/-- The renames component of `Block.liftInitsInLoopBodyM (s :: rest) σ` is the +head's renames concatenated with the tail's. -/ +private theorem Block.liftInitsInLoopBodyM_cons_renames [HasIdent P] + (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) (σ : StringGenState) : + (Block.liftInitsInLoopBodyM (s :: rest) σ).1.2.1 + = (Stmt.liftInitsInLoopBodyM s σ).1.2.1 ++ + (Block.liftInitsInLoopBodyM rest (Stmt.liftInitsInLoopBodyM s σ).2).1.2.1 := by + rw [Block.liftInitsInLoopBodyM] + rcases h₁ : Stmt.liftInitsInLoopBodyM s σ with ⟨⟨hs_s, rn_s, ss_s⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM rest σ₁ with ⟨⟨hs_r, rn_r, ss_r⟩, σ₂⟩ + simp only [h₁, h₂] + +mutual +/-- Every rename target produced by `Stmt.liftInitsInLoopBodyM s σ` is captured +in the lift's output state's `stringGens`. -/ +theorem Stmt.liftInitsInLoopBodyM_renames_captured [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + ∀ p ∈ (Stmt.liftInitsInLoopBodyM s σ).1.2.1, + ∃ str : String, p.2 = HasIdent.ident str ∧ + str ∈ StringGenState.stringGens (Stmt.liftInitsInLoopBodyM s σ).2 := by + match s with + | .cmd c => + cases c with + | init y ty rhs md => + intro p hp + rw [Stmt.liftInitsInLoopBodyM] at hp ⊢ + simp only [List.mem_singleton] at hp + subst hp + refine ⟨(StringGenState.gen hoistFreshPrefix σ).1, rfl, ?_⟩ + rw [StringGenState.stringGens_gen]; exact List.mem_cons_self .. + | set x rhs md => intro p hp; simp only [Stmt.liftInitsInLoopBodyM, List.not_mem_nil] at hp + | assert l ex md => intro p hp; simp only [Stmt.liftInitsInLoopBodyM, List.not_mem_nil] at hp + | assume l ex md => intro p hp; simp only [Stmt.liftInitsInLoopBodyM, List.not_mem_nil] at hp + | cover l ex md => intro p hp; simp only [Stmt.liftInitsInLoopBodyM, List.not_mem_nil] at hp + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM_block_renames, Stmt.liftInitsInLoopBodyM_block_residual_state] + exact Block.liftInitsInLoopBodyM_renames_captured bss σ + | .ite g tss ess md => + have h_step_e : GenStep (Block.liftInitsInLoopBodyM tss σ).2 + (Block.liftInitsInLoopBodyM ess (Block.liftInitsInLoopBodyM tss σ).2).2 := + Block.liftInitsInLoopBodyM_genStep ess _ + rw [Stmt.liftInitsInLoopBodyM_ite_renames, Stmt.liftInitsInLoopBodyM_ite_residual_state, + List.forall_mem_append] + refine ⟨fun p h => ?_, Block.liftInitsInLoopBodyM_renames_captured ess _⟩ + obtain ⟨str, hstr_eq, hstr_in⟩ := Block.liftInitsInLoopBodyM_renames_captured tss σ p h + exact ⟨str, hstr_eq, h_step_e.subset hstr_in⟩ + | .loop g m inv body md => intro p hp; simp only [Stmt.liftInitsInLoopBodyM, List.not_mem_nil] at hp + | .exit lbl md => intro p hp; simp only [Stmt.liftInitsInLoopBodyM, List.not_mem_nil] at hp + | .funcDecl d md => intro p hp; simp only [Stmt.liftInitsInLoopBodyM, List.not_mem_nil] at hp + | .typeDecl t md => intro p hp; simp only [Stmt.liftInitsInLoopBodyM, List.not_mem_nil] at hp + termination_by sizeOf s + +/-- Every rename target produced by `Block.liftInitsInLoopBodyM ss σ` is captured +in the lift's output state's `stringGens`. -/ +theorem Block.liftInitsInLoopBodyM_renames_captured [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + ∀ p ∈ (Block.liftInitsInLoopBodyM ss σ).1.2.1, + ∃ str : String, p.2 = HasIdent.ident str ∧ + str ∈ StringGenState.stringGens (Block.liftInitsInLoopBodyM ss σ).2 := by + match ss with + | [] => intro p hp; simp only [Block.liftInitsInLoopBodyM, List.not_mem_nil] at hp + | s :: rest => + have h_step_r : GenStep (Stmt.liftInitsInLoopBodyM s σ).2 + (Block.liftInitsInLoopBodyM rest (Stmt.liftInitsInLoopBodyM s σ).2).2 := + Block.liftInitsInLoopBodyM_genStep rest _ + rw [Block.liftInitsInLoopBodyM_cons_renames, Block.liftInitsInLoopBodyM_cons_residual_state, + List.forall_mem_append] + refine ⟨fun p h => ?_, Block.liftInitsInLoopBodyM_renames_captured rest _⟩ + obtain ⟨str, hstr_eq, hstr_in⟩ := Stmt.liftInitsInLoopBodyM_renames_captured s σ p h + exact ⟨str, hstr_eq, h_step_r.subset hstr_in⟩ + termination_by sizeOf ss +end + +/-! ## Output-state peels for the hoist pass. + +These expose `(Block/Stmt.hoistLoopPrefixInitsM _ σ).2` in terms of the +sub-structure's output states, the analogue of the `_out` list peels. They let +the gen-state freshness route name the per-subtree output `stringGens`. -/ + +theorem Stmt.hoistLoopPrefixInitsM_block_state [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (lbl : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) (σ : StringGenState) : + (Stmt.hoistLoopPrefixInitsM (.block lbl bss md) σ).2 + = (Block.hoistLoopPrefixInitsM bss σ).2 := by + rw [Stmt.hoistLoopPrefixInitsM] + rcases h : Block.hoistLoopPrefixInitsM bss σ with ⟨bss', σ'⟩ + simp only [h] + +theorem Stmt.hoistLoopPrefixInitsM_ite_state [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (g : ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) : + (Stmt.hoistLoopPrefixInitsM (.ite g tss ess md) σ).2 + = (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).2 := by + rw [Stmt.hoistLoopPrefixInitsM] + rcases h₁ : Block.hoistLoopPrefixInitsM tss σ with ⟨tss', σ₁⟩ + rcases h₂ : Block.hoistLoopPrefixInitsM ess σ₁ with ⟨ess', σ₂⟩ + simp only [h₁, h₂] + +theorem Stmt.hoistLoopPrefixInitsM_loop_state [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (g : ExprOrNondet P) (m : Option P.Expr) (inv : List (String × P.Expr)) + (body : List (Stmt P (Cmd P))) (md : MetaData P) (σ : StringGenState) : + (Stmt.hoistLoopPrefixInitsM (.loop g m inv body md) σ).2 + = (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).2 := by + rw [Stmt.hoistLoopPrefixInitsM] + rcases h₁ : Block.hoistLoopPrefixInitsM body σ with ⟨body₁, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM body₁ σ₁ with ⟨⟨havocs, renames, body₂⟩, σ₂⟩ + simp only [h₁, h₂] + +theorem Block.hoistLoopPrefixInitsM_cons_state [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) (σ : StringGenState) : + (Block.hoistLoopPrefixInitsM (s :: rest) σ).2 + = (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).2 := by + rw [Block.hoistLoopPrefixInitsM] + rcases h₁ : Stmt.hoistLoopPrefixInitsM s σ with ⟨ss_s, σ₁⟩ + rcases h₂ : Block.hoistLoopPrefixInitsM rest σ₁ with ⟨ss_r, σ₂⟩ + simp only [h₁, h₂] + +/-! ## Gen-state freshness route to the TARGETS carrier. + +A second generic preservation, dual to the suffix route: names that are fresh +from the pass's OUTPUT state's `stringGens` stay fresh through the pass (given +they were fresh in the source body's exprs). Every rename target the pass +introduces is captured in that output state (`..._renames_captured`), so the +`.loop` arm's `applyRenames` cannot reintroduce a name. This is the half that +the TARGETS carrier (`targetsOf' E`, fresh from the pass output by `TargetGen`) +satisfies. -/ + +mutual +/-- `Stmt.hoistLoopPrefixInitsM` preserves `Block.namesFreshInExprs names` for +names that are fresh from the pass output state's `stringGens` (and fresh in the +source statement's exprs). -/ +theorem Stmt.hoistLoopPrefixInitsM_namesFreshInExprs_genfresh [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + (names : List P.Ident) (s : Stmt P (Cmd P)) (σ : StringGenState) + (h_genfresh : ∀ str : String, + HasIdent.ident (P := P) str ∈ names → + str ∉ StringGenState.stringGens (Stmt.hoistLoopPrefixInitsM s σ).2) + (h : Stmt.namesFreshInExprs names s = true) : + Block.namesFreshInExprs names (Stmt.hoistLoopPrefixInitsM s σ).1 = true := by + match s with + | .cmd c => + simp only [Stmt.hoistLoopPrefixInitsM, Block.namesFreshInExprs, Bool.and_true] + exact h + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM_block_out] + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true] + have h_bss : Block.namesFreshInExprs names bss = true := by + simp only [Stmt.namesFreshInExprs] at h; exact h + refine Block.hoistLoopPrefixInitsM_namesFreshInExprs_genfresh names bss σ ?_ h_bss + intro str hstr + rw [← Stmt.hoistLoopPrefixInitsM_block_state lbl bss md σ] + exact h_genfresh str hstr + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM_ite_out] + have h_parts : + names.all (fun z => freshFromIdents z (ExprOrNondet.getVars g)) = true ∧ + Block.namesFreshInExprs names tss = true ∧ + Block.namesFreshInExprs names ess = true := by + simp only [Stmt.namesFreshInExprs, Bool.and_eq_true] at h + exact ⟨h.1.1, h.1.2, h.2⟩ + have h_step_e : GenStep (Block.hoistLoopPrefixInitsM tss σ).2 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).2 := + Block.hoistLoopPrefixInitsM_genStep ess _ + have ih_t := Block.hoistLoopPrefixInitsM_namesFreshInExprs_genfresh names tss σ + (fun str hstr => by + intro hin + exact h_genfresh str hstr (by + rw [Stmt.hoistLoopPrefixInitsM_ite_state] + exact h_step_e.subset hin)) h_parts.2.1 + have ih_e := Block.hoistLoopPrefixInitsM_namesFreshInExprs_genfresh names ess + (Block.hoistLoopPrefixInitsM tss σ).2 + (fun str hstr => by + intro hin + exact h_genfresh str hstr (by + rw [Stmt.hoistLoopPrefixInitsM_ite_state]; exact hin)) h_parts.2.2 + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_true] + rw [Bool.and_eq_true, Bool.and_eq_true] + exact ⟨⟨h_parts.1, ih_t⟩, ih_e⟩ + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM_loop_out] + have h_loop : Stmt.namesFreshInExprs names (.loop g m inv body md) = true := h + unfold Stmt.namesFreshInExprs at h_loop + rw [Bool.and_eq_true, Bool.and_eq_true, Bool.and_eq_true] at h_loop + obtain ⟨⟨⟨h_g, h_m⟩, h_inv⟩, h_body⟩ := h_loop + -- the inner-loop renames are captured in this loop's output state σ₂. + have h_step_lift : GenStep (Block.hoistLoopPrefixInitsM body σ).2 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).2 := + Block.liftInitsInLoopBodyM_genStep _ _ + -- the post-order body is fresh by the IH (its output state ⊆ σ₂). + have ih_body : Block.namesFreshInExprs names (Block.hoistLoopPrefixInitsM body σ).1 = true := by + refine Block.hoistLoopPrefixInitsM_namesFreshInExprs_genfresh names body σ ?_ h_body + intro str hstr hin + exact h_genfresh str hstr (by + rw [Stmt.hoistLoopPrefixInitsM_loop_state] + exact h_step_lift.subset hin) + have h_body₂ : + Block.namesFreshInExprs names + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 = true := + Block.liftInitsInLoopBodyM_snd_namesFreshInExprs names _ _ ih_body + have h_body₃ : + Block.namesFreshInExprs names + (Block.applyRenames + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) = true := by + refine Block.namesFreshInExprs_applyRenames names _ _ ?_ h_body₂ + intro p hp + obtain ⟨str, hstr_eq, hstr_in⟩ := + Block.liftInitsInLoopBodyM_renames_captured + (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 p hp + rw [hstr_eq] + intro hmem + exact h_genfresh str hmem (by rw [Stmt.hoistLoopPrefixInitsM_loop_state]; exact hstr_in) + refine Block.namesFreshInExprs_append names _ _ ?_ ?_ + · rw [(LoopInitHoistLoopDriver.Block.lift_harvest_subst + (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1] + exact namesFreshInExprs_havocStmts' names _ + · rw [Block.namesFreshInExprs] + simp only [Block.namesFreshInExprs, Bool.and_true] + unfold Stmt.namesFreshInExprs + rw [Bool.and_eq_true, Bool.and_eq_true, Bool.and_eq_true] + exact ⟨⟨⟨h_g, h_m⟩, h_inv⟩, h_body₃⟩ + | .exit lbl md => + simp only [Stmt.hoistLoopPrefixInitsM, Block.namesFreshInExprs, Stmt.namesFreshInExprs, + Bool.and_true] + | .funcDecl d md => + simp only [Stmt.hoistLoopPrefixInitsM, Block.namesFreshInExprs, Stmt.namesFreshInExprs, + Bool.and_true] + | .typeDecl t md => + simp only [Stmt.hoistLoopPrefixInitsM, Block.namesFreshInExprs, Stmt.namesFreshInExprs, + Bool.and_true] + termination_by sizeOf s + +/-- `Block.hoistLoopPrefixInitsM` preserves `Block.namesFreshInExprs names` for +names that are fresh from the pass output state's `stringGens`. -/ +theorem Block.hoistLoopPrefixInitsM_namesFreshInExprs_genfresh [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + (names : List P.Ident) (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_genfresh : ∀ str : String, + HasIdent.ident (P := P) str ∈ names → + str ∉ StringGenState.stringGens (Block.hoistLoopPrefixInitsM ss σ).2) + (h : Block.namesFreshInExprs names ss = true) : + Block.namesFreshInExprs names (Block.hoistLoopPrefixInitsM ss σ).1 = true := by + match ss with + | [] => + simp only [Block.hoistLoopPrefixInitsM, Block.namesFreshInExprs] + | s :: rest => + rw [Block.hoistLoopPrefixInitsM_cons_out] + have h_s : Stmt.namesFreshInExprs names s = true := by + simp only [Block.namesFreshInExprs, Bool.and_eq_true] at h; exact h.1 + have h_rest : Block.namesFreshInExprs names rest = true := by + simp only [Block.namesFreshInExprs, Bool.and_eq_true] at h; exact h.2 + have h_step_rest : GenStep (Stmt.hoistLoopPrefixInitsM s σ).2 + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).2 := + Block.hoistLoopPrefixInitsM_genStep rest _ + have ih_s := Stmt.hoistLoopPrefixInitsM_namesFreshInExprs_genfresh names s σ + (fun str hstr hin => h_genfresh str hstr (by + rw [Block.hoistLoopPrefixInitsM_cons_state] + exact h_step_rest.subset hin)) h_s + have ih_rest := Block.hoistLoopPrefixInitsM_namesFreshInExprs_genfresh names rest + (Stmt.hoistLoopPrefixInitsM s σ).2 + (fun str hstr hin => h_genfresh str hstr (by + rw [Block.hoistLoopPrefixInitsM_cons_state]; exact hin)) h_rest + exact Block.namesFreshInExprs_append names _ _ ih_s ih_rest + termination_by sizeOf ss +end + +/-! ## The TARGETS carrier is fresh from the harvest's input state. + +`targetsOf' (Block.entriesOf body₁ σ₁)` are the freshly generated names harvested +from `body₁` at `σ₁`. By `Block.entriesOf_targetGen` (under `WF σ₁`), every such +target is `HasIdent.ident s` with `s ∉ stringGens σ₁`. Hence the targets satisfy +the `genfresh` premise at `σ₁`. -/ + +/-- Every `targetsOf'`-element of `Block.entriesOf body₁ σ₁` is `HasIdent.ident +str` for a `str ∉ stringGens σ₁` (given `WF σ₁`). This is exactly the `genfresh` +premise of `..._namesFreshInExprs_genfresh` at the harvest input state. -/ +theorem Block.targetsOf'_entriesOf_genfresh [HasIdent P] [LawfulHasIdent P] + (body₁ : List (Stmt P (Cmd P))) (σ₁ : StringGenState) (h_wf : StringGenState.WF σ₁) : + ∀ str : String, + HasIdent.ident (P := P) str ∈ targetsOf' (Block.entriesOf body₁ σ₁) → + str ∉ StringGenState.stringGens σ₁ := by + intro str hstr hin + -- `targetsOf' E = E.map (·.2.1)`, so the membership comes from an entry. + simp only [LoopInitHoistLoopDriver.targetsOf', List.mem_map] at hstr + obtain ⟨e, he_mem, he_eq⟩ := hstr + obtain ⟨s, hs_eq, hs_in, hs_not⟩ := (Block.entriesOf_targetGen body₁ σ₁ h_wf).1 e he_mem + -- `ident str = e.2.1 = ident s`, so `str = s` by injectivity, and `s ∉ stringGens σ₁`. + have h_id : (HasIdent.ident str : P.Ident) = HasIdent.ident s := he_eq.symm.trans hs_eq + have : str = s := LawfulHasIdent.ident_inj h_id + exact hs_not (this ▸ hin) + +/-- Producer `h_B_fresh` for the TARGETS carrier: the harvest targets +`targetsOf' (Block.entriesOf body₁ σ₁)` (with `body₁ = (hoistLoopPrefixInitsM +body σ).1`, `σ₁ = (hoistLoopPrefixInitsM body σ).2`) are fresh in `body₁` PROVIDED +they are fresh in the SOURCE body's exprs. The gen-state freshness premise is +discharged internally from `WF σ₁` via `targetsOf'_entriesOf_genfresh`. + +`h_tgt_body_fresh` (targets fresh in `body`'s exprs) is supplied by the producer +wiring: the targets are generator-suffixed names minted strictly after `σ`, so +they are fresh in the original (pre-pass) source body, which only mentions +program names. -/ +theorem Block.hoistLoopPrefixInitsM_namesFreshInExprs_targets [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] + (body : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_wf₁ : StringGenState.WF (Block.hoistLoopPrefixInitsM body σ).2) + (h_tgt_body_fresh : + Block.namesFreshInExprs + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2)) body = true) : + Block.namesFreshInExprs + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.hoistLoopPrefixInitsM body σ).1 = true := by + refine Block.hoistLoopPrefixInitsM_namesFreshInExprs_genfresh _ body σ ?_ h_tgt_body_fresh + exact Block.targetsOf'_entriesOf_genfresh (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2 h_wf₁ + +/-! ## The harvest targets carry hoist's mint kind `Q`. + +Routing the harvest through `entriesOf_target_suffix` (which exposes that every +harvested `.init` target is literally a `gen hoistFreshPrefix _` output) with the +mint witness `hQmint` exposes that every member of `targetsOf' (Block.entriesOf +ss σ)` is `HasIdent.ident str` for a `Q`-kind `str` — the structural fact that +separates the harvest targets from program names (which never carry hoist's +mint kind). Instantiating `Q := String.HasUnderscoreDigitSuffix` recovers the +blanket generator-suffix statement. -/ + +/-- Every entry harvested from a block has a target ident that is +`HasIdent.ident str` for a `Q`-kind generator string `str` (given the mint +witness `hQmint`). -/ +theorem Block.entriesOf_target_hasUnderscoreDigitSuffix [HasIdent P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + {e : Entry P} (he : e ∈ Block.entriesOf ss σ) : + ∃ str : String, e.2.1 = HasIdent.ident str ∧ Q str := + Block.entriesOf_target_suffix hQmint ss σ e he + +/-- Every member of `targetsOf' (Block.entriesOf ss σ)` is `HasIdent.ident str` +for a `Q`-kind generator string `str`. -/ +theorem Block.mem_targetsOf'_entriesOf_hasUnderscoreDigitSuffix [HasIdent P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + {x : P.Ident} (hx : x ∈ targetsOf' (Block.entriesOf ss σ)) : + ∃ str : String, x = HasIdent.ident str ∧ Q str := by + obtain ⟨e, he_mem, he_eq⟩ := List.mem_map.mp hx + obtain ⟨str, h_eq, h_suf⟩ := + Block.entriesOf_target_hasUnderscoreDigitSuffix hQmint ss σ he_mem + exact ⟨str, by rw [← he_eq, h_eq], h_suf⟩ + +/-! ## The `exprsShapeFree` ⇒ `h_B_fresh` bridge. + +`Block.bodyTransport_of_lift` is fed at `B := targetsOf' E` with +`E := Block.entriesOf body₁ σ₁`, `body₁ = (hoistLoopPrefixInitsM body σ).1`, +`σ₁ = (hoistLoopPrefixInitsM body σ).2`. Its `h_B_fresh` reads +`namesFreshInExprs (targetsOf' E) body₁ = true`. The reducer +`hoistLoopPrefixInitsM_namesFreshInExprs_targets` reduces that to freshness in +the SOURCE body `body`. Source-body freshness in turn follows from the +front-end well-formedness assumption `Block.exprsShapeFree body`: every target +is a `_`-suffixed ident (`mem_targetsOf'_entriesOf_hasUnderscoreDigitSuffix`) +and a shape-free body never reads such a name, so the targets are fresh in +`body`'s exprs. -/ + +/-- The harvest targets are fresh in the SOURCE body's exprs, given the +body is `exprsShapeFree Q`. This is exactly the `h_tgt_body_fresh` premise of +`hoistLoopPrefixInitsM_namesFreshInExprs_targets`. -/ +theorem Block.targetsOf'_entriesOf_namesFreshInExprs_of_exprsShapeFree [HasIdent P] [HasVarsPure P P.Expr] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (body body₁ : List (Stmt P (Cmd P))) (σ₁ : StringGenState) + (_h_wf₁ : StringGenState.WF σ₁) + (h_sf : Block.exprsShapeFree (P := P) Q body) : + Block.namesFreshInExprs (targetsOf' (Block.entriesOf body₁ σ₁)) body = true := + Block.namesFreshInExprs_of_exprsShapeFree' + (fun _z hz => Block.mem_targetsOf'_entriesOf_hasUnderscoreDigitSuffix hQmint body₁ σ₁ hz) + body h_sf + +/-- The full producer-side `h_B_fresh` for the `.loop` arm: from +`Block.exprsShapeFree Q body`, the harvest targets `targetsOf' (entriesOf body₁ +σ₁)` (`body₁`/`σ₁` the post-order body / its gen state) are fresh in `body₁`'s +exprs. The targets carry hoist's mint kind; the source body is shape-free, +so they are fresh in `body`; the reducer lifts that to `body₁`. -/ +theorem Block.hoistLoopPrefixInitsM_namesFreshInExprs_targets_of_exprsShapeFree [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (body : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_wf₁ : StringGenState.WF (Block.hoistLoopPrefixInitsM body σ).2) + (h_sf : Block.exprsShapeFree (P := P) Q body) : + Block.namesFreshInExprs + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.hoistLoopPrefixInitsM body σ).1 = true := + Block.hoistLoopPrefixInitsM_namesFreshInExprs_targets body σ h_wf₁ + (Block.targetsOf'_entriesOf_namesFreshInExprs_of_exprsShapeFree hQmint body + (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 h_wf₁ h_sf) + +/-! ## The harvest sources are a `Sublist` of the body's inits. + +`Block.sourcesOf_entriesOf_subset` (in `LoopInitHoistLoopDriver`) records the +membership form `sourcesOf' (entriesOf ss σ) ⊆ Block.initVars ss`. For the +producer-precondition `(sourcesOf' (entriesOf ss σ)).Nodup` we need the stronger +`List.Sublist` form, so `Nodup` transfers via `List.Sublist.nodup`. + +The harvest `entriesOf` and `initVars` walk the SAME `.block`/`.ite`/cons shape +and harvest the SAME `.cmd (.init y _ _ _)` heads (`[y]` each); they diverge only +at `.loop`, where `entriesOf` harvests `[]` (loops are passed through, their +inits hoisted separately) while `initVars` descends into the loop body. Hence +the harvest sources are a SUBLIST (`[] <+ Block.initVars body` at the `.loop` +arm; refl/append elsewhere), not necessarily equal. -/ + +mutual +/-- `sourcesOf' (Stmt.entriesOf s σ)` is a `List.Sublist` of `Stmt.initVars s`. -/ +theorem Stmt.sourcesOf_entriesOf_sublist [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + (sourcesOf' (Stmt.entriesOf s σ)).Sublist (Stmt.initVars s) := by + match s with + | .cmd c => + cases c <;> + simp only [Stmt.entriesOf, Stmt.initVars, sourcesOf', List.map_cons, + List.map_nil] <;> + exact (List.Sublist.refl _) + | .block lbl bss md => + rw [Stmt.entriesOf, Stmt.initVars] + exact Block.sourcesOf_entriesOf_sublist bss σ + | .ite g tss ess md => + rw [Stmt.entriesOf, Stmt.initVars] + simp only [sourcesOf', List.map_append] + exact (Block.sourcesOf_entriesOf_sublist tss σ).append + (Block.sourcesOf_entriesOf_sublist ess _) + | .loop g m inv body md => + rw [Stmt.entriesOf, Stmt.initVars] + simp only [sourcesOf', List.map_nil] + exact List.nil_sublist _ + | .exit lbl md => + rw [Stmt.entriesOf, Stmt.initVars] + simp only [sourcesOf', List.map_nil]; exact List.nil_sublist _ + | .funcDecl d md => + rw [Stmt.entriesOf, Stmt.initVars] + simp only [sourcesOf', List.map_nil]; exact List.nil_sublist _ + | .typeDecl t md => + rw [Stmt.entriesOf, Stmt.initVars] + simp only [sourcesOf', List.map_nil]; exact List.nil_sublist _ + termination_by sizeOf s + +/-- `sourcesOf' (Block.entriesOf ss σ)` is a `List.Sublist` of `Block.initVars ss`. -/ +theorem Block.sourcesOf_entriesOf_sublist [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + (sourcesOf' (Block.entriesOf ss σ)).Sublist (Block.initVars ss) := by + match ss with + | [] => + rw [Block.entriesOf, Block.initVars] + simp only [sourcesOf', List.map_nil]; exact List.nil_sublist _ + | s :: rest => + rw [Block.entriesOf, Block.initVars] + simp only [sourcesOf', List.map_append] + exact (Stmt.sourcesOf_entriesOf_sublist s σ).append + (Block.sourcesOf_entriesOf_sublist rest _) + termination_by sizeOf ss +end + +/-- **Producer precondition (GAP 1).** From `(Block.initVars body₁).Nodup`, the +harvest sources `sourcesOf' (Block.entriesOf body₁ σ)` are `Nodup`. This is the +shape `Block.bodyTransport_of_lift` consumes as `h_src_nodup` (recall +`(substOf' E).map Prod.fst = sourcesOf' E`). `Nodup` transfers along the sublist +of the previous lemma. -/ +theorem Block.entriesOf_sourcesOf_nodup_of_initVars [HasIdent P] + (body₁ : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_nd : (Block.initVars body₁).Nodup) : + (sourcesOf' (Block.entriesOf body₁ σ)).Nodup := + (Block.sourcesOf_entriesOf_sublist body₁ σ).nodup h_nd + +/-- The producer's `h_src_nodup` reads `(subst.map Prod.fst).Nodup` over +`subst := substOf' E`; this records the projection identity +`(substOf' E).map Prod.fst = sourcesOf' E` so the previous lemma lands directly +on the producer's shape. -/ +theorem substOf'_map_fst (entries : List (Entry P)) : + (substOf' entries).map Prod.fst = sourcesOf' entries := by + simp only [substOf', sourcesOf', List.map_map, Function.comp_def] + +/-- **Producer precondition, in the producer's own `h_src_nodup` shape.** From +`(Block.initVars body₁).Nodup`, the substitution `substOf' (Block.entriesOf body₁ σ)` +has `Nodup` sources — exactly the `h_src_nodup` argument of +`Block.bodyTransport_of_lift` at `subst := substOf' (Block.entriesOf body₁ σ)`. -/ +theorem Block.entriesOf_substOf_src_nodup_of_initVars [HasIdent P] + (body₁ : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_nd : (Block.initVars body₁).Nodup) : + ((substOf' (Block.entriesOf body₁ σ)).map Prod.fst).Nodup := by + rw [substOf'_map_fst] + exact Block.entriesOf_sourcesOf_nodup_of_initVars body₁ σ h_nd + +/-! ## Producer shape precondition on the post-order body. + +`Block.bodyTransport_of_lift` needs `Block.transportShape body₁ = true` for +`body₁ = (Block.hoistLoopPrefixInitsM body σ).1`. The post-order pass preserves +each of the structural Bool walkers (`containsNondetLoop`, `containsFuncDecl`, +`loopHasNoInvariants`, `loopMeasureNone`) in value, so the body's §E +arm preconditions transport to `body₁`, and `transportShape_of_arm_preconds` +assembles them. -/ +theorem Block.transportShape_hoistLoopPrefixInitsM [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIntOrder P] [HasVarsPure P P.Expr] + (body : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_nd : Block.containsNondetLoop body = false) + (h_fd : Block.containsFuncDecl body = false) + (h_inv : Block.loopHasNoInvariants body = true) + (h_measure : Block.loopMeasureNone body = true) : + Block.transportShape (Block.hoistLoopPrefixInitsM body σ).1 = true := by + apply Block.transportShape_of_arm_preconds + · rw [Block.hoistLoopPrefixInitsM_containsNondetLoop]; exact h_nd + · rw [Block.hoistLoopPrefixInitsM_containsFuncDecl]; exact h_fd + · rw [Block.hoistLoopPrefixInitsM_loopHasNoInvariants]; exact h_inv + · rw [Block.hoistLoopPrefixInitsM_loopMeasureNone]; exact h_measure + +/-! ## The post-order body's `initVars` is `Nodup` (GAP 1 part (b)). + +The §E `.loop` arm needs `(Block.initVars body₁).Nodup` for +`body₁ = (Block.hoistLoopPrefixInitsM body σ).1` — the producer-precondition GAP +1 part (b) that part (a) (`entriesOf_sourcesOf_nodup_of_initVars`) reduces to. +It does NOT follow from `uniqueInits body` alone: the pass lifts nested-loop +prefix inits to NET-NEW fresh `_hoist` names at `body₁`'s top level, so +`initVars body₁` is `{body's non-nested-loop inits} ∪ {fresh _hoist names}`. + +The proof mirrors `entriesOf_targetGen`: a mutual induction over the pass that +both proves `Nodup` and classifies every member of `initVars (pass output)` as +either an ORIGINAL (a member of the source `initVars`, hence suffix-free by +`h_src_shapefree`) or a FRESH generator name (suffix-shaped, captured in the +pass output state's `stringGens` but absent from the input state's). The two +classes are disjoint by shape; same-class collisions are ruled out by +`uniqueInits` (originals) and `StringGenState` monotonicity (fresh). + +The `.loop` arm is where the fresh names appear: its output is +`havocs.map .cmd ++ [.loop g m inv body₃ md]`. Crucially the rewritten body +`body₃` is init-free — the post-order body is `allLoopBodiesInitFree`, so the +lift residual `body₂` has no inits (`liftInitsInLoopBodyM_snd_noInitsAnywhere`) +and `applyRenames` preserves init-emptiness — so the loop arm's `initVars` is +exactly the havoc targets `targetsOf' (entriesOf body₁' σ₁')`, which are +generator names, `Nodup` by `entriesOf_targetGen`. -/ + +/-- `Block.applyRenames` preserves whether `Block.initVars` is empty: each +`substIdent` rename maps one init binder to one new binder, never adding or +removing init binders, so emptiness is invariant under the whole fold. -/ +theorem Block.applyRenames_initVars_isEmpty [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + (Block.initVars (Block.applyRenames renames ss)).isEmpty + = (Block.initVars ss).isEmpty := by + induction renames generalizing ss with + | nil => simp only [Block.applyRenames, List.foldl_nil] + | cons p rest ih => + have hstep : Block.applyRenames (p :: rest) ss + = Block.applyRenames rest (Block.substIdent p.1 p.2 ss) := by + simp only [Block.applyRenames, List.foldl_cons] + rw [hstep, ih (Block.substIdent p.1 p.2 ss), + Block.substIdent_initVars_isEmpty p.1 p.2 ss] + +/-- The rewritten loop body `body₃ = applyRenames renames body₂` produced by the +`.loop` arm is init-free. `body₁ = (hoistLoopPrefixInitsM body σ).1` is +`allLoopBodiesInitFree`, so the lift residual `body₂` has no inits anywhere, and +`applyRenames` preserves init-emptiness. -/ +theorem Block.applyRenames_liftResidual_initVars_nil [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (body : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.initVars + (Block.applyRenames + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) = [] := by + -- `body₂` is `noInitsAnywhere`, so its `initVars` is empty; `applyRenames` + -- preserves emptiness. + have h_albif : Block.allLoopBodiesInitFree (Block.hoistLoopPrefixInitsM body σ).1 = true := + Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree body σ + have h_nia : + Block.noInitsAnywhere + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 = true := + Block.liftInitsInLoopBodyM_snd_noInitsAnywhere _ _ h_albif + have h_body₂_nil : + Block.initVars + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 = [] := + Block.initVars_eq_nil_of_noInitsAnywhere _ h_nia + have h_isEmpty := Block.applyRenames_initVars_isEmpty + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2 + rw [h_body₂_nil] at h_isEmpty + simp only [List.isEmpty_nil] at h_isEmpty + exact List.isEmpty_iff.mp h_isEmpty + +/-- `Block.initVars` distributes over `++`. -/ +theorem Block.initVars_append' + (xs ys : List (Stmt P (Cmd P))) : + Block.initVars (xs ++ ys) = Block.initVars xs ++ Block.initVars ys := by + induction xs with + | nil => simp [Block.initVars] + | cons x rest ih => + simp only [List.cons_append, Block.initVars_cons, ih, List.append_assoc] + +/-- The havoc prelude's `initVars` are exactly the harvest targets: every havoc +is `init e.2.1 ty .nondet md`, contributing its target ident `e.2.1`. -/ +theorem Block.initVars_havocStmts' (entries : List (Entry P)) : + Block.initVars (havocStmts' entries) = targetsOf' entries := by + induction entries with + | nil => + simp only [LoopInitHoistLoopDriver.havocStmts'_nil, Block.initVars, + LoopInitHoistLoopDriver.targetsOf'_nil] + | cons e rest ih => + rw [LoopInitHoistLoopDriver.havocStmts'_cons, Block.initVars_cons, + LoopInitHoistLoopDriver.targetsOf'_cons, ih] + simp only [Stmt.initVars, List.singleton_append] + +/-- Classification of an `initVars` element of the post-order pass output: +either an ORIGINAL source init (a member of the source `initVars` carrier +`src`), or a FRESH generator name (`HasIdent.ident str` for a string `str` +captured in the output state `σ'` but absent from the input state `σ`). The +fresh disjunct additionally records that `str` carries the hoist pass's mint +kind `Q` (`Q str`), which the freshly minted carrier names satisfy by the mint +witness `hQmint`. Instantiating `Q := String.HasUnderscoreDigitSuffix` recovers +the blanket generator-suffix statement. -/ +def HoistInitClass [HasIdent P] (Q : String → Prop) (src : List P.Ident) (σ σ' : StringGenState) (x : P.Ident) : Prop := + (x ∈ src) ∨ + (∃ str : String, x = HasIdent.ident str + ∧ str ∈ StringGenState.stringGens σ' + ∧ str ∉ StringGenState.stringGens σ + ∧ Q str) + +/-- Two classified `initVars` carriers from consecutive sub-passes are disjoint: +originals are disjoint by `uniqueInits` and suffix-free by `h_src_shapefree`; +fresh names are suffix-shaped and captured in disjoint state windows. All four +cross-class collisions are impossible. -/ +theorem hoistInitClass_disjoint [HasIdent P] [LawfulHasIdent P] {Q : String → Prop} + (src₁ src₂ : List P.Ident) (σ σmid σ' : StringGenState) + (_h_wf : StringGenState.WF σ) + (_h_step₁ : GenStep σ σmid) (_h_step₂ : GenStep σmid σ') + (h_src_disjoint : ∀ a ∈ src₁, ∀ b ∈ src₂, a ≠ b) + (h_sf₁ : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ src₁) + (h_sf₂ : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ src₂) + (L₁ L₂ : List P.Ident) + (hc₁ : ∀ x ∈ L₁, HoistInitClass Q src₁ σ σmid x) + (hc₂ : ∀ x ∈ L₂, HoistInitClass Q src₂ σmid σ' x) : + ∀ a ∈ L₁, ∀ b ∈ L₂, a ≠ b := by + intro a ha b hb hab + subst hab + rcases hc₁ a ha with h_o₁ | ⟨str₁, hstr₁_eq, hstr₁_in, hstr₁_not, hstr₁_Q⟩ + · rcases hc₂ a hb with h_o₂ | ⟨str₂, hstr₂_eq, hstr₂_in, _, hstr₂_Q⟩ + · exact h_src_disjoint a h_o₁ a h_o₂ rfl + · -- a ∈ src₁ (kind-free) but a = ident str₂ with `Q str₂`. + exact h_sf₁ str₂ hstr₂_Q (hstr₂_eq ▸ h_o₁) + · -- a = ident str₁ with str₁ ∈ σmid \ σ and `Q str₁`. + rcases hc₂ a hb with h_o₂ | ⟨str₂, hstr₂_eq, hstr₂_in, hstr₂_not, _⟩ + · exact h_sf₂ str₁ hstr₁_Q (hstr₁_eq ▸ h_o₂) + · -- ident str₁ = ident str₂ ⇒ str₁ = str₂; but str₁ ∈ σmid, str₂ ∉ σmid. + have h_id : (HasIdent.ident str₁ : P.Ident) = HasIdent.ident str₂ := + hstr₁_eq.symm.trans hstr₂_eq + have : str₁ = str₂ := LawfulHasIdent.ident_inj h_id + exact hstr₂_not (this ▸ hstr₁_in) + +mutual +/-- Mutual `Stmt` step: the post-order pass output's `initVars` is `Nodup`, and +each member is `HoistInitClass`-classified between the input and output states. -/ +theorem Stmt.hoistLoopPrefixInitsM_initVars_classified [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (s : Stmt P (Cmd P)) (σ : StringGenState) (h_wf : StringGenState.WF σ) + (h_unique : (Stmt.initVars s).Nodup) + (h_shapefree : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s) : + (∀ x ∈ Block.initVars (Stmt.hoistLoopPrefixInitsM s σ).1, + HoistInitClass Q (Stmt.initVars s) σ (Stmt.hoistLoopPrefixInitsM s σ).2 x) + ∧ (Block.initVars (Stmt.hoistLoopPrefixInitsM s σ).1).Nodup := by + match s with + | .cmd c => + -- residual `[.cmd c]`; initVars unchanged; every member is an original. + cases c with + | init y ty rhs md => + refine ⟨?_, ?_⟩ + · intro x hx + simp only [Stmt.hoistLoopPrefixInitsM, Block.initVars_cons, Stmt.initVars, + Block.initVars, List.append_nil] at hx ⊢ + exact Or.inl hx + · simp only [Stmt.hoistLoopPrefixInitsM, Block.initVars_cons, Stmt.initVars, + Block.initVars, List.append_nil] + simp [List.nodup_cons] + | set x rhs md => + refine ⟨fun x hx => ?_, ?_⟩ <;> + simp_all [Stmt.hoistLoopPrefixInitsM, Block.initVars, Stmt.initVars] + | assert l e md => + refine ⟨fun x hx => ?_, ?_⟩ <;> + simp_all [Stmt.hoistLoopPrefixInitsM, Block.initVars, Stmt.initVars] + | assume l e md => + refine ⟨fun x hx => ?_, ?_⟩ <;> + simp_all [Stmt.hoistLoopPrefixInitsM, Block.initVars, Stmt.initVars] + | cover l e md => + refine ⟨fun x hx => ?_, ?_⟩ <;> + simp_all [Stmt.hoistLoopPrefixInitsM, Block.initVars, Stmt.initVars] + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM_block_out, Stmt.hoistLoopPrefixInitsM_block_state] + have h_unique' : (Block.initVars bss).Nodup := by + simpa only [Stmt.initVars_block] using h_unique + have h_shapefree' : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars bss := by + intro str hsuf; simpa only [Stmt.initVars_block] using h_shapefree str hsuf + have ih := Block.hoistLoopPrefixInitsM_initVars_classified hQmint bss σ h_wf h_unique' h_shapefree' + refine ⟨?_, ?_⟩ + · intro x hx + simp only [Block.initVars_cons, Stmt.initVars_block, Block.initVars, + List.append_nil] at hx + have := ih.1 x hx + simpa only [Stmt.initVars_block] using this + · simp only [Block.initVars_cons, Stmt.initVars_block, Block.initVars, List.append_nil] + exact ih.2 + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM_ite_out, Stmt.hoistLoopPrefixInitsM_ite_state] + -- split uniqueInits/shapefree across the two branches. + have h_uni : (Block.initVars tss ++ Block.initVars ess).Nodup := by + simpa only [Stmt.initVars_ite] using h_unique + have h_uni_t : (Block.initVars tss).Nodup := (List.nodup_append.mp h_uni).1 + have h_uni_e : (Block.initVars ess).Nodup := (List.nodup_append.mp h_uni).2.1 + have h_disj_te : ∀ a ∈ Block.initVars tss, ∀ b ∈ Block.initVars ess, a ≠ b := + (List.nodup_append.mp h_uni).2.2 + have h_sf_t : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars tss := by + intro str hsuf hmem + exact h_shapefree str hsuf (by + rw [Stmt.initVars_ite, List.mem_append]; exact Or.inl hmem) + have h_sf_e : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars ess := by + intro str hsuf hmem + exact h_shapefree str hsuf (by + rw [Stmt.initVars_ite, List.mem_append]; exact Or.inr hmem) + have ih_t := Block.hoistLoopPrefixInitsM_initVars_classified hQmint tss σ h_wf h_uni_t h_sf_t + have h_wf_t : StringGenState.WF (Block.hoistLoopPrefixInitsM tss σ).2 := + (Block.hoistLoopPrefixInitsM_genStep tss σ).wf_mono h_wf + have ih_e := Block.hoistLoopPrefixInitsM_initVars_classified hQmint ess + (Block.hoistLoopPrefixInitsM tss σ).2 h_wf_t h_uni_e h_sf_e + have h_step_t : GenStep σ (Block.hoistLoopPrefixInitsM tss σ).2 := + Block.hoistLoopPrefixInitsM_genStep tss σ + have h_step_e : GenStep (Block.hoistLoopPrefixInitsM tss σ).2 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).2 := + Block.hoistLoopPrefixInitsM_genStep ess _ + refine ⟨?_, ?_⟩ + · intro x hx + simp only [Block.initVars_cons, Stmt.initVars_ite, Block.initVars, + List.append_nil] at hx ⊢ + rw [List.mem_append] at hx + rcases hx with h | h + · rcases ih_t.1 x h with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (by rw [List.mem_append]; exact Or.inl h_o) + · exact Or.inr ⟨str, he, h_step_e.subset hin, hnot, hQ⟩ + · rcases ih_e.1 x h with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (by rw [List.mem_append]; exact Or.inr h_o) + · refine Or.inr ⟨str, he, hin, ?_, hQ⟩ + intro h_in_σ; exact hnot (h_step_t.subset h_in_σ) + · simp only [Block.initVars_cons, Stmt.initVars_ite, Block.initVars, List.append_nil] + rw [List.nodup_append] + refine ⟨ih_t.2, ih_e.2, ?_⟩ + exact hoistInitClass_disjoint (Block.initVars tss) (Block.initVars ess) + σ (Block.hoistLoopPrefixInitsM tss σ).2 _ h_wf h_step_t h_step_e + h_disj_te h_sf_t h_sf_e _ _ ih_t.1 ih_e.1 + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM_loop_out, Stmt.hoistLoopPrefixInitsM_loop_state] + -- output initVars = targetsOf'(entriesOf body₁ σ₁) ++ initVars body₃ = targets ++ []. + have h_wf₁ : StringGenState.WF (Block.hoistLoopPrefixInitsM body σ).2 := + (Block.hoistLoopPrefixInitsM_genStep body σ).wf_mono h_wf + have h_body₃_nil : + Block.initVars + (Block.applyRenames + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) = [] := + Block.applyRenames_liftResidual_initVars_nil body σ + -- the havoc prelude's initVars are the harvest targets. + have h_havoc_init : + Block.initVars + ((Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.1.map Stmt.cmd) + = targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2) := by + rw [(LoopInitHoistLoopDriver.Block.lift_harvest_subst + (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1] + exact Block.initVars_havocStmts' _ + -- GenStep window: σ ⊆ σ₁, so a target fresh from σ₁ is fresh from σ. + have h_step_body : GenStep σ (Block.hoistLoopPrefixInitsM body σ).2 := + Block.hoistLoopPrefixInitsM_genStep body σ + refine ⟨?_, ?_⟩ + · intro x hx + rw [Block.initVars_append', h_havoc_init] at hx + simp only [Block.initVars_cons, Stmt.initVars_loop, Block.initVars, + List.append_nil] at hx + rw [h_body₃_nil, List.append_nil] at hx + -- x is a harvest target: fresh between σ₁ and σ₂; classify as fresh from σ. + obtain ⟨e, he_mem, he_eq⟩ := List.mem_map.mp hx + obtain ⟨t, ht_eq, ht_in, ht_not⟩ := + (Block.entriesOf_targetGen (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2 h_wf₁).1 e he_mem + obtain ⟨t', ht'_eq, ht'_Q⟩ := + Block.entriesOf_target_suffix hQmint (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2 e he_mem + have h_t_eq : t = t' := + LawfulHasIdent.ident_inj (ht_eq.symm.trans ht'_eq) + refine Or.inr ⟨t, ?_, ht_in, ?_, h_t_eq ▸ ht'_Q⟩ + · rw [← he_eq, ht_eq] + · intro h_in_σ; exact ht_not (h_step_body.subset h_in_σ) + · rw [Block.initVars_append', h_havoc_init] + simp only [Block.initVars_cons, Stmt.initVars_loop, Block.initVars, List.append_nil] + rw [h_body₃_nil, List.append_nil] + exact (Block.entriesOf_targetGen (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2 h_wf₁).2 + | .exit lbl md => + refine ⟨fun x hx => ?_, ?_⟩ <;> + simp_all [Stmt.hoistLoopPrefixInitsM, Block.initVars, Stmt.initVars] + | .funcDecl d md => + refine ⟨fun x hx => ?_, ?_⟩ <;> + simp_all [Stmt.hoistLoopPrefixInitsM, Block.initVars, Stmt.initVars] + | .typeDecl t md => + refine ⟨fun x hx => ?_, ?_⟩ <;> + simp_all [Stmt.hoistLoopPrefixInitsM, Block.initVars, Stmt.initVars] + termination_by sizeOf s + +/-- Mutual `Block` step. -/ +theorem Block.hoistLoopPrefixInitsM_initVars_classified [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) (h_wf : StringGenState.WF σ) + (h_unique : (Block.initVars ss).Nodup) + (h_shapefree : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars ss) : + (∀ x ∈ Block.initVars (Block.hoistLoopPrefixInitsM ss σ).1, + HoistInitClass Q (Block.initVars ss) σ (Block.hoistLoopPrefixInitsM ss σ).2 x) + ∧ (Block.initVars (Block.hoistLoopPrefixInitsM ss σ).1).Nodup := by + match ss with + | [] => + refine ⟨fun x hx => ?_, ?_⟩ <;> + simp_all [Block.hoistLoopPrefixInitsM, Block.initVars] + | s :: rest => + rw [Block.hoistLoopPrefixInitsM_cons_out, Block.hoistLoopPrefixInitsM_cons_state] + have h_uni : (Stmt.initVars s ++ Block.initVars rest).Nodup := by + simpa only [Block.initVars_cons] using h_unique + have h_uni_s : (Stmt.initVars s).Nodup := (List.nodup_append.mp h_uni).1 + have h_uni_r : (Block.initVars rest).Nodup := (List.nodup_append.mp h_uni).2.1 + have h_disj_sr : ∀ a ∈ Stmt.initVars s, ∀ b ∈ Block.initVars rest, a ≠ b := + (List.nodup_append.mp h_uni).2.2 + have h_sf_s : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s := by + intro str hsuf hmem + exact h_shapefree str hsuf (by + rw [Block.initVars_cons, List.mem_append]; exact Or.inl hmem) + have h_sf_r : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars rest := by + intro str hsuf hmem + exact h_shapefree str hsuf (by + rw [Block.initVars_cons, List.mem_append]; exact Or.inr hmem) + have ih_s := Stmt.hoistLoopPrefixInitsM_initVars_classified hQmint s σ h_wf h_uni_s h_sf_s + have h_wf_s : StringGenState.WF (Stmt.hoistLoopPrefixInitsM s σ).2 := + (Stmt.hoistLoopPrefixInitsM_genStep s σ).wf_mono h_wf + have ih_r := Block.hoistLoopPrefixInitsM_initVars_classified hQmint rest + (Stmt.hoistLoopPrefixInitsM s σ).2 h_wf_s h_uni_r h_sf_r + have h_step_s : GenStep σ (Stmt.hoistLoopPrefixInitsM s σ).2 := + Stmt.hoistLoopPrefixInitsM_genStep s σ + have h_step_r : GenStep (Stmt.hoistLoopPrefixInitsM s σ).2 + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).2 := + Block.hoistLoopPrefixInitsM_genStep rest _ + refine ⟨?_, ?_⟩ + · intro x hx + rw [Block.initVars_append'] at hx + rw [Block.initVars_cons] + rw [List.mem_append] at hx + rcases hx with h | h + · rcases ih_s.1 x h with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (by rw [List.mem_append]; exact Or.inl h_o) + · exact Or.inr ⟨str, he, h_step_r.subset hin, hnot, hQ⟩ + · rcases ih_r.1 x h with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (by rw [List.mem_append]; exact Or.inr h_o) + · refine Or.inr ⟨str, he, hin, ?_, hQ⟩ + intro h_in_σ; exact hnot (h_step_s.subset h_in_σ) + · rw [Block.initVars_append', List.nodup_append] + refine ⟨ih_s.2, ih_r.2, ?_⟩ + exact hoistInitClass_disjoint (Stmt.initVars s) (Block.initVars rest) + σ (Stmt.hoistLoopPrefixInitsM s σ).2 _ h_wf h_step_s h_step_r + h_disj_sr h_sf_s h_sf_r _ _ ih_s.1 ih_r.1 + termination_by sizeOf ss +end + +/-- **GAP 1 part (b).** The post-order body `body₁ = (hoistLoopPrefixInitsM body +σ).1` has `Nodup` `initVars`, given `WF σ`, the source body's `uniqueInits`, and +the arm's `h_src_shapefree` (originals avoid the generator `_` suffix). +Combined with part (a) (`entriesOf_sourcesOf_nodup_of_initVars`) this discharges +the producer's `h_src_nodup` for the §E `.loop` arm. -/ +theorem Block.hoistLoopPrefixInitsM_initVars_nodup [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (body : List (Stmt P (Cmd P))) (σ : StringGenState) (h_wf : StringGenState.WF σ) + (h_unique : (Block.initVars body).Nodup) + (h_shapefree : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars body) : + (Block.initVars (Block.hoistLoopPrefixInitsM body σ).1).Nodup := + (Block.hoistLoopPrefixInitsM_initVars_classified hQmint body σ h_wf h_unique h_shapefree).2 + +/-! ## `modifiedVars` classification of the post-order pass output. + +The `.loop` arm's final disjointness obligation is `modifiedVars body₁ ∩ +targetsOf' E = ∅` for `body₁ = (hoistLoopPrefixInitsM body σ).1` and `E = +entriesOf body₁ σ₁`. Mirroring `Block.sourcesOf'_disjoint_targetsOf'_self`, this +follows from classifying each `x ∈ modifiedVars body₁` as either an ORIGINAL +source modified-or-init var (suffix-free for a well-formed source) or a FRESH +generator name captured by `σ₁`; both are disjoint from the suffix-shaped +targets `∉ σ₁`. The lemmas below build that classification bottom-up from the +structural action of `substIdent`/`applyRenames`/`liftInitsInLoopBodyM` on +`modifiedVars`. -/ + +/-- `Block.modifiedVars` cons split. -/ +private theorem Block.modVars_cons (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) : + Block.modifiedVars (s :: rest) = Stmt.modifiedVars s ++ Block.modifiedVars rest := by + simp only [Block.modifiedVars] + +/-- `Block.modifiedVars` distributes over `++`. -/ +private theorem Block.modVars_append (xs ys : List (Stmt P (Cmd P))) : + Block.modifiedVars (xs ++ ys) = Block.modifiedVars xs ++ Block.modifiedVars ys := by + induction xs with + | nil => simp [Block.modifiedVars] + | cons x rest ih => simp only [List.cons_append, Block.modVars_cons, ih, List.append_assoc] + +mutual +/-- A `substIdent y y'` rename sends each modified var of a statement either to +an unchanged original (`≠ y`) or to the new name `y'`. -/ +theorem Stmt.substIdent_modVars_mem [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (s : Stmt P (Cmd P)) + (x : P.Ident) (hx : x ∈ Stmt.modifiedVars (Stmt.substIdent y y' s)) : + (x ∈ Stmt.modifiedVars s ∧ x ≠ y) ∨ x = y' := by + match s with + | .cmd c => + cases c with + | init name ty rhs md => + simp only [Stmt.substIdent_cmd, Cmd.substIdent_init, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars] at hx + exact absurd hx List.not_mem_nil + | set name rhs md => + simp only [Stmt.substIdent_cmd, Cmd.substIdent_set, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars, List.mem_singleton] at hx + by_cases h : name = y + · subst h; simp only [] at hx; exact Or.inr hx + · simp only [if_neg h] at hx + subst hx + refine Or.inl ⟨?_, h⟩ + simp only [Stmt.modifiedVars, HasVarsImp.modifiedVars, Cmd.modifiedVars, + List.mem_singleton] + | assert l e md => + simp only [Stmt.substIdent_cmd, Cmd.substIdent_assert, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars] at hx + exact absurd hx List.not_mem_nil + | assume l e md => + simp only [Stmt.substIdent_cmd, Cmd.substIdent_assume, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars] at hx + exact absurd hx List.not_mem_nil + | cover l e md => + simp only [Stmt.substIdent_cmd, Cmd.substIdent_cover, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars] at hx + exact absurd hx List.not_mem_nil + | .block lbl bss md => + simp only [Stmt.substIdent_block, Stmt.modifiedVars] at hx ⊢ + exact Block.substIdent_modVars_mem y y' bss x hx + | .ite g tss ess md => + simp only [Stmt.substIdent_ite, Stmt.modifiedVars, List.mem_append] at hx ⊢ + rcases hx with h | h + · rcases Block.substIdent_modVars_mem y y' tss x h with ⟨hm, hne⟩ | he + · exact Or.inl ⟨Or.inl hm, hne⟩ + · exact Or.inr he + · rcases Block.substIdent_modVars_mem y y' ess x h with ⟨hm, hne⟩ | he + · exact Or.inl ⟨Or.inr hm, hne⟩ + · exact Or.inr he + | .loop g m inv body md => + simp only [Stmt.substIdent_loop, Stmt.modifiedVars] at hx ⊢ + exact Block.substIdent_modVars_mem y y' body x hx + | .exit lbl md => + simp only [Stmt.substIdent_exit, Stmt.modifiedVars] at hx + exact absurd hx List.not_mem_nil + | .funcDecl d md => + simp only [Stmt.substIdent_funcDecl, Stmt.modifiedVars] at hx + exact absurd hx List.not_mem_nil + | .typeDecl t md => + simp only [Stmt.substIdent_typeDecl, Stmt.modifiedVars] at hx + exact absurd hx List.not_mem_nil + termination_by sizeOf s + +/-- Block-level `substIdent` modified-var classification. -/ +theorem Block.substIdent_modVars_mem [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) (ss : List (Stmt P (Cmd P))) + (x : P.Ident) (hx : x ∈ Block.modifiedVars (Block.substIdent y y' ss)) : + (x ∈ Block.modifiedVars ss ∧ x ≠ y) ∨ x = y' := by + match ss with + | [] => + simp only [Block.substIdent_nil, Block.modifiedVars] at hx + exact absurd hx List.not_mem_nil + | s :: rest => + simp only [Block.substIdent_cons, Block.modVars_cons, List.mem_append] at hx ⊢ + rcases hx with h | h + · rcases Stmt.substIdent_modVars_mem y y' s x h with ⟨hm, hne⟩ | he + · exact Or.inl ⟨Or.inl hm, hne⟩ + · exact Or.inr he + · rcases Block.substIdent_modVars_mem y y' rest x h with ⟨hm, hne⟩ | he + · exact Or.inl ⟨Or.inr hm, hne⟩ + · exact Or.inr he + termination_by sizeOf ss +end + +/-- `applyRenames` modified-var classification: each modified var of the renamed +block is either an original modified var or one of the rename TARGETS. -/ +theorem Block.applyRenames_modVars_mem [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (renames : List (P.Ident × P.Ident)) + (ss : List (Stmt P (Cmd P))) (x : P.Ident) + (hx : x ∈ Block.modifiedVars (Block.applyRenames renames ss)) : + x ∈ Block.modifiedVars ss ∨ x ∈ renames.map Prod.snd := by + induction renames generalizing ss with + | nil => + simp only [Block.applyRenames, List.foldl_nil] at hx + exact Or.inl hx + | cons p rest ih => + have hstep : Block.applyRenames (p :: rest) ss + = Block.applyRenames rest (Block.substIdent p.1 p.2 ss) := by + simp only [Block.applyRenames, List.foldl_cons] + rw [hstep] at hx + rcases ih (Block.substIdent p.1 p.2 ss) hx with h | h + · rcases Block.substIdent_modVars_mem p.1 p.2 ss x h with ⟨hm, _⟩ | he + · exact Or.inl hm + · refine Or.inr ?_; simp only [List.map_cons, List.mem_cons]; exact Or.inl he + · refine Or.inr ?_; simp only [List.map_cons, List.mem_cons]; exact Or.inr h + +mutual +/-- The lift residual's `modifiedVars` are contained in the input block's +`modifiedVars` plus the rename SOURCES (each lifted `.init y` adds a `.set y` +residual whose target `y` is the rename source). -/ +theorem Stmt.liftResidual_modVars_mem [HasIdent P] (s : Stmt P (Cmd P)) (σ : StringGenState) + (x : P.Ident) (hx : x ∈ Block.modifiedVars (Stmt.liftInitsInLoopBodyM s σ).1.2.2) : + x ∈ Stmt.modifiedVars s ∨ x ∈ (Stmt.liftInitsInLoopBodyM s σ).1.2.1.map Prod.fst := by + match s with + | .cmd c => + cases c with + | init name ty rhs md => + simp only [Stmt.liftInitsInLoopBodyM, Block.modifiedVars, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars, List.append_nil, List.mem_singleton, + List.map_cons, List.map_nil] at hx ⊢ + exact Or.inr hx + | set name rhs md => + simp only [Stmt.liftInitsInLoopBodyM, Block.modifiedVars, Stmt.modifiedVars, + List.append_nil] at hx ⊢ + exact Or.inl hx + | assert l e md => + simp only [Stmt.liftInitsInLoopBodyM, Block.modifiedVars, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars, List.append_nil] at hx + exact absurd hx List.not_mem_nil + | assume l e md => + simp only [Stmt.liftInitsInLoopBodyM, Block.modifiedVars, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars, List.append_nil] at hx + exact absurd hx List.not_mem_nil + | cover l e md => + simp only [Stmt.liftInitsInLoopBodyM, Block.modifiedVars, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars, List.append_nil] at hx + exact absurd hx List.not_mem_nil + | .block lbl bss md => + have hx' : x ∈ Block.modifiedVars (Block.liftInitsInLoopBodyM bss σ).1.2.2 := by + rw [Stmt.liftInitsInLoopBodyM_block_residual] at hx + simpa only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil] using hx + have hfst : (Stmt.liftInitsInLoopBodyM (.block lbl bss md) σ).1.2.1 + = (Block.liftInitsInLoopBodyM bss σ).1.2.1 := by + rw [Stmt.liftInitsInLoopBodyM] + rcases hb : Block.liftInitsInLoopBodyM bss σ with ⟨⟨hs, rn, bss'⟩, σ'⟩ + simp only [hb] + simp only [Stmt.modifiedVars, hfst] + exact Block.liftResidual_modVars_mem bss σ x hx' + | .ite g tss ess md => + have hx' : x ∈ Block.modifiedVars (Block.liftInitsInLoopBodyM tss σ).1.2.2 ∨ + x ∈ Block.modifiedVars + (Block.liftInitsInLoopBodyM ess (Block.liftInitsInLoopBodyM tss σ).2).1.2.2 := by + rw [Stmt.liftInitsInLoopBodyM_ite_residual] at hx + simpa only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil, List.mem_append] using hx + have hfst : (Stmt.liftInitsInLoopBodyM (.ite g tss ess md) σ).1.2.1 + = (Block.liftInitsInLoopBodyM tss σ).1.2.1 ++ + (Block.liftInitsInLoopBodyM ess (Block.liftInitsInLoopBodyM tss σ).2).1.2.1 := by + rw [Stmt.liftInitsInLoopBodyM] + rcases ht : Block.liftInitsInLoopBodyM tss σ with ⟨⟨ths, trn, tss'⟩, σ₁⟩ + rcases he : Block.liftInitsInLoopBodyM ess σ₁ with ⟨⟨ehs, ern, ess'⟩, σ₂⟩ + simp only [ht, he] + simp only [Stmt.modifiedVars, hfst, List.map_append, List.mem_append] + rcases hx' with h | h + · rcases Block.liftResidual_modVars_mem tss σ x h with h2 | h2 + · exact Or.inl (Or.inl h2) + · exact Or.inr (Or.inl h2) + · rcases Block.liftResidual_modVars_mem ess (Block.liftInitsInLoopBodyM tss σ).2 x h with h2 | h2 + · exact Or.inl (Or.inr h2) + · exact Or.inr (Or.inr h2) + | .loop g m inv body md => + simp only [Stmt.liftInitsInLoopBodyM, Block.modifiedVars, Stmt.modifiedVars, + List.append_nil] at hx ⊢ + exact Or.inl hx + | .exit lbl md => + simp only [Stmt.liftInitsInLoopBodyM, Block.modifiedVars, Stmt.modifiedVars, + List.append_nil] at hx + exact absurd hx List.not_mem_nil + | .funcDecl d md => + simp only [Stmt.liftInitsInLoopBodyM, Block.modifiedVars, Stmt.modifiedVars, + List.append_nil] at hx + exact absurd hx List.not_mem_nil + | .typeDecl t md => + simp only [Stmt.liftInitsInLoopBodyM, Block.modifiedVars, Stmt.modifiedVars, + List.append_nil] at hx + exact absurd hx List.not_mem_nil + termination_by sizeOf s + +/-- Block-level lift residual modified-var containment. -/ +theorem Block.liftResidual_modVars_mem [HasIdent P] (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (x : P.Ident) (hx : x ∈ Block.modifiedVars (Block.liftInitsInLoopBodyM ss σ).1.2.2) : + x ∈ Block.modifiedVars ss ∨ x ∈ (Block.liftInitsInLoopBodyM ss σ).1.2.1.map Prod.fst := by + match ss with + | [] => + simp only [Block.liftInitsInLoopBodyM, Block.modifiedVars] at hx + exact absurd hx List.not_mem_nil + | s :: rest => + have hx' : x ∈ Block.modifiedVars (Stmt.liftInitsInLoopBodyM s σ).1.2.2 ∨ + x ∈ Block.modifiedVars + (Block.liftInitsInLoopBodyM rest (Stmt.liftInitsInLoopBodyM s σ).2).1.2.2 := by + rw [Block.liftInitsInLoopBodyM_cons_residual] at hx + simpa only [Block.modVars_append, List.mem_append] using hx + have hfst : (Block.liftInitsInLoopBodyM (s :: rest) σ).1.2.1 + = (Stmt.liftInitsInLoopBodyM s σ).1.2.1 ++ + (Block.liftInitsInLoopBodyM rest (Stmt.liftInitsInLoopBodyM s σ).2).1.2.1 := by + rw [Block.liftInitsInLoopBodyM] + rcases hs : Stmt.liftInitsInLoopBodyM s σ with ⟨⟨hs_s, rn_s, ss_s⟩, σ₁⟩ + rcases hr : Block.liftInitsInLoopBodyM rest σ₁ with ⟨⟨hs_r, rn_r, ss_r⟩, σ₂⟩ + simp only [hs, hr] + simp only [Block.modVars_cons, hfst, List.map_append, List.mem_append] + rcases hx' with h | h + · rcases Stmt.liftResidual_modVars_mem s σ x h with h2 | h2 + · exact Or.inl (Or.inl h2) + · exact Or.inr (Or.inl h2) + · rcases Block.liftResidual_modVars_mem rest (Stmt.liftInitsInLoopBodyM s σ).2 x h with h2 | h2 + · exact Or.inl (Or.inr h2) + · exact Or.inr (Or.inr h2) + termination_by sizeOf ss +end + +/-- The havoc prelude `havocStmts' entries` (all `.init`) modifies nothing. -/ +private theorem Block.modifiedVars_havocStmts' (entries : List (Entry P)) : + Block.modifiedVars (havocStmts' entries) = [] := by + induction entries with + | nil => + simp only [LoopInitHoistLoopDriver.havocStmts'_nil, Block.modifiedVars] + | cons e rest ih => + rw [LoopInitHoistLoopDriver.havocStmts'_cons, Block.modVars_cons, ih] + simp only [Stmt.modifiedVars, HasVarsImp.modifiedVars, Cmd.modifiedVars, List.append_nil] + +mutual +/-- Mutual `Stmt` step of the `modifiedVars` classification: every modified var +of the post-order pass output is either an ORIGINAL source modified-or-init var, +or a FRESH generator name captured between the input and output states. (The +source carrier is `modifiedVars ++ initVars`: a lifted nested-loop init turns a +`.init y` into a `.set y` residual whose name `y` may survive un-renamed, so the +ORIGINAL branch must admit source inits as well as source set-targets.) -/ +theorem Stmt.hoistLoopPrefixInitsM_modVars_classified [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [LawfulHasIdent P] [HasVarsPure P P.Expr] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIntOrder P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (s : Stmt P (Cmd P)) (σ : StringGenState) (h_wf : StringGenState.WF σ) + (h_unique : (Stmt.initVars s).Nodup) + (h_shapefree : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s) : + ∀ x ∈ Block.modifiedVars (Stmt.hoistLoopPrefixInitsM s σ).1, + HoistInitClass Q (Stmt.modifiedVars s ++ Stmt.initVars s) σ + (Stmt.hoistLoopPrefixInitsM s σ).2 x := by + match s with + | .cmd c => + intro x hx + cases c with + | init y ty rhs md => + simp only [Stmt.hoistLoopPrefixInitsM, Block.modifiedVars, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars, List.append_nil] at hx + exact absurd hx List.not_mem_nil + | set y rhs md => + simp only [Stmt.hoistLoopPrefixInitsM, Block.modifiedVars, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars, List.append_nil] at hx + refine Or.inl ?_ + simp only [Stmt.modifiedVars, HasVarsImp.modifiedVars, Cmd.modifiedVars, + Stmt.initVars, List.mem_append] + exact Or.inl hx + | assert l e md => + simp only [Stmt.hoistLoopPrefixInitsM, Block.modifiedVars, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars, List.append_nil] at hx + exact absurd hx List.not_mem_nil + | assume l e md => + simp only [Stmt.hoistLoopPrefixInitsM, Block.modifiedVars, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars, List.append_nil] at hx + exact absurd hx List.not_mem_nil + | cover l e md => + simp only [Stmt.hoistLoopPrefixInitsM, Block.modifiedVars, Stmt.modifiedVars, + HasVarsImp.modifiedVars, Cmd.modifiedVars, List.append_nil] at hx + exact absurd hx List.not_mem_nil + | .block lbl bss md => + intro x hx + rw [Stmt.hoistLoopPrefixInitsM_block_out, Stmt.hoistLoopPrefixInitsM_block_state] at * + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil] at hx + have h_unique' : (Block.initVars bss).Nodup := by simpa only [Stmt.initVars_block] using h_unique + have h_shapefree' : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars bss := by + intro str hsuf; simpa only [Stmt.initVars_block] using h_shapefree str hsuf + have ih := Block.hoistLoopPrefixInitsM_modVars_classified hQmint bss σ h_wf h_unique' h_shapefree' x hx + rcases ih with h_o | h_f + · refine Or.inl ?_ + simp only [Stmt.modifiedVars, Stmt.initVars_block, List.mem_append] at h_o ⊢ + exact h_o + · exact Or.inr h_f + | .ite g tss ess md => + intro x hx + rw [Stmt.hoistLoopPrefixInitsM_ite_out, Stmt.hoistLoopPrefixInitsM_ite_state] at * + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil, List.mem_append] at hx + have h_uni : (Block.initVars tss ++ Block.initVars ess).Nodup := by + simpa only [Stmt.initVars_ite] using h_unique + have h_uni_t : (Block.initVars tss).Nodup := (List.nodup_append.mp h_uni).1 + have h_uni_e : (Block.initVars ess).Nodup := (List.nodup_append.mp h_uni).2.1 + have h_sf_t : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars tss := by + intro str hsuf hmem + exact h_shapefree str hsuf (by rw [Stmt.initVars_ite, List.mem_append]; exact Or.inl hmem) + have h_sf_e : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars ess := by + intro str hsuf hmem + exact h_shapefree str hsuf (by rw [Stmt.initVars_ite, List.mem_append]; exact Or.inr hmem) + have h_wf_t : StringGenState.WF (Block.hoistLoopPrefixInitsM tss σ).2 := + (Block.hoistLoopPrefixInitsM_genStep tss σ).wf_mono h_wf + have h_step_t : GenStep σ (Block.hoistLoopPrefixInitsM tss σ).2 := + Block.hoistLoopPrefixInitsM_genStep tss σ + have h_step_e : GenStep (Block.hoistLoopPrefixInitsM tss σ).2 + (Block.hoistLoopPrefixInitsM ess (Block.hoistLoopPrefixInitsM tss σ).2).2 := + Block.hoistLoopPrefixInitsM_genStep ess _ + rcases hx with h | h + · have ih := Block.hoistLoopPrefixInitsM_modVars_classified hQmint tss σ h_wf h_uni_t h_sf_t x h + rcases ih with h_o | ⟨str, he, hin, hnot, hQ⟩ + · refine Or.inl ?_ + simp only [Stmt.modifiedVars, Stmt.initVars_ite, List.mem_append] at h_o ⊢ + rcases h_o with hm | hi + · exact Or.inl (Or.inl hm) + · exact Or.inr (Or.inl hi) + · exact Or.inr ⟨str, he, h_step_e.subset hin, hnot, hQ⟩ + · have ih := Block.hoistLoopPrefixInitsM_modVars_classified hQmint ess + (Block.hoistLoopPrefixInitsM tss σ).2 h_wf_t h_uni_e h_sf_e x h + rcases ih with h_o | ⟨str, he, hin, hnot, hQ⟩ + · refine Or.inl ?_ + simp only [Stmt.modifiedVars, Stmt.initVars_ite, List.mem_append] at h_o ⊢ + rcases h_o with hm | hi + · exact Or.inl (Or.inr hm) + · exact Or.inr (Or.inr hi) + · refine Or.inr ⟨str, he, hin, ?_, hQ⟩ + intro h_in_σ; exact hnot (h_step_t.subset h_in_σ) + | .loop g m inv body md => + intro x hx + -- abbreviations: body₁ = hoist body, σ₁ its state; renames/body₂ from the lift. + rw [Stmt.hoistLoopPrefixInitsM_loop_out, Stmt.hoistLoopPrefixInitsM_loop_state] at * + have h_wf₁ : StringGenState.WF (Block.hoistLoopPrefixInitsM body σ).2 := + (Block.hoistLoopPrefixInitsM_genStep body σ).wf_mono h_wf + have h_step_body : GenStep σ (Block.hoistLoopPrefixInitsM body σ).2 := + Block.hoistLoopPrefixInitsM_genStep body σ + have h_step_lift : + GenStep (Block.hoistLoopPrefixInitsM body σ).2 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).2 := + Block.liftInitsInLoopBodyM_genStep _ _ + have h_unique' : (Block.initVars body).Nodup := by simpa only [Stmt.initVars_loop] using h_unique + have h_shapefree' : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars body := by + intro str hsuf; simpa only [Stmt.initVars_loop] using h_shapefree str hsuf + -- the output's modifiedVars are exactly `modifiedVars body₃` (havocs are `.init`). + have hx_body₃ : x ∈ Block.modifiedVars + (Block.applyRenames + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) := by + rw [Block.modVars_append] at hx + rw [(LoopInitHoistLoopDriver.Block.lift_harvest_subst + (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1, + Block.modifiedVars_havocStmts'] at hx + simp only [Stmt.modifiedVars, Block.modifiedVars, + List.append_nil, List.nil_append] at hx + exact hx + -- rename targets are exactly `targetsOf' E`; sources `sourcesOf' E`. + have h_subst : (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + = substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2) := + (LoopInitHoistLoopDriver.Block.lift_harvest_subst _ _).2 + -- classify via applyRenames: original residual modVars or a rename target. + rcases Block.applyRenames_modVars_mem _ _ x hx_body₃ with h_res | h_tgt + · -- residual modVars: original body₁ modVars or a rename source (= lifted init name). + rcases Block.liftResidual_modVars_mem _ _ x h_res with h_body₁ | h_src + · -- x ∈ modifiedVars body₁: classify by IH on `body`. + have ih := Block.hoistLoopPrefixInitsM_modVars_classified hQmint body σ h_wf h_unique' h_shapefree' x h_body₁ + rcases ih with h_o | ⟨str, he, hin, hnot, hQ⟩ + · refine Or.inl ?_ + simp only [Stmt.modifiedVars, Stmt.initVars_loop, List.mem_append] at h_o ⊢ + exact h_o + · exact Or.inr ⟨str, he, h_step_lift.subset hin, hnot, hQ⟩ + · -- x ∈ renames.map .1 = sourcesOf' E ⊆ initVars body₁: classify by initVars classification. + rw [h_subst, substOf'_map_fst] at h_src + have h_x_in₁ : x ∈ Block.initVars (Block.hoistLoopPrefixInitsM body σ).1 := + Block.sourcesOf_entriesOf_subset _ _ x h_src + have ih := (Block.hoistLoopPrefixInitsM_initVars_classified hQmint body σ h_wf + h_unique' h_shapefree').1 x h_x_in₁ + rcases ih with h_o | ⟨str, he, hin, hnot, hQ⟩ + · refine Or.inl ?_ + simp only [Stmt.modifiedVars, Stmt.initVars_loop, List.mem_append] + exact Or.inr h_o + · exact Or.inr ⟨str, he, h_step_lift.subset hin, hnot, hQ⟩ + · -- x is a rename TARGET = targetsOf' E: fresh between σ₁ and σ₂, hence fresh from σ. + rw [h_subst, ← LoopInitHoistLoopDriver.targetsOf'_eq_substOf'_snd] at h_tgt + obtain ⟨e, he_mem, he_eq⟩ := List.mem_map.mp h_tgt + obtain ⟨t, ht_eq, ht_in, ht_not⟩ := + (Block.entriesOf_targetGen (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2 h_wf₁).1 e he_mem + obtain ⟨t', ht'_eq, ht'_Q⟩ := + Block.entriesOf_target_suffix hQmint (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2 e he_mem + have h_t_eq : t = t' := + LawfulHasIdent.ident_inj (ht_eq.symm.trans ht'_eq) + refine Or.inr ⟨t, ?_, ht_in, ?_, h_t_eq ▸ ht'_Q⟩ + · rw [← he_eq, ht_eq] + · intro h_in_σ; exact ht_not (h_step_body.subset h_in_σ) + | .exit lbl md => + intro x hx + simp only [Stmt.hoistLoopPrefixInitsM, Block.modifiedVars, Stmt.modifiedVars, + List.append_nil] at hx + exact absurd hx List.not_mem_nil + | .funcDecl d md => + intro x hx + simp only [Stmt.hoistLoopPrefixInitsM, Block.modifiedVars, Stmt.modifiedVars, + List.append_nil] at hx + exact absurd hx List.not_mem_nil + | .typeDecl t md => + intro x hx + simp only [Stmt.hoistLoopPrefixInitsM, Block.modifiedVars, Stmt.modifiedVars, + List.append_nil] at hx + exact absurd hx List.not_mem_nil + termination_by sizeOf s + +/-- Mutual `Block` step of the `modifiedVars` classification. -/ +theorem Block.hoistLoopPrefixInitsM_modVars_classified [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [LawfulHasIdent P] [HasVarsPure P P.Expr] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIntOrder P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) (h_wf : StringGenState.WF σ) + (h_unique : (Block.initVars ss).Nodup) + (h_shapefree : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars ss) : + ∀ x ∈ Block.modifiedVars (Block.hoistLoopPrefixInitsM ss σ).1, + HoistInitClass Q (Block.modifiedVars ss ++ Block.initVars ss) σ + (Block.hoistLoopPrefixInitsM ss σ).2 x := by + match ss with + | [] => + intro x hx + simp only [Block.hoistLoopPrefixInitsM, Block.modifiedVars] at hx + exact absurd hx List.not_mem_nil + | s :: rest => + intro x hx + rw [Block.hoistLoopPrefixInitsM_cons_out, Block.hoistLoopPrefixInitsM_cons_state] at * + simp only [Block.modVars_append, List.mem_append] at hx + have h_uni : (Stmt.initVars s ++ Block.initVars rest).Nodup := by + simpa only [Block.initVars_cons] using h_unique + have h_uni_s : (Stmt.initVars s).Nodup := (List.nodup_append.mp h_uni).1 + have h_uni_r : (Block.initVars rest).Nodup := (List.nodup_append.mp h_uni).2.1 + have h_sf_s : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s := by + intro str hsuf hmem + exact h_shapefree str hsuf (by rw [Block.initVars_cons, List.mem_append]; exact Or.inl hmem) + have h_sf_r : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars rest := by + intro str hsuf hmem + exact h_shapefree str hsuf (by rw [Block.initVars_cons, List.mem_append]; exact Or.inr hmem) + have h_wf_s : StringGenState.WF (Stmt.hoistLoopPrefixInitsM s σ).2 := + (Stmt.hoistLoopPrefixInitsM_genStep s σ).wf_mono h_wf + have h_step_s : GenStep σ (Stmt.hoistLoopPrefixInitsM s σ).2 := + Stmt.hoistLoopPrefixInitsM_genStep s σ + have h_step_r : GenStep (Stmt.hoistLoopPrefixInitsM s σ).2 + (Block.hoistLoopPrefixInitsM rest (Stmt.hoistLoopPrefixInitsM s σ).2).2 := + Block.hoistLoopPrefixInitsM_genStep rest _ + rcases hx with h | h + · have ih := Stmt.hoistLoopPrefixInitsM_modVars_classified hQmint s σ h_wf h_uni_s h_sf_s x h + rcases ih with h_o | ⟨str, he, hin, hnot, hQ⟩ + · refine Or.inl ?_ + simp only [Block.modVars_cons, Block.initVars_cons, List.mem_append] at h_o ⊢ + rcases h_o with hm | hi + · exact Or.inl (Or.inl hm) + · exact Or.inr (Or.inl hi) + · exact Or.inr ⟨str, he, h_step_r.subset hin, hnot, hQ⟩ + · have ih := Block.hoistLoopPrefixInitsM_modVars_classified hQmint rest + (Stmt.hoistLoopPrefixInitsM s σ).2 h_wf_s h_uni_r h_sf_r x h + rcases ih with h_o | ⟨str, he, hin, hnot, hQ⟩ + · refine Or.inl ?_ + simp only [Block.modVars_cons, Block.initVars_cons, List.mem_append] at h_o ⊢ + rcases h_o with hm | hi + · exact Or.inl (Or.inr hm) + · exact Or.inr (Or.inr hi) + · refine Or.inr ⟨str, he, hin, ?_, hQ⟩ + intro h_in_σ; exact hnot (h_step_s.subset h_in_σ) + termination_by sizeOf ss +end + +/-! ## Producer precondition `h_disjoint`: harvest sources ∩ targets = ∅. + +`Block.bodyTransport_of_lift` needs the renaming's keys (sources) disjoint from +its values (targets): `∀ a ∈ sourcesOf' E, a ∉ targetsOf' E` for +`E = entriesOf body₁ σ₁`. Sources are top-level inits of `body₁` (a `Sublist` +of `initVars body₁`); each such init is CLASSIFIED (by the post-order pass) as +either an ORIGINAL source init (a member of the source `initVars body`, hence +suffix-free) or a FRESH hoist name whose generator string lies in the HOIST +pass's output state `σ₁`. Each target is a generator string of the SUBSEQUENT +lift pass, suffix-shaped and ABSENT from `σ₁`. Both classes are therefore +disjoint from the targets: a suffix-free original can't equal a suffix-shaped +target, and a fresh source's string is in `σ₁` while a target's is not. -/ +theorem Block.sourcesOf'_disjoint_targetsOf'_self [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (body : List (Stmt P (Cmd P))) (σ : StringGenState) (h_wf : StringGenState.WF σ) + (h_unique : (Block.initVars body).Nodup) + (h_shapefree : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars body) : + ∀ a ∈ sourcesOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2), + a ∉ targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2) := by + classical + intro a ha_src ha_tgt + -- abbreviations + have h_wf₁ : StringGenState.WF (Block.hoistLoopPrefixInitsM body σ).2 := + (Block.hoistLoopPrefixInitsM_genStep body σ).wf_mono h_wf + -- (1) `a ∈ initVars body₁` (sources ⊆ inits). + have h_a_in₁ : a ∈ Block.initVars (Block.hoistLoopPrefixInitsM body σ).1 := + Block.sourcesOf_entriesOf_subset _ _ a ha_src + -- (2) classify `a` as original or fresh-hoist. + have h_class := + (Block.hoistLoopPrefixInitsM_initVars_classified hQmint body σ h_wf h_unique h_shapefree).1 + a h_a_in₁ + -- (3) `a` is a target: `a = e.2.1` with `TargetGen σ₁ σ₂ e`, i.e. `a = ident + -- str_b`, `str_b ∉ σ₁`, and (separately) `str_b` carries the mint kind `Q`. + obtain ⟨e, he_mem, he_eq⟩ := List.mem_map.mp ha_tgt + obtain ⟨str_b, h_b_eq, _, h_str_b_notσ₁⟩ := + (Block.entriesOf_targetGen _ _ h_wf₁).1 e he_mem + have h_a_eq_b : a = HasIdent.ident str_b := he_eq ▸ h_b_eq + have h_str_b_Q : Q str_b := by + obtain ⟨str_b', h_eq', h_Q'⟩ := + Block.mem_targetsOf'_entriesOf_hasUnderscoreDigitSuffix hQmint _ _ ha_tgt + have : (HasIdent.ident str_b' : P.Ident) = HasIdent.ident str_b := by + rw [← h_eq', h_a_eq_b] + rw [← LawfulHasIdent.ident_inj this]; exact h_Q' + rcases h_class with h_orig | ⟨str_a, h_a_eq_a, h_str_a_inσ₁, _⟩ + · -- ORIGINAL: `a ∈ initVars body`, but `a = HasIdent.ident str_b` carries kind + -- `Q` — contradicts `h_shapefree`. + exact h_shapefree str_b h_str_b_Q (h_a_eq_b ▸ h_orig) + · -- FRESH hoist: `a = HasIdent.ident str_a`, `str_a ∈ σ₁`; but + -- `a = HasIdent.ident str_b`, `str_b ∉ σ₁`. `str_a = str_b` ⇒ contradiction. + have h_id : (HasIdent.ident str_a : P.Ident) = HasIdent.ident str_b := by + rw [← h_a_eq_a, ← h_a_eq_b] + have h_str_eq : str_a = str_b := LawfulHasIdent.ident_inj h_id + exact h_str_b_notσ₁ (h_str_eq ▸ h_str_a_inσ₁) + +/-! ## Producer precondition `h_mod_disjoint_B1`: harvest targets ∩ modifiedVars = ∅. + +`Block.stepB_self_of_lift` needs `modifiedVars body₁ ∩ targetsOf' E = ∅` for +`body₁ = (hoistLoopPrefixInitsM body σ).1` and `E = entriesOf body₁ σ₁`. Each +`x ∈ modifiedVars body₁` is CLASSIFIED (by the post-order pass) as either an +ORIGINAL source modified-or-init var (a member of `modifiedVars body ++ initVars +body`, hence suffix-free for a well-formed source) or a FRESH hoist name whose +generator string lies in the HOIST pass's output state `σ₁` (a name minted by the +inner hoist of a nested-loop init). Each target is a +generator string of the SUBSEQUENT lift pass, suffix-shaped and ABSENT from +`σ₁`. Both classes are therefore disjoint from the targets: a suffix-free +original can't equal a suffix-shaped target, and a fresh source's string is in +`σ₁` while a target's is not. -/ +theorem Block.modifiedVars_disjoint_targetsOf'_self [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIntOrder P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (body : List (Stmt P (Cmd P))) (σ : StringGenState) (h_wf : StringGenState.WF σ) + (h_unique : (Block.initVars body).Nodup) + (h_iv_shapefree : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars body) + (h_mod_shapefree : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.modifiedVars body) : + ∀ x ∈ Block.modifiedVars (Block.hoistLoopPrefixInitsM body σ).1, + x ∉ targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2) := by + classical + intro x hx_mod hx_tgt + -- abbreviation: σ₁ = output state of the hoist pass. + have h_wf₁ : StringGenState.WF (Block.hoistLoopPrefixInitsM body σ).2 := + (Block.hoistLoopPrefixInitsM_genStep body σ).wf_mono h_wf + -- (1) classify `x` as ORIGINAL (∈ modifiedVars body ++ initVars body) or FRESH (∈ σ₁ \ σ). + have h_class := + Block.hoistLoopPrefixInitsM_modVars_classified hQmint body σ h_wf h_unique h_iv_shapefree x hx_mod + -- (2) `x` is a target: `x = ident str_b` with `str_b ∉ σ₁`, carrying kind `Q`. + obtain ⟨e, he_mem, he_eq⟩ := List.mem_map.mp hx_tgt + obtain ⟨str_b, h_b_eq, _, h_str_b_notσ₁⟩ := + (Block.entriesOf_targetGen _ _ h_wf₁).1 e he_mem + have h_x_eq_b : x = HasIdent.ident str_b := he_eq ▸ h_b_eq + have h_str_b_Q : Q str_b := by + obtain ⟨str_b', h_eq', h_Q'⟩ := + Block.mem_targetsOf'_entriesOf_hasUnderscoreDigitSuffix hQmint _ _ hx_tgt + have : (HasIdent.ident str_b' : P.Ident) = HasIdent.ident str_b := by + rw [← h_eq', h_x_eq_b] + rw [← LawfulHasIdent.ident_inj this]; exact h_Q' + rcases h_class with h_orig | ⟨str_a, h_x_eq_a, h_str_a_inσ₁, _⟩ + · -- ORIGINAL: `x ∈ modifiedVars body ++ initVars body`, but `x = ident str_b` + -- carries kind `Q` — contradicts `h_mod_shapefree`/`h_iv_shapefree`. + rcases List.mem_append.mp h_orig with h_m | h_i + · exact h_mod_shapefree str_b h_str_b_Q (h_x_eq_b ▸ h_m) + · exact h_iv_shapefree str_b h_str_b_Q (h_x_eq_b ▸ h_i) + · -- FRESH hoist: `x = ident str_a`, `str_a ∈ σ₁`; but `x = ident str_b`, + -- `str_b ∉ σ₁`. `str_a = str_b` ⇒ contradiction. + have h_id : (HasIdent.ident str_a : P.Ident) = HasIdent.ident str_b := by + rw [← h_x_eq_a, ← h_x_eq_b] + have h_str_eq : str_a = str_b := LawfulHasIdent.ident_inj h_id + exact h_str_b_notσ₁ (h_str_eq ▸ h_str_a_inσ₁) + +/-! ## §E `.loop` arm final reconciliation. + +`union_entry_hinv` builds the loop-entry union `HoistInv` (ambient `A B subst` +relating `ρ_src ρ_hoist`, prelude relating `ρ_hoist ρ_pre` on the fresh +carriers, composed at the union). `loop_arm_close` then runs the full guarded +assembly — prelude bridge → union entry → `compose_union_sf_sum` (composing the +guarded bridge) → two-guard loop driver → stitch (havoc prelude ++ loop run) → `stepJ_restrict` +back to the ambient carriers — producing the §E sum-typed terminal conclusion +for the residual `havocStmts' E ++ [.loop (.det g) none [] body₃ md]`. -/ + +open LoopInitHoistLoopDriver (BodySimSum BodySimUSFSum + bodySimUSFSum_is_driver_slot + compose_union_sf_sum + bridge_in_guarded_undef_sf stepJ_restrict + loopDet_lift_sf_undef_TE_recovers_single + loopDet_lift_sf_undef_E_recovers_single + loopDet_lift_sf_2g_undef_F_fuel + compose_union_fail + prelude_bridge_list_md_frame) + +open OptEStepBProvider (BodySimFail) + +/-- Loop-entry union `HoistInv` builder (guarded frame). -/ +theorem union_entry_hinv + {A B As Bs : List P.Ident} {subst ss : List (P.Ident × P.Ident)} + {ρ_src ρ_hoist ρ_pre : Env P} + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (_h_pre : HoistInv (P := P) A Bs ss ρ_hoist.store ρ_pre.store) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_ss_wf : ∀ a b, (a, b) ∈ ss → a ∈ As ∧ b ∈ Bs) + (_h_As_notA : ∀ x ∈ As, x ∉ A) (_h_As_notB : ∀ x ∈ As, x ∉ B) + (h_B_notBs : ∀ b ∈ B, b ∉ Bs) + (h_src_As_undef : ∀ a ∈ As, ρ_src.store a = none) + (h_pre_frame_off_Bs : ∀ x, x ∉ Bs → ρ_pre.store x = ρ_hoist.store x) : + HoistInv (P := P) (A ++ As) (B ++ Bs) (subst ++ ss) ρ_src.store ρ_pre.store := by + refine ⟨?_, ?_⟩ + · intro x hxA hxB h_x_ne + have hxAo : x ∉ A := fun h => hxA (List.mem_append.mpr (Or.inl h)) + have hxBo : x ∉ B := fun h => hxB (List.mem_append.mpr (Or.inl h)) + have hxBs : x ∉ Bs := fun h => hxB (List.mem_append.mpr (Or.inr h)) + rw [h_hinv.1 x hxAo hxBo h_x_ne, (h_pre_frame_off_Bs x hxBs).symm] + · intro a b h_pair h_ne + rcases List.mem_append.mp h_pair with h_so | h_ss + · obtain ⟨ha_A, hb_B⟩ := h_subst_wf a b h_so + obtain ⟨h_b_ne, h_eq⟩ := h_hinv.2 a b h_so h_ne + have h_move : ρ_pre.store b = ρ_hoist.store b := h_pre_frame_off_Bs b (h_B_notBs b hb_B) + exact ⟨by rw [h_move]; exact h_b_ne, by rw [h_move]; exact h_eq⟩ + · obtain ⟨ha_As, hb_Bs⟩ := h_ss_wf a b h_ss + exact absurd (h_src_As_undef a ha_As) h_ne + +/-- **Step B, self-assembled at the harvest carriers.** On the post-order body +`body₁ = (hoistLoopPrefixInitsM body σ).1`, the lift's renaming simulation holds +at `body₁`'s OWN harvest carriers `sourcesOf' E`/`targetsOf' E`/`substOf' E` +(`E = entriesOf body₁ σ₁`), producing the rewritten loop body `body₃ = +applyRenames (substOf' E) (lift residual)`. Every producer precondition of +`Block.stepB_bodySim_of_lift` is discharged from the source body's §E arm shape +facts: the self-`EntriesIn` is `List.mem_map`, the target freshness/nodup/shape +facts come from the harvest-target generator lemmas, and the source∩target +disjointness from `sourcesOf'_disjoint_targetsOf'_self`. -/ +theorem Block.stepB_self_of_lift [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIntOrder P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {extendEval : ExtendEval P} + (body : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_wf_σ : StringGenState.WF σ) + (h_nd : Block.containsNondetLoop body = false) + (h_fd : Block.containsFuncDecl body = false) + (h_inv : Block.loopHasNoInvariants body = true) + (h_measure : Block.loopMeasureNone body = true) + (h_unique : Block.uniqueInits body) + (h_sf : Block.exprsShapeFree (P := P) Q body) + (h_src_shapefree : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars body) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars (Block.hoistLoopPrefixInitsM body σ).1, + x ∉ targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2)) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) + (sourcesOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.hoistLoopPrefixInitsM body σ).1 + (Block.applyRenames + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) := by + have h_wf₁ : StringGenState.WF (Block.hoistLoopPrefixInitsM body σ).2 := + (Block.hoistLoopPrefixInitsM_genStep body σ).wf_mono h_wf_σ + have h_nd_body1 : (Block.initVars (Block.hoistLoopPrefixInitsM body σ).1).Nodup := + Block.hoistLoopPrefixInitsM_initVars_nodup hQmint body σ h_wf_σ h_unique h_src_shapefree + have h_entries : LoopInitHoistStepCProducer.EntriesIn + (sourcesOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 := by + intro e he + exact ⟨List.mem_map.mpr ⟨e, he, rfl⟩, + List.mem_map.mpr ⟨e, he, rfl⟩, + List.mem_map.mpr ⟨e, he, rfl⟩⟩ + refine LoopInitHoistStepCProducer.Block.stepB_bodySim_of_lift + (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 + (sourcesOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + ?_ h_entries ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ h_wfvar h_wfcongr h_wfsubst h_wfdef + · exact Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree body σ + · exact Block.hoistLoopPrefixInitsM_namesFreshInExprs_targets_of_exprsShapeFree + hQmint body σ h_wf₁ h_sf + · exact h_mod_disjoint_B + · intro a b hab + obtain ⟨e, he, heq⟩ := List.mem_map.mp hab + cases heq + exact ⟨List.mem_map.mpr ⟨e, he, rfl⟩, List.mem_map.mpr ⟨e, he, rfl⟩⟩ + · exact Block.entriesOf_substOf_src_nodup_of_initVars (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2 h_nd_body1 + · rw [show (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)).map Prod.snd + = targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2) from + (LoopInitHoistLoopDriver.targetsOf'_eq_substOf'_snd _).symm] + exact (Block.entriesOf_targetGen (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 h_wf₁).2 + · rw [substOf'_map_fst, show (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)).map Prod.snd + = targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2) from + (LoopInitHoistLoopDriver.targetsOf'_eq_substOf'_snd _).symm] + exact Block.sourcesOf'_disjoint_targetsOf'_self hQmint body σ h_wf_σ h_unique h_src_shapefree + · exact Block.transportShape_hoistLoopPrefixInitsM body σ h_nd h_fd h_inv h_measure + · rw [substOf'_map_fst]; exact fun a ha => ha + · rw [substOf'_map_fst]; exact fun a ha => ha + · rw [show (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)).map Prod.snd + = targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2) from + (LoopInitHoistLoopDriver.targetsOf'_eq_substOf'_snd _).symm] + exact fun b hb => hb + +/-- The FAILING-config sibling of `Block.stepB_self_of_lift`: the same harvest +carriers and lift preconditions, but producing a `BodySimFail` (a failing +`body₁`-run is matched by a failing `body₃`-run) via +`Block.stepB_bodySim_of_lift_fail`. The preconditions are discharged identically +to `Block.stepB_self_of_lift`. -/ +theorem Block.stepB_self_of_lift_fail [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIntOrder P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + {extendEval : ExtendEval P} + (body : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_wf_σ : StringGenState.WF σ) + (h_nd : Block.containsNondetLoop body = false) + (h_fd : Block.containsFuncDecl body = false) + (h_inv : Block.loopHasNoInvariants body = true) + (h_measure : Block.loopMeasureNone body = true) + (h_unique : Block.uniqueInits body) + (h_sf : Block.exprsShapeFree (P := P) Q body) + (h_src_shapefree : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars body) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars (Block.hoistLoopPrefixInitsM body σ).1, + x ∉ targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2)) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + BodySimFail (extendEval := extendEval) + (sourcesOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.hoistLoopPrefixInitsM body σ).1 + (Block.applyRenames + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) := by + have h_wf₁ : StringGenState.WF (Block.hoistLoopPrefixInitsM body σ).2 := + (Block.hoistLoopPrefixInitsM_genStep body σ).wf_mono h_wf_σ + have h_nd_body1 : (Block.initVars (Block.hoistLoopPrefixInitsM body σ).1).Nodup := + Block.hoistLoopPrefixInitsM_initVars_nodup hQmint body σ h_wf_σ h_unique h_src_shapefree + have h_entries : LoopInitHoistStepCProducer.EntriesIn + (sourcesOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 := by + intro e he + exact ⟨List.mem_map.mpr ⟨e, he, rfl⟩, + List.mem_map.mpr ⟨e, he, rfl⟩, + List.mem_map.mpr ⟨e, he, rfl⟩⟩ + refine LoopInitHoistStepCProducer.Block.stepB_bodySim_of_lift_fail + (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 + (sourcesOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + ?_ h_entries ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ h_wfvar h_wfcongr h_wfsubst h_wfdef + · exact Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree body σ + · exact Block.hoistLoopPrefixInitsM_namesFreshInExprs_targets_of_exprsShapeFree + hQmint body σ h_wf₁ h_sf + · exact h_mod_disjoint_B + · intro a b hab + obtain ⟨e, he, heq⟩ := List.mem_map.mp hab + cases heq + exact ⟨List.mem_map.mpr ⟨e, he, rfl⟩, List.mem_map.mpr ⟨e, he, rfl⟩⟩ + · exact Block.entriesOf_substOf_src_nodup_of_initVars (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2 h_nd_body1 + · rw [show (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)).map Prod.snd + = targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2) from + (LoopInitHoistLoopDriver.targetsOf'_eq_substOf'_snd _).symm] + exact (Block.entriesOf_targetGen (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 h_wf₁).2 + · rw [substOf'_map_fst, show (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)).map Prod.snd + = targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2) from + (LoopInitHoistLoopDriver.targetsOf'_eq_substOf'_snd _).symm] + exact Block.sourcesOf'_disjoint_targetsOf'_self hQmint body σ h_wf_σ h_unique h_src_shapefree + · exact Block.transportShape_hoistLoopPrefixInitsM body σ h_nd h_fd h_inv h_measure + · rw [substOf'_map_fst]; exact fun a ha => ha + · rw [substOf'_map_fst]; exact fun a ha => ha + · rw [show (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)).map Prod.snd + = targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2) from + (LoopInitHoistLoopDriver.targetsOf'_eq_substOf'_snd _).symm] + exact fun b hb => hb + +/-- **Step B residual is `noFuncDecl`.** The rewritten loop body +`body₃ = applyRenames (substOf' E) (lift residual)` (`E = entriesOf body₁ σ₁`, +`body₁ = (hoistLoopPrefixInitsM body σ).1`) is `noFuncDecl` — the body-transport +relation that `body₁` ↝ `body₃` inhabits (`bodyTransport_of_lift`, at the same +harvest carriers `stepB_self_of_lift` uses) has a `noFuncDecl` hoist side +(`BodyTransport.noFuncDecl_h`). The producer preconditions are discharged from +the source body's §E arm-shape facts exactly as in `stepB_self_of_lift`. -/ +theorem Block.stepB_noFuncDecl_h_of_lift [HasIdent P] [LawfulHasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [LawfulHasSubstFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIntOrder P] {Q : String → Prop} + (hQmint : ∀ sg, Q (StringGenState.gen hoistFreshPrefix sg).1) + (body : List (Stmt P (Cmd P))) (σ : StringGenState) + (h_wf_σ : StringGenState.WF σ) + (h_nd : Block.containsNondetLoop body = false) + (h_fd : Block.containsFuncDecl body = false) + (h_inv : Block.loopHasNoInvariants body = true) + (h_measure : Block.loopMeasureNone body = true) + (h_unique : Block.uniqueInits body) + (h_sf : Block.exprsShapeFree (P := P) Q body) + (h_src_shapefree : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ Block.initVars body) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars (Block.hoistLoopPrefixInitsM body σ).1, + x ∉ targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2)) : + Block.noFuncDecl + (Block.applyRenames + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) + = true := by + have h_wf₁ : StringGenState.WF (Block.hoistLoopPrefixInitsM body σ).2 := + (Block.hoistLoopPrefixInitsM_genStep body σ).wf_mono h_wf_σ + have h_nd_body1 : (Block.initVars (Block.hoistLoopPrefixInitsM body σ).1).Nodup := + Block.hoistLoopPrefixInitsM_initVars_nodup hQmint body σ h_wf_σ h_unique h_src_shapefree + have h_entries : LoopInitHoistStepCProducer.EntriesIn + (sourcesOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 := by + intro e he + exact ⟨List.mem_map.mpr ⟨e, he, rfl⟩, + List.mem_map.mpr ⟨e, he, rfl⟩, + List.mem_map.mpr ⟨e, he, rfl⟩⟩ + refine LoopInitHoistBodyTransport.BodyTransport.noFuncDecl_h + (LoopInitHoistStepCProducer.Block.bodyTransport_of_lift + (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 + (sourcesOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)) + (Block.hoistLoopPrefixInitsM_allLoopBodiesInitFree body σ) + h_entries + (Block.hoistLoopPrefixInitsM_namesFreshInExprs_targets_of_exprsShapeFree + hQmint body σ h_wf₁ h_sf) + h_mod_disjoint_B + ?_ ?_ ?_ ?_ ?_ ?_) + · intro a b hab + obtain ⟨e, he, heq⟩ := List.mem_map.mp hab + cases heq + exact ⟨List.mem_map.mpr ⟨e, he, rfl⟩, List.mem_map.mpr ⟨e, he, rfl⟩⟩ + · rw [substOf'_map_fst]; exact fun a ha => ha + · exact Block.entriesOf_substOf_src_nodup_of_initVars (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2 h_nd_body1 + · rw [show (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)).map Prod.snd + = targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2) from + (LoopInitHoistLoopDriver.targetsOf'_eq_substOf'_snd _).symm] + exact (Block.entriesOf_targetGen (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2 h_wf₁).2 + · rw [substOf'_map_fst, show (substOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2)).map Prod.snd + = targetsOf' (Block.entriesOf (Block.hoistLoopPrefixInitsM body σ).1 (Block.hoistLoopPrefixInitsM body σ).2) from + (LoopInitHoistLoopDriver.targetsOf'_eq_substOf'_snd _).symm] + exact Block.sourcesOf'_disjoint_targetsOf'_self hQmint body σ h_wf_σ h_unique h_src_shapefree + · exact Block.transportShape_hoistLoopPrefixInitsM body σ h_nd h_fd h_inv h_measure + +/-- The full §E `.loop` arm reconciliation: given a SUM-TYPED Step A (both the +terminal `stepA` and exiting `stepA_exit` clauses for `body ↝ body₁`) and a +SUM-TYPED Step B (`BodySimSum (sources)(targets)(substOf'E) body₁ body₃`) plus the +arm's disjointness / freshness / run facts, produce the §E sum-typed conclusion +for the residual `havocStmts' E ++ [.loop (.det g) none [] body₃ md]`. + +The two clauses compose into a `BodySimUSFSum` (`compose_union_sf_sum`), which +drives BOTH source loop outcomes: a `.terminal` source run is matched by a +`.terminal` hoist run (the sum-typed terminal driver `loopDet_lift_sf_undef_TE_recovers_single`), +and an `.exiting label` source run (some iteration's body broke) is matched by an +`.exiting label` hoist run (the sum-typed exiting driver +`loopDet_lift_sf_undef_E_recovers_single`). No static no-exit precondition is +required: a body `.exit` is admitted and faithfully simulated. Guard `g` is UNCHANGED (the renames live +inside `body₃`). -/ +theorem loop_arm_close [HasIdent P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [HasBool P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIntOrder P] [HasSubstFvar P] + {Q : String → Prop} + {extendEval : ExtendEval P} + {g : P.Expr} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {Vs : List P.Ident} {σ_sf : StringGenState} + {body body₁ body₃ : List (Stmt P (Cmd P))} {md : MetaData P} + {entries : List (Entry P)} + {ρ_src ρ_hoist : Env P} {cfg_src : Config P (Cmd P)} + (stepA : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vs, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + (stepA_exit : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vs, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + (stepB : BodySimSum (extendEval := extendEval) + (sourcesOf' entries) (targetsOf' entries) (substOf' entries) body₁ body₃) + (h_entry_Vs : ∀ y ∈ Vs, ρ_src.store y = none) + (h_entry_Vh : ∀ y ∈ Vs, ρ_hoist.store y = none) + (h_arm_src_sf : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_src.store (HasIdent.ident (P := P) str) = none) + (h_sf_notA : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → HasIdent.ident (P := P) str ∉ A) + (h_sf_notB : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → HasIdent.ident (P := P) str ∉ B) + (h_Vs_notA : ∀ y ∈ Vs, y ∉ A) (h_Vs_notB : ∀ y ∈ Vs, y ∉ B) + (h_Vs_notBs : ∀ y ∈ Vs, y ∉ targetsOf' entries) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_ss_wf : ∀ a b, (a, b) ∈ substOf' entries → + a ∈ sourcesOf' entries ∧ b ∈ targetsOf' entries) + (h_As_notA : ∀ x ∈ sourcesOf' entries, x ∉ A) + (h_As_notB : ∀ x ∈ sourcesOf' entries, x ∉ B) + (h_B_notAs : ∀ b ∈ B, b ∉ sourcesOf' entries) + (h_B_notBs : ∀ b ∈ B, b ∉ targetsOf' entries) + (_h_Bs_notB : ∀ b ∈ targetsOf' entries, b ∉ B) + (h_g_A_fresh : ∀ x ∈ A, x ∉ HasVarsPure.getVars g) + (h_g_B_fresh : ∀ x ∈ B, x ∉ HasVarsPure.getVars g) + -- EXPERIMENT: the *source-name* guard freshness is needed ONLY for sources + -- that are NOT in `Vs` (the loop's own body-inits): an original-source + -- (`∈ Vs`) cannot read the guard since it is undefined at every loop head + -- (eval-def contradiction), so guard freshness is derived from `Vs`-undef. + -- The residual non-`Vs` sources (fresh names synthesised by an inner hoist) + -- still need a static freshness witness (shape-freedom at the caller). + (h_g_As_minus_Vs_fresh : ∀ x ∈ sourcesOf' entries, x ∉ Vs → x ∉ HasVarsPure.getVars g) + (h_g_Bs_fresh : ∀ x ∈ targetsOf' entries, x ∉ HasVarsPure.getVars g) + (h_src_As_undef : ∀ a ∈ sourcesOf' entries, ρ_src.store a = none) + (h_nofd_src : Block.noFuncDecl body = true) + (h_nofd_h : Block.noFuncDecl body₃ = true) + (h_tgt_nodup : (targetsOf' entries).Nodup) + (h_src_undef_h : ∀ e ∈ entries, ρ_hoist.store e.1 = none) + (h_tgt_undef_h : ∀ e ∈ entries, ρ_hoist.store e.2.1 = none) + (h_post_src_none : ∀ (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ_src) (.terminal ρ_post) → + x ∈ sourcesOf' entries → ρ_post.store x = none) + (h_post_tgt_none : ∀ (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ_src) (.terminal ρ_post) → + x ∈ targetsOf' entries → ρ_post.store x = none) + (h_post_src_none_exit : ∀ (lbl : String) (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ_src) (.exiting lbl ρ_post) → + x ∈ sourcesOf' entries → ρ_post.store x = none) + (h_post_tgt_none_exit : ∀ (lbl : String) (ρ_post : Env P) (x : P.Ident), + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ_src) (.exiting lbl ρ_post) → + x ∈ targetsOf' entries → ρ_post.store x = none) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval : ρ_src.eval = ρ_hoist.eval) (h_hf : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ_src) cfg_src) + (h_cfg_src : (∃ ρ_src' : Env P, cfg_src = .terminal ρ_src') ∨ + (∃ lbl ρ_src', cfg_src = .exiting lbl ρ_src')) : + ∃ ρ_h', ∃ cfg_hoist : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts (havocStmts' entries ++ [.loop (.det g) none [] body₃ md]) ρ_hoist) + cfg_hoist + ∧ ((∃ ρ_src' : Env P, + cfg_src = .terminal ρ_src' ∧ cfg_hoist = .terminal ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none)) ∨ + (∃ lbl ρ_src', + cfg_src = .exiting lbl ρ_src' ∧ cfg_hoist = .exiting lbl ρ_h' ∧ + HoistInv (P := P) A B subst ρ_src'.store ρ_h'.store ∧ + ρ_src'.hasFailure = ρ_h'.hasFailure ∧ + (∀ y ∈ B, ρ_h'.store y ≠ none))) := by + classical + obtain ⟨ρ_pre, h_prelude_run, h_pre_hinv, h_pre_eval, h_pre_hf, h_pre_bnd, + h_pre_frame⟩ := + prelude_bridge_list_md_frame (A := A) entries ρ_hoist ρ_hoist rfl rfl rfl + h_src_undef_h h_tgt_undef_h h_tgt_nodup h_wfvar + -- Compose Step A (sum-typed: both outcomes) with Step B (sum-typed `BodySimSum`) + -- into a sum-typed `BodySimUSFSum`: a body run that terminates is matched by a + -- terminating hoist run, and a body run that breaks is matched by a hoist run + -- that breaks with the same label. + have composed : BodySimUSFSum (extendEval := extendEval) Q Vs Vs σ_sf + (A ++ sourcesOf' entries) (B ++ targetsOf' entries) (subst ++ substOf' entries) + body body₃ := + compose_union_sf_sum stepA stepA_exit stepB + h_subst_wf h_ss_wf h_As_notA h_As_notB h_B_notAs h_B_notBs + (fun _ hy => hy) + (fun ρ_s ρ_h h he hf hb hVh hsf => + bridge_in_guarded_undef_sf h_subst_wf h_ss_wf h_As_notA h_As_notB h_Vs_notA h_Vs_notB + h_sf_notA h_sf_notB ρ_s ρ_h h he hf hb hVh hsf) + have h_union_entry : HoistInv (P := P) + (A ++ sourcesOf' entries) (B ++ targetsOf' entries) (subst ++ substOf' entries) + ρ_src.store ρ_pre.store := + union_entry_hinv h_hinv h_pre_hinv h_subst_wf h_ss_wf h_As_notA h_As_notB + h_B_notBs h_src_As_undef h_pre_frame + have h_union_eval : ρ_src.eval = ρ_pre.eval := h_eval.trans h_pre_eval + have h_union_hf : ρ_src.hasFailure = ρ_pre.hasFailure := h_hf.trans h_pre_hf + have h_union_bnd : ∀ y ∈ B ++ targetsOf' entries, ρ_pre.store y ≠ none := by + intro y hy + rcases List.mem_append.mp hy with hyB | hyBs + · have : ρ_pre.store y = ρ_hoist.store y := h_pre_frame y (h_B_notBs y hyB) + rw [this]; exact h_bound y hyB + · exact h_pre_bnd y hyBs + -- EXPERIMENT: drop `h_g_As_fresh`; derive sourcesOf' disjointness from + -- `Vs`-undef on ρ_s + eval-def contradiction (sourcesOf' ⊆ Vs). + have h_guard_agree : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) (A ++ sourcesOf' entries) (B ++ targetsOf' entries) + (subst ++ substOf' entries) ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + (∀ x ∈ HasVarsPure.getVars g, ρ_s.store x ≠ none) → + ρ_s.eval ρ_s.store g = ρ_h.eval ρ_h.store g := by + intro ρ_s ρ_h hi he h_Vs_undef h_read_def + have h_store_agree : ∀ x ∈ HasVarsPure.getVars g, ρ_s.store x = ρ_h.store x := by + intro x hx + refine hi.1 x ?_ ?_ (h_read_def x hx) + · intro h; rcases List.mem_append.mp h with h | h + · exact h_g_A_fresh x h hx + · -- A source body-init in `Vs` is undefined at this loop head, so it + -- cannot be read by an evaluating guard (eval-def contradiction); + -- a non-`Vs` source is fresh and discharged statically. + by_cases hxVs : x ∈ Vs + · exact absurd (h_Vs_undef x hxVs) (h_read_def x hx) + · exact h_g_As_minus_Vs_fresh x h hxVs hx + · intro h; rcases List.mem_append.mp h with h | h + · exact h_g_B_fresh x h hx + · exact h_g_Bs_fresh x h hx + rw [he]; exact (h_wfcongr ρ_h) g ρ_s.store ρ_h.store h_store_agree + have h_guard_tt : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) (A ++ sourcesOf' entries) (B ++ targetsOf' entries) + (subst ++ substOf' entries) ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + ρ_s.eval ρ_s.store g = .some HasBool.tt → ρ_h.eval ρ_h.store g = .some HasBool.tt := by + intro ρ_s ρ_h hi he hVs ht + rw [← h_guard_agree ρ_s ρ_h hi he hVs (read_vars_def_of_eval (h_wfdef ρ_s) ht)]; exact ht + have h_guard_ff : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) (A ++ sourcesOf' entries) (B ++ targetsOf' entries) + (subst ++ substOf' entries) ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + ρ_s.eval ρ_s.store g = .some HasBool.ff → ρ_h.eval ρ_h.store g = .some HasBool.ff := by + intro ρ_s ρ_h hi he hVs hf + rw [← h_guard_agree ρ_s ρ_h hi he hVs (read_vars_def_of_eval (h_wfdef ρ_s) hf)]; exact hf + -- The driver's hoist env is the prelude post env `ρ_pre`; transport the + -- hoist-side `Vs`-undef seed from `ρ_hoist` to `ρ_pre` (they agree off the + -- fresh targets, and `Vs` is disjoint from the targets). + have h_entry_Vh_pre : ∀ y ∈ Vs, ρ_pre.store y = none := by + intro y hy + rw [h_pre_frame y (h_Vs_notBs y hy)]; exact h_entry_Vh y hy + -- Dispatch on the source loop outcome. Both arms run the SAME hoist residual + -- (havoc prelude ++ hoisted loop) from `ρ_hoist`; only the driver (terminal vs + -- exiting target) and the final restriction differ. + rcases h_cfg_src with ⟨ρ_post, h_cfg⟩ | ⟨lbl, ρ_post, h_cfg⟩ + · -- TERMINAL: feed the terminal driver the terminal clause of the composed sim. + subst h_cfg + have h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ_src) (.terminal ρ_post) := h_run_src + obtain ⟨ρ_post_h, h_loop_h_run, h_post_hinv, h_post_hf, h_post_bnd⟩ := + loopDet_lift_sf_undef_TE_recovers_single (g := g) (md_s := md) (md_h := md) + (A := A ++ sourcesOf' entries) (B := B ++ targetsOf' entries) + (subst := subst ++ substOf' entries) (Vs := Vs) (Vh := Vs) (σ_sf := σ_sf) + h_guard_tt h_guard_ff (fun _ _ he hwfb => he ▸ hwfb) + (bodySimUSFSum_is_driver_slot _ _ _ _ _ _ _ _ composed) + h_nofd_src h_nofd_h + h_union_entry h_union_eval h_union_hf h_union_bnd + h_entry_Vs h_entry_Vh_pre h_arm_src_sf h_run + refine ⟨ρ_post_h, .terminal ρ_post_h, ?_, ?_⟩ + · have h_pfx := stmts_prefix_terminal_append P (EvalCmd P) extendEval + (havocStmts' entries) [Stmt.loop (.det g) none [] body₃ md] ρ_hoist ρ_pre h_prelude_run + refine ReflTrans_Transitive _ _ _ _ h_pfx ?_ + refine ReflTrans.step _ _ _ .step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_loop_h_run) ?_ + exact ReflTrans.step _ _ _ .step_seq_done + (ReflTrans.step _ _ _ .step_stmts_nil (.refl _)) + · refine Or.inl ⟨ρ_post, rfl, rfl, ?_, ?_, ?_⟩ + · exact stepJ_restrict h_post_hinv + (fun x hx => h_post_src_none ρ_post x h_run hx) + (fun x hx => h_post_tgt_none ρ_post x h_run hx) + · exact h_post_hf + · intro y hy + exact h_post_bnd y (List.mem_append.mpr (Or.inl hy)) + · -- EXITING: feed the sum-typed exiting-target driver the full composed sim. + subst h_cfg + have h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ_src) (.exiting lbl ρ_post) := h_run_src + obtain ⟨ρ_post_h, h_loop_h_run, h_post_hinv, h_post_hf, h_post_bnd⟩ := + loopDet_lift_sf_undef_E_recovers_single (g := g) (md_s := md) (md_h := md) + (A := A ++ sourcesOf' entries) (B := B ++ targetsOf' entries) + (subst := subst ++ substOf' entries) (Vs := Vs) (Vh := Vs) (σ_sf := σ_sf) + h_guard_tt (fun _ _ he hwfb => he ▸ hwfb) + (bodySimUSFSum_is_driver_slot _ _ _ _ _ _ _ _ composed) + h_nofd_src h_nofd_h + h_union_entry h_union_eval h_union_hf h_union_bnd + h_entry_Vs h_entry_Vh_pre h_arm_src_sf h_run + refine ⟨ρ_post_h, .exiting lbl ρ_post_h, ?_, ?_⟩ + · have h_pfx := stmts_prefix_terminal_append P (EvalCmd P) extendEval + (havocStmts' entries) [Stmt.loop (.det g) none [] body₃ md] ρ_hoist ρ_pre h_prelude_run + refine ReflTrans_Transitive _ _ _ _ h_pfx ?_ + refine ReflTrans.step _ _ _ .step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_loop_h_run) ?_ + exact ReflTrans.step _ _ _ .step_seq_exit (.refl _) + · refine Or.inr ⟨lbl, ρ_post, rfl, rfl, ?_, ?_, ?_⟩ + · exact stepJ_restrict h_post_hinv + (fun x hx => h_post_src_none_exit lbl ρ_post x h_run hx) + (fun x hx => h_post_tgt_none_exit lbl ρ_post x h_run hx) + · exact h_post_hf + · intro y hy + exact h_post_bnd y (List.mem_append.mpr (Or.inl hy)) + +/-- The FAILING-config sibling of `loop_arm_close`: a source loop run reaching a +failing config is matched by a failing run of the hoisted residual +`havocStmts' entries ++ [loop g body₃]`. Reuses `loop_arm_close`'s prelude bridge, +terminal composed sim (`composed`, for COMPLETED iterations), and guard transports; +adds the failing composed sim (`composed_fail`, via `compose_union_fail` from the +failing Step A `stepA_fail` and failing Step B `stepB_fail`) and dispatches to the +failing-target driver `loopDet_lift_sf_2g_undef_F_fuel`. The havoc prelude never +fails, so the failure surfaces inside the hoisted loop. -/ +theorem loop_arm_close_fail [HasIdent P] [HasFvar P] [DecidableEq P.Ident] [HasVarsPure P P.Expr] [HasBool P] [HasNot P] + [HasVal P] [HasBoolVal P] [HasIntOrder P] [HasSubstFvar P] + {Q : String → Prop} + {extendEval : ExtendEval P} + {g : P.Expr} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {Vs : List P.Ident} {σ_sf : StringGenState} + {body body₁ body₃ : List (Stmt P (Cmd P))} {md : MetaData P} + {entries : List (Entry P)} + {ρ_src ρ_hoist : Env P} {a' : Config P (Cmd P)} + (stepA : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vs, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + (stepA_exit : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vs, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + (stepA_fail : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vs, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) d' + ∧ d'.getEnv.hasFailure = true) + (stepB : BodySimSum (extendEval := extendEval) + (sourcesOf' entries) (targetsOf' entries) (substOf' entries) body₁ body₃) + (stepB_fail : BodySimFail (extendEval := extendEval) + (sourcesOf' entries) (targetsOf' entries) (substOf' entries) body₁ body₃) + (h_entry_Vs : ∀ y ∈ Vs, ρ_src.store y = none) + (h_entry_Vh : ∀ y ∈ Vs, ρ_hoist.store y = none) + (h_arm_src_sf : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_src.store (HasIdent.ident (P := P) str) = none) + (h_sf_notA : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → HasIdent.ident (P := P) str ∉ A) + (h_sf_notB : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → HasIdent.ident (P := P) str ∉ B) + (h_Vs_notA : ∀ y ∈ Vs, y ∉ A) (h_Vs_notB : ∀ y ∈ Vs, y ∉ B) + (h_Vs_notBs : ∀ y ∈ Vs, y ∉ targetsOf' entries) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_ss_wf : ∀ a b, (a, b) ∈ substOf' entries → + a ∈ sourcesOf' entries ∧ b ∈ targetsOf' entries) + (h_As_notA : ∀ x ∈ sourcesOf' entries, x ∉ A) + (h_As_notB : ∀ x ∈ sourcesOf' entries, x ∉ B) + (h_B_notAs : ∀ b ∈ B, b ∉ sourcesOf' entries) + (h_B_notBs : ∀ b ∈ B, b ∉ targetsOf' entries) + (_h_Bs_notB : ∀ b ∈ targetsOf' entries, b ∉ B) + (h_g_A_fresh : ∀ x ∈ A, x ∉ HasVarsPure.getVars g) + (h_g_B_fresh : ∀ x ∈ B, x ∉ HasVarsPure.getVars g) + (h_g_As_minus_Vs_fresh : ∀ x ∈ sourcesOf' entries, x ∉ Vs → x ∉ HasVarsPure.getVars g) + (h_g_Bs_fresh : ∀ x ∈ targetsOf' entries, x ∉ HasVarsPure.getVars g) + (h_src_As_undef : ∀ a ∈ sourcesOf' entries, ρ_src.store a = none) + (h_nofd_src : Block.noFuncDecl body = true) + (h_nofd_h : Block.noFuncDecl body₃ = true) + (h_tgt_nodup : (targetsOf' entries).Nodup) + (h_src_undef_h : ∀ e ∈ entries, ρ_hoist.store e.1 = none) + (h_tgt_undef_h : ∀ e ∈ entries, ρ_hoist.store e.2.1 = none) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval : ρ_src.eval = ρ_hoist.eval) (h_hf : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run_src : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ_src) a') + (h_a'_fail : a'.getEnv.hasFailure = true) : + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmts (havocStmts' entries ++ [.loop (.det g) none [] body₃ md]) ρ_hoist) d + ∧ d.getEnv.hasFailure = true := by + classical + obtain ⟨ρ_pre, h_prelude_run, h_pre_hinv, h_pre_eval, h_pre_hf, h_pre_bnd, + h_pre_frame⟩ := + prelude_bridge_list_md_frame (A := A) entries ρ_hoist ρ_hoist rfl rfl rfl + h_src_undef_h h_tgt_undef_h h_tgt_nodup h_wfvar + -- Terminal composed sim (for the COMPLETED iterations the F driver advances). + have composed : BodySimUSFSum (extendEval := extendEval) Q Vs Vs σ_sf + (A ++ sourcesOf' entries) (B ++ targetsOf' entries) (subst ++ substOf' entries) + body body₃ := + compose_union_sf_sum stepA stepA_exit stepB + h_subst_wf h_ss_wf h_As_notA h_As_notB h_B_notAs h_B_notBs + (fun _ hy => hy) + (fun ρ_s ρ_h h he hf hb hVh hsf => + bridge_in_guarded_undef_sf h_subst_wf h_ss_wf h_As_notA h_As_notB h_Vs_notA h_Vs_notB + h_sf_notA h_sf_notB ρ_s ρ_h h he hf hb hVh hsf) + -- Failing composed sim (for the FAILING iteration). + have composed_fail := compose_union_fail (Q := Q) (Vs := Vs) (Vh := Vs) (σ_sf := σ_sf) + (Ao := A) (Bo := B) (As := sourcesOf' entries) (Bs := targetsOf' entries) + (so := subst) (ss := substOf' entries) (body := body) (body₁ := body₁) (body₃ := body₃) + stepA_fail + (fun ρ_s ρ_h hi he hf hb d hrun hd => stepB_fail ρ_s ρ_h hi he hf hb d hrun hd) + (fun _ hy => hy) + (fun ρ_s ρ_h h he hf hb hVh hsf => + bridge_in_guarded_undef_sf h_subst_wf h_ss_wf h_As_notA h_As_notB h_Vs_notA h_Vs_notB + h_sf_notA h_sf_notB ρ_s ρ_h h he hf hb hVh hsf) + have h_union_entry : HoistInv (P := P) + (A ++ sourcesOf' entries) (B ++ targetsOf' entries) (subst ++ substOf' entries) + ρ_src.store ρ_pre.store := + union_entry_hinv h_hinv h_pre_hinv h_subst_wf h_ss_wf h_As_notA h_As_notB + h_B_notBs h_src_As_undef h_pre_frame + have h_union_eval : ρ_src.eval = ρ_pre.eval := h_eval.trans h_pre_eval + have h_union_hf : ρ_src.hasFailure = ρ_pre.hasFailure := h_hf.trans h_pre_hf + have h_union_bnd : ∀ y ∈ B ++ targetsOf' entries, ρ_pre.store y ≠ none := by + intro y hy + rcases List.mem_append.mp hy with hyB | hyBs + · have : ρ_pre.store y = ρ_hoist.store y := h_pre_frame y (h_B_notBs y hyB) + rw [this]; exact h_bound y hyB + · exact h_pre_bnd y hyBs + -- guard transports (identical to `loop_arm_close`). + have h_guard_agree : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) (A ++ sourcesOf' entries) (B ++ targetsOf' entries) + (subst ++ substOf' entries) ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + (∀ x ∈ HasVarsPure.getVars g, ρ_s.store x ≠ none) → + ρ_s.eval ρ_s.store g = ρ_h.eval ρ_h.store g := by + intro ρ_s ρ_h hi he h_Vs_undef h_read_def + have h_store_agree : ∀ x ∈ HasVarsPure.getVars g, ρ_s.store x = ρ_h.store x := by + intro x hx + refine hi.1 x ?_ ?_ (h_read_def x hx) + · intro h; rcases List.mem_append.mp h with h | h + · exact h_g_A_fresh x h hx + · by_cases hxVs : x ∈ Vs + · exact absurd (h_Vs_undef x hxVs) (h_read_def x hx) + · exact h_g_As_minus_Vs_fresh x h hxVs hx + · intro h; rcases List.mem_append.mp h with h | h + · exact h_g_B_fresh x h hx + · exact h_g_Bs_fresh x h hx + rw [he]; exact (h_wfcongr ρ_h) g ρ_s.store ρ_h.store h_store_agree + have h_guard_tt : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) (A ++ sourcesOf' entries) (B ++ targetsOf' entries) + (subst ++ substOf' entries) ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + ρ_s.eval ρ_s.store g = .some HasBool.tt → ρ_h.eval ρ_h.store g = .some HasBool.tt := by + intro ρ_s ρ_h hi he hVs ht + rw [← h_guard_agree ρ_s ρ_h hi he hVs (read_vars_def_of_eval (h_wfdef ρ_s) ht)]; exact ht + have h_entry_Vh_pre : ∀ y ∈ Vs, ρ_pre.store y = none := by + intro y hy + rw [h_pre_frame y (h_Vs_notBs y hy)]; exact h_entry_Vh y hy + -- Run the failing-target driver from the prelude post env. + obtain ⟨d, h_loop_h_run, hd_fail⟩ := + loopDet_lift_sf_2g_undef_F_fuel (g_s := g) (g_h := g) + (A := A ++ sourcesOf' entries) (B := B ++ targetsOf' entries) + (subst := subst ++ substOf' entries) (Vs := Vs) (Vh := Vs) (σ_sf := σ_sf) + h_guard_tt (fun _ _ he hwfb => he ▸ hwfb) + (bodySimUSFSum_is_driver_slot _ _ _ _ _ _ _ _ composed) + composed_fail + h_nofd_src h_nofd_h + (reflTrans_to_T h_run_src).len + h_union_entry h_union_eval h_union_hf h_union_bnd + h_entry_Vs h_entry_Vh_pre h_arm_src_sf + (reflTrans_to_T h_run_src) h_a'_fail (Nat.le_refl _) + -- Prepend the (terminating) havoc prelude before the failing hoisted loop. + refine ⟨.seq d ([] : List (Stmt P (Cmd P))), ?_, by simpa [Config.getEnv] using hd_fail⟩ + have h_pfx := stmts_prefix_terminal_append P (EvalCmd P) extendEval + (havocStmts' entries) [Stmt.loop (.det g) none [] body₃ md] ρ_hoist ρ_pre h_prelude_run + refine ReflTrans_Transitive _ _ _ _ h_pfx ?_ + refine ReflTrans.step _ _ _ .step_stmts_cons ?_ + exact seq_inner_star P (EvalCmd P) extendEval _ _ _ h_loop_h_run + +end LoopInitHoistLoopArmWF +end Imperative + +end -- public section diff --git a/Strata/Transform/LoopInitHoistLoopDriver.lean b/Strata/Transform/LoopInitHoistLoopDriver.lean new file mode 100644 index 0000000000..1f25e530dd --- /dev/null +++ b/Strata/Transform/LoopInitHoistLoopDriver.lean @@ -0,0 +1,2837 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.DL.Imperative.StmtSemantics +public import Strata.DL.Imperative.CmdSemantics +public import Strata.Transform.LoopInitHoist +public import Strata.Transform.LoopInitHoistContains +public import Strata.Transform.LoopInitHoistFreshness +public import Strata.Transform.LoopInitHoistRewrite +public import Strata.Transform.LoopInitHoistInfra +public import Strata.Transform.DetToKleeneCorrect + +import all Strata.DL.Imperative.Stmt +import all Strata.DL.Imperative.Cmd +import all Strata.Transform.LoopInitHoist +import all Strata.Transform.LoopInitHoistContains +import all Strata.Transform.LoopInitHoistFreshness +import all Strata.Transform.LoopInitHoistRewrite +import all Strata.Transform.LoopInitHoistInfra +import all Strata.Transform.DetToKleeneCorrect + +public section + +/-! # Loop-init hoisting: the `.loop`-arm driver library + +This file collects the reusable lemmas that the `.loop` arm of the loop-init +hoisting equivalence proof (`Strata/Transform/LoopInitHoistCorrect.lean`) cites +to discharge a renamed nested loop. It sits upstream of the equivalence proof +(`LoopInitHoistCorrect` imports it) and depends only on the hoisting +infrastructure (`LoopInitHoistInfra`) and the determinised-loop iteration +machinery (`DetToKleeneCorrect`). + +The library has four parts: + +1. **Two-guard determinised-loop driver.** A generalisation of the + single-guard iteration lift in which the source loop guard `g_s` and the + hoist loop guard `g_h` may differ. A nested loop's guard is renamed by + `applyRenames` (`g ↦ substFvarMany g subst`), so the source runs + `.loop (.det g_s) …` while the hoist runs `.loop (.det g_h) …` with + `g_h = substFvarMany g_s subst`. The two guards need not be definitionally + equal — only to evaluate equally under `HoistInv`, which + `renamed_guard_eval_same_delta` establishes because the loop guard reads no + renamed name (every variable it reads lies in the `HoistInv` frame). + `loopDet_lift_renamedGuard_E` / `_TE` package this specialisation: the caller + supplies only the body simulation and the freshness / well-formedness side facts. + +2. **Entries-from-lift structural bridge.** Connects the concrete lift output + `Block.liftInitsInLoopBodyM ss σ` to the abstract `entries` list consumed by + the prelude bridge: it exhibits `entries` such that the lift's havocs (mapped + to `.cmd`) equal `havocStmts' entries`, the lift's renames equal + `substOf' entries`, and every entry's source ident is a body init. + +3. **Per-entry-metadata prelude bridge.** Runs the arbitrary-length havoc + prelude `havocStmts' entries` from a store-equal environment and establishes + `HoistInv A (targetsOf' entries) (substOf' entries)` together with the + evaluator / failure agreement and target-boundedness the driver consumes. + Each entry carries its own type and metadata, matching the lift output on the + nose. + +4. **Union-carrier body-simulation compose.** Composes a Step-A body + simulation at the enclosing carriers `Ao Bo so` with a Step-B body simulation + at the new inner carriers `As Bs ss` into a single body simulation at the + union carriers `(Ao ++ As) (Bo ++ Bs) (so ++ ss)`, which is exactly the + `body_sim` slot the two-guard driver consumes. +-/ + +namespace Imperative +namespace LoopInitHoistLoopDriver + +open StructuredToUnstructuredCorrect (extendStoreOne extendStoreOne_self extendStoreOne_other) + +/-- Discharge a renamed invariant-failure flag `$hif` to `false` (using the + invariant-list emptiness witness `$hiff`) and substitute it away. Captures + the identical four-line discharge the `.loop`-arm inversions repeat right + after `rename_i`. -/ +local macro "discharge_hif " hif:ident hiff:ident : tactic => + `(tactic| + (have h_hif_false : $hif = false := by + cases h_hif : $hif with + | false => rfl + | true => obtain ⟨le, hle_mem, _⟩ := ($hiff).mp h_hif; simp at hle_mem + subst h_hif_false)) + +variable {P : PureExpr} + +/-! ## Iteration peel / build helpers. + +`peelIterationDet` and `buildLoopIterationDet` are the per-iteration inversion +and construction lemmas for a determinised loop with no measure and no +invariants. They are restated here (rather than imported from the equivalence +proof) so this driver library sits strictly upstream of that proof. Both are +self-contained against the iteration machinery in `DetToKleeneCorrect` and the +store/relation helpers; they are internal to this file. -/ + +private theorem peelIterationDet [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {g : P.Expr} {inv : List (String × P.Expr)} + {body : List (Stmt P (Cmd P))} {md : MetaData P} + {ρ_pre ρ_post : Env P} {hasInvFailure : Bool} + (h_body_no_exit : ∀ (lbl : String) (ρe : Env P), + ¬ StepStmtStar P (EvalCmd P) extendEval + (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || hasInvFailure }) + (.exiting lbl ρe)) + (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ_pre.store + (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || hasInvFailure })) + [.loop (.det g) none inv body md]) + (.terminal ρ_post)) : + ∃ (ρ_inner : Env P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || hasInvFailure }) + (.terminal ρ_inner) ∧ + ∃ (h_inner_T : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (Stmt.loop (.det g) none inv body md) + { ρ_inner with store := projectStore ρ_pre.store ρ_inner.store }) + (.terminal ρ_post)), + h_inner_T.len < hrest.len := by + obtain ⟨ρ_block, h_block_term, h_loop_stmts, hlen_seq⟩ := + seqT_reaches_terminal extendEval hrest + obtain ⟨ρ_inner, h_body_term_T, h_ρ_block_eq, hlen_block⟩ := + blockT_reaches_terminal_noExit extendEval h_block_term h_body_no_exit + subst h_ρ_block_eq + obtain ⟨ρ_x, h_loop_T, h_nil, hlen_cons⟩ := + stmtsT_cons_terminal extendEval h_loop_stmts + have hρ_x_eq : ρ_x = ρ_post := by + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + subst hρ_x_eq + exact ⟨ρ_inner, reflTransT_to_prop h_body_term_T, h_loop_T, by omega⟩ + +private theorem buildLoopIterationDet [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {g : P.Expr} {body : List (Stmt P (Cmd P))} {md : MetaData P} + {ρ_pre ρ_body : Env P} + (h_guard : ρ_pre.eval ρ_pre.store g = .some HasBool.tt) + (h_wfb : WellFormedSemanticEvalBool ρ_pre.eval) + (h_body_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_pre) (.terminal ρ_body)) : + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ_pre) + (.stmts [.loop (.det g) none [] body md] + { ρ_body with store := projectStore ρ_pre.store ρ_body.store }) := by + have h_enter : StepStmt P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ_pre) + (.seq (.block .none ρ_pre.store + (.stmts body { ρ_pre with hasFailure := ρ_pre.hasFailure || false })) + [.loop (.det g) none [] body md]) := + .step_loop_enter h_guard (by intro le hle; simp at hle) (by simp) h_wfb + have h_ρpre_eq : ({ ρ_pre with hasFailure := ρ_pre.hasFailure || false } : Env P) = ρ_pre := by + simp + rw [h_ρpre_eq] at h_enter + have h_block_run : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_pre.store (.stmts body ρ_pre)) + (.terminal { ρ_body with store := projectStore ρ_pre.store ρ_body.store }) := + ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ (none : Option String) ρ_pre.store h_body_run) + (.step _ _ _ .step_block_done (.refl _)) + have h_seq_run : StepStmtStar P (EvalCmd P) extendEval + (.seq (.block .none ρ_pre.store (.stmts body ρ_pre)) + [.loop (.det g) none [] body md]) + (.stmts [.loop (.det g) none [] body md] + { ρ_body with store := projectStore ρ_pre.store ρ_body.store }) := + ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_block_run) + (.step _ _ _ .step_seq_done (.refl _)) + exact ReflTrans.step _ _ _ h_enter h_seq_run + +/-! ## Exiting-trace decompositions for determinised loops. + +These `*'`-suffixed `ReflTransT` exiting-trace decompositions invert a run that +reaches a labeled `.exiting` through a `.seq` / `.none`-block / `.stmts`-cons +context. They are restated here (rather than imported from the equivalence proof) +so this driver library sits strictly upstream of that proof, and are self-contained +against the iteration machinery in `DetToKleeneCorrect` and the store/relation +helpers. -/ + +/-- T-version of `seq_reaches_exiting` (private in SUC; re-derived here). -/ +public theorem seqT_reaches_exiting' [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' 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 + +/-- T-version: `.block .none σ inner` reaching `.exiting label`. -/ +public theorem blockT_none_reaches_exiting' [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' 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 + +/-- T-version of `stmtsT_cons` for the exiting case. -/ +public theorem stmtsT_cons_exiting' [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' 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⟩ + + + + + + + + + +/-! ## The sum-typed (terminal-OR-exiting) two-guard driver. + +This driver handles BOTH loop outcomes, with no `h_src_body_no_exit` hypothesis: a +source loop run reaching `.terminal ρ_post` OR `.exiting label ρ_post` (the loop +terminated early because some iteration's body broke) is matched by a hoist loop run +to the corresponding outcome, with `HoistInv` / `hasFailure` / `B`-boundedness at the +projected (capped) exit stores. + +The `body_sim` slot is the sum-typed `BodySimSum`: a body run that TERMINATES is +matched by a terminating hoist run, and a body run that EXITS with label `l` is +matched by a hoist run that exits with the SAME label `l`, re-establishing +`HoistInv` at the body-exit stores. The enclosing loop's `.block .none` projection +then caps both the source body-local and the hoist target away, so `HoistInv` +survives via `HoistInv.project_both` — exactly the relation the §E mutual already +carries on its `.exiting` disjunct. -/ + +/-- The sum-typed body simulation: a body run that TERMINATES is matched by a +terminating hoist run (the existing terminal clause), and a body run that EXITS +with label `l` is matched by a hoist run that exits with the SAME label `l`, +re-establishing `HoistInv` at the body-exit stores together with `hasFailure` +agreement and `B`-boundedness. This is the predicate the sum-typed two-guard +driver's `body_sim` slot consumes. -/ +public def BodySimSum [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) + (bsrc bh : List (Stmt P (Cmd P))) : Prop := + ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + -- TERMINAL clause: + (∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts bsrc ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts bh ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + ∧ + -- EXITING clause (new): + (∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts bsrc ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts bh ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + +/-- No-exit-free block-terminal inversion for a `.none`-labelled block: a `.none` +block can only reach `.terminal` via `step_block_done` from an inner `.terminal` +(an inner `.exiting` always MISMATCHES `.none` and propagates as `.exiting`, never +`.terminal`), so the inner body reached `.terminal ρ_inner` with the projected +store — WITHOUT any no-exit hypothesis. The sum-typed driver's recursive +(terminal-iteration) case uses this to recover the body's terminal run for an +intermediate iteration without ruling out body exits in general. -/ +public theorem blockT_none_reaches_terminal [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 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) _ => exact (nomatch heq) + | .step _ _ _ (.step_block_exit_mismatch _) hrest => + match hrest with + | .step _ _ _ h _ => exact nomatch h + +/-- **The sum-typed two-guard exiting-target fuel recursion.** + +The EXITING-target recursion. Takes a sum-typed `body_sim` (terminal AND exiting +clauses) and, given a source loop run reaching `.exiting label ρ_post`, produces a +hoist loop run reaching `.exiting label ρ_post_h` with `HoistInv` / `hasFailure` / +`B`-boundedness at the exit stores. + +Structure of the recursion (fuel `n` on the source run length): +* `step_loop_exit` cannot reach `.exiting` (it goes to `.terminal`) — discharged + by inverting `hrest`. +* `step_loop_enter`: the body of THIS iteration runs in `.block .none`. By + `seqT_reaches_exiting'`: + - **inl** (this iteration's block exits): `blockT_none_reaches_exiting'` gives a + body run to `.exiting label ρ_inner` with `ρ_post = {ρ_inner with store := + projectStore ρ_src.store ρ_inner.store}`. Feed the body's EXITING clause → + hoist body exits → build the hoist loop's early exit (`step_loop_enter` then + the `.none`-block mismatch + seq exit). + - **inr** (this iteration's block terminates, then the recursive loop exits): + `blockT_none_reaches_terminal` recovers the body's TERMINAL run (no no-exit + needed); feed the body's TERMINAL clause, build one hoist iteration, and + recurse via `ih` on the inner loop. -/ +public theorem loopDet_lift_2g_E_fuel [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {g_s g_h : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + (h_guard_transport : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + ρ_s.eval ρ_s.store g_s = .some HasBool.tt → ρ_h.eval ρ_h.store g_h = .some HasBool.tt) + (h_wfb_transport : ∀ (ρ_s ρ_h : Env P), + ρ_s.eval = ρ_h.eval → WellFormedSemanticEvalBool ρ_s.eval → + WellFormedSemanticEvalBool ρ_h.eval) + (body_sim : BodySimSum (extendEval := extendEval) A B subst body_src body_h) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) : + ∀ (n : Nat) {ρ_src ρ_hoist ρ_post : Env P} {label : String}, + HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store → + ρ_src.eval = ρ_hoist.eval → ρ_src.hasFailure = ρ_hoist.hasFailure → + (∀ y ∈ B, ρ_hoist.store y ≠ none) → + (h_run : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop (.det g_s) none [] body_src md_s) ρ_src) (.exiting label ρ_post)) → + h_run.len ≤ n → + ∃ ρ_post_h : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) (.exiting label ρ_post_h) ∧ + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store ∧ + ρ_post.hasFailure = ρ_post_h.hasFailure ∧ + (∀ y ∈ B, ρ_post_h.store y ≠ none) := by + intro n + induction n with + | zero => + intro ρ_src ρ_hoist ρ_post label _ _ _ _ h_run hlen + match h_run with + | .step _ _ _ _ _ => simp [ReflTransT.len] at hlen + | succ n ih => + intro ρ_src ρ_hoist ρ_post label h_hinv h_eval h_hf h_bound h_run hlen + match h_run with + | .step _ _ _ step hrest => + cases step with + | step_loop_exit ht hinv hiff hwf => + -- A `.terminal` target; `hrest : .terminal … →* .exiting …` is impossible. + match hrest with + | .step _ _ _ hd _ => exact nomatch hd + | step_loop_enter ht hinv hiff hwf => + rename_i hasInvFailure + discharge_hif hasInvFailure hiff + -- Common bodies, with the `|| false` collapse. + let ρ_src_body : Env P := { ρ_src with hasFailure := ρ_src.hasFailure || false } + let ρ_h_body : Env P := { ρ_hoist with hasFailure := ρ_hoist.hasFailure || false } + have h_hinv_body : HoistInv (P := P) A B subst ρ_src_body.store ρ_h_body.store := by + show HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store; exact h_hinv + have h_eval_body : ρ_src_body.eval = ρ_h_body.eval := h_eval + have h_hf_body : ρ_src_body.hasFailure = ρ_h_body.hasFailure := by + show (ρ_src.hasFailure || false) = (ρ_hoist.hasFailure || false); simp [h_hf] + have h_bound_body : ∀ y ∈ B, ρ_h_body.store y ≠ none := h_bound + have h_guard_h : ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.tt := + h_guard_transport ρ_src ρ_hoist h_hinv h_eval ht + have h_wfb_h : WellFormedSemanticEvalBool ρ_hoist.eval := + h_wfb_transport ρ_src ρ_hoist h_eval hwf + -- Decompose the seq run to `.exiting`: either this iteration's block exits + -- (inl), or it terminates and the recursive loop exits (inr). + rcases seqT_reaches_exiting' hrest with ⟨h_block_exit, hl⟩ | ⟨ρ₁, h_block_term, h_loop_stmts, hl⟩ + · -- inl: this iteration's body exits with `label`. + obtain ⟨ρ_inner, h_body_exit_T, h_ρpost_eq, hl2⟩ := blockT_none_reaches_exiting' h_block_exit + -- Feed the EXITING clause of the body simulation. + obtain ⟨ρ_h_inner, h_body_h_exit, h_hinv_inner, h_hf_inner, h_bound_inner⟩ := + (body_sim ρ_src_body ρ_h_body h_hinv_body h_eval_body h_hf_body h_bound_body).2 + label ρ_inner (reflTransT_to_prop h_body_exit_T) + -- Build the hoist loop's early exit: + -- .stmt loop ρ_hoist + -- → .seq (.block .none ρ_hoist.store (.stmts body_h ρ_h_body)) [loop] (step_loop_enter) + -- →* .seq (.block .none ρ_hoist.store (.exiting label ρ_h_inner)) [loop] (body run) + -- → .seq (.exiting label {ρ_h_inner with store := projectStore …}) [loop] (block mismatch) + -- → .exiting label {ρ_h_inner with store := projectStore …} (seq exit) + refine ⟨{ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store }, ?_, ?_, ?_, ?_⟩ + · refine ReflTrans.step _ _ _ + (.step_loop_enter (hasInvFailure := false) + h_guard_h (by intro le hle; simp at hle) (by simp) h_wfb_h) ?_ + -- Run the body inside the seq+block context to `.exiting`. + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ (none : Option String) ρ_hoist.store + (show StepStmtStar P (EvalCmd P) extendEval + (.stmts body_h { ρ_hoist with hasFailure := ρ_hoist.hasFailure || false }) + (.exiting label ρ_h_inner) from h_body_h_exit))) ?_ + -- `.seq (.block .none ρ_hoist.store (.exiting label ρ_h_inner)) [loop]` exits. + refine ReflTrans.step _ _ _ (.step_seq_inner (.step_block_exit_mismatch ?_)) ?_ + · exact (by simp) + · exact ReflTrans.step _ _ _ .step_seq_exit (.refl _) + · -- HoistInv at the projected exit stores: `HoistInv.project_both`. + subst h_ρpost_eq + exact HoistInv.project_both h_hinv h_hinv_inner + · -- hasFailure agreement at the projected stores (store-only projection). + subst h_ρpost_eq + show ρ_inner.hasFailure = ρ_h_inner.hasFailure; exact h_hf_inner + · -- `B`-boundedness survives the projection (parent binds `B`). + intro y hy + show projectStore ρ_hoist.store ρ_h_inner.store y ≠ none + unfold projectStore + have h_parent_some : (ρ_hoist.store y).isSome = true := by + cases h : ρ_hoist.store y with + | none => exact absurd h (h_bound y hy) + | some _ => rfl + rw [h_parent_some]; simp; exact h_bound_inner y hy + · -- inr: this iteration's body terminates; recurse on the inner loop. + obtain ⟨ρ_inner, h_body_term_T, h_ρ_block_eq, hl_blk⟩ := blockT_none_reaches_terminal h_block_term + subst h_ρ_block_eq + -- Feed the TERMINAL clause of the body simulation for this iteration. + obtain ⟨ρ_h_inner, h_body_h_run, h_hinv_inner, h_hf_inner, h_bound_inner⟩ := + (body_sim ρ_src_body ρ_h_body h_hinv_body h_eval_body h_hf_body h_bound_body).1 + ρ_inner (reflTransT_to_prop h_body_term_T) + -- Build one hoist iteration: loop → … → .stmts [loop_h] {ρ_h_inner with projected}. + have h_hoist_iter : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) + (.stmts [.loop (.det g_h) none [] body_h md_h] + { ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store }) := by + have hb : StepStmtStar P (EvalCmd P) extendEval + (.stmts body_h ρ_h_body) (.terminal ρ_h_inner) := h_body_h_run + have := buildLoopIterationDet (g := g_h) (body := body_h) (md := md_h) + (ρ_pre := ρ_h_body) (ρ_body := ρ_h_inner) ?_ ?_ hb + · simpa [ρ_h_body] using this + · show ρ_h_body.eval ρ_h_body.store g_h = .some HasBool.tt + show ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.tt; exact h_guard_h + · show WellFormedSemanticEvalBool ρ_h_body.eval + show WellFormedSemanticEvalBool ρ_hoist.eval; exact h_wfb_h + -- The inner-loop entry stores are HoistInv-related (project_both) etc. + have h_hinv_block : HoistInv (P := P) A B subst + (projectStore ρ_src.store ρ_inner.store) + (projectStore ρ_hoist.store ρ_h_inner.store) := + HoistInv.project_both h_hinv h_hinv_inner + have h_eval_block : ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).eval + = ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).eval := by + show ρ_inner.eval = ρ_h_inner.eval + have e1 : ρ_inner.eval = ρ_src_body.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body_src ρ_src_body ρ_inner h_src_body_nofd (reflTransT_to_prop h_body_term_T) + have e2 : ρ_h_inner.eval = ρ_h_body.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body_h ρ_h_body ρ_h_inner h_h_body_nofd h_body_h_run + rw [e1, e2]; exact h_eval_body + have h_hf_block : ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).hasFailure + = ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).hasFailure := by + show ρ_inner.hasFailure = ρ_h_inner.hasFailure; exact h_hf_inner + have h_bound_block : ∀ y ∈ B, + ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).store y ≠ none := by + intro y hy + show projectStore ρ_hoist.store ρ_h_inner.store y ≠ none + unfold projectStore + have h_parent_some : (ρ_hoist.store y).isSome = true := by + cases h : ρ_hoist.store y with + | none => exact absurd h (h_bound y hy) + | some _ => rfl + rw [h_parent_some]; simp; exact h_bound_inner y hy + -- The residual after the terminal block is `.stmts [loop_s] ρ_inner_proj` + -- reaching `.exiting`. Recover the inner-loop run via stmtsT_cons_exiting'. + rcases stmtsT_cons_exiting' h_loop_stmts with ⟨h_inner_loop_T, _⟩ | ⟨ρ₂, _, h_nil, _⟩ + · -- The single loop statement (the recursive loop) reaches `.exiting`; recurse. + obtain ⟨ρ_post_h, h_post_h_run, h_hinv_post, h_hf_post, h_bound_post⟩ := + ih h_hinv_block h_eval_block h_hf_block h_bound_block h_inner_loop_T + (by simp only [ReflTransT.len] at hlen; omega) + refine ⟨ρ_post_h, ?_, h_hinv_post, h_hf_post, h_bound_post⟩ + -- Splice: one hoist iteration, then the recursive hoist loop's exit. + refine ReflTrans_Transitive _ _ _ _ h_hoist_iter ?_ + refine ReflTrans.step _ _ _ .step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_post_h_run) ?_ + exact ReflTrans.step _ _ _ .step_seq_exit (.refl _) + · -- tail is `[]`, cannot reach `.exiting`. + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .step _ _ _ hd _ => exact nomatch hd + +/-- Prop-level wrapper of `loopDet_lift_2g_E_fuel`: the sum-typed exiting-target +two-guard driver. Given a source loop run reaching `.exiting label ρ_post`, +produces the matching hoist loop run reaching `.exiting label ρ_post_h`. -/ +public theorem loopDet_lift_2g_E [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {g_s g_h : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + (h_guard_transport : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + ρ_s.eval ρ_s.store g_s = .some HasBool.tt → ρ_h.eval ρ_h.store g_h = .some HasBool.tt) + (h_wfb_transport : ∀ (ρ_s ρ_h : Env P), + ρ_s.eval = ρ_h.eval → WellFormedSemanticEvalBool ρ_s.eval → + WellFormedSemanticEvalBool ρ_h.eval) + (body_sim : BodySimSum (extendEval := extendEval) A B subst body_src body_h) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) + {ρ_src ρ_hoist ρ_post : Env P} {label : String} + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval : ρ_src.eval = ρ_hoist.eval) (h_hf : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_s) none [] body_src md_s) ρ_src) (.exiting label ρ_post)) : + ∃ ρ_post_h : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) (.exiting label ρ_post_h) ∧ + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store ∧ + ρ_post.hasFailure = ρ_post_h.hasFailure ∧ + (∀ y ∈ B, ρ_post_h.store y ≠ none) := + loopDet_lift_2g_E_fuel h_guard_transport h_wfb_transport body_sim h_src_body_nofd h_h_body_nofd + (reflTrans_to_T h_run).len h_hinv h_eval h_hf h_bound (reflTrans_to_T h_run) (Nat.le_refl _) + +/-- **Undefinedness preservation for an EXITING loop run — WITHOUT a no-exit +hypothesis.** + +A loop run reaching `.exiting label ρ_post` keeps any variable `x` undefined at +the exit store provided it was undefined at loop entry. No `h_body_no_exit` is +needed: a `.none`-block iteration projects (`projectStore`) every entry undefined +at iteration entry back to `none`, so the entry-undefinedness of `x` is an +invariant across iterations, and the FINAL (exiting) iteration's `.block .none` +mismatch caps the body-exit store via the same `projectStore` (so `x` stays +`none` at the projected exit env). Mirrors `loopDet_lift_2g_E_fuel`'s exit-run +inversion, tracking a single `x`'s undefinedness instead of the simulation. -/ +public theorem loopDet_preserves_none_exiting_fuel [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {g : P.Expr} {body : List (Stmt P (Cmd P))} {md : MetaData P} + {x : P.Ident} : + ∀ (n : Nat) {ρ ρ_post : Env P} {label : String}, + ρ.store x = none → + (h_run : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop (.det g) none [] body md) ρ) (.exiting label ρ_post)) → + h_run.len ≤ n → + ρ_post.store x = none := by + intro n + induction n with + | zero => + intro ρ ρ_post label _ h_run hlen + match h_run with + | .step _ _ _ _ _ => simp [ReflTransT.len] at hlen + | succ n ih => + intro ρ ρ_post label h_none h_run hlen + match h_run with + | .step _ _ _ step hrest => + cases step with + | step_loop_exit ht hinv hiff hwf => + match hrest with + | .step _ _ _ hd _ => exact nomatch hd + | step_loop_enter ht hinv hiff hwf => + rename_i hasInvFailure + discharge_hif hasInvFailure hiff + rcases seqT_reaches_exiting' hrest with ⟨h_block_exit, _⟩ | ⟨ρ₁, h_block_term, h_loop_stmts, _⟩ + · -- inl: this iteration's body exits; `ρ_post` is the projected exit store. + obtain ⟨ρ_inner, _, h_ρpost_eq, _⟩ := blockT_none_reaches_exiting' h_block_exit + subst h_ρpost_eq + show projectStore ρ.store ρ_inner.store x = none + exact projectStore_undef_at h_none + · -- inr: this iteration's body terminates; recurse on the inner loop. + obtain ⟨ρ_inner, _, h_ρ_block_eq, _⟩ := blockT_none_reaches_terminal h_block_term + subst h_ρ_block_eq + have h_none_inner : + ({ ρ_inner with store := projectStore ρ.store ρ_inner.store } : Env P).store x = none := by + show projectStore ρ.store ρ_inner.store x = none + exact projectStore_undef_at h_none + rcases stmtsT_cons_exiting' h_loop_stmts with ⟨h_inner_loop_T, _⟩ | ⟨ρ₂, _, h_nil, _⟩ + · exact ih h_none_inner h_inner_loop_T (by simp only [ReflTransT.len] at hlen; omega) + · match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .step _ _ _ hd _ => exact nomatch hd + +/-- Prop-level corollary of `loopDet_preserves_none_exiting_fuel`. -/ +public theorem loopDet_preserves_none_exiting [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {g : P.Expr} {body : List (Stmt P (Cmd P))} {md : MetaData P} + {x : P.Ident} {ρ ρ_post : Env P} {label : String} + (h_none : ρ.store x = none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ) (.exiting label ρ_post)) : + ρ_post.store x = none := + loopDet_preserves_none_exiting_fuel (reflTrans_to_T h_run).len h_none + (reflTrans_to_T h_run) (Nat.le_refl _) + +/-- **Undefinedness preservation for a TERMINAL loop run — WITHOUT a no-exit +hypothesis.** + +The TERMINAL analogue of `loopDet_preserves_none_exiting_fuel`, taking no +`h_body_no_exit`. A loop run reaching +`.terminal ρ_post` keeps any variable `x` undefined at the exit store provided it +was undefined at loop entry. No `h_body_no_exit` is needed: the loop terminates +either by failing the guard (`step_loop_exit`, store unchanged at `x`) or by +running an iteration whose `.none`-block reaches `.terminal` +(`blockT_none_reaches_terminal`, an inner `.exiting` always mismatches `.none` and +propagates, so a `.none`-block reaching `.terminal` forces an inner `.terminal`); +each iteration projects (`projectStore`) every entry undefined at iteration entry +back to `none`, so the entry-undefinedness of `x` is an invariant across +iterations. Mirrors `loopDet_preserves_none_exiting_fuel`'s inversion, with the +`.terminal` target instead of `.exiting`. -/ +public theorem loopDet_preserves_none_terminal_fuel [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {g : P.Expr} {body : List (Stmt P (Cmd P))} {md : MetaData P} + {x : P.Ident} : + ∀ (n : Nat) {ρ ρ_post : Env P}, + ρ.store x = none → + (h_run : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop (.det g) none [] body md) ρ) (.terminal ρ_post)) → + h_run.len ≤ n → + ρ_post.store x = none := by + intro n + induction n with + | zero => + intro ρ ρ_post _ h_run hlen + match h_run with + | .step _ _ _ _ _ => simp [ReflTransT.len] at hlen + | succ n ih => + intro ρ ρ_post h_none h_run hlen + match h_run with + | .step _ _ _ step hrest => + cases step with + | step_loop_exit ht hinv hiff hwf => + rename_i hasInvFailure + have h_ρ_post_eq : ρ_post = { ρ with hasFailure := ρ.hasFailure || hasInvFailure } := by + match hrest with + | .refl _ => rfl + | .step _ _ _ hd _ => exact nomatch hd + subst h_ρ_post_eq + exact h_none + | step_loop_enter ht hinv hiff hwf => + rename_i hasInvFailure + discharge_hif hasInvFailure hiff + -- Peel one iteration WITHOUT a no-exit hypothesis: the seq decomposes to a + -- `.block .none` reaching `.terminal`, which forces an inner `.terminal`. + obtain ⟨ρ_block, h_block_term, h_loop_stmts, _⟩ := + seqT_reaches_terminal extendEval hrest + obtain ⟨ρ_inner, _, h_ρ_block_eq, _⟩ := blockT_none_reaches_terminal h_block_term + subst h_ρ_block_eq + obtain ⟨ρ_x, h_loop_T, h_nil, _⟩ := + stmtsT_cons_terminal extendEval h_loop_stmts + have hρ_x_eq : ρ_x = ρ_post := by + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + subst hρ_x_eq + have h_none_inner : + ({ ρ_inner with store := projectStore ρ.store ρ_inner.store } : Env P).store x = none := by + show projectStore ρ.store ρ_inner.store x = none + exact projectStore_undef_at h_none + exact ih h_none_inner h_loop_T (by simp only [ReflTransT.len] at hlen; omega) + +/-- Prop-level corollary of `loopDet_preserves_none_terminal_fuel`. -/ +public theorem loopDet_preserves_none_terminal [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] + {extendEval : ExtendEval P} + {g : P.Expr} {body : List (Stmt P (Cmd P))} {md : MetaData P} + {x : P.Ident} {ρ ρ_post : Env P} + (h_none : ρ.store x = none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body md) ρ) (.terminal ρ_post)) : + ρ_post.store x = none := + loopDet_preserves_none_terminal_fuel (reflTrans_to_T h_run).len h_none + (reflTrans_to_T h_run) (Nat.le_refl _) + +/-- **The sum-typed two-guard TERMINAL-target fuel recursion.** + +The TERMINAL analogue of `loopDet_lift_2g_E_fuel`: takes no `h_src_body_no_exit` +and consumes a sum-typed `body_sim` (`BodySimSum`). +A source loop run reaching `.terminal ρ_post` means NO iteration's body broke (a +body `.exit` would propagate the loop to `.exiting`, not `.terminal`); so each +peeled iteration's `.block .none` reaches `.terminal` via `blockT_none_reaches_terminal` +(which recovers the body's TERMINAL run WITHOUT a no-exit hypothesis — an inner +`.exiting` always mismatches `.none` and propagates, so a `.none`-block reaching +`.terminal` forces an inner `.terminal`). The body's TERMINAL clause then drives +one hoist iteration, and the recursion (`ih`) handles the residual loop. -/ +public theorem loopDet_lift_2g_TE_fuel [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {g_s g_h : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + (h_guard_transport : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + ρ_s.eval ρ_s.store g_s = .some HasBool.tt → ρ_h.eval ρ_h.store g_h = .some HasBool.tt) + (h_guard_transport_ff : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + ρ_s.eval ρ_s.store g_s = .some HasBool.ff → ρ_h.eval ρ_h.store g_h = .some HasBool.ff) + (h_wfb_transport : ∀ (ρ_s ρ_h : Env P), + ρ_s.eval = ρ_h.eval → WellFormedSemanticEvalBool ρ_s.eval → + WellFormedSemanticEvalBool ρ_h.eval) + (body_sim : BodySimSum (extendEval := extendEval) A B subst body_src body_h) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) : + ∀ (n : Nat) {ρ_src ρ_hoist ρ_post : Env P}, + HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store → + ρ_src.eval = ρ_hoist.eval → ρ_src.hasFailure = ρ_hoist.hasFailure → + (∀ y ∈ B, ρ_hoist.store y ≠ none) → + (h_run : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop (.det g_s) none [] body_src md_s) ρ_src) (.terminal ρ_post)) → + h_run.len ≤ n → + ∃ ρ_post_h : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) (.terminal ρ_post_h) ∧ + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store ∧ + ρ_post.hasFailure = ρ_post_h.hasFailure ∧ + (∀ y ∈ B, ρ_post_h.store y ≠ none) := by + intro n + induction n with + | zero => + intro ρ_src ρ_hoist ρ_post _ _ _ _ h_run hlen + match h_run with + | .step _ _ _ _ _ => simp [ReflTransT.len] at hlen + | succ n ih => + intro ρ_src ρ_hoist ρ_post h_hinv h_eval h_hf h_bound h_run hlen + match h_run with + | .step _ _ _ step hrest => + cases step with + | step_loop_exit ht hinv hiff hwf => + rename_i hasInvFailure + have h_hif_false : hasInvFailure = false := by + cases h_hif : hasInvFailure with + | false => rfl + | true => obtain ⟨le, hle_mem, _⟩ := hiff.mp h_hif; simp at hle_mem + have h_ρ_post_eq : ρ_post = { ρ_src with hasFailure := ρ_src.hasFailure || hasInvFailure } := by + match hrest with + | .refl _ => rfl + | .step _ _ _ hd _ => exact nomatch hd + subst h_ρ_post_eq + subst h_hif_false + have h_guard_h : ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.ff := + h_guard_transport_ff ρ_src ρ_hoist h_hinv h_eval ht + have h_wfb_h : WellFormedSemanticEvalBool ρ_hoist.eval := + h_wfb_transport ρ_src ρ_hoist h_eval hwf + refine ⟨{ ρ_hoist with hasFailure := ρ_hoist.hasFailure || false }, ?_, ?_, ?_, ?_⟩ + · exact .step _ _ _ + (.step_loop_exit h_guard_h (by intro le hle; simp at hle) (by simp) h_wfb_h) + (.refl _) + · simpa using h_hinv + · show (ρ_src.hasFailure || false) = (ρ_hoist.hasFailure || false); simp [h_hf] + · intro y hy; show ρ_hoist.store y ≠ none; exact h_bound y hy + | step_loop_enter ht hinv hiff hwf => + rename_i hasInvFailure + discharge_hif hasInvFailure hiff + -- Peel one iteration WITHOUT a no-exit hypothesis: the seq decomposes to a + -- `.block .none` reaching `.terminal`, which forces an inner `.terminal`. + obtain ⟨ρ_block, h_block_term, h_loop_stmts, hlen_seq⟩ := + seqT_reaches_terminal extendEval hrest + obtain ⟨ρ_inner, h_body_src_T, h_ρ_block_eq, hlen_block⟩ := + blockT_none_reaches_terminal h_block_term + subst h_ρ_block_eq + obtain ⟨ρ_x, h_loop_T, h_nil, hlen_cons⟩ := + stmtsT_cons_terminal extendEval h_loop_stmts + have hρ_x_eq : ρ_x = ρ_post := by + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + subst hρ_x_eq + let ρ_src_body : Env P := { ρ_src with hasFailure := ρ_src.hasFailure || false } + let ρ_h_body : Env P := { ρ_hoist with hasFailure := ρ_hoist.hasFailure || false } + have h_hinv_body : HoistInv (P := P) A B subst ρ_src_body.store ρ_h_body.store := by + show HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store; exact h_hinv + have h_eval_body : ρ_src_body.eval = ρ_h_body.eval := h_eval + have h_hf_body : ρ_src_body.hasFailure = ρ_h_body.hasFailure := by + show (ρ_src.hasFailure || false) = (ρ_hoist.hasFailure || false); simp [h_hf] + have h_bound_body : ∀ y ∈ B, ρ_h_body.store y ≠ none := h_bound + obtain ⟨ρ_h_inner, h_body_h_run, h_hinv_inner, h_hf_inner, h_bound_inner⟩ := + (body_sim ρ_src_body ρ_h_body h_hinv_body h_eval_body h_hf_body h_bound_body).1 + ρ_inner (reflTransT_to_prop h_body_src_T) + have h_guard_h : ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.tt := + h_guard_transport ρ_src ρ_hoist h_hinv h_eval ht + have h_wfb_h : WellFormedSemanticEvalBool ρ_hoist.eval := + h_wfb_transport ρ_src ρ_hoist h_eval hwf + have h_hoist_iter : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) + (.stmts [.loop (.det g_h) none [] body_h md_h] + { ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store }) := by + have hb : StepStmtStar P (EvalCmd P) extendEval + (.stmts body_h ρ_h_body) (.terminal ρ_h_inner) := h_body_h_run + have := buildLoopIterationDet (g := g_h) (body := body_h) (md := md_h) + (ρ_pre := ρ_h_body) (ρ_body := ρ_h_inner) ?_ ?_ hb + · simpa [ρ_h_body] using this + · show ρ_h_body.eval ρ_h_body.store g_h = .some HasBool.tt + show ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.tt; exact h_guard_h + · show WellFormedSemanticEvalBool ρ_h_body.eval + show WellFormedSemanticEvalBool ρ_hoist.eval; exact h_wfb_h + have h_hinv_block : HoistInv (P := P) A B subst + (projectStore ρ_src.store ρ_inner.store) + (projectStore ρ_hoist.store ρ_h_inner.store) := + HoistInv.project_both h_hinv h_hinv_inner + have h_eval_block : ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).eval + = ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).eval := by + show ρ_inner.eval = ρ_h_inner.eval + have e1 : ρ_inner.eval = ρ_src_body.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body_src ρ_src_body ρ_inner h_src_body_nofd (reflTransT_to_prop h_body_src_T) + have e2 : ρ_h_inner.eval = ρ_h_body.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body_h ρ_h_body ρ_h_inner h_h_body_nofd h_body_h_run + rw [e1, e2]; exact h_eval_body + have h_hf_block : ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).hasFailure + = ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).hasFailure := by + show ρ_inner.hasFailure = ρ_h_inner.hasFailure; exact h_hf_inner + have h_bound_block : ∀ y ∈ B, + ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).store y ≠ none := by + intro y hy + show projectStore ρ_hoist.store ρ_h_inner.store y ≠ none + unfold projectStore + have h_parent_some : (ρ_hoist.store y).isSome = true := by + cases h : ρ_hoist.store y with + | none => exact absurd h (h_bound y hy) + | some _ => rfl + rw [h_parent_some]; simp; exact h_bound_inner y hy + obtain ⟨ρ_post_h, h_post_h_run, h_hinv_post, h_hf_post, h_bound_post⟩ := + ih h_hinv_block h_eval_block h_hf_block h_bound_block h_loop_T + (by simp only [ReflTransT.len] at hlen; omega) + refine ⟨ρ_post_h, ?_, h_hinv_post, h_hf_post, h_bound_post⟩ + refine ReflTrans_Transitive _ _ _ _ h_hoist_iter ?_ + refine ReflTrans.step _ _ _ .step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_post_h_run) ?_ + exact ReflTrans.step _ _ _ .step_seq_done + (ReflTrans.step _ _ _ .step_stmts_nil (.refl _)) + +/-- Prop-level wrapper of `loopDet_lift_2g_TE_fuel`: the sum-typed two-guard +TERMINAL-target driver (consumes a `BodySimSum` body sim, concludes `.terminal`, +no `h_src_body_no_exit`). -/ +public theorem loopDet_lift_2g_TE [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {g_s g_h : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + (h_guard_transport : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + ρ_s.eval ρ_s.store g_s = .some HasBool.tt → ρ_h.eval ρ_h.store g_h = .some HasBool.tt) + (h_guard_transport_ff : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + ρ_s.eval ρ_s.store g_s = .some HasBool.ff → ρ_h.eval ρ_h.store g_h = .some HasBool.ff) + (h_wfb_transport : ∀ (ρ_s ρ_h : Env P), + ρ_s.eval = ρ_h.eval → WellFormedSemanticEvalBool ρ_s.eval → + WellFormedSemanticEvalBool ρ_h.eval) + (body_sim : BodySimSum (extendEval := extendEval) A B subst body_src body_h) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) + {ρ_src ρ_hoist ρ_post : Env P} + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval : ρ_src.eval = ρ_hoist.eval) (h_hf : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_s) none [] body_src md_s) ρ_src) (.terminal ρ_post)) : + ∃ ρ_post_h : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) (.terminal ρ_post_h) ∧ + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store ∧ + ρ_post.hasFailure = ρ_post_h.hasFailure ∧ + (∀ y ∈ B, ρ_post_h.store y ≠ none) := + loopDet_lift_2g_TE_fuel h_guard_transport h_guard_transport_ff h_wfb_transport + body_sim h_src_body_nofd h_h_body_nofd + (reflTrans_to_T h_run).len h_hinv h_eval h_hf h_bound (reflTrans_to_T h_run) (Nat.le_refl _) + +/-- **The two-guard FAILING-target fuel recursion (with store-shape-freedom +carriers).** + +The failing-config sibling of `loopDet_lift_sf_2g_undef_TE_fuel`: a source loop +run that reaches an intermediate *failing* configuration (`getEnv.hasFailure = +true`, possibly on a never-terminating loop) is matched by a hoist loop run that +reaches a failing configuration too. Inducts on a `Nat` fuel bounding the source +run length (finite by failure monotonicity); the loop is never assumed to +terminate. The `Vs`/`Vh`/`σ_sf` store-shape-freedom carriers are threaded +exactly as in the terminal driver (projected per iteration) because the COMPLETED +iterations consume the `body_sim` terminal clause, which demands them. + +* `refl` / `step_loop_exit`: the loop head env is the failing config, so + `ρ_src.hasFailure = true`; by `h_hf` the hoist loop head env is failing too and + the target loop head config (`refl`) already fails. +* `step_loop_enter`: peel one iteration. By `seqT_reaches_failing'`: + - **inl** (the failure is inside THIS iteration's body block): + `blockT_none_reaches_failing'` exposes a body run to a failing config; the + FAILING body provider `body_sim_fail` supplies a failing `body_h` run, lifted + into the hoist loop's body-block (the trailing residual loop is never reached). + - **inr** (this iteration's block terminated, then the residual loop fails): + `blockT_none_reaches_terminal` recovers the body's TERMINAL run; the body's + TERMINAL clause (`body_sim`) drives one hoist iteration, and the recursion + (`ih`) handles the residual loop at strictly smaller fuel (carriers projected). -/ +public theorem loopDet_lift_sf_2g_undef_F_fuel [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {Q : String → Prop} + {g_s g_h : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {Vs Vh : List P.Ident} {σ_sf : StringGenState} + (h_guard_transport : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + ρ_s.eval ρ_s.store g_s = .some HasBool.tt → ρ_h.eval ρ_h.store g_h = .some HasBool.tt) + (h_wfb_transport : ∀ (ρ_s ρ_h : Env P), + ρ_s.eval = ρ_h.eval → WellFormedSemanticEvalBool ρ_s.eval → + WellFormedSemanticEvalBool ρ_h.eval) + (body_sim : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + ∧ + (∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none))) + -- Failing per-iteration body simulation, used for the FAILING iteration: a + -- failing source body run is matched by a failing hoist body run (no + -- HoistInv / eval / bound re-establishment at the failing point). + (body_sim_fail : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + ∀ (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) d' + ∧ d'.getEnv.hasFailure = true) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) : + ∀ (n : Nat) {ρ_src ρ_hoist : Env P} {a' : Config P (Cmd P)}, + HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store → + ρ_src.eval = ρ_hoist.eval → ρ_src.hasFailure = ρ_hoist.hasFailure → + (∀ y ∈ B, ρ_hoist.store y ≠ none) → + (∀ y ∈ Vs, ρ_src.store y = none) → (∀ y ∈ Vh, ρ_hoist.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_src.store (HasIdent.ident (P := P) str) = none) → + (h_run : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop (.det g_s) none [] body_src md_s) ρ_src) a') → + a'.getEnv.hasFailure = true → + h_run.len ≤ n → + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) d + ∧ d.getEnv.hasFailure = true := by + intro n + induction n with + | zero => + intro ρ_src ρ_hoist a' h_hinv h_eval h_hf h_bound _ _ _ h_run h_a'_fail hlen + match h_run, hlen with + | .refl _, _ => + have : ρ_src.hasFailure = true := by simpa [Config.getEnv] using h_a'_fail + exact ⟨.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist, .refl _, + by simpa [Config.getEnv] using (h_hf ▸ this)⟩ + | .step _ _ _ _ _, hl => simp [ReflTransT.len] at hl + | succ n ih => + intro ρ_src ρ_hoist a' h_hinv h_eval h_hf h_bound h_Vs h_Vh h_src_sf h_run h_a'_fail hlen + match h_run, hlen with + | .refl _, _ => + have : ρ_src.hasFailure = true := by simpa [Config.getEnv] using h_a'_fail + exact ⟨.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist, .refl _, + by simpa [Config.getEnv] using (h_hf ▸ this)⟩ + | .step _ _ _ step hrest, hl_succ => + cases step with + | step_loop_exit ht hinv hiff hwf => + rename_i hasInvFailure + discharge_hif hasInvFailure hiff + have ha'_eq : a' = .terminal ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) := by + match hrest with + | .refl _ => rfl + | .step _ _ _ hd _ => exact nomatch hd + rw [ha'_eq] at h_a'_fail + have : ρ_src.hasFailure = true := by simpa [Config.getEnv, Bool.or_false] using h_a'_fail + exact ⟨.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist, .refl _, + by simpa [Config.getEnv] using (h_hf ▸ this)⟩ + | step_loop_enter ht hinv hiff hwf => + rename_i hasInvFailure + discharge_hif hasInvFailure hiff + have h_guard_h : ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.tt := + h_guard_transport ρ_src ρ_hoist h_hinv h_eval h_Vs ht + have h_wfb_h : WellFormedSemanticEvalBool ρ_hoist.eval := + h_wfb_transport ρ_src ρ_hoist h_eval hwf + -- The hoist enters its loop: one step to the body-block context. + have h_step_enter : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) + (.seq (.block .none ρ_hoist.store (.stmts body_h + ({ ρ_hoist with hasFailure := ρ_hoist.hasFailure || false } : Env P))) + [.loop (.det g_h) none [] body_h md_h]) := + .step _ _ _ (StepStmt.step_loop_enter (hasInvFailure := false) + h_guard_h (by intro le hle; simp at hle) (by simp) h_wfb_h) (.refl _) + rcases seqT_reaches_failing' P (EvalCmd P) extendEval hrest h_a'_fail with hA | hB + · -- CASE A: the failure is inside THIS iteration's body block. + obtain ⟨d_blk, h_blk_run, hd_blk_fail, _⟩ := hA + obtain ⟨d_body, h_body_run, hd_body_fail, _⟩ := + blockT_none_reaches_failing' P (EvalCmd P) extendEval h_blk_run hd_blk_fail + have h_body_init_eq : + ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) = ρ_src := by + simp [Bool.or_false] + rw [h_body_init_eq] at h_body_run + obtain ⟨d', h_body_tgt, hd'_fail⟩ := + body_sim_fail ρ_src ρ_hoist h_hinv h_eval h_hf h_bound h_Vs h_Vh h_src_sf d_body + (reflTransT_to_prop h_body_run) hd_body_fail + have h_body_tgt' : StepStmtStar P (EvalCmd P) extendEval + (.stmts body_h ({ ρ_hoist with hasFailure := ρ_hoist.hasFailure || false } : Env P)) d' := by + have he : ({ ρ_hoist with hasFailure := ρ_hoist.hasFailure || false } : Env P) = ρ_hoist := by + simp [Bool.or_false] + rw [he]; exact h_body_tgt + have h_blk_tgt : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_hoist.store (.stmts body_h + ({ ρ_hoist with hasFailure := ρ_hoist.hasFailure || false } : Env P))) + (.block .none ρ_hoist.store d') := + block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_hoist.store h_body_tgt' + refine ⟨.seq (.block .none ρ_hoist.store d') + [.loop (.det g_h) none [] body_h md_h], + ReflTrans_Transitive _ _ _ _ h_step_enter + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_blk_tgt), ?_⟩ + simpa [Config.getEnv] using hd'_fail + · -- CASE B: this iteration's body terminated; recurse on the next iteration. + obtain ⟨ρ_block, d_rest, h_blk_term, h_loop_rest, hd_rest_fail, hlen_rest⟩ := hB + obtain ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_none_reaches_terminal (extendEval := extendEval) h_blk_term + subst heq_ρ_block + have h_body_init_eq : + ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) = ρ_src := by + simp [Bool.or_false] + rw [h_body_init_eq] at h_inner_term + have h_body_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts body_src ρ_src) (.terminal ρ_inner) := reflTransT_to_prop h_inner_term + obtain ⟨ρ_h_inner, h_body_h_run, h_hinv_inner, h_hf_inner, h_bound_inner⟩ := + (body_sim ρ_src ρ_hoist h_hinv h_eval h_hf h_bound h_Vs h_Vh h_src_sf).1 + ρ_inner h_body_run + -- One hoist iteration: enter, run the (terminal) body block, exit the block. + have h_hoist_iter : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) + (.stmts [.loop (.det g_h) none [] body_h md_h] + { ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store }) := by + have hb : StepStmtStar P (EvalCmd P) extendEval + (.stmts body_h ρ_hoist) (.terminal ρ_h_inner) := h_body_h_run + have := buildLoopIterationDet (g := g_h) (body := body_h) (md := md_h) + (ρ_pre := ρ_hoist) (ρ_body := ρ_h_inner) h_guard_h h_wfb_h hb + exact this + -- Next-iteration projected envs (source through ρ_src, hoist through ρ_hoist). + let ρ_src_next : Env P := { ρ_inner with store := projectStore ρ_src.store ρ_inner.store } + let ρ_tgt_next : Env P := { ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } + have h_hinv_next : HoistInv (P := P) A B subst ρ_src_next.store ρ_tgt_next.store := + HoistInv.project_both h_hinv h_hinv_inner + have h_eval_inner_src : ρ_inner.eval = ρ_src.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body_src ρ_src ρ_inner h_src_body_nofd h_body_run + have h_eval_inner_h : ρ_h_inner.eval = ρ_hoist.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body_h ρ_hoist ρ_h_inner h_h_body_nofd h_body_h_run + have h_eval_next : ρ_src_next.eval = ρ_tgt_next.eval := by + show ρ_inner.eval = ρ_h_inner.eval; rw [h_eval_inner_src, h_eval_inner_h]; exact h_eval + have h_hf_next : ρ_src_next.hasFailure = ρ_tgt_next.hasFailure := by + show ρ_inner.hasFailure = ρ_h_inner.hasFailure; exact h_hf_inner + have h_bound_next : ∀ y ∈ B, ρ_tgt_next.store y ≠ none := by + intro y hy + show projectStore ρ_hoist.store ρ_h_inner.store y ≠ none + unfold projectStore + have h_parent_some : (ρ_hoist.store y).isSome = true := by + cases h : ρ_hoist.store y with + | none => exact absurd h (h_bound y hy) + | some _ => rfl + rw [h_parent_some]; simp; exact h_bound_inner y hy + have h_Vs_next : ∀ y ∈ Vs, ρ_src_next.store y = none := by + intro y hy; show projectStore ρ_src.store ρ_inner.store y = none + exact projectStore_undef_at (h_Vs y hy) + have h_Vh_next : ∀ y ∈ Vh, ρ_tgt_next.store y = none := by + intro y hy; show projectStore ρ_hoist.store ρ_h_inner.store y = none + exact projectStore_undef_at (h_Vh y hy) + have h_src_sf_next : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → + ρ_src_next.store (HasIdent.ident (P := P) str) = none := by + intro str h_suf h_notσ + show projectStore ρ_src.store ρ_inner.store (HasIdent.ident (P := P) str) = none + exact projectStore_undef_at (h_src_sf str h_suf h_notσ) + -- Decompose the residual loop-tail (`[loop]` singleton) for the IH. + obtain ⟨d_loop, h_loop_stmt, hd_loop_fail, hlen_loop⟩ := + stmts_singleton_reaches_failing' P (EvalCmd P) extendEval h_loop_rest hd_rest_fail + have h_inner_le_n : h_loop_stmt.len ≤ n := by + simp only [ReflTransT.len] at hl_succ; omega + obtain ⟨d, h_run_recurse, hd_fail⟩ := + ih h_hinv_next h_eval_next h_hf_next h_bound_next h_Vs_next h_Vh_next h_src_sf_next + h_loop_stmt hd_loop_fail h_inner_le_n + -- Lift the recursive `.stmt loop'` failing run into `.stmts [loop']`. + have h_run_recurse_stmts : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.loop (.det g_h) none [] body_h md_h] ρ_tgt_next) + (.seq d ([] : List (Stmt P (Cmd P)))) := + .step _ _ _ StepStmt.step_stmts_cons + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_run_recurse) + refine ⟨.seq d ([] : List (Stmt P (Cmd P))), + ReflTrans_Transitive _ _ _ _ h_hoist_iter h_run_recurse_stmts, ?_⟩ + simpa [Config.getEnv] using hd_fail + + +/-! ## Guard-transport companion — discharges the renamed-guard seam. + +Under `HoistInv` and guard-freshness, the source guard `g` on the source store +evaluates exactly as its renamed image `substFvarMany g subst` on the hoist +store (both via the SAME evaluator `δ`). Every read var of `g` lies outside the +rename sources/targets, so the frame component of `HoistInv` closes it. -/ +public theorem renamed_guard_eval_same_delta [HasFvar P] [HasSubstFvar P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {δ : SemanticEval P} + {g : P.Expr} {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {σ_s σ_h : SemanticStore P} + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_g_B_fresh : ∀ x ∈ B, x ∉ HasVarsPure.getVars g) + (h_hinv : HoistInv (P := P) A B subst σ_s σ_h) + (h_read_def : ∀ x ∈ HasVarsPure.getVars g, σ_s x ≠ none) + (h_wfcongr : WellFormedSemanticEvalExprCongr δ) + (h_wfsubst : WellFormedSemanticEvalSubstFvar δ) : + δ σ_s g = δ σ_h (substFvarMany g subst) := by + classical + have h_congr : δ σ_s g = δ (fun x => σ_h (renameLookup subst x)) g := by + apply h_wfcongr g σ_s (fun x => σ_h (renameLookup subst x)) + intro x hx + -- A read var `x` is either a rename SOURCE (in `subst.fst`) — handled by the + -- guarded pairing (read ⇒ defined ⇒ the pairing antecedent holds) — or it is + -- outside the rename and `A`/`B`-frame, handled by the guarded frame. No + -- source-freshness of `g` is needed: a guard var that IS a rename source is + -- exactly what the guarded pairing closes. + by_cases hx_src : x ∈ subst.map Prod.fst + · obtain ⟨⟨a, b⟩, hb_pair, hxa⟩ := List.mem_map.mp hx_src + simp only at hxa + subst a + rw [renameLookup_mem subst h_src_nodup hb_pair] + exact (h_hinv.2 x b hb_pair (h_read_def x hx)).2 + · have hx_notin_A : x ∉ A := fun hA => hx_src (h_A_subst_fst x hA) + have hx_notin_B : x ∉ B := fun hB => h_g_B_fresh x hB hx + rw [renameLookup_notin subst x hx_src] + -- Guarded frame: read var `x` is defined in `σ_s` by `h_read_def`. + exact h_hinv.1 x hx_notin_A hx_notin_B (h_read_def x hx) + rw [h_congr] + exact substFvarMany_eval_tweak δ subst h_src_nodup h_disjoint h_tgt_nodup h_wfsubst + + +/-- The SUM-TYPED (exiting-target) renamed-guard driver: a thin wrapper over the +sum-typed exiting driver +`loopDet_lift_2g_E` (the renamed-guard discharge of the guard-tt transport is +identical; the exit path never takes the false-guard branch, so no ff-transport is +needed). Consumes a sum-typed `BodySimSum` (the inner loop body may break) and a +source loop run reaching `.exiting label ρ_post`, producing the matching hoist +(renamed-guard) loop run reaching `.exiting label ρ_post_h`. -/ +public theorem loopDet_lift_renamedGuard_E [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {g : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_g_B_fresh : ∀ x ∈ B, x ∉ HasVarsPure.getVars g) + (_h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (body_sim : BodySimSum (extendEval := extendEval) A B subst body_src body_h) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) + {ρ_src ρ_hoist ρ_post : Env P} {label : String} + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval : ρ_src.eval = ρ_hoist.eval) (h_hf : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body_src md_s) ρ_src) (.exiting label ρ_post)) : + ∃ ρ_post_h : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det (substFvarMany g subst)) none [] body_h md_h) ρ_hoist) + (.exiting label ρ_post_h) ∧ + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store ∧ + ρ_post.hasFailure = ρ_post_h.hasFailure ∧ + (∀ y ∈ B, ρ_post_h.store y ≠ none) := by + refine loopDet_lift_2g_E (g_s := g) (g_h := substFvarMany g subst) + ?_ ?_ body_sim h_src_body_nofd h_h_body_nofd + h_hinv h_eval h_hf h_bound h_run + · intro ρ_s ρ_h hi he ht + have h := renamed_guard_eval_same_delta (δ := ρ_h.eval) (g := g) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup h_g_B_fresh + hi (read_vars_def_of_eval (h_wfdef ρ_h) (he ▸ ht)) (h_wfcongr ρ_h) (h_wfsubst ρ_h) + rw [← h, ← he]; exact ht + · intro ρ_s ρ_h he hwfb; exact he ▸ hwfb + +/-- The renamed-guard TERMINAL-target sum-typed driver: a thin wrapper over +`loopDet_lift_2g_TE` discharging the renamed-guard transport (the terminal companion +of `loopDet_lift_renamedGuard_E`). Consumes a sum-typed `BodySimSum` (the inner +loop body may break) but a source loop run reaching `.terminal`. -/ +public theorem loopDet_lift_renamedGuard_TE [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {g : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_g_B_fresh : ∀ x ∈ B, x ∉ HasVarsPure.getVars g) + (_h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (body_sim : BodySimSum (extendEval := extendEval) A B subst body_src body_h) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) + {ρ_src ρ_hoist ρ_post : Env P} + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval : ρ_src.eval = ρ_hoist.eval) (h_hf : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body_src md_s) ρ_src) (.terminal ρ_post)) : + ∃ ρ_post_h : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det (substFvarMany g subst)) none [] body_h md_h) ρ_hoist) + (.terminal ρ_post_h) ∧ + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store ∧ + ρ_post.hasFailure = ρ_post_h.hasFailure ∧ + (∀ y ∈ B, ρ_post_h.store y ≠ none) := by + refine loopDet_lift_2g_TE (g_s := g) (g_h := substFvarMany g subst) + ?_ ?_ ?_ body_sim h_src_body_nofd h_h_body_nofd + h_hinv h_eval h_hf h_bound h_run + · intro ρ_s ρ_h hi he ht + have h := renamed_guard_eval_same_delta (δ := ρ_h.eval) (g := g) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup h_g_B_fresh + hi (read_vars_def_of_eval (h_wfdef ρ_h) (he ▸ ht)) (h_wfcongr ρ_h) (h_wfsubst ρ_h) + rw [← h, ← he]; exact ht + · intro ρ_s ρ_h hi he hf + have h := renamed_guard_eval_same_delta (δ := ρ_h.eval) (g := g) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup h_g_B_fresh + hi (read_vars_def_of_eval (h_wfdef ρ_h) (he ▸ hf)) (h_wfcongr ρ_h) (h_wfsubst ρ_h) + rw [← h, ← he]; exact hf + · intro ρ_s ρ_h he hwfb; exact he ▸ hwfb + +/-- Prop-level wrapper of `loopDet_lift_sf_2g_undef_F_fuel` with the store-shape +carriers specialised away (`Vs = Vh = []`, `Q = ⊥`). This is the raw two-guard +FAILING-target driver: a source loop run reaching a failing config is matched by a +hoist (possibly renamed-guard) loop run reaching a failing config. The carrier +hypotheses become vacuous (no `Vs`/`Vh` members; no `Q`-kind names) so the guard +transports drop to the bare `HoistInv`-keyed form. -/ +public theorem loopDet_lift_2g_F [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {g_s g_h : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + (h_guard_transport : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + ρ_s.eval ρ_s.store g_s = .some HasBool.tt → ρ_h.eval ρ_h.store g_h = .some HasBool.tt) + (h_wfb_transport : ∀ (ρ_s ρ_h : Env P), + ρ_s.eval = ρ_h.eval → WellFormedSemanticEvalBool ρ_s.eval → + WellFormedSemanticEvalBool ρ_h.eval) + (body_sim : BodySimSum (extendEval := extendEval) A B subst body_src body_h) + (body_sim_fail : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + ∀ (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) d' + ∧ d'.getEnv.hasFailure = true) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) + {ρ_src ρ_hoist : Env P} {a' : Config P (Cmd P)} + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval : ρ_src.eval = ρ_hoist.eval) (h_hf : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_s) none [] body_src md_s) ρ_src) a') + (h_a'_fail : a'.getEnv.hasFailure = true) : + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) d + ∧ d.getEnv.hasFailure = true := + loopDet_lift_sf_2g_undef_F_fuel (Q := fun _ => False) (Vs := []) (Vh := []) + (σ_sf := StringGenState.emp) + (fun ρ_s ρ_h hi he _ ht => h_guard_transport ρ_s ρ_h hi he ht) + h_wfb_transport + (fun ρ_s ρ_h hi he hf hb _ _ _ => body_sim ρ_s ρ_h hi he hf hb) + (fun ρ_s ρ_h hi he hf hb _ _ _ d hrun hd => body_sim_fail ρ_s ρ_h hi he hf hb d hrun hd) + h_src_body_nofd h_h_body_nofd + (reflTrans_to_T h_run).len h_hinv h_eval h_hf h_bound + (by intro y hy; exact absurd hy (by simp)) (by intro y hy; exact absurd hy (by simp)) + (by intro str hQ _; exact absurd hQ (by simp)) + (reflTrans_to_T h_run) h_a'_fail (Nat.le_refl _) + +/-- The renamed-guard FAILING-target driver: a thin wrapper over `loopDet_lift_2g_F` +discharging the renamed-guard transport (the failing companion of +`loopDet_lift_renamedGuard_TE` / `_E`). A source loop run reaching a failing config +is matched by a hoist loop run (whose guard is `substFvarMany g subst`) reaching a +failing config. Consumes a sum-typed `BodySimSum` for completed iterations and a +failing body provider for the failing iteration. -/ +public theorem loopDet_lift_renamedGuard_F [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {g : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_g_B_fresh : ∀ x ∈ B, x ∉ HasVarsPure.getVars g) + (_h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (body_sim : BodySimSum (extendEval := extendEval) A B subst body_src body_h) + (body_sim_fail : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + ∀ (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) d' + ∧ d'.getEnv.hasFailure = true) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) + {ρ_src ρ_hoist : Env P} {a' : Config P (Cmd P)} + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval : ρ_src.eval = ρ_hoist.eval) (h_hf : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body_src md_s) ρ_src) a') + (h_a'_fail : a'.getEnv.hasFailure = true) : + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det (substFvarMany g subst)) none [] body_h md_h) ρ_hoist) d + ∧ d.getEnv.hasFailure = true := by + refine loopDet_lift_2g_F (g_s := g) (g_h := substFvarMany g subst) + ?_ ?_ body_sim body_sim_fail h_src_body_nofd h_h_body_nofd + h_hinv h_eval h_hf h_bound h_run h_a'_fail + · intro ρ_s ρ_h hi he ht + have h := renamed_guard_eval_same_delta (δ := ρ_h.eval) (g := g) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup h_g_B_fresh + hi (read_vars_def_of_eval (h_wfdef ρ_h) (he ▸ ht)) (h_wfcongr ρ_h) (h_wfsubst ρ_h) + rw [← h, ← he]; exact ht + · intro ρ_s ρ_h he hwfb; exact he ▸ hwfb + +/-! ## Entries-from-lift structural bridge. + +`Entry P = P.Ident × P.Ident × P.Ty × MetaData P`, `e = (y, y', ty, md)`: +* `y = e.1` — source body-local being renamed; +* `y' = e.2.1` — fresh hoist target; +* `ty = e.2.2.1` — init type carried into the havoc; +* `md = e.2.2.2` — the original init's metadata carried into the havoc. + +The lift's `.cmd (.init y ty rhs md)` arm emits a havoc `.init y' ty .nondet md` +carrying the original init's `md` (and `ty`), so each entry stores its own +`(ty, md)`. -/ + +@[expose] abbrev Entry (P : PureExpr) := P.Ident × P.Ident × P.Ty × MetaData P + +/-- Per-entry-metadata havoc statements: each entry yields its own `md`. -/ +@[expose] def havocStmts' (entries : List (Entry P)) : List (Stmt P (Cmd P)) := + entries.map (fun e => Stmt.cmd (.init e.2.1 e.2.2.1 ExprOrNondet.nondet e.2.2.2)) + +/-- Source↦fresh substitution recorded by the entries (reads only `e.1`/`e.2.1`). -/ +@[expose] def substOf' (entries : List (Entry P)) : List (P.Ident × P.Ident) := + entries.map (fun e => (e.1, e.2.1)) + +/-- Hoist target idents. -/ +@[expose] def targetsOf' (entries : List (Entry P)) : List P.Ident := + entries.map (fun e => e.2.1) + +/-- Source idents being renamed (the `y`s). -/ +@[expose] def sourcesOf' (entries : List (Entry P)) : List P.Ident := + entries.map (fun e => e.1) + +@[simp] theorem havocStmts'_nil : havocStmts' ([] : List (Entry P)) = [] := rfl +@[simp] theorem havocStmts'_cons (e : Entry P) (rest : List (Entry P)) : + havocStmts' (e :: rest) + = Stmt.cmd (.init e.2.1 e.2.2.1 ExprOrNondet.nondet e.2.2.2) + :: havocStmts' rest := rfl +@[simp] theorem substOf'_nil : substOf' ([] : List (Entry P)) = [] := rfl +@[simp] theorem substOf'_cons (e : Entry P) (rest : List (Entry P)) : + substOf' (e :: rest) = (e.1, e.2.1) :: substOf' rest := rfl +@[simp] theorem targetsOf'_nil : targetsOf' ([] : List (Entry P)) = [] := rfl +@[simp] theorem targetsOf'_cons (e : Entry P) (rest : List (Entry P)) : + targetsOf' (e :: rest) = e.2.1 :: targetsOf' rest := rfl +@[simp] theorem sourcesOf'_nil : sourcesOf' ([] : List (Entry P)) = [] := rfl +@[simp] theorem sourcesOf'_cons (e : Entry P) (rest : List (Entry P)) : + sourcesOf' (e :: rest) = e.1 :: sourcesOf' rest := rfl + +theorem havocStmts'_append (xs ys : List (Entry P)) : + havocStmts' (xs ++ ys) = havocStmts' xs ++ havocStmts' ys := by + simp [havocStmts', List.map_append] + +theorem substOf'_append (xs ys : List (Entry P)) : + substOf' (xs ++ ys) = substOf' xs ++ substOf' ys := by + simp [substOf', List.map_append] + +theorem sourcesOf'_append (xs ys : List (Entry P)) : + sourcesOf' (xs ++ ys) = sourcesOf' xs ++ sourcesOf' ys := by + simp [sourcesOf', List.map_append] + +theorem sourcesOf'_mem {entries : List (Entry P)} {e : Entry P} (he : e ∈ entries) : + e.1 ∈ sourcesOf' entries := + List.mem_map.mpr ⟨e, he, rfl⟩ + +/-! ### The harvested entries, mutual over the lift recursion. -/ + +mutual +/-- The entries harvested from a single statement's lift, threaded at `σ`. -/ +@[expose] def Stmt.entriesOf [HasIdent P] (s : Stmt P (Cmd P)) (σ : StringGenState) : + List (Entry P) := + match s with + | .cmd (.init y ty _ md) => + let (fresh, _) := StringGenState.gen hoistFreshPrefix σ + [(y, HasIdent.ident fresh, ty, md)] + | .cmd _ => [] + | .block _ bss _ => Block.entriesOf bss σ + | .ite _ tss ess _ => + Block.entriesOf tss σ ++ + Block.entriesOf ess (Block.liftInitsInLoopBodyM tss σ).2 + | .loop _ _ _ _ _ => [] + | .exit _ _ => [] + | .funcDecl _ _ => [] + | .typeDecl _ _ => [] + termination_by sizeOf s + +/-- The entries harvested from a block's lift, threaded at `σ`. -/ +@[expose] def Block.entriesOf [HasIdent P] (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + List (Entry P) := + match ss with + | [] => [] + | s :: rest => + Stmt.entriesOf s σ ++ + Block.entriesOf rest (Stmt.liftInitsInLoopBodyM s σ).2 + termination_by sizeOf ss +end + +theorem Stmt.entriesOf_block [HasIdent P] (lbl : String) (bss : List (Stmt P (Cmd P))) + (md : MetaData P) (σ : StringGenState) : + Stmt.entriesOf (.block lbl bss md) σ = Block.entriesOf bss σ := by + rw [Stmt.entriesOf] + +theorem Stmt.entriesOf_ite [HasIdent P] (g : ExprOrNondet P) (tss ess : List (Stmt P (Cmd P))) + (md : MetaData P) (σ : StringGenState) : + Stmt.entriesOf (.ite g tss ess md) σ = + Block.entriesOf tss σ ++ + Block.entriesOf ess (Block.liftInitsInLoopBodyM tss σ).2 := by + rw [Stmt.entriesOf] + +theorem Block.entriesOf_cons [HasIdent P] (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) + (σ : StringGenState) : + Block.entriesOf (s :: rest) σ = + Stmt.entriesOf s σ ++ + Block.entriesOf rest (Stmt.liftInitsInLoopBodyM s σ).2 := by + rw [Block.entriesOf] + +/-! ### Correspondence: harvest + renames = `havocStmts'` + `substOf'`. -/ + +mutual +theorem Stmt.lift_harvest_subst [HasIdent P] (s : Stmt P (Cmd P)) (σ : StringGenState) : + (Stmt.liftInitsInLoopBodyM s σ).1.1.map Stmt.cmd = havocStmts' (Stmt.entriesOf s σ) + ∧ (Stmt.liftInitsInLoopBodyM s σ).1.2.1 = substOf' (Stmt.entriesOf s σ) := by + match s with + | .cmd c => + cases c <;> + refine ⟨?_, ?_⟩ <;> + simp [Stmt.liftInitsInLoopBodyM, Stmt.entriesOf, havocStmts', substOf'] + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM, Stmt.entriesOf_block] + rcases h : Block.liftInitsInLoopBodyM bss σ with ⟨⟨hs, rn, bss'⟩, σ'⟩ + have ih := Block.lift_harvest_subst bss σ + rw [h] at ih + simp only [h] + exact ih + | .ite g tss ess md => + rw [Stmt.liftInitsInLoopBodyM, Stmt.entriesOf_ite] + rcases h₁ : Block.liftInitsInLoopBodyM tss σ with ⟨⟨ths, trn, tss'⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM ess σ₁ with ⟨⟨ehs, ern, ess'⟩, σ₂⟩ + have hσ₁ : (Block.liftInitsInLoopBodyM tss σ).2 = σ₁ := by rw [h₁] + have ih₁ := Block.lift_harvest_subst tss σ + rw [h₁] at ih₁; simp only at ih₁ + have ih₂ := Block.lift_harvest_subst ess σ₁ + rw [h₂] at ih₂; simp only at ih₂ + simp only [h₁, h₂] + refine ⟨?_, ?_⟩ + · rw [List.map_append, ih₁.1, ih₂.1, havocStmts'_append] + · rw [ih₁.2, ih₂.2, substOf'_append] + | .loop g m inv body md => + rw [Stmt.liftInitsInLoopBodyM, Stmt.entriesOf]; exact ⟨rfl, rfl⟩ + | .exit lbl md => rw [Stmt.liftInitsInLoopBodyM, Stmt.entriesOf]; exact ⟨rfl, rfl⟩ + | .funcDecl d md => rw [Stmt.liftInitsInLoopBodyM, Stmt.entriesOf]; exact ⟨rfl, rfl⟩ + | .typeDecl t md => rw [Stmt.liftInitsInLoopBodyM, Stmt.entriesOf]; exact ⟨rfl, rfl⟩ + termination_by sizeOf s + +theorem Block.lift_harvest_subst [HasIdent P] (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + (Block.liftInitsInLoopBodyM ss σ).1.1.map Stmt.cmd = havocStmts' (Block.entriesOf ss σ) + ∧ (Block.liftInitsInLoopBodyM ss σ).1.2.1 = substOf' (Block.entriesOf ss σ) := by + match ss with + | [] => rw [Block.liftInitsInLoopBodyM, Block.entriesOf]; exact ⟨rfl, rfl⟩ + | s :: rest => + rw [Block.liftInitsInLoopBodyM, Block.entriesOf_cons] + rcases h₁ : Stmt.liftInitsInLoopBodyM s σ with ⟨⟨hs_s, rn_s, ss_s⟩, σ₁⟩ + rcases h₂ : Block.liftInitsInLoopBodyM rest σ₁ with ⟨⟨hs_r, rn_r, ss_r⟩, σ₂⟩ + have hσ₁ : (Stmt.liftInitsInLoopBodyM s σ).2 = σ₁ := by rw [h₁] + have ih₁ := Stmt.lift_harvest_subst s σ + rw [h₁] at ih₁; simp only at ih₁ + have ih₂ := Block.lift_harvest_subst rest σ₁ + rw [h₂] at ih₂; simp only at ih₂ + simp only [h₁, h₂] + refine ⟨?_, ?_⟩ + · rw [List.map_append, ih₁.1, ih₂.1, havocStmts'_append] + · rw [ih₁.2, ih₂.2, substOf'_append] + termination_by sizeOf ss +end + +/-! ### The `e.1 ∈ initVars` invariant. + +Every harvested entry's source ident `e.1` lies in the input's `initVars`. This +is a subset (not equality): `entriesOf` harvests inits reachable through +`.block`/`.ite` only, not through nested `.loop` (which the lift passes through), +whereas `Block.initVars` also descends into `.loop` bodies. Since `entriesOf` +skips loops and loops only add to `initVars`, the harvest sources are a subset of +`initVars` unconditionally. -/ + +mutual +theorem Stmt.sourcesOf_entriesOf_subset [HasIdent P] (s : Stmt P (Cmd P)) (σ : StringGenState) : + ∀ x ∈ sourcesOf' (Stmt.entriesOf s σ), x ∈ Stmt.initVars s := by + match s with + | .cmd c => + cases c <;> + simp [Stmt.entriesOf, Stmt.initVars, sourcesOf'] + | .block lbl bss md => + intro x hx + rw [Stmt.entriesOf_block] at hx + rw [Stmt.initVars_block] + exact Block.sourcesOf_entriesOf_subset bss σ x hx + | .ite g tss ess md => + intro x hx + rw [Stmt.entriesOf_ite, sourcesOf'_append, List.mem_append] at hx + rw [Stmt.initVars_ite, List.mem_append] + rcases hx with h | h + · exact Or.inl (Block.sourcesOf_entriesOf_subset tss σ x h) + · exact Or.inr (Block.sourcesOf_entriesOf_subset ess _ x h) + | .loop g m inv body md => + simp [Stmt.entriesOf, sourcesOf'] + | .exit lbl md => simp [Stmt.entriesOf, sourcesOf'] + | .funcDecl d md => simp [Stmt.entriesOf, sourcesOf'] + | .typeDecl t md => simp [Stmt.entriesOf, sourcesOf'] + termination_by sizeOf s + +theorem Block.sourcesOf_entriesOf_subset [HasIdent P] (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + ∀ x ∈ sourcesOf' (Block.entriesOf ss σ), x ∈ Block.initVars ss := by + match ss with + | [] => simp [Block.entriesOf, sourcesOf'] + | s :: rest => + intro x hx + rw [Block.entriesOf_cons, sourcesOf'_append, List.mem_append] at hx + rw [Block.initVars_cons, List.mem_append] + rcases hx with h | h + · exact Or.inl (Stmt.sourcesOf_entriesOf_subset s σ x h) + · exact Or.inr (Block.sourcesOf_entriesOf_subset rest _ x h) + termination_by sizeOf ss +end + +/-- Membership form: every entry's source ident is in the block's `initVars`. -/ +theorem Block.entry_source_mem_initVars [HasIdent P] (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + {e : Entry P} (he : e ∈ Block.entriesOf ss σ) : + e.1 ∈ Block.initVars ss := + Block.sourcesOf_entriesOf_subset ss σ e.1 (sourcesOf'_mem he) + +/-- The top-level entries-from-lift bridge (block-level): from a body `ss` lifted +at `σ`, exhibit `entries` such that the lift's havocs (mapped to `.cmd`) equal +`havocStmts' entries`, the lift's renames equal `substOf' entries`, and every +entry's source ident is a body init. -/ +public theorem entries_from_lift [HasIdent P] (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + ∃ entries : List (Entry P), + let r := Block.liftInitsInLoopBodyM ss σ + r.1.1.map Stmt.cmd = havocStmts' entries + ∧ r.1.2.1 = substOf' entries + ∧ (∀ e ∈ entries, e.1 ∈ Block.initVars ss) := by + refine ⟨Block.entriesOf ss σ, ?_, ?_, ?_⟩ + · exact (Block.lift_harvest_subst ss σ).1 + · exact (Block.lift_harvest_subst ss σ).2 + · intro e he; exact Block.entry_source_mem_initVars ss σ he + +/-! ## Per-entry-metadata prelude bridge. + +`havocStmts'`/`substOf'`/`targetsOf'` read only `e.1`/`e.2.1`. We add the +`extendStoreMany` bindings the run lands at — `(y', mkFvar y')` per entry. -/ + +@[expose] def bindingsOf' [HasFvar P] (entries : List (Entry P)) : + List (P.Ident × P.Expr) := + entries.map (fun e => (e.2.1, HasFvar.mkFvar e.2.1)) + +@[simp] theorem bindingsOf'_nil [HasFvar P] : + bindingsOf' ([] : List (Entry P)) = [] := rfl + +@[simp] theorem bindingsOf'_cons [HasFvar P] (e : Entry P) (rest : List (Entry P)) : + bindingsOf' (e :: rest) + = (e.2.1, HasFvar.mkFvar e.2.1) :: bindingsOf' rest := rfl + +/-- `targetsOf' entries = (substOf' entries).map Prod.snd`. -/ +theorem targetsOf'_eq_substOf'_snd (entries : List (Entry P)) : + targetsOf' entries = (substOf' entries).map Prod.snd := by + induction entries with + | nil => rfl + | cons e rest ih => simp [ih] + +/-- Outside the targets, `extendStoreMany σ (bindingsOf' entries)` agrees with `σ`. -/ +theorem extendStoreMany_bindingsOf'_outside [HasFvar P] [DecidableEq P.Ident] + (σ : SemanticStore P) (entries : List (Entry P)) + {x : P.Ident} (hx : x ∉ targetsOf' entries) : + extendStoreMany σ (bindingsOf' entries) x = σ x := by + induction entries generalizing σ with + | nil => rfl + | cons e rest ih => + simp only [targetsOf'_cons, List.mem_cons, not_or] at hx + rw [bindingsOf'_cons, extendStoreMany_cons, ih _ hx.2] + exact extendStoreOne_other σ e.2.1 (HasFvar.mkFvar e.2.1) x hx.1 + +/-- At a target (with `Nodup` targets), `extendStoreMany σ (bindingsOf' entries)` +is defined. -/ +theorem extendStoreMany_bindingsOf'_bound [HasFvar P] [DecidableEq P.Ident] + (σ : SemanticStore P) (entries : List (Entry P)) + (h_nodup : (targetsOf' entries).Nodup) + {b : P.Ident} (hb : b ∈ targetsOf' entries) : + extendStoreMany σ (bindingsOf' entries) b ≠ none := by + induction entries generalizing σ with + | nil => simp only [targetsOf'_nil, List.not_mem_nil] at hb + | cons e rest ih => + simp only [targetsOf'_cons, List.mem_cons] at hb + simp only [targetsOf'_cons, List.nodup_cons] at h_nodup + rw [bindingsOf'_cons, extendStoreMany_cons] + rcases hb with h | h + · subst h + have h_notin : e.2.1 ∉ targetsOf' rest := h_nodup.1 + rw [extendStoreMany_bindingsOf'_outside _ rest h_notin, extendStoreOne_self] + exact Option.some_ne_none _ + · exact ih _ h_nodup.2 h + +/-- The prelude run reaches the `extendStoreMany` post-store. Each head +`.init e.2.1 e.2.2.1 .nondet e.2.2.2` steps by +`StepStmt.step_cmd (EvalCmd.eval_init_unconstrained (InitState.init ...))`, +choosing witness `mkFvar e.2.1`, which is exactly +`extendStoreOne σ e.2.1 (mkFvar e.2.1)`. -/ +theorem prelude_run_list_md [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + (entries : List (Entry P)) + (ρ_hoist : Env P) + (h_targets_undef : ∀ e ∈ entries, ρ_hoist.store e.2.1 = none) + (h_targets_nodup : (targetsOf' entries).Nodup) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) : + StepStmtStar P (EvalCmd P) extendEval + (.stmts (havocStmts' entries) ρ_hoist) + (.terminal + { ρ_hoist with + store := extendStoreMany ρ_hoist.store (bindingsOf' entries) + hasFailure := ρ_hoist.hasFailure }) := by + induction entries generalizing ρ_hoist with + | nil => + simp only [havocStmts'_nil, bindingsOf'_nil, extendStoreMany_nil] + have h_env : ({ ρ_hoist with store := ρ_hoist.store, hasFailure := ρ_hoist.hasFailure } : Env P) = ρ_hoist := rfl + rw [h_env] + exact ReflTrans.step _ _ _ StepStmt.step_stmts_nil (ReflTrans.refl _) + | cons e rest ih => + rcases e with ⟨y, y', ty, md⟩ + let v : P.Expr := HasFvar.mkFvar y' + let σ1 : SemanticStore P := extendStoreOne ρ_hoist.store y' v + let ρ1 : Env P := { ρ_hoist with store := σ1, hasFailure := ρ_hoist.hasFailure || false } + have h_y'_undef : ρ_hoist.store y' = none := + h_targets_undef (y, y', ty, md) List.mem_cons_self + have h_is : InitState P ρ_hoist.store y' v σ1 := + InitState.init h_y'_undef (extendStoreOne_self ρ_hoist.store y' v) + (fun z hz => extendStoreOne_other ρ_hoist.store y' v z (fun h => hz h.symm)) + have h_step : StepStmt P (EvalCmd P) extendEval + (.stmt (.cmd (Cmd.init y' ty ExprOrNondet.nondet md)) ρ_hoist) + (.terminal ρ1) := + StepStmt.step_cmd (EvalCmd.eval_init_unconstrained h_is (h_wfvar ρ_hoist)) + have h_nodup_tl : (targetsOf' rest).Nodup := by + simp only [targetsOf'_cons, List.nodup_cons] at h_targets_nodup + exact h_targets_nodup.2 + have h_y'_notin_tl : y' ∉ targetsOf' rest := by + simp only [targetsOf'_cons, List.nodup_cons] at h_targets_nodup + exact h_targets_nodup.1 + have h_targets_undef_tl : ∀ e ∈ rest, ρ1.store e.2.1 = none := by + intro e' he' + have h_e'_in_tgts : e'.2.1 ∈ targetsOf' rest := + List.mem_map.mpr ⟨e', he', rfl⟩ + have h_ne : e'.2.1 ≠ y' := by + intro h; apply h_y'_notin_tl; rw [← h]; exact h_e'_in_tgts + show (if e'.2.1 = y' then some v else ρ_hoist.store e'.2.1) = none + rw [if_neg h_ne] + exact h_targets_undef e' (List.mem_cons_of_mem _ he') + have h_run_tl := ih ρ1 h_targets_undef_tl h_nodup_tl + simp only [havocStmts'_cons] + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans.step _ _ _ (StepStmt.step_seq_inner h_step) ?_ + refine ReflTrans.step _ _ _ StepStmt.step_seq_done ?_ + have h_run_tl' : + StepStmtStar P (EvalCmd P) extendEval + (.stmts (havocStmts' rest) ρ1) + (.terminal + { ρ_hoist with + store := extendStoreMany ρ_hoist.store (bindingsOf' ((y, y', ty, md) :: rest)), + hasFailure := ρ_hoist.hasFailure }) := by + have h_eq : + ({ ρ_hoist with + store := extendStoreMany ρ_hoist.store (bindingsOf' ((y, y', ty, md) :: rest)), + hasFailure := ρ_hoist.hasFailure } : Env P) + = { store := extendStoreMany ρ1.store (bindingsOf' rest), eval := ρ1.eval, + hasFailure := ρ1.hasFailure } := by + show (_ : Env P) = _ + rw [bindingsOf'_cons, extendStoreMany_cons] + show (_ : Env P) = _ + simp only [ρ1, σ1, v, Bool.or_false] + rw [h_eq]; exact h_run_tl + exact h_run_tl' + +/-- Frame-exposing prelude bridge. Runs `havocStmts' entries` from a +store-equal env and establishes `HoistInv A (targetsOf' entries) (substOf' +entries)` together with the evaluator / failure agreement and +target-boundedness, and ALSO returns the unguarded off-targets agreement +`ρ_pre = ρ_run off targetsOf' entries`. The §E `.loop` arm's union-entry +`HoistInv` builder needs this agreement (it lives outside the guarded +`HoistInv` frame, holding even on `A`), so the prelude's structural havoc-frame +is surfaced explicitly. -/ +public theorem prelude_bridge_list_md_frame [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + (A : List P.Ident) + (entries : List (Entry P)) + (ρ_src ρ_run : Env P) + (h_store_eq : ρ_run.store = ρ_src.store) + (h_eval_eq : ρ_run.eval = ρ_src.eval) + (h_hf_eq : ρ_run.hasFailure = ρ_src.hasFailure) + (h_src_undef : ∀ e ∈ entries, ρ_src.store e.1 = none) + (h_tgt_undef : ∀ e ∈ entries, ρ_src.store e.2.1 = none) + (h_tgt_nodup : (targetsOf' entries).Nodup) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) : + ∃ ρ_pre : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmts (havocStmts' entries) ρ_run) + (.terminal ρ_pre) + ∧ HoistInv (P := P) A (targetsOf' entries) (substOf' entries) + ρ_src.store ρ_pre.store + ∧ ρ_src.eval = ρ_pre.eval + ∧ ρ_src.hasFailure = ρ_pre.hasFailure + ∧ (∀ b ∈ targetsOf' entries, ρ_pre.store b ≠ none) + ∧ (∀ x, x ∉ targetsOf' entries → ρ_pre.store x = ρ_run.store x) := by + have h_tgt_undef_h : ∀ e ∈ entries, ρ_run.store e.2.1 = none := by + intro e he; rw [h_store_eq]; exact h_tgt_undef e he + have h_run := prelude_run_list_md (extendEval := extendEval) + entries ρ_run h_tgt_undef_h h_tgt_nodup h_wfvar + -- `prelude_run_list_md` pins the run output to the concrete extend-store env; + -- rebuild the HoistInv + agreements directly against that concrete env. + refine ⟨{ ρ_run with + store := extendStoreMany ρ_run.store (bindingsOf' entries) + hasFailure := ρ_run.hasFailure }, h_run, ?_, ?_, ?_, ?_, ?_⟩ + · -- HoistInv A (targets) (substOf'E) ρ_src ρ_pre at the concrete env. + have h_seed : HoistInv (P := P) A [] [] ρ_src.store ρ_run.store := by + refine ⟨?_, ?_⟩ + · intro x _ _ _; rw [h_store_eq] + · intro a b h_pair _; simp at h_pair + have h_new_src_undef : + ∀ a ∈ (substOf' entries).map Prod.fst, ρ_src.store a = none := by + intro a ha + rcases List.mem_map.mp ha with ⟨p, hp_mem, hp_eq⟩ + rcases List.mem_map.mp hp_mem with ⟨e, he, he_eq⟩ + subst he_eq; subst hp_eq; exact h_src_undef e he + have h_extend : ∀ x, x ∉ targetsOf' entries → + (extendStoreMany ρ_run.store (bindingsOf' entries)) x = ρ_run.store x := by + intro x hx; exact extendStoreMany_bindingsOf'_outside ρ_run.store entries hx + have h_inv := + HoistInv.add_vacuous_pairs (P := P) (A := A) (B := []) (B_new := targetsOf' entries) + (subst := []) (subst_new := substOf' entries) + (σ_src := ρ_src.store) (σ_h := ρ_run.store) + (σ_h' := extendStoreMany ρ_run.store (bindingsOf' entries)) + h_new_src_undef + (by intro b hb; simp at hb) + h_extend + (by intro b hb; simp at hb) + h_seed + simpa using h_inv + · show ρ_src.eval = ρ_run.eval; exact h_eval_eq.symm + · show ρ_src.hasFailure = ρ_run.hasFailure; exact h_hf_eq.symm + · intro b hb + show extendStoreMany ρ_run.store (bindingsOf' entries) b ≠ none + exact extendStoreMany_bindingsOf'_bound ρ_run.store entries h_tgt_nodup hb + · intro x hx + show extendStoreMany ρ_run.store (bindingsOf' entries) x = ρ_run.store x + exact extendStoreMany_bindingsOf'_outside ρ_run.store entries hx + + + +/-- List-generalised HoistInv union bridge: Step A at the enclosing carriers +`Ao Bo so` composed with Step B at the new carriers `As Bs ss` yields `HoistInv` +at the union carriers, from disjointness facts. -/ +public theorem bridge_out_union_list + {Ao Bo As Bs : List P.Ident} + {so ss : List (P.Ident × P.Ident)} + {ρ_s' ρ₁' ρ_h' : Env P} + (hA : HoistInv (P := P) Ao Bo so ρ_s'.store ρ₁'.store) + (hB : HoistInv (P := P) As Bs ss ρ₁'.store ρ_h'.store) + (h_so_wf : ∀ a b, (a, b) ∈ so → a ∈ Ao ∧ b ∈ Bo) + (h_ss_wf : ∀ a b, (a, b) ∈ ss → a ∈ As ∧ b ∈ Bs) + (h_As_notAo : ∀ x ∈ As, x ∉ Ao) (h_As_notBo : ∀ x ∈ As, x ∉ Bo) + (h_Bo_notAs : ∀ b ∈ Bo, b ∉ As) (h_Bo_notBs : ∀ b ∈ Bo, b ∉ Bs) : + HoistInv (P := P) (Ao ++ As) (Bo ++ Bs) (so ++ ss) ρ_s'.store ρ_h'.store := by + refine ⟨?_, ?_⟩ + · intro x hxA hxB h_x_ne + have hxAo : x ∉ Ao := fun h => hxA (List.mem_append.mpr (Or.inl h)) + have hxAs : x ∉ As := fun h => hxA (List.mem_append.mpr (Or.inr h)) + have hxBo : x ∉ Bo := fun h => hxB (List.mem_append.mpr (Or.inl h)) + have hxBs : x ∉ Bs := fun h => hxB (List.mem_append.mpr (Or.inr h)) + have e1 : ρ_s'.store x = ρ₁'.store x := hA.1 x hxAo hxBo h_x_ne + have e2 : ρ₁'.store x = ρ_h'.store x := hB.1 x hxAs hxBs (e1 ▸ h_x_ne) + rw [e1, e2] + · intro a b h_pair h_ne + rcases List.mem_append.mp h_pair with h_so | h_ss + · obtain ⟨h_b_ne₁, h_eq₁⟩ := hA.2 a b h_so h_ne + have h_b_in_Bo : b ∈ Bo := (h_so_wf a b h_so).2 + have h_b_notAs : b ∉ As := h_Bo_notAs b h_b_in_Bo + have h_b_notBs : b ∉ Bs := h_Bo_notBs b h_b_in_Bo + have h_b_move : ρ₁'.store b = ρ_h'.store b := hB.1 b h_b_notAs h_b_notBs h_b_ne₁ + exact ⟨h_b_move ▸ h_b_ne₁, by rw [h_eq₁, h_b_move]⟩ + · have h_a_in_As : a ∈ As := (h_ss_wf a b h_ss).1 + have h_a_notAo : a ∉ Ao := h_As_notAo a h_a_in_As + have h_a_notBo : a ∉ Bo := h_As_notBo a h_a_in_As + have h_ya : ρ_s'.store a = ρ₁'.store a := hA.1 a h_a_notAo h_a_notBo h_ne + have h_ne₁ : ρ₁'.store a ≠ none := h_ya ▸ h_ne + obtain ⟨h_b_ne, h_eq⟩ := hB.2 a b h_ss h_ne₁ + exact ⟨h_b_ne, by rw [h_ya]; exact h_eq⟩ + +/-- The composed body simulation must re-establish `Bo`-boundedness at `ρ_h'`. +Step A gives it at the mid env `ρ₁'`; Step B's frame transports it to `ρ_h'` +since `Bo` is disjoint from the new carriers. -/ +public theorem bound_Bo_through_stepB + {Bo As Bs : List P.Ident} {ss : List (P.Ident × P.Ident)} + {ρ₁' ρ_h' : Env P} + (hB : HoistInv (P := P) As Bs ss ρ₁'.store ρ_h'.store) + (h_bnd₁_Bo : ∀ y ∈ Bo, ρ₁'.store y ≠ none) + (h_Bo_notAs : ∀ b ∈ Bo, b ∉ As) (h_Bo_notBs : ∀ b ∈ Bo, b ∉ Bs) : + ∀ y ∈ Bo, ρ_h'.store y ≠ none := by + intro y hy + have h_move : ρ₁'.store y = ρ_h'.store y := + hB.1 y (h_Bo_notAs y hy) (h_Bo_notBs y hy) (h_bnd₁_Bo y hy) + exact h_move ▸ h_bnd₁_Bo y hy + + + + + + + + + + +/-- `bridge_in_guarded_undef` augmented with a `σ_sf`-relative HOIST-side +store-kind-freedom conjunct on the mid env `ρ₁`. Because `ρ₁ = ρ_s` off the +enclosing carriers `Ao ∪ Bo`, and a `Q`-kind name `∉ σ_sf` avoids those carriers +(`h_sf_notAo` / `h_sf_notBo`), `ρ₁` agrees with `ρ_s` on every such name, so the +SOURCE kind-freedom (`h_src_sf`) transports to `ρ₁`. -/ +public theorem bridge_in_guarded_undef_sf [HasIdent P] [DecidableEq P.Ident] + {Q : String → Prop} + {Vh : List P.Ident} {σ_sf : StringGenState} + {Ao Bo As Bs : List P.Ident} {so ss : List (P.Ident × P.Ident)} + (h_so_wf : ∀ a b, (a, b) ∈ so → a ∈ Ao ∧ b ∈ Bo) + (h_ss_wf : ∀ a b, (a, b) ∈ ss → a ∈ As ∧ b ∈ Bs) + (h_As_notAo : ∀ x ∈ As, x ∉ Ao) (h_As_notBo : ∀ x ∈ As, x ∉ Bo) + (h_Vh_notAo : ∀ y ∈ Vh, y ∉ Ao) (h_Vh_notBo : ∀ y ∈ Vh, y ∉ Bo) + (h_sf_notAo : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → HasIdent.ident (P := P) str ∉ Ao) + (h_sf_notBo : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → HasIdent.ident (P := P) str ∉ Bo) + (ρ_s ρ_h : Env P) + (h_hinv : HoistInv (P := P) (Ao ++ As) (Bo ++ Bs) (so ++ ss) ρ_s.store ρ_h.store) + (h_eval : ρ_s.eval = ρ_h.eval) (h_hf : ρ_s.hasFailure = ρ_h.hasFailure) + (h_bnd : ∀ y ∈ Bo ++ Bs, ρ_h.store y ≠ none) + (h_Vh_src : ∀ y ∈ Vh, ρ_s.store y = none) + (h_src_sf : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) : + ∃ ρ₁ : Env P, + HoistInv (P := P) Ao Bo so ρ_s.store ρ₁.store ∧ + ρ_s.eval = ρ₁.eval ∧ ρ_s.hasFailure = ρ₁.hasFailure ∧ + (∀ y ∈ Bo, ρ₁.store y ≠ none) ∧ + (∀ y ∈ Vh, ρ₁.store y = none) ∧ + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ₁.store (HasIdent.ident (P := P) str) = none) ∧ + HoistInv (P := P) As Bs ss ρ₁.store ρ_h.store ∧ + ρ₁.eval = ρ_h.eval ∧ ρ₁.hasFailure = ρ_h.hasFailure ∧ + (∀ y ∈ Bs, ρ_h.store y ≠ none) := by + classical + let σ₁ : SemanticStore P := fun x => if x ∈ Ao ∨ x ∈ Bo then ρ_h.store x else ρ_s.store x + let ρ₁ : Env P := { store := σ₁, eval := ρ_h.eval, hasFailure := ρ_h.hasFailure } + have hσ_in : ∀ x, x ∈ Ao ∨ x ∈ Bo → σ₁ x = ρ_h.store x := by + intro x hx; show (if x ∈ Ao ∨ x ∈ Bo then _ else _) = _; rw [if_pos hx] + have hσ_out : ∀ x, x ∉ Ao → x ∉ Bo → σ₁ x = ρ_s.store x := by + intro x hA hB; show (if x ∈ Ao ∨ x ∈ Bo then _ else _) = _ + rw [if_neg (not_or.mpr ⟨hA, hB⟩)] + refine ⟨ρ₁, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · refine ⟨?_, ?_⟩ + · intro x hxAo hxBo _; show ρ_s.store x = σ₁ x; rw [hσ_out x hxAo hxBo] + · intro a b h_pair h_ne + obtain ⟨ha_Ao, hb_Bo⟩ := h_so_wf a b h_pair + obtain ⟨h_b_ne, h_eq⟩ := h_hinv.2 a b (List.mem_append.mpr (Or.inl h_pair)) h_ne + have hσ : σ₁ b = ρ_h.store b := hσ_in b (Or.inr hb_Bo) + exact ⟨by show σ₁ b ≠ none; rw [hσ]; exact h_b_ne, + by show ρ_s.store a = σ₁ b; rw [hσ]; exact h_eq⟩ + · exact h_eval + · exact h_hf + · intro y hy + show σ₁ y ≠ none + rw [hσ_in y (Or.inr hy)]; exact h_bnd y (List.mem_append.mpr (Or.inl hy)) + · intro y hy + show σ₁ y = none + rw [hσ_out y (h_Vh_notAo y hy) (h_Vh_notBo y hy)]; exact h_Vh_src y hy + · -- the new HOIST-side shape-freedom conjunct on `ρ₁`. + intro str h_suf h_notσ + show σ₁ (HasIdent.ident (P := P) str) = none + rw [hσ_out (HasIdent.ident (P := P) str) + (h_sf_notAo str h_suf h_notσ) (h_sf_notBo str h_suf h_notσ)] + exact h_src_sf str h_suf h_notσ + · refine ⟨?_, ?_⟩ + · intro x hxAs hxBs h_x_ne + show σ₁ x = ρ_h.store x + by_cases hAB : x ∈ Ao ∨ x ∈ Bo + · rw [hσ_in x hAB] + · have hxAo : x ∉ Ao := fun h => hAB (Or.inl h) + have hxBo : x ∉ Bo := fun h => hAB (Or.inr h) + have hσx : σ₁ x = ρ_s.store x := hσ_out x hxAo hxBo + have hxAoAs : x ∉ Ao ++ As := by + intro h; rcases List.mem_append.mp h with h | h + · exact hxAo h + · exact hxAs h + have hxBoBs : x ∉ Bo ++ Bs := by + intro h; rcases List.mem_append.mp h with h | h + · exact hxBo h + · exact hxBs h + have h_s_ne : ρ_s.store x ≠ none := hσx ▸ h_x_ne + rw [hσx]; exact h_hinv.1 x hxAoAs hxBoBs h_s_ne + · intro a b h_pair h_ne + obtain ⟨ha_As, hb_Bs⟩ := h_ss_wf a b h_pair + have ha_notAo : a ∉ Ao := h_As_notAo a ha_As + have ha_notBo : a ∉ Bo := h_As_notBo a ha_As + have hσa : σ₁ a = ρ_s.store a := hσ_out a ha_notAo ha_notBo + have h_s_ne : ρ_s.store a ≠ none := hσa ▸ h_ne + obtain ⟨h_b_ne, h_eq⟩ := h_hinv.2 a b (List.mem_append.mpr (Or.inr h_pair)) h_s_ne + refine ⟨h_b_ne, ?_⟩ + show σ₁ a = ρ_h.store b + rw [hσa]; exact h_eq + · rfl + · rfl + · intro y hy; exact h_bnd y (List.mem_append.mpr (Or.inr hy)) + + + + +/-! ## Sum-typed shapefree-carrying body simulation + union compose + exiting driver. + +The sum-typed (terminal-OR-exiting) shapefree-carrying stack, combining +per-iteration store-kind-freedom bookkeeping (the `Vs`/`Vh`/`σ_sf` carriers) with +the sum-typed exiting outcome of `BodySimSum` / `loopDet_lift_2g_E_fuel`: + +* `BodySimUSFSum` is the shapefree-carrying body sim with both clauses: a body run + that TERMINATES is matched by a terminating hoist run, and a body run that breaks + with label `l` is matched by a hoist body run that breaks with the SAME label, + re-establishing `HoistInv` / `hasFailure` / `B`-boundedness at the body-exit + stores. +* `compose_union_sf_sum` composes a sum-typed Step A (explicit ∀-shape with both + outcomes) with a sum-typed Step B (`BodySimSum`) into a `BodySimUSFSum`; the + exiting clause composes sequentially body→body₁→body₃ exactly as the terminal + clause does (structurally parallel to the proven `bodySimES_cons`). +* `loopDet_lift_sf_2g_undef_E_fuel` is the EXITING-target driver: structurally + `loopDet_lift_2g_E_fuel` with the `Vs`/`Vh`/`σ_sf` carriers threaded but UNUSED on + the exit path (the exiting outcome caps both stores via `HoistInv.project_both` + and never recurses on the inner loop), consuming a `BodySimUSFSum`. -/ + +/-- The sum-typed shapefree-carrying body simulation, with both clauses. A body +run that TERMINATES is matched by a +terminating hoist run; a body run that EXITS +with label `l` is matched by a hoist run that exits with the SAME label `l`, +re-establishing `HoistInv` / `hasFailure` / `B`-boundedness at the body-exit +stores. The `σ_sf`-relative SOURCE store-kind-freedom invariant is assumed at +entry (it gates which `Q`-kind names may be undefined). -/ +public def BodySimUSFSum [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + (Q : String → Prop) + (Vs Vh : List P.Ident) (σ_sf : StringGenState) (A B : List P.Ident) + (subst : List (P.Ident × P.Ident)) + (bsrc bh : List (Stmt P (Cmd P))) : Prop := + ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + -- TERMINAL clause: + (∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts bsrc ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts bh ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + ∧ + -- EXITING clause (new): + (∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts bsrc ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts bh ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + +/-- The sum-typed shapefree-carrying union compose. Step A is the explicit ∀-shape +carrying BOTH outcomes +(terminal AND exiting), with the `σ_sf`-relative store-kind-freedom assumed on +both `ρ_s` and its hoist mid env `ρ₁`. Step B is a sum-typed `BodySimSum`. The +composed body simulation (`BodySimUSFSum`) carries both outcomes, each composing +sequentially body→body₁→body₃ (Step A produces a body₁ run at the mid env `ρ₁`, +then Step B produces the body₃ run), exactly parallel to `bodySimES_cons`. -/ +public theorem compose_union_sf_sum [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + {Q : String → Prop} + {Vs Vh : List P.Ident} {σ_sf : StringGenState} + {Ao Bo As Bs : List P.Ident} + {so ss : List (P.Ident × P.Ident)} + {body body₁ body₃ : List (Stmt P (Cmd P))} + (stepA_term : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) Ao Bo so ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ Bo, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) Ao Bo so ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ Bo, ρ_h'.store y ≠ none)) + (stepA_exit : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) Ao Bo so ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ Bo, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) Ao Bo so ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ Bo, ρ_h'.store y ≠ none)) + (stepB : BodySimSum (extendEval := extendEval) As Bs ss body₁ body₃) + (h_so_wf : ∀ a b, (a, b) ∈ so → a ∈ Ao ∧ b ∈ Bo) + (h_ss_wf : ∀ a b, (a, b) ∈ ss → a ∈ As ∧ b ∈ Bs) + (h_As_notAo : ∀ x ∈ As, x ∉ Ao) (h_As_notBo : ∀ x ∈ As, x ∉ Bo) + (h_Bo_notAs : ∀ b ∈ Bo, b ∉ As) (h_Bo_notBs : ∀ b ∈ Bo, b ∉ Bs) + (h_Vh_sub_Vs : ∀ y ∈ Vh, y ∈ Vs) + (bridge_in : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) (Ao ++ As) (Bo ++ Bs) (so ++ ss) ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ Bo ++ Bs, ρ_h.store y ≠ none) → + (∀ y ∈ Vh, ρ_s.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + ∃ ρ₁ : Env P, + HoistInv (P := P) Ao Bo so ρ_s.store ρ₁.store ∧ + ρ_s.eval = ρ₁.eval ∧ ρ_s.hasFailure = ρ₁.hasFailure ∧ + (∀ y ∈ Bo, ρ₁.store y ≠ none) ∧ + (∀ y ∈ Vh, ρ₁.store y = none) ∧ + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ₁.store (HasIdent.ident (P := P) str) = none) ∧ + HoistInv (P := P) As Bs ss ρ₁.store ρ_h.store ∧ + ρ₁.eval = ρ_h.eval ∧ ρ₁.hasFailure = ρ_h.hasFailure ∧ + (∀ y ∈ Bs, ρ_h.store y ≠ none)) : + BodySimUSFSum (extendEval := extendEval) Q Vs Vh σ_sf (Ao ++ As) (Bo ++ Bs) (so ++ ss) body body₃ := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd h_Vs h_Vh h_src_sf + obtain ⟨ρ₁, h_hinv_A, h_eval_A, h_hf_A, h_bnd_A, h_Vh_A, h_sf_A, + h_hinv_B, h_eval_B, h_hf_B, h_bnd_B⟩ := + bridge_in ρ_s ρ_h h_hinv h_eval h_hf h_bnd + (by intro y hy; exact h_Vs y (h_Vh_sub_Vs y hy)) h_src_sf + refine ⟨?_, ?_⟩ + · -- TERMINAL clause: Step A terminal then Step B terminal, composed. + intro ρ_s' h_run + obtain ⟨ρ₁', h_run₁, h_hinv₁, h_hf₁, h_bnd₁⟩ := + stepA_term ρ_s ρ₁ h_hinv_A h_eval_A h_hf_A h_bnd_A h_Vs h_Vh_A h_src_sf h_sf_A ρ_s' h_run + obtain ⟨ρ_h', h_run₃, h_hinv₃, h_hf₃, h_bnd₃⟩ := + (stepB ρ₁ ρ_h h_hinv_B h_eval_B h_hf_B h_bnd_B).1 ρ₁' h_run₁ + refine ⟨ρ_h', h_run₃, ?_, ?_, ?_⟩ + · exact bridge_out_union_list h_hinv₁ h_hinv₃ h_so_wf h_ss_wf + h_As_notAo h_As_notBo h_Bo_notAs h_Bo_notBs + · rw [h_hf₁, h_hf₃] + · intro y hy + rcases List.mem_append.mp hy with hyBo | hyBs + · exact bound_Bo_through_stepB h_hinv₃ h_bnd₁ h_Bo_notAs h_Bo_notBs y hyBo + · exact h_bnd₃ y hyBs + · -- EXITING clause: compose body→body₁→body₃ via the two exiting clauses. + intro l ρ_s' h_run + obtain ⟨ρ₁', h_run₁, h_hinv₁, h_hf₁, h_bnd₁⟩ := + stepA_exit ρ_s ρ₁ h_hinv_A h_eval_A h_hf_A h_bnd_A h_Vs h_Vh_A h_src_sf h_sf_A l ρ_s' h_run + obtain ⟨ρ_h', h_run₃, h_hinv₃, h_hf₃, h_bnd₃⟩ := + (stepB ρ₁ ρ_h h_hinv_B h_eval_B h_hf_B h_bnd_B).2 l ρ₁' h_run₁ + refine ⟨ρ_h', h_run₃, ?_, ?_, ?_⟩ + · exact bridge_out_union_list h_hinv₁ h_hinv₃ h_so_wf h_ss_wf + h_As_notAo h_As_notBo h_Bo_notAs h_Bo_notBs + · rw [h_hf₁, h_hf₃] + · intro y hy + rcases List.mem_append.mp hy with hyBo | hyBs + · exact bound_Bo_through_stepB h_hinv₃ h_bnd₁ h_Bo_notAs h_Bo_notBs y hyBo + · exact h_bnd₃ y hyBs + +/-- The FAILING-config union composition: a failing Step A (`body → body₁` over the +enclosing carriers `Ao Bo so`, carrier-guarded) composed with a failing Step B +(`body₁ → body₃` over the new carriers `As Bs ss`) yields a failing body provider +`body → body₃` over the union carriers, in the shape +`loopDet_lift_sf_2g_undef_F_fuel`'s `body_sim_fail` slot expects. + +The mid env `ρ₁` comes from the same `bridge_in` splitter the terminal compose uses; +then the failing chain is direct: `body` fails from `ρ_s` ⟹ (Step A fail) `body₁` +fails from `ρ₁` ⟹ (Step B fail) `body₃` fails from `ρ_h`. No terminal/exiting +re-establishment is needed at the failing point. -/ +public theorem compose_union_fail [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + {Q : String → Prop} + {Vs Vh : List P.Ident} {σ_sf : StringGenState} + {Ao Bo As Bs : List P.Ident} + {so ss : List (P.Ident × P.Ident)} + {body body₁ body₃ : List (Stmt P (Cmd P))} + (stepA_fail : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) Ao Bo so ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ Bo, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_h.store (HasIdent.ident (P := P) str) = none) → + ∀ (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_h) d' + ∧ d'.getEnv.hasFailure = true) + (stepB_fail : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) As Bs ss ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ Bs, ρ_h.store y ≠ none) → + ∀ (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmts body₁ ρ_s) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts body₃ ρ_h) d' + ∧ d'.getEnv.hasFailure = true) + (h_Vh_sub_Vs : ∀ y ∈ Vh, y ∈ Vs) + (bridge_in : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) (Ao ++ As) (Bo ++ Bs) (so ++ ss) ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ Bo ++ Bs, ρ_h.store y ≠ none) → + (∀ y ∈ Vh, ρ_s.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + ∃ ρ₁ : Env P, + HoistInv (P := P) Ao Bo so ρ_s.store ρ₁.store ∧ + ρ_s.eval = ρ₁.eval ∧ ρ_s.hasFailure = ρ₁.hasFailure ∧ + (∀ y ∈ Bo, ρ₁.store y ≠ none) ∧ + (∀ y ∈ Vh, ρ₁.store y = none) ∧ + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ₁.store (HasIdent.ident (P := P) str) = none) ∧ + HoistInv (P := P) As Bs ss ρ₁.store ρ_h.store ∧ + ρ₁.eval = ρ_h.eval ∧ ρ₁.hasFailure = ρ_h.hasFailure ∧ + (∀ y ∈ Bs, ρ_h.store y ≠ none)) : + ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) (Ao ++ As) (Bo ++ Bs) (so ++ ss) ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ Bo ++ Bs, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + ∀ (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ_s) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts body₃ ρ_h) d' + ∧ d'.getEnv.hasFailure = true := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd h_Vs h_Vh h_src_sf d h_run hd + obtain ⟨ρ₁, h_hinv_A, h_eval_A, h_hf_A, h_bnd_A, h_Vh_A, h_sf_A, + h_hinv_B, h_eval_B, h_hf_B, h_bnd_B⟩ := + bridge_in ρ_s ρ_h h_hinv h_eval h_hf h_bnd + (by intro y hy; exact h_Vs y (h_Vh_sub_Vs y hy)) h_src_sf + obtain ⟨d₁, h_run₁, hd₁⟩ := + stepA_fail ρ_s ρ₁ h_hinv_A h_eval_A h_hf_A h_bnd_A h_Vs h_Vh_A h_src_sf h_sf_A d h_run hd + exact stepB_fail ρ₁ ρ_h h_hinv_B h_eval_B h_hf_B h_bnd_B d₁ h_run₁ hd₁ + +/-- `BodySimUSFSum` unfolds definitionally to the ∀-shape the sum-typed exiting +driver `loopDet_lift_sf_2g_undef_E_fuel`'s `body_sim` parameter expects (a +`BodySimSum`-like predicate guarded by the `Vs`/`Vh`/`σ_sf` carriers). -/ +public theorem bodySimUSFSum_is_driver_slot [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + {Q : String → Prop} + (Vs Vh : List P.Ident) (σ_sf : StringGenState) (A B : List P.Ident) + (subst : List (P.Ident × P.Ident)) + (bsrc bh : List (Stmt P (Cmd P))) + (h : BodySimUSFSum (extendEval := extendEval) Q Vs Vh σ_sf A B subst bsrc bh) : + ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts bsrc ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts bh ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + ∧ + (∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts bsrc ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts bh ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) := + h + +/-- **The sum-typed shapefree-carrying two-guard EXITING-target fuel recursion.** + +`loopDet_lift_2g_E_fuel` with the `Vs`/`Vh`/`σ_sf` store-kind-freedom +carriers threaded through. Given a source loop +run reaching `.exiting label ρ_post`, produces a hoist loop run reaching `.exiting +label ρ_post_h` with `HoistInv` / `hasFailure` / `B`-boundedness at the exit +stores. The body simulation slot is the `BodySimUSFSum`-shaped predicate +(terminal AND exiting clauses, guarded by the carriers). + +On the exit path the carriers do bookkeeping only: each terminal intermediate +iteration re-establishes +them at the projected store (`projectStore_undef_at`) before recursing; the +exiting final iteration consumes the body's exiting clause and caps both stores +via `HoistInv.project_both` (no further recursion). -/ +public theorem loopDet_lift_sf_2g_undef_E_fuel [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {Q : String → Prop} + {g_s g_h : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {Vs Vh : List P.Ident} {σ_sf : StringGenState} + (h_guard_transport : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + ρ_s.eval ρ_s.store g_s = .some HasBool.tt → ρ_h.eval ρ_h.store g_h = .some HasBool.tt) + (h_wfb_transport : ∀ (ρ_s ρ_h : Env P), + ρ_s.eval = ρ_h.eval → WellFormedSemanticEvalBool ρ_s.eval → + WellFormedSemanticEvalBool ρ_h.eval) + (body_sim : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + ∧ + (∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none))) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) : + ∀ (n : Nat) {ρ_src ρ_hoist ρ_post : Env P} {label : String}, + HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store → + ρ_src.eval = ρ_hoist.eval → ρ_src.hasFailure = ρ_hoist.hasFailure → + (∀ y ∈ B, ρ_hoist.store y ≠ none) → + (∀ y ∈ Vs, ρ_src.store y = none) → (∀ y ∈ Vh, ρ_hoist.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_src.store (HasIdent.ident (P := P) str) = none) → + (h_run : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop (.det g_s) none [] body_src md_s) ρ_src) (.exiting label ρ_post)) → + h_run.len ≤ n → + ∃ ρ_post_h : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) (.exiting label ρ_post_h) ∧ + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store ∧ + ρ_post.hasFailure = ρ_post_h.hasFailure ∧ + (∀ y ∈ B, ρ_post_h.store y ≠ none) := by + intro n + induction n with + | zero => + intro ρ_src ρ_hoist ρ_post label _ _ _ _ _ _ _ h_run hlen + match h_run with + | .step _ _ _ _ _ => simp [ReflTransT.len] at hlen + | succ n ih => + intro ρ_src ρ_hoist ρ_post label h_hinv h_eval h_hf h_bound h_Vs h_Vh h_src_sf h_run hlen + match h_run with + | .step _ _ _ step hrest => + cases step with + | step_loop_exit ht hinv hiff hwf => + -- A `.terminal` target; `hrest : .terminal … →* .exiting …` is impossible. + match hrest with + | .step _ _ _ hd _ => exact nomatch hd + | step_loop_enter ht hinv hiff hwf => + rename_i hasInvFailure + discharge_hif hasInvFailure hiff + let ρ_src_body : Env P := { ρ_src with hasFailure := ρ_src.hasFailure || false } + let ρ_h_body : Env P := { ρ_hoist with hasFailure := ρ_hoist.hasFailure || false } + have h_hinv_body : HoistInv (P := P) A B subst ρ_src_body.store ρ_h_body.store := by + show HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store; exact h_hinv + have h_eval_body : ρ_src_body.eval = ρ_h_body.eval := h_eval + have h_hf_body : ρ_src_body.hasFailure = ρ_h_body.hasFailure := by + show (ρ_src.hasFailure || false) = (ρ_hoist.hasFailure || false); simp [h_hf] + have h_bound_body : ∀ y ∈ B, ρ_h_body.store y ≠ none := h_bound + have h_Vs_body : ∀ y ∈ Vs, ρ_src_body.store y = none := h_Vs + have h_Vh_body : ∀ y ∈ Vh, ρ_h_body.store y = none := h_Vh + have h_src_sf_body : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → + ρ_src_body.store (HasIdent.ident (P := P) str) = none := h_src_sf + have h_guard_h : ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.tt := + h_guard_transport ρ_src ρ_hoist h_hinv h_eval h_Vs ht + have h_wfb_h : WellFormedSemanticEvalBool ρ_hoist.eval := + h_wfb_transport ρ_src ρ_hoist h_eval hwf + -- Decompose the seq run to `.exiting`: either this iteration's block exits + -- (inl), or it terminates and the recursive loop exits (inr). + rcases seqT_reaches_exiting' hrest with ⟨h_block_exit, hl⟩ | ⟨ρ₁, h_block_term, h_loop_stmts, hl⟩ + · -- inl: this iteration's body exits with `label`. + obtain ⟨ρ_inner, h_body_exit_T, h_ρpost_eq, hl2⟩ := blockT_none_reaches_exiting' h_block_exit + obtain ⟨ρ_h_inner, h_body_h_exit, h_hinv_inner, h_hf_inner, h_bound_inner⟩ := + (body_sim ρ_src_body ρ_h_body h_hinv_body h_eval_body h_hf_body h_bound_body + h_Vs_body h_Vh_body h_src_sf_body).2 + label ρ_inner (reflTransT_to_prop h_body_exit_T) + refine ⟨{ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store }, ?_, ?_, ?_, ?_⟩ + · refine ReflTrans.step _ _ _ + (.step_loop_enter (hasInvFailure := false) + h_guard_h (by intro le hle; simp at hle) (by simp) h_wfb_h) ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ (none : Option String) ρ_hoist.store + (show StepStmtStar P (EvalCmd P) extendEval + (.stmts body_h { ρ_hoist with hasFailure := ρ_hoist.hasFailure || false }) + (.exiting label ρ_h_inner) from h_body_h_exit))) ?_ + refine ReflTrans.step _ _ _ (.step_seq_inner (.step_block_exit_mismatch ?_)) ?_ + · exact (by simp) + · exact ReflTrans.step _ _ _ .step_seq_exit (.refl _) + · subst h_ρpost_eq + exact HoistInv.project_both h_hinv h_hinv_inner + · subst h_ρpost_eq + show ρ_inner.hasFailure = ρ_h_inner.hasFailure; exact h_hf_inner + · intro y hy + show projectStore ρ_hoist.store ρ_h_inner.store y ≠ none + unfold projectStore + have h_parent_some : (ρ_hoist.store y).isSome = true := by + cases h : ρ_hoist.store y with + | none => exact absurd h (h_bound y hy) + | some _ => rfl + rw [h_parent_some]; simp; exact h_bound_inner y hy + · -- inr: this iteration's body terminates; recurse on the inner loop. + obtain ⟨ρ_inner, h_body_term_T, h_ρ_block_eq, hl_blk⟩ := blockT_none_reaches_terminal h_block_term + subst h_ρ_block_eq + obtain ⟨ρ_h_inner, h_body_h_run, h_hinv_inner, h_hf_inner, h_bound_inner⟩ := + (body_sim ρ_src_body ρ_h_body h_hinv_body h_eval_body h_hf_body h_bound_body + h_Vs_body h_Vh_body h_src_sf_body).1 + ρ_inner (reflTransT_to_prop h_body_term_T) + have h_hoist_iter : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) + (.stmts [.loop (.det g_h) none [] body_h md_h] + { ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store }) := by + have hb : StepStmtStar P (EvalCmd P) extendEval + (.stmts body_h ρ_h_body) (.terminal ρ_h_inner) := h_body_h_run + have := buildLoopIterationDet (g := g_h) (body := body_h) (md := md_h) + (ρ_pre := ρ_h_body) (ρ_body := ρ_h_inner) ?_ ?_ hb + · simpa [ρ_h_body] using this + · show ρ_h_body.eval ρ_h_body.store g_h = .some HasBool.tt + show ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.tt; exact h_guard_h + · show WellFormedSemanticEvalBool ρ_h_body.eval + show WellFormedSemanticEvalBool ρ_hoist.eval; exact h_wfb_h + have h_hinv_block : HoistInv (P := P) A B subst + (projectStore ρ_src.store ρ_inner.store) + (projectStore ρ_hoist.store ρ_h_inner.store) := + HoistInv.project_both h_hinv h_hinv_inner + have h_eval_block : ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).eval + = ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).eval := by + show ρ_inner.eval = ρ_h_inner.eval + have e1 : ρ_inner.eval = ρ_src_body.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body_src ρ_src_body ρ_inner h_src_body_nofd (reflTransT_to_prop h_body_term_T) + have e2 : ρ_h_inner.eval = ρ_h_body.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body_h ρ_h_body ρ_h_inner h_h_body_nofd h_body_h_run + rw [e1, e2]; exact h_eval_body + have h_hf_block : ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).hasFailure + = ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).hasFailure := by + show ρ_inner.hasFailure = ρ_h_inner.hasFailure; exact h_hf_inner + have h_bound_block : ∀ y ∈ B, + ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).store y ≠ none := by + intro y hy + show projectStore ρ_hoist.store ρ_h_inner.store y ≠ none + unfold projectStore + have h_parent_some : (ρ_hoist.store y).isSome = true := by + cases h : ρ_hoist.store y with + | none => exact absurd h (h_bound y hy) + | some _ => rfl + rw [h_parent_some]; simp; exact h_bound_inner y hy + have h_Vs_block : ∀ y ∈ Vs, + ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).store y = none := by + intro y hy; show projectStore ρ_src.store ρ_inner.store y = none + exact projectStore_undef_at (h_Vs y hy) + have h_Vh_block : ∀ y ∈ Vh, + ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).store y = none := by + intro y hy; show projectStore ρ_hoist.store ρ_h_inner.store y = none + exact projectStore_undef_at (h_Vh y hy) + have h_src_sf_block : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → + ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).store + (HasIdent.ident (P := P) str) = none := by + intro str h_suf h_notσ + show projectStore ρ_src.store ρ_inner.store (HasIdent.ident (P := P) str) = none + exact projectStore_undef_at (h_src_sf str h_suf h_notσ) + rcases stmtsT_cons_exiting' h_loop_stmts with ⟨h_inner_loop_T, _⟩ | ⟨ρ₂, _, h_nil, _⟩ + · obtain ⟨ρ_post_h, h_post_h_run, h_hinv_post, h_hf_post, h_bound_post⟩ := + ih h_hinv_block h_eval_block h_hf_block h_bound_block h_Vs_block h_Vh_block + h_src_sf_block h_inner_loop_T + (by simp only [ReflTransT.len] at hlen; omega) + refine ⟨ρ_post_h, ?_, h_hinv_post, h_hf_post, h_bound_post⟩ + refine ReflTrans_Transitive _ _ _ _ h_hoist_iter ?_ + refine ReflTrans.step _ _ _ .step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_post_h_run) ?_ + exact ReflTrans.step _ _ _ .step_seq_exit (.refl _) + · match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .step _ _ _ hd _ => exact nomatch hd + +/-- Prop-level wrapper of `loopDet_lift_sf_2g_undef_E_fuel` specialised to the +single-guard diagonal `g_s = g_h = g` (the shape the §E `.loop` arm produces: +the loop guard is UNCHANGED by the hoist pass), the EXITING-target driver. -/ +public theorem loopDet_lift_sf_undef_E_recovers_single [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {Q : String → Prop} + {g : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {Vs Vh : List P.Ident} {σ_sf : StringGenState} + (h_guard_transport : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + ρ_s.eval ρ_s.store g = .some HasBool.tt → ρ_h.eval ρ_h.store g = .some HasBool.tt) + (h_wfb_transport : ∀ (ρ_s ρ_h : Env P), + ρ_s.eval = ρ_h.eval → WellFormedSemanticEvalBool ρ_s.eval → + WellFormedSemanticEvalBool ρ_h.eval) + (body_sim : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + ∧ + (∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none))) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) + {ρ_src ρ_hoist ρ_post : Env P} {label : String} + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval : ρ_src.eval = ρ_hoist.eval) (h_hf : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_Vs : ∀ y ∈ Vs, ρ_src.store y = none) (h_Vh : ∀ y ∈ Vh, ρ_hoist.store y = none) + (h_src_sf : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_src.store (HasIdent.ident (P := P) str) = none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body_src md_s) ρ_src) (.exiting label ρ_post)) : + ∃ ρ_post_h : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body_h md_h) ρ_hoist) (.exiting label ρ_post_h) ∧ + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store ∧ + ρ_post.hasFailure = ρ_post_h.hasFailure ∧ + (∀ y ∈ B, ρ_post_h.store y ≠ none) := + loopDet_lift_sf_2g_undef_E_fuel (g_s := g) (g_h := g) + h_guard_transport h_wfb_transport body_sim h_src_body_nofd h_h_body_nofd + (reflTrans_to_T h_run).len h_hinv h_eval h_hf h_bound h_Vs h_Vh h_src_sf + (reflTrans_to_T h_run) (Nat.le_refl _) + +/-- **The sum-typed shapefree-carrying two-guard TERMINAL-target fuel recursion.** + +The TERMINAL analogue of `loopDet_lift_sf_2g_undef_E_fuel`: takes no +`h_src_body_no_exit` and consumes the +sum-typed `BodySimUSFSum`-shaped `body_sim`. A source loop run reaching `.terminal +ρ_post` means NO iteration's body broke (a body `.exit` would propagate the loop +to `.exiting`, not `.terminal`); so each peeled iteration's `.block .none` reaches +`.terminal` via `blockT_none_reaches_terminal` (which recovers the body's TERMINAL +run WITHOUT a no-exit hypothesis), the body's TERMINAL clause drives one hoist +iteration, and the recursion handles the residual loop. The `Vs`/`Vh`/`σ_sf` +carriers are re-established at each projected iteration store. -/ +public theorem loopDet_lift_sf_2g_undef_TE_fuel [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {Q : String → Prop} + {g_s g_h : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {Vs Vh : List P.Ident} {σ_sf : StringGenState} + (h_guard_transport : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + ρ_s.eval ρ_s.store g_s = .some HasBool.tt → ρ_h.eval ρ_h.store g_h = .some HasBool.tt) + (h_guard_transport_ff : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + ρ_s.eval ρ_s.store g_s = .some HasBool.ff → ρ_h.eval ρ_h.store g_h = .some HasBool.ff) + (h_wfb_transport : ∀ (ρ_s ρ_h : Env P), + ρ_s.eval = ρ_h.eval → WellFormedSemanticEvalBool ρ_s.eval → + WellFormedSemanticEvalBool ρ_h.eval) + (body_sim : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + ∧ + (∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none))) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) : + ∀ (n : Nat) {ρ_src ρ_hoist ρ_post : Env P}, + HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store → + ρ_src.eval = ρ_hoist.eval → ρ_src.hasFailure = ρ_hoist.hasFailure → + (∀ y ∈ B, ρ_hoist.store y ≠ none) → + (∀ y ∈ Vs, ρ_src.store y = none) → (∀ y ∈ Vh, ρ_hoist.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_src.store (HasIdent.ident (P := P) str) = none) → + (h_run : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop (.det g_s) none [] body_src md_s) ρ_src) (.terminal ρ_post)) → + h_run.len ≤ n → + ∃ ρ_post_h : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) (.terminal ρ_post_h) ∧ + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store ∧ + ρ_post.hasFailure = ρ_post_h.hasFailure ∧ + (∀ y ∈ B, ρ_post_h.store y ≠ none) := by + intro n + induction n with + | zero => + intro ρ_src ρ_hoist ρ_post _ _ _ _ _ _ _ h_run hlen + match h_run with + | .step _ _ _ _ _ => simp [ReflTransT.len] at hlen + | succ n ih => + intro ρ_src ρ_hoist ρ_post h_hinv h_eval h_hf h_bound h_Vs h_Vh h_src_sf h_run hlen + match h_run with + | .step _ _ _ step hrest => + cases step with + | step_loop_exit ht hinv hiff hwf => + rename_i hasInvFailure + have h_hif_false : hasInvFailure = false := by + cases h_hif : hasInvFailure with + | false => rfl + | true => obtain ⟨le, hle_mem, _⟩ := hiff.mp h_hif; simp at hle_mem + have h_ρ_post_eq : ρ_post = { ρ_src with hasFailure := ρ_src.hasFailure || hasInvFailure } := by + match hrest with + | .refl _ => rfl + | .step _ _ _ hd _ => exact nomatch hd + subst h_ρ_post_eq + subst h_hif_false + have h_guard_h : ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.ff := + h_guard_transport_ff ρ_src ρ_hoist h_hinv h_eval h_Vs ht + have h_wfb_h : WellFormedSemanticEvalBool ρ_hoist.eval := + h_wfb_transport ρ_src ρ_hoist h_eval hwf + refine ⟨{ ρ_hoist with hasFailure := ρ_hoist.hasFailure || false }, ?_, ?_, ?_, ?_⟩ + · exact .step _ _ _ + (.step_loop_exit h_guard_h (by intro le hle; simp at hle) (by simp) h_wfb_h) + (.refl _) + · simpa using h_hinv + · show (ρ_src.hasFailure || false) = (ρ_hoist.hasFailure || false); simp [h_hf] + · intro y hy; show ρ_hoist.store y ≠ none; exact h_bound y hy + | step_loop_enter ht hinv hiff hwf => + rename_i hasInvFailure + discharge_hif hasInvFailure hiff + obtain ⟨ρ_block, h_block_term, h_loop_stmts, hlen_seq⟩ := + seqT_reaches_terminal extendEval hrest + obtain ⟨ρ_inner, h_body_src_T, h_ρ_block_eq, hlen_block⟩ := + blockT_none_reaches_terminal h_block_term + subst h_ρ_block_eq + obtain ⟨ρ_x, h_loop_T, h_nil, hlen_cons⟩ := + stmtsT_cons_terminal extendEval h_loop_stmts + have hρ_x_eq : ρ_x = ρ_post := by + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + subst hρ_x_eq + let ρ_src_body : Env P := { ρ_src with hasFailure := ρ_src.hasFailure || false } + let ρ_h_body : Env P := { ρ_hoist with hasFailure := ρ_hoist.hasFailure || false } + have h_hinv_body : HoistInv (P := P) A B subst ρ_src_body.store ρ_h_body.store := by + show HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store; exact h_hinv + have h_eval_body : ρ_src_body.eval = ρ_h_body.eval := h_eval + have h_hf_body : ρ_src_body.hasFailure = ρ_h_body.hasFailure := by + show (ρ_src.hasFailure || false) = (ρ_hoist.hasFailure || false); simp [h_hf] + have h_bound_body : ∀ y ∈ B, ρ_h_body.store y ≠ none := h_bound + have h_Vs_body : ∀ y ∈ Vs, ρ_src_body.store y = none := h_Vs + have h_Vh_body : ∀ y ∈ Vh, ρ_h_body.store y = none := h_Vh + have h_src_sf_body : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → + ρ_src_body.store (HasIdent.ident (P := P) str) = none := h_src_sf + obtain ⟨ρ_h_inner, h_body_h_run, h_hinv_inner, h_hf_inner, h_bound_inner⟩ := + (body_sim ρ_src_body ρ_h_body h_hinv_body h_eval_body h_hf_body h_bound_body + h_Vs_body h_Vh_body h_src_sf_body).1 + ρ_inner (reflTransT_to_prop h_body_src_T) + have h_guard_h : ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.tt := + h_guard_transport ρ_src ρ_hoist h_hinv h_eval h_Vs ht + have h_wfb_h : WellFormedSemanticEvalBool ρ_hoist.eval := + h_wfb_transport ρ_src ρ_hoist h_eval hwf + have h_hoist_iter : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g_h) none [] body_h md_h) ρ_hoist) + (.stmts [.loop (.det g_h) none [] body_h md_h] + { ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store }) := by + have hb : StepStmtStar P (EvalCmd P) extendEval + (.stmts body_h ρ_h_body) (.terminal ρ_h_inner) := h_body_h_run + have := buildLoopIterationDet (g := g_h) (body := body_h) (md := md_h) + (ρ_pre := ρ_h_body) (ρ_body := ρ_h_inner) ?_ ?_ hb + · simpa [ρ_h_body] using this + · show ρ_h_body.eval ρ_h_body.store g_h = .some HasBool.tt + show ρ_hoist.eval ρ_hoist.store g_h = .some HasBool.tt; exact h_guard_h + · show WellFormedSemanticEvalBool ρ_h_body.eval + show WellFormedSemanticEvalBool ρ_hoist.eval; exact h_wfb_h + have h_hinv_block : HoistInv (P := P) A B subst + (projectStore ρ_src.store ρ_inner.store) + (projectStore ρ_hoist.store ρ_h_inner.store) := + HoistInv.project_both h_hinv h_hinv_inner + have h_eval_block : ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).eval + = ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).eval := by + show ρ_inner.eval = ρ_h_inner.eval + have e1 : ρ_inner.eval = ρ_src_body.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body_src ρ_src_body ρ_inner h_src_body_nofd (reflTransT_to_prop h_body_src_T) + have e2 : ρ_h_inner.eval = ρ_h_body.eval := + smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + body_h ρ_h_body ρ_h_inner h_h_body_nofd h_body_h_run + rw [e1, e2]; exact h_eval_body + have h_hf_block : ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).hasFailure + = ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).hasFailure := by + show ρ_inner.hasFailure = ρ_h_inner.hasFailure; exact h_hf_inner + have h_bound_block : ∀ y ∈ B, + ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).store y ≠ none := by + intro y hy + show projectStore ρ_hoist.store ρ_h_inner.store y ≠ none + unfold projectStore + have h_parent_some : (ρ_hoist.store y).isSome = true := by + cases h : ρ_hoist.store y with + | none => exact absurd h (h_bound y hy) + | some _ => rfl + rw [h_parent_some]; simp; exact h_bound_inner y hy + have h_Vs_block : ∀ y ∈ Vs, + ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).store y = none := by + intro y hy; show projectStore ρ_src.store ρ_inner.store y = none + exact projectStore_undef_at (h_Vs y hy) + have h_Vh_block : ∀ y ∈ Vh, + ({ ρ_h_inner with store := projectStore ρ_hoist.store ρ_h_inner.store } : Env P).store y = none := by + intro y hy; show projectStore ρ_hoist.store ρ_h_inner.store y = none + exact projectStore_undef_at (h_Vh y hy) + have h_src_sf_block : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → + ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P).store + (HasIdent.ident (P := P) str) = none := by + intro str h_suf h_notσ + show projectStore ρ_src.store ρ_inner.store (HasIdent.ident (P := P) str) = none + exact projectStore_undef_at (h_src_sf str h_suf h_notσ) + obtain ⟨ρ_post_h, h_post_h_run, h_hinv_post, h_hf_post, h_bound_post⟩ := + ih h_hinv_block h_eval_block h_hf_block h_bound_block h_Vs_block h_Vh_block + h_src_sf_block h_loop_T + (by simp only [ReflTransT.len] at hlen; omega) + refine ⟨ρ_post_h, ?_, h_hinv_post, h_hf_post, h_bound_post⟩ + refine ReflTrans_Transitive _ _ _ _ h_hoist_iter ?_ + refine ReflTrans.step _ _ _ .step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_post_h_run) ?_ + exact ReflTrans.step _ _ _ .step_seq_done + (ReflTrans.step _ _ _ .step_stmts_nil (.refl _)) + +/-- Prop-level wrapper of `loopDet_lift_sf_2g_undef_TE_fuel` specialised to the +single-guard diagonal `g_s = g_h = g`. The TERMINAL-target analogue of +`loopDet_lift_sf_undef_E_recovers_single` (consumes the sum-typed +`BodySimUSFSum`-shaped `body_sim`, no `h_src_body_no_exit`). -/ +public theorem loopDet_lift_sf_undef_TE_recovers_single [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {Q : String → Prop} + {g : P.Expr} {body_src body_h : List (Stmt P (Cmd P))} {md_s md_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {Vs Vh : List P.Ident} {σ_sf : StringGenState} + (h_guard_transport : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + ρ_s.eval ρ_s.store g = .some HasBool.tt → ρ_h.eval ρ_h.store g = .some HasBool.tt) + (h_guard_transport_ff : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∀ y ∈ Vs, ρ_s.store y = none) → + ρ_s.eval ρ_s.store g = .some HasBool.ff → ρ_h.eval ρ_h.store g = .some HasBool.ff) + (h_wfb_transport : ∀ (ρ_s ρ_h : Env P), + ρ_s.eval = ρ_h.eval → WellFormedSemanticEvalBool ρ_s.eval → + WellFormedSemanticEvalBool ρ_h.eval) + (body_sim : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ y ∈ Vs, ρ_s.store y = none) → (∀ y ∈ Vh, ρ_h.store y = none) → + (∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_s.store (HasIdent.ident (P := P) str) = none) → + (∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none)) + ∧ + (∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts body_src ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts body_h ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none))) + (h_src_body_nofd : Block.noFuncDecl body_src = true) + (h_h_body_nofd : Block.noFuncDecl body_h = true) + {ρ_src ρ_hoist ρ_post : Env P} + (h_hinv : HoistInv (P := P) A B subst ρ_src.store ρ_hoist.store) + (h_eval : ρ_src.eval = ρ_hoist.eval) (h_hf : ρ_src.hasFailure = ρ_hoist.hasFailure) + (h_bound : ∀ y ∈ B, ρ_hoist.store y ≠ none) + (h_Vs : ∀ y ∈ Vs, ρ_src.store y = none) (h_Vh : ∀ y ∈ Vh, ρ_hoist.store y = none) + (h_src_sf : ∀ str : String, Q str → + str ∉ StringGenState.stringGens σ_sf → ρ_src.store (HasIdent.ident (P := P) str) = none) + (h_run : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body_src md_s) ρ_src) (.terminal ρ_post)) : + ∃ ρ_post_h : Env P, + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det g) none [] body_h md_h) ρ_hoist) (.terminal ρ_post_h) ∧ + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store ∧ + ρ_post.hasFailure = ρ_post_h.hasFailure ∧ + (∀ y ∈ B, ρ_post_h.store y ≠ none) := + loopDet_lift_sf_2g_undef_TE_fuel (g_s := g) (g_h := g) + h_guard_transport h_guard_transport_ff h_wfb_transport body_sim h_src_body_nofd h_h_body_nofd + (reflTrans_to_T h_run).len h_hinv h_eval h_hf h_bound h_Vs h_Vh h_src_sf + (reflTrans_to_T h_run) (Nat.le_refl _) + + + +/-! ## Step J: restrict the union-carrier `HoistInv` back to the ambient carriers. + +The loop driver delivers `HoistInv (A++As)(B++Bs)(subst++ss) ρ_post ρ_post_h` at +the union carriers; the §E `.loop` arm needs it at the ambient `A B subst`. +Under the GUARDED frame this restriction is SOUND: the fresh sources/targets +`As`/`Bs` are undefined in the source loop post-store `ρ_post` (they are body +inits / generator names absent from the source store — see +`loopDet_preserves_none_terminal` / `_exiting`), so the guarded ambient frame, whose obligation only +fires at `ρ_post x ≠ none`, never applies to them and the union frame covers +every remaining variable. The pairing restricts directly (`subst ⊆ subst++ss`). -/ +public theorem stepJ_restrict + {A B As Bs : List P.Ident} {subst ss : List (P.Ident × P.Ident)} + {ρ_post ρ_post_h : Env P} + (h_hinv : HoistInv (P := P) (A ++ As) (B ++ Bs) (subst ++ ss) ρ_post.store ρ_post_h.store) + (h_post_As_none : ∀ x ∈ As, ρ_post.store x = none) + (h_post_Bs_none : ∀ x ∈ Bs, ρ_post.store x = none) : + HoistInv (P := P) A B subst ρ_post.store ρ_post_h.store := by + refine ⟨?_, ?_⟩ + · intro x hxA hxB h_x_ne + have hxAs : x ∉ As := fun h => h_x_ne (h_post_As_none x h) + have hxBs : x ∉ Bs := fun h => h_x_ne (h_post_Bs_none x h) + refine h_hinv.1 x ?_ ?_ h_x_ne + · intro h; rcases List.mem_append.mp h with h | h + · exact hxA h + · exact hxAs h + · intro h; rcases List.mem_append.mp h with h | h + · exact hxB h + · exact hxBs h + · intro a b h_pair h_ne + exact h_hinv.2 a b (List.mem_append.mpr (Or.inl h_pair)) h_ne + +end LoopInitHoistLoopDriver +end Imperative + +end -- public section diff --git a/Strata/Transform/LoopInitHoistRewrite.lean b/Strata/Transform/LoopInitHoistRewrite.lean new file mode 100644 index 0000000000..468c9684f2 --- /dev/null +++ b/Strata/Transform/LoopInitHoistRewrite.lean @@ -0,0 +1,710 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.Transform.LoopInitHoist +public import Strata.Transform.GenSuffix + +import all Strata.DL.Imperative.Cmd +import all Strata.DL.Imperative.Stmt +import all Strata.Transform.LoopInitHoist + +public section + +namespace Imperative + +open Strata.Transform.GenSuffix (NoGenSuffix) + +variable {P : PureExpr} + +/-! # Phase 7.5 redesign: rewrite predicate `RewriteSum` + +This file establishes the predicate framework used to characterise the +output of `Block.liftInitsInLoopBody` for the merged `loop_preserves_struct` +theorem in Phase 8. The eventual consumer (the `.loop` arm of the hoisting +preservation proof) needs a STRUCTURAL relation between a source body +`body₁` and the pass's emitted `body₂ = (Block.liftInitsInLoopBody body₁).snd`, +parametrised by the hoisted-names list +`hoistedNames = (Block.liftInitsInLoopBody body₁).fst.flatMap Cmd.definedVars`. + +## Encoding + +The encoding is a SINGLE inductive predicate `RewriteSum` over the sum +`Stmt P (Cmd P) ⊕ List (Stmt P (Cmd P))`. This avoids `mutual inductive` +(which fails Lean's `induction` tactic on Prop-valued mutuals) and the +function-form alternative (which forced ~395 LoC of `applyHoistRewrite_*` +infrastructure for the discharge — 5–8x the budget). + +`Stmt.InitsRewrittenAsSets` and `Block.InitsRewrittenAsSets` are thin +wrappers that publicly project to the appropriate `.inl`/`.inr` side; the +discharge proof works internally on `RewriteSum` and uses the wrappers as +the user-facing API. + +## Caveat — `stmt_non_hoisted_cmd` carries `Cmd.definedVars c = []` + +The non-init constructor's premise is a STRUCTURAL fact about the cmd +(rather than a name-list relation), tightening β's predicate compared to +the plan's spec. This is correct for THIS use site because +`liftInitsInLoopBody` only emits non-init cmds (whose `definedVars = []`). +If a future hoist optimisation extends the rewrite to `set y rhs` shapes +(which DO have non-empty `definedVars`), this constructor must add a +`stmt_passthrough_cmd` companion with the original disjointness premise. +-/ + +/-! ## Step 3 — `DisjointModuloRewrite` predicate + +The eventual `loop_preserves_struct` consumer also needs a positional +disjointness predicate: every body stmt must be disjoint from the +hoistedNames list, EXCEPT at the rewrite sites themselves (a `set y _ _` +in the OUTPUT body whose `y ∈ hoistedNames` came from an original +`init y _ _ _` rewrite — `y ∈ hoistedNames` is allowed in modifiedVars +precisely because it IS the rewrite target). + +`Stmt.DisjointModuloRewrite` is a *function-form* `Prop` recursing +structurally over Stmt. The predicate is shaped to match the OUTPUT of +`liftInitsInLoopBody`: +- `init y _ _ _` cmds at hoistedName positions are FORBIDDEN (the output + never has them — they've all been rewritten to `set`). +- `set y rhs _` cmds permit `y ∈ hoistedNames` (rewrite-site carve-out) + but require RHS vars disjoint from hoistedNames. +- `assert/assume/cover _ e _` cmds require `e`'s vars disjoint from + hoistedNames. + +Anti-monotonicity in `hoistedNames` makes the `.ite` arm of the discharge +load-bearing — each branch's witness must be lifted from its own +harvested-name list to the union. The discharge threads +`Block.uniqueInits` (for branch-disjoint harvests) and a strengthened +`Block.hoistedNamesFreshInRhsAndGuards` (for RHS-freshness across the +entire program). -/ + +mutual + +/-- Stmt-level disjointness modulo the rewrite. -/ +@[expose] def Stmt.DisjointModuloRewrite [HasVarsPure P P.Expr] + (hoistedNames : List P.Ident) : + Stmt P (Cmd P) → Prop + | .cmd (.init y _ rhs _) => + -- Output never has init at hoistedName positions. Plus RHS-freshness. + y ∉ hoistedNames ∧ ∀ z ∈ hoistedNames, z ∉ ExprOrNondet.getVars rhs + | .cmd (.set _ rhs _) => + -- Rewrite-site allowed: y MAY be in hoistedNames. But rhs is fresh. + ∀ z ∈ hoistedNames, z ∉ ExprOrNondet.getVars rhs + | .cmd (.assert _ e _) => + ∀ z ∈ hoistedNames, z ∉ HasVarsPure.getVars e + | .cmd (.assume _ e _) => + ∀ z ∈ hoistedNames, z ∉ HasVarsPure.getVars e + | .cmd (.cover _ e _) => + ∀ z ∈ hoistedNames, z ∉ HasVarsPure.getVars e + | .block _ bss _ => Block.DisjointModuloRewrite hoistedNames bss + | .ite _ tss ess _ => + Block.DisjointModuloRewrite hoistedNames tss ∧ + Block.DisjointModuloRewrite hoistedNames ess + | .loop _ _ _ body _ => + Block.DisjointModuloRewrite hoistedNames body + | .exit _ _ => True + | .funcDecl _ _ => True + | .typeDecl _ _ => True + termination_by s => sizeOf s + +/-- Block-level disjointness modulo the rewrite. -/ +@[expose] def Block.DisjointModuloRewrite [HasVarsPure P P.Expr] + (hoistedNames : List P.Ident) : + List (Stmt P (Cmd P)) → Prop + | [] => True + | s :: rest => + Stmt.DisjointModuloRewrite hoistedNames s ∧ + Block.DisjointModuloRewrite hoistedNames rest + termination_by ss => sizeOf ss + +end + +/-! ## Strengthened freshness predicate `namesFreshInExprs` + +Parametric form: "every `names` element is fresh in every cmd +expression / loop guard / inv / measure at any depth in `s`". Used by +the discharge below to lift each branch's `DisjointModuloRewrite` +witness across the `.ite` union. + +The predicate is MONOTONE in `names`'s subset relation (smaller names +list = weaker requirement). It checks freshness at every expression +position — command RHS, loop/ite guard, invariant, and measure. -/ + +/-- Helper: list-membership test using `P.EqIdent` (the only decidable +equality available on `P.Ident`). Returns `true` iff `z ∉ vars`. -/ +@[expose] def freshFromIdents (z : P.Ident) (vars : List P.Ident) : Bool := + vars.all (fun v => ¬ (P.EqIdent z v).decide) + +mutual + +/-- "names is fresh in s": every name z ∈ names doesn't appear in any +cmd's expression, loop guard, invariant, or measure at any depth in s. +This explicitly does NOT carve out rewrite-target positions — that's +fine because `init y _ rhs _` and `set y _ rhs _` only check `rhs`'s +vars (the modifiedVar y is not constrained by this predicate). -/ +@[expose] def Stmt.namesFreshInExprs [HasVarsPure P P.Expr] + (names : List P.Ident) (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd (.init _ _ rhs _) => + names.all (fun z => freshFromIdents z (ExprOrNondet.getVars rhs)) + | .cmd (.set _ rhs _) => + names.all (fun z => freshFromIdents z (ExprOrNondet.getVars rhs)) + | .cmd (.assert _ e _) => + names.all (fun z => freshFromIdents z (HasVarsPure.getVars e)) + | .cmd (.assume _ e _) => + names.all (fun z => freshFromIdents z (HasVarsPure.getVars e)) + | .cmd (.cover _ e _) => + names.all (fun z => freshFromIdents z (HasVarsPure.getVars e)) + | .block _ bss _ => Block.namesFreshInExprs names bss + | .ite g tss ess _ => + names.all (fun z => freshFromIdents z (ExprOrNondet.getVars g)) && + Block.namesFreshInExprs names tss && Block.namesFreshInExprs names ess + | .loop g m inv body _ => + names.all (fun z => freshFromIdents z (ExprOrNondet.getVars g)) && + (match m with + | none => true + | some me => names.all (fun z => freshFromIdents z (HasVarsPure.getVars me))) && + inv.all (fun p => names.all (fun z => freshFromIdents z (HasVarsPure.getVars p.snd))) && + Block.namesFreshInExprs names body + | .exit _ _ => true + | .funcDecl _ _ => true + | .typeDecl _ _ => true + termination_by sizeOf s + +/-- "names is fresh in ss": same as `Stmt.namesFreshInExprs` lifted +pointwise across the block. -/ +@[expose] def Block.namesFreshInExprs [HasVarsPure P P.Expr] + (names : List P.Ident) (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => true + | s :: rest => + Stmt.namesFreshInExprs names s && Block.namesFreshInExprs names rest + termination_by sizeOf ss + +end + +/-! ## RHS-only freshness predicate `namesFreshInRhsExprs` + +A relaxation of `namesFreshInExprs` that checks freshness only against +command *right-hand-side* expressions (`init`/`set` rhs, assertion / assume / +cover conditions) at every depth, but NOT against `.ite`/`.loop` *guard*, +invariant, or measure expressions. This is exactly what +`hoistedNamesFreshInRhsAndGuards` requires for its `initVars` component: the +hoisting proof only ever reads back the RHS / body-recursion parts — the +guard-read clauses are always discarded. Guard agreement for a loop's body +inits is instead obtained from their undefinedness at the loop head (a +body-init name is `none` there, so an evaluating guard cannot read it), and +from the hoist-accumulated-name `namesFreshInExprs A`/`B` instances. + +Restricting to RHS positions makes the predicate satisfiable on a pass output +that synthesises `.ite (.det (mkFvar g)) …` / `.loop (.det (mkFvar g)) …` +guards reading a freshly-minted `g` that is simultaneously a top-level +init-var: such an output reads `g` only in a *guard*, never in a command RHS, +so it is RHS-fresh even though it is not guard-fresh. + +`namesFreshInExprs names s ⇒ namesFreshInRhsExprs names s` (it drops +hypotheses), proven below as `*_of_namesFreshInExprs`. -/ + +mutual + +/-- "names is fresh in every command RHS of `s`": every `z ∈ names` is absent +from each `init`/`set` rhs and each `assert`/`assume`/`cover` condition at any +depth in `s`, with `.ite`/`.loop` recursing into branches/body only (the +guard/invariant/measure read positions are NOT checked). -/ +@[expose] def Stmt.namesFreshInRhsExprs [HasVarsPure P P.Expr] + (names : List P.Ident) (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd (.init _ _ rhs _) => + names.all (fun z => freshFromIdents z (ExprOrNondet.getVars rhs)) + | .cmd (.set _ rhs _) => + names.all (fun z => freshFromIdents z (ExprOrNondet.getVars rhs)) + | .cmd (.assert _ e _) => + names.all (fun z => freshFromIdents z (HasVarsPure.getVars e)) + | .cmd (.assume _ e _) => + names.all (fun z => freshFromIdents z (HasVarsPure.getVars e)) + | .cmd (.cover _ e _) => + names.all (fun z => freshFromIdents z (HasVarsPure.getVars e)) + | .block _ bss _ => Block.namesFreshInRhsExprs names bss + | .ite _ tss ess _ => + Block.namesFreshInRhsExprs names tss && Block.namesFreshInRhsExprs names ess + | .loop _ _ _ body _ => + Block.namesFreshInRhsExprs names body + | .exit _ _ => true + | .funcDecl _ _ => true + | .typeDecl _ _ => true + termination_by sizeOf s + +/-- Block-level RHS-only freshness, lifted pointwise across the block. -/ +@[expose] def Block.namesFreshInRhsExprs [HasVarsPure P P.Expr] + (names : List P.Ident) (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => true + | s :: rest => + Stmt.namesFreshInRhsExprs names s && Block.namesFreshInRhsExprs names rest + termination_by sizeOf ss + +end + +mutual + +/-- The full `namesFreshInExprs` implies the RHS-only relaxation: dropping the +guard/invariant/measure conjuncts only weakens the predicate. -/ +theorem Stmt.namesFreshInRhsExprs_of_namesFreshInExprs [HasVarsPure P P.Expr] + (names : List P.Ident) (s : Stmt P (Cmd P)) + (h : Stmt.namesFreshInExprs names s = true) : + Stmt.namesFreshInRhsExprs names s = true := by + match s with + | .cmd (.init _ _ rhs _) => simpa only [Stmt.namesFreshInExprs, Stmt.namesFreshInRhsExprs] using h + | .cmd (.set _ rhs _) => simpa only [Stmt.namesFreshInExprs, Stmt.namesFreshInRhsExprs] using h + | .cmd (.assert _ e _) => simpa only [Stmt.namesFreshInExprs, Stmt.namesFreshInRhsExprs] using h + | .cmd (.assume _ e _) => simpa only [Stmt.namesFreshInExprs, Stmt.namesFreshInRhsExprs] using h + | .cmd (.cover _ e _) => simpa only [Stmt.namesFreshInExprs, Stmt.namesFreshInRhsExprs] using h + | .block _ bss _ => + simp only [Stmt.namesFreshInExprs] at h + simp only [Stmt.namesFreshInRhsExprs] + exact Block.namesFreshInRhsExprs_of_namesFreshInExprs names bss h + | .ite g tss ess _ => + simp only [Stmt.namesFreshInExprs, Bool.and_eq_true] at h + simp only [Stmt.namesFreshInRhsExprs, Bool.and_eq_true] + exact ⟨Block.namesFreshInRhsExprs_of_namesFreshInExprs names tss h.1.2, + Block.namesFreshInRhsExprs_of_namesFreshInExprs names ess h.2⟩ + | .loop g m inv body _ => + unfold Stmt.namesFreshInExprs at h + rw [Bool.and_eq_true, Bool.and_eq_true, Bool.and_eq_true] at h + obtain ⟨⟨⟨_, _⟩, _⟩, h_body⟩ := h + simp only [Stmt.namesFreshInRhsExprs] + exact Block.namesFreshInRhsExprs_of_namesFreshInExprs names body h_body + | .exit _ _ => simp only [Stmt.namesFreshInRhsExprs] + | .funcDecl _ _ => simp only [Stmt.namesFreshInRhsExprs] + | .typeDecl _ _ => simp only [Stmt.namesFreshInRhsExprs] + termination_by sizeOf s + +theorem Block.namesFreshInRhsExprs_of_namesFreshInExprs [HasVarsPure P P.Expr] + (names : List P.Ident) (ss : List (Stmt P (Cmd P))) + (h : Block.namesFreshInExprs names ss = true) : + Block.namesFreshInRhsExprs names ss = true := by + match ss with + | [] => simp only [Block.namesFreshInRhsExprs] + | s :: rest => + simp only [Block.namesFreshInExprs, Bool.and_eq_true] at h + simp only [Block.namesFreshInRhsExprs, Bool.and_eq_true] + exact ⟨Stmt.namesFreshInRhsExprs_of_namesFreshInExprs names s h.1, + Block.namesFreshInRhsExprs_of_namesFreshInExprs names rest h.2⟩ + termination_by sizeOf ss + +end + +mutual +/-- `namesFreshInRhsExprs` is monotone in the `names` subset relation: a +smaller name list is a weaker requirement. -/ +theorem Stmt.namesFreshInRhsExprs_subset + [HasVarsPure P P.Expr] {names₁ names₂ : List P.Ident} + (h_sub : names₁ ⊆ names₂) + (s : Stmt P (Cmd P)) + (h : Stmt.namesFreshInRhsExprs names₂ s = true) : + Stmt.namesFreshInRhsExprs names₁ s = true := by + cases s with + | cmd c => + cases c <;> + · simp only [Stmt.namesFreshInRhsExprs, List.all_eq_true] at h ⊢ + intro z hz; exact h z (h_sub hz) + | block lbl bss md => + simp only [Stmt.namesFreshInRhsExprs] at h ⊢ + exact Block.namesFreshInRhsExprs_subset h_sub bss h + | ite g tss ess md => + simp only [Stmt.namesFreshInRhsExprs, Bool.and_eq_true] at h ⊢ + exact ⟨Block.namesFreshInRhsExprs_subset h_sub tss h.1, + Block.namesFreshInRhsExprs_subset h_sub ess h.2⟩ + | loop g m inv body md => + simp only [Stmt.namesFreshInRhsExprs] at h ⊢ + exact Block.namesFreshInRhsExprs_subset h_sub body h + | exit lbl md => simp only [Stmt.namesFreshInRhsExprs] + | funcDecl d md => simp only [Stmt.namesFreshInRhsExprs] + | typeDecl t md => simp only [Stmt.namesFreshInRhsExprs] + termination_by sizeOf s + +theorem Block.namesFreshInRhsExprs_subset + [HasVarsPure P P.Expr] {names₁ names₂ : List P.Ident} + (h_sub : names₁ ⊆ names₂) + (ss : List (Stmt P (Cmd P))) + (h : Block.namesFreshInRhsExprs names₂ ss = true) : + Block.namesFreshInRhsExprs names₁ ss = true := by + match ss with + | [] => simp only [Block.namesFreshInRhsExprs] + | s :: rest => + simp only [Block.namesFreshInRhsExprs, Bool.and_eq_true] at h ⊢ + exact ⟨Stmt.namesFreshInRhsExprs_subset h_sub s h.1, + Block.namesFreshInRhsExprs_subset h_sub rest h.2⟩ + termination_by sizeOf ss +end + +/-- `Block.namesFreshInRhsExprs` distributes over `++`. -/ +theorem Block.namesFreshInRhsExprs_append + [HasVarsPure P P.Expr] {names : List P.Ident} + (xs ys : List (Stmt P (Cmd P))) + (hx : Block.namesFreshInRhsExprs names xs = true) + (hy : Block.namesFreshInRhsExprs names ys = true) : + Block.namesFreshInRhsExprs names (xs ++ ys) = true := by + induction xs with + | nil => simpa only [List.nil_append] using hy + | cons x rest ih => + simp only [Block.namesFreshInRhsExprs, Bool.and_eq_true] at hx + simp only [List.cons_append, Block.namesFreshInRhsExprs, Bool.and_eq_true] + exact ⟨hx.1, ih hx.2⟩ + +mutual +/-- The empty name list is RHS-fresh in every statement. -/ +theorem Stmt.namesFreshInRhsExprs_nil [HasVarsPure P P.Expr] (s : Stmt P (Cmd P)) : + Stmt.namesFreshInRhsExprs (P := P) [] s = true := by + cases s with + | cmd c => cases c <;> simp only [Stmt.namesFreshInRhsExprs, List.all_nil] + | block lbl bss md => + simp only [Stmt.namesFreshInRhsExprs]; exact Block.namesFreshInRhsExprs_nil bss + | ite g tss ess md => + simp only [Stmt.namesFreshInRhsExprs, Bool.and_eq_true] + exact ⟨Block.namesFreshInRhsExprs_nil tss, Block.namesFreshInRhsExprs_nil ess⟩ + | loop g m inv body md => + simp only [Stmt.namesFreshInRhsExprs]; exact Block.namesFreshInRhsExprs_nil body + | exit lbl md => simp only [Stmt.namesFreshInRhsExprs] + | funcDecl d md => simp only [Stmt.namesFreshInRhsExprs] + | typeDecl t md => simp only [Stmt.namesFreshInRhsExprs] + termination_by sizeOf s + +theorem Block.namesFreshInRhsExprs_nil [HasVarsPure P P.Expr] (ss : List (Stmt P (Cmd P))) : + Block.namesFreshInRhsExprs (P := P) [] ss = true := by + match ss with + | [] => simp only [Block.namesFreshInRhsExprs] + | s :: rest => + simp only [Block.namesFreshInRhsExprs, Bool.and_eq_true] + exact ⟨Stmt.namesFreshInRhsExprs_nil s, Block.namesFreshInRhsExprs_nil rest⟩ + termination_by sizeOf ss +end + +mutual +/-- `namesFreshInRhsExprs` over a `cons` name list splits as the head-singleton +freshness and the tail freshness (the leaf is `names.all`, which splits as +`f hd && tail.all f`). -/ +theorem Stmt.namesFreshInRhsExprs_cons_names + [HasVarsPure P P.Expr] (hd : P.Ident) (tl : List P.Ident) (s : Stmt P (Cmd P)) + (h_hd : Stmt.namesFreshInRhsExprs (P := P) [hd] s = true) + (h_tl : Stmt.namesFreshInRhsExprs (P := P) tl s = true) : + Stmt.namesFreshInRhsExprs (P := P) (hd :: tl) s = true := by + cases s with + | cmd c => + cases c <;> + · simp only [Stmt.namesFreshInRhsExprs, List.all_cons, List.all_nil, + Bool.and_true] at h_hd h_tl ⊢ + exact Bool.and_eq_true _ _ ▸ ⟨h_hd, h_tl⟩ + | block lbl bss md => + simp only [Stmt.namesFreshInRhsExprs] at h_hd h_tl ⊢ + exact Block.namesFreshInRhsExprs_cons_names hd tl bss h_hd h_tl + | ite g tss ess md => + simp only [Stmt.namesFreshInRhsExprs, Bool.and_eq_true] at h_hd h_tl ⊢ + exact ⟨Block.namesFreshInRhsExprs_cons_names hd tl tss h_hd.1 h_tl.1, + Block.namesFreshInRhsExprs_cons_names hd tl ess h_hd.2 h_tl.2⟩ + | loop g m inv body md => + simp only [Stmt.namesFreshInRhsExprs] at h_hd h_tl ⊢ + exact Block.namesFreshInRhsExprs_cons_names hd tl body h_hd h_tl + | exit lbl md => simp only [Stmt.namesFreshInRhsExprs] + | funcDecl d md => simp only [Stmt.namesFreshInRhsExprs] + | typeDecl t md => simp only [Stmt.namesFreshInRhsExprs] + termination_by sizeOf s + +theorem Block.namesFreshInRhsExprs_cons_names + [HasVarsPure P P.Expr] (hd : P.Ident) (tl : List P.Ident) (ss : List (Stmt P (Cmd P))) + (h_hd : Block.namesFreshInRhsExprs (P := P) [hd] ss = true) + (h_tl : Block.namesFreshInRhsExprs (P := P) tl ss = true) : + Block.namesFreshInRhsExprs (P := P) (hd :: tl) ss = true := by + match ss with + | [] => simp only [Block.namesFreshInRhsExprs] + | s :: rest => + simp only [Block.namesFreshInRhsExprs, Bool.and_eq_true] at h_hd h_tl ⊢ + exact ⟨Stmt.namesFreshInRhsExprs_cons_names hd tl s h_hd.1 h_tl.1, + Block.namesFreshInRhsExprs_cons_names hd tl rest h_hd.2 h_tl.2⟩ + termination_by sizeOf ss +end + +/-- Assemble `namesFreshInRhsExprs names ss` from per-name singleton facts. -/ +theorem Block.namesFreshInRhsExprs_of_forall_mem + [HasVarsPure P P.Expr] (names : List P.Ident) (ss : List (Stmt P (Cmd P))) + (h : ∀ z ∈ names, Block.namesFreshInRhsExprs (P := P) [z] ss = true) : + Block.namesFreshInRhsExprs (P := P) names ss = true := by + induction names with + | nil => exact Block.namesFreshInRhsExprs_nil ss + | cons hd tl ih => + exact Block.namesFreshInRhsExprs_cons_names hd tl ss + (h hd (List.mem_cons_self ..)) (ih (fun z hz => h z (List.mem_cons_of_mem _ hz))) + +/-- The freshness predicate the hoisting pass requires: RHS-only freshness +for the body's own init-vars. It uses `namesFreshInRhsExprs` (not the full +`namesFreshInExprs`): the hoisting preservation proof reads back only the +RHS / body-recursion parts of this conjunct, so the guard-read clauses would +be dead weight — and dropping them lets a pass output that reads a fresh +init-var only in a synthesised guard still satisfy the predicate. Guard +freshness for the body's own init-vars is no longer demanded statically: at +every loop head a body-init name is undefined, so an evaluating guard cannot +read it, and the loop driver discharges the guard agreement from that +undefinedness invariant directly. -/ +@[expose] def Block.hoistedNamesFreshInRhsAndGuards [HasVarsPure P P.Expr] + (ss : List (Stmt P (Cmd P))) : Bool := + Block.namesFreshInRhsExprs (Block.initVars ss) ss + +/-! ## Expression shape-freedom predicate `exprsShapeFree` + +A front-end well-formedness assumption on a source program: every variable +read by any expression occurring in the program — `init`/`set` rhs, `assert` +/`assume`/`cover` conditions, loop guards/measures/invariants, `.ite` guards +— is a "kind-free" name: it never satisfies the *kind predicate* `Q` on the +underlying label string (the kind of name *this* pass mints). Instantiating +`Q := String.HasUnderscoreDigitSuffix` recovers the blanket "shape-free" +condition: source programs only mention program names, which never collide +with the generator's freshly-minted naming scheme. A per-kind `Q` lets a +composition argument restrict the obligation to just the labels this pass +mints rather than every gen-suffix-shaped name. + +The predicate is `Prop`-valued (function-form recursion, like +`DisjointModuloRewrite` above) because its leaf condition quantifies over the +`Prop`-valued kind predicate `Q`. It mirrors the recursion shape of +`namesFreshInExprs`, descending into `.block`/`.ite`/`.loop` bodies, +and is threaded through the hoisting-preservation proof exactly like the +source-shape-freedom invariant carried for the carrier names. The discharge +consumer is the `.loop` arm, which needs that the freshly minted harvest +targets (all of kind `Q`) cannot appear among `body`'s read-vars. -/ + +mutual + +/-- "Every read-var occurring in `s` is kind-free": no expression read by `s` +is the identifier of a `Q`-kind label string. -/ +@[expose] def Stmt.exprsShapeFree [HasIdent P] [HasVarsPure P P.Expr] + (Q : String → Prop) + (s : Stmt P (Cmd P)) : Prop := + match s with + | .cmd (.init _ _ rhs _) => + NoGenSuffix (P := P) Q (ExprOrNondet.getVars rhs) + | .cmd (.set _ rhs _) => + NoGenSuffix (P := P) Q (ExprOrNondet.getVars rhs) + | .cmd (.assert _ e _) => + NoGenSuffix (P := P) Q (HasVarsPure.getVars e) + | .cmd (.assume _ e _) => + NoGenSuffix (P := P) Q (HasVarsPure.getVars e) + | .cmd (.cover _ e _) => + NoGenSuffix (P := P) Q (HasVarsPure.getVars e) + | .block _ bss _ => Block.exprsShapeFree Q bss + | .ite g tss ess _ => + NoGenSuffix (P := P) Q (ExprOrNondet.getVars g) ∧ + Block.exprsShapeFree Q tss ∧ Block.exprsShapeFree Q ess + | .loop g m inv body _ => + NoGenSuffix (P := P) Q (ExprOrNondet.getVars g) ∧ + (match m with + | none => True + | some me => NoGenSuffix (P := P) Q (HasVarsPure.getVars me)) ∧ + (∀ p ∈ inv, NoGenSuffix (P := P) Q (HasVarsPure.getVars p.snd)) ∧ + Block.exprsShapeFree Q body + | .exit _ _ => True + | .funcDecl _ _ => True + | .typeDecl _ _ => True + termination_by sizeOf s + +/-- "Every read-var occurring in `ss` is kind-free": pointwise lift of +`Stmt.exprsShapeFree` across the block. -/ +@[expose] def Block.exprsShapeFree [HasIdent P] [HasVarsPure P P.Expr] + (Q : String → Prop) + (ss : List (Stmt P (Cmd P))) : Prop := + match ss with + | [] => True + | s :: rest => + Stmt.exprsShapeFree Q s ∧ Block.exprsShapeFree Q rest + termination_by sizeOf ss + +end + +/-! ## Shape-only freshness helpers + +Name-agnostic helpers over `namesFreshInExprs`. `freshFromIdents_not_mem` is the +membership lemma decoding a freshness predicate's per-name leaf +(`freshFromIdents z vars`) into the negated-membership `z ∉ vars`. -/ + +/-! ### Helper: `freshFromIdents` membership characterisation -/ + +/-- `freshFromIdents z vars = true` implies `z ∉ vars`. -/ +private theorem freshFromIdents_not_mem + {z : P.Ident} {vars : List P.Ident} + (h : freshFromIdents z vars = true) : + z ∉ vars := by + unfold freshFromIdents at h + rw [List.all_eq_true] at h + intro hmem + have h_z := h z hmem + have h_eq : (P.EqIdent z z).decide = true := by simp + rw [h_eq] at h_z + exact absurd h_z (by decide) + +/-- `z ∉ vars` implies `freshFromIdents z vars = true`. -/ +private theorem freshFromIdents_of_not_mem + {z : P.Ident} {vars : List P.Ident} + (h : z ∉ vars) : + freshFromIdents z vars = true := by + unfold freshFromIdents + rw [List.all_eq_true] + intro v hv + have h_ne : z ≠ v := fun heq => h (heq ▸ hv) + have hfalse : (P.EqIdent z v).decide = false := by + rw [decide_eq_false_iff_not]; exact h_ne + simp only [hfalse] + decide + +/-- Public membership characterisation of `freshFromIdents` (both directions), +re-exported (non-`private`) so cross-pass bridges can decode a freshness +predicate's per-name `freshFromIdents` leaf. -/ +theorem freshFromIdents_iff_not_mem + {z : P.Ident} {vars : List P.Ident} : + freshFromIdents z vars = true ↔ z ∉ vars := + ⟨freshFromIdents_not_mem, freshFromIdents_of_not_mem⟩ + +mutual +/-- The empty name list is fresh in every statement's expressions: each leaf is +`[].all _`, which is `true`. -/ +theorem Stmt.namesFreshInExprs_nil [HasVarsPure P P.Expr] (s : Stmt P (Cmd P)) : + Stmt.namesFreshInExprs (P := P) [] s = true := by + cases s with + | cmd c => cases c <;> simp only [Stmt.namesFreshInExprs, List.all_nil] + | block lbl bss md => + simp only [Stmt.namesFreshInExprs]; exact Block.namesFreshInExprs_nil bss + | ite g tss ess md => + simp only [Stmt.namesFreshInExprs, List.all_nil, Bool.true_and, Bool.and_eq_true] + exact ⟨Block.namesFreshInExprs_nil tss, Block.namesFreshInExprs_nil ess⟩ + | loop g m inv body md => + unfold Stmt.namesFreshInExprs + rw [Bool.and_eq_true, Bool.and_eq_true, Bool.and_eq_true] + refine ⟨⟨⟨?_, ?_⟩, ?_⟩, Block.namesFreshInExprs_nil body⟩ + · simp only [List.all_nil] + · cases m <;> simp only [List.all_nil] + · rw [List.all_eq_true]; intro p _; simp only [List.all_nil] + | exit lbl md => simp only [Stmt.namesFreshInExprs] + | funcDecl d md => simp only [Stmt.namesFreshInExprs] + | typeDecl t md => simp only [Stmt.namesFreshInExprs] + termination_by sizeOf s + +theorem Block.namesFreshInExprs_nil [HasVarsPure P P.Expr] (ss : List (Stmt P (Cmd P))) : + Block.namesFreshInExprs (P := P) [] ss = true := by + match ss with + | [] => simp only [Block.namesFreshInExprs] + | s :: rest => + simp only [Block.namesFreshInExprs, Bool.and_eq_true] + exact ⟨Stmt.namesFreshInExprs_nil s, Block.namesFreshInExprs_nil rest⟩ + termination_by sizeOf ss +end + +/-! ### `exprsShapeFree` ⇒ `namesFreshInExprs` for kind-shaped names + +If every name in `names` is the identifier of a `Q`-kind label string, and +`ss` is kind-free (its read-vars are never `Q`-kind idents), then `names` is +fresh in `ss`'s expressions. This is the generic core driving the `.loop` +arm's `h_B_fresh` discharge: the harvest TARGETS are all of this pass's kind, +the source body is kind-free, so the targets cannot appear among the body's +read-vars. -/ + +/-- Local helper: a single `Q`-kind name is fresh in a read-var set, given +that set contains no `Q`-kind ident. -/ +private theorem freshFromIdents_of_shapefree_leaf [HasIdent P] + {Q : String → Prop} + {z : P.Ident} {vars : List P.Ident} + (h_z : ∃ str : String, z = HasIdent.ident str ∧ Q str) + (h_sf : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ vars) : + freshFromIdents z vars = true := by + obtain ⟨str, h_eq, h_suf⟩ := h_z + exact freshFromIdents_of_not_mem (h_eq ▸ h_sf str h_suf) + +mutual +/-- `exprsShapeFree s` plus "every `names` element is a `Q`-kind ident" +implies `names` is fresh in `s`'s expressions. -/ +private theorem Stmt.namesFreshInExprs_of_exprsShapeFree + [HasIdent P] [HasVarsPure P P.Expr] {Q : String → Prop} {names : List P.Ident} + (h_names_suffix : ∀ z ∈ names, + ∃ str : String, z = HasIdent.ident str ∧ Q str) + (s : Stmt P (Cmd P)) + (h : Stmt.exprsShapeFree (P := P) Q s) : + Stmt.namesFreshInExprs names s = true := by + cases s with + | cmd c => + cases c <;> + · simp only [Stmt.exprsShapeFree] at h + simp only [Stmt.namesFreshInExprs, List.all_eq_true] + intro z hz + exact freshFromIdents_of_shapefree_leaf (h_names_suffix z hz) h + | block lbl bss md => + simp only [Stmt.exprsShapeFree] at h + simp only [Stmt.namesFreshInExprs] + exact Block.namesFreshInExprs_of_exprsShapeFree h_names_suffix bss h + | ite g tss ess md => + simp only [Stmt.exprsShapeFree] at h + obtain ⟨h_g, h_tss, h_ess⟩ := h + simp only [Stmt.namesFreshInExprs, Bool.and_eq_true] + refine ⟨⟨?_, ?_⟩, ?_⟩ + · rw [List.all_eq_true] + intro z hz + exact freshFromIdents_of_shapefree_leaf (h_names_suffix z hz) h_g + · exact Block.namesFreshInExprs_of_exprsShapeFree h_names_suffix tss h_tss + · exact Block.namesFreshInExprs_of_exprsShapeFree h_names_suffix ess h_ess + | loop g m inv body md => + unfold Stmt.exprsShapeFree at h + obtain ⟨h_g, h_m, h_inv, h_body⟩ := h + unfold Stmt.namesFreshInExprs + rw [Bool.and_eq_true, Bool.and_eq_true, Bool.and_eq_true] + refine ⟨⟨⟨?_, ?_⟩, ?_⟩, ?_⟩ + · rw [List.all_eq_true] + intro z hz + exact freshFromIdents_of_shapefree_leaf (h_names_suffix z hz) h_g + · cases m with + | none => rfl + | some me => + simp only + rw [List.all_eq_true] + intro z hz + exact freshFromIdents_of_shapefree_leaf (h_names_suffix z hz) h_m + · rw [List.all_eq_true] + intro p hp + rw [List.all_eq_true] + intro z hz + exact freshFromIdents_of_shapefree_leaf (h_names_suffix z hz) (fun str hstr => h_inv p hp str hstr) + · exact Block.namesFreshInExprs_of_exprsShapeFree h_names_suffix body h_body + | exit lbl md => simp only [Stmt.namesFreshInExprs] + | funcDecl d md => simp only [Stmt.namesFreshInExprs] + | typeDecl t md => simp only [Stmt.namesFreshInExprs] + termination_by sizeOf s + +private theorem Block.namesFreshInExprs_of_exprsShapeFree + [HasIdent P] [HasVarsPure P P.Expr] {Q : String → Prop} {names : List P.Ident} + (h_names_suffix : ∀ z ∈ names, + ∃ str : String, z = HasIdent.ident str ∧ Q str) + (ss : List (Stmt P (Cmd P))) + (h : Block.exprsShapeFree (P := P) Q ss) : + Block.namesFreshInExprs names ss = true := by + match ss with + | [] => simp only [Block.namesFreshInExprs] + | s :: rest => + simp only [Block.exprsShapeFree] at h + simp only [Block.namesFreshInExprs, Bool.and_eq_true] + exact ⟨Stmt.namesFreshInExprs_of_exprsShapeFree h_names_suffix s h.1, + Block.namesFreshInExprs_of_exprsShapeFree h_names_suffix rest h.2⟩ + termination_by sizeOf ss +end + +/-- Public form: `exprsShapeFree ss` plus `Q`-kind `names` give freshness in +exprs. Re-exported (non-`private`) so the `.loop` arm's `h_B_fresh` discharge +in the WF layer can consume it. -/ +theorem Block.namesFreshInExprs_of_exprsShapeFree' + [HasIdent P] [HasVarsPure P P.Expr] {Q : String → Prop} {names : List P.Ident} + (h_names_suffix : ∀ z ∈ names, + ∃ str : String, z = HasIdent.ident str ∧ Q str) + (ss : List (Stmt P (Cmd P))) + (h : Block.exprsShapeFree (P := P) Q ss) : + Block.namesFreshInExprs names ss = true := + Block.namesFreshInExprs_of_exprsShapeFree h_names_suffix ss h + +end Imperative diff --git a/Strata/Transform/LoopInitHoistStepBProvider.lean b/Strata/Transform/LoopInitHoistStepBProvider.lean new file mode 100644 index 0000000000..3d65143210 --- /dev/null +++ b/Strata/Transform/LoopInitHoistStepBProvider.lean @@ -0,0 +1,975 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT + + Step B provider — the per-iteration body-simulation vocabulary the loop-init + hoisting correctness proof is built on. This file is load-bearing: it is + imported by `LoopInitHoistBodyTransport` (and transitively by the end-to-end + theorem `hoistLoopPrefixInits_preserves`). + + It defines the eval-carrying per-statement simulation predicate `StmtSimE` and + the SUM-TYPED (terminal-OR-exiting) `BodySimES` / `StmtSimES` vocabulary together + with their combinators (`bodySimES_nil`, `bodySimES_cons`, + `bodySimES_to_bodySimSum`, `nestedLoop_stmtSimES`, and the per-arm + `*_stmtSimES` producers). `Block.bodyTransport` consumes this vocabulary in + every statement arm; the nested-loop arm feeds an inner body simulation — + produced from the same mutual induction — into the renamed-guard loop driver, + so a renamed+lifted loop body (whose guard is rewritten and whose nested loops + are renamed) simulates its source faithfully. +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.DL.Imperative.StmtSemantics +public import Strata.DL.Imperative.CmdSemantics +public import Strata.Transform.LoopInitHoist +public import Strata.Transform.LoopInitHoistContains +public import Strata.Transform.LoopInitHoistFreshness +public import Strata.Transform.LoopInitHoistRewrite +public import Strata.Transform.LoopInitHoistInfra +public import Strata.Transform.LoopInitHoistLoopDriver + +import all Strata.DL.Imperative.Stmt +import all Strata.DL.Imperative.Cmd +import all Strata.Transform.LoopInitHoist +import all Strata.Transform.LoopInitHoistContains +import all Strata.Transform.LoopInitHoistFreshness +import all Strata.Transform.LoopInitHoistRewrite +import all Strata.Transform.LoopInitHoistInfra +import all Strata.Transform.LoopInitHoistLoopDriver + +public section + +namespace Imperative +namespace OptEStepBProvider + +open StructuredToUnstructuredCorrect (extendStoreOne extendStoreOne_self extendStoreOne_other) +open LoopInitHoistLoopDriver (loopDet_lift_renamedGuard_E + loopDet_lift_renamedGuard_TE renamed_guard_eval_same_delta) + +variable {P : PureExpr} + +/-! ## STEP 1 — the per-statement sim. + +A `StmtSimE A B subst s s'` is the single-statement (eval-carrying) terminal-only +simulation predicate (run the ONE statement `s` against `s'` from any +`HoistInv`-related entry, terminal to terminal, preserving eval). This is the +shape `stmtSimE_to_stmtSimES_of_noExit` lifts into the sum-typed `StmtSimES` for a +source statement that can never `.exiting` (e.g. a `.cmd`), so the sum-typed cons +sequencer `bodySimES_cons` can stitch it into the whole-body `BodySimES`. -/ +@[expose] def StmtSimE [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) + (s s' : Stmt P (Cmd P)) : Prop := + ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + ∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmt s' ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) ∧ + ρ_s'.eval = ρ_h'.eval + +/-! ## SUM-TYPED (terminal-OR-exiting) body/statement simulation. + +The `StmtSimE` predicate above is TERMINAL-ONLY by construction: it says nothing +about a statement that runs to `.exiting l ρ'` (the break pattern). +The redesigned `loopDet_lift_*_E` driver family (which drops `h_src_body_no_exit`) +consumes the sum-typed `BodySimSum`; to PRODUCE one from a `BodyTransport` +derivation, the eval-carrying provider vocabulary must also gain the exiting +clause. + +`BodySimES` / `StmtSimES` are the eval-carrying, SUM-TYPED analogues: each carries +the existing terminal clause AND a parallel exiting clause that matches a source +`.exiting l ρ_s'` run by a hoist `.exiting l ρ_h'` run at the SAME label `l`, +re-establishing `HoistInv` / `hasFailure` / `B`-boundedness / `eval` at the +body-exit stores. This is the exact relation the §E mutual already carries on +its `.exiting` disjunct (the body-exit `HoistInv`, NOT the weaker projected-store +`StoreAgreement`), so the enclosing loop's `.block .none` projection re-establishes +`HoistInv` via `HoistInv.project_both` exactly as the terminal clause does. -/ + +/-- Eval-carrying SUM-TYPED body sim: a terminal clause (source `.terminal` matched +by hoist `.terminal`), plus an exiting clause (a source `.exiting l` run is matched +by a hoist `.exiting l` run at the SAME label), each with `HoistInv` / `hasFailure` / +`B`-bound / `eval` agreement at the body-exit stores. -/ +@[expose] def BodySimES [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) + (bsrc bh : List (Stmt P (Cmd P))) : Prop := + ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + -- TERMINAL clause: + (∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts bsrc ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts bh ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) ∧ + ρ_s'.eval = ρ_h'.eval) + ∧ + -- EXITING clause (new): + (∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmts bsrc ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmts bh ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) ∧ + ρ_s'.eval = ρ_h'.eval) + +/-- Eval-carrying SUM-TYPED single-statement sim (the `StmtSimE` analogue, with the +parallel exiting clause). -/ +@[expose] def StmtSimES [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) + (s s' : Stmt P (Cmd P)) : Prop := + ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + (∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ_s) (.terminal ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmt s' ρ_h) (.terminal ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) ∧ + ρ_s'.eval = ρ_h'.eval) + ∧ + (∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ_s) (.exiting l ρ_s') → + ∃ ρ_h' : Env P, + StepStmtStar P (EvalCmd P) extendEval (.stmt s' ρ_h) (.exiting l ρ_h') ∧ + HoistInv (P := P) A B subst ρ_s'.store ρ_h'.store ∧ + ρ_s'.hasFailure = ρ_h'.hasFailure ∧ (∀ y ∈ B, ρ_h'.store y ≠ none) ∧ + ρ_s'.eval = ρ_h'.eval) + +/-- Forget the eval conjunct: `BodySimES → BodySimSum` (drops into the sum-typed +driver `loopDet_lift_2g_E`'s `body_sim` slot). -/ +theorem bodySimES_to_bodySimSum [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {bsrc bh : List (Stmt P (Cmd P))} + (h : BodySimES (extendEval := extendEval) A B subst bsrc bh) : + LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) A B subst bsrc bh := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd + obtain ⟨h_term, h_exit⟩ := h ρ_s ρ_h h_hinv h_eval h_hf h_bnd + refine ⟨?_, ?_⟩ + · intro ρ_s' h_run + obtain ⟨ρ_h', h_run_h, h_hinv', h_hf', h_bnd', _⟩ := h_term ρ_s' h_run + exact ⟨ρ_h', h_run_h, h_hinv', h_hf', h_bnd'⟩ + · intro l ρ_s' h_run + obtain ⟨ρ_h', h_run_h, h_hinv', h_hf', h_bnd', _⟩ := h_exit l ρ_s' h_run + exact ⟨ρ_h', h_run_h, h_hinv', h_hf', h_bnd'⟩ + +/-- The empty body is a `BodySimES`: terminal stays terminal (the only run is +`step_stmts_nil` to `.terminal`, so the hoist replays it), and the empty body NEVER +reaches `.exiting`, so the exiting clause is vacuous. -/ +theorem bodySimES_nil [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) : + BodySimES (extendEval := extendEval) A B subst [] [] := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd + refine ⟨?_, ?_⟩ + · -- terminal clause: the empty body's only run is `step_stmts_nil` to `.terminal`. + intro ρ_s' h_run + have h_eq : ρ_s' = ρ_s := by + cases h_run with + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | refl => rfl + | step _ _ _ hd _ => exact nomatch hd + subst h_eq + refine ⟨ρ_h, ?_, h_hinv, h_hf, h_bnd, h_eval⟩ + exact ReflTrans.step _ _ _ StepStmt.step_stmts_nil (ReflTrans.refl _) + · -- exiting clause: the empty body cannot reach `.exiting`. + intro l ρ_s' h_run + exfalso + cases h_run with + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | step _ _ _ hd _ => exact nomatch hd + +/-- THE SUM-TYPED CONS-SEQUENCER: a head `StmtSimES` and a tail `BodySimES` compose +into a `BodySimES` for the cons body. + +The terminal clause sequences the head's terminal clause then the tail's, splicing +the two hoist runs. The exiting clause: +a cons-run reaching `.exiting l ρ_s'` steps `.stmts (s :: rest) → .seq (.stmt s ρ_s) rest`, +then by `seq_reaches_exiting` either + (a) the HEAD exits (`.stmt s ρ_s →* .exiting l ρ_s'`): fire the head's exiting + clause → hoist head exits → reassemble the hoist cons-run's exit (`step_stmts_cons` + then `seq_inner_star` then `step_seq_exit`); or + (b) the head terminates to `ρ_mid` and the TAIL exits: fire the head's terminal + clause (yielding mid `HoistInv`/eval/hf/bound), then the tail's exiting clause + from the mid env, and splice the hoist head-run (terminal) with the hoist + tail-run (exit) via `stmts_cons_step` then the tail. -/ +theorem bodySimES_cons [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {s s' : Stmt P (Cmd P)} {rest rest' : List (Stmt P (Cmd P))} + (hhead : StmtSimES (extendEval := extendEval) A B subst s s') + (htail : BodySimES (extendEval := extendEval) A B subst rest rest') : + BodySimES (extendEval := extendEval) A B subst (s :: rest) (s' :: rest') := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd + refine ⟨?_, ?_⟩ + · -- terminal clause: head terminal then tail terminal. + intro ρ_s' h_run + obtain ⟨ρ_mid, h_head_run, h_rest_run⟩ := + stmts_cons_terminal_inv (extendEval := extendEval) h_run + obtain ⟨ρ_h_mid, h_head_h_run, h_hinv_mid, h_hf_mid, h_bnd_mid, h_eval_mid⟩ := + (hhead ρ_s ρ_h h_hinv h_eval h_hf h_bnd).1 ρ_mid h_head_run + obtain ⟨ρ_h', h_rest_h_run, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (htail ρ_mid ρ_h_mid h_hinv_mid h_eval_mid h_hf_mid h_bnd_mid).1 ρ_s' h_rest_run + refine ⟨ρ_h', ?_, h_hinv', h_hf', h_bnd', h_eval'⟩ + exact ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval s' rest' ρ_h ρ_h_mid h_head_h_run) + h_rest_h_run + · -- exiting clause. + intro l ρ_s' h_run + -- `.stmts (s :: rest) ρ_s → .seq (.stmt s ρ_s) rest → … → .exiting l ρ_s'`. + have h_seq : StepStmtStar P (EvalCmd P) extendEval + (.seq (.stmt s ρ_s) rest) (.exiting l ρ_s') := by + cases h_run with + | step _ _ _ h1 hr1 => cases h1; exact hr1 + rcases seq_reaches_exiting P (EvalCmd P) extendEval h_seq with + h_head_exit | ⟨ρ_mid, h_head_term, h_tail_exit⟩ + · -- (a) the head exits with `l`. + obtain ⟨ρ_h', h_head_h_exit, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (hhead ρ_s ρ_h h_hinv h_eval h_hf h_bnd).2 l ρ_s' h_head_exit + refine ⟨ρ_h', ?_, h_hinv', h_hf', h_bnd', h_eval'⟩ + -- reassemble: `.stmts (s' :: rest') ρ_h → .seq (.stmt s' ρ_h) rest' → … → .exiting`. + refine ReflTrans.step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_head_h_exit) ?_ + exact ReflTrans.step _ _ _ StepStmt.step_seq_exit (ReflTrans.refl _) + · -- (b) the head terminates to `ρ_mid`, the tail exits with `l`. + obtain ⟨ρ_h_mid, h_head_h_run, h_hinv_mid, h_hf_mid, h_bnd_mid, h_eval_mid⟩ := + (hhead ρ_s ρ_h h_hinv h_eval h_hf h_bnd).1 ρ_mid h_head_term + obtain ⟨ρ_h', h_tail_h_exit, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (htail ρ_mid ρ_h_mid h_hinv_mid h_eval_mid h_hf_mid h_bnd_mid).2 l ρ_s' h_tail_exit + refine ⟨ρ_h', ?_, h_hinv', h_hf', h_bnd', h_eval'⟩ + -- splice the hoist head-run (terminal) with the hoist tail-run (exit). + exact ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval s' rest' ρ_h ρ_h_mid h_head_h_run) + h_tail_h_exit + +/-! ## FAILING-config body / statement simulation. + +The `_to_fail` siblings of `BodySimES` / `StmtSimES`. A `BodySimFail` says: from +any `HoistInv`-related entry (eval / `hasFailure` agreement, `B`-boundedness), a +source body run reaching a *failing* configuration (`getEnv.hasFailure = true`, +possibly intermediate on a never-terminating run) is matched by a hoist body run +reaching a failing configuration. No `HoistInv` / eval re-establishment at the +failing point is needed — the conclusion only asserts the hoist side fails too. + +The cons sequencer `bodySimFail_cons` mirrors `stmts_cons_reaches_failing'`: a +failing cons run either has the HEAD failing (discharged by the head's +`StmtSimFail`) or the head terminates (discharged by the head's existing terminal +`StmtSimES` clause, re-establishing `HoistInv`) and the TAIL fails (tail +`BodySimFail`). -/ + +/-- Failing-config single-statement sim: a source `.stmt s` run reaching a failing +config is matched by a hoist `.stmt s'` run reaching a failing config. -/ +@[expose] def StmtSimFail [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) + (s s' : Stmt P (Cmd P)) : Prop := + ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + ∀ (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ_s) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmt s' ρ_h) d' + ∧ d'.getEnv.hasFailure = true + +/-- Failing-config body sim: a source `.stmts bsrc` run reaching a failing config is +matched by a hoist `.stmts bh` run reaching a failing config. -/ +@[expose] def BodySimFail [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) + (bsrc bh : List (Stmt P (Cmd P))) : Prop := + ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → + ρ_s.eval = ρ_h.eval → ρ_s.hasFailure = ρ_h.hasFailure → + (∀ y ∈ B, ρ_h.store y ≠ none) → + ∀ (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmts bsrc ρ_s) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts bh ρ_h) d' + ∧ d'.getEnv.hasFailure = true + +/-- The empty body's only run is `step_stmts_nil` to `.terminal ρ_s`; a failing +config forces `ρ_s.hasFailure = true`, so the hoist empty body's start (failing by +`h_hf`) is itself a failing reachable config (`refl`). -/ +theorem bodySimFail_nil [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) : + BodySimFail (extendEval := extendEval) A B subst [] [] := by + intro ρ_s ρ_h _ _ h_hf _ d h_run hd + -- Every config reached from `.stmts [] ρ_s` has env `ρ_s`, so `ρ_s.hasFailure = true`. + have h_ρs_fail : ρ_s.hasFailure = true := by + cases h_run with + | refl => simpa [Config.getEnv] using hd + | step _ _ _ h1 hr1 => + cases h1 + have h_d_eq : d = .terminal ρ_s := by + cases hr1 with + | refl => rfl + | step _ _ _ hd' _ => exact nomatch hd' + rw [h_d_eq] at hd; simpa [Config.getEnv] using hd + refine ⟨.stmts [] ρ_h, .refl _, ?_⟩ + simpa [Config.getEnv] using (h_hf ▸ h_ρs_fail) + +/-- THE FAILING CONS-SEQUENCER: a head `StmtSimES` (terminal+exiting), a head +`StmtSimFail`, and a tail `BodySimFail` compose into a `BodySimFail` for the cons +body. By `stmts_cons_reaches_failing'`, a failing cons run either has the head +failing (use the head `StmtSimFail`, then lift the failing hoist head run into the +cons frame) or the head terminates to `ρ_mid` (use the head's terminal `StmtSimES` +clause to re-establish `HoistInv` at the hoist mid env, then the tail `BodySimFail` +from there, splicing the hoist head-terminal run before the failing tail run). -/ +theorem bodySimFail_cons [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {s s' : Stmt P (Cmd P)} {rest rest' : List (Stmt P (Cmd P))} + (hhead_es : StmtSimES (extendEval := extendEval) A B subst s s') + (hhead_fail : StmtSimFail (extendEval := extendEval) A B subst s s') + (htail : BodySimFail (extendEval := extendEval) A B subst rest rest') : + BodySimFail (extendEval := extendEval) A B subst (s :: rest) (s' :: rest') := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd d h_run hd + rcases stmts_cons_reaches_failing' P (EvalCmd P) extendEval (reflTrans_to_T h_run) hd with + hA | ⟨ρ_mid, d_rest, h_head_term, h_rest_run, hd_rest⟩ + · -- HEAD fails. The hoist head reaches a failing config; lift into the cons frame. + obtain ⟨d_head, h_head_run, hd_head⟩ := hA + obtain ⟨d_h, h_head_h_run, hd_h_fail⟩ := + hhead_fail ρ_s ρ_h h_hinv h_eval h_hf h_bnd d_head h_head_run hd_head + -- `.stmts (s' :: rest') ρ_h → .seq (.stmt s' ρ_h) rest' → … → .seq d_h rest'`. + refine ⟨.seq d_h rest', ?_, by simpa [Config.getEnv] using hd_h_fail⟩ + exact .step _ _ _ StepStmt.step_stmts_cons + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_head_h_run) + · -- HEAD terminates to `ρ_mid`; the TAIL fails from `ρ_mid`. + obtain ⟨ρ_h_mid, h_head_h_run, h_hinv_mid, h_hf_mid, h_bnd_mid, h_eval_mid⟩ := + (hhead_es ρ_s ρ_h h_hinv h_eval h_hf h_bnd).1 ρ_mid h_head_term + obtain ⟨d_h, h_tail_h_run, hd_h_fail⟩ := + htail ρ_mid ρ_h_mid h_hinv_mid h_eval_mid h_hf_mid h_bnd_mid d_rest h_rest_run hd_rest + -- splice the hoist head-run (terminal) with the failing hoist tail-run. + refine ⟨d_h, ?_, hd_h_fail⟩ + exact ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval s' rest' ρ_h ρ_h_mid h_head_h_run) + h_tail_h_run + +/-! ## SUM-TYPED nested-loop `StmtSimES`. + +A nested loop `.loop (.det g2) none [] inner` reaches `.exiting l` exactly when its +OWN body `inner` breaks with a label `l` (a loop has no catching label, so a body +`.exit` propagates straight through). The terminal clause fires +`loopDet_lift_renamedGuard_TE` (consuming the inner body's TERMINAL clause); the +exiting clause fires `loopDet_lift_renamedGuard_E` on the inner body's SUM-TYPED +sim, then recovers eval-preservation from both loop runs (`noFuncDecl` ⇒ eval fixed). + +The inner-body simulation is supplied as a `BodySimSum` (the SELF-REFERENTIAL piece: +in the real §E mutual it comes from the same mutual recursion on the strictly-smaller +inner body, now sum-typed). -/ +theorem nestedLoop_stmtSimES [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {g2 : P.Expr} {inner inner_h : List (Stmt P (Cmd P))} {md2_s md2_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_g_B_fresh : ∀ z ∈ B, z ∉ HasVarsPure.getVars g2) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + -- the inner body's SUM-TYPED sim (self-referential piece — the §E IH on the + -- SMALLER body, now terminal-OR-exiting): + (inner_sim : LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) A B subst inner inner_h) + (h_nofd_src : Block.noFuncDecl inner = true) + (h_nofd_h : Block.noFuncDecl inner_h = true) : + StmtSimES (extendEval := extendEval) A B subst + (.loop (.det g2) none [] inner md2_s) + (.loop (.det (substFvarMany g2 subst)) none [] inner_h md2_h) := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd + have h_src_nofd_loop : Stmt.noFuncDecl (.loop (.det g2) none [] inner md2_s) = true := by + simp only [Stmt.noFuncDecl]; exact h_nofd_src + have h_h_nofd_loop : + Stmt.noFuncDecl (.loop (.det (substFvarMany g2 subst)) none [] inner_h md2_h) = true := by + simp only [Stmt.noFuncDecl]; exact h_nofd_h + refine ⟨?_, ?_⟩ + · -- terminal clause: the inner-body sum-typed sim feeds `loopDet_lift_renamedGuard_TE` + -- (a nested loop CAN exit, so we route through the sum-typed terminal driver, + -- which peels iterations WITHOUT a no-exit hypothesis — a `.none`-block reaching + -- `.terminal` forces an inner `.terminal`, capping any would-be break). + intro ρ_s' h_run + obtain ⟨ρ_h', h_loop_h_run, h_hinv', h_hf', h_bnd'⟩ := + loopDet_lift_renamedGuard_TE (A := A) (B := B) (subst := subst) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup h_g_B_fresh + h_wfvar h_wfcongr h_wfsubst h_wfdef + inner_sim h_nofd_src h_nofd_h + h_hinv h_eval h_hf h_bnd h_run + refine ⟨ρ_h', h_loop_h_run, h_hinv', h_hf', h_bnd', ?_⟩ + have e_s : ρ_s'.eval = ρ_s.eval := + smallStep_noFuncDecl_preserves_eval P (EvalCmd P) extendEval _ ρ_s ρ_s' h_src_nofd_loop h_run + have e_h : ρ_h'.eval = ρ_h.eval := + smallStep_noFuncDecl_preserves_eval P (EvalCmd P) extendEval _ ρ_h ρ_h' h_h_nofd_loop h_loop_h_run + rw [e_s, e_h]; exact h_eval + · -- exiting clause: the inner-body SUM-TYPED sim feeds `loopDet_lift_renamedGuard_E`. + intro l ρ_s' h_run + obtain ⟨ρ_h', h_loop_h_run, h_hinv', h_hf', h_bnd'⟩ := + loopDet_lift_renamedGuard_E (A := A) (B := B) (subst := subst) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup h_g_B_fresh + h_wfvar h_wfcongr h_wfsubst h_wfdef + inner_sim h_nofd_src h_nofd_h + h_hinv h_eval h_hf h_bnd h_run + refine ⟨ρ_h', h_loop_h_run, h_hinv', h_hf', h_bnd', ?_⟩ + have e_s : ρ_s'.eval = ρ_s.eval := + smallStep_noFuncDecl_preserves_eval_exiting P (EvalCmd P) extendEval _ ρ_s ρ_s' l h_src_nofd_loop h_run + have e_h : ρ_h'.eval = ρ_h.eval := + smallStep_noFuncDecl_preserves_eval_exiting P (EvalCmd P) extendEval _ ρ_h ρ_h' l h_h_nofd_loop h_loop_h_run + rw [e_s, e_h]; exact h_eval + +/-- Generic lifter: a terminal-only `StmtSimE s s'` whose SOURCE statement `s` can +NEVER reach `.exiting` lifts to a sum-typed `StmtSimES s s'` — the exiting clause is +vacuous. This is what every `.cmd` arm (init/set/assert/assume/cover/typeDecl) of +`Block.bodyTransport` needs: a command steps only to `.terminal` (`step_cmd`), so it +never `.exiting`s, and its existing `StmtSimE` lifts for free. -/ +theorem stmtSimE_to_stmtSimES_of_noExit [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {s s' : Stmt P (Cmd P)} + (h_src_no_exit : ∀ (ρ : Env P) (l : String) (ρe : Env P), + ¬ StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (.exiting l ρe)) + (h : StmtSimE (extendEval := extendEval) A B subst s s') : + StmtSimES (extendEval := extendEval) A B subst s s' := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd + refine ⟨?_, ?_⟩ + · intro ρ_s' h_run; exact h ρ_s ρ_h h_hinv h_eval h_hf h_bnd ρ_s' h_run + · intro l ρ_s' h_run; exact absurd h_run (h_src_no_exit ρ_s l ρ_s') + +/-- A single `.cmd` statement never reaches `.exiting` (it steps to `.terminal` via +`step_cmd` and is then stuck). -/ +theorem cmd_stmt_no_exit [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (c : Cmd P) : + ∀ (ρ : Env P) (l : String) (ρe : Env P), + ¬ StepStmtStar P (EvalCmd P) extendEval (.stmt (.cmd c) ρ) (.exiting l ρe) := by + intro ρ l ρe h + cases h with + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | step _ _ _ hd _ => exact nomatch hd + +/-! ## FAILING `StmtSimFail` producers (per statement kind). + +For an ATOMIC statement (`.cmd` / `.typeDecl` / `.exit`) a failing reachable +config is either the start (`refl`, so `ρ_s` already fails) or a terminal/exiting +ENDPOINT; the corresponding endpoint clause of the head `StmtSimES` transports the +failure flag. For `.block` / `.ite` / nested-`.loop` the failure can be INTERNAL, +discharged by the inner body's own `BodySimFail` (recursion). -/ + +/-- Generic atomic lifter: a statement `s` whose every failing reachable config is +the start (`refl`) or a terminal/exiting endpoint has `StmtSimFail` derivable from +its `StmtSimES`. The `h_endpoint_inv` hypothesis captures the atomicity. -/ +theorem stmtSimFail_of_stmtSimES_atomic [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {s s' : Stmt P (Cmd P)} + (h_endpoint_inv : ∀ (ρ : Env P) (d : Config P (Cmd P)), + StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) d → + d.getEnv.hasFailure = true → + ρ.hasFailure = true ∨ + (∃ ρ', StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (.terminal ρ') ∧ + ρ'.hasFailure = true) ∨ + (∃ l ρ', StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (.exiting l ρ') ∧ + ρ'.hasFailure = true)) + (h_es : StmtSimES (extendEval := extendEval) A B subst s s') : + StmtSimFail (extendEval := extendEval) A B subst s s' := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd d h_run hd + rcases h_endpoint_inv ρ_s d h_run hd with h_ρs | ⟨ρ', h_term, h_fail⟩ | ⟨l, ρ', h_exit, h_fail⟩ + · -- ρ_s already failing → the hoist start is failing too. + refine ⟨.stmt s' ρ_h, .refl _, ?_⟩ + simpa [Config.getEnv] using (h_hf ▸ h_ρs) + · -- terminal endpoint: the head terminal clause transports the failure flag. + obtain ⟨ρ_h', h_h_run, _, h_hf', _, _⟩ := (h_es ρ_s ρ_h h_hinv h_eval h_hf h_bnd).1 ρ' h_term + refine ⟨.terminal ρ_h', h_h_run, ?_⟩ + simpa [Config.getEnv] using (h_hf' ▸ h_fail) + · -- exiting endpoint: the head exiting clause transports the failure flag. + obtain ⟨ρ_h', h_h_run, _, h_hf', _, _⟩ := (h_es ρ_s ρ_h h_hinv h_eval h_hf h_bnd).2 l ρ' h_exit + refine ⟨.exiting l ρ_h', h_h_run, ?_⟩ + simpa [Config.getEnv] using (h_hf' ▸ h_fail) + +/-- A `.cmd c` run reaching a failing config: either `refl` (start fails) or one +`step_cmd` to a failing `.terminal`. (`.cmd` never `.exiting`s.) -/ +theorem cmd_endpoint_inv [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (c : Cmd P) (ρ : Env P) (d : Config P (Cmd P)) + (h_run : StepStmtStar P (EvalCmd P) extendEval (.stmt (.cmd c) ρ) d) + (hd : d.getEnv.hasFailure = true) : + ρ.hasFailure = true ∨ + (∃ ρ', StepStmtStar P (EvalCmd P) extendEval (.stmt (.cmd c) ρ) (.terminal ρ') ∧ + ρ'.hasFailure = true) ∨ + (∃ l ρ', StepStmtStar P (EvalCmd P) extendEval (.stmt (.cmd c) ρ) (.exiting l ρ') ∧ + ρ'.hasFailure = true) := by + match h_run with + | .refl _ => exact Or.inl (by simpa [Config.getEnv] using hd) + | .step _ _ _ (StepStmt.step_cmd h_cmd) hr1 => + -- after one `step_cmd`, the mid config is a `.terminal`; `hr1` from it stays there. + match hr1 with + | .refl _ => + exact Or.inr (Or.inl ⟨_, .step _ _ _ (StepStmt.step_cmd h_cmd) (.refl _), + by simpa [Config.getEnv] using hd⟩) + | .step _ _ _ hd' _ => exact nomatch hd' + +/-- A `.cmd c` statement's `StmtSimFail` from its `StmtSimES` (the head sim already +proven for the `.cmd` arm of `Block.bodyTransport`). -/ +theorem cmd_stmtSimFail [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} {c c' : Cmd P} + (h_es : StmtSimES (extendEval := extendEval) A B subst (.cmd c) (.cmd c')) : + StmtSimFail (extendEval := extendEval) A B subst (.cmd c) (.cmd c') := + stmtSimFail_of_stmtSimES_atomic (cmd_endpoint_inv c) h_es + +/-! ## The `.ite` arms of a sum-typed `StmtSimES`. + +An `.ite` steps to its taken branch body `.stmts tss/ess ρ` in the SAME store (no +block wrapper — branch-locals are not projected). So an `.ite` reaches `.exiting l` +exactly when the taken branch exits with `l`, propagated verbatim. The det-guard +arm transports the guard via the supplied `h_guard_eq` (the renamed guard evaluates as +the source guard, exactly the `cond_transport'` fact `Block.bodyTransport`'s `.ite` +arm computes); the nondet arm replays the same branch choice. -/ +theorem ite_stmtSimES [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {g : P.Expr} {tss_s tss_h ess_s ess_h : List (Stmt P (Cmd P))} {md : MetaData P} + -- the renamed guard evaluates as the source guard under any HoistInv-related + -- entry with eval-equality (the `cond_transport'` fact): + (h_guard_eq : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∃ w, ρ_s.eval ρ_s.store g = some w) → + ρ_s.eval ρ_s.store g = ρ_h.eval ρ_h.store (substFvarMany g subst)) + (then_sim : BodySimES (extendEval := extendEval) A B subst tss_s tss_h) + (else_sim : BodySimES (extendEval := extendEval) A B subst ess_s ess_h) : + StmtSimES (extendEval := extendEval) A B subst + (.ite (.det g) tss_s ess_s md) + (.ite (.det (substFvarMany g subst)) tss_h ess_h md) := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd + -- Peel the source `.ite` step into a branch run (guard tt → then, ff → else). The + -- `.refl` case is impossible: a target reaching `.terminal`/`.exiting` differs from + -- the un-stepped `.stmt (.ite …)`, so any such run takes the ite step first. + have peel : ∀ {ρ' : Env P} {tgt : Config P (Cmd P)}, + (tgt = .terminal ρ' ∨ ∃ l, tgt = .exiting l ρ') → + StepStmtStar P (EvalCmd P) extendEval (.stmt (.ite (.det g) tss_s ess_s md) ρ_s) tgt → + (ρ_s.eval ρ_s.store g = .some HasBool.tt ∧ WellFormedSemanticEvalBool ρ_s.eval ∧ + StepStmtStar P (EvalCmd P) extendEval (.stmts tss_s ρ_s) tgt) ∨ + (ρ_s.eval ρ_s.store g = .some HasBool.ff ∧ WellFormedSemanticEvalBool ρ_s.eval ∧ + StepStmtStar P (EvalCmd P) extendEval (.stmts ess_s ρ_s) tgt) := by + intro ρ' tgt htgt h + cases h with + | refl => rcases htgt with h | ⟨l, h⟩ <;> exact nomatch h + | step _ _ _ h1 hr1 => + cases h1 with + | step_ite_true hg hwf => exact .inl ⟨hg, hwf, hr1⟩ + | step_ite_false hg hwf => exact .inr ⟨hg, hwf, hr1⟩ + -- The hoist guard equals the source guard's value (transported). + have guard_h : ∀ {bv : P.Expr}, ρ_s.eval ρ_s.store g = .some bv → + ρ_h.eval ρ_h.store (substFvarMany g subst) = .some bv := by + intro bv hg + have := h_guard_eq ρ_s ρ_h h_hinv h_eval ⟨_, hg⟩ + rw [hg] at this; exact this.symm + refine ⟨?_, ?_⟩ + · -- terminal clause. + intro ρ_s' h_run + rcases peel (Or.inl rfl) h_run with ⟨hg, hwf, h_branch⟩ | ⟨hg, hwf, h_branch⟩ + · obtain ⟨ρ_h', h_branch_h, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (then_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).1 ρ_s' h_branch + refine ⟨ρ_h', ?_, h_hinv', h_hf', h_bnd', h_eval'⟩ + exact ReflTrans.step _ _ _ (StepStmt.step_ite_true (guard_h hg) (h_eval ▸ hwf)) h_branch_h + · obtain ⟨ρ_h', h_branch_h, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (else_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).1 ρ_s' h_branch + refine ⟨ρ_h', ?_, h_hinv', h_hf', h_bnd', h_eval'⟩ + exact ReflTrans.step _ _ _ (StepStmt.step_ite_false (guard_h hg) (h_eval ▸ hwf)) h_branch_h + · -- exiting clause. + intro l ρ_s' h_run + rcases peel (Or.inr ⟨l, rfl⟩) h_run with ⟨hg, hwf, h_branch⟩ | ⟨hg, hwf, h_branch⟩ + · obtain ⟨ρ_h', h_branch_h, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (then_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).2 l ρ_s' h_branch + refine ⟨ρ_h', ?_, h_hinv', h_hf', h_bnd', h_eval'⟩ + exact ReflTrans.step _ _ _ (StepStmt.step_ite_true (guard_h hg) (h_eval ▸ hwf)) h_branch_h + · obtain ⟨ρ_h', h_branch_h, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (else_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).2 l ρ_s' h_branch + refine ⟨ρ_h', ?_, h_hinv', h_hf', h_bnd', h_eval'⟩ + exact ReflTrans.step _ _ _ (StepStmt.step_ite_false (guard_h hg) (h_eval ▸ hwf)) h_branch_h + +/-- The nondet-guard `.ite` arm: no guard test; the hoist replays the SAME branch +choice (then/else) the source took. -/ +theorem ite_nondet_stmtSimES [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {tss_s tss_h ess_s ess_h : List (Stmt P (Cmd P))} {md : MetaData P} + (then_sim : BodySimES (extendEval := extendEval) A B subst tss_s tss_h) + (else_sim : BodySimES (extendEval := extendEval) A B subst ess_s ess_h) : + StmtSimES (extendEval := extendEval) A B subst + (.ite .nondet tss_s ess_s md) (.ite .nondet tss_h ess_h md) := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd + have peel : ∀ {ρ' : Env P} {tgt : Config P (Cmd P)}, + (tgt = .terminal ρ' ∨ ∃ l, tgt = .exiting l ρ') → + StepStmtStar P (EvalCmd P) extendEval (.stmt (.ite .nondet tss_s ess_s md) ρ_s) tgt → + (StepStmtStar P (EvalCmd P) extendEval (.stmts tss_s ρ_s) tgt) ∨ + (StepStmtStar P (EvalCmd P) extendEval (.stmts ess_s ρ_s) tgt) := by + intro ρ' tgt htgt h + cases h with + | refl => rcases htgt with h | ⟨l, h⟩ <;> exact nomatch h + | step _ _ _ h1 hr1 => + cases h1 with + | step_ite_nondet_true => exact .inl hr1 + | step_ite_nondet_false => exact .inr hr1 + refine ⟨?_, ?_⟩ + · intro ρ_s' h_run + rcases peel (Or.inl rfl) h_run with h_branch | h_branch + · obtain ⟨ρ_h', h_branch_h, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (then_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).1 ρ_s' h_branch + exact ⟨ρ_h', ReflTrans.step _ _ _ StepStmt.step_ite_nondet_true h_branch_h, + h_hinv', h_hf', h_bnd', h_eval'⟩ + · obtain ⟨ρ_h', h_branch_h, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (else_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).1 ρ_s' h_branch + exact ⟨ρ_h', ReflTrans.step _ _ _ StepStmt.step_ite_nondet_false h_branch_h, + h_hinv', h_hf', h_bnd', h_eval'⟩ + · intro l ρ_s' h_run + rcases peel (Or.inr ⟨l, rfl⟩) h_run with h_branch | h_branch + · obtain ⟨ρ_h', h_branch_h, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (then_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).2 l ρ_s' h_branch + exact ⟨ρ_h', ReflTrans.step _ _ _ StepStmt.step_ite_nondet_true h_branch_h, + h_hinv', h_hf', h_bnd', h_eval'⟩ + · obtain ⟨ρ_h', h_branch_h, h_hinv', h_hf', h_bnd', h_eval'⟩ := + (else_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).2 l ρ_s' h_branch + exact ⟨ρ_h', ReflTrans.step _ _ _ StepStmt.step_ite_nondet_false h_branch_h, + h_hinv', h_hf', h_bnd', h_eval'⟩ + +/-! ## The `.block` arm of a sum-typed `StmtSimES` (the hard extension). + +This is the arm the StepC-producer comment names as "the hard extension". A +`.block lbl inner` whose inner body can `.exit` has THREE outcomes: + (T1) inner `.terminal` → block `.terminal` (projected); + (T2) inner `.exiting lbl` (matches the block label) → block CATCHES it → + `.terminal` (projected) — this is the previously-unhandled case; + (X) inner `.exiting l` with `l ≠ lbl` (mismatch) → block PROPAGATES `.exiting l` + (projected). +Given a `BodySimES` for the inner body, all three close: the hoist block replays the +same inner outcome (terminal/match/mismatch) at the SAME label, and `HoistInv` survives +the projection via `HoistInv.project_both`. -/ +theorem block_stmtSimES [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {lbl : String} {inner inner_h : List (Stmt P (Cmd P))} {md : MetaData P} + (inner_sim : BodySimES (extendEval := extendEval) A B subst inner inner_h) : + StmtSimES (extendEval := extendEval) A B subst + (.block lbl inner md) (.block lbl inner_h md) := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd + -- A `b ∈ B` survives the projection `projectStore ρ_h.store · b`: the parent binds + -- `b` (`h_bnd`), so `projectStore` keeps the inner value, which the inner sim's + -- boundedness makes `some`. + have bound_proj : ∀ (ρ_inner : Env P), (∀ y ∈ B, ρ_inner.store y ≠ none) → + ∀ y ∈ B, projectStore ρ_h.store ρ_inner.store y ≠ none := by + intro ρ_inner h_bnd_inner y hy + unfold projectStore + have h_parent_some : (ρ_h.store y).isSome = true := by + cases h : ρ_h.store y with + | none => exact absurd h (h_bnd y hy) + | some _ => rfl + rw [h_parent_some]; simp; exact h_bnd_inner y hy + -- Peel the source block-enter step: `.stmt (.block lbl inner md) ρ → .block (.some lbl) + -- ρ.store (.stmts inner ρ)`, exposing the inner-config run for inversion. + have peel_term : ∀ (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmt (.block lbl inner md) ρ_s) (.terminal ρ_s') → + StepStmtStar P (EvalCmd P) extendEval + (.block (.some lbl) ρ_s.store (.stmts inner ρ_s)) (.terminal ρ_s') := by + intro ρ_s' h_run + cases h_run with + | step _ _ _ h1 hr1 => cases h1; exact hr1 + have peel_exit : ∀ (l : String) (ρ_s' : Env P), + StepStmtStar P (EvalCmd P) extendEval (.stmt (.block lbl inner md) ρ_s) (.exiting l ρ_s') → + StepStmtStar P (EvalCmd P) extendEval + (.block (.some lbl) ρ_s.store (.stmts inner ρ_s)) (.exiting l ρ_s') := by + intro l ρ_s' h_run + cases h_run with + | step _ _ _ h1 hr1 => cases h1; exact hr1 + refine ⟨?_, ?_⟩ + · -- terminal clause: inner `.terminal` (T1) OR inner `.exiting lbl` matched (T2). + intro ρ_s' h_run0 + have h_run := peel_term ρ_s' h_run0 + rcases block_some_reaches_terminal P (EvalCmd P) extendEval h_run with + ⟨ρ_inner, h_inner_term, h_eq⟩ | ⟨ρ_inner, h_inner_exit, h_eq⟩ + · -- T1: inner terminates. Feed the inner TERMINAL clause. + obtain ⟨ρ_h_inner, h_inner_h_run, h_hinv_inner, h_hf_inner, h_bnd_inner, h_eval_inner⟩ := + (inner_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).1 ρ_inner h_inner_term + refine ⟨{ ρ_h_inner with store := projectStore ρ_h.store ρ_h_inner.store }, ?_, ?_, ?_, ?_, ?_⟩ + · -- hoist block: enter, run inner to terminal, `step_block_done`. + refine ReflTrans.step _ _ _ StepStmt.step_block ?_ + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ (some lbl) ρ_h.store h_inner_h_run) ?_ + exact ReflTrans.step _ _ _ StepStmt.step_block_done (ReflTrans.refl _) + · subst h_eq; exact HoistInv.project_both h_hinv h_hinv_inner + · subst h_eq; show ρ_inner.hasFailure = ρ_h_inner.hasFailure; exact h_hf_inner + · subst h_eq; exact bound_proj ρ_h_inner h_bnd_inner + · subst h_eq; show ρ_inner.eval = ρ_h_inner.eval; exact h_eval_inner + · -- T2: inner exits with the block's own label `lbl` → block catches it. + obtain ⟨ρ_h_inner, h_inner_h_run, h_hinv_inner, h_hf_inner, h_bnd_inner, h_eval_inner⟩ := + (inner_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).2 lbl ρ_inner h_inner_exit + refine ⟨{ ρ_h_inner with store := projectStore ρ_h.store ρ_h_inner.store }, ?_, ?_, ?_, ?_, ?_⟩ + · -- hoist block: enter, run inner to `.exiting lbl`, `step_block_exit_match`. + refine ReflTrans.step _ _ _ StepStmt.step_block ?_ + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ (some lbl) ρ_h.store h_inner_h_run) ?_ + exact ReflTrans.step _ _ _ (StepStmt.step_block_exit_match rfl) (ReflTrans.refl _) + · subst h_eq; exact HoistInv.project_both h_hinv h_hinv_inner + · subst h_eq; show ρ_inner.hasFailure = ρ_h_inner.hasFailure; exact h_hf_inner + · subst h_eq; exact bound_proj ρ_h_inner h_bnd_inner + · subst h_eq; show ρ_inner.eval = ρ_h_inner.eval; exact h_eval_inner + · -- exiting clause: inner exits with `l ≠ lbl` (mismatch) → block propagates. + intro l ρ_s' h_run0 + have h_run := peel_exit l ρ_s' h_run0 + obtain ⟨ρ_inner, h_inner_exit, h_ne, h_eq⟩ := + block_reaches_exiting_strong P (EvalCmd P) extendEval h_run + obtain ⟨ρ_h_inner, h_inner_h_run, h_hinv_inner, h_hf_inner, h_bnd_inner, h_eval_inner⟩ := + (inner_sim ρ_s ρ_h h_hinv h_eval h_hf h_bnd).2 l ρ_inner h_inner_exit + refine ⟨{ ρ_h_inner with store := projectStore ρ_h.store ρ_h_inner.store }, ?_, ?_, ?_, ?_, ?_⟩ + · -- hoist block: enter, run inner to `.exiting l`, `step_block_exit_mismatch`. + refine ReflTrans.step _ _ _ StepStmt.step_block ?_ + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ (some lbl) ρ_h.store h_inner_h_run) ?_ + exact ReflTrans.step _ _ _ (StepStmt.step_block_exit_mismatch h_ne) (ReflTrans.refl _) + · subst h_eq; exact HoistInv.project_both h_hinv h_hinv_inner + · subst h_eq; show ρ_inner.hasFailure = ρ_h_inner.hasFailure; exact h_hf_inner + · subst h_eq; exact bound_proj ρ_h_inner h_bnd_inner + · subst h_eq; show ρ_inner.eval = ρ_h_inner.eval; exact h_eval_inner + +/-! ## The `.exit` base case for a sum-typed `StmtSimES`. + +A single `.exit lbl md` statement is the new base case the (future) `BodyTransport.exit` +constructor invokes. The source `.stmt (.exit lbl md) ρ_s` reaches ONLY `.exiting lbl ρ_s` +(never `.terminal` — `step_exit` produces `.exiting`). The hoist side is the SAME +`.exit lbl md` (`applyRenames`/`substIdent` leaves `.exit` literally unchanged), which +reaches `.exiting lbl ρ_h` carrying the body-entry `HoistInv`/eval/hf/bound unchanged +(the `.exit` copies the env). So the terminal clause is vacuous and the exiting clause +re-uses the entry invariant. -/ +theorem exit_stmtSimES [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) (lbl : String) (md : MetaData P) : + StmtSimES (extendEval := extendEval) A B subst (.exit lbl md) (.exit lbl md) := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd + refine ⟨?_, ?_⟩ + · -- terminal clause: `.exit` never reaches `.terminal` (only `.exiting`). + intro ρ_s' h_run + exfalso + cases h_run with + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | step _ _ _ hd _ => exact nomatch hd + · -- exiting clause: invert the source `.exit` run (label = lbl, env unchanged), + -- then drive the hoist `.exit` to `.exiting lbl ρ_h`. + intro l ρ_s' h_run + have h_inv : l = lbl ∧ ρ_s' = ρ_s := by + cases h_run with + | step _ _ _ h1 hr1 => + cases h1 + cases hr1 with + | refl => exact ⟨rfl, rfl⟩ + | step _ _ _ hd _ => exact nomatch hd + obtain ⟨h_l, h_ρ⟩ := h_inv + subst h_l; subst h_ρ + refine ⟨ρ_h, ?_, h_hinv, h_hf, h_bnd, h_eval⟩ + exact ReflTrans.step _ _ _ StepStmt.step_exit (ReflTrans.refl _) + +/-! ## The remaining FAILING `StmtSimFail` producers. -/ + +/-- A `.typeDecl` run reaching a failing config: either `refl` (start fails) or one +no-op step to a failing `.terminal` (the env is unchanged, so the flag is `ρ`'s). -/ +theorem typeDecl_endpoint_inv [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (tc : TypeConstructor) (md : MetaData P) (ρ : Env P) (d : Config P (Cmd P)) + (h_run : StepStmtStar P (EvalCmd P) extendEval (.stmt (.typeDecl tc md) ρ) d) + (hd : d.getEnv.hasFailure = true) : + ρ.hasFailure = true ∨ + (∃ ρ', StepStmtStar P (EvalCmd P) extendEval (.stmt (.typeDecl tc md) ρ) (.terminal ρ') ∧ + ρ'.hasFailure = true) ∨ + (∃ l ρ', StepStmtStar P (EvalCmd P) extendEval (.stmt (.typeDecl tc md) ρ) (.exiting l ρ') ∧ + ρ'.hasFailure = true) := by + match h_run with + | .refl _ => exact Or.inl (by simpa [Config.getEnv] using hd) + | .step _ _ _ StepStmt.step_typeDecl hr1 => + match hr1 with + | .refl _ => + exact Or.inr (Or.inl ⟨_, .step _ _ _ StepStmt.step_typeDecl (.refl _), + by simpa [Config.getEnv] using hd⟩) + | .step _ _ _ hd' _ => exact nomatch hd' + +theorem typeDecl_stmtSimFail [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} {tc : TypeConstructor} {md : MetaData P} + (h_es : StmtSimES (extendEval := extendEval) A B subst (.typeDecl tc md) (.typeDecl tc md)) : + StmtSimFail (extendEval := extendEval) A B subst (.typeDecl tc md) (.typeDecl tc md) := + stmtSimFail_of_stmtSimES_atomic (typeDecl_endpoint_inv tc md) h_es + +/-- A `.exit lbl md` run reaching a failing config: either `refl` (start fails) or one +`step_exit` to a failing `.exiting lbl` (env unchanged, flag is `ρ`'s). -/ +theorem exit_endpoint_inv [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (lbl : String) (md : MetaData P) (ρ : Env P) (d : Config P (Cmd P)) + (h_run : StepStmtStar P (EvalCmd P) extendEval (.stmt (.exit lbl md) ρ) d) + (hd : d.getEnv.hasFailure = true) : + ρ.hasFailure = true ∨ + (∃ ρ', StepStmtStar P (EvalCmd P) extendEval (.stmt (.exit lbl md) ρ) (.terminal ρ') ∧ + ρ'.hasFailure = true) ∨ + (∃ l ρ', StepStmtStar P (EvalCmd P) extendEval (.stmt (.exit lbl md) ρ) (.exiting l ρ') ∧ + ρ'.hasFailure = true) := by + match h_run with + | .refl _ => exact Or.inl (by simpa [Config.getEnv] using hd) + | .step _ _ _ StepStmt.step_exit hr1 => + match hr1 with + | .refl _ => + exact Or.inr (Or.inr ⟨lbl, _, .step _ _ _ StepStmt.step_exit (.refl _), + by simpa [Config.getEnv] using hd⟩) + | .step _ _ _ hd' _ => exact nomatch hd' + +theorem exit_stmtSimFail [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) (lbl : String) (md : MetaData P) : + StmtSimFail (extendEval := extendEval) A B subst (.exit lbl md) (.exit lbl md) := + stmtSimFail_of_stmtSimES_atomic (exit_endpoint_inv lbl md) (exit_stmtSimES A B subst lbl md) + +/-- The det-guard `.ite` failing arm: a failing run peels the guard step, the taken +branch fails, discharged by that branch's `BodySimFail`; the hoist replays the same +branch with the transported guard. -/ +theorem ite_stmtSimFail [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {g : P.Expr} {tss_s tss_h ess_s ess_h : List (Stmt P (Cmd P))} {md : MetaData P} + (h_guard_eq : ∀ (ρ_s ρ_h : Env P), + HoistInv (P := P) A B subst ρ_s.store ρ_h.store → ρ_s.eval = ρ_h.eval → + (∃ w, ρ_s.eval ρ_s.store g = some w) → + ρ_s.eval ρ_s.store g = ρ_h.eval ρ_h.store (substFvarMany g subst)) + (then_fail : BodySimFail (extendEval := extendEval) A B subst tss_s tss_h) + (else_fail : BodySimFail (extendEval := extendEval) A B subst ess_s ess_h) : + StmtSimFail (extendEval := extendEval) A B subst + (.ite (.det g) tss_s ess_s md) + (.ite (.det (substFvarMany g subst)) tss_h ess_h md) := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd d h_run hd + have guard_h : ∀ {bv : P.Expr}, ρ_s.eval ρ_s.store g = .some bv → + ρ_h.eval ρ_h.store (substFvarMany g subst) = .some bv := by + intro bv hg + have := h_guard_eq ρ_s ρ_h h_hinv h_eval ⟨_, hg⟩ + rw [hg] at this; exact this.symm + -- Either the source `.ite` start is failing (refl), or it steps into a branch. + cases h_run with + | refl => + refine ⟨.stmt (.ite (.det (substFvarMany g subst)) tss_h ess_h md) ρ_h, .refl _, ?_⟩ + have : ρ_s.hasFailure = true := by simpa [Config.getEnv] using hd + simpa [Config.getEnv] using (h_hf ▸ this) + | step _ _ _ h1 hr1 => + cases h1 with + | step_ite_true hg hwf => + obtain ⟨d', h_branch_h, hd'⟩ := + then_fail ρ_s ρ_h h_hinv h_eval h_hf h_bnd d hr1 hd + exact ⟨d', .step _ _ _ (StepStmt.step_ite_true (guard_h hg) (h_eval ▸ hwf)) h_branch_h, hd'⟩ + | step_ite_false hg hwf => + obtain ⟨d', h_branch_h, hd'⟩ := + else_fail ρ_s ρ_h h_hinv h_eval h_hf h_bnd d hr1 hd + exact ⟨d', .step _ _ _ (StepStmt.step_ite_false (guard_h hg) (h_eval ▸ hwf)) h_branch_h, hd'⟩ + +/-- The nondet-guard `.ite` failing arm: a failing run peels the nondet branch step, +the chosen branch fails, discharged by that branch's `BodySimFail`; the hoist replays +the SAME branch choice. -/ +theorem ite_nondet_stmtSimFail [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {tss_s tss_h ess_s ess_h : List (Stmt P (Cmd P))} {md : MetaData P} + (then_fail : BodySimFail (extendEval := extendEval) A B subst tss_s tss_h) + (else_fail : BodySimFail (extendEval := extendEval) A B subst ess_s ess_h) : + StmtSimFail (extendEval := extendEval) A B subst + (.ite .nondet tss_s ess_s md) (.ite .nondet tss_h ess_h md) := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd d h_run hd + cases h_run with + | refl => + refine ⟨.stmt (.ite .nondet tss_h ess_h md) ρ_h, .refl _, ?_⟩ + have : ρ_s.hasFailure = true := by simpa [Config.getEnv] using hd + simpa [Config.getEnv] using (h_hf ▸ this) + | step _ _ _ h1 hr1 => + cases h1 with + | step_ite_nondet_true => + obtain ⟨d', h_branch_h, hd'⟩ := then_fail ρ_s ρ_h h_hinv h_eval h_hf h_bnd d hr1 hd + exact ⟨d', .step _ _ _ StepStmt.step_ite_nondet_true h_branch_h, hd'⟩ + | step_ite_nondet_false => + obtain ⟨d', h_branch_h, hd'⟩ := else_fail ρ_s ρ_h h_hinv h_eval h_hf h_bnd d hr1 hd + exact ⟨d', .step _ _ _ StepStmt.step_ite_nondet_false h_branch_h, hd'⟩ + +/-- The `.block` failing arm: a failing run peels the block-enter step; the failure is +inside the body (`block_reaches_failing'`), discharged by the inner body's `BodySimFail`; +the hoist enters its block and the lifted inner failing run keeps the flag. -/ +theorem block_stmtSimFail [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {lbl : String} {inner inner_h : List (Stmt P (Cmd P))} {md : MetaData P} + (inner_fail : BodySimFail (extendEval := extendEval) A B subst inner inner_h) : + StmtSimFail (extendEval := extendEval) A B subst + (.block lbl inner md) (.block lbl inner_h md) := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd d h_run hd + cases h_run with + | refl => + refine ⟨.stmt (.block lbl inner_h md) ρ_h, .refl _, ?_⟩ + have : ρ_s.hasFailure = true := by simpa [Config.getEnv] using hd + simpa [Config.getEnv] using (h_hf ▸ this) + | step _ _ _ h1 hr1 => + cases h1 with + | step_block => + -- The failure is inside the body block; `block_reaches_failing'` exposes the + -- inner-config (`.stmts inner ρ_s`) failing run directly. + obtain ⟨d_inner, h_inner_run, hd_inner⟩ := + block_reaches_failing' P (EvalCmd P) extendEval hr1 hd + obtain ⟨d', h_inner_h_run, hd'⟩ := + inner_fail ρ_s ρ_h h_hinv h_eval h_hf h_bnd d_inner h_inner_run hd_inner + -- Lift the failing inner run into the hoist block. + refine ⟨.block (.some lbl) ρ_h.store d', ?_, by simpa [Config.getEnv] using hd'⟩ + exact .step _ _ _ StepStmt.step_block + (block_inner_star P (EvalCmd P) extendEval _ _ (.some lbl) ρ_h.store h_inner_h_run) + +/-- The nested-loop failing arm: a failing run of `.loop (.det g2) none [] inner` +peels into the failing loop driver `loopDet_lift_renamedGuard_F`, with the inner +body's SUM-TYPED sim for completed iterations and the inner body's `BodySimFail` for +the failing iteration; the hoist loop (renamed guard) reaches a failing config. -/ +theorem nestedLoop_stmtSimFail [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + {g2 : P.Expr} {inner inner_h : List (Stmt P (Cmd P))} {md2_s md2_h : MetaData P} + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_g_B_fresh : ∀ z ∈ B, z ∉ HasVarsPure.getVars g2) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (inner_sim : LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) A B subst inner inner_h) + (inner_fail : BodySimFail (extendEval := extendEval) A B subst inner inner_h) + (h_nofd_src : Block.noFuncDecl inner = true) + (h_nofd_h : Block.noFuncDecl inner_h = true) : + StmtSimFail (extendEval := extendEval) A B subst + (.loop (.det g2) none [] inner md2_s) + (.loop (.det (substFvarMany g2 subst)) none [] inner_h md2_h) := by + intro ρ_s ρ_h h_hinv h_eval h_hf h_bnd d h_run hd + exact LoopInitHoistLoopDriver.loopDet_lift_renamedGuard_F (A := A) (B := B) (subst := subst) + h_A_subst_fst h_src_nodup h_disjoint h_tgt_nodup h_g_B_fresh + h_wfvar h_wfcongr h_wfsubst h_wfdef + inner_sim + (fun ρ_s' ρ_h' hi he hf hb d' hrun' hd' => + inner_fail ρ_s' ρ_h' hi he hf hb d' hrun' hd') + h_nofd_src h_nofd_h + h_hinv h_eval h_hf h_bnd h_run hd + +end OptEStepBProvider +end Imperative + +end -- public section diff --git a/Strata/Transform/LoopInitHoistStepCProducer.lean b/Strata/Transform/LoopInitHoistStepCProducer.lean new file mode 100644 index 0000000000..3106214e66 --- /dev/null +++ b/Strata/Transform/LoopInitHoistStepCProducer.lean @@ -0,0 +1,1105 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.DL.Imperative.StmtSemantics +public import Strata.DL.Imperative.CmdSemantics +public import Strata.Transform.LoopInitHoist +public import Strata.Transform.LoopInitHoistContains +public import Strata.Transform.LoopInitHoistFreshness +public import Strata.Transform.LoopInitHoistRewrite +public import Strata.Transform.LoopInitHoistInfra +public import Strata.Transform.LoopInitHoistLoopDriver +public import Strata.Transform.LoopInitHoistKeystone +public import Strata.Transform.LoopInitHoistBodyTransport + +import all Strata.DL.Imperative.Stmt +import all Strata.DL.Imperative.Cmd +import all Strata.Transform.LoopInitHoist +import all Strata.Transform.LoopInitHoistContains +import all Strata.Transform.LoopInitHoistFreshness +import all Strata.Transform.LoopInitHoistRewrite +import all Strata.Transform.LoopInitHoistInfra + +public section + +namespace Imperative +namespace LoopInitHoistStepCProducer + +/-! +# Step-C producer: the loop-init hoist pass output inhabits `BodyTransport`. + +The loop-init hoist pass processes a `.loop`'s post-order body `body₁` (already +init-free in every nested loop) by harvesting its prefix inits into fresh-name +havocs and rewriting each lifted `init y ty rhs md` to `set y rhs md`, recording +`(y, y')` renames. The renamed-lifted body is +`body₃ = Block.applyRenames (substOf' (Block.entriesOf body₁ σ)) + (Block.liftInitsInLoopBodyM body₁ σ).1.2.2`. + +This module proves that `body₁` and `body₃` are related by the per-statement +`BodyTransport` correspondence relation, at the global carriers harvested from +the lift (`sourcesOf'`/`targetsOf'`/`substOf'` of the entries). This is the +producer the `.loop` arm of the hoist correctness proof consumes (together with +`Block.bodyTransport`, which turns a `BodyTransport` derivation into the +eval-carrying body simulation the loop driver wants). + +The proof is a structural mutual induction over `body₁` MIRRORING the recursion +of `Block.entriesOf`/`Stmt.entriesOf`: `Block.entriesOf_cons` / +`Stmt.entriesOf_block` / `Stmt.entriesOf_ite` peel the entries, the keystone +`applyRenames_eq_map_stmtSubstMany` aligns `body₃` statement-by-statement, and +the per-init `init_site_applyRenames` lands the renamed `set`. + +Carriers `A B subst` are fixed at the GLOBAL harvest of the enclosing loop body, +so `body₃`'s every statement is `stmtSubstMany · subst`; the recursion threads a +membership invariant `EntriesIn` (every harvested entry's source/target/pair lies +in `A`/`B`/`subst`), which is monotone across the sub-block recursion, plus the +monotone `Block.namesFreshInExprs` freshness facts over `A` and `B`. +-/ + +open LoopInitHoistLoopDriver (Entry havocStmts' substOf' targetsOf' sourcesOf' + Stmt.entriesOf Block.entriesOf Block.entriesOf_cons Stmt.entriesOf_block Stmt.entriesOf_ite) +open LoopInitHoistBodyTransport (BodyTransport) +open OptEKeystone (applyRenames_eq_map_stmtSubstMany applyRenames_cons applyRenames_stmt_cons + applyRenames_empty_block stmtSubstMany stmtSubstMany_nil stmtSubstMany_cons + stmtSubstMany_loop_det cmdSubstMany_assert cmdSubstMany_init_det exprOrNondet_substMany_det + exprOrNondet_substMany_nondet name_fold_eq_renameLookup) + +variable {P : PureExpr} + +/-! ## Ported leaf helpers from the Step-C scratch. + +These align ONE lifted-init site of `body₂` with the `BodyTransport.init_set` +hoist shape under the GLOBAL `subst`. They are syntactic (no eval), proved from +the keystone fold lemmas; reproduced here so the producer is self-contained. -/ + +/-- A `.cmd` folds to `.cmd` of the per-`Cmd` fold. -/ +theorem stmtSubstMany_cmd [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] (c : Cmd P) (subst : List (P.Ident × P.Ident)) : + stmtSubstMany (.cmd c) subst + = .cmd (subst.foldl (fun acc p => Cmd.substIdent p.1 p.2 acc) c) := by + induction subst generalizing c with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + rw [stmtSubstMany_cons, Stmt.substIdent_cmd] + exact ih _ + +/-- The `set` name-fold (no freshness needed). -/ +theorem cmdSubstMany_set_name_fold [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (name : P.Ident) (e : ExprOrNondet P) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) : + (subst.foldl (fun acc p => Cmd.substIdent p.1 p.2 acc) (Cmd.set name e md)) + = Cmd.set + (subst.foldl (fun acc p => if acc = p.1 then p.2 else acc) name) + (subst.foldl (fun acc p => ExprOrNondet.substIdent p.1 p.2 acc) e) + md := by + induction subst generalizing name e with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨a, b⟩ + simp only [List.foldl_cons, Cmd.substIdent_set] + exact ih _ _ + +/-- A `set` command folds: name renamed by `renameLookup`, rhs by `substFvarMany`. -/ +theorem cmdSubstMany_set_det [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (name : P.Ident) (rhs : P.Expr) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) : + stmtSubstMany (.cmd (.set name (.det rhs) md)) subst + = .cmd (.set (renameLookup subst name) (.det (substFvarMany rhs subst)) md) := by + rw [stmtSubstMany_cmd, cmdSubstMany_set_name_fold, + name_fold_eq_renameLookup subst name h_disjoint, exprOrNondet_substMany_det] + +/-- The cmd-only init site of `body₂` becomes, after `applyRenames` +(= `stmtSubstMany` global subst), exactly the `BodyTransport.init_set` hoist +shape. -/ +theorem init_site_applyRenames [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (a b : P.Ident) (rhs : P.Expr) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) + (h_pair : (a, b) ∈ subst) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) : + stmtSubstMany (.cmd (.set a (.det rhs) md)) subst + = .cmd (.set b (.det (substFvarMany rhs subst)) md) := by + rw [cmdSubstMany_set_det a rhs md subst h_disjoint, + renameLookup_mem subst h_src_nodup h_pair] + +/-- A nondet-rhs `set` command folds: name renamed by `renameLookup`, `.nondet` +rhs fixed. -/ +theorem cmdSubstMany_set_nondet [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (name : P.Ident) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) : + stmtSubstMany (.cmd (.set name .nondet md)) subst + = .cmd (.set (renameLookup subst name) .nondet md) := by + rw [stmtSubstMany_cmd, cmdSubstMany_set_name_fold, + name_fold_eq_renameLookup subst name h_disjoint, exprOrNondet_substMany_nondet] + +/-- The nondet-init site of `body₂` (lifted to `set a .nondet`) becomes, after +`applyRenames`, the `BodyTransport.init_nondet` hoist shape `set b .nondet`. -/ +theorem init_nondet_site_applyRenames [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (a b : P.Ident) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) + (h_pair : (a, b) ∈ subst) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) : + stmtSubstMany (.cmd (.set a .nondet md)) subst + = .cmd (.set b .nondet md) := by + rw [cmdSubstMany_set_nondet a md subst h_disjoint, + renameLookup_mem subst h_src_nodup h_pair] + +/-- A genuine (non-lifted) `.set name (.det rhs)`'s name is UNCHANGED by the +rename (its `name ∉ subst sources`), and its rhs is `substFvarMany`-renamed. -/ +theorem set_site_applyRenames [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (name : P.Ident) (rhs : P.Expr) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) + (h_name_notin_src : name ∉ subst.map Prod.fst) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) : + stmtSubstMany (.cmd (.set name (.det rhs) md)) subst + = .cmd (.set name (.det (substFvarMany rhs subst)) md) := by + rw [cmdSubstMany_set_det name rhs md subst h_disjoint, + renameLookup_notin subst name h_name_notin_src] + +/-- A genuine (non-lifted) `.set name .nondet`'s name is UNCHANGED by the rename. -/ +theorem set_nondet_site_applyRenames [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (name : P.Ident) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) + (h_name_notin_src : name ∉ subst.map Prod.fst) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) : + stmtSubstMany (.cmd (.set name .nondet md)) subst + = .cmd (.set name .nondet md) := by + rw [cmdSubstMany_set_nondet name md subst h_disjoint, + renameLookup_notin subst name h_name_notin_src] + +/-! ## `assert`/`assume`/`cover` fold to renamed predicates. -/ + +theorem stmtSubstMany_cmd_assert [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (lbl : String) (e : P.Expr) (md : MetaData P) (subst : List (P.Ident × P.Ident)) : + stmtSubstMany (.cmd (.assert lbl e md)) subst + = .cmd (.assert lbl (substFvarMany e subst) md) := by + rw [stmtSubstMany_cmd, cmdSubstMany_assert] + +theorem stmtSubstMany_cmd_assume [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (lbl : String) (e : P.Expr) (md : MetaData P) (subst : List (P.Ident × P.Ident)) : + stmtSubstMany (.cmd (.assume lbl e md)) subst + = .cmd (.assume lbl (substFvarMany e subst) md) := by + rw [stmtSubstMany_cmd] + congr 1 + induction subst generalizing e with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨x, y⟩ + simp only [List.foldl_cons, Cmd.substIdent_assume] + rw [ih]; rfl + +theorem stmtSubstMany_cmd_cover [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (lbl : String) (e : P.Expr) (md : MetaData P) (subst : List (P.Ident × P.Ident)) : + stmtSubstMany (.cmd (.cover lbl e md)) subst + = .cmd (.cover lbl (substFvarMany e subst) md) := by + rw [stmtSubstMany_cmd] + congr 1 + induction subst generalizing e with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨x, y⟩ + simp only [List.foldl_cons, Cmd.substIdent_cover] + rw [ih]; rfl + +/-! ## `.block` / `.ite` fold to renamed sub-blocks. -/ + +theorem stmtSubstMany_block [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (lbl : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) : + stmtSubstMany (.block lbl bss md) subst + = .block lbl (Block.applyRenames subst bss) md := by + induction subst generalizing bss with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨x, y⟩ + rw [stmtSubstMany_cons, Stmt.substIdent_block, ih, applyRenames_cons] + +theorem stmtSubstMany_ite [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (g : P.Expr) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) : + stmtSubstMany (.ite (.det g) tss ess md) subst + = .ite (.det (substFvarMany g subst)) + (Block.applyRenames subst tss) (Block.applyRenames subst ess) md := by + induction subst generalizing g tss ess with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨x, y⟩ + rw [stmtSubstMany_cons, Stmt.substIdent_ite] + simp only [ExprOrNondet.substIdent_det] + rw [ih, applyRenames_cons, applyRenames_cons] + rfl + +theorem stmtSubstMany_ite_nondet [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (subst : List (P.Ident × P.Ident)) : + stmtSubstMany (.ite .nondet tss ess md) subst + = .ite .nondet + (Block.applyRenames subst tss) (Block.applyRenames subst ess) md := by + induction subst generalizing tss ess with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨x, y⟩ + rw [stmtSubstMany_cons, Stmt.substIdent_ite] + simp only [ExprOrNondet.substIdent_nondet] + rw [ih, applyRenames_cons, applyRenames_cons] + +theorem stmtSubstMany_typeDecl [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (tc : TypeConstructor) (md : MetaData P) (subst : List (P.Ident × P.Ident)) : + stmtSubstMany (.typeDecl tc md) subst = (.typeDecl tc md : Stmt P (Cmd P)) := by + induction subst with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨x, y⟩ + rw [stmtSubstMany_cons, Stmt.substIdent_typeDecl]; exact ih + +/-- An `.exit` is left literally unchanged by the rename fold (`substIdent_exit`). -/ +theorem stmtSubstMany_exit [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (lbl : String) (md : MetaData P) (subst : List (P.Ident × P.Ident)) : + stmtSubstMany (.exit lbl md) subst = (.exit lbl md : Stmt P (Cmd P)) := by + induction subst with + | nil => rfl + | cons hd tl ih => + rcases hd with ⟨x, y⟩ + rw [stmtSubstMany_cons, Stmt.substIdent_exit]; exact ih + +/-! ## The membership invariant carried through the recursion. -/ + +/-- Every entry harvested from `body₁` at `σ` has its source ident in `A`, its +target ident in `B`, and its `(source, target)` pair in `subst`. This is the +positional connection between each `init`/expr in `body₁` and its entry, kept at +the GLOBAL carriers; monotone across the sub-block recursion. -/ +def EntriesIn [HasIdent P] (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) + (body₁ : List (Stmt P (Cmd P))) (σ : StringGenState) : Prop := + ∀ e ∈ Block.entriesOf body₁ σ, e.1 ∈ A ∧ e.2.1 ∈ B ∧ (e.1, e.2.1) ∈ subst + +theorem EntriesIn.cons_head [HasIdent P] + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} {σ : StringGenState} + (h : EntriesIn A B subst (s :: rest) σ) : + ∀ e ∈ Stmt.entriesOf s σ, e.1 ∈ A ∧ e.2.1 ∈ B ∧ (e.1, e.2.1) ∈ subst := by + intro e he + refine h e ?_ + rw [Block.entriesOf_cons] + exact List.mem_append.mpr (Or.inl he) + +theorem EntriesIn.cons_tail [HasIdent P] + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} {σ : StringGenState} + (h : EntriesIn A B subst (s :: rest) σ) : + EntriesIn A B subst rest (Stmt.liftInitsInLoopBodyM s σ).2 := by + intro e he + refine h e ?_ + rw [Block.entriesOf_cons] + exact List.mem_append.mpr (Or.inr he) + +theorem EntriesIn.block [HasIdent P] + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {lbl : String} {bss : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} {σ : StringGenState} + (h : EntriesIn A B subst (.block lbl bss md :: rest) σ) : + EntriesIn A B subst bss σ := by + intro e he + apply EntriesIn.cons_head h e + rw [Stmt.entriesOf_block] + exact he + +theorem EntriesIn.ite_then [HasIdent P] + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} {σ : StringGenState} + (h : EntriesIn A B subst (.ite g tss ess md :: rest) σ) : + EntriesIn A B subst tss σ := by + intro e he + apply EntriesIn.cons_head h e + rw [Stmt.entriesOf_ite] + exact List.mem_append.mpr (Or.inl he) + +theorem EntriesIn.ite_else [HasIdent P] + {A B : List P.Ident} {subst : List (P.Ident × P.Ident)} + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} {σ : StringGenState} + (h : EntriesIn A B subst (.ite g tss ess md :: rest) σ) : + EntriesIn A B subst ess (Block.liftInitsInLoopBodyM tss σ).2 := by + intro e he + apply EntriesIn.cons_head h e + rw [Stmt.entriesOf_ite] + exact List.mem_append.mpr (Or.inr he) + +/-- The head init's entry pair, at the head of the entries list. -/ +theorem entriesOf_init_head_mem [HasIdent P] + (a : P.Ident) (τ : P.Ty) (rhs : ExprOrNondet P) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) (σ : StringGenState) : + ((a, HasIdent.ident (P := P) (StringGenState.gen hoistFreshPrefix σ).1, τ, md) : Entry P) + ∈ Block.entriesOf (.cmd (.init a τ rhs md) :: rest) σ := by + rw [Block.entriesOf_cons, Stmt.entriesOf] + exact List.mem_append.mpr (Or.inl (by simp)) + +/-! ## Per-statement freshness extraction from `namesFreshInExprs`. -/ + +theorem namesFresh_cmd_init [HasVarsPure P P.Expr] + {names : List P.Ident} {a : P.Ident} {τ : P.Ty} {rhs : P.Expr} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.namesFreshInExprs names (.cmd (.init a τ (.det rhs) md) :: rest) = true) : + (∀ x ∈ names, x ∉ HasVarsPure.getVars rhs) ∧ + Block.namesFreshInExprs names rest = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_eq_true] at h + refine ⟨?_, h.2⟩ + intro x hx + have := (List.all_eq_true.mp h.1) x hx + exact freshFromIdents_not_mem (by simpa [ExprOrNondet.getVars] using this) + +theorem namesFresh_cmd_set_det [HasVarsPure P P.Expr] + {names : List P.Ident} {name : P.Ident} {rhs : P.Expr} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.namesFreshInExprs names (.cmd (.set name (.det rhs) md) :: rest) = true) : + (∀ x ∈ names, x ∉ HasVarsPure.getVars rhs) ∧ + Block.namesFreshInExprs names rest = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_eq_true] at h + refine ⟨?_, h.2⟩ + intro x hx + have := (List.all_eq_true.mp h.1) x hx + exact freshFromIdents_not_mem (by simpa [ExprOrNondet.getVars] using this) + +theorem namesFresh_cmd_assert [HasVarsPure P P.Expr] + {names : List P.Ident} {lbl : String} {e : P.Expr} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.namesFreshInExprs names (.cmd (.assert lbl e md) :: rest) = true) : + (∀ x ∈ names, x ∉ HasVarsPure.getVars e) ∧ + Block.namesFreshInExprs names rest = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_eq_true] at h + refine ⟨?_, h.2⟩ + intro x hx + exact freshFromIdents_not_mem ((List.all_eq_true.mp h.1) x hx) + +theorem namesFresh_cmd_assume [HasVarsPure P P.Expr] + {names : List P.Ident} {lbl : String} {e : P.Expr} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.namesFreshInExprs names (.cmd (.assume lbl e md) :: rest) = true) : + (∀ x ∈ names, x ∉ HasVarsPure.getVars e) ∧ + Block.namesFreshInExprs names rest = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_eq_true] at h + refine ⟨?_, h.2⟩ + intro x hx + exact freshFromIdents_not_mem ((List.all_eq_true.mp h.1) x hx) + +theorem namesFresh_block [HasVarsPure P P.Expr] + {names : List P.Ident} {lbl : String} {bss : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.namesFreshInExprs names (.block lbl bss md :: rest) = true) : + Block.namesFreshInExprs names bss = true ∧ + Block.namesFreshInExprs names rest = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_eq_true] at h + exact h + +theorem namesFresh_ite [HasVarsPure P P.Expr] + {names : List P.Ident} {g : P.Expr} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.namesFreshInExprs names (.ite (.det g) tss ess md :: rest) = true) : + (∀ x ∈ names, x ∉ HasVarsPure.getVars g) ∧ + Block.namesFreshInExprs names tss = true ∧ + Block.namesFreshInExprs names ess = true ∧ + Block.namesFreshInExprs names rest = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_eq_true] at h + obtain ⟨⟨⟨h_g, h_tss⟩, h_ess⟩, h_rest⟩ := h + refine ⟨?_, h_tss, h_ess, h_rest⟩ + intro x hx + exact freshFromIdents_not_mem (by simpa [ExprOrNondet.getVars] using ((List.all_eq_true.mp h_g) x hx)) + +theorem namesFresh_ite_nondet [HasVarsPure P P.Expr] + {names : List P.Ident} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.namesFreshInExprs names (.ite .nondet tss ess md :: rest) = true) : + Block.namesFreshInExprs names tss = true ∧ + Block.namesFreshInExprs names ess = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, Bool.and_eq_true] at h + obtain ⟨⟨⟨_, h_tss⟩, h_ess⟩, _⟩ := h + exact ⟨h_tss, h_ess⟩ + +theorem namesFresh_loop [HasVarsPure P P.Expr] + {names : List P.Ident} {g : P.Expr} {body : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} + (h : Block.namesFreshInExprs names (.loop (.det g) none [] body md :: rest) = true) : + (∀ x ∈ names, x ∉ HasVarsPure.getVars g) ∧ + Block.namesFreshInExprs names body = true ∧ + Block.namesFreshInExprs names rest = true := by + simp only [Block.namesFreshInExprs, Stmt.namesFreshInExprs, List.all_nil, Bool.and_true, + Bool.and_eq_true] at h + obtain ⟨⟨h_g, h_body⟩, h_rest⟩ := h + refine ⟨?_, h_body, h_rest⟩ + intro x hx + exact freshFromIdents_not_mem (by simpa [ExprOrNondet.getVars] using ((List.all_eq_true.mp h_g) x hx)) + +/-! ## `modifiedVars` peel helpers (for the `.set` name-disjointness side-conditions). -/ + +/-- The head `.set name`'s name is in the body's `modifiedVars`. -/ +theorem set_name_mem_modifiedVars + (name : P.Ident) (rhs : ExprOrNondet P) (md : MetaData P) + (rest : List (Stmt P (Cmd P))) : + name ∈ Block.modifiedVars (.cmd (.set name rhs md) :: rest) := by + simp [Block.modifiedVars, Stmt.modifiedVars, HasVarsImp.modifiedVars, Cmd.modifiedVars] + +theorem modifiedVars_cons_tail + {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} {x : P.Ident} + (hx : x ∈ Block.modifiedVars rest) : + x ∈ Block.modifiedVars (s :: rest) := by + simp only [Block.modifiedVars, List.mem_append] + exact Or.inr hx + +theorem modifiedVars_block_subset + {lbl : String} {bss : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} {x : P.Ident} + (hx : x ∈ Block.modifiedVars bss) : + x ∈ Block.modifiedVars (.block lbl bss md :: rest) := by + simp only [Block.modifiedVars, Stmt.modifiedVars, List.mem_append] + exact Or.inl hx + +theorem modifiedVars_ite_then_subset + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} {x : P.Ident} + (hx : x ∈ Block.modifiedVars tss) : + x ∈ Block.modifiedVars (.ite g tss ess md :: rest) := by + simp only [Block.modifiedVars, Stmt.modifiedVars, List.mem_append] + exact Or.inl (Or.inl hx) + +theorem modifiedVars_ite_else_subset + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} {x : P.Ident} + (hx : x ∈ Block.modifiedVars ess) : + x ∈ Block.modifiedVars (.ite g tss ess md :: rest) := by + simp only [Block.modifiedVars, Stmt.modifiedVars, List.mem_append] + exact Or.inl (Or.inr hx) + +theorem modifiedVars_loop_subset + {g : ExprOrNondet P} {m : Option P.Expr} {inv : List (String × P.Expr)} + {lbody : List (Stmt P (Cmd P))} {md : MetaData P} + {rest : List (Stmt P (Cmd P))} {x : P.Ident} + (hx : x ∈ Block.modifiedVars lbody) : + x ∈ Block.modifiedVars (.loop g m inv lbody md :: rest) := by + simp only [Block.modifiedVars, Stmt.modifiedVars, List.mem_append] + exact Or.inl hx + +/-! ## `allLoopBodiesInitFree` peel helpers. -/ + +theorem initfree_cons + {s : Stmt P (Cmd P)} {rest : List (Stmt P (Cmd P))} + (h : Block.allLoopBodiesInitFree (s :: rest) = true) : + Stmt.allLoopBodiesInitFree s = true ∧ Block.allLoopBodiesInitFree rest = true := by + simp only [Block.allLoopBodiesInitFree, Bool.and_eq_true] at h + exact h + +theorem initfree_block + {lbl : String} {bss : List (Stmt P (Cmd P))} {md : MetaData P} + (h : Stmt.allLoopBodiesInitFree (.block lbl bss md) = true) : + Block.allLoopBodiesInitFree bss = true := by + simpa [Stmt.allLoopBodiesInitFree] using h + +theorem initfree_ite + {g : ExprOrNondet P} {tss ess : List (Stmt P (Cmd P))} {md : MetaData P} + (h : Stmt.allLoopBodiesInitFree (.ite g tss ess md) = true) : + Block.allLoopBodiesInitFree tss = true ∧ Block.allLoopBodiesInitFree ess = true := by + simp only [Stmt.allLoopBodiesInitFree, Bool.and_eq_true] at h + exact h + +theorem initfree_loop_noinits + {g : ExprOrNondet P} {body : List (Stmt P (Cmd P))} {md : MetaData P} + (h : Stmt.allLoopBodiesInitFree (.loop g none [] body md) = true) : + Block.noInitsAnywhere body = true ∧ Block.allLoopBodiesInitFree body = true := by + simp only [Stmt.allLoopBodiesInitFree, Bool.and_eq_true] at h + exact h + +mutual +/-- A `noInitsAnywhere` statement has empty `Stmt.entriesOf` (no `.init` to +harvest, and loops are passed through). -/ +theorem Stmt.entriesOf_noInits [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) + (h : Stmt.noInitsAnywhere s = true) : + Stmt.entriesOf s σ = [] := by + match s with + | .cmd c => + cases c with + | init _ _ _ _ => exact absurd h (by simp [Stmt.noInitsAnywhere]) + | _ => simp [Stmt.entriesOf] + | .block lbl bss md => + rw [Stmt.entriesOf_block] + exact Block.entriesOf_noInits bss σ (by simpa [Stmt.noInitsAnywhere] using h) + | .ite g tss ess md => + rw [Stmt.entriesOf_ite] + simp only [Stmt.noInitsAnywhere, Bool.and_eq_true] at h + rw [Block.entriesOf_noInits tss σ h.1, + Block.entriesOf_noInits ess _ h.2, List.append_nil] + | .loop g m inv body md => rw [Stmt.entriesOf] + | .exit lbl md => rw [Stmt.entriesOf] + | .funcDecl d md => rw [Stmt.entriesOf] + | .typeDecl t md => rw [Stmt.entriesOf] + termination_by sizeOf s + +/-- A `noInitsAnywhere` body has empty `entriesOf` (no `.init` to harvest, and +loops are passed through). -/ +theorem Block.entriesOf_noInits [HasIdent P] + (body : List (Stmt P (Cmd P))) (σ : StringGenState) + (h : Block.noInitsAnywhere body = true) : + Block.entriesOf body σ = [] := by + match body with + | [] => rw [Block.entriesOf] + | s :: rest => + rw [Block.entriesOf_cons] + simp only [Block.noInitsAnywhere, Bool.and_eq_true] at h + rw [Stmt.entriesOf_noInits s σ h.1, + Block.entriesOf_noInits rest _ h.2, List.append_nil] + termination_by sizeOf body +end + +/-! ## `applyRenames` distributes over `++`. -/ + +theorem applyRenames_append [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (subst : List (P.Ident × P.Ident)) (xs ys : List (Stmt P (Cmd P))) : + Block.applyRenames subst (xs ++ ys) + = Block.applyRenames subst xs ++ Block.applyRenames subst ys := by + rw [applyRenames_eq_map_stmtSubstMany, applyRenames_eq_map_stmtSubstMany, + applyRenames_eq_map_stmtSubstMany, List.map_append] + +/-- `applyRenames` of a singleton statement is the singleton `stmtSubstMany`. -/ +theorem applyRenames_singleton [HasFvar P] [HasSubstFvar P] [DecidableEq P.Ident] + (subst : List (P.Ident × P.Ident)) (s : Stmt P (Cmd P)) : + Block.applyRenames subst [s] = [stmtSubstMany s subst] := by + rw [applyRenames_eq_map_stmtSubstMany, List.map_cons, List.map_nil] + +/-- The per-pair source-functional uniqueness the `init_set` constructor wants: +distinct sources, so a source resolves to a unique target. -/ +theorem unique_of_src_nodup [DecidableEq P.Ident] + {subst : List (P.Ident × P.Ident)} {a b : P.Ident} + (h_src_nodup : (subst.map Prod.fst).Nodup) (h_pair : (a, b) ∈ subst) : + ∀ a' b', (a', b') ∈ subst → a' = a → b' = b := by + intro a' b' h_mem h_eq + subst h_eq + have e1 : renameLookup subst a' = b' := renameLookup_mem subst h_src_nodup h_mem + have e2 : renameLookup subst a' = b := renameLookup_mem subst h_src_nodup h_pair + rw [e1] at e2; exact e2 + +/-- Target-side analog: distinct targets, so a target resolves to a unique +source. Proved by induction on `subst` mirroring `renameLookup`. -/ +theorem unique_of_tgt_nodup + {subst : List (P.Ident × P.Ident)} {a b : P.Ident} + (h_tgt_nodup : (subst.map Prod.snd).Nodup) (h_pair : (a, b) ∈ subst) : + ∀ a' b', (a', b') ∈ subst → b' = b → a' = a := by + intro a' b' h_mem h_eq + subst h_eq + induction subst with + | nil => simp at h_pair + | cons hd tl ih => + rcases hd with ⟨x, y⟩ + simp only [List.map_cons, List.nodup_cons] at h_tgt_nodup + rcases List.mem_cons.mp h_pair with h_eq1 | h_in1 <;> + rcases List.mem_cons.mp h_mem with h_eq2 | h_in2 + · simp only [Prod.mk.injEq] at h_eq1 h_eq2 + rw [h_eq1.1, h_eq2.1] + · -- (a,b') = (x,y) so b'=y; (a',b')∈tl so b'∈ tl.snd; tgt nodup ⊥ + simp only [Prod.mk.injEq] at h_eq1 + exact absurd (List.mem_map.mpr ⟨(a', b'), h_in2, by rw [h_eq1.2]⟩) h_tgt_nodup.1 + · simp only [Prod.mk.injEq] at h_eq2 + exact absurd (List.mem_map.mpr ⟨(a, b'), h_in1, by rw [h_eq2.2]⟩) h_tgt_nodup.1 + · exact ih h_tgt_nodup.2 h_in2 h_in1 + +/-! ## The BodyTransport-expressible structural fragment. + +`BodyTransport` (read its constructors) covers: `.det`-rhs `init`, `.nondet`-rhs +`init`, `.det`-rhs `set`, `.nondet`-rhs `set`, `assert`/`assume`/`cover`, +`.block`, `.det`-guard `.ite`, `.nondet`-guard `.ite`, `.typeDecl`, an `.exit`, +and a measure-free, invariant-free, `.det`-guard nested `.loop`. It carries NO +constructor for a measured / invariant-bearing / `.nondet`-guard `.loop` or a +`.funcDecl`. + +`transportShape` is the Bool walker that asserts a body lies in this expressible +fragment. Via `transportShape_of_arm_preconds` below it FOLLOWS FROM the genuine +§E `.loop` arm Bool preconditions ALONE (`containsNondetLoop = false`, +`containsFuncDecl = false`, `loopHasNoInvariants = true`, `loopMeasureNone = +true`). An `.exit` is now admitted: `BodyTransport` carries an `.exit` +constructor and `Block.bodyTransport` produces a SUM-TYPED `BodySimES`, so a +`.block` whose inner body breaks (and the loop early-exit pattern) is handled by +the banked `block_stmtSimES` / `exit_stmtSimES` arms — no `noExit` residual is +needed. -/ + +mutual +@[expose] def Stmt.transportShape (s : Stmt P (Cmd P)) : Bool := + match s with + | .cmd (.init _ _ (.det _) _) => true + | .cmd (.init _ _ .nondet _) => true + | .cmd (.set _ (.det _) _) => true + | .cmd (.set _ .nondet _) => true + | .cmd (.assert _ _ _) => true + | .cmd (.assume _ _ _) => true + | .cmd (.cover _ _ _) => true + | .block _ bss _ => Block.transportShape bss + | .ite (.det _) tss ess _ => Block.transportShape tss && Block.transportShape ess + | .ite .nondet tss ess _ => Block.transportShape tss && Block.transportShape ess + | .loop (.det _) none [] lbody _ => Block.transportShape lbody + | .loop _ _ _ _ _ => false + | .exit _ _ => true + | .funcDecl _ _ => false + | .typeDecl _ _ => true + termination_by sizeOf s + +@[expose] def Block.transportShape (ss : List (Stmt P (Cmd P))) : Bool := + match ss with + | [] => true + | s :: rest => Stmt.transportShape s && Block.transportShape rest + termination_by sizeOf ss +end + +/-! ## `transportShape` from the §E `.loop` arm Bool preconditions. + +With `BodyTransport` now carrying an `.exit` constructor (and `Block.bodyTransport` +producing a SUM-TYPED `BodySimES`, so an inner body that breaks is handled), the +expressible fragment ADMITS `.exit` anywhere — `transportShape (.exit _ _) = true`. +The residual `noExit` requirement is therefore GONE. + +`transportShape` FOLLOWS FROM the genuine §E `.loop` arm Bool preconditions ALONE +(`containsNondetLoop = false`, `containsFuncDecl = false`, `loopHasNoInvariants = +true`, `loopMeasureNone = true`). Proved by mutual structural induction; each +statement constructor reduces to its sub-blocks under the corresponding Bool-walker +reductions (the `.exit` arm is now a trivial `true`). -/ +mutual +theorem Stmt.transportShape_of_arm_preconds + (s : Stmt P (Cmd P)) + (h_nd : Stmt.containsNondetLoop s = false) + (h_fd : Stmt.containsFuncDecl s = false) + (h_inv : Stmt.loopHasNoInvariants s = true) + (h_measure : Stmt.loopMeasureNone s = true) : + Stmt.transportShape s = true := by + match s with + | .cmd c => + cases c with + | init _ _ rhs _ => cases rhs <;> simp only [Stmt.transportShape] + | set _ rhs _ => cases rhs <;> simp only [Stmt.transportShape] + | assert _ _ _ => simp only [Stmt.transportShape] + | assume _ _ _ => simp only [Stmt.transportShape] + | cover _ _ _ => simp only [Stmt.transportShape] + | .block lbl bss md => + simp only [Stmt.transportShape] + exact Block.transportShape_of_arm_preconds bss + (by simpa only [Stmt.containsNondetLoop] using h_nd) + (by simpa only [Stmt.containsFuncDecl] using h_fd) + (by simpa only [Stmt.loopHasNoInvariants] using h_inv) + (by simpa only [Stmt.loopMeasureNone] using h_measure) + | .ite g tss ess md => + simp only [Stmt.containsNondetLoop, Bool.or_eq_false_iff] at h_nd + simp only [Stmt.containsFuncDecl, Bool.or_eq_false_iff] at h_fd + simp only [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h_inv + simp only [Stmt.loopMeasureNone, Bool.and_eq_true] at h_measure + have h_t := Block.transportShape_of_arm_preconds tss h_nd.1 h_fd.1 h_inv.1 h_measure.1 + have h_e := Block.transportShape_of_arm_preconds ess h_nd.2 h_fd.2 h_inv.2 h_measure.2 + cases g <;> + simp only [Stmt.transportShape, Bool.and_eq_true] <;> exact ⟨h_t, h_e⟩ + | .loop g m inv body md => + -- `containsNondetLoop` forces a `.det` guard; `loopMeasureNone` forces `m = none`; + -- `loopHasNoInvariants` forces `inv = []`. Then recurse on the body. + cases g with + | nondet => exact absurd h_nd (by simp [Stmt.containsNondetLoop]) + | det g' => + have h_m : m = none := by + rw [Stmt.loopMeasureNone, Bool.and_eq_true] at h_measure + exact Option.isNone_iff_eq_none.mp h_measure.1 + have h_inv_nil : inv = [] := by + rw [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h_inv + exact List.isEmpty_iff.mp h_inv.1 + subst h_m; subst h_inv_nil + simp only [Stmt.transportShape] + exact Block.transportShape_of_arm_preconds body + (by simpa only [Stmt.containsNondetLoop] using h_nd) + (by simpa only [Stmt.containsFuncDecl] using h_fd) + (by rw [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h_inv; exact h_inv.2) + (by rw [Stmt.loopMeasureNone, Bool.and_eq_true] at h_measure; exact h_measure.2) + | .exit lbl md => simp only [Stmt.transportShape] + | .funcDecl d md => exact absurd h_fd (by simp [Stmt.containsFuncDecl]) + | .typeDecl t md => simp only [Stmt.transportShape] + termination_by sizeOf s + +theorem Block.transportShape_of_arm_preconds + (ss : List (Stmt P (Cmd P))) + (h_nd : Block.containsNondetLoop ss = false) + (h_fd : Block.containsFuncDecl ss = false) + (h_inv : Block.loopHasNoInvariants ss = true) + (h_measure : Block.loopMeasureNone ss = true) : + Block.transportShape ss = true := by + match ss with + | [] => simp only [Block.transportShape] + | s :: rest => + simp only [Block.containsNondetLoop, Bool.or_eq_false_iff] at h_nd + simp only [Block.containsFuncDecl, Bool.or_eq_false_iff] at h_fd + simp only [Block.loopHasNoInvariants, Bool.and_eq_true] at h_inv + simp only [Block.loopMeasureNone, Bool.and_eq_true] at h_measure + simp only [Block.transportShape, Bool.and_eq_true] + exact ⟨Stmt.transportShape_of_arm_preconds s h_nd.1 h_fd.1 h_inv.1 h_measure.1, + Block.transportShape_of_arm_preconds rest h_nd.2 h_fd.2 h_inv.2 h_measure.2⟩ + termination_by sizeOf ss +end + +/-! ## The producer. + +Structural induction over `body₁`, mirroring `Block.entriesOf`'s recursion. The +hoist body is `body₃ = applyRenames subst (lift residual)`. Carriers `A B subst` +are the GLOBAL harvest of the enclosing loop body, so each statement of `body₃` +is `stmtSubstMany · subst`; the recursion threads the `EntriesIn` membership +invariant (monotone across sub-blocks) and the monotone `namesFreshInExprs` +freshness facts over `A` and `B`. -/ + +theorem Block.bodyTransport_of_lift [HasFvar P] [HasIdent P] [HasSubstFvar P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + (body₁ : List (Stmt P (Cmd P))) (σ : StringGenState) + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) + (h_initfree : Block.allLoopBodiesInitFree body₁ = true) + (h_entries : EntriesIn A B subst body₁ σ) + (h_B_fresh : Block.namesFreshInExprs B body₁ = true) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars body₁, x ∉ B) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_shape : Block.transportShape body₁ = true) : + BodyTransport A B subst + body₁ + (Block.applyRenames subst (Block.liftInitsInLoopBodyM body₁ σ).1.2.2) := by + match body₁ with + | [] => + -- residual of [] is [], applyRenames _ [] = []. + have h_res : (Block.liftInitsInLoopBodyM ([] : List (Stmt P (Cmd P))) σ).1.2.2 = [] := by + rw [Block.liftInitsInLoopBodyM] + rw [h_res, applyRenames_empty_block] + exact BodyTransport.nil + | s :: rest => + -- Peel the residual and applyRenames over the cons append. + rw [Block.liftInitsInLoopBodyM_cons_residual, applyRenames_append] + -- structural facts for the tail. + obtain ⟨h_if_s, h_if_rest⟩ := initfree_cons h_initfree + obtain ⟨h_shape_s, h_shape_rest⟩ : Stmt.transportShape s = true ∧ Block.transportShape rest = true := by + simpa only [Block.transportShape, Bool.and_eq_true] using h_shape + have h_entries_tail : EntriesIn A B subst rest (Stmt.liftInitsInLoopBodyM s σ).2 := + EntriesIn.cons_tail h_entries + have h_tail : + BodyTransport A B subst rest + (Block.applyRenames subst + (Block.liftInitsInLoopBodyM rest (Stmt.liftInitsInLoopBodyM s σ).2).1.2.2) := by + refine Block.bodyTransport_of_lift rest (Stmt.liftInitsInLoopBodyM s σ).2 A B subst + h_if_rest h_entries_tail ?_ ?_ h_subst_wf h_A_subst_fst + h_src_nodup h_tgt_nodup h_disjoint h_shape_rest + · simp only [Block.namesFreshInExprs, Bool.and_eq_true] at h_B_fresh; exact h_B_fresh.2 + · exact fun x hx => h_mod_disjoint_B x (modifiedVars_cons_tail hx) + -- Now case on the head statement. `s` is restricted to the + -- BodyTransport-expressible fragment by `h_shape` (see `transportShape`). + match s, h_if_s, h_entries, h_B_fresh, h_mod_disjoint_B, h_shape_s with + | .cmd (.init a τ (.det rhs0) md), _, h_entries, h_B_fresh, _, _ => + -- residual of a .det init = [.cmd (.set a (.det rhs0) md)]. + have h_sres : (Stmt.liftInitsInLoopBodyM (.cmd (.init a τ (.det rhs0) md)) σ).1.2.2 + = [.cmd (.set a (.det rhs0) md)] := by + rw [Stmt.liftInitsInLoopBodyM] + rw [h_sres, applyRenames_singleton] + -- the head entry pair (a, b) with b the generated fresh ident. + have h_pair_mem : (a, HasIdent.ident (P := P) (StringGenState.gen hoistFreshPrefix σ).1) ∈ subst := by + have := h_entries _ (entriesOf_init_head_mem a τ (.det rhs0) md rest σ) + exact this.2.2 + have h_a_in_A : a ∈ A := by + have := h_entries _ (entriesOf_init_head_mem a τ (.det rhs0) md rest σ) + exact this.1 + have h_b_in_B : HasIdent.ident (P := P) (StringGenState.gen hoistFreshPrefix σ).1 ∈ B := by + have := h_entries _ (entriesOf_init_head_mem a τ (.det rhs0) md rest σ) + exact this.2.1 + -- the renamed set equals the BodyTransport.init_set hoist shape. + rw [init_site_applyRenames a _ rhs0 md subst h_pair_mem h_src_nodup h_disjoint] + -- freshness of rhs0 (TARGET side only; sources need no freshness). + obtain ⟨h_B_rhs, _⟩ := namesFresh_cmd_init h_B_fresh + exact BodyTransport.init_set h_pair_mem h_a_in_A h_b_in_B + (fun a' b' hm he => unique_of_src_nodup h_src_nodup h_pair_mem a' b' hm he) + (fun a' b' hm he => unique_of_tgt_nodup h_tgt_nodup h_pair_mem a' b' hm he) + h_B_rhs h_tail + | .cmd (.init a τ ExprOrNondet.nondet md), _, h_entries, _, _, _ => + -- A nondet-rhs init is lifted like a det one: residual `[.cmd (.set a .nondet md)]`, + -- entry/rename `(a, b)`; `applyRenames` renames it to `.set b .nondet`. + have h_sres : (Stmt.liftInitsInLoopBodyM (.cmd (.init a τ ExprOrNondet.nondet md)) σ).1.2.2 + = [.cmd (.set a .nondet md)] := by + rw [Stmt.liftInitsInLoopBodyM] + rw [h_sres, applyRenames_singleton] + have h_pair_mem : (a, HasIdent.ident (P := P) (StringGenState.gen hoistFreshPrefix σ).1) ∈ subst := by + have := h_entries _ (entriesOf_init_head_mem a τ ExprOrNondet.nondet md rest σ) + exact this.2.2 + have h_a_in_A : a ∈ A := by + have := h_entries _ (entriesOf_init_head_mem a τ ExprOrNondet.nondet md rest σ) + exact this.1 + have h_b_in_B : HasIdent.ident (P := P) (StringGenState.gen hoistFreshPrefix σ).1 ∈ B := by + have := h_entries _ (entriesOf_init_head_mem a τ ExprOrNondet.nondet md rest σ) + exact this.2.1 + rw [init_nondet_site_applyRenames a _ md subst h_pair_mem h_src_nodup h_disjoint] + exact BodyTransport.init_nondet h_pair_mem h_a_in_A h_b_in_B + (fun a' b' hm he => unique_of_src_nodup h_src_nodup h_pair_mem a' b' hm he) + (fun a' b' hm he => unique_of_tgt_nodup h_tgt_nodup h_pair_mem a' b' hm he) + h_tail + | .cmd (.set name (.det rhs) md), _, _, h_B_fresh, h_mdB, _ => + -- A `.set name` is the residual verbatim; DISPATCH on whether `name` is a + -- rename SOURCE. If `name ∈ subst sources` (= `A`), the var was ALSO declared + -- (`init name`) in this body: the lift hoists the declaration and `applyRenames` + -- renames this later `.set name → .set b` (the same rename it applies at the + -- `.init` site), giving `set_renamed`. Otherwise `name ∉ A` and the name is + -- UNCHANGED by the rename, giving the plain `set`. + have h_sres : (Stmt.liftInitsInLoopBodyM (.cmd (.set name (.det rhs) md)) σ).1.2.2 + = [.cmd (.set name (.det rhs) md)] := by + simp [Stmt.liftInitsInLoopBodyM] + rw [h_sres, applyRenames_singleton] + obtain ⟨h_B_rhs, _⟩ := namesFresh_cmd_set_det h_B_fresh + have h_name_notin_B : name ∉ B := + h_mdB name (set_name_mem_modifiedVars name (.det rhs) md rest) + by_cases h_src : name ∈ subst.map Prod.fst + · -- rename source: `name = a`, target `b := renameLookup subst name`. + obtain ⟨p, hp, hp1⟩ := List.mem_map.mp h_src + have h_pair_mem : (name, p.2) ∈ subst := by cases p; cases hp1; exact hp + obtain ⟨h_a_in_A, h_b_in_B⟩ := h_subst_wf name p.2 h_pair_mem + have h_b_eq : renameLookup subst name = p.2 := + renameLookup_mem subst h_src_nodup h_pair_mem + rw [init_site_applyRenames name (renameLookup subst name) rhs md subst + (h_b_eq ▸ h_pair_mem) h_src_nodup h_disjoint] + refine BodyTransport.set_renamed (h_b_eq ▸ h_pair_mem) h_a_in_A (h_b_eq ▸ h_b_in_B) + (fun a' b' hm he => unique_of_src_nodup h_src_nodup (h_b_eq ▸ h_pair_mem) a' b' hm he) + (fun a' b' hm he => unique_of_tgt_nodup h_tgt_nodup (h_b_eq ▸ h_pair_mem) a' b' hm he) + h_B_rhs h_tail + · -- not a rename source: `name ∉ A` (since `A ⊆ sources`), name UNCHANGED. + have h_name_notin_A : name ∉ A := fun ha => h_src (h_A_subst_fst name ha) + rw [set_site_applyRenames name rhs md subst h_src h_disjoint] + exact BodyTransport.set h_name_notin_A h_name_notin_B h_B_rhs h_tail + | .cmd (.set name ExprOrNondet.nondet md), _, _, _, h_mdB, _ => + have h_sres : (Stmt.liftInitsInLoopBodyM (.cmd (.set name ExprOrNondet.nondet md)) σ).1.2.2 + = [.cmd (.set name .nondet md)] := by + simp [Stmt.liftInitsInLoopBodyM] + rw [h_sres, applyRenames_singleton] + have h_name_notin_B : name ∉ B := + h_mdB name (set_name_mem_modifiedVars name .nondet md rest) + by_cases h_src : name ∈ subst.map Prod.fst + · obtain ⟨p, hp, hp1⟩ := List.mem_map.mp h_src + have h_pair_mem : (name, p.2) ∈ subst := by cases p; cases hp1; exact hp + obtain ⟨h_a_in_A, h_b_in_B⟩ := h_subst_wf name p.2 h_pair_mem + have h_b_eq : renameLookup subst name = p.2 := + renameLookup_mem subst h_src_nodup h_pair_mem + rw [init_nondet_site_applyRenames name (renameLookup subst name) md subst + (h_b_eq ▸ h_pair_mem) h_src_nodup h_disjoint] + exact BodyTransport.set_renamed_nondet (h_b_eq ▸ h_pair_mem) h_a_in_A (h_b_eq ▸ h_b_in_B) + (fun a' b' hm he => unique_of_src_nodup h_src_nodup (h_b_eq ▸ h_pair_mem) a' b' hm he) + (fun a' b' hm he => unique_of_tgt_nodup h_tgt_nodup (h_b_eq ▸ h_pair_mem) a' b' hm he) + h_tail + · have h_name_notin_A : name ∉ A := fun ha => h_src (h_A_subst_fst name ha) + rw [set_nondet_site_applyRenames name md subst h_src h_disjoint] + exact BodyTransport.set_nondet h_name_notin_A h_name_notin_B h_tail + | .cmd (.assert lbl e md), _, h_entries, h_B_fresh, _, _ => + have h_sres : (Stmt.liftInitsInLoopBodyM (.cmd (.assert lbl e md)) σ).1.2.2 + = [.cmd (.assert lbl e md)] := by + simp [Stmt.liftInitsInLoopBodyM] + rw [h_sres, applyRenames_singleton, + stmtSubstMany_cmd_assert] + obtain ⟨h_B_e, _⟩ := namesFresh_cmd_assert h_B_fresh + exact BodyTransport.assert h_B_e h_tail + | .cmd (.assume lbl e md), _, h_entries, h_B_fresh, _, _ => + have h_sres : (Stmt.liftInitsInLoopBodyM (.cmd (.assume lbl e md)) σ).1.2.2 + = [.cmd (.assume lbl e md)] := by + simp [Stmt.liftInitsInLoopBodyM] + rw [h_sres, applyRenames_singleton, + stmtSubstMany_cmd_assume] + obtain ⟨h_B_e, _⟩ := namesFresh_cmd_assume h_B_fresh + exact BodyTransport.assume h_B_e h_tail + | .cmd (.cover lbl e md), _, h_entries, h_B_fresh, _, _ => + have h_sres : (Stmt.liftInitsInLoopBodyM (.cmd (.cover lbl e md)) σ).1.2.2 + = [.cmd (.cover lbl e md)] := by + simp [Stmt.liftInitsInLoopBodyM] + rw [h_sres, applyRenames_singleton, + stmtSubstMany_cmd_cover] + exact BodyTransport.cover h_tail + | .typeDecl tc md, _, _, _, _, _ => + -- residual of a `.typeDecl` is the typeDecl verbatim; `applyRenames`/ + -- `substIdent` leave it unchanged. + have h_sres : (Stmt.liftInitsInLoopBodyM (.typeDecl tc md) σ).1.2.2 + = [.typeDecl tc md] := by + simp [Stmt.liftInitsInLoopBodyM] + rw [h_sres, applyRenames_singleton, stmtSubstMany_typeDecl] + exact BodyTransport.typeDecl h_tail + | .exit lbl md, _, _, _, _, _ => + -- residual of an `.exit` is the exit verbatim; `applyRenames`/`substIdent` + -- leave it unchanged. + have h_sres : (Stmt.liftInitsInLoopBodyM (.exit lbl md) σ).1.2.2 + = [.exit lbl md] := by + simp [Stmt.liftInitsInLoopBodyM] + rw [h_sres, applyRenames_singleton, stmtSubstMany_exit] + exact BodyTransport.exit h_tail + | .block lbl bss md, h_if_s, h_entries, h_B_fresh, h_mdB, h_shape_s => + -- residual of a .block = [.block lbl bss_res md]. + rw [Stmt.liftInitsInLoopBodyM_block_residual, applyRenames_singleton, stmtSubstMany_block] + -- recurse on bss at σ. + have h_if_bss := initfree_block h_if_s + have h_entries_bss : EntriesIn A B subst bss σ := EntriesIn.block h_entries + obtain ⟨h_B_bss, _⟩ := namesFresh_block h_B_fresh + have h_shape_bss : Block.transportShape bss = true := by + simpa only [Stmt.transportShape] using h_shape_s + have h_inner := + Block.bodyTransport_of_lift bss σ A B subst h_if_bss h_entries_bss h_B_bss + (fun x hx => h_mdB x (modifiedVars_block_subset hx)) h_subst_wf h_A_subst_fst + h_src_nodup h_tgt_nodup h_disjoint h_shape_bss + exact BodyTransport.block h_inner h_tail + | .ite (.det g) tss ess md, h_if_s, h_entries, h_B_fresh, h_mdB, h_shape_s => + rw [Stmt.liftInitsInLoopBodyM_ite_residual, applyRenames_singleton, stmtSubstMany_ite] + have ⟨h_if_tss, h_if_ess⟩ := initfree_ite h_if_s + have h_entries_tss : EntriesIn A B subst tss σ := EntriesIn.ite_then h_entries + have h_entries_ess : EntriesIn A B subst ess (Block.liftInitsInLoopBodyM tss σ).2 := + EntriesIn.ite_else h_entries + obtain ⟨h_B_g, h_B_tss, h_B_ess, _⟩ := namesFresh_ite h_B_fresh + have h_shape_tss : Block.transportShape tss = true ∧ Block.transportShape ess = true := by + simpa only [Stmt.transportShape, Bool.and_eq_true] using h_shape_s + have h_then := + Block.bodyTransport_of_lift tss σ A B subst h_if_tss h_entries_tss h_B_tss + (fun x hx => h_mdB x (modifiedVars_ite_then_subset hx)) h_subst_wf h_A_subst_fst + h_src_nodup h_tgt_nodup h_disjoint h_shape_tss.1 + have h_else := + Block.bodyTransport_of_lift ess (Block.liftInitsInLoopBodyM tss σ).2 A B subst + h_if_ess h_entries_ess h_B_ess + (fun x hx => h_mdB x (modifiedVars_ite_else_subset hx)) h_subst_wf h_A_subst_fst + h_src_nodup h_tgt_nodup h_disjoint h_shape_tss.2 + exact BodyTransport.ite h_B_g h_then h_else h_tail + | .ite ExprOrNondet.nondet tss ess md, h_if_s, h_entries, h_B_fresh, h_mdB, h_shape_s => + rw [Stmt.liftInitsInLoopBodyM_ite_residual, applyRenames_singleton, stmtSubstMany_ite_nondet] + have ⟨h_if_tss, h_if_ess⟩ := initfree_ite h_if_s + have h_entries_tss : EntriesIn A B subst tss σ := EntriesIn.ite_then h_entries + have h_entries_ess : EntriesIn A B subst ess (Block.liftInitsInLoopBodyM tss σ).2 := + EntriesIn.ite_else h_entries + obtain ⟨h_B_tss, h_B_ess⟩ := namesFresh_ite_nondet h_B_fresh + have h_shape_tss : Block.transportShape tss = true ∧ Block.transportShape ess = true := by + simpa only [Stmt.transportShape, Bool.and_eq_true] using h_shape_s + have h_then := + Block.bodyTransport_of_lift tss σ A B subst h_if_tss h_entries_tss h_B_tss + (fun x hx => h_mdB x (modifiedVars_ite_then_subset hx)) h_subst_wf h_A_subst_fst + h_src_nodup h_tgt_nodup h_disjoint h_shape_tss.1 + have h_else := + Block.bodyTransport_of_lift ess (Block.liftInitsInLoopBodyM tss σ).2 A B subst + h_if_ess h_entries_ess h_B_ess + (fun x hx => h_mdB x (modifiedVars_ite_else_subset hx)) h_subst_wf h_A_subst_fst + h_src_nodup h_tgt_nodup h_disjoint h_shape_tss.2 + exact BodyTransport.ite_nondet h_then h_else h_tail + | .loop (.det g) none [] lbody md, h_if_s, h_entries, h_B_fresh, h_mdB, h_shape_s => + -- residual of a nested .loop is the loop verbatim. + have h_sres : (Stmt.liftInitsInLoopBodyM (.loop (.det g) none [] lbody md) σ).1.2.2 + = [.loop (.det g) none [] lbody md] := by + simp [Stmt.liftInitsInLoopBodyM] + rw [h_sres, applyRenames_singleton, stmtSubstMany_loop_det] + -- the loop body is init-free, so its entries are []. + obtain ⟨h_noinits, h_if_lbody⟩ := initfree_loop_noinits h_if_s + have h_lbody_iv : Block.initVars lbody = [] := + Block.initVars_eq_nil_of_noInitsAnywhere lbody h_noinits + -- recurse on lbody at σ; its entries are empty so EntriesIn holds vacuously. + have h_entries_lbody : EntriesIn A B subst lbody σ := by + intro e he + rw [Block.entriesOf_noInits lbody σ h_noinits] at he + simp at he + obtain ⟨h_B_g, h_B_lbody, _⟩ := namesFresh_loop h_B_fresh + have h_shape_lbody : Block.transportShape lbody = true := by + simpa only [Stmt.transportShape] using h_shape_s + have h_lbody := + Block.bodyTransport_of_lift lbody σ A B subst h_if_lbody h_entries_lbody + h_B_lbody + (fun x hx => h_mdB x (modifiedVars_loop_subset hx)) h_subst_wf h_A_subst_fst + h_src_nodup h_tgt_nodup h_disjoint h_shape_lbody + -- the lift residual of an init-free body is the body verbatim. + rw [Block.liftInitsInLoopBodyM_snd_no_inits lbody σ h_lbody_iv] at h_lbody + exact BodyTransport.loop h_B_g h_lbody h_tail + -- The remaining head shapes are excluded by `transportShape` (a measured / + -- invariant-bearing / nondet-guard loop, or a `.funcDecl`). + | .loop (.det g) (some me) inv lbody md, _, _, _, _, h_shape => + exact absurd h_shape (by simp [Stmt.transportShape]) + | .loop (.det g) none (i :: inv) lbody md, _, _, _, _, h_shape => + exact absurd h_shape (by simp [Stmt.transportShape]) + | .loop ExprOrNondet.nondet m inv lbody md, _, _, _, _, h_shape => + exact absurd h_shape (by simp [Stmt.transportShape]) + | .funcDecl d md, _, _, _, _, h_shape => + exact absurd h_shape (by simp [Stmt.transportShape]) + termination_by sizeOf body₁ + +/-! ## Step B builder: the producer's `BodyTransport` becomes the driver's +sum-typed `BodySimSum`. + +`Block.bodyTransport_of_lift` produces a `BodyTransport` derivation; +`LoopInitHoistBodyTransport.Block.bodyTransport` turns it into the eval-carrying, +SUM-TYPED `BodySimES`; `OptEStepBProvider.bodySimES_to_bodySimSum` forgets the eval +conjunct to land in the driver's `BodySimSum` slot (terminal-OR-exiting). This +packages Step B for the §E `.loop` arm at the harvest carriers `A B subst` and +admits a loop body that breaks (`.exit`). -/ +theorem Block.stepB_bodySim_of_lift [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + (body₁ : List (Stmt P (Cmd P))) (σ : StringGenState) + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) + (h_initfree : Block.allLoopBodiesInitFree body₁ = true) + (h_entries : EntriesIn A B subst body₁ σ) + (h_B_fresh : Block.namesFreshInExprs B body₁ = true) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars body₁, x ∉ B) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_shape : Block.transportShape body₁ = true) + (h_subst_fst_A : ∀ a ∈ subst.map Prod.fst, a ∈ A) + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_subst_snd_B : ∀ b ∈ subst.map Prod.snd, b ∈ B) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + LoopInitHoistLoopDriver.BodySimSum (extendEval := extendEval) A B subst + body₁ + (Block.applyRenames subst (Block.liftInitsInLoopBodyM body₁ σ).1.2.2) := by + -- `BodySimES` (eval-carrying, sum-typed, `@[expose]`) drives into + -- `LoopInitHoistLoopDriver.BodySimSum` via `bodySimES_to_bodySimSum`, dropping the + -- eval conjunct from each (terminal and exiting) output. + have hBES : OptEStepBProvider.BodySimES (extendEval := extendEval) A B subst body₁ + (Block.applyRenames subst (Block.liftInitsInLoopBodyM body₁ σ).1.2.2) := + LoopInitHoistBodyTransport.Block.bodyTransport (extendEval := extendEval) + (Block.bodyTransport_of_lift body₁ σ A B subst h_initfree h_entries h_B_fresh + h_mod_disjoint_B h_subst_wf h_A_subst_fst h_src_nodup h_tgt_nodup h_disjoint h_shape) + h_subst_fst_A h_A_subst_fst h_subst_snd_B h_src_nodup h_disjoint h_tgt_nodup + h_wfvar h_wfcongr h_wfsubst h_wfdef + exact OptEStepBProvider.bodySimES_to_bodySimSum hBES + +/-- The FAILING-config sibling of `Block.stepB_bodySim_of_lift`: the same lift's +`BodyTransport` derivation, fed to `Block.bodyTransport_to_fail`, yields a +`BodySimFail` for the rewritten loop body (a failing source-body run is matched by a +failing renamed-lifted-body run). -/ +theorem Block.stepB_bodySim_of_lift_fail [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasBoolVal P] [HasIdent P] [HasSubstFvar P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {extendEval : ExtendEval P} + (body₁ : List (Stmt P (Cmd P))) (σ : StringGenState) + (A B : List P.Ident) (subst : List (P.Ident × P.Ident)) + (h_initfree : Block.allLoopBodiesInitFree body₁ = true) + (h_entries : EntriesIn A B subst body₁ σ) + (h_B_fresh : Block.namesFreshInExprs B body₁ = true) + (h_mod_disjoint_B : ∀ x ∈ Block.modifiedVars body₁, x ∉ B) + (h_subst_wf : ∀ a b, (a, b) ∈ subst → a ∈ A ∧ b ∈ B) + (h_src_nodup : (subst.map Prod.fst).Nodup) + (h_tgt_nodup : (subst.map Prod.snd).Nodup) + (h_disjoint : ∀ a ∈ subst.map Prod.fst, a ∉ subst.map Prod.snd) + (h_shape : Block.transportShape body₁ = true) + (h_subst_fst_A : ∀ a ∈ subst.map Prod.fst, a ∈ A) + (h_A_subst_fst : ∀ a ∈ A, a ∈ subst.map Prod.fst) + (h_subst_snd_B : ∀ b ∈ subst.map Prod.snd, b ∈ B) + (h_wfvar : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (h_wfcongr : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (h_wfsubst : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (h_wfdef : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) : + OptEStepBProvider.BodySimFail (extendEval := extendEval) A B subst + body₁ + (Block.applyRenames subst (Block.liftInitsInLoopBodyM body₁ σ).1.2.2) := + LoopInitHoistBodyTransport.Block.bodyTransport_to_fail (extendEval := extendEval) + (Block.bodyTransport_of_lift body₁ σ A B subst h_initfree h_entries h_B_fresh + h_mod_disjoint_B h_subst_wf h_A_subst_fst h_src_nodup h_tgt_nodup h_disjoint h_shape) + h_subst_fst_A h_A_subst_fst h_subst_snd_B h_src_nodup h_disjoint h_tgt_nodup + h_wfvar h_wfcongr h_wfsubst h_wfdef + +end LoopInitHoistStepCProducer +end Imperative + +end -- public section diff --git a/Strata/Transform/NondetElim.lean b/Strata/Transform/NondetElim.lean new file mode 100644 index 0000000000..a5826a9473 --- /dev/null +++ b/Strata/Transform/NondetElim.lean @@ -0,0 +1,457 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.DL.Imperative.Stmt +public import Strata.DL.Imperative.Cmd +public import Strata.DL.Util.LabelGen + +public section + +namespace Imperative + +open LabelGen (StringGenM) + +/-! # `nondetElim` — structured-to-structured nondeterministic-control elimination + +Replaces every nondeterministic `.ite`/`.loop` guard with a deterministic read +of a freshly-generated boolean variable that is havoc'd at the construct's site. +After the pass, no `.ite`/`.loop` carries a `.nondet` guard; nondeterminism +survives only as havoc commands. + +The fresh-name prefixes are distinct from the str2unstr translator's +`$__nondet_*` prefixes so the two passes' generated names are unmistakable in +origin; disjointness in the proofs is suffix-based, not prefix-based. -/ + +/-- Fresh-name prefix for nondet `.ite` guard variables. -/ +@[expose] def ndelimItePrefix : String := "$__ndelim_ite$" + +/-- Fresh-name prefix for nondet `.loop` guard variables. -/ +@[expose] def ndelimLoopPrefix : String := "$__ndelim_loop$" + +mutual +/-- Rewrite a single statement, eliminating nondeterministic control. Threads a +`StringGenState`. For `.ite .nondet`, allocates a fresh boolean `$g`, emits a +local `init $g := *` before the rewritten ite, and makes the guard `.det $g`. +For `.loop .nondet`, emits a before-loop `init $g := *`, makes the guard +`.det $g`, and appends a body-tail `set $g := *` (re-havoc each iteration). Det +constructs and atomic commands pass through, recursing into sub-bodies. -/ +@[expose] def Stmt.nondetElimM {P : PureExpr} + [HasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) : StringGenM (List (Stmt P (Cmd P))) := + match s with + | .cmd c => fun σ => ([.cmd c], σ) + | .block lbl bss md => fun σ => + let (bss', σ') := Block.nondetElimM bss σ + ([.block lbl bss' md], σ') + | .ite (.det e) tss ess md => fun σ => + let (tss', σ₁) := Block.nondetElimM tss σ + let (ess', σ₂) := Block.nondetElimM ess σ₁ + ([.ite (.det e) tss' ess' md], σ₂) + | .ite .nondet tss ess md => fun σ => + let (g, σ₁) := StringGenState.gen ndelimItePrefix σ + let ident := HasIdent.ident (P := P) g + let (tss', σ₂) := Block.nondetElimM tss σ₁ + let (ess', σ₃) := Block.nondetElimM ess σ₂ + ([.cmd (HasInit.init ident HasBool.boolTy .nondet md), + .ite (.det (HasFvar.mkFvar ident)) tss' ess' md], σ₃) + | .loop (.det e) m inv body md => fun σ => + let (body', σ') := Block.nondetElimM body σ + ([.loop (.det e) m inv body' md], σ') + | .loop .nondet m inv body md => fun σ => + let (g, σ₁) := StringGenState.gen ndelimLoopPrefix σ + let ident := HasIdent.ident (P := P) g + let (body', σ₂) := Block.nondetElimM body σ₁ + ([.cmd (HasInit.init ident HasBool.boolTy .nondet md), + .loop (.det (HasFvar.mkFvar ident)) m inv + (body' ++ [.cmd (HasHavoc.havoc ident md)]) md], σ₂) + | .exit lbl md => fun σ => ([.exit lbl md], σ) + | .funcDecl d md => fun σ => ([.funcDecl d md], σ) + | .typeDecl t md => fun σ => ([.typeDecl t md], σ) + termination_by sizeOf s + +/-- Apply `Stmt.nondetElimM` to each statement of the block, threading the state +and concatenating the resulting lists. -/ +@[expose] def Block.nondetElimM {P : PureExpr} + [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) : StringGenM (List (Stmt P (Cmd P))) := + match ss with + | [] => fun σ => ([], σ) + | s :: rest => fun σ => + let (ss_s, σ₁) := Stmt.nondetElimM s σ + let (ss_r, σ₂) := Block.nondetElimM rest σ₁ + (ss_s ++ ss_r, σ₂) + termination_by sizeOf ss +end + +section Projections + +theorem Stmt.nondetElimM_block_out {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (lbl : String) (bss : List (Stmt P (Cmd P))) (md : MetaData P) (σ : StringGenState) : + (Stmt.nondetElimM (.block lbl bss md) σ).1 = + [Stmt.block lbl (Block.nondetElimM bss σ).1 md] := by + rw [Stmt.nondetElimM] + rcases h : Block.nondetElimM bss σ with ⟨bss', σ'⟩ + simp only [h] + +theorem Stmt.nondetElimM_ite_det_out {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (e : P.Expr) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) (σ : StringGenState) : + (Stmt.nondetElimM (.ite (.det e) tss ess md) σ).1 = + [Stmt.ite (.det e) (Block.nondetElimM tss σ).1 + (Block.nondetElimM ess (Block.nondetElimM tss σ).2).1 md] := by + rw [Stmt.nondetElimM] + rcases h₁ : Block.nondetElimM tss σ with ⟨tss', σ₁⟩ + rcases h₂ : Block.nondetElimM ess σ₁ with ⟨ess', σ₂⟩ + simp only [h₁, h₂] + +theorem Stmt.nondetElimM_ite_nondet_out {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) (σ : StringGenState) : + (Stmt.nondetElimM (.ite .nondet tss ess md) σ).1 = + let g := (StringGenState.gen ndelimItePrefix σ).1 + let ident := HasIdent.ident (P := P) g + let σ₁ := (StringGenState.gen ndelimItePrefix σ).2 + [Stmt.cmd (HasInit.init ident HasBool.boolTy .nondet md), + Stmt.ite (.det (HasFvar.mkFvar ident)) (Block.nondetElimM tss σ₁).1 + (Block.nondetElimM ess (Block.nondetElimM tss σ₁).2).1 md] := by + rw [Stmt.nondetElimM] + rcases hg : StringGenState.gen ndelimItePrefix σ with ⟨g, σ₁⟩ + rcases h₁ : Block.nondetElimM tss σ₁ with ⟨tss', σ₂⟩ + rcases h₂ : Block.nondetElimM ess σ₂ with ⟨ess', σ₃⟩ + simp only [hg, h₁, h₂] + +theorem Stmt.nondetElimM_loop_det_out {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (e : P.Expr) (m : Option P.Expr) (inv : List (String × P.Expr)) + (body : List (Stmt P (Cmd P))) (md : MetaData P) (σ : StringGenState) : + (Stmt.nondetElimM (.loop (.det e) m inv body md) σ).1 = + [Stmt.loop (.det e) m inv (Block.nondetElimM body σ).1 md] := by + rw [Stmt.nondetElimM] + rcases h : Block.nondetElimM body σ with ⟨body', σ'⟩ + simp only [h] + +theorem Stmt.nondetElimM_loop_nondet_out {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (m : Option P.Expr) (inv : List (String × P.Expr)) + (body : List (Stmt P (Cmd P))) (md : MetaData P) (σ : StringGenState) : + (Stmt.nondetElimM (.loop .nondet m inv body md) σ).1 = + let g := (StringGenState.gen ndelimLoopPrefix σ).1 + let ident := HasIdent.ident (P := P) g + let σ₁ := (StringGenState.gen ndelimLoopPrefix σ).2 + [Stmt.cmd (HasInit.init ident HasBool.boolTy .nondet md), + Stmt.loop (.det (HasFvar.mkFvar ident)) m inv + ((Block.nondetElimM body σ₁).1 ++ [Stmt.cmd (HasHavoc.havoc ident md)]) md] := by + rw [Stmt.nondetElimM] + rcases hg : StringGenState.gen ndelimLoopPrefix σ with ⟨g, σ₁⟩ + rcases h : Block.nondetElimM body σ₁ with ⟨body', σ₂⟩ + simp only [hg, h] + +theorem Block.nondetElimM_cons_out {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) (σ : StringGenState) : + (Block.nondetElimM (s :: rest) σ).1 = + (Stmt.nondetElimM s σ).1 ++ + (Block.nondetElimM rest (Stmt.nondetElimM s σ).2).1 := by + rw [Block.nondetElimM] + rcases h₁ : Stmt.nondetElimM s σ with ⟨ss_s, σ₁⟩ + rcases h₂ : Block.nondetElimM rest σ₁ with ⟨ss_r, σ₂⟩ + simp only [h₁, h₂] + +end Projections + +/-- Pure top-level wrapper: run the monadic pass from the empty `StringGenState` +and discard the final state. -/ +@[expose] def Block.nondetElim {P : PureExpr} + [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) : List (Stmt P (Cmd P)) := + (Block.nondetElimM ss StringGenState.emp).1 + +section Preservation + +/-- `Block.loopHasNoInvariants` distributes over `++`. -/ +theorem Block.loopHasNoInvariants_append {P : PureExpr} (xs ys : List (Stmt P (Cmd P))) : + Block.loopHasNoInvariants (xs ++ ys) = + (Block.loopHasNoInvariants xs && Block.loopHasNoInvariants ys) := by + induction xs with + | nil => simp [Block.loopHasNoInvariants] + | cons x rest ih => simp [Block.loopHasNoInvariants, ih, Bool.and_assoc] + +/-- `Block.noMeasureLoops` distributes over `++`. -/ +theorem Block.noMeasureLoops_append {P : PureExpr} (xs ys : List (Stmt P (Cmd P))) : + Block.noMeasureLoops (xs ++ ys) = + (Block.noMeasureLoops xs && Block.noMeasureLoops ys) := by + induction xs with + | nil => simp [Block.noMeasureLoops] + | cons x rest ih => simp [Block.noMeasureLoops, ih, Bool.and_assoc] + +/-- `Block.noFuncDecl` distributes over `++`. -/ +theorem Block.noFuncDecl_append {P : PureExpr} (xs ys : List (Stmt P (Cmd P))) : + Block.noFuncDecl (xs ++ ys) = + (Block.noFuncDecl xs && Block.noFuncDecl ys) := by + induction xs with + | nil => simp [Block.noFuncDecl] + | cons x rest ih => simp [Block.noFuncDecl, ih, Bool.and_assoc] + +mutual +/-- `Stmt.nondetElimM` preserves `loopHasNoInvariants`: the rewrite passes loop +invariant lists through unchanged and adds no labeled-invariant loops. -/ +theorem Stmt.nondetElimM_loopHasNoInvariants {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) (σ : StringGenState) + (h : Stmt.loopHasNoInvariants s = true) : + Block.loopHasNoInvariants (Stmt.nondetElimM s σ).1 = true := by + match s with + | .cmd c => simp [Stmt.nondetElimM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + | .block lbl bss md => + rw [Stmt.nondetElimM_block_out] + simp only [Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, Bool.and_true] + rw [Stmt.loopHasNoInvariants] at h + exact Block.nondetElimM_loopHasNoInvariants bss σ h + | .ite (.det e) tss ess md => + rw [Stmt.nondetElimM_ite_det_out] + rw [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h + simp only [Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, Bool.and_true, + Block.nondetElimM_loopHasNoInvariants tss σ h.1, + Block.nondetElimM_loopHasNoInvariants ess _ h.2] + | .ite .nondet tss ess md => + rw [Stmt.nondetElimM_ite_nondet_out] + rw [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h + simp only [Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, Bool.and_true, + Block.nondetElimM_loopHasNoInvariants tss _ h.1, + Block.nondetElimM_loopHasNoInvariants ess _ h.2] + | .loop (.det e) m inv body md => + rw [Stmt.nondetElimM_loop_det_out] + rw [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h + simp only [Block.loopHasNoInvariants, Stmt.loopHasNoInvariants, Bool.and_true, + h.1, Block.nondetElimM_loopHasNoInvariants body σ h.2] + | .loop .nondet m inv body md => + rw [Stmt.nondetElimM_loop_nondet_out] + rw [Stmt.loopHasNoInvariants, Bool.and_eq_true] at h + simp only [Block.loopHasNoInvariants_append, Block.loopHasNoInvariants, + Stmt.loopHasNoInvariants, Bool.and_true, h.1, + Block.nondetElimM_loopHasNoInvariants body _ h.2] + | .exit lbl md => simp [Stmt.nondetElimM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + | .funcDecl d md => simp [Stmt.nondetElimM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + | .typeDecl t md => simp [Stmt.nondetElimM, Block.loopHasNoInvariants, Stmt.loopHasNoInvariants] + termination_by sizeOf s + +theorem Block.nondetElimM_loopHasNoInvariants {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h : Block.loopHasNoInvariants ss = true) : + Block.loopHasNoInvariants (Block.nondetElimM ss σ).1 = true := by + match ss with + | [] => simp [Block.nondetElimM, Block.loopHasNoInvariants] + | s :: rest => + rw [Block.loopHasNoInvariants, Bool.and_eq_true] at h + rw [Block.nondetElimM_cons_out, Block.loopHasNoInvariants_append] + simp only [Stmt.nondetElimM_loopHasNoInvariants s σ h.1, + Block.nondetElimM_loopHasNoInvariants rest _ h.2, Bool.and_true] + termination_by sizeOf ss +end + +mutual +/-- `Stmt.nondetElimM` preserves `noMeasureLoops`: the rewrite passes loop +measures through unchanged and adds no measured loops. -/ +theorem Stmt.nondetElimM_noMeasureLoops {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) (σ : StringGenState) + (h : Stmt.noMeasureLoops s = true) : + Block.noMeasureLoops (Stmt.nondetElimM s σ).1 = true := by + match s with + | .cmd c => simp [Stmt.nondetElimM, Block.noMeasureLoops, Stmt.noMeasureLoops] + | .block lbl bss md => + rw [Stmt.nondetElimM_block_out] + simp only [Block.noMeasureLoops, Stmt.noMeasureLoops, Bool.and_true] + rw [Stmt.noMeasureLoops] at h + exact Block.nondetElimM_noMeasureLoops bss σ h + | .ite (.det e) tss ess md => + rw [Stmt.nondetElimM_ite_det_out] + rw [Stmt.noMeasureLoops, Bool.and_eq_true] at h + simp only [Block.noMeasureLoops, Stmt.noMeasureLoops, Bool.and_true, + Block.nondetElimM_noMeasureLoops tss σ h.1, + Block.nondetElimM_noMeasureLoops ess _ h.2] + | .ite .nondet tss ess md => + rw [Stmt.nondetElimM_ite_nondet_out] + rw [Stmt.noMeasureLoops, Bool.and_eq_true] at h + simp only [Block.noMeasureLoops, Stmt.noMeasureLoops, Bool.and_true, + Block.nondetElimM_noMeasureLoops tss _ h.1, + Block.nondetElimM_noMeasureLoops ess _ h.2] + | .loop (.det e) m inv body md => + rw [Stmt.nondetElimM_loop_det_out] + rw [Stmt.noMeasureLoops, Bool.and_eq_true] at h + simp only [Block.noMeasureLoops, Stmt.noMeasureLoops, Bool.and_true, + h.1, Block.nondetElimM_noMeasureLoops body σ h.2] + | .loop .nondet m inv body md => + rw [Stmt.nondetElimM_loop_nondet_out] + rw [Stmt.noMeasureLoops, Bool.and_eq_true] at h + simp only [Block.noMeasureLoops_append, Block.noMeasureLoops, + Stmt.noMeasureLoops, Bool.and_true, h.1, + Block.nondetElimM_noMeasureLoops body _ h.2] + | .exit lbl md => simp [Stmt.nondetElimM, Block.noMeasureLoops, Stmt.noMeasureLoops] + | .funcDecl d md => simp [Stmt.nondetElimM, Block.noMeasureLoops, Stmt.noMeasureLoops] + | .typeDecl t md => simp [Stmt.nondetElimM, Block.noMeasureLoops, Stmt.noMeasureLoops] + termination_by sizeOf s + +theorem Block.nondetElimM_noMeasureLoops {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h : Block.noMeasureLoops ss = true) : + Block.noMeasureLoops (Block.nondetElimM ss σ).1 = true := by + match ss with + | [] => simp [Block.nondetElimM, Block.noMeasureLoops] + | s :: rest => + rw [Block.noMeasureLoops, Bool.and_eq_true] at h + rw [Block.nondetElimM_cons_out, Block.noMeasureLoops_append] + simp only [Stmt.nondetElimM_noMeasureLoops s σ h.1, + Block.nondetElimM_noMeasureLoops rest _ h.2, Bool.and_true] + termination_by sizeOf ss +end + +mutual +/-- `Stmt.nondetElimM` preserves `noFuncDecl`: the rewrite never emits a +function declaration and passes `.funcDecl` through unchanged (so under the +hypothesis the `.funcDecl` arm is vacuous). -/ +theorem Stmt.nondetElimM_noFuncDecl {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) (σ : StringGenState) + (h : Stmt.noFuncDecl s = true) : + Block.noFuncDecl (Stmt.nondetElimM s σ).1 = true := by + match s with + | .cmd c => simp [Stmt.nondetElimM, Block.noFuncDecl, Stmt.noFuncDecl] + | .block lbl bss md => + rw [Stmt.nondetElimM_block_out] + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_true] + rw [Stmt.noFuncDecl] at h + exact Block.nondetElimM_noFuncDecl bss σ h + | .ite (.det e) tss ess md => + rw [Stmt.nondetElimM_ite_det_out] + rw [Stmt.noFuncDecl, Bool.and_eq_true] at h + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_true, + Block.nondetElimM_noFuncDecl tss σ h.1, + Block.nondetElimM_noFuncDecl ess _ h.2] + | .ite .nondet tss ess md => + rw [Stmt.nondetElimM_ite_nondet_out] + rw [Stmt.noFuncDecl, Bool.and_eq_true] at h + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_true, + Block.nondetElimM_noFuncDecl tss _ h.1, + Block.nondetElimM_noFuncDecl ess _ h.2] + | .loop (.det e) m inv body md => + rw [Stmt.nondetElimM_loop_det_out] + simp only [Block.noFuncDecl, Stmt.noFuncDecl, Bool.and_true] + rw [Stmt.noFuncDecl] at h + exact Block.nondetElimM_noFuncDecl body σ h + | .loop .nondet m inv body md => + rw [Stmt.nondetElimM_loop_nondet_out] + rw [Stmt.noFuncDecl] at h + simp only [Block.noFuncDecl_append, Block.noFuncDecl, + Stmt.noFuncDecl, Bool.and_true, + Block.nondetElimM_noFuncDecl body _ h] + | .exit lbl md => simp [Stmt.nondetElimM, Block.noFuncDecl, Stmt.noFuncDecl] + | .funcDecl d md => exact absurd h (by simp [Stmt.noFuncDecl]) + | .typeDecl t md => simp [Stmt.nondetElimM, Block.noFuncDecl, Stmt.noFuncDecl] + termination_by sizeOf s + +theorem Block.nondetElimM_noFuncDecl {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h : Block.noFuncDecl ss = true) : + Block.noFuncDecl (Block.nondetElimM ss σ).1 = true := by + match ss with + | [] => simp [Block.nondetElimM, Block.noFuncDecl] + | s :: rest => + rw [Block.noFuncDecl, Bool.and_eq_true] at h + rw [Block.nondetElimM_cons_out, Block.noFuncDecl_append] + simp only [Stmt.nondetElimM_noFuncDecl s σ h.1, + Block.nondetElimM_noFuncDecl rest _ h.2, Bool.and_true] + termination_by sizeOf ss +end + +/-- Top-level preservation: `Block.nondetElim` preserves `loopHasNoInvariants`. -/ +theorem nondetElim_loopHasNoInvariants {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (h : Block.loopHasNoInvariants ss = true) : + Block.loopHasNoInvariants (Block.nondetElim ss) = true := + Block.nondetElimM_loopHasNoInvariants ss StringGenState.emp h + +/-- Top-level preservation: `Block.nondetElim` preserves `noMeasureLoops`. -/ +theorem nondetElim_noMeasureLoops {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (h : Block.noMeasureLoops ss = true) : + Block.noMeasureLoops (Block.nondetElim ss) = true := + Block.nondetElimM_noMeasureLoops ss StringGenState.emp h + +/-- Top-level preservation: `Block.nondetElim` preserves `noFuncDecl`. -/ +theorem nondetElim_noFuncDecl {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (h : Block.noFuncDecl ss = true) : + Block.noFuncDecl (Block.nondetElim ss) = true := + Block.nondetElimM_noFuncDecl ss StringGenState.emp h + +mutual +/-- The pass advances the generator state by a `GenStep`: it only ever calls +`StringGenState.gen` (which is a `GenStep`), so well-formedness is preserved and +the generated-labels list only grows. -/ +theorem Stmt.nondetElimM_genStep {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + StringGenState.GenStep σ (Stmt.nondetElimM s σ).2 := by + match s with + | .cmd c => simp only [Stmt.nondetElimM]; exact StringGenState.GenStep.refl _ + | .block lbl bss md => + rw [Stmt.nondetElimM] + rcases h : Block.nondetElimM bss σ with ⟨bss', σ'⟩ + simp only [h] + have := Block.nondetElimM_genStep bss σ + rw [h] at this; exact this + | .ite (.det e) tss ess md => + rw [Stmt.nondetElimM] + rcases h₁ : Block.nondetElimM tss σ with ⟨tss', σ₁⟩ + rcases h₂ : Block.nondetElimM ess σ₁ with ⟨ess', σ₂⟩ + simp only [h₁, h₂] + have g₁ := Block.nondetElimM_genStep tss σ + have g₂ := Block.nondetElimM_genStep ess σ₁ + rw [h₁] at g₁; rw [h₂] at g₂ + exact StringGenState.GenStep.trans g₁ g₂ + | .ite .nondet tss ess md => + rw [Stmt.nondetElimM] + rcases hg : StringGenState.gen ndelimItePrefix σ with ⟨g, σ₁⟩ + rcases h₁ : Block.nondetElimM tss σ₁ with ⟨tss', σ₂⟩ + rcases h₂ : Block.nondetElimM ess σ₂ with ⟨ess', σ₃⟩ + simp only [hg, h₁, h₂] + have g₀ : StringGenState.GenStep σ σ₁ := by + have := StringGenState.GenStep.of_gen ndelimItePrefix σ; rw [hg] at this; exact this + have g₁ := Block.nondetElimM_genStep tss σ₁ + have g₂ := Block.nondetElimM_genStep ess σ₂ + rw [h₁] at g₁; rw [h₂] at g₂ + exact StringGenState.GenStep.trans g₀ (StringGenState.GenStep.trans g₁ g₂) + | .loop (.det e) m inv body md => + rw [Stmt.nondetElimM] + rcases h : Block.nondetElimM body σ with ⟨body', σ'⟩ + simp only [h] + have := Block.nondetElimM_genStep body σ + rw [h] at this; exact this + | .loop .nondet m inv body md => + rw [Stmt.nondetElimM] + rcases hg : StringGenState.gen ndelimLoopPrefix σ with ⟨g, σ₁⟩ + rcases h : Block.nondetElimM body σ₁ with ⟨body', σ₂⟩ + simp only [hg, h] + have g₀ : StringGenState.GenStep σ σ₁ := by + have := StringGenState.GenStep.of_gen ndelimLoopPrefix σ; rw [hg] at this; exact this + have g₁ := Block.nondetElimM_genStep body σ₁ + rw [h] at g₁ + exact StringGenState.GenStep.trans g₀ g₁ + | .exit lbl md => simp only [Stmt.nondetElimM]; exact StringGenState.GenStep.refl _ + | .funcDecl d md => simp only [Stmt.nondetElimM]; exact StringGenState.GenStep.refl _ + | .typeDecl t md => simp only [Stmt.nondetElimM]; exact StringGenState.GenStep.refl _ + termination_by sizeOf s + +theorem Block.nondetElimM_genStep {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + StringGenState.GenStep σ (Block.nondetElimM ss σ).2 := by + match ss with + | [] => simp only [Block.nondetElimM]; exact StringGenState.GenStep.refl _ + | s :: rest => + rw [Block.nondetElimM] + rcases h₁ : Stmt.nondetElimM s σ with ⟨ss_s, σ₁⟩ + rcases h₂ : Block.nondetElimM rest σ₁ with ⟨ss_r, σ₂⟩ + simp only [h₁, h₂] + have g₁ := Stmt.nondetElimM_genStep s σ + have g₂ := Block.nondetElimM_genStep rest σ₁ + rw [h₁] at g₁; rw [h₂] at g₂ + exact StringGenState.GenStep.trans g₁ g₂ + termination_by sizeOf ss +end + +end Preservation + +end Imperative diff --git a/Strata/Transform/NondetElimCorrect.lean b/Strata/Transform/NondetElimCorrect.lean new file mode 100644 index 0000000000..12d9347162 --- /dev/null +++ b/Strata/Transform/NondetElimCorrect.lean @@ -0,0 +1,4802 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.Transform.NondetElim +public import Strata.Transform.LoopInitHoist +public import Strata.DL.Imperative.StmtSemantics +public import Strata.DL.Imperative.CmdSemantics +public import Strata.DL.Imperative.StmtSemanticsProps +import all Strata.DL.Imperative.StmtSemanticsProps +import all Strata.DL.Util.StringGen +import all Strata.DL.Util.Relations + +public section + +namespace Imperative + +/-- The simulated source/target outcome configuration, parametrized on an +`Option String` selector: `none` denotes the terminal outcome `.terminal ρ`, +`some lbl` denotes the exiting outcome `.exiting lbl ρ`. Both mutual simulation +lemmas conclude over this shape so that a source run reaching *either* outcome is +matched by the rewritten program reaching the *same* outcome; the `.exiting` +selector is what lets the `.block` simulation arm discharge the case where the +block body exits to a non-matching label (caught by `step_block_exit_mismatch`) +or to the block's own label (caught by `step_block_exit_match`). -/ +@[expose] def outcomeConfig {P : PureExpr} (oc : Option String) (ρ : Env P) : + Config P (Cmd P) := + match oc with + | none => .terminal ρ + | some lbl => .exiting lbl ρ + +/-! ## Structural postcondition: the pass output has no nondeterministic control + +`Block.simpleShape` holds of every output of `Block.nondetElim` (spec guarantee +2): the rewrite replaces each nondeterministic `.ite`/`.loop` guard with a +deterministic read, so no `.ite .nondet`/`.loop .nondet` survives. -/ + +/-- `Block.simpleShape` distributes over `++`. -/ +theorem Block.simpleShape_append {P : PureExpr} (xs ys : List (Stmt P (Cmd P))) : + Block.simpleShape (xs ++ ys) = + (Block.simpleShape xs && Block.simpleShape ys) := by + induction xs with + | nil => simp [Block.simpleShape] + | cons x rest ih => simp [Block.simpleShape, ih, Bool.and_assoc] + +mutual +/-- The output of `Stmt.nondetElimM s σ` satisfies `simpleShape` (no +nondeterministic control). -/ +theorem Stmt.nondetElimM_simpleShape {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.simpleShape (Stmt.nondetElimM s σ).1 = true := by + match s with + | .cmd c => simp [Stmt.nondetElimM, Block.simpleShape, Stmt.simpleShape] + | .block lbl bss md => + rw [Stmt.nondetElimM_block_out] + simp only [Block.simpleShape, Stmt.simpleShape, Bool.and_true] + exact Block.nondetElimM_simpleShape bss σ + | .ite (.det e) tss ess md => + rw [Stmt.nondetElimM_ite_det_out] + simp only [Block.simpleShape, Stmt.simpleShape, Bool.and_true, + Block.nondetElimM_simpleShape tss σ, + Block.nondetElimM_simpleShape ess _] + | .ite .nondet tss ess md => + rw [Stmt.nondetElimM_ite_nondet_out] + simp only [Block.simpleShape, Stmt.simpleShape, Bool.and_true, + Block.nondetElimM_simpleShape tss _, + Block.nondetElimM_simpleShape ess _] + | .loop (.det e) m inv body md => + rw [Stmt.nondetElimM_loop_det_out] + simp only [Block.simpleShape, Stmt.simpleShape, Bool.and_true] + exact Block.nondetElimM_simpleShape body σ + | .loop .nondet m inv body md => + rw [Stmt.nondetElimM_loop_nondet_out] + simp only [Block.simpleShape, Stmt.simpleShape, Block.simpleShape_append, + Bool.and_true, + Block.nondetElimM_simpleShape body _] + | .exit lbl md => simp [Stmt.nondetElimM, Block.simpleShape, Stmt.simpleShape] + | .funcDecl d md => simp [Stmt.nondetElimM, Block.simpleShape, Stmt.simpleShape] + | .typeDecl t md => simp [Stmt.nondetElimM, Block.simpleShape, Stmt.simpleShape] + termination_by sizeOf s + +theorem Block.nondetElimM_simpleShape {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.simpleShape (Block.nondetElimM ss σ).1 = true := by + match ss with + | [] => simp [Block.nondetElimM, Block.simpleShape] + | s :: rest => + rw [Block.nondetElimM_cons_out, Block.simpleShape_append] + simp only [Stmt.nondetElimM_simpleShape s σ, + Block.nondetElimM_simpleShape rest _, Bool.and_true] + termination_by sizeOf ss +end + +/-- Top-level structural postcondition: `Block.nondetElim` output has no +nondeterministic control (spec guarantee 2). -/ +theorem nondetElim_simpleShape {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) : + Block.simpleShape (Block.nondetElim ss) = true := + Block.nondetElimM_simpleShape ss StringGenState.emp + +/-! ## Foundation lemmas for the simulation proof + +These are fully-proved building blocks for `nondetElim_simulation`, reused +arm-by-arm. They live outside the main inductive lemma so that each can be +verified independently. -/ + +section Foundation + +/-- A terminating empty statement list leaves the environment unchanged. -/ +theorem stmts_nil_terminal_eq {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (ρ ρ' : Env P) + (h : StepStmtStar P (EvalCmd P) extendEval (.stmts [] ρ) (.terminal ρ')) : + ρ = ρ' := by + cases h with + | step _ _ _ hstep hrest => + cases hstep with + | step_stmts_nil => + cases hrest with + | refl => rfl + | step _ _ _ h _ => cases h + +/-- A single statement that runs to terminal also runs to terminal when wrapped +as a singleton statement list. This is the bridge from the `.stmt s` shape of +the source-side step rules to the `.stmts [s]` shape that the pass emits for the +pass-through `.cmd` arm. -/ +theorem stmt_to_singleton_stmts {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (s : Stmt P (Cmd P)) (ρ ρ' : Env P) + (h : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (.terminal ρ')) : + StepStmtStar P (EvalCmd P) extendEval (.stmts [s] ρ) (.terminal ρ') := + ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval s [] ρ ρ' h) + (evalStmtsSmallNil P (EvalCmd P) extendEval ρ') + +/-- Exiting variant of `stmt_to_singleton_stmts`: a single statement exiting +yields the singleton list exiting. -/ +theorem stmt_to_singleton_stmts_exiting {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (s : Stmt P (Cmd P)) (ρ ρ' : Env P) (lbl : String) + (h : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (.exiting lbl ρ')) : + StepStmtStar P (EvalCmd P) extendEval (.stmts [s] ρ) (.exiting lbl ρ') := by + refine .step _ _ _ .step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ (seq_inner_star P (EvalCmd P) extendEval _ _ [] h) ?_ + exact .step _ _ _ .step_seq_exit (.refl _) + +/-- Outcome-generic variant of `stmt_to_singleton_stmts`: a single statement +reaching `outcomeConfig oc ρ'` yields the singleton list reaching the same +outcome. -/ +theorem stmt_to_singleton_stmts_outcome {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + (s : Stmt P (Cmd P)) (ρ ρ' : Env P) (oc : Option String) + (h : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (outcomeConfig oc ρ')) : + StepStmtStar P (EvalCmd P) extendEval (.stmts [s] ρ) (outcomeConfig oc ρ') := by + cases oc with + | none => exact stmt_to_singleton_stmts (extendEval := extendEval) s ρ ρ' h + | some lbl => exact stmt_to_singleton_stmts_exiting (extendEval := extendEval) s ρ ρ' lbl h + +/-- Outcome-generic decomposition of `.stmts (s :: rest)`: a run reaching +`outcomeConfig oc ρ'` either (a) had the head `s` exit (so `oc = some lbl` and +the whole list exits with that label, skipping `rest`), or (b) had `s` terminate +to some `ρ_mid` after which `rest` reached the same outcome. -/ +theorem stmts_cons_outcome {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) (oc : Option String) + (h : StepStmtStar P (EvalCmd P) extendEval (.stmts (s :: rest) ρ) (outcomeConfig oc ρ')) : + (∃ lbl, oc = some lbl ∧ + StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (.exiting lbl ρ')) ∨ + (∃ ρ_mid, StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (.terminal ρ_mid) ∧ + StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ_mid) (outcomeConfig oc ρ')) := by + -- Reduce `outcomeConfig` to a concrete constructor before inverting the run, + -- so dependent elimination on the `.stmts (s :: rest)` head step succeeds. + cases oc with + | none => + simp only [outcomeConfig] at h ⊢ + cases h with + | step _ _ _ hstep hrest => + cases hstep with + | step_stmts_cons => + have ⟨ρ_mid, h_s, h_tail⟩ := seq_reaches_terminal P (EvalCmd P) extendEval hrest + exact .inr ⟨ρ_mid, h_s, h_tail⟩ + | some lbl => + simp only [outcomeConfig] at h ⊢ + cases h with + | step _ _ _ hstep hrest => + cases hstep with + | step_stmts_cons => + rcases seq_reaches_exiting P (EvalCmd P) extendEval hrest with + h_s | ⟨ρ_mid, h_s, h_tail⟩ + · exact .inl ⟨lbl, rfl, h_s⟩ + · exact .inr ⟨ρ_mid, h_s, h_tail⟩ + +/-- Forward: if a prefix list `pfx` exits with `lbl`, then `pfx ++ sfx` exits +with `lbl` (the suffix is skipped). Mirrors `stmts_prefix_terminal_append` for +the exiting outcome. -/ +theorem stmts_cons_head_exiting_append {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (pfx sfx : List (Stmt P (Cmd P))) (ρ ρ' : Env P) (lbl : String) + (h : StepStmtStar P (EvalCmd P) extendEval (.stmts pfx ρ) (.exiting lbl ρ')) : + StepStmtStar P (EvalCmd P) extendEval (.stmts (pfx ++ sfx) ρ) (.exiting lbl ρ') := by + induction pfx generalizing ρ with + | nil => + -- `.stmts [] ρ` cannot exit. + exfalso + cases h with + | step _ _ _ hstep hrest => + cases hstep with + | step_stmts_nil => cases hrest with | step _ _ _ h _ => cases h + | cons s rest ih => + cases h with + | step _ _ _ hstep hrest => + cases hstep with + | step_stmts_cons => + rcases seq_reaches_exiting P (EvalCmd P) extendEval hrest with + h_s | ⟨ρ₁, h_term, h_tail⟩ + · -- head `s` exits: lift through `step_stmts_cons`/`step_seq_exit`. + refine .step _ _ _ .step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ (rest ++ sfx) h_s) ?_ + exact .step _ _ _ .step_seq_exit (.refl _) + · -- head terminates to ρ₁, recurse on `rest`. + exact ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval s (rest ++ sfx) ρ ρ₁ h_term) + (ih ρ₁ h_tail) + +/-- Store update that defines `ident := b`, leaving every other variable +untouched. This is the post-state of `init $g := *` / `set $g := *` when the +havoc picks value `b`. -/ +@[expose] def storeWith {P : PureExpr} [DecidableEq P.Ident] (σ : SemanticStore P) (ident : P.Ident) (b : P.Expr) : + SemanticStore P := + fun y => if y = ident then some b else σ y + +/-- Defining a fresh guard variable in the target store preserves +`StoreAgreement` with the source: the only changed slot is `ident`, which the +source store does not define (one-directionality of `StoreAgreement`). This is +the mechanism by which the generated `$g` stays hidden from the source. -/ +theorem storeAgreement_storeWith {P : PureExpr} [DecidableEq P.Ident] + (σ_src σ_tgt : SemanticStore P) (ident : P.Ident) (b : P.Expr) + (h_agree : StoreAgreement σ_src σ_tgt) + (h_src_none : σ_src ident = none) : + StoreAgreement σ_src (storeWith σ_tgt ident b) := by + intro x h_def + have h_x_def : (σ_src x).isSome = true := h_def x (List.mem_singleton.mpr rfl) + have h_ne : x ≠ ident := by + rintro rfl; rw [h_src_none] at h_x_def; exact absurd h_x_def (by simp) + rw [h_agree x h_def] + simp [storeWith, h_ne] + +/-- `init $g := *` (havoc-init) with the chosen value `b` steps `.stmt (init …)` +to terminal with the slot defined to `b`, provided the slot was undefined. +The havoc value is existentially chosen by `eval_init_unconstrained`. -/ +theorem step_init_havoc_to {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + (ident : P.Ident) (ty : P.Ty) (b : P.Expr) (md : MetaData P) (ρ : Env P) + (h_none : ρ.store ident = none) + (hwf_var : WellFormedSemanticEvalVar ρ.eval) : + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd (HasInit.init ident ty (.nondet) md)) ρ) + (.terminal ({ ρ with store := storeWith ρ.store ident b } : Env P)) := by + have h_init : EvalCmd P ρ.eval ρ.store (.init ident ty .nondet md) + (storeWith ρ.store ident b) false := by + apply EvalCmd.eval_init_unconstrained (v := b) + · exact InitState.init h_none (by simp [storeWith]) (by + intro y hy; simp [storeWith, Ne.symm hy]) + · exact hwf_var + have h_step := StepStmt.step_cmd (P := P) (EvalCmd := EvalCmd P) + (extendEval := extendEval) (ρ := ρ) (c := HasInit.init ident ty .nondet md) + (σ' := storeWith ρ.store ident b) (hasAssertFailure := false) h_init + refine .step _ _ _ ?_ (.refl _) + simpa [Bool.or_false] using h_step + +/-- `havoc $g` (= `set $g := *`) with the chosen value `b` steps +`.stmt (.cmd (havoc ident))` to terminal with the slot re-defined to `b`, +provided the slot was *already* defined (UpdateState's precondition). The +havoc value is existentially chosen by `eval_set_nondet`. This is the +per-iteration re-havoc emitted at the body tail of the rewritten nondet loop. -/ +theorem step_havoc_set_to {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + (ident : P.Ident) (b : P.Expr) (md : MetaData P) (ρ : Env P) + (v' : P.Expr) (h_def : ρ.store ident = some v') + (hwf_var : WellFormedSemanticEvalVar ρ.eval) : + StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd (HasHavoc.havoc ident md)) ρ) + (.terminal ({ ρ with store := storeWith ρ.store ident b } : Env P)) := by + have h_set : EvalCmd P ρ.eval ρ.store (.set ident .nondet md) + (storeWith ρ.store ident b) false := by + apply EvalCmd.eval_set_nondet (v := b) + · exact UpdateState.update h_def (by simp [storeWith]) (by + intro y hy; simp [storeWith, Ne.symm hy]) + · exact hwf_var + have h_step := StepStmt.step_cmd (P := P) (EvalCmd := EvalCmd P) + (extendEval := extendEval) (ρ := ρ) (c := HasHavoc.havoc ident md) + (σ' := storeWith ρ.store ident b) (hasAssertFailure := false) + (by simpa only [HasHavoc.havoc] using h_set) + refine .step _ _ _ ?_ (.refl _) + simpa [Bool.or_false] using h_step + +/-- Reading the guard variable `mkFvar ident` out of a `storeWith _ ident b` +store yields exactly `b`. Uses `WellFormedSemanticEvalVar` (the evaluator reads +free variables straight from the store) plus the `getFvar (mkFvar _)` round-trip +(`LawfulHasFvar`). -/ +theorem eval_mkFvar_storeWith {P : PureExpr} [HasFvar P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] [LawfulHasFvar P] + (δ : SemanticEval P) (σ : SemanticStore P) (ident : P.Ident) (b : P.Expr) + (hwf_var : WellFormedSemanticEvalVar δ) : + δ (storeWith σ ident b) (HasFvar.mkFvar ident) = some b := by + have h := hwf_var (HasFvar.mkFvar (P := P) ident) ident (storeWith σ ident b) + (LawfulHasFvar.getFvar_mkFvar ident) + rw [h] + simp [storeWith] + +/-! ### Agreement-preserving replay of a single source command + +A source-side `EvalCmd c σ_src₀ σ_src₁ failed` can be replayed on a target store +`σ_tgt₀` that agrees with `σ_src₀` (in the `StoreAgreement` sense), producing a +`σ_tgt₁` that agrees with `σ_src₁`. This is the workhorse of the pass-through +`.cmd` arm: the rewrite is the identity on `.cmd`, so the target replays the +exact same command, and we only need that the command's evaluation depends on +the store solely through the source-visible part. Ported (self-contained) from +the analogous replay machinery in `structuredToUnstructured_sound_kind`. -/ + +/-- Invert a single `.cmd` execution: `.stmt (.cmd c) ρ →* .terminal ρ'` is +exactly one `step_cmd`, exposing the `EvalCmd` witness and the post-state. -/ +theorem cmd_step_inv {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 (.stmt (.cmd c) ρ) (.terminal ρ')) : + ∃ σ' haf, EvalCmd P ρ.eval ρ.store c σ' haf ∧ + ρ' = { ρ with store := σ', hasFailure := ρ.hasFailure || haf } := by + cases h with + | step _ _ _ hstep hrest => + cases hstep with + | step_cmd hcmd => + cases hrest with + | refl => exact ⟨_, _, hcmd, rfl⟩ + | step _ _ _ h _ => cases h + +/-- Invert a single `.stmt s` execution to terminal: the first step is +`step_stmts_cons`-free; `s` itself steps to some `c`, then `c →* terminal`. -/ +theorem stmt_step_first_inv {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} (s : Stmt P (Cmd P)) (ρ ρ' : Env P) + (h : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) (.terminal ρ')) : + ∃ c, StepStmt P (EvalCmd P) extendEval (.stmt s ρ) c ∧ + StepStmtStar P (EvalCmd P) extendEval c (.terminal ρ') := by + cases h with + | step _ mid _ hstep hrest => exact ⟨mid, hstep, hrest⟩ + +/-- First-step inversion to *any* target config: a `.stmt s ρ` reaching some +non-`.stmt`-shaped `tgt` must take at least one step (a `.stmt` is never itself a +terminal/exiting/etc. config), exposing the first step `c` and the residual run. +Used by the unified (terminal-or-exiting) simulation arms. -/ +theorem stmt_step_first_inv_to {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} (s : Stmt P (Cmd P)) (ρ : Env P) (tgt : Config P (Cmd P)) + (h_ne : ∀ ρ', tgt ≠ .stmt s ρ') + (h : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) tgt) : + ∃ c, StepStmt P (EvalCmd P) extendEval (.stmt s ρ) c ∧ + StepStmtStar P (EvalCmd P) extendEval c tgt := by + cases h with + | refl => exact absurd rfl (h_ne ρ) + | step _ mid _ hstep hrest => exact ⟨mid, hstep, hrest⟩ + +/-- Outcome-generic source nondeterministic-`ite` inversion: the chosen branch +runs to the same outcome (terminal or exiting). -/ +theorem ite_nondet_step_inv_outcome {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) (ρ ρ' : Env P) (oc : Option String) + (h : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.ite .nondet tss ess md) ρ) (outcomeConfig oc ρ')) : + StepStmtStar P (EvalCmd P) extendEval (.stmts tss ρ) (outcomeConfig oc ρ') ∨ + StepStmtStar P (EvalCmd P) extendEval (.stmts ess ρ) (outcomeConfig oc ρ') := by + obtain ⟨c, hstep, hrest⟩ := + stmt_step_first_inv_to (extendEval := extendEval) _ ρ (outcomeConfig oc ρ') + (by intro ρ'' h; cases oc <;> simp only [outcomeConfig] at h <;> cases h) h + cases hstep with + | step_ite_nondet_true => exact Or.inl hrest + | step_ite_nondet_false => exact Or.inr hrest + +/-- A `.seq` whose inner config runs to terminal and whose continuation list is +empty itself runs to that same terminal. (The trailing `step_seq_done` lands on +`.stmts [] ρ'`, which is one `step_stmts_nil` from `.terminal ρ'`.) -/ +theorem seq_nil_terminal {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (inner : Config P (Cmd P)) (ρ' : Env P) + (h : StepStmtStar P (EvalCmd P) extendEval inner (.terminal ρ')) : + StepStmtStar P (EvalCmd P) extendEval (.seq inner []) (.terminal ρ') := by + have h1 : StepStmtStar P (EvalCmd P) extendEval (.seq inner []) (.seq (.terminal ρ') []) := + seq_inner_star P (EvalCmd P) extendEval _ _ [] h + refine ReflTrans_Transitive _ _ _ _ h1 ?_ + refine .step _ _ _ .step_seq_done ?_ + exact evalStmtsSmallNil P (EvalCmd P) extendEval ρ' + +/-- Outcome-generic `.seq inner []`: if `inner` reaches `outcomeConfig oc ρ'`, +the seq with empty continuation reaches the same outcome (terminal flows through +`step_seq_done`; exiting flows through `step_seq_exit`). -/ +theorem seq_nil_outcome {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + (inner : Config P (Cmd P)) (ρ' : Env P) (oc : Option String) + (h : StepStmtStar P (EvalCmd P) extendEval inner (outcomeConfig oc ρ')) : + StepStmtStar P (EvalCmd P) extendEval (.seq inner []) (outcomeConfig oc ρ') := by + cases oc with + | none => exact seq_nil_terminal (extendEval := extendEval) inner ρ' h + | some lbl => + have h1 : StepStmtStar P (EvalCmd P) extendEval (.seq inner []) (.seq (.exiting lbl ρ') []) := + seq_inner_star P (EvalCmd P) extendEval _ _ [] h + refine ReflTrans_Transitive _ _ _ _ h1 ?_ + exact .step _ _ _ .step_seq_exit (.refl _) + +/-- Outcome-generic `.ite .nondet` prefix replay (then side): the chosen branch +`tss` reaching `outcomeConfig oc ρt'` drives the emitted prefix to the same +outcome (havoc value `tt`). -/ +theorem step_ndelim_ite_prefix_outcome {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] [LawfulHasFvar P] {extendEval : ExtendEval P} + (b : Bool) (ident : P.Ident) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (ρ ρt' : Env P) (oc : Option String) + (h_none : ρ.store ident = none) + (hwf_var : WellFormedSemanticEvalVar ρ.eval) + (hwfb : WellFormedSemanticEvalBool ρ.eval) + (h_branch : StepStmtStar P (EvalCmd P) extendEval + (.stmts (if b then tss else ess) + ({ ρ with store := storeWith ρ.store ident (if b then HasBool.tt else HasBool.ff) } : Env P)) + (outcomeConfig oc ρt')) : + StepStmtStar P (EvalCmd P) extendEval + (.stmts [.cmd (HasInit.init ident HasBool.boolTy (.nondet) md), + .ite (.det (HasFvar.mkFvar ident)) tss ess md] ρ) + (outcomeConfig oc ρt') := by + let v : P.Expr := if b then HasBool.tt else HasBool.ff + let ρg : Env P := { ρ with store := storeWith ρ.store ident v } + have h1 : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.cmd (HasInit.init ident HasBool.boolTy (.nondet) md), + .ite (.det (HasFvar.mkFvar ident)) tss ess md] ρ) + (.stmts [.ite (.det (HasFvar.mkFvar ident)) tss ess md] ρg) := + stmts_cons_step P (EvalCmd P) extendEval _ _ ρ ρg + (step_init_havoc_to (extendEval := extendEval) ident HasBool.boolTy v md ρ h_none hwf_var) + have h_guard : ρg.eval ρg.store (HasFvar.mkFvar ident) = some v := + eval_mkFvar_storeWith ρ.eval ρ.store ident v hwf_var + have hwfb' : WellFormedSemanticEvalBool ρg.eval := hwfb + have h2 : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.ite (.det (HasFvar.mkFvar ident)) tss ess md] ρg) (outcomeConfig oc ρt') := by + refine .step _ _ _ .step_stmts_cons ?_ + cases b with + | true => + exact .step _ _ _ (.step_seq_inner (.step_ite_true h_guard hwfb')) + (seq_nil_outcome (extendEval := extendEval) _ _ oc h_branch) + | false => + exact .step _ _ _ (.step_seq_inner (.step_ite_false h_guard hwfb')) + (seq_nil_outcome (extendEval := extendEval) _ _ oc h_branch) + exact ReflTrans_Transitive _ _ _ _ h1 h2 + +/-- From a *clean*-start statement run reaching a *failing* config, the run takes +at least one step. (A refl run would keep the config at `.stmt s ρ`, whose +`getEnv` is the clean `ρ`, contradicting the failing flag.) Exposes the first +step and residual. -/ +theorem clean_stmt_first_step {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {s : Stmt P (Cmd P)} {ρ : Env P} {c : Config P (Cmd P)} + (h_reach : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) c) + (hc : c.getEnv.hasFailure = true) + (h_clean : ρ.hasFailure = false) : + ∃ cfg, StepStmt P (EvalCmd P) extendEval (.stmt s ρ) cfg ∧ + StepStmtStar P (EvalCmd P) extendEval cfg c := by + cases h_reach with + | refl => exact absurd (by simpa [Config.getEnv] using hc) (by rw [h_clean]; simp) + | step _ mid _ hstep hrest => exact ⟨mid, hstep, hrest⟩ + +/-- Singleton-list failing lift: a single statement reaching a *failing* config +(not necessarily terminal/exiting) yields the singleton list reaching a failing +config. The residual `d` is wrapped as `.seq d []`, whose `getEnv` (hence failure +flag) is `d`'s. -/ +theorem stmt_to_singleton_stmts_fail {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + (s : Stmt P (Cmd P)) (ρ : Env P) (d : Config P (Cmd P)) + (h : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ) d) + (hd : d.getEnv.hasFailure = true) : + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts [s] ρ) d' + ∧ d'.getEnv.hasFailure = true := + ⟨.seq d ([] : List (Stmt P (Cmd P))), + .step _ _ _ StepStmt.step_stmts_cons (seq_inner_star P (EvalCmd P) extendEval _ _ _ h), + by simpa [Config.getEnv] using hd⟩ + +/-- Failing `.ite .nondet` prefix replay (then side): the chosen branch `tss` +reaching a *failing* config drives the emitted `init $g; ite $g` prefix to a +failing config (havoc value `tt`). -/ +theorem step_ndelim_ite_prefix_fail {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] [LawfulHasFvar P] {extendEval : ExtendEval P} + (b : Bool) (ident : P.Ident) (tss ess : List (Stmt P (Cmd P))) (md : MetaData P) + (ρ : Env P) (d : Config P (Cmd P)) + (h_none : ρ.store ident = none) + (hwf_var : WellFormedSemanticEvalVar ρ.eval) + (hwfb : WellFormedSemanticEvalBool ρ.eval) + (h_branch : StepStmtStar P (EvalCmd P) extendEval + (.stmts (if b then tss else ess) + ({ ρ with store := storeWith ρ.store ident (if b then HasBool.tt else HasBool.ff) } : Env P)) d) + (hd : d.getEnv.hasFailure = true) : + ∃ d', StepStmtStar P (EvalCmd P) extendEval + (.stmts [.cmd (HasInit.init ident HasBool.boolTy (.nondet) md), + .ite (.det (HasFvar.mkFvar ident)) tss ess md] ρ) d' + ∧ d'.getEnv.hasFailure = true := by + let v : P.Expr := if b then HasBool.tt else HasBool.ff + let ρg : Env P := { ρ with store := storeWith ρ.store ident v } + have h1 : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.cmd (HasInit.init ident HasBool.boolTy (.nondet) md), + .ite (.det (HasFvar.mkFvar ident)) tss ess md] ρ) + (.stmts [.ite (.det (HasFvar.mkFvar ident)) tss ess md] ρg) := + stmts_cons_step P (EvalCmd P) extendEval _ _ ρ ρg + (step_init_havoc_to (extendEval := extendEval) ident HasBool.boolTy v md ρ h_none hwf_var) + have h_guard : ρg.eval ρg.store (HasFvar.mkFvar ident) = some v := + eval_mkFvar_storeWith ρ.eval ρ.store ident v hwf_var + -- The single-statement `.ite` enters the chosen branch, which reaches `d` (failing). + have h_ite : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.ite (.det (HasFvar.mkFvar ident)) tss ess md) ρg) d := by + cases b with + | true => exact .step _ _ _ (.step_ite_true h_guard hwfb) h_branch + | false => exact .step _ _ _ (.step_ite_false h_guard hwfb) h_branch + obtain ⟨d', h2, hd'⟩ := + stmt_to_singleton_stmts_fail (extendEval := extendEval) + (.ite (.det (HasFvar.mkFvar ident)) tss ess md) ρg d h_ite hd + exact ⟨d', ReflTrans_Transitive _ _ _ _ h1 h2, hd'⟩ + +/-! ### ReflTransT decomposition helpers (for the loop fuel induction) + +These are pure structured-semantics facts about `StepStmt`/`ReflTransT` (the +*Type*-valued, length-carrying multi-step closure). They split a run that +reaches `.terminal` into its constituent sub-runs while exposing a strict +length decrease, which is what feeds the `decreasing_by`/`termination_by` +fuel induction used by the `.loop` simulation arms. They are independent of +the rewritten (target) program shape, so they hold over the source semantics +verbatim. -/ + +/-- Split a `.seq inner ss` run reaching `.terminal` into a run of the inner +config to `.terminal` followed by a run of the remaining statements, with the +two sub-run lengths summing strictly below the original. -/ +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 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 + +/-- Split a `(s :: rest)` statement-list run reaching `.terminal` into a run of +the head statement to `.terminal` followed by a run of the tail, with a `+ 2` +length slack (the `step_stmts_cons` and `step_seq_done` administrative steps). -/ +theorem stmtsT_cons_terminal {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {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 := extendEval) hrest + exact ⟨ρ₁, h1, h2, by simp [ReflTransT.len]; omega⟩ + +/-- Invert a block execution reaching terminal when the inner config cannot +exit: the inner reaches terminal with a strictly shorter derivation, and the +block's result store is the inner store projected through the parent store. -/ +theorem blockT_reaches_terminal_noExit {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {inner : Config P (Cmd P)} {l : Option String} {σ_parent : SemanticStore P} {ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.block l σ_parent inner) (.terminal ρ')) + (h_no_exit : ∀ lbl ρ_x, + ¬ StepStmtStar P (EvalCmd P) extendEval inner (.exiting lbl ρ_x)) : + ∃ (ρ_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 h_no_exit' : ∀ lbl ρ_x, + ¬ StepStmtStar P (EvalCmd P) extendEval inner₁ (.exiting lbl ρ_x) := by + intro lbl ρ_x hinner₁ + exact h_no_exit lbl ρ_x (.step _ _ _ h hinner₁) + have ⟨ρ_inner, hterm, heq, hlen⟩ := blockT_reaches_terminal_noExit hrest h_no_exit' + 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 _) hrest => + exfalso + exact h_no_exit _ _ (.refl _) + | .step _ _ _ (.step_block_exit_mismatch _) hrest => + match hrest with + | .step _ _ _ h _ => exact nomatch h + +/-- With an empty invariant list, the `hasInvFailure` flag returned by any +`step_loop_*` rule is vacuously `false`: the boolean iff cannot witness an +invariant in an empty list. -/ +theorem empty_inv_no_failure + {α : Type} {Q : α → Prop} {hasInvFailure : Bool} + (hff_iff : hasInvFailure = true ↔ ∃ le, le ∈ ([] : List α) ∧ Q le) : + hasInvFailure = false := by + cases hb : hasInvFailure with + | false => rfl + | true => + rw [hb] at hff_iff + have ⟨_, hmem, _⟩ := hff_iff.mp rfl + exact ((List.mem_nil_iff _).mp hmem).elim + +/-- Type-valued inversion of an *anonymous* (`.none`-labeled) block reaching +terminal: the inner config reaches terminal with a strictly shorter derivation, +and the block's result store is the inner store projected through the parent +store. Unlike `blockT_reaches_terminal_noExit`, no `h_no_exit` premise is +needed — a `.none` block can never match an exiting label, so the only way to +reach `.terminal` is for the inner config to terminate. -/ +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 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 => + -- `.none = .some l` is impossible. + exact nomatch heq + | .step _ _ _ (.step_block_exit_mismatch _) hrest => + match hrest with + | .step _ _ _ h _ => exact nomatch h + +/-- Type-valued inversion of a `.seq inner ss` run reaching `.exiting lbl`: +either the inner config exits (skipping `ss`), or the inner config terminates +and `ss` reaches the exiting outcome. Both pieces carry a strict len-decrease. -/ +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))} {lbl : String} {ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.seq inner ss) (.exiting lbl ρ')) : + (∃ (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.exiting lbl ρ')), + 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 lbl ρ')), + h1.len + h2.len < hstar.len) := by + match hstar with + | .step _ _ _ (.step_seq_inner h) hrest => + rcases seqT_reaches_exiting hrest with ⟨hexit, hlen⟩ | ⟨ρ₁, h1, h2, hlen⟩ + · exact .inl ⟨.step _ _ _ h hexit, by simp only [ReflTransT.len]; omega⟩ + · exact .inr ⟨ρ₁, .step _ _ _ h h1, h2, by simp only [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_seq_done hrest => + exact .inr ⟨_, .refl _, hrest, by simp only [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_seq_exit hrest => + exact .inl ⟨hrest, by simp only [ReflTransT.len]; omega⟩ + +/-- Type-valued inversion of an anonymous (`.none`-labeled) block reaching +`.exiting lbl`: the inner config exits with the *same* label `lbl` (the `.none` +block never matches, so the exit propagates unchanged), with a strict +len-decrease. The result store is projected through the parent store. -/ +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} {lbl : String} {ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.block .none σ_parent inner) (.exiting lbl ρ')) : + ∃ (ρ_inner : Env P) (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.exiting lbl ρ_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 hrest + exact ⟨ρ_inner, .step _ _ _ h hexit, heq, by simp only [ReflTransT.len]; omega⟩ + | .step _ _ _ (.step_block_exit_mismatch _) 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_done hrest => + match hrest with + | .step _ _ _ h _ => exact nomatch h + +/-- Type-valued inversion of a singleton statement-list `[s]` reaching +`.exiting lbl`: the head statement reaches the exiting outcome, with a strict +len-decrease (the `step_stmts_cons` administrative step). -/ +theorem stmtsT_singleton_exiting {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + {s : Stmt P (Cmd P)} {lbl : String} {ρ₀ ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmts [s] ρ₀) (.exiting lbl ρ')) : + ∃ (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt s ρ₀) (.exiting lbl ρ')), + h.len < hstar.len := by + match hstar with + | .step _ _ _ .step_stmts_cons hrest => + rcases seqT_reaches_exiting (extendEval := extendEval) hrest with ⟨hexit, hlen⟩ | ⟨ρ₁, _, h2, hlen⟩ + · exact ⟨hexit, by simp only [ReflTransT.len]; omega⟩ + · -- The tail `[]` cannot reach `.exiting`: it steps to `.terminal` only. + match h2 with + | .step _ _ _ .step_stmts_nil hr => + match hr with + | .step _ _ _ h _ => exact nomatch h + +/-- First-step inversion of a deterministic loop run reaching an outcome +(`outcomeConfig oc ρ'`). The first step is either `step_loop_exit` (guard `ff`, +residual run from `.terminal (ρ + false)`) or `step_loop_enter` (guard `tt`, +residual run from `.seq (.block .none ρ.store (.stmts body (ρ + false))) [loop]`). +With empty invariants the `hasInvFailure` flag is `false`, and the residual +carries a strict len-decrease. Casing `oc` makes the outcome target a +constructor, so the `.refl` case (which would require `outcomeConfig oc ρ' = +.stmt (.loop …)`) is ruled out by constructor mismatch. -/ +theorem loop_det_step_first_inv {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {e : P.Expr} {m : Option P.Expr} + {body : List (Stmt P (Cmd P))} {md : MetaData P} + {ρ ρ' : Env P} {oc : Option String} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop (.det e) m ([] : List (String × P.Expr)) body md) ρ) (outcomeConfig oc ρ')) : + (ρ.eval ρ.store e = some HasBool.ff ∧ WellFormedSemanticEvalBool ρ.eval ∧ + ∃ (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.terminal ({ ρ with hasFailure := ρ.hasFailure || false } : Env P)) + (outcomeConfig oc ρ')), + hrest.len < hstar.len) ∨ + (ρ.eval ρ.store e = some HasBool.tt ∧ WellFormedSemanticEvalBool ρ.eval ∧ + ∃ (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ.store (.stmts body + ({ ρ with hasFailure := ρ.hasFailure || false } : Env P))) + [.loop (.det e) m ([] : List (String × P.Expr)) body md]) + (outcomeConfig oc ρ')), + hrest.len < hstar.len) := by + cases oc with + | none => + simp only [outcomeConfig] at hstar ⊢ + match hstar with + | .step _ _ _ (@StepStmt.step_loop_exit _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure h_cond _ hff_iff hwfb_s) hrest => + have h_no : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_no + refine .inl ⟨h_cond, hwfb_s, hrest, ?_⟩ + simp only [ReflTransT.len]; omega + | .step _ _ _ (@StepStmt.step_loop_enter _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure h_cond _ hff_iff hwfb_s) hrest => + have h_no : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_no + refine .inr ⟨h_cond, hwfb_s, hrest, ?_⟩ + simp only [ReflTransT.len]; omega + | some lbl => + simp only [outcomeConfig] at hstar ⊢ + match hstar with + | .step _ _ _ (@StepStmt.step_loop_exit _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure h_cond _ hff_iff hwfb_s) hrest => + have h_no : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_no + refine .inl ⟨h_cond, hwfb_s, hrest, ?_⟩ + simp only [ReflTransT.len]; omega + | .step _ _ _ (@StepStmt.step_loop_enter _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure h_cond _ hff_iff hwfb_s) hrest => + have h_no : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_no + refine .inr ⟨h_cond, hwfb_s, hrest, ?_⟩ + simp only [ReflTransT.len]; omega + +/-- First-step inversion of a *nondeterministic* loop run reaching an outcome +(`outcomeConfig oc ρ'`). The first step is either `step_loop_nondet_exit` +(residual run from `.terminal (ρ + false)`) or `step_loop_nondet_enter` +(residual run from `.seq (.block .none ρ.store (.stmts body (ρ + false))) [loop]`). +With empty invariants the `hasInvFailure` flag is `false`, and the residual +carries a strict len-decrease. Unlike the deterministic variant there is *no* +guard read: the enter/exit choice is genuinely nondeterministic. -/ +theorem loop_nondet_step_first_inv {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {m : Option P.Expr} + {body : List (Stmt P (Cmd P))} {md : MetaData P} + {ρ ρ' : Env P} {oc : Option String} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop .nondet m ([] : List (String × P.Expr)) body md) ρ) (outcomeConfig oc ρ')) : + (∃ (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.terminal ({ ρ with hasFailure := ρ.hasFailure || false } : Env P)) + (outcomeConfig oc ρ')), + hrest.len < hstar.len) ∨ + (∃ (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ.store (.stmts body + ({ ρ with hasFailure := ρ.hasFailure || false } : Env P))) + [.loop .nondet m ([] : List (String × P.Expr)) body md]) + (outcomeConfig oc ρ')), + hrest.len < hstar.len) := by + cases oc with + | none => + simp only [outcomeConfig] at hstar ⊢ + match hstar with + | .step _ _ _ (@StepStmt.step_loop_nondet_exit _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure _ hff_iff) hrest => + have h_no : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_no + exact .inl ⟨hrest, by simp only [ReflTransT.len]; omega⟩ + | .step _ _ _ (@StepStmt.step_loop_nondet_enter _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure _ hff_iff) hrest => + have h_no : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_no + exact .inr ⟨hrest, by simp only [ReflTransT.len]; omega⟩ + | some lbl => + simp only [outcomeConfig] at hstar ⊢ + match hstar with + | .step _ _ _ (@StepStmt.step_loop_nondet_exit _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure _ hff_iff) hrest => + have h_no : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_no + exact .inl ⟨hrest, by simp only [ReflTransT.len]; omega⟩ + | .step _ _ _ (@StepStmt.step_loop_nondet_enter _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure _ hff_iff) hrest => + have h_no : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_no + exact .inr ⟨hrest, by simp only [ReflTransT.len]; omega⟩ + +/-- Failing-config first-step inversion of a *nondeterministic* loop run reaching +an arbitrary config `c` (with `c.getEnv.hasFailure = true`). Same shape as +`loop_nondet_step_first_inv` but keyed on a failing config rather than an +outcome, with one extra disjunct for the *refl* run (the loop start is itself the +failing config, forcing `ρ.hasFailure = true`): the run is either reflexive +(no step taken, `ρ` already failing), or its first step is `step_loop_nondet_exit` +(residual from `.terminal (ρ + false)`) or `step_loop_nondet_enter` (residual from +`.seq (.block .none ρ.store (.stmts body (ρ + false))) [loop]`), with the +residual carrying the failing config and a strict len-decrease. -/ +theorem loop_nondet_step_first_inv_fail {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] {extendEval : ExtendEval P} + {m : Option P.Expr} + {body : List (Stmt P (Cmd P))} {md : MetaData P} + {ρ : Env P} {c : Config P (Cmd P)} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop .nondet m ([] : List (String × P.Expr)) body md) ρ) c) + (hc : c.getEnv.hasFailure = true) : + ρ.hasFailure = true ∨ + (∃ (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.terminal ({ ρ with hasFailure := ρ.hasFailure || false } : Env P)) c), + hrest.len < hstar.len) ∨ + (∃ (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ.store (.stmts body + ({ ρ with hasFailure := ρ.hasFailure || false } : Env P))) + [.loop .nondet m ([] : List (String × P.Expr)) body md]) c), + hrest.len < hstar.len) := by + match hstar with + | .refl _ => + exact .inl (by simpa [Config.getEnv] using hc) + | .step _ _ _ (@StepStmt.step_loop_nondet_exit _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure _ hff_iff) hrest => + have h_no : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_no + exact .inr (.inl ⟨hrest, by simp only [ReflTransT.len]; omega⟩) + | .step _ _ _ (@StepStmt.step_loop_nondet_enter _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure _ hff_iff) hrest => + have h_no : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_no + exact .inr (.inr ⟨hrest, by simp only [ReflTransT.len]; omega⟩) + +/-! ### Slot-definedness frame (the gen guard survives the rewritten body) + +The generated loop guard `$g` is `init`'d in the parent (target) scope before +the loop, so it is *defined* when the per-iteration block starts. Running the +rewritten body `body'` cannot *undefine* it: `init`/`set` only ever assign +`some`, and the only operation that can turn a slot to `none` — +`projectStore` at a block boundary — gates on the block's recorded parent, where +`$g` was already defined. Hence `$g` stays defined throughout `body'`, which is +exactly the precondition for the body-tail re-havoc `set $g := *`. This frame +fact needs *no* characterization of what `body'` writes: it is a structural +property of the small-step semantics. -/ + +/-- A single `EvalCmd` never undefines a slot: any `y` that was `isSome` stays +`isSome` (`init`/`set` only assign `some`; `assert`/`assume`/`cover` keep the +store). -/ +theorem EvalCmd_preserves_isSome {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {δ : SemanticEval P} {σ σ' : SemanticStore P} {c : Cmd P} {haf : Bool} + (h : EvalCmd P δ σ c σ' haf) + {y : P.Ident} (h_some : (σ y).isSome = true) : + (σ' y).isSome = true := by + cases h with + | eval_init heval hinit hwfvar hwfcongr => + rename_i ty md x v e + cases hinit with + | init _ h_xv h_other => + by_cases hxy : x = y + · subst hxy; rw [h_xv]; rfl + · rw [h_other y hxy]; exact h_some + | eval_init_unconstrained hinit hwfvar => + rename_i ty md x v + cases hinit with + | init _ h_xv h_other => + by_cases hxy : x = y + · subst hxy; rw [h_xv]; rfl + · rw [h_other y hxy]; exact h_some + | eval_set heval hupd hwfvar hwfcongr => + rename_i md x v e + cases hupd with + | update _ h_xv h_other => + by_cases hxy : x = y + · subst hxy; rw [h_xv]; rfl + · rw [h_other y hxy]; exact h_some + | eval_set_nondet hupd hwfvar => + rename_i md x v + cases hupd with + | update _ h_xv h_other => + by_cases hxy : x = y + · subst hxy; rw [h_xv]; rfl + · rw [h_other y hxy]; exact h_some + | eval_assert_pass _ _ _ => exact h_some + | eval_assert_fail _ _ _ => exact h_some + | eval_assume _ _ _ => exact h_some + | eval_cover _ => exact h_some + +/-- `y` is defined in a config's operative store and in every block-parent on its +stack. The invariant that makes "the gen guard stays defined" step-preservable. -/ +@[expose] def GuardDefined {P : PureExpr} (y : P.Ident) : Config P (Cmd P) → Prop + | .stmt _ ρ => (ρ.store y).isSome = true + | .stmts _ ρ => (ρ.store y).isSome = true + | .terminal ρ => (ρ.store y).isSome = true + | .exiting _ ρ => (ρ.store y).isSome = true + | .block _ σ_parent inner => (σ_parent y).isSome = true ∧ GuardDefined y inner + | .seq inner _ => GuardDefined y inner + +/-- A single step preserves `GuardDefined`. -/ +theorem step_preserves_GuardDefined {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + {y : P.Ident} {c c' : Config P (Cmd P)} + (hstep : StepStmt P (EvalCmd P) extendEval c c') + (h : GuardDefined y c) : + GuardDefined y c' := by + induction hstep with + | step_cmd hcmd => + rename_i ρ cc σ' haf + exact EvalCmd_preserves_isSome hcmd h + | step_block => + rename_i label ss md ρ + exact ⟨h, h⟩ + | step_ite_true _ _ => exact h + | step_ite_false _ _ => exact h + | step_ite_nondet_true => exact h + | step_ite_nondet_false => exact h + | step_loop_enter _ _ _ _ => exact ⟨h, h⟩ + | step_loop_exit _ _ _ _ => exact h + | step_loop_nondet_enter _ _ => exact ⟨h, h⟩ + | step_loop_nondet_exit _ _ => exact h + | step_exit => exact h + | step_funcDecl => exact h + | step_typeDecl => exact h + | step_stmts_nil => exact h + | step_stmts_cons => exact h + | step_seq_inner _ ih => exact ih h + | step_seq_done => exact h + | step_seq_exit => exact h + | step_block_body _ ih => + exact ⟨h.1, ih h.2⟩ + | step_block_done => + simp only [GuardDefined, projectStore] at h ⊢ + rw [if_pos h.1]; exact h.2 + | step_block_exit_match heq => + simp only [GuardDefined, projectStore] at h ⊢ + rw [if_pos h.1]; exact h.2 + | step_block_exit_mismatch hne => + simp only [GuardDefined, projectStore] at h ⊢ + rw [if_pos h.1]; exact h.2 + +/-- Multi-step preservation of `GuardDefined`. -/ +theorem star_preserves_GuardDefined {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + {y : P.Ident} {c c' : Config P (Cmd P)} + (hstar : StepStmtStar P (EvalCmd P) extendEval c c') + (h : GuardDefined y c) : + GuardDefined y c' := by + induction hstar with + | refl => exact h + | step _ _ _ hstep _ ih => exact ih (step_preserves_GuardDefined (extendEval := extendEval) hstep h) + +/-- The gen guard `y`, defined in the start store, stays defined after running a +statement list to terminal. -/ +theorem stmts_preserves_isSome {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] {extendEval : ExtendEval P} + {y : P.Ident} {ss : List (Stmt P (Cmd P))} {ρ ρ' : Env P} + (hstar : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ) (.terminal ρ')) + (h_some : (ρ.store y).isSome = true) : + (ρ'.store y).isSome = true := + star_preserves_GuardDefined (extendEval := extendEval) hstar (show GuardDefined y (.stmts ss ρ) from h_some) + + +end Foundation + +/-! ### Freshness invariant for generated guard variables + +The simulation lemma is mutual over `Stmt`/`Block` and threads a +`StringGenState σ`. Each `.ite .nondet`/`.loop .nondet` generates a fresh guard +`g` at the *current* `σ`, defines it in the target store, then recurses at the +*advanced* state. To keep generating fresh guards legal under recursion we +track a self-preserving invariant on the target store: + +> every gen-shaped string `s` that has **not yet been generated** +> (`s ∉ σ.stringGens`) is undefined in the target store. + +A freshly generated `g` is gen-shaped (`gen_hasUnderscoreDigitSuffix`) and not +yet in `σ.stringGens` (`stringGens_gen_not_in`, needs `WF σ`), so the invariant +gives `g`'s slot is `none` — exactly the `init`/`set` precondition. After +defining `g`, the advanced state's `stringGens` gains `g`, so any *still*-ungenerated +gen-shaped `s` differs from `g` (`ident` injective) and stays `none`. -/ + +section Freshness + +/-- Target-store freshness invariant relative to a generator state `σ`, for a +*kind predicate* `Q` on label strings: every `Q`-string not yet generated by +`σ` is undefined in `σ_tgt`. Instantiating `Q := HasUnderscoreDigitSuffix` +recovers the blanket gen-shape freshness invariant; a per-kind `Q` lets a +composition argument restrict freshness to just the labels *this* pass mints. -/ +@[expose] def GenFreshStore {P : PureExpr} [HasIdent P] + (Q : String → Prop) + (σ : StringGenState) (σ_tgt : SemanticStore P) : Prop := + ∀ s, Q s → s ∉ σ.stringGens → + σ_tgt (HasIdent.ident (P := P) s) = none + +/-- The freshly-generated guard's slot is undefined in a `GenFreshStore` target, +given `WF σ` and that the freshly minted label satisfies the kind predicate. -/ +theorem GenFreshStore.gen_slot_none {P : PureExpr} [HasIdent P] + {Q : String → Prop} + {σ : StringGenState} {σ_tgt : SemanticStore P} + (pf : String) (h_fresh : GenFreshStore Q σ σ_tgt) (hwf : StringGenState.WF σ) + (hQ : Q (StringGenState.gen pf σ).1) : + σ_tgt (HasIdent.ident (P := P) (StringGenState.gen pf σ).1) = none := + h_fresh _ hQ (StringGenState.stringGens_gen_not_in pf σ hwf) + +/-- `GenFreshStore` is preserved across defining the freshly-generated guard +`g := (gen pf σ).1` (via `storeWith`), advancing the state to `(gen pf σ).2`. -/ +theorem GenFreshStore.storeWith_gen {P : PureExpr} [HasIdent P] [DecidableEq P.Ident] + [LawfulHasIdent P] + {Q : String → Prop} + {σ : StringGenState} {σ_tgt : SemanticStore P} + (pf : String) (b : P.Expr) (h_fresh : GenFreshStore Q σ σ_tgt) : + GenFreshStore Q (StringGenState.gen pf σ).2 + (storeWith σ_tgt (HasIdent.ident (P := P) (StringGenState.gen pf σ).1) b) := by + intro s h_suf h_nin + rw [StringGenState.stringGens_gen] at h_nin + have h_ne_g : s ≠ (StringGenState.gen pf σ).1 := fun h => h_nin (h ▸ List.mem_cons_self) + have h_nin_σ : s ∉ σ.stringGens := fun h => h_nin (List.mem_cons_of_mem _ h) + have h_ident_ne : + HasIdent.ident (P := P) s ≠ HasIdent.ident (P := P) (StringGenState.gen pf σ).1 := + fun h => h_ne_g (LawfulHasIdent.ident_inj h) + show (if HasIdent.ident (P := P) s = _ then some b else _) = none + rw [if_neg h_ident_ne] + exact h_fresh s h_suf h_nin_σ + +/-- `GenFreshStore` strengthens as the generator advances: once more names have +been generated (`GenStep σ σ'`), there are *fewer* ungenerated gen-shaped names, +so the "ungenerated ⟹ undefined" obligation is easier to meet. -/ +theorem GenFreshStore.mono {P : PureExpr} [HasIdent P] + {Q : String → Prop} + {σ σ' : StringGenState} {σ_tgt : SemanticStore P} + (h_step : StringGenState.GenStep σ σ') + (h_fresh : GenFreshStore Q σ σ_tgt) : + GenFreshStore Q σ' σ_tgt := by + intro s h_suf h_nin + exact h_fresh s h_suf (fun h => h_nin (h_step.subset h)) + +end Freshness + +/-! ### Source store-frame preservation + +A source command/statement execution can only change store slots that the +command *defines* (for `init`) or *modifies* (for `set`); a slot that was +`none` and is neither defined nor a `set` target stays `none`. This is the +mechanism by which the source side preserves freshness of gen-shaped names +across sequencing (the names a source program writes are user names, never +gen-shaped). -/ + +section SrcFrame + +/-- A single `EvalCmd` preserves a `none` slot `y` that the command does not +define and does not assign to. (`set`/`init` to `y` are the only writers; both +list `y` only when it is their target.) -/ +theorem evalCmd_preserves_none {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + {δ : SemanticEval P} {σ σ' : SemanticStore P} {c : Cmd P} {haf : Bool} + (h : EvalCmd P δ σ c σ' haf) + {y : P.Ident} + (h_none : σ y = none) + (h_not_def : y ∉ Cmd.definedVars c) + (h_not_mod : y ∉ Cmd.modifiedVars c) : + σ' y = none := by + cases h with + | eval_init heval hinit hwfvar hwfcongr => + rename_i ty md x v e + have h_ne : x ≠ y := by + intro h_eq; apply h_not_def + rw [h_eq]; with_unfolding_all exact List.mem_singleton.mpr rfl + cases hinit with + | init _ _ h_other => rw [h_other y h_ne]; exact h_none + | eval_init_unconstrained hinit hwfvar => + rename_i ty md x v + have h_ne : x ≠ y := by + intro h_eq; apply h_not_def + rw [h_eq]; with_unfolding_all exact List.mem_singleton.mpr rfl + cases hinit with + | init _ _ h_other => rw [h_other y h_ne]; exact h_none + | eval_set heval hupd hwfvar hwfcongr => + rename_i md x v e + have h_ne : x ≠ y := by + intro h_eq; apply h_not_mod + rw [h_eq]; with_unfolding_all exact List.mem_singleton.mpr rfl + cases hupd with + | update _ _ h_other => rw [h_other y h_ne]; exact h_none + | eval_set_nondet hupd hwfvar => + rename_i md x v + have h_ne : x ≠ y := by + intro h_eq; apply h_not_mod + rw [h_eq]; with_unfolding_all exact List.mem_singleton.mpr rfl + cases hupd with + | update _ _ h_other => rw [h_other y h_ne]; exact h_none + | eval_assert_pass _ _ _ => exact h_none + | eval_assert_fail _ _ _ => exact h_none + | eval_assume _ _ _ => exact h_none + | eval_cover _ => exact h_none + +end SrcFrame + +/-! ### Source-shape precondition (spec §7) + +The simulation is only sound for source programs that never `init`/`set` a +gen-shaped (`HasUnderscoreDigitSuffix`) variable. Spec §7 states this as an +explicit assumption: the front-ends feeding this pipeline never write such +names, and a source program that re-`init`s a parent-scoped variable inside a +loop body is already stuck under the existing semantics, independent of this +pass. Without it the theorem is false — a pass-through source +`.cmd (set "$g_0" .nondet)` defines a gen-shaped slot, after which a later +`.ite .nondet`'s inserted `init $g := *` would collide and be stuck. + +We carry it as `NoGenSuffix` over the block's defined + modified variables +(mirroring `structuredToUnstructured_sound_kind`'s threaded `NoGenSuffix` on +`definedVars ++ initVars` / `modifiedVars`). Membership in `++` distributes +the obligation across sequencing and recursion automatically. -/ + +/-- Every ident in `xs` was supplied by user source: it is `HasIdent.ident s` +only for strings `s` that do *not* satisfy the kind predicate `Q` (the kind of +label this pass mints). Instantiating `Q := HasUnderscoreDigitSuffix` recovers +the blanket "no statement writes a gen-shaped variable" condition. -/ +@[expose] def NoGenSuffix {P : PureExpr} [HasIdent P] + (Q : String → Prop) + (xs : List P.Ident) : Prop := + ∀ x ∈ xs, ∀ s : String, + x = HasIdent.ident (P := P) s → ¬ Q s + +/-- The source-shape precondition over a source block: no statement in `ss` +ever defines or modifies a `Q`-kind variable. -/ +@[expose] def SrcNoGenWrites {P : PureExpr} [HasIdent P] [HasVarsPure P P.Expr] + (Q : String → Prop) + (ss : List (Stmt P (Cmd P))) : Prop := + NoGenSuffix (P := P) Q (Block.definedVars ss ++ Block.modifiedVars ss) + +/-- A single `EvalCmd` whose command writes no `Q`-kind variable preserves the +"no `Q`-kind slot is defined" invariant on its store. -/ +theorem evalCmd_preserves_src_fresh {P : PureExpr} [HasFvar P] [HasBool P] + [HasNot P] [HasIdent P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + {Q : String → Prop} + {δ : SemanticEval P} {σ σ' : SemanticStore P} {c : Cmd P} {haf : Bool} + (h : EvalCmd P δ σ c σ' haf) + (h_src_fresh : ∀ s, Q s → + σ (HasIdent.ident (P := P) s) = none) + (h_no_writes : NoGenSuffix (P := P) Q (Cmd.definedVars c ++ Cmd.modifiedVars c)) : + ∀ s, Q s → + σ' (HasIdent.ident (P := P) s) = none := by + intro s h_suf + have h_none : σ (HasIdent.ident (P := P) s) = none := h_src_fresh s h_suf + refine evalCmd_preserves_none (P := P) h h_none ?_ ?_ + · intro h_mem + exact (h_no_writes _ (List.mem_append_left _ h_mem) s rfl) h_suf + · intro h_mem + exact (h_no_writes _ (List.mem_append_right _ h_mem) s rfl) h_suf + +/-- Bidirectional agreement off the gen-shaped names: the target and source +stores assign the same value at every ident that is *definitely not* a +gen-shaped name (i.e. either not `HasIdent.ident _` of any string, or +`HasIdent.ident s` for a non-gen-shaped `s`). Stronger than `StoreAgreement` +(which is one-directional and only on source-defined vars), but agrees with it +off the guards: the only slots on which target may differ from source are the +gen-shaped guard slots. This is the invariant the `.cmd`/`init` arm needs (a +source-fresh user var stays fresh in the target). -/ +@[expose] def AgreeOffGen {P : PureExpr} [HasIdent P] + (Q : String → Prop) + (σ_src σ_tgt : SemanticStore P) : Prop := + ∀ x : P.Ident, + (∀ s : String, x = HasIdent.ident (P := P) s → ¬ Q s) → + σ_tgt x = σ_src x + +/-- `AgreeOffGen` is reflexive. -/ +theorem AgreeOffGen.refl {P : PureExpr} [HasIdent P] {Q : String → Prop} + (σ : SemanticStore P) : + AgreeOffGen Q σ σ := fun _ _ => rfl + +/-- Defining a gen-shaped guard `ident = HasIdent.ident g` (`g` gen-shaped) in the +target store preserves `AgreeOffGen`: the only changed slot is `ident`, which is +gen-shaped, so the off-gen equation (which constrains only non-gen idents) is +untouched. -/ +theorem AgreeOffGen.storeWith_gen {P : PureExpr} [HasIdent P] [LawfulHasIdent P] + [DecidableEq P.Ident] + {Q : String → Prop} + {σ_src σ_tgt : SemanticStore P} {g : String} {b : P.Expr} + (h_off : AgreeOffGen Q σ_src σ_tgt) + (h_gen : Q g) : + AgreeOffGen Q σ_src (storeWith σ_tgt (HasIdent.ident (P := P) g) b) := by + intro x h_nongen + have h_ne : x ≠ HasIdent.ident (P := P) g := by + rintro rfl + exact (h_nongen g rfl) h_gen + show (if x = HasIdent.ident (P := P) g then some b else σ_tgt x) = σ_src x + rw [if_neg h_ne]; exact h_off x h_nongen + +section CmdReplayOffGen + +/-- `AgreeOffGen` implies pointwise equality on the variables of an expression +defined in the source — those vars are non-gen (defined ⇒ `isSome`, but a +gen-shaped slot is `none` by source-freshness). -/ +theorem agreeOffGen_pointwise_on_expr_vars {P : PureExpr} [HasIdent P] + [HasVarsPure P P.Expr] + {Q : String → Prop} + (σ_src σ_tgt : SemanticStore P) (e : P.Expr) + (h_off : AgreeOffGen Q σ_src σ_tgt) + (h_src_fresh : ∀ s, Q s → + σ_src (HasIdent.ident (P := P) s) = none) + (h_def : isDefined σ_src (HasVarsPure.getVars e)) : + ∀ x ∈ HasVarsPure.getVars e, σ_src x = σ_tgt x := by + intro x hx + have h_x_some : (σ_src x).isSome = true := h_def x hx + have h_nongen : ∀ s : String, x = HasIdent.ident (P := P) s → + ¬ Q s := by + intro s h_eq h_suf + rw [h_eq, h_src_fresh s h_suf] at h_x_some + exact absurd h_x_some (by simp) + exact (h_off x h_nongen).symm + +/-- Replay a source `EvalCmd` step on a target store that `AgreeOffGen`s the +source, given the command writes no gen-shaped variable. Produces a target +post-store that still `AgreeOffGen`s the source post-store. -/ +theorem cmd_replay_offgen {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasIdent P] + [HasVarsPure P P.Expr] [DecidableEq P.Ident] [LawfulHasIdent P] + {Q : String → Prop} + (δ : SemanticEval P) (σ_src₀ σ_tgt₀ : SemanticStore P) + (c : Cmd P) (σ_src₁ : SemanticStore P) (failed : Bool) + (h_off : AgreeOffGen Q σ_src₀ σ_tgt₀) + (h_eval : EvalCmd P δ σ_src₀ c σ_src₁ failed) + (h_wf_def : WellFormedSemanticEvalDef δ) + (h_congr : WellFormedSemanticEvalExprCongr δ) + (h_src_fresh : ∀ s, Q s → + σ_src₀ (HasIdent.ident (P := P) s) = none) + (h_no_writes : NoGenSuffix (P := P) Q (Cmd.definedVars c ++ Cmd.modifiedVars c)) : + ∃ σ_tgt₁, EvalCmd P δ σ_tgt₀ c σ_tgt₁ failed + ∧ AgreeOffGen Q σ_src₁ σ_tgt₁ := by + -- The target keeps the same write var `x ↦ v`; off `x` the two post-stores + -- agree off-gen by `h_off` (both unchanged off `x`). + cases h_eval with + | eval_init heval hinit hwfvar hwfcongr => + rename_i ty md x v e + have h_x_nongen : ∀ s : String, x = HasIdent.ident (P := P) s → + ¬ Q s := by + intro s heq; apply h_no_writes x (List.mem_append_left _ ?_) s heq + with_unfolding_all exact List.mem_singleton.mpr rfl + have h_def_e : isDefined σ_src₀ (HasVarsPure.getVars e) := h_wf_def e v σ_src₀ heval + have h_pointwise : ∀ y ∈ HasVarsPure.getVars e, σ_src₀ y = σ_tgt₀ y := + agreeOffGen_pointwise_on_expr_vars σ_src₀ σ_tgt₀ e h_off h_src_fresh h_def_e + have h_eval_tgt : δ σ_tgt₀ e = .some v := by + rw [← heval]; exact (h_congr e σ_src₀ σ_tgt₀ h_pointwise).symm + cases hinit with + | init h_xn h_xv h_other => + have h_tgt_x_none : σ_tgt₀ x = none := by rw [h_off x h_x_nongen]; exact h_xn + let σ_tgt₁ : SemanticStore P := fun y => if y = x then some v else σ_tgt₀ y + have h_tgt_x : σ_tgt₁ x = some v := by show (if x = x then _ else _) = _; simp + have h_tgt_other : ∀ y, x ≠ y → σ_tgt₁ y = σ_tgt₀ y := by + intro y hxy; show (if y = x then _ else _) = _; rw [if_neg (fun h => hxy h.symm)] + refine ⟨σ_tgt₁, EvalCmd.eval_init h_eval_tgt (InitState.init h_tgt_x_none h_tgt_x h_tgt_other) hwfvar hwfcongr, ?_⟩ + intro y h_y_nongen + by_cases hyx : y = x + · subst hyx; rw [h_xv, h_tgt_x] + · rw [h_other y (fun h => hyx h.symm), h_tgt_other y (fun h => hyx h.symm)] + exact h_off y h_y_nongen + | eval_init_unconstrained hinit hwfvar => + rename_i ty md x v + have h_x_nongen : ∀ s : String, x = HasIdent.ident (P := P) s → + ¬ Q s := by + intro s heq; apply h_no_writes x (List.mem_append_left _ ?_) s heq + with_unfolding_all exact List.mem_singleton.mpr rfl + cases hinit with + | init h_xn h_xv h_other => + have h_tgt_x_none : σ_tgt₀ x = none := by rw [h_off x h_x_nongen]; exact h_xn + let σ_tgt₁ : SemanticStore P := fun y => if y = x then some v else σ_tgt₀ y + have h_tgt_x : σ_tgt₁ x = some v := by show (if x = x then _ else _) = _; simp + have h_tgt_other : ∀ y, x ≠ y → σ_tgt₁ y = σ_tgt₀ y := by + intro y hxy; show (if y = x then _ else _) = _; rw [if_neg (fun h => hxy h.symm)] + refine ⟨σ_tgt₁, EvalCmd.eval_init_unconstrained (InitState.init h_tgt_x_none h_tgt_x h_tgt_other) hwfvar, ?_⟩ + intro y h_y_nongen + by_cases hyx : y = x + · subst hyx; rw [h_xv, h_tgt_x] + · rw [h_other y (fun h => hyx h.symm), h_tgt_other y (fun h => hyx h.symm)] + exact h_off y h_y_nongen + | eval_set heval hupd hwfvar hwfcongr => + rename_i md x v e + have h_x_nongen : ∀ s : String, x = HasIdent.ident (P := P) s → + ¬ Q s := by + intro s heq; apply h_no_writes x (List.mem_append_right _ ?_) s heq + with_unfolding_all exact List.mem_singleton.mpr rfl + have h_def_e : isDefined σ_src₀ (HasVarsPure.getVars e) := h_wf_def e v σ_src₀ heval + have h_pointwise : ∀ y ∈ HasVarsPure.getVars e, σ_src₀ y = σ_tgt₀ y := + agreeOffGen_pointwise_on_expr_vars σ_src₀ σ_tgt₀ e h_off h_src_fresh h_def_e + have h_eval_tgt : δ σ_tgt₀ e = .some v := by + rw [← heval]; exact (h_congr e σ_src₀ σ_tgt₀ h_pointwise).symm + cases hupd with + | update h_xv' h_xv h_other => + rename_i v' + have h_tgt_x_old : σ_tgt₀ x = some v' := by rw [h_off x h_x_nongen]; exact h_xv' + let σ_tgt₁ : SemanticStore P := fun y => if y = x then some v else σ_tgt₀ y + have h_tgt_x : σ_tgt₁ x = some v := by show (if x = x then _ else _) = _; simp + have h_tgt_other : ∀ y, x ≠ y → σ_tgt₁ y = σ_tgt₀ y := by + intro y hxy; show (if y = x then _ else _) = _; rw [if_neg (fun h => hxy h.symm)] + refine ⟨σ_tgt₁, EvalCmd.eval_set h_eval_tgt (UpdateState.update h_tgt_x_old h_tgt_x h_tgt_other) hwfvar hwfcongr, ?_⟩ + intro y h_y_nongen + by_cases hyx : y = x + · subst hyx; rw [h_xv, h_tgt_x] + · rw [h_other y (fun h => hyx h.symm), h_tgt_other y (fun h => hyx h.symm)] + exact h_off y h_y_nongen + | eval_set_nondet hupd hwfvar => + rename_i md x v + have h_x_nongen : ∀ s : String, x = HasIdent.ident (P := P) s → + ¬ Q s := by + intro s heq; apply h_no_writes x (List.mem_append_right _ ?_) s heq + with_unfolding_all exact List.mem_singleton.mpr rfl + cases hupd with + | update h_xv' h_xv h_other => + rename_i v' + have h_tgt_x_old : σ_tgt₀ x = some v' := by rw [h_off x h_x_nongen]; exact h_xv' + let σ_tgt₁ : SemanticStore P := fun y => if y = x then some v else σ_tgt₀ y + have h_tgt_x : σ_tgt₁ x = some v := by show (if x = x then _ else _) = _; simp + have h_tgt_other : ∀ y, x ≠ y → σ_tgt₁ y = σ_tgt₀ y := by + intro y hxy; show (if y = x then _ else _) = _; rw [if_neg (fun h => hxy h.symm)] + refine ⟨σ_tgt₁, EvalCmd.eval_set_nondet (UpdateState.update h_tgt_x_old h_tgt_x h_tgt_other) hwfvar, ?_⟩ + intro y h_y_nongen + by_cases hyx : y = x + · subst hyx; rw [h_xv, h_tgt_x] + · rw [h_other y (fun h => hyx h.symm), h_tgt_other y (fun h => hyx h.symm)] + exact h_off y h_y_nongen + | eval_assert_pass hcond hwfb hwfcongr => + rename_i l md e + have h_def_e : isDefined σ_src₀ (HasVarsPure.getVars e) := h_wf_def e HasBool.tt σ_src₀ hcond + have h_pointwise : ∀ y ∈ HasVarsPure.getVars e, σ_src₀ y = σ_tgt₀ y := + agreeOffGen_pointwise_on_expr_vars σ_src₀ σ_tgt₀ e h_off h_src_fresh h_def_e + have h_eval_tgt : δ σ_tgt₀ e = .some HasBool.tt := by + rw [← hcond]; exact (h_congr e σ_src₀ σ_tgt₀ h_pointwise).symm + exact ⟨σ_tgt₀, EvalCmd.eval_assert_pass h_eval_tgt hwfb hwfcongr, h_off⟩ + | eval_assert_fail hcond hwfb hwfcongr => + rename_i l md e + have h_def_e : isDefined σ_src₀ (HasVarsPure.getVars e) := h_wf_def e HasBool.ff σ_src₀ hcond + have h_pointwise : ∀ y ∈ HasVarsPure.getVars e, σ_src₀ y = σ_tgt₀ y := + agreeOffGen_pointwise_on_expr_vars σ_src₀ σ_tgt₀ e h_off h_src_fresh h_def_e + have h_eval_tgt : δ σ_tgt₀ e = .some HasBool.ff := by + rw [← hcond]; exact (h_congr e σ_src₀ σ_tgt₀ h_pointwise).symm + exact ⟨σ_tgt₀, EvalCmd.eval_assert_fail h_eval_tgt hwfb hwfcongr, h_off⟩ + | eval_assume hcond hwfb hwfcongr => + rename_i l md e + have h_def_e : isDefined σ_src₀ (HasVarsPure.getVars e) := h_wf_def e HasBool.tt σ_src₀ hcond + have h_pointwise : ∀ y ∈ HasVarsPure.getVars e, σ_src₀ y = σ_tgt₀ y := + agreeOffGen_pointwise_on_expr_vars σ_src₀ σ_tgt₀ e h_off h_src_fresh h_def_e + have h_eval_tgt : δ σ_tgt₀ e = .some HasBool.tt := by + rw [← hcond]; exact (h_congr e σ_src₀ σ_tgt₀ h_pointwise).symm + exact ⟨σ_tgt₀, EvalCmd.eval_assume h_eval_tgt hwfb hwfcongr, h_off⟩ + | eval_cover hwfb => + exact ⟨σ_tgt₀, EvalCmd.eval_cover hwfb, h_off⟩ + +/-- Trace-level pass-through `.cmd` replay under `AgreeOffGen`: a terminating +source `.cmd c` execution is matched by a terminating target `.cmd c` execution +from any off-gen-agreeing store (matching evaluator and failure flag), with the +post-stores agreeing off-gen, the failure flags equal, the evaluators equal, the +source post-store still free of gen-shaped slots, and the target post-store still +`GenFreshStore` (the replayed `c` writes no gen-shaped variable). -/ +theorem cmd_replay_agreement_offgen {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasIdent P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] [LawfulHasIdent P] + {Q : String → Prop} + (extendEval : ExtendEval P) + (c : Cmd P) (ρ_src ρ_src' ρ_tgt : Env P) (σ : StringGenState) + (h_eval_eq : ρ_tgt.eval = ρ_src.eval) + (h_fail_eq : ρ_tgt.hasFailure = ρ_src.hasFailure) + (h_off : AgreeOffGen Q ρ_src.store ρ_tgt.store) + (h_wf_def : WellFormedSemanticEvalDef ρ_src.eval) + (h_congr : WellFormedSemanticEvalExprCongr ρ_src.eval) + (h_src_fresh : ∀ s, Q s → + ρ_src.store (HasIdent.ident (P := P) s) = none) + (h_tgt_fresh : GenFreshStore Q σ ρ_tgt.store) + (h_no_writes : NoGenSuffix (P := P) Q (Cmd.definedVars c ++ Cmd.modifiedVars c)) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd c) ρ_src) (.terminal ρ_src')) : + (∀ s, Q s → + ρ_src'.store (HasIdent.ident (P := P) s) = none) + ∧ ∃ ρ_tgt', StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd c) ρ_tgt) (.terminal ρ_tgt') + ∧ AgreeOffGen Q ρ_src'.store ρ_tgt'.store + ∧ ρ_tgt'.hasFailure = ρ_src'.hasFailure + ∧ ρ_tgt'.eval = ρ_src'.eval + ∧ GenFreshStore Q σ ρ_tgt'.store := by + obtain ⟨σ', haf, h_cmd, h_eq⟩ := cmd_step_inv (extendEval := extendEval) c ρ_src ρ_src' h_term + obtain ⟨σ_tgt', h_eval_tgt, h_off'⟩ := + cmd_replay_offgen ρ_src.eval ρ_src.store ρ_tgt.store c σ' haf + h_off h_cmd h_wf_def h_congr h_src_fresh h_no_writes + have h_eval_tgt' : EvalCmd P ρ_tgt.eval ρ_tgt.store c σ_tgt' haf := h_eval_eq ▸ h_eval_tgt + -- Source post-store still has no gen-shaped slot. + have h_src'_fresh : ∀ s, Q s → + ρ_src'.store (HasIdent.ident (P := P) s) = none := by + subst h_eq + exact evalCmd_preserves_src_fresh h_cmd h_src_fresh h_no_writes + refine ⟨h_src'_fresh, { ρ_tgt with store := σ_tgt', hasFailure := ρ_tgt.hasFailure || haf }, + .step _ _ _ (StepStmt.step_cmd h_eval_tgt') (.refl _), ?_, ?_, ?_, ?_⟩ + · subst h_eq; exact h_off' + · subst h_eq; simp [h_fail_eq] + · subst h_eq; exact h_eval_eq + · -- GenFreshStore preserved on the target: replayed c writes no gen-shaped var. + intro s h_suf h_nin + have h_none : ρ_tgt.store (HasIdent.ident (P := P) s) = none := h_tgt_fresh s h_suf h_nin + refine evalCmd_preserves_none (P := P) (h_eval_eq ▸ h_eval_tgt) h_none ?_ ?_ + · intro h_mem; exact (h_no_writes _ (List.mem_append_left _ h_mem) s rfl) h_suf + · intro h_mem; exact (h_no_writes _ (List.mem_append_right _ h_mem) s rfl) h_suf + +end CmdReplayOffGen + +/-- A source store with no gen-shaped slot defined that `AgreeOffGen`s a target +store also `StoreAgreement`s it: every source-*defined* variable is non-gen +(else its slot would be `none`, contradicting `isDefined`), so the bidirectional +off-gen equation specializes to the one-directional agreement. -/ +theorem StoreAgreement.of_agreeOffGen {P : PureExpr} [HasIdent P] [LawfulHasIdent P] + {Q : String → Prop} + {σ_src σ_tgt : SemanticStore P} + (h_off : AgreeOffGen Q σ_src σ_tgt) + (h_src_fresh : ∀ s, Q s → + σ_src (HasIdent.ident (P := P) s) = none) : + StoreAgreement σ_src σ_tgt := by + intro x h_def + have h_x_def : (σ_src x).isSome = true := h_def x (List.mem_singleton.mpr rfl) + have h_nongen : ∀ s : String, x = HasIdent.ident (P := P) s → + ¬ Q s := by + intro s h_eq h_suf + rw [h_eq, h_src_fresh s h_suf] at h_x_def + exact absurd h_x_def (by simp) + exact (h_off x h_nongen).symm + +/-- Deterministic-loop forward simulation, by structural induction on a `Nat` +fuel bounding the *Type-valued* length of the source run. The source loop +`.loop (.det e) m [] body md` is simulated by the target loop +`.loop (.det e) m [] body' md`, where `body'` is the rewritten body and the +per-iteration body simulation is supplied by `h_body_sim`. Threading `body'` +and `h_body_sim` as parameters keeps this lemma outside the mutual block: the +`.loop (.det e)` arm instantiates `body' := (Block.nondetElimM body σ).1`, +`h_body_sim := nondetElim_simulation_gen` (the body output is fixed across +iterations). + +The fuel is threaded over `hstarT.len`, the genuine Type-valued length of the +source run, so each ENTER iteration applies the IH to the loop tail at a +strictly smaller fuel (`omega` on the `seqT`/`blockT`/`stmtsT` length bounds). +The invariant list is empty (`h_lhni` provides `is = []`), so the `step_loop_*` +side-conditions on invariants are vacuous (`empty_inv_no_failure`). -/ +private theorem nondetElim_loop_det_sim_iteration {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] + {Q : String → Prop} + (extendEval : ExtendEval P) + (e : P.Expr) (m : Option P.Expr) + (body body' : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) + -- Per-iteration body simulation: a run of `body` reaching an outcome + -- (`.terminal` or an `.exiting` propagated past the loop) from a + -- source store / target store pair (agreeing off the gen names, with the + -- usual freshness invariants) is simulated by a run of `body'`, + -- re-establishing all five store/eval/failure/freshness conjuncts. + -- Mirrors `nondetElim_simulation_gen` specialized to `body`/`body'`/`σ`. + (h_body_sim : ∀ (oc_b : Option String) (ρb_src ρb' ρb_tgt : Env P), + ρb_tgt.eval = ρb_src.eval → + ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → + WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → + WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → + StringGenState.WF σ → + (∀ t, Q t → + ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) (outcomeConfig oc_b ρb') → + (∀ t, Q t → + ρb'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρb_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ρb_tgt) (outcomeConfig oc_b ρb_out) + ∧ AgreeOffGen Q ρb'.store ρb_out.store + ∧ ρb_out.hasFailure = ρb'.hasFailure + ∧ ρb_out.eval = ρb'.eval + ∧ GenFreshStore Q σ_out ρb_out.store) + (_σ_out : StringGenState) + (h_nofd_body : Block.noFuncDecl body = true) + (oc : Option String) + (ρ_src ρ' ρ_tgt : Env P) (n : Nat) + (h_eval_eq : ρ_tgt.eval = ρ_src.eval) + (h_fail_eq : ρ_tgt.hasFailure = ρ_src.hasFailure) + (h_agree : AgreeOffGen Q ρ_src.store ρ_tgt.store) + (hwfb : WellFormedSemanticEvalBool ρ_src.eval) + (hwfv : WellFormedSemanticEvalVal ρ_src.eval) + (hwf_def : WellFormedSemanticEvalDef ρ_src.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ_src.eval) + (hwf_var : WellFormedSemanticEvalVar ρ_src.eval) + (h_wf_gen : StringGenState.WF σ) + (h_src_fresh : ∀ t, Q t → + ρ_src.store (HasIdent.ident (P := P) t) = none) + (h_tgt_fresh : GenFreshStore Q σ ρ_tgt.store) + (hstarT : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop (.det e) m ([] : List (String × P.Expr)) body md) ρ_src) (outcomeConfig oc ρ')) + (hlen : hstarT.len ≤ n) : + (∀ t, Q t → + ρ'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det e) m ([] : List (String × P.Expr)) body' md) ρ_tgt) + (outcomeConfig oc ρ_out) + ∧ AgreeOffGen Q ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure + ∧ ρ_out.eval = ρ'.eval + ∧ GenFreshStore Q σ ρ_out.store := by + induction n generalizing oc ρ_src ρ_tgt ρ' with + | zero => + -- A run of length 0 has no first loop step; both inversion branches give a + -- residual of strictly smaller length, contradicting `hlen : len ≤ 0`. + rcases loop_det_step_first_inv (extendEval := extendEval) hstarT with + ⟨_, _, _, hl⟩ | ⟨_, _, _, hl⟩ + · exact absurd (Nat.lt_of_lt_of_le hl hlen) (Nat.not_lt_zero _) + · exact absurd (Nat.lt_of_lt_of_le hl hlen) (Nat.not_lt_zero _) + | succ n ih => + rcases loop_det_step_first_inv (extendEval := extendEval) hstarT with + ⟨h_cond, hwfb_s, hrest, hl⟩ | ⟨h_cond, hwfb_s, hrest, hl⟩ + · -- EXIT: guard reads `ff`; loop terminates. The loop exit reaches + -- `.terminal`, so the outcome must be `none` (a `.terminal →*T .exiting` + -- run is impossible). + have hlen : hstarT.len ≤ n + 1 := hlen + cases oc with + | none => + simp only [outcomeConfig] at hrest ⊢ + -- The remaining run `.terminal (ρ_src + false) →*T .terminal ρ'` forces ρ' = ρ_src. + have hρ' : ρ' = ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) := by + match hrest with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + have hρ'_eq : ρ' = ρ_src := by rw [hρ', Bool.or_false] + -- Target: guard reads ff too (AgreeOffGen Q on guard's source-defined vars). + have h_def_e : isDefined ρ_src.store (HasVarsPure.getVars e) := + hwf_def e HasBool.ff ρ_src.store h_cond + have h_pw : ∀ x ∈ HasVarsPure.getVars e, ρ_src.store x = ρ_tgt.store x := + agreeOffGen_pointwise_on_expr_vars ρ_src.store ρ_tgt.store e h_agree h_src_fresh h_def_e + have h_cond_t : ρ_tgt.eval ρ_tgt.store e = some HasBool.ff := by + rw [h_eval_eq, ← h_cond]; exact (hwf_congr e ρ_src.store ρ_tgt.store h_pw).symm + subst hρ'_eq + refine ⟨h_src_fresh, ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P), ?_, ?_, ?_, ?_, ?_⟩ + · refine .step _ _ _ (StepStmt.step_loop_exit (hasInvFailure := false) + h_cond_t (by simp) (by simp) (h_eval_eq ▸ hwfb)) (.refl _) + · -- AgreeOffGen: only hasFailure changed on both sides. + simpa using h_agree + · simp [h_fail_eq] + · simpa using h_eval_eq + · simpa using h_tgt_fresh + | some lbl => + -- `.terminal (ρ_src + false) →*T .exiting lbl ρ'` is impossible. + exfalso + simp only [outcomeConfig] at hrest + match hrest with + | .step _ _ _ h _ => exact nomatch h + · -- ENTER: guard reads `tt`; run one body iteration then recurse (terminal + -- outcome) or propagate the body's exit (exiting outcome). + have hlen : hstarT.len ≤ n + 1 := hlen + -- ρ_src' is ρ_src with the (no-op) failure update from the empty invariants. + let ρ_src' : Env P := { ρ_src with hasFailure := ρ_src.hasFailure || false } + have hρ_src'_eq : ρ_src' = ρ_src := by simp [ρ_src', Bool.or_false] + -- Guard reads tt in the target (used by both outcome subcases). + have h_def_e : isDefined ρ_src.store (HasVarsPure.getVars e) := + hwf_def e HasBool.tt ρ_src.store h_cond + have h_pw : ∀ x ∈ HasVarsPure.getVars e, ρ_src.store x = ρ_tgt.store x := + agreeOffGen_pointwise_on_expr_vars ρ_src.store ρ_tgt.store e h_agree h_src_fresh h_def_e + have h_cond_t : ρ_tgt.eval ρ_tgt.store e = some HasBool.tt := by + rw [h_eval_eq, ← h_cond]; exact (hwf_congr e ρ_src.store ρ_tgt.store h_pw).symm + -- A reusable body-block-to-terminal transport for the target side. + have h_block_tgt_to : ∀ (ρb_tgt : Env P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ρb_tgt) → + StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts body' + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.terminal ({ ρb_tgt with store := projectStore ρ_tgt.store ρb_tgt.store } : Env P)) := by + intro ρb_tgt h_run + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_run) ?_ + exact .step _ _ _ StepStmt.step_block_done (.refl _) + cases oc with + | none => + simp only [outcomeConfig] at hrest ⊢ + -- Re-state `hl` against the now `.terminal`-typed `hrest` so the residual + -- length appears as a single atom shared with the `seqT` split below. + have hl : hrest.len < hstarT.len := hl + -- Split the seq: body-block reaches ρ_block, then [loop] reaches ρ'. + have ⟨ρ_block, h_block_term, h_loop_stmts, hlen_seq⟩ := + seqT_reaches_terminal (extendEval := extendEval) hrest + -- Unwrap the anonymous body block. + have ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_none_reaches_terminal (extendEval := extendEval) h_block_term + -- Decompose [loop] ρ_block: head loop reaches ρ_x, then [] reaches ρ'. + have ⟨ρ_x, h_loop_T_T, h_nil, hlen_cons⟩ := + stmtsT_cons_terminal (extendEval := extendEval) h_loop_stmts + have hρ_x_eq : ρ_x = ρ' := by + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + subst hρ_x_eq + -- The body ran from ρ_src' (= ρ_src) to ρ_inner. + have h_body_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_src) (outcomeConfig none ρ_inner) := + hρ_src'_eq ▸ reflTransT_to_prop h_inner_term + -- Simulate the body once via the provider (terminal outcome). + obtain ⟨h_inner_fresh, ρ_inner_tgt, h_body_tgt, h_off_inner, h_fail_inner, + h_eval_inner, h_fresh_inner⟩ := + h_body_sim none ρ_src ρ_inner ρ_tgt h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr + hwf_var h_wf_gen h_src_fresh h_tgt_fresh h_body_run + -- Eval is preserved across the (funcDecl-free) body. + have h_eval_inner_src : ρ_inner.eval = ρ_src.eval := + block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ_src ρ_inner h_nofd_body + (by simpa only [outcomeConfig] using h_body_run) + -- The next iteration's source env is the block-projected `ρ_block`. + have heq_ρ_block_full : + ρ_block = ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P) := by + have hstore : ρ_src'.store = ρ_src.store := by rw [hρ_src'_eq] + rw [heq_ρ_block, hstore] + subst heq_ρ_block_full + let ρ_src_next : Env P := { ρ_inner with store := projectStore ρ_src.store ρ_inner.store } + let ρ_tgt_next : Env P := { ρ_inner_tgt with store := projectStore ρ_tgt.store ρ_inner_tgt.store } + -- WF-eval facts at ρ_src_next (eval = ρ_inner.eval = ρ_src.eval). + have h_eval_next : ρ_src_next.eval = ρ_src.eval := h_eval_inner_src + have hwfb_next : WellFormedSemanticEvalBool ρ_src_next.eval := by rw [h_eval_next]; exact hwfb + have hwfv_next : WellFormedSemanticEvalVal ρ_src_next.eval := by rw [h_eval_next]; exact hwfv + have hwf_def_next : WellFormedSemanticEvalDef ρ_src_next.eval := by rw [h_eval_next]; exact hwf_def + have hwf_congr_next : WellFormedSemanticEvalExprCongr ρ_src_next.eval := by rw [h_eval_next]; exact hwf_congr + have hwf_var_next : WellFormedSemanticEvalVar ρ_src_next.eval := by rw [h_eval_next]; exact hwf_var + -- eval/fail agreement between the two projected stores. + have h_eval_eq_next : ρ_tgt_next.eval = ρ_src_next.eval := by + show ρ_inner_tgt.eval = ρ_inner.eval; exact h_eval_inner + have h_fail_eq_next : ρ_tgt_next.hasFailure = ρ_src_next.hasFailure := by + show ρ_inner_tgt.hasFailure = ρ_inner.hasFailure; exact h_fail_inner + -- AgreeOffGen Q survives projecting both stores through their agreeing parents. + have h_agree_next : AgreeOffGen Q ρ_src_next.store ρ_tgt_next.store := by + intro x h_nongen + show projectStore ρ_tgt.store ρ_inner_tgt.store x + = projectStore ρ_src.store ρ_inner.store x + show (if (ρ_tgt.store x).isSome then ρ_inner_tgt.store x else none) + = (if (ρ_src.store x).isSome then ρ_inner.store x else none) + have h_par : ρ_tgt.store x = ρ_src.store x := h_agree x h_nongen + have h_inn : ρ_inner_tgt.store x = ρ_inner.store x := h_off_inner x h_nongen + rw [h_par, h_inn] + -- Source freshness at the projected store. + have h_src_fresh_next : ∀ t, Q t → + ρ_src_next.store (HasIdent.ident (P := P) t) = none := by + intro t h_suf + show projectStore ρ_src.store ρ_inner.store (HasIdent.ident (P := P) t) = none + show (if (ρ_src.store (HasIdent.ident (P := P) t)).isSome + then ρ_inner.store (HasIdent.ident (P := P) t) else none) = none + by_cases hp : (ρ_src.store (HasIdent.ident (P := P) t)).isSome + · rw [if_pos hp]; exact h_inner_fresh t h_suf + · rw [if_neg hp] + -- Target freshness at the projected store: derived from the *parent* + -- `h_tgt_fresh` (the gen slot is already `none` in the parent, so the + -- projection wipes it regardless of the body's post-store). + have h_tgt_fresh_next : GenFreshStore Q σ ρ_tgt_next.store := by + intro s h_suf h_notin + show projectStore ρ_tgt.store ρ_inner_tgt.store (HasIdent.ident (P := P) s) = none + show (if (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + then ρ_inner_tgt.store (HasIdent.ident (P := P) s) else none) = none + rw [h_tgt_fresh s h_suf h_notin]; rfl + -- Recurse on the loop tail at strictly smaller fuel. (`subst hρ_x_eq` + -- eliminated the conclusion's terminal env in favour of `ρ_x`; + -- `h_loop_T_T` already targets `ρ_x` from the substituted `ρ_src_next`.) + have hlen_tail : h_loop_T_T.len ≤ n := by omega + obtain ⟨h_fresh', ρ_out, h_loop_tgt, h_off', h_fail', h_eval', h_fresh_out⟩ := + ih (oc := none) (ρ_src := ρ_src_next) (ρ' := ρ_x) (ρ_tgt := ρ_tgt_next) + h_eval_eq_next h_fail_eq_next h_agree_next + hwfb_next hwfv_next hwf_def_next hwf_congr_next hwf_var_next + h_src_fresh_next h_tgt_fresh_next h_loop_T_T hlen_tail + simp only [outcomeConfig] at h_loop_tgt + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', h_fresh_out⟩ + -- Build the target loop run: enter (guard tt, body-block) then recurse. + refine .step _ _ _ (StepStmt.step_loop_enter (hasInvFailure := false) + h_cond_t (by simp) (by simp) (h_eval_eq ▸ hwfb)) ?_ + have h_body_tgt' : StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ρ_inner_tgt) := by + have : ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) = ρ_tgt := by + simp [Bool.or_false] + rw [this]; simpa only [outcomeConfig] using h_body_tgt + -- After step_seq_done we reach `.stmts [loop] ρ_tgt_next`; loop tail runs + -- to `.stmts []`, then `step_stmts_nil` to `.terminal ρ_out`. + refine ReflTrans_Transitive _ _ _ _ + (ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ (h_block_tgt_to ρ_inner_tgt h_body_tgt')) + (.step _ _ _ StepStmt.step_seq_done (.refl _))) + (ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval _ _ ρ_tgt_next ρ_out h_loop_tgt) + (.step _ _ _ StepStmt.step_stmts_nil (.refl _))) + | some lbl => + simp only [outcomeConfig] at hrest ⊢ + -- Re-state `hl` against the now `.exiting`-typed `hrest` so the residual + -- length appears as a single atom shared with the `seqT` split below. + have hl : hrest.len < hstarT.len := hl + -- The loop exits with `lbl`. Split the seq: either the body-block + -- exits (skipping the loop tail), or the body terminates and the loop + -- tail exits. + rcases seqT_reaches_exiting (extendEval := extendEval) hrest with + ⟨h_block_exit, hlen_be⟩ | ⟨ρ_block, h_block_term, h_loop_exit, hlen_te⟩ + · -- Body-block exits with `lbl`: the body exits, propagated past the loop. + have ⟨ρ_inner, h_inner_exit, heq_ρ', hlen_inner⟩ := + blockT_none_reaches_exiting (extendEval := extendEval) h_block_exit + -- The body ran from ρ_src' (= ρ_src) exiting `lbl` to ρ_inner. + have h_body_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_src) (outcomeConfig (some lbl) ρ_inner) := + hρ_src'_eq ▸ reflTransT_to_prop h_inner_exit + obtain ⟨h_inner_fresh, ρ_inner_tgt, h_body_tgt, h_off_inner, h_fail_inner, + h_eval_inner, h_fresh_inner⟩ := + h_body_sim (some lbl) ρ_src ρ_inner ρ_tgt h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr + hwf_var h_wf_gen h_src_fresh h_tgt_fresh h_body_run + subst heq_ρ' + refine ⟨?_, ({ ρ_inner_tgt with store := projectStore ρ_tgt.store ρ_inner_tgt.store } : Env P), + ?_, ?_, ?_, ?_, ?_⟩ + · -- Source freshness at the projected store. + intro t h_suf + show projectStore ρ_src.store ρ_inner.store (HasIdent.ident (P := P) t) = none + show (if (ρ_src.store (HasIdent.ident (P := P) t)).isSome + then ρ_inner.store (HasIdent.ident (P := P) t) else none) = none + by_cases hp : (ρ_src.store (HasIdent.ident (P := P) t)).isSome + · rw [if_pos hp]; exact h_inner_fresh t h_suf + · rw [if_neg hp] + · -- Target loop: enter (guard tt), body-block exits `lbl`, seq exits. + refine .step _ _ _ (StepStmt.step_loop_enter (hasInvFailure := false) + h_cond_t (by simp) (by simp) (h_eval_eq ▸ hwfb)) ?_ + have h_body_tgt' : StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.exiting lbl ρ_inner_tgt) := by + have : ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) = ρ_tgt := by + simp [Bool.or_false] + rw [this]; simpa only [outcomeConfig] using h_body_tgt + -- Lift body' exit through the block (block_inner_star), then + -- step_block_exit_mismatch (`.none ≠ .some lbl`) propagates, then + -- step_seq_exit skips the loop tail. + have h_block_tgt_exit : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts body' + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.exiting lbl ({ ρ_inner_tgt with store := projectStore ρ_tgt.store ρ_inner_tgt.store } : Env P)) := by + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_body_tgt') ?_ + exact .step _ _ _ (StepStmt.step_block_exit_mismatch (by simp)) (.refl _) + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_block_tgt_exit) ?_ + exact .step _ _ _ StepStmt.step_seq_exit (.refl _) + · -- AgreeOffGen Q at the projected stores. + intro x h_nongen + show projectStore ρ_tgt.store ρ_inner_tgt.store x + = projectStore ρ_src.store ρ_inner.store x + show (if (ρ_tgt.store x).isSome then ρ_inner_tgt.store x else none) + = (if (ρ_src.store x).isSome then ρ_inner.store x else none) + rw [h_agree x h_nongen, h_off_inner x h_nongen] + · exact h_fail_inner + · exact h_eval_inner + · -- GenFreshStore Q at the projected store: from the parent `h_tgt_fresh`. + intro s h_suf h_notin + show projectStore ρ_tgt.store ρ_inner_tgt.store (HasIdent.ident (P := P) s) = none + show (if (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + then ρ_inner_tgt.store (HasIdent.ident (P := P) s) else none) = none + rw [h_tgt_fresh s h_suf h_notin]; rfl + · -- Body terminates, loop tail exits with `lbl`: recurse on the tail. + have ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_none_reaches_terminal (extendEval := extendEval) h_block_term + -- Decompose [loop] ρ_block exiting: the head loop exits `lbl`. + have ⟨h_loop_T_exit, hlen_cons⟩ := + stmtsT_singleton_exiting (extendEval := extendEval) h_loop_exit + have h_body_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_src) (outcomeConfig none ρ_inner) := + hρ_src'_eq ▸ reflTransT_to_prop h_inner_term + obtain ⟨h_inner_fresh, ρ_inner_tgt, h_body_tgt, h_off_inner, h_fail_inner, + h_eval_inner, h_fresh_inner⟩ := + h_body_sim none ρ_src ρ_inner ρ_tgt h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr + hwf_var h_wf_gen h_src_fresh h_tgt_fresh h_body_run + have h_eval_inner_src : ρ_inner.eval = ρ_src.eval := + block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ_src ρ_inner h_nofd_body + (by simpa only [outcomeConfig] using h_body_run) + have heq_ρ_block_full : + ρ_block = ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P) := by + have hstore : ρ_src'.store = ρ_src.store := by rw [hρ_src'_eq] + rw [heq_ρ_block, hstore] + subst heq_ρ_block_full + let ρ_src_next : Env P := { ρ_inner with store := projectStore ρ_src.store ρ_inner.store } + let ρ_tgt_next : Env P := { ρ_inner_tgt with store := projectStore ρ_tgt.store ρ_inner_tgt.store } + have h_eval_next : ρ_src_next.eval = ρ_src.eval := h_eval_inner_src + have hwfb_next : WellFormedSemanticEvalBool ρ_src_next.eval := by rw [h_eval_next]; exact hwfb + have hwfv_next : WellFormedSemanticEvalVal ρ_src_next.eval := by rw [h_eval_next]; exact hwfv + have hwf_def_next : WellFormedSemanticEvalDef ρ_src_next.eval := by rw [h_eval_next]; exact hwf_def + have hwf_congr_next : WellFormedSemanticEvalExprCongr ρ_src_next.eval := by rw [h_eval_next]; exact hwf_congr + have hwf_var_next : WellFormedSemanticEvalVar ρ_src_next.eval := by rw [h_eval_next]; exact hwf_var + have h_eval_eq_next : ρ_tgt_next.eval = ρ_src_next.eval := by + show ρ_inner_tgt.eval = ρ_inner.eval; exact h_eval_inner + have h_fail_eq_next : ρ_tgt_next.hasFailure = ρ_src_next.hasFailure := by + show ρ_inner_tgt.hasFailure = ρ_inner.hasFailure; exact h_fail_inner + have h_agree_next : AgreeOffGen Q ρ_src_next.store ρ_tgt_next.store := by + intro x h_nongen + show projectStore ρ_tgt.store ρ_inner_tgt.store x + = projectStore ρ_src.store ρ_inner.store x + show (if (ρ_tgt.store x).isSome then ρ_inner_tgt.store x else none) + = (if (ρ_src.store x).isSome then ρ_inner.store x else none) + rw [h_agree x h_nongen, h_off_inner x h_nongen] + have h_src_fresh_next : ∀ t, Q t → + ρ_src_next.store (HasIdent.ident (P := P) t) = none := by + intro t h_suf + show projectStore ρ_src.store ρ_inner.store (HasIdent.ident (P := P) t) = none + show (if (ρ_src.store (HasIdent.ident (P := P) t)).isSome + then ρ_inner.store (HasIdent.ident (P := P) t) else none) = none + by_cases hp : (ρ_src.store (HasIdent.ident (P := P) t)).isSome + · rw [if_pos hp]; exact h_inner_fresh t h_suf + · rw [if_neg hp] + have h_tgt_fresh_next : GenFreshStore Q σ ρ_tgt_next.store := by + intro s h_suf h_notin + show projectStore ρ_tgt.store ρ_inner_tgt.store (HasIdent.ident (P := P) s) = none + show (if (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + then ρ_inner_tgt.store (HasIdent.ident (P := P) s) else none) = none + rw [h_tgt_fresh s h_suf h_notin]; rfl + have hlen_tail : h_loop_T_exit.len ≤ n := by omega + obtain ⟨h_fresh', ρ_out, h_loop_tgt, h_off', h_fail', h_eval', h_fresh_out⟩ := + ih (oc := some lbl) (ρ_src := ρ_src_next) (ρ' := ρ') (ρ_tgt := ρ_tgt_next) + h_eval_eq_next h_fail_eq_next h_agree_next + hwfb_next hwfv_next hwf_def_next hwf_congr_next hwf_var_next + h_src_fresh_next h_tgt_fresh_next h_loop_T_exit hlen_tail + simp only [outcomeConfig] at h_loop_tgt + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', h_fresh_out⟩ + refine .step _ _ _ (StepStmt.step_loop_enter (hasInvFailure := false) + h_cond_t (by simp) (by simp) (h_eval_eq ▸ hwfb)) ?_ + have h_body_tgt' : StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ρ_inner_tgt) := by + have : ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) = ρ_tgt := by + simp [Bool.or_false] + rw [this]; simpa only [outcomeConfig] using h_body_tgt + -- After step_seq_done we reach `.stmts [loop] ρ_tgt_next`; the loop + -- tail exits with `lbl` (lift the `.stmt loop` exit into `.stmts + -- [loop]` via step_stmts_cons / seq_inner_star / step_seq_exit). + have h_loop_stmts_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.loop (.det e) m ([] : List (String × P.Expr)) body' md] ρ_tgt_next) + (.exiting lbl ρ_out) := by + refine .step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_loop_tgt) ?_ + exact .step _ _ _ StepStmt.step_seq_exit (.refl _) + refine ReflTrans_Transitive _ _ _ _ + (ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ (h_block_tgt_to ρ_inner_tgt h_body_tgt')) + (.step _ _ _ StepStmt.step_seq_done (.refl _))) + h_loop_stmts_exit + + +/-- Closes the EXIT case of the nondet-loop iteration: the source loop +terminates (so `oc = none` and `ρ' = ρ_src`), and the target deterministic loop +reads the guard `$g = ff` and exits via `step_loop_exit`. Shared between the +fuel `zero` and `succ` cases. -/ +private theorem loop_nondet_exit_close {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] + {Q : String → Prop} + (extendEval : ExtendEval P) + (ident : P.Ident) (m : Option P.Expr) + (body' : List (Stmt P (Cmd P))) (md : MetaData P) + (σ : StringGenState) + (oc : Option String) + (ρ_src ρ' ρ_tgt : Env P) + (h_eval_eq : ρ_tgt.eval = ρ_src.eval) + (h_fail_eq : ρ_tgt.hasFailure = ρ_src.hasFailure) + (h_agree : AgreeOffGen Q ρ_src.store ρ_tgt.store) + (hwfb : WellFormedSemanticEvalBool ρ_src.eval) + (hwf_var : WellFormedSemanticEvalVar ρ_src.eval) + (h_src_fresh : ∀ t, Q t → + ρ_src.store (HasIdent.ident (P := P) t) = none) + (h_tgt_fresh : GenFreshStore Q σ ρ_tgt.store) + (h_guard_def : ρ_tgt.store ident = some HasBool.ff) + (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.terminal ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P)) + (outcomeConfig oc ρ')) : + (∀ t, Q t → + ρ'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det (HasFvar.mkFvar ident)) m ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc ident md)]) md) ρ_tgt) + (outcomeConfig oc ρ_out) + ∧ AgreeOffGen Q ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure + ∧ ρ_out.eval = ρ'.eval + ∧ GenFreshStore Q σ ρ_out.store := by + cases oc with + | some lbl => + exfalso + simp only [outcomeConfig] at hrest + match hrest with + | .step _ _ _ h _ => exact nomatch h + | none => + simp only [outcomeConfig] at hrest ⊢ + have hρ' : ρ' = ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) := by + match hrest with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + have hρ'_eq : ρ' = ρ_src := by rw [hρ', Bool.or_false] + have h_guard_ff : ρ_tgt.eval ρ_tgt.store (HasFvar.mkFvar ident) = some HasBool.ff := by + have h := hwf_var (HasFvar.mkFvar (P := P) ident) ident ρ_tgt.store + (LawfulHasFvar.getFvar_mkFvar ident) + rw [h_eval_eq, h, h_guard_def] + subst hρ'_eq + refine ⟨h_src_fresh, ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P), ?_, ?_, ?_, ?_, ?_⟩ + · refine .step _ _ _ (StepStmt.step_loop_exit (hasInvFailure := false) + h_guard_ff (by simp) (by simp) (h_eval_eq ▸ hwfb)) (.refl _) + · simpa using h_agree + · simp [h_fail_eq] + · simpa using h_eval_eq + · simpa using h_tgt_fresh + +/-- Nondeterministic-loop forward simulation, by structural induction on a `Nat` +fuel bounding the *Type-valued* length of the source run. The source loop +`.loop .nondet m [] body md` is simulated by the target *deterministic* loop +`.loop (.det $g) m [] (body' ++ [havoc $g]) md`, where `$g = mkFvar (ident g)` +(`g` gen-shaped, `g ∈ σ.stringGens`) is the generated guard, `body'` is the +rewritten body, and the per-iteration body simulation is supplied by +`h_body_sim`. + +The guard `$g` lives in the *parent* (target) scope: it is `init`'d to a value +matching the source's first enter/exit choice *before* the loop (the caller), +then re-havoced (`set $g := *`) at each body tail to match the *next* choice +(spec §3.2/§3.3). The relocated head-test reads/writes only the gen slot `$g`, +which `AgreeOffGen`/`GenFreshStore` quarantine from the source store, so the +relocation is invisible on the agreeing (off-gen) part. Because `$g` is +parent-defined, it survives each block-scoped iteration's `projectStore` +(`stmts_preserves_isSome` over the body) and the body-tail havoc can fire. + +The first iteration's matched guard is supplied as an explicit `entering : Bool` +plus the *already-inverted* source first step `h_src_first`, carrying a +`len ≤ n` fuel bound. Each recursive step re-inverts the loop tail with +`loop_nondet_step_first_inv` and chooses the matching havoc value. -/ +private theorem nondetElim_loop_nondet_sim_iteration {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] + {Q : String → Prop} + (extendEval : ExtendEval P) + (g : String) (m : Option P.Expr) + (body body' : List (Stmt P (Cmd P))) (md : MetaData P) + (σ σ_out : StringGenState) + (h_body_sim : ∀ (oc_b : Option String) (ρb_src ρb' ρb_tgt : Env P), + ρb_tgt.eval = ρb_src.eval → + ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → + WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → + WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → + StringGenState.WF σ → + (∀ t, Q t → + ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) (outcomeConfig oc_b ρb') → + (∀ t, Q t → + ρb'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρb_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ρb_tgt) (outcomeConfig oc_b ρb_out) + ∧ AgreeOffGen Q ρb'.store ρb_out.store + ∧ ρb_out.hasFailure = ρb'.hasFailure + ∧ ρb_out.eval = ρb'.eval + ∧ GenFreshStore Q σ_out ρb_out.store) + (h_g_gen : Q g) + (_h_g_in : g ∈ σ.stringGens) + (h_nofd_body : Block.noFuncDecl body = true) + (oc : Option String) + (ρ_src ρ' ρ_tgt : Env P) (n : Nat) + (h_eval_eq : ρ_tgt.eval = ρ_src.eval) + (h_fail_eq : ρ_tgt.hasFailure = ρ_src.hasFailure) + (h_agree : AgreeOffGen Q ρ_src.store ρ_tgt.store) + (hwfb : WellFormedSemanticEvalBool ρ_src.eval) + (hwfv : WellFormedSemanticEvalVal ρ_src.eval) + (hwf_def : WellFormedSemanticEvalDef ρ_src.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ_src.eval) + (hwf_var : WellFormedSemanticEvalVar ρ_src.eval) + (h_wf_gen : StringGenState.WF σ) + (h_src_fresh : ∀ t, Q t → + ρ_src.store (HasIdent.ident (P := P) t) = none) + (h_tgt_fresh : GenFreshStore Q σ ρ_tgt.store) + (entering : Bool) + (h_guard_def : ρ_tgt.store (HasIdent.ident (P := P) g) + = some (if entering then HasBool.tt else HasBool.ff)) + (h_src_first : + (entering = false ∧ ∃ (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.terminal ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P)) + (outcomeConfig oc ρ')), hrest.len ≤ n) ∨ + (entering = true ∧ ∃ (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ_src.store (.stmts body + ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P))) + [.loop .nondet m ([] : List (String × P.Expr)) body md]) + (outcomeConfig oc ρ')), hrest.len ≤ n)) : + (∀ t, Q t → + ρ'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m + ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md) ρ_tgt) + (outcomeConfig oc ρ_out) + ∧ AgreeOffGen Q ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure + ∧ ρ_out.eval = ρ'.eval + ∧ GenFreshStore Q σ ρ_out.store := by + induction n generalizing oc ρ_src ρ_tgt ρ' entering with + | zero => + rcases h_src_first with ⟨h_ent, hrest, hl⟩ | ⟨h_ent, hrest, hl⟩ + · subst h_ent + simp only [Bool.false_eq_true, if_false] at h_guard_def + exact loop_nondet_exit_close extendEval (HasIdent.ident (P := P) g) m body' md σ + oc ρ_src ρ' ρ_tgt h_eval_eq h_fail_eq h_agree hwfb hwf_var + h_src_fresh h_tgt_fresh h_guard_def hrest + · exfalso + subst h_ent + cases oc <;> simp only [outcomeConfig] at hrest <;> + (match hrest with + | .step _ _ _ _ _ => simp only [ReflTransT.len] at hl; omega) + | succ n ih => + rcases h_src_first with ⟨h_ent, hrest, hl⟩ | ⟨h_ent, hrest, hl⟩ + · subst h_ent + simp only [Bool.false_eq_true, if_false] at h_guard_def + exact loop_nondet_exit_close extendEval (HasIdent.ident (P := P) g) m body' md σ + oc ρ_src ρ' ρ_tgt h_eval_eq h_fail_eq h_agree hwfb hwf_var + h_src_fresh h_tgt_fresh h_guard_def hrest + · subst h_ent + simp only [if_true] at h_guard_def + -- Guard reads tt in target (via mkFvar / h_guard_def). + have h_guard_tt : ρ_tgt.eval ρ_tgt.store (HasFvar.mkFvar (HasIdent.ident (P := P) g)) + = some HasBool.tt := by + have h := hwf_var (HasFvar.mkFvar (P := P) (HasIdent.ident (P := P) g)) + (HasIdent.ident (P := P) g) ρ_tgt.store + (LawfulHasFvar.getFvar_mkFvar (HasIdent.ident (P := P) g)) + rw [h_eval_eq, h, h_guard_def] + have hwf_var_t : WellFormedSemanticEvalVar ρ_tgt.eval := h_eval_eq ▸ hwf_var + have hρ_src'_eq : ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) = ρ_src := by + simp [Bool.or_false] + cases oc with + | none => + simp only [outcomeConfig] at hrest ⊢ + have hl : hrest.len ≤ n + 1 := hl + have ⟨ρ_block, h_block_term, h_loop_stmts, hlen_seq⟩ := + seqT_reaches_terminal (extendEval := extendEval) hrest + have ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_none_reaches_terminal (extendEval := extendEval) h_block_term + have ⟨ρ_x, h_loop_T_T, h_nil, hlen_cons⟩ := + stmtsT_cons_terminal (extendEval := extendEval) h_loop_stmts + have hρ_x_eq : ρ_x = ρ' := by + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + subst hρ_x_eq + have h_body_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_src) (outcomeConfig none ρ_inner) := + hρ_src'_eq ▸ reflTransT_to_prop h_inner_term + obtain ⟨h_inner_fresh, ρ_inner_tgt, h_body_tgt, h_off_inner, h_fail_inner, + h_eval_inner, h_fresh_inner⟩ := + h_body_sim none ρ_src ρ_inner ρ_tgt h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr + hwf_var h_wf_gen h_src_fresh h_tgt_fresh h_body_run + have h_eval_inner_src : ρ_inner.eval = ρ_src.eval := + block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ_src ρ_inner h_nofd_body + (by simpa only [outcomeConfig] using h_body_run) + have heq_ρ_block_full : + ρ_block = ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P) := by + rw [heq_ρ_block] + subst heq_ρ_block_full + -- $g stays defined in ρ_inner_tgt (it was defined in ρ_tgt = ρ_tgt+false). + have h_g_some_tgt : (ρ_tgt.store (HasIdent.ident (P := P) g)).isSome = true := by + rw [h_guard_def]; rfl + have h_body_tgt_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ρ_inner_tgt) := by + have he : ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) = ρ_tgt := by + simp [Bool.or_false] + rw [he]; simpa only [outcomeConfig] using h_body_tgt + have h_g_some_inner : (ρ_inner_tgt.store (HasIdent.ident (P := P) g)).isSome = true := by + have := stmts_preserves_isSome (extendEval := extendEval) h_body_tgt_term + (y := HasIdent.ident (P := P) g) + have he : (({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P).store + (HasIdent.ident (P := P) g)).isSome = true := h_g_some_tgt + exact this he + obtain ⟨v', hv'⟩ := Option.isSome_iff_exists.mp h_g_some_inner + -- Invert the loop tail to learn the NEXT source decision. + rcases loop_nondet_step_first_inv (extendEval := extendEval) (oc := none) + h_loop_T_T with + ⟨hrest_next, hlen_next⟩ | ⟨hrest_next, hlen_next⟩ + · -- NEXT = EXIT: re-havoc $g := ff. + have hwf_var_inner : WellFormedSemanticEvalVar ρ_inner_tgt.eval := by + rw [h_eval_inner, h_eval_inner_src]; exact hwf_var + -- Build the per-iteration block run: body' to ρ_inner_tgt, then havoc $g := ff. + have h_tail : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)) ρ_inner_tgt) + (.terminal ({ ρ_inner_tgt with store := storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.ff } : Env P)) := + step_havoc_set_to (extendEval := extendEval) (HasIdent.ident (P := P) g) HasBool.ff md ρ_inner_tgt v' hv' + hwf_var_inner + have h_body_tail : StepStmtStar P (EvalCmd P) extendEval + (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ({ ρ_inner_tgt with store := storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.ff } : Env P)) := + ReflTrans_Transitive _ _ _ _ + (stmts_prefix_terminal_append P (EvalCmd P) extendEval _ _ _ ρ_inner_tgt h_body_tgt_term) + (stmt_to_singleton_stmts (extendEval := extendEval) _ ρ_inner_tgt _ h_tail) + let ρ_tgt_next : Env P := { ρ_inner_tgt with store := projectStore ρ_tgt.store (storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.ff) } + let ρ_src_next : Env P := { ρ_inner with store := projectStore ρ_src.store ρ_inner.store } + -- $g slot in ρ_tgt_next. + have h_guard_next : ρ_tgt_next.store (HasIdent.ident (P := P) g) = some HasBool.ff := by + show (if (ρ_tgt.store (HasIdent.ident (P := P) g)).isSome + then storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.ff + (HasIdent.ident (P := P) g) else none) = some HasBool.ff + rw [if_pos h_g_some_tgt]; simp [storeWith] + -- WF facts and agreements at the projected envs. + have h_eval_next : ρ_src_next.eval = ρ_src.eval := h_eval_inner_src + have hwfb_next : WellFormedSemanticEvalBool ρ_src_next.eval := by rw [h_eval_next]; exact hwfb + have hwfv_next : WellFormedSemanticEvalVal ρ_src_next.eval := by rw [h_eval_next]; exact hwfv + have hwf_def_next : WellFormedSemanticEvalDef ρ_src_next.eval := by rw [h_eval_next]; exact hwf_def + have hwf_congr_next : WellFormedSemanticEvalExprCongr ρ_src_next.eval := by rw [h_eval_next]; exact hwf_congr + have hwf_var_next : WellFormedSemanticEvalVar ρ_src_next.eval := by rw [h_eval_next]; exact hwf_var + have h_eval_eq_next : ρ_tgt_next.eval = ρ_src_next.eval := by + show ρ_inner_tgt.eval = ρ_inner.eval; exact h_eval_inner + have h_fail_eq_next : ρ_tgt_next.hasFailure = ρ_src_next.hasFailure := by + show ρ_inner_tgt.hasFailure = ρ_inner.hasFailure; exact h_fail_inner + have h_agree_next : AgreeOffGen Q ρ_src_next.store ρ_tgt_next.store := by + intro x h_nongen + show projectStore ρ_tgt.store + (storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.ff) x + = projectStore ρ_src.store ρ_inner.store x + have h_x_ne : x ≠ HasIdent.ident (P := P) g := by + rintro rfl; exact (h_nongen g rfl) h_g_gen + show (if (ρ_tgt.store x).isSome then + (if x = HasIdent.ident (P := P) g then some HasBool.ff else ρ_inner_tgt.store x) + else none) + = (if (ρ_src.store x).isSome then ρ_inner.store x else none) + rw [if_neg h_x_ne, h_agree x h_nongen, h_off_inner x h_nongen] + have h_src_fresh_next : ∀ t, Q t → + ρ_src_next.store (HasIdent.ident (P := P) t) = none := by + intro t h_suf + show (if (ρ_src.store (HasIdent.ident (P := P) t)).isSome + then ρ_inner.store (HasIdent.ident (P := P) t) else none) = none + by_cases hp : (ρ_src.store (HasIdent.ident (P := P) t)).isSome + · rw [if_pos hp]; exact h_inner_fresh t h_suf + · rw [if_neg hp] + have h_tgt_fresh_next : GenFreshStore Q σ ρ_tgt_next.store := by + intro s h_suf h_notin + show (if (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + then storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.ff + (HasIdent.ident (P := P) s) else none) = none + rw [h_tgt_fresh s h_suf h_notin]; rfl + -- Recurse with entering = false (exit) at smaller fuel. `h_loop_T_T.len` + -- shares its atom across the cons/seq bounds (no cast), so bound it + -- first; the inversion's `< h_loop_T_T.len` then chains by defeq. + have h_bound : h_loop_T_T.len ≤ n := by omega + have hlen_tail : hrest_next.len ≤ n := + Nat.le_of_lt (Nat.lt_of_lt_of_le hlen_next h_bound) + obtain ⟨h_fresh', ρ_out, h_loop_tgt, h_off', h_fail', h_eval', h_fresh_out⟩ := + ih (oc := none) (ρ_src := ρ_src_next) (ρ' := ρ_x) (ρ_tgt := ρ_tgt_next) + h_eval_eq_next h_fail_eq_next h_agree_next + hwfb_next hwfv_next hwf_def_next hwf_congr_next hwf_var_next + h_src_fresh_next h_tgt_fresh_next false h_guard_next + (.inl ⟨rfl, hrest_next, hlen_tail⟩) + simp only [outcomeConfig] at h_loop_tgt + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', h_fresh_out⟩ + -- Assemble: enter (guard tt), block runs body'++[havoc], step_seq_done, recurse. + refine .step _ _ _ (StepStmt.step_loop_enter (hasInvFailure := false) + h_guard_tt (by simp) (by simp) (h_eval_eq ▸ hwfb)) ?_ + have h_block_run : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.terminal ρ_tgt_next) := by + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_body_tail) ?_ + exact .step _ _ _ StepStmt.step_block_done (.refl _) + refine ReflTrans_Transitive _ _ _ _ + (ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_block_run) + (.step _ _ _ StepStmt.step_seq_done (.refl _))) + (ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval _ _ ρ_tgt_next ρ_out h_loop_tgt) + (.step _ _ _ StepStmt.step_stmts_nil (.refl _))) + · -- NEXT = ENTER: re-havoc $g := tt. + have hwf_var_inner : WellFormedSemanticEvalVar ρ_inner_tgt.eval := by + rw [h_eval_inner, h_eval_inner_src]; exact hwf_var + have h_tail : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)) ρ_inner_tgt) + (.terminal ({ ρ_inner_tgt with store := storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.tt } : Env P)) := + step_havoc_set_to (extendEval := extendEval) (HasIdent.ident (P := P) g) HasBool.tt md ρ_inner_tgt v' hv' + hwf_var_inner + have h_body_tail : StepStmtStar P (EvalCmd P) extendEval + (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ({ ρ_inner_tgt with store := storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.tt } : Env P)) := + ReflTrans_Transitive _ _ _ _ + (stmts_prefix_terminal_append P (EvalCmd P) extendEval _ _ _ ρ_inner_tgt h_body_tgt_term) + (stmt_to_singleton_stmts (extendEval := extendEval) _ ρ_inner_tgt _ h_tail) + let ρ_tgt_next : Env P := { ρ_inner_tgt with store := projectStore ρ_tgt.store (storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.tt) } + let ρ_src_next : Env P := { ρ_inner with store := projectStore ρ_src.store ρ_inner.store } + have h_guard_next : ρ_tgt_next.store (HasIdent.ident (P := P) g) = some HasBool.tt := by + show (if (ρ_tgt.store (HasIdent.ident (P := P) g)).isSome + then storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.tt + (HasIdent.ident (P := P) g) else none) = some HasBool.tt + rw [if_pos h_g_some_tgt]; simp [storeWith] + have h_eval_next : ρ_src_next.eval = ρ_src.eval := h_eval_inner_src + have hwfb_next : WellFormedSemanticEvalBool ρ_src_next.eval := by rw [h_eval_next]; exact hwfb + have hwfv_next : WellFormedSemanticEvalVal ρ_src_next.eval := by rw [h_eval_next]; exact hwfv + have hwf_def_next : WellFormedSemanticEvalDef ρ_src_next.eval := by rw [h_eval_next]; exact hwf_def + have hwf_congr_next : WellFormedSemanticEvalExprCongr ρ_src_next.eval := by rw [h_eval_next]; exact hwf_congr + have hwf_var_next : WellFormedSemanticEvalVar ρ_src_next.eval := by rw [h_eval_next]; exact hwf_var + have h_eval_eq_next : ρ_tgt_next.eval = ρ_src_next.eval := by + show ρ_inner_tgt.eval = ρ_inner.eval; exact h_eval_inner + have h_fail_eq_next : ρ_tgt_next.hasFailure = ρ_src_next.hasFailure := by + show ρ_inner_tgt.hasFailure = ρ_inner.hasFailure; exact h_fail_inner + have h_agree_next : AgreeOffGen Q ρ_src_next.store ρ_tgt_next.store := by + intro x h_nongen + have h_x_ne : x ≠ HasIdent.ident (P := P) g := by + rintro rfl; exact (h_nongen g rfl) h_g_gen + show (if (ρ_tgt.store x).isSome then + (if x = HasIdent.ident (P := P) g then some HasBool.tt else ρ_inner_tgt.store x) + else none) + = (if (ρ_src.store x).isSome then ρ_inner.store x else none) + rw [if_neg h_x_ne, h_agree x h_nongen, h_off_inner x h_nongen] + have h_src_fresh_next : ∀ t, Q t → + ρ_src_next.store (HasIdent.ident (P := P) t) = none := by + intro t h_suf + show (if (ρ_src.store (HasIdent.ident (P := P) t)).isSome + then ρ_inner.store (HasIdent.ident (P := P) t) else none) = none + by_cases hp : (ρ_src.store (HasIdent.ident (P := P) t)).isSome + · rw [if_pos hp]; exact h_inner_fresh t h_suf + · rw [if_neg hp] + have h_tgt_fresh_next : GenFreshStore Q σ ρ_tgt_next.store := by + intro s h_suf h_notin + show (if (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + then storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.tt + (HasIdent.ident (P := P) s) else none) = none + rw [h_tgt_fresh s h_suf h_notin]; rfl + have h_bound : h_loop_T_T.len ≤ n := by omega + have hlen_tail : hrest_next.len ≤ n := + Nat.le_of_lt (Nat.lt_of_lt_of_le hlen_next h_bound) + obtain ⟨h_fresh', ρ_out, h_loop_tgt, h_off', h_fail', h_eval', h_fresh_out⟩ := + ih (oc := none) (ρ_src := ρ_src_next) (ρ' := ρ_x) (ρ_tgt := ρ_tgt_next) + h_eval_eq_next h_fail_eq_next h_agree_next + hwfb_next hwfv_next hwf_def_next hwf_congr_next hwf_var_next + h_src_fresh_next h_tgt_fresh_next true h_guard_next + (.inr ⟨rfl, hrest_next, hlen_tail⟩) + simp only [outcomeConfig] at h_loop_tgt + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', h_fresh_out⟩ + refine .step _ _ _ (StepStmt.step_loop_enter (hasInvFailure := false) + h_guard_tt (by simp) (by simp) (h_eval_eq ▸ hwfb)) ?_ + have h_block_run : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.terminal ρ_tgt_next) := by + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_body_tail) ?_ + exact .step _ _ _ StepStmt.step_block_done (.refl _) + refine ReflTrans_Transitive _ _ _ _ + (ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_block_run) + (.step _ _ _ StepStmt.step_seq_done (.refl _))) + (ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval _ _ ρ_tgt_next ρ_out h_loop_tgt) + (.step _ _ _ StepStmt.step_stmts_nil (.refl _))) + | some lbl => + simp only [outcomeConfig] at hrest ⊢ + have hl : hrest.len ≤ n + 1 := hl + rcases seqT_reaches_exiting (extendEval := extendEval) hrest with + ⟨h_block_exit, hlen_be⟩ | ⟨ρ_block, h_block_term, h_loop_exit, hlen_te⟩ + · -- Body-block exits with lbl: the body exits, propagated past the loop. + have ⟨ρ_inner, h_inner_exit, heq_ρ', hlen_inner⟩ := + blockT_none_reaches_exiting (extendEval := extendEval) h_block_exit + have h_body_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_src) (outcomeConfig (some lbl) ρ_inner) := + hρ_src'_eq ▸ reflTransT_to_prop h_inner_exit + obtain ⟨h_inner_fresh, ρ_inner_tgt, h_body_tgt, h_off_inner, h_fail_inner, + h_eval_inner, h_fresh_inner⟩ := + h_body_sim (some lbl) ρ_src ρ_inner ρ_tgt h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr + hwf_var h_wf_gen h_src_fresh h_tgt_fresh h_body_run + subst heq_ρ' + refine ⟨?_, ({ ρ_inner_tgt with store := projectStore ρ_tgt.store ρ_inner_tgt.store } : Env P), + ?_, ?_, ?_, ?_, ?_⟩ + · intro t h_suf + show (if (ρ_src.store (HasIdent.ident (P := P) t)).isSome + then ρ_inner.store (HasIdent.ident (P := P) t) else none) = none + by_cases hp : (ρ_src.store (HasIdent.ident (P := P) t)).isSome + · rw [if_pos hp]; exact h_inner_fresh t h_suf + · rw [if_neg hp] + · -- Target: enter (guard tt), body' exits lbl inside the block; the + -- trailing havoc is skipped (the body' exit propagates), block + -- mismatch (.none), seq exit skips the loop tail. + refine .step _ _ _ (StepStmt.step_loop_enter (hasInvFailure := false) + h_guard_tt (by simp) (by simp) (h_eval_eq ▸ hwfb)) ?_ + have h_body_tgt' : StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.exiting lbl ρ_inner_tgt) := by + have he : ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) = ρ_tgt := by + simp [Bool.or_false] + rw [he]; simpa only [outcomeConfig] using h_body_tgt + -- body' ++ [havoc] exits lbl (the prefix exits, suffix skipped). + have h_body_tail_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.exiting lbl ρ_inner_tgt) := + stmts_cons_head_exiting_append (extendEval := extendEval) _ _ _ ρ_inner_tgt lbl h_body_tgt' + have h_block_tgt_exit : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.exiting lbl ({ ρ_inner_tgt with store := projectStore ρ_tgt.store ρ_inner_tgt.store } : Env P)) := by + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_body_tail_exit) ?_ + exact .step _ _ _ (StepStmt.step_block_exit_mismatch (by simp)) (.refl _) + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_block_tgt_exit) ?_ + exact .step _ _ _ StepStmt.step_seq_exit (.refl _) + · intro x h_nongen + show projectStore ρ_tgt.store ρ_inner_tgt.store x + = projectStore ρ_src.store ρ_inner.store x + show (if (ρ_tgt.store x).isSome then ρ_inner_tgt.store x else none) + = (if (ρ_src.store x).isSome then ρ_inner.store x else none) + rw [h_agree x h_nongen, h_off_inner x h_nongen] + · exact h_fail_inner + · exact h_eval_inner + · intro s h_suf h_notin + show (if (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + then ρ_inner_tgt.store (HasIdent.ident (P := P) s) else none) = none + rw [h_tgt_fresh s h_suf h_notin]; rfl + · -- Body terminates, loop tail exits with lbl: recurse on the tail. + have ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_none_reaches_terminal (extendEval := extendEval) h_block_term + have ⟨h_loop_T_exit, hlen_cons⟩ := + stmtsT_singleton_exiting (extendEval := extendEval) h_loop_exit + have h_body_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_src) (outcomeConfig none ρ_inner) := + hρ_src'_eq ▸ reflTransT_to_prop h_inner_term + obtain ⟨h_inner_fresh, ρ_inner_tgt, h_body_tgt, h_off_inner, h_fail_inner, + h_eval_inner, h_fresh_inner⟩ := + h_body_sim none ρ_src ρ_inner ρ_tgt h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr + hwf_var h_wf_gen h_src_fresh h_tgt_fresh h_body_run + have h_eval_inner_src : ρ_inner.eval = ρ_src.eval := + block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ_src ρ_inner h_nofd_body + (by simpa only [outcomeConfig] using h_body_run) + have heq_ρ_block_full : + ρ_block = ({ ρ_inner with store := projectStore ρ_src.store ρ_inner.store } : Env P) := by + rw [heq_ρ_block] + subst heq_ρ_block_full + have h_g_some_tgt : (ρ_tgt.store (HasIdent.ident (P := P) g)).isSome = true := by + rw [h_guard_def]; rfl + have h_body_tgt_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ρ_inner_tgt) := by + have he : ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) = ρ_tgt := by + simp [Bool.or_false] + rw [he]; simpa only [outcomeConfig] using h_body_tgt + have h_g_some_inner : (ρ_inner_tgt.store (HasIdent.ident (P := P) g)).isSome = true := + stmts_preserves_isSome (extendEval := extendEval) h_body_tgt_term (y := HasIdent.ident (P := P) g) + (show (({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P).store + (HasIdent.ident (P := P) g)).isSome = true from h_g_some_tgt) + obtain ⟨v', hv'⟩ := Option.isSome_iff_exists.mp h_g_some_inner + have hwf_var_inner : WellFormedSemanticEvalVar ρ_inner_tgt.eval := by + rw [h_eval_inner, h_eval_inner_src]; exact hwf_var + let ρ_src_next : Env P := { ρ_inner with store := projectStore ρ_src.store ρ_inner.store } + -- Invert the loop tail (exiting lbl) to learn the next decision. EXIT + -- is impossible (`.terminal _ →* .exiting lbl`), so the next is ENTER: + -- re-havoc $g := tt and recurse with entering = true. + have hrest_enter : + ∃ (hr : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ_src_next.store (.stmts body + ({ ρ_src_next with hasFailure := ρ_src_next.hasFailure || false } : Env P))) + [.loop .nondet m ([] : List (String × P.Expr)) body md]) + (outcomeConfig (some lbl) ρ')), hr.len ≤ n := by + rcases loop_nondet_step_first_inv (extendEval := extendEval) (oc := some lbl) + h_loop_T_exit with + ⟨hrest_next, _⟩ | ⟨hrest_next, hlen_next⟩ + · exfalso + simp only [outcomeConfig] at hrest_next + match hrest_next with + | .step _ _ _ h _ => exact nomatch h + · have h_bound : h_loop_T_exit.len ≤ n := by omega + exact ⟨hrest_next, Nat.le_of_lt (Nat.lt_of_lt_of_le hlen_next h_bound)⟩ + obtain ⟨hrest_next, hlen_tail⟩ := hrest_enter + have h_tail : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)) ρ_inner_tgt) + (.terminal ({ ρ_inner_tgt with store := storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.tt } : Env P)) := + step_havoc_set_to (extendEval := extendEval) (HasIdent.ident (P := P) g) HasBool.tt md ρ_inner_tgt v' hv' + hwf_var_inner + have h_body_tail : StepStmtStar P (EvalCmd P) extendEval + (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ({ ρ_inner_tgt with store := storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.tt } : Env P)) := + ReflTrans_Transitive _ _ _ _ + (stmts_prefix_terminal_append P (EvalCmd P) extendEval _ _ _ ρ_inner_tgt h_body_tgt_term) + (stmt_to_singleton_stmts (extendEval := extendEval) _ ρ_inner_tgt _ h_tail) + let ρ_tgt_next : Env P := { ρ_inner_tgt with store := projectStore ρ_tgt.store (storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.tt) } + have h_guard_next : ρ_tgt_next.store (HasIdent.ident (P := P) g) = some HasBool.tt := by + show (if (ρ_tgt.store (HasIdent.ident (P := P) g)).isSome + then storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.tt + (HasIdent.ident (P := P) g) else none) = some HasBool.tt + rw [if_pos h_g_some_tgt]; simp [storeWith] + have h_eval_next : ρ_src_next.eval = ρ_src.eval := h_eval_inner_src + have hwfb_next : WellFormedSemanticEvalBool ρ_src_next.eval := by rw [h_eval_next]; exact hwfb + have hwfv_next : WellFormedSemanticEvalVal ρ_src_next.eval := by rw [h_eval_next]; exact hwfv + have hwf_def_next : WellFormedSemanticEvalDef ρ_src_next.eval := by rw [h_eval_next]; exact hwf_def + have hwf_congr_next : WellFormedSemanticEvalExprCongr ρ_src_next.eval := by rw [h_eval_next]; exact hwf_congr + have hwf_var_next : WellFormedSemanticEvalVar ρ_src_next.eval := by rw [h_eval_next]; exact hwf_var + have h_eval_eq_next : ρ_tgt_next.eval = ρ_src_next.eval := by + show ρ_inner_tgt.eval = ρ_inner.eval; exact h_eval_inner + have h_fail_eq_next : ρ_tgt_next.hasFailure = ρ_src_next.hasFailure := by + show ρ_inner_tgt.hasFailure = ρ_inner.hasFailure; exact h_fail_inner + have h_agree_next : AgreeOffGen Q ρ_src_next.store ρ_tgt_next.store := by + intro x h_nongen + have h_x_ne : x ≠ HasIdent.ident (P := P) g := by + rintro rfl; exact (h_nongen g rfl) h_g_gen + show (if (ρ_tgt.store x).isSome then + (if x = HasIdent.ident (P := P) g then some HasBool.tt else ρ_inner_tgt.store x) + else none) + = (if (ρ_src.store x).isSome then ρ_inner.store x else none) + rw [if_neg h_x_ne, h_agree x h_nongen, h_off_inner x h_nongen] + have h_src_fresh_next : ∀ t, Q t → + ρ_src_next.store (HasIdent.ident (P := P) t) = none := by + intro t h_suf + show (if (ρ_src.store (HasIdent.ident (P := P) t)).isSome + then ρ_inner.store (HasIdent.ident (P := P) t) else none) = none + by_cases hp : (ρ_src.store (HasIdent.ident (P := P) t)).isSome + · rw [if_pos hp]; exact h_inner_fresh t h_suf + · rw [if_neg hp] + have h_tgt_fresh_next : GenFreshStore Q σ ρ_tgt_next.store := by + intro s h_suf h_notin + show (if (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + then storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) HasBool.tt + (HasIdent.ident (P := P) s) else none) = none + rw [h_tgt_fresh s h_suf h_notin]; rfl + obtain ⟨h_fresh', ρ_out, h_loop_tgt, h_off', h_fail', h_eval', h_fresh_out⟩ := + ih (oc := some lbl) (ρ_src := ρ_src_next) (ρ' := ρ') (ρ_tgt := ρ_tgt_next) + h_eval_eq_next h_fail_eq_next h_agree_next + hwfb_next hwfv_next hwf_def_next hwf_congr_next hwf_var_next + h_src_fresh_next h_tgt_fresh_next true h_guard_next + (.inr ⟨rfl, hrest_next, hlen_tail⟩) + simp only [outcomeConfig] at h_loop_tgt + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', h_fresh_out⟩ + refine .step _ _ _ (StepStmt.step_loop_enter (hasInvFailure := false) + h_guard_tt (by simp) (by simp) (h_eval_eq ▸ hwfb)) ?_ + have h_block_run : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.terminal ρ_tgt_next) := by + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_body_tail) ?_ + exact .step _ _ _ StepStmt.step_block_done (.refl _) + have h_loop_stmts_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m + ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md] ρ_tgt_next) + (.exiting lbl ρ_out) := by + refine .step _ _ _ StepStmt.step_stmts_cons ?_ + refine ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_loop_tgt) ?_ + exact .step _ _ _ StepStmt.step_seq_exit (.refl _) + refine ReflTrans_Transitive _ _ _ _ + (ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_block_run) + (.step _ _ _ StepStmt.step_seq_done (.refl _))) + h_loop_stmts_exit + + +/- General forward simulation with **separate** source and target start stores +threading the generator state `σ`. This is the inductive workhorse: a source +run from `ρ_src` is simulated by the rewritten block from any target store that +agrees with the source off the gen-shaped guards (`AgreeOffGen`) and matches its +evaluator and failure flag. The generated guard variables are hidden from the +source by `AgreeOffGen`/`StoreAgreement`'s treatment of the gen slots. + +Invariants threaded: +- `AgreeOffGen Q ρ_src.store ρ_tgt.store`: target = source off the guard slots + (so a fresh user var stays fresh in the target — the `.cmd`/`init` arm); +- `GenFreshStore Q σ ρ_tgt.store`: the target store has no *ungenerated* gen-shaped + slot defined (so each freshly-generated guard slot is `none` for the inserted + `init`/`set`); +- `h_src_fresh`: the source store has *no* gen-shaped slot defined (so the + generated guard is hidden from the source via `storeAgreement_storeWith`); +- `SrcNoGenWrites ss`: the source program never writes a gen-shaped variable + (spec §7; preserves `h_src_fresh` across sequencing); +- `WF σ`: the generator is well-formed (so generated names are genuinely fresh). + +The conclusion strengthens to `AgreeOffGen Q ρ'.store ρ_out.store` so the inductive +step composes; the public `StoreAgreement` corollary follows by +`StoreAgreement.of_agreeOffGen`. See spec §4. -/ +mutual +/-- Per-statement forward simulation (the workhorse companion of +`nondetElim_simulation_gen`). A terminating source run of a single statement +`s` is simulated by the rewritten block `(Stmt.nondetElimM s σ).1`, threading the +same invariants and producing the advanced-state freshness for sequencing. -/ +private theorem nondetElim_stmt_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] + {Q : String → Prop} + (hQmint : (∀ sg, Q (StringGenState.gen ndelimItePrefix sg).1) + ∧ (∀ sg, Q (StringGenState.gen ndelimLoopPrefix sg).1)) + (extendEval : ExtendEval P) + (s : Stmt P (Cmd P)) (σ : StringGenState) + (ρ_src ρ' ρ_tgt : Env P) + (h_eval_eq : ρ_tgt.eval = ρ_src.eval) + (h_fail_eq : ρ_tgt.hasFailure = ρ_src.hasFailure) + (h_agree : AgreeOffGen Q ρ_src.store ρ_tgt.store) + (hwfb : WellFormedSemanticEvalBool ρ_src.eval) + (hwfv : WellFormedSemanticEvalVal ρ_src.eval) + (hwf_def : WellFormedSemanticEvalDef ρ_src.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ_src.eval) + (hwf_var : WellFormedSemanticEvalVar ρ_src.eval) + (h_wf_gen : StringGenState.WF σ) + (h_src_fresh : ∀ t, Q t → + ρ_src.store (HasIdent.ident (P := P) t) = none) + (h_tgt_fresh : GenFreshStore Q σ ρ_tgt.store) + (h_no_writes : NoGenSuffix (P := P) Q (Stmt.definedVars s ++ Stmt.modifiedVars s)) + (h_nofd : Stmt.noFuncDecl s = true) + (h_lhni : Stmt.loopHasNoInvariants s = true) + (oc : Option String) + (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ_src) (outcomeConfig oc ρ')) : + (∀ t, Q t → + ρ'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.nondetElimM s σ).1 ρ_tgt) (outcomeConfig oc ρ_out) + ∧ AgreeOffGen Q ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure + ∧ ρ_out.eval = ρ'.eval + ∧ GenFreshStore Q (Stmt.nondetElimM s σ).2 ρ_out.store := by + match s, h_no_writes, h_nofd, h_lhni, oc, h_term with + | .cmd c, h_no_writes, _, _, oc, h_term => + -- A `.cmd` only ever reaches `.terminal`, so the exiting outcome is vacuous. + match oc, h_term with + | none, h_term => + -- Output is the same `.cmd c`; replay it under `AgreeOffGen`. + have h_no_writes_c : NoGenSuffix (P := P) Q (Cmd.definedVars c ++ Cmd.modifiedVars c) := by + have h_dv : Stmt.definedVars (P := P) (.cmd c) = Cmd.definedVars c := by + with_unfolding_all rfl + have h_mv : Stmt.modifiedVars (P := P) (.cmd c) = Cmd.modifiedVars c := by + with_unfolding_all rfl + rw [h_dv, h_mv] at h_no_writes; exact h_no_writes + obtain ⟨h_src'_fresh, ρ_tgt', h_run, h_off', h_fail', h_eval', h_fresh'⟩ := + cmd_replay_agreement_offgen extendEval c ρ_src ρ' ρ_tgt σ + h_eval_eq h_fail_eq h_agree hwf_def hwf_congr h_src_fresh h_tgt_fresh + h_no_writes_c h_term + refine ⟨h_src'_fresh, ρ_tgt', ?_, h_off', h_fail', h_eval', ?_⟩ + · simp only [Stmt.nondetElimM, outcomeConfig] + exact stmt_to_singleton_stmts (extendEval := extendEval) (.cmd c) ρ_tgt ρ_tgt' h_run + · simp only [Stmt.nondetElimM]; exact h_fresh' + | some lbl, h_term => + -- `.cmd c` cannot reach `.exiting`: its only step is `step_cmd` to `.terminal`. + exfalso + obtain ⟨cfg, hstep, hrest⟩ := + stmt_step_first_inv_to (extendEval := extendEval) _ ρ_src (outcomeConfig (some lbl) ρ') + (by intro ρ'' h; simp only [outcomeConfig] at h <;> cases h) h_term + cases hstep with + | step_cmd _ => + -- residual run: `.terminal _ →* .exiting lbl ρ'` is impossible. + cases hrest with + | step _ _ _ h _ => cases h + | .block lbl bss md, h_no_writes, h_nofd, h_lhni, oc, h_term => + -- Source: `.stmt (.block lbl bss md) ρ_src` steps via `step_block` to the + -- block context `.block (.some lbl) ρ_src.store (.stmts bss ρ_src)`, which + -- then reaches the outer outcome. Invert it to the inner body's run. + obtain ⟨c, hstep, hrest⟩ := + stmt_step_first_inv_to (extendEval := extendEval) _ ρ_src (outcomeConfig oc ρ') + (by intro ρ'' h; cases oc <;> simp only [outcomeConfig] at h <;> cases h) h_term + cases hstep with + | step_block => + -- Distribute the source side-conditions onto `bss`. + have h_dv : Stmt.definedVars (P := P) (.block lbl bss md) = Block.definedVars bss := by + with_unfolding_all rfl + have h_mv : Stmt.modifiedVars (P := P) (.block lbl bss md) = Block.modifiedVars bss := by + with_unfolding_all rfl + have h_no_writes_bss : SrcNoGenWrites (P := P) Q bss := by + show NoGenSuffix (P := P) Q (Block.definedVars bss ++ Block.modifiedVars bss) + rw [h_dv, h_mv] at h_no_writes; exact h_no_writes + have h_nofd_bss : Block.noFuncDecl bss = true := by + simpa only [Stmt.noFuncDecl] using h_nofd + have h_lhni_bss : Block.loopHasNoInvariants bss = true := + Stmt.loopHasNoInvariants_block_body h_lhni + -- In every subcase the inner body `bss` reaches some inner outcome + -- `outcomeConfig oc_inner ρ_inner`, with `ρ' = ρ_inner ⊳ projectStore`. + -- We first determine `oc_inner` from `oc` and the block inversion, then + -- recurse on `bss`, then re-wrap with the matching block step rule. The + -- five store-level conjuncts are identical across subcases (both target and + -- source project the inner store through their agreeing parents), so we + -- discharge them through the shared `wrap` continuation. + have wrap : ∀ (oc_inner : Option String) (ρ_inner : Env P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts bss ρ_src) (outcomeConfig oc_inner ρ_inner) → + (∀ (ρ_out_inner : Env P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElimM bss σ).1 ρ_tgt) (outcomeConfig oc_inner ρ_out_inner) → + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.nondetElimM (.block lbl bss md) σ).1 ρ_tgt) + (outcomeConfig oc ({ ρ_out_inner with + store := projectStore ρ_tgt.store ρ_out_inner.store } : Env P))) → + ρ' = { ρ_inner with store := projectStore ρ_src.store ρ_inner.store } → + (∀ t, Q t → + ρ'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.nondetElimM (.block lbl bss md) σ).1 ρ_tgt) + (outcomeConfig oc ρ_out) + ∧ AgreeOffGen Q ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure + ∧ ρ_out.eval = ρ'.eval + ∧ GenFreshStore Q (Stmt.nondetElimM (.block lbl bss md) σ).2 ρ_out.store := by + intro oc_inner ρ_inner h_inner_run wrap_run h_ρ'_eq + obtain ⟨h_fresh_inner, ρ_out_inner, h_run_inner, h_off_inner, h_fail_inner, + h_eval_inner, h_fresh_out⟩ := + nondetElim_simulation_gen hQmint extendEval bss σ ρ_src ρ_inner ρ_tgt + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf_gen h_src_fresh h_tgt_fresh h_no_writes_bss h_nofd_bss h_lhni_bss + oc_inner h_inner_run + refine ⟨?_, ({ ρ_out_inner with + store := projectStore ρ_tgt.store ρ_out_inner.store } : Env P), + wrap_run ρ_out_inner h_run_inner, ?_, ?_, ?_, ?_⟩ + · -- ρ'.store is fresh: ρ' = ρ_inner projected through ρ_src.store. + subst h_ρ'_eq + intro t h_suf + show projectStore ρ_src.store ρ_inner.store (HasIdent.ident (P := P) t) = none + show (if (ρ_src.store (HasIdent.ident (P := P) t)).isSome + then ρ_inner.store (HasIdent.ident (P := P) t) else none) = none + by_cases hp : (ρ_src.store (HasIdent.ident (P := P) t)).isSome + · rw [if_pos hp]; exact h_fresh_inner t h_suf + · rw [if_neg hp] + · -- AgreeOffGen Q survives projecting both stores through agreeing parents. + subst h_ρ'_eq + intro x h_nongen + show projectStore ρ_tgt.store ρ_out_inner.store x + = projectStore ρ_src.store ρ_inner.store x + show (if (ρ_tgt.store x).isSome then ρ_out_inner.store x else none) + = (if (ρ_src.store x).isSome then ρ_inner.store x else none) + have h_par : ρ_tgt.store x = ρ_src.store x := h_agree x h_nongen + have h_inn : ρ_out_inner.store x = ρ_inner.store x := h_off_inner x h_nongen + rw [h_par, h_inn] + · -- hasFailure unchanged: the record-update keeps `hasFailure`. + subst h_ρ'_eq; exact h_fail_inner + · -- eval unchanged. + subst h_ρ'_eq; exact h_eval_inner + · -- GenFreshStore Q at the block output state = (Block.nondetElimM bss σ).2. + have h_out_eq : (Stmt.nondetElimM (.block lbl bss md) σ).2 + = (Block.nondetElimM bss σ).2 := by + rw [Stmt.nondetElimM] + rcases hh : Block.nondetElimM bss σ with ⟨bss', σ'⟩ + simp only [hh] + rw [h_out_eq] + intro s h_suf h_notin + show projectStore ρ_tgt.store ρ_out_inner.store (HasIdent.ident (P := P) s) = none + show (if (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + then ρ_out_inner.store (HasIdent.ident (P := P) s) else none) = none + by_cases hp : (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + · rw [if_pos hp]; exact h_fresh_out s h_suf h_notin + · rw [if_neg hp] + -- Now branch on the outer outcome. + cases oc with + | none => + -- Block terminates: body terminated, or exited matching `lbl`. + rcases block_some_reaches_terminal P (EvalCmd P) extendEval hrest with + ⟨ρ_inner, h_inner_term, h_ρ'_eq⟩ | ⟨ρ_inner, h_inner_exit, h_ρ'_eq⟩ + · -- TERMINAL inner: re-wrap with `step_block_done`. + refine wrap none ρ_inner h_inner_term (fun ρ_out_inner h_run_inner => ?_) h_ρ'_eq + rw [Stmt.nondetElimM_block_out] + refine stmt_to_singleton_stmts (extendEval := extendEval) _ ρ_tgt _ ?_ + refine .step _ _ _ (StepStmt.step_block) ?_ + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ (.some lbl) ρ_tgt.store + (show StepStmtStar P (EvalCmd P) extendEval _ (.terminal ρ_out_inner) from + h_run_inner)) ?_ + exact .step _ _ _ StepStmt.step_block_done (.refl _) + · -- MATCHING-EXIT inner: re-wrap with `step_block_exit_match`. + refine wrap (some lbl) ρ_inner h_inner_exit (fun ρ_out_inner h_run_inner => ?_) h_ρ'_eq + rw [Stmt.nondetElimM_block_out] + refine stmt_to_singleton_stmts (extendEval := extendEval) _ ρ_tgt _ ?_ + refine .step _ _ _ (StepStmt.step_block) ?_ + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ (.some lbl) ρ_tgt.store + (show StepStmtStar P (EvalCmd P) extendEval _ (.exiting lbl ρ_out_inner) from + h_run_inner)) ?_ + exact .step _ _ _ (StepStmt.step_block_exit_match rfl) (.refl _) + | some lbl' => + -- Block exits with `lbl'`: body exited with the same (non-matching) label. + obtain ⟨ρ_inner, h_inner_exit, h_ne, h_ρ'_eq⟩ := + block_reaches_exiting_strong P (EvalCmd P) extendEval hrest + refine wrap (some lbl') ρ_inner h_inner_exit + (fun ρ_out_inner h_run_inner => ?_) h_ρ'_eq + rw [Stmt.nondetElimM_block_out] + refine stmt_to_singleton_stmts_exiting (extendEval := extendEval) _ ρ_tgt _ lbl' ?_ + refine .step _ _ _ (StepStmt.step_block) ?_ + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ (.some lbl) ρ_tgt.store + (show StepStmtStar P (EvalCmd P) extendEval _ (.exiting lbl' ρ_out_inner) from + h_run_inner)) ?_ + exact .step _ _ _ (StepStmt.step_block_exit_mismatch h_ne) (.refl _) + | .ite (.det e) tss ess md, h_no_writes, h_nofd, h_lhni, oc, h_term => + -- The deterministic guard reads the same value in the target (AgreeOffGen Q on + -- the guard's source-defined vars), so the target takes the matching branch. + obtain ⟨cfg, hstep, hbranch⟩ := + stmt_step_first_inv_to (extendEval := extendEval) _ ρ_src (outcomeConfig oc ρ') + (by intro ρ'' h; cases oc <;> simp only [outcomeConfig] at h <;> cases h) h_term + have hwf_var_t : WellFormedSemanticEvalVar ρ_tgt.eval := h_eval_eq ▸ hwf_var + -- Source-shape and noFuncDecl split into the two branches. + have h_dv : Stmt.definedVars (P := P) (.ite (.det e) tss ess md) + = Block.definedVars tss ++ Block.definedVars ess := rfl + have h_mv : Stmt.modifiedVars (P := P) (.ite (.det e) tss ess md) + = Block.modifiedVars tss ++ Block.modifiedVars ess := rfl + have h_nofd' : Block.noFuncDecl tss = true ∧ Block.noFuncDecl ess = true := by + have : (Block.noFuncDecl tss && Block.noFuncDecl ess) = true := by + simpa only [Stmt.noFuncDecl] using h_nofd + exact Bool.and_eq_true _ _ |>.mp this + -- The target output: [.ite (.det e) tss' ess']. + cases hstep with + | step_ite_true h_cond hwfb_s => + -- Branch `tss` runs to terminal `ρ'`; recurse on it via the block lemma. + have h_no_writes_t : SrcNoGenWrites (P := P) Q tss := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (by rw [h_dv]; exact List.mem_append_left _ (List.mem_append_left _ hd)) t heq + · exact h_no_writes x (by rw [h_mv]; exact List.mem_append_right _ (List.mem_append_left _ hm)) t heq + obtain ⟨h_fresh', ρ_out, h_run, h_off', h_fail', h_eval', h_fresh_out⟩ := + nondetElim_simulation_gen hQmint extendEval tss σ ρ_src ρ' ρ_tgt + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf_gen h_src_fresh h_tgt_fresh h_no_writes_t h_nofd'.1 + (Stmt.loopHasNoInvariants_branch_then h_lhni) oc hbranch + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', ?_⟩ + · -- Target: [.ite (.det e) (nondetElim tss) (nondetElim ess at σ₂)] reads tt. + rw [Stmt.nondetElimM_ite_det_out] + -- guard reads tt in target + have h_def_e : isDefined ρ_src.store (HasVarsPure.getVars e) := + hwf_def e HasBool.tt ρ_src.store h_cond + have h_pw : ∀ x ∈ HasVarsPure.getVars e, ρ_src.store x = ρ_tgt.store x := + agreeOffGen_pointwise_on_expr_vars ρ_src.store ρ_tgt.store e h_agree h_src_fresh h_def_e + have h_cond_t : ρ_tgt.eval ρ_tgt.store e = some HasBool.tt := by + rw [h_eval_eq, ← h_cond]; exact (hwf_congr e ρ_src.store ρ_tgt.store h_pw).symm + refine stmt_to_singleton_stmts_outcome (extendEval := extendEval) _ ρ_tgt ρ_out oc ?_ + refine .step _ _ _ (StepStmt.step_ite_true h_cond_t (h_eval_eq ▸ hwfb)) ?_ + exact h_run + · simp only [Stmt.nondetElimM] + rcases h₁ : Block.nondetElimM tss σ with ⟨tss', σ₁⟩ + rcases h₂ : Block.nondetElimM ess σ₁ with ⟨ess', σ₂⟩ + simp only [h₂] + -- Freshness at σ₂ ⊇ σ₁ = output of tss; ρ_out fresh at σ₁ (= (nondetElimM tss σ).2). + have h_eq1 : σ₁ = (Block.nondetElimM tss σ).2 := by rw [h₁] + have h_step12 : StringGenState.GenStep σ₁ σ₂ := by + have := Block.nondetElimM_genStep ess σ₁; rw [h₂] at this; exact this + have h_fresh_σ₁ : GenFreshStore Q σ₁ ρ_out.store := by + rw [h_eq1]; exact h_fresh_out + exact GenFreshStore.mono h_step12 h_fresh_σ₁ + | step_ite_false h_cond hwfb_s => + have h_no_writes_e : SrcNoGenWrites (P := P) Q ess := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (by rw [h_dv]; exact List.mem_append_left _ (List.mem_append_right _ hd)) t heq + · exact h_no_writes x (by rw [h_mv]; exact List.mem_append_right _ (List.mem_append_right _ hm)) t heq + -- The else branch runs from σ₁ = (Block.nondetElimM tss σ).2. + have h_wf₁ : StringGenState.WF (Block.nondetElimM tss σ).2 := + (Block.nondetElimM_genStep tss σ).wf_mono h_wf_gen + have h_tgt_fresh₁ : GenFreshStore Q (Block.nondetElimM tss σ).2 ρ_tgt.store := + GenFreshStore.mono (Block.nondetElimM_genStep tss σ) h_tgt_fresh + obtain ⟨h_fresh', ρ_out, h_run, h_off', h_fail', h_eval', h_fresh_out⟩ := + nondetElim_simulation_gen hQmint extendEval ess (Block.nondetElimM tss σ).2 ρ_src ρ' ρ_tgt + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf₁ h_src_fresh h_tgt_fresh₁ h_no_writes_e h_nofd'.2 + (Stmt.loopHasNoInvariants_branch_else h_lhni) oc hbranch + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', ?_⟩ + · rw [Stmt.nondetElimM_ite_det_out] + have h_def_e : isDefined ρ_src.store (HasVarsPure.getVars e) := + hwf_def e HasBool.ff ρ_src.store h_cond + have h_pw : ∀ x ∈ HasVarsPure.getVars e, ρ_src.store x = ρ_tgt.store x := + agreeOffGen_pointwise_on_expr_vars ρ_src.store ρ_tgt.store e h_agree h_src_fresh h_def_e + have h_cond_t : ρ_tgt.eval ρ_tgt.store e = some HasBool.ff := by + rw [h_eval_eq, ← h_cond]; exact (hwf_congr e ρ_src.store ρ_tgt.store h_pw).symm + refine stmt_to_singleton_stmts_outcome (extendEval := extendEval) _ ρ_tgt ρ_out oc ?_ + refine .step _ _ _ (StepStmt.step_ite_false h_cond_t (h_eval_eq ▸ hwfb)) ?_ + exact h_run + · simp only [Stmt.nondetElimM] + rcases h₁ : Block.nondetElimM tss σ with ⟨tss', σ₁⟩ + rcases h₂ : Block.nondetElimM ess σ₁ with ⟨ess', σ₂⟩ + simp only [h₂] + have h_eq2 : σ₂ = (Block.nondetElimM ess σ₁).2 := by rw [h₂] + have h_eq1 : σ₁ = (Block.nondetElimM tss σ).2 := by rw [h₁] + rw [h_eq2, h_eq1] at * + exact h_fresh_out + | .ite .nondet tss ess md, h_no_writes, h_nofd, h_lhni, oc, h_term => + -- Generated guard and advanced state. + rcases hgen : StringGenState.gen ndelimItePrefix σ with ⟨g, σ₁⟩ + -- g is gen-shaped and the target guard slot is fresh. + have h_g_gen : Q g := by + have := hQmint.1 σ + rw [hgen] at this; exact this + have h_tgt_g_none : ρ_tgt.store (HasIdent.ident (P := P) g) = none := by + have := GenFreshStore.gen_slot_none ndelimItePrefix h_tgt_fresh h_wf_gen (hQmint.1 σ) + rw [hgen] at this; exact this + have hwf_var_t : WellFormedSemanticEvalVar ρ_tgt.eval := h_eval_eq ▸ hwf_var + have hwfb_t : WellFormedSemanticEvalBool ρ_tgt.eval := h_eval_eq ▸ hwfb + -- GenStep facts. + have h_step01 : StringGenState.GenStep σ σ₁ := by + have := StringGenState.GenStep.of_gen ndelimItePrefix σ; rw [hgen] at this; exact this + have h_wf₁ : StringGenState.WF σ₁ := h_step01.wf_mono h_wf_gen + -- Branch source-shape splits. + have h_dv : Stmt.definedVars (P := P) (.ite .nondet tss ess md) + = Block.definedVars tss ++ Block.definedVars ess := rfl + have h_mv : Stmt.modifiedVars (P := P) (.ite .nondet tss ess md) + = Block.modifiedVars tss ++ Block.modifiedVars ess := rfl + have h_nofd' : Block.noFuncDecl tss = true ∧ Block.noFuncDecl ess = true := by + have : (Block.noFuncDecl tss && Block.noFuncDecl ess) = true := by + simpa only [Stmt.noFuncDecl] using h_nofd + exact Bool.and_eq_true _ _ |>.mp this + have h_no_writes_t : SrcNoGenWrites (P := P) Q tss := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (by rw [h_dv]; exact List.mem_append_left _ (List.mem_append_left _ hd)) t heq + · exact h_no_writes x (by rw [h_mv]; exact List.mem_append_right _ (List.mem_append_left _ hm)) t heq + have h_no_writes_e : SrcNoGenWrites (P := P) Q ess := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (by rw [h_dv]; exact List.mem_append_left _ (List.mem_append_right _ hd)) t heq + · exact h_no_writes x (by rw [h_mv]; exact List.mem_append_right _ (List.mem_append_right _ hm)) t heq + -- Invert source nondet-ite: either tss or ess runs to the outcome. + rcases ite_nondet_step_inv_outcome (extendEval := extendEval) tss ess md ρ_src ρ' oc h_term with h_br | h_br + · -- True branch fired: choose havoc value tt. + have h_off_g : AgreeOffGen Q ρ_src.store + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.tt) := + AgreeOffGen.storeWith_gen h_agree h_g_gen + have h_fresh_g : GenFreshStore Q σ₁ + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.tt) := by + have := GenFreshStore.storeWith_gen (P := P) ndelimItePrefix HasBool.tt h_tgt_fresh + rw [hgen] at this; exact this + obtain ⟨h_fresh', ρ_out, h_run, h_off', h_fail', h_eval', h_fresh_out⟩ := + nondetElim_simulation_gen hQmint extendEval tss σ₁ + ρ_src ρ' ({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.tt } : Env P) + h_eval_eq h_fail_eq h_off_g hwfb hwfv hwf_def hwf_congr hwf_var + h_wf₁ h_src_fresh h_fresh_g h_no_writes_t h_nofd'.1 + (Stmt.loopHasNoInvariants_branch_then h_lhni) oc h_br + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', ?_⟩ + · rw [Stmt.nondetElimM_ite_nondet_out] + simp only [hgen] + exact step_ndelim_ite_prefix_outcome (extendEval := extendEval) true (HasIdent.ident (P := P) g) + (Block.nondetElimM tss σ₁).1 (Block.nondetElimM ess (Block.nondetElimM tss σ₁).2).1 md + ρ_tgt ρ_out oc h_tgt_g_none hwf_var_t hwfb_t h_run + · simp only [Stmt.nondetElimM, hgen] + rcases h₁ : Block.nondetElimM tss σ₁ with ⟨tss', σ₂⟩ + rcases h₂ : Block.nondetElimM ess σ₂ with ⟨ess', σ₃⟩ + simp only [h₂] + have h_eq2 : σ₂ = (Block.nondetElimM tss σ₁).2 := by rw [h₁] + have h_step23 : StringGenState.GenStep σ₂ σ₃ := by + have := Block.nondetElimM_genStep ess σ₂; rw [h₂] at this; exact this + have h_fresh_σ₂ : GenFreshStore Q σ₂ ρ_out.store := by rw [h_eq2]; exact h_fresh_out + exact GenFreshStore.mono h_step23 h_fresh_σ₂ + · -- False branch fired: choose havoc value ff. The output's else branch is + -- generated at σ₂ = (nondetElimM tss σ₁).2, so recurse on `ess` at σ₂. + have h_step12 : StringGenState.GenStep σ₁ (Block.nondetElimM tss σ₁).2 := + Block.nondetElimM_genStep tss σ₁ + have h_wf₂ : StringGenState.WF (Block.nondetElimM tss σ₁).2 := h_step12.wf_mono h_wf₁ + have h_off_g : AgreeOffGen Q ρ_src.store + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff) := + AgreeOffGen.storeWith_gen h_agree h_g_gen + have h_fresh_g1 : GenFreshStore Q σ₁ + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff) := by + have := GenFreshStore.storeWith_gen (P := P) ndelimItePrefix HasBool.ff h_tgt_fresh + rw [hgen] at this; exact this + have h_fresh_g : GenFreshStore Q (Block.nondetElimM tss σ₁).2 + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff) := + GenFreshStore.mono h_step12 h_fresh_g1 + obtain ⟨h_fresh', ρ_out, h_run, h_off', h_fail', h_eval', h_fresh_out⟩ := + nondetElim_simulation_gen hQmint extendEval ess (Block.nondetElimM tss σ₁).2 + ρ_src ρ' ({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff } : Env P) + h_eval_eq h_fail_eq h_off_g hwfb hwfv hwf_def hwf_congr hwf_var + h_wf₂ h_src_fresh h_fresh_g h_no_writes_e h_nofd'.2 + (Stmt.loopHasNoInvariants_branch_else h_lhni) oc h_br + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', ?_⟩ + · rw [Stmt.nondetElimM_ite_nondet_out] + simp only [hgen] + exact step_ndelim_ite_prefix_outcome (extendEval := extendEval) false (HasIdent.ident (P := P) g) + (Block.nondetElimM tss σ₁).1 (Block.nondetElimM ess (Block.nondetElimM tss σ₁).2).1 md + ρ_tgt ρ_out oc h_tgt_g_none hwf_var_t hwfb_t h_run + · simp only [Stmt.nondetElimM, hgen] + rcases h₁ : Block.nondetElimM tss σ₁ with ⟨tss', σ₂⟩ + rcases h₂ : Block.nondetElimM ess σ₂ with ⟨ess', σ₃⟩ + simp only [h₂] + simp only [h₁, h₂] at h_fresh_out + exact h_fresh_out + | .loop (.det e) m inv body md, h_no_writes, h_nofd, h_lhni, oc, h_term => + -- The invariant list is empty (`h_lhni`), so the loop matches the iteration + -- lemma's shape. The body output `(Block.nondetElimM body σ).1` is fixed + -- across iterations; `nondetElim_simulation_gen` on `body` supplies the + -- per-iteration body simulation. + have h_inv_nil : inv = [] := Stmt.loopHasNoInvariants_loop_invs h_lhni + subst h_inv_nil + have h_lhni_body : Block.loopHasNoInvariants body = true := + Stmt.loopHasNoInvariants_loop_body_rec h_lhni + have h_nofd_body : Block.noFuncDecl body = true := by + simpa only [Stmt.noFuncDecl] using h_nofd + have h_no_writes_body : SrcNoGenWrites (P := P) Q body := by + have h_dv : Stmt.definedVars (P := P) (.loop (.det e) m ([] : List (String × P.Expr)) body md) + = Block.definedVars body := rfl + have h_mv : Stmt.modifiedVars (P := P) (.loop (.det e) m ([] : List (String × P.Expr)) body md) + = Block.modifiedVars body := rfl + show NoGenSuffix (P := P) Q (Block.definedVars body ++ Block.modifiedVars body) + rw [h_dv, h_mv] at h_no_writes; exact h_no_writes + -- The per-iteration body simulation, from the mutual companion. + have h_body_sim : ∀ (oc_b : Option String) (ρb_src ρb' ρb_tgt : Env P), + ρb_tgt.eval = ρb_src.eval → + ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → + WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → + WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → + StringGenState.WF σ → + (∀ t, Q t → + ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) (outcomeConfig oc_b ρb') → + (∀ t, Q t → + ρb'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρb_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElimM body σ).1 ρb_tgt) (outcomeConfig oc_b ρb_out) + ∧ AgreeOffGen Q ρb'.store ρb_out.store + ∧ ρb_out.hasFailure = ρb'.hasFailure + ∧ ρb_out.eval = ρb'.eval + ∧ GenFreshStore Q (Block.nondetElimM body σ).2 ρb_out.store := + fun oc_b ρb_src ρb' ρb_tgt h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf hrun => + nondetElim_simulation_gen hQmint extendEval body σ ρb_src ρb' ρb_tgt + h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf + h_no_writes_body h_nofd_body h_lhni_body oc_b hrun + -- Run the iteration lemma, threading the Type-valued source-run length. + have hstarT := reflTrans_to_T h_term + obtain ⟨h_fresh', ρ_out, h_loop_run, h_off', h_fail', h_eval', h_fresh_out⟩ := + nondetElim_loop_det_sim_iteration extendEval e m body (Block.nondetElimM body σ).1 md σ + h_body_sim (Block.nondetElimM body σ).2 h_nofd_body + oc ρ_src ρ' ρ_tgt hstarT.len + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf_gen h_src_fresh h_tgt_fresh hstarT (Nat.le_refl _) + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', ?_⟩ + · -- Target output is `[.loop (.det e) m [] (Block.nondetElimM body σ).1 md]`. + rw [Stmt.nondetElimM_loop_det_out] + exact stmt_to_singleton_stmts_outcome (extendEval := extendEval) _ ρ_tgt ρ_out oc h_loop_run + · -- `(Stmt.nondetElimM (.loop …) σ).2 = (Block.nondetElimM body σ).2`; the loop + -- keeps gen state at `σ`, so mono the freshness up to the advanced state. + have h_out_eq : (Stmt.nondetElimM (.loop (.det e) m ([] : List (String × P.Expr)) body md) σ).2 + = (Block.nondetElimM body σ).2 := by + rw [Stmt.nondetElimM] + rcases hh : Block.nondetElimM body σ with ⟨body', σ'⟩ + simp only [hh] + rw [h_out_eq] + exact GenFreshStore.mono (Block.nondetElimM_genStep body σ) h_fresh_out + | .loop .nondet m inv body md, h_no_writes, h_nofd, h_lhni, oc, h_term => + -- The invariant list is empty (`h_lhni`). The pass emits an `init $g := *` + -- before a deterministic loop whose guard reads `$g` and whose body tail is a + -- re-havoc `set $g := *`. Generate `$g`, init it to the value matching the + -- source's first enter/exit choice, then run the nondet iteration lemma. + have h_inv_nil : inv = [] := Stmt.loopHasNoInvariants_loop_invs h_lhni + subst h_inv_nil + have h_lhni_body : Block.loopHasNoInvariants body = true := + Stmt.loopHasNoInvariants_loop_body_rec h_lhni + have h_nofd_body : Block.noFuncDecl body = true := by + simpa only [Stmt.noFuncDecl] using h_nofd + have h_no_writes_body : SrcNoGenWrites (P := P) Q body := by + have h_dv : Stmt.definedVars (P := P) (.loop .nondet m ([] : List (String × P.Expr)) body md) + = Block.definedVars body := rfl + have h_mv : Stmt.modifiedVars (P := P) (.loop .nondet m ([] : List (String × P.Expr)) body md) + = Block.modifiedVars body := rfl + show NoGenSuffix (P := P) Q (Block.definedVars body ++ Block.modifiedVars body) + rw [h_dv, h_mv] at h_no_writes; exact h_no_writes + -- Generate the loop guard `$g` and advance the state to σ₁. + rcases hgen : StringGenState.gen ndelimLoopPrefix σ with ⟨g, σ₁⟩ + have h_g_gen : Q g := by + have := hQmint.2 σ + rw [hgen] at this; exact this + have h_g_in : g ∈ σ₁.stringGens := by + have h := StringGenState.stringGens_gen ndelimLoopPrefix σ + rw [hgen] at h; rw [h]; exact List.mem_cons_self + have h_step01 : StringGenState.GenStep σ σ₁ := by + have := StringGenState.GenStep.of_gen ndelimLoopPrefix σ; rw [hgen] at this; exact this + have h_wf₁ : StringGenState.WF σ₁ := h_step01.wf_mono h_wf_gen + have h_tgt_g_none : ρ_tgt.store (HasIdent.ident (P := P) g) = none := by + have := GenFreshStore.gen_slot_none ndelimLoopPrefix h_tgt_fresh h_wf_gen (hQmint.2 σ) + rw [hgen] at this; exact this + have hwf_var_t : WellFormedSemanticEvalVar ρ_tgt.eval := h_eval_eq ▸ hwf_var + -- The per-iteration body simulation, from the mutual companion at σ₁. + have h_body_sim : ∀ (oc_b : Option String) (ρb_src ρb' ρb_tgt : Env P), + ρb_tgt.eval = ρb_src.eval → + ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → + WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → + WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → + StringGenState.WF σ₁ → + (∀ t, Q t → + ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ₁ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) (outcomeConfig oc_b ρb') → + (∀ t, Q t → + ρb'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρb_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElimM body σ₁).1 ρb_tgt) (outcomeConfig oc_b ρb_out) + ∧ AgreeOffGen Q ρb'.store ρb_out.store + ∧ ρb_out.hasFailure = ρb'.hasFailure + ∧ ρb_out.eval = ρb'.eval + ∧ GenFreshStore Q (Block.nondetElimM body σ₁).2 ρb_out.store := + fun oc_b ρb_src ρb' ρb_tgt h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf hrun => + nondetElim_simulation_gen hQmint extendEval body σ₁ ρb_src ρb' ρb_tgt + h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf + h_no_writes_body h_nofd_body h_lhni_body oc_b hrun + -- Common tail: from the matched `init`/iteration result, build the full run + -- (init $g := * then the loop) and discharge the output-freshness conjunct. + have finish : ∀ (entering : Bool) (b : P.Expr) + (h_b : b = (if entering then HasBool.tt else HasBool.ff)), + ((∀ t, Q t → + ρ'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m + ([] : List (String × P.Expr)) + ((Block.nondetElimM body σ₁).1 ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md) + ({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) b } : Env P)) + (outcomeConfig oc ρ_out) + ∧ AgreeOffGen Q ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure + ∧ ρ_out.eval = ρ'.eval + ∧ GenFreshStore Q σ₁ ρ_out.store) → + (∀ t, Q t → + ρ'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.nondetElimM (.loop .nondet m ([] : List (String × P.Expr)) body md) σ).1 ρ_tgt) + (outcomeConfig oc ρ_out) + ∧ AgreeOffGen Q ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure + ∧ ρ_out.eval = ρ'.eval + ∧ GenFreshStore Q (Stmt.nondetElimM (.loop .nondet m ([] : List (String × P.Expr)) body md) σ).2 ρ_out.store := by + intro entering b h_b ⟨h_fresh', ρ_out, h_loop_run, h_off', h_fail', h_eval', h_fresh_out⟩ + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', ?_⟩ + · rw [Stmt.nondetElimM_loop_nondet_out] + simp only [hgen] + -- Prepend the `init $g := b` step, then the loop run. + have h_init : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd (HasInit.init (HasIdent.ident (P := P) g) HasBool.boolTy .nondet md)) ρ_tgt) + (.terminal ({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) b } : Env P)) := + step_init_havoc_to (extendEval := extendEval) (HasIdent.ident (P := P) g) HasBool.boolTy b md ρ_tgt + h_tgt_g_none hwf_var_t + refine ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval _ _ ρ_tgt _ h_init) ?_ + exact stmt_to_singleton_stmts_outcome (extendEval := extendEval) _ _ ρ_out oc h_loop_run + · -- Output gen state = (Block.nondetElimM body σ₁).2 ⊇ σ₁; mono. + have h_out_eq2 : (Stmt.nondetElimM (.loop .nondet m ([] : List (String × P.Expr)) body md) σ).2 + = (Block.nondetElimM body σ₁).2 := by + rw [Stmt.nondetElimM] + rcases hh : Block.nondetElimM body σ₁ with ⟨body', σ₂⟩ + simp only [hgen, hh] + rw [h_out_eq2] + exact GenFreshStore.mono (Block.nondetElimM_genStep body σ₁) h_fresh_out + -- Invert the source loop's first step to pick the matched guard value. + have hstarT := reflTrans_to_T h_term + rcases loop_nondet_step_first_inv (extendEval := extendEval) hstarT with + ⟨hrest, hl⟩ | ⟨hrest, hl⟩ + · -- EXIT first: init $g := ff, entering = false. + have h_off_g : AgreeOffGen Q ρ_src.store + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff) := + AgreeOffGen.storeWith_gen h_agree h_g_gen + have h_fresh_g : GenFreshStore Q σ₁ + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff) := by + have := GenFreshStore.storeWith_gen (P := P) ndelimLoopPrefix HasBool.ff h_tgt_fresh + rw [hgen] at this; exact this + have h_guard_def : (({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff } : Env P).store) + (HasIdent.ident (P := P) g) = some (if false then HasBool.tt else HasBool.ff) := by + simp [storeWith] + exact finish false HasBool.ff (by simp) + (nondetElim_loop_nondet_sim_iteration extendEval g m body (Block.nondetElimM body σ₁).1 md σ₁ (Block.nondetElimM body σ₁).2 + h_body_sim h_g_gen h_g_in h_nofd_body oc ρ_src ρ' + ({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff } : Env P) + hstarT.len h_eval_eq h_fail_eq h_off_g hwfb hwfv hwf_def hwf_congr hwf_var + h_wf₁ h_src_fresh h_fresh_g false h_guard_def + (.inl ⟨rfl, hrest, Nat.le_of_lt hl⟩)) + · -- ENTER first: init $g := tt, entering = true. + have h_off_g : AgreeOffGen Q ρ_src.store + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.tt) := + AgreeOffGen.storeWith_gen h_agree h_g_gen + have h_fresh_g : GenFreshStore Q σ₁ + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.tt) := by + have := GenFreshStore.storeWith_gen (P := P) ndelimLoopPrefix HasBool.tt h_tgt_fresh + rw [hgen] at this; exact this + have h_guard_def : (({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.tt } : Env P).store) + (HasIdent.ident (P := P) g) = some (if true then HasBool.tt else HasBool.ff) := by + simp [storeWith] + exact finish true HasBool.tt (by simp) + (nondetElim_loop_nondet_sim_iteration extendEval g m body (Block.nondetElimM body σ₁).1 md σ₁ (Block.nondetElimM body σ₁).2 + h_body_sim h_g_gen h_g_in h_nofd_body oc ρ_src ρ' + ({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.tt } : Env P) + hstarT.len h_eval_eq h_fail_eq h_off_g hwfb hwfv hwf_def hwf_congr hwf_var + h_wf₁ h_src_fresh h_fresh_g true h_guard_def + (.inr ⟨rfl, hrest, Nat.le_of_lt hl⟩)) + | .exit lbl md, _, _, _, oc, h_term => + -- `.exit lbl` steps to `.exiting lbl ρ_src`: vacuous on `.terminal`, and on + -- the exiting outcome the label/env are forced and the rewritten `[.exit lbl]` + -- mirrors the step. + cases oc with + | none => + exfalso + simp only [outcomeConfig] at h_term + obtain ⟨c, hstep, hrest⟩ := stmt_step_first_inv (extendEval := extendEval) _ ρ_src ρ' h_term + cases hstep + -- `hrest : .exiting lbl ρ_src →* .terminal ρ'` is impossible. + cases hrest with + | step _ _ _ h _ => cases h + | some lbl' => + simp only [outcomeConfig] at h_term + obtain ⟨c, hstep, hrest⟩ := + stmt_step_first_inv_to (extendEval := extendEval) _ ρ_src (.exiting lbl' ρ') + (by intro ρ'' h; cases h) h_term + cases hstep + -- `.exiting lbl ρ_src →* .exiting lbl' ρ'` forces `lbl' = lbl` and `ρ' = ρ_src`. + have h_eq : lbl' = lbl ∧ ρ' = ρ_src := by + cases hrest with + | refl => exact ⟨rfl, rfl⟩ + | step _ _ _ h _ => cases h + obtain ⟨h_lbl_eq, h_ρ_eq⟩ := h_eq + subst h_lbl_eq; subst h_ρ_eq + refine ⟨h_src_fresh, ρ_tgt, ?_, h_agree, h_fail_eq, h_eval_eq, ?_⟩ + · simp only [Stmt.nondetElimM, outcomeConfig] + exact stmt_to_singleton_stmts_exiting (extendEval := extendEval) (.exit lbl' md) ρ_tgt ρ_tgt lbl' + (.step _ _ _ StepStmt.step_exit (.refl _)) + · simp only [Stmt.nondetElimM]; exact h_tgt_fresh + | .funcDecl d md, _, h_nofd, _, _, _ => + exact absurd h_nofd (by simp [Stmt.noFuncDecl]) + | .typeDecl t md, _, _, _, oc, h_term => + -- `.typeDecl` is a runtime no-op: it steps to `.terminal ρ_src`; exiting vacuous. + cases oc with + | none => + simp only [outcomeConfig] at h_term + obtain ⟨c, hstep, hrest⟩ := stmt_step_first_inv (extendEval := extendEval) _ ρ_src ρ' h_term + cases hstep + have h_eq : ρ_src = ρ' := by + cases hrest with + | refl => rfl + | step _ _ _ h _ => cases h + subst h_eq + refine ⟨h_src_fresh, ρ_tgt, ?_, h_agree, h_fail_eq, h_eval_eq, ?_⟩ + · simp only [Stmt.nondetElimM, outcomeConfig] + exact stmt_to_singleton_stmts (extendEval := extendEval) (.typeDecl t md) ρ_tgt ρ_tgt + (.step _ _ _ StepStmt.step_typeDecl (.refl _)) + · simp only [Stmt.nondetElimM]; exact h_tgt_fresh + | some lbl => + exfalso + simp only [outcomeConfig] at h_term + obtain ⟨c, hstep, hrest⟩ := + stmt_step_first_inv_to (extendEval := extendEval) _ ρ_src (.exiting lbl ρ') + (by intro ρ'' h; cases h) h_term + cases hstep + -- `.terminal ρ_src →* .exiting lbl ρ'` impossible. + cases hrest with + | step _ _ _ h _ => cases h + termination_by sizeOf s + +/-- General forward simulation over a statement list with separate source/target +start stores and threaded generator state. See spec §4. -/ +private theorem nondetElim_simulation_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] + {Q : String → Prop} + (hQmint : (∀ sg, Q (StringGenState.gen ndelimItePrefix sg).1) + ∧ (∀ sg, Q (StringGenState.gen ndelimLoopPrefix sg).1)) + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (ρ_src ρ' ρ_tgt : Env P) + (h_eval_eq : ρ_tgt.eval = ρ_src.eval) + (h_fail_eq : ρ_tgt.hasFailure = ρ_src.hasFailure) + (h_agree : AgreeOffGen Q ρ_src.store ρ_tgt.store) + (hwfb : WellFormedSemanticEvalBool ρ_src.eval) + (hwfv : WellFormedSemanticEvalVal ρ_src.eval) + (hwf_def : WellFormedSemanticEvalDef ρ_src.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ_src.eval) + (hwf_var : WellFormedSemanticEvalVar ρ_src.eval) + (h_wf_gen : StringGenState.WF σ) + (h_src_fresh : ∀ t, Q t → + ρ_src.store (HasIdent.ident (P := P) t) = none) + (h_tgt_fresh : GenFreshStore Q σ ρ_tgt.store) + (h_no_writes : SrcNoGenWrites (P := P) Q ss) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (oc : Option String) + (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ_src) (outcomeConfig oc ρ')) : + (∀ t, Q t → + ρ'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElimM ss σ).1 ρ_tgt) (outcomeConfig oc ρ_out) + ∧ AgreeOffGen Q ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure + ∧ ρ_out.eval = ρ'.eval + ∧ GenFreshStore Q (Block.nondetElimM ss σ).2 ρ_out.store := by + match ss, h_no_writes, h_nofd, oc, h_term with + | [], _, _, oc, h_term => + -- An empty list only reaches `.terminal`; the exiting outcome is vacuous. + match oc, h_term with + | none, h_term => + have h_eq : ρ_src = ρ' := stmts_nil_terminal_eq (extendEval := extendEval) ρ_src ρ' h_term + subst h_eq + refine ⟨h_src_fresh, ρ_tgt, ?_, h_agree, h_fail_eq, h_eval_eq, ?_⟩ + · simp only [Block.nondetElimM, outcomeConfig] + exact evalStmtsSmallNil P (EvalCmd P) extendEval ρ_tgt + · simp only [Block.nondetElimM]; exact h_tgt_fresh + | some lbl, h_term => + exfalso + -- `.stmts [] ρ_src` steps to `.terminal ρ_src`, never `.exiting`. + simp only [outcomeConfig] at h_term + cases h_term with + | step _ _ _ h h2 => + cases h with + | step_stmts_nil => + cases h2 with + | step _ _ _ h3 _ => cases h3 + | s :: rest, h_no_writes, h_nofd, oc, h_term => + -- Decompose the source run: either the head `s` exits (skipping `rest`), or + -- `s` terminates to `ρ_mid` then `rest` reaches the same outcome. + rcases stmts_cons_outcome (extendEval := extendEval) s rest ρ_src ρ' oc h_term with + ⟨lbl, h_oc_eq, h_s_exit⟩ | ⟨ρ_mid, h_s_run, h_rest_run⟩ + · -- Head exits: recurse on `s` with the exiting outcome, then `step_seq_exit` + -- past the (rewritten) `rest`. + subst h_oc_eq + -- Source-shape split for `s` (head of the cons). + have h_no_writes_s_e : NoGenSuffix (P := P) Q (Stmt.definedVars s ++ Stmt.modifiedVars s) := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (List.mem_append_left _ (List.mem_append_left _ hd)) t heq + · exact h_no_writes x (List.mem_append_right _ (List.mem_append_left _ hm)) t heq + have h_nofd_pair_e : Stmt.noFuncDecl s = true ∧ Block.noFuncDecl rest = true := by + have : (Stmt.noFuncDecl s && Block.noFuncDecl rest) = true := by + simpa only [Block.noFuncDecl] using h_nofd + exact Bool.and_eq_true _ _ |>.mp this + have h_lhni_pair_e : Stmt.loopHasNoInvariants s = true ∧ + Block.loopHasNoInvariants rest = true := + Block.loopHasNoInvariants_cons_iff.mp h_lhni + obtain ⟨h_fresh', ρ_out, h_s_tgt, h_off', h_fail', h_eval', h_fresh_s⟩ := + nondetElim_stmt_gen hQmint extendEval s σ ρ_src ρ' ρ_tgt + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf_gen h_src_fresh h_tgt_fresh h_no_writes_s_e h_nofd_pair_e.1 h_lhni_pair_e.1 + (some lbl) h_s_exit + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', ?_⟩ + · rw [Block.nondetElimM_cons_out] + -- The rewritten head exits; `step_seq_exit` past the rewritten tail. + refine stmts_cons_head_exiting_append (extendEval := extendEval) _ _ ρ_tgt ρ_out lbl ?_ + simpa only [outcomeConfig] using h_s_tgt + · -- GenFreshStore Q at `(Block.nondetElimM (s :: rest) σ).2 ⊇ (Stmt.nondetElimM s σ).2`. + have h_out_eq : (Block.nondetElimM (s :: rest) σ).2 + = (Block.nondetElimM rest (Stmt.nondetElimM s σ).2).2 := by + rw [Block.nondetElimM] + rcases hh : Stmt.nondetElimM s σ with ⟨ss_s, σ_s⟩ + rcases hk : Block.nondetElimM rest σ_s with ⟨ss_r, σ_r⟩ + simp only [hh, hk] + rw [h_out_eq] + exact GenFreshStore.mono (Block.nondetElimM_genStep rest (Stmt.nondetElimM s σ).2) h_fresh_s + · -- Head terminates: original sequencing argument, now threading the outcome. + have h_s_run' : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ_src) (.terminal ρ_mid) := + h_s_run + -- Source-shape splits. + have h_no_writes_s : NoGenSuffix (P := P) Q (Stmt.definedVars s ++ Stmt.modifiedVars s) := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (List.mem_append_left _ (List.mem_append_left _ hd)) t heq + · exact h_no_writes x (List.mem_append_right _ (List.mem_append_left _ hm)) t heq + have h_no_writes_rest : SrcNoGenWrites (P := P) Q rest := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (List.mem_append_left _ (List.mem_append_right _ hd)) t heq + · exact h_no_writes x (List.mem_append_right _ (List.mem_append_right _ hm)) t heq + have h_nofd_pair : Stmt.noFuncDecl s = true ∧ Block.noFuncDecl rest = true := by + have : (Stmt.noFuncDecl s && Block.noFuncDecl rest) = true := by + simpa only [Block.noFuncDecl] using h_nofd + exact Bool.and_eq_true _ _ |>.mp this + have h_nofd_s : Stmt.noFuncDecl s = true := h_nofd_pair.1 + have h_nofd_rest : Block.noFuncDecl rest = true := h_nofd_pair.2 + have h_lhni_pair : Stmt.loopHasNoInvariants s = true ∧ Block.loopHasNoInvariants rest = true := + Block.loopHasNoInvariants_cons_iff.mp h_lhni + have h_lhni_s : Stmt.loopHasNoInvariants s = true := h_lhni_pair.1 + have h_lhni_rest : Block.loopHasNoInvariants rest = true := h_lhni_pair.2 + -- Simulate `s` (to terminal). + obtain ⟨h_mid_fresh, ρ_mid_tgt, h_s_tgt, h_off_mid, h_fail_mid, h_eval_mid, h_fresh_mid⟩ := + nondetElim_stmt_gen hQmint extendEval s σ ρ_src ρ_mid ρ_tgt + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf_gen h_src_fresh h_tgt_fresh h_no_writes_s h_nofd_s h_lhni_s none h_s_run' + -- Advance the generator: σ₁ := (Stmt.nondetElimM s σ).2. + have h_step_s : StringGenState.GenStep σ (Stmt.nondetElimM s σ).2 := + Stmt.nondetElimM_genStep s σ + have h_wf₁ : StringGenState.WF (Stmt.nondetElimM s σ).2 := h_step_s.wf_mono h_wf_gen + -- Source eval is preserved across a single (funcDecl-free) statement. + have h_eval_mid_src : ρ_mid.eval = ρ_src.eval := + smallStep_noFuncDecl_preserves_eval P (EvalCmd P) extendEval s ρ_src ρ_mid h_nofd_s h_s_run' + have hwfb_mid : WellFormedSemanticEvalBool ρ_mid.eval := h_eval_mid_src ▸ hwfb + have hwfv_mid : WellFormedSemanticEvalVal ρ_mid.eval := h_eval_mid_src ▸ hwfv + have hwf_def_mid : WellFormedSemanticEvalDef ρ_mid.eval := h_eval_mid_src ▸ hwf_def + have hwf_congr_mid : WellFormedSemanticEvalExprCongr ρ_mid.eval := h_eval_mid_src ▸ hwf_congr + have hwf_var_mid : WellFormedSemanticEvalVar ρ_mid.eval := h_eval_mid_src ▸ hwf_var + -- IH on `rest` at the advanced state from ρ_mid (src) and ρ_mid_tgt (tgt). + have h_eval_eq' : ρ_mid_tgt.eval = ρ_mid.eval := h_eval_mid + have h_fail_eq' : ρ_mid_tgt.hasFailure = ρ_mid.hasFailure := h_fail_mid + obtain ⟨h_fresh', ρ_out, h_rest_tgt, h_off', h_fail', h_eval', h_fresh_out⟩ := + nondetElim_simulation_gen hQmint extendEval rest (Stmt.nondetElimM s σ).2 ρ_mid ρ' ρ_mid_tgt + h_eval_eq' h_fail_eq' h_off_mid hwfb_mid hwfv_mid hwf_def_mid hwf_congr_mid hwf_var_mid + h_wf₁ h_mid_fresh h_fresh_mid h_no_writes_rest h_nofd_rest h_lhni_rest oc h_rest_run + -- Assemble: output = (Stmt.nondetElimM s σ).1 ++ (Block.nondetElimM rest (…).2).1. + refine ⟨h_fresh', ρ_out, ?_, h_off', h_fail', h_eval', ?_⟩ + · rw [Block.nondetElimM_cons_out] + exact ReflTrans_Transitive _ _ _ _ + (stmts_prefix_terminal_append P (EvalCmd P) extendEval _ _ ρ_tgt ρ_mid_tgt h_s_tgt) + h_rest_tgt + · -- GenFreshStore at (Block.nondetElimM (s::rest) σ).2. + have h_out_eq : (Block.nondetElimM (s :: rest) σ).2 + = (Block.nondetElimM rest (Stmt.nondetElimM s σ).2).2 := by + rw [Block.nondetElimM] + rcases hh : Stmt.nondetElimM s σ with ⟨ss_s, σ_s⟩ + rcases hk : Block.nondetElimM rest σ_s with ⟨ss_r, σ_r⟩ + simp only [hh, hk] + rw [h_out_eq]; exact h_fresh_out + termination_by sizeOf ss +end + +/-- Forward simulation (per-constructor inductive lemma): every terminating +source execution of `ss` has a matching execution of `Block.nondetElim ss` +agreeing on the source's variables (`StoreAgreement`) and the failure flag. The +existential picks each guard's havoc value to match the source's +nondeterministic choice; `StoreAgreement`'s one-directionality hides the +generated guard variables. See spec §4. + +This is the substantive simulation lemma; `nondetElim_sound` is its top-level +corollary. It instantiates `nondetElim_simulation_gen` at `ρ_tgt = ρ_src` and +the empty generator state. -/ +private theorem nondetElim_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] + {Q : String → Prop} + (hQmint : (∀ sg, Q (StringGenState.gen ndelimItePrefix sg).1) + ∧ (∀ sg, Q (StringGenState.gen ndelimLoopPrefix sg).1)) + (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) + (h_no_gen_suffix : + ∀ s, Q s → + ρ₀.store (HasIdent.ident (P := P) s) = none) + (h_no_writes : SrcNoGenWrites (P := P) Q ss) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) : + ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElim ss) ρ₀) (.terminal ρ_out) + ∧ StoreAgreement ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure := by + have h_tgt_fresh : GenFreshStore Q StringGenState.emp ρ₀.store := by + intro s h_suf _; exact h_no_gen_suffix s h_suf + obtain ⟨h_fresh', ρ_out, h_run, h_off, h_fl, _, _⟩ := + nondetElim_simulation_gen hQmint extendEval ss StringGenState.emp ρ₀ ρ' ρ₀ + rfl rfl (AgreeOffGen.refl _) hwfb hwfv hwf_def hwf_congr hwf_var + StringGenState.wf_emp h_no_gen_suffix h_tgt_fresh h_no_writes h_nofd h_lhni + none h_term + exact ⟨ρ_out, h_run, StoreAgreement.of_agreeOffGen h_off h_fresh', h_fl⟩ + +/-- Escaping sibling of `nondetElim_simulation`: surfaces the banked exiting +disjunct of `nondetElim_simulation_gen`. Every *escaping* source run of `ss` +(reaching `.exiting lbl ρ'`) is matched by an escaping run of `Block.nondetElim ss` +to the *same* label, agreeing on the source's variables and the failure flag. +Identical to the terminal `nondetElim_simulation` except it instantiates the +outcome selector at `some lbl`. -/ +private theorem nondetElim_simulation_exit {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] + {Q : String → Prop} + (hQmint : (∀ sg, Q (StringGenState.gen ndelimItePrefix sg).1) + ∧ (∀ sg, Q (StringGenState.gen ndelimLoopPrefix sg).1)) + (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) + (h_no_gen_suffix : + ∀ s, Q s → + ρ₀.store (HasIdent.ident (P := P) s) = none) + (h_no_writes : SrcNoGenWrites (P := P) Q ss) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (lbl : String) + (h_exit : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.exiting lbl ρ')) : + ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElim ss) ρ₀) (.exiting lbl ρ_out) + ∧ StoreAgreement ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure := by + have h_tgt_fresh : GenFreshStore Q StringGenState.emp ρ₀.store := by + intro s h_suf _; exact h_no_gen_suffix s h_suf + obtain ⟨h_fresh', ρ_out, h_run, h_off, h_fl, _, _⟩ := + nondetElim_simulation_gen hQmint extendEval ss StringGenState.emp ρ₀ ρ' ρ₀ + rfl rfl (AgreeOffGen.refl _) hwfb hwfv hwf_def hwf_congr hwf_var + StringGenState.wf_emp h_no_gen_suffix h_tgt_fresh h_no_writes h_nofd h_lhni + (some lbl) (by simpa only [outcomeConfig] using h_exit) + refine ⟨ρ_out, ?_, StoreAgreement.of_agreeOffGen h_off h_fresh', h_fl⟩ + simpa only [outcomeConfig] using h_run + +/-- Forward simulation: every terminating source execution of `ss` has a +matching execution of `Block.nondetElim ss` agreeing on the source's variables +(`StoreAgreement`) and the failure flag. The existential picks each guard's +havoc value to match the source's nondeterministic choice; `StoreAgreement`'s +one-directionality hides the generated guard variables. + +The instance and well-formed-eval hypothesis list mirrors +`structuredToUnstructured_sound_kind` +(`Strata/Transform/StructuredToUnstructuredCorrect.lean`) exactly, so this +theorem composes with that proof downstream. See spec §4. -/ +theorem nondetElim_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) + (h_no_gen_suffix : + ∀ s, String.HasUnderscoreDigitSuffix s → + ρ₀.store (HasIdent.ident (P := P) s) = none) + (h_no_writes : SrcNoGenWrites (P := P) String.HasUnderscoreDigitSuffix ss) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) : + ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElim ss) ρ₀) (.terminal ρ_out) + ∧ StoreAgreement ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure := + nondetElim_simulation + (Q := String.HasUnderscoreDigitSuffix) + ⟨fun sg => StringGenState.gen_hasUnderscoreDigitSuffix ndelimItePrefix sg, + fun sg => StringGenState.gen_hasUnderscoreDigitSuffix ndelimLoopPrefix sg⟩ + extendEval ss ρ₀ ρ' + hwfb hwfv hwf_def hwf_congr hwf_var h_no_gen_suffix h_no_writes h_nofd h_lhni h_term + +/-! ### The nondetElim label *kind* + +`nondetElim` mints labels under exactly two prefixes: `ndelimItePrefix` and +`ndelimLoopPrefix`. `ndelimKind s` is the precise predicate "`s` is a label this +pass could have minted": it carries the matching generator prefix and is equal to +some `gen`-output. This is the per-kind `Q` to instantiate the kind-generalized +simulation at, replacing the blanket `HasUnderscoreDigitSuffix` (which would +overcommit a composition partner to keeping *every* gen-shaped name fresh). -/ + +/-- A label that `nondetElim` could have minted: it has the ite- or loop-prefix +and equals a corresponding `gen` output. -/ +@[expose] def ndelimKind (s : String) : Prop := + (∃ sg, String.HasGenPrefix ndelimItePrefix s + ∧ s = (StringGenState.gen ndelimItePrefix sg).1) + ∨ (∃ sg, String.HasGenPrefix ndelimLoopPrefix s + ∧ s = (StringGenState.gen ndelimLoopPrefix sg).1) + +/-- The two prefixes `nondetElim` mints under both land inside `ndelimKind`: +this is exactly the `hQmint` conjunction at `Q := ndelimKind`. -/ +theorem ndelimKind_gen : + (∀ sg, ndelimKind (StringGenState.gen ndelimItePrefix sg).1) + ∧ (∀ sg, ndelimKind (StringGenState.gen ndelimLoopPrefix sg).1) := by + refine ⟨fun sg => ?_, fun sg => ?_⟩ + · exact Or.inl ⟨sg, StringGenState.gen_hasGenPrefix ndelimItePrefix sg, rfl⟩ + · exact Or.inr ⟨sg, StringGenState.gen_hasGenPrefix ndelimLoopPrefix sg, rfl⟩ + +/-- Kind-generalized soundness: `nondetElim` is sound for any source store whose +only `ndelimKind`-labelled slots are undefined, and any source block that never +writes an `ndelimKind` label. Weaker entry precondition than `nondetElim_sound` +(it constrains only the labels this pass mints, not every gen-shaped name), +which is what lets a composition partner — e.g. one that mints under a disjoint +prefix — satisfy it vacuously. -/ +theorem nondetElim_sound_kind {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) + (h_no_gen_suffix : NoGenStore (P := P) ndelimKind ρ₀) + (h_no_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) : + ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElim ss) ρ₀) (.terminal ρ_out) + ∧ StoreAgreement ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure := + nondetElim_simulation + (Q := ndelimKind) ndelimKind_gen + extendEval ss ρ₀ ρ' + hwfb hwfv hwf_def hwf_congr hwf_var h_no_gen_suffix h_no_writes h_nofd h_lhni h_term + +/-- Escaping companion of `nondetElim_sound_kind` (at `Q := ndelimKind`): every +escaping source run of `ss` reaching `.exiting lbl` is matched by an escaping run +of `Block.nondetElim ss` to the *same* label, agreeing on the source's variables +and the failure flag. A thin forwarder to `nondetElim_simulation_exit`; the +`NoGenStore` store precondition unfolds to the explicit per-kind freshness fact +the simulation consumes. -/ +theorem nondetElim_sound_kind_exit {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) + (h_no_gen_suffix : NoGenStore (P := P) ndelimKind ρ₀) + (h_no_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (lbl : String) + (h_exit : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.exiting lbl ρ')) : + ∃ ρ_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElim ss) ρ₀) (.exiting lbl ρ_out) + ∧ StoreAgreement ρ'.store ρ_out.store + ∧ ρ_out.hasFailure = ρ'.hasFailure := + nondetElim_simulation_exit + (Q := ndelimKind) ndelimKind_gen + extendEval ss ρ₀ ρ' + hwfb hwfv hwf_def hwf_congr hwf_var h_no_gen_suffix h_no_writes h_nofd h_lhni lbl h_exit + +/-! ## Failing-config forward simulation (`nondetElim_to_fail`) + +`nondetElim_simulation` and its kind/exit wrappers are *endpoint*-keyed: each +consumes a source run reaching a terminal/exiting outcome. A reachable *failing* +configuration need not lie on such a run (an `assert` only OR-s the cumulative +`hasFailure` flag and continues, so a failing run may diverge or get stuck). The +`_to_fail` siblings below remove the endpoint demand: a reachable failing source +configuration is matched by a reachable failing configuration of +`Block.nondetElim ss`, running both from the same start. + +The construction mirrors the terminal simulation but keys on the *failing +configuration* as the halting condition. Each statement / loop iteration that +*completed before the failure* terminated, so the existing terminal simulation +applies to it verbatim and advances the store relation; only the single statement +/ iteration that *contains* the failure is transported by a bare failing-config +reach (no terminal demand). The loop arms induct on a `Nat` fuel bounding the +*source* run length — finite because failure is monotone — never on the loop's +termination. -/ + +/-- Deterministic-loop failing-config iteration: from a source loop +`.loop (.det e) m [] body md` reaching a failing config `a'`, build a failing run +of the rewritten target loop `.loop (.det e) m [] body' md`. + +Inducts on a `Nat` fuel bounding the source run length (finite by failure +monotonicity), NOT on the loop terminating. Each COMPLETED iteration (case B) +terminated at the body-block boundary — the loop re-entered it — so the terminal +body simulation `h_body_sim` applies and advances `AgreeOffGen`/`GenFreshStore` to +seed the next iteration at strictly smaller fuel. The FAILING iteration (case A) +is a partial body run to the failing command, discharged by the body-level +failing provider `h_body_sim_fail` with NO terminal demand. The guard-false +(`step_loop_exit`) base case reaches a terminal whose failure flag equals +`ρ_pre'.hasFailure`; if failing, the loop head is already a failing target config, +so the loop terminating is never used. -/ +private theorem nondetElim_loop_det_to_fail_iteration {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] + {Q : String → Prop} + (extendEval : ExtendEval P) + (e : P.Expr) (m : Option P.Expr) + (body body' : List (Stmt P (Cmd P))) (md : MetaData P) + (σ σ_out : StringGenState) + -- Terminal per-iteration body simulation (the existing simulation shape, + -- specialized to `body`/`body'`/`σ`), used for COMPLETED iterations. Its + -- trailing freshness conjunct is at the (unused) advanced state `σ_out`. + (h_body_sim : ∀ (oc_b : Option String) (ρb_src ρb' ρb_tgt : Env P), + ρb_tgt.eval = ρb_src.eval → + ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → + WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → + WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → + StringGenState.WF σ → + (∀ t, Q t → + ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) (outcomeConfig oc_b ρb') → + (∀ t, Q t → + ρb'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρb_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ρb_tgt) (outcomeConfig oc_b ρb_out) + ∧ AgreeOffGen Q ρb'.store ρb_out.store + ∧ ρb_out.hasFailure = ρb'.hasFailure + ∧ ρb_out.eval = ρb'.eval + ∧ GenFreshStore Q σ_out ρb_out.store) + -- Failing per-iteration body simulation, used for the FAILING iteration. + (h_body_sim_fail : ∀ (ρb_src ρb_tgt : Env P) (d : Config P (Cmd P)), + ρb_tgt.eval = ρb_src.eval → + ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → + WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → + WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → + StringGenState.WF σ → + (∀ t, Q t → + ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts body' ρb_tgt) d' + ∧ d'.getEnv.hasFailure = true) + (h_nofd_body : Block.noFuncDecl body = true) + (ρ_src ρ_tgt : Env P) (a' : Config P (Cmd P)) (n : Nat) + (h_eval_eq : ρ_tgt.eval = ρ_src.eval) + (h_fail_eq : ρ_tgt.hasFailure = ρ_src.hasFailure) + (h_agree : AgreeOffGen Q ρ_src.store ρ_tgt.store) + (hwfb : WellFormedSemanticEvalBool ρ_src.eval) + (hwfv : WellFormedSemanticEvalVal ρ_src.eval) + (hwf_def : WellFormedSemanticEvalDef ρ_src.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ_src.eval) + (hwf_var : WellFormedSemanticEvalVar ρ_src.eval) + (h_wf_gen : StringGenState.WF σ) + (h_src_fresh : ∀ t, Q t → + ρ_src.store (HasIdent.ident (P := P) t) = none) + (h_tgt_fresh : GenFreshStore Q σ ρ_tgt.store) + (hT : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (.loop (.det e) m ([] : List (String × P.Expr)) body md) ρ_src) a') + (h_a'_fail : a'.getEnv.hasFailure = true) + (hlen : hT.len ≤ n) : + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det e) m ([] : List (String × P.Expr)) body' md) ρ_tgt) d + ∧ d.getEnv.hasFailure = true := by + induction n generalizing ρ_src ρ_tgt a' with + | zero => + match hT, hlen with + | .refl _, _ => + have : ρ_src.hasFailure = true := by simpa [Config.getEnv] using h_a'_fail + exact ⟨.stmt (.loop (.det e) m ([] : List (String × P.Expr)) body' md) ρ_tgt, .refl _, + by simpa [Config.getEnv] using (h_fail_eq.trans this)⟩ + | .step _ _ _ _ _, hl => simp [ReflTransT.len] at hl + | succ n ih => + match hT, hlen with + | .refl _, _ => + have : ρ_src.hasFailure = true := by simpa [Config.getEnv] using h_a'_fail + exact ⟨.stmt (.loop (.det e) m ([] : List (String × P.Expr)) body' md) ρ_tgt, .refl _, + by simpa [Config.getEnv] using (h_fail_eq.trans this)⟩ + | .step _ _ _ (@StepStmt.step_loop_exit _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure hg_false hinv_eval hff_iff hwfb_step) hrest, hl_succ => + -- EXIT: the loop terminates at `ρ_src + false`; the failing config must be + -- that terminal env, forcing `ρ_src.hasFailure = true` ⟹ the target loop + -- head is already failing. + have h_hif : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_hif + have ha''_eq : a' = .terminal ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) := + reflTransT_from_terminal P (EvalCmd P) extendEval hrest + rw [ha''_eq] at h_a'_fail + have : ρ_src.hasFailure = true := by simpa [Config.getEnv, Bool.or_false] using h_a'_fail + exact ⟨.stmt (.loop (.det e) m ([] : List (String × P.Expr)) body' md) ρ_tgt, .refl _, + by simpa [Config.getEnv] using (h_fail_eq.trans this)⟩ + | .step _ _ _ (@StepStmt.step_loop_enter _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure hg_true hinv_eval hff_iff hwfb_step) hrest, hl_succ => + have h_hif : hasInvFailure = false := empty_inv_no_failure hff_iff + subst h_hif + have h_body_init_eq : + ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) = ρ_src := by + simp [Bool.or_false] + -- Target reads guard tt (AgreeOffGen on the guard's source-defined vars). + have h_def_e : isDefined ρ_src.store (HasVarsPure.getVars e) := + hwf_def e HasBool.tt ρ_src.store hg_true + have h_pw : ∀ x ∈ HasVarsPure.getVars e, ρ_src.store x = ρ_tgt.store x := + agreeOffGen_pointwise_on_expr_vars ρ_src.store ρ_tgt.store e h_agree h_src_fresh h_def_e + have h_cond_t : ρ_tgt.eval ρ_tgt.store e = some HasBool.tt := by + rw [h_eval_eq, ← hg_true]; exact (hwf_congr e ρ_src.store ρ_tgt.store h_pw).symm + -- The target enters its loop: one step to the body-block context. + have h_step_enter : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det e) m ([] : List (String × P.Expr)) body' md) ρ_tgt) + (.seq (.block .none ρ_tgt.store (.stmts body' + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + [.loop (.det e) m ([] : List (String × P.Expr)) body' md]) := + .step _ _ _ (StepStmt.step_loop_enter (hasInvFailure := false) + h_cond_t (by simp) (by simp) (h_eval_eq ▸ hwfb)) (.refl _) + rcases seqT_reaches_failing' P (EvalCmd P) extendEval hrest h_a'_fail with hA | hB + · -- CASE A: the failure is inside THIS iteration's body block. + obtain ⟨d_blk, h_blk_run, hd_blk_fail, _⟩ := hA + have ⟨d_body, h_body_run, hd_body_fail, _⟩ := + blockT_none_reaches_failing' P (EvalCmd P) extendEval h_blk_run hd_blk_fail + rw [h_body_init_eq] at h_body_run + have ⟨d', h_body_tgt, hd'_fail⟩ := + h_body_sim_fail ρ_src ρ_tgt d_body h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def + hwf_congr hwf_var h_wf_gen h_src_fresh h_tgt_fresh + (reflTransT_to_prop h_body_run) hd_body_fail + -- Lift the failing body' run into the body-block, reaching a failing config. + -- The body-block context starts at `ρ_tgt + false = ρ_tgt`; the lifted + -- block config `.block .none _ d'` keeps `d'`'s failure flag, as does the + -- enclosing `.seq _ [loop']` frame (both read `getEnv` from the inner). + have h_body_tgt' : StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) d' := by + have he : ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) = ρ_tgt := by + simp [Bool.or_false] + rw [he]; exact h_body_tgt + have h_blk_tgt : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts body' + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.block .none ρ_tgt.store d') := + block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_body_tgt' + refine ⟨.seq (.block .none ρ_tgt.store d') + [.loop (.det e) m ([] : List (String × P.Expr)) body' md], + ReflTrans_Transitive _ _ _ _ h_step_enter + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_blk_tgt), ?_⟩ + simpa [Config.getEnv] using hd'_fail + · -- CASE B: this iteration's body terminated; recurse on the next iteration. + obtain ⟨ρ_blk_inner, d_rest, h_blk_term, h_loop_rest, hd_rest_fail, hlen_rest⟩ := hB + have ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_none_reaches_terminal (extendEval := extendEval) h_blk_term + subst heq_ρ_block + rw [h_body_init_eq] at h_inner_term + have h_body_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_src) (outcomeConfig none ρ_inner) := reflTransT_to_prop h_inner_term + obtain ⟨h_inner_fresh, ρ_inner_tgt, h_body_tgt, h_off_inner, h_fail_inner, + h_eval_inner, h_fresh_inner⟩ := + h_body_sim none ρ_src ρ_inner ρ_tgt h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def + hwf_congr hwf_var h_wf_gen h_src_fresh h_tgt_fresh h_body_run + -- The target body-block terminates at the projected env. + have h_blk_tgt_term : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts body' + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.terminal ({ ρ_inner_tgt with store := projectStore ρ_tgt.store ρ_inner_tgt.store } : Env P)) := by + have h_body_tgt' : StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ρ_inner_tgt) := by + have he : ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) = ρ_tgt := by + simp [Bool.or_false] + rw [he]; simpa only [outcomeConfig] using h_body_tgt + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_body_tgt') ?_ + exact .step _ _ _ StepStmt.step_block_done (.refl _) + -- The target reaches `.stmts [loop'] (projected target env)` after this iteration. + have h_step_after_iter : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det e) m ([] : List (String × P.Expr)) body' md) ρ_tgt) + (.stmts [.loop (.det e) m ([] : List (String × P.Expr)) body' md] + ({ ρ_inner_tgt with store := projectStore ρ_tgt.store ρ_inner_tgt.store } : Env P)) := + ReflTrans_Transitive _ _ _ _ h_step_enter + (ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_blk_tgt_term) + (.step _ _ _ StepStmt.step_seq_done (.refl _))) + -- Source next-iteration env (projected through ρ_src) = `ρ_blk_inner`, already + -- substituted; the target counterpart projects through `ρ_tgt`. + let ρ_src_next : Env P := { ρ_inner with store := projectStore ρ_src.store ρ_inner.store } + let ρ_tgt_next : Env P := { ρ_inner_tgt with store := projectStore ρ_tgt.store ρ_inner_tgt.store } + -- WF-eval facts at ρ_src_next (eval = ρ_inner.eval = ρ_src.eval). + have h_eval_inner_src : ρ_inner.eval = ρ_src.eval := + block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ_src ρ_inner h_nofd_body + (by simpa only [outcomeConfig] using h_body_run) + have h_eval_next : ρ_src_next.eval = ρ_src.eval := h_eval_inner_src + have hwfb_next : WellFormedSemanticEvalBool ρ_src_next.eval := by rw [h_eval_next]; exact hwfb + have hwfv_next : WellFormedSemanticEvalVal ρ_src_next.eval := by rw [h_eval_next]; exact hwfv + have hwf_def_next : WellFormedSemanticEvalDef ρ_src_next.eval := by rw [h_eval_next]; exact hwf_def + have hwf_congr_next : WellFormedSemanticEvalExprCongr ρ_src_next.eval := by rw [h_eval_next]; exact hwf_congr + have hwf_var_next : WellFormedSemanticEvalVar ρ_src_next.eval := by rw [h_eval_next]; exact hwf_var + have h_eval_eq_next : ρ_tgt_next.eval = ρ_src_next.eval := by + show ρ_inner_tgt.eval = ρ_inner.eval; exact h_eval_inner + have h_fail_eq_next : ρ_tgt_next.hasFailure = ρ_src_next.hasFailure := by + show ρ_inner_tgt.hasFailure = ρ_inner.hasFailure; exact h_fail_inner + have h_agree_next : AgreeOffGen Q ρ_src_next.store ρ_tgt_next.store := by + intro x h_nongen + show projectStore ρ_tgt.store ρ_inner_tgt.store x + = projectStore ρ_src.store ρ_inner.store x + show (if (ρ_tgt.store x).isSome then ρ_inner_tgt.store x else none) + = (if (ρ_src.store x).isSome then ρ_inner.store x else none) + rw [h_agree x h_nongen, h_off_inner x h_nongen] + have h_src_fresh_next : ∀ t, Q t → + ρ_src_next.store (HasIdent.ident (P := P) t) = none := by + intro t h_suf + show projectStore ρ_src.store ρ_inner.store (HasIdent.ident (P := P) t) = none + show (if (ρ_src.store (HasIdent.ident (P := P) t)).isSome + then ρ_inner.store (HasIdent.ident (P := P) t) else none) = none + by_cases hp : (ρ_src.store (HasIdent.ident (P := P) t)).isSome + · rw [if_pos hp]; exact h_inner_fresh t h_suf + · rw [if_neg hp] + have h_tgt_fresh_next : GenFreshStore Q σ ρ_tgt_next.store := by + intro s h_suf h_notin + show projectStore ρ_tgt.store ρ_inner_tgt.store (HasIdent.ident (P := P) s) = none + show (if (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + then ρ_inner_tgt.store (HasIdent.ident (P := P) s) else none) = none + rw [h_tgt_fresh s h_suf h_notin]; rfl + -- Decompose the residual loop-tail run (`[loop]` singleton) for the IH. + have ⟨d_loop, h_loop_stmt, hd_loop_fail, hlen_loop⟩ := + stmts_singleton_reaches_failing' P (EvalCmd P) extendEval h_loop_rest hd_rest_fail + have h_inner_le_n : h_loop_stmt.len ≤ n := by + simp only [ReflTransT.len] at hl_succ; omega + obtain ⟨d, h_run_recurse, hd_fail⟩ := + ih ρ_src_next ρ_tgt_next d_loop h_eval_eq_next h_fail_eq_next h_agree_next + hwfb_next hwfv_next hwf_def_next hwf_congr_next hwf_var_next + h_src_fresh_next h_tgt_fresh_next h_loop_stmt hd_loop_fail h_inner_le_n + -- Lift the recursive `.stmt loop'` failing run into `.stmts [loop']`: the + -- residual `d` need not be terminal, so wrap it as `.seq d []` whose + -- `getEnv` (hence failure flag) is `d`'s. + have h_run_recurse_stmts : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.loop (.det e) m ([] : List (String × P.Expr)) body' md] ρ_tgt_next) + (.seq d ([] : List (Stmt P (Cmd P)))) := + .step _ _ _ StepStmt.step_stmts_cons + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_run_recurse) + refine ⟨.seq d ([] : List (Stmt P (Cmd P))), + ReflTrans_Transitive _ _ _ _ h_step_after_iter h_run_recurse_stmts, ?_⟩ + simpa [Config.getEnv] using hd_fail + +/-- Nondeterministic-loop failing-config iteration: from a source loop +`.loop .nondet m [] body md` reaching a failing config (via the first-decision +disjunction `h_src_first`), build a failing run of the rewritten target +deterministic loop `.loop (.det $g) m [] (body' ++ [havoc $g]) md`, where `$g` is +the generated guard, `init`'d to match the first decision and re-havoced at each +body tail to match the next decision. + +Inducts on the `Nat` fuel bounding the source run length. The EXIT first step +forces the source loop to terminate at `ρ_src + false`; the failing config is +that terminal env, so `ρ_src.hasFailure = true` and the target loop head is +already a failing config (the guard-false exit step is never needed). The ENTER +first step runs one body iteration: if the body itself fails (case A), the +body-level failing provider supplies a failing `body'` run lifted into the loop +body-block (the trailing havoc is never reached); otherwise (case B) the terminal +body provider advances the iteration and the loop tail's first step +(`loop_nondet_step_first_inv_fail`) selects the re-havoc value for the recursive +call at strictly smaller fuel. -/ +private theorem nondetElim_loop_nondet_to_fail_iteration {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] + {Q : String → Prop} + (extendEval : ExtendEval P) + (g : String) (m : Option P.Expr) + (body body' : List (Stmt P (Cmd P))) (md : MetaData P) + (σ σ_out : StringGenState) + (h_body_sim : ∀ (oc_b : Option String) (ρb_src ρb' ρb_tgt : Env P), + ρb_tgt.eval = ρb_src.eval → + ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → + WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → + WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → + StringGenState.WF σ → + (∀ t, Q t → + ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) (outcomeConfig oc_b ρb') → + (∀ t, Q t → + ρb'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρb_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ρb_tgt) (outcomeConfig oc_b ρb_out) + ∧ AgreeOffGen Q ρb'.store ρb_out.store + ∧ ρb_out.hasFailure = ρb'.hasFailure + ∧ ρb_out.eval = ρb'.eval + ∧ GenFreshStore Q σ_out ρb_out.store) + (h_body_sim_fail : ∀ (ρb_src ρb_tgt : Env P) (d : Config P (Cmd P)), + ρb_tgt.eval = ρb_src.eval → + ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → + WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → + WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → + StringGenState.WF σ → + (∀ t, Q t → + ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) d → + d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts body' ρb_tgt) d' + ∧ d'.getEnv.hasFailure = true) + (h_g_gen : Q g) + (h_nofd_body : Block.noFuncDecl body = true) + (ρ_src ρ_tgt : Env P) (a' : Config P (Cmd P)) (n : Nat) + (h_eval_eq : ρ_tgt.eval = ρ_src.eval) + (h_fail_eq : ρ_tgt.hasFailure = ρ_src.hasFailure) + (h_agree : AgreeOffGen Q ρ_src.store ρ_tgt.store) + (hwfb : WellFormedSemanticEvalBool ρ_src.eval) + (hwfv : WellFormedSemanticEvalVal ρ_src.eval) + (hwf_def : WellFormedSemanticEvalDef ρ_src.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ_src.eval) + (hwf_var : WellFormedSemanticEvalVar ρ_src.eval) + (h_wf_gen : StringGenState.WF σ) + (h_src_fresh : ∀ t, Q t → + ρ_src.store (HasIdent.ident (P := P) t) = none) + (h_tgt_fresh : GenFreshStore Q σ ρ_tgt.store) + (entering : Bool) + (h_guard_def : ρ_tgt.store (HasIdent.ident (P := P) g) + = some (if entering then HasBool.tt else HasBool.ff)) + (h_a'_fail : a'.getEnv.hasFailure = true) + (h_src_first : + (entering = false ∧ ∃ (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.terminal ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P)) a'), + hrest.len ≤ n) ∨ + (entering = true ∧ ∃ (hrest : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ_src.store (.stmts body + ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P))) + [.loop .nondet m ([] : List (String × P.Expr)) body md]) a'), + hrest.len ≤ n)) : + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m + ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md) ρ_tgt) d + ∧ d.getEnv.hasFailure = true := by + induction n generalizing ρ_src ρ_tgt a' entering with + | zero => + rcases h_src_first with ⟨h_ent, hrest, hl⟩ | ⟨h_ent, hrest, hl⟩ + · -- EXIT: terminal residual; failing forces `ρ_src.hasFailure = true`. + have ha'_eq : a' = .terminal ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) := + reflTransT_from_terminal P (EvalCmd P) extendEval hrest + rw [ha'_eq] at h_a'_fail + have : ρ_src.hasFailure = true := by simpa [Config.getEnv, Bool.or_false] using h_a'_fail + exact ⟨.stmt (.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m + ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md) ρ_tgt, .refl _, + by simpa [Config.getEnv] using (h_fail_eq.trans this)⟩ + · -- ENTER with fuel 0: the residual is refl, so `a'` is the body-block entry + -- whose env is `ρ_src + false`; failing forces `ρ_src.hasFailure = true`. + subst h_ent + have ha'_eq : a' = .seq (.block .none ρ_src.store (.stmts body + ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P))) + [.loop .nondet m ([] : List (String × P.Expr)) body md] := by + match hrest, hl with + | .refl _, _ => rfl + | .step _ _ _ _ _, hl => simp only [ReflTransT.len] at hl; omega + rw [ha'_eq] at h_a'_fail + have : ρ_src.hasFailure = true := by + simpa [Config.getEnv, Bool.or_false] using h_a'_fail + exact ⟨.stmt (.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m + ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md) ρ_tgt, .refl _, + by simpa [Config.getEnv] using (h_fail_eq.trans this)⟩ + | succ n ih => + rcases h_src_first with ⟨h_ent, hrest, hl⟩ | ⟨h_ent, hrest, hl⟩ + · -- EXIT: as in the `zero` case. + have ha'_eq : a' = .terminal ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) := + reflTransT_from_terminal P (EvalCmd P) extendEval hrest + rw [ha'_eq] at h_a'_fail + have : ρ_src.hasFailure = true := by simpa [Config.getEnv, Bool.or_false] using h_a'_fail + exact ⟨.stmt (.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m + ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md) ρ_tgt, .refl _, + by simpa [Config.getEnv] using (h_fail_eq.trans this)⟩ + · -- ENTER: one body iteration, then recurse or finish. + subst h_ent + simp only [if_true] at h_guard_def + have h_guard_tt : ρ_tgt.eval ρ_tgt.store (HasFvar.mkFvar (HasIdent.ident (P := P) g)) + = some HasBool.tt := by + have h := hwf_var (HasFvar.mkFvar (P := P) (HasIdent.ident (P := P) g)) + (HasIdent.ident (P := P) g) ρ_tgt.store + (LawfulHasFvar.getFvar_mkFvar (HasIdent.ident (P := P) g)) + rw [h_eval_eq, h, h_guard_def] + have hρ_src'_eq : ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P) = ρ_src := by + simp [Bool.or_false] + -- The target enters: one step to the body-block context. + have h_step_enter : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m + ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md) ρ_tgt) + (.seq (.block .none ρ_tgt.store (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + [.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md]) := + .step _ _ _ (StepStmt.step_loop_enter (hasInvFailure := false) + h_guard_tt (by simp) (by simp) (h_eval_eq ▸ hwfb)) (.refl _) + have h_g_some_tgt : (ρ_tgt.store (HasIdent.ident (P := P) g)).isSome = true := by + rw [h_guard_def]; rfl + rcases seqT_reaches_failing' P (EvalCmd P) extendEval hrest h_a'_fail with hA | hB + · -- CASE A: failure inside THIS iteration's body block (before the havoc). + obtain ⟨d_blk, h_blk_run, hd_blk_fail, _⟩ := hA + have ⟨d_body, h_body_run, hd_body_fail, _⟩ := + blockT_none_reaches_failing' P (EvalCmd P) extendEval h_blk_run hd_blk_fail + rw [hρ_src'_eq] at h_body_run + have ⟨d', h_body_tgt, hd'_fail⟩ := + h_body_sim_fail ρ_src ρ_tgt d_body h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def + hwf_congr hwf_var h_wf_gen h_src_fresh h_tgt_fresh + (reflTransT_to_prop h_body_run) hd_body_fail + -- `body'` reaches a failing config ⟹ `body' ++ [havoc]` reaches one. + obtain ⟨d'', h_body_tail_fail, hd''_fail⟩ := + stmts_prefix_failing_append P (EvalCmd P) extendEval + body' [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)] ρ_tgt d' h_body_tgt hd'_fail + have h_body_tail_fail' : StepStmtStar P (EvalCmd P) extendEval + (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) d'' := by + have he : ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) = ρ_tgt := by + simp [Bool.or_false] + rw [he]; exact h_body_tail_fail + have h_blk_tgt : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.block .none ρ_tgt.store d'') := + block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_body_tail_fail' + refine ⟨.seq (.block .none ρ_tgt.store d'') + [.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md], + ReflTrans_Transitive _ _ _ _ h_step_enter + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_blk_tgt), ?_⟩ + simpa [Config.getEnv] using hd''_fail + · -- CASE B: this iteration's body terminated; recurse on the next iteration. + obtain ⟨ρ_blk_inner, d_rest, h_blk_term, h_loop_rest, hd_rest_fail, hlen_rest⟩ := hB + have ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_none_reaches_terminal (extendEval := extendEval) h_blk_term + subst heq_ρ_block + rw [hρ_src'_eq] at h_inner_term + have h_body_run : StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_src) (outcomeConfig none ρ_inner) := reflTransT_to_prop h_inner_term + obtain ⟨h_inner_fresh, ρ_inner_tgt, h_body_tgt, h_off_inner, h_fail_inner, + h_eval_inner, h_fresh_inner⟩ := + h_body_sim none ρ_src ρ_inner ρ_tgt h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def + hwf_congr hwf_var h_wf_gen h_src_fresh h_tgt_fresh h_body_run + have h_eval_inner_src : ρ_inner.eval = ρ_src.eval := + block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ_src ρ_inner h_nofd_body + (by simpa only [outcomeConfig] using h_body_run) + -- The target body' terminates at ρ_inner_tgt; lift to the block context. + have h_body_tgt_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts body' ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ρ_inner_tgt) := by + have he : ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) = ρ_tgt := by + simp [Bool.or_false] + rw [he]; simpa only [outcomeConfig] using h_body_tgt + -- $g stays defined through body' (parent-defined slot survives the block). + have h_g_some_inner : (ρ_inner_tgt.store (HasIdent.ident (P := P) g)).isSome = true := + stmts_preserves_isSome (extendEval := extendEval) h_body_tgt_term + (by simpa using h_g_some_tgt) + obtain ⟨v', hv'⟩ := Option.isSome_iff_exists.mp h_g_some_inner + have hwf_var_inner : WellFormedSemanticEvalVar ρ_inner_tgt.eval := by + rw [h_eval_inner, h_eval_inner_src]; exact hwf_var + -- Projected source next-iteration env (already substituted via `heq_ρ_block`). + let ρ_src_next : Env P := { ρ_inner with store := projectStore ρ_src.store ρ_inner.store } + -- Peel the residual loop-tail (`[loop]` singleton) to a `.stmt loop` run. + have ⟨d_loop, h_loop_stmt, hd_loop_fail, hlen_loop⟩ := + stmts_singleton_reaches_failing' P (EvalCmd P) extendEval h_loop_rest hd_rest_fail + -- Re-havoc $g and assemble per chosen next-decision bool. A unified + -- continuation: given the chosen re-havoc bool `next_ent` and the next + -- `h_src_first`, build the per-iteration block run (body' then havoc to + -- `next_ent`), the projected target env, the next-iteration agreements, then + -- recurse via `ih`. + have step_assemble : ∀ (next_ent : Bool), + (entering_next_src_first : (next_ent = false ∧ ∃ (hr : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.terminal ({ ρ_src_next with hasFailure := ρ_src_next.hasFailure || false } : Env P)) d_loop), + hr.len ≤ n) ∨ + (next_ent = true ∧ ∃ (hr : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ_src_next.store (.stmts body + ({ ρ_src_next with hasFailure := ρ_src_next.hasFailure || false } : Env P))) + [.loop .nondet m ([] : List (String × P.Expr)) body md]) d_loop), + hr.len ≤ n)) → + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmt (.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m + ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md) ρ_tgt) d + ∧ d.getEnv.hasFailure = true := by + intro next_ent hsfirst_next + let bval : P.Expr := if next_ent then HasBool.tt else HasBool.ff + -- The body tail havoc sets $g := bval, terminating at the re-havoced env. + have h_tail : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)) ρ_inner_tgt) + (.terminal ({ ρ_inner_tgt with store := storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) bval } : Env P)) := + step_havoc_set_to (extendEval := extendEval) (HasIdent.ident (P := P) g) bval md ρ_inner_tgt v' hv' + hwf_var_inner + have h_body_tail : StepStmtStar P (EvalCmd P) extendEval + (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P)) + (.terminal ({ ρ_inner_tgt with store := storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) bval } : Env P)) := + ReflTrans_Transitive _ _ _ _ + (stmts_prefix_terminal_append P (EvalCmd P) extendEval _ _ _ ρ_inner_tgt h_body_tgt_term) + (stmt_to_singleton_stmts (extendEval := extendEval) _ ρ_inner_tgt _ h_tail) + let ρ_tgt_next : Env P := { ρ_inner_tgt with store := projectStore ρ_tgt.store (storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) bval) } + have h_guard_next : ρ_tgt_next.store (HasIdent.ident (P := P) g) + = some (if next_ent then HasBool.tt else HasBool.ff) := by + show (if (ρ_tgt.store (HasIdent.ident (P := P) g)).isSome + then storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) bval + (HasIdent.ident (P := P) g) else none) = some (if next_ent then HasBool.tt else HasBool.ff) + rw [if_pos h_g_some_tgt]; simp [storeWith, bval] + -- WF facts / agreements at the projected next envs. + have h_eval_next : ρ_src_next.eval = ρ_src.eval := h_eval_inner_src + have hwfb_next : WellFormedSemanticEvalBool ρ_src_next.eval := by rw [h_eval_next]; exact hwfb + have hwfv_next : WellFormedSemanticEvalVal ρ_src_next.eval := by rw [h_eval_next]; exact hwfv + have hwf_def_next : WellFormedSemanticEvalDef ρ_src_next.eval := by rw [h_eval_next]; exact hwf_def + have hwf_congr_next : WellFormedSemanticEvalExprCongr ρ_src_next.eval := by rw [h_eval_next]; exact hwf_congr + have hwf_var_next : WellFormedSemanticEvalVar ρ_src_next.eval := by rw [h_eval_next]; exact hwf_var + have h_eval_eq_next : ρ_tgt_next.eval = ρ_src_next.eval := by + show ρ_inner_tgt.eval = ρ_inner.eval; exact h_eval_inner + have h_fail_eq_next : ρ_tgt_next.hasFailure = ρ_src_next.hasFailure := by + show ρ_inner_tgt.hasFailure = ρ_inner.hasFailure; exact h_fail_inner + have h_agree_next : AgreeOffGen Q ρ_src_next.store ρ_tgt_next.store := by + intro x h_nongen + have h_x_ne : x ≠ HasIdent.ident (P := P) g := by + rintro rfl; exact (h_nongen g rfl) h_g_gen + show projectStore ρ_tgt.store + (storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) bval) x + = projectStore ρ_src.store ρ_inner.store x + show (if (ρ_tgt.store x).isSome then + (if x = HasIdent.ident (P := P) g then some bval else ρ_inner_tgt.store x) + else none) + = (if (ρ_src.store x).isSome then ρ_inner.store x else none) + rw [if_neg h_x_ne, h_agree x h_nongen, h_off_inner x h_nongen] + have h_src_fresh_next : ∀ t, Q t → + ρ_src_next.store (HasIdent.ident (P := P) t) = none := by + intro t h_suf + show (if (ρ_src.store (HasIdent.ident (P := P) t)).isSome + then ρ_inner.store (HasIdent.ident (P := P) t) else none) = none + by_cases hp : (ρ_src.store (HasIdent.ident (P := P) t)).isSome + · rw [if_pos hp]; exact h_inner_fresh t h_suf + · rw [if_neg hp] + have h_tgt_fresh_next : GenFreshStore Q σ ρ_tgt_next.store := by + intro s h_suf h_notin + show (if (ρ_tgt.store (HasIdent.ident (P := P) s)).isSome + then storeWith ρ_inner_tgt.store (HasIdent.ident (P := P) g) bval + (HasIdent.ident (P := P) s) else none) = none + rw [h_tgt_fresh s h_suf h_notin]; rfl + obtain ⟨d, h_run_recurse, hd_fail⟩ := + ih ρ_src_next ρ_tgt_next d_loop h_eval_eq_next h_fail_eq_next h_agree_next + hwfb_next hwfv_next hwf_def_next hwf_congr_next hwf_var_next + h_src_fresh_next h_tgt_fresh_next next_ent h_guard_next hd_loop_fail hsfirst_next + -- Assemble: enter (guard tt), block runs body'++[havoc], step_seq_done, recurse. + have h_block_run : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.terminal ρ_tgt_next) := by + refine ReflTrans_Transitive _ _ _ _ + (block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_body_tail) ?_ + exact .step _ _ _ StepStmt.step_block_done (.refl _) + -- The recursive `.stmt loop'` failing run wrapped into `.stmts [loop']`. + have h_run_recurse_stmts : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m + ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md] ρ_tgt_next) + (.seq d ([] : List (Stmt P (Cmd P)))) := + .step _ _ _ StepStmt.step_stmts_cons + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_run_recurse) + refine ⟨.seq d ([] : List (Stmt P (Cmd P))), + ReflTrans_Transitive _ _ _ _ h_step_enter + (ReflTrans_Transitive _ _ _ _ + (ReflTrans_Transitive _ _ _ _ + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_block_run) + (.step _ _ _ StepStmt.step_seq_done (.refl _))) + h_run_recurse_stmts), ?_⟩ + simpa [Config.getEnv] using hd_fail + -- Invert the peeled loop-tail's first step to pick the next re-havoc value. + rcases loop_nondet_step_first_inv_fail (extendEval := extendEval) + h_loop_stmt hd_loop_fail with + h_refl | ⟨hrest_next, hlen_next⟩ | ⟨hrest_next, hlen_next⟩ + · -- LOOP TAIL is refl: the loop start (= this iteration's post-env) is itself + -- the failing config, so `ρ_inner.hasFailure = true`, hence `ρ_inner_tgt` + -- (the target body' terminal) is failing. Running `body' ++ [havoc]` reaches + -- a failing config (the `body'` prefix already terminates failing); lift it + -- into the loop body-block — already failing, no recursion needed. + have h_inner_fail : ρ_inner.hasFailure = true := by + simpa [ρ_src_next, Config.getEnv] using h_refl + have h_inner_tgt_fail : ρ_inner_tgt.hasFailure = true := by + rw [h_fail_inner]; exact h_inner_fail + obtain ⟨d'', h_body_tail_fail, hd''_fail⟩ := + stmts_prefix_failing_append P (EvalCmd P) extendEval + body' [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)] + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P) + (.terminal ρ_inner_tgt) h_body_tgt_term + (by simpa [Config.getEnv] using h_inner_tgt_fail) + have h_blk_tgt : StepStmtStar P (EvalCmd P) extendEval + (.block .none ρ_tgt.store (.stmts (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) + ({ ρ_tgt with hasFailure := ρ_tgt.hasFailure || false } : Env P))) + (.block .none ρ_tgt.store d'') := + block_inner_star P (EvalCmd P) extendEval _ _ .none ρ_tgt.store h_body_tail_fail + refine ⟨.seq (.block .none ρ_tgt.store d'') + [.loop (.det (HasFvar.mkFvar (HasIdent.ident (P := P) g))) m ([] : List (String × P.Expr)) + (body' ++ [.cmd (HasHavoc.havoc (HasIdent.ident (P := P) g) md)]) md], + ReflTrans_Transitive _ _ _ _ h_step_enter + (seq_inner_star P (EvalCmd P) extendEval _ _ _ h_blk_tgt), ?_⟩ + simpa [Config.getEnv] using hd''_fail + · -- NEXT = EXIT: re-havoc $g := ff, recurse with entering = false. + exact step_assemble false (.inl ⟨rfl, hrest_next, by omega⟩) + · -- NEXT = ENTER: re-havoc $g := tt, recurse with entering = true. + exact step_assemble true (.inr ⟨rfl, hrest_next, by omega⟩) + +mutual +/-- Statement-level failing-config simulation (the `_to_fail` analogue of +`nondetElim_stmt_gen`): a failing source run of a single statement `s` is matched +by a failing run of the rewritten block `(Stmt.nondetElimM s σ).1`. Each nested +structure (block body, `ite` branch, loop body) recurses through the list-level +`_to_fail`; completed iterations of a loop use the *terminal* simulation, the +failing iteration uses this `_to_fail` recursion. -/ +private theorem nondetElim_stmt_to_fail_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] + {Q : String → Prop} + (hQmint : (∀ sg, Q (StringGenState.gen ndelimItePrefix sg).1) + ∧ (∀ sg, Q (StringGenState.gen ndelimLoopPrefix sg).1)) + (extendEval : ExtendEval P) + (s : Stmt P (Cmd P)) (σ : StringGenState) + (ρ_src ρ_tgt : Env P) (c : Config P (Cmd P)) + (h_eval_eq : ρ_tgt.eval = ρ_src.eval) + (h_fail_eq : ρ_tgt.hasFailure = ρ_src.hasFailure) + (h_agree : AgreeOffGen Q ρ_src.store ρ_tgt.store) + (hwfb : WellFormedSemanticEvalBool ρ_src.eval) + (hwfv : WellFormedSemanticEvalVal ρ_src.eval) + (hwf_def : WellFormedSemanticEvalDef ρ_src.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ_src.eval) + (hwf_var : WellFormedSemanticEvalVar ρ_src.eval) + (h_wf_gen : StringGenState.WF σ) + (h_src_fresh : ∀ t, Q t → + ρ_src.store (HasIdent.ident (P := P) t) = none) + (h_tgt_fresh : GenFreshStore Q σ ρ_tgt.store) + (h_no_writes : NoGenSuffix (P := P) Q (Stmt.definedVars s ++ Stmt.modifiedVars s)) + (h_nofd : Stmt.noFuncDecl s = true) + (h_lhni : Stmt.loopHasNoInvariants s = true) + (h_reach : StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ_src) c) + (h_c_fail : c.getEnv.hasFailure = true) : + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.nondetElimM s σ).1 ρ_tgt) d + ∧ d.getEnv.hasFailure = true := by + -- Shortcut: if the source is already failing, the target start config (its + -- `getEnv` is `ρ_tgt`, failing by the failure-flag agreement) is itself a failing + -- reachable config (refl). This handles the refl source-run and every base case. + by_cases h_ρsrc_fail : ρ_src.hasFailure = true + · exact ⟨.stmts (Stmt.nondetElimM s σ).1 ρ_tgt, .refl _, + by simpa [Config.getEnv] using (h_fail_eq.trans h_ρsrc_fail)⟩ + have h_ρsrc_nofail : ρ_src.hasFailure = false := by simpa using h_ρsrc_fail + match s, h_no_writes, h_nofd, h_lhni, h_reach with + | .cmd c0, h_no_writes, _, _, h_reach => + -- `.cmd c0` reaches only `.terminal`; with `ρ_src` clean the failure appears at + -- the post-command terminal `ρ_mid`. Replay `c0` on the agreeing target store to + -- a terminal carrying the same (true) failure flag. + have h_no_writes_c : NoGenSuffix (P := P) Q (Cmd.definedVars c0 ++ Cmd.modifiedVars c0) := by + have h_dv : Stmt.definedVars (P := P) (.cmd c0) = Cmd.definedVars c0 := by with_unfolding_all rfl + have h_mv : Stmt.modifiedVars (P := P) (.cmd c0) = Cmd.modifiedVars c0 := by with_unfolding_all rfl + rw [h_dv, h_mv] at h_no_writes; exact h_no_writes + -- The clean source forces a genuine step; the post-env is the failing terminal. + obtain ⟨cfg0, hstep, hrest⟩ := clean_stmt_first_step (extendEval := extendEval) h_reach h_c_fail h_ρsrc_nofail + cases hstep with + | step_cmd hcmd => + rename_i σ' hasAssertFailure + -- The post-command terminal env is the failing `c`. + have h_c_eq := reflTransT_from_terminal P (EvalCmd P) extendEval (reflTrans_to_T hrest) + have h_mid_fail : + ({ ρ_src with store := σ', hasFailure := ρ_src.hasFailure || hasAssertFailure } : Env P).hasFailure + = true := by rw [h_c_eq] at h_c_fail; simpa [Config.getEnv] using h_c_fail + have h_term_src : StepStmtStar P (EvalCmd P) extendEval (.stmt (.cmd c0) ρ_src) + (.terminal ({ ρ_src with store := σ', hasFailure := ρ_src.hasFailure || hasAssertFailure } : Env P)) := + .step _ _ _ (StepStmt.step_cmd hcmd) (.refl _) + obtain ⟨_, ρ_tgt', h_run, _, h_fail', _, _⟩ := + cmd_replay_agreement_offgen extendEval c0 ρ_src + ({ ρ_src with store := σ', hasFailure := ρ_src.hasFailure || hasAssertFailure } : Env P) ρ_tgt σ + h_eval_eq h_fail_eq h_agree hwf_def hwf_congr h_src_fresh h_tgt_fresh + h_no_writes_c h_term_src + refine ⟨.terminal ρ_tgt', ?_, by simpa [Config.getEnv, h_fail'] using h_mid_fail⟩ + simp only [Stmt.nondetElimM] + exact stmt_to_singleton_stmts (extendEval := extendEval) (.cmd c0) ρ_tgt ρ_tgt' h_run + | .block lbl bss md, h_no_writes, h_nofd, h_lhni, h_reach => + -- `.block`: the failure is inside the body `bss`; recurse on `bss` via the + -- list-level `_to_fail`, then wrap the failing inner config in the block frame. + have h_dv : Stmt.definedVars (P := P) (.block lbl bss md) = Block.definedVars bss := by + with_unfolding_all rfl + have h_mv : Stmt.modifiedVars (P := P) (.block lbl bss md) = Block.modifiedVars bss := by + with_unfolding_all rfl + have h_no_writes_bss : SrcNoGenWrites (P := P) Q bss := by + show NoGenSuffix (P := P) Q (Block.definedVars bss ++ Block.modifiedVars bss) + rw [h_dv, h_mv] at h_no_writes; exact h_no_writes + have h_nofd_bss : Block.noFuncDecl bss = true := by simpa only [Stmt.noFuncDecl] using h_nofd + have h_lhni_bss : Block.loopHasNoInvariants bss = true := Stmt.loopHasNoInvariants_block_body h_lhni + -- Source: step into the block context, then the inner body reaches a failing config. + obtain ⟨cfg0, hstep, hrest⟩ := clean_stmt_first_step (extendEval := extendEval) h_reach h_c_fail h_ρsrc_nofail + cases hstep with + | step_block => + have ⟨d_body, h_body_run, hd_body_fail⟩ := + block_reaches_failing' P (EvalCmd P) extendEval hrest h_c_fail + obtain ⟨d_tgt, h_run_tgt, hd_tgt_fail⟩ := + nondetElim_to_fail_gen hQmint extendEval bss σ ρ_src ρ_tgt d_body + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf_gen h_src_fresh h_tgt_fresh h_no_writes_bss h_nofd_bss h_lhni_bss + h_body_run hd_body_fail + -- Target: step into the block over `(Block.nondetElimM bss σ).1`, lift the inner + -- failing run, wrap as the block then seq config (each reads `getEnv` from the + -- inner failing config). + rw [Stmt.nondetElimM_block_out] + have h_block_stmt : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.block lbl (Block.nondetElimM bss σ).1 md) ρ_tgt) + (.block (some lbl) ρ_tgt.store d_tgt) := + .step _ _ _ StepStmt.step_block + (block_inner_star P (EvalCmd P) extendEval _ _ (some lbl) ρ_tgt.store h_run_tgt) + exact stmt_to_singleton_stmts_fail (extendEval := extendEval) + (.block lbl (Block.nondetElimM bss σ).1 md) ρ_tgt + (.block (some lbl) ρ_tgt.store d_tgt) h_block_stmt + (by simpa [Config.getEnv] using hd_tgt_fail) + | .ite (.det e) tss ess md, h_no_writes, h_nofd, h_lhni, h_reach => + -- `.ite (.det e)`: the guard reads the same value in the target; the failure is + -- in the taken branch; recurse on it via the list-level `_to_fail`. + have h_dv : Stmt.definedVars (P := P) (.ite (.det e) tss ess md) + = Block.definedVars tss ++ Block.definedVars ess := rfl + have h_mv : Stmt.modifiedVars (P := P) (.ite (.det e) tss ess md) + = Block.modifiedVars tss ++ Block.modifiedVars ess := rfl + have h_nofd' : Block.noFuncDecl tss = true ∧ Block.noFuncDecl ess = true := by + have : (Block.noFuncDecl tss && Block.noFuncDecl ess) = true := by + simpa only [Stmt.noFuncDecl] using h_nofd + exact Bool.and_eq_true _ _ |>.mp this + obtain ⟨cfg0, hstep, hrest⟩ := clean_stmt_first_step (extendEval := extendEval) h_reach h_c_fail h_ρsrc_nofail + have hwf_var_t : WellFormedSemanticEvalVar ρ_tgt.eval := h_eval_eq ▸ hwf_var + cases hstep with + | step_ite_true h_cond hwfb_s => + have h_no_writes_t : SrcNoGenWrites (P := P) Q tss := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (by rw [h_dv]; exact List.mem_append_left _ (List.mem_append_left _ hd)) t heq + · exact h_no_writes x (by rw [h_mv]; exact List.mem_append_right _ (List.mem_append_left _ hm)) t heq + obtain ⟨d_tgt, h_run_tgt, hd_tgt_fail⟩ := + nondetElim_to_fail_gen hQmint extendEval tss σ ρ_src ρ_tgt c + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf_gen h_src_fresh h_tgt_fresh h_no_writes_t h_nofd'.1 + (Stmt.loopHasNoInvariants_branch_then h_lhni) hrest h_c_fail + have h_def_e : isDefined ρ_src.store (HasVarsPure.getVars e) := + hwf_def e HasBool.tt ρ_src.store h_cond + have h_pw : ∀ x ∈ HasVarsPure.getVars e, ρ_src.store x = ρ_tgt.store x := + agreeOffGen_pointwise_on_expr_vars ρ_src.store ρ_tgt.store e h_agree h_src_fresh h_def_e + have h_cond_t : ρ_tgt.eval ρ_tgt.store e = some HasBool.tt := by + rw [h_eval_eq, ← h_cond]; exact (hwf_congr e ρ_src.store ρ_tgt.store h_pw).symm + rw [Stmt.nondetElimM_ite_det_out] + refine ⟨.seq d_tgt [], ?_, by simpa [Config.getEnv] using hd_tgt_fail⟩ + refine .step _ _ _ StepStmt.step_stmts_cons ?_ + exact seq_inner_star P (EvalCmd P) extendEval _ _ [] + (.step _ _ _ (StepStmt.step_ite_true h_cond_t (h_eval_eq ▸ hwfb)) h_run_tgt) + | step_ite_false h_cond hwfb_s => + have h_no_writes_e : SrcNoGenWrites (P := P) Q ess := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (by rw [h_dv]; exact List.mem_append_left _ (List.mem_append_right _ hd)) t heq + · exact h_no_writes x (by rw [h_mv]; exact List.mem_append_right _ (List.mem_append_right _ hm)) t heq + have h_wf₁ : StringGenState.WF (Block.nondetElimM tss σ).2 := + (Block.nondetElimM_genStep tss σ).wf_mono h_wf_gen + have h_tgt_fresh₁ : GenFreshStore Q (Block.nondetElimM tss σ).2 ρ_tgt.store := + GenFreshStore.mono (Block.nondetElimM_genStep tss σ) h_tgt_fresh + obtain ⟨d_tgt, h_run_tgt, hd_tgt_fail⟩ := + nondetElim_to_fail_gen hQmint extendEval ess (Block.nondetElimM tss σ).2 ρ_src ρ_tgt c + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf₁ h_src_fresh h_tgt_fresh₁ h_no_writes_e h_nofd'.2 + (Stmt.loopHasNoInvariants_branch_else h_lhni) hrest h_c_fail + have h_def_e : isDefined ρ_src.store (HasVarsPure.getVars e) := + hwf_def e HasBool.ff ρ_src.store h_cond + have h_pw : ∀ x ∈ HasVarsPure.getVars e, ρ_src.store x = ρ_tgt.store x := + agreeOffGen_pointwise_on_expr_vars ρ_src.store ρ_tgt.store e h_agree h_src_fresh h_def_e + have h_cond_t : ρ_tgt.eval ρ_tgt.store e = some HasBool.ff := by + rw [h_eval_eq, ← h_cond]; exact (hwf_congr e ρ_src.store ρ_tgt.store h_pw).symm + rw [Stmt.nondetElimM_ite_det_out] + refine ⟨.seq d_tgt [], ?_, by simpa [Config.getEnv] using hd_tgt_fail⟩ + refine .step _ _ _ StepStmt.step_stmts_cons ?_ + exact seq_inner_star P (EvalCmd P) extendEval _ _ [] + (.step _ _ _ (StepStmt.step_ite_false h_cond_t (h_eval_eq ▸ hwfb)) h_run_tgt) + | .ite .nondet tss ess md, h_no_writes, h_nofd, h_lhni, h_reach => + -- `.ite .nondet`: generated guard `$g`; the taken branch fails; recurse with the + -- matching havoc value, then drive the emitted `init $g; ite $g` prefix. + rcases hgen : StringGenState.gen ndelimItePrefix σ with ⟨g, σ₁⟩ + have h_g_gen : Q g := by have := hQmint.1 σ; rw [hgen] at this; exact this + have h_tgt_g_none : ρ_tgt.store (HasIdent.ident (P := P) g) = none := by + have := GenFreshStore.gen_slot_none ndelimItePrefix h_tgt_fresh h_wf_gen (hQmint.1 σ) + rw [hgen] at this; exact this + have hwf_var_t : WellFormedSemanticEvalVar ρ_tgt.eval := h_eval_eq ▸ hwf_var + have hwfb_t : WellFormedSemanticEvalBool ρ_tgt.eval := h_eval_eq ▸ hwfb + have h_step01 : StringGenState.GenStep σ σ₁ := by + have := StringGenState.GenStep.of_gen ndelimItePrefix σ; rw [hgen] at this; exact this + have h_wf₁ : StringGenState.WF σ₁ := h_step01.wf_mono h_wf_gen + have h_dv : Stmt.definedVars (P := P) (.ite .nondet tss ess md) + = Block.definedVars tss ++ Block.definedVars ess := rfl + have h_mv : Stmt.modifiedVars (P := P) (.ite .nondet tss ess md) + = Block.modifiedVars tss ++ Block.modifiedVars ess := rfl + have h_nofd' : Block.noFuncDecl tss = true ∧ Block.noFuncDecl ess = true := by + have : (Block.noFuncDecl tss && Block.noFuncDecl ess) = true := by + simpa only [Stmt.noFuncDecl] using h_nofd + exact Bool.and_eq_true _ _ |>.mp this + have h_no_writes_t : SrcNoGenWrites (P := P) Q tss := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (by rw [h_dv]; exact List.mem_append_left _ (List.mem_append_left _ hd)) t heq + · exact h_no_writes x (by rw [h_mv]; exact List.mem_append_right _ (List.mem_append_left _ hm)) t heq + have h_no_writes_e : SrcNoGenWrites (P := P) Q ess := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (by rw [h_dv]; exact List.mem_append_left _ (List.mem_append_right _ hd)) t heq + · exact h_no_writes x (by rw [h_mv]; exact List.mem_append_right _ (List.mem_append_right _ hm)) t heq + -- Invert the source nondet-ite to the failing branch. + obtain ⟨cfg0, hstep, hrest⟩ := clean_stmt_first_step (extendEval := extendEval) h_reach h_c_fail h_ρsrc_nofail + cases hstep with + | step_ite_nondet_true => + -- True branch fired: choose havoc value tt. + have h_off_g : AgreeOffGen Q ρ_src.store + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.tt) := + AgreeOffGen.storeWith_gen h_agree h_g_gen + have h_fresh_g : GenFreshStore Q σ₁ + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.tt) := by + have := GenFreshStore.storeWith_gen (P := P) ndelimItePrefix HasBool.tt h_tgt_fresh + rw [hgen] at this; exact this + obtain ⟨d_tgt, h_run_tgt, hd_tgt_fail⟩ := + nondetElim_to_fail_gen hQmint extendEval tss σ₁ + ρ_src ({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.tt } : Env P) c + h_eval_eq h_fail_eq h_off_g hwfb hwfv hwf_def hwf_congr hwf_var + h_wf₁ h_src_fresh h_fresh_g h_no_writes_t h_nofd'.1 + (Stmt.loopHasNoInvariants_branch_then h_lhni) hrest h_c_fail + rw [Stmt.nondetElimM_ite_nondet_out]; simp only [hgen] + exact step_ndelim_ite_prefix_fail (extendEval := extendEval) true (HasIdent.ident (P := P) g) + (Block.nondetElimM tss σ₁).1 (Block.nondetElimM ess (Block.nondetElimM tss σ₁).2).1 md + ρ_tgt d_tgt h_tgt_g_none hwf_var_t hwfb_t h_run_tgt hd_tgt_fail + | step_ite_nondet_false => + have h_step12 : StringGenState.GenStep σ₁ (Block.nondetElimM tss σ₁).2 := + Block.nondetElimM_genStep tss σ₁ + have h_wf₂ : StringGenState.WF (Block.nondetElimM tss σ₁).2 := h_step12.wf_mono h_wf₁ + have h_off_g : AgreeOffGen Q ρ_src.store + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff) := + AgreeOffGen.storeWith_gen h_agree h_g_gen + have h_fresh_g1 : GenFreshStore Q σ₁ + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff) := by + have := GenFreshStore.storeWith_gen (P := P) ndelimItePrefix HasBool.ff h_tgt_fresh + rw [hgen] at this; exact this + have h_fresh_g : GenFreshStore Q (Block.nondetElimM tss σ₁).2 + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff) := + GenFreshStore.mono h_step12 h_fresh_g1 + obtain ⟨d_tgt, h_run_tgt, hd_tgt_fail⟩ := + nondetElim_to_fail_gen hQmint extendEval ess (Block.nondetElimM tss σ₁).2 + ρ_src ({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) HasBool.ff } : Env P) c + h_eval_eq h_fail_eq h_off_g hwfb hwfv hwf_def hwf_congr hwf_var + h_wf₂ h_src_fresh h_fresh_g h_no_writes_e h_nofd'.2 + (Stmt.loopHasNoInvariants_branch_else h_lhni) hrest h_c_fail + rw [Stmt.nondetElimM_ite_nondet_out]; simp only [hgen] + exact step_ndelim_ite_prefix_fail (extendEval := extendEval) false (HasIdent.ident (P := P) g) + (Block.nondetElimM tss σ₁).1 (Block.nondetElimM ess (Block.nondetElimM tss σ₁).2).1 md + ρ_tgt d_tgt h_tgt_g_none hwf_var_t hwfb_t h_run_tgt hd_tgt_fail + | .loop (.det e) m inv body md, h_no_writes, h_nofd, h_lhni, h_reach => + have h_inv_nil : inv = [] := Stmt.loopHasNoInvariants_loop_invs h_lhni + subst h_inv_nil + have h_lhni_body : Block.loopHasNoInvariants body = true := + Stmt.loopHasNoInvariants_loop_body_rec h_lhni + have h_nofd_body : Block.noFuncDecl body = true := by simpa only [Stmt.noFuncDecl] using h_nofd + have h_no_writes_body : SrcNoGenWrites (P := P) Q body := by + have h_dv : Stmt.definedVars (P := P) (.loop (.det e) m ([] : List (String × P.Expr)) body md) + = Block.definedVars body := rfl + have h_mv : Stmt.modifiedVars (P := P) (.loop (.det e) m ([] : List (String × P.Expr)) body md) + = Block.modifiedVars body := rfl + show NoGenSuffix (P := P) Q (Block.definedVars body ++ Block.modifiedVars body) + rw [h_dv, h_mv] at h_no_writes; exact h_no_writes + have h_body_sim : ∀ (oc_b : Option String) (ρb_src ρb' ρb_tgt : Env P), + ρb_tgt.eval = ρb_src.eval → ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → StringGenState.WF σ → + (∀ t, Q t → ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) (outcomeConfig oc_b ρb') → + (∀ t, Q t → ρb'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρb_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElimM body σ).1 ρb_tgt) (outcomeConfig oc_b ρb_out) + ∧ AgreeOffGen Q ρb'.store ρb_out.store ∧ ρb_out.hasFailure = ρb'.hasFailure + ∧ ρb_out.eval = ρb'.eval ∧ GenFreshStore Q (Block.nondetElimM body σ).2 ρb_out.store := + fun oc_b ρb_src ρb' ρb_tgt h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf hrun => + nondetElim_simulation_gen hQmint extendEval body σ ρb_src ρb' ρb_tgt + h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf + h_no_writes_body h_nofd_body h_lhni_body oc_b hrun + have h_body_sim_fail : ∀ (ρb_src ρb_tgt : Env P) (d : Config P (Cmd P)), + ρb_tgt.eval = ρb_src.eval → ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → StringGenState.WF σ → + (∀ t, Q t → ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) d → d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts (Block.nondetElimM body σ).1 ρb_tgt) d' + ∧ d'.getEnv.hasFailure = true := + fun ρb_src ρb_tgt d h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf hrun hdfail => + nondetElim_to_fail_gen hQmint extendEval body σ ρb_src ρb_tgt d + h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf + h_no_writes_body h_nofd_body h_lhni_body hrun hdfail + obtain ⟨d_tgt, h_run_tgt, hd_tgt_fail⟩ := + nondetElim_loop_det_to_fail_iteration extendEval e m body (Block.nondetElimM body σ).1 md σ + (Block.nondetElimM body σ).2 + h_body_sim h_body_sim_fail h_nofd_body ρ_src ρ_tgt c (reflTrans_to_T h_reach).len + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf_gen h_src_fresh h_tgt_fresh (reflTrans_to_T h_reach) h_c_fail (Nat.le_refl _) + rw [Stmt.nondetElimM_loop_det_out] + refine ⟨.seq d_tgt [], ?_, by simpa [Config.getEnv] using hd_tgt_fail⟩ + refine .step _ _ _ StepStmt.step_stmts_cons ?_ + exact seq_inner_star P (EvalCmd P) extendEval _ _ [] h_run_tgt + | .loop .nondet m inv body md, h_no_writes, h_nofd, h_lhni, h_reach => + have h_inv_nil : inv = [] := Stmt.loopHasNoInvariants_loop_invs h_lhni + subst h_inv_nil + have h_lhni_body : Block.loopHasNoInvariants body = true := + Stmt.loopHasNoInvariants_loop_body_rec h_lhni + have h_nofd_body : Block.noFuncDecl body = true := by simpa only [Stmt.noFuncDecl] using h_nofd + have h_no_writes_body : SrcNoGenWrites (P := P) Q body := by + have h_dv : Stmt.definedVars (P := P) (.loop .nondet m ([] : List (String × P.Expr)) body md) + = Block.definedVars body := rfl + have h_mv : Stmt.modifiedVars (P := P) (.loop .nondet m ([] : List (String × P.Expr)) body md) + = Block.modifiedVars body := rfl + show NoGenSuffix (P := P) Q (Block.definedVars body ++ Block.modifiedVars body) + rw [h_dv, h_mv] at h_no_writes; exact h_no_writes + rcases hgen : StringGenState.gen ndelimLoopPrefix σ with ⟨g, σ₁⟩ + have h_g_gen : Q g := by have := hQmint.2 σ; rw [hgen] at this; exact this + have h_step01 : StringGenState.GenStep σ σ₁ := by + have := StringGenState.GenStep.of_gen ndelimLoopPrefix σ; rw [hgen] at this; exact this + have h_wf₁ : StringGenState.WF σ₁ := h_step01.wf_mono h_wf_gen + have h_tgt_g_none : ρ_tgt.store (HasIdent.ident (P := P) g) = none := by + have := GenFreshStore.gen_slot_none ndelimLoopPrefix h_tgt_fresh h_wf_gen (hQmint.2 σ) + rw [hgen] at this; exact this + have hwf_var_t : WellFormedSemanticEvalVar ρ_tgt.eval := h_eval_eq ▸ hwf_var + have h_body_sim : ∀ (oc_b : Option String) (ρb_src ρb' ρb_tgt : Env P), + ρb_tgt.eval = ρb_src.eval → ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → StringGenState.WF σ₁ → + (∀ t, Q t → ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ₁ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) (outcomeConfig oc_b ρb') → + (∀ t, Q t → ρb'.store (HasIdent.ident (P := P) t) = none) + ∧ ∃ ρb_out, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElimM body σ₁).1 ρb_tgt) (outcomeConfig oc_b ρb_out) + ∧ AgreeOffGen Q ρb'.store ρb_out.store ∧ ρb_out.hasFailure = ρb'.hasFailure + ∧ ρb_out.eval = ρb'.eval ∧ GenFreshStore Q (Block.nondetElimM body σ₁).2 ρb_out.store := + fun oc_b ρb_src ρb' ρb_tgt h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf hrun => + nondetElim_simulation_gen hQmint extendEval body σ₁ ρb_src ρb' ρb_tgt + h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf + h_no_writes_body h_nofd_body h_lhni_body oc_b hrun + have h_body_sim_fail : ∀ (ρb_src ρb_tgt : Env P) (d : Config P (Cmd P)), + ρb_tgt.eval = ρb_src.eval → ρb_tgt.hasFailure = ρb_src.hasFailure → + AgreeOffGen Q ρb_src.store ρb_tgt.store → + WellFormedSemanticEvalBool ρb_src.eval → WellFormedSemanticEvalVal ρb_src.eval → + WellFormedSemanticEvalDef ρb_src.eval → WellFormedSemanticEvalExprCongr ρb_src.eval → + WellFormedSemanticEvalVar ρb_src.eval → StringGenState.WF σ₁ → + (∀ t, Q t → ρb_src.store (HasIdent.ident (P := P) t) = none) → + GenFreshStore Q σ₁ ρb_tgt.store → + StepStmtStar P (EvalCmd P) extendEval (.stmts body ρb_src) d → d.getEnv.hasFailure = true → + ∃ d', StepStmtStar P (EvalCmd P) extendEval (.stmts (Block.nondetElimM body σ₁).1 ρb_tgt) d' + ∧ d'.getEnv.hasFailure = true := + fun ρb_src ρb_tgt d h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf hrun hdfail => + nondetElim_to_fail_gen hQmint extendEval body σ₁ ρb_src ρb_tgt d + h_ev h_fl h_ag hb hv hd hc hvar hwfg hsf htf + h_no_writes_body h_nofd_body h_lhni_body hrun hdfail + -- Invert the source loop's first decision to seed the iteration (the start + -- env `ρ_tgt + (g↦b)` matches the first enter/exit choice), then drive the + -- iteration to a failing target loop config and prepend the `init $g := *` step. + have hstarT := reflTrans_to_T h_reach + have h_finish : ∀ (entering : Bool) (b : P.Expr) + (_h_b : b = (if entering then HasBool.tt else HasBool.ff)) + (h_first : + (entering = false ∧ ∃ (hr : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.terminal ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P)) c), + hr.len ≤ hstarT.len) ∨ + (entering = true ∧ ∃ (hr : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.seq (.block .none ρ_src.store (.stmts body + ({ ρ_src with hasFailure := ρ_src.hasFailure || false } : Env P))) + [.loop .nondet m ([] : List (String × P.Expr)) body md]) c), + hr.len ≤ hstarT.len)), + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Stmt.nondetElimM (.loop .nondet m ([] : List (String × P.Expr)) body md) σ).1 ρ_tgt) d + ∧ d.getEnv.hasFailure = true := by + intro entering b h_b h_first + have h_off_g : AgreeOffGen Q ρ_src.store + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) b) := + AgreeOffGen.storeWith_gen h_agree h_g_gen + have h_fresh_g : GenFreshStore Q σ₁ + (storeWith ρ_tgt.store (HasIdent.ident (P := P) g) b) := by + have := GenFreshStore.storeWith_gen (P := P) ndelimLoopPrefix b h_tgt_fresh + rw [hgen] at this; exact this + have h_guard_def : (({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) b } : Env P).store) + (HasIdent.ident (P := P) g) = some (if entering then HasBool.tt else HasBool.ff) := by + subst h_b; simp [storeWith] + obtain ⟨d_tgt, h_loop_run, hd_tgt_fail⟩ := + nondetElim_loop_nondet_to_fail_iteration extendEval g m body (Block.nondetElimM body σ₁).1 md σ₁ + (Block.nondetElimM body σ₁).2 + h_body_sim h_body_sim_fail h_g_gen h_nofd_body ρ_src + ({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) b } : Env P) + c hstarT.len h_eval_eq h_fail_eq h_off_g hwfb hwfv hwf_def hwf_congr hwf_var + h_wf₁ h_src_fresh h_fresh_g entering h_guard_def h_c_fail h_first + -- Prepend `init $g := *` (choosing value `b`), then the loop run. + rw [Stmt.nondetElimM_loop_nondet_out]; simp only [hgen] + have h_init : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd (HasInit.init (HasIdent.ident (P := P) g) HasBool.boolTy .nondet md)) ρ_tgt) + (.terminal ({ ρ_tgt with store := storeWith ρ_tgt.store (HasIdent.ident (P := P) g) b } : Env P)) := + step_init_havoc_to (extendEval := extendEval) (HasIdent.ident (P := P) g) HasBool.boolTy b md ρ_tgt + h_tgt_g_none hwf_var_t + refine ⟨.seq d_tgt ([] : List (Stmt P (Cmd P))), ?_, by simpa [Config.getEnv] using hd_tgt_fail⟩ + refine ReflTrans_Transitive _ _ _ _ + (stmts_cons_step P (EvalCmd P) extendEval _ _ ρ_tgt _ h_init) ?_ + exact .step _ _ _ StepStmt.step_stmts_cons (seq_inner_star P (EvalCmd P) extendEval _ _ [] h_loop_run) + -- Invert the source loop's first step to choose the matched guard value. + rcases loop_nondet_step_first_inv_fail (extendEval := extendEval) hstarT h_c_fail with + h_refl | ⟨hrest, hl⟩ | ⟨hrest, hl⟩ + · -- Refl: `ρ_src` already failing — excluded by the clean-source branch. + exact absurd h_refl h_ρsrc_fail + · exact h_finish false HasBool.ff (by simp) (.inl ⟨rfl, hrest, Nat.le_of_lt hl⟩) + · exact h_finish true HasBool.tt (by simp) (.inr ⟨rfl, hrest, Nat.le_of_lt hl⟩) + | .exit lbl md, _, _, _, h_reach => + -- `.exit lbl` steps to `.exiting lbl ρ_src`; with `ρ_src` clean the exiting env + -- is also clean, contradicting `h_c_fail`. + exfalso + obtain ⟨cfg0, hstep, hrest⟩ := clean_stmt_first_step (extendEval := extendEval) h_reach h_c_fail h_ρsrc_nofail + cases hstep with + | step_exit => + have h_c_eq : c = .exiting lbl ρ_src := + reflTransT_from_exiting P (EvalCmd P) extendEval (reflTrans_to_T hrest) + rw [h_c_eq] at h_c_fail + exact absurd (by simpa [Config.getEnv] using h_c_fail) h_ρsrc_fail + | .funcDecl d md, _, h_nofd, _, _ => exact absurd h_nofd (by simp [Stmt.noFuncDecl]) + | .typeDecl t md, _, _, _, h_reach => + -- `.typeDecl` is a no-op: steps to `.terminal ρ_src`; with `ρ_src` clean this + -- cannot be the failing config. + exfalso + obtain ⟨cfg0, hstep, hrest⟩ := clean_stmt_first_step (extendEval := extendEval) h_reach h_c_fail h_ρsrc_nofail + cases hstep with + | step_typeDecl => + have h_c_eq : c = .terminal ρ_src := + reflTransT_from_terminal P (EvalCmd P) extendEval (reflTrans_to_T hrest) + rw [h_c_eq] at h_c_fail + exact absurd (by simpa [Config.getEnv] using h_c_fail) h_ρsrc_fail + termination_by sizeOf s + +/-- Statement-list-level failing-config simulation (the `_to_fail` analogue of +`nondetElim_simulation_gen`): a failing source run of `ss` is matched by a failing +run of the rewritten block `(Block.nondetElimM ss σ).1`. Decomposes the source +run with `stmts_cons_reaches_failing'`: either the head statement already fails +(handled by the statement-level `_to_fail`), or it terminates (handled by the +existing *terminal* `nondetElim_stmt_gen`) and the tail fails (recursion). -/ +private theorem nondetElim_to_fail_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] + {Q : String → Prop} + (hQmint : (∀ sg, Q (StringGenState.gen ndelimItePrefix sg).1) + ∧ (∀ sg, Q (StringGenState.gen ndelimLoopPrefix sg).1)) + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (ρ_src ρ_tgt : Env P) (c : Config P (Cmd P)) + (h_eval_eq : ρ_tgt.eval = ρ_src.eval) + (h_fail_eq : ρ_tgt.hasFailure = ρ_src.hasFailure) + (h_agree : AgreeOffGen Q ρ_src.store ρ_tgt.store) + (hwfb : WellFormedSemanticEvalBool ρ_src.eval) + (hwfv : WellFormedSemanticEvalVal ρ_src.eval) + (hwf_def : WellFormedSemanticEvalDef ρ_src.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ_src.eval) + (hwf_var : WellFormedSemanticEvalVar ρ_src.eval) + (h_wf_gen : StringGenState.WF σ) + (h_src_fresh : ∀ t, Q t → + ρ_src.store (HasIdent.ident (P := P) t) = none) + (h_tgt_fresh : GenFreshStore Q σ ρ_tgt.store) + (h_no_writes : SrcNoGenWrites (P := P) Q ss) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_reach : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ_src) c) + (h_c_fail : c.getEnv.hasFailure = true) : + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElimM ss σ).1 ρ_tgt) d + ∧ d.getEnv.hasFailure = true := by + -- Already-failing source ⟹ the target start config is failing (refl). + by_cases h_ρsrc_fail : ρ_src.hasFailure = true + · exact ⟨.stmts (Block.nondetElimM ss σ).1 ρ_tgt, .refl _, + by simpa [Config.getEnv] using (h_fail_eq.trans h_ρsrc_fail)⟩ + have h_ρsrc_nofail : ρ_src.hasFailure = false := by simpa using h_ρsrc_fail + match ss, h_no_writes, h_nofd, h_lhni with + | [], _, _, _ => + -- Clean `.stmts [] ρ_src` reaches only `.terminal ρ_src` (clean): no failing config. + exfalso + have h_c_env : c.getEnv = ρ_src := by + match h_reach with + | .refl _ => rfl + | .step _ _ _ hstep hrest => + cases hstep with + | step_stmts_nil => + have := reflTransT_from_terminal P (EvalCmd P) extendEval (reflTrans_to_T hrest) + rw [this]; rfl + rw [h_c_env] at h_c_fail + exact absurd (by simpa [Config.getEnv] using h_c_fail) h_ρsrc_fail + | s :: rest, h_no_writes, h_nofd, h_lhni => + have h_no_writes_s : NoGenSuffix (P := P) Q (Stmt.definedVars s ++ Stmt.modifiedVars s) := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (List.mem_append_left _ (List.mem_append_left _ hd)) t heq + · exact h_no_writes x (List.mem_append_right _ (List.mem_append_left _ hm)) t heq + have h_no_writes_rest : SrcNoGenWrites (P := P) Q rest := by + intro x hx t heq + rcases List.mem_append.mp hx with hd | hm + · exact h_no_writes x (List.mem_append_left _ (List.mem_append_right _ hd)) t heq + · exact h_no_writes x (List.mem_append_right _ (List.mem_append_right _ hm)) t heq + have h_nofd_pair : Stmt.noFuncDecl s = true ∧ Block.noFuncDecl rest = true := by + have : (Stmt.noFuncDecl s && Block.noFuncDecl rest) = true := by + simpa only [Block.noFuncDecl] using h_nofd + exact Bool.and_eq_true _ _ |>.mp this + have h_lhni_pair : Stmt.loopHasNoInvariants s = true ∧ Block.loopHasNoInvariants rest = true := + Block.loopHasNoInvariants_cons_iff.mp h_lhni + -- The target output prefix-decomposes as `(Stmt.nondetElimM s σ).1 ++ (rest output)`. + have h_out_eq : (Block.nondetElimM (s :: rest) σ).1 + = (Stmt.nondetElimM s σ).1 ++ (Block.nondetElimM rest (Stmt.nondetElimM s σ).2).1 := by + rw [Block.nondetElimM] + rcases hh : Stmt.nondetElimM s σ with ⟨ss_s, σ_s⟩ + rcases hk : Block.nondetElimM rest σ_s with ⟨ss_r, σ_r⟩ + simp only [hh, hk] + rw [h_out_eq] + rcases stmts_cons_reaches_failing' P (EvalCmd P) extendEval (reflTrans_to_T h_reach) h_c_fail with + hA | hB + · -- CASE A: the head statement already fails. Its rewritten block is the output + -- prefix; lift its failing run to the appended list. + obtain ⟨d_head, h_head_run, hd_head_fail⟩ := hA + obtain ⟨d_tgt, h_run_tgt, hd_tgt_fail⟩ := + nondetElim_stmt_to_fail_gen hQmint extendEval s σ ρ_src ρ_tgt d_head + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf_gen h_src_fresh h_tgt_fresh h_no_writes_s h_nofd_pair.1 h_lhni_pair.1 + h_head_run hd_head_fail + exact stmts_prefix_failing_append P (EvalCmd P) extendEval + (Stmt.nondetElimM s σ).1 (Block.nondetElimM rest (Stmt.nondetElimM s σ).2).1 + ρ_tgt d_tgt h_run_tgt hd_tgt_fail + · -- CASE B: the head terminates at ρ_mid (clean, else covered by A's failing reach + -- of the head), then `rest` fails. Use the *terminal* head simulation to advance + -- the relation, then recurse on `rest`. + obtain ⟨ρ_mid, d_rest, h_head_term, h_rest_run, hd_rest_fail⟩ := hB + obtain ⟨h_mid_fresh, ρ_mid_tgt, h_s_tgt, h_off_mid, h_fail_mid, h_eval_mid, h_fresh_mid⟩ := + nondetElim_stmt_gen hQmint extendEval s σ ρ_src ρ_mid ρ_tgt + h_eval_eq h_fail_eq h_agree hwfb hwfv hwf_def hwf_congr hwf_var + h_wf_gen h_src_fresh h_tgt_fresh h_no_writes_s h_nofd_pair.1 h_lhni_pair.1 none h_head_term + -- Advance the generator and WF-eval facts to ρ_mid. + have h_wf₁ : StringGenState.WF (Stmt.nondetElimM s σ).2 := + (Stmt.nondetElimM_genStep s σ).wf_mono h_wf_gen + have h_eval_mid_src : ρ_mid.eval = ρ_src.eval := + smallStep_noFuncDecl_preserves_eval P (EvalCmd P) extendEval s ρ_src ρ_mid h_nofd_pair.1 h_head_term + have hwfb_mid : WellFormedSemanticEvalBool ρ_mid.eval := h_eval_mid_src ▸ hwfb + have hwfv_mid : WellFormedSemanticEvalVal ρ_mid.eval := h_eval_mid_src ▸ hwfv + have hwf_def_mid : WellFormedSemanticEvalDef ρ_mid.eval := h_eval_mid_src ▸ hwf_def + have hwf_congr_mid : WellFormedSemanticEvalExprCongr ρ_mid.eval := h_eval_mid_src ▸ hwf_congr + have hwf_var_mid : WellFormedSemanticEvalVar ρ_mid.eval := h_eval_mid_src ▸ hwf_var + obtain ⟨d_tgt, h_run_tgt, hd_tgt_fail⟩ := + nondetElim_to_fail_gen hQmint extendEval rest (Stmt.nondetElimM s σ).2 ρ_mid ρ_mid_tgt d_rest + h_eval_mid h_fail_mid h_off_mid hwfb_mid hwfv_mid hwf_def_mid hwf_congr_mid hwf_var_mid + h_wf₁ h_mid_fresh h_fresh_mid h_no_writes_rest h_nofd_pair.2 h_lhni_pair.2 + h_rest_run hd_rest_fail + -- Concatenate: head output runs to terminal ρ_mid_tgt, then rest output fails. + exact ⟨d_tgt, ReflTrans_Transitive _ _ _ _ + (stmts_prefix_terminal_append P (EvalCmd P) extendEval _ _ ρ_tgt ρ_mid_tgt h_s_tgt) + h_run_tgt, hd_tgt_fail⟩ + termination_by sizeOf ss +end + +/-- **Failing-config forward simulation (gen-parametric top form).** Every +reachable *failing* source configuration of `ss` is matched by a reachable +failing configuration of `Block.nondetElim ss` (same `ρ₀`, no endpoint demand). +Instantiates the gen-level `_to_fail` at `ρ_tgt = ρ₀` and the empty generator. -/ +private theorem nondetElim_simulation_to_fail {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] + {Q : String → Prop} + (hQmint : (∀ sg, Q (StringGenState.gen ndelimItePrefix sg).1) + ∧ (∀ sg, Q (StringGenState.gen ndelimLoopPrefix sg).1)) + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ : Env P) (c : Config P (Cmd P)) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (h_no_gen_suffix : ∀ s, Q s → ρ₀.store (HasIdent.ident (P := P) s) = none) + (h_no_writes : SrcNoGenWrites (P := P) Q ss) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_reach : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) c) + (h_c_fail : c.getEnv.hasFailure = true) : + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElim ss) ρ₀) d + ∧ d.getEnv.hasFailure = true := by + have h_tgt_fresh : GenFreshStore Q StringGenState.emp ρ₀.store := by + intro s h_suf _; exact h_no_gen_suffix s h_suf + exact nondetElim_to_fail_gen hQmint extendEval ss StringGenState.emp ρ₀ ρ₀ c + rfl rfl (AgreeOffGen.refl _) hwfb hwfv hwf_def hwf_congr hwf_var + StringGenState.wf_emp h_no_gen_suffix h_tgt_fresh h_no_writes h_nofd h_lhni h_reach h_c_fail + +/-- **`Block.nondetElim` failing-config preservation (at `Q := ndelimKind`).** A +reachable failing source configuration of `ss` is matched by a reachable failing +configuration of `Block.nondetElim ss`, with no terminal/exiting endpoint +required. This is the `_to_fail` sibling of `nondetElim_sound_kind`; the +`NoGenStore`/`SrcNoGenWrites` preconditions are exactly those the terminal +soundness theorems already consume, so it composes into the structured-pass +failing bridge identically. -/ +theorem nondetElim_to_fail {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) (c : Config P (Cmd P)) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (h_no_gen_suffix : NoGenStore (P := P) ndelimKind ρ₀) + (h_no_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_reach : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) c) + (h_c_fail : c.getEnv.hasFailure = true) : + ∃ d, StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.nondetElim ss) ρ₀) d + ∧ d.getEnv.hasFailure = true := + nondetElim_simulation_to_fail (Q := ndelimKind) ndelimKind_gen + extendEval ss ρ₀ c hwfb hwfv hwf_def hwf_congr hwf_var + h_no_gen_suffix h_no_writes h_nofd h_lhni h_reach h_c_fail + +end Imperative diff --git a/Strata/Transform/PipelineBridge.lean b/Strata/Transform/PipelineBridge.lean new file mode 100644 index 0000000000..3e01c53cca --- /dev/null +++ b/Strata/Transform/PipelineBridge.lean @@ -0,0 +1,2957 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.Transform.NondetElimCorrect +public import Strata.Transform.LoopInitHoistCorrect +public import Strata.Transform.StructuredToUnstructuredCorrect +public import Strata.Transform.PipelineLabelsPreserved + +-- `import all` to reach the (module-private) name-classification helpers from the +-- loop-init-hoist WF family and the `Block.initVars`/`modVars` distribution +-- lemmas they rely on; these discharge the Direction-B cross-pass leaves. +import all Strata.Transform.NondetElim +import all Strata.Transform.LoopInitHoistLoopArmWF + +public section + +namespace Imperative + +/-! # Pipeline preservation bridges + +This module proves the structural preservation lemmas that let the three +structured-to-unstructured passes chain end-to-end: + + `nondetElim` ▸ `hoistLoopPrefixInits` ▸ `stmtsToCFG` + +The three soundness theorems are: + * `nondetElim_sound` (`NondetElimCorrect`), + * `hoistLoopPrefixInits_preserves` (`LoopInitHoistCorrect`, the §F theorem), + * `structuredToUnstructured_sound_kind` (`StructuredToUnstructuredCorrect`). + +To compose them via `StoreAgreement.trans`, the OUTPUT of each pass must +satisfy the INPUT preconditions of the next. This file establishes those +bridge facts as `Bool`-predicate / shape postconditions on the pass outputs. + +## Direction A — `nondetElim` output ⊨ hoist §F preconditions + +`nondetElim` only ever adds `init`/`ite (.det _)`/`loop (.det _)`/`havoc` +statements; it never adds invariants, measures, exits, or function +declarations, and (by its `simpleShape` postcondition) it removes every +nondeterministic loop. Hence the structural §F preconditions are preserved +or established. + +## Direction B — hoist output ⊨ simple-S2U preconditions + +`hoistLoopPrefixInits` lifts loop-body inits and renames the lifted names; it +preserves the simple shape, the no-invariant / no-measure restrictions, and +establishes `loopBodyNoInits` (its raison d'être). +-/ + +--------------------------------------------------------------------- +/-! ## Section 0 — `loopMeasureNone` ↔ `noMeasureLoops` reconciliation + +The hoist §F precondition speaks of `Block.loopMeasureNone` +(`LoopInitHoist.lean`) while the simple-S2U precondition speaks of +`Block.noMeasureLoops` (`Stmt.lean`). The two predicates have identical +recursion (`m.isNone && recurse`), so they are pointwise equal. We prove +the equality once and use it to translate between the two namespaces. -/ + +mutual +/-- `Stmt.loopMeasureNone` and `Stmt.noMeasureLoops` are the same predicate. -/ +theorem Stmt.loopMeasureNone_eq_noMeasureLoops {P : PureExpr} + (s : Stmt P (Cmd P)) : + Stmt.loopMeasureNone s = Stmt.noMeasureLoops s := by + match s with + | .cmd c => simp [Stmt.loopMeasureNone, Stmt.noMeasureLoops] + | .block lbl bss md => + rw [Stmt.loopMeasureNone, Stmt.noMeasureLoops] + exact Block.loopMeasureNone_eq_noMeasureLoops bss + | .ite g tss ess md => + rw [Stmt.loopMeasureNone, Stmt.noMeasureLoops, + Block.loopMeasureNone_eq_noMeasureLoops tss, + Block.loopMeasureNone_eq_noMeasureLoops ess] + | .loop g m inv body md => + rw [Stmt.loopMeasureNone, Stmt.noMeasureLoops, + Block.loopMeasureNone_eq_noMeasureLoops body] + | .exit lbl md => simp [Stmt.loopMeasureNone, Stmt.noMeasureLoops] + | .funcDecl d md => simp [Stmt.loopMeasureNone, Stmt.noMeasureLoops] + | .typeDecl t md => simp [Stmt.loopMeasureNone, Stmt.noMeasureLoops] + termination_by sizeOf s + +/-- `Block.loopMeasureNone` and `Block.noMeasureLoops` are the same predicate. -/ +theorem Block.loopMeasureNone_eq_noMeasureLoops {P : PureExpr} + (ss : List (Stmt P (Cmd P))) : + Block.loopMeasureNone ss = Block.noMeasureLoops ss := by + match ss with + | [] => simp [Block.loopMeasureNone, Block.noMeasureLoops] + | s :: rest => + rw [Block.loopMeasureNone, Block.noMeasureLoops, + Stmt.loopMeasureNone_eq_noMeasureLoops s, + Block.loopMeasureNone_eq_noMeasureLoops rest] + termination_by sizeOf ss +end + +--------------------------------------------------------------------- +/-! ## Section 1 — `noFuncDecl` ↔ `containsFuncDecl` duality + +`nondetElim` preserves `noFuncDecl` (proven in `NondetElim.lean`), while the +hoist §F precondition speaks of `containsFuncDecl = false`. The two are exact +negations; we prove the direction we need: `noFuncDecl = true` implies +`containsFuncDecl = false`. -/ + +mutual +/-- `Stmt.noFuncDecl s = true` implies `Stmt.containsFuncDecl s = false`. -/ +theorem Stmt.not_containsFuncDecl_of_noFuncDecl {P : PureExpr} + (s : Stmt P (Cmd P)) (h : Stmt.noFuncDecl s = true) : + Stmt.containsFuncDecl s = false := by + match s with + | .cmd c => rw [Stmt.containsFuncDecl] + | .block lbl bss md => + rw [Stmt.containsFuncDecl] + rw [Stmt.noFuncDecl] at h + exact Block.not_containsFuncDecl_of_noFuncDecl bss h + | .ite g tss ess md => + rw [Stmt.containsFuncDecl, Bool.or_eq_false_iff] + rw [Stmt.noFuncDecl, Bool.and_eq_true] at h + exact ⟨Block.not_containsFuncDecl_of_noFuncDecl tss h.1, + Block.not_containsFuncDecl_of_noFuncDecl ess h.2⟩ + | .loop g m inv body md => + rw [Stmt.containsFuncDecl] + rw [Stmt.noFuncDecl] at h + exact Block.not_containsFuncDecl_of_noFuncDecl body h + | .exit lbl md => rw [Stmt.containsFuncDecl] + | .funcDecl d md => rw [Stmt.noFuncDecl] at h; exact absurd h (by simp) + | .typeDecl t md => rw [Stmt.containsFuncDecl] + termination_by sizeOf s + +/-- `Block.noFuncDecl ss = true` implies `Block.containsFuncDecl ss = false`. -/ +theorem Block.not_containsFuncDecl_of_noFuncDecl {P : PureExpr} + (ss : List (Stmt P (Cmd P))) (h : Block.noFuncDecl ss = true) : + Block.containsFuncDecl ss = false := by + match ss with + | [] => rw [Block.containsFuncDecl] + | s :: rest => + rw [Block.containsFuncDecl, Bool.or_eq_false_iff] + rw [Block.noFuncDecl, Bool.and_eq_true] at h + exact ⟨Stmt.not_containsFuncDecl_of_noFuncDecl s h.1, + Block.not_containsFuncDecl_of_noFuncDecl rest h.2⟩ + termination_by sizeOf ss +end + +mutual +/-- `Stmt.containsFuncDecl s = false` implies `Stmt.noFuncDecl s = true`. -/ +theorem Stmt.noFuncDecl_of_not_containsFuncDecl {P : PureExpr} + (s : Stmt P (Cmd P)) (h : Stmt.containsFuncDecl s = false) : + Stmt.noFuncDecl s = true := by + match s with + | .cmd c => rw [Stmt.noFuncDecl] + | .block lbl bss md => + rw [Stmt.noFuncDecl]; rw [Stmt.containsFuncDecl] at h + exact Block.noFuncDecl_of_not_containsFuncDecl bss h + | .ite g tss ess md => + rw [Stmt.noFuncDecl, Bool.and_eq_true] + rw [Stmt.containsFuncDecl, Bool.or_eq_false_iff] at h + exact ⟨Block.noFuncDecl_of_not_containsFuncDecl tss h.1, + Block.noFuncDecl_of_not_containsFuncDecl ess h.2⟩ + | .loop g m inv body md => + rw [Stmt.noFuncDecl]; rw [Stmt.containsFuncDecl] at h + exact Block.noFuncDecl_of_not_containsFuncDecl body h + | .exit lbl md => rw [Stmt.noFuncDecl] + | .funcDecl d md => rw [Stmt.containsFuncDecl] at h; exact absurd h (by simp) + | .typeDecl t md => rw [Stmt.noFuncDecl] + termination_by sizeOf s + +/-- `Block.containsFuncDecl ss = false` implies `Block.noFuncDecl ss = true`. -/ +theorem Block.noFuncDecl_of_not_containsFuncDecl {P : PureExpr} + (ss : List (Stmt P (Cmd P))) (h : Block.containsFuncDecl ss = false) : + Block.noFuncDecl ss = true := by + match ss with + | [] => rw [Block.noFuncDecl] + | s :: rest => + rw [Block.noFuncDecl, Bool.and_eq_true] + rw [Block.containsFuncDecl, Bool.or_eq_false_iff] at h + exact ⟨Stmt.noFuncDecl_of_not_containsFuncDecl s h.1, + Block.noFuncDecl_of_not_containsFuncDecl rest h.2⟩ + termination_by sizeOf ss +end + +--------------------------------------------------------------------- +/-! ## Section 2 — `simpleShape` excludes nondeterministic loops + +`Block.simpleShape` admits a `.loop` only with a deterministic guard, so any +block satisfying `simpleShape` has `containsNondetLoop = false`. Combined with +`nondetElim_simpleShape`, this discharges the hoist §F precondition +`containsNondetLoop (nondetElim ss) = false`. -/ + +mutual +/-- A simple-shape statement contains no nondeterministic loop. -/ +theorem Stmt.not_containsNondetLoop_of_simpleShape {P : PureExpr} + (s : Stmt P (Cmd P)) (h : Stmt.simpleShape s = true) : + Stmt.containsNondetLoop s = false := by + match s with + | .cmd c => rw [Stmt.containsNondetLoop] + | .block lbl bss md => + rw [Stmt.containsNondetLoop] + rw [Stmt.simpleShape] at h + exact Block.not_containsNondetLoop_of_simpleShape bss h + | .ite (.det e) tss ess md => + rw [Stmt.containsNondetLoop, Bool.or_eq_false_iff] + rw [Stmt.simpleShape, Bool.and_eq_true] at h + exact ⟨Block.not_containsNondetLoop_of_simpleShape tss h.1, + Block.not_containsNondetLoop_of_simpleShape ess h.2⟩ + | .ite .nondet tss ess md => rw [Stmt.simpleShape] at h; exact absurd h (by simp) + | .loop (.det e) m inv body md => + rw [Stmt.containsNondetLoop] + rw [Stmt.simpleShape, Bool.and_eq_true] at h + exact Block.not_containsNondetLoop_of_simpleShape body h.2 + | .loop .nondet m inv body md => + rw [Stmt.simpleShape] at h; exact absurd h (by simp) + | .exit lbl md => rw [Stmt.containsNondetLoop] + | .funcDecl d md => rw [Stmt.containsNondetLoop] + | .typeDecl t md => rw [Stmt.containsNondetLoop] + termination_by sizeOf s + +/-- A simple-shape block contains no nondeterministic loop. -/ +theorem Block.not_containsNondetLoop_of_simpleShape {P : PureExpr} + (ss : List (Stmt P (Cmd P))) (h : Block.simpleShape ss = true) : + Block.containsNondetLoop ss = false := by + match ss with + | [] => rw [Block.containsNondetLoop] + | s :: rest => + rw [Block.containsNondetLoop, Bool.or_eq_false_iff] + rw [Block.simpleShape, Bool.and_eq_true] at h + exact ⟨Stmt.not_containsNondetLoop_of_simpleShape s h.1, + Block.not_containsNondetLoop_of_simpleShape rest h.2⟩ + termination_by sizeOf ss +end + +--------------------------------------------------------------------- +/-! ## Section 3 — Direction A: structural §F preconditions on `nondetElim` + +The hoist §F theorem `hoistLoopPrefixInits_preserves` takes the `nondetElim` +output as its input program. The structural (shape-only) §F preconditions are +discharged here from the corresponding facts on the source `ss`: + + * `containsNondetLoop = false` — established (nondetElim removes nondet loops), + * `containsFuncDecl = false` — preserved (from `noFuncDecl`), + * `loopHasNoInvariants = true` — preserved, + * `loopMeasureNone = true` — preserved (via `noMeasureLoops`). + +The hoist soundness theorem no longer requires the source to be exit-free, so no +`noExit` precondition is discharged here. The `loopMeasureNone` preservation is +net-new here; the other two reuse the `nondetElim_*` postconditions from +`NondetElim.lean`. -/ + +/-- nondetElim establishes the hoist §F `containsNondetLoop = false` precond. -/ +theorem nondetElim_containsNondetLoop {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) : + Block.containsNondetLoop (Block.nondetElim ss) = false := + Block.not_containsNondetLoop_of_simpleShape _ (nondetElim_simpleShape ss) + +/-- nondetElim preserves `containsFuncDecl = false` (via `noFuncDecl`). -/ +theorem nondetElim_containsFuncDecl {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (h : Block.noFuncDecl ss = true) : + Block.containsFuncDecl (Block.nondetElim ss) = false := + Block.not_containsFuncDecl_of_noFuncDecl _ (nondetElim_noFuncDecl ss h) + +-- No `noExit` bridge for `nondetElim`: a loop-body `.exit` in the user source is +-- admitted and faithfully simulated, so the composition need not carry `noExit`. + +--------------------------------------------------------------------- +/-! ## Section 4 — Direction B: structural simple-S2U preconditions on `hoist` + +The simple-S2U theorem `structuredToUnstructured_sound_kind` takes the hoist output +as its input program. Its structural (shape-only) preconditions are discharged +here from hoist's preservation/postcondition lemmas: + + * `noFuncDecl = true` — preserved (via `containsFuncDecl`), + * `simpleShape = true` — preserved (net-new chain in `LoopInitHoist`), + * `loopBodyNoInits = true` — established (hoist's raison d'être), + * `loopHasNoInvariants = true` — preserved, + * `noMeasureLoops = true` — preserved (via `loopMeasureNone`). + +The remaining simple-S2U preconditions (`uniqueInits`, `fresh_inits`, +`store_gens`, `NoGenSuffix`, `userLabelsShapeNodup`) are NAME-level conditions +on the hoist output's `initVars`/`modVars`, discharged by the composition in +the sections that follow. -/ + +variable {P : PureExpr} + +/-- Direction B: hoist preserves `noFuncDecl` (via `containsFuncDecl`). -/ +theorem hoist_noFuncDecl [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (h : Block.noFuncDecl ss = true) : + Block.noFuncDecl (Block.hoistLoopPrefixInits ss) = true := + Block.noFuncDecl_of_not_containsFuncDecl _ + (Block.hoistLoopPrefixInits_preserves_containsFuncDecl ss + (Block.not_containsFuncDecl_of_noFuncDecl ss h)) + +/-- Direction B: hoist preserves `simpleShape`. -/ +theorem hoist_simpleShape [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (h : Block.simpleShape ss = true) : + Block.simpleShape (Block.hoistLoopPrefixInits ss) = true := + Block.hoistLoopPrefixInits_preserves_simpleShape ss h + +/-- Direction B: hoist establishes `loopBodyNoInits` (its raison d'être). -/ +theorem hoist_loopBodyNoInits [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) : + Block.loopBodyNoInits (Block.hoistLoopPrefixInits ss) = true := + Block.hoistLoopPrefixInits_preserves_loopBodyNoInits ss + +/-- Direction B: hoist preserves `loopHasNoInvariants`. -/ +theorem hoist_loopHasNoInvariants [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (h : Block.loopHasNoInvariants ss = true) : + Block.loopHasNoInvariants (Block.hoistLoopPrefixInits ss) = true := + Block.hoistLoopPrefixInits_preserves_loopHasNoInvariants ss h + +/-- Direction B: hoist preserves `noMeasureLoops` (via `loopMeasureNone`). -/ +theorem hoist_noMeasureLoops [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (h : Block.noMeasureLoops ss = true) : + Block.noMeasureLoops (Block.hoistLoopPrefixInits ss) = true := by + rw [← Block.loopMeasureNone_eq_noMeasureLoops] at h ⊢ + exact Block.hoistLoopPrefixInits_preserves_loopMeasureNone ss h + +--------------------------------------------------------------------- +/-! ## Section 6 — Composition: from blanket suffix-shape to per-kind reasoning + +The structural bridges above (Sections 1–4) discharge every SHAPE-only +precondition of the chain. The remaining preconditions are NAME-SHAPE +conditions. Under the original *blanket* statements they could not be +discharged, because each pass's correctness theorem certified collision-freedom +by requiring the input to contain NO `_`-suffixed name AT ALL — a +suffix-shape exclusion rather than a prefix-disjointness one: + + * `nondetElim → hoist` (direction A) needed + `exprsShapeFree (Block.nondetElim ss)` and + `hoistedNamesFreshInRhsAndGuards (Block.nondetElim ss)`. Both are FALSE + under the blanket reading: `nondetElim` emits `.ite (.det (fvar g))` / + `.loop (.det (fvar g))` guards whose read-var `g = $__ndelim_*$_n` is + suffix-shaped *and* is a top-level `init`-var, so the suffix-shape guard + conjuncts demand `g ∉ getVars (fvar g) = [g]` — a contradiction. + + * `hoist → str2unstr` (direction B) needed + `NoGenSuffix (initVars (hoist …))` and + `NoGenSuffix (transformBlockModVars (hoist …))`, both FALSE because hoist + lifts loop-body inits under fresh `_hoist_n` names, which are suffix-shaped. + +**Resolution.** The obstruction is dissolved on two axes, and the +chain is closed in `pipeline_sound` (Section 11): + + 1. *Per-kind generalization.* The three `_sound_kind` theorems replace the + blanket `HasUnderscoreDigitSuffix` exclusion with a `Kind` predicate `Q` + (`ndelimKind` / `hoistKind` / `s2uKind`). The generated namespaces are + prefix-disjoint (Section 7's foreignness lemmas: `ndelimKind`/`hoistKind`/ + `s2uKind` are pairwise non-overlapping), so each cross-pass name-shape leaf + `∀ str, Q str → ident str ∉ …` is *vacuous on a foreign upstream name* + (Sections 8–10's output classifications: every output read-var, init-var + and mod-var is upstream-kind-or-source, hence `¬ Q`). + + 2. *RHS-only freshness.* The remaining obligation the per-kind axis does NOT + cover — `hoistedNamesFreshInRhsAndGuards`, the `initVars`-freshness whose + `.ite`/`.loop` *guard*-read clause is the false one above — is relaxed to + `namesFreshInRhsExprs`, which checks only command-RHS read positions (the + guard-read clauses were already dead in every consumption site of the hoist + proof; guard agreement for a loop's body inits comes from their + undefinedness at the loop head, discharged inside the loop driver). + `nondetElim` then *preserves* this RHS-only freshness + (`nondetElim_hoistedNamesFreshInRhsAndGuards`, Section 10), because it reads + its fresh guard only in a guard, never in a command RHS. + +No precondition is papered over with a false or vacuous-on-the-interesting-input +hypothesis: every `pipeline_sound` precondition is satisfiable by a clean +initial store and a shape-restricted, kind-free user program. -/ + +--------------------------------------------------------------------- +/-! ## Section 7 — Cross-pass foreignness of minted names + +The kind-generalized soundness theorems (`nondetElim_sound_kind`, +`hoistLoopPrefixInits_preserves_kind`, `structuredToUnstructured_sound_kind`) +replace the blanket `HasUnderscoreDigitSuffix` exclusion of Section 6 with +per-kind reasoning, so the cross-pass name-shape preconditions become +*vacuous on foreign names*: each leaf has the form `∀ str, Q str → …`, and an +upstream-minted name `str` satisfies `¬ Q str` for the downstream kind `Q`, +discharging the implication trivially. + +The two lemmas below supply that foreignness. Each refutes the downstream +`Kind` predicate on an upstream mint by showing the generator prefixes disagree +at character `0`: every disjunct of the downstream kind carries some literal +`HasGenPrefix pfᵢ` clause, but the upstream mint begins with a different literal +character, so `(pfᵢ ++ "_").toList.isPrefixOf _` is `false`. The reverse +disjointness (hoist mint ∉ ndelimKind) follows by the same head-clash argument +with the two prefixes swapped. -/ + +/-- A name minted by `nondetElim` (under `ndelimItePrefix` or `ndelimLoopPrefix`, +both beginning with `$`) is *not* a `hoistKind` label (`hoistFreshPrefix` begins +with `_`). This is the Direction-A foreignness fact: every read-var / init-var / +modified-var that `nondetElim` introduces is `ndelimKind`, hence `¬ hoistKind`, +so the hoist pass's `exprsShapeFree`/`*_shapefree` leaves are vacuous on the +`nondetElim` output. -/ +theorem ndelim_name_not_hoistKind (sg : StringGenState) : + ¬ hoistKind (StringGenState.gen ndelimItePrefix sg).1 + ∧ ¬ hoistKind (StringGenState.gen ndelimLoopPrefix sg).1 := by + refine ⟨?_, ?_⟩ <;> + · rw [StringGenState.gen_eq] + rintro ⟨_, hpref, _⟩ + simp only [String.HasGenPrefix, hoistFreshPrefix, ndelimItePrefix, + ndelimLoopPrefix, String.toList_append] at hpref + simp [List.isPrefixOf] at hpref + +/-- A name minted by `hoistLoopPrefixInits` (under `hoistFreshPrefix`, beginning +with `_`) is *not* an `s2uKind` label. Each of the thirteen `s2uKind` disjuncts +carries a literal generator prefix beginning with one of `i`, `$`, `l`, `m`, +`e`, `b` — and the parametric `block${l}$` disjunct always begins with `b` for +*every* `l` — none of which is `_`, so the hoist mint disagrees with each at +character `0`. This is the Direction-B foreignness fact: every `initVars` / +`transformBlockModVars` name the hoist pass freshly introduces is `hoistKind`, +hence `¬ s2uKind`, so the S2U pass's `NoGenSuffix` leaves are vacuous on the +hoist output's fresh names. -/ +theorem hoist_name_not_s2uKind (sg : StringGenState) : + ¬ StructuredToUnstructuredCorrect.s2uKind + (StringGenState.gen hoistFreshPrefix sg).1 := by + rw [StringGenState.gen_eq] + -- Each disjunct yields `hpref : HasGenPrefix pfᵢ (hoistFreshPrefix ++ "_" ++ …)`. + -- Unfold to a `List.isPrefixOf` over `toList`, then read off the prefix's head: + -- for the twelve fixed prefixes `pfᵢ.toList` reduces to a literal `c :: …`, and + -- for the parametric `block$⟨l⟩$` disjunct the head `toString "block$"` still + -- reduces to `'b' :: …` even though `l` blocks full reduction. In every case + -- the head is `≠ '_'`, the head of the `hoistFreshPrefix` (`"_hoist"`) name, so + -- the prefix relation is refuted by a head clash. + rintro (⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | + ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | + ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | + ⟨l, _, hpref, _⟩) <;> + simp only [String.HasGenPrefix, hoistFreshPrefix, String.toList_append] at hpref <;> + · rw [List.isPrefixOf_iff_prefix] at hpref + obtain ⟨t, ht⟩ := hpref + simp only [String.toList, show (toString "block$") = "block$" from rfl] at ht + exact absurd (List.cons.inj ht).1 (by decide) + +/-- A name minted by `nondetElim` (under `ndelimItePrefix`/`ndelimLoopPrefix`, +both beginning `$__ndelim_`) is *not* an `s2uKind` label. Eleven of the thirteen +`s2uKind` prefixes disagree with `$` at character `0`; the two `$`-leading S2U +prefixes (`$__nondet_ite$`, `$__nondet_loop$`) agree through `$__n` but diverge at +character `4` (`o` vs. the ndelim `d`), so the prefix relation is still refuted by +a (deeper) head clash. This is the Direction-B foreignness fact for the *ndelim* +names that survive into the hoist output's `initVars`/`modVars`: they are not +`s2uKind`, so the S2U `NoGenSuffix` leaves are vacuous on them. -/ +theorem ndelim_name_not_s2uKind (sg : StringGenState) : + ¬ StructuredToUnstructuredCorrect.s2uKind (StringGenState.gen ndelimItePrefix sg).1 + ∧ ¬ StructuredToUnstructuredCorrect.s2uKind (StringGenState.gen ndelimLoopPrefix sg).1 := by + refine ⟨?_, ?_⟩ <;> + · rw [StringGenState.gen_eq] + rintro (⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | + ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | + ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | ⟨_, hpref, _⟩ | + ⟨_, _, hpref, _⟩) <;> + simp only [String.HasGenPrefix, ndelimItePrefix, ndelimLoopPrefix, + String.toList_append] at hpref <;> + · rw [List.isPrefixOf_iff_prefix] at hpref + obtain ⟨t, ht⟩ := hpref + simp only [String.toList, show (toString "block$") = "block$" from rfl] at ht + -- character 0 clash for the eleven non-`$` prefixes; character 4 clash + -- (`o`/`n` vs. ndelim `d`) for the two `$`-leading nondet prefixes. + first + | exact absurd (List.cons.inj ht).1 (by decide) + | exact absurd + (List.cons.inj (List.cons.inj (List.cons.inj + (List.cons.inj (List.cons.inj ht).2).2).2).2).1 (by decide) + +/-- Kind-level form of the Direction-A foreignness: any `ndelimKind` string is +not a `hoistKind` string. (Unpacks the `ndelimKind` witness to a `gen` output +and applies `ndelim_name_not_hoistKind`.) -/ +theorem ndelimKind_not_hoistKind {s : String} (h : ndelimKind s) : ¬ hoistKind s := by + rcases h with ⟨sg, _, he⟩ | ⟨sg, _, he⟩ + · exact he ▸ (ndelim_name_not_hoistKind sg).1 + · exact he ▸ (ndelim_name_not_hoistKind sg).2 + +/-- Kind-level form: any `ndelimKind` string is not an `s2uKind` string. -/ +theorem ndelimKind_not_s2uKind {s : String} (h : ndelimKind s) : + ¬ StructuredToUnstructuredCorrect.s2uKind s := by + rcases h with ⟨sg, _, he⟩ | ⟨sg, _, he⟩ + · exact he ▸ (ndelim_name_not_s2uKind sg).1 + · exact he ▸ (ndelim_name_not_s2uKind sg).2 + +/-- Kind-level form: any `hoistKind` string is not an `s2uKind` string. -/ +theorem hoistKind_not_s2uKind {s : String} (h : hoistKind s) : + ¬ StructuredToUnstructuredCorrect.s2uKind s := by + obtain ⟨sg, _, he⟩ := h + exact he ▸ hoist_name_not_s2uKind sg + +--------------------------------------------------------------------- +/-! ## Section 8 — Direction A: `nondetElim` output name classification + +The hoist §F preconditions at `Q := hoistKind` (`exprsShapeFree`, the +`*_shapefree` `initVars`/`modVars` leaves) reach into the *whole* `nondetElim` +output, not just its source-inherited names. Their leaves all have the shape +`∀ str, Q str → ident str ∉ …`, and to make them vacuous on the `nondetElim` +output we classify every name the pass can introduce: + + * every `initVars` / `modVars` name of the output is either a *source* name + (inherited verbatim) or a freshly-minted `ndelimKind` guard ident, and + * every read-var the output mentions is either a source read-var or, in the + two `.nondet` arms, the freshly-minted guard `mkFvar (ndelim ident)` — + which is `ndelimKind`, foreign to `hoistKind`. + +The classification (`*_classified`) drives the `*_shapefree` leaves; the +`exprsShapeFree` preservation (`*_exprsShapeFree`) drives the guard leaf. Both +are parametric in the downstream kind `Q` *and* a foreignness witness +(`¬ Q ndelim-name`), so instantiating `Q := hoistKind` with +`ndelim_name_not_hoistKind` discharges Direction A. -/ + +/-- `Block.initVars` distributes over list append. -/ +theorem Block.initVars_append (xs ys : List (Stmt P (Cmd P))) : + Block.initVars (xs ++ ys) = Block.initVars xs ++ Block.initVars ys := by + induction xs with + | nil => simp [Block.initVars] + | cons x rest ih => + simp only [List.cons_append, Block.initVars_cons, ih, List.append_assoc] + +/-- `Block.modifiedVars` distributes over list append. -/ +theorem Block.modifiedVars_append (xs ys : List (Stmt P (Cmd P))) : + Block.modifiedVars (xs ++ ys) = Block.modifiedVars xs ++ Block.modifiedVars ys := by + induction xs with + | nil => simp [Block.modifiedVars] + | cons x rest ih => + simp only [List.cons_append, Block.modifiedVars, ih, List.append_assoc] + +/-- An `init` command modifies nothing (it *defines*, not modifies). -/ +private theorem init_modVars (x : P.Ident) (ty : P.Ty) (e : ExprOrNondet P) + (md : MetaData P) : + HasVarsImp.modifiedVars (HasInit.init (CmdT := Cmd P) x ty e md) = + ([] : List P.Ident) := by + with_unfolding_all rfl + +/-- A `havoc x` command modifies exactly `[x]`. -/ +private theorem havoc_modVars (x : P.Ident) (md : MetaData P) : + HasVarsImp.modifiedVars (HasHavoc.havoc (CmdT := Cmd P) x md) = [x] := by + with_unfolding_all rfl + +mutual +/-- Every `initVars` element of the `nondetElim` output of a statement is either +an original source `initVars` element or a freshly-minted `ndelimKind` guard. -/ +theorem Stmt.nondetElimM_initVars_classified [HasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + ∀ x ∈ Block.initVars (P := P) (Stmt.nondetElimM s σ).1, + x ∈ Stmt.initVars s ∨ + (∃ str : String, x = HasIdent.ident (P := P) str ∧ ndelimKind str) := by + match s with + | .cmd c => + intro x hx + simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, List.append_nil] at hx + exact Or.inl hx + | .block lbl bss md => + intro x hx + rw [Stmt.nondetElimM_block_out] at hx + simp only [Block.initVars_cons, Stmt.initVars_block, Block.initVars, + List.append_nil] at hx ⊢ + exact Block.nondetElimM_initVars_classified bss σ x hx + | .ite (.det e) tss ess md => + intro x hx + rw [Stmt.nondetElimM_ite_det_out] at hx + simp only [Block.initVars_cons, Stmt.initVars_ite, Block.initVars, + List.append_nil, List.mem_append] at hx ⊢ + rcases hx with h | h + · rcases Block.nondetElimM_initVars_classified tss σ x h with h' | h' + · exact Or.inl (Or.inl h') + · exact Or.inr h' + · rcases Block.nondetElimM_initVars_classified ess _ x h with h' | h' + · exact Or.inl (Or.inr h') + · exact Or.inr h' + | .ite .nondet tss ess md => + intro x hx + rw [Stmt.nondetElimM_ite_nondet_out] at hx + rw [Block.initVars_cons] at hx + rw [show Stmt.initVars (P := P) + (Stmt.cmd (HasInit.init (HasIdent.ident (P := P) (StringGenState.gen ndelimItePrefix σ).1) + HasBool.boolTy ExprOrNondet.nondet md)) = + [HasIdent.ident (P := P) (StringGenState.gen ndelimItePrefix σ).1] + from by with_unfolding_all rfl] at hx + simp only [Stmt.initVars_ite, Block.initVars_cons, Block.initVars, List.append_nil, + List.singleton_append, List.mem_cons, List.mem_append] at hx ⊢ + rcases hx with h_g | h_t | h_e + · exact Or.inr ⟨(StringGenState.gen ndelimItePrefix σ).1, h_g, ndelimKind_gen.1 σ⟩ + · rcases Block.nondetElimM_initVars_classified tss _ x h_t with h' | h' + · exact Or.inl (Or.inl h') + · exact Or.inr h' + · rcases Block.nondetElimM_initVars_classified ess _ x h_e with h' | h' + · exact Or.inl (Or.inr h') + · exact Or.inr h' + | .loop (.det e) m inv body md => + intro x hx + rw [Stmt.nondetElimM_loop_det_out] at hx + simp only [Block.initVars_cons, Stmt.initVars_loop, Block.initVars, + List.append_nil] at hx ⊢ + exact Block.nondetElimM_initVars_classified body σ x hx + | .loop .nondet m inv body md => + intro x hx + rw [Stmt.nondetElimM_loop_nondet_out] at hx + rw [Block.initVars_cons] at hx + rw [show Stmt.initVars (P := P) + (Stmt.cmd (HasInit.init (HasIdent.ident (P := P) (StringGenState.gen ndelimLoopPrefix σ).1) + HasBool.boolTy ExprOrNondet.nondet md)) = + [HasIdent.ident (P := P) (StringGenState.gen ndelimLoopPrefix σ).1] + from by with_unfolding_all rfl] at hx + have h_havoc : Block.initVars (P := P) + [Stmt.cmd (HasHavoc.havoc (HasIdent.ident (P := P) (StringGenState.gen ndelimLoopPrefix σ).1) md)] = [] := by + with_unfolding_all rfl + simp only [Stmt.initVars_loop, Block.initVars_cons, Block.initVars, List.append_nil, + List.singleton_append, List.mem_cons] at hx ⊢ + rcases hx with h_g | h_body + · exact Or.inr ⟨(StringGenState.gen ndelimLoopPrefix σ).1, h_g, ndelimKind_gen.2 σ⟩ + · rw [Block.initVars_append, h_havoc, List.append_nil] at h_body + rcases Block.nondetElimM_initVars_classified body _ x h_body with h' | h' + · exact Or.inl h' + · exact Or.inr h' + | .exit lbl md => + intro x hx + simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, Stmt.initVars, + List.append_nil] at hx + exact absurd hx List.not_mem_nil + | .funcDecl d md => + intro x hx + simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, Stmt.initVars, + List.append_nil] at hx + exact absurd hx List.not_mem_nil + | .typeDecl t md => + intro x hx + simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, Stmt.initVars, + List.append_nil] at hx + exact absurd hx List.not_mem_nil + termination_by sizeOf s + +/-- Block-level `initVars` classification of the `nondetElim` output. -/ +theorem Block.nondetElimM_initVars_classified [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + ∀ x ∈ Block.initVars (P := P) (Block.nondetElimM ss σ).1, + x ∈ Block.initVars ss ∨ + (∃ str : String, x = HasIdent.ident (P := P) str ∧ ndelimKind str) := by + match ss with + | [] => + intro x hx + simp only [Block.nondetElimM, Block.initVars] at hx + exact absurd hx List.not_mem_nil + | s :: rest => + intro x hx + rw [Block.nondetElimM_cons_out, Block.initVars_append] at hx + simp only [List.mem_append] at hx + rw [Block.initVars_cons, List.mem_append] + rcases hx with h | h + · rcases Stmt.nondetElimM_initVars_classified s σ x h with h' | h' + · exact Or.inl (Or.inl h') + · exact Or.inr h' + · rcases Block.nondetElimM_initVars_classified rest _ x h with h' | h' + · exact Or.inl (Or.inr h') + · exact Or.inr h' + termination_by sizeOf ss +end + +mutual +/-- Every `modifiedVars` element of the `nondetElim` output of a statement is +either an original source `modifiedVars` element or a freshly-minted +`ndelimKind` guard (the loop re-havoc target). -/ +theorem Stmt.nondetElimM_modVars_classified [HasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + ∀ x ∈ Block.modifiedVars (P := P) (Stmt.nondetElimM s σ).1, + x ∈ Stmt.modifiedVars s ∨ + (∃ str : String, x = HasIdent.ident (P := P) str ∧ ndelimKind str) := by + match s with + | .cmd c => + intro x hx + simp only [Stmt.nondetElimM, Block.modifiedVars, List.append_nil] at hx + exact Or.inl hx + | .block lbl bss md => + intro x hx + rw [Stmt.nondetElimM_block_out] at hx + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil] at hx ⊢ + exact Block.nondetElimM_modVars_classified bss σ x hx + | .ite (.det e) tss ess md => + intro x hx + rw [Stmt.nondetElimM_ite_det_out] at hx + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil, List.mem_append] at hx ⊢ + rcases hx with h | h + · rcases Block.nondetElimM_modVars_classified tss σ x h with h' | h' + · exact Or.inl (Or.inl h') + · exact Or.inr h' + · rcases Block.nondetElimM_modVars_classified ess _ x h with h' | h' + · exact Or.inl (Or.inr h') + · exact Or.inr h' + | .ite .nondet tss ess md => + intro x hx + rw [Stmt.nondetElimM_ite_nondet_out] at hx + simp only [Block.modifiedVars, Stmt.modifiedVars, init_modVars, List.nil_append, + List.append_nil, List.mem_append] at hx ⊢ + rcases hx with h | h + · rcases Block.nondetElimM_modVars_classified tss _ x h with h' | h' + · exact Or.inl (Or.inl h') + · exact Or.inr h' + · rcases Block.nondetElimM_modVars_classified ess _ x h with h' | h' + · exact Or.inl (Or.inr h') + · exact Or.inr h' + | .loop (.det e) m inv body md => + intro x hx + rw [Stmt.nondetElimM_loop_det_out] at hx + simp only [Block.modifiedVars, Stmt.modifiedVars, List.append_nil] at hx ⊢ + exact Block.nondetElimM_modVars_classified body σ x hx + | .loop .nondet m inv body md => + intro x hx + rw [Stmt.nondetElimM_loop_nondet_out] at hx + simp only [Block.modifiedVars, Stmt.modifiedVars, init_modVars, List.nil_append, + List.append_nil] at hx ⊢ + rw [Block.modifiedVars_append] at hx + simp only [Block.modifiedVars, Stmt.modifiedVars, havoc_modVars, List.append_nil, + List.mem_append, List.mem_singleton] at hx ⊢ + rcases hx with h | h_g + · rcases Block.nondetElimM_modVars_classified body _ x h with h' | h' + · exact Or.inl h' + · exact Or.inr h' + · exact Or.inr ⟨(StringGenState.gen ndelimLoopPrefix σ).1, h_g, ndelimKind_gen.2 σ⟩ + | .exit lbl md => + intro x hx + simp only [Stmt.nondetElimM, Block.modifiedVars, Stmt.modifiedVars, List.append_nil] at hx + exact absurd hx List.not_mem_nil + | .funcDecl d md => + intro x hx + simp only [Stmt.nondetElimM, Block.modifiedVars, Stmt.modifiedVars, List.append_nil] at hx + exact absurd hx List.not_mem_nil + | .typeDecl t md => + intro x hx + simp only [Stmt.nondetElimM, Block.modifiedVars, Stmt.modifiedVars, List.append_nil] at hx + exact absurd hx List.not_mem_nil + termination_by sizeOf s + +/-- Block-level `modifiedVars` classification of the `nondetElim` output. -/ +theorem Block.nondetElimM_modVars_classified [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + ∀ x ∈ Block.modifiedVars (P := P) (Block.nondetElimM ss σ).1, + x ∈ Block.modifiedVars ss ∨ + (∃ str : String, x = HasIdent.ident (P := P) str ∧ ndelimKind str) := by + match ss with + | [] => + intro x hx + simp only [Block.nondetElimM, Block.modifiedVars] at hx + exact absurd hx List.not_mem_nil + | s :: rest => + intro x hx + rw [Block.nondetElimM_cons_out, Block.modifiedVars_append] at hx + simp only [List.mem_append] at hx + simp only [Block.modifiedVars, List.mem_append] + rcases hx with h | h + · rcases Stmt.nondetElimM_modVars_classified s σ x h with h' | h' + · exact Or.inl (Or.inl h') + · exact Or.inr h' + · rcases Block.nondetElimM_modVars_classified rest _ x h with h' | h' + · exact Or.inl (Or.inr h') + · exact Or.inr h' + termination_by sizeOf ss +end + +/-- `Block.exprsShapeFree Q` distributes over list append. -/ +theorem Block.exprsShapeFree_append [HasIdent P] [HasVarsPure P P.Expr] {Q : String → Prop} + (xs ys : List (Stmt P (Cmd P))) + (h : Block.exprsShapeFree (P := P) Q xs ∧ Block.exprsShapeFree (P := P) Q ys) : + Block.exprsShapeFree (P := P) Q (xs ++ ys) := by + induction xs with + | nil => simpa only [List.nil_append] using h.2 + | cons x rest ih => + rw [List.cons_append, Block.exprsShapeFree] + rw [Block.exprsShapeFree] at h + exact ⟨h.1.1, ih ⟨h.1.2, h.2⟩⟩ + +/-- A `.cmd (init _ _ .nondet _)` reads nothing, so it is `exprsShapeFree`. -/ +private theorem init_nondet_sf [HasIdent P] [HasVarsPure P P.Expr] {Q : String → Prop} (ident : P.Ident) (ty : P.Ty) + (md : MetaData P) : + Stmt.exprsShapeFree (P := P) Q (Stmt.cmd (HasInit.init ident ty ExprOrNondet.nondet md)) := by + show Stmt.exprsShapeFree (P := P) Q (Stmt.cmd (Cmd.init ident ty ExprOrNondet.nondet md)) + simp only [Stmt.exprsShapeFree, ExprOrNondet.getVars] + exact fun str _ hmem => absurd hmem List.not_mem_nil + +/-- A `.cmd (havoc _)` reads nothing, so it is `exprsShapeFree`. -/ +private theorem havoc_sf [HasIdent P] [HasVarsPure P P.Expr] {Q : String → Prop} (ident : P.Ident) (md : MetaData P) : + Stmt.exprsShapeFree (P := P) Q (Stmt.cmd (HasHavoc.havoc ident md)) := by + show Stmt.exprsShapeFree (P := P) Q (Stmt.cmd (Cmd.set ident ExprOrNondet.nondet md)) + simp only [Stmt.exprsShapeFree, ExprOrNondet.getVars] + exact fun str _ hmem => absurd hmem List.not_mem_nil + +/-- The freshly minted ndelim guard ident is `∉ getVars` of any `Q`-foreign +read-var slot: the only read is `mkFvar ident` whose vars ⊆ `[ident]` and `ident` +carries the ndelim kind, foreign to `Q`. -/ +private theorem ndelim_guard_fresh [HasIdent P] [HasFvar P] [HasVarsPure P P.Expr] + [LawfulHasFvar P] [LawfulHasIdent P] {Q : String → Prop} + (pf : String) (σ : StringGenState) + (hforeign : ¬ Q (StringGenState.gen pf σ).1) : + ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ + HasVarsPure.getVars (P := P) + (HasFvar.mkFvar (HasIdent.ident (P := P) (StringGenState.gen pf σ).1)) := by + intro str hQ hmem + have hin : HasIdent.ident (P := P) str ∈ + [HasIdent.ident (P := P) (StringGenState.gen pf σ).1] := + LawfulHasFvar.mkFvar_getVars (P := P) _ hmem + rw [List.mem_singleton] at hin + exact hforeign (LawfulHasIdent.ident_inj hin ▸ hQ) + +/-- Transport `exprsShapeFree` across a `.loop` whose guard/body are replaced but +whose measure/invariants are unchanged: the measure/invariant freshness conjuncts +carry over verbatim from the source loop. -/ +private theorem loop_sf_transport [HasIdent P] [HasVarsPure P P.Expr] {Q : String → Prop} (g₀ g₁ : ExprOrNondet P) + (m : Option P.Expr) (inv : List (String × P.Expr)) + (body₀ body₁ : List (Stmt P (Cmd P))) (md : MetaData P) + (h : Stmt.exprsShapeFree (P := P) Q (.loop g₀ m inv body₀ md)) + (hg : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ ExprOrNondet.getVars (P := P) g₁) + (hb : Block.exprsShapeFree (P := P) Q body₁) : + Stmt.exprsShapeFree (P := P) Q (.loop g₁ m inv body₁ md) := by + rw [Stmt.exprsShapeFree.eq_def] at h ⊢ + exact ⟨hg, h.2.1, h.2.2.1, hb⟩ + +mutual +/-- `nondetElim` preserves `exprsShapeFree Q`, provided the labels it mints (the +two ndelim guard prefixes) are foreign to `Q`: source read-vars stay `Q`-free, +and the only new read-var is the freshly-minted guard ident, which is `¬ Q` by +foreignness. -/ +theorem Stmt.nondetElimM_exprsShapeFree [HasIdent P] [HasFvar P] [HasBool P] [HasVarsPure P P.Expr] + [LawfulHasFvar P] [LawfulHasIdent P] {Q : String → Prop} + (hfi : ∀ sg, ¬ Q (StringGenState.gen ndelimItePrefix sg).1) + (hfl : ∀ sg, ¬ Q (StringGenState.gen ndelimLoopPrefix sg).1) + (s : Stmt P (Cmd P)) (σ : StringGenState) + (h : Stmt.exprsShapeFree (P := P) Q s) : + Block.exprsShapeFree (P := P) Q (Stmt.nondetElimM s σ).1 := by + match s with + | .cmd c => + simp only [Stmt.nondetElimM, Block.exprsShapeFree] + exact ⟨h, trivial⟩ + | .block lbl bss md => + rw [Stmt.nondetElimM_block_out] + simp only [Stmt.exprsShapeFree] at h + simp only [Block.exprsShapeFree, Stmt.exprsShapeFree, and_true] + exact Block.nondetElimM_exprsShapeFree hfi hfl bss σ h + | .ite (.det e) tss ess md => + rw [Stmt.nondetElimM_ite_det_out] + simp only [Stmt.exprsShapeFree] at h + simp only [Block.exprsShapeFree, Stmt.exprsShapeFree, and_true] + exact ⟨h.1, Block.nondetElimM_exprsShapeFree hfi hfl tss σ h.2.1, + Block.nondetElimM_exprsShapeFree hfi hfl ess _ h.2.2⟩ + | .ite .nondet tss ess md => + rw [Stmt.nondetElimM_ite_nondet_out] + simp only [Stmt.exprsShapeFree] at h + simp only [Block.exprsShapeFree, and_true] + refine ⟨init_nondet_sf _ _ _, ?_⟩ + simp only [Stmt.exprsShapeFree] + refine ⟨ndelim_guard_fresh ndelimItePrefix σ (hfi σ), + Block.nondetElimM_exprsShapeFree hfi hfl tss _ h.2.1, + Block.nondetElimM_exprsShapeFree hfi hfl ess _ h.2.2⟩ + | .loop (.det e) m inv body md => + rw [Stmt.nondetElimM_loop_det_out] + have hg : ∀ str : String, Q str → + HasIdent.ident (P := P) str ∉ ExprOrNondet.getVars (P := P) (.det e) := by + rw [Stmt.exprsShapeFree.eq_def] at h; exact h.1 + have hbody : Block.exprsShapeFree (P := P) Q body := by + rw [Stmt.exprsShapeFree.eq_def] at h; exact h.2.2.2 + simp only [Block.exprsShapeFree, and_true] + exact loop_sf_transport (.det e) (.det e) m inv body _ md h hg + (Block.nondetElimM_exprsShapeFree hfi hfl body σ hbody) + | .loop .nondet m inv body md => + rw [Stmt.nondetElimM_loop_nondet_out] + have hbody : Block.exprsShapeFree (P := P) Q body := by + rw [Stmt.exprsShapeFree.eq_def] at h; exact h.2.2.2 + simp only [Block.exprsShapeFree, and_true] + refine ⟨init_nondet_sf _ _ _, ?_⟩ + refine loop_sf_transport .nondet + (.det (HasFvar.mkFvar (HasIdent.ident (P := P) (StringGenState.gen ndelimLoopPrefix σ).1))) + m inv body _ md h + (ndelim_guard_fresh ndelimLoopPrefix σ (hfl σ)) ?_ + refine Block.exprsShapeFree_append _ _ + ⟨Block.nondetElimM_exprsShapeFree hfi hfl body _ hbody, ?_⟩ + simp only [Block.exprsShapeFree, and_true] + exact havoc_sf _ _ + | .exit lbl md => + simp only [Stmt.nondetElimM, Block.exprsShapeFree, Stmt.exprsShapeFree, and_true] + | .funcDecl d md => + simp only [Stmt.nondetElimM, Block.exprsShapeFree, Stmt.exprsShapeFree, and_true] + | .typeDecl t md => + simp only [Stmt.nondetElimM, Block.exprsShapeFree, Stmt.exprsShapeFree, and_true] + termination_by sizeOf s + +/-- Block-level `exprsShapeFree Q` preservation through `nondetElim`. -/ +theorem Block.nondetElimM_exprsShapeFree [HasIdent P] [HasFvar P] [HasBool P] [HasVarsPure P P.Expr] + [LawfulHasFvar P] [LawfulHasIdent P] {Q : String → Prop} + (hfi : ∀ sg, ¬ Q (StringGenState.gen ndelimItePrefix sg).1) + (hfl : ∀ sg, ¬ Q (StringGenState.gen ndelimLoopPrefix sg).1) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h : Block.exprsShapeFree (P := P) Q ss) : + Block.exprsShapeFree (P := P) Q (Block.nondetElimM ss σ).1 := by + match ss with + | [] => + simp only [Block.nondetElimM, Block.exprsShapeFree] + | s :: rest => + rw [Block.nondetElimM_cons_out] + simp only [Block.exprsShapeFree] at h + exact Block.exprsShapeFree_append _ _ + ⟨Stmt.nondetElimM_exprsShapeFree hfi hfl s σ h.1, + Block.nondetElimM_exprsShapeFree hfi hfl rest _ h.2⟩ + termination_by sizeOf ss +end + +--------------------------------------------------------------------- +/-\! ## Section 9 — Direction A: `nondetElim` output `uniqueInits` + +The hoist §F precondition `Block.uniqueInits (nondetElim ss)` (= `Nodup` of the +output `initVars`) is established by a window-tracked classification that +mirrors the loop-init-hoist `_initVars_classified`: every output init name is +either an original source init (a member of `Block.initVars ss`) or a +freshly-minted `ndelimKind` guard captured in a `gen`-step window disjoint from +its neighbours. Distinctness across the source/source, source/fresh, and +fresh/fresh classes is exactly `hoistInitClass_disjoint` (pass-agnostic in `Q` +and the carrier), reused here at `Q := ndelimKind`. The source-side +`h_sf` hypothesis (no ndelim-kind name is a source init) is discharged at the +top level from a kind-free front-end source. -/ + +section NondetElimUniqueInits +variable {P : PureExpr} + +local notation "HoistInitClass" => LoopInitHoistLoopArmWF.HoistInitClass +local notation "hoistInitClass_disjoint" => @LoopInitHoistLoopArmWF.hoistInitClass_disjoint +local notation "GenStep" => StringGenState.GenStep + +theorem Stmt.nondetElimM_block_state [HasIdent P] [HasFvar P] [HasBool P] (lbl : String) (bss : List (Stmt P (Cmd P))) + (md : MetaData P) (σ : StringGenState) : + (Stmt.nondetElimM (.block lbl bss md) σ).2 = (Block.nondetElimM bss σ).2 := by + rw [Stmt.nondetElimM]; rcases h : Block.nondetElimM bss σ with ⟨bss', σ'⟩; simp only [h] + +theorem Stmt.nondetElimM_ite_det_state [HasIdent P] [HasFvar P] [HasBool P] (e : P.Expr) (tss ess : List (Stmt P (Cmd P))) + (md : MetaData P) (σ : StringGenState) : + (Stmt.nondetElimM (.ite (.det e) tss ess md) σ).2 = + (Block.nondetElimM ess (Block.nondetElimM tss σ).2).2 := by + rw [Stmt.nondetElimM] + rcases h₁ : Block.nondetElimM tss σ with ⟨tss', σ₁⟩ + rcases h₂ : Block.nondetElimM ess σ₁ with ⟨ess', σ₂⟩ + simp only [h₁, h₂] + +theorem Stmt.nondetElimM_ite_nondet_state [HasIdent P] [HasFvar P] [HasBool P] (tss ess : List (Stmt P (Cmd P))) + (md : MetaData P) (σ : StringGenState) : + (Stmt.nondetElimM (.ite .nondet tss ess md) σ).2 = + (Block.nondetElimM ess (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).2).2 := by + rw [Stmt.nondetElimM] + rcases hg : StringGenState.gen ndelimItePrefix σ with ⟨g, σ₁⟩ + rcases h₁ : Block.nondetElimM tss σ₁ with ⟨tss', σ₂⟩ + rcases h₂ : Block.nondetElimM ess σ₂ with ⟨ess', σ₃⟩ + simp only [hg, h₁, h₂] + +theorem Stmt.nondetElimM_loop_det_state [HasIdent P] [HasFvar P] [HasBool P] (e : P.Expr) (m : Option P.Expr) + (inv : List (String × P.Expr)) (body : List (Stmt P (Cmd P))) + (md : MetaData P) (σ : StringGenState) : + (Stmt.nondetElimM (.loop (.det e) m inv body md) σ).2 = (Block.nondetElimM body σ).2 := by + rw [Stmt.nondetElimM]; rcases h : Block.nondetElimM body σ with ⟨body', σ'⟩; simp only [h] + +theorem Stmt.nondetElimM_loop_nondet_state [HasIdent P] [HasFvar P] [HasBool P] (m : Option P.Expr) (inv : List (String × P.Expr)) + (body : List (Stmt P (Cmd P))) (md : MetaData P) (σ : StringGenState) : + (Stmt.nondetElimM (.loop .nondet m inv body md) σ).2 = + (Block.nondetElimM body (StringGenState.gen ndelimLoopPrefix σ).2).2 := by + rw [Stmt.nondetElimM] + rcases hg : StringGenState.gen ndelimLoopPrefix σ with ⟨g, σ₁⟩ + rcases h : Block.nondetElimM body σ₁ with ⟨body', σ₂⟩ + simp only [hg, h] + +theorem Block.nondetElimM_cons_state [HasIdent P] [HasFvar P] [HasBool P] (s : Stmt P (Cmd P)) (rest : List (Stmt P (Cmd P))) + (σ : StringGenState) : + (Block.nondetElimM (s :: rest) σ).2 = (Block.nondetElimM rest (Stmt.nondetElimM s σ).2).2 := by + rw [Block.nondetElimM] + rcases h₁ : Stmt.nondetElimM s σ with ⟨ss_s, σ₁⟩ + rcases h₂ : Block.nondetElimM rest σ₁ with ⟨ss_r, σ₂⟩ + simp only [h₁, h₂] + +/-- The freshly minted ndelim guard satisfies the `HoistInitClass` fresh +disjunct at `ndelimKind` over a one-`gen`-step window. -/ +private theorem ndelim_fresh_class [HasIdent P] (pf : String) (σ : StringGenState) + (h_wf : StringGenState.WF σ) + (hpf : ndelimKind (StringGenState.gen pf σ).1) : + ∃ str : String, HasIdent.ident (P := P) (StringGenState.gen pf σ).1 = HasIdent.ident str + ∧ str ∈ StringGenState.stringGens (StringGenState.gen pf σ).2 + ∧ str ∉ StringGenState.stringGens σ + ∧ ndelimKind str := + ⟨(StringGenState.gen pf σ).1, rfl, + by rw [StringGenState.stringGens_gen]; exact List.mem_cons.mpr (Or.inl rfl), + StringGenState.stringGens_gen_not_in pf σ h_wf, hpf⟩ + +mutual +/-- Strengthened nondetElim `initVars` classification: window-tracked +`HoistInitClass` at `ndelimKind`, plus `Nodup`. Mirrors the hoist +`_initVars_classified`. -/ +theorem Stmt.nondetElimM_initVars_nodup [HasIdent P] [LawfulHasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) (σ : StringGenState) (h_wf : StringGenState.WF σ) + (h_unique : (Stmt.initVars s).Nodup) + (h_sf : ∀ str : String, ndelimKind str → HasIdent.ident (P := P) str ∉ Stmt.initVars s) : + (∀ x ∈ Block.initVars (P := P) (Stmt.nondetElimM s σ).1, + HoistInitClass ndelimKind (Stmt.initVars s) σ (Stmt.nondetElimM s σ).2 x) + ∧ (Block.initVars (P := P) (Stmt.nondetElimM s σ).1).Nodup := by + match s with + | .cmd c => + refine ⟨fun x hx => ?_, ?_⟩ + · simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, List.append_nil] at hx ⊢ + exact Or.inl hx + · simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, List.append_nil] + exact h_unique + | .block lbl bss md => + rw [Stmt.nondetElimM_block_out, Stmt.nondetElimM_block_state] + have h_unique' : (Block.initVars bss).Nodup := by + simpa only [Stmt.initVars_block] using h_unique + have h_sf' : ∀ str : String, ndelimKind str → + HasIdent.ident (P := P) str ∉ Block.initVars bss := by + intro str hsuf; simpa only [Stmt.initVars_block] using h_sf str hsuf + have ih := Block.nondetElimM_initVars_nodup bss σ h_wf h_unique' h_sf' + refine ⟨?_, ?_⟩ + · intro x hx + simp only [Block.initVars_cons, Stmt.initVars_block, Block.initVars, + List.append_nil] at hx ⊢ + simpa only [Stmt.initVars_block] using ih.1 x hx + · simp only [Block.initVars_cons, Stmt.initVars_block, Block.initVars, List.append_nil] + exact ih.2 + | .ite (.det e) tss ess md => + rw [Stmt.nondetElimM_ite_det_out, Stmt.nondetElimM_ite_det_state] + have h_uni : (Block.initVars tss ++ Block.initVars ess).Nodup := by + simpa only [Stmt.initVars_ite] using h_unique + have h_uni_t : (Block.initVars tss).Nodup := (List.nodup_append.mp h_uni).1 + have h_uni_e : (Block.initVars ess).Nodup := (List.nodup_append.mp h_uni).2.1 + have h_disj_te : ∀ a ∈ Block.initVars tss, ∀ b ∈ Block.initVars ess, a ≠ b := + (List.nodup_append.mp h_uni).2.2 + have h_sf_t : ∀ str : String, ndelimKind str → + HasIdent.ident (P := P) str ∉ Block.initVars tss := by + intro str hsuf hmem; exact h_sf str hsuf (by + rw [Stmt.initVars_ite, List.mem_append]; exact Or.inl hmem) + have h_sf_e : ∀ str : String, ndelimKind str → + HasIdent.ident (P := P) str ∉ Block.initVars ess := by + intro str hsuf hmem; exact h_sf str hsuf (by + rw [Stmt.initVars_ite, List.mem_append]; exact Or.inr hmem) + have ih_t := Block.nondetElimM_initVars_nodup tss σ h_wf h_uni_t h_sf_t + have h_wf_t : StringGenState.WF (Block.nondetElimM tss σ).2 := + (Block.nondetElimM_genStep tss σ).wf_mono h_wf + have ih_e := Block.nondetElimM_initVars_nodup ess (Block.nondetElimM tss σ).2 h_wf_t h_uni_e h_sf_e + have h_step_t : GenStep σ (Block.nondetElimM tss σ).2 := Block.nondetElimM_genStep tss σ + have h_step_e : GenStep (Block.nondetElimM tss σ).2 + (Block.nondetElimM ess (Block.nondetElimM tss σ).2).2 := Block.nondetElimM_genStep ess _ + refine ⟨?_, ?_⟩ + · intro x hx + simp only [Block.initVars_cons, Stmt.initVars_ite, Block.initVars, List.append_nil] at hx ⊢ + rw [List.mem_append] at hx + rcases hx with h | h + · rcases ih_t.1 x h with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (by rw [List.mem_append]; exact Or.inl h_o) + · exact Or.inr ⟨str, he, h_step_e.subset hin, hnot, hQ⟩ + · rcases ih_e.1 x h with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (by rw [List.mem_append]; exact Or.inr h_o) + · exact Or.inr ⟨str, he, hin, fun h_in_σ => hnot (h_step_t.subset h_in_σ), hQ⟩ + · simp only [Block.initVars_cons, Stmt.initVars_ite, Block.initVars, List.append_nil] + rw [List.nodup_append] + exact ⟨ih_t.2, ih_e.2, hoistInitClass_disjoint (Block.initVars tss) (Block.initVars ess) + σ (Block.nondetElimM tss σ).2 _ h_wf h_step_t h_step_e + h_disj_te h_sf_t h_sf_e _ _ ih_t.1 ih_e.1⟩ + | .ite .nondet tss ess md => + rw [Stmt.nondetElimM_ite_nondet_out, Stmt.nondetElimM_ite_nondet_state] + have h_wf₀ : StringGenState.WF (StringGenState.gen ndelimItePrefix σ).2 := (StringGenState.GenStep.of_gen ndelimItePrefix σ).wf_mono h_wf + have h_step_g : GenStep σ (StringGenState.gen ndelimItePrefix σ).2 := StringGenState.GenStep.of_gen ndelimItePrefix σ + -- the source `.ite .nondet` initVars are the branches'. + have h_uni : (Block.initVars tss ++ Block.initVars ess).Nodup := by + simpa only [Stmt.initVars] using h_unique + have h_uni_t : (Block.initVars tss).Nodup := (List.nodup_append.mp h_uni).1 + have h_uni_e : (Block.initVars ess).Nodup := (List.nodup_append.mp h_uni).2.1 + have h_disj_te : ∀ a ∈ Block.initVars tss, ∀ b ∈ Block.initVars ess, a ≠ b := + (List.nodup_append.mp h_uni).2.2 + have h_sf_src : ∀ str : String, ndelimKind str → + HasIdent.ident (P := P) str ∉ Block.initVars tss ++ Block.initVars ess := by + intro str hsuf; simpa only [Stmt.initVars] using h_sf str hsuf + have h_sf_t : ∀ str : String, ndelimKind str → + HasIdent.ident (P := P) str ∉ Block.initVars tss := + fun str hsuf hmem => h_sf_src str hsuf (List.mem_append.mpr (Or.inl hmem)) + have h_sf_e : ∀ str : String, ndelimKind str → + HasIdent.ident (P := P) str ∉ Block.initVars ess := + fun str hsuf hmem => h_sf_src str hsuf (List.mem_append.mpr (Or.inr hmem)) + have ih_t := Block.nondetElimM_initVars_nodup tss (StringGenState.gen ndelimItePrefix σ).2 h_wf₀ h_uni_t h_sf_t + have h_wf_t : StringGenState.WF (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).2 := + (Block.nondetElimM_genStep tss (StringGenState.gen ndelimItePrefix σ).2).wf_mono h_wf₀ + have ih_e := Block.nondetElimM_initVars_nodup ess (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).2 h_wf_t h_uni_e h_sf_e + have h_step_t : GenStep (StringGenState.gen ndelimItePrefix σ).2 (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).2 := Block.nondetElimM_genStep tss (StringGenState.gen ndelimItePrefix σ).2 + have h_step_e : GenStep (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).2 + (Block.nondetElimM ess (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).2).2 := Block.nondetElimM_genStep ess _ + -- the freshly minted guard, classified over the `σ → (StringGenState.gen ndelimItePrefix σ).2` gen window. + have h_guard_iv : Stmt.initVars (P := P) + (Stmt.cmd (HasInit.init (HasIdent.ident (P := P) (StringGenState.gen ndelimItePrefix σ).1) + HasBool.boolTy ExprOrNondet.nondet md)) = + [HasIdent.ident (P := P) (StringGenState.gen ndelimItePrefix σ).1] := by + with_unfolding_all rfl + -- branch inits classified together over the post-gen window `(StringGenState.gen ndelimItePrefix σ).2 → σ₂`. + have h_branchClass : ∀ y ∈ Block.initVars (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).1 ++ + Block.initVars (Block.nondetElimM ess (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).2).1, + HoistInitClass ndelimKind (Block.initVars tss ++ Block.initVars ess) (StringGenState.gen ndelimItePrefix σ).2 + (Block.nondetElimM ess (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).2).2 y := by + intro y hy + rw [List.mem_append] at hy + rcases hy with h | h + · rcases ih_t.1 y h with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (List.mem_append.mpr (Or.inl h_o)) + · exact Or.inr ⟨str, he, h_step_e.subset hin, hnot, hQ⟩ + · rcases ih_e.1 y h with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (List.mem_append.mpr (Or.inr h_o)) + · exact Or.inr ⟨str, he, hin, fun hσ => hnot (h_step_t.subset hσ), hQ⟩ + have h_branchNodup : (Block.initVars (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).1 ++ + Block.initVars (Block.nondetElimM ess (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).2).1).Nodup := by + rw [List.nodup_append] + exact ⟨ih_t.2, ih_e.2, hoistInitClass_disjoint (Block.initVars tss) (Block.initVars ess) + (StringGenState.gen ndelimItePrefix σ).2 (Block.nondetElimM tss (StringGenState.gen ndelimItePrefix σ).2).2 _ h_wf₀ h_step_t h_step_e + h_disj_te h_sf_t h_sf_e _ _ ih_t.1 ih_e.1⟩ + refine ⟨?_, ?_⟩ + · intro x hx + simp only [Block.initVars_cons, Stmt.initVars_ite, Block.initVars, List.append_nil, + h_guard_iv, List.singleton_append, List.mem_cons, List.mem_append] at hx + rcases hx with h_g | h_t | h_e + · obtain ⟨str, he, hin, hnot, hQ⟩ := ndelim_fresh_class (P := P) ndelimItePrefix σ h_wf (ndelimKind_gen.1 σ) + exact Or.inr ⟨str, h_g.trans he, h_step_e.subset (h_step_t.subset hin), hnot, hQ⟩ + · rcases ih_t.1 x h_t with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (by rw [Stmt.initVars_ite, List.mem_append]; exact Or.inl h_o) + · exact Or.inr ⟨str, he, h_step_e.subset hin, + fun hσ => hnot (h_step_g.subset hσ), hQ⟩ + · rcases ih_e.1 x h_e with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (by rw [Stmt.initVars_ite, List.mem_append]; exact Or.inr h_o) + · exact Or.inr ⟨str, he, hin, + fun hσ => hnot (h_step_t.subset (h_step_g.subset hσ)), hQ⟩ + · simp only [Block.initVars_cons, Stmt.initVars_ite, Block.initVars, List.append_nil, + h_guard_iv, List.singleton_append] + rw [List.nodup_cons] + refine ⟨?_, h_branchNodup⟩ + -- guard ∉ branchInits: a guard ident is `∈ stringGens (StringGenState.gen ndelimItePrefix σ).2 \ σ`; classify each + -- branch member and refute each cross-class collision. + intro hmem + have h_guard_fresh := ndelim_fresh_class (P := P) ndelimItePrefix σ h_wf (ndelimKind_gen.1 σ) + obtain ⟨gstr, geq, gin, gnot, gQ⟩ := h_guard_fresh + rcases h_branchClass _ hmem with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact h_sf_src gstr gQ (geq ▸ h_o) + · have : gstr = str := LawfulHasIdent.ident_inj (geq.symm.trans he) + exact hnot (this ▸ gin) + | .loop (.det e) m inv body md => + rw [Stmt.nondetElimM_loop_det_out, Stmt.nondetElimM_loop_det_state] + have h_unique' : (Block.initVars body).Nodup := by + simpa only [Stmt.initVars_loop] using h_unique + have h_sf' : ∀ str : String, ndelimKind str → + HasIdent.ident (P := P) str ∉ Block.initVars body := by + intro str hsuf; simpa only [Stmt.initVars_loop] using h_sf str hsuf + have ih := Block.nondetElimM_initVars_nodup body σ h_wf h_unique' h_sf' + refine ⟨?_, ?_⟩ + · intro x hx + simp only [Block.initVars_cons, Stmt.initVars_loop, Block.initVars, + List.append_nil] at hx ⊢ + simpa only [Stmt.initVars_loop] using ih.1 x hx + · simp only [Block.initVars_cons, Stmt.initVars_loop, Block.initVars, List.append_nil] + exact ih.2 + | .loop .nondet m inv body md => + rw [Stmt.nondetElimM_loop_nondet_out, Stmt.nondetElimM_loop_nondet_state] + have h_wf₀ : StringGenState.WF (StringGenState.gen ndelimLoopPrefix σ).2 := + (StringGenState.GenStep.of_gen ndelimLoopPrefix σ).wf_mono h_wf + have h_step_g : GenStep σ (StringGenState.gen ndelimLoopPrefix σ).2 := + StringGenState.GenStep.of_gen ndelimLoopPrefix σ + have h_unique' : (Block.initVars body).Nodup := by + simpa only [Stmt.initVars] using h_unique + have h_sf' : ∀ str : String, ndelimKind str → + HasIdent.ident (P := P) str ∉ Block.initVars body := by + intro str hsuf; simpa only [Stmt.initVars] using h_sf str hsuf + have ih := Block.nondetElimM_initVars_nodup body (StringGenState.gen ndelimLoopPrefix σ).2 h_wf₀ h_unique' h_sf' + have h_step_body : GenStep (StringGenState.gen ndelimLoopPrefix σ).2 + (Block.nondetElimM body (StringGenState.gen ndelimLoopPrefix σ).2).2 := + Block.nondetElimM_genStep body _ + -- the new loop body is `body' ++ [havoc guard]`; havoc has no inits. + have h_havoc_init : Block.initVars (P := P) + [Stmt.cmd (HasHavoc.havoc (HasIdent.ident (P := P) (StringGenState.gen ndelimLoopPrefix σ).1) md)] = [] := by + with_unfolding_all rfl + have h_guard_iv : Stmt.initVars (P := P) + (Stmt.cmd (HasInit.init (HasIdent.ident (P := P) (StringGenState.gen ndelimLoopPrefix σ).1) + HasBool.boolTy ExprOrNondet.nondet md)) = + [HasIdent.ident (P := P) (StringGenState.gen ndelimLoopPrefix σ).1] := by + with_unfolding_all rfl + refine ⟨?_, ?_⟩ + · intro x hx + simp only [Block.initVars_cons, Stmt.initVars_loop, Block.initVars, List.append_nil, + h_guard_iv, List.singleton_append, List.mem_cons] at hx + rw [Block.initVars_append, h_havoc_init, List.append_nil] at hx + simp only [Stmt.initVars_loop] + rcases hx with h_g | h_body + · obtain ⟨str, he, hin, hnot, hQ⟩ := ndelim_fresh_class (P := P) ndelimLoopPrefix σ h_wf (ndelimKind_gen.2 σ) + exact Or.inr ⟨str, h_g.trans he, h_step_body.subset hin, hnot, hQ⟩ + · rcases ih.1 x h_body with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl h_o + · exact Or.inr ⟨str, he, hin, fun hσ => hnot (h_step_g.subset hσ), hQ⟩ + · simp only [Block.initVars_cons, Stmt.initVars_loop, Block.initVars, List.append_nil, + h_guard_iv, List.singleton_append] + rw [Block.initVars_append, h_havoc_init, List.append_nil, List.nodup_cons] + refine ⟨?_, ih.2⟩ + intro hmem + obtain ⟨gstr, geq, gin, gnot, gQ⟩ := ndelim_fresh_class (P := P) ndelimLoopPrefix σ h_wf (ndelimKind_gen.2 σ) + rcases ih.1 _ hmem with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact h_sf' gstr gQ (geq ▸ h_o) + · have : gstr = str := LawfulHasIdent.ident_inj (geq.symm.trans he) + exact hnot (this ▸ gin) + | .exit lbl md => + refine ⟨fun x hx => ?_, ?_⟩ + · simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, Stmt.initVars, + List.append_nil] at hx; exact (List.not_mem_nil hx).elim + · simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, Stmt.initVars, + List.append_nil]; exact List.nodup_nil + | .funcDecl d md => + refine ⟨fun x hx => ?_, ?_⟩ + · simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, Stmt.initVars, + List.append_nil] at hx; exact (List.not_mem_nil hx).elim + · simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, Stmt.initVars, + List.append_nil]; exact List.nodup_nil + | .typeDecl t md => + refine ⟨fun x hx => ?_, ?_⟩ + · simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, Stmt.initVars, + List.append_nil] at hx; exact (List.not_mem_nil hx).elim + · simp only [Stmt.nondetElimM, Block.initVars_cons, Block.initVars, Stmt.initVars, + List.append_nil]; exact List.nodup_nil + termination_by sizeOf s + +theorem Block.nondetElimM_initVars_nodup [HasIdent P] [LawfulHasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) (h_wf : StringGenState.WF σ) + (h_unique : (Block.initVars ss).Nodup) + (h_sf : ∀ str : String, ndelimKind str → HasIdent.ident (P := P) str ∉ Block.initVars ss) : + (∀ x ∈ Block.initVars (P := P) (Block.nondetElimM ss σ).1, + HoistInitClass ndelimKind (Block.initVars ss) σ (Block.nondetElimM ss σ).2 x) + ∧ (Block.initVars (P := P) (Block.nondetElimM ss σ).1).Nodup := by + match ss with + | [] => + refine ⟨fun x hx => ?_, ?_⟩ + · simp only [Block.nondetElimM, Block.initVars] at hx; exact (List.not_mem_nil hx).elim + · simp only [Block.nondetElimM, Block.initVars]; exact List.nodup_nil + | s :: rest => + rw [Block.nondetElimM_cons_out, Block.nondetElimM_cons_state] + have h_uni : (Stmt.initVars s ++ Block.initVars rest).Nodup := by + simpa only [Block.initVars_cons] using h_unique + have h_uni_s : (Stmt.initVars s).Nodup := (List.nodup_append.mp h_uni).1 + have h_uni_r : (Block.initVars rest).Nodup := (List.nodup_append.mp h_uni).2.1 + have h_disj_sr : ∀ a ∈ Stmt.initVars s, ∀ b ∈ Block.initVars rest, a ≠ b := + (List.nodup_append.mp h_uni).2.2 + have h_sf_s : ∀ str : String, ndelimKind str → + HasIdent.ident (P := P) str ∉ Stmt.initVars s := by + intro str hsuf hmem; exact h_sf str hsuf (by + rw [Block.initVars_cons, List.mem_append]; exact Or.inl hmem) + have h_sf_r : ∀ str : String, ndelimKind str → + HasIdent.ident (P := P) str ∉ Block.initVars rest := by + intro str hsuf hmem; exact h_sf str hsuf (by + rw [Block.initVars_cons, List.mem_append]; exact Or.inr hmem) + have ih_s := Stmt.nondetElimM_initVars_nodup s σ h_wf h_uni_s h_sf_s + have h_wf_s : StringGenState.WF (Stmt.nondetElimM s σ).2 := + (Stmt.nondetElimM_genStep s σ).wf_mono h_wf + have ih_r := Block.nondetElimM_initVars_nodup rest (Stmt.nondetElimM s σ).2 h_wf_s h_uni_r h_sf_r + have h_step_s : GenStep σ (Stmt.nondetElimM s σ).2 := Stmt.nondetElimM_genStep s σ + have h_step_r : GenStep (Stmt.nondetElimM s σ).2 + (Block.nondetElimM rest (Stmt.nondetElimM s σ).2).2 := Block.nondetElimM_genStep rest _ + refine ⟨?_, ?_⟩ + · intro x hx + rw [Block.initVars_append] at hx + rw [Block.initVars_cons] + rw [List.mem_append] at hx + rcases hx with h | h + · rcases ih_s.1 x h with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (by rw [List.mem_append]; exact Or.inl h_o) + · exact Or.inr ⟨str, he, h_step_r.subset hin, hnot, hQ⟩ + · rcases ih_r.1 x h with h_o | ⟨str, he, hin, hnot, hQ⟩ + · exact Or.inl (by rw [List.mem_append]; exact Or.inr h_o) + · exact Or.inr ⟨str, he, hin, fun h_in_σ => hnot (h_step_s.subset h_in_σ), hQ⟩ + · rw [Block.initVars_append, List.nodup_append] + exact ⟨ih_s.2, ih_r.2, hoistInitClass_disjoint (Stmt.initVars s) (Block.initVars rest) + σ (Stmt.nondetElimM s σ).2 _ h_wf h_step_s h_step_r + h_disj_sr h_sf_s h_sf_r _ _ ih_s.1 ih_r.1⟩ + termination_by sizeOf ss +end +end NondetElimUniqueInits + +--------------------------------------------------------------------- +/-! ## Section 10 — Direction A: `hoistedNamesFreshInRhsAndGuards` on `nondetElim` + +The hoist §F precondition `hoistedNamesFreshInRhsAndGuards (nondetElim ss)` is +the last cross-pass obligation. The predicate is the RHS-only `initVars` +freshness `namesFreshInRhsExprs (initVars _) _`: + + `nondetElim` only ever introduces command RHS positions that read nothing + (`init _ .nondet` / `havoc`); it reads its fresh guard *only* in a + `.ite`/`.loop` *guard*, never in a command RHS. So the RHS-only freshness is + preserved verbatim for any fixed name list + (`Block.nondetElimM_namesFreshInRhsExprs`), and the per-name coverage of the + output's own `initVars` is supplied by the Section-8/9 classification (source + inits inherit the source hypothesis; fresh `ndelimKind` guards are RHS-fresh + by source kind-freedom). + +Guard freshness for a loop's body inits is no longer demanded: at every loop +head a body-init name is undefined, so an evaluating guard cannot read it, and +the loop driver discharges the guard agreement from that undefinedness +invariant directly. -/ + +section NondetElimFresh +variable {P : PureExpr} + +/-- A `.cmd (init _ _ .nondet _)` has an empty-vars RHS, so any names list is +RHS-fresh in it. -/ +private theorem init_nondet_rhsfree [HasVarsPure P P.Expr] (names : List P.Ident) (ident : P.Ident) + (ty : P.Ty) (md : MetaData P) : + Stmt.namesFreshInRhsExprs (P := P) names + (Stmt.cmd (HasInit.init ident ty ExprOrNondet.nondet md)) = true := by + show Stmt.namesFreshInRhsExprs (P := P) names + (Stmt.cmd (Cmd.init ident ty ExprOrNondet.nondet md)) = true + simp only [Stmt.namesFreshInRhsExprs, ExprOrNondet.getVars] + rw [List.all_eq_true]; intro z _; rfl + +/-- A `.cmd (havoc _)` has an empty-vars RHS, so any names list is RHS-fresh in +it. -/ +private theorem havoc_rhsfree [HasVarsPure P P.Expr] (names : List P.Ident) (ident : P.Ident) + (md : MetaData P) : + Stmt.namesFreshInRhsExprs (P := P) names + (Stmt.cmd (HasHavoc.havoc ident md)) = true := by + show Stmt.namesFreshInRhsExprs (P := P) names + (Stmt.cmd (Cmd.set ident ExprOrNondet.nondet md)) = true + simp only [Stmt.namesFreshInRhsExprs, ExprOrNondet.getVars] + rw [List.all_eq_true]; intro z _; rfl + +mutual +/-- `nondetElim` preserves `namesFreshInRhsExprs names` for a fixed name list: +all introduced command RHS positions read nothing, and source RHS positions are +unchanged. -/ +theorem Stmt.nondetElimM_namesFreshInRhsExprs [HasIdent P] [HasFvar P] [HasBool P] [HasVarsPure P P.Expr] (names : List P.Ident) + (s : Stmt P (Cmd P)) (σ : StringGenState) + (h : Stmt.namesFreshInRhsExprs (P := P) names s = true) : + Block.namesFreshInRhsExprs (P := P) names (Stmt.nondetElimM s σ).1 = true := by + match s with + | .cmd c => + simp only [Stmt.nondetElimM, Block.namesFreshInRhsExprs, Bool.and_true] + exact h + | .block lbl bss md => + rw [Stmt.nondetElimM_block_out] + simp only [Stmt.namesFreshInRhsExprs] at h + simp only [Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, Bool.and_true] + exact Block.nondetElimM_namesFreshInRhsExprs names bss σ h + | .ite (.det e) tss ess md => + rw [Stmt.nondetElimM_ite_det_out] + simp only [Stmt.namesFreshInRhsExprs, Bool.and_eq_true] at h + simp only [Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, Bool.and_true, + Bool.and_eq_true] + exact ⟨Block.nondetElimM_namesFreshInRhsExprs names tss σ h.1, + Block.nondetElimM_namesFreshInRhsExprs names ess _ h.2⟩ + | .ite .nondet tss ess md => + rw [Stmt.nondetElimM_ite_nondet_out] + simp only [Stmt.namesFreshInRhsExprs, Bool.and_eq_true] at h + simp only [Block.namesFreshInRhsExprs, Bool.and_true, Bool.and_eq_true] + refine ⟨init_nondet_rhsfree _ _ _ _, ?_⟩ + simp only [Stmt.namesFreshInRhsExprs, Bool.and_eq_true] + exact ⟨Block.nondetElimM_namesFreshInRhsExprs names tss _ h.1, + Block.nondetElimM_namesFreshInRhsExprs names ess _ h.2⟩ + | .loop (.det e) m inv body md => + rw [Stmt.nondetElimM_loop_det_out] + simp only [Stmt.namesFreshInRhsExprs] at h + simp only [Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, Bool.and_true] + exact Block.nondetElimM_namesFreshInRhsExprs names body σ h + | .loop .nondet m inv body md => + rw [Stmt.nondetElimM_loop_nondet_out] + simp only [Stmt.namesFreshInRhsExprs] at h + simp only [Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, Bool.and_true, + Bool.and_eq_true] + have h_havoc : Block.namesFreshInRhsExprs (P := P) names + [Stmt.cmd (HasHavoc.havoc (HasIdent.ident (P := P) (StringGenState.gen ndelimLoopPrefix σ).1) md)] = true := by + simp only [Block.namesFreshInRhsExprs, Bool.and_true] + exact havoc_rhsfree _ _ _ + refine ⟨init_nondet_rhsfree _ _ _ _, ?_⟩ + exact Block.namesFreshInRhsExprs_append _ _ + (Block.nondetElimM_namesFreshInRhsExprs names body _ h) h_havoc + | .exit lbl md => + simp only [Stmt.nondetElimM, Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, + Bool.and_true] + | .funcDecl d md => + simp only [Stmt.nondetElimM, Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, + Bool.and_true] + | .typeDecl t md => + simp only [Stmt.nondetElimM, Block.namesFreshInRhsExprs, Stmt.namesFreshInRhsExprs, + Bool.and_true] + termination_by sizeOf s + +theorem Block.nondetElimM_namesFreshInRhsExprs [HasIdent P] [HasFvar P] [HasBool P] [HasVarsPure P P.Expr] (names : List P.Ident) + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) + (h : Block.namesFreshInRhsExprs (P := P) names ss = true) : + Block.namesFreshInRhsExprs (P := P) names (Block.nondetElimM ss σ).1 = true := by + match ss with + | [] => simp only [Block.nondetElimM, Block.namesFreshInRhsExprs] + | s :: rest => + rw [Block.nondetElimM_cons_out] + simp only [Block.namesFreshInRhsExprs, Bool.and_eq_true] at h + exact Block.namesFreshInRhsExprs_append _ _ + (Stmt.nondetElimM_namesFreshInRhsExprs names s σ h.1) + (Block.nondetElimM_namesFreshInRhsExprs names rest _ h.2) + termination_by sizeOf ss +end + +/-- An `ndelimKind` guard ident is RHS-fresh in the kind-free source: it is the +identifier of an `ndelimKind` label, and the source reads no `ndelimKind` ident +in any expression (`exprsShapeFree ndelimKind`), so a fortiori not in any RHS. -/ +private theorem ndelim_guard_namesFreshInRhsExprs_src [HasIdent P] [HasVarsPure P P.Expr] + {str : String} (h_kind : ndelimKind str) (ss : List (Stmt P (Cmd P))) + (h_sf : Block.exprsShapeFree (P := P) ndelimKind ss) : + Block.namesFreshInRhsExprs (P := P) [HasIdent.ident (P := P) str] ss = true := + Block.namesFreshInRhsExprs_of_namesFreshInExprs _ ss + (Block.namesFreshInExprs_of_exprsShapeFree' (Q := ndelimKind) + (fun z hz => by + rw [List.mem_singleton] at hz; exact ⟨str, hz, h_kind⟩) + ss h_sf) + +/-- Every name in `initVars (nondetElim ss)` is RHS-fresh in the source `ss`: +source inits inherit the source RHS-freshness; freshly minted `ndelimKind` +guards are RHS-fresh by source kind-freedom. -/ +theorem nondetElim_initVars_namesFreshInRhsExprs_src [HasIdent P] [HasFvar P] [HasBool P] [HasVarsPure P P.Expr] + (ss : List (Stmt P (Cmd P))) + (h_src_rhs : Block.namesFreshInRhsExprs (P := P) (Block.initVars ss) ss = true) + (h_sf : Block.exprsShapeFree (P := P) ndelimKind ss) : + Block.namesFreshInRhsExprs (P := P) + (Block.initVars (Block.nondetElim ss)) ss = true := by + refine Block.namesFreshInRhsExprs_of_forall_mem _ ss (fun z hz => ?_) + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp z hz with + h_src | ⟨str, h_eq, h_kind⟩ + · exact Block.namesFreshInRhsExprs_subset + (fun w hw => by rw [List.mem_singleton] at hw; exact hw ▸ h_src) ss h_src_rhs + · exact h_eq ▸ ndelim_guard_namesFreshInRhsExprs_src h_kind ss h_sf + +/-- The `namesFreshInRhsExprs (initVars …) …` conjunct of +`hoistedNamesFreshInRhsAndGuards` holds on the `nondetElim` output: the source +fact (every output init RHS-fresh in the source) is transported through the pass +(which only adds variable-free command RHS positions). -/ +theorem nondetElim_namesFreshInRhsExprs [HasIdent P] [HasFvar P] [HasBool P] [HasVarsPure P P.Expr] + (ss : List (Stmt P (Cmd P))) + (h_src_rhs : Block.namesFreshInRhsExprs (P := P) (Block.initVars ss) ss = true) + (h_sf : Block.exprsShapeFree (P := P) ndelimKind ss) : + Block.namesFreshInRhsExprs (P := P) + (Block.initVars (Block.nondetElim ss)) (Block.nondetElim ss) = true := + Block.nondetElimM_namesFreshInRhsExprs _ ss StringGenState.emp + (nondetElim_initVars_namesFreshInRhsExprs_src ss h_src_rhs h_sf) + +end NondetElimFresh + +section NondetElimFreshAssembly +variable {P : PureExpr} + +/-- Top-level Direction-A bridge: `nondetElim` establishes the +`hoistedNamesFreshInRhsAndGuards` postcondition on its output, given the +front-end source facts (its own `hoistedNamesFreshInRhsAndGuards` and its +`ndelimKind`-freedom). This discharges the hoist §F `h_fresh` precondition at +the `nondetElim` output: the predicate is the RHS-only `initVars` freshness, +preserved verbatim because `nondetElim` only ever adds variable-free command +RHS positions (its fresh guard is read only in a `.ite`/`.loop` guard). -/ +theorem nondetElim_hoistedNamesFreshInRhsAndGuards [HasIdent P] [LawfulHasIdent P] [HasFvar P] [HasBool P] [HasVarsPure P P.Expr] [LawfulHasFvar P] + (ss : List (Stmt P (Cmd P))) + (h_fresh_src : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_sf : Block.exprsShapeFree (P := P) ndelimKind ss) : + Block.hoistedNamesFreshInRhsAndGuards (P := P) (Block.nondetElim ss) = true := by + unfold Block.hoistedNamesFreshInRhsAndGuards at h_fresh_src ⊢ + exact nondetElim_namesFreshInRhsExprs ss h_fresh_src h_sf + +end NondetElimFreshAssembly + +--------------------------------------------------------------------- +/-! ## Section 10b — `transformBlockModVars` ≡ `Block.modifiedVars` + +The S2U `NoGenSuffix` precondition speaks of the translator's local +`transformBlockModVars`, whose recursion is identical to `Block.modifiedVars` +(`.cmd c ↦ Cmd.modifiedVars c`, branch/body recursion). They are pointwise +equal; we prove it once so the modVars `NoGenSuffix s2uKind` leaf can be +discharged from the (kind-classified) `Block.modifiedVars` of the hoist output. -/ + +mutual +theorem transformStmtModVars_eq_modifiedVars {P : PureExpr} (s : Stmt P (Cmd P)) : + StructuredToUnstructuredCorrect.transformStmtModVars (P := P) s = Stmt.modifiedVars s := by + match s with + | .cmd c => rfl + | .block lbl bss md => + show StructuredToUnstructuredCorrect.transformBlockModVars bss = Block.modifiedVars bss + exact transformBlockModVars_eq_modifiedVars bss + | .ite g tss ess md => + show StructuredToUnstructuredCorrect.transformBlockModVars tss ++ + StructuredToUnstructuredCorrect.transformBlockModVars ess = + Block.modifiedVars tss ++ Block.modifiedVars ess + rw [transformBlockModVars_eq_modifiedVars tss, transformBlockModVars_eq_modifiedVars ess] + | .loop g m inv body md => + show StructuredToUnstructuredCorrect.transformBlockModVars body = Block.modifiedVars body + exact transformBlockModVars_eq_modifiedVars body + | .exit lbl md => rfl + | .funcDecl d md => rfl + | .typeDecl t md => rfl + termination_by sizeOf s + +theorem transformBlockModVars_eq_modifiedVars {P : PureExpr} (ss : List (Stmt P (Cmd P))) : + StructuredToUnstructuredCorrect.transformBlockModVars (P := P) ss = Block.modifiedVars ss := by + match ss with + | [] => rfl + | s :: rest => + show StructuredToUnstructuredCorrect.transformStmtModVars s ++ + StructuredToUnstructuredCorrect.transformBlockModVars rest = + Stmt.modifiedVars s ++ Block.modifiedVars rest + rw [transformStmtModVars_eq_modifiedVars s, transformBlockModVars_eq_modifiedVars rest] + termination_by sizeOf ss +end + +--------------------------------------------------------------------- +/-! ## Section 11 — The composed pipeline soundness theorem + +`pipeline ss := stmtsToCFG (hoist (nondetElim ss))`. The three kind-generalized +soundness theorems chain via `StoreAgreement.trans`: each pass runs its input +program from the same clean initial environment `ρ₀`, and the cross-pass +name-shape preconditions are discharged by per-kind foreignness (Sections 7–10) +rather than the blanket suffix-shape exclusion that obstructed the original +composition. + +The front-end hypotheses on the user source `ss` are all satisfiable by a real +program: `ss` is shape-restricted (no func decls, no loop invariants/measures) +and *kind-free* — it mentions none of the +`$__ndelim_*$` / `_hoist` / S2U construct prefixes that the three passes mint +(the `*_kindfree` hypotheses), and never writes or reads such a name. `ρ₀`'s +store need only leave the source inits (`h_store_inits`) and the three passes' +minted names (`h_store_mints`) undefined — not the entire store. -/ + +section PipelineSound +variable {P : PureExpr} + +/-- The composed structured-to-unstructured pipeline. -/ +@[expose] def pipeline [HasIdent P] [HasFvar P] [HasBool P] [HasSubstFvar P] [DecidableEq P.Ident] + [HasNot P] [HasIntOrder P] + (ss : List (Stmt P (Cmd P))) : + CFG String (DetBlock String (Cmd P) P) := + (stmtsToCFG ∘ Block.hoistLoopPrefixInits ∘ Block.nondetElim) ss + +/-- The target (unstructured CFG) `Lang` for pipeline refinement, mirroring the +proven `Lang.kleene` template. + +The statement type is the deterministic CFG produced by `pipeline`. A +configuration pairs the CFG being executed with a `CFGConfig` execution state; +`star` runs the deterministic CFG semantics from the *left* (start) endpoint's +CFG (`c.1`), reading only the two `CFGConfig` states (`c.2`, `d.2`). The +right-endpoint CFG (`d.1`) is therefore irrelevant, so `terminalCfg` / +`exitingCfg` use a trivial placeholder CFG. + +`exitingCfg lbl ρ` carries the real `CFGConfig.exiting lbl` shape (tagged with +the escaping label `lbl`), so the exiting endpoint models a genuine top-level +escaping CFG run, distinct from the `CFGConfig.terminal` shape of `terminalCfg`. + +`isAtAssert` / `getEnv` are total placeholders. The refinement predicate +`OverapproximatesRel` references only `star` / `stmtCfg` / `terminalCfg` / +`exitingCfg`; it never reads `isAtAssert` or `getEnv`, so any total value for +those two fields is sound. `getEnv` projects the running store and failure +flag faithfully and uses a fixed placeholder evaluator (the configuration +carries no evaluator). -/ +abbrev Lang.cfg [HasFvar P] [HasNot P] [HasVal P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) : Specification.Lang P where + StmtT := CFG String (DetBlock String (Cmd P) P) + CfgT := (CFG String (DetBlock String (Cmd P) P)) × (CFGConfig String (Cmd P) P) + star := fun c d => StructuredToUnstructuredCorrect.StepDetCFGStar extendEval c.1 c.2 d.2 + stmtCfg := fun cfg ρ => (cfg, .atBlock cfg.entry ρ.store ρ.hasFailure) + terminalCfg := fun ρ => (⟨"", []⟩, .terminal ρ.store ρ.hasFailure) + exitingCfg := fun lbl ρ => (⟨"", []⟩, CFGConfig.exiting lbl ρ.store ρ.hasFailure) + isAtAssert := fun _ _ => False + getEnv := fun c => { store := c.2.getStore, eval := fun _ _ => none, hasFailure := c.2.getFailure } + InitEnvWFParamsTy := Unit + initEnvWF := fun _ _ _ => True + +/-- **Compositional-input pipeline soundness (terminal outcome).** Generalises +`pipeline_sound_terminal` so the CFG `pipeline ss` may start from an *arbitrary* +external store `σ_ext` that overapproximates the source initial store +(`StoreAgreement ρ₀.store σ_ext`): `σ_ext` agrees on every source-defined +variable and may bind strictly more. + +This is the constructive flip that makes the pipeline an +`OverapproximatesUptoWhen`-shaped statement feeding a *further* transform: the +downstream consumer universally quantifies the target initial env over all +`R`-related (overapproximating) envs, and this theorem supports exactly that +quantification instead of dropping it. + +The structured passes (`nondetElim`, `hoistLoopPrefixInits`) still run from +`ρ₀` — they are source-to-source and never touch the CFG store — so they keep +their original `ρ₀`-freshness preconditions. Only the final `stmtsToCFG` pass +runs the CFG, so only it consumes the `σ_ext` agreement and the `σ_ext`-stated +freshness: the source `initVars`, the `ndelimKind` *and* `hoistKind` *and* +`s2uKind` minted names must all be undefined in `σ_ext`. The `ndelimKind` +freshness on `σ_ext` is irreducibly required: `nondetElim` mints fresh-named +`init` targets that become part of the CFG (S2U input) program's `initVars`, so +`σ_ext` must leave them undefined for those CFG inits to fire. (The `s2uKind` +*source*-store mint hypothesis is no longer needed and is dropped.) -/ +theorem pipeline_sound_terminal_compositional + [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] [HasSubstFvar P] [LawfulHasSubstFvar P] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) + (σ_ext : SemanticStore P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfvar' : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (hwfcongr' : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (hwfsubst' : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (hwfdef' : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + -- ρ₀-freshness for the *structured* passes (nondetElim / hoist), unchanged: + (h_store_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) + (h_store_mints_ndelim : NoGenStore (P := P) ndelimKind ρ₀) + (h_store_mints_hoist : NoGenStore (P := P) hoistKind ρ₀) + -- Track A: agreement + σ_ext-freshness for the *CFG* (S2U) pass: + (h_agree_ext : StoreAgreement ρ₀.store σ_ext) + (h_store_inits_ext : ∀ x ∈ Block.initVars ss, σ_ext x = none) + (h_store_mints_ndelim_ext : + ∀ s : String, ndelimKind s → σ_ext (HasIdent.ident (P := P) s) = none) + (h_store_mints_hoist_ext : + ∀ s : String, hoistKind s → σ_ext (HasIdent.ident (P := P) s) = none) + (h_store_mints_s2u_ext : + ∀ s : String, StructuredToUnstructuredCorrect.s2uKind s → + σ_ext (HasIdent.ident (P := P) s) = none) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_disj : StructuredToUnstructuredCorrect.Block.userLabelsShapeNodup ss) + (h_ndelim_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_ndelim_exprs : Block.exprsShapeFree (P := P) ndelimKind ss) + (h_hoist_exprs : Block.exprsShapeFree (P := P) hoistKind ss) + (h_disj_initVars : ∀ str : String, + (ndelimKind str ∨ hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.initVars ss) + (h_disj_modVars : ∀ str : String, + (hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) + (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) : + ∃ σ_cfg, StructuredToUnstructuredCorrect.StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry σ_ext ρ₀.hasFailure) + (.terminal σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := by + -- === STEP 1: nondetElim (structured, from ρ₀) === + obtain ⟨ρ_out, h_run1, h_agree1, h_hf1⟩ := + nondetElim_sound_kind extendEval ss ρ₀ ρ' + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + h_store_mints_ndelim h_ndelim_writes h_nofd h_lhni h_term + have h_out_unique : Block.uniqueInits (Block.nondetElim ss) := + (Block.nondetElimM_initVars_nodup ss StringGenState.emp StringGenState.wf_emp + h_unique (fun str hk => h_disj_initVars str (Or.inl hk))).2 + have h_out_iv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.initVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_initVars str (Or.inr (Or.inl hk)) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_mv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.modifiedVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_modVars str (Or.inl hk) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_exprs_sf : Block.exprsShapeFree (P := P) hoistKind (Block.nondetElim ss) := + Block.nondetElimM_exprsShapeFree + (fun sg => (ndelim_name_not_hoistKind sg).1) + (fun sg => (ndelim_name_not_hoistKind sg).2) + ss StringGenState.emp h_hoist_exprs + have h_out_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) (Block.nondetElim ss) = true := + nondetElim_hoistedNamesFreshInRhsAndGuards ss h_fresh h_ndelim_exprs + have h_out_undef : ∀ y ∈ Block.initVars (Block.nondetElim ss), ρ₀.store y = none := by + intro y hy + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp y hy with + h_src | ⟨str, h_eq, h_nd⟩ + · exact h_store_inits y h_src + · rw [h_eq]; exact h_store_mints_ndelim str h_nd + -- === STEP 2: hoist (structured, from ρ₀) === + obtain ⟨ρ_h', h_run2, h_agree2, h_hf2⟩ := + hoistLoopPrefixInits_preserves_kind (Q := hoistKind) hoistKind_gen + (extendEval := extendEval) (Block.nondetElim ss) + (nondetElim_containsNondetLoop ss) + (nondetElim_containsFuncDecl ss h_nofd) + (nondetElim_loopHasNoInvariants ss h_lhni) + (by rw [Block.loopMeasureNone_eq_noMeasureLoops]; exact nondetElim_noMeasureLoops ss h_nml) + h_out_exprs_sf h_out_unique h_out_fresh + h_out_iv_sf h_out_mv_sf h_out_undef h_store_mints_hoist h_run1 + hwfvar' hwfcongr' hwfsubst' hwfdef' + -- === Direction-B S2U preconds on the hoist output, at Q := s2uKind === + have h_hoist_iv_cls := + LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_initVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf + have h_step3_unique : Block.uniqueInits (Block.hoistLoopPrefixInits (Block.nondetElim ss)) := + h_hoist_iv_cls.2 + -- σ_ext analogue of the transformed-program initVars freshness (was ρ₀.store). + have h_out_undef_ext : ∀ y ∈ Block.initVars (Block.nondetElim ss), σ_ext y = none := by + intro y hy + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp y hy with + h_src | ⟨str, h_eq, h_nd⟩ + · exact h_store_inits_ext y h_src + · -- ndelim-minted init targets reach the CFG (S2U) input program's initVars, + -- so σ_ext must leave them undefined too: discharged by h_store_mints_ndelim_ext. + rw [h_eq]; exact h_store_mints_ndelim_ext str h_nd + have h_step3_undef_ext : ∀ x ∈ Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss)), + σ_ext x = none := by + intro x hx + rcases h_hoist_iv_cls.1 x hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · exact h_out_undef_ext x h_src + · rw [h_eq]; exact h_store_mints_hoist_ext str h_hoistk + have h_step3_iv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + intro s hk hx + rcases h_hoist_iv_cls.1 _ hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_src with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_step3_mv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (StructuredToUnstructuredCorrect.transformBlockModVars + (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + rw [transformBlockModVars_eq_modifiedVars] + intro s hk hx + rcases LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_modVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf _ hx with + h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rw [List.mem_append] at h_src + rcases h_src with h_mv | h_iv + · rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ h_mv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_modVars s (Or.inr hk) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_iv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + -- === STEP 3: stmtsToCFG via the COMPOSITIONAL S2U spike (CFG from σ_ext) === + obtain ⟨σ_cfg, h_run3, h_agree3⟩ := + StructuredToUnstructuredCorrect.stmtsToCFG_terminal_compositional + (Q := StructuredToUnstructuredCorrect.s2uKind) + extendEval (Block.hoistLoopPrefixInits (Block.nondetElim ss)) ρ₀ ρ_h' σ_ext + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + (hoist_noFuncDecl _ (nondetElim_noFuncDecl ss h_nofd)) + (hoist_simpleShape _ (nondetElim_simpleShape ss)) + h_step3_unique + (hoist_loopBodyNoInits _) + (hoist_loopHasNoInvariants _ (nondetElim_loopHasNoInvariants ss h_lhni)) + (hoist_noMeasureLoops _ (nondetElim_noMeasureLoops ss h_nml)) + h_agree_ext + h_step3_undef_ext + (Block.userLabelsShapeNodup_pipeline_preserved ss h_disj) + h_store_mints_s2u_ext + h_step3_iv h_step3_mv + StructuredToUnstructuredCorrect.s2uKind_gen + h_run2 + -- === CHAIN via StoreAgreement.trans (source on the left) === + have h_hf : ρ_h'.hasFailure = ρ'.hasFailure := h_hf2.trans h_hf1 + rw [h_hf] at h_run3 + -- (pipeline ss).entry def-unfolds to (stmtsToCFG (hoist (nondetElim ss))).entry + exact ⟨σ_cfg, h_run3, StoreAgreement.trans h_agree1 (StoreAgreement.trans h_agree2 h_agree3)⟩ + +/-- **Compositional-input pipeline soundness (exiting outcome).** The exiting +companion of `pipeline_sound_terminal_compositional`: an *escaping* source run of +`ss` from `ρ₀` to a top-level uncaught exit `.exiting lbl ρ'` is matched by a CFG +run of `pipeline ss` started from an *arbitrary* overapproximating external store +`σ_ext` (`StoreAgreement ρ₀.store σ_ext`) reaching the *same* `.exiting lbl +σ_cfg` with an agreeing final store. + +As in the terminal compositional theorem, the structured passes (`nondetElim`, +`hoistLoopPrefixInits`) still run from `ρ₀` — source-to-source, never touching +the CFG store — and keep their `ρ₀`-freshness preconditions; only the final +`stmtsToCFG` pass consumes the `σ_ext` agreement and the `σ_ext`-stated freshness +(source `initVars` and all three minted kinds undefined in `σ_ext`). This is the +exiting arm the up-to-relation overapproximation's conjunct-1 needs, since `Upto` +runs the target from the `R`-related `ρ₀'`. -/ +theorem pipeline_sound_exiting_compositional + [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] [HasSubstFvar P] [LawfulHasSubstFvar P] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) + (σ_ext : SemanticStore P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfvar' : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (hwfcongr' : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (hwfsubst' : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (hwfdef' : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (h_store_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) + (h_store_mints_ndelim : NoGenStore (P := P) ndelimKind ρ₀) + (h_store_mints_hoist : NoGenStore (P := P) hoistKind ρ₀) + (h_agree_ext : StoreAgreement ρ₀.store σ_ext) + (h_store_inits_ext : ∀ x ∈ Block.initVars ss, σ_ext x = none) + (h_store_mints_ndelim_ext : + ∀ s : String, ndelimKind s → σ_ext (HasIdent.ident (P := P) s) = none) + (h_store_mints_hoist_ext : + ∀ s : String, hoistKind s → σ_ext (HasIdent.ident (P := P) s) = none) + (h_store_mints_s2u_ext : + ∀ s : String, StructuredToUnstructuredCorrect.s2uKind s → + σ_ext (HasIdent.ident (P := P) s) = none) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_disj : StructuredToUnstructuredCorrect.Block.userLabelsShapeNodup ss) + (h_ndelim_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_ndelim_exprs : Block.exprsShapeFree (P := P) ndelimKind ss) + (h_hoist_exprs : Block.exprsShapeFree (P := P) hoistKind ss) + (h_disj_initVars : ∀ str : String, + (ndelimKind str ∨ hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.initVars ss) + (h_disj_modVars : ∀ str : String, + (hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) + (lbl : String) + (h_exit : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.exiting lbl ρ')) : + ∃ σ_cfg, StructuredToUnstructuredCorrect.StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry σ_ext ρ₀.hasFailure) + (.exiting lbl σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := by + -- === STEP 1: nondetElim (exiting, from ρ₀) === + obtain ⟨ρ_out, h_run1, h_agree1, h_hf1⟩ := + nondetElim_sound_kind_exit extendEval ss ρ₀ ρ' + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + h_store_mints_ndelim h_ndelim_writes h_nofd h_lhni lbl h_exit + have h_out_unique : Block.uniqueInits (Block.nondetElim ss) := + (Block.nondetElimM_initVars_nodup ss StringGenState.emp StringGenState.wf_emp + h_unique (fun str hk => h_disj_initVars str (Or.inl hk))).2 + have h_out_iv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.initVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_initVars str (Or.inr (Or.inl hk)) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_mv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.modifiedVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_modVars str (Or.inl hk) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_exprs_sf : Block.exprsShapeFree (P := P) hoistKind (Block.nondetElim ss) := + Block.nondetElimM_exprsShapeFree + (fun sg => (ndelim_name_not_hoistKind sg).1) + (fun sg => (ndelim_name_not_hoistKind sg).2) + ss StringGenState.emp h_hoist_exprs + have h_out_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) (Block.nondetElim ss) = true := + nondetElim_hoistedNamesFreshInRhsAndGuards ss h_fresh h_ndelim_exprs + have h_out_undef : ∀ y ∈ Block.initVars (Block.nondetElim ss), ρ₀.store y = none := by + intro y hy + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp y hy with + h_src | ⟨str, h_eq, h_nd⟩ + · exact h_store_inits y h_src + · rw [h_eq]; exact h_store_mints_ndelim str h_nd + -- === STEP 2: hoist (exiting, from ρ₀) === + obtain ⟨ρ_h', h_run2, h_agree2, h_hf2⟩ := + hoistLoopPrefixInits_preserves_kind_exit (Q := hoistKind) hoistKind_gen + (extendEval := extendEval) (Block.nondetElim ss) + (nondetElim_containsNondetLoop ss) + (nondetElim_containsFuncDecl ss h_nofd) + (nondetElim_loopHasNoInvariants ss h_lhni) + (by rw [Block.loopMeasureNone_eq_noMeasureLoops]; exact nondetElim_noMeasureLoops ss h_nml) + h_out_exprs_sf h_out_unique h_out_fresh + h_out_iv_sf h_out_mv_sf h_out_undef h_store_mints_hoist lbl h_run1 + hwfvar' hwfcongr' hwfsubst' hwfdef' + -- === Direction-B S2U preconds on the hoist output, at Q := s2uKind === + have h_hoist_iv_cls := + LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_initVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf + have h_step3_unique : Block.uniqueInits (Block.hoistLoopPrefixInits (Block.nondetElim ss)) := + h_hoist_iv_cls.2 + have h_out_undef_ext : ∀ y ∈ Block.initVars (Block.nondetElim ss), σ_ext y = none := by + intro y hy + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp y hy with + h_src | ⟨str, h_eq, h_nd⟩ + · exact h_store_inits_ext y h_src + · rw [h_eq]; exact h_store_mints_ndelim_ext str h_nd + have h_step3_undef_ext : ∀ x ∈ Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss)), + σ_ext x = none := by + intro x hx + rcases h_hoist_iv_cls.1 x hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · exact h_out_undef_ext x h_src + · rw [h_eq]; exact h_store_mints_hoist_ext str h_hoistk + have h_step3_iv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + intro s hk hx + rcases h_hoist_iv_cls.1 _ hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_src with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_step3_mv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (StructuredToUnstructuredCorrect.transformBlockModVars + (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + rw [transformBlockModVars_eq_modifiedVars] + intro s hk hx + rcases LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_modVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf _ hx with + h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rw [List.mem_append] at h_src + rcases h_src with h_mv | h_iv + · rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ h_mv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_modVars s (Or.inr hk) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_iv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + -- === STEP 3: stmtsToCFG via the COMPOSITIONAL exiting wrap (CFG from σ_ext) === + obtain ⟨σ_cfg, h_run3, h_agree3⟩ := + StructuredToUnstructuredCorrect.stmtsToCFG_exiting_compositional + (Q := StructuredToUnstructuredCorrect.s2uKind) + extendEval (Block.hoistLoopPrefixInits (Block.nondetElim ss)) ρ₀ ρ_h' σ_ext + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + (hoist_noFuncDecl _ (nondetElim_noFuncDecl ss h_nofd)) + (hoist_simpleShape _ (nondetElim_simpleShape ss)) + h_step3_unique + (hoist_loopBodyNoInits _) + (hoist_loopHasNoInvariants _ (nondetElim_loopHasNoInvariants ss h_lhni)) + (hoist_noMeasureLoops _ (nondetElim_noMeasureLoops ss h_nml)) + h_agree_ext + h_step3_undef_ext + (Block.userLabelsShapeNodup_pipeline_preserved ss h_disj) + h_store_mints_s2u_ext + h_step3_iv h_step3_mv + StructuredToUnstructuredCorrect.s2uKind_gen + lbl h_run2 + -- === CHAIN via StoreAgreement.trans (source on the left) === + have h_hf : ρ_h'.hasFailure = ρ'.hasFailure := h_hf2.trans h_hf1 + rw [h_hf] at h_run3 + exact ⟨σ_cfg, h_run3, StoreAgreement.trans h_agree1 (StoreAgreement.trans h_agree2 h_agree3)⟩ + +/-- **Compositional-input pipeline soundness with a target-shape (domain) +guarantee (terminal outcome).** Strengthens `pipeline_sound_terminal_compositional` +with a *third* conjunct pinning down exactly which variables the CFG terminal +store `σ_cfg` may bind: every variable left undefined by the external start +store `σ_ext` stays undefined in `σ_cfg` *unless* it is a source `initVars` +target or one of the three kinds of pipeline-minted name (`ndelimKind`, +`hoistKind`, `s2uKind`). In other words the CFG run introduces *no* fresh +bindings beyond the source's own `init` targets and the pipeline's own minted +names — the shape guarantee a downstream transform needs to reason about the +domain of `σ_cfg`. + +This is the **Track B** output WF. Combined with `StoreAgreement ρ'.store σ_cfg` +(which already gives every source-output variable defined in `σ_cfg` with the +source value — the definedness guarantee), the source-output definedness and the +extra-var shape together are exactly what a next transform expecting "source +outputs defined, only pipeline-minted extra names" consumes. + +The guarantee threads the S2U-layer +`stmtsToCFG_terminal_compositional_shape` conjunct: the pipeline-minted CFG +`init` targets of the S2U input program (`hoistLoopPrefixInits (nondetElim ss)`) +classify — via the same `nondetElimM_initVars_classified` / +`hoistLoopPrefixInitsM_initVars_classified` lemmas the freshness derivations use +— into source `initVars`, `ndelimKind` and `hoistKind` idents, all excluded by +the corresponding `¬ kind` hypotheses. -/ +theorem pipeline_sound_terminal_compositional_shape + [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] [HasSubstFvar P] [LawfulHasSubstFvar P] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) + (σ_ext : SemanticStore P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfvar' : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (hwfcongr' : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (hwfsubst' : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (hwfdef' : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (h_store_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) + (h_store_mints_ndelim : NoGenStore (P := P) ndelimKind ρ₀) + (h_store_mints_hoist : NoGenStore (P := P) hoistKind ρ₀) + (h_agree_ext : StoreAgreement ρ₀.store σ_ext) + (h_store_inits_ext : ∀ x ∈ Block.initVars ss, σ_ext x = none) + (h_store_mints_ndelim_ext : + ∀ s : String, ndelimKind s → σ_ext (HasIdent.ident (P := P) s) = none) + (h_store_mints_hoist_ext : + ∀ s : String, hoistKind s → σ_ext (HasIdent.ident (P := P) s) = none) + (h_store_mints_s2u_ext : + ∀ s : String, StructuredToUnstructuredCorrect.s2uKind s → + σ_ext (HasIdent.ident (P := P) s) = none) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_disj : StructuredToUnstructuredCorrect.Block.userLabelsShapeNodup ss) + (h_ndelim_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_ndelim_exprs : Block.exprsShapeFree (P := P) ndelimKind ss) + (h_hoist_exprs : Block.exprsShapeFree (P := P) hoistKind ss) + (h_disj_initVars : ∀ str : String, + (ndelimKind str ∨ hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.initVars ss) + (h_disj_modVars : ∀ str : String, + (hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) + (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) : + ∃ σ_cfg, StructuredToUnstructuredCorrect.StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry σ_ext ρ₀.hasFailure) + (.terminal σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg + ∧ (∀ x, σ_ext x = none → + x ∉ Block.initVars ss → + (∀ s : String, x = HasIdent.ident (P := P) s → ¬ ndelimKind s) → + (∀ s : String, x = HasIdent.ident (P := P) s → ¬ hoistKind s) → + (∀ s : String, x = HasIdent.ident (P := P) s → + ¬ StructuredToUnstructuredCorrect.s2uKind s) → + σ_cfg x = none) := by + -- === STEP 1: nondetElim (structured, from ρ₀) === + obtain ⟨ρ_out, h_run1, h_agree1, h_hf1⟩ := + nondetElim_sound_kind extendEval ss ρ₀ ρ' + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + h_store_mints_ndelim h_ndelim_writes h_nofd h_lhni h_term + have h_out_unique : Block.uniqueInits (Block.nondetElim ss) := + (Block.nondetElimM_initVars_nodup ss StringGenState.emp StringGenState.wf_emp + h_unique (fun str hk => h_disj_initVars str (Or.inl hk))).2 + have h_out_iv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.initVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_initVars str (Or.inr (Or.inl hk)) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_mv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.modifiedVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_modVars str (Or.inl hk) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_exprs_sf : Block.exprsShapeFree (P := P) hoistKind (Block.nondetElim ss) := + Block.nondetElimM_exprsShapeFree + (fun sg => (ndelim_name_not_hoistKind sg).1) + (fun sg => (ndelim_name_not_hoistKind sg).2) + ss StringGenState.emp h_hoist_exprs + have h_out_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) (Block.nondetElim ss) = true := + nondetElim_hoistedNamesFreshInRhsAndGuards ss h_fresh h_ndelim_exprs + have h_out_undef : ∀ y ∈ Block.initVars (Block.nondetElim ss), ρ₀.store y = none := by + intro y hy + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp y hy with + h_src | ⟨str, h_eq, h_nd⟩ + · exact h_store_inits y h_src + · rw [h_eq]; exact h_store_mints_ndelim str h_nd + -- === STEP 2: hoist (structured, from ρ₀) === + obtain ⟨ρ_h', h_run2, h_agree2, h_hf2⟩ := + hoistLoopPrefixInits_preserves_kind (Q := hoistKind) hoistKind_gen + (extendEval := extendEval) (Block.nondetElim ss) + (nondetElim_containsNondetLoop ss) + (nondetElim_containsFuncDecl ss h_nofd) + (nondetElim_loopHasNoInvariants ss h_lhni) + (by rw [Block.loopMeasureNone_eq_noMeasureLoops]; exact nondetElim_noMeasureLoops ss h_nml) + h_out_exprs_sf h_out_unique h_out_fresh + h_out_iv_sf h_out_mv_sf h_out_undef h_store_mints_hoist h_run1 + hwfvar' hwfcongr' hwfsubst' hwfdef' + -- === Direction-B S2U preconds on the hoist output, at Q := s2uKind === + have h_hoist_iv_cls := + LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_initVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf + have h_step3_unique : Block.uniqueInits (Block.hoistLoopPrefixInits (Block.nondetElim ss)) := + h_hoist_iv_cls.2 + have h_out_undef_ext : ∀ y ∈ Block.initVars (Block.nondetElim ss), σ_ext y = none := by + intro y hy + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp y hy with + h_src | ⟨str, h_eq, h_nd⟩ + · exact h_store_inits_ext y h_src + · rw [h_eq]; exact h_store_mints_ndelim_ext str h_nd + have h_step3_undef_ext : ∀ x ∈ Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss)), + σ_ext x = none := by + intro x hx + rcases h_hoist_iv_cls.1 x hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · exact h_out_undef_ext x h_src + · rw [h_eq]; exact h_store_mints_hoist_ext str h_hoistk + have h_step3_iv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + intro s hk hx + rcases h_hoist_iv_cls.1 _ hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_src with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_step3_mv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (StructuredToUnstructuredCorrect.transformBlockModVars + (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + rw [transformBlockModVars_eq_modifiedVars] + intro s hk hx + rcases LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_modVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf _ hx with + h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rw [List.mem_append] at h_src + rcases h_src with h_mv | h_iv + · rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ h_mv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_modVars s (Or.inr hk) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_iv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + -- === STEP 3: stmtsToCFG via the COMPOSITIONAL S2U SHAPE spike (CFG from σ_ext) === + obtain ⟨σ_cfg, h_run3, h_agree3, h_preserve3⟩ := + StructuredToUnstructuredCorrect.stmtsToCFG_terminal_compositional_shape + (Q := StructuredToUnstructuredCorrect.s2uKind) + extendEval (Block.hoistLoopPrefixInits (Block.nondetElim ss)) ρ₀ ρ_h' σ_ext + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + (hoist_noFuncDecl _ (nondetElim_noFuncDecl ss h_nofd)) + (hoist_simpleShape _ (nondetElim_simpleShape ss)) + h_step3_unique + (hoist_loopBodyNoInits _) + (hoist_loopHasNoInvariants _ (nondetElim_loopHasNoInvariants ss h_lhni)) + (hoist_noMeasureLoops _ (nondetElim_noMeasureLoops ss h_nml)) + h_agree_ext + h_step3_undef_ext + (Block.userLabelsShapeNodup_pipeline_preserved ss h_disj) + h_store_mints_s2u_ext + h_step3_iv h_step3_mv + StructuredToUnstructuredCorrect.s2uKind_gen + h_run2 + -- === CHAIN via StoreAgreement.trans (source on the left) === + have h_hf : ρ_h'.hasFailure = ρ'.hasFailure := h_hf2.trans h_hf1 + rw [h_hf] at h_run3 + refine ⟨σ_cfg, h_run3, + StoreAgreement.trans h_agree1 (StoreAgreement.trans h_agree2 h_agree3), ?_⟩ + -- === Track B: rephrase the S2U preserve conjunct over the SOURCE vars/kinds === + -- The S2U `h_preserve3` excludes the S2U input program's `initVars` and + -- `s2uKind` idents; we discharge its `initVars` exclusion from the source + -- `initVars` + `¬ ndelimKind` + `¬ hoistKind` hypotheses via the same + -- classification lemmas. + intro x h_σext_x h_x_not_inits h_x_not_nd h_x_not_ho h_x_not_s2u + refine h_preserve3 x h_σext_x ?_ h_x_not_s2u + -- Goal: x ∉ Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss)) + intro hx + rcases h_hoist_iv_cls.1 x hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · -- x ∈ initVars (nondetElim ss): classify into source init or ndelim ident + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp x h_src with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_x_not_inits h_src2 + · exact h_x_not_nd str2 h_eq2 h_nd + · -- x = ident str with hoistKind str + exact h_x_not_ho str h_eq h_hoistk + +/-- **Pipeline soundness, terminal outcome (helper).** The terminal half of the +dual `pipeline_sound`: a *terminating* source run of `ss` from a clean initial +store `ρ₀` is matched by a terminating CFG run of `pipeline ss` agreeing on the +final store (source on the left). A real composition of the three terminal +`_sound_kind` theorems via `StoreAgreement.trans`. + +This is the terminal-only restatement the dual `pipeline_sound`'s terminal arm +delegates to; it is also what the refinement statements consume to discharge +their terminal clause, since that clause needs a *terminal* CFG witness directly +(the dual theorem's disjunctive conclusion cannot be projected to its terminal +disjunct without a target-IR determinism principle, which the development does +not carry). -/ +private theorem pipeline_sound_terminal [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] [HasSubstFvar P] [LawfulHasSubstFvar P] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfvar' : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (hwfcongr' : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (hwfsubst' : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (hwfdef' : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (h_store_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) + (h_store_mints_ndelim : NoGenStore (P := P) ndelimKind ρ₀) + (h_store_mints_hoist : NoGenStore (P := P) hoistKind ρ₀) + (h_store_mints_s2u : NoGenStore (P := P) StructuredToUnstructuredCorrect.s2uKind ρ₀) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_disj : StructuredToUnstructuredCorrect.Block.userLabelsShapeNodup ss) + (h_ndelim_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_ndelim_exprs : Block.exprsShapeFree (P := P) ndelimKind ss) + (h_hoist_exprs : Block.exprsShapeFree (P := P) hoistKind ss) + (h_disj_initVars : ∀ str : String, + (ndelimKind str ∨ hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.initVars ss) + (h_disj_modVars : ∀ str : String, + (hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) + (h_term : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ')) : + ∃ σ_cfg, StructuredToUnstructuredCorrect.StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry ρ₀.store ρ₀.hasFailure) + (.terminal σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := by + -- === STEP 1: nondetElim === StoreAgreement ρ'.store ρ_out.store. + obtain ⟨ρ_out, h_run1, h_agree1, h_hf1⟩ := + nondetElim_sound_kind extendEval ss ρ₀ ρ' + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + h_store_mints_ndelim h_ndelim_writes h_nofd h_lhni h_term + -- Direction-A hoist §F preconds on the `nondetElim` output, at `Q := hoistKind`. + have h_out_unique : Block.uniqueInits (Block.nondetElim ss) := + (Block.nondetElimM_initVars_nodup ss StringGenState.emp StringGenState.wf_emp + h_unique (fun str hk => h_disj_initVars str (Or.inl hk))).2 + have h_out_iv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.initVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_initVars str (Or.inr (Or.inl hk)) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_mv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.modifiedVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_modVars str (Or.inl hk) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_exprs_sf : Block.exprsShapeFree (P := P) hoistKind (Block.nondetElim ss) := + Block.nondetElimM_exprsShapeFree + (fun sg => (ndelim_name_not_hoistKind sg).1) + (fun sg => (ndelim_name_not_hoistKind sg).2) + ss StringGenState.emp h_hoist_exprs + have h_out_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) (Block.nondetElim ss) = true := + nondetElim_hoistedNamesFreshInRhsAndGuards ss h_fresh h_ndelim_exprs + have h_out_undef : ∀ y ∈ Block.initVars (Block.nondetElim ss), ρ₀.store y = none := by + intro y hy + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp y hy with + h_src | ⟨str, h_eq, h_nd⟩ + · exact h_store_inits y h_src + · rw [h_eq]; exact h_store_mints_ndelim str h_nd + -- === STEP 2: hoist (input `nondetElim ss`, source run = Step 1's) === + obtain ⟨ρ_h', h_run2, h_agree2, h_hf2⟩ := + hoistLoopPrefixInits_preserves_kind (Q := hoistKind) hoistKind_gen + (extendEval := extendEval) (Block.nondetElim ss) + (nondetElim_containsNondetLoop ss) + (nondetElim_containsFuncDecl ss h_nofd) + (nondetElim_loopHasNoInvariants ss h_lhni) + (by rw [Block.loopMeasureNone_eq_noMeasureLoops]; exact nondetElim_noMeasureLoops ss h_nml) + h_out_exprs_sf h_out_unique h_out_fresh + h_out_iv_sf + h_out_mv_sf + h_out_undef + h_store_mints_hoist + h_run1 + hwfvar' hwfcongr' hwfsubst' hwfdef' + -- === Direction-B S2U preconds on the hoist output, at `Q := s2uKind` === + have h_hoist_iv_cls := + LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_initVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf + have h_step3_unique : Block.uniqueInits (Block.hoistLoopPrefixInits (Block.nondetElim ss)) := + h_hoist_iv_cls.2 + have h_step3_undef : ∀ x ∈ Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss)), + ρ₀.store x = none := by + intro x hx + rcases h_hoist_iv_cls.1 x hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · exact h_out_undef x h_src + · rw [h_eq]; exact h_store_mints_hoist str h_hoistk + have h_step3_iv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + intro s hk hx + rcases h_hoist_iv_cls.1 _ hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_src with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_step3_mv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (StructuredToUnstructuredCorrect.transformBlockModVars + (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + rw [transformBlockModVars_eq_modifiedVars] + intro s hk hx + rcases LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_modVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf _ hx with + h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rw [List.mem_append] at h_src + rcases h_src with h_mv | h_iv + · rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ h_mv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_modVars s (Or.inr hk) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_iv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + -- === STEP 3: stmtsToCFG (input `hoist (nondetElim ss)`, source run = Step 2's) === + obtain ⟨σ_cfg, h_run3, h_agree3⟩ := + StructuredToUnstructuredCorrect.structuredToUnstructured_sound_kind + (Q := StructuredToUnstructuredCorrect.s2uKind) + StructuredToUnstructuredCorrect.s2uKind_gen + extendEval (Block.hoistLoopPrefixInits (Block.nondetElim ss)) ρ₀ ρ_h' + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + (hoist_noFuncDecl _ (nondetElim_noFuncDecl ss h_nofd)) + (hoist_simpleShape _ (nondetElim_simpleShape ss)) + h_step3_unique + (hoist_loopBodyNoInits _) + (hoist_loopHasNoInvariants _ (nondetElim_loopHasNoInvariants ss h_lhni)) + (hoist_noMeasureLoops _ (nondetElim_noMeasureLoops ss h_nml)) + h_step3_undef + -- Discharge the transformed-body `userLabelsShapeNodup` obligation from + -- the source-side condition: `userBlockLabels` is preserved by both + -- `nondetElim` and `hoistLoopPrefixInits`. + (Block.userLabelsShapeNodup_pipeline_preserved ss h_disj) + h_store_mints_s2u + h_step3_iv h_step3_mv + h_run2 + -- === CHAIN via StoreAgreement.trans (source on the left) === + have h_hf : ρ_h'.hasFailure = ρ'.hasFailure := h_hf2.trans h_hf1 + rw [h_hf] at h_run3 + exact ⟨σ_cfg, h_run3, StoreAgreement.trans h_agree1 (StoreAgreement.trans h_agree2 h_agree3)⟩ + +/-- **Pipeline soundness, exiting outcome (helper).** The exiting half of the +dual `pipeline_sound`: an *escaping* source run of `ss` from a clean initial +store `ρ₀` to a top-level uncaught exit `.exiting lbl ρ'` is matched by a CFG +run of `pipeline ss` reaching the *same* `.exiting lbl σ_cfg`, agreeing on the +final store (source on the left). A real composition of the three +`_sound_kind_exit` theorems via `StoreAgreement.trans`, threading the escaping +label `lbl` through each pass (the pipeline preserves the escaping label). + +This is the exiting-only restatement the dual `pipeline_sound`'s exiting arm +delegates to; it is also what the refinement statements consume to discharge +their exiting clause, since that clause needs an *exiting* CFG witness for the +*same* `lbl` directly (the dual theorem's disjunctive conclusion cannot be +projected to its exiting disjunct without a target-IR determinism principle, +which is not a theorem of the CFG semantics — the per-config evaluator binders +make `StepCFG` non-deterministic in its outcome kind). -/ +private theorem pipeline_sound_exiting [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] [HasSubstFvar P] [LawfulHasSubstFvar P] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfvar' : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (hwfcongr' : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (hwfsubst' : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (hwfdef' : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (h_store_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) + (h_store_mints_ndelim : NoGenStore (P := P) ndelimKind ρ₀) + (h_store_mints_hoist : NoGenStore (P := P) hoistKind ρ₀) + (h_store_mints_s2u : NoGenStore (P := P) StructuredToUnstructuredCorrect.s2uKind ρ₀) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_disj : StructuredToUnstructuredCorrect.Block.userLabelsShapeNodup ss) + (h_ndelim_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_ndelim_exprs : Block.exprsShapeFree (P := P) ndelimKind ss) + (h_hoist_exprs : Block.exprsShapeFree (P := P) hoistKind ss) + (h_disj_initVars : ∀ str : String, + (ndelimKind str ∨ hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.initVars ss) + (h_disj_modVars : ∀ str : String, + (hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) + (lbl : String) + (h_exit : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.exiting lbl ρ')) : + ∃ σ_cfg, StructuredToUnstructuredCorrect.StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry ρ₀.store ρ₀.hasFailure) + (.exiting lbl σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := by + -- === STEP 1: nondetElim (exiting) === + obtain ⟨ρ_out, h_run1, h_agree1, h_hf1⟩ := + nondetElim_sound_kind_exit extendEval ss ρ₀ ρ' + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + h_store_mints_ndelim h_ndelim_writes h_nofd h_lhni lbl h_exit + -- Direction-A hoist §F preconds on the `nondetElim` output, at `Q := hoistKind`. + have h_out_unique : Block.uniqueInits (Block.nondetElim ss) := + (Block.nondetElimM_initVars_nodup ss StringGenState.emp StringGenState.wf_emp + h_unique (fun str hk => h_disj_initVars str (Or.inl hk))).2 + have h_out_iv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.initVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_initVars str (Or.inr (Or.inl hk)) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_mv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.modifiedVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_modVars str (Or.inl hk) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_exprs_sf : Block.exprsShapeFree (P := P) hoistKind (Block.nondetElim ss) := + Block.nondetElimM_exprsShapeFree + (fun sg => (ndelim_name_not_hoistKind sg).1) + (fun sg => (ndelim_name_not_hoistKind sg).2) + ss StringGenState.emp h_hoist_exprs + have h_out_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) (Block.nondetElim ss) = true := + nondetElim_hoistedNamesFreshInRhsAndGuards ss h_fresh h_ndelim_exprs + have h_out_undef : ∀ y ∈ Block.initVars (Block.nondetElim ss), ρ₀.store y = none := by + intro y hy + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp y hy with + h_src | ⟨str, h_eq, h_nd⟩ + · exact h_store_inits y h_src + · rw [h_eq]; exact h_store_mints_ndelim str h_nd + -- === STEP 2: hoist (exiting; input `nondetElim ss`, source run = Step 1's) === + obtain ⟨ρ_h', h_run2, h_agree2, h_hf2⟩ := + hoistLoopPrefixInits_preserves_kind_exit (Q := hoistKind) hoistKind_gen + (extendEval := extendEval) (Block.nondetElim ss) + (nondetElim_containsNondetLoop ss) + (nondetElim_containsFuncDecl ss h_nofd) + (nondetElim_loopHasNoInvariants ss h_lhni) + (by rw [Block.loopMeasureNone_eq_noMeasureLoops]; exact nondetElim_noMeasureLoops ss h_nml) + h_out_exprs_sf h_out_unique h_out_fresh + h_out_iv_sf h_out_mv_sf + h_out_undef + h_store_mints_hoist + lbl h_run1 + hwfvar' hwfcongr' hwfsubst' hwfdef' + -- === Direction-B S2U preconds on the hoist output, at `Q := s2uKind` === + have h_hoist_iv_cls := + LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_initVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf + have h_step3_unique : Block.uniqueInits (Block.hoistLoopPrefixInits (Block.nondetElim ss)) := + h_hoist_iv_cls.2 + have h_step3_undef : ∀ x ∈ Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss)), + ρ₀.store x = none := by + intro x hx + rcases h_hoist_iv_cls.1 x hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · exact h_out_undef x h_src + · rw [h_eq]; exact h_store_mints_hoist str h_hoistk + have h_step3_iv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + intro s hk hx + rcases h_hoist_iv_cls.1 _ hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_src with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_step3_mv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (StructuredToUnstructuredCorrect.transformBlockModVars + (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + rw [transformBlockModVars_eq_modifiedVars] + intro s hk hx + rcases LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_modVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf _ hx with + h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rw [List.mem_append] at h_src + rcases h_src with h_mv | h_iv + · rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ h_mv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_modVars s (Or.inr hk) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_iv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + -- === STEP 3: stmtsToCFG (exiting; input `hoist (nondetElim ss)`, run = Step 2's) === + obtain ⟨σ_cfg, h_run3, h_agree3⟩ := + StructuredToUnstructuredCorrect.structuredToUnstructured_sound_kind_exit + (Q := StructuredToUnstructuredCorrect.s2uKind) + StructuredToUnstructuredCorrect.s2uKind_gen + extendEval (Block.hoistLoopPrefixInits (Block.nondetElim ss)) ρ₀ ρ_h' + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + (hoist_noFuncDecl _ (nondetElim_noFuncDecl ss h_nofd)) + (hoist_simpleShape _ (nondetElim_simpleShape ss)) + h_step3_unique + (hoist_loopBodyNoInits _) + (hoist_loopHasNoInvariants _ (nondetElim_loopHasNoInvariants ss h_lhni)) + (hoist_noMeasureLoops _ (nondetElim_noMeasureLoops ss h_nml)) + h_step3_undef + -- Discharge the transformed-body `userLabelsShapeNodup` obligation from + -- the source-side condition: `userBlockLabels` is preserved by both + -- `nondetElim` and `hoistLoopPrefixInits`. + (Block.userLabelsShapeNodup_pipeline_preserved ss h_disj) + h_store_mints_s2u + h_step3_iv h_step3_mv + lbl h_run2 + -- === CHAIN via StoreAgreement.trans (source on the left) === + have h_hf : ρ_h'.hasFailure = ρ'.hasFailure := h_hf2.trans h_hf1 + rw [h_hf] at h_run3 + exact ⟨σ_cfg, h_run3, StoreAgreement.trans h_agree1 (StoreAgreement.trans h_agree2 h_agree3)⟩ + +/-- **Pipeline soundness (dual outcome).** Every source run of `ss` from a clean +initial store `ρ₀` is matched by a run of the unstructured CFG `pipeline ss` +reaching the *matching* outcome with a final store agreeing with the source's +(source on the left). The source outcome selects the disjunct: + + * a *terminating* source run (`.terminal ρ'`) is matched by a CFG run reaching + `.terminal σ_cfg`; and + * an *escaping* source run (`.exiting lbl ρ'` — an uncaught top-level exit, as + every label is uncaught at the top level where `exitConts = []`) is matched + by a CFG run reaching the *same* `.exiting lbl σ_cfg`. + +A real composition of the three `_sound_kind`/`_sound_kind_exit` theorems via +`StoreAgreement.trans`: no hypothesis is vacuous or false — each precondition is +satisfiable by a clean initial store and a shape-restricted, kind-free user +program. Each pass preserves the outcome *kind* over `StoreAgreement`, so the +disjunct chosen at the source is carried verbatim to the CFG conclusion: the +terminal arm composes the unchanged terminal lemmas, the exiting arm the banked +`_sound_kind_exit` siblings that surface the sum-typed loop-body drivers. -/ +theorem pipeline_sound [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] + [HasSubstFvar P] [LawfulHasSubstFvar P] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ ρ' : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfvar' : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (hwfcongr' : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (hwfsubst' : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (hwfdef' : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + -- `ρ₀` need only leave the source inits and the three passes' minted + -- (gen-kind) names undefined — not the entire store. Source inits are the + -- runtime-shape precondition the hoist's `prelude_execution` consumes; the + -- minted names (`ndelimKind`/`hoistKind`/`s2uKind`) are foreign to the source + -- vars and their undefinedness is irreducibly required (a fresh guard or a + -- fresh CFG-relevant binder collides with a populated store). `modVars` need + -- NOT be undefined. + (h_store_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) + (h_store_mints_ndelim : NoGenStore (P := P) ndelimKind ρ₀) + (h_store_mints_hoist : NoGenStore (P := P) hoistKind ρ₀) + (h_store_mints_s2u : NoGenStore (P := P) StructuredToUnstructuredCorrect.s2uKind ρ₀) + -- source shape restrictions (front-end well-formedness): + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_disj : StructuredToUnstructuredCorrect.Block.userLabelsShapeNodup ss) + -- source kind-freedom (user names never collide with any minted prefix): + (h_ndelim_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_ndelim_exprs : Block.exprsShapeFree (P := P) ndelimKind ss) + (h_hoist_exprs : Block.exprsShapeFree (P := P) hoistKind ss) + -- The three passes' minted-name kinds avoid the source `initVars` (one merged + -- disjunction over the three pass kinds, replacing the per-kind triple): + (h_disj_initVars : ∀ str : String, + (ndelimKind str ∨ hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.initVars ss) + -- The hoist/S2U minted-name kinds avoid the source `modifiedVars` (one merged + -- disjunction; `ndelimKind` modVars-freedom is folded into `h_ndelim_writes`): + (h_disj_modVars : ∀ str : String, + (hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) + (h_run : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.terminal ρ') + ∨ ∃ lbl, StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.exiting lbl ρ')) : + (∃ σ_cfg, StructuredToUnstructuredCorrect.StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry ρ₀.store ρ₀.hasFailure) + (.terminal σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg) + ∨ (∃ lbl σ_cfg, StructuredToUnstructuredCorrect.StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry ρ₀.store ρ₀.hasFailure) + (.exiting lbl σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg) := by + rcases h_run with h_term | ⟨lbl, h_exit⟩ + -- ========================================================================= + -- EXITING ARM — the source run reaches `.exiting lbl ρ'` (an uncaught + -- top-level exit); delegate to the exiting-only helper, which composes the + -- three banked `_sound_kind_exit` siblings (the sum-typed loop-body drivers), + -- threading the escaping label `lbl` through. Factored out so the refinement + -- statements can consume an exiting CFG witness directly. + -- ========================================================================= + case inr => + right + obtain ⟨σ_cfg, h_run, h_agree⟩ := + pipeline_sound_exiting extendEval ss ρ₀ ρ' + hwfb hwfv hwfvar' hwfcongr' hwfsubst' hwfdef' + h_store_inits h_store_mints_ndelim h_store_mints_hoist h_store_mints_s2u + h_nofd h_lhni h_nml h_unique h_fresh h_disj + h_ndelim_writes h_ndelim_exprs h_hoist_exprs h_disj_initVars h_disj_modVars + lbl h_exit + exact ⟨lbl, σ_cfg, h_run, h_agree⟩ + -- ========================================================================= + -- TERMINAL ARM — the source run reaches `.terminal ρ'`; delegate to the + -- terminal-only helper, which composes the three terminal `_sound_kind` + -- lemmas (the single-outcome proof, factored out so the refinement statements + -- can consume a terminal CFG witness directly). + -- ========================================================================= + left + exact pipeline_sound_terminal extendEval ss ρ₀ ρ' + hwfb hwfv hwfvar' hwfcongr' hwfsubst' hwfdef' + h_store_inits h_store_mints_ndelim h_store_mints_hoist h_store_mints_s2u + h_nofd h_lhni h_nml h_unique h_fresh h_disj + h_ndelim_writes h_ndelim_exprs h_hoist_exprs h_disj_initVars h_disj_modVars h_term + +/-- The bundled precondition under which `pipeline ss` refines `ss`. + +Its fields are exactly the dual `pipeline_sound`'s hypothesis list — the +well-formed evaluator bundle, the clean-initial-store conditions +(`h_store_inits`, `h_store_mints`), the source shape restrictions, and the +per-pass minted-name kind-freedom conditions. No covered-exit condition is +required: the refinement discharges *both* outcomes (terminal and escaping +exit) non-vacuously from the dual soundness helpers, so a top-level escaping +exit is matched, not assumed away. -/ +structure PipelinePre [HasFvar P] [HasNot P] [HasVal P] [HasVarsPure P P.Expr] + [HasBoolVal P] [HasIdent P] [HasIntOrder P] [HasSubstFvar P] + [DecidableEq P.Ident] (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ : Env P) : Prop where + hwfb : WellFormedSemanticEvalBool ρ₀.eval + hwfv : WellFormedSemanticEvalVal ρ₀.eval + hwfvar' : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval + hwfcongr' : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval + hwfsubst' : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval + hwfdef' : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval + h_store_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none + h_store_mints_ndelim : NoGenStore (P := P) ndelimKind ρ₀ + h_store_mints_hoist : NoGenStore (P := P) hoistKind ρ₀ + h_store_mints_s2u : NoGenStore (P := P) StructuredToUnstructuredCorrect.s2uKind ρ₀ + h_nofd : Block.noFuncDecl ss = true + h_lhni : Block.loopHasNoInvariants ss = true + h_nml : Block.noMeasureLoops ss = true + h_unique : Block.uniqueInits ss + h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true + h_disj : StructuredToUnstructuredCorrect.Block.userLabelsShapeNodup ss + h_ndelim_writes : SrcNoGenWrites (P := P) ndelimKind ss + h_ndelim_exprs : Block.exprsShapeFree (P := P) ndelimKind ss + h_hoist_exprs : Block.exprsShapeFree (P := P) hoistKind ss + h_disj_initVars : ∀ str : String, + (ndelimKind str ∨ hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.initVars ss + h_disj_modVars : ∀ str : String, + (hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss + +/-- The source statement-list language whose initial-environment well-formedness +field carries the `ρ₀`-dependent pipeline preconditions. + +This is `Lang.imperativeBlock` over `Cmd P` / `EvalCmd P` / `isAtAssert`, but +with `initEnvWF` overriding the trivial default: `initEnvWF () ss ρ₀` is exactly +`PipelinePre extendEval ss ρ₀`. Routing the bundle through `initEnvWF` lets a +downstream consumer state the preconditions per-language (via the `Lang`'s own +`initEnvWF` field) instead of carrying them as a separate explicit hypothesis, +which is what the up-to-relation overapproximation family expects. + +`InitEnvWFParamsTy` stays `Unit`: `PipelinePre` already takes the statement `ss` +and the environment `ρ₀` directly, so no extra parameter record is needed. -/ +abbrev Lang.imperativeBlockSrc [HasFvar P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [HasSubstFvar P] (extendEval : ExtendEval P) : Specification.Lang P := + Specification.Transform.Lang.imperativeBlock (P := P) (CmdT := Cmd P) + (EvalCmd P) extendEval (isAtAssert P) + Unit (fun _ ss ρ₀ => PipelinePre extendEval ss ρ₀) + +/-- **Projection of the source `initEnvWF`.** The custom `initEnvWF` of +`Lang.imperativeBlockSrc` unfolds to the full `PipelinePre` bundle, from which +every individual pipeline precondition (the well-formed-evaluator facts, the +clean-initial-store conditions, the per-pass minted-name kind-freedom +conditions, and the source-shape restrictions) is recoverable. + +This is the entry point a downstream up-to-relation overapproximation proof uses +to turn the `L₁.initEnvWF params st ρ₀` hypothesis back into the concrete facts +the dual `pipeline_sound` consumes. -/ +theorem imperativeBlockSrc_initEnvWF_pipelinePre [HasFvar P] [HasNot P] [HasVal P] + [HasBoolVal P] [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] + [DecidableEq P.Ident] [HasSubstFvar P] (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ : Env P) + (h : (Lang.imperativeBlockSrc extendEval).initEnvWF () ss ρ₀) : + PipelinePre extendEval ss ρ₀ := h + +/-- **Structured-pass failing-config bridge.** The combined structured prefix +`hoist ∘ nondetElim` carries an *arbitrary reachable failing* source configuration +to a reachable failing configuration of the transformed program, running both from +the *same* clean initial environment `ρ₀`. + +The endpoint-keyed per-pass simulation lemmas (`nondetElim_simulation`, +`hoistLoopPrefixInits_preserves`, and their kind variants) cannot supply this: +each consumes a source run reaching `.terminal ρ'` / `.exiting lbl ρ'` and +produces a matching transformed endpoint, whereas a failing source configuration +need NOT lie on a run that reaches an endpoint (`assert` is a skip in the +operational semantics — it only OR-s the cumulative `hasFailure` flag and +continues — so a failing run may diverge or get stuck afterwards with no +terminal/exiting endpoint). + +The per-pass *failing-config* siblings (`nondetElim_to_fail` and +`hoistLoopPrefixInits_to_fail_kind`) are keyed on a failing configuration as the +halting condition, so they DO supply it. `structuredPassFailingBridge_holds` +composes them to discharge this bridge from the (PipelinePre-derivable) +structured-pass preconditions; it is no longer taken as a hypothesis. -/ +@[expose] def StructuredPassFailingBridge + [HasFvar P] [HasNot P] [HasVal P] [HasBoolVal P] + [HasIdent P] [HasIntOrder P] [HasVarsPure P P.Expr] [DecidableEq P.Ident] + [HasSubstFvar P] + (extendEval : ExtendEval P) (ss : List (Stmt P (Cmd P))) (ρ₀ : Env P) : Prop := + ∀ c : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) c → + c.getEnv.hasFailure = true → + ∃ c' : Config P (Cmd P), + StepStmtStar P (EvalCmd P) extendEval + (.stmts (Block.hoistLoopPrefixInits (Block.nondetElim ss)) ρ₀) c' + ∧ c'.getEnv.hasFailure = true + +/-- **Discharge of the structured-pass failing-config bridge.** Given the +structured-pass preconditions (all `PipelinePre`-derivable), the +`StructuredPassFailingBridge` holds: a reachable failing source configuration of +`ss` is matched by a reachable failing configuration of +`hoist (nondetElim ss)`, started from the same `ρ₀`. + +Composition: `nondetElim_to_fail` transports the source failing config to a +failing config of `nondetElim ss`; `hoistLoopPrefixInits_to_fail_kind` (at +`Q := hoistKind`) then transports that to a failing config of +`hoist (nondetElim ss)`. The hoist pass's structural / kind-freedom preconditions +on `nondetElim ss` are discharged from the source-shape and minted-name conditions +by the SAME `nondetElim` postcondition plumbing the terminal compositional pipeline +uses (the `containsNondetLoop`/`noFuncDecl`/`loopHasNoInvariants`/`loopMeasureNone` +preservation lemmas, the `initVars`/`modVars` classifications, and the +`exprsShapeFree` / `hoistedNamesFreshInRhsAndGuards` transports). -/ +theorem structuredPassFailingBridge_holds + [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] [HasSubstFvar P] [LawfulHasSubstFvar P] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ : Env P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfvar' : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (hwfcongr' : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (hwfsubst' : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (hwfdef' : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (h_store_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) + (h_store_mints_ndelim : NoGenStore (P := P) ndelimKind ρ₀) + (h_store_mints_hoist : NoGenStore (P := P) hoistKind ρ₀) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_ndelim_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_ndelim_exprs : Block.exprsShapeFree (P := P) ndelimKind ss) + (h_hoist_exprs : Block.exprsShapeFree (P := P) hoistKind ss) + (h_disj_initVars : ∀ str : String, + (ndelimKind str ∨ hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.initVars ss) + (h_disj_modVars : ∀ str : String, + (hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) : + StructuredPassFailingBridge extendEval ss ρ₀ := by + intro c h_reach h_c_fail + -- === STEP 1 (failing): source `ss` failing config ⟹ `nondetElim ss` failing. === + obtain ⟨c1, h_run1, h_c1_fail⟩ := + nondetElim_to_fail extendEval ss ρ₀ c + hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + h_store_mints_ndelim h_ndelim_writes h_nofd h_lhni h_reach h_c_fail + -- === Direction-A hoist preconds on `nondetElim ss` (same plumbing as the + -- terminal compositional pipeline). === + have h_out_unique : Block.uniqueInits (Block.nondetElim ss) := + (Block.nondetElimM_initVars_nodup ss StringGenState.emp StringGenState.wf_emp + h_unique (fun str hk => h_disj_initVars str (Or.inl hk))).2 + have h_out_iv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.initVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_initVars str (Or.inr (Or.inl hk)) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_mv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.modifiedVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_modVars str (Or.inl hk) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_out_exprs_sf : Block.exprsShapeFree (P := P) hoistKind (Block.nondetElim ss) := + Block.nondetElimM_exprsShapeFree + (fun sg => (ndelim_name_not_hoistKind sg).1) + (fun sg => (ndelim_name_not_hoistKind sg).2) + ss StringGenState.emp h_hoist_exprs + have h_out_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) (Block.nondetElim ss) = true := + nondetElim_hoistedNamesFreshInRhsAndGuards ss h_fresh h_ndelim_exprs + have h_out_undef : ∀ y ∈ Block.initVars (Block.nondetElim ss), ρ₀.store y = none := by + intro y hy + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp y hy with + h_src | ⟨str, h_eq, h_nd⟩ + · exact h_store_inits y h_src + · rw [h_eq]; exact h_store_mints_ndelim str h_nd + -- === STEP 2 (failing): `nondetElim ss` failing config ⟹ `hoist (nondetElim ss)` + -- failing config. === + obtain ⟨c2, h_run2, h_c2_fail⟩ := + hoistLoopPrefixInits_to_fail_kind (Q := hoistKind) hoistKind_gen + (extendEval := extendEval) (Block.nondetElim ss) + (nondetElim_containsNondetLoop ss) + (nondetElim_containsFuncDecl ss h_nofd) + (nondetElim_loopHasNoInvariants ss h_lhni) + (by rw [Block.loopMeasureNone_eq_noMeasureLoops]; exact nondetElim_noMeasureLoops ss h_nml) + h_out_exprs_sf h_out_unique h_out_fresh + h_out_iv_sf h_out_mv_sf h_out_undef h_store_mints_hoist h_run1 h_c1_fail + hwfvar' hwfcongr' hwfsubst' hwfdef' + exact ⟨c2, h_run2, h_c2_fail⟩ + +/-- **Pipeline failure preservation (unconditional).** An arbitrary reachable +failing source configuration of `ss` (no terminal/exiting endpoint required) is +matched by a reachable failing configuration of the CFG `pipeline ss`, started +from an overapproximating external store `σ_ext`. + +Composition: `structuredPassFailingBridge_holds` (discharged inline from the +structured-pass preconditions) transports the source failing config to a failing +config of `hoist (nondetElim ss)`; `structuredToUnstructured_sound_kind_fail` (the +S2U failing-config sibling) then transports that to a failing CFG config. The S2U +pass consumes the `σ_ext` agreement and the `σ_ext`-stated freshness (source +`initVars` and all three minted kinds undefined in `σ_ext`), exactly as in the +terminal compositional theorem; the structured-pass `_disj`/shape side conditions +flow through `nondetElim`/`hoist` postconditions identically. -/ +theorem pipeline_to_fail + [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] [HasSubstFvar P] [LawfulHasSubstFvar P] + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) (ρ₀ : Env P) + (c : Config P (Cmd P)) + (σ_ext : SemanticStore P) + (h_ρ₀_nofail : ρ₀.hasFailure = false) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwfvar' : ∀ ρ : Env P, WellFormedSemanticEvalVar ρ.eval) + (hwfcongr' : ∀ ρ : Env P, WellFormedSemanticEvalExprCongr ρ.eval) + (hwfsubst' : ∀ ρ : Env P, WellFormedSemanticEvalSubstFvar ρ.eval) + (hwfdef' : ∀ ρ : Env P, WellFormedSemanticEvalDef ρ.eval) + (h_store_inits : ∀ x ∈ Block.initVars ss, ρ₀.store x = none) + (h_store_mints_ndelim : NoGenStore (P := P) ndelimKind ρ₀) + (h_store_mints_hoist : NoGenStore (P := P) hoistKind ρ₀) + (h_agree_ext : StoreAgreement ρ₀.store σ_ext) + (h_store_inits_ext : ∀ x ∈ Block.initVars ss, σ_ext x = none) + (h_store_mints_ndelim_ext : + ∀ s : String, ndelimKind s → σ_ext (HasIdent.ident (P := P) s) = none) + (h_store_mints_hoist_ext : + ∀ s : String, hoistKind s → σ_ext (HasIdent.ident (P := P) s) = none) + (h_store_mints_s2u_ext : + ∀ s : String, StructuredToUnstructuredCorrect.s2uKind s → + σ_ext (HasIdent.ident (P := P) s) = none) + (h_nofd : Block.noFuncDecl ss = true) + (h_lhni : Block.loopHasNoInvariants ss = true) + (h_nml : Block.noMeasureLoops ss = true) + (h_unique : Block.uniqueInits ss) + (h_fresh : Block.hoistedNamesFreshInRhsAndGuards (P := P) ss = true) + (h_disj : StructuredToUnstructuredCorrect.Block.userLabelsShapeNodup ss) + (h_ndelim_writes : SrcNoGenWrites (P := P) ndelimKind ss) + (h_ndelim_exprs : Block.exprsShapeFree (P := P) ndelimKind ss) + (h_hoist_exprs : Block.exprsShapeFree (P := P) hoistKind ss) + (h_disj_initVars : ∀ str : String, + (ndelimKind str ∨ hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.initVars ss) + (h_disj_modVars : ∀ str : String, + (hoistKind str ∨ StructuredToUnstructuredCorrect.s2uKind str) → + HasIdent.ident (P := P) str ∉ Block.modifiedVars ss) + (h_reach : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) c) + (h_c_fail : c.getEnv.hasFailure = true) : + ∃ d : CFGConfig String (Cmd P) P, + StructuredToUnstructuredCorrect.StepDetCFGStar extendEval (pipeline ss) + (.atBlock (pipeline ss).entry σ_ext ρ₀.hasFailure) d + ∧ d.getFailure = true := by + -- === STRUCTURED PASSES: bridge the source failing config to a failing config + -- of `hoist (nondetElim ss)` (running from the same `ρ₀`). The structured-pass + -- failing bridge is discharged inline from the (PipelinePre-derivable) + -- structured-pass preconditions. === + obtain ⟨c', h_reach', h_c'_fail⟩ := + structuredPassFailingBridge_holds extendEval ss ρ₀ + hwfb hwfv hwfvar' hwfcongr' hwfsubst' hwfdef' + h_store_inits h_store_mints_ndelim h_store_mints_hoist + h_nofd h_lhni h_nml h_unique h_fresh + h_ndelim_writes h_ndelim_exprs h_hoist_exprs h_disj_initVars h_disj_modVars + c h_reach h_c_fail + -- === Direction-A/B structural side conditions on the structured output, reused + -- verbatim from the terminal compositional theorem. === + have h_out_unique : Block.uniqueInits (Block.nondetElim ss) := + (Block.nondetElimM_initVars_nodup ss StringGenState.emp StringGenState.wf_emp + h_unique (fun str hk => h_disj_initVars str (Or.inl hk))).2 + have h_out_iv_sf : ∀ str : String, hoistKind str → + HasIdent.ident (P := P) str ∉ Block.initVars (Block.nondetElim ss) := by + intro str hk hmem + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ hmem with + h_src | ⟨str', h_eq, h_nd⟩ + · exact h_disj_initVars str (Or.inr (Or.inl hk)) h_src + · exact ndelimKind_not_hoistKind h_nd (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_hoist_iv_cls := + LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_initVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf + have h_step3_unique : Block.uniqueInits (Block.hoistLoopPrefixInits (Block.nondetElim ss)) := + h_hoist_iv_cls.2 + have h_out_undef_ext : ∀ y ∈ Block.initVars (Block.nondetElim ss), σ_ext y = none := by + intro y hy + rcases Block.nondetElimM_initVars_classified ss StringGenState.emp y hy with + h_src | ⟨str, h_eq, h_nd⟩ + · exact h_store_inits_ext y h_src + · rw [h_eq]; exact h_store_mints_ndelim_ext str h_nd + have h_step3_undef_ext : ∀ x ∈ Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss)), + σ_ext x = none := by + intro x hx + rcases h_hoist_iv_cls.1 x hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · exact h_out_undef_ext x h_src + · rw [h_eq]; exact h_store_mints_hoist_ext str h_hoistk + have h_step3_iv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (Block.initVars (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + intro s hk hx + rcases h_hoist_iv_cls.1 _ hx with h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_src with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + have h_step3_mv : Strata.Transform.GenSuffix.NoGenSuffix + (P := P) StructuredToUnstructuredCorrect.s2uKind + (StructuredToUnstructuredCorrect.transformBlockModVars + (Block.hoistLoopPrefixInits (Block.nondetElim ss))) := by + rw [transformBlockModVars_eq_modifiedVars] + intro s hk hx + rcases LoopInitHoistLoopArmWF.Block.hoistLoopPrefixInitsM_modVars_classified (Q := hoistKind) hoistKind_gen + (Block.nondetElim ss) StringGenState.emp StringGenState.wf_emp h_out_unique h_out_iv_sf _ hx with + h_src | ⟨str, h_eq, _, _, h_hoistk⟩ + · rw [List.mem_append] at h_src + rcases h_src with h_mv | h_iv + · rcases Block.nondetElimM_modVars_classified ss StringGenState.emp _ h_mv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_modVars s (Or.inr hk) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · rcases Block.nondetElimM_initVars_classified ss StringGenState.emp _ h_iv with + h_src2 | ⟨str2, h_eq2, h_nd⟩ + · exact h_disj_initVars s (Or.inr (Or.inr hk)) h_src2 + · exact ndelimKind_not_s2uKind h_nd (LawfulHasIdent.ident_inj h_eq2 ▸ hk) + · exact hoistKind_not_s2uKind h_hoistk (LawfulHasIdent.ident_inj h_eq ▸ hk) + -- === FINAL S2U PASS: transport the failing config of `hoist (nondetElim ss)` + -- to a failing CFG config, from the external store `σ_ext`. === + exact StructuredToUnstructuredCorrect.structuredToUnstructured_sound_kind_fail + (Q := StructuredToUnstructuredCorrect.s2uKind) + StructuredToUnstructuredCorrect.s2uKind_gen + extendEval (Block.hoistLoopPrefixInits (Block.nondetElim ss)) ρ₀ c' σ_ext + h_ρ₀_nofail hwfb hwfv (hwfdef' ρ₀) (hwfcongr' ρ₀) (hwfvar' ρ₀) + (hoist_noFuncDecl _ (nondetElim_noFuncDecl ss h_nofd)) + (hoist_simpleShape _ (nondetElim_simpleShape ss)) + h_step3_unique + (hoist_loopBodyNoInits _) + (hoist_loopHasNoInvariants _ (nondetElim_loopHasNoInvariants ss h_lhni)) + (hoist_noMeasureLoops _ (nondetElim_noMeasureLoops ss h_nml)) + h_agree_ext h_step3_undef_ext + (Block.userLabelsShapeNodup_pipeline_preserved ss h_disj) + h_store_mints_s2u_ext + h_step3_iv h_step3_mv + h_reach' h_c'_fail + +/-- **Covered-exit no-escape.** When every `.exit` in the source `ss` is caught +by an enclosing labeled block (`Block.exitsCoveredByBlocks [] ss`), no source +run reaches a top-level `.exiting` configuration — it can only terminate (or +diverge). + +This is an independent characterization of the covered-exit fragment: for such +programs the exiting disjunct of `pipeline_sound` is empty, so its terminal +disjunct holds outright. (`pipeline_sound` itself no longer needs this — it is +dual, matching whichever outcome the source reaches via the real +`CFGConfig.exiting` target; this lemma remains a useful standalone fact about +exit-covered programs.) -/ +theorem pipeline_no_escaping_exit + [HasFvar P] [HasNot P] [HasBool P] [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) (ss : List (Stmt P (Cmd P))) + (h_covered : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks [] ss) : + ∀ (ρ₀ : Env P) (lbl : String) (ρ' : Env P), + ¬ StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) (.exiting lbl ρ') := by + intro ρ₀ lbl ρ' + exact block_exitsCoveredByBlocks_noEscape P (EvalCmd P) extendEval ss h_covered ρ₀ lbl ρ' + +end PipelineSound + +end Imperative diff --git a/Strata/Transform/PipelineLabelsPreserved.lean b/Strata/Transform/PipelineLabelsPreserved.lean new file mode 100644 index 0000000000..3d1b41f457 --- /dev/null +++ b/Strata/Transform/PipelineLabelsPreserved.lean @@ -0,0 +1,439 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.Transform.NondetElim +public import Strata.Transform.LoopInitHoist +public import Strata.Languages.Core.Statement + +-- `import all` to reach the (module-private) `_out`/`_residual` projection +-- lemmas of the two structured-to-structured passes; these are the same +-- per-constructor projections the downstream correctness files consume. +import all Strata.Transform.NondetElim +import all Strata.Transform.LoopInitHoist + +public section + +namespace Imperative + +/-! # `userBlockLabels` is preserved by `nondetElim` and `hoistLoopPrefixInits` + +The structured-to-structured passes `Block.nondetElim` (eliminates +nondeterministic control) and `Block.hoistLoopPrefixInits` (lifts loop-body +inits out as fresh-named siblings) both preserve the multiset *and order* of +user-provided `.block` labels: every label is carried through verbatim, the +freshly minted statements are all `.cmd`s (which `userBlockLabels` ignores), +and the loop-body rename step (`applyRenames`, a fold of `substIdent`) renames +identifiers without touching `.block` labels (which are `String` literals, not +`P.Ident` substitution targets). + +Hence the source-side well-formedness condition `userLabelsShapeNodup ss` +(which depends only on `userBlockLabels ss` as a list) survives the pipeline +prefix `hoistLoopPrefixInits ∘ nondetElim`. The final corollary +`userLabelsShapeNodup_pipeline_preserved` discharges the transformed-body +obligation from the source-side condition, so the front-end never has to +reason about `hoist (nondetElim ss)`. -/ + +/-! ## Distributivity helpers for `userBlockLabels` + +`userBlockLabels` is a list-valued structural walk, so the per-constructor +`_out`/`_residual`/havoc-prefix lemmas of the passes (which split via `++` and +`List.map Stmt.cmd`) need these two distributivity facts. -/ + +/-- `userBlockLabels` of the empty block is empty. -/ +theorem Block.userBlockLabels_nil {P : PureExpr} {C : Type} : + Block.userBlockLabels ([] : List (Stmt P C)) = [] := rfl + +/-- `userBlockLabels` distributes over list concatenation. -/ +theorem Block.userBlockLabels_append {P : PureExpr} {C : Type} + (ss₁ ss₂ : List (Stmt P C)) : + Block.userBlockLabels (ss₁ ++ ss₂) = + Block.userBlockLabels ss₁ ++ Block.userBlockLabels ss₂ := by + induction ss₁ with + | nil => simp [Block.userBlockLabels] + | cons s rest ih => + simp only [List.cons_append, Block.userBlockLabels, ih, List.append_assoc] + +/-- A list of `.cmd` statements contributes no user block labels. -/ +theorem Block.userBlockLabels_map_cmd {P : PureExpr} {C : Type} + (cs : List C) : + Block.userBlockLabels (cs.map (@Stmt.cmd P C)) = ([] : List String) := by + induction cs with + | nil => simp [Block.userBlockLabels] + | cons c rest ih => + simp only [List.map_cons] + rw [Block.userBlockLabels_cmd_cons, ih] + +/-! ## `substIdent` / `applyRenames` preserve `userBlockLabels` + +A rename `y → y'` rewrites command/guard/measure/invariant *identifiers*; the +`.block` arm carries its `String` label through verbatim (see +`Stmt.substIdent_block`). So `substIdent` — and `applyRenames`, a fold of +`substIdent` — leave `userBlockLabels` unchanged. Proof template: +`Stmt/Block.substIdent_noInitsAnywhere`. -/ + +mutual +/-- `Stmt.substIdent` preserves `userBlockLabels` (singleton form). -/ +theorem Stmt.substIdent_userBlockLabels {P : PureExpr} + [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) + (s : Stmt P (Cmd P)) : + Block.userBlockLabels [Stmt.substIdent y y' s] = Block.userBlockLabels [s] := by + match s with + | .cmd c => simp only [Stmt.substIdent_cmd, Block.userBlockLabels_cmd_cons] + | .block lbl bss md => + simp only [Stmt.substIdent_block] + rw [show ([Stmt.block lbl (Block.substIdent y y' bss) md] : List (Stmt P (Cmd P))) + = Stmt.block lbl (Block.substIdent y y' bss) md :: [] from rfl, + Block.userBlockLabels_block_cons, + show ([Stmt.block lbl bss md] : List (Stmt P (Cmd P))) + = Stmt.block lbl bss md :: [] from rfl, + Block.userBlockLabels_block_cons, + Block.substIdent_userBlockLabels y y' bss] + | .ite g tss ess md => + simp only [Stmt.substIdent_ite] + rw [show ([Stmt.ite (g.substIdent y y') (Block.substIdent y y' tss) + (Block.substIdent y y' ess) md] : List (Stmt P (Cmd P))) + = Stmt.ite (g.substIdent y y') (Block.substIdent y y' tss) + (Block.substIdent y y' ess) md :: [] from rfl, + Block.userBlockLabels_ite_cons, + show ([Stmt.ite g tss ess md] : List (Stmt P (Cmd P))) + = Stmt.ite g tss ess md :: [] from rfl, + Block.userBlockLabels_ite_cons, + Block.substIdent_userBlockLabels y y' tss, + Block.substIdent_userBlockLabels y y' ess] + | .loop g m inv body md => + simp only [Stmt.substIdent_loop] + rw [show ([Stmt.loop (g.substIdent y y') + (m.map (fun mm => HasSubstFvar.substFvar mm y (HasFvar.mkFvar y'))) + (inv.map (fun p => (p.1, HasSubstFvar.substFvar p.2 y (HasFvar.mkFvar y')))) + (Block.substIdent y y' body) md] : List (Stmt P (Cmd P))) + = Stmt.loop (g.substIdent y y') + (m.map (fun mm => HasSubstFvar.substFvar mm y (HasFvar.mkFvar y'))) + (inv.map (fun p => (p.1, HasSubstFvar.substFvar p.2 y (HasFvar.mkFvar y')))) + (Block.substIdent y y' body) md :: [] from rfl, + Block.userBlockLabels_loop_cons, + show ([Stmt.loop g m inv body md] : List (Stmt P (Cmd P))) + = Stmt.loop g m inv body md :: [] from rfl, + Block.userBlockLabels_loop_cons, + Block.substIdent_userBlockLabels y y' body] + | .exit lbl md => simp only [Stmt.substIdent] + | .funcDecl d md => simp only [Stmt.substIdent] + | .typeDecl t md => simp only [Stmt.substIdent] + termination_by sizeOf s + +/-- `Block.substIdent` preserves `userBlockLabels`. -/ +theorem Block.substIdent_userBlockLabels {P : PureExpr} + [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] (y y' : P.Ident) + (ss : List (Stmt P (Cmd P))) : + Block.userBlockLabels (Block.substIdent y y' ss) = Block.userBlockLabels ss := by + match ss with + | [] => simp [Block.userBlockLabels] + | s :: rest => + rw [Block.substIdent, + show (Stmt.substIdent y y' s :: Block.substIdent y y' rest) + = [Stmt.substIdent y y' s] ++ Block.substIdent y y' rest from rfl, + Block.userBlockLabels_append, + show (s :: rest) = [s] ++ rest from rfl, + Block.userBlockLabels_append, + Stmt.substIdent_userBlockLabels y y' s, + Block.substIdent_userBlockLabels y y' rest] + termination_by sizeOf ss +end + +/-- `Block.applyRenames` (a fold of `Block.substIdent`) preserves +`userBlockLabels`. Template: `Block.applyRenames_noInitsAnywhere`. -/ +theorem Block.applyRenames_userBlockLabels {P : PureExpr} + [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (renames : List (P.Ident × P.Ident)) (ss : List (Stmt P (Cmd P))) : + Block.userBlockLabels (Block.applyRenames renames ss) = + Block.userBlockLabels ss := by + unfold Block.applyRenames + induction renames generalizing ss with + | nil => simp + | cons p rest ih => + simp only [List.foldl_cons] + rw [ih (Block.substIdent p.1 p.2 ss), Block.substIdent_userBlockLabels] + +/-! ## The lift residual preserves `userBlockLabels` + +`liftInitsInLoopBodyM`'s residual (`.1.2.2`) rewrites every collected `.init` +into a same-name `.set` (still a `.cmd`), recurses through `.block`/`.ite`, and +leaves `.loop`s untouched (they are already hoist-processed). None of these +moves change `userBlockLabels`. -/ + +mutual +/-- `Stmt.liftInitsInLoopBodyM`'s residual preserves `userBlockLabels`. -/ +theorem Stmt.liftInitsInLoopBodyM_userBlockLabels {P : PureExpr} [HasIdent P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.userBlockLabels (Stmt.liftInitsInLoopBodyM s σ).1.2.2 = + Block.userBlockLabels [s] := by + match s with + | .cmd c => + -- Every `.cmd` arm of the lift returns a residual that is a singleton + -- `.cmd` (the `.init` arm rewrites to a same-name `.set`), so both sides + -- collapse to `[]`. + cases c <;> + simp only [Stmt.liftInitsInLoopBodyM, Block.userBlockLabels_cmd_cons] + | .block lbl bss md => + rw [Stmt.liftInitsInLoopBodyM_block_residual] + rw [show ([Stmt.block lbl (Block.liftInitsInLoopBodyM bss σ).1.2.2 md] + : List (Stmt P (Cmd P))) + = Stmt.block lbl (Block.liftInitsInLoopBodyM bss σ).1.2.2 md :: [] from rfl, + Block.userBlockLabels_block_cons, + show ([Stmt.block lbl bss md] : List (Stmt P (Cmd P))) + = Stmt.block lbl bss md :: [] from rfl, + Block.userBlockLabels_block_cons, + Block.liftInitsInLoopBodyM_userBlockLabels bss σ] + | .ite g tss ess md => + rw [Stmt.liftInitsInLoopBodyM_ite_residual] + rw [show ([Stmt.ite g (Block.liftInitsInLoopBodyM tss σ).1.2.2 + (Block.liftInitsInLoopBodyM ess + (Block.liftInitsInLoopBodyM tss σ).2).1.2.2 md] + : List (Stmt P (Cmd P))) + = Stmt.ite g (Block.liftInitsInLoopBodyM tss σ).1.2.2 + (Block.liftInitsInLoopBodyM ess + (Block.liftInitsInLoopBodyM tss σ).2).1.2.2 md :: [] from rfl, + Block.userBlockLabels_ite_cons, + show ([Stmt.ite g tss ess md] : List (Stmt P (Cmd P))) + = Stmt.ite g tss ess md :: [] from rfl, + Block.userBlockLabels_ite_cons, + Block.liftInitsInLoopBodyM_userBlockLabels tss σ, + Block.liftInitsInLoopBodyM_userBlockLabels ess _] + | .loop g m inv body md => + rw [Stmt.liftInitsInLoopBodyM] + | .exit lbl md => rw [Stmt.liftInitsInLoopBodyM] + | .funcDecl d md => rw [Stmt.liftInitsInLoopBodyM] + | .typeDecl t md => rw [Stmt.liftInitsInLoopBodyM] + termination_by sizeOf s + +/-- `Block.liftInitsInLoopBodyM`'s residual preserves `userBlockLabels`. -/ +theorem Block.liftInitsInLoopBodyM_userBlockLabels {P : PureExpr} [HasIdent P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.userBlockLabels (Block.liftInitsInLoopBodyM ss σ).1.2.2 = + Block.userBlockLabels ss := by + match ss with + | [] => simp [Block.liftInitsInLoopBodyM, Block.userBlockLabels] + | s :: rest => + rw [Block.liftInitsInLoopBodyM_cons_residual, Block.userBlockLabels_append, + show (s :: rest) = [s] ++ rest from rfl, Block.userBlockLabels_append, + Stmt.liftInitsInLoopBodyM_userBlockLabels s σ, + Block.liftInitsInLoopBodyM_userBlockLabels rest _] + termination_by sizeOf ss +end + +/-! ## `nondetElim` preserves `userBlockLabels` + +Template: `Stmt/Block.nondetElimM_loopHasNoInvariants`. The pass keeps every +`.block` label, recurses into sub-bodies, and the only minted statements (the +`init $g := *` havoc and, for nondet loops, the body-tail `set $g := *`) are +`.cmd`s. -/ + +mutual +/-- `Stmt.nondetElimM` preserves `userBlockLabels` at any threaded state. -/ +theorem Stmt.nondetElimM_userBlockLabels {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.userBlockLabels (Stmt.nondetElimM s σ).1 = Block.userBlockLabels [s] := by + match s with + | .cmd c => + rw [Stmt.nondetElimM] + | .block lbl bss md => + rw [Stmt.nondetElimM_block_out, + show ([Stmt.block lbl (Block.nondetElimM bss σ).1 md] : List (Stmt P (Cmd P))) + = Stmt.block lbl (Block.nondetElimM bss σ).1 md :: [] from rfl, + Block.userBlockLabels_block_cons, + show ([Stmt.block lbl bss md] : List (Stmt P (Cmd P))) + = Stmt.block lbl bss md :: [] from rfl, + Block.userBlockLabels_block_cons, + Block.nondetElimM_userBlockLabels bss σ] + | .ite (.det e) tss ess md => + rw [Stmt.nondetElimM_ite_det_out, + show ([Stmt.ite (.det e) (Block.nondetElimM tss σ).1 + (Block.nondetElimM ess (Block.nondetElimM tss σ).2).1 md] + : List (Stmt P (Cmd P))) + = Stmt.ite (.det e) (Block.nondetElimM tss σ).1 + (Block.nondetElimM ess (Block.nondetElimM tss σ).2).1 md :: [] from rfl, + Block.userBlockLabels_ite_cons, + show ([Stmt.ite (.det e) tss ess md] : List (Stmt P (Cmd P))) + = Stmt.ite (.det e) tss ess md :: [] from rfl, + Block.userBlockLabels_ite_cons, + Block.nondetElimM_userBlockLabels tss σ, + Block.nondetElimM_userBlockLabels ess _] + | .ite .nondet tss ess md => + rw [Stmt.nondetElimM_ite_nondet_out] + -- The output is `[init $g, ite (.det $g) tss' ess']`; the prelude `init` + -- is a `.cmd` (label-free), and both branches recurse. Finish by the + -- structural cons lemmas + the branch IHs. + simp only [Block.userBlockLabels_cmd_cons, + Block.nondetElimM_userBlockLabels tss, + Block.nondetElimM_userBlockLabels ess, Block.userBlockLabels_nil, + Block.userBlockLabels_ite_cons] + | .loop (.det e) m inv body md => + rw [Stmt.nondetElimM_loop_det_out, + show ([Stmt.loop (.det e) m inv (Block.nondetElimM body σ).1 md] + : List (Stmt P (Cmd P))) + = Stmt.loop (.det e) m inv (Block.nondetElimM body σ).1 md :: [] from rfl, + Block.userBlockLabels_loop_cons, + show ([Stmt.loop (.det e) m inv body md] : List (Stmt P (Cmd P))) + = Stmt.loop (.det e) m inv body md :: [] from rfl, + Block.userBlockLabels_loop_cons, + Block.nondetElimM_userBlockLabels body σ] + | .loop .nondet m inv body md => + rw [Stmt.nondetElimM_loop_nondet_out] + -- The output is `[init $g, loop (body' ++ [havoc $g])]`; the prelude + -- `init` and the body-tail `havoc` are `.cmd`s (label-free), and the loop + -- body recurses. Generalise the generated name/state and finish by the + -- structural cons/append lemmas + the body IH. + simp only [Block.userBlockLabels_cmd_cons, Block.userBlockLabels_append, + Block.nondetElimM_userBlockLabels body, Block.userBlockLabels_nil, + Block.userBlockLabels_loop_cons, List.append_nil] + | .exit lbl md => + rw [Stmt.nondetElimM] + | .funcDecl d md => + rw [Stmt.nondetElimM] + | .typeDecl t md => + rw [Stmt.nondetElimM] + termination_by sizeOf s + +/-- `Block.nondetElimM` preserves `userBlockLabels` at any threaded state. -/ +theorem Block.nondetElimM_userBlockLabels {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.userBlockLabels (Block.nondetElimM ss σ).1 = Block.userBlockLabels ss := by + match ss with + | [] => simp [Block.nondetElimM, Block.userBlockLabels] + | s :: rest => + rw [Block.nondetElimM_cons_out, Block.userBlockLabels_append, + show (s :: rest) = [s] ++ rest from rfl, Block.userBlockLabels_append, + Stmt.nondetElimM_userBlockLabels s σ, + Block.nondetElimM_userBlockLabels rest _] + termination_by sizeOf ss +end + +/-- Pure-wrapper corollary: `Block.nondetElim` preserves `userBlockLabels`. -/ +theorem Block.nondetElim_userBlockLabels {P : PureExpr} [HasIdent P] [HasFvar P] [HasBool P] + (ss : List (Stmt P (Cmd P))) : + Block.userBlockLabels (Block.nondetElim ss) = Block.userBlockLabels ss := by + rw [Block.nondetElim, Block.nondetElimM_userBlockLabels] + +/-! ## `hoistLoopPrefixInits` preserves `userBlockLabels` + +The `.loop` arm emits `havocs.map Stmt.cmd ++ [.loop … body₃ …]` where `body₃ = +applyRenames renames (lift residual)`: the havoc prelude is `.cmd`s (label-free, +H1), `applyRenames` is label-invariant (A), and the lift residual is +label-preserving (L). All other arms recurse structurally and keep their labels. +Template: `Stmt/Block.nondetElimM_loopHasNoInvariants`. -/ + +mutual +/-- `Stmt.hoistLoopPrefixInitsM` preserves `userBlockLabels` at any state. -/ +theorem Stmt.hoistLoopPrefixInitsM_userBlockLabels {P : PureExpr} + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (s : Stmt P (Cmd P)) (σ : StringGenState) : + Block.userBlockLabels (Stmt.hoistLoopPrefixInitsM s σ).1 = + Block.userBlockLabels [s] := by + match s with + | .cmd c => + rw [Stmt.hoistLoopPrefixInitsM] + | .block lbl bss md => + rw [Stmt.hoistLoopPrefixInitsM_block_out, + show ([Stmt.block lbl (Block.hoistLoopPrefixInitsM bss σ).1 md] + : List (Stmt P (Cmd P))) + = Stmt.block lbl (Block.hoistLoopPrefixInitsM bss σ).1 md :: [] from rfl, + Block.userBlockLabels_block_cons, + show ([Stmt.block lbl bss md] : List (Stmt P (Cmd P))) + = Stmt.block lbl bss md :: [] from rfl, + Block.userBlockLabels_block_cons, + Block.hoistLoopPrefixInitsM_userBlockLabels bss σ] + | .ite g tss ess md => + rw [Stmt.hoistLoopPrefixInitsM_ite_out, + show ([Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess + (Block.hoistLoopPrefixInitsM tss σ).2).1 md] + : List (Stmt P (Cmd P))) + = Stmt.ite g (Block.hoistLoopPrefixInitsM tss σ).1 + (Block.hoistLoopPrefixInitsM ess + (Block.hoistLoopPrefixInitsM tss σ).2).1 md :: [] from rfl, + Block.userBlockLabels_ite_cons, + show ([Stmt.ite g tss ess md] : List (Stmt P (Cmd P))) + = Stmt.ite g tss ess md :: [] from rfl, + Block.userBlockLabels_ite_cons, + Block.hoistLoopPrefixInitsM_userBlockLabels tss σ, + Block.hoistLoopPrefixInitsM_userBlockLabels ess _] + | .loop g m inv body md => + rw [Stmt.hoistLoopPrefixInitsM_loop_out, Block.userBlockLabels_append, + Block.userBlockLabels_map_cmd, + show ([Stmt.loop g m inv + (Block.applyRenames + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) md] + : List (Stmt P (Cmd P))) + = Stmt.loop g m inv + (Block.applyRenames + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.1 + (Block.liftInitsInLoopBodyM (Block.hoistLoopPrefixInitsM body σ).1 + (Block.hoistLoopPrefixInitsM body σ).2).1.2.2) md :: [] from rfl, + Block.userBlockLabels_loop_cons, + Block.applyRenames_userBlockLabels, + Block.liftInitsInLoopBodyM_userBlockLabels, + Block.hoistLoopPrefixInitsM_userBlockLabels body σ, + show ([Stmt.loop g m inv body md] : List (Stmt P (Cmd P))) + = Stmt.loop g m inv body md :: [] from rfl, + Block.userBlockLabels_loop_cons, List.nil_append] + | .exit lbl md => + rw [Stmt.hoistLoopPrefixInitsM] + | .funcDecl d md => + rw [Stmt.hoistLoopPrefixInitsM] + | .typeDecl t md => + rw [Stmt.hoistLoopPrefixInitsM] + termination_by sizeOf s + +/-- `Block.hoistLoopPrefixInitsM` preserves `userBlockLabels` at any state. -/ +theorem Block.hoistLoopPrefixInitsM_userBlockLabels {P : PureExpr} + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) (σ : StringGenState) : + Block.userBlockLabels (Block.hoistLoopPrefixInitsM ss σ).1 = + Block.userBlockLabels ss := by + match ss with + | [] => simp [Block.hoistLoopPrefixInitsM, Block.userBlockLabels] + | s :: rest => + rw [Block.hoistLoopPrefixInitsM_cons_out, Block.userBlockLabels_append, + show (s :: rest) = [s] ++ rest from rfl, Block.userBlockLabels_append, + Stmt.hoistLoopPrefixInitsM_userBlockLabels s σ, + Block.hoistLoopPrefixInitsM_userBlockLabels rest _] + termination_by sizeOf ss +end + +/-- Pure-wrapper corollary: `Block.hoistLoopPrefixInits` preserves +`userBlockLabels`. -/ +theorem Block.hoistLoopPrefixInits_userBlockLabels {P : PureExpr} + [HasIdent P] [HasSubstFvar P] [HasFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) : + Block.userBlockLabels (Block.hoistLoopPrefixInits ss) = + Block.userBlockLabels ss := by + rw [Block.hoistLoopPrefixInits, Block.hoistLoopPrefixInitsM_userBlockLabels] + +/-! ## The discharger: source-side `userLabelsShapeNodup` survives the pipeline + +`userLabelsShapeNodup` is a function only of the `userBlockLabels` list, so the +two preservation corollaries rewrite the transformed-body obligation back to the +source body. -/ + +/-- Source-side `userLabelsShapeNodup` is preserved through the pipeline prefix +`hoistLoopPrefixInits ∘ nondetElim`. This discharges the transformed-body +well-formedness obligation from the source-side condition. -/ +theorem Block.userLabelsShapeNodup_pipeline_preserved {P : PureExpr} + [HasIdent P] [HasFvar P] [HasBool P] [HasSubstFvar P] [DecidableEq P.Ident] + (ss : List (Stmt P (Cmd P))) + (h : Block.userLabelsShapeNodup ss) : + Block.userLabelsShapeNodup (Block.hoistLoopPrefixInits (Block.nondetElim ss)) := by + unfold Block.userLabelsShapeNodup at h ⊢ + rw [Block.hoistLoopPrefixInits_userBlockLabels, Block.nondetElim_userBlockLabels] + exact h + +end Imperative + +end -- public section diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index b8bb5896a6..2384d88f06 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -213,7 +213,8 @@ private theorem PrefixStepsOK_assumes (h_preconds : ∀ (label : CoreLabel) (check : Procedure.Check), (label, check) ∈ preconds.toList → ρ.eval ρ.store check.expr = some HasBool.tt) - (h_wfBool : WellFormedSemanticEvalBool ρ.eval) : + (h_wfBool : WellFormedSemanticEvalBool ρ.eval) + (h_wfCongr : WellFormedSemanticEvalExprCongr ρ.eval) : PrefixStepsOK π φ (requiresToAssumes preconds) ρ := by suffices h : ∀ (items : List (CoreLabel × Procedure.Check)), (∀ (label : CoreLabel) (check : Procedure.Check), @@ -242,7 +243,7 @@ private theorem PrefixStepsOK_assumes exact ⟨h_rest_ok, _, rfl, _, by rw [h_store_eq] exact EvalCommand.cmd_sem (EvalCmd.eval_assume - (h_items label check List.mem_cons_self) h_wfBool), + (h_items label check List.mem_cons_self) h_wfBool h_wfCongr), by show _ = (prefixInitEnv _ ρ).store; rw [h_env_eq]⟩ /-- For a nondet init statement, if `x` is none in the pre-state and some in the target, @@ -305,6 +306,7 @@ private theorem PrefixStepsOK_det_init_cons (id : Expression.Ident) (oldG : Expression.Ident) (ty : Expression.Ty) (rest : List Statement) (ρ : Imperative.Env Expression) (h_wfVar : WellFormedSemanticEvalVar ρ.eval) + (h_wfCongr : WellFormedSemanticEvalExprCongr ρ.eval) (h_rest : PrefixStepsOK π φ rest ρ) (_h_id_some : ((prefixInitEnv rest ρ).store id).isSome) (h_old_some : ((prefixInitEnv rest ρ).store oldG).isSome) @@ -330,7 +332,7 @@ private theorem PrefixStepsOK_det_init_cons exact EvalCommand.cmd_sem (EvalCmd.eval_init h_eval (InitState.init h_none hv (fun y hne => by exact (prefixInitEnv_store_other _ _ _ y oldG rfl hne).symm)) - h_wfVar) + h_wfVar h_wfCongr) /-- PrefixStepsOK for a list of det init statements `init (mkOld id.name) ty (.det (fvar id))`. -/ private theorem PrefixStepsOK_det_init_map @@ -338,6 +340,7 @@ private theorem PrefixStepsOK_det_init_map (entries : List (Expression.Ident × Lambda.LMonoTy)) (ρ : Imperative.Env Expression) (h_wfVar : WellFormedSemanticEvalVar ρ.eval) + (h_wfCongr : WellFormedSemanticEvalExprCongr ρ.eval) (h_defined : ∀ id ∈ entries.map Prod.fst, (ρ.store id).isSome) (h_old_defined : ∀ id ∈ entries.map Prod.fst, @@ -358,7 +361,7 @@ private theorem PrefixStepsOK_det_init_map simp only [List.map] at h_defined h_old_defined h_old_match h_nodup h_not_old h_nodup_old ⊢ rw [List.nodup_cons] at h_nodup h_nodup_old apply PrefixStepsOK_det_init_cons π φ id (CoreIdent.mkOld id.name) - (Lambda.LTy.forAll [] ty) _ ρ h_wfVar + (Lambda.LTy.forAll [] ty) _ ρ h_wfVar h_wfCongr · exact ih (fun i hi => h_defined i (List.mem_cons_of_mem _ hi)) (fun i hi => h_old_defined i (List.mem_cons_of_mem _ hi)) (fun i hi => h_old_match i (List.mem_cons_of_mem _ hi)) @@ -510,7 +513,7 @@ theorem procToVerifyStmt_structure simp only [assumes, requiresToAssumes, List.mem_map] at hs obtain ⟨⟨l, c⟩, _, rfl⟩ := hs; simp [stmtInitVar] refine ⟨PrefixStepsOK_assumes π φ proc.spec.preconditions ρ₀ - h_wf.preconditionsHold h_wf.wfBool, ?_⟩ + h_wf.preconditionsHold h_wf.wfBool h_wf.wfExprCongr, ?_⟩ rw [h_assumes_id] -- Split: (inputInits ++ outputOnlyInits) ++ oldInoutInits rw [show inputInits ++ outputOnlyInits ++ oldInoutInits = @@ -527,7 +530,7 @@ theorem procToVerifyStmt_structure exact absurd hsx.symm (h_wf_proc.ioNotOld x hx id.name) constructor · -- PrefixStepsOK for oldInoutInits at ρ₀ - apply PrefixStepsOK_det_init_map π φ _ _ h_wf.wfVar + apply PrefixStepsOK_det_init_map π φ _ _ h_wf.wfVar h_wf.wfExprCongr · -- inout params are defined in store (they are inputs) intro id hid rw [← ListMap.keys_eq_map_fst] at hid @@ -862,7 +865,9 @@ theorem procBodyVerify_procedureCorrect .step _ _ _ (.step_cmd (@EvalCommand.cmd_sem π φ ρ_proj.eval ρ_proj.store (Cmd.assert lh eh mdh) ρ_proj.store false - (EvalCmd.eval_assert_pass h_head_eval_proj (by rw [h_proj_eval]; exact h_wfb_term)))) + (EvalCmd.eval_assert_pass h_head_eval_proj + (by rw [h_proj_eval]; exact h_wfb_term) + (by rw [h_proj_eval]; exact h_wfExprCongr_term)))) (.refl _) have h2 : (⟨ρ_proj.store, ρ_proj.eval, ρ_proj.hasFailure || false⟩ : Env Expression) = ρ_proj := by cases ρ'; simp [ρ_proj, Bool.or_false] diff --git a/Strata/Transform/Specification.lean b/Strata/Transform/Specification.lean index f7685d28ed..ce95c2eab7 100644 --- a/Strata/Transform/Specification.lean +++ b/Strata/Transform/Specification.lean @@ -94,22 +94,34 @@ structure Lang (P : PureExpr) [HasFvar P] [HasBool P] [HasNot P] where isAtAssert : CfgT → AssertId P → Prop /-- Extract env from a configuration. -/ getEnv : CfgT → Env P + /-- The type of parameters threaded into `initEnvWF`. The default for the + generic imperative layer is `Unit` (no parameters); a source language may + override it with a record carrying language-specific data needed to state + initial-environment well-formedness. -/ + InitEnvWFParamsTy : Type + /-- Initial-environment well-formedness, parameterized by `InitEnvWFParamsTy` + and the statement. The default for the generic imperative layer is the + trivial predicate `True`; a source language may override it to carry the + initial-environment facts a downstream transform relies on. -/ + initEnvWF : InitEnvWFParamsTy → StmtT → Env P → Prop /-- Build a `Lang` from `Imperative.Stmt`/`Config` with a given command - type and evaluator. -/ + type and evaluator. The two well-formedness fields are supplied with the + trivial defaults `InitEnvWFParamsTy := Unit` and `initEnvWF := fun _ _ _ => True`; + a source language can shadow this `abbrev` to override them. -/ abbrev Lang.imperative (P : PureExpr) [HasFvar P] [HasBool P] [HasNot P] (CmdT : Type) (evalCmd : EvalCmdParam P CmdT) (extendEval : ExtendEval P) (isAtAssert : Config P CmdT → AssertId P → Prop) : Lang P := ⟨Stmt P CmdT, Config P CmdT, StepStmtStar P evalCmd extendEval, - .stmt, .terminal, .exiting, isAtAssert, Config.getEnv⟩ + .stmt, .terminal, .exiting, isAtAssert, Config.getEnv, Unit, fun _ _ _ => True⟩ /-- The standard `Lang` for `Cmd P` / `EvalCmd P` / `isAtAssert`. -/ -abbrev Lang.standard (P : PureExpr) [HasFvar P] [HasBool P] [HasNot P] +abbrev Lang.standard (P : PureExpr) [HasFvar P] [HasBool P] [HasNot P] [HasVarsPure P P.Expr] (extendEval : ExtendEval P) : Lang P := Lang.imperative P (Cmd P) (EvalCmd P) extendEval (Imperative.isAtAssert P) -variable {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVal P] +variable {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasVarsPure P P.Expr] variable (L : Lang P) @@ -169,10 +181,12 @@ namespace Hoare TODO: We will want to define Triple for total correctness. It will be useful when proving preservation of termination after program transformation. -/ -def Triple +def Triple [HasVarsPure P P.Expr] (Pre : Env P → Prop) (s : L.StmtT) (Post : Env P → Prop) : Prop := ∀ (ρ₀ ρ' : Env P), - Pre ρ₀ → WellFormedSemanticEvalBool ρ₀.eval → ρ₀.hasFailure = false → + Pre ρ₀ → WellFormedSemanticEvalBool ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → + ρ₀.hasFailure = false → L.star (L.stmtCfg s ρ₀) (L.terminalCfg ρ') → Post ρ' ∧ ρ'.hasFailure = false @@ -186,11 +200,13 @@ variable (isAtAssertFn : Config P CmdT → AssertId P → Prop) /-- Partial-correctness Hoare triple for a block body. The output configuration is allowed to be still in an exiting mode (see Config.exiting) because the outer block can catch the exit. -/ -def TripleBlock +def TripleBlock [HasVarsPure P P.Expr] {CmdT : Type} (evalCmd : EvalCmdParam P CmdT) (extendEval : ExtendEval P) (Pre : Env P → Prop) (ss : List (Stmt P CmdT)) (Post : Env P → Prop) : Prop := ∀ (ρ₀ ρ' : Env P), - Pre ρ₀ → WellFormedSemanticEvalBool ρ₀.eval → ρ₀.hasFailure = false → + Pre ρ₀ → WellFormedSemanticEvalBool ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → + ρ₀.hasFailure = false → (StepStmtStar P evalCmd extendEval (.stmts ss ρ₀) (.terminal ρ') ∨ ∃ lbl, StepStmtStar P evalCmd extendEval (.stmts ss ρ₀) (.exiting lbl ρ')) → Post ρ' ∧ ρ'.hasFailure = false @@ -249,12 +265,165 @@ def Overapproximates (L₁ L₂ : Lang P) (T : L₁.StmtT → Option L₂.StmtT) ∀ (ρ₀ ρ' : Env P), WellFormedSemanticEvalBool ρ₀.eval → WellFormedSemanticEvalVal ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → (L₁.star (L₁.stmtCfg st ρ₀) (L₁.terminalCfg ρ') → L₂.star (L₂.stmtCfg s' ρ₀) (L₂.terminalCfg ρ')) ∧ (∀ lbl, L₁.star (L₁.stmtCfg st ρ₀) (L₁.exitingCfg lbl ρ') → L₂.star (L₂.stmtCfg s' ρ₀) (L₂.exitingCfg lbl ρ')) +/-! ## Store-relaxed overapproximation + +`Overapproximates` forces the target's terminal/exiting env to be the *same* +`ρ'` as the source's — i.e. full env equality (store, eval, and `hasFailure` +all identical). A refinement that introduces extra target variables (e.g. the +pipeline's minted gen-suffix scratch names) cannot satisfy that: the target +store is a *superset* of the source store, agreeing on every source binding but +carrying additional ones. + +`OverapproximatesRel` generalizes the terminal/exiting clauses over a store +relation `R : SemanticStore P → SemanticStore P → Prop`. Instead of demanding +the target reach `L₂.terminalCfg ρ'`, it asks for *some* target terminal env +`ρ_t` whose store is related to the source's by `R` (and whose failure flag +matches). Plain equality `R := (· = ·)` recovers the exact-store discipline of +`Overapproximates`; `R := StoreAgreement` (source on the left) recovers the +pipeline's superset discipline. -/ + +/-- Overapproximation parameterized by a target-vs-source store relation `R` + (source store on the left). Every terminal/exiting env reachable from the + source is matched by a target run reaching a terminal/exiting env whose + store is `R`-related to the source's, with the same failure flag. -/ +def OverapproximatesRel (L₁ L₂ : Lang P) + (R : SemanticStore P → SemanticStore P → Prop) + (T : L₁.StmtT → Option L₂.StmtT) : Prop := + ∀ (st : L₁.StmtT) (s' : L₂.StmtT), + T st = some s' → + ∀ (ρ₀ ρ' : Env P), + WellFormedSemanticEvalBool ρ₀.eval → + WellFormedSemanticEvalVal ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → + (L₁.star (L₁.stmtCfg st ρ₀) (L₁.terminalCfg ρ') → + ∃ ρ_t : Env P, R ρ'.store ρ_t.store ∧ ρ_t.hasFailure = ρ'.hasFailure ∧ + L₂.star (L₂.stmtCfg s' ρ₀) (L₂.terminalCfg ρ_t)) + ∧ + (∀ lbl, L₁.star (L₁.stmtCfg st ρ₀) (L₁.exitingCfg lbl ρ') → + ∃ ρ_t : Env P, R ρ'.store ρ_t.store ∧ ρ_t.hasFailure = ρ'.hasFailure ∧ + L₂.star (L₂.stmtCfg s' ρ₀) (L₂.exitingCfg lbl ρ_t)) + +/-! ## Precondition-guarded overapproximation + +A transform whose soundness is conditional — valid only on source programs and +initial environments meeting front-end well-formedness conditions — refines its +source under those conditions, not unconditionally. `OverapproximatesRelWhen` +guards `OverapproximatesRel` with a precondition `pre : L₁.StmtT → Env P → Prop` +on the source statement and the initial environment. The body is otherwise +identical to `OverapproximatesRel`: the guard sits between the `ρ₀ ρ'` +quantifiers and the well-formed-evaluator hypotheses. -/ + +/-- Overapproximation conditioned on a source-and-initial-environment + precondition `pre`. Identical to `OverapproximatesRel` except every + obligation is discharged only when `pre st ρ₀` holds. -/ +def OverapproximatesRelWhen (L₁ L₂ : Lang P) + (pre : L₁.StmtT → Env P → Prop) + (R : SemanticStore P → SemanticStore P → Prop) + (T : L₁.StmtT → Option L₂.StmtT) : Prop := + ∀ (st : L₁.StmtT) (s' : L₂.StmtT), + T st = some s' → + ∀ (ρ₀ ρ' : Env P), + pre st ρ₀ → + WellFormedSemanticEvalBool ρ₀.eval → + WellFormedSemanticEvalVal ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → + (L₁.star (L₁.stmtCfg st ρ₀) (L₁.terminalCfg ρ') → + ∃ ρ_t : Env P, R ρ'.store ρ_t.store ∧ ρ_t.hasFailure = ρ'.hasFailure ∧ + L₂.star (L₂.stmtCfg s' ρ₀) (L₂.terminalCfg ρ_t)) + ∧ + (∀ lbl, L₁.star (L₁.stmtCfg st ρ₀) (L₁.exitingCfg lbl ρ') → + ∃ ρ_t : Env P, R ρ'.store ρ_t.store ∧ ρ_t.hasFailure = ρ'.hasFailure ∧ + L₂.star (L₂.stmtCfg s' ρ₀) (L₂.exitingCfg lbl ρ_t)) + +/-! ## Overapproximation up to an environment relation (`OverapproximatesUpto*`) + +This family relates the source and target executions *up to a single relation +`R : Relation (Env P)` on whole environments*, with the per-language +well-formedness facts routed through each `Lang`'s `initEnvWF` field rather than +through explicit evaluator hypotheses. It is the additive Upto formulation: + +* `OverapproximatesUptoWhen R` relates initial environments by `R` (as a + hypothesis) and final environments by `R` (under an existential), guards the + obligation by a statement-only precondition `pre : L₁.StmtT → Prop`, and also + preserves failure (`CanFail`) and the target's `initEnvWF`. +* `OverapproximatesWhen` / `OverapproximatesUpto` are the obvious specializations + (equality relation, no precondition). + +Unlike the `OverapproximatesRel` family above — which keeps the WF-evaluator +hypotheses explicit and relates only the *stores* — the Upto family threads +initial-environment well-formedness through `initEnvWF` and relates whole +environments. Both families coexist. -/ + +/-- After steps from `s`, it reaches a configuration whose `hasFailure` is true. + The configuration need not be terminal or exiting. -/ +@[expose] def CanFail (L : Lang P) (s : L.StmtT) (ρ₀ : Env P) : Prop := + ∃ cfg, (L.getEnv cfg).hasFailure = true ∧ L.star (L.stmtCfg s ρ₀) cfg + +/-- Overapproximation up to an environment relation `R`, under a statement-only + precondition `pre`. + + For every transformed pair `T st = some st'` with `pre st`, every source + initial env `ρ₀` that is `initEnvWF` (with the source parameters), and every + target initial env `ρ₀'` related to it by `R`: + 1. every terminal (resp. exiting) env `ρ'` reachable from `st` in `L₁` has a + target counterpart `ρ''` reachable from `st'` in `L₂`, related by `R`; + 2. failure is preserved (from `ρ₀` in `L₁` to `ρ₀'` in `L₂`); + 3. the target initial env `ρ₀'` is `initEnvWF` (with the target parameters), + so the guarantee can be threaded into a further transform. + + `R` is used on both the input (as a hypothesis) and the output (under an + existential). -/ +@[expose] def OverapproximatesUptoWhen + (R : Relation (Env P)) + (L₁ L₂ : Lang P) (T : L₁.StmtT → Option L₂.StmtT) + (pre : L₁.StmtT → Prop) + (params₁ : L₁.InitEnvWFParamsTy) (params₂ : L₂.InitEnvWFParamsTy) : Prop := + ∀ (st : L₁.StmtT) (st' : L₂.StmtT), + T st = some st' → + pre st → + ∀ (ρ₀ ρ₀' : Env P), + R ρ₀ ρ₀' → + L₁.initEnvWF params₁ st ρ₀ → + -- Terminal/exiting envs have an `R`-related target counterpart. + (∀ (ρ' : Env P), + (L₁.star (L₁.stmtCfg st ρ₀) (L₁.terminalCfg ρ') → + ∃ ρ'', R ρ' ρ'' ∧ L₂.star (L₂.stmtCfg st' ρ₀') (L₂.terminalCfg ρ'')) + ∧ + (∀ lbl, L₁.star (L₁.stmtCfg st ρ₀) (L₁.exitingCfg lbl ρ') → + ∃ ρ'', R ρ' ρ'' ∧ L₂.star (L₂.stmtCfg st' ρ₀') (L₂.exitingCfg lbl ρ''))) + ∧ + -- Fail preservation. + (CanFail L₁ st ρ₀ → CanFail L₂ st' ρ₀') + ∧ + -- `initEnvWF` preservation on the target side, with the target's parameters. + L₂.initEnvWF params₂ st' ρ₀' + +/-- Overapproximation up to an environment relation `R`, with no precondition. -/ +@[expose] def OverapproximatesUpto + (R : Relation (Env P)) + (L₁ L₂ : Lang P) (T : L₁.StmtT → Option L₂.StmtT) + (params₁ : L₁.InitEnvWFParamsTy) (params₂ : L₂.InitEnvWFParamsTy) : Prop := + OverapproximatesUptoWhen R L₁ L₂ T (fun _ => True) params₁ params₂ + +/-- Overapproximation under a statement-only precondition `pre`: terminal/exiting + envs reachable from the source are also reachable from the target, and + failing programs are preserved. + + This is the special case of `OverapproximatesUptoWhen` where the environment + relation is equality — source and target run from the *same* initial env and + reach the *same* final env. -/ +@[expose] def OverapproximatesWhen (L₁ L₂ : Lang P) (T : L₁.StmtT → Option L₂.StmtT) + (pre : L₁.StmtT → Prop) + (params₁ : L₁.InitEnvWFParamsTy) (params₂ : L₂.InitEnvWFParamsTy) : Prop := + OverapproximatesUptoWhen (· = ·) L₁ L₂ T pre params₁ params₂ + /-! ## Statement-list overapproximation (Imperative-specific) -/ section ImperativeStmts @@ -263,8 +432,16 @@ variable {CmdT : Type} (evalCmd : EvalCmdParam P CmdT) (extendEval : ExtendEval variable (isAtAssertFn : Config P CmdT → AssertId P → Prop) /-- `Lang` for block-level (statement-list) overapproximation. - `StmtT` is `List (Stmt P CmdT)` and `stmtCfg` embeds via `.stmts`. -/ -abbrev Lang.imperativeBlock : Lang P where + `StmtT` is `List (Stmt P CmdT)` and `stmtCfg` embeds via `.stmts`. + + `ParamsTy` is the `InitEnvWFParamsTy` for the resulting language; it defaults + to `Unit` (no parameters), in which case `initEnvWF` defaults to the trivial + predicate `True`. A source language can supply both to carry the + initial-environment facts a downstream transform relies on. -/ +abbrev Lang.imperativeBlock + (ParamsTy : Type := Unit) + (initEnvWF : ParamsTy → List (Stmt P CmdT) → Env P → Prop := fun _ _ _ => True) : + Lang P where StmtT := List (Stmt P CmdT) CfgT := Config P CmdT star := StepStmtStar P evalCmd extendEval @@ -273,6 +450,8 @@ abbrev Lang.imperativeBlock : Lang P where exitingCfg := .exiting isAtAssert := isAtAssertFn getEnv := Config.getEnv + InitEnvWFParamsTy := ParamsTy + initEnvWF := initEnvWF end ImperativeStmts diff --git a/Strata/Transform/SpecificationProps.lean b/Strata/Transform/SpecificationProps.lean index 9c3ed46627..21998a30e9 100644 --- a/Strata/Transform/SpecificationProps.lean +++ b/Strata/Transform/SpecificationProps.lean @@ -22,19 +22,13 @@ namespace Imperative namespace Specification -variable {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVal P] +variable {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] [HasVal P] [HasVarsPure P P.Expr] variable (L : Lang P) namespace Hoare /-! ## Parametric Hoare rules -/ -omit [HasVal P] in -/-- False precondition proves anything -/ -theorem false_pre (s : L.StmtT) (Post : Env P → Prop) : - Triple L (fun _ => False) s Post := by - intro _ _ hpre; exact absurd hpre id - omit [HasVal P] in /-- Consequence (weakening): strengthen precondition, weaken postconditions. -/ theorem consequence @@ -42,8 +36,8 @@ theorem consequence (h : Triple L Pre s Post) (hpre : ∀ ρ, Pre' ρ → Pre ρ) (hpost : ∀ ρ, Post ρ → Post' ρ) : Triple L Pre' s Post' := by - intro ρ₀ ρ' hpre' hwfb hf₀ hstar - have ⟨hp, hf⟩ := h ρ₀ ρ' (hpre ρ₀ hpre') hwfb hf₀ hstar + intro ρ₀ ρ' hpre' hwfb hwfcongr hf₀ hstar + have ⟨hp, hf⟩ := h ρ₀ ρ' (hpre ρ₀ hpre') hwfb hwfcongr hf₀ hstar exact ⟨hpost ρ' hp, hf⟩ @@ -58,7 +52,7 @@ variable (isAtAssertFn : Config P CmdT → AssertId P → Prop) /-- Empty statement list is skip. -/ theorem skip_block (Pre : Env P → Prop) : TripleBlock evalCmd extendEval Pre [] Pre := by - intro ρ₀ ρ' hpre _ hf₀ hstar + intro ρ₀ ρ' hpre _ _ hf₀ hstar match hstar with | .inl hterm => cases hterm with @@ -78,7 +72,7 @@ theorem cmd (c : CmdT) (Pre Post : Env P → Prop) evalCmd ρ₀.eval ρ₀.store c σ' f → Post { ρ₀ with store := σ', hasFailure := f } ∧ f = false) : Triple (Lang.imperative P CmdT evalCmd extendEval isAtAssertFn) Pre (.cmd c) Post := by - intro ρ₀ ρ' hpre hwfb hf₀ hstar + intro ρ₀ ρ' hpre hwfb _hwfcongr hf₀ hstar cases hstar with | step _ _ _ h1 r1 => cases h1 with | step_cmd hcmd => @@ -97,20 +91,25 @@ theorem seq_cons {s : Stmt P CmdT} {ss : List (Stmt P CmdT)} (hnofd : Stmt.noFuncDecl s = true) (hnoesc : Stmt.exitsCoveredByBlocks [] s) : TripleBlock evalCmd extendEval Pre (s :: ss) Post := by - intro ρ₀ ρ' hpre hwfb hf₀ hdone + intro ρ₀ ρ' hpre hwfb hwfcongr hf₀ hdone have hwfb_preserved : ∀ ρ₁, StepStmtStar P evalCmd extendEval (.stmt s ρ₀) (.terminal ρ₁) → WellFormedSemanticEvalBool ρ₁.eval := by intro ρ₁ hterm have this := smallStep_noFuncDecl_preserves_eval P evalCmd extendEval s ρ₀ ρ₁ hnofd hterm rw [this]; exact hwfb + have hwfcongr_preserved : ∀ ρ₁, StepStmtStar P evalCmd extendEval (.stmt s ρ₀) (.terminal ρ₁) → + WellFormedSemanticEvalExprCongr ρ₁.eval := by + intro ρ₁ hterm + have this := smallStep_noFuncDecl_preserves_eval P evalCmd extendEval s ρ₀ ρ₁ hnofd hterm + rw [this]; exact hwfcongr match hdone with | .inl hterm => cases hterm with | step _ _ _ hstep hrest => cases hstep with | step_stmts_cons => have ⟨ρ₁, hterm_s, hrest_ss⟩ := seq_reaches_terminal P evalCmd extendEval hrest - have ⟨hmid, hf₁⟩ := h₁ ρ₀ ρ₁ hpre hwfb hf₀ hterm_s - exact h₂ ρ₁ ρ' hmid (hwfb_preserved ρ₁ hterm_s) hf₁ (.inl hrest_ss) + have ⟨hmid, hf₁⟩ := h₁ ρ₀ ρ₁ hpre hwfb hwfcongr hf₀ hterm_s + exact h₂ ρ₁ ρ' hmid (hwfb_preserved ρ₁ hterm_s) (hwfcongr_preserved ρ₁ hterm_s) hf₁ (.inl hrest_ss) | .inr ⟨lbl, hexit⟩ => cases hexit with | step _ _ _ hstep hrest => cases hstep with @@ -120,8 +119,8 @@ theorem seq_cons {s : Stmt P CmdT} {ss : List (Stmt P CmdT)} exact absurd hexit_inner (exitsCoveredByBlocks_noEscape P evalCmd extendEval s hnoesc ρ₀ lbl ρ') | .inr ⟨ρ₁, hterm_s, hexit_ss⟩ => - have ⟨hmid, hf₁⟩ := h₁ ρ₀ ρ₁ hpre hwfb hf₀ hterm_s - exact h₂ ρ₁ ρ' hmid (hwfb_preserved ρ₁ hterm_s) hf₁ (.inr ⟨lbl, hexit_ss⟩) + have ⟨hmid, hf₁⟩ := h₁ ρ₀ ρ₁ hpre hwfb hwfcongr hf₀ hterm_s + exact h₂ ρ₁ ρ' hmid (hwfb_preserved ρ₁ hterm_s) (hwfcongr_preserved ρ₁ hterm_s) hf₁ (.inr ⟨lbl, hexit_ss⟩) omit [HasVal P] in /-- Lift a `TripleBlock` to a `Triple` by wrapping in a block. @@ -132,51 +131,18 @@ theorem TripleBlock.toTriple {ss : List (Stmt P CmdT)} {l : String} {md : MetaDa (h : TripleBlock evalCmd extendEval Pre ss Post) (hpost_proj : PostWF Post) : Triple (Lang.imperative P CmdT evalCmd extendEval isAtAssertFn) Pre (.block l ss md) Post := by - intro ρ₀ ρ' hpre hwfb hf₀ hstar + intro ρ₀ ρ' hpre hwfb hwfcongr hf₀ hstar cases hstar with | step _ _ _ hstep hrest => cases hstep with | step_block => match block_reaches_terminal P evalCmd extendEval hrest with | .inl ⟨ρ_inner, hterm, heq⟩ => - have ⟨hpost, hf⟩ := h ρ₀ ρ_inner hpre hwfb hf₀ (.inl hterm) + have ⟨hpost, hf⟩ := h ρ₀ ρ_inner hpre hwfb hwfcongr hf₀ (.inl hterm) subst heq; exact hpost_proj ρ_inner _ hpost hf | .inr ⟨lbl, ρ_inner, hexit, heq⟩ => - have ⟨hpost, hf⟩ := h ρ₀ ρ_inner hpre hwfb hf₀ (.inr ⟨lbl, hexit⟩) + have ⟨hpost, hf⟩ := h ρ₀ ρ_inner hpre hwfb hwfcongr hf₀ (.inr ⟨lbl, hexit⟩) subst heq; exact hpost_proj ρ_inner _ hpost hf -omit [HasVal P] in -/-- Lift a `Triple` to a `TripleBlock` for a singleton list. -/ -theorem Triple.toTripleBlock {s : Stmt P CmdT} - {Pre Post : Env P → Prop} - (h : Triple (Lang.imperative P CmdT evalCmd extendEval isAtAssertFn) Pre s Post) - (hnoesc : Stmt.exitsCoveredByBlocks [] s) : - TripleBlock evalCmd extendEval Pre [s] Post := by - intro ρ₀ ρ' hpre hwfb hf₀ hdone - match hdone with - | .inl hterm => - cases hterm with - | step _ _ _ hstep hrest => cases hstep with - | step_stmts_cons => - have ⟨ρ₁, hterm_s, hrest_nil⟩ := seq_reaches_terminal P evalCmd extendEval hrest - have ⟨hp, hf⟩ := h ρ₀ ρ₁ hpre hwfb hf₀ hterm_s - cases hrest_nil with - | step _ _ _ h1 r1 => cases h1 with - | step_stmts_nil => cases r1 with - | refl => exact ⟨hp, hf⟩ - | step _ _ _ h _ => exact nomatch h - | .inr ⟨lbl, hexit⟩ => - cases hexit with - | step _ _ _ hstep hrest => cases hstep with - | step_stmts_cons => - match seq_reaches_exiting P evalCmd extendEval hrest with - | .inl hexit_s => - exact absurd hexit_s - (exitsCoveredByBlocks_noEscape P evalCmd extendEval s hnoesc ρ₀ lbl ρ') - | .inr ⟨ρ₁, hterm_s, hexit_nil⟩ => - cases hexit_nil with - | step _ _ _ h _ => cases h with - | step_stmts_nil => rename_i r; cases r with | step _ _ _ h _ => cases h - omit [HasVal P] in /-- Empty block is skip. -/ theorem skip (l : String) (md : MetaData P) (Pre : Env P → Prop) @@ -191,11 +157,11 @@ theorem ite {c : P.Expr} {tss ess : List (Stmt P CmdT)} {md : MetaData P} (ht : TripleBlock evalCmd extendEval (fun ρ => Pre ρ ∧ ρ.eval ρ.store c = some HasBool.tt) tss Post) (he : TripleBlock evalCmd extendEval (fun ρ => Pre ρ ∧ ρ.eval ρ.store c = some HasBool.ff) ess Post) : Triple (Lang.imperative P CmdT evalCmd extendEval isAtAssertFn) Pre (.ite (.det c) tss ess md) Post := by - intro ρ₀ ρ' hpre hwfb hf₀ hstar + intro ρ₀ ρ' hpre hwfb hwfcongr hf₀ hstar cases hstar with | step _ _ _ h1 r1 => cases h1 with - | step_ite_true hc _ => exact ht ρ₀ ρ' ⟨hpre, hc⟩ hwfb hf₀ (.inl r1) - | step_ite_false hc _ => exact he ρ₀ ρ' ⟨hpre, hc⟩ hwfb hf₀ (.inl r1) + | step_ite_true hc _ => exact ht ρ₀ ρ' ⟨hpre, hc⟩ hwfb hwfcongr hf₀ (.inl r1) + | step_ite_false hc _ => exact he ρ₀ ρ' ⟨hpre, hc⟩ hwfb hwfcongr hf₀ (.inl r1) /- TODO: the WHILE rule -/ @@ -206,7 +172,7 @@ end StmtRules section StandardConnection -variable (P' : PureExpr) [HasFvar P'] [HasBool P'] [HasNot P'] +variable (P' : PureExpr) [HasFvar P'] [HasBool P'] [HasNot P'] [HasVarsPure P' P'.Expr] variable (extendEval : ExtendEval P') /-- **Direction 1**: Hoare triple implies assert validity for `PredicatedStmt`. -/ @@ -279,14 +245,14 @@ theorem hoareTriple_implies_assertValid cases h_assume_step with | step_cmd hcmd => cases hcmd with - | eval_assume hpre hwfb => + | eval_assume hpre hwfb hwfcongr => cases h_assume_rest with | refl => have ⟨ρ'_clean, hterm_clean, hs_eq, he_eq⟩ := smallStep_hasFailure_irrel P' (EvalCmd P') extendEval st _ ρ' hterm_st { ρ₀ with hasFailure := false } rfl rfl have ⟨hpost, _⟩ := hoare { ρ₀ with hasFailure := false } ρ'_clean - hpre hwfb rfl hterm_clean + hpre hwfb hwfcongr rfl hterm_clean simp only [hs_eq, he_eq] at hpost have ⟨he, hs⟩ := assert_tail_getEvalStore P' extendEval ρ' post_label post_expr post_md inner ⟨post_label, post_expr⟩ @@ -308,7 +274,7 @@ theorem allAssertsValid_implies_hoareTriple (fun ρ => ρ.eval ρ.store pre_expr = some HasBool.tt) st (fun ρ => ρ.eval ρ.store post_expr = some HasBool.tt) := by - intro ρ₀ ρ' hpre hwfb hf₀ hstar + intro ρ₀ ρ' hpre hwfb hwfcongr hf₀ hstar let assume_stmt : Stmt P' (Cmd P') := .cmd (.assume pre_label pre_expr pre_md) let assert_stmt : Stmt P' (Cmd P') := .cmd (.assert post_label post_expr post_md) let body : List (Stmt P' (Cmd P')) := [assume_stmt, st, assert_stmt] @@ -319,7 +285,7 @@ theorem allAssertsValid_implies_hoareTriple intro a cfg hstar_st hat have h_assume : StepStmtStar P' (EvalCmd P') extendEval (.stmt assume_stmt ρ₀) (.terminal { ρ₀ with store := ρ₀.store, hasFailure := ρ₀.hasFailure || false }) := - .step _ _ _ (StepStmt.step_cmd (EvalCmd.eval_assume hpre hwfb)) (.refl _) + .step _ _ _ (StepStmt.step_cmd (EvalCmd.eval_assume hpre hwfb hwfcongr)) (.refl _) have h_ρ₁_eq : ({ store := ρ₀.store, eval := ρ₀.eval, hasFailure := ρ₀.hasFailure || false } : Env P') = ρ₀ := by cases ρ₀; simp [Bool.or_false] have h1 := stmts_cons_step P' (EvalCmd P') extendEval assume_stmt [st, assert_stmt] ρ₀ _ h_assume @@ -339,7 +305,7 @@ theorem allAssertsValid_implies_hoareTriple exact h_result have h_assume : StepStmtStar P' (EvalCmd P') extendEval (.stmt assume_stmt ρ₀) (.terminal { ρ₀ with store := ρ₀.store, hasFailure := ρ₀.hasFailure || false }) := - .step _ _ _ (StepStmt.step_cmd (EvalCmd.eval_assume hpre hwfb)) (.refl _) + .step _ _ _ (StepStmt.step_cmd (EvalCmd.eval_assume hpre hwfb hwfcongr)) (.refl _) have h_ρ₁_eq : ({ store := ρ₀.store, eval := ρ₀.eval, hasFailure := ρ₀.hasFailure || false } : Env P') = ρ₀ := by cases ρ₀; simp [Bool.or_false] have h1 := stmts_cons_step P' (EvalCmd P') extendEval assume_stmt [st, assert_stmt] ρ₀ _ h_assume @@ -409,13 +375,13 @@ theorem overapproximates_triple (L₁ L₂ : Lang P) (htriple : Hoare.Triple L₂ Pre s' Post) (hwfv : ∀ ρ₀ : Env P, Pre ρ₀ → WellFormedSemanticEvalVal ρ₀.eval) : Hoare.Triple L₁ Pre st Post := by - intro ρ₀ ρ' hpre hwfb hf₀ hstar - exact htriple ρ₀ ρ' hpre hwfb hf₀ - ((hsem st s' ht ρ₀ ρ' hwfb (hwfv ρ₀ hpre)).1 hstar) + intro ρ₀ ρ' hpre hwfb hwfcongr hf₀ hstar + exact htriple ρ₀ ρ' hpre hwfb hwfcongr hf₀ + ((hsem st s' ht ρ₀ ρ' hwfb (hwfv ρ₀ hpre) hwfcongr).1 hstar) theorem overapproximates_id (L₁ : Lang P) : Overapproximates L₁ L₁ some := by - intro st s' ht ρ₀ ρ' _ _ + intro st s' ht ρ₀ ρ' _ _ _ simp at ht; subst ht exact ⟨id, fun _ => id⟩ @@ -424,18 +390,151 @@ theorem overapproximates_comp (L₁ L₂ L₃ : Lang P) (h₁ : Overapproximates L₁ L₂ T₁) (h₂ : Overapproximates L₂ L₃ T₂) : Overapproximates L₁ L₃ (fun s => T₁ s >>= T₂) := by - intro st s'' ht ρ₀ ρ' hwfb hwfv + intro st s'' ht ρ₀ ρ' hwfb hwfv hwfcongr simp [bind, Option.bind] at ht match h : T₁ st with | some s' => rw [h] at ht - have hr₁ := h₁ st s' h ρ₀ ρ' hwfb hwfv - have hr₂ := h₂ s' s'' ht ρ₀ ρ' hwfb hwfv + have hr₁ := h₁ st s' h ρ₀ ρ' hwfb hwfv hwfcongr + have hr₂ := h₂ s' s'' ht ρ₀ ρ' hwfb hwfv hwfcongr refine ⟨?_, ?_⟩ · intro hstar; exact hr₂.1 (hr₁.1 hstar) · intro lbl hstar; exact hr₂.2 lbl (hr₁.2 lbl hstar) | none => rw [h] at ht; exact absurd ht (by nofun) +/-! ## Overapproximation up to an environment relation (`OverapproximatesUpto*`) + +Consumer lemmas for the additive Upto family. The Upto predicates relate whole +environments by a relation `R : Relation (Env P)` and route initial-environment +well-formedness through each `Lang`'s `initEnvWF` field. These lemmas establish +monotonicity in `R`, precondition strengthening, identity, and compositionality +(via relation composition `RComp`, collapsed back to a single relation when `R` +is a preorder). -/ + +section Upto + +open scoped Relations -- `R₁ ∘ R₂` for relation composition (`RComp`) + +omit [HasVal P] [HasVarsPure P P.Expr] in +/-- Rewriting the relation `R → R'`. Since `R` is used both as an input + hypothesis (antitone) and an output witness (monotone), the change requires + `R' ⊆ R` (for the input) *and* `R ⊆ R'` (for the output). -/ +theorem OverapproximatesUptoWhen.mono (L₁ L₂ : Lang P) + (T : L₁.StmtT → Option L₂.StmtT) (pre : L₁.StmtT → Prop) + (params₁ : L₁.InitEnvWFParamsTy) (params₂ : L₂.InitEnvWFParamsTy) + {R R' : Relation (Env P)} + (hin : ∀ a b, R' a b → R a b) + (hout : ∀ a b, R a b → R' a b) + (h : OverapproximatesUptoWhen R L₁ L₂ T pre params₁ params₂) : + OverapproximatesUptoWhen R' L₁ L₂ T pre params₁ params₂ := by + intro st st' ht hpre ρ₀ ρ₀' hR' hwf + have hr := h st st' ht hpre ρ₀ ρ₀' (hin _ _ hR') hwf + refine ⟨fun ρ' => ⟨fun hstar => ?_, fun lbl hstar => ?_⟩, hr.2.1, hr.2.2⟩ + · obtain ⟨ρ'', hR, hstar'⟩ := (hr.1 ρ').1 hstar; exact ⟨ρ'', hout _ _ hR, hstar'⟩ + · obtain ⟨ρ'', hR, hstar'⟩ := (hr.1 ρ').2 lbl hstar; exact ⟨ρ'', hout _ _ hR, hstar'⟩ + +omit [HasVal P] [HasVarsPure P P.Expr] in +/-- Precondition strengthening. -/ +theorem OverapproximatesUptoWhen.strengthen (L₁ L₂ : Lang P) + (T : L₁.StmtT → Option L₂.StmtT) {pre pre' : L₁.StmtT → Prop} + (params₁ : L₁.InitEnvWFParamsTy) (params₂ : L₂.InitEnvWFParamsTy) + {R : Relation (Env P)} + (himp : ∀ st, pre' st → pre st) + (h : OverapproximatesUptoWhen R L₁ L₂ T pre params₁ params₂) : + OverapproximatesUptoWhen R L₁ L₂ T pre' params₁ params₂ := by + intro st st' ht hpre' ρ₀ ρ₀' hR hwf + exact h st st' ht (himp st hpre') ρ₀ ρ₀' hR hwf + +omit [HasVal P] [HasVarsPure P P.Expr] in +/-- The identity transform is an overapproximation up to `Eq` (reflexivity). + This is the unit for `comp`. -/ +theorem OverapproximatesUpto.id (L : Lang P) (params : L.InitEnvWFParamsTy) : + OverapproximatesUpto (· = ·) L L some params params := by + intro st st' ht _ ρ₀ ρ₀' heq hwf + simp only [Option.some.injEq] at ht; subst ht; subst heq + exact ⟨fun ρ' => ⟨fun hstar => ⟨ρ', rfl, hstar⟩, fun lbl hstar => ⟨ρ', rfl, hstar⟩⟩, + (fun h => h), hwf⟩ + +omit [HasVal P] [HasVarsPure P P.Expr] in +/-- **Compositionality** (general form): composing transforms composes the + relations via `RComp`. No conditions on the relations are needed at this + level of generality — they only appear when collapsing the composite + `RComp R₁ R₂` back into a single relation (see `comp_preorder`). -/ +theorem OverapproximatesUptoWhen.comp (L₁ L₂ L₃ : Lang P) + (T₁ : L₁.StmtT → Option L₂.StmtT) (T₂ : L₂.StmtT → Option L₃.StmtT) + {pre₁ : L₁.StmtT → Prop} {pre₂ : L₂.StmtT → Prop} + (params₁ : L₁.InitEnvWFParamsTy) (params₂ : L₂.InitEnvWFParamsTy) + (params₃ : L₃.InitEnvWFParamsTy) + {R₁ R₂ : Relation (Env P)} + (hpre : ∀ st st', T₁ st = some st' → pre₁ st → pre₂ st') + (h₁ : OverapproximatesUptoWhen R₁ L₁ L₂ T₁ pre₁ params₁ params₂) + (h₂ : OverapproximatesUptoWhen R₂ L₂ L₃ T₂ pre₂ params₂ params₃) : + OverapproximatesUptoWhen (R₁ ∘ R₂) + L₁ L₃ (fun s => T₁ s >>= T₂) pre₁ params₁ params₃ := by + intro st st'' ht hpre₁ ρ₀ ρ₀'' hR hwf + -- Decompose the composed transform and the composed input relation. + simp only [bind, Option.bind] at ht + match hT₁ : T₁ st with + | none => rw [hT₁] at ht; exact absurd ht (by nofun) + | some st' => + rw [hT₁] at ht + obtain ⟨ρ₀', hR₁, hR₂⟩ := hR + have hr₁ := h₁ st st' hT₁ hpre₁ ρ₀ ρ₀' hR₁ hwf + have hr₂ := h₂ st' st'' ht (hpre st st' hT₁ hpre₁) ρ₀' ρ₀'' hR₂ hr₁.2.2 + refine ⟨fun ρ' => ⟨fun hstar => ?_, fun lbl hstar => ?_⟩, + fun hcf => hr₂.2.1 (hr₁.2.1 hcf), hr₂.2.2⟩ + · obtain ⟨ρ'₂, hR₁', hstar₂⟩ := (hr₁.1 ρ').1 hstar + obtain ⟨ρ'₃, hR₂', hstar₃⟩ := (hr₂.1 ρ'₂).1 hstar₂ + exact ⟨ρ'₃, ⟨ρ'₂, hR₁', hR₂'⟩, hstar₃⟩ + · obtain ⟨ρ'₂, hR₁', hstar₂⟩ := (hr₁.1 ρ').2 lbl hstar + obtain ⟨ρ'₃, hR₂', hstar₃⟩ := (hr₂.1 ρ'₂).2 lbl hstar₂ + exact ⟨ρ'₃, ⟨ρ'₂, hR₁', hR₂'⟩, hstar₃⟩ + +omit [HasVal P] [HasVarsPure P P.Expr] in +/-- **Compositionality** (single-relation form): if `R` is a *preorder* + (`Reflexive` and `Transitive`) then composing two `OverapproximatesUptoWhen R` + transforms yields another `OverapproximatesUptoWhen R` transform. + + The preorder conditions are exactly what is needed to collapse `RComp R R` + back into `R`: *reflexivity* witnesses `R ⊆ RComp R R` on inputs (antitone + side), and *transitivity* witnesses `RComp R R ⊆ R` on outputs (monotone + side). -/ +theorem OverapproximatesUptoWhen.comp_preorder (L₁ L₂ L₃ : Lang P) + (T₁ : L₁.StmtT → Option L₂.StmtT) (T₂ : L₂.StmtT → Option L₃.StmtT) + {pre₁ : L₁.StmtT → Prop} {pre₂ : L₂.StmtT → Prop} + (params₁ : L₁.InitEnvWFParamsTy) (params₂ : L₂.InitEnvWFParamsTy) + (params₃ : L₃.InitEnvWFParamsTy) + {R : Relation (Env P)} + (hrefl : Reflexive R) + (htrans : Transitive R) + (hpre : ∀ st st', T₁ st = some st' → pre₁ st → pre₂ st') + (h₁ : OverapproximatesUptoWhen R L₁ L₂ T₁ pre₁ params₁ params₂) + (h₂ : OverapproximatesUptoWhen R L₂ L₃ T₂ pre₂ params₂ params₃) : + OverapproximatesUptoWhen R L₁ L₃ (fun s => T₁ s >>= T₂) pre₁ params₁ params₃ := + -- The composite holds for `RComp R R`; reflexivity/transitivity collapse it to `R`. + OverapproximatesUptoWhen.mono L₁ L₃ (fun s => T₁ s >>= T₂) pre₁ params₁ params₃ + (fun a _ hab => ⟨a, hrefl a, hab⟩) + (fun _ _ h => RComp.collapse htrans (fun _ _ => _root_.id) (fun _ _ => _root_.id) h) + (OverapproximatesUptoWhen.comp L₁ L₂ L₃ T₁ T₂ params₁ params₂ params₃ hpre h₁ h₂) + +omit [HasVal P] [HasVarsPure P P.Expr] in +/-- **Compositionality** for the unconditional `OverapproximatesUpto` under a + preorder `R`. The precondition obligation vanishes since `pre = fun _ => True`. -/ +theorem OverapproximatesUpto.comp_preorder (L₁ L₂ L₃ : Lang P) + (T₁ : L₁.StmtT → Option L₂.StmtT) (T₂ : L₂.StmtT → Option L₃.StmtT) + (params₁ : L₁.InitEnvWFParamsTy) (params₂ : L₂.InitEnvWFParamsTy) + (params₃ : L₃.InitEnvWFParamsTy) + {R : Relation (Env P)} + (hrefl : Reflexive R) + (htrans : Transitive R) + (h₁ : OverapproximatesUpto R L₁ L₂ T₁ params₁ params₂) + (h₂ : OverapproximatesUpto R L₂ L₃ T₂ params₂ params₃) : + OverapproximatesUpto R L₁ L₃ (fun s => T₁ s >>= T₂) params₁ params₃ := + OverapproximatesUptoWhen.comp_preorder L₁ L₂ L₃ T₁ T₂ params₁ params₂ params₃ + hrefl htrans (fun _ _ _ _ => trivial) h₁ h₂ + +end Upto + /-! ## Statement-list overapproximation (Imperative-specific) Uses `Overapproximates L L T` (single-language): the proof decomposes @@ -470,6 +569,7 @@ private theorem overapproximates_stmts_aux ∀ (ρ₀ ρ' : Env P), WellFormedSemanticEvalBool ρ₀.eval → WellFormedSemanticEvalVal ρ₀.eval → + WellFormedSemanticEvalExprCongr ρ₀.eval → (StepStmtStar P evalCmd extendEval (.stmts ss ρ₀) (.terminal ρ') → StepStmtStar P evalCmd extendEval (.stmts ss' ρ₀) (.terminal ρ')) ∧ @@ -477,32 +577,33 @@ private theorem overapproximates_stmts_aux StepStmtStar P evalCmd extendEval (.stmts ss' ρ₀) (.exiting lbl ρ')) := by induction ss with | nil => - intro ss' hmap ρ₀ ρ' _ _ + intro ss' hmap ρ₀ ρ' _ _ _ have : ss' = [] := by simp [List.mapM_nil] at hmap; exact hmap subst this; exact ⟨id, fun _ => id⟩ | cons s rest ih => - intro ss' hmap ρ₀ ρ' hwfb hwfv + intro ss' hmap ρ₀ ρ' hwfb hwfv hwfcongr simp [Block.noFuncDecl, Bool.and_eq_true] at hnofd have ⟨hnofd_s, hnofd_rest⟩ := hnofd have ⟨s', rest', hs, hrm, hss'⟩ := List.mapM_cons_some hmap subst hss' have eval_preserved : ∀ ρ₁ : Env P, StepStmtStar P evalCmd extendEval (.stmt s ρ₀) (.terminal ρ₁) → - WellFormedSemanticEvalBool ρ₁.eval ∧ WellFormedSemanticEvalVal ρ₁.eval := by + WellFormedSemanticEvalBool ρ₁.eval ∧ WellFormedSemanticEvalVal ρ₁.eval ∧ + WellFormedSemanticEvalExprCongr ρ₁.eval := by intro ρ₁ hterm_s have heq := smallStep_noFuncDecl_preserves_eval P evalCmd extendEval s ρ₀ ρ₁ hnofd_s hterm_s - exact ⟨heq ▸ hwfb, heq ▸ hwfv⟩ + exact ⟨heq ▸ hwfb, heq ▸ hwfv, heq ▸ hwfcongr⟩ constructor · intro hstar cases hstar with | step _ _ _ hstep hrest_exec => cases hstep with | step_stmts_cons => have ⟨ρ₁, hterm_s, hterm_rest⟩ := seq_reaches_terminal P evalCmd extendEval hrest_exec - have ⟨hwfb₁, hwfv₁⟩ := eval_preserved ρ₁ hterm_s + have ⟨hwfb₁, hwfv₁, hwfcongr₁⟩ := eval_preserved ρ₁ hterm_s exact ReflTrans_Transitive _ _ _ _ (stmts_cons_step P evalCmd extendEval s' rest' ρ₀ ρ₁ - ((hsem s s' hs ρ₀ ρ₁ hwfb hwfv).1 hterm_s)) - ((ih hnofd_rest rest' hrm ρ₁ ρ' hwfb₁ hwfv₁).1 hterm_rest) + ((hsem s s' hs ρ₀ ρ₁ hwfb hwfv hwfcongr).1 hterm_s)) + ((ih hnofd_rest rest' hrm ρ₁ ρ' hwfb₁ hwfv₁ hwfcongr₁).1 hterm_rest) · intro lbl hstar cases hstar with | step _ _ _ hstep hrest_exec => cases hstep with @@ -511,14 +612,14 @@ private theorem overapproximates_stmts_aux | .inl hexit_s => exact .step _ _ _ .step_stmts_cons (ReflTrans_Transitive _ _ _ _ (seq_inner_star P evalCmd extendEval _ _ rest' - ((hsem s s' hs ρ₀ ρ' hwfb hwfv).2 lbl hexit_s)) + ((hsem s s' hs ρ₀ ρ' hwfb hwfv hwfcongr).2 lbl hexit_s)) (.step _ _ _ .step_seq_exit (.refl _))) | .inr ⟨ρ₁, hterm_s, hexit_rest⟩ => - have ⟨hwfb₁, hwfv₁⟩ := eval_preserved ρ₁ hterm_s + have ⟨hwfb₁, hwfv₁, hwfcongr₁⟩ := eval_preserved ρ₁ hterm_s exact ReflTrans_Transitive _ _ _ _ (stmts_cons_step P evalCmd extendEval s' rest' ρ₀ ρ₁ - ((hsem s s' hs ρ₀ ρ₁ hwfb hwfv).1 hterm_s)) - ((ih hnofd_rest rest' hrm ρ₁ ρ' hwfb₁ hwfv₁).2 lbl hexit_rest) + ((hsem s s' hs ρ₀ ρ₁ hwfb hwfv hwfcongr).1 hterm_s)) + ((ih hnofd_rest rest' hrm ρ₁ ρ' hwfb₁ hwfv₁ hwfcongr₁).2 lbl hexit_rest) theorem overapproximates_stmts (T : Stmt P CmdT → Option (Stmt P CmdT)) @@ -528,9 +629,9 @@ theorem overapproximates_stmts (Lang.imperativeBlock evalCmd extendEval isAtAssertFn) (Lang.imperativeBlock evalCmd extendEval isAtAssertFn) (fun ss => ss.mapM T) := by - intro ss ss' hmap ρ₀ ρ' hwfb hwfv + intro ss ss' hmap ρ₀ ρ' hwfb hwfv hwfcongr exact overapproximates_stmts_aux evalCmd extendEval isAtAssertFn T hsem ss - (mapM_noFuncDecl T hnofd_T ss ss' hmap) ss' hmap ρ₀ ρ' hwfb hwfv + (mapM_noFuncDecl T hnofd_T ss ss' hmap) ss' hmap ρ₀ ρ' hwfb hwfv hwfcongr end ImperativeStmts diff --git a/Strata/Transform/StructuredToUnstructured.lean b/Strata/Transform/StructuredToUnstructured.lean index 77168ca4d1..2c64c56963 100644 --- a/Strata/Transform/StructuredToUnstructured.lean +++ b/Strata/Transform/StructuredToUnstructured.lean @@ -15,16 +15,21 @@ namespace Imperative abbrev DetBlocks (Label CmdT : Type) (P : PureExpr) := List (Label × DetBlock Label CmdT P) -def detCmdBlock [HasBool P] (c : CmdT) (k : Label) : +abbrev synthesizedMd {P : PureExpr} : MetaData P := + MetaData.ofProvenance (.synthesized .structuredToUnstructured) + +def detCmdBlock [HasBool P] (c : CmdT) (k : Label) (md : MetaData P) : DetBlock Label CmdT P := - { cmds := [c], transfer := .goto k } + { cmds := [c], transfer := .goto k md } open LabelGen -/-- Flush the list of accumulated commands. If the list is empty, propagate the -provided continuation. If the list is non-empty, create a block containing -one command that jumps to the provided continuation and provide the new block's -label as a new continuation. -/ +/-- Flush the list of accumulated commands. If both the accumulator is empty +and no explicit transfer is provided, propagate the continuation `k`. +Otherwise emit a block: when `tr?` is `some tr`, use `tr` as the transfer +(this is required for `condGoto` so the conditional is materialized even +with empty accum); when `tr?` is `none`, use `.goto k`. -/ +@[expose] def flushCmds [HasBool P] (pfx : String) @@ -32,17 +37,21 @@ def flushCmds (tr? : Option (DetTransferCmd String P)) (k : String) : StringGenM (String × DetBlocks String CmdT P) := do - if accum.isEmpty then - pure (k, []) - else + match tr? with + | none => + if accum.isEmpty then + pure (k, []) + else + let l ← StringGenState.gen pfx + let b := (l, { cmds := accum.reverse, transfer := .goto k .empty }) + pure (l, [b]) + | some tr => let l ← StringGenState.gen pfx - let b := (l, { cmds := accum.reverse, transfer := tr?.getD (.goto k) }) + let b := (l, { cmds := accum.reverse, transfer := tr }) pure (l, [b]) -private abbrev synthesizedMd {P : PureExpr} : MetaData P := - MetaData.ofProvenance (.synthesized .structuredToUnstructured) - /-- Translate a list of statements to basic blocks, accumulating commands -/ +@[expose] def stmtsToBlocks [HasBool P] [HasPassiveCmds P CmdT] [HasInit P CmdT] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] @@ -64,7 +73,7 @@ match ss with | .typeDecl _ _ :: rest => do -- Not yet supported, so just continue with `rest`. stmtsToBlocks k rest exitConts accum -| .block l bss _md :: rest => do +| .block l bss md :: rest => do -- Process rest first let (kNext, bsNext) ← stmtsToBlocks k rest exitConts [] -- Process block body, extending the list of exit continuations. @@ -76,9 +85,9 @@ match ss with -- Empty accumulated block pure (accumEntry, accumBlocks ++ bbs ++ bsNext) else - let b := (l, { cmds := [], transfer := .goto bl }) - pure (l, accumBlocks ++ [b] ++ bbs ++ bsNext) -| .ite c tss fss _md :: rest => do + let b := (l, { cmds := [], transfer := .goto bl md }) + pure (accumEntry, accumBlocks ++ [b] ++ bbs ++ bsNext) +| .ite c tss fss md :: rest => do -- Process rest first let (kNext, bsNext) ← stmtsToBlocks k rest exitConts [] -- Create ite block @@ -94,9 +103,9 @@ match ss with let initCmd := HasInit.init ident HasBool.boolTy .nondet synthesizedMd pure (HasFvar.mkFvar ident, [initCmd]) let (accumEntry, accumBlocks) ← flushCmds "ite$" (accum ++ extraCmds) - (.some (.condGoto condExpr tl fl)) l + (.some (.condGoto condExpr tl fl md)) l pure (accumEntry, accumBlocks ++ tbs ++ fbs ++ bsNext) -| .loop c m is bss _md :: rest => do +| .loop c m is bss md :: rest => do -- Process rest first let (kNext, bsNext) ← stmtsToBlocks k rest exitConts [] -- Create loop entry block @@ -118,7 +127,7 @@ match ss with let decCmd := HasPassiveCmds.assert s!"measure_decrease_{mLabel}" (HasIntOrder.lt mExpr mOldExpr) synthesizedMd let ldec ← StringGenState.gen "measure_decrease$" - let decBlock := (ldec, { cmds := [decCmd], transfer := .goto lentry }) + let decBlock := (ldec, { cmds := [decCmd], transfer := .goto lentry synthesizedMd }) pure ([initCmd, assumeCmd, lbCmd], ldec, [decBlock]) -- Body jumps to bodyK (either directly to lentry, or through the decrease block). let (bl, bbs) ← stmtsToBlocks bodyK bss ((.none, kNext) :: exitConts) [] @@ -131,10 +140,18 @@ match ss with if srcLabel.isEmpty then StringGenState.gen "inv$" else pure srcLabel pure (HasPassiveCmds.assert assertLabel i synthesizedMd)) + -- Attach loop contract (invariants + measure) to the transfer metadata so + -- downstream CFG passes can recover the original spec without relying on the + -- lowered assert commands alone. + let contractMd := is.foldl (fun md (_, inv) => + md.pushElem MetaData.specLoopInvariant (.expr inv)) md + let contractMd := match m with + | some mExpr => contractMd.pushElem MetaData.specDecreases (.expr mExpr) + | none => contractMd -- For nondet guards, introduce a fresh boolean variable match c with | .det e => - let b := (lentry, { cmds := invCmds ++ measureCmds, transfer := .condGoto e bl kNext }) + let b := (lentry, { cmds := invCmds ++ measureCmds, transfer := .condGoto e bl kNext contractMd }) let (accumEntry, accumBlocks) ← flushCmds "before_loop$" accum .none lentry pure (accumEntry, accumBlocks ++ [b] ++ bbs ++ decreaseBlocks ++ bsNext) | .nondet => do @@ -142,32 +159,37 @@ match ss with let ident := HasIdent.ident (P := P) freshName let initCmd := HasInit.init ident HasBool.boolTy .nondet synthesizedMd let b := (lentry, { cmds := [initCmd] ++ invCmds ++ measureCmds, - transfer := .condGoto (HasFvar.mkFvar ident) bl kNext }) + transfer := .condGoto (HasFvar.mkFvar ident) bl kNext contractMd }) let (accumEntry, accumBlocks) ← flushCmds "before_loop$" accum .none lentry pure (accumEntry, accumBlocks ++ [b] ++ bbs ++ decreaseBlocks ++ bsNext) -| .exit l _md :: _ => do - -- Find the continuation of the block labeled `l`. - let bk := - match exitConts.lookup (.some l) with - | .some k => k - -- Just keep going if this is an invalid exit. We assume a prior - -- check to avoid this. - | .none => k - -- Flush the accumulated commands, going to the continuation calculated above. - -- Any statements after the `.exit` are skipped. +| .exit l md :: _ => do + -- Any statements after the `.exit` are skipped. Flush the accumulated + -- commands and emit the transfer that matches the exit's outcome kind. let exitName := s!"block${l}$" - flushCmds exitName accum .none bk + match exitConts.lookup (.some l) with + -- Covered exit: an enclosing block named `l` catches it. Goto that block's + -- continuation `bk`; the structured `.exiting l` is consumed there and the + -- outcome is a normal continuation, faithfully modelled by a goto. + | .some bk => flushCmds exitName accum (.some (.goto bk md)) bk + -- Uncaught exit: no enclosing block catches `l`, so the structured run + -- escapes via `.exiting l`. Emit the dedicated `.exitTo l` transfer so the + -- escaping outcome (and its label) is observable on the target side, rather + -- than silently falling through to `k` (which would miscompile the escape to + -- a normal terminal). + | .none => flushCmds exitName accum (.some (.exitTo l md)) k +@[expose] def stmtsToCFGM [HasBool P] [HasPassiveCmds P CmdT] [HasInit P CmdT] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] (ss : List (Stmt P CmdT)) : StringGenM (CFG String (DetBlock String CmdT P)) := do let lend ← StringGenState.gen "end$" - let bend := (lend, { cmds := [], transfer := .finish }) + let bend := (lend, { cmds := [], transfer := .finish synthesizedMd }) let (l, bs) ← stmtsToBlocks lend ss [] [] pure { entry := l, blocks := bs ++ [bend] } +@[expose] def stmtsToCFG [HasBool P] [HasPassiveCmds P CmdT] [HasInit P CmdT] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] diff --git a/Strata/Transform/StructuredToUnstructuredCorrect.lean b/Strata/Transform/StructuredToUnstructuredCorrect.lean new file mode 100644 index 0000000000..11d339c2cb --- /dev/null +++ b/Strata/Transform/StructuredToUnstructuredCorrect.lean @@ -0,0 +1,14279 @@ +/- + 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.CFGSemantics +public import Strata.DL.Imperative.KleeneSemanticsProps +public import Strata.Transform.StructuredToUnstructured +public import Strata.Transform.GenSuffix +public import Strata.Transform.SpecificationProps +public import Strata.DL.Util.StringGen +public import Strata.Languages.Core.StatementSemantics +import Strata.DL.Imperative.BasicBlock +import all Strata.DL.Imperative.Cmd +import all Strata.DL.Util.Relations + +/-! # 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_kind`. + +## 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 -/ +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` is defined in `Strata.Transform.GenSuffix` (a low base module +-- so multiple correctness passes can reuse it). Re-exported here so all in-file +-- and downstream `open StructuredToUnstructuredCorrect` references resolve +-- unchanged. +export Strata.Transform.GenSuffix (NoGenSuffix) + +/-! ## 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') + +/-- Prefix bridge: lift an `EvalCmds` derivation for a *prefix* `pre` into a chain +of `StepCFG.step_cmd` steps inside `.inBlock t (pre ++ suf) ...`, consuming exactly +`pre` and leaving the suffix `suf` residual. The step rule consumes the head +command regardless of what follows, so the same chain that runs a standalone +`pre` runs it as the leading commands of `pre ++ suf`. -/ +theorem EvalCmds_prefix_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} + {pre suf : List (Cmd P)} {f : Bool} + (h_cmds : EvalCmds P (EvalCmd P) δ σ pre σ' f) : + ∀ (t : String) (tr : DetTransferCmd String P) (f_base : Bool), + StepCFGStar P (EvalCmd P) extendEval cfg + (.inBlock t (pre ++ suf) tr σ f_base) + (.inBlock t suf tr σ' (f_base || f)) := by + induction h_cmds with + | eval_cmds_none => + intro t tr f_base + 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 + have h1 : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.inBlock t ((c :: cs_t) ++ suf) tr σ_in f_base) + (.inBlock t (cs_t ++ suf) tr σ_mid (f_base || failed)) := + StepCFG.step_cmd (extendEval := extendEval) hcmd + have h2 := ih t tr (f_base || failed) + 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 + +/-- 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 _))) + +/-- Like `run_block_finish`, but for the escaping `.exitTo lbl` transfer: a +block whose transfer is `.exitTo lbl` runs its command list and then escapes at +`.exiting lbl`, recording the escaping label. -/ +theorem run_block_exitTo {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 lbl : String} + (h_lkp : List.lookup t cfg.blocks = .some ⟨cs, .exitTo lbl md⟩) + (h_cmds : EvalCmds P (EvalCmd P) δ σ cs σ' f) : + StepCFGStar P (EvalCmd P) extendEval cfg + (.atBlock t σ f_base) + (.exiting lbl σ' (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 (.exitTo lbl md) σ f_base) := + StepCFG.fetch (extendEval := extendEval) h_lkp + have h_chain := EvalCmds_to_StepCFG_chain (extendEval := extendEval) + (cfg := cfg) h_cmds t (.exitTo lbl md) f_base + have h_exit : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.inBlock t [] (.exitTo lbl md) σ' (f_base || f)) + (.exiting lbl σ' (f_base || f)) := + StepCFG.exitTo (extendEval := extendEval) + exact ReflTrans.step _ _ _ h_fetch + (ReflTrans_Transitive _ _ _ _ h_chain + (ReflTrans.step _ _ _ h_exit (ReflTrans.refl _))) + +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 + +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] + (δ : 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_cons_self + 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_cons_self + 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_cons_self + 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_cons_self + 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⟩ + +/-- 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') + +/- Re-export the relocated `Block.userBlockLabels` and `Block.userLabelsShapeNodup` +(now defined in the base statement module) under this namespace, so existing +fully-qualified references resolve unchanged. -/ +export Imperative (Block.userBlockLabels Block.userLabelsShapeNodup) + +/-- `userLabelsShapeNodup` recovers `userLabelsDisjoint` at any WF generator +state: the third (disjointness) conjunct follows from the shape-free conjunct via +`userLabel_not_in_stringGens_of_shape_free`. -/ +theorem Block.userLabelsDisjoint_of_shapeNodup {P : PureExpr} + (ss : List (Stmt P (Cmd P))) + (h : Block.userLabelsShapeNodup ss) : + ∀ gen : StringGenState, StringGenState.WF gen → + Block.userLabelsDisjoint ss gen := by + intro gen hwf + refine ⟨h.1, h.2, ?_⟩ + intro l hl + exact userLabel_not_in_stringGens_of_shape_free hwf (h.1 l hl) + +/-- `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 + +/-- 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. -/ +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 + cases h_lkp : exitConts.lookup (some l?) with + | some bk => + rw [h_lkp] at h_gen + exact flushCmds_genStep _ accum _ _ gen gen' entry blocks h_gen + | none => + rw [h_lkp] 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 := + 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 + | 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 := + 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 + 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) + +/-! ### Pass-tracking: every label `stmtsToCFG` mints satisfies the label *kind* + +`stmtsToCFG` mints block labels under exactly thirteen generator prefixes (the +twelve fixed ones listed in `s2uKind` plus the user-label-parameterised +`"block$⟨l⟩$"`). The lemmas below track `AllMem R` across `flushCmds` and +`stmtsToBlocks` for *any* label-kind predicate `R` that holds of every +`gen`-output under those thirteen prefixes (the thirteen-conjunct mint witness +`hmints`, the same shape as `s2uKind_gen`/`hQmint`). Starting from the empty +generator state (which satisfies `AllMem R` vacuously), every label this pass +produces satisfies `R`. Instantiated at `R := s2uKind`, this lets a downstream +discharge a foreign-label obligation — any label that is *not* `s2uKind` is +absent from the output generator — by plain contraposition +(`not_mem_stringGens_of_not_allMem`), without assuming the consumer keeps *every* +gen-shaped name fresh. -/ + +/-- The thirteen-conjunct mint witness: `R` holds of every `gen`-output under each +of the thirteen prefixes `stmtsToCFG` mints under (twelve fixed and one +parameterised by the user block label being exited). Identical in shape to +`s2uKind_gen` and to the `hQmint` hypothesis of `structuredToUnstructured_sound_kind`. -/ +@[expose] def S2UMintWitness (R : String → Prop) : Prop := + (∀ sg, R (StringGenState.gen "ite" sg).1) + ∧ (∀ sg, R (StringGenState.gen "$__nondet_ite$" sg).1) + ∧ (∀ sg, R (StringGenState.gen "ite$" sg).1) + ∧ (∀ sg, R (StringGenState.gen "loop_entry$" sg).1) + ∧ (∀ sg, R (StringGenState.gen "loop_measure$" sg).1) + ∧ (∀ sg, R (StringGenState.gen "measure_decrease$" sg).1) + ∧ (∀ sg, R (StringGenState.gen "inv$" sg).1) + ∧ (∀ sg, R (StringGenState.gen "$__nondet_loop$" sg).1) + ∧ (∀ sg, R (StringGenState.gen "end$" sg).1) + ∧ (∀ sg, R (StringGenState.gen "l$" sg).1) + ∧ (∀ sg, R (StringGenState.gen "blk$" sg).1) + ∧ (∀ sg, R (StringGenState.gen "before_loop$" sg).1) + ∧ (∀ (l : String) sg, R (StringGenState.gen (s!"block${l}$") sg).1) + +/-- `flushCmds` advancing under a mint prefix preserves `AllMem R`: it either +leaves the generator untouched (empty accumulator, no transfer) or mints a single +label `(gen pfx gen).1`, which `allMem_gen` absorbs via the per-prefix mint +witness `h_mint`. -/ +private theorem flushCmds_allMem {P : PureExpr} [HasBool P] {R : String → Prop} + (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')) + (h_mint : ∀ sg, R (StringGenState.gen pfx sg).1) + (h_in : StringGenState.AllMem R gen) : + StringGenState.AllMem R 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 h_in + · 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.allMem_gen R pfx gen h_in (h_mint 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.allMem_gen R pfx gen h_in (h_mint gen) + +/-- A generic `mapM_allMem`: if each step of a `StringGenM` computation +preserves `AllMem R`, the whole `mapM` does too. The analogue of +`mapM_genStep` for the membership-tracking invariant. -/ +private theorem mapM_allMem {α β : Type} (Pred : String → Prop) + (f : α → LabelGen.StringGenM β) + (h_step : ∀ (a : α) (gen gen' : StringGenState) (b : β), + f a gen = (b, gen') → + StringGenState.AllMem Pred gen → + StringGenState.AllMem Pred gen') + (xs : List α) + (gen gen' : StringGenState) (ys : List β) + (h_eq : xs.mapM f gen = (ys, gen')) + (h_in : StringGenState.AllMem Pred gen) : + StringGenState.AllMem Pred gen' := by + induction xs generalizing gen gen' ys with + | nil => + rw [List.mapM_nil] at h_eq + simp only [pure, StateT.pure] at h_eq + have h_gen' : gen = gen' := (Prod.mk.inj h_eq).2 + exact h_gen' ▸ h_in + | 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 h_mid : StringGenState.AllMem Pred gen_mid := + h_step hd gen gen_mid y h_f h_in + exact h_gen' ▸ ih gen_mid gen_end ys' h_tail h_mid + +/-- The invariant-assert `mapM` only mints under `"inv$"` (for empty source +labels) or not at all, so it preserves `AllMem R` whenever `R` holds of every +`"inv$"` `gen`-output. -/ +private theorem invMapM_allMem {P : PureExpr} [HasPassiveCmds P (Cmd P)] + {R : String → Prop} + (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)) + (h_inv_mint : ∀ sg, R (StringGenState.gen "inv$" sg).1) + (h_in : StringGenState.AllMem R gen_b) : + StringGenState.AllMem R gen_i := by + apply mapM_allMem R _ _ is gen_b gen_i invCmds h_inv_def h_in + intro a g g' b h_step h_g_in + 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.allMem_gen R "inv$" g h_g_in (h_inv_mint 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 h_g_in + +/-- `stmtsToBlocks` preserves `AllMem R`: every label it mints satisfies `R`, +given that `R` holds of every `gen`-output under the thirteen mint prefixes +(`hmints : S2UMintWitness R`). Mirrors `stmtsToBlocks_genStep` arm-by-arm, +discharging each `flushCmds`/`gen` mint with the matching component of `hmints` +and composing recursive calls through the IH. -/ +private theorem stmtsToBlocks_allMem + {P : PureExpr} [HasBool P] [HasIdent P] [HasFvar P] [HasIntOrder P] [HasNot P] + {R : String → Prop} (hmints : S2UMintWitness R) + (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_in : StringGenState.AllMem R gen) : + StringGenState.AllMem R gen' := by + match h_match : ss with + | [] => + unfold stmtsToBlocks at h_gen + exact flushCmds_allMem "l$" accum .none k gen gen' entry blocks h_gen + hmints.2.2.2.2.2.2.2.2.2.1 h_in + | .cmd c :: rest => + unfold stmtsToBlocks at h_gen + exact stmtsToBlocks_allMem hmints k rest exitConts (c :: accum) gen gen' entry blocks + h_gen h_in + | .funcDecl _ _ :: rest => + unfold stmtsToBlocks at h_gen + exact stmtsToBlocks_allMem hmints k rest exitConts accum gen gen' entry blocks h_gen h_in + | .typeDecl _ _ :: rest => + unfold stmtsToBlocks at h_gen + exact stmtsToBlocks_allMem hmints k rest exitConts accum gen gen' entry blocks h_gen h_in + | .exit l? md :: _ => + unfold stmtsToBlocks at h_gen + cases h_lkp : exitConts.lookup (some l?) with + | some bk => + rw [h_lkp] at h_gen + exact flushCmds_allMem _ accum _ _ gen gen' entry blocks h_gen + (hmints.2.2.2.2.2.2.2.2.2.2.2.2 l?) h_in + | none => + rw [h_lkp] at h_gen + exact flushCmds_allMem _ accum _ _ gen gen' entry blocks h_gen + (hmints.2.2.2.2.2.2.2.2.2.2.2.2 l?) h_in + | .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_in_rest := stmtsToBlocks_allMem hmints k rest exitConts [] gen gen_r + kNext bsNext h_rest_eq h_in + have h_in_body := stmtsToBlocks_allMem hmints kNext bss _ [] gen_r gen_b + bl bbs h_body_eq h_in_rest + have h_in_flush := flushCmds_allMem "blk$" accum .none bl gen_b gen_f + accumEntry accumBlocks h_flush_eq + hmints.2.2.2.2.2.2.2.2.2.2.1 h_in_body + 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_in_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_in_rest := stmtsToBlocks_allMem hmints k rest exitConts [] gen gen_r + kNext bsNext h_rest_eq h_in + have h_in_ite : StringGenState.AllMem R gen_ite := by + rw [show gen_ite = (StringGenState.gen "ite" gen_r).2 from (by rw [h_ite_label])] + exact StringGenState.allMem_gen R "ite" gen_r h_in_rest (hmints.1 gen_r) + have h_in_then := stmtsToBlocks_allMem hmints kNext tss exitConts [] gen_ite gen_t + tl tbs h_then_eq h_in_ite + have h_in_else := stmtsToBlocks_allMem hmints kNext fss exitConts [] gen_t gen_e + fl fbs h_else_eq h_in_then + 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_in_flush : StringGenState.AllMem R gen_f := + flushCmds_allMem "ite$" accum _ l_ite gen_e gen_f + accumEntry accumBlocks h_flush_eq hmints.2.2.1 h_in_else + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ h_in_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_in_nondet : StringGenState.AllMem R gen_n := by + rw [show gen_n = (StringGenState.gen "$__nondet_ite$" gen_e).2 from + (by rw [h_nondet_gen])] + exact StringGenState.allMem_gen R "$__nondet_ite$" gen_e h_in_else + (hmints.2.1 gen_e) + have h_in_flush : StringGenState.AllMem R gen_f := + flushCmds_allMem "ite$" _ _ l_ite gen_n gen_f + accumEntry accumBlocks h_flush_eq hmints.2.2.1 h_in_nondet + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ h_in_flush + | .loop c m is bss md :: rest => + simp only [stmtsToBlocks, bind, StateT.bind] 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_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_in_rest := stmtsToBlocks_allMem hmints k rest exitConts [] gen gen_r + kNext bsNext h_rest_eq h_in + have h_in_le : StringGenState.AllMem R gen_le := by + rw [show gen_le = (StringGenState.gen "loop_entry$" gen_r).2 from + (by rw [h_lentry_def])] + exact StringGenState.allMem_gen R "loop_entry$" gen_r h_in_rest + (hmints.2.2.2.1 gen_r) + 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 + 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_in_body := stmtsToBlocks_allMem hmints lentry bss _ [] gen_le gen_b bl bbs + h_body_eq h_in_le + have h_in_inv : StringGenState.AllMem R gen_i := + invMapM_allMem is gen_b gen_i invCmds h_inv_def hmints.2.2.2.2.2.2.1 h_in_body + 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_in_flush : StringGenState.AllMem R gen_f := + flushCmds_allMem "before_loop$" accum _ lentry gen_i gen_f + accumEntry accumBlocks h_flush_eq + hmints.2.2.2.2.2.2.2.2.2.2.2.1 h_in_inv + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ h_in_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_in_nondet : StringGenState.AllMem R gen_n := by + rw [show gen_n = (StringGenState.gen "$__nondet_loop$" gen_i).2 from + (by rw [h_nondet_gen])] + exact StringGenState.allMem_gen R "$__nondet_loop$" gen_i h_in_inv + (hmints.2.2.2.2.2.2.2.1 gen_i) + have h_in_flush : StringGenState.AllMem R gen_f := + flushCmds_allMem "before_loop$" accum _ lentry gen_n gen_f + accumEntry accumBlocks h_flush_eq + hmints.2.2.2.2.2.2.2.2.2.2.2.1 h_in_nondet + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ h_in_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_in_ml : StringGenState.AllMem R gen_ml := by + rw [show gen_ml = (StringGenState.gen "loop_measure$" gen_le).2 from + (by rw [h_ml_def])] + exact StringGenState.allMem_gen R "loop_measure$" gen_le h_in_le + (hmints.2.2.2.2.1 gen_le) + have h_in_ldec : StringGenState.AllMem R gen_ldec := by + rw [show gen_ldec = (StringGenState.gen "measure_decrease$" gen_ml).2 from + (by rw [h_ldec_def])] + exact StringGenState.allMem_gen R "measure_decrease$" gen_ml h_in_ml + (hmints.2.2.2.2.2.1 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_in_body := stmtsToBlocks_allMem hmints ldec bss _ [] gen_ldec gen_b bl bbs + h_body_eq h_in_ldec + have h_in_inv : StringGenState.AllMem R gen_i := + invMapM_allMem is gen_b gen_i invCmds h_inv_def hmints.2.2.2.2.2.2.1 h_in_body + 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_in_flush : StringGenState.AllMem R gen_f := + flushCmds_allMem "before_loop$" accum _ lentry gen_i gen_f + accumEntry accumBlocks h_flush_eq + hmints.2.2.2.2.2.2.2.2.2.2.2.1 h_in_inv + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ h_in_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_in_nondet : StringGenState.AllMem R gen_n := by + rw [show gen_n = (StringGenState.gen "$__nondet_loop$" gen_i).2 from + (by rw [h_nondet_gen])] + exact StringGenState.allMem_gen R "$__nondet_loop$" gen_i h_in_inv + (hmints.2.2.2.2.2.2.2.1 gen_i) + have h_in_flush : StringGenState.AllMem R gen_f := + flushCmds_allMem "before_loop$" accum _ lentry gen_n gen_f + accumEntry accumBlocks h_flush_eq + hmints.2.2.2.2.2.2.2.2.2.2.2.1 h_in_nondet + have h_gen_eq : gen_f = gen' := (Prod.mk.inj h_gen).2 + exact h_gen_eq ▸ h_in_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 transfer choice is pure (no gen calls); only flushCmds is stateful. + -- exit truncates so blocks only come from flushCmds (no user labels). + -- Either branch (covered goto / uncaught exitTo) emits via flushCmds. + unfold stmtsToBlocks at h_gen + rw [Block.userBlockLabels_exit_cons] + have h_inv : @GenInv P gen gen' [] blocks := by + cases h_lkp : exitConts.lookup (some l?) with + | some bk => + rw [h_lkp] at h_gen + exact flushCmds_invariant _ accum _ _ gen gen' entry blocks h_gen hwf + | none => + rw [h_lkp] at h_gen + exact 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] 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 := + invMapM_genStep is gen_b gen_i invCmds h_inv_def + 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 := + 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 + · -- 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] + 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] + 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 := + invMapM_genStep is gen_b gen_i invCmds h_inv_def + 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] + 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] + 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', StringGenState.WF 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 hwf_r2 : StringGenState.WF r.2 := + (stmtsToBlocks_genStep lend ss [] [] gen0 r.2 r.1.1 r.1.2 h_eq).wf_mono hwf0 + 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 _ hwf_r2) + -- 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 condGoto flushing + +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. -/ + +/-- 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) + (b : Bool) + (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 (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 (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 _ ρ₀.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 (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 + 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` +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 .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 .empty } := + List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup _ _ h_mem + -- `.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 + 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 + +/-- Escaping analogue of `flushCmds_goto_simulation_agree` for the `flushCmds` +shape where the transfer is `.some (.exitTo lbl md)` (the uncaught `.exit` +constructor of `stmtsToBlocks`). The emitted block always materializes a single +fresh block (regardless of whether `accum` is empty) and escapes at +`.exiting lbl` rather than reaching a continuation `.atBlock`. -/ +private theorem flushCmds_exitTo_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) (lbl : String) + (k : String) + (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P) + (h_gen : flushCmds pfx accum (.some (.exitTo lbl md)) k gen + = ((entry, blocks), gen')) + (σ_struct_base σ_base : SemanticStore P) + (hf_base hf_accum : Bool) + (ρ₀ : Env P) + (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) + (.exiting lbl σ_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.exitTo lbl md } + : DetBlock String (Cmd P) P)) ∈ cfg.blocks := + h_cfg_blocks _ (List.Mem.head _) + have h_lkp : cfg.blocks.lookup (StringGenState.gen pfx gen).fst = + some { cmds := accum.reverse, transfer := DetTransferCmd.exitTo lbl md } := + List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup _ _ h_mem + have h_run := run_block_exitTo (extendEval := extendEval) (cfg := cfg) + (f_base := hf_base) h_lkp h_accum_cfg + 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] + {Q : String → Prop} + {δ : 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, + Q x → + x ∉ StringGenState.stringGens gen → + σ_base (HasIdent.ident (P := P) x) = none) + (h_accum_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars accum.reverse)) : + ∀ x : String, + Q 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 := + h_accum_no_gen_suffix x 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] + {Q : String → Prop} + {σ_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, + Q x → + x ∉ StringGenState.stringGens gen → + σ_base (HasIdent.ident (P := P) x) = none) + (h_accum_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars accum.reverse)) : + ∀ x : String, + Q 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 := + h_accum_no_gen_suffix x 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] + {Q : String → Prop} + {σ_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, + Q x → + x ∉ StringGenState.stringGens genUpperBound → + σ_in (HasIdent.ident (P := P) x) = none) + (h_sub_no_gen_suffix : NoGenSuffix (P := P) Q sub_init) : + ∀ x : String, + Q 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 := + h_sub_no_gen_suffix x 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] + {Q : String → Prop} + (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) Q (Cmds.definedVars accum.reverse ++ Block.initVars (.cmd c :: rest))) + (h_no_m : NoGenSuffix (P := P) Q (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) Q (Cmds.definedVars (c :: accum).reverse ++ Block.initVars rest)) + ∧ (NoGenSuffix (P := P) Q (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 + | 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] + exact ⟨h_d_snoc, + fun x hx => h_fresh x (h_d ▸ hx), + h_d ▸ h_uniq, + h_d ▸ h_no_d, + h_m ▸ h_no_m⟩ + +/-- 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 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_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) + ∧ (∀ 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_inits_after_step`, plus `h_unique`, the 2-way `h_initvars_eq`, + `h_preserve_body` (5-premise form), the `gen_b`-foreign discharge + `h_foreign_b`, and the per-element no-gen-suffix discharge. + + The disjunction-guard premise of `h_preserve_body` is discharged via + `Or.inr (s ∉ stringGens gen_b)`: a `rest`-init var `s` fails the kind + predicate `Q` (it is user source), and `h_foreign_b` certifies that any + non-`Q` string is absent from this pass's generated labels. Instantiating + `Q := HasUnderscoreDigitSuffix` recovers the blanket discharge via a WF + generator (every generated label is gen-shaped, so a non-gen-shaped `s` + cannot have been minted). + Used at every body/then/else paired site in `stmtsToBlocks_simulation`. -/ +private theorem fresh_rest_inits_body_step {P : PureExpr} [HasIdent P] + {Q : String → Prop} + {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_foreign_b : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens gen_b) + (h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (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 + (h_foreign_b s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simp [Cmds.definedVars]; exact hx))))) + +/-- 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 + ∧ (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} + [HasIdent P] [HasVarsPure P P.Expr] + {Q : String → Prop} + (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) Q (Cmds.definedVars accum.reverse ++ Block.initVars (.typeDecl tc md :: rest))) + (h_no_m : NoGenSuffix (P := P) Q (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) Q (Cmds.definedVars accum.reverse ++ Block.initVars rest)) + ∧ (NoGenSuffix (P := P) Q (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 [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] + exact ⟨fun x hx => h_fresh x (h_d ▸ hx), + h_d ▸ h_uniq, + h_d ▸ h_no_d, + h_m ▸ h_no_m⟩ + +/-! ### 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 + +/-! ### 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 +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_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 ∧ + 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_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 + 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_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.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⟩ + +/-- 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) + (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 (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) := + 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 (if b then HasBool.tt else HasBool.ff) := + h_cond ▸ (h_congr g σ_struct σ_cfg h_pointwise).symm + 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 +ρ_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 + +/-- 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) + (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)) + (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 → + 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) + (hwfb_pre : WellFormedSemanticEvalBool ρ_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 ∧ + 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 + 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' → + storeInv σ_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' ∧ + storeInv σ_cfg_kNext' from + h_inner hT.len ρ_pre ρ_post_loop σ_cfg_pre rfl + 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' 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' 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 => + -- 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', h_inv'⟩ + 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 _ _ _ _ _ _ _ _ _ _ _ _ + 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 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). + 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 := + 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, h_inv_post⟩ := + ih ρ_block ρ_post' σ_cfg_after_body h_eval_eq_block + hwfb_block hwf_def_block hwfcongr_block + 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 + +/-- `_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) + (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)) + (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 → + 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) + (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 ∧ + storeInv σ_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 ∧ + 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 + 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' → + storeInv σ_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' ∧ + storeInv σ_cfg_bk' from + h_inner hT.len ρ_pre ρ_post_loop σ_cfg_pre rfl + 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' 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' 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 => + -- 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 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 + 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_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, 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_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] + 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, h_inv_post⟩ := + ih ρ_block ρ_post' σ_cfg_after_body h_eval_eq_block + hwfb_block hwf_def_block hwfcongr_block + 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 + + +private theorem loop_iterations_to_exit_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 : 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)) + (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 → + 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) + (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) + (.exiting label σ_cfg_after_body ρ_body.hasFailure) ∧ + 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) : + ∃ σ_cfg_bk, + StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre ρ_pre.hasFailure) + (.exiting label σ_cfg_bk ρ_post_loop.hasFailure) ∧ + 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 + 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' → + storeInv σ_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) + (.exiting label σ_cfg_bk' ρ_post'.hasFailure) ∧ + 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 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' 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' 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 => + -- 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 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 + 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_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, 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_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] + 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, h_inv_post⟩ := + ih ρ_block ρ_post' σ_cfg_after_body h_eval_eq_block + hwfb_block hwf_def_block hwfcongr_block + 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 + +/-! ### Failing-config (`_to_fail`) structured-side peeling helpers + +These are the length-bearing analogues of the `_reaches_terminal'` / `_reaches_exiting'` +inversion lemmas, but keyed on a FAILING configuration as the halting condition +(`d.getEnv.hasFailure = true`) instead of a stuck endpoint. They drive a simulation +variant that tracks the cumulative failure flag rather than a normal/escaping outcome, +so that `hasFailure`-reachability on the structured side maps to `getFailure`-reachability +on the CFG side WITHOUT any termination assumption. + +The target config is left abstract (it is the failing config, which need not be stuck), +so a direct `match` on the trace cannot refine the source frame's components; each lemma +therefore generalises the source over its frame component(s) and recurses on a `Nat` fuel +bounding the derivation length (the same shape `loop_iterations_det` uses). -/ + +/-- A `ReflTransT` run starting at a stuck `.terminal ρ` stays at `.terminal ρ`. -/ +private theorem reflTransT_from_terminal {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) {ρ : Env P} {c : Config P (Cmd P)} + (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.terminal ρ) c) : c = .terminal ρ := by + match h with + | .refl _ => rfl + | .step _ _ _ hstep _ => exact nomatch hstep + +/-- A `ReflTransT` run starting at a stuck `.exiting l ρ` stays at `.exiting l ρ`. -/ +private theorem reflTransT_from_exiting {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) {l : String} {ρ : Env P} {c : Config P (Cmd P)} + (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.exiting l ρ) c) : c = .exiting l ρ := by + match h with + | .refl _ => rfl + | .step _ _ _ hstep _ => exact nomatch hstep + +/-- Failing-config inversion for a `.seq inner ss` frame. Either the failure is +inside `inner` (it reaches a failing config), or `inner` terminates at `ρ₁` and the +continuation `.stmts ss ρ₁` reaches a failing config — with strictly decreasing +derivation length in the second case (the seq prefix is consumed). -/ +private theorem seqT_reaches_failing' {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))} {c : Config P (Cmd P)} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.seq inner ss) c) + (hc : c.getEnv.hasFailure = true) : + (∃ d, ∃ (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner d), + d.getEnv.hasFailure = true ∧ h.len ≤ hstar.len) ∨ + (∃ (ρ₁ : Env P), ∃ d, + ∃ (h1 : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.terminal ρ₁)), + ∃ (h2 : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmts ss ρ₁) d), + d.getEnv.hasFailure = true ∧ h1.len + h2.len < hstar.len) := by + suffices H : ∀ n (inn : Config P (Cmd P)) + (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.seq inn ss) c), + h.len ≤ n → c.getEnv.hasFailure = true → + (∃ d, ∃ (h' : ReflTransT (StepStmt P (EvalCmd P) extendEval) inn d), + d.getEnv.hasFailure = true ∧ h'.len ≤ h.len) ∨ + (∃ (ρ₁ : Env P), ∃ d, + ∃ (h1 : ReflTransT (StepStmt P (EvalCmd P) extendEval) inn (.terminal ρ₁)), + ∃ (h2 : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmts ss ρ₁) d), + d.getEnv.hasFailure = true ∧ h1.len + h2.len < h.len) by + exact H hstar.len inner hstar (Nat.le_refl _) hc + intro n + induction n with + | zero => + intro inn h hlen hc' + match h, hlen with + | .refl _, _ => left; exact ⟨inn, .refl _, hc', by simp [ReflTransT.len]⟩ + | .step _ _ _ _ _, hl => simp [ReflTransT.len] at hl + | succ n ih => + intro inn h hlen hc' + match h, hlen with + | .refl _, _ => left; exact ⟨inn, .refl _, hc', by simp [ReflTransT.len]⟩ + | .step _ (.seq inner₁ _) _ (.step_seq_inner h_inner_step) hrest, hl => + have hlen' : hrest.len ≤ n := by simp [ReflTransT.len] at hl; omega + rcases ih inner₁ hrest hlen' hc' with hA | hB + · obtain ⟨d, h', hd, hlen''⟩ := hA + exact .inl ⟨d, .step _ _ _ h_inner_step h', hd, by simp [ReflTransT.len]; omega⟩ + · obtain ⟨ρ₁, d, h1, h2, hd, hlen''⟩ := hB + exact .inr ⟨ρ₁, d, .step _ _ _ h_inner_step h1, h2, hd, by simp [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_seq_done hrest, hl => + rename_i ρ' + exact .inr ⟨ρ', _, .refl _, hrest, hc', by simp [ReflTransT.len]⟩ + | .step _ _ _ .step_seq_exit hrest, hl => + rename_i label ρ' + left + refine ⟨.exiting label ρ', .refl _, ?_, by simp [ReflTransT.len]⟩ + match hrest with + | .refl _ => exact hc' + | .step _ _ _ h' _ => exact nomatch h' + +/-- Failing-config inversion for a `.block .none σ_parent inner` frame: the failure +is inside the block body (`inner` reaches a failing config), with derivation length +bounded by the original. The block-done / exit-propagation cases reduce to the inner +body's already-reached failing endpoint. -/ +private theorem blockT_none_reaches_failing' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + {inner : Config P (Cmd P)} {σ_parent : SemanticStore P} {c : Config P (Cmd P)} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.block .none σ_parent inner) c) + (hc : c.getEnv.hasFailure = true) : + ∃ d, ∃ (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner d), + d.getEnv.hasFailure = true ∧ h.len ≤ hstar.len := by + suffices H : ∀ n (σ_p : SemanticStore P) (inn : Config P (Cmd P)) + (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.block .none σ_p inn) c), + h.len ≤ n → c.getEnv.hasFailure = true → + ∃ d, ∃ (h' : ReflTransT (StepStmt P (EvalCmd P) extendEval) inn d), + d.getEnv.hasFailure = true ∧ h'.len ≤ h.len by + exact H hstar.len σ_parent inner hstar (Nat.le_refl _) hc + intro n + induction n with + | zero => + intro σ_p inn h hlen hc' + match h, hlen with + | .refl _, _ => exact ⟨inn, .refl _, hc', by simp [ReflTransT.len]⟩ + | .step _ _ _ _ _, hl => simp [ReflTransT.len] at hl + | succ n ih => + intro σ_p inn h hlen hc' + match h, hlen with + | .refl _, _ => exact ⟨inn, .refl _, hc', by simp [ReflTransT.len]⟩ + | .step _ (.block _ _ inner₁) _ (.step_block_body h_inner_step) hrest, hl => + have hlen' : hrest.len ≤ n := by simp [ReflTransT.len] at hl; omega + have ⟨d, h', hd, hlen''⟩ := ih σ_p inner₁ hrest hlen' hc' + exact ⟨d, .step _ _ _ h_inner_step h', hd, by simp [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_block_done hrest, hl => + have hz := reflTransT_from_terminal extendEval hrest + refine ⟨_, .refl _, ?_, by simp [ReflTransT.len]⟩ + rw [hz] at hc' + simpa [Config.getEnv] using hc' + | .step _ _ _ (.step_block_exit_match heq) hrest, hl => exact (nomatch heq) + | .step _ _ _ (.step_block_exit_mismatch hne) hrest, hl => + have hz := reflTransT_from_exiting extendEval hrest + refine ⟨_, .refl _, ?_, by simp [ReflTransT.len]⟩ + rw [hz] at hc' + simpa [Config.getEnv] using hc' + +/-- Failing-config inversion for a general `.block l σ_parent inner` frame (any +label, `.none` or `.some`): the failure is inside the block body, so `inner` +reaches a failing config. The block-done / exit-match cases reduce to the inner +body's already-reached failing endpoint (a matched exit terminates the block at a +projected env whose failure flag is the inner exiting env's); the exit-mismatch +case propagates the inner exiting env unchanged. Prop-level (no length bound) +since the `.block` arm only needs the recursive body's failing reach, not a +decreasing measure. -/ +private theorem block_reaches_failing' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + {l : Option String} {inner : Config P (Cmd P)} {σ_parent : SemanticStore P} + {c : Config P (Cmd P)} + (hstar : StepStmtStar P (EvalCmd P) extendEval (.block l σ_parent inner) c) + (hc : c.getEnv.hasFailure = true) : + ∃ d, StepStmtStar P (EvalCmd P) extendEval inner d ∧ d.getEnv.hasFailure = true := by + suffices H : ∀ src tgt, StepStmtStar P (EvalCmd P) extendEval src tgt → + ∀ (lp : Option String) (σ_p : SemanticStore P) (inn : Config P (Cmd P)), + src = .block lp σ_p inn → tgt.getEnv.hasFailure = true → + ∃ d, StepStmtStar P (EvalCmd P) extendEval inn d ∧ d.getEnv.hasFailure = true by + exact H _ _ hstar l σ_parent inner rfl hc + intro src tgt hstar_g + induction hstar_g with + | refl => + intro lp σ_p inn hsrc hc' + subst hsrc + exact ⟨inn, .refl _, by simpa [Config.getEnv] using hc'⟩ + | step _ mid _ hstep hrest ih => + intro lp σ_p inn hsrc hc' + subst hsrc + cases hstep with + | step_block_body h_inner_step => + rename_i inner₁ + have ⟨d, h', hd⟩ := ih _ _ _ rfl hc' + exact ⟨d, .step _ _ _ h_inner_step h', hd⟩ + | step_block_done => + have hz := reflTransT_from_terminal extendEval (reflTrans_to_T hrest) + rw [hz] at hc' + exact ⟨_, .refl _, by simpa [Config.getEnv] using hc'⟩ + | step_block_exit_match heq => + have hz := reflTransT_from_terminal extendEval (reflTrans_to_T hrest) + rw [hz] at hc' + exact ⟨_, .refl _, by simpa [Config.getEnv] using hc'⟩ + | step_block_exit_mismatch hne => + have hz := reflTransT_from_exiting extendEval (reflTrans_to_T hrest) + rw [hz] at hc' + exact ⟨_, .refl _, by simpa [Config.getEnv] using hc'⟩ + +/-- Singleton-list peel for the failing case: from `.stmts [s] ρ₀ ⟶* c` (failing), +recover `.stmt s ρ₀ ⟶* d` reaching a failing config of no-greater length. Used to +recurse one loop iteration on the residual `[.loop ...]` singleton. -/ +private theorem stmts_singleton_reaches_failing' {P : PureExpr} [HasFvar P] [HasBool P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + {s : Stmt P (Cmd P)} {ρ₀ : Env P} {c : Config P (Cmd P)} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmts [s] ρ₀) c) + (hc : c.getEnv.hasFailure = true) : + ∃ d, ∃ (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmt s ρ₀) d), + d.getEnv.hasFailure = true ∧ h.len ≤ hstar.len := by + match hstar with + | .refl _ => + exact ⟨.stmt s ρ₀, .refl _, hc, by simp [ReflTransT.len]⟩ + | .step _ _ _ .step_stmts_cons hrest => + rcases seqT_reaches_failing' extendEval hrest hc with hA | hB + · obtain ⟨d, h, hd, hlen⟩ := hA + exact ⟨d, h, hd, by simp [ReflTransT.len]; omega⟩ + · obtain ⟨ρ₁, d, h1, h2, hd, hlen⟩ := hB + refine ⟨.terminal ρ₁, h1, ?_, by simp [ReflTransT.len]; omega⟩ + have hρ₁ : ρ₁.hasFailure = true := by + have : d.getEnv = ρ₁ := by + match h2 with + | .refl _ => rfl + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h' _ => exact nomatch h' + rw [this] at hd + exact hd + simpa [Config.getEnv] using hρ₁ + +/-- Cons-list peel for the failing case: from `.stmts (s :: rest) ρ₀ ⟶* c` (failing), +either the head statement `.stmt s ρ₀` already reaches a failing config, or it +terminates at `ρ₁` and `.stmts rest ρ₁` reaches a failing config. This is the +generic decomposition shared by every cons-arm of `stmtsToBlocks_simulation_to_fail`: +the head's failing-reach routes into the head-specific discharge, the +terminate-then-rest case recurses on `rest`. -/ +private theorem stmts_cons_reaches_failing' {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} {c : Config P (Cmd P)} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.stmts (s :: rest) ρ₀) c) + (hc : c.getEnv.hasFailure = true) : + (∃ d, StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ₀) d ∧ + d.getEnv.hasFailure = true) ∨ + (∃ (ρ₁ : Env P), ∃ d, + StepStmtStar P (EvalCmd P) extendEval (.stmt s ρ₀) (.terminal ρ₁) ∧ + StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ₁) d ∧ + d.getEnv.hasFailure = true) := by + match hstar with + | .refl _ => + exact .inl ⟨.stmt s ρ₀, .refl _, by simpa [Config.getEnv] using hc⟩ + | .step _ _ _ .step_stmts_cons hrest => + rcases seqT_reaches_failing' extendEval hrest hc with hA | hB + · obtain ⟨d, h, hd, _⟩ := hA + exact .inl ⟨d, reflTransT_to_prop h, hd⟩ + · obtain ⟨ρ₁, d, h1, h2, hd, _⟩ := hB + exact .inr ⟨ρ₁, d, reflTransT_to_prop h1, reflTransT_to_prop h2, hd⟩ + +/-- Iterate the deterministic loop until a FAILING configuration is reached (the +`_to_fail` analogue of `loop_iterations_det`). Inducts on a `Nat` fuel bounding the +length of the finite structured run that reaches the failing config `a'` (finite by +`hasFailure`-monotonicity), NOT on a terminal run. Each COMPLETED iteration +(case B) terminated at the body-block boundary — the loop re-entered — so the existing +per-iteration terminal body sim `h_body_sim_at` applies, and we recurse on the next +iteration via `stmts_singleton_reaches_failing'` with a strictly smaller bound. The +FAILING iteration (case A) is a partial body run to the failing command, discharged by +the body-level `_to_fail` sim `h_body_sim_fail_at` with NO terminal demand. The +guard-false base case (`step_loop_exit`, `inv = []`) reaches a terminal whose failure +flag equals `ρ_pre'.hasFailure`; if it is failing then the loop head is already a failing +CFG config, so the loop terminating is never used. -/ +private theorem loop_iterations_to_fail_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 : Env P) (a' : Config P (Cmd P)) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (lentry kNext bl : 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_reach : StepStmtStar P (EvalCmd P) extendEval + (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) a') + (h_a'_fail : a'.getEnv.hasFailure = true) + (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 → + 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) + (h_body_sim_fail_at : + ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), + ρ_iter.eval = ρ_pre.eval → + StoreAgreement ρ_iter.store σ_cfg_iter → + storeInv σ_cfg_iter → + ∀ (d : Config P (Cmd P)), StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_iter) d → d.getEnv.hasFailure = true → + ∃ e : CFGConfig String (Cmd P) P, + StepDetCFGStar extendEval cfg + (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) e ∧ + e.getFailure = true) + (hwfb_pre : WellFormedSemanticEvalBool ρ_pre.eval) + (hwf_def_pre : WellFormedSemanticEvalDef ρ_pre.eval) + (hwfcongr_pre : WellFormedSemanticEvalExprCongr ρ_pre.eval) : + ∃ e : CFGConfig String (Cmd P) P, + StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre ρ_pre.hasFailure) e ∧ + e.getFailure = true := by + have hT : ReflTransT (StepStmt P (EvalCmd P) extendEval) + (.stmt (Stmt.loop (.det g) none [] body md) ρ_pre) a' := reflTrans_to_T h_reach + suffices h_inner : + ∀ n (ρ_pre' : Env P) (a'' : Config P (Cmd P)) (σ_cfg_pre' : SemanticStore P), + ρ_pre'.eval = ρ_pre.eval → + WellFormedSemanticEvalBool ρ_pre'.eval → + 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') a''), + a''.getEnv.hasFailure = true → + hT'.len ≤ n → + ∃ e : CFGConfig String (Cmd P) P, + StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) e ∧ + e.getFailure = true from + h_inner hT.len ρ_pre a' σ_cfg_pre rfl + hwfb_pre hwf_def_pre hwfcongr_pre h_agree_pre h_inv_pre hT h_a'_fail (Nat.le_refl _) + intro n + induction n with + | zero => + intro ρ_pre' a'' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' h_inv' hT' ha''_fail hlen' + match hT', hlen' with + | .refl _, _ => + have : ρ_pre'.hasFailure = true := by simpa [Config.getEnv] using ha''_fail + exact ⟨.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure, ReflTrans.refl _, + by simpa [CFGConfig.getFailure] using this⟩ + | .step _ _ _ _ _, hl => simp [ReflTransT.len] at hl + | succ n ih => + intro ρ_pre' a'' σ_cfg_pre' h_eval_eq hwfb' hwf_def' hwfcongr' h_agree' h_inv' hT' ha''_fail hlen' + match hT', hlen' with + | .refl _, _ => + have : ρ_pre'.hasFailure = true := by simpa [Config.getEnv] using ha''_fail + exact ⟨.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure, ReflTrans.refl _, + by simpa [CFGConfig.getFailure] using this⟩ + | .step _ _ _ (@StepStmt.step_loop_exit _ _ _ _ _ _ _ _ _ _ _ _ + hasInvFailure hg_false 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 ha''_eq : a'' = .terminal { ρ_pre' with hasFailure := ρ_pre'.hasFailure || false } := + reflTransT_from_terminal extendEval hrest + rw [ha''_eq] at ha''_fail + have : ρ_pre'.hasFailure = true := by simpa [Config.getEnv] using ha''_fail + exact ⟨.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure, ReflTrans.refl _, + by simpa [CFGConfig.getFailure] using this⟩ + | .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 + have h_step_enter : StepDetCFGStar extendEval cfg + (.atBlock lentry σ_cfg_pre' ρ_pre'.hasFailure) + (.atBlock bl σ_cfg_pre' ρ_pre'.hasFailure) := + 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 seqT_reaches_failing' extendEval hrest ha''_fail with hA | hB + · -- CASE A: failure inside THIS iteration's body block. + obtain ⟨d_blk, h_blk_run, hd_blk_fail, hlen_blk⟩ := hA + have ⟨d_body, h_body_run, hd_body_fail, hlen_body⟩ := + blockT_none_reaches_failing' extendEval h_blk_run hd_blk_fail + rw [h_body_init_eq] at h_body_run + have ⟨e, h_step_body, he_fail⟩ := + h_body_sim_fail_at ρ_pre' σ_cfg_pre' h_eval_eq h_agree' h_inv' d_body + (reflTransT_to_prop h_body_run) hd_body_fail + exact ⟨e, StepDetCFGStar_trans h_step_enter h_step_body, he_fail⟩ + · -- CASE B: this iteration's body terminated; recurse on the next iteration. + obtain ⟨ρ_blk_inner, d_rest, h_blk_term, h_loop_rest, hd_rest_fail, hlen_rest⟩ := hB + have ⟨ρ_inner, h_inner_term, hρ_blk_eq, hlen_inner⟩ := + blockT_none_reaches_terminal' extendEval h_blk_term + rw [h_body_init_eq] at h_inner_term + 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 + (reflTransT_to_prop h_inner_term) + have h_agree_block : StoreAgreement ρ_blk_inner.store σ_cfg_after_body := + StoreAgreement.through_projectStore hρ_blk_eq h_agree_after_body + have h_hf_block : ρ_blk_inner.hasFailure = ρ_inner.hasFailure := by rw [hρ_blk_eq] + have hρ_block_eval : ρ_blk_inner.eval = ρ_pre'.eval := by + rw [hρ_blk_eq] + show ρ_inner.eval = ρ_pre'.eval + have := smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval body + ρ_pre' ρ_inner h_nofd_body (reflTransT_to_prop h_inner_term) + rw [this] + have h_eval_eq_block : ρ_blk_inner.eval = ρ_pre.eval := by + rw [hρ_block_eval]; exact h_eval_eq + have hwfb_block : WellFormedSemanticEvalBool ρ_blk_inner.eval := by + rw [hρ_block_eval]; exact hwfb' + have hwf_def_block : WellFormedSemanticEvalDef ρ_blk_inner.eval := by + rw [hρ_block_eval]; exact hwf_def' + have hwfcongr_block : WellFormedSemanticEvalExprCongr ρ_blk_inner.eval := by + rw [hρ_block_eval]; exact hwfcongr' + have ⟨d_loop, h_loop_stmt, hd_loop_fail, hlen_loop⟩ := + stmts_singleton_reaches_failing' extendEval h_loop_rest hd_rest_fail + have h_inner_le_n : h_loop_stmt.len ≤ n := by + simp [ReflTransT.len] at hl_succ; omega + have ⟨e, h_run_recurse, he_fail⟩ := + ih ρ_blk_inner d_loop σ_cfg_after_body h_eval_eq_block + hwfb_block hwf_def_block hwfcongr_block + h_agree_block h_inv_after h_loop_stmt hd_loop_fail h_inner_le_n + rw [h_hf_block] at h_run_recurse + exact ⟨e, StepDetCFGStar_trans (StepDetCFGStar_trans h_step_enter h_step_body) h_run_recurse, + he_fail⟩ + +/-- For a non-empty `accum`, `flushCmds` always materializes a single block whose +command list is exactly `accum.reverse`, with the produced entry label as its key +and the requested transfer. (For `tr? = some _` it always materializes; for +`tr? = none` it materializes because `accum` is non-empty.) -/ +private theorem flushCmds_nonempty_mem + {P : PureExpr} [HasBool P] + (pfx : String) (accum : List (Cmd P)) (tr? : Option (DetTransferCmd String P)) + (kk : String) (gen gen' : StringGenState) + (entry : String) (blocks : DetBlocks String (Cmd P) P) + (h_flush : flushCmds pfx accum tr? kk gen = ((entry, blocks), gen')) + (h_accum_ne : accum ≠ []) : + ∃ tr : DetTransferCmd String P, + blocks = [(entry, { cmds := accum.reverse, transfer := tr })] := by + unfold flushCmds at h_flush + cases tr? with + | none => + simp only at h_flush + rw [if_neg (by + simp only [List.isEmpty_iff] + exact fun h => h_accum_ne h)] at h_flush + simp only [bind, StateT.bind, pure, StateT.pure, Id] at h_flush + injection h_flush with h_pair h_gen_eq + injection h_pair with h_entry_eq h_blks_eq + subst h_entry_eq; subst h_blks_eq + exact ⟨.goto kk .empty, rfl⟩ + | some tr => + simp only [bind, StateT.bind, pure, StateT.pure, Id] at h_flush + injection h_flush with h_pair h_gen_eq + injection h_pair with h_entry_eq h_blks_eq + subst h_entry_eq; subst h_blks_eq + exact ⟨tr, rfl⟩ + +/-- Syntactic entry-block shape: when `accum` is non-empty, the entry block of +`stmtsToBlocks k ss exitConts accum gen` carries `accum.reverse` as the leading +segment of its command list — every arm either flushes `accum` directly (block +cmds `= accum.reverse`) or defers via the `.cmd`/`.funcDecl`/`.typeDecl` recursion, +which only prepends to `accum` (so `accum.reverse` stays the front prefix of the +eventual flush). Lets a downstream discharge run the already-evaluated, failing +`accum.reverse` prefix on the CFG side even when a *later* deferred command is stuck. -/ +private theorem stmtsToBlocks_entry_has_accum_prefix + {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')) + (h_simple : Block.simpleShape ss = true) + (h_accum_ne : accum ≠ []) : + ∃ (suf : List (Cmd P)) (tr : DetTransferCmd String P), + (entry, ({ cmds := accum.reverse ++ suf, transfer := tr } : DetBlock String (Cmd P) P)) + ∈ blocks := by + match h_match : ss with + | [] => + unfold stmtsToBlocks at h_gen + obtain ⟨tr, h_bs⟩ := flushCmds_nonempty_mem "l$" accum .none k gen gen' entry blocks h_gen h_accum_ne + exact ⟨[], tr, by rw [h_bs, List.append_nil]; exact List.mem_cons_self⟩ + | .cmd c :: rest => + unfold stmtsToBlocks at h_gen + have ⟨suf, tr, h_mem⟩ := + stmtsToBlocks_entry_has_accum_prefix k rest exitConts (c :: accum) gen gen' + entry blocks h_gen (Block.simpleShape_cons_iff.mp h_simple).2 (by simp) + refine ⟨c :: suf, tr, ?_⟩ + rwa [List.reverse_cons, List.append_assoc, List.singleton_append] at h_mem + | .funcDecl _ _ :: rest => + unfold stmtsToBlocks at h_gen + exact stmtsToBlocks_entry_has_accum_prefix k rest exitConts accum gen gen' + entry blocks h_gen (Block.simpleShape_cons_iff.mp h_simple).2 h_accum_ne + | .typeDecl _ _ :: rest => + unfold stmtsToBlocks at h_gen + exact stmtsToBlocks_entry_has_accum_prefix k rest exitConts accum gen gen' + entry blocks h_gen (Block.simpleShape_cons_iff.mp h_simple).2 h_accum_ne + | .exit l? md :: _ => + unfold stmtsToBlocks at h_gen + simp only at h_gen + cases h_lkp : exitConts.lookup (some l?) with + | some bk => + rw [h_lkp] at h_gen + simp only at h_gen + obtain ⟨tr, h_bs⟩ := flushCmds_nonempty_mem _ accum _ _ gen gen' entry blocks h_gen h_accum_ne + exact ⟨[], tr, by rw [h_bs, List.append_nil]; exact List.mem_cons_self⟩ + | none => + rw [h_lkp] at h_gen + simp only at h_gen + obtain ⟨tr, h_bs⟩ := flushCmds_nonempty_mem _ accum _ _ gen gen' entry blocks h_gen h_accum_ne + exact ⟨[], tr, by rw [h_bs, List.append_nil]; exact List.mem_cons_self⟩ + | .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 only 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 only 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 + obtain ⟨tr, h_ab⟩ := + flushCmds_nonempty_mem "blk$" accum .none bl gen_b gen_f accumEntry accumBlocks h_flush_eq h_accum_ne + simp only at h_gen + split 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 + refine ⟨[], tr, ?_⟩ + rw [h_ab, List.append_nil] + exact List.mem_append_left _ List.mem_cons_self + · 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 + refine ⟨[], tr, ?_⟩ + rw [h_ab, List.append_nil] + exact List.mem_append_left _ List.mem_cons_self + | .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 + cases h_c : c with + | det e => + rw [h_c] at h_gen + 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 + obtain ⟨tr, h_ab⟩ := + flushCmds_nonempty_mem "ite$" accum _ l_ite gen_e gen_f accumEntry accumBlocks h_flush_eq h_accum_ne + 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 + refine ⟨[], tr, ?_⟩ + rw [h_ab, List.append_nil, List.cons_append, List.nil_append] + exact List.mem_cons_self + | nondet => + exact absurd ((Block.simpleShape_cons_iff.mp h_simple).1) + (by rw [h_c]; simp [Stmt.simpleShape]) + | .loop c m is bss md :: rest => + simp only [stmtsToBlocks, bind, StateT.bind] 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_le_eq : StringGenState.gen "loop_entry$" gen_r = r_le at h_gen + obtain ⟨lentry, gen_le⟩ := r_le + simp only at h_gen + cases h_m : m with + | none => + rw [h_m] at h_gen + simp only [pure, StateT.pure, bind, StateT.bind] at h_gen + 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 + 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 + obtain ⟨tr, h_ab⟩ := + flushCmds_nonempty_mem "before_loop$" accum .none lentry gen_i gen_f + accumEntry accumBlocks h_flush_eq h_accum_ne + 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 + refine ⟨[], tr, ?_⟩ + rw [h_ab] + simp only [List.append_nil, List.cons_append, List.nil_append] + exact List.mem_cons_self + | nondet => + exact absurd ((Block.simpleShape_cons_iff.mp h_simple).1) + (by rw [h_c]; simp [Stmt.simpleShape]) + | some mExpr => + rw [h_m] at h_gen + simp only [bind, StateT.bind, pure, StateT.pure] at h_gen + generalize h_ml_eq : 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_eq : StringGenState.gen "measure_decrease$" gen_ml = r_ldec at h_gen + obtain ⟨ldec, gen_ld⟩ := r_ldec + simp only at h_gen + generalize h_body_eq : + stmtsToBlocks ldec bss ((none, kNext) :: exitConts) [] gen_ld = 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 + 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 + obtain ⟨tr, h_ab⟩ := + flushCmds_nonempty_mem "before_loop$" accum .none lentry gen_i gen_f + accumEntry accumBlocks h_flush_eq h_accum_ne + 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 + refine ⟨[], tr, ?_⟩ + rw [h_ab] + simp only [List.append_nil, List.cons_append, List.nil_append] + exact List.mem_cons_self + | nondet => + exact absurd ((Block.simpleShape_cons_iff.mp h_simple).1) + (by rw [h_c]; simp [Stmt.simpleShape]) +termination_by sizeOf ss +decreasing_by + all_goals (subst h_match; simp_wf; omega) + +/-- Already-failed-prefix discharge: when the accumulated commands carry a failure +(`hf_base || hf_accum = true`) and `accum` is non-empty, the CFG starting at the +entry block of `stmtsToBlocks k ss exitConts accum gen` reaches a failing config — +by fetching the entry block (whose command list begins with `accum.reverse`, +which is *already evaluated* on the CFG side to a failing flag) and running just +that leading prefix, which sets the block's failure flag. No source run of `ss` +is needed, and any later deferred command being stuck does not matter (the prefix +runs first). -/ +private theorem accum_failed_reaches_failing + {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_simple : Block.simpleShape ss = true) + (h_accum_ne : accum ≠ []) + (σ_struct_base σ_base : SemanticStore P) + (hf_base hf_accum : Bool) + (ρ₀ : Env P) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_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_fail : (hf_base || hf_accum) = true) + (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) : + ∃ e : CFGConfig String (Cmd P) P, + StepDetCFGStar extendEval cfg (.atBlock entry σ_base hf_base) e ∧ + e.getFailure = true := by + -- Entry block has `accum.reverse` as its leading command segment. + have ⟨suf, tr, h_mem⟩ := + stmtsToBlocks_entry_has_accum_prefix k ss exitConts accum gen gen' entry blocks h_gen h_simple h_accum_ne + have h_lkp : List.lookup entry cfg.blocks = + some { cmds := accum.reverse ++ suf, transfer := tr } := + List.lookup_of_mem_nodup cfg.blocks h_cfg_nodup _ _ (h_cfg_blocks _ h_mem) + -- Lift the (failing) accum to the CFG side via store agreement. + have ⟨σ_cfg_after, h_accum_cfg, _⟩ := + 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 + -- Fetch the entry block, then run the `accum.reverse` prefix; the resulting + -- `.inBlock` carries `hf_base || hf_accum = true`. + have h_fetch : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.atBlock entry σ_base hf_base) + (.inBlock entry (accum.reverse ++ suf) tr σ_base hf_base) := + StepCFG.fetch (extendEval := extendEval) h_lkp + have h_chain := EvalCmds_prefix_to_StepCFG_chain (extendEval := extendEval) (cfg := cfg) + (suf := suf) h_accum_cfg entry tr hf_base + refine ⟨.inBlock entry suf tr σ_cfg_after (hf_base || hf_accum), + ReflTrans.step _ _ _ h_fetch h_chain, ?_⟩ + simpa [CFGConfig.getFailure] using h_fail + +/-- Within-block failing-command discharge: when the accumulated commands of a block +carry a `true` failure flag at the block end, the post-chain `.inBlock t [] tr σ' true` +is a reachable CFG config with `getFailure = true`. The block transfer need not fire — +an `.inBlock` with `getFailure = true` is already a valid reachable failing config. +This is the `flushCmds_to_fail_agree` core for the within-block (`.cmd`) arm. -/ +private theorem within_block_reaches_failing {P : PureExpr} [HasFvar P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (t : String) (cs : List (Cmd P)) (tr : DetTransferCmd String P) + (δ : SemanticEval P) (σ σ' : SemanticStore P) (f_base f : Bool) + (h_cmds : EvalCmds P (EvalCmd P) δ σ cs σ' f) + (h_fail : (f_base || f) = true) : + ∃ e : CFGConfig String (Cmd P) P, + StepCFGStar P (EvalCmd P) extendEval cfg (.inBlock t cs tr σ f_base) e ∧ + e.getFailure = true := by + refine ⟨.inBlock t [] tr σ' (f_base || f), + EvalCmds_to_StepCFG_chain (extendEval := extendEval) (cfg := cfg) h_cmds t tr f_base, ?_⟩ + simpa [CFGConfig.getFailure] using h_fail + +/-- Fetch-then-discharge composite: from `.atBlock t` whose block records a failure in +its command list, reach a `getFailure = true` config. -/ +private theorem atBlock_reaches_failing {P : PureExpr} [HasFvar P] [HasNot P] + [HasVarsPure P P.Expr] + (extendEval : ExtendEval P) + (cfg : CFG String (DetBlock String (Cmd P) P)) + (t : String) (cs : List (Cmd P)) (tr : DetTransferCmd String P) + (δ : SemanticEval P) (σ σ' : SemanticStore P) (f_base f : Bool) + (h_lkp : List.lookup t cfg.blocks = .some ⟨cs, tr⟩) + (h_cmds : EvalCmds P (EvalCmd P) δ σ cs σ' f) + (h_fail : (f_base || f) = true) : + ∃ e : CFGConfig String (Cmd P) P, + StepCFGStar P (EvalCmd P) extendEval cfg (.atBlock t σ f_base) e ∧ + e.getFailure = true := by + have h_fetch : StepCFG (l := String) (CmdT := Cmd P) P (EvalCmd P) extendEval cfg + (.atBlock t σ f_base) (.inBlock t cs tr σ f_base) := + StepCFG.fetch (extendEval := extendEval) h_lkp + obtain ⟨e, h_run, he⟩ := within_block_reaches_failing extendEval cfg t cs tr δ σ σ' + f_base f h_cmds h_fail + exact ⟨e, ReflTrans.step _ _ _ h_fetch h_run, he⟩ + +/-- The `STEP 3b` `GenStep` chain shared by every `.loop`-arm of the four mutual +simulation theorems. From the four sub-translation equations produced by +`loop_det_decompose_h_gen` (`rest`, `loop_entry$`, `body`, `before_loop$` flush), +the input `WF gen`, and the outer upper-bound fact, it threads the +`gen → gen_r → gen_le → gen_b → gen_f` `GenStep` chain together with the +intermediate `WF` and `⊆ genUpperBound` facts the arms consume. -/ +theorem loop_genStep_chain {P : PureExpr} [HasBool P] [HasIdent P] [HasFvar P] + [HasIntOrder P] [HasNot P] + {k kNext lentry : String} {gen gen_r gen_le gen_b gen_f genUpperBound : StringGenState} + {bl : String} {bbs bsRest : DetBlocks String (Cmd P) P} + {accum : List (Cmd P)} {accumEntry : String} {accumBlocks : DetBlocks String (Cmd P) P} + {body rest : List (Stmt P (Cmd P))} {exitConts : List (Option String × String)} + (h_rest_eq : stmtsToBlocks k rest exitConts [] gen = ((kNext, bsRest), gen_r)) + (h_le_eq : StringGenState.gen "loop_entry$" gen_r = (lentry, gen_le)) + (h_body_eq : stmtsToBlocks lentry body ((Option.none, kNext) :: exitConts) [] gen_le + = ((bl, bbs), gen_b)) + (h_flush_eq : flushCmds (P := P) (CmdT := Cmd P) "before_loop$" accum .none lentry gen_b + = ((accumEntry, accumBlocks), gen_f)) + (h_wf_gen : StringGenState.WF gen) + (h_outer_upper : StringGenState.stringGens gen_f ⊆ StringGenState.stringGens genUpperBound) : + StringGenState.GenStep gen gen_r ∧ + StringGenState.GenStep gen_r gen_le ∧ + StringGenState.GenStep gen_le gen_b ∧ + StringGenState.GenStep gen_b gen_f ∧ + StringGenState.GenStep gen gen_le ∧ + StringGenState.GenStep gen gen_b ∧ + StringGenState.WF gen_r ∧ + StringGenState.WF gen_le ∧ + StringGenState.WF gen_b ∧ + StringGenState.stringGens gen_b ⊆ StringGenState.stringGens genUpperBound ∧ + StringGenState.stringGens gen_le ⊆ StringGenState.stringGens genUpperBound ∧ + StringGenState.stringGens gen_r ⊆ StringGenState.stringGens genUpperBound := by + 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 + exact ⟨h_step_gen_to_r, h_step_r_to_le, h_step_le_to_b, h_step_b_to_f, h_step_gen_to_le, + h_step_gen_to_b, h_wf_r, h_wf_le, h_wf_b, h_outer_upper_b, h_outer_upper_le, h_outer_upper_r⟩ + +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 1024 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] + {Q : String → Prop} + (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) + (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) + (ρ₀ ρ' : 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) Q (Cmds.definedVars accum.reverse ++ Block.initVars ss)) + (h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars accum.reverse ++ transformBlockModVars ss)) + (genUpperBound : StringGenState) + (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) + (h_store_no_gens_upper : ∀ x : String, + Q x → + x ∉ StringGenState.stringGens genUpperBound → + σ_base (HasIdent.ident (P := P) x) = none) + (h_foreign : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens genUpperBound) + (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 := 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 := + (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'⟩ := + 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 + 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' + 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' + genUpperBound h_outer_upper h_store_no_gens_upper h_foreign + 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 [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 + -- 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_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_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 + 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 + · 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 + 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_ite := unique_combined_ite h_unique_outer_inits + have h_unique_combined_then : + (Cmds.definedVars [].reverse ++ Block.initVars thenBranch).Nodup := + 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 := + 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 := + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + -- 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) Q (Cmds.definedVars [].reverse ++ Block.initVars thenBranch) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.definedVars] using hmem)))) + have h_else_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars elseBranch) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem)))) + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem))) + -- 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars thenBranch) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem)))) + have h_else_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars elseBranch) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem)))) + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + 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_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 + -- 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 + 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 + 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 h_foreign + 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 + (fun h_in => h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simp [Cmds.definedVars]; exact hx))) + (h_outer_upper_t h_in))) + -- 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 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 + -- 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, Q 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 s hQ hmem => h_then_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + 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 + 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) + 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 h_foreign + 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_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 + -- 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 + 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 + 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 h_foreign + 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 + (fun h_in => h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simp [Cmds.definedVars]; exact hx))) + (h_outer_upper_e h_in))) + -- 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 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 + -- 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, Q 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 s hQ hmem => h_else_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + 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 + 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) + 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 h_foreign + 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. + -- 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 guard measure invariants body md :: rest => + -- 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. + -- === 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 + obtain ⟨h_step_gen_to_r, h_step_r_to_le, h_step_le_to_b, h_step_b_to_f, + h_step_gen_to_le, h_step_gen_to_b, h_wf_r, h_wf_le, h_wf_b, + h_outer_upper_b, h_outer_upper_le, h_outer_upper_r⟩ := + InlineLoopHelpers.loop_genStep_chain h_rest_eq h_le_eq h_body_eq h_flush_eq + h_wf_gen h_outer_upper + -- === 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) Q (Cmds.definedVars [].reverse ++ Block.initVars body) := by + rw [h_body_no_inits]; intro s hQ; simp [Cmds.definedVars] + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + (by simpa [Cmds.definedVars] using hmem))) + have h_body_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := + fun s hQ hmem => h_combined_no_gen_suffix_mod s hQ + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem))) + -- 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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 + genUpperBound h_outer_upper_b h_sng_iter h_foreign + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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_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, Q 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 => + h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simpa [Cmds.definedVars] using hx))) + (h_outer_upper_b 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 := + 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) + 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := + fun s hQ hmem => h_combined_no_gen_suffix_mod s hQ + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + 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 + genUpperBound h_outer_upper_r h_sng_loop h_foreign + 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] 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 + -- 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 + 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 + -- 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) Q (Cmds.definedVars [].reverse ++ Block.initVars body) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.definedVars] using hmem))) + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem))) + -- 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem))) + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + -- 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + -- 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 + 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 + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + -- 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 + 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) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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_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 := + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + -- 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 + 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 + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + -- 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 + 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) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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_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 := + 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 + 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 + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + 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 + 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) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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_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 := + 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 + 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 + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + 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 + 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) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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_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'⟩ := + 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 + 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 + 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 + h_wf_gen h_combined_no_gen_suffix' h_combined_no_gen_suffix_mod' + genUpperBound h_outer_upper h_store_no_gens_upper h_foreign + 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 [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] + {Q : String → Prop} + (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) + (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) + (ρ₀ ρ' : 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) Q (Cmds.definedVars accum.reverse ++ Block.initVars ss)) + (h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars accum.reverse ++ transformBlockModVars ss)) + (genUpperBound : StringGenState) + (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) + (h_store_no_gens_upper : ∀ x : String, + Q x → + x ∉ StringGenState.stringGens genUpperBound → + σ_base (HasIdent.ident (P := P) x) = none) + (h_foreign : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens genUpperBound) + (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 := 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 := + (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'⟩ := + 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 + 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' + 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' + genUpperBound h_outer_upper h_store_no_gens_upper h_foreign + 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 [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_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'⟩ := + 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 + 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 + 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 + h_wf_gen h_combined_no_gen_suffix' h_combined_no_gen_suffix_mod' + genUpperBound h_outer_upper h_store_no_gens_upper h_foreign + 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 [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] 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 + -- 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 + have h_initvars_eq : + Block.initVars (Stmt.block label' body md :: rest) = + Block.initVars body ++ Block.initVars rest := by + rw [Block.initVars] + simp + -- Sub-block and rest combined-no-gen-suffix discharges. + have h_body_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars body) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.definedVars] using hmem))) + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem))) + -- 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem))) + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + -- 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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_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 := + 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 + 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 + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 := + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + 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 + 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 + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + 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 + 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 + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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_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 := + 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 + 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 + h_combined_body h_unique_combined_body (by simp) + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 := + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + 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 + 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 + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + 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 + 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 + h_combined_rest h_unique_combined_rest (by simp) + h_wf_gen h_rest_no_gen_suffix h_rest_no_gen_suffix_mod + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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 + -- 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_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_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 + 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 := + 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 + 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_ite := unique_combined_ite h_unique_outer_inits + have h_unique_combined_then : + (Cmds.definedVars [].reverse ++ Block.initVars thenBranch).Nodup := + 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 := + 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 + -- 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + -- 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) Q (Cmds.definedVars [].reverse ++ Block.initVars thenBranch) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.definedVars] using hmem)))) + have h_else_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars elseBranch) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem)))) + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem))) + -- 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars thenBranch) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem)))) + have h_else_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars elseBranch) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem)))) + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + 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_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 + -- 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 + 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 + 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 h_foreign + 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_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 + 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 + 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 + 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 h_foreign + 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_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 + 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 + 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 + 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 h_foreign + 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 + (fun h_in => h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simp [Cmds.definedVars]; exact hx))) + (h_outer_upper_t h_in))) + 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 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 + -- using the strengthened (4-premise) `h_preserve_then` directly. + have h_store_no_gens_upper_branch_t : + ∀ x : String, Q 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 s hQ hmem => h_then_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + 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 + 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 + h_combined_rest h_unique_combined_rest (by simp) + 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 h_foreign + 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_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 + 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 + 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 + 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 h_foreign + 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 + (fun h_in => h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simp [Cmds.definedVars]; exact hx))) + (h_outer_upper_e h_in))) + 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 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 + -- using the strengthened (4-premise) `h_preserve_else` directly. + have h_store_no_gens_upper_branch_e : + ∀ x : String, Q 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 s hQ hmem => h_else_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + 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 + 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 + h_combined_rest h_unique_combined_rest (by simp) + 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 h_foreign + 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 guard measure invariants body md :: rest => + -- 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 + -- === 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 + obtain ⟨h_step_gen_to_r, h_step_r_to_le, h_step_le_to_b, h_step_b_to_f, + h_step_gen_to_le, h_step_gen_to_b, h_wf_r, h_wf_le, h_wf_b, + h_outer_upper_b, h_outer_upper_le, h_outer_upper_r⟩ := + InlineLoopHelpers.loop_genStep_chain h_rest_eq h_le_eq h_body_eq h_flush_eq + h_wf_gen h_outer_upper + -- === 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) Q (Cmds.definedVars [].reverse ++ Block.initVars body) := by + rw [h_body_no_inits]; intro s hQ; simp [Cmds.definedVars] + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + (by simpa [Cmds.definedVars] using hmem))) + have h_body_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := + fun s hQ hmem => h_combined_no_gen_suffix_mod s hQ + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem))) + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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, Q 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 + genUpperBound h_outer_upper_b (h_sng_of_inv σ_cfg_iter h_inv_iter) h_foreign + 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 + genUpperBound h_outer_upper_b (h_sng_of_inv σ_cfg_iter h_inv_iter) h_foreign + 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_nofd_body h_body_sim_at + hwfb hwf_def hwf_congr + have h_sng_loop : ∀ x : String, Q 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 => + h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simpa [Cmds.definedVars] using hx))) + (h_outer_upper_b 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := + fun s hQ hmem => h_combined_no_gen_suffix_mod s hQ + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + 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 + genUpperBound h_outer_upper_r h_sng_loop h_foreign + 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) + +/-- Escaping sibling of `stmtsToBlocks_simulation` / `_to_cont`: handles the +case where the structured execution `.exiting label` is *uncaught* — no entry +in `exitConts` catches `label` (`exitConts.lookup (some label) = none`). The +emitter materializes the dedicated `.exitTo label` transfer for this case, so +the CFG-side escapes at `.exiting label` (rather than reaching a continuation +`.atBlock`), preserving the escaping label. + +Same accum/agreement/freshness preconditions as `stmtsToBlocks_simulation`. +Mutual with `_simulation` (terminating sub-runs) and `_to_cont` (caught sub-runs): +a body/branch exiting with a *caught* inner label routes through `_to_cont`, one +exiting with the propagated uncaught `label` routes through this lemma. -/ +private theorem stmtsToBlocks_simulation_to_exit {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] + {Q : String → Prop} + (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) + (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) + (ρ₀ ρ' : Env P) + (label : String) + (h_label : exitConts.lookup (some label) = none) + (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) Q (Cmds.definedVars accum.reverse ++ Block.initVars ss)) + (h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars accum.reverse ++ transformBlockModVars ss)) + (genUpperBound : StringGenState) + (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) + (h_store_no_gens_upper : ∀ x : String, + Q x → + x ∉ StringGenState.stringGens genUpperBound → + σ_base (HasIdent.ident (P := P) x) = none) + (h_foreign : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens genUpperBound) + (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) + (.exiting label σ_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 := 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 := + (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'⟩ := + 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 + have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := + stmtsToBlocks_simulation_to_exit 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 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' + genUpperBound h_outer_upper h_store_no_gens_upper h_foreign + 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 [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_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'⟩ := + 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 + have ⟨σ_cfg, h_step, h_agree, h_preserve⟩ := + stmtsToBlocks_simulation_to_exit extendEval k rest exitConts 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 + ρ₀ ρ' label 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' + genUpperBound h_outer_upper h_store_no_gens_upper h_foreign + 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 [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 an uncaught .exit label: the lookup is `none`, so the + -- emitter materializes `.some (.exitTo label md)` (escaping transfer). + unfold stmtsToBlocks at h_gen + -- Select the uncaught (`none`) branch of the match using h_label. + rw [h_label] at h_gen + simp only at h_gen + -- Now h_gen : flushCmds "block$..." accum (.some (.exitTo label md)) k 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_exitTo_simulation_agree extendEval (s!"block${label}$") accum md label k + gen gen' entry blocks h_gen σ_struct_base σ_base hf_base hf_accum ρ₀ + 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] 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 + -- 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 + have h_initvars_eq : + Block.initVars (Stmt.block label' body md :: rest) = + Block.initVars body ++ Block.initVars rest := by + rw [Block.initVars] + simp + -- Sub-block and rest combined-no-gen-suffix discharges. + have h_body_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars body) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.definedVars] using hmem))) + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem))) + -- 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem))) + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + -- 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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): uncaught (label' != label, outer lookup none). + have h_label_lookup : + ((some label', kNext) :: exitConts).lookup (some label) = none := by + show (match label == label' with + | true => some kNext + | false => List.lookup (some label) exitConts) = none + 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_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 := + 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_exit (uncaught: escapes with label). + have ⟨σ_cfg_body, h_step_body, h_agree_body, h_preserve_body⟩ := + stmtsToBlocks_simulation_to_exit 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 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 + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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) → exiting label. 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_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 := + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_exit extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_exit extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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) = none := by + show (match label == label' with + | true => some kNext + | false => List.lookup (some label) exitConts) = none + 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_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 := + 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_exit 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 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 + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 := + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_exit extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_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 + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + have ⟨σ_cfg_rest, h_step_rest, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_exit extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + 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 + -- 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_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_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 + 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 := + 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 + 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_ite := unique_combined_ite h_unique_outer_inits + have h_unique_combined_then : + (Cmds.definedVars [].reverse ++ Block.initVars thenBranch).Nodup := + 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 := + 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 + -- 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + -- 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) Q (Cmds.definedVars [].reverse ++ Block.initVars thenBranch) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.definedVars] using hmem)))) + have h_else_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars elseBranch) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem)))) + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem))) + -- 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars thenBranch) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem)))) + have h_else_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars elseBranch) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem)))) + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + 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_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 + -- Recurse on thenBranch with _to_exit (escapes with label). + 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_exit 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 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 h_foreign + 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_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 + 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_exit 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 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 h_foreign + 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_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 + 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 + 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 + 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 h_foreign + 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 + (fun h_in => h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simp [Cmds.definedVars]; exact hx))) + (h_outer_upper_t h_in))) + 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 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 + -- using the strengthened (4-premise) `h_preserve_then` directly. + have h_store_no_gens_upper_branch_t : + ∀ x : String, Q 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 s hQ hmem => h_then_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_exit extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_t h_foreign + 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_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 + 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 + 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 + 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 h_foreign + 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 + (fun h_in => h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simp [Cmds.definedVars]; exact hx))) + (h_outer_upper_e h_in))) + 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 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 + -- using the strengthened (4-premise) `h_preserve_else` directly. + have h_store_no_gens_upper_branch_e : + ∀ x : String, Q 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 s hQ hmem => h_else_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_exit extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_e h_foreign + 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 guard measure invariants body md :: rest => + -- 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 + -- === 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 + obtain ⟨h_step_gen_to_r, h_step_r_to_le, h_step_le_to_b, h_step_b_to_f, + h_step_gen_to_le, h_step_gen_to_b, h_wf_r, h_wf_le, h_wf_b, + h_outer_upper_b, h_outer_upper_le, h_outer_upper_r⟩ := + InlineLoopHelpers.loop_genStep_chain h_rest_eq h_le_eq h_body_eq h_flush_eq + h_wf_gen h_outer_upper + -- === 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) Q (Cmds.definedVars [].reverse ++ Block.initVars body) := by + rw [h_body_no_inits]; intro s hQ; simp [Cmds.definedVars] + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + (by simpa [Cmds.definedVars] using hmem))) + have h_body_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := + fun s hQ hmem => h_combined_no_gen_suffix_mod s hQ + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem))) + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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, Q 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 + genUpperBound h_outer_upper_b (h_sng_of_inv σ_cfg_iter h_inv_iter) h_foreign + 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: the loop's own exitCont key is `.none`, so a body + -- exit with `label` looks through to the outer (uncaught) `none`. + have h_label_lookup : + ((.none, kNext) :: exitConts).lookup (.some label) = none := 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) + (.exiting label σ_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_exit 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 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 + genUpperBound h_outer_upper_b (h_sng_of_inv σ_cfg_iter h_inv_iter) h_foreign + 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; the loop escapes at .exiting label. + subst hρ'_eq + have ⟨σ_cfg_bk, h_loop_run, h_agree_bk, h_inv_bk⟩ := + InlineLoopHelpers.loop_iterations_to_exit_det extendEval guardExpr body md + ρ₀ ρ' label cfg lentry kNext bl σ_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_nofd_body h_body_sim_at + hwfb hwf_def hwf_congr + have h_sng_loop : ∀ x : String, Q 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 => + h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simpa [Cmds.definedVars] using hx))) + (h_outer_upper_b 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := + fun s hQ hmem => h_combined_no_gen_suffix_mod s hQ + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + have ⟨σ_cfg, h_rest_sim, h_agree_rest, h_preserve_rest⟩ := + stmtsToBlocks_simulation_to_exit 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 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 + genUpperBound h_outer_upper_r h_sng_loop h_foreign + 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 +/-- Failing sibling of `stmtsToBlocks_simulation` / `_to_cont` / `_to_exit`: +handles the case where the structured execution reaches a configuration whose +cumulative `hasFailure` flag is set (a *failing* reachable config). The CFG-side +reaches a configuration whose `getFailure` is `true` — no terminal or exiting +endpoint is required. + +Same accum/agreement/freshness preconditions as the other siblings, but instead +of a terminal/exiting endpoint the trigger is a reachable failing config: +`h_reach : StepStmtStar (.stmts ss ρ₀) c` with `h_c_fail : c.getEnv.hasFailure += true`. The reflexive run (`c = .stmts ss ρ₀`) covers the case where `ρ₀` has +already failed (`hf_base || hf_accum = true`): the next flush of `accum` carries +that flag, so the CFG entry block is already failing. + +Mutual with the three other siblings: a completed loop iteration (a terminating +body sub-run) routes through `_simulation`; the failing iteration's body routes +back through this lemma; the cons-split's "head terminates, then rest fails" +recurses on `rest` here. -/ +private theorem stmtsToBlocks_simulation_to_fail {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] + {Q : String → Prop} + (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) + (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) + (ρ₀ : Env P) + (c : Config P (Cmd P)) + (h_ρ₀_nofail : ρ₀.hasFailure = false) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (h_reach : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) c) + (h_c_fail : c.getEnv.hasFailure = true) + (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) Q (Cmds.definedVars accum.reverse ++ Block.initVars ss)) + (h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars accum.reverse ++ transformBlockModVars ss)) + (genUpperBound : StringGenState) + (h_outer_upper : StringGenState.stringGens gen' ⊆ StringGenState.stringGens genUpperBound) + (h_store_no_gens_upper : ∀ x : String, + Q x → + x ∉ StringGenState.stringGens genUpperBound → + σ_base (HasIdent.ident (P := P) x) = none) + (h_foreign : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens genUpperBound) + (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) : + ∃ d : CFGConfig String (Cmd P) P, + StepDetCFGStar extendEval cfg + (.atBlock entry σ_base hf_base) d + ∧ d.getFailure = true := by + match h_match : ss with + | [] => + -- `.stmts [] ρ₀` reaches only `.terminal ρ₀`; the failing config forces + -- `ρ₀.hasFailure = true`. Flushing `accum` reaches `.atBlock k σ_cfg ρ₀.hasFailure`, + -- which is already a failing CFG config. + unfold stmtsToBlocks at h_gen + have h_ρ₀_fail : ρ₀.hasFailure = true := by + have h_c_env : c.getEnv = ρ₀ := by + match h_reach with + | .refl _ => rfl + | .step _ _ _ hstep hrest => + cases hstep with + | step_stmts_nil => + have := InlineLoopHelpers.reflTransT_from_terminal extendEval (reflTrans_to_T hrest) + rw [this]; rfl + rw [h_c_env] at h_c_fail + simpa [Config.getEnv] using h_c_fail + 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, _, _⟩ := + 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 + exact ⟨.atBlock k σ_cfg ρ₀.hasFailure, h_step, + by simpa [CFGConfig.getFailure] using h_ρ₀_fail⟩ + | .cmd c0 :: rest => + have h_gen_orig := h_gen + unfold stmtsToBlocks at h_gen + -- The head command always terminates at some `ρ₁` (a single command cannot + -- diverge or exit). Decompose `.stmts (.cmd c0 :: rest) ρ₀ ⟶* c` (failing): + -- either the head's run already fails, or the head terminates and `rest` fails. + -- In both subcases `.stmt (.cmd c0) ρ₀` steps to a terminal `ρ₁` (the refl-head + -- subcase is excluded by `h_ρ₀_nofail`), and either `ρ₁` is failing or `rest` + -- reaches a failing config from `ρ₁`. + have ⟨ρ₁, h_c_star', h_rest_or_fail⟩ : ∃ ρ₁, + StepStmtStar P (EvalCmd P) extendEval (.stmts [.cmd c0] ρ₀) (.terminal ρ₁) ∧ + (ρ₁.hasFailure = true ∨ + ∃ d_rest, StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ₁) d_rest ∧ + d_rest.getEnv.hasFailure = true) := by + rcases InlineLoopHelpers.stmts_cons_reaches_failing' extendEval + (reflTrans_to_T h_reach) h_c_fail with hA | hB + · obtain ⟨d, h_head_run, hd_fail⟩ := hA + match h_head_run with + | .refl _ => + exact absurd (h_ρ₀_nofail ▸ (by simpa [Config.getEnv] using hd_fail) : + (false : Bool) = true) (by simp) + | .step _ (.terminal ρ_mid) _ hstep hrest => + have h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmt (.cmd c0) ρ₀) (.terminal ρ_mid) := .step _ _ _ hstep (.refl _) + have h_d_env : d.getEnv = ρ_mid := by + have := InlineLoopHelpers.reflTransT_from_terminal extendEval (reflTrans_to_T hrest) + rw [this]; rfl + have h_stp : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.cmd c0] ρ₀) (.stmts [] ρ_mid) := + stmts_cons_step P (EvalCmd P) extendEval (.cmd c0) [] ρ₀ ρ_mid h_term + exact ⟨ρ_mid, ReflTrans_Transitive _ _ _ _ h_stp (.step _ _ _ .step_stmts_nil (.refl _)), + Or.inl (by simpa [Config.getEnv] using (h_d_env ▸ hd_fail))⟩ + | .step _ (.stmt _ _) _ hstep hrest => exact nomatch hstep + | .step _ (.stmts _ _) _ hstep hrest => exact nomatch hstep + | .step _ (.exiting _ _) _ hstep hrest => exact nomatch hstep + | .step _ (.block _ _ _) _ hstep hrest => exact nomatch hstep + | .step _ (.seq _ _) _ hstep hrest => exact nomatch hstep + · obtain ⟨ρ₁, d, h_head_term, h_rest_run, hd_fail⟩ := hB + have h_stp : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.cmd c0] ρ₀) (.stmts [] ρ₁) := + stmts_cons_step P (EvalCmd P) extendEval (.cmd c0) [] ρ₀ ρ₁ h_head_term + exact ⟨ρ₁, ReflTrans_Transitive _ _ _ _ h_stp (.step _ _ _ .step_stmts_nil (.refl _)), + Or.inr ⟨d, h_rest_run, hd_fail⟩⟩ + have ⟨σ_c, failed_c, heval_c, hstore_c, heval_eq_c, hfail_c⟩ := + single_cmd_eval extendEval c0 ρ₀ ρ₁ h_c_star' + have h_accum' : EvalCmds P (EvalCmd P) ρ₁.eval σ_struct_base + (c0 :: 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 c0 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] + -- `ρ₀.hasFailure = false` ⟹ `hf_base = false` and `hf_accum = false`. + have h_hf_base_false : hf_base = false := by + rw [h_hf] at h_ρ₀_nofail; exact (Bool.or_eq_false_iff.mp h_ρ₀_nofail).1 + have h_hf_accum_false : hf_accum = false := by + rw [h_hf] at h_ρ₀_nofail; exact (Bool.or_eq_false_iff.mp h_ρ₀_nofail).2 + 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 + 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_definedVars_snoc, h_fresh_combined', h_unique_combined', + h_combined_no_gen_suffix', h_combined_no_gen_suffix_mod'⟩ := + cmd_arm_combined_lemmas c0 accum rest σ_base + h_fresh_combined h_unique_combined + h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + by_cases h_failed_c : failed_c = true + · -- Head command failed. Discharge directly: the entry block's command list + -- begins with `(c0 :: accum).reverse`, which is already evaluated on the CFG + -- side to a failing flag (`hf_accum || failed_c = true`). + subst h_failed_c + have h_fresh_accum' : ∀ x ∈ Cmds.definedVars (c0 :: 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 (c0 :: accum).reverse).Nodup := + (List.nodup_append.mp h_unique_combined').1 + have h_fail' : (hf_base || (hf_accum || true)) = true := by simp + exact InlineLoopHelpers.accum_failed_reaches_failing extendEval k rest exitConts + (c0 :: accum) gen gen' entry blocks h_gen + (Block.simpleShape_cons_iff.mp h_simple).2 (by simp) + σ_struct_base σ_base hf_base (hf_accum || true) ρ₁ + (heval_eq_c ▸ hwf_def) (heval_eq_c ▸ hwf_congr) h_accum' + h_agree_entry h_fresh_accum' h_unique_accum' h_fail' + cfg h_cfg_blocks h_cfg_nodup + · -- Head command did not fail. Then `ρ₁.hasFailure = false`, and the failing + -- config lies in `rest`. Recurse on `rest`. + have h_failed_c_false : failed_c = false := by simpa using h_failed_c + subst h_failed_c_false + have h_ρ₁_nofail : ρ₁.hasFailure = false := by + rw [h_hf', h_hf_base_false, h_hf_accum_false]; simp + have ⟨d_rest, h_rest_reach, hd_rest_fail⟩ : + ∃ d_rest, StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ₁) d_rest ∧ + d_rest.getEnv.hasFailure = true := by + rcases h_rest_or_fail with h | h + · exact absurd (h_ρ₁_nofail ▸ h : (false : Bool) = true) (by simp) + · exact h + 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 + exact stmtsToBlocks_simulation_to_fail extendEval k rest exitConts (c0 :: 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 || false) + ρ₁ d_rest h_ρ₁_nofail hwfb' hwfv' hwf_def' hwf_congr' hwf_var' + h_rest_reach hd_rest_fail 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' + genUpperBound h_outer_upper h_store_no_gens_upper h_foreign + cfg h_cfg_blocks h_cfg_nodup + | .funcDecl _ _ :: _ => + simp [Block.noFuncDecl, Stmt.noFuncDecl] at h_nofd + | .typeDecl tc md :: rest => + unfold stmtsToBlocks at h_gen + -- typeDecl is a no-op: it steps to `.terminal ρ₀`, then `.stmts rest ρ₀` carries + -- the failing run. + have ⟨d_rest, h_rest_reach, hd_rest_fail⟩ : ∃ d_rest, + StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ₀) d_rest ∧ + d_rest.getEnv.hasFailure = true := by + rcases InlineLoopHelpers.stmts_cons_reaches_failing' extendEval (reflTrans_to_T h_reach) h_c_fail with hA | hB + · obtain ⟨d, h_head_run, hd_fail⟩ := hA + -- `.stmt (.typeDecl ..) ρ₀ ⟶* d`: d's env is ρ₀ (typeDecl preserves env). + refine ⟨.stmts rest ρ₀, .refl _, ?_⟩ + have h_d_env : d.getEnv = ρ₀ := by + match h_head_run with + | .refl _ => rfl + | .step _ _ _ hstep hrest => + cases hstep with + | step_typeDecl => + have := InlineLoopHelpers.reflTransT_from_terminal extendEval (reflTrans_to_T hrest) + rw [this]; rfl + rw [h_d_env] at hd_fail + simpa [Config.getEnv] using hd_fail + · obtain ⟨ρ₁, d, h_head_term, h_rest_run, hd_fail⟩ := hB + -- typeDecl terminates only at ρ₀, so ρ₁ = ρ₀. + have h_ρ₁_eq : ρ₁ = ρ₀ := by + match h_head_term with + | .step _ _ _ hstep hrest => + cases hstep with + | step_typeDecl => + have := InlineLoopHelpers.reflTransT_from_terminal extendEval (reflTrans_to_T hrest) + exact Config.terminal.inj this + exact ⟨d, h_ρ₁_eq ▸ h_rest_run, hd_fail⟩ + 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_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'⟩ := + typeDecl_arm_combined_lemmas (tc := tc) (md := md) accum rest σ_base + h_fresh_combined h_unique_combined + h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + exact stmtsToBlocks_simulation_to_fail extendEval k rest exitConts 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 + ρ₀ d_rest h_ρ₀_nofail hwfb hwfv hwf_def hwf_congr hwf_var + h_rest_reach hd_rest_fail 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' + genUpperBound h_outer_upper h_store_no_gens_upper h_foreign + cfg h_cfg_blocks h_cfg_nodup + | .exit label md :: _ => + -- An `.exit` immediately escapes with `label`, skipping `rest`; the run reaches + -- only `.exiting label ρ₀` (a stuck config whose env is `ρ₀`). Since + -- `ρ₀.hasFailure = false`, no reachable config is failing — `h_c_fail` is absurd. + exfalso + match h_reach with + | .refl _ => + simp [Config.getEnv, h_ρ₀_nofail] at h_c_fail + | .step _ _ _ hstep hrest => + cases hstep with + | step_stmts_cons => + -- `.seq (.stmt (.exit label) ρ₀) tail ⟶* c` with `c` failing. Invert: either + -- the inner exit-stmt reaches a failing config (impossible — exit cannot fail), + -- or it terminates (impossible — exit escapes), then a continuation fails. + rcases InlineLoopHelpers.seqT_reaches_failing' extendEval (reflTrans_to_T hrest) h_c_fail + with hA | hB + · obtain ⟨d, h_inner, hd_fail, _⟩ := hA + -- `.stmt (.exit label) ρ₀ ⟶* d` failing: only reachable is `.exiting label ρ₀` + -- (env ρ₀, non-failing). + match h_inner with + | .refl _ => + simp [Config.getEnv, h_ρ₀_nofail] at hd_fail + | .step _ _ _ hs hr => + cases hs with + | step_exit => + have heq := InlineLoopHelpers.reflTransT_from_exiting extendEval hr + rw [heq] at hd_fail + simp [Config.getEnv, h_ρ₀_nofail] at hd_fail + · obtain ⟨ρ_mid, d, h_inner_term, _, _, _⟩ := hB + -- `.stmt (.exit label) ρ₀` cannot terminate (it escapes). + match h_inner_term with + | .step _ _ _ hs hr => + cases hs with + | step_exit => + have heq := InlineLoopHelpers.reflTransT_from_exiting extendEval hr + exact absurd heq (by simp) + | .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 + 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 + subst h_blocks + -- Cons-split: either the ite (one of its branches) reaches a failing config, or + -- the ite terminates and rest fails. Decompose the failing run accordingly. + have h_ite_dispatch : + ((∃ d_t, StepStmtStar P (EvalCmd P) extendEval (.stmts thenBranch ρ₀) d_t ∧ + d_t.getEnv.hasFailure = true ∧ ρ₀.eval ρ₀.store e = .some HasBool.tt) ∨ + (∃ d_f, StepStmtStar P (EvalCmd P) extendEval (.stmts elseBranch ρ₀) d_f ∧ + d_f.getEnv.hasFailure = true ∧ ρ₀.eval ρ₀.store e = .some HasBool.ff)) ∨ + (∃ ρ₁, ∃ d_rest, + ((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)) ∧ + StepStmtStar P (EvalCmd P) extendEval (.stmts rest ρ₁) d_rest ∧ + d_rest.getEnv.hasFailure = true) := by + rcases InlineLoopHelpers.stmts_cons_reaches_failing' extendEval (reflTrans_to_T h_reach) h_c_fail with hA | hB + · -- The head `.stmt (.ite ..) ρ₀` reaches a failing config; the ite steps into + -- the chosen branch first. + obtain ⟨d, h_head_run, hd_fail⟩ := hA + left + match h_head_run with + | .refl _ => + -- `d = .stmt (.ite ..) ρ₀`, so `ρ₀.hasFailure = true`, excluded by `h_ρ₀_nofail`. + exact absurd (h_ρ₀_nofail ▸ (by simpa [Config.getEnv] using hd_fail) : + (false : Bool) = true) (by simp) + | .step _ _ _ hstep hrest => + cases hstep with + | step_ite_true h_eval_tt _ => exact Or.inl ⟨d, hrest, hd_fail, h_eval_tt⟩ + | step_ite_false h_eval_ff _ => exact Or.inr ⟨d, hrest, hd_fail, h_eval_ff⟩ + · obtain ⟨ρ₁, d, h_head_term, h_rest_run, hd_fail⟩ := hB + right + -- head `.stmt (.ite ..) ρ₀ ⟶* .terminal ρ₁`: invert into branch terminate. + match h_head_term with + | .step _ _ _ hstep hrest => + cases hstep with + | step_ite_true h_eval_tt _ => + exact ⟨ρ₁, d, Or.inl ⟨hrest, h_eval_tt⟩, h_rest_run, hd_fail⟩ + | step_ite_false h_eval_ff _ => + exact ⟨ρ₁, d, Or.inr ⟨hrest, h_eval_ff⟩, h_rest_run, hd_fail⟩ + 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))) + 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 + 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_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_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_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 + 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 := Block.uniqueInits.ite_else h_unique + have h_unique_rest : Block.uniqueInits rest := Block.uniqueInits.tail h_unique + 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 + 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_σ + 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 + 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 + 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_ite := unique_combined_ite h_unique_outer_inits + have h_unique_combined_then : + (Cmds.definedVars [].reverse ++ Block.initVars thenBranch).Nodup := + 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 := + 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 + 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 + have h_store_no_gens_upper_after : + ∀ x : String, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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) + have h_then_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars thenBranch) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.definedVars] using hmem)))) + have h_else_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars elseBranch) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem)))) + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem))) + 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars thenBranch) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem)))) + have h_else_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars elseBranch) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem)))) + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + -- The accum prefix runs on the CFG side from `entry` to the chosen branch's + -- entry (via the materialized condGoto). We share this with both branches. + rcases h_ite_dispatch with h_branch_fails | h_rest_fails + · -- Failure inside the chosen branch. + rcases h_branch_fails with ⟨d_t, h_then_reach, hd_t_fail, h_cond_tt⟩ | ⟨d_f, h_else_reach, hd_f_fail, h_cond_ff⟩ + · have h_flush_sim : StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock tl σ_cfg_after ρ₀.hasFailure) := + 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 + have h_accum_nil_t : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨d, h_then_step, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail 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 + ρ₀ d_t h_ρ₀_nofail hwfb hwfv hwf_def hwf_congr hwf_var + h_then_reach hd_t_fail 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 h_foreign + cfg h_cfg_tbs h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans h_flush_sim h_then_step, hd_fail⟩ + · have h_flush_sim : StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock fl σ_cfg_after ρ₀.hasFailure) := + 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 + have h_accum_nil_f : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store + [].reverse ρ₀.store false := EvalCmds.eval_cmds_none + have ⟨d, h_else_step, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail 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 + ρ₀ d_f h_ρ₀_nofail hwfb hwfv hwf_def hwf_congr hwf_var + h_else_reach hd_f_fail 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 h_foreign + cfg h_cfg_fbs h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans h_flush_sim h_else_step, hd_fail⟩ + · -- The chosen branch terminates at ρ₁; rest reaches a failing config. Run the + -- terminating branch (via `_simulation`) to kNext, then recurse on rest. + obtain ⟨ρ₁, d_rest, h_branch_term, h_rest_reach, hd_rest_fail⟩ := h_rest_fails + have h_eval_eq : ρ₁.eval = ρ₀.eval := by + rcases h_branch_term with ⟨h, _⟩ | ⟨h, _⟩ + · exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + thenBranch ρ₀ ρ₁ h_nofd_then h + · exact smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval + elseBranch ρ₀ ρ₁ h_nofd_else h + 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_accum_nil_r : EvalCmds P (EvalCmd P) ρ₁.eval ρ₁.store + [].reverse ρ₁.store false := EvalCmds.eval_cmds_none + have h_unique_combined_rest : + (Cmds.definedVars [].reverse ++ Block.initVars rest).Nodup := + (unique_combined_ite h_unique_outer_inits).2.2 + rcases h_branch_term with ⟨h_then_term, h_cond_tt⟩ | ⟨h_else_term, h_cond_ff⟩ + · have h_flush_sim : StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock tl σ_cfg_after ρ₀.hasFailure) := + 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 + 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 + 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 + 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 h_foreign + cfg h_cfg_tbs h_cfg_nodup + 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 + exact (List.nodup_append.mp h1).2.2 x (List.mem_append_left _ h_in_then) 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 [].reverse := by simp [Cmds.definedVars] + exact h_preserve_then x h_σ_after_x h_nil_not h_x_not_then + (fun s heq => Or.inr + (fun h_in => h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simp [Cmds.definedVars]; exact hx))) + (h_outer_upper_t h_in))) + 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_store_no_gens_upper_branch_t : + ∀ x : String, Q 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 s hQ hmem => h_then_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + by_cases h_ρ₁_fail : ρ₁.hasFailure = true + · exact ⟨.atBlock kNext σ_branch ρ₁.hasFailure, + StepDetCFGStar_trans h_flush_sim h_then_step, + by simpa [CFGConfig.getFailure] using h_ρ₁_fail⟩ + · have h_ρ₁_nofail : ρ₁.hasFailure = false := by simpa using h_ρ₁_fail + have ⟨d, h_rest_step, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 + ρ₁ d_rest h_ρ₁_nofail hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_reach hd_rest_fail 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_t h_foreign + cfg h_cfg_rest h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans (StepDetCFGStar_trans h_flush_sim h_then_step) h_rest_step, hd_fail⟩ + · have h_flush_sim : StepDetCFGStar extendEval cfg + (.atBlock accumEntry σ_base hf_base) + (.atBlock fl σ_cfg_after ρ₀.hasFailure) := + 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 + 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 + 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 + 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 h_foreign + 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 + exact (List.nodup_append.mp h1).2.2 x (List.mem_append_right _ h_in_else) 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 [].reverse := by simp [Cmds.definedVars] + exact h_preserve_else x h_σ_after_x h_nil_not h_x_not_else + (fun s heq => Or.inr + (fun h_in => h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simp [Cmds.definedVars]; exact hx))) + (h_outer_upper_e h_in))) + 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_store_no_gens_upper_branch_e : + ∀ x : String, Q 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 s hQ hmem => h_else_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + by_cases h_ρ₁_fail : ρ₁.hasFailure = true + · exact ⟨.atBlock kNext σ_branch ρ₁.hasFailure, + StepDetCFGStar_trans h_flush_sim h_else_step, + by simpa [CFGConfig.getFailure] using h_ρ₁_fail⟩ + · have h_ρ₁_nofail : ρ₁.hasFailure = false := by simpa using h_ρ₁_fail + have ⟨d, h_rest_step, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 + ρ₁ d_rest h_ρ₁_nofail hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_reach hd_rest_fail 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_branch_e h_foreign + cfg h_cfg_rest h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans (StepDetCFGStar_trans h_flush_sim h_else_step) h_rest_step, hd_fail⟩ + | .ite .nondet _ _ _ :: _ => + 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] 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 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 + -- Cons-split: either the block reaches a failing config (failure inside body), + -- or the block terminates and rest fails. + have h_block_dispatch : + (∃ d_body, StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) d_body ∧ + d_body.getEnv.hasFailure = true) ∨ + (∃ ρ_blk, ∃ d_rest, + ((∃ ρ_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) d_rest ∧ + d_rest.getEnv.hasFailure = true) := by + rcases InlineLoopHelpers.stmts_cons_reaches_failing' extendEval (reflTrans_to_T h_reach) h_c_fail with hA | hB + · -- The head `.stmt (.block ..) ρ₀` reaches a failing config: step into block, + -- failure inside body. + obtain ⟨d, h_head_run, hd_fail⟩ := hA + left + match h_head_run with + | .refl _ => + exact absurd (h_ρ₀_nofail ▸ (by simpa [Config.getEnv] using hd_fail) : + (false : Bool) = true) (by simp) + | .step _ _ _ hstep hrest => + cases hstep with + | step_block => + -- `.block (some label) ρ₀.store (.stmts body ρ₀) ⟶* d` failing: failure + -- inside the body frame. + have ⟨d_body, h_body_run, hd_body_fail⟩ := + InlineLoopHelpers.block_reaches_failing' extendEval hrest hd_fail + exact ⟨d_body, h_body_run, hd_body_fail⟩ + · obtain ⟨ρ_blk, d, h_head_term, h_rest_run, hd_fail⟩ := hB + right + -- Invert `.stmt (.block ..) ρ₀ ⟶* .terminal ρ_blk`. + 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 + match h_head_term with + | .step _ _ _ hstep hrest => + cases hstep with + | step_block => + exact block_some_reaches_terminal P (EvalCmd P) extendEval hrest + exact ⟨ρ_blk, d, h_block_inv, h_rest_run, hd_fail⟩ + 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_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_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 + have h_initvars_eq : + Block.initVars (Stmt.block label body md :: rest) = + Block.initVars body ++ Block.initVars rest := by + rw [Block.initVars]; simp + have h_body_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars body) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.definedVars] using hmem))) + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.definedVars] using hmem))) + 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) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem))) + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix_mod s hQ (List.mem_append_right _ (h_modvars_eq ▸ + List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + 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 + by_cases h_l_eq_bl : label = bl + · 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 + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := + (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 := + 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_none : + ((some label, kNext) :: exitConts).lookup .none = exitConts.lookup .none := by + simp [List.lookup] + rcases h_block_dispatch with h_body_fails | h_rest_fails + · -- Failure inside the block body. Recurse on body with `_to_fail`; the body's + -- CFG entry is `bl`. + obtain ⟨d_body, h_body_reach, hd_body_fail⟩ := h_body_fails + have ⟨d, h_step_body, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail 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 + ρ₀ d_body h_ρ₀_nofail hwfb hwfv hwf_def hwf_congr hwf_var + h_body_reach hd_body_fail 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 + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + cfg h_cfg_bbs h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans h_step_flush h_step_body, hd_fail⟩ + · -- Block terminates at ρ_blk; rest fails. Run the body (terminate or + -- match-exit) via `_simulation` / `_to_cont`, then recurse on rest. + obtain ⟨ρ_blk, d_rest, h_body_or_match, h_rest_reach, hd_rest_fail⟩ := h_rest_fails + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).2 + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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] + have h_store_no_gens_upper_body : + ∀ x : String, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + by_cases h_blk_fail : ρ_blk.hasFailure = true + · exact ⟨.atBlock kNext σ_cfg_body ρ_blk.hasFailure, + StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body), + by simpa [CFGConfig.getFailure] using h_blk_fail⟩ + · have h_blk_nofail : ρ_blk.hasFailure = false := by simpa using h_blk_fail + have ⟨d, h_step_rest, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 d_rest h_blk_nofail + hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_reach hd_rest_fail 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + cfg h_cfg_rest h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest, hd_fail⟩ + · obtain ⟨ρ_inner, h_body_match, h_ρ_blk_eq⟩ := h_match_branch + have h_label_lookup : + ((some label, kNext) :: exitConts).lookup (some label) = some kNext := by + simp [List.lookup] + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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] + have h_store_no_gens_upper_body : + ∀ x : String, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + by_cases h_blk_fail : ρ_blk.hasFailure = true + · exact ⟨.atBlock kNext σ_cfg_body ρ_blk.hasFailure, + StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body), + by simpa [CFGConfig.getFailure] using h_blk_fail⟩ + · have h_blk_nofail : ρ_blk.hasFailure = false := by simpa using h_blk_fail + have ⟨d, h_step_rest, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 d_rest h_blk_nofail + hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_reach hd_rest_fail 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + cfg h_cfg_rest h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest, hd_fail⟩ + · -- label ≠ bl: the materialized vestigial (label, goto bl) block prepends a + -- single extra block; the flow is otherwise identical. + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + have h_fresh_body_inits_after : ∀ x ∈ Block.initVars body, σ_cfg_after x = none := + (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 := + 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 + rcases h_block_dispatch with h_body_fails | h_rest_fails + · obtain ⟨d_body, h_body_reach, hd_body_fail⟩ := h_body_fails + have ⟨d, h_step_body, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail 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 + ρ₀ d_body h_ρ₀_nofail hwfb hwfv hwf_def hwf_congr hwf_var + h_body_reach hd_body_fail 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 + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + cfg h_cfg_bbs h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans h_step_flush h_step_body, hd_fail⟩ + · obtain ⟨ρ_blk, d_rest, h_body_or_match, h_rest_reach, hd_rest_fail⟩ := h_rest_fails + have h_fresh_rest_inits_after : ∀ x ∈ Block.initVars rest, σ_cfg_after x = none := + (fresh_inits_after_step h_initvars_eq h_unique_combined h_fresh_combined + h_preserve_flush).2 + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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] + have h_store_no_gens_upper_body : + ∀ x : String, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + by_cases h_blk_fail : ρ_blk.hasFailure = true + · exact ⟨.atBlock kNext σ_cfg_body ρ_blk.hasFailure, + StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body), + by simpa [CFGConfig.getFailure] using h_blk_fail⟩ + · have h_blk_nofail : ρ_blk.hasFailure = false := by simpa using h_blk_fail + have ⟨d, h_step_rest, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 d_rest h_blk_nofail + hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_reach hd_rest_fail 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + cfg h_cfg_rest h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest, hd_fail⟩ + · obtain ⟨ρ_inner, h_body_match, h_ρ_blk_eq⟩ := h_match_branch + have h_label_lookup : + ((some label, kNext) :: exitConts).lookup (some label) = some kNext := by + simp [List.lookup] + 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 + 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 + h_combined_body h_unique_combined_body h_hf_body + h_wf_r h_body_no_gen_suffix h_body_no_gen_suffix_mod + genUpperBound h_outer_upper_b h_store_no_gens_upper_after h_foreign + 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_body : ∀ x ∈ Block.initVars rest, σ_cfg_body x = none := + fresh_rest_inits_body_step h_initvars_eq h_unique h_preserve_body + (fun s hns h_in => h_foreign s hns (h_outer_upper_b h_in)) + 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] + have h_store_no_gens_upper_body : + ∀ x : String, Q 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 s hQ hmem => h_body_no_gen_suffix s hQ (List.mem_append_right _ hmem)) + by_cases h_blk_fail : ρ_blk.hasFailure = true + · exact ⟨.atBlock kNext σ_cfg_body ρ_blk.hasFailure, + StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body), + by simpa [CFGConfig.getFailure] using h_blk_fail⟩ + · have h_blk_nofail : ρ_blk.hasFailure = false := by simpa using h_blk_fail + have ⟨d, h_step_rest, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail extendEval k rest exitConts [] gen gen_r kNext bsNext + 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 d_rest h_blk_nofail + hwfb₁ hwfv₁ hwf_def₁ hwf_congr₁ hwf_var₁ + h_rest_reach hd_rest_fail 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 + genUpperBound h_outer_upper_r h_store_no_gens_upper_body h_foreign + cfg h_cfg_rest h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans + (StepDetCFGStar_trans h_step_flush (h_hasFail_blk.symm ▸ h_step_body)) h_step_rest, hd_fail⟩ + | .loop guard measure invariants body md :: rest => + 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 + 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 + 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 + -- === 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 + 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 the failing run into "loop fails" vs "loop terminates, rest fails". === + have h_loop_dispatch : + (∃ a', StepStmtStar P (EvalCmd P) extendEval + (.stmt (Stmt.loop (.det guardExpr) none [] body md) ρ₀) a' ∧ + a'.getEnv.hasFailure = true) ∨ + (∃ ρ_loop_post, ∃ d_rest, 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) d_rest ∧ + d_rest.getEnv.hasFailure = true) := by + rcases InlineLoopHelpers.stmts_cons_reaches_failing' extendEval (reflTrans_to_T h_reach) h_c_fail with hA | hB + · obtain ⟨d, h_head_run, hd_fail⟩ := hA + exact Or.inl ⟨d, h_head_run, hd_fail⟩ + · obtain ⟨ρ_loop_post, d, h_head_term, h_rest_run, hd_fail⟩ := hB + exact Or.inr ⟨ρ_loop_post, d, h_head_term, h_rest_run, hd_fail⟩ + -- === STEP 3b: GenStep chain. === + subst h_entry_eq + subst h_gen_eq + obtain ⟨h_step_gen_to_r, h_step_r_to_le, h_step_le_to_b, h_step_b_to_f, + h_step_gen_to_le, h_step_gen_to_b, h_wf_r, h_wf_le, h_wf_b, + h_outer_upper_b, h_outer_upper_le, h_outer_upper_r⟩ := + InlineLoopHelpers.loop_genStep_chain h_rest_eq h_le_eq h_body_eq h_flush_eq + h_wf_gen h_outer_upper + -- === 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) Q (Cmds.definedVars [].reverse ++ Block.initVars body) := by + rw [h_body_no_inits]; intro s hQ; simp [Cmds.definedVars] + have h_rest_no_gen_suffix : + NoGenSuffix (P := P) Q (Cmds.definedVars [].reverse ++ Block.initVars rest) := fun s hQ hmem => + h_combined_no_gen_suffix s hQ (List.mem_append_right _ (h_initvars_eq ▸ + (by simpa [Cmds.definedVars] using hmem))) + have h_body_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars body) := + fun s hQ hmem => h_combined_no_gen_suffix_mod s hQ + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_left _ (by simpa [Cmds.modifiedVars] using hmem))) + have h_rest_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars rest) := + fun s hQ hmem => h_combined_no_gen_suffix_mod s hQ + (List.mem_append_right _ (by + rw [transformBlockModVars_cons, transformStmtModVars_loop] + exact List.mem_append_right _ (by simpa [Cmds.modifiedVars] using hmem))) + 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, Q 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 s hQ hmem => h_combined_no_gen_suffix s hQ (List.mem_append_left _ hmem)) + 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 + have h_sng_of_inv : ∀ σ, storeInv σ → + ∀ x : String, Q 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 (completed) 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 + genUpperBound h_outer_upper_b (h_sng_of_inv σ_cfg_iter h_inv_iter) h_foreign + 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 FAILING iteration. === + have h_body_sim_fail_at : + ∀ (ρ_iter : Env P) (σ_cfg_iter : SemanticStore P), + ρ_iter.eval = ρ₀.eval → + StoreAgreement ρ_iter.store σ_cfg_iter → + storeInv σ_cfg_iter → + ∀ (d : Config P (Cmd P)), StepStmtStar P (EvalCmd P) extendEval + (.stmts body ρ_iter) d → d.getEnv.hasFailure = true → + ∃ e : CFGConfig String (Cmd P) P, + StepDetCFGStar extendEval cfg + (.atBlock bl σ_cfg_iter ρ_iter.hasFailure) e ∧ + e.getFailure = true := by + intro ρ_iter σ_cfg_iter h_eval_iter h_agree_iter h_inv_iter d h_body_run hd_fail + 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 iteration may start from an already-failing `ρ_iter` (the loop driver + -- does not constrain it). If so, the starting CFG config is already failing; + -- otherwise recurse on the body with `_to_fail`. + by_cases h_iter_fail : ρ_iter.hasFailure = true + · exact ⟨.atBlock bl σ_cfg_iter ρ_iter.hasFailure, ReflTrans.refl _, + by simpa [CFGConfig.getFailure] using h_iter_fail⟩ + · have h_iter_nofail : ρ_iter.hasFailure = false := by simpa using h_iter_fail + exact stmtsToBlocks_simulation_to_fail 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 d h_iter_nofail hwfb_iter hwfv_iter hwf_def_iter hwf_congr_iter hwf_var_iter + h_body_run hd_fail 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 + genUpperBound h_outer_upper_b (h_sng_of_inv σ_cfg_iter h_inv_iter) h_foreign + cfg h_cfg_bbs h_cfg_nodup + -- === STEP 7: Dispatch. === + rcases h_loop_dispatch with ⟨a', h_loop_reach, ha'_fail⟩ | h_rest_fails + · -- CASE A: the loop reaches a failing config (failure inside some iteration). + have ⟨e, h_loop_run, he_fail⟩ := + InlineLoopHelpers.loop_iterations_to_fail_det extendEval guardExpr body md + ρ₀ a' cfg lentry kNext bl σ_cfg_after storeInv h_lentry_lkp h_agree_after + h_inv_after h_loop_reach ha'_fail h_nofd_body h_body_sim_at h_body_sim_fail_at + hwfb hwf_def hwf_congr + exact ⟨e, StepDetCFGStar_trans h_step_flush h_loop_run, he_fail⟩ + · -- CASE B: the loop terminates at ρ_loop_post, then rest reaches a failing config. + obtain ⟨ρ_loop_post, d_rest, h_loop_term, h_rest_reach, hd_rest_fail⟩ := h_rest_fails + have h_loop_stmt : StepStmtStar P (EvalCmd P) extendEval + (.stmt (Stmt.loop (.det guardExpr) none [] body md) ρ₀) (.terminal ρ_loop_post) := + 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_nofd_body h_body_sim_at + hwfb hwf_def hwf_congr + have h_sng_loop : ∀ x : String, Q 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 => + h_foreign s + (fun hQ => h_rest_no_gen_suffix s hQ + (heq ▸ (by simpa [Cmds.definedVars] using hx))) + (h_outer_upper_b h_in_b)) + exact h_inv_loop x h_keep (h_fresh_rest_inits_after x hx) + have h_loop_term_stmts : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.loop (.det guardExpr) none [] body md] ρ₀) (.terminal ρ_loop_post) := by + have h_stp : StepStmtStar P (EvalCmd P) extendEval + (.stmts [.loop (.det guardExpr) none [] body md] ρ₀) + (.stmts [] ρ_loop_post) := + stmts_cons_step P (EvalCmd P) extendEval + (.loop (.det guardExpr) none [] body md) [] ρ₀ ρ_loop_post h_loop_term + exact ReflTrans_Transitive _ _ _ _ h_stp (.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_term_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 + by_cases h_lp_fail : ρ_loop_post.hasFailure = true + · exact ⟨.atBlock kNext σ_cfg_kNext ρ_loop_post.hasFailure, + StepDetCFGStar_trans h_step_flush h_loop_run, + by simpa [CFGConfig.getFailure] using h_lp_fail⟩ + · have h_lp_nofail : ρ_loop_post.hasFailure = false := by simpa using h_lp_fail + have ⟨d, h_rest_step, hd_fail⟩ := + stmtsToBlocks_simulation_to_fail 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 d_rest h_lp_nofail hwfb_loop hwfv_loop hwf_def_loop hwf_congr_loop hwf_var_loop + h_rest_reach hd_rest_fail 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 + genUpperBound h_outer_upper_r h_sng_loop h_foreign + cfg h_cfg_bsRest h_cfg_nodup + exact ⟨d, StepDetCFGStar_trans (StepDetCFGStar_trans h_step_flush h_loop_run) h_rest_step, hd_fail⟩ +termination_by sizeOf ss +decreasing_by + all_goals (subst h_match; simp_wf; omega) +end + + +/-! ## 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', StringGenState.WF 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 ∧ + -- `gen` is the generator state after the single `"end$"` mint that + -- `stmtsToCFGM` performs before invoking `stmtsToBlocks`. Exposing this + -- lets the caller track `AllMem` from `StringGenState.emp` through to the + -- output `gen'`, which underpins the foreign-label self-discharge. + gen = (StringGenState.gen "end$" StringGenState.emp).2 := 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, rfl⟩ + · 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 hwf_r2 : StringGenState.WF r.2 := + (stmtsToBlocks_genStep lend ss [] [] gen0 r.2 r.1.1 r.1.2 h_eq).wf_mono hwf0 + 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 _ hwf_r2) + 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 + +/-- **Compositional input variant of `stmtsToCFG_terminal`.** Runs the CFG from +an *arbitrary* external store `σ_ext` that overapproximates the source initial +store (`StoreAgreement ρ₀.store σ_ext` — `σ_ext` agrees on every source-defined +variable and may bind strictly more). The source program still runs from `ρ₀`; +only the CFG-side starting store is generalised. + +This is a verbatim re-exposure of `stmtsToCFG_terminal`: the underlying +`stmtsToBlocks_simulation` already takes the CFG-side base store as a free +parameter `σ_base` distinct from the source store (with a `StoreAgreement` +between them), and `flushCmds_condGoto_agree` already proves every guard +evaluates to the *same* boolean under the agreeing store (so `condGoto` selects +the identical successor — branch divergence is excluded). `stmtsToCFG_terminal` +is the instance `σ_ext := ρ₀.store`. + +The freshness side conditions (`h_fresh_inits`, `h_store_gens`) are now stated +about `σ_ext` rather than `ρ₀.store`: a generic superset is not enough, because +the CFG emits `init` commands whose targets must be undefined for `InitState` +to fire. So `σ_ext` must leave the program's `initVars` and the minted +`Q`-kind names undefined — the same shape as the original precondition with +`σ_ext` substituted for `ρ₀.store`. -/ +theorem stmtsToCFG_terminal_compositional {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] + {Q : String → Prop} + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) + (ρ₀ ρ' : Env P) + (σ_ext : SemanticStore P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (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) + -- Track A: agreement between source initial store and the external CFG store. + (h_agree_ext : StoreAgreement ρ₀.store σ_ext) + -- Track A: freshness conditions now stated about σ_ext (was ρ₀.store). + (h_fresh_inits : ∀ x ∈ Block.initVars ss, σ_ext x = none) + (h_disj : Block.userLabelsShapeNodup ss) + (h_store_gens : ∀ x : String, Q x → σ_ext (HasIdent.ident (P := P) x) = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) Q (transformBlockModVars ss)) + (hQmint : S2UMintWitness Q) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.terminal ρ')) : + let cfg := stmtsToCFG ss + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock cfg.entry σ_ext ρ₀.hasFailure) + (.terminal σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := by + intro cfg + have h_disj_wf : ∀ gen', StringGenState.WF gen' → Block.userLabelsDisjoint ss gen' := + Block.userLabelsDisjoint_of_shapeNodup ss h_disj + have ⟨lend, gen, gen', entry, blocks, h_gen, h_entry, h_blocks, h_lend, h_wf_gen, h_gen0⟩ := + stmtsToCFG_stmtsToBlocks_spec ss h_disj_wf + rw [h_entry] + -- accum runs struct-side from ρ₀.store to ρ₀.store (empty accum). + have h_accum : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := + EvalCmds.eval_cmds_none + have h_hf : ρ₀.hasFailure = (ρ₀.hasFailure || false) := by simp + have h_nodup := stmtsToCFG_nodup_keys ss h_disj_wf + -- freshness now about σ_ext + have h_fresh_combined : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars ss, + σ_ext 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) Q (Cmds.definedVars [].reverse ++ Block.initVars ss) := by + intro s hQ + simpa [Cmds.definedVars] using h_input_no_gen_suffix s hQ + have h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars ss) := by + intro s hQ + simpa [Cmds.modifiedVars] using h_input_no_gen_suffix_mod s hQ + have h_store_no_gens_upper : + ∀ x : String, Q x → + x ∉ StringGenState.stringGens gen' → + σ_ext (HasIdent.ident (P := P) x) = none := fun x hx _ => h_store_gens x hx + have h_allmem_gen : StringGenState.AllMem Q gen := by + rw [h_gen0] + exact StringGenState.allMem_gen Q "end$" StringGenState.emp + (StringGenState.allMem_emp Q) (hQmint.2.2.2.2.2.2.2.2.1 StringGenState.emp) + have h_allmem_gen' : StringGenState.AllMem Q gen' := + stmtsToBlocks_allMem hQmint lend ss [] [] gen gen' entry blocks h_gen h_allmem_gen + have h_foreign : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens gen' := + fun s hns => StringGenState.not_mem_stringGens_of_not_allMem h_allmem_gen' hns + 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 h_lbni h_lhni h_nml + ρ₀.store σ_ext ρ₀.hasFailure false ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var + h_term h_accum h_agree_ext h_fresh_combined h_unique_combined h_hf + h_wf_gen h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + gen' (fun _ h => h) h_store_no_gens_upper h_foreign + 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⟩ + +/-- **Target shape (domain) guarantee for `stmtsToCFG_terminal_compositional`.** +Strengthens the compositional terminal theorem with a *third* conjunct stating +exactly which variables the CFG terminal store `σ_cfg` may bind: every variable +left undefined by the external start store `σ_ext` stays undefined in `σ_cfg` +*unless* it is a source `initVars` target or a `Q`-kind minted name. In other +words the CFG run introduces *no* fresh bindings beyond the source's own +`init` targets and the `Q`-kind names this pass mints — a shape guarantee that +lets a downstream transform reason about the domain of `σ_cfg`. + +The guarantee is already produced inside `stmtsToBlocks_simulation` (its third +conjunct, the `_h_preserve` discarded by `stmtsToCFG_terminal_compositional`). +This theorem re-exposes it, converting the simulation's generator-state minted +condition into the consumer-facing `¬ Q s` form via the same `AllMem Q` +contrapositive (`not_mem_stringGens_of_not_allMem`) that discharges the +foreign-label obligation: a non-`Q` name cannot appear in the output generator, +so any non-`Q` ident left undefined by `σ_ext` stays undefined in `σ_cfg`. -/ +theorem stmtsToCFG_terminal_compositional_shape {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] + {Q : String → Prop} + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) + (ρ₀ ρ' : Env P) + (σ_ext : SemanticStore P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (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_agree_ext : StoreAgreement ρ₀.store σ_ext) + (h_fresh_inits : ∀ x ∈ Block.initVars ss, σ_ext x = none) + (h_disj : Block.userLabelsShapeNodup ss) + (h_store_gens : ∀ x : String, Q x → σ_ext (HasIdent.ident (P := P) x) = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) Q (transformBlockModVars ss)) + (hQmint : S2UMintWitness Q) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.terminal ρ')) : + let cfg := stmtsToCFG ss + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock cfg.entry σ_ext ρ₀.hasFailure) + (.terminal σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg + ∧ (∀ x, σ_ext x = none → + x ∉ Block.initVars ss → + (∀ s : String, x = HasIdent.ident (P := P) s → ¬ Q s) → + σ_cfg x = none) := by + intro cfg + have h_disj_wf : ∀ gen', StringGenState.WF gen' → Block.userLabelsDisjoint ss gen' := + Block.userLabelsDisjoint_of_shapeNodup ss h_disj + have ⟨lend, gen, gen', entry, blocks, h_gen, h_entry, h_blocks, h_lend, h_wf_gen, h_gen0⟩ := + stmtsToCFG_stmtsToBlocks_spec ss h_disj_wf + rw [h_entry] + have h_accum : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := + EvalCmds.eval_cmds_none + have h_hf : ρ₀.hasFailure = (ρ₀.hasFailure || false) := by simp + have h_nodup := stmtsToCFG_nodup_keys ss h_disj_wf + have h_fresh_combined : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars ss, + σ_ext 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) Q (Cmds.definedVars [].reverse ++ Block.initVars ss) := by + intro s hQ + simpa [Cmds.definedVars] using h_input_no_gen_suffix s hQ + have h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars ss) := by + intro s hQ + simpa [Cmds.modifiedVars] using h_input_no_gen_suffix_mod s hQ + have h_store_no_gens_upper : + ∀ x : String, Q x → + x ∉ StringGenState.stringGens gen' → + σ_ext (HasIdent.ident (P := P) x) = none := fun x hx _ => h_store_gens x hx + have h_allmem_gen : StringGenState.AllMem Q gen := by + rw [h_gen0] + exact StringGenState.allMem_gen Q "end$" StringGenState.emp + (StringGenState.allMem_emp Q) (hQmint.2.2.2.2.2.2.2.2.1 StringGenState.emp) + have h_allmem_gen' : StringGenState.AllMem Q gen' := + stmtsToBlocks_allMem hQmint lend ss [] [] gen gen' entry blocks h_gen h_allmem_gen + have h_foreign : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens gen' := + fun s hns => StringGenState.not_mem_stringGens_of_not_allMem h_allmem_gen' hns + 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 h_lbni h_lhni h_nml + ρ₀.store σ_ext ρ₀.hasFailure false ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var + h_term h_accum h_agree_ext h_fresh_combined h_unique_combined h_hf + h_wf_gen h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + gen' (fun _ h => h) h_store_no_gens_upper h_foreign + cfg h_blocks h_nodup + have h_end := end_block_terminal extendEval cfg lend σ_cfg ρ'.eval ρ'.hasFailure h_lend + refine ⟨σ_cfg, StepDetCFGStar_trans h_sim h_end, h_agree, ?_⟩ + -- Re-expose the simulation's preserve conjunct in the `¬ Q s` form. The + -- end-block step leaves the store unchanged, so `σ_cfg` is the terminal store. + intro x h_σext_x h_x_not_inits h_x_not_Q + refine h_preserve x h_σext_x ?_ h_x_not_inits ?_ + · -- x ∉ Cmds.definedVars [].reverse (= []) + simp [Cmds.definedVars] + · -- the simulation's minted-name disjunction, supplied from `¬ Q s` + intro s h_x_eq + exact Or.inr (h_foreign s (h_x_not_Q s h_x_eq)) + +/-- **Compositional-input companion of `stmtsToCFG_exiting`.** An *escaping* +source run to `.exiting label ρ'`, with the CFG started from an overapproximating +external store `σ_ext` (rather than `ρ₀.store`), is matched by the CFG +`stmtsToCFG ss` escaping at the *same* `.exiting label` with an agreeing final +store. This is the `σ_ext`-input restatement the pipeline's exiting-arm +composition consumes, mirroring `stmtsToCFG_terminal_compositional` but built on +`stmtsToBlocks_simulation_to_exit`. -/ +theorem stmtsToCFG_exiting_compositional {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] + {Q : String → Prop} + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) + (ρ₀ ρ' : Env P) + (σ_ext : SemanticStore P) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (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_agree_ext : StoreAgreement ρ₀.store σ_ext) + (h_fresh_inits : ∀ x ∈ Block.initVars ss, σ_ext x = none) + (h_disj : Block.userLabelsShapeNodup ss) + (h_store_gens : ∀ x : String, Q x → σ_ext (HasIdent.ident (P := P) x) = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) Q (transformBlockModVars ss)) + (hQmint : S2UMintWitness Q) + (label : String) + (h_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.exiting label ρ')) : + let cfg := stmtsToCFG ss + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock cfg.entry σ_ext ρ₀.hasFailure) + (.exiting label σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := by + intro cfg + have h_disj_wf : ∀ gen', StringGenState.WF gen' → Block.userLabelsDisjoint ss gen' := + Block.userLabelsDisjoint_of_shapeNodup ss h_disj + have ⟨lend, gen, gen', entry, blocks, h_gen, h_entry, h_blocks, h_lend, h_wf_gen, h_gen0⟩ := + stmtsToCFG_stmtsToBlocks_spec ss h_disj_wf + rw [h_entry] + have h_accum : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := + EvalCmds.eval_cmds_none + have h_hf : ρ₀.hasFailure = (ρ₀.hasFailure || false) := by simp + have h_nodup := stmtsToCFG_nodup_keys ss h_disj_wf + have h_fresh_combined : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars ss, + σ_ext 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) Q (Cmds.definedVars [].reverse ++ Block.initVars ss) := by + intro s hQ + simpa [Cmds.definedVars] using h_input_no_gen_suffix s hQ + have h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars ss) := by + intro s hQ + simpa [Cmds.modifiedVars] using h_input_no_gen_suffix_mod s hQ + have h_store_no_gens_upper : + ∀ x : String, Q x → + x ∉ StringGenState.stringGens gen' → + σ_ext (HasIdent.ident (P := P) x) = none := fun x hx _ => h_store_gens x hx + have h_allmem_gen : StringGenState.AllMem Q gen := by + rw [h_gen0] + exact StringGenState.allMem_gen Q "end$" StringGenState.emp + (StringGenState.allMem_emp Q) (hQmint.2.2.2.2.2.2.2.2.1 StringGenState.emp) + have h_allmem_gen' : StringGenState.AllMem Q gen' := + stmtsToBlocks_allMem hQmint lend ss [] [] gen gen' entry blocks h_gen h_allmem_gen + have h_foreign : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens gen' := + fun s hns => StringGenState.not_mem_stringGens_of_not_allMem h_allmem_gen' hns + have h_label : ([] : List (Option String × String)).lookup (some label) = none := rfl + have ⟨σ_cfg, h_sim, h_agree, _h_preserve⟩ := + stmtsToBlocks_simulation_to_exit extendEval lend ss [] [] gen gen' entry blocks + h_gen h_nofd h_simple h_unique h_lbni h_lhni h_nml + ρ₀.store σ_ext ρ₀.hasFailure false ρ₀ ρ' label h_label + hwfb hwfv hwf_def hwf_congr hwf_var + h_exit h_accum h_agree_ext h_fresh_combined h_unique_combined h_hf + h_wf_gen h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + gen' (fun _ h => h) h_store_no_gens_upper h_foreign + cfg h_blocks h_nodup + exact ⟨σ_cfg, h_sim, h_agree⟩ + +/-- If the structured program reaches a terminal state, the CFG also reaches + a corresponding terminal state. + + 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). + + The label-kind predicate `Q` is constrained only by `hQmint`: the + thirteen-conjunct witness that `Q` holds of every `gen`-output under the + prefixes `stmtsToCFG` mints under. From it the proof *derives* the + foreign-label obligation — any label that is not `Q` is absent from the + output generator — by tracking `AllMem Q` from the empty generator state + (through the single `"end$"` mint and `stmtsToBlocks`) and discharging by + contraposition, so no universal-over-all-WF-states freshness assumption is + needed. -/ +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] + {Q : String → Prop} + (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) + (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 : Block.userLabelsShapeNodup ss) + (h_store_gens : ∀ x : String, Q x → ρ₀.store (HasIdent.ident (P := P) x) = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) Q (transformBlockModVars ss)) + (hQmint : S2UMintWitness Q) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.terminal ρ')) : + let cfg := stmtsToCFG ss + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock cfg.entry ρ₀.store ρ₀.hasFailure) + (.terminal σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := by + intro cfg + -- Bridge the gen-free `userLabelsShapeNodup` precondition to the + -- `∀ WF gen', userLabelsDisjoint ss gen'` form the spec/nodup helpers consume: + -- the disjointness conjunct is recovered from shape-freedom at any WF state. + have h_disj_wf : ∀ gen', StringGenState.WF gen' → Block.userLabelsDisjoint ss gen' := + Block.userLabelsDisjoint_of_shapeNodup ss h_disj + have ⟨lend, gen, gen', entry, blocks, h_gen, h_entry, h_blocks, h_lend, h_wf_gen, h_gen0⟩ := + stmtsToCFG_stmtsToBlocks_spec ss h_disj_wf + rw [h_entry] + have h_accum : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := + EvalCmds.eval_cmds_none + have h_hf : ρ₀.hasFailure = (ρ₀.hasFailure || false) := by simp + have h_nodup := stmtsToCFG_nodup_keys ss h_disj_wf + -- 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) Q (Cmds.definedVars [].reverse ++ Block.initVars ss) := by + intro s hQ + simpa [Cmds.definedVars] using h_input_no_gen_suffix s hQ + have h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars ss) := by + intro s hQ + simpa [Cmds.modifiedVars] using h_input_no_gen_suffix_mod s hQ + have h_store_no_gens_upper : + ∀ x : String, Q x → + x ∉ StringGenState.stringGens gen' → + ρ₀.store (HasIdent.ident (P := P) x) = none := fun x hx _ => h_store_gens x hx + -- Self-discharge of the foreign-label obligation. `gen` is the empty + -- generator state advanced by the single `"end$"` mint; every label `gen` + -- holds therefore satisfies `Q` (by `hQmint`'s `"end$"` witness). + -- `stmtsToBlocks_allMem` carries this to `gen'`: every label `gen'` holds + -- satisfies `Q`. Hence any label that is *not* `Q` is absent — plain + -- contraposition, no universal-WF assumption needed. + have h_allmem_gen : StringGenState.AllMem Q gen := by + rw [h_gen0] + exact StringGenState.allMem_gen Q "end$" StringGenState.emp + (StringGenState.allMem_emp Q) (hQmint.2.2.2.2.2.2.2.2.1 StringGenState.emp) + have h_allmem_gen' : StringGenState.AllMem Q gen' := + stmtsToBlocks_allMem hQmint lend ss [] [] gen gen' entry blocks h_gen h_allmem_gen + have h_foreign : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens gen' := + fun s hns => StringGenState.not_mem_stringGens_of_not_allMem h_allmem_gen' hns + 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 h_lbni h_lhni h_nml + ρ₀.store ρ₀.store ρ₀.hasFailure 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 + gen' (fun _ h => h) h_store_no_gens_upper h_foreign + 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⟩ + +/-- Escaping companion of `stmtsToCFG_terminal`: an *uncaught* top-level exit. +When the structured run of `ss` escapes via `.exiting label` (no enclosing block +catches `label` — at the top level `exitConts = []`, so every label is uncaught), +the CFG `stmtsToCFG ss` escapes at the matching `.exiting label` with an +agreeing final store. Built on `stmtsToBlocks_simulation_to_exit`. -/ +theorem stmtsToCFG_exiting {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] + {Q : String → Prop} + (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) + (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 : Block.userLabelsShapeNodup ss) + (h_store_gens : ∀ x : String, Q x → ρ₀.store (HasIdent.ident (P := P) x) = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) Q (transformBlockModVars ss)) + (hQmint : S2UMintWitness Q) + (label : String) + (h_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.exiting label ρ')) : + let cfg := stmtsToCFG ss + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock cfg.entry ρ₀.store ρ₀.hasFailure) + (.exiting label σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := by + intro cfg + -- Bridge the gen-free `userLabelsShapeNodup` precondition to the + -- `∀ WF gen', userLabelsDisjoint ss gen'` form the spec/nodup helpers consume: + -- the disjointness conjunct is recovered from shape-freedom at any WF state. + have h_disj_wf : ∀ gen', StringGenState.WF gen' → Block.userLabelsDisjoint ss gen' := + Block.userLabelsDisjoint_of_shapeNodup ss h_disj + have ⟨lend, gen, gen', entry, blocks, h_gen, h_entry, h_blocks, h_lend, h_wf_gen, h_gen0⟩ := + stmtsToCFG_stmtsToBlocks_spec ss h_disj_wf + rw [h_entry] + have h_accum : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := + EvalCmds.eval_cmds_none + have h_hf : ρ₀.hasFailure = (ρ₀.hasFailure || false) := by simp + have h_nodup := stmtsToCFG_nodup_keys ss h_disj_wf + -- 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) Q (Cmds.definedVars [].reverse ++ Block.initVars ss) := by + intro s hQ + simpa [Cmds.definedVars] using h_input_no_gen_suffix s hQ + have h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars ss) := by + intro s hQ + simpa [Cmds.modifiedVars] using h_input_no_gen_suffix_mod s hQ + have h_store_no_gens_upper : + ∀ x : String, Q x → + x ∉ StringGenState.stringGens gen' → + ρ₀.store (HasIdent.ident (P := P) x) = none := fun x hx _ => h_store_gens x hx + -- Self-discharge of the foreign-label obligation. `gen` is the empty + -- generator state advanced by the single `"end$"` mint; every label `gen` + -- holds therefore satisfies `Q` (by `hQmint`'s `"end$"` witness). + -- `stmtsToBlocks_allMem` carries this to `gen'`: every label `gen'` holds + -- satisfies `Q`. Hence any label that is *not* `Q` is absent — plain + -- contraposition, no universal-WF assumption needed. + have h_allmem_gen : StringGenState.AllMem Q gen := by + rw [h_gen0] + exact StringGenState.allMem_gen Q "end$" StringGenState.emp + (StringGenState.allMem_emp Q) (hQmint.2.2.2.2.2.2.2.2.1 StringGenState.emp) + have h_allmem_gen' : StringGenState.AllMem Q gen' := + stmtsToBlocks_allMem hQmint lend ss [] [] gen gen' entry blocks h_gen h_allmem_gen + have h_foreign : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens gen' := + fun s hns => StringGenState.not_mem_stringGens_of_not_allMem h_allmem_gen' hns + -- The top-level `exitConts` is `[]`, so any label is uncaught. + have h_label : ([] : List (Option String × String)).lookup (some label) = none := rfl + have ⟨σ_cfg, h_sim, h_agree, _h_preserve⟩ := + stmtsToBlocks_simulation_to_exit extendEval lend ss [] [] gen gen' entry blocks + h_gen h_nofd h_simple h_unique h_lbni h_lhni h_nml + ρ₀.store ρ₀.store ρ₀.hasFailure false ρ₀ ρ' label h_label + hwfb hwfv hwf_def hwf_congr hwf_var + h_exit 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 + gen' (fun _ h => h) h_store_no_gens_upper h_foreign + cfg h_blocks h_nodup + -- The simulation already lands at `.exiting label σ_cfg`; no end-block compose. + exact ⟨σ_cfg, h_sim, h_agree⟩ + +/-- **Failing companion of `stmtsToCFG_terminal_compositional`.** From an +*arbitrary reachable failing* source configuration `c` (no terminal/exiting +endpoint required — the run may diverge or get stuck after the failure), the CFG +`stmtsToCFG ss` started from an overapproximating external store `σ_ext` reaches a +configuration whose `getFailure` flag is set. + +This is the compositional `σ_ext`-input restatement (the form a downstream +transform consumes, running the target from an `R`-related store) of the +intermediate-failing-config simulation: it threads the same agreement / +`σ_ext`-freshness preconditions as the terminal compositional theorem and +delegates to the `stmtsToBlocks_simulation_to_fail` mutual sibling. The source +must start non-failing (`h_ρ₀_nofail`) so the failure genuinely arises within +the run rather than being inherited at entry; this matches the pipeline's clean +initial store. -/ +theorem stmtsToCFG_to_fail {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] + {Q : String → Prop} + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) + (ρ₀ : Env P) + (c : Config P (Cmd P)) + (σ_ext : SemanticStore P) + (h_ρ₀_nofail : ρ₀.hasFailure = false) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (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_agree_ext : StoreAgreement ρ₀.store σ_ext) + (h_fresh_inits : ∀ x ∈ Block.initVars ss, σ_ext x = none) + (h_disj : Block.userLabelsShapeNodup ss) + (h_store_gens : ∀ x : String, Q x → σ_ext (HasIdent.ident (P := P) x) = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) Q (transformBlockModVars ss)) + (hQmint : S2UMintWitness Q) + (h_reach : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) c) + (h_c_fail : c.getEnv.hasFailure = true) : + let cfg := stmtsToCFG ss + ∃ d : CFGConfig String (Cmd P) P, + StepDetCFGStar extendEval cfg + (.atBlock cfg.entry σ_ext ρ₀.hasFailure) d + ∧ d.getFailure = true := by + intro cfg + have h_disj_wf : ∀ gen', StringGenState.WF gen' → Block.userLabelsDisjoint ss gen' := + Block.userLabelsDisjoint_of_shapeNodup ss h_disj + have ⟨lend, gen, gen', entry, blocks, h_gen, h_entry, h_blocks, h_lend, h_wf_gen, h_gen0⟩ := + stmtsToCFG_stmtsToBlocks_spec ss h_disj_wf + rw [h_entry] + -- accum runs struct-side from ρ₀.store to ρ₀.store (empty accum). + have h_accum : EvalCmds P (EvalCmd P) ρ₀.eval ρ₀.store [].reverse ρ₀.store false := + EvalCmds.eval_cmds_none + have h_hf : ρ₀.hasFailure = (ρ₀.hasFailure || false) := by simp + have h_nodup := stmtsToCFG_nodup_keys ss h_disj_wf + -- Combined freshness/Nodup: empty accum, so reduces to just inits (about σ_ext). + have h_fresh_combined : ∀ x ∈ Cmds.definedVars [].reverse ++ Block.initVars ss, + σ_ext 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) Q (Cmds.definedVars [].reverse ++ Block.initVars ss) := by + intro s hQ + simpa [Cmds.definedVars] using h_input_no_gen_suffix s hQ + have h_combined_no_gen_suffix_mod : + NoGenSuffix (P := P) Q (Cmds.modifiedVars [].reverse ++ transformBlockModVars ss) := by + intro s hQ + simpa [Cmds.modifiedVars] using h_input_no_gen_suffix_mod s hQ + have h_store_no_gens_upper : + ∀ x : String, Q x → + x ∉ StringGenState.stringGens gen' → + σ_ext (HasIdent.ident (P := P) x) = none := fun x hx _ => h_store_gens x hx + -- Foreign-label self-discharge, identical to the terminal corollaries. + have h_allmem_gen : StringGenState.AllMem Q gen := by + rw [h_gen0] + exact StringGenState.allMem_gen Q "end$" StringGenState.emp + (StringGenState.allMem_emp Q) (hQmint.2.2.2.2.2.2.2.2.1 StringGenState.emp) + have h_allmem_gen' : StringGenState.AllMem Q gen' := + stmtsToBlocks_allMem hQmint lend ss [] [] gen gen' entry blocks h_gen h_allmem_gen + have h_foreign : ∀ s : String, ¬ Q s → s ∉ StringGenState.stringGens gen' := + fun s hns => StringGenState.not_mem_stringGens_of_not_allMem h_allmem_gen' hns + exact stmtsToBlocks_simulation_to_fail extendEval lend ss [] [] gen gen' entry blocks + h_gen h_nofd h_simple h_unique h_lbni h_lhni h_nml + ρ₀.store σ_ext ρ₀.hasFailure false ρ₀ c h_ρ₀_nofail hwfb hwfv hwf_def hwf_congr hwf_var + h_reach h_c_fail h_accum h_agree_ext h_fresh_combined h_unique_combined h_hf + h_wf_gen h_combined_no_gen_suffix h_combined_no_gen_suffix_mod + gen' (fun _ h => h) h_store_no_gens_upper h_foreign + cfg h_blocks h_nodup + +/-! ## Main theorems -/ + +/-! ### The structured-to-unstructured label *kind* + +`stmtsToCFG` mints block labels under thirteen distinct prefixes. Eight come +from the direct `gen` calls — one per syntactic construct it compiles: +`"ite"`, `"$__nondet_ite$"`, `"loop_entry$"`, `"loop_measure$"`, +`"measure_decrease$"`, `"inv$"`, `"$__nondet_loop$"`, and `"end$"`. Four more +come from the auxiliary `flushCmds` helper that emits accumulated command +blocks: `"l$"` (the statement-list tail), `"blk$"` (the `.block` arm), `"ite$"` +(the `.ite` arm), and `"before_loop$"` (the `.loop` arm). The thirteenth is +parametric: the `.exit` arm flushes under `"block$⟨l⟩$"` where `l` is the user +block label being exited. `s2uKind s` is the precise predicate "`s` is a label +this pass could have minted under one of those prefixes": it carries the +matching generator prefix and equals some `gen`-output. This is the per-kind +`Q` to instantiate the kind-generalized soundness at, replacing the blanket +`HasUnderscoreDigitSuffix` (which would overcommit a composition partner to +keeping *every* gen-shaped name fresh). -/ + +/-- A label that `stmtsToCFG` could have minted: it carries one of the thirteen +construct prefixes and equals a corresponding `gen` output. Twelve prefixes are +fixed; the last is parameterised by the user block label being exited. -/ +@[expose] def s2uKind (s : String) : Prop := + (∃ sg, String.HasGenPrefix "ite" s + ∧ s = (StringGenState.gen "ite" sg).1) + ∨ (∃ sg, String.HasGenPrefix "$__nondet_ite$" s + ∧ s = (StringGenState.gen "$__nondet_ite$" sg).1) + ∨ (∃ sg, String.HasGenPrefix "ite$" s + ∧ s = (StringGenState.gen "ite$" sg).1) + ∨ (∃ sg, String.HasGenPrefix "loop_entry$" s + ∧ s = (StringGenState.gen "loop_entry$" sg).1) + ∨ (∃ sg, String.HasGenPrefix "loop_measure$" s + ∧ s = (StringGenState.gen "loop_measure$" sg).1) + ∨ (∃ sg, String.HasGenPrefix "measure_decrease$" s + ∧ s = (StringGenState.gen "measure_decrease$" sg).1) + ∨ (∃ sg, String.HasGenPrefix "inv$" s + ∧ s = (StringGenState.gen "inv$" sg).1) + ∨ (∃ sg, String.HasGenPrefix "$__nondet_loop$" s + ∧ s = (StringGenState.gen "$__nondet_loop$" sg).1) + ∨ (∃ sg, String.HasGenPrefix "end$" s + ∧ s = (StringGenState.gen "end$" sg).1) + ∨ (∃ sg, String.HasGenPrefix "l$" s + ∧ s = (StringGenState.gen "l$" sg).1) + ∨ (∃ sg, String.HasGenPrefix "blk$" s + ∧ s = (StringGenState.gen "blk$" sg).1) + ∨ (∃ sg, String.HasGenPrefix "before_loop$" s + ∧ s = (StringGenState.gen "before_loop$" sg).1) + ∨ (∃ l : String, ∃ sg, String.HasGenPrefix (s!"block${l}$") s + ∧ s = (StringGenState.gen (s!"block${l}$") sg).1) + +/-- Each of the thirteen prefixes `stmtsToCFG` mints under lands inside +`s2uKind`: this is exactly the thirteen-conjunct mint witness at +`Q := s2uKind`, the analogue of `ndelimKind_gen` for the S2U construct prefixes. +The final conjunct is parametric in the user block label `l`. -/ +theorem s2uKind_gen : S2UMintWitness s2uKind := by + refine ⟨fun sg => ?_, fun sg => ?_, fun sg => ?_, fun sg => ?_, fun sg => ?_, + fun sg => ?_, fun sg => ?_, fun sg => ?_, fun sg => ?_, fun sg => ?_, + fun sg => ?_, fun sg => ?_, fun l sg => ?_⟩ + · exact Or.inl ⟨sg, StringGenState.gen_hasGenPrefix "ite" sg, rfl⟩ + · exact Or.inr (Or.inl ⟨sg, StringGenState.gen_hasGenPrefix "$__nondet_ite$" sg, rfl⟩) + · exact Or.inr (Or.inr (Or.inl ⟨sg, StringGenState.gen_hasGenPrefix "ite$" sg, rfl⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl + ⟨sg, StringGenState.gen_hasGenPrefix "loop_entry$" sg, rfl⟩))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨sg, StringGenState.gen_hasGenPrefix "loop_measure$" sg, rfl⟩)))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨sg, StringGenState.gen_hasGenPrefix "measure_decrease$" sg, rfl⟩))))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨sg, StringGenState.gen_hasGenPrefix "inv$" sg, rfl⟩)))))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨sg, StringGenState.gen_hasGenPrefix "$__nondet_loop$" sg, rfl⟩))))))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨sg, StringGenState.gen_hasGenPrefix "end$" sg, rfl⟩)))))))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨sg, StringGenState.gen_hasGenPrefix "l$" sg, rfl⟩))))))))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨sg, StringGenState.gen_hasGenPrefix "blk$" sg, rfl⟩)))))))))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl + ⟨sg, StringGenState.gen_hasGenPrefix "before_loop$" sg, rfl⟩))))))))))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr + ⟨l, sg, StringGenState.gen_hasGenPrefix (s!"block${l}$") sg, rfl⟩))))))))))) + +/-- Kind-generalized soundness of `stmtsToCFG`. Like a blanket-freshness +formulation but with the threaded input-freshness invariant (`NoGenSuffix`) +constraining only the labels *this* pass mints (`s2uKind`) rather than every +gen-shaped name, which is what lets a composition partner — one that mints under +disjoint prefixes — satisfy it. + +Unlike the structured-to-structured passes (`nondetElim`, the loop-init hoist), +`stmtsToCFG` produces a CFG and so its soundness must dispatch a *foreign-label* +obligation: any label not minted by this pass is absent from the output +generator's `stringGens`. This obligation is *not* derivable from +well-formedness alone at the finer `Q := s2uKind` — `stmtsToCFG` also mints under +auxiliary `flushCmds` prefixes (`"l$"`, `"blk$"`, `"before_loop$"`, and a +user-label-parameterised `"block$⟨l⟩$"`), so a generic WF state may legitimately +contain non-`s2uKind` labels. It is instead discharged *internally* by +`stmtsToCFG_terminal`: from the thirteen-conjunct mint witness `hQmint` it tracks +`AllMem Q` from the empty generator state through the pass, so every label the +pass produces satisfies `Q`, and any label that is not `Q` is absent by +contraposition. Phase 4 therefore supplies only `hQmint` (via `s2uKind_gen` at +`Q := s2uKind`) — there is no separate foreign hypothesis to discharge. -/ +theorem structuredToUnstructured_sound_kind {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] + {Q : String → Prop} + (hQmint : S2UMintWitness Q) + (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) + (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 : Block.userLabelsShapeNodup ss) + (h_store_gens : ∀ x : String, Q x → ρ₀.store (HasIdent.ident (P := P) x) = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) Q (transformBlockModVars ss)) + (h_term : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.terminal ρ')) : + let cfg := stmtsToCFG ss + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock cfg.entry ρ₀.store ρ₀.hasFailure) + (.terminal σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := + -- `hQmint` is the thirteen-conjunct mint witness for the construct prefixes — + -- definitionally `S2UMintWitness Q`. `stmtsToCFG_terminal` consumes it to + -- *derive* the foreign-label obligation internally (via `AllMem Q`), so this + -- handle needs no separate foreign hypothesis. A composition partner supplies + -- `hQmint` via `s2uKind_gen` at `Q := s2uKind`. + stmtsToCFG_terminal (Q := Q) + extendEval ss ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var + h_nofd h_simple h_unique h_lbni h_lhni h_nml + h_fresh_inits h_disj h_store_gens h_input_no_gen_suffix + h_input_no_gen_suffix_mod hQmint h_term + +/-- Escaping companion of `structuredToUnstructured_sound_kind`: an *uncaught* +top-level exit. When the source run of `ss` escapes via `.exiting label`, the +unstructured CFG `stmtsToCFG ss` escapes at the matching `.exiting label` with +an agreeing final store. A thin forwarder to `stmtsToCFG_exiting`. -/ +theorem structuredToUnstructured_sound_kind_exit {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] + {Q : String → Prop} + (hQmint : S2UMintWitness Q) + (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) + (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 : Block.userLabelsShapeNodup ss) + (h_store_gens : ∀ x : String, Q x → ρ₀.store (HasIdent.ident (P := P) x) = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) Q (transformBlockModVars ss)) + (label : String) + (h_exit : StepStmtStar P (EvalCmd P) extendEval + (.stmts ss ρ₀) (.exiting label ρ')) : + let cfg := stmtsToCFG ss + ∃ σ_cfg, StepDetCFGStar extendEval cfg + (.atBlock cfg.entry ρ₀.store ρ₀.hasFailure) + (.exiting label σ_cfg ρ'.hasFailure) + ∧ StoreAgreement ρ'.store σ_cfg := + stmtsToCFG_exiting (Q := Q) + extendEval ss ρ₀ ρ' hwfb hwfv hwf_def hwf_congr hwf_var + h_nofd h_simple h_unique h_lbni h_lhni h_nml + h_fresh_inits h_disj h_store_gens h_input_no_gen_suffix + h_input_no_gen_suffix_mod hQmint label h_exit + +/-- **Failing companion of `structuredToUnstructured_sound_kind`.** From an +arbitrary reachable *failing* source configuration (no endpoint demand), the +unstructured CFG `stmtsToCFG ss`, run from an overapproximating external store +`σ_ext`, reaches a failing configuration. A thin forwarder to +`stmtsToCFG_to_fail`; the foreign-label obligation is discharged internally from +`hQmint`. -/ +theorem structuredToUnstructured_sound_kind_fail {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] + {Q : String → Prop} + (hQmint : S2UMintWitness Q) + (extendEval : ExtendEval P) + (ss : List (Stmt P (Cmd P))) + (ρ₀ : Env P) + (c : Config P (Cmd P)) + (σ_ext : SemanticStore P) + (h_ρ₀_nofail : ρ₀.hasFailure = false) + (hwfb : WellFormedSemanticEvalBool ρ₀.eval) + (hwfv : WellFormedSemanticEvalVal ρ₀.eval) + (hwf_def : WellFormedSemanticEvalDef ρ₀.eval) + (hwf_congr : WellFormedSemanticEvalExprCongr ρ₀.eval) + (hwf_var : WellFormedSemanticEvalVar ρ₀.eval) + (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_agree_ext : StoreAgreement ρ₀.store σ_ext) + (h_fresh_inits : ∀ x ∈ Block.initVars ss, σ_ext x = none) + (h_disj : Block.userLabelsShapeNodup ss) + (h_store_gens : ∀ x : String, Q x → σ_ext (HasIdent.ident (P := P) x) = none) + (h_input_no_gen_suffix : NoGenSuffix (P := P) Q (Block.initVars ss)) + (h_input_no_gen_suffix_mod : NoGenSuffix (P := P) Q (transformBlockModVars ss)) + (h_reach : StepStmtStar P (EvalCmd P) extendEval (.stmts ss ρ₀) c) + (h_c_fail : c.getEnv.hasFailure = true) : + let cfg := stmtsToCFG ss + ∃ d : CFGConfig String (Cmd P) P, + StepDetCFGStar extendEval cfg + (.atBlock cfg.entry σ_ext ρ₀.hasFailure) d + ∧ d.getFailure = true := + stmtsToCFG_to_fail (Q := Q) + extendEval ss ρ₀ c σ_ext h_ρ₀_nofail hwfb hwfv hwf_def hwf_congr hwf_var + h_nofd h_simple h_unique h_lbni h_lhni h_nml + h_agree_ext h_fresh_inits h_disj h_store_gens h_input_no_gen_suffix + h_input_no_gen_suffix_mod hQmint h_reach h_c_fail + +--------------------------------------------------------------------- +-- Loop-init-hoisting additive helpers (ported; used by LoopInitHoist*). +--------------------------------------------------------------------- + +/-- Extend a `SemanticStore` with a single `(ident, value)` binding. +Returns a function that maps `ident` to `some value` and delegates other +keys to the original store. -/ +@[expose] def extendStoreOne {P : PureExpr} [DecidableEq P.Ident] + (σ : SemanticStore P) (ident : P.Ident) (val : P.Expr) : + SemanticStore P := + fun y => if y = ident then some val else σ y + +/-- `extendStoreOne` evaluated at the bound ident returns `some val`. -/ +theorem extendStoreOne_self {P : PureExpr} [DecidableEq P.Ident] + (σ : SemanticStore P) (ident : P.Ident) (val : P.Expr) : + extendStoreOne σ ident val ident = some val := by + simp [extendStoreOne] + +/-- `extendStoreOne` evaluated at any other ident equals the original +store. -/ +theorem extendStoreOne_other {P : PureExpr} [DecidableEq P.Ident] + (σ : SemanticStore P) (ident : P.Ident) (val : P.Expr) + (y : P.Ident) (h : y ≠ ident) : + extendStoreOne σ ident val y = σ y := by + simp [extendStoreOne, h] + +end StructuredToUnstructuredCorrect + +end -- public section diff --git a/StrataTest/DL/Imperative/CFGToCProverGOTO.lean b/StrataTest/DL/Imperative/CFGToCProverGOTO.lean index 49d2aeed0c..9e6757c7a6 100644 --- a/StrataTest/DL/Imperative/CFGToCProverGOTO.lean +++ b/StrataTest/DL/Imperative/CFGToCProverGOTO.lean @@ -275,8 +275,8 @@ info: ok: #[LOCATION 0, -- Construct a CFG where entry label doesn't match the first block let cfg : Imperative.CFG String (Imperative.DetBlock String (Imperative.Cmd LExprTP) LExprTP) := { entry := "second", - blocks := [("first", { cmds := [], transfer := .finish }), - ("second", { cmds := [], transfer := .finish })] } + blocks := [("first", { cmds := [], transfer := .finish .empty }), + ("second", { cmds := [], transfer := .finish .empty })] } match Imperative.detCFGToGotoTransform Lambda.TEnv.default "test" cfg with | .error e => assert! (s!"{e}".splitOn "Entry label").length > 1 | .ok _ => assert! false @@ -304,7 +304,7 @@ info: ok: () let trueExpr : LExprTP.Expr := .const { underlying := (), type := mty[bool] } (.boolConst true) let blk : Imperative.DetBlock String (Imperative.Cmd LExprTP) LExprTP := - { cmds := [], transfer := .condGoto trueExpr "missing_label" "also_missing" } + { cmds := [], transfer := .condGoto trueExpr "missing_label" "also_missing" .empty } let cfg : Imperative.CFG String (Imperative.DetBlock String (Imperative.Cmd LExprTP) LExprTP) := { entry := "entry", blocks := [("entry", blk)] } match Imperative.detCFGToGotoTransform Lambda.TEnv.default "test" cfg with diff --git a/StrataTest/DL/Imperative/StepStmtTest.lean b/StrataTest/DL/Imperative/StepStmtTest.lean index 4712b61e5e..db8e81c1ec 100644 --- a/StrataTest/DL/Imperative/StepStmtTest.lean +++ b/StrataTest/DL/Imperative/StepStmtTest.lean @@ -52,6 +52,10 @@ instance : HasBool MiniPureExpr where instance : HasNot MiniPureExpr where not := .not +/-- `HasVarsPure` for `MiniPureExpr.Expr`: closed expressions, no free variables. -/ +instance : HasVarsPure MiniPureExpr Expr where + getVars _ := [] + --------------------------------------------------------------------- /-! ## Evaluator and well-formedness setup -/ @@ -350,6 +354,13 @@ theorem miniEval_wfVar : WellFormedSemanticEvalVar (P := MiniPureExpr) miniEval intro e v σ hfv simp [HasFvar.getFvar] at hfv +/-- `WellFormedSemanticEvalExprCongr` for `miniEval` — trivially holds since + `miniEval` ignores the store. -/ +theorem miniEval_wfCongr : WellFormedSemanticEvalExprCongr (P := MiniPureExpr) miniEval := by + unfold WellFormedSemanticEvalExprCongr + intros e σ σ' _ + rfl + /-- The standard `EvalCmd` for `Cmd MiniPureExpr`. -/ def stdEvalCmd : EvalCmdParam MiniPureExpr (Cmd MiniPureExpr) := EvalCmd MiniPureExpr @@ -405,7 +416,8 @@ theorem blockScopeTest : (show storeWithX "y" = none from rfl) (show storeWithXY "y" = some .tt from rfl) storeWithXY_frame) - miniEval_wfVar)))) ?_ + miniEval_wfVar + miniEval_wfCongr)))) ?_ -- Step 4: step_block_body (step_seq_done) — seq is done, go to stmts []. refine .step _ _ _ (StepStmt.step_block_body StepStmt.step_seq_done) ?_ @@ -476,7 +488,8 @@ theorem loopScopeTest : (show storeWithX "y" = none from rfl) (show storeWithXY "y" = some .tt from rfl) storeWithXY_frame) - miniEval_wfVar))))) ?_ + miniEval_wfVar + miniEval_wfCongr))))) ?_ -- Step 4: step_seq_inner (step_block_body step_seq_done) — inner stmt terminal refine .step _ _ _ (StepStmt.step_seq_inner @@ -512,7 +525,7 @@ theorem loopScopeTest : -- Need to reconcile the env shape. conv => rhs; rw [show Env.mk storeWithX miniEval false = { Env.mk (projectStore storeWithX storeWithXY) miniEval false with - hasFailure := false || false } from by simp [hproj]] + hasFailure := false || false } from by simp [hproj, Bool.or_false]] exact .step _ _ _ StepStmt.step_stmts_nil (.refl _) --------------------------------------------------------------------- @@ -536,7 +549,7 @@ theorem reinit_stuck : (.stmt (.cmd (.init "x" .Bool (.det .ff) .empty)) ρ_x) c₂ := by intro ⟨c₂, hstep⟩ match hstep with - | .step_cmd (.eval_init _ (.init h_none _ _) _) => + | .step_cmd (.eval_init _ (.init h_none _ _) _ _) => exact absurd h_none (by simp [ρ_x, storeWithX]) --------------------------------------------------------------------- diff --git a/StrataTest/Languages/Core/Examples/Exit.lean b/StrataTest/Languages/Core/Examples/Exit.lean index d4f3f2d0e2..6e2fd04a8a 100644 --- a/StrataTest/Languages/Core/Examples/Exit.lean +++ b/StrataTest/Languages/Core/Examples/Exit.lean @@ -3,11 +3,14 @@ SPDX-License-Identifier: Apache-2.0 OR MIT -/ +module -import Strata.Languages.Core -import StrataTest.Languages.Core.Examples.Loops +meta import Strata.Languages.Core +meta import Strata.Languages.Core +meta import StrataTest.Languages.Core.Examples.Loops import StrataDDM.Integration.Lean.HashCommands +meta section open StrataDDM (Program) --------------------------------------------------------------------- namespace Strata @@ -114,51 +117,58 @@ Result: ✅ pass /-- -info: Entry: l1 +info: Entry: block$l1$_2 l1: - condGoto true block$l1$_2 block$l1$_2 + #[<[provenance]: :480-595>] condGoto true block$l1$_2 block$l1$_2 block$l1$_2: assert [a1]: x == x; - condGoto true l$_1 l$_1 + #[<[provenance]: :519-527>] condGoto true l$_1 l$_1 l$_1: assert [a3]: x == x; condGoto true end$_0 end$_0 end$_0: - finish + #[<[provenance]: >] finish -/ #guard_msgs in #eval (Std.format (singleCFG exitPgm 0)) /-- -info: Entry: l5 +info: Entry: ite$_7 l5: - condGoto true l4 l4 + #[<[provenance]: :670-1149>] condGoto true ite$_7 ite$_7 l4: - condGoto true l4_before l4_before + #[<[provenance]: :682-1143>] condGoto true ite$_7 ite$_7 l4_before: - condGoto true l3_before l3_before + #[<[provenance]: :696-1089>] condGoto true ite$_7 ite$_7 l3_before: - condGoto true l1 l1 + #[<[provenance]: :719-1026>] condGoto true ite$_7 ite$_7 l1: - condGoto true ite$_5 ite$_5 -ite$_5: + #[<[provenance]: :744-928>] condGoto true ite$_7 ite$_7 +ite$_7: assert [a4]: x == x; - condGoto x > 0 block$l5$_2 block$l5$_1 + #[<[provenance]: :799-914>] condGoto x > 0 block$l3_before$_5 block$l4_before$_6 +block$l3_before$_5: + #[<[provenance]: :828-843>] condGoto true block$l5$_2 block$l5$_2 +block$l4_before$_6: + #[<[provenance]: :883-898>] condGoto true block$l5$_1 block$l5$_1 l2: - condGoto true l$_3 l$_3 + #[<[provenance]: :941-1014>] condGoto true l$_3 l$_3 l$_3: assert [a5]: !(x == x); condGoto true block$l5$_2 block$l5$_2 block$l5$_2: assert [a6]: x * 2 > x; - condGoto true end$_0 end$_0 + #[<[provenance]: :1071-1079>] condGoto true end$_0 end$_0 block$l5$_1: assert [a7]: x <= 0; - condGoto true end$_0 end$_0 + #[<[provenance]: :1127-1135>] condGoto true end$_0 end$_0 end$_0: - finish + #[<[provenance]: >] finish -/ #guard_msgs in #eval (Std.format (singleCFG exitPgm 1)) + +end Strata +end diff --git a/StrataTest/Languages/Core/Examples/Functions.lean b/StrataTest/Languages/Core/Examples/Functions.lean index 389ef9e8b8..0583925c8d 100644 --- a/StrataTest/Languages/Core/Examples/Functions.lean +++ b/StrataTest/Languages/Core/Examples/Functions.lean @@ -3,12 +3,13 @@ SPDX-License-Identifier: Apache-2.0 OR MIT -/ +module -import Strata.Languages.Core -import Strata.Languages.Core.CallGraph +meta import Strata.Languages.Core +meta import Strata.Languages.Core.CallGraph import StrataDDM.Integration.Lean.HashCommands -import Strata.MetaVerifier +meta section open StrataDDM (Program) --------------------------------------------------------------------- namespace Strata @@ -75,10 +76,6 @@ Result: ✅ pass #guard_msgs in #eval Core.verify funcPgm -theorem funcPgm_correct : smtVCsCorrect funcPgm := by - gen_smt_vcs - all_goals (try grind) - --------------------------------------------------------------------- /-! ## Multi-argument function test @@ -158,9 +155,6 @@ Result: ✅ pass #guard_msgs in #eval Core.verify quantBodyFuncPgm -theorem quantBodyFuncPgm_correct : smtVCsCorrect quantBodyFuncPgm := by - gen_smt_vcs - all_goals (try grind) - end Strata +end --------------------------------------------------------------------- diff --git a/StrataTest/Languages/Core/Examples/Loops.lean b/StrataTest/Languages/Core/Examples/Loops.lean index d54b0c0bf0..8cdf16dc34 100644 --- a/StrataTest/Languages/Core/Examples/Loops.lean +++ b/StrataTest/Languages/Core/Examples/Loops.lean @@ -3,22 +3,22 @@ SPDX-License-Identifier: Apache-2.0 OR MIT -/ - +module import Strata.Languages.Core.Verifier -import Strata.Languages.Core +meta import Strata.Languages.Core import Strata.Transform.StructuredToUnstructured import Lean.Parser.Types -import Strata.Languages.Core.DDMTransform.Grammar -import Strata.Languages.Core.DDMTransform.Translate -import Strata.Languages.Core.Options -import StrataDDM.AST -import Strata.DL.Imperative.BasicBlock -import Strata.Languages.Core.Statement -import Strata.Languages.Core.Expressions +meta import Strata.Languages.Core.DDMTransform.Grammar +meta import Strata.Languages.Core.DDMTransform.Translate +meta import Strata.Languages.Core.Options +public import StrataDDM.AST +public import Strata.DL.Imperative.BasicBlock +public import Strata.Languages.Core.Statement +public import Strata.Languages.Core.Expressions import StrataDDM.Integration.Lean.HashCommands import Strata.Languages.Core.StatementSemantics -import Strata.MetaVerifier +public section open StrataDDM (Program) namespace Strata @@ -64,15 +64,18 @@ loop_entry$_1: var loop_measure$_2 : int; assume [assume_loop_measure$_2]: loop_measure$_2 == n; assert [measure_lb_loop_measure$_2]: !(loop_measure$_2 < 0); - condGoto i < n l$_4 end$_0 + #[<[provenance]: :1298-1404>, + <[#spec_loop_invariant]: 0 <= i>, + <[#spec_loop_invariant]: i <= n>, + <[#spec_decreases]: n>] condGoto i < n l$_4 end$_0 l$_4: i := i + 1; condGoto true measure_decrease$_3 measure_decrease$_3 measure_decrease$_3: assert [measure_decrease_loop_measure$_2]: n < loop_measure$_2; - condGoto true loop_entry$_1 loop_entry$_1 + #[<[provenance]: >] condGoto true loop_entry$_1 loop_entry$_1 end$_0: - finish + #[<[provenance]: >] finish -/ #guard_msgs in #eval (Std.format (singleCFG measureFailExamplePgm 0)) @@ -152,16 +155,20 @@ loop_entry$_1: var loop_measure$_2 : int; assume [assume_loop_measure$_2]: loop_measure$_2 == n - i; assert [measure_lb_loop_measure$_2]: !(loop_measure$_2 < 0); - condGoto i < n l$_4 end$_0 + #[<[provenance]: :3146-3302>, + <[#spec_loop_invariant]: 0 <= i>, + <[#spec_loop_invariant]: i <= n>, + <[#spec_loop_invariant]: s == i * (i + 1) / 2>, + <[#spec_decreases]: n - i>] condGoto i < n l$_4 end$_0 l$_4: i := i + 1; s := s + i; condGoto true measure_decrease$_3 measure_decrease$_3 measure_decrease$_3: assert [measure_decrease_loop_measure$_2]: n - i < loop_measure$_2; - condGoto true loop_entry$_1 loop_entry$_1 + #[<[provenance]: >] condGoto true loop_entry$_1 loop_entry$_1 end$_0: - finish + #[<[provenance]: >] finish -/ #guard_msgs in #eval (Std.format (singleCFG gaussPgm 0)) @@ -344,10 +351,6 @@ Result: ✅ pass #guard_msgs in #eval Core.verify gaussPgm -theorem gaussPgm_correct : smtVCsCorrect gaussPgm := by - gen_smt_vcs - all_goals (try grind) - --------------------------------------------------------------------- def nestedPgm := @@ -404,7 +407,11 @@ Context: Global scope: var loop_measure$_2 : int; assume [assume_loop_measure$_2]: loop_measure$_2 == n - x; assert [measure_lb_loop_measure$_2]: !(loop_measure$_2 < 0); - condGoto x < n before_loop$_11 end$_0 + #[<[provenance]: :9041-9294>, + <[#spec_loop_invariant]: x >= 0>, + <[#spec_loop_invariant]: x <= n>, + <[#spec_loop_invariant]: n < top>, + <[#spec_decreases]: n - x>] condGoto x < n before_loop$_11 end$_0 before_loop$_11: y := 0; condGoto true loop_entry$_5 loop_entry$_5 @@ -414,21 +421,24 @@ loop_entry$_5: var loop_measure$_6 : int; assume [assume_loop_measure$_6]: loop_measure$_6 == x - y; assert [measure_lb_loop_measure$_6]: !(loop_measure$_6 < 0); - condGoto y < x l$_8 l$_4 + #[<[provenance]: :9161-9274>, + <[#spec_loop_invariant]: y >= 0>, + <[#spec_loop_invariant]: y <= x>, + <[#spec_decreases]: x - y>] condGoto y < x l$_8 l$_4 l$_8: y := y + 1; condGoto true measure_decrease$_7 measure_decrease$_7 measure_decrease$_7: assert [measure_decrease_loop_measure$_6]: x - y < loop_measure$_6; - condGoto true loop_entry$_5 loop_entry$_5 + #[<[provenance]: >] condGoto true loop_entry$_5 loop_entry$_5 l$_4: x := x + 1; condGoto true measure_decrease$_3 measure_decrease$_3 measure_decrease$_3: assert [measure_decrease_loop_measure$_2]: n - x < loop_measure$_2; - condGoto true loop_entry$_1 loop_entry$_1 + #[<[provenance]: >] condGoto true loop_entry$_1 loop_entry$_1 end$_0: - finish + #[<[provenance]: >] finish -/ #guard_msgs in #eval (Std.format (singleCFG nestedPgm 2)) @@ -494,10 +504,6 @@ Result: ✅ pass #guard_msgs in #eval Core.verify nestedPgm (options := .quiet) -theorem nestedPgm_correct : smtVCsCorrect nestedPgm := by - gen_smt_vcs - all_goals (try grind) - --------------------------------------------------------------------- -- A loop where the `decreases` clause uses integer division `i / d`. @@ -564,26 +570,6 @@ Result: ✅ pass #guard_msgs in #eval Core.verify precondElimInMeasurePgm (options := .quiet) -/-- -This theorem requires a little bit of manual work to handle facts about -division, though most goals are solved by `grind`. --/ -theorem precondElimInMeasurePgm_correct : smtVCsCorrect precondElimInMeasurePgm := by - gen_smt_vcs - all_goals (try grind) - -- measure_lb_0: the loop measure i / d is non-negative - case measure_lb_0 => - intro _ d i _ _ dpos _ _ _ inonneg meas_def - subst meas_def - have p := Int.ediv_nonneg (a := i) (b := d) - grind - -- measure_decrease_0: the loop measure i / d strictly decreases - case measure_decrease_0 => - intro _ d i _ _ dpos _ _ _ _ meas_def - subst meas_def - have p := Int.add_mul_ediv_left (a := i) (b := d) (c := -1) - grind - -- Now, we show the precondition (d > 0) is necessary for the measure-related -- checks. def precondElimInMeasureBadPgm := @@ -711,3 +697,4 @@ Result: ✅ pass #eval Core.verify precondElimMeasureBodyMutatesPgm (options := .quiet) end Strata +end diff --git a/StrataTest/Languages/Core/Examples/Min.lean b/StrataTest/Languages/Core/Examples/Min.lean index 97e9f28eec..5f7598c54c 100644 --- a/StrataTest/Languages/Core/Examples/Min.lean +++ b/StrataTest/Languages/Core/Examples/Min.lean @@ -3,11 +3,12 @@ SPDX-License-Identifier: Apache-2.0 OR MIT -/ +module -import Strata.Languages.Core +meta import Strata.Languages.Core import StrataDDM.Integration.Lean.HashCommands -import Strata.MetaVerifier +meta section open StrataDDM (Program) --------------------------------------------------------------------- namespace Strata @@ -46,9 +47,6 @@ Result: ✅ pass #guard_msgs in #eval Core.verify testPgm -theorem testPgm_correct : smtVCsCorrect testPgm := by - gen_smt_vcs - grind - end Strata +end --------------------------------------------------------------------- diff --git a/StrataTest/Languages/Core/Examples/Quantifiers.lean b/StrataTest/Languages/Core/Examples/Quantifiers.lean index 3641766eb3..3aaf7c7dfc 100644 --- a/StrataTest/Languages/Core/Examples/Quantifiers.lean +++ b/StrataTest/Languages/Core/Examples/Quantifiers.lean @@ -3,11 +3,12 @@ SPDX-License-Identifier: Apache-2.0 OR MIT -/ +module -import Strata.Languages.Core +meta import Strata.Languages.Core import StrataDDM.Integration.Lean.HashCommands -import Strata.MetaVerifier +meta section --------------------------------------------------------------------- namespace Strata @@ -151,8 +152,5 @@ Result: ✅ pass #guard_msgs in #eval Core.verify triggerPgm -theorem triggerPgm_correct : smtVCsCorrect triggerPgm := by - gen_smt_vcs - all_goals (try grind) - end Strata +end diff --git a/StrataTest/Languages/Core/Examples/RecursiveProcIte.lean b/StrataTest/Languages/Core/Examples/RecursiveProcIte.lean index edee2f5c55..4d286baaac 100644 --- a/StrataTest/Languages/Core/Examples/RecursiveProcIte.lean +++ b/StrataTest/Languages/Core/Examples/RecursiveProcIte.lean @@ -3,11 +3,12 @@ SPDX-License-Identifier: Apache-2.0 OR MIT -/ +module -import Strata.Languages.Core +meta import Strata.Languages.Core import StrataDDM.Integration.Lean.HashCommands -import Strata.MetaVerifier +meta section open StrataDDM (Program) --------------------------------------------------------------------- namespace Strata @@ -76,10 +77,6 @@ Result: ✅ pass #guard_msgs in #eval Core.verify procIfPgm -theorem procIfPgm_correct : smtVCsCorrect procIfPgm := by - gen_smt_vcs - all_goals (try grind) - /- if (cond) { @@ -97,3 +94,4 @@ if (cond) { -/ end Strata +end 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).