From 12e7e3e0794b9472e5021bc2a4da3ab43af27e0f Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 5 May 2026 11:24:59 -0700 Subject: [PATCH 01/57] add CFG to procedure body, no error handling, tests pass --- Strata/Backends/CBMC/CoreToCBMC.lean | 2 +- .../Backends/CBMC/GOTO/CoreToCProverGOTO.lean | 4 +- .../CBMC/GOTO/CoreToGOTOPipeline.lean | 2 +- Strata/Languages/Boole/Verify.lean | 4 +- Strata/Languages/C_Simp/Verify.lean | 2 +- Strata/Languages/Core/CallGraph.lean | 2 +- Strata/Languages/Core/Core.lean | 4 +- .../Core/DDMTransform/FormatCore.lean | 2 +- .../Core/DDMTransform/Translate.lean | 4 +- .../Languages/Core/ObligationExtraction.lean | 2 +- Strata/Languages/Core/Procedure.lean | 59 ++++++++++++++++--- Strata/Languages/Core/ProcedureEval.lean | 2 +- Strata/Languages/Core/ProcedureType.lean | 8 +-- Strata/Languages/Core/StatementEval.lean | 2 +- Strata/Languages/Core/StatementSemantics.lean | 2 +- Strata/Languages/Core/WF.lean | 6 +- .../Laurel/LaurelToCoreTranslator.lean | 2 +- Strata/Languages/Python/PythonToCore.lean | 4 +- Strata/Transform/ANFEncoder.lean | 4 +- Strata/Transform/CoreSpecification.lean | 4 +- Strata/Transform/CoreTransform.lean | 4 +- Strata/Transform/LoopElim.lean | 4 +- Strata/Transform/PrecondElim.lean | 14 ++--- Strata/Transform/ProcBodyVerify.lean | 2 +- Strata/Transform/ProcBodyVerifyCorrect.lean | 20 +++---- Strata/Transform/ProcedureInlining.lean | 10 ++-- .../Backends/CBMC/GOTO/E2E_CoreToGOTO.lean | 2 +- .../Languages/Boole/global_readonly_call.lean | 26 ++++---- StrataTest/Languages/Core/Examples/Loops.lean | 2 +- .../Core/Tests/ProcedureTypeTests.lean | 2 +- .../Core/Tests/ProgramEvalTests.lean | 2 +- .../Core/Tests/ProgramTypeTests.lean | 8 +-- .../Core/Tests/StatementTypeTests.lean | 2 +- StrataTest/Transform/ProcedureInlining.lean | 8 +-- 34 files changed, 134 insertions(+), 93 deletions(-) diff --git a/Strata/Backends/CBMC/CoreToCBMC.lean b/Strata/Backends/CBMC/CoreToCBMC.lean index 04617c385c..8b66190c5f 100644 --- a/Strata/Backends/CBMC/CoreToCBMC.lean +++ b/Strata/Backends/CBMC/CoreToCBMC.lean @@ -346,7 +346,7 @@ def createImplementationSymbolFromAST (func : Core.Procedure) : Except String CB -- For now, keep the hardcoded implementation but use function name from AST let loc : SourceLoc := { functionName := (func.header.name.toPretty), lineNum := "1" } - let stmtJsons ← (func.body.mapM (stmtToJson (I:=CoreLParams) · loc)) + let stmtJsons ← (func.body.toStmts.mapM (stmtToJson (I:=CoreLParams) · loc)) let implValue := Json.mkObj [ ("id", "code"), diff --git a/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean index bd353e0895..a14fc59cef 100644 --- a/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean +++ b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean @@ -201,7 +201,7 @@ def transformToGoto (cprog : Core.Program) : Except Format CProverGOTO.Context : if !p.header.typeArgs.isEmpty then throw f!"[transformToGoto] Translation for polymorphic Strata Core procedures is unimplemented." - let cmds ← p.body.mapM + let cmds ← p.body.toStmts.mapM (fun b => match b with | .cmd (.cmd c) => return c | _ => throw f!"[transformToGoto] We can process Strata Core commands only, not statements! \ @@ -218,7 +218,7 @@ def transformToGoto (cprog : Core.Program) : Except Format CProverGOTO.Context : let formals_renamed := formals.zip new_formals let formals_tys : Map String CProverGOTO.Ty := formals.zip formals_tys - let locals := (Imperative.Block.definedVars p.body).map Core.CoreIdent.toPretty + let locals := (Imperative.Block.definedVars p.body.toStmts).map Core.CoreIdent.toPretty let new_locals := locals.map (fun l => CProverGOTO.mkLocalSymbol pname l) let locals_renamed := locals.zip new_locals diff --git a/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean b/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean index 2cc5e57433..421724bd72 100644 --- a/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean +++ b/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean @@ -259,7 +259,7 @@ def procedureToGotoCtx : Except Std.Format (CoreToGOTO.CProverGOTO.Context × List Core.Function) := do -- Lift local function declarations out of the body - let (liftedFuncs, body) ← collectFuncDecls p.body + let (liftedFuncs, body) ← collectFuncDecls p.body.toStmts let pname := Core.CoreIdent.toPretty p.header.name if !p.header.typeArgs.isEmpty then .error f!"[procedureToGotoCtx] Polymorphic procedures unsupported." diff --git a/Strata/Languages/Boole/Verify.lean b/Strata/Languages/Boole/Verify.lean index 30924563ed..b32f169450 100644 --- a/Strata/Languages/Boole/Verify.lean +++ b/Strata/Languages/Boole/Verify.lean @@ -810,7 +810,7 @@ private def translateProcedureDecl return [.proc { header := { name := mkIdent n, typeArgs := tys, inputs := allInputs, outputs := allOutputs } spec := spec - body := body + body := .structured body } .empty] def toCoreDecls (cmd : BooleDDM.Command SourceRange) : TranslateM (List Core.Decl) := do @@ -882,7 +882,7 @@ def toCoreDecls (cmd : BooleDDM.Command SourceRange) : TranslateM (List Core.Dec return [.proc { header := { name := mkIdent topLevelBlockProcedureName, typeArgs := [], inputs := [], outputs := [] } spec := { preconditions := [], postconditions := [] } - body := ← toCoreBlock b + body := .structured (← toCoreBlock b) } .empty] | .command_datatypes _ ⟨_, decls⟩ => return [.type (.data (← decls.toList.mapM toCoreDatatypeDecl)) .empty] diff --git a/Strata/Languages/C_Simp/Verify.lean b/Strata/Languages/C_Simp/Verify.lean index b04c557882..621769f17c 100644 --- a/Strata/Languages/C_Simp/Verify.lean +++ b/Strata/Languages/C_Simp/Verify.lean @@ -172,7 +172,7 @@ def loop_elimination_function(f : C_Simp.Function) : Core.Procedure := outputs := [("return", f.ret_ty)]}, spec := {preconditions := core_preconditions, postconditions := core_postconditions}, - body := f.body.map loop_elimination_statement} + body := .structured (f.body.map loop_elimination_statement)} def loop_elimination(program : C_Simp.Program) : Core.Program := diff --git a/Strata/Languages/Core/CallGraph.lean b/Strata/Languages/Core/CallGraph.lean index 0ddbc39c53..17f7fc581e 100644 --- a/Strata/Languages/Core/CallGraph.lean +++ b/Strata/Languages/Core/CallGraph.lean @@ -253,7 +253,7 @@ end /-- Extract all procedure calls from a procedure's body -/ def extractCallsFromProcedure (proc : Procedure) : List String := - extractCallsFromStatements proc.body + extractCallsFromStatements proc.body.toStmts @[expose] abbrev ProcedureCG := CallGraph @[expose] abbrev FunctionCG := CallGraph diff --git a/Strata/Languages/Core/Core.lean b/Strata/Languages/Core/Core.lean index e600ad3601..e085c78716 100644 --- a/Strata/Languages/Core/Core.lean +++ b/Strata/Languages/Core/Core.lean @@ -95,7 +95,7 @@ def buildEnv (options : VerifyOptions) (program : Program) for func in funcs do E ← E.addFactoryFunc func | .distinct _ es _ => E := { E with distinct := es :: E.distinct } | .proc proc _ => - for stmt in proc.body.flatMap collectFuncDecls do + for stmt in proc.body.toStmts.flatMap collectFuncDecls do match E.exprEnv.addFactoryFunc stmt with | .ok σ' => E := { E with exprEnv := σ' } | .error _ => pure () @@ -174,7 +174,7 @@ def toCoreProofObligationProgram (options : VerifyOptions) (program : Program) | some name => [Decl.proc { header := { name := name, typeArgs := [], inputs := [], outputs := [] }, spec := { preconditions := [], postconditions := [] }, - body := body + body := .structured body } .empty] | none => [] diff --git a/Strata/Languages/Core/DDMTransform/FormatCore.lean b/Strata/Languages/Core/DDMTransform/FormatCore.lean index 639c5f355f..22a5a941ff 100644 --- a/Strata/Languages/Core/DDMTransform/FormatCore.lean +++ b/Strata/Languages/Core/DDMTransform/FormatCore.lean @@ -938,7 +938,7 @@ def procToCST {M} [Inhabited M] (proc : Core.Procedure) : ToCSTM M (Command M) : ⟨default, none⟩ else ⟨default, some (Spec.spec_mk default specAnn)⟩ - let bodyCST ← blockToCST proc.body + let bodyCST ← blockToCST proc.body.toStmts let body : Ann (Option (CoreDDM.Block M)) M := ⟨default, some bodyCST⟩ modify ToCSTContext.popScope pure (.command_procedure default name typeArgs arguments spec body) diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index aa088ca54f..d463a16ba9 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -1583,7 +1583,7 @@ def translateProcedure (p : Program) (bindings : TransBindings) (op : Operation) outputs := ret }, spec := { preconditions := requires, postconditions := ensures }, - body := body + body := .structured body } md, origBindings) @@ -1602,7 +1602,7 @@ def translateBlockCommand (p : Program) (bindings : TransBindings) (op : Operati outputs := [] }, spec := { preconditions := [], postconditions := [] }, - body := body + body := .structured body } md, bindings) diff --git a/Strata/Languages/Core/ObligationExtraction.lean b/Strata/Languages/Core/ObligationExtraction.lean index 34eb371291..a61eeba042 100644 --- a/Strata/Languages/Core/ObligationExtraction.lean +++ b/Strata/Languages/Core/ObligationExtraction.lean @@ -103,7 +103,7 @@ def extractObligations (p : Program) : Except String (ProofObligations Expressio .ok (axiomPc ++ [.assumption a.name a.e], allObs) | .proc proc _md => do let globalPc : PathConditions Expression := [axiomPc] - let obs ← extractFromStatements globalPc proc.body + let obs ← extractFromStatements globalPc proc.body.toStmts .ok (axiomPc, allObs ++ obs) | _ => .ok (axiomPc, allObs) return allObs diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 154711b3c4..4151d40c1d 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -7,6 +7,7 @@ module public import Strata.DL.Imperative.HasVars +public import Strata.DL.Imperative.BasicBlock public import Strata.Languages.Core.Statement --------------------------------------------------------------------- @@ -278,21 +279,43 @@ def Procedure.Spec.updateCheckExprs | e :: erest, c :: crest => { c with expr := e } :: go erest crest +/-- The body of a Core procedure: either structured (a list of statements) or +unstructured (a control-flow graph of basic blocks). An empty structured body +(`structured []`) represents an abstract/bodyless procedure. -/ +inductive Procedure.Body where + /-- A structured body: a sequential list of statements. -/ + | structured : List Statement → Procedure.Body + /-- An unstructured body: a control-flow graph of deterministic basic blocks. + Labels are strings; each block contains Core commands and ends with a + deterministic transfer (conditional goto or finish). -/ + | cfg : Imperative.CFG String (Imperative.DetBlock String Command Expression) → Procedure.Body + deriving Inhabited + +/-- Get the structured statements from a body, or `[]` if unstructured. -/ +def Procedure.Body.toStmts : Procedure.Body → List Statement + | .structured ss => ss + | .cfg _ => [] + +/-- Is this body empty (abstract)? -/ +def Procedure.Body.isEmpty : Procedure.Body → Bool + | .structured ss => ss.isEmpty + | .cfg _ => false + /-- A Strata Core procedure: the main verification unit. A procedure consists of a header (name, type parameters, input/output signatures), -a specification (contract), and an optional body (list of statements). If the body -is empty, the procedure is abstract and can only be reasoned about via its contract. -If the body is present, it is verified against the specification. +a specification (contract), and an optional body (list of statements or a CFG). +If the body is empty, the procedure is abstract and can only be reasoned about +via its contract. If the body is present, it is verified against the specification. -/ structure Procedure where /-- The procedure header: name, type parameters, and parameter signatures. -/ header : Procedure.Header /-- The procedure's contract: modifies clause, preconditions, and postconditions. -/ spec : Procedure.Spec - /-- The procedure body. Empty for abstract (bodyless) procedures. -/ - body : List Statement + /-- The procedure body. -/ + body : Procedure.Body := .structured [] deriving Inhabited --------------------------------------------------------------------- @@ -306,21 +329,39 @@ def Procedure.modifiedVars (p : Procedure) : List Expression.Ident := def Procedure.getVars (p : Procedure) : List Expression.Ident := (p.spec.postconditions.values.map Procedure.Check.expr).flatMap HasVarsPure.getVars ++ (p.spec.preconditions.values.map Procedure.Check.expr).flatMap HasVarsPure.getVars ++ - p.body.flatMap HasVarsPure.getVars |> List.filter (not $ Membership.mem p.header.inputs.keys ·) + p.body.toStmts.flatMap HasVarsPure.getVars |> List.filter (not $ Membership.mem p.header.inputs.keys ·) instance : HasVarsPure Expression Procedure where getVars := Procedure.getVars +instance : HasVarsPure Expression Procedure.Body where + getVars b := match b with + | .structured ss => HasVarsPure.getVars ss + | .cfg _ => [] + +instance : HasVarsImp Expression Procedure.Body where + definedVars b := match b with + | .structured ss => HasVarsImp.definedVars ss + | .cfg _ => [] + modifiedVars b := match b with + | .structured ss => HasVarsImp.modifiedVars ss + | .cfg _ => [] + instance : HasVarsImp Expression Procedure where definedVars := Procedure.definedVars modifiedVars := Procedure.modifiedVars def Procedure.eraseTypes (p : Procedure) : Procedure := - { p with body := Statements.eraseTypes p.body, spec := p.spec } + let body' := match p.body with + | .structured ss => .structured (Statements.eraseTypes ss) + | .cfg c => .cfg c + { p with body := body', spec := p.spec } -/-- Remove all metadata from procedure. -/ def Procedure.stripMetaData (p : Procedure) : Procedure := - { p with body := Imperative.Block.stripMetaData p.body } + let body' := match p.body with + | .structured ss => .structured (Imperative.Block.stripMetaData ss) + | .cfg c => .cfg c + { p with body := body' } /-- Transitive variable lookup for procedures. This is a version that looks into the body, diff --git a/Strata/Languages/Core/ProcedureEval.lean b/Strata/Languages/Core/ProcedureEval.lean index 9ea328f41b..bcfb5defcc 100644 --- a/Strata/Languages/Core/ProcedureEval.lean +++ b/Strata/Languages/Core/ProcedureEval.lean @@ -113,7 +113,7 @@ def eval (E : Env) (p : Procedure) : Env × Statistics := /- the assumptions from preconditions are set to have empty metadata -/ (.assume label check.expr check.md)) p.spec.preconditions - let (ssEs, evalStats) := Statement.eval E old_g_subst (precond_assumes ++ p.body ++ postcond_asserts) + let (ssEs, evalStats) := Statement.eval E old_g_subst (precond_assumes ++ p.body.toStmts ++ postcond_asserts) (mergeResults E (ssEs.map (fun sE => fixupError sE)), evalStats) --------------------------------------------------------------------- diff --git a/Strata/Languages/Core/ProcedureType.lean b/Strata/Languages/Core/ProcedureType.lean index 9b5b9bdbed..e63a8fbda8 100644 --- a/Strata/Languages/Core/ProcedureType.lean +++ b/Strata/Languages/Core/ProcedureType.lean @@ -30,8 +30,8 @@ private def checkNoDuplicates (proc : Procedure) (sourceLoc : FileRange) : private def checkModificationRights (proc : Procedure) (sourceLoc : FileRange) : Except DiagnosticModel Unit := do - let modifiedVars := (Imperative.Block.modifiedVars proc.body).eraseDups - let definedVars := (Imperative.Block.definedVars proc.body).eraseDups + let modifiedVars := (Imperative.Block.modifiedVars proc.body.toStmts).eraseDups + let definedVars := (Imperative.Block.definedVars proc.body.toStmts).eraseDups let allowedVars := proc.header.outputs.keys ++ definedVars let disallowed := modifiedVars.filter (fun v => v ∉ allowedVars) if !disallowed.isEmpty then @@ -111,7 +111,7 @@ def typeCheck (C : Core.Expression.TyContext) (Env : Core.Expression.TyEnv) (p : -- Type check body. -- Note that `Statement.typeCheck` already reports source locations in -- error messages. - let (annotated_body, finalEnv) ← Statement.typeCheck C envAfterPostconds p (.some proc) proc.body + let (annotated_body, finalEnv) ← Statement.typeCheck C envAfterPostconds p (.some proc) proc.body.toStmts -- Remove formals and returns from the context -- they ought to be local to -- the procedure body. @@ -126,7 +126,7 @@ def typeCheck (C : Core.Expression.TyContext) (Env : Core.Expression.TyEnv) (p : outputs := out_mty_sig } let new_spec := { proc.spec with preconditions := finalPreconditions, postconditions := finalPostconditions } - let new_proc := { proc with header := new_hdr, spec := new_spec, body := annotated_body } + let new_proc := { proc with header := new_hdr, spec := new_spec, body := .structured annotated_body } return (new_proc, finalEnv) diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 267dad9452..58c11d95a1 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -813,7 +813,7 @@ def Command.runCall (lhs : List Expression.Ident) (procName : String) (args : Li addError := fun E msg => CmdEval.updateError E (.Misc msg) } let config : Imperative.RunConfig Expression Command Env := - .stmts proc.body callEnv + .stmts proc.body.toStmts callEnv let configAfter := Imperative.runStmt ops fuel' config match configAfter with | .terminal callEnv' => diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 513a72a11f..42cfdfd96c 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -318,7 +318,7 @@ inductive EvalCommand (π : String → Option Procedure) (φ : CoreEval → Pure isDefinedOver (HasVarsPure.getVars) σAO pre ∧ δ σAO pre = .some HasBool.tt) → CoreStepStar π φ - (.stmts p.body ⟨σAO, δ, false⟩) + (.stmts p.body.toStmts ⟨σAO, δ, false⟩) (.terminal ρ') → (∀ post, (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → isDefinedOver (HasVarsPure.getVars) σAO post ∧ diff --git a/Strata/Languages/Core/WF.lean b/Strata/Languages/Core/WF.lean index 85fc2f110f..6c4a77396c 100644 --- a/Strata/Languages/Core/WF.lean +++ b/Strata/Languages/Core/WF.lean @@ -138,15 +138,15 @@ structure WFAxiomDeclarationProp (p : Program) (f : Axiom) : Prop where structure WFDistinctDeclarationProp (p : Program) (l : Expression.Ident) (es : List (Expression.Expr)) : Prop where structure WFProcedureProp (p : Program) (d : Procedure) : Prop where - wfstmts : WFStatementsProp p d.body - wfloclnd : (HasVarsImp.definedVars (P:=Expression) d.body).Nodup + wfstmts : WFStatementsProp p d.body.toStmts + wfloclnd : (HasVarsImp.definedVars (P:=Expression) d.body.toStmts).Nodup inputsNodup : (ListMap.keys d.header.inputs).Nodup outputsNodup : (ListMap.keys d.header.outputs).Nodup ioNotOld : ∀ id ∈ ListMap.keys d.header.inputs ++ ListMap.keys d.header.outputs, ∀ x, id ≠ CoreIdent.mkOld x 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 + bodyExitsCovered : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks [] d.body.toStmts structure WFFunctionProp (p : Program) (f : Function) : Prop where structure WFRecFuncBlockProp (p : Program) (fs : List Function) : Prop where diff --git a/Strata/Languages/Laurel/LaurelToCoreTranslator.lean b/Strata/Languages/Laurel/LaurelToCoreTranslator.lean index 1a9c78e081..f0c244ea14 100644 --- a/Strata/Languages/Laurel/LaurelToCoreTranslator.lean +++ b/Strata/Languages/Laurel/LaurelToCoreTranslator.lean @@ -579,7 +579,7 @@ def translateProcedure (proc : Procedure) : TranslateM Core.Procedure := do -- Wrap body in a labeled block so early returns (exit) work correctly. let body : List Core.Statement := [.block "$body" bodyStmts mdWithUnknownLoc] let spec : Core.Procedure.Spec := { preconditions, postconditions } - return { header, spec, body } + return { header, spec, body := .structured body } def translateInvokeOnAxiom (proc : Procedure) (trigger : StmtExprMd) : TranslateM (Option Core.Decl) := do diff --git a/Strata/Languages/Python/PythonToCore.lean b/Strata/Languages/Python/PythonToCore.lean index cceb2c563e..9f70811581 100644 --- a/Strata/Languages/Python/PythonToCore.lean +++ b/Strata/Languages/Python/PythonToCore.lean @@ -792,7 +792,7 @@ def translateFunctions (a : Array (Python.stmt SourceRange)) (translation_ctx: T inputs := [], outputs := [("maybe_except", (.tcons "ExceptOrNone" []))]}, spec := default, - body := varDecls ++ [.block "end" ((ArrPyStmtToCore translation_ctx body.val).fst) .empty] + body := .structured (varDecls ++ [.block "end" ((ArrPyStmtToCore translation_ctx body.val).fst) .empty]) } some (.proc proc .empty) | _ => none) @@ -823,7 +823,7 @@ def pythonFuncToCore (name : String) (args: List (String × String)) (body: Arra inputs, outputs}, spec, - body + body := .structured body } def unpackPyArguments (args: Python.arguments SourceRange) : List (String × String) := diff --git a/Strata/Transform/ANFEncoder.lean b/Strata/Transform/ANFEncoder.lean index 39390bb321..5ff937800c 100644 --- a/Strata/Transform/ANFEncoder.lean +++ b/Strata/Transform/ANFEncoder.lean @@ -217,8 +217,8 @@ def anfEncodeProgram (p : Program) : Bool × Program := let (revDecls, _, changed) := p.decls.foldl (fun (acc, idx, changed) decl => match decl with | .proc proc md => - let (body', idx') := anfEncodeBody proc.body idx - (.proc { proc with body := body' } md :: acc, idx', changed || idx' > idx) + let (body', idx') := anfEncodeBody proc.body.toStmts idx + (.proc { proc with body := .structured body' } md :: acc, idx', changed || idx' > idx) | other => (other :: acc, idx, changed) ) ([], 0, false) (changed, { decls := revDecls.reverse }) diff --git a/Strata/Transform/CoreSpecification.lean b/Strata/Transform/CoreSpecification.lean index 2b5e4fa475..9a2835a972 100644 --- a/Strata/Transform/CoreSpecification.lean +++ b/Strata/Transform/CoreSpecification.lean @@ -82,7 +82,7 @@ variable (φ : CoreEval → PureFunc Expression → CoreEval) (proc : Procedure) (a : Imperative.AssertId Expression) : Prop := Imperative.Specification.AssertValidWhen (Specification.Lang.core π φ) - (ProcEnvWF proc) (Stmt.block "" proc.body #[]) a + (ProcEnvWF proc) (Stmt.block "" proc.body.toStmts #[]) a /-- A procedure is correct with respect to its specification. @@ -143,7 +143,7 @@ structure ProcedureCorrect (proc : Procedure) (p : Program) : Prop where WF.WFProcedureProp p proc → ∀ (ρ₀ ρ' : Env Expression), ProcEnvWF proc ρ₀ → - CoreStepStar π φ (.stmts proc.body ρ₀) (.terminal ρ') → + CoreStepStar π φ (.stmts proc.body.toStmts ρ₀) (.terminal ρ') → (∀ (label : CoreLabel) (check : Procedure.Check), (label, check) ∈ proc.spec.postconditions.toList → check.attr = Procedure.CheckAttr.Default → diff --git a/Strata/Transform/CoreTransform.lean b/Strata/Transform/CoreTransform.lean index d621676ee0..d5a614b7de 100644 --- a/Strata/Transform/CoreTransform.lean +++ b/Strata/Transform/CoreTransform.lean @@ -332,10 +332,10 @@ def runProgram currentProcedureName := .some proc.header.name.1 }) - let (changed, new_body) ← runStmtsRec f proc.body + let (changed, new_body) ← runStmtsRec f proc.body.toStmts if changed then - newDecls := newDecls.set i (Decl.proc { proc with body := new_body } md) + newDecls := newDecls.set i (Decl.proc { proc with body := .structured new_body } md) anyChanged := true modify (fun σ => { σ with currentProgram := .some { decls := newDecls } diff --git a/Strata/Transform/LoopElim.lean b/Strata/Transform/LoopElim.lean index efbee4a8cd..160e4e09e7 100644 --- a/Strata/Transform/LoopElim.lean +++ b/Strata/Transform/LoopElim.lean @@ -241,8 +241,8 @@ def loopElim (p : Program) : Program × Statistics := let (decls, stats) := p.decls.foldl (fun (acc, stats) d => match d with | .proc proc md => - let (body, st) := StateT.run (Block.removeLoopsM proc.body) {} - ((.proc { proc with body := body } md) :: acc, stats.merge st.statistics) + let (body, st) := StateT.run (Block.removeLoopsM proc.body.toStmts) {} + ((.proc { proc with body := .structured body } md) :: acc, stats.merge st.statistics) | other => (other :: acc, stats)) ([], {}) ({ decls := decls.reverse }, stats) diff --git a/Strata/Transform/PrecondElim.lean b/Strata/Transform/PrecondElim.lean index 4c483b65e9..4f1017fafe 100644 --- a/Strata/Transform/PrecondElim.lean +++ b/Strata/Transform/PrecondElim.lean @@ -174,7 +174,7 @@ def mkContractWFProc (F : @Lambda.Factory CoreLParams) (proc : Procedure) some <| .proc { header := { proc.header with name := ⟨wfProcName name, ()⟩, noFilter := true } spec := { preconditions := [], postconditions := [] } - body := body + body := .structured body } md else none @@ -230,7 +230,7 @@ def mkFuncWFProc (F : @Lambda.Factory CoreLParams) (func : Function) noFilter := true } spec := { preconditions := [], postconditions := [] } - body := wfStmts + body := .structured wfStmts } md) /-! ## Statement transformation -/ @@ -377,16 +377,16 @@ where match d with | .proc proc md => do let F ← getFactory - let (changed, body') ← transformStmts proc.body + let (changed, body') ← transformStmts proc.body.toStmts setFactory F - let proc' := { proc with body := body' } + let proc' := { proc with body := .structured body' } let procDecl := Decl.proc proc' md let (changed', rest') ← transformDecls rest match mkContractWFProc F proc md with | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => p.body.length | _ => 0) + (match wfDecl with | .proc p _ => p.body.toStmts.length | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty proc.header.name)) return (true, wfDecl :: procDecl :: rest') @@ -406,7 +406,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => p.body.length | _ => 0) + (match wfDecl with | .proc p _ => p.body.toStmts.length | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty func.name)) return (true, wfDecl :: funcDecl :: rest') @@ -431,7 +431,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => p.body.length | _ => 0) + (match wfDecl with | .proc p _ => p.body.toStmts.length | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty func.name)) return some wfDecl diff --git a/Strata/Transform/ProcBodyVerify.lean b/Strata/Transform/ProcBodyVerify.lean index aa68c38a96..25441dbeab 100644 --- a/Strata/Transform/ProcBodyVerify.lean +++ b/Strata/Transform/ProcBodyVerify.lean @@ -89,7 +89,7 @@ open Core Imperative Transform let assumes := requiresToAssumes proc.spec.preconditions -- Wrap body in labeled block - let bodyBlock := Stmt.block bodyLabel proc.body #[] + let bodyBlock := Stmt.block bodyLabel proc.body.toStmts #[] -- Convert postconditions to asserts let asserts := ensuresToAsserts proc.spec.postconditions diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index cf64ee7633..c2e3a4651b 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -461,7 +461,7 @@ theorem procToVerifyStmt_structure (h_wf_proc : WF.WFProcedureProp p proc) : ∃ (prefixStmts : List Statement), verifyStmt = Stmt.block s!"verify_{proc.header.name.name}" - (prefixStmts ++ [Stmt.block s!"body_{proc.header.name.name}" proc.body #[]] ++ + (prefixStmts ++ [Stmt.block s!"body_{proc.header.name.name}" proc.body.toStmts #[]] ++ ensuresToAsserts proc.spec.postconditions) #[] ∧ (∀ s ∈ prefixStmts, ∃ c, s = Stmt.cmd c) ∧ (∀ ρ₀, Core.Specification.ProcEnvWF proc ρ₀ → @@ -656,7 +656,7 @@ theorem procBodyVerify_procedureCorrect verifyStmt context (block verifyLabel > seq > block bodyLabel). -/ have h_embed_body : ∀ ρ₀ (h_wf : Specification.ProcEnvWF proc ρ₀) (cfg : CoreConfig), - CoreStepStar π φ (.stmts proc.body ρ₀) cfg → + CoreStepStar π φ (.stmts proc.body.toStmts ρ₀) cfg → ∃ ρ_init, StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt verifyStmt ρ_init) @@ -712,7 +712,7 @@ theorem procBodyVerify_procedureCorrect -- Unified helper: all asserts reachable from proc.body are valid have body_asserts_valid : ∀ ρ₀ (h_wf : Specification.ProcEnvWF proc ρ₀) (a : AssertId Expression) (cfg : CoreConfig), - CoreStepStar π φ (.stmts proc.body ρ₀) cfg → + CoreStepStar π φ (.stmts proc.body.toStmts ρ₀) cfg → coreIsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt := by intro ρ₀ h_wf a cfg h_body h_assert @@ -731,19 +731,19 @@ theorem procBodyVerify_procedureCorrect simp only [Specification.Lang.core, Specification.Lang.imperative] intro ρ₀ cfg (h_wf : Specification.ProcEnvWF proc ρ₀) (h_body : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmt (Stmt.block "" proc.body #[]) ρ₀) cfg) + (.stmt (Stmt.block "" proc.body.toStmts #[]) ρ₀) cfg) (h_assert : coreIsAtAssert cfg a) -- Extract first step: .stmt (block "" body #[]) ρ₀ → .block "" (.stmts body ρ₀) have h_block_star : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.block "" (.stmts proc.body ρ₀)) cfg := by + (.block "" (.stmts proc.body.toStmts ρ₀)) cfg := by cases h_body with | refl => simp [coreIsAtAssert] at h_assert | step _ _ _ hstep hrest => cases hstep; exact hrest -- Body never exits (from WFProcedureProp.bodyExitsCovered) have h_no_exit : ∀ lbl ρ', ¬ StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmts proc.body ρ₀) (.exiting lbl ρ') := + (.stmts proc.body.toStmts ρ₀) (.exiting lbl ρ') := block_exitsCoveredByBlocks_noEscape Expression (EvalCommand π φ) (EvalPureFunc φ) - proc.body h_wf_proc.bodyExitsCovered ρ₀ + proc.body.toStmts h_wf_proc.bodyExitsCovered ρ₀ -- cfg is not terminal or exiting (has an assert) have h_nt : ∀ ρ', cfg ≠ .terminal ρ' := by intro ρ' heq; subst heq; exact coreIsAtAssert_not_terminal ρ' a h_assert @@ -765,18 +765,18 @@ theorem procBodyVerify_procedureCorrect obtain ⟨ρ_init, h_prefix⟩ := h_prefix_trace ρ₀ h_wf -- h_valid: all asserts in body from ρ₀ evaluate to true have h_valid : ∀ (a : AssertId Expression) (cfg : CoreConfig), - CoreStepStar π φ (.stmts proc.body ρ₀) cfg → + CoreStepStar π φ (.stmts proc.body.toStmts ρ₀) cfg → coreIsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt := fun a cfg h h' => body_asserts_valid ρ₀ h_wf a cfg h h' -- hasFailure = false have h_nf' : ρ'.hasFailure = Bool.false := Core.core_noFailure_preserved π φ - (.stmts proc.body ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term + (.stmts proc.body.toStmts ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term -- wfBool preservation have h_wfb_term : WellFormedSemanticEvalBool ρ'.eval := Core.core_wfBool_preserved π φ h_wf_ext - (.stmts proc.body ρ₀) (.terminal ρ') h_wf.wfBool h_term + (.stmts proc.body.toStmts ρ₀) (.terminal ρ') h_wf.wfBool h_term have h_to_post : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt verifyStmt ρ_init) (.block verifyLabel (.stmts postAsserts ρ')) := by diff --git a/Strata/Transform/ProcedureInlining.lean b/Strata/Transform/ProcedureInlining.lean index 38629b6399..cc3842701d 100644 --- a/Strata/Transform/ProcedureInlining.lean +++ b/Strata/Transform/ProcedureInlining.lean @@ -94,13 +94,13 @@ private def renameAllLocalNames (c:Procedure) let proc_name := c.header.name.name -- Make a map for renaming local variables - let lhs_vars := List.flatMap (fun (s:Statement) => s.definedVars) c.body + let lhs_vars := List.flatMap (fun (s:Statement) => s.definedVars) c.body.toStmts let lhs_vars := lhs_vars ++ c.header.inputs.unzip.fst ++ c.header.outputs.unzip.fst let var_map <- genOldToFreshIdMappings lhs_vars var_map proc_name -- Make a map for renaming label names - let labels := List.flatMap (fun s => Statement.labels s) c.body + let labels := List.flatMap (fun s => Statement.labels s) c.body.toStmts -- Reuse genOldToFreshIdMappings by introducing dummy data to Identifier let label_ids:List Expression.Ident := labels.map (fun s => { name:=s, metadata := () }) @@ -117,7 +117,7 @@ private def renameAllLocalNames (c:Procedure) let s := Statement.substFvar s old_id (.fvar () new_id .none) let s := Statement.renameLhs s old_id new_id Statement.replaceLabels s label_map) - s0) c.body + s0) c.body.toStmts let new_header := { c.header with inputs := c.header.inputs.map (fun (id,ty) => match var_map.find? id with @@ -128,7 +128,7 @@ private def renameAllLocalNames (c:Procedure) | .some id' => (id',ty) | .none => panic! "unreachable") } - return ({ c with body := new_body, header := new_header }, var_map) + return ({ c with body := .structured new_body, header := new_header }, var_map) /-- Update the call graph after inlining one f(caller) -> g(callee) invocation. -/ @@ -271,7 +271,7 @@ def inlineCallCmd let stmts:List (Imperative.Stmt Core.Expression Core.Command) := inputInits ++ outputInits - ++ Block.setCallSiteMetadata proc.body md + ++ Block.setCallSiteMetadata proc.body.toStmts md ++ outputSetStmts -- Update CallGraph if available diff --git a/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean b/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean index a33056b01b..1147ade06e 100644 --- a/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean +++ b/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean @@ -350,7 +350,7 @@ private def coreToGotoJsonWithSummary (p : Strata.Program) (summary : String) : let Env := Lambda.TEnv.default let procs := cprog.decls.filterMap fun d => d.getProc? let p := procs[0]! - let p' : Core.Procedure := { p with body := injectPropertySummary p.body summary } + let p' : Core.Procedure := { p with body := .structured (injectPropertySummary p.body.toStmts summary) } let pname := Core.CoreIdent.toPretty p'.header.name let ctx ← procedureToGotoCtx Env p' let json ← (CoreToGOTO.CProverGOTO.Context.toJson pname ctx.1).mapError (fun e => f!"{e}") diff --git a/StrataTest/Languages/Boole/global_readonly_call.lean b/StrataTest/Languages/Boole/global_readonly_call.lean index a0445f8753..d79c5a522c 100644 --- a/StrataTest/Languages/Boole/global_readonly_call.lean +++ b/StrataTest/Languages/Boole/global_readonly_call.lean @@ -66,7 +66,7 @@ private def callHelper (p : Strata.Program) : Except String (List String) := do return cp.decls.filterMap fun d => match d with | .proc p _ => - p.body.findSome? fun + p.body.toStmts.findSome? fun | .block _ stmts _ => stmts.findSome? fun | .cmd (.call pname args _) => some s!"call {pname}({", ".intercalate (args.map fmtCallArg)})" @@ -141,41 +141,41 @@ spec { VCs: -Label: inc_ensures_1_2418 +Label: inc_ensures_1_2426 Property: assert Assumptions: -inc_requires_0_2400: z@1 > 0 +inc_requires_0_2408: z@1 > 0 Obligation: true -Label: callElimAssert_inc_requires_0_2400_6 +Label: callElimAssert_inc_requires_0_2408_6 Property: assert Assumptions: -main_caller_requires_2_2534: z@3 == 10 -main_caller_requires_3_2554: g@3 == 0 +main_caller_requires_2_2542: z@3 == 10 +main_caller_requires_3_2562: g@3 == 0 Obligation: z@3 > 0 -Label: main_caller_ensures_4_2573 +Label: main_caller_ensures_4_2581 Property: assert Assumptions: -main_caller_requires_2_2534: z@3 == 10 -main_caller_requires_3_2554: g@3 == 0 -callElimAssume_inc_ensures_1_2418_7: g@5 == g@3 + 5 + z@5 +main_caller_requires_2_2542: z@3 == 10 +main_caller_requires_3_2562: g@3 == 0 +callElimAssume_inc_ensures_1_2426_7: g@5 == g@3 + 5 + z@5 Obligation: g@5 == 15 --- info: -Obligation: inc_ensures_1_2418 +Obligation: inc_ensures_1_2426 Property: assert Result: ✅ pass -Obligation: callElimAssert_inc_requires_0_2400_6 +Obligation: callElimAssert_inc_requires_0_2408_6 Property: assert Result: ✅ pass -Obligation: main_caller_ensures_4_2573 +Obligation: main_caller_ensures_4_2581 Property: assert Result: ❓ unknown Model: diff --git a/StrataTest/Languages/Core/Examples/Loops.lean b/StrataTest/Languages/Core/Examples/Loops.lean index 729c9c9a23..dbd4f71190 100644 --- a/StrataTest/Languages/Core/Examples/Loops.lean +++ b/StrataTest/Languages/Core/Examples/Loops.lean @@ -15,7 +15,7 @@ def singleCFG (p : Program) (n : Nat) : Imperative.CFG String let corePgm : Core.Program := TransM.run Inhabited.default (translateProgram p) |>.fst let proc := match corePgm.decls[n]? with | .some (.proc p _) => p | _ => Inhabited.default - Imperative.stmtsToCFG proc.body + Imperative.stmtsToCFG proc.body.toStmts --------------------------------------------------------------------- diff --git a/StrataTest/Languages/Core/Tests/ProcedureTypeTests.lean b/StrataTest/Languages/Core/Tests/ProcedureTypeTests.lean index f970ca1270..fe3912e4f0 100644 --- a/StrataTest/Languages/Core/Tests/ProcedureTypeTests.lean +++ b/StrataTest/Languages/Core/Tests/ProcedureTypeTests.lean @@ -36,7 +36,7 @@ info: ok: (procedure P (x : int, out y : int) outputs := [("y", mty[int])] }, spec := { preconditions := [("0_lt_x", ⟨eb[((~Int.Lt #0) x)], .Default, #[]⟩)], postconditions := [("ret_y_lt_0", ⟨eb[((~Int.Lt y) #0)], .Default, #[]⟩)] }, - body := [ + body := .structured [ Statement.set "y" eb[((~Int.Sub #0) x)] .empty ] } diff --git a/StrataTest/Languages/Core/Tests/ProgramEvalTests.lean b/StrataTest/Languages/Core/Tests/ProgramEvalTests.lean index d9ee5b06a5..f7f2b155c4 100644 --- a/StrataTest/Languages/Core/Tests/ProgramEvalTests.lean +++ b/StrataTest/Languages/Core/Tests/ProgramEvalTests.lean @@ -404,7 +404,7 @@ Proof Obligation: spec := { preconditions := [("0_lt_x", ⟨eb[((~Int.Lt #0) x)], .Default, #[]⟩)], postconditions := [("ret_y_lt_0", ⟨eb[((~Int.Lt y) #0)], .Default, #[]⟩)] }, - body := [ + body := .structured [ Statement.set "y" eb[(~Int.Neg x)] .empty ] } diff --git a/StrataTest/Languages/Core/Tests/ProgramTypeTests.lean b/StrataTest/Languages/Core/Tests/ProgramTypeTests.lean index ea9c591c50..9a56d40530 100644 --- a/StrataTest/Languages/Core/Tests/ProgramTypeTests.lean +++ b/StrataTest/Languages/Core/Tests/ProgramTypeTests.lean @@ -30,7 +30,7 @@ def bad_prog : Program := { decls := [ spec := { preconditions := [], postconditions := [] }, - body := [ + body := .structured [ Statement.assert "test" eb[(~fooAliasVal == ~fooVal)] .empty ] } .empty @@ -60,7 +60,7 @@ def good_prog : Program := { decls := [ spec := { preconditions := [], postconditions := [] }, - body := [ + body := .structured [ Statement.assert "test" eb[(~fooAliasVal == ~fooVal)] .empty ] } .empty @@ -102,7 +102,7 @@ def outOfScopeVarProg : Program := { decls := [ spec := { preconditions := [], postconditions := [] }, - body := [ + body := .structured [ Statement.set "y" eb[((~Bool.Or x) x)] .empty, .ite (.det eb[(x == #true)]) [Statement.init "q" t[int] (.det eb[#0]) .empty, @@ -146,7 +146,7 @@ def polyFuncProg : Program := { decls := [ outputs := [] }, spec := { preconditions := [], postconditions := [] }, - body := [ + body := .structured [ -- var m : Map int bool; Statement.init "m" (.forAll [] (.tcons "Map" [.tcons "int" [], .tcons "bool" []])) Imperative.ExprOrNondet.nondet .empty, -- m := makePair(identity(42), identity(true)); diff --git a/StrataTest/Languages/Core/Tests/StatementTypeTests.lean b/StrataTest/Languages/Core/Tests/StatementTypeTests.lean index c635fb2184..489ec6e6e5 100644 --- a/StrataTest/Languages/Core/Tests/StatementTypeTests.lean +++ b/StrataTest/Languages/Core/Tests/StatementTypeTests.lean @@ -253,7 +253,7 @@ private def testProc : Procedure := inputs := [(⟨"x", ()⟩, .int)], outputs := [(⟨"x", ()⟩, .int), (⟨"y", ()⟩, .int)] }, spec := { preconditions := [], postconditions := [] }, - body := [] } + body := .structured [] } private def testProgram : Program := { decls := [.proc testProc .empty] } diff --git a/StrataTest/Transform/ProcedureInlining.lean b/StrataTest/Transform/ProcedureInlining.lean index 2697471f1f..728a01afef 100644 --- a/StrataTest/Transform/ProcedureInlining.lean +++ b/StrataTest/Transform/ProcedureInlining.lean @@ -215,13 +215,13 @@ def alphaEquivStatement (s1 s2: Core.Statement) (map:IdMap) end private def alphaEquiv (p1 p2:Core.Procedure):Except Format Bool := do - if p1.body.length ≠ p2.body.length then + if p1.body.toStmts.length ≠ p2.body.toStmts.length then .error (s!"# statements do not match: in {p1.header.name}, " - ++ s!"inlined fn one has {p1.body.length}" - ++ s!" whereas the answer has {p2.body.length}") + ++ s!"inlined fn one has {p1.body.toStmts.length}" + ++ s!" whereas the answer has {p2.body.toStmts.length}") else let newmap:IdMap := IdMap.mk ([], []) [] - let stmts := (p1.body.zip p2.body) + let stmts := (p1.body.toStmts.zip p2.body.toStmts) let m ← List.foldlM (fun (map:IdMap) (s1,s2) => alphaEquivStatement s1 s2 map) newmap stmts From cbeee723b4ad4bac77dd4d74b8876f9f9d955154 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 5 May 2026 13:55:26 -0700 Subject: [PATCH 02/57] eliminate toStmts and use pattern matching/error handling --- Strata/Backends/CBMC/CoreToCBMC.lean | 3 ++- .../Backends/CBMC/GOTO/CoreToCProverGOTO.lean | 7 +++-- .../CBMC/GOTO/CoreToGOTOPipeline.lean | 5 +++- Strata/Languages/Core/CallGraph.lean | 4 ++- Strata/Languages/Core/Core.lean | 2 +- .../Core/DDMTransform/FormatCore.lean | 4 ++- .../Languages/Core/ObligationExtraction.lean | 4 ++- Strata/Languages/Core/Procedure.lean | 22 +++++++++++----- Strata/Languages/Core/ProcedureEval.lean | 3 ++- Strata/Languages/Core/ProcedureType.lean | 8 +++--- Strata/Languages/Core/StatementEval.lean | 4 ++- Strata/Languages/Core/StatementSemantics.lean | 2 +- Strata/Languages/Core/WF.lean | 6 ++--- Strata/Transform/ANFEncoder.lean | 7 +++-- Strata/Transform/CoreSpecification.lean | 4 +-- Strata/Transform/CoreTransform.lean | 5 +++- Strata/Transform/LoopElim.lean | 7 +++-- Strata/Transform/PrecondElim.lean | 9 ++++--- Strata/Transform/ProcBodyVerify.lean | 3 ++- Strata/Transform/ProcBodyVerifyCorrect.lean | 20 +++++++------- Strata/Transform/ProcedureInlining.lean | 10 ++++--- .../Backends/CBMC/GOTO/E2E_CoreToGOTO.lean | 2 +- .../Languages/Boole/global_readonly_call.lean | 26 +++++++++---------- StrataTest/Languages/Core/Examples/Loops.lean | 2 +- StrataTest/Transform/ProcedureInlining.lean | 11 +++++--- 25 files changed, 112 insertions(+), 68 deletions(-) diff --git a/Strata/Backends/CBMC/CoreToCBMC.lean b/Strata/Backends/CBMC/CoreToCBMC.lean index 8b66190c5f..84b1c958d1 100644 --- a/Strata/Backends/CBMC/CoreToCBMC.lean +++ b/Strata/Backends/CBMC/CoreToCBMC.lean @@ -346,7 +346,8 @@ def createImplementationSymbolFromAST (func : Core.Procedure) : Except String CB -- For now, keep the hardcoded implementation but use function name from AST let loc : SourceLoc := { functionName := (func.header.name.toPretty), lineNum := "1" } - let stmtJsons ← (func.body.toStmts.mapM (stmtToJson (I:=CoreLParams) · loc)) + let bodyStmts := match func.body with | .structured ss => ss | .cfg _ => [] + let stmtJsons ← (bodyStmts.mapM (stmtToJson (I:=CoreLParams) · loc)) let implValue := Json.mkObj [ ("id", "code"), diff --git a/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean index a14fc59cef..0d29e03bff 100644 --- a/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean +++ b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean @@ -201,7 +201,10 @@ def transformToGoto (cprog : Core.Program) : Except Format CProverGOTO.Context : if !p.header.typeArgs.isEmpty then throw f!"[transformToGoto] Translation for polymorphic Strata Core procedures is unimplemented." - let cmds ← p.body.toStmts.mapM + let bodyStmts ← match p.body with + | .structured ss => pure ss + | .cfg _ => throw f!"CFG body not supported for GOTO translation" + let cmds ← bodyStmts.mapM (fun b => match b with | .cmd (.cmd c) => return c | _ => throw f!"[transformToGoto] We can process Strata Core commands only, not statements! \ @@ -218,7 +221,7 @@ def transformToGoto (cprog : Core.Program) : Except Format CProverGOTO.Context : let formals_renamed := formals.zip new_formals let formals_tys : Map String CProverGOTO.Ty := formals.zip formals_tys - let locals := (Imperative.Block.definedVars p.body.toStmts).map Core.CoreIdent.toPretty + let locals := (Imperative.Block.definedVars bodyStmts).map Core.CoreIdent.toPretty let new_locals := locals.map (fun l => CProverGOTO.mkLocalSymbol pname l) let locals_renamed := locals.zip new_locals diff --git a/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean b/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean index 421724bd72..47315e867a 100644 --- a/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean +++ b/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean @@ -259,7 +259,10 @@ def procedureToGotoCtx : Except Std.Format (CoreToGOTO.CProverGOTO.Context × List Core.Function) := do -- Lift local function declarations out of the body - let (liftedFuncs, body) ← collectFuncDecls p.body.toStmts + let bodyStmts ← match p.body with + | .structured ss => pure ss + | .cfg _ => throw f!"CFG body not supported for GOTO pipeline" + let (liftedFuncs, body) ← collectFuncDecls bodyStmts let pname := Core.CoreIdent.toPretty p.header.name if !p.header.typeArgs.isEmpty then .error f!"[procedureToGotoCtx] Polymorphic procedures unsupported." diff --git a/Strata/Languages/Core/CallGraph.lean b/Strata/Languages/Core/CallGraph.lean index 17f7fc581e..4f4cad139c 100644 --- a/Strata/Languages/Core/CallGraph.lean +++ b/Strata/Languages/Core/CallGraph.lean @@ -253,7 +253,9 @@ end /-- Extract all procedure calls from a procedure's body -/ def extractCallsFromProcedure (proc : Procedure) : List String := - extractCallsFromStatements proc.body.toStmts + match proc.body with + | .structured ss => extractCallsFromStatements ss + | .cfg _ => [] @[expose] abbrev ProcedureCG := CallGraph @[expose] abbrev FunctionCG := CallGraph diff --git a/Strata/Languages/Core/Core.lean b/Strata/Languages/Core/Core.lean index e085c78716..9ded48acec 100644 --- a/Strata/Languages/Core/Core.lean +++ b/Strata/Languages/Core/Core.lean @@ -95,7 +95,7 @@ def buildEnv (options : VerifyOptions) (program : Program) for func in funcs do E ← E.addFactoryFunc func | .distinct _ es _ => E := { E with distinct := es :: E.distinct } | .proc proc _ => - for stmt in proc.body.toStmts.flatMap collectFuncDecls do + for stmt in proc.body.stmts.flatMap collectFuncDecls do match E.exprEnv.addFactoryFunc stmt with | .ok σ' => E := { E with exprEnv := σ' } | .error _ => pure () diff --git a/Strata/Languages/Core/DDMTransform/FormatCore.lean b/Strata/Languages/Core/DDMTransform/FormatCore.lean index 22a5a941ff..34eb28f5a5 100644 --- a/Strata/Languages/Core/DDMTransform/FormatCore.lean +++ b/Strata/Languages/Core/DDMTransform/FormatCore.lean @@ -938,7 +938,9 @@ def procToCST {M} [Inhabited M] (proc : Core.Procedure) : ToCSTM M (Command M) : ⟨default, none⟩ else ⟨default, some (Spec.spec_mk default specAnn)⟩ - let bodyCST ← blockToCST proc.body.toStmts + let bodyCST ← match proc.body with + | .structured ss => blockToCST ss + | .cfg _ => blockToCST [] let body : Ann (Option (CoreDDM.Block M)) M := ⟨default, some bodyCST⟩ modify ToCSTContext.popScope pure (.command_procedure default name typeArgs arguments spec body) diff --git a/Strata/Languages/Core/ObligationExtraction.lean b/Strata/Languages/Core/ObligationExtraction.lean index a61eeba042..b90b8441e4 100644 --- a/Strata/Languages/Core/ObligationExtraction.lean +++ b/Strata/Languages/Core/ObligationExtraction.lean @@ -103,7 +103,9 @@ def extractObligations (p : Program) : Except String (ProofObligations Expressio .ok (axiomPc ++ [.assumption a.name a.e], allObs) | .proc proc _md => do let globalPc : PathConditions Expression := [axiomPc] - let obs ← extractFromStatements globalPc proc.body.toStmts + let obs ← match proc.body with + | .structured ss => extractFromStatements globalPc ss + | .cfg _ => .ok #[] .ok (axiomPc, allObs ++ obs) | _ => .ok (axiomPc, allObs) return allObs diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 4151d40c1d..e047913fbc 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -291,11 +291,23 @@ inductive Procedure.Body where | cfg : Imperative.CFG String (Imperative.DetBlock String Command Expression) → Procedure.Body deriving Inhabited -/-- Get the structured statements from a body, or `[]` if unstructured. -/ -def Procedure.Body.toStmts : Procedure.Body → List Statement +/-- Extract the structured statements, or error if the body is a CFG. -/ +def Procedure.Body.getStructured : Procedure.Body → Except String (List Statement) + | .structured ss => .ok ss + | .cfg _ => .error "expected structured body, got CFG" + +/-- Extract statements from a structured body, or `[]` for CFG. + Intended for use in Prop contexts where `Except` is inconvenient. -/ +@[simp, expose] def Procedure.Body.stmts : Procedure.Body → List Statement | .structured ss => ss | .cfg _ => [] +/-- Get variables referenced in the body. -/ +def Procedure.Body.getVars : Procedure.Body → List Expression.Ident + | .structured ss => ss.flatMap Imperative.HasVarsPure.getVars + | .cfg c => c.blocks.flatMap fun (_, blk) => + blk.cmds.flatMap Imperative.HasVarsPure.getVars + /-- Is this body empty (abstract)? -/ def Procedure.Body.isEmpty : Procedure.Body → Bool | .structured ss => ss.isEmpty @@ -329,15 +341,13 @@ def Procedure.modifiedVars (p : Procedure) : List Expression.Ident := def Procedure.getVars (p : Procedure) : List Expression.Ident := (p.spec.postconditions.values.map Procedure.Check.expr).flatMap HasVarsPure.getVars ++ (p.spec.preconditions.values.map Procedure.Check.expr).flatMap HasVarsPure.getVars ++ - p.body.toStmts.flatMap HasVarsPure.getVars |> List.filter (not $ Membership.mem p.header.inputs.keys ·) + p.body.getVars |> List.filter (not $ Membership.mem p.header.inputs.keys ·) instance : HasVarsPure Expression Procedure where getVars := Procedure.getVars instance : HasVarsPure Expression Procedure.Body where - getVars b := match b with - | .structured ss => HasVarsPure.getVars ss - | .cfg _ => [] + getVars := Procedure.Body.getVars instance : HasVarsImp Expression Procedure.Body where definedVars b := match b with diff --git a/Strata/Languages/Core/ProcedureEval.lean b/Strata/Languages/Core/ProcedureEval.lean index bcfb5defcc..2fd6d3b0cf 100644 --- a/Strata/Languages/Core/ProcedureEval.lean +++ b/Strata/Languages/Core/ProcedureEval.lean @@ -113,7 +113,8 @@ def eval (E : Env) (p : Procedure) : Env × Statistics := /- the assumptions from preconditions are set to have empty metadata -/ (.assume label check.expr check.md)) p.spec.preconditions - let (ssEs, evalStats) := Statement.eval E old_g_subst (precond_assumes ++ p.body.toStmts ++ postcond_asserts) + let bodyStmts := match p.body with | .structured ss => ss | .cfg _ => [] + let (ssEs, evalStats) := Statement.eval E old_g_subst (precond_assumes ++ bodyStmts ++ postcond_asserts) (mergeResults E (ssEs.map (fun sE => fixupError sE)), evalStats) --------------------------------------------------------------------- diff --git a/Strata/Languages/Core/ProcedureType.lean b/Strata/Languages/Core/ProcedureType.lean index e63a8fbda8..42bf81acd7 100644 --- a/Strata/Languages/Core/ProcedureType.lean +++ b/Strata/Languages/Core/ProcedureType.lean @@ -30,8 +30,9 @@ private def checkNoDuplicates (proc : Procedure) (sourceLoc : FileRange) : private def checkModificationRights (proc : Procedure) (sourceLoc : FileRange) : Except DiagnosticModel Unit := do - let modifiedVars := (Imperative.Block.modifiedVars proc.body.toStmts).eraseDups - let definedVars := (Imperative.Block.definedVars proc.body.toStmts).eraseDups + let bodyStmts ← proc.body.getStructured.mapError (fun e => DiagnosticModel.withRange sourceLoc f!"{e}") + let modifiedVars := (Imperative.Block.modifiedVars bodyStmts).eraseDups + let definedVars := (Imperative.Block.definedVars bodyStmts).eraseDups let allowedVars := proc.header.outputs.keys ++ definedVars let disallowed := modifiedVars.filter (fun v => v ∉ allowedVars) if !disallowed.isEmpty then @@ -111,7 +112,8 @@ def typeCheck (C : Core.Expression.TyContext) (Env : Core.Expression.TyEnv) (p : -- Type check body. -- Note that `Statement.typeCheck` already reports source locations in -- error messages. - let (annotated_body, finalEnv) ← Statement.typeCheck C envAfterPostconds p (.some proc) proc.body.toStmts + let bodyStmts := match proc.body with | .structured ss => ss | .cfg _ => [] + let (annotated_body, finalEnv) ← Statement.typeCheck C envAfterPostconds p (.some proc) bodyStmts -- Remove formals and returns from the context -- they ought to be local to -- the procedure body. diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 58c11d95a1..b62c54e300 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -812,8 +812,10 @@ def Command.runCall (lhs : List Expression.Ident) (procName : String) (args : Li hasError := fun E => E.error.isSome addError := fun E msg => CmdEval.updateError E (.Misc msg) } + let bodyStmts := match proc.body with + | .structured ss => ss | .cfg _ => [] let config : Imperative.RunConfig Expression Command Env := - .stmts proc.body.toStmts callEnv + .stmts bodyStmts callEnv let configAfter := Imperative.runStmt ops fuel' config match configAfter with | .terminal callEnv' => diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 42cfdfd96c..6d80a0c92b 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -318,7 +318,7 @@ inductive EvalCommand (π : String → Option Procedure) (φ : CoreEval → Pure isDefinedOver (HasVarsPure.getVars) σAO pre ∧ δ σAO pre = .some HasBool.tt) → CoreStepStar π φ - (.stmts p.body.toStmts ⟨σAO, δ, false⟩) + (.stmts p.body.stmts ⟨σAO, δ, false⟩) (.terminal ρ') → (∀ post, (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → isDefinedOver (HasVarsPure.getVars) σAO post ∧ diff --git a/Strata/Languages/Core/WF.lean b/Strata/Languages/Core/WF.lean index 6c4a77396c..010631b172 100644 --- a/Strata/Languages/Core/WF.lean +++ b/Strata/Languages/Core/WF.lean @@ -138,15 +138,15 @@ structure WFAxiomDeclarationProp (p : Program) (f : Axiom) : Prop where structure WFDistinctDeclarationProp (p : Program) (l : Expression.Ident) (es : List (Expression.Expr)) : Prop where structure WFProcedureProp (p : Program) (d : Procedure) : Prop where - wfstmts : WFStatementsProp p d.body.toStmts - wfloclnd : (HasVarsImp.definedVars (P:=Expression) d.body.toStmts).Nodup + wfstmts : WFStatementsProp p d.body.stmts + wfloclnd : (HasVarsImp.definedVars (P:=Expression) d.body.stmts).Nodup inputsNodup : (ListMap.keys d.header.inputs).Nodup outputsNodup : (ListMap.keys d.header.outputs).Nodup ioNotOld : ∀ id ∈ ListMap.keys d.header.inputs ++ ListMap.keys d.header.outputs, ∀ x, id ≠ CoreIdent.mkOld x 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.toStmts + bodyExitsCovered : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks [] d.body.stmts structure WFFunctionProp (p : Program) (f : Function) : Prop where structure WFRecFuncBlockProp (p : Program) (fs : List Function) : Prop where diff --git a/Strata/Transform/ANFEncoder.lean b/Strata/Transform/ANFEncoder.lean index 5ff937800c..e8c741ffa2 100644 --- a/Strata/Transform/ANFEncoder.lean +++ b/Strata/Transform/ANFEncoder.lean @@ -217,8 +217,11 @@ def anfEncodeProgram (p : Program) : Bool × Program := let (revDecls, _, changed) := p.decls.foldl (fun (acc, idx, changed) decl => match decl with | .proc proc md => - let (body', idx') := anfEncodeBody proc.body.toStmts idx - (.proc { proc with body := .structured body' } md :: acc, idx', changed || idx' > idx) + match proc.body with + | .structured ss => + let (body', idx') := anfEncodeBody ss idx + (.proc { proc with body := .structured body' } md :: acc, idx', changed || idx' > idx) + | .cfg _ => (.proc proc md :: acc, idx, changed) | other => (other :: acc, idx, changed) ) ([], 0, false) (changed, { decls := revDecls.reverse }) diff --git a/Strata/Transform/CoreSpecification.lean b/Strata/Transform/CoreSpecification.lean index 9a2835a972..f6f18dbdd2 100644 --- a/Strata/Transform/CoreSpecification.lean +++ b/Strata/Transform/CoreSpecification.lean @@ -82,7 +82,7 @@ variable (φ : CoreEval → PureFunc Expression → CoreEval) (proc : Procedure) (a : Imperative.AssertId Expression) : Prop := Imperative.Specification.AssertValidWhen (Specification.Lang.core π φ) - (ProcEnvWF proc) (Stmt.block "" proc.body.toStmts #[]) a + (ProcEnvWF proc) (Stmt.block "" proc.body.stmts #[]) a /-- A procedure is correct with respect to its specification. @@ -143,7 +143,7 @@ structure ProcedureCorrect (proc : Procedure) (p : Program) : Prop where WF.WFProcedureProp p proc → ∀ (ρ₀ ρ' : Env Expression), ProcEnvWF proc ρ₀ → - CoreStepStar π φ (.stmts proc.body.toStmts ρ₀) (.terminal ρ') → + CoreStepStar π φ (.stmts proc.body.stmts ρ₀) (.terminal ρ') → (∀ (label : CoreLabel) (check : Procedure.Check), (label, check) ∈ proc.spec.postconditions.toList → check.attr = Procedure.CheckAttr.Default → diff --git a/Strata/Transform/CoreTransform.lean b/Strata/Transform/CoreTransform.lean index d5a614b7de..3d62e93d1a 100644 --- a/Strata/Transform/CoreTransform.lean +++ b/Strata/Transform/CoreTransform.lean @@ -332,7 +332,10 @@ def runProgram currentProcedureName := .some proc.header.name.1 }) - let (changed, new_body) ← runStmtsRec f proc.body.toStmts + let bodyStmts ← match proc.body with + | .structured ss => pure ss + | .cfg _ => pure [] + let (changed, new_body) ← runStmtsRec f bodyStmts if changed then newDecls := newDecls.set i (Decl.proc { proc with body := .structured new_body } md) diff --git a/Strata/Transform/LoopElim.lean b/Strata/Transform/LoopElim.lean index 160e4e09e7..cb328493ca 100644 --- a/Strata/Transform/LoopElim.lean +++ b/Strata/Transform/LoopElim.lean @@ -241,8 +241,11 @@ def loopElim (p : Program) : Program × Statistics := let (decls, stats) := p.decls.foldl (fun (acc, stats) d => match d with | .proc proc md => - let (body, st) := StateT.run (Block.removeLoopsM proc.body.toStmts) {} - ((.proc { proc with body := .structured body } md) :: acc, stats.merge st.statistics) + match proc.body with + | .structured ss => + let (body, st) := StateT.run (Block.removeLoopsM ss) {} + ((.proc { proc with body := .structured body } md) :: acc, stats.merge st.statistics) + | .cfg _ => ((.proc proc md) :: acc, stats) | other => (other :: acc, stats)) ([], {}) ({ decls := decls.reverse }, stats) diff --git a/Strata/Transform/PrecondElim.lean b/Strata/Transform/PrecondElim.lean index 4f1017fafe..004135db3f 100644 --- a/Strata/Transform/PrecondElim.lean +++ b/Strata/Transform/PrecondElim.lean @@ -377,7 +377,8 @@ where match d with | .proc proc md => do let F ← getFactory - let (changed, body') ← transformStmts proc.body.toStmts + let bodyStmts := match proc.body with | .structured ss => ss | .cfg _ => [] + let (changed, body') ← transformStmts bodyStmts setFactory F let proc' := { proc with body := .structured body' } let procDecl := Decl.proc proc' md @@ -386,7 +387,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => p.body.toStmts.length | _ => 0) + (match wfDecl with | .proc p _ => p.body.stmts.length | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty proc.header.name)) return (true, wfDecl :: procDecl :: rest') @@ -406,7 +407,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => p.body.toStmts.length | _ => 0) + (match wfDecl with | .proc p _ => p.body.stmts.length | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty func.name)) return (true, wfDecl :: funcDecl :: rest') @@ -431,7 +432,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => p.body.toStmts.length | _ => 0) + (match wfDecl with | .proc p _ => p.body.stmts.length | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty func.name)) return some wfDecl diff --git a/Strata/Transform/ProcBodyVerify.lean b/Strata/Transform/ProcBodyVerify.lean index 25441dbeab..f9de6a1b4f 100644 --- a/Strata/Transform/ProcBodyVerify.lean +++ b/Strata/Transform/ProcBodyVerify.lean @@ -88,8 +88,9 @@ open Core Imperative Transform -- Convert preconditions to assumes let assumes := requiresToAssumes proc.spec.preconditions + let bodyStmts := match proc.body with | .structured ss => ss | .cfg _ => [] -- Wrap body in labeled block - let bodyBlock := Stmt.block bodyLabel proc.body.toStmts #[] + let bodyBlock := Stmt.block bodyLabel bodyStmts #[] -- Convert postconditions to asserts let asserts := ensuresToAsserts proc.spec.postconditions diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index c2e3a4651b..865a24dc1a 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -461,7 +461,7 @@ theorem procToVerifyStmt_structure (h_wf_proc : WF.WFProcedureProp p proc) : ∃ (prefixStmts : List Statement), verifyStmt = Stmt.block s!"verify_{proc.header.name.name}" - (prefixStmts ++ [Stmt.block s!"body_{proc.header.name.name}" proc.body.toStmts #[]] ++ + (prefixStmts ++ [Stmt.block s!"body_{proc.header.name.name}" proc.body.stmts #[]] ++ ensuresToAsserts proc.spec.postconditions) #[] ∧ (∀ s ∈ prefixStmts, ∃ c, s = Stmt.cmd c) ∧ (∀ ρ₀, Core.Specification.ProcEnvWF proc ρ₀ → @@ -656,7 +656,7 @@ theorem procBodyVerify_procedureCorrect verifyStmt context (block verifyLabel > seq > block bodyLabel). -/ have h_embed_body : ∀ ρ₀ (h_wf : Specification.ProcEnvWF proc ρ₀) (cfg : CoreConfig), - CoreStepStar π φ (.stmts proc.body.toStmts ρ₀) cfg → + CoreStepStar π φ (.stmts proc.body.stmts ρ₀) cfg → ∃ ρ_init, StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt verifyStmt ρ_init) @@ -712,7 +712,7 @@ theorem procBodyVerify_procedureCorrect -- Unified helper: all asserts reachable from proc.body are valid have body_asserts_valid : ∀ ρ₀ (h_wf : Specification.ProcEnvWF proc ρ₀) (a : AssertId Expression) (cfg : CoreConfig), - CoreStepStar π φ (.stmts proc.body.toStmts ρ₀) cfg → + CoreStepStar π φ (.stmts proc.body.stmts ρ₀) cfg → coreIsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt := by intro ρ₀ h_wf a cfg h_body h_assert @@ -731,19 +731,19 @@ theorem procBodyVerify_procedureCorrect simp only [Specification.Lang.core, Specification.Lang.imperative] intro ρ₀ cfg (h_wf : Specification.ProcEnvWF proc ρ₀) (h_body : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmt (Stmt.block "" proc.body.toStmts #[]) ρ₀) cfg) + (.stmt (Stmt.block "" proc.body.stmts #[]) ρ₀) cfg) (h_assert : coreIsAtAssert cfg a) -- Extract first step: .stmt (block "" body #[]) ρ₀ → .block "" (.stmts body ρ₀) have h_block_star : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.block "" (.stmts proc.body.toStmts ρ₀)) cfg := by + (.block "" (.stmts proc.body.stmts ρ₀)) cfg := by cases h_body with | refl => simp [coreIsAtAssert] at h_assert | step _ _ _ hstep hrest => cases hstep; exact hrest -- Body never exits (from WFProcedureProp.bodyExitsCovered) have h_no_exit : ∀ lbl ρ', ¬ StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmts proc.body.toStmts ρ₀) (.exiting lbl ρ') := + (.stmts proc.body.stmts ρ₀) (.exiting lbl ρ') := block_exitsCoveredByBlocks_noEscape Expression (EvalCommand π φ) (EvalPureFunc φ) - proc.body.toStmts h_wf_proc.bodyExitsCovered ρ₀ + proc.body.stmts h_wf_proc.bodyExitsCovered ρ₀ -- cfg is not terminal or exiting (has an assert) have h_nt : ∀ ρ', cfg ≠ .terminal ρ' := by intro ρ' heq; subst heq; exact coreIsAtAssert_not_terminal ρ' a h_assert @@ -765,18 +765,18 @@ theorem procBodyVerify_procedureCorrect obtain ⟨ρ_init, h_prefix⟩ := h_prefix_trace ρ₀ h_wf -- h_valid: all asserts in body from ρ₀ evaluate to true have h_valid : ∀ (a : AssertId Expression) (cfg : CoreConfig), - CoreStepStar π φ (.stmts proc.body.toStmts ρ₀) cfg → + CoreStepStar π φ (.stmts proc.body.stmts ρ₀) cfg → coreIsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt := fun a cfg h h' => body_asserts_valid ρ₀ h_wf a cfg h h' -- hasFailure = false have h_nf' : ρ'.hasFailure = Bool.false := Core.core_noFailure_preserved π φ - (.stmts proc.body.toStmts ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term + (.stmts proc.body.stmts ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term -- wfBool preservation have h_wfb_term : WellFormedSemanticEvalBool ρ'.eval := Core.core_wfBool_preserved π φ h_wf_ext - (.stmts proc.body.toStmts ρ₀) (.terminal ρ') h_wf.wfBool h_term + (.stmts proc.body.stmts ρ₀) (.terminal ρ') h_wf.wfBool h_term have h_to_post : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt verifyStmt ρ_init) (.block verifyLabel (.stmts postAsserts ρ')) := by diff --git a/Strata/Transform/ProcedureInlining.lean b/Strata/Transform/ProcedureInlining.lean index cc3842701d..e40fc94f85 100644 --- a/Strata/Transform/ProcedureInlining.lean +++ b/Strata/Transform/ProcedureInlining.lean @@ -94,13 +94,14 @@ private def renameAllLocalNames (c:Procedure) let proc_name := c.header.name.name -- Make a map for renaming local variables - let lhs_vars := List.flatMap (fun (s:Statement) => s.definedVars) c.body.toStmts + let bodyStmts := match c.body with | .structured ss => ss | .cfg _ => [] + let lhs_vars := List.flatMap (fun (s:Statement) => s.definedVars) bodyStmts let lhs_vars := lhs_vars ++ c.header.inputs.unzip.fst ++ c.header.outputs.unzip.fst let var_map <- genOldToFreshIdMappings lhs_vars var_map proc_name -- Make a map for renaming label names - let labels := List.flatMap (fun s => Statement.labels s) c.body.toStmts + let labels := List.flatMap (fun s => Statement.labels s) bodyStmts -- Reuse genOldToFreshIdMappings by introducing dummy data to Identifier let label_ids:List Expression.Ident := labels.map (fun s => { name:=s, metadata := () }) @@ -117,7 +118,7 @@ private def renameAllLocalNames (c:Procedure) let s := Statement.substFvar s old_id (.fvar () new_id .none) let s := Statement.renameLhs s old_id new_id Statement.replaceLabels s label_map) - s0) c.body.toStmts + s0) bodyStmts let new_header := { c.header with inputs := c.header.inputs.map (fun (id,ty) => match var_map.find? id with @@ -269,9 +270,10 @@ def inlineCallCmd Statement.set lhs_var (.fvar () out_var (.none)) md) outs_lhs_and_sig + let procBodyStmts := match proc.body with | .structured ss => ss | .cfg _ => [] let stmts:List (Imperative.Stmt Core.Expression Core.Command) := inputInits ++ outputInits - ++ Block.setCallSiteMetadata proc.body.toStmts md + ++ Block.setCallSiteMetadata procBodyStmts md ++ outputSetStmts -- Update CallGraph if available diff --git a/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean b/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean index 1147ade06e..60fbf7e1f9 100644 --- a/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean +++ b/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean @@ -350,7 +350,7 @@ private def coreToGotoJsonWithSummary (p : Strata.Program) (summary : String) : let Env := Lambda.TEnv.default let procs := cprog.decls.filterMap fun d => d.getProc? let p := procs[0]! - let p' : Core.Procedure := { p with body := .structured (injectPropertySummary p.body.toStmts summary) } + let p' : Core.Procedure := { p with body := .structured (injectPropertySummary (match p.body with | .structured ss => ss | .cfg _ => []) summary) } let pname := Core.CoreIdent.toPretty p'.header.name let ctx ← procedureToGotoCtx Env p' let json ← (CoreToGOTO.CProverGOTO.Context.toJson pname ctx.1).mapError (fun e => f!"{e}") diff --git a/StrataTest/Languages/Boole/global_readonly_call.lean b/StrataTest/Languages/Boole/global_readonly_call.lean index d79c5a522c..5bcb087121 100644 --- a/StrataTest/Languages/Boole/global_readonly_call.lean +++ b/StrataTest/Languages/Boole/global_readonly_call.lean @@ -66,7 +66,7 @@ private def callHelper (p : Strata.Program) : Except String (List String) := do return cp.decls.filterMap fun d => match d with | .proc p _ => - p.body.toStmts.findSome? fun + p.body.stmts.findSome? fun | .block _ stmts _ => stmts.findSome? fun | .cmd (.call pname args _) => some s!"call {pname}({", ".intercalate (args.map fmtCallArg)})" @@ -141,41 +141,41 @@ spec { VCs: -Label: inc_ensures_1_2426 +Label: inc_ensures_1_2424 Property: assert Assumptions: -inc_requires_0_2408: z@1 > 0 +inc_requires_0_2406: z@1 > 0 Obligation: true -Label: callElimAssert_inc_requires_0_2408_6 +Label: callElimAssert_inc_requires_0_2406_6 Property: assert Assumptions: -main_caller_requires_2_2542: z@3 == 10 -main_caller_requires_3_2562: g@3 == 0 +main_caller_requires_2_2540: z@3 == 10 +main_caller_requires_3_2560: g@3 == 0 Obligation: z@3 > 0 -Label: main_caller_ensures_4_2581 +Label: main_caller_ensures_4_2579 Property: assert Assumptions: -main_caller_requires_2_2542: z@3 == 10 -main_caller_requires_3_2562: g@3 == 0 -callElimAssume_inc_ensures_1_2426_7: g@5 == g@3 + 5 + z@5 +main_caller_requires_2_2540: z@3 == 10 +main_caller_requires_3_2560: g@3 == 0 +callElimAssume_inc_ensures_1_2424_7: g@5 == g@3 + 5 + z@5 Obligation: g@5 == 15 --- info: -Obligation: inc_ensures_1_2426 +Obligation: inc_ensures_1_2424 Property: assert Result: ✅ pass -Obligation: callElimAssert_inc_requires_0_2408_6 +Obligation: callElimAssert_inc_requires_0_2406_6 Property: assert Result: ✅ pass -Obligation: main_caller_ensures_4_2581 +Obligation: main_caller_ensures_4_2579 Property: assert Result: ❓ unknown Model: diff --git a/StrataTest/Languages/Core/Examples/Loops.lean b/StrataTest/Languages/Core/Examples/Loops.lean index dbd4f71190..2b32f78c60 100644 --- a/StrataTest/Languages/Core/Examples/Loops.lean +++ b/StrataTest/Languages/Core/Examples/Loops.lean @@ -15,7 +15,7 @@ def singleCFG (p : Program) (n : Nat) : Imperative.CFG String let corePgm : Core.Program := TransM.run Inhabited.default (translateProgram p) |>.fst let proc := match corePgm.decls[n]? with | .some (.proc p _) => p | _ => Inhabited.default - Imperative.stmtsToCFG proc.body.toStmts + Imperative.stmtsToCFG (match proc.body with | .structured ss => ss | .cfg _ => []) --------------------------------------------------------------------- diff --git a/StrataTest/Transform/ProcedureInlining.lean b/StrataTest/Transform/ProcedureInlining.lean index 728a01afef..5626271343 100644 --- a/StrataTest/Transform/ProcedureInlining.lean +++ b/StrataTest/Transform/ProcedureInlining.lean @@ -214,14 +214,17 @@ def alphaEquivStatement (s1 s2: Core.Statement) (map:IdMap) end +private def getStmts (p : Core.Procedure) : List Core.Statement := + match p.body with | .structured ss => ss | .cfg _ => [] + private def alphaEquiv (p1 p2:Core.Procedure):Except Format Bool := do - if p1.body.toStmts.length ≠ p2.body.toStmts.length then + if (getStmts p1).length ≠ (getStmts p2).length then .error (s!"# statements do not match: in {p1.header.name}, " - ++ s!"inlined fn one has {p1.body.toStmts.length}" - ++ s!" whereas the answer has {p2.body.toStmts.length}") + ++ s!"inlined fn one has {(getStmts p1).length}" + ++ s!" whereas the answer has {(getStmts p2).length}") else let newmap:IdMap := IdMap.mk ([], []) [] - let stmts := (p1.body.toStmts.zip p2.body.toStmts) + let stmts := ((getStmts p1).zip (getStmts p2)) let m ← List.foldlM (fun (map:IdMap) (s1,s2) => alphaEquivStatement s1 s2 map) newmap stmts From 723b1ae438710574977cc683a419b3da146cbb9f Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 08:54:20 -0700 Subject: [PATCH 03/57] add parser support for user-facing syntax with examples and tests --- Examples/CFGNondet.core.st | 23 ++ Examples/CFGSimple.core.st | 48 +++++ Strata/Languages/Boole/Verify.lean | 3 + .../Languages/Core/DDMTransform/Grammar.lean | 46 ++++ .../Core/DDMTransform/Translate.lean | 117 +++++++++++ .../Languages/Core/Tests/CFGParseTests.lean | 197 ++++++++++++++++++ 6 files changed, 434 insertions(+) create mode 100644 Examples/CFGNondet.core.st create mode 100644 Examples/CFGSimple.core.st create mode 100644 StrataTest/Languages/Core/Tests/CFGParseTests.lean diff --git a/Examples/CFGNondet.core.st b/Examples/CFGNondet.core.st new file mode 100644 index 0000000000..ab23e62eb8 --- /dev/null +++ b/Examples/CFGNondet.core.st @@ -0,0 +1,23 @@ +program Core; + +// Nondeterministic CFG: y is set to either 1 or 2. +procedure NondetChoice(out y : int) +spec { + ensures (y == 1 || y == 2); +} +cfg entry { + entry: { + goto left, right; + } + left: { + y := 1; + goto done; + } + right: { + y := 2; + goto done; + } + done: { + return; + } +}; diff --git a/Examples/CFGSimple.core.st b/Examples/CFGSimple.core.st new file mode 100644 index 0000000000..9e1af0ee9c --- /dev/null +++ b/Examples/CFGSimple.core.st @@ -0,0 +1,48 @@ +program Core; + +// A simple deterministic CFG: compute max of two integers. +procedure Max(x : int, y : int, out m : int) +spec { + ensures (m >= x); + ensures (m >= y); + ensures (m == x || m == y); +} +cfg entry { + entry: { + branch (x >= y) goto then_branch else else_branch; + } + then_branch: { + m := x; + goto done; + } + else_branch: { + m := y; + goto done; + } + done: { + return; + } +}; + +// A CFG with a simple loop: increment y until it reaches n. +procedure CountUp(n : int, out y : int) +spec { + requires (n >= 0); + ensures (y == n); +} +cfg entry { + entry: { + y := 0; + goto loop; + } + loop: { + branch (y < n) goto body else done; + } + body: { + y := y + 1; + goto loop; + } + done: { + return; + } +}; diff --git a/Strata/Languages/Boole/Verify.lean b/Strata/Languages/Boole/Verify.lean index b32f169450..2d7190d26a 100644 --- a/Strata/Languages/Boole/Verify.lean +++ b/Strata/Languages/Boole/Verify.lean @@ -750,6 +750,7 @@ private def registerCommandSymbols (cmd : BooleDDM.Command SourceRange) : List B | .command_block _ _ => [] | .command_axiom _ _ _ => [] | .command_distinct _ _ _ => [] + | .command_cfg_procedure _ _ _ _ _ _ => [] /-- Build the symbol-class table used by `getFVarIsOp`. @@ -884,6 +885,8 @@ def toCoreDecls (cmd : BooleDDM.Command SourceRange) : TranslateM (List Core.Dec spec := { preconditions := [], postconditions := [] } body := .structured (← toCoreBlock b) } .empty] + | .command_cfg_procedure _ _ _ _ _ _ => + throwAt default "CFG procedures are not supported in Boole dialect" | .command_datatypes _ ⟨_, decls⟩ => return [.type (.data (← decls.toList.mapM toCoreDatatypeDecl)) .empty] diff --git a/Strata/Languages/Core/DDMTransform/Grammar.lean b/Strata/Languages/Core/DDMTransform/Grammar.lean index 0374322193..81f8124aa9 100644 --- a/Strata/Languages/Core/DDMTransform/Grammar.lean +++ b/Strata/Languages/Core/DDMTransform/Grammar.lean @@ -455,6 +455,52 @@ op datatype_decl (name : Ident, op command_datatypes (datatypes : NewlineSepBy DatatypeDecl) : Command => datatypes ";\n"; +// ===================================================================== +// CFG (Unstructured Control Flow) Syntax +// ===================================================================== + +// Transfer commands: how a basic block ends +category Transfer; + +// Goto: one target = unconditional, multiple targets = nondeterministic choice +op transfer_goto (labels : CommaSepBy Ident) : Transfer => + "goto " labels ";"; + +// Conditional goto (deterministic: condition selects between two targets) +op transfer_cond_goto (c : Expr, lt : Ident, lf : Ident) : Transfer => + "branch (" c ") goto " lt " else " lf ";"; + +// Return/finish (terminate execution) +op transfer_return : Transfer => + "return;"; + +// A single CFG basic block: label, commands, transfer +category CFGBlock; +@[scope(cmds)] +op cfg_block (label : Ident, cmds : Seq Statement, tr : Transfer) : CFGBlock => + label ":" " {\n" indent(2, cmds) " " tr "\n}"; + +// A list of CFG blocks +category CFGBlocks; +op cfg_blocks_one (b : CFGBlock) : CFGBlocks => b; +op cfg_blocks_cons (b : CFGBlock, rest : CFGBlocks) : CFGBlocks => + b "\n" rest; + +// CFG body: entry label + blocks +category CFGBody; +op cfg_body (entry : Ident, blocks : CFGBlocks) : CFGBody => + "cfg " entry " {\n" indent(2, blocks) "\n}"; + +// Procedure with CFG body +op command_cfg_procedure (name : Ident, + typeArgs : Option TypeArgs, + @[scope(typeArgs)] b : Bindings, + @[scope(b)] s : Option Spec, + @[scope(b)] body : CFGBody) : + Command => + @[prec(10)] "procedure " name typeArgs b "\n" + s body ";\n"; + #end --------------------------------------------------------------------- diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index d463a16ba9..43c9f8fdb9 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -1609,6 +1609,121 @@ def translateBlockCommand (p : Program) (bindings : TransBindings) (op : Operati --------------------------------------------------------------------- +/-- Translate a transfer command from the CFG syntax -/ + +private instance : Inhabited (Imperative.DetTransferCmd String Core.Expression) := ⟨.finish⟩ +private instance : Inhabited (Imperative.BasicBlock (Imperative.DetTransferCmd String Core.Expression) Core.Command) := ⟨⟨[], .finish⟩⟩ +private instance : Inhabited (Imperative.CFG String (Imperative.DetBlock String Core.Command Core.Expression)) := ⟨⟨"", []⟩⟩ + +partial def translateTransfer (p : Program) (bindings : TransBindings) (arg : Arg) : + TransM (Imperative.DetTransferCmd String Core.Expression) := do + let .op op := arg + | TransM.error s!"translateTransfer expected op {repr arg}" + match op.name with + | q`Core.transfer_goto => + let .seq _ .comma labels := op.args[0]! + | TransM.error s!"translateTransfer goto expected comma-sep labels" + match labels.toList with + | [] => return .finish + | [l] => + let label ← translateIdent String l + return .condGoto (Lambda.LExpr.boolConst () Bool.true) label label + | l1 :: l2 :: _ => + let label1 ← translateIdent String l1 + let label2 ← translateIdent String l2 + let condName := s!"$__nondet_{bindings.gen.var_def}" + return .condGoto (Lambda.LExpr.fvar () ⟨condName, ()⟩ none) label1 label2 + | q`Core.transfer_cond_goto => + let cond ← translateExpr p bindings op.args[0]! + let lt ← translateIdent String op.args[1]! + let lf ← translateIdent String op.args[2]! + return .condGoto cond lt lf + | q`Core.transfer_return => + return .finish + | _ => TransM.error s!"translateTransfer: unknown transfer {repr op.name}" + +/-- Translate a single CFG block -/ +partial def translateCFGBlock (p : Program) (bindings : TransBindings) (arg : Arg) : + TransM (String × Imperative.BasicBlock (Imperative.DetTransferCmd String Core.Expression) Core.Command) := do + let .op op := arg + | TransM.error s!"translateCFGBlock expected op {repr arg}" + let label ← translateIdent String op.args[0]! + -- Translate commands - handle both Seq and empty cases + let stmts : Array Arg := match op.args[1]! with + | .seq _ _ arr => arr + | other => #[other] -- single statement or empty + let mut cmds : Array Core.Command := #[] + let mut bindings := bindings + for s in stmts do + -- Skip empty/null args + if let .op _ := s then + let (translated, bindings') ← translateStmt p bindings s + bindings := bindings' + for stmt in translated do + match stmt with + | .cmd c => cmds := cmds.push c + | _ => TransM.error s!"translateCFGBlock: only commands allowed in CFG blocks, got statement" + let transfer ← translateTransfer p bindings op.args[2]! + return (label, ⟨cmds.toList, transfer⟩) + +/-- Translate a list of CFG blocks -/ +partial def translateCFGBlocks (p : Program) (bindings : TransBindings) (arg : Arg) : + TransM (List (String × Imperative.BasicBlock (Imperative.DetTransferCmd String Core.Expression) Core.Command)) := do + let .op op := arg + | TransM.error s!"translateCFGBlocks expected op {repr arg}" + match op.name with + | q`Core.cfg_blocks_one => + let block ← translateCFGBlock p bindings op.args[0]! + return [block] + | q`Core.cfg_blocks_cons => + let block ← translateCFGBlock p bindings op.args[0]! + let rest ← translateCFGBlocks p bindings op.args[1]! + return block :: rest + | _ => TransM.error s!"translateCFGBlocks: unknown {repr op.name}" + +/-- Translate a CFG body -/ +partial def translateCFGBody (p : Program) (bindings : TransBindings) (arg : Arg) : + TransM (Imperative.CFG String (Imperative.DetBlock String Core.Command Core.Expression)) := do + let .op op := arg + | TransM.error s!"translateCFGBody expected op {repr arg}" + let entry ← translateIdent String op.args[0]! + let blocks ← translateCFGBlocks p bindings op.args[1]! + return { entry := entry, blocks := blocks } + +/-- Translate a procedure with CFG body -/ +def translateCFGProcedure (p : Program) (bindings : TransBindings) (op : Operation) : + TransM (Core.Decl × TransBindings) := do + let _ ← @checkOp (Core.Decl × TransBindings) op q`Core.command_cfg_procedure 5 + let pname ← translateIdent Core.CoreIdent op.args[0]! + let typeArgs ← translateTypeArgs op.args[1]! + let (sig, ret) ← translateBindingsPartitioned bindings op.args[2]! + let in_bindings := (sig.map (fun (v, ty) => (LExpr.fvar () v ty))).toArray + let out_bindings_only := (ret.filter (fun (v, _) => !sig.any (fun (iv, _) => iv == v))).map + (fun (v, ty) => (LExpr.fvar () v ty)) + let out_bindings := out_bindings_only.toArray + let origBindings := bindings + let bbindings := bindings.boundVars ++ in_bindings ++ out_bindings + let bindings := { bindings with boundVars := bbindings } + let .option _ speca := op.args[3]! + | TransM.error s!"translateCFGProcedure spec expected: {repr op.args[3]!}" + let (requires, ensures) ← + if speca.isSome then translateSpec p pname bindings speca.get! else pure ([], []) + let cfg ← translateCFGBody p bindings op.args[4]! + let origBindings := { origBindings with gen := bindings.gen } + let md ← getOpMetaData op + return (.proc { header := { name := pname, + typeArgs := typeArgs.toList, + inputs := sig, + outputs := ret }, + spec := { preconditions := requires, + postconditions := ensures }, + body := .cfg cfg + } + md, + origBindings) + +--------------------------------------------------------------------- + def translateConstant (bindings : TransBindings) (op : Operation) : TransM (Core.Decl × TransBindings) := do let _ ← @checkOp (Core.Decl × TransBindings) op q`Core.command_constdecl 3 @@ -2024,6 +2139,8 @@ partial def translateCoreDecls (p : Program) (bindings : TransBindings) : translateRecFuncBlock p bindings op | q`Core.command_block => translateBlockCommand p bindings op + | q`Core.command_cfg_procedure => + translateCFGProcedure p bindings op | _ => TransM.error s!"translateCoreDecls unimplemented for {repr op}" pure ([decl], bindings) let (decls, bindings) ← go (count + 1) max bindings ops diff --git a/StrataTest/Languages/Core/Tests/CFGParseTests.lean b/StrataTest/Languages/Core/Tests/CFGParseTests.lean new file mode 100644 index 0000000000..cd6bb1ae0a --- /dev/null +++ b/StrataTest/Languages/Core/Tests/CFGParseTests.lean @@ -0,0 +1,197 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +import Strata.DDM.Elab +import Strata.DDM.BuiltinDialects.Init +import Strata.Languages.Core.DDMTransform.Grammar +import Strata.Languages.Core.Verifier +import Strata.SimpleAPI + +/-! # Tests for CFG (unstructured) procedure parsing -/ + +open Strata +open Strata.Elab (parseStrataProgramFromDialect) + +private def parseCoreText (input : String) : IO Core.Program := do + let inputCtx := Strata.Parser.stringInputContext "inline" input + let dialects := Strata.Elab.LoadedDialects.ofDialects! #[initDialect, Strata.Core] + let strataProgram ← parseStrataProgramFromDialect dialects Strata.Core.name inputCtx + match genericToCore strataProgram with + | .ok program => pure program + | .error msg => throw (IO.userError msg) + +/-! ## Deterministic CFG with conditional branch -/ + +/-- +info: Procedure: Max + CFG entry: entry, 4 blocks + Block 'entry': 0 cmds + Block 'then_branch': 1 cmds + Block 'else_branch': 1 cmds + Block 'done': 0 cmds +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure Max(x : int, y : int, out m : int) +spec { + ensures (m >= x); + ensures (m >= y); +} +cfg entry { + entry: { + branch (x >= y) goto then_branch else else_branch; + } + then_branch: { + m := x; + goto done; + } + else_branch: { + m := y; + goto done; + } + done: { + return; + } +}; +" + for d in prog.decls do + match d with + | .proc p _ => + IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" + match p.body with + | .cfg c => + IO.println s!" CFG entry: {c.entry}, {c.blocks.length} blocks" + for (lbl, blk) in c.blocks do + IO.println s!" Block '{lbl}': {blk.cmds.length} cmds" + | .structured _ => IO.println " ERROR: expected CFG body" + | _ => pure () + +/-! ## Nondeterministic CFG with multi-target goto -/ + +/-- +info: Procedure: NondetChoice + CFG entry: entry, 4 blocks + Block 'entry': 0 cmds, branch → left/right + Block 'left': 1 cmds, goto done + Block 'right': 1 cmds, goto done + Block 'done': 0 cmds, return +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure NondetChoice(out y : int) +cfg entry { + entry: { + goto left, right; + } + left: { + y := 1; + goto done; + } + right: { + y := 2; + goto done; + } + done: { + return; + } +}; +" + for d in prog.decls do + match d with + | .proc p _ => + IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" + match p.body with + | .cfg c => + IO.println s!" CFG entry: {c.entry}, {c.blocks.length} blocks" + for (lbl, blk) in c.blocks do + let transferDesc := match blk.transfer with + | .condGoto _ l1 l2 _ => if l1 == l2 then s!"goto {l1}" else s!"branch → {l1}/{l2}" + | .finish _ => "return" + IO.println s!" Block '{lbl}': {blk.cmds.length} cmds, {transferDesc}" + | .structured _ => IO.println " ERROR: expected CFG body" + | _ => pure () + +/-! ## CFG loop pattern -/ + +/-- +info: Procedure: CountUp + CFG entry: entry, 4 blocks + Block 'entry': 1 cmds, goto loop + Block 'loop': 0 cmds, branch → body/done + Block 'body': 1 cmds, goto loop + Block 'done': 0 cmds, return +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure CountUp(n : int, out y : int) +spec { + requires (n >= 0); +} +cfg entry { + entry: { + y := 0; + goto loop; + } + loop: { + branch (y < n) goto body else done; + } + body: { + y := y + 1; + goto loop; + } + done: { + return; + } +}; +" + for d in prog.decls do + match d with + | .proc p _ => + IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" + match p.body with + | .cfg c => + IO.println s!" CFG entry: {c.entry}, {c.blocks.length} blocks" + for (lbl, blk) in c.blocks do + let transferDesc := match blk.transfer with + | .condGoto _ l1 l2 _ => if l1 == l2 then s!"goto {l1}" else s!"branch → {l1}/{l2}" + | .finish _ => "return" + IO.println s!" Block '{lbl}': {blk.cmds.length} cmds, {transferDesc}" + | .structured _ => IO.println " ERROR: expected CFG body" + | _ => pure () + +/-! ## Empty block (just a transfer) -/ + +/-- +info: Procedure: Trivial + CFG entry: start, 1 blocks + Block 'start': 0 cmds, return +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure Trivial() +cfg start { + start: { + return; + } +}; +" + for d in prog.decls do + match d with + | .proc p _ => + IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" + match p.body with + | .cfg c => + IO.println s!" CFG entry: {c.entry}, {c.blocks.length} blocks" + for (lbl, blk) in c.blocks do + let transferDesc := match blk.transfer with + | .condGoto _ l1 l2 _ => if l1 == l2 then s!"goto {l1}" else s!"branch → {l1}/{l2}" + | .finish _ => "return" + IO.println s!" Block '{lbl}': {blk.cmds.length} cmds, {transferDesc}" + | .structured _ => IO.println " ERROR: expected CFG body" + | _ => pure () From 602741cb90dd03ee2ae162c76345ad9663d34f88 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 12:05:39 -0700 Subject: [PATCH 04/57] Add TODO comments for two-stage GOTO pipeline refactor MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Address PR review comments: note that the GOTO backend could be refactored into a two-stage pipeline (structured→cfg, then cfg→GOTO) to eliminate the pattern matching on Procedure.Body. --- Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean | 3 +++ Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean | 3 +++ 2 files changed, 6 insertions(+) diff --git a/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean index 0d29e03bff..34db25bd34 100644 --- a/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean +++ b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean @@ -201,6 +201,9 @@ def transformToGoto (cprog : Core.Program) : Except Format CProverGOTO.Context : if !p.header.typeArgs.isEmpty then throw f!"[transformToGoto] Translation for polymorphic Strata Core procedures is unimplemented." + -- TODO: This pass could be split into a two-stage transformation: + -- 1. structured → cfg (via StructuredToUnstructured) + -- 2. cfg → CProverGOTO (always operates on CFG, no pattern matching needed) let bodyStmts ← match p.body with | .structured ss => pure ss | .cfg _ => throw f!"CFG body not supported for GOTO translation" diff --git a/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean b/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean index 47315e867a..a3fd851dc1 100644 --- a/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean +++ b/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean @@ -259,6 +259,9 @@ def procedureToGotoCtx : Except Std.Format (CoreToGOTO.CProverGOTO.Context × List Core.Function) := do -- Lift local function declarations out of the body + -- TODO: This pass could be split into a two-stage transformation: + -- 1. structured → cfg (via StructuredToUnstructured) + -- 2. cfg → CProverGOTO (always operates on CFG, no pattern matching needed) let bodyStmts ← match p.body with | .structured ss => pure ss | .cfg _ => throw f!"CFG body not supported for GOTO pipeline" From dbb6f917db70501bfeec34b5d51d42466f4f03de Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 14:08:06 -0700 Subject: [PATCH 05/57] add DetCFG abbrev, add obligation extraction and call extraction for DetCFGs --- Strata/Languages/Core/CallGraph.lean | 16 ++++++++-- .../Languages/Core/ObligationExtraction.lean | 31 ++++++++++++++++++- Strata/Languages/Core/Procedure.lean | 5 ++- 3 files changed, 47 insertions(+), 5 deletions(-) diff --git a/Strata/Languages/Core/CallGraph.lean b/Strata/Languages/Core/CallGraph.lean index 4f4cad139c..b4c3fc4794 100644 --- a/Strata/Languages/Core/CallGraph.lean +++ b/Strata/Languages/Core/CallGraph.lean @@ -228,12 +228,17 @@ def extractCallsFromFunction (func : Function) : List String := | some body => extractFunctionCallsFromExpr body | none => [] +/-- Extract procedure calls from a CmdExt -/ +def extractCallsFromCmdExt (cmd : Command) : List String := + match cmd with + | .call procName _ _ => [procName] + | .cmd _ => [] + mutual /-- Extract procedure calls from a single statement -/ def extractCallsFromStatement (stmt : Statement) : List String := match stmt with - | .cmd (.call procName _ _) => [procName] - | .cmd _ => [] + | .cmd c => extractCallsFromCmdExt c | .block _ body _ => extractCallsFromStatements body | .ite _ thenBody elseBody _ => extractCallsFromStatements thenBody ++ @@ -251,11 +256,16 @@ def extractCallsFromStatements (stmts : List Statement) : List String := extractCallsFromStatements rest end +/-- Extract procedure calls from a deterministic CFG -/ +def extractCallsFromDetCFG (cfg : DetCFG) : List String := + cfg.blocks.flatMap fun (_, blk) => + blk.cmds.flatMap extractCallsFromCmdExt + /-- Extract all procedure calls from a procedure's body -/ def extractCallsFromProcedure (proc : Procedure) : List String := match proc.body with | .structured ss => extractCallsFromStatements ss - | .cfg _ => [] + | .cfg c => extractCallsFromDetCFG c @[expose] abbrev ProcedureCG := CallGraph @[expose] abbrev FunctionCG := CallGraph diff --git a/Strata/Languages/Core/ObligationExtraction.lean b/Strata/Languages/Core/ObligationExtraction.lean index b90b8441e4..5f3a9e7eb5 100644 --- a/Strata/Languages/Core/ObligationExtraction.lean +++ b/Strata/Languages/Core/ObligationExtraction.lean @@ -92,6 +92,35 @@ def extractFromStatements extractGo pathConditions ss #[] end +/-- Extract proof obligations from a single command, accumulating path conditions. -/ +private def extractFromCmd (pc : PathConditions Expression) (cmd : Command) + : PathConditions Expression × Array (ProofObligation Expression) := + match cmd with + | .cmd (.assert label e md) => + let propType := match md.getPropertyType with + | some s => if s == MetaData.divisionByZero then .divisionByZero + else if s == MetaData.arithmeticOverflow then .arithmeticOverflow + else .assert + | none => .assert + (pc, #[ProofObligation.mk label propType pc e md]) + | .cmd (.cover label e md) => + (pc, #[ProofObligation.mk label .cover pc e md]) + | .cmd (.assume label e _md) => + (pc.addInNewest [.assumption label e], #[]) + | .cmd (.init name ty e _md) => + (pc.addEntry (.varDecl name ty e), #[]) + | _ => (pc, #[]) + +/-- Extract proof obligations from a deterministic CFG by walking all blocks. -/ +def extractFromDetCFG (pc : PathConditions Expression) (cfg : DetCFG) + : Except String (Array (ProofObligation Expression)) := + let obs := cfg.blocks.foldl (init := #[]) fun acc (_, blk) => + let (_, blockObs) := blk.cmds.foldl (init := (pc, #[])) fun (curPc, obs) cmd => + let (newPc, newObs) := extractFromCmd curPc cmd + (newPc, obs ++ newObs) + acc ++ blockObs + .ok obs + /-- Extract proof obligations from a program. Axioms become global assumptions that are prepended to the path conditions of every obligation. -/ def extractObligations (p : Program) : Except String (ProofObligations Expression) := do @@ -105,7 +134,7 @@ def extractObligations (p : Program) : Except String (ProofObligations Expressio let globalPc : PathConditions Expression := [axiomPc] let obs ← match proc.body with | .structured ss => extractFromStatements globalPc ss - | .cfg _ => .ok #[] + | .cfg c => extractFromDetCFG globalPc c .ok (axiomPc, allObs ++ obs) | _ => .ok (axiomPc, allObs) return allObs diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index e047913fbc..082bfbbbd4 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -279,6 +279,9 @@ def Procedure.Spec.updateCheckExprs | e :: erest, c :: crest => { c with expr := e } :: go erest crest +/-- A deterministic control-flow graph over Core commands and expressions. -/ +@[expose] abbrev DetCFG := Imperative.CFG String (Imperative.DetBlock String Command Expression) + /-- The body of a Core procedure: either structured (a list of statements) or unstructured (a control-flow graph of basic blocks). An empty structured body (`structured []`) represents an abstract/bodyless procedure. -/ @@ -288,7 +291,7 @@ inductive Procedure.Body where /-- An unstructured body: a control-flow graph of deterministic basic blocks. Labels are strings; each block contains Core commands and ends with a deterministic transfer (conditional goto or finish). -/ - | cfg : Imperative.CFG String (Imperative.DetBlock String Command Expression) → Procedure.Body + | cfg : DetCFG → Procedure.Body deriving Inhabited /-- Extract the structured statements, or error if the body is a CFG. -/ From 39123b00292a98bb951649602d4a2a8ba53453d5 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 14:10:32 -0700 Subject: [PATCH 06/57] refactor ObligationExtraction --- .../Languages/Core/ObligationExtraction.lean | 61 +++++++------------ 1 file changed, 23 insertions(+), 38 deletions(-) diff --git a/Strata/Languages/Core/ObligationExtraction.lean b/Strata/Languages/Core/ObligationExtraction.lean index 5f3a9e7eb5..72ec40c4fd 100644 --- a/Strata/Languages/Core/ObligationExtraction.lean +++ b/Strata/Languages/Core/ObligationExtraction.lean @@ -45,6 +45,25 @@ def isValidObligationInput : Statements → Bool | s :: rest => isValidObligationStatement s && isValidObligationInput rest end +/-- Extract proof obligations from a single command, accumulating path conditions. -/ +def extractFromCmd (pc : PathConditions Expression) (cmd : Command) + : PathConditions Expression × Array (ProofObligation Expression) := + match cmd with + | .cmd (.assert label e md) => + let propType := match md.getPropertyType with + | some s => if s == MetaData.divisionByZero then .divisionByZero + else if s == MetaData.arithmeticOverflow then .arithmeticOverflow + else .assert + | none => .assert + (pc, #[ProofObligation.mk label propType pc e md]) + | .cmd (.cover label e md) => + (pc, #[ProofObligation.mk label .cover pc e md]) + | .cmd (.assume label e _md) => + (pc.addInNewest [.assumption label e], #[]) + | .cmd (.init name ty e _md) => + (pc.addEntry (.varDecl name ty e), #[]) + | _ => (pc, #[]) + mutual /-- Core recursive worker for `extractFromStatements`. Walks the statement list, accumulating path conditions and collecting proof obligations. -/ @@ -54,28 +73,15 @@ def extractGo (pc : PathConditions Expression) : Statements → | [], acc => .ok acc | s :: rest, acc => match s with - | .cmd (.cmd (.assert label e md)) => - let propType := match md.getPropertyType with - | some s => if s == MetaData.divisionByZero then .divisionByZero - else if s == MetaData.arithmeticOverflow then .arithmeticOverflow - else .assert - | none => .assert - extractGo pc rest (acc.push (ProofObligation.mk label propType pc e md)) - - | .cmd (.cmd (.cover label e md)) => - extractGo pc rest (acc.push (ProofObligation.mk label .cover pc e md)) - - | .cmd (.cmd (.assume label e _md)) => - extractGo (pc.addInNewest [.assumption label e]) rest acc + | .cmd c => + let (newPc, newObs) := extractFromCmd pc c + extractGo newPc rest (acc ++ newObs) | .ite .nondet thenSs elseSs _md => do let thenObs ← extractFromStatements pc thenSs let elseObs ← extractFromStatements pc elseSs extractGo pc rest (acc ++ thenObs ++ elseObs) - | .cmd (.cmd (.init name ty e _md)) => - extractGo (pc.addEntry (.varDecl name ty e)) rest acc - | _other => .error s!"ObligationExtraction: unsupported statement" @@ -92,25 +98,6 @@ def extractFromStatements extractGo pathConditions ss #[] end -/-- Extract proof obligations from a single command, accumulating path conditions. -/ -private def extractFromCmd (pc : PathConditions Expression) (cmd : Command) - : PathConditions Expression × Array (ProofObligation Expression) := - match cmd with - | .cmd (.assert label e md) => - let propType := match md.getPropertyType with - | some s => if s == MetaData.divisionByZero then .divisionByZero - else if s == MetaData.arithmeticOverflow then .arithmeticOverflow - else .assert - | none => .assert - (pc, #[ProofObligation.mk label propType pc e md]) - | .cmd (.cover label e md) => - (pc, #[ProofObligation.mk label .cover pc e md]) - | .cmd (.assume label e _md) => - (pc.addInNewest [.assumption label e], #[]) - | .cmd (.init name ty e _md) => - (pc.addEntry (.varDecl name ty e), #[]) - | _ => (pc, #[]) - /-- Extract proof obligations from a deterministic CFG by walking all blocks. -/ def extractFromDetCFG (pc : PathConditions Expression) (cfg : DetCFG) : Except String (Array (ProofObligation Expression)) := @@ -155,8 +142,6 @@ private theorem extractGo_ok (pc : PathConditions Expression) (ss : Statements) obtain ⟨hs, hrest⟩ := h unfold extractGo; split · exact extractGo_ok _ _ _ hrest - · exact extractGo_ok _ _ _ hrest - · exact extractGo_ok _ _ _ hrest · rename_i thenSs elseSs _ unfold isValidObligationStatement at hs simp [Bool.and_eq_true] at hs @@ -171,8 +156,8 @@ private theorem extractGo_ok (pc : PathConditions Expression) (ss : Statements) cases extractGo pc elseSs #[] with | error => intro _ h; simp [Except.isOk, Except.toBool] at h | ok v2 => intro _ _; simp; exact extractGo_ok _ _ _ hrest - · exact extractGo_ok _ _ _ hrest · unfold isValidObligationStatement at hs; simp at hs + split at hs <;> simp at * /-- If the input satisfies `isValidObligationInput`, then `extractFromStatements` never returns an error. -/ From 814530e0bcec46180f5bf5ba76a2f0f4bd84ba19 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 14:25:20 -0700 Subject: [PATCH 07/57] Address PR review: getCfg, CBMC error, CFG eval, grammar comment - Add Body.getCfg accessor (mirrors getStructured) - CoreToCBMC: throw error on CFG body instead of returning [] - StatementEval: interpret CFG bodies by linearizing blocks - Grammar: add comment explaining why 'branch' is used instead of 'if' (DDM registers tokens globally, causing conflict with if-statement) --- Strata/Backends/CBMC/CoreToCBMC.lean | 4 +++- Strata/Languages/Core/DDMTransform/Grammar.lean | 3 +++ Strata/Languages/Core/Procedure.lean | 5 +++++ Strata/Languages/Core/StatementEval.lean | 8 +++++++- 4 files changed, 18 insertions(+), 2 deletions(-) diff --git a/Strata/Backends/CBMC/CoreToCBMC.lean b/Strata/Backends/CBMC/CoreToCBMC.lean index 84b1c958d1..d8d7e67984 100644 --- a/Strata/Backends/CBMC/CoreToCBMC.lean +++ b/Strata/Backends/CBMC/CoreToCBMC.lean @@ -346,7 +346,9 @@ def createImplementationSymbolFromAST (func : Core.Procedure) : Except String CB -- For now, keep the hardcoded implementation but use function name from AST let loc : SourceLoc := { functionName := (func.header.name.toPretty), lineNum := "1" } - let bodyStmts := match func.body with | .structured ss => ss | .cfg _ => [] + let bodyStmts ← match func.body with + | .structured ss => .ok ss + | .cfg _ => .error "Cannot translate unstructured CFG body to CBMC JSON format" let stmtJsons ← (bodyStmts.mapM (stmtToJson (I:=CoreLParams) · loc)) let implValue := Json.mkObj [ diff --git a/Strata/Languages/Core/DDMTransform/Grammar.lean b/Strata/Languages/Core/DDMTransform/Grammar.lean index 81f8124aa9..f3de016c7e 100644 --- a/Strata/Languages/Core/DDMTransform/Grammar.lean +++ b/Strata/Languages/Core/DDMTransform/Grammar.lean @@ -467,6 +467,9 @@ op transfer_goto (labels : CommaSepBy Ident) : Transfer => "goto " labels ";"; // Conditional goto (deterministic: condition selects between two targets) +// NOTE: We use "branch" instead of "if" to avoid ambiguity with the +// structured if-statement syntax. The DDM parser registers tokens globally, +// so "if (" in Transfer would conflict with "if (" in Statement. op transfer_cond_goto (c : Expr, lt : Ident, lf : Ident) : Transfer => "branch (" c ") goto " lt " else " lf ";"; diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 082bfbbbd4..8abef6a28f 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -299,6 +299,11 @@ def Procedure.Body.getStructured : Procedure.Body → Except String (List Statem | .structured ss => .ok ss | .cfg _ => .error "expected structured body, got CFG" +/-- Extract the CFG, or error if the body is structured. -/ +def Procedure.Body.getCfg : Procedure.Body → Except String DetCFG + | .cfg c => .ok c + | .structured _ => .error "expected CFG body, got structured" + /-- Extract statements from a structured body, or `[]` for CFG. Intended for use in Prop contexts where `Except` is inconvenient. -/ @[simp, expose] def Procedure.Body.stmts : Procedure.Body → List Statement diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index b62c54e300..241c65f605 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -813,7 +813,13 @@ def Command.runCall (lhs : List Expression.Ident) (procName : String) (args : Li addError := fun E msg => CmdEval.updateError E (.Misc msg) } let bodyStmts := match proc.body with - | .structured ss => ss | .cfg _ => [] + | .structured ss => ss + | .cfg cfgBody => + -- Interpret CFG by linearizing: execute blocks in order from entry. + -- This is a simple approximation; a full CFG interpreter would + -- follow control flow edges. + cfgBody.blocks.flatMap fun (_, blk) => + blk.cmds.map (Imperative.Stmt.cmd ·) let config : Imperative.RunConfig Expression Command Env := .stmts bodyStmts callEnv let configAfter := Imperative.runStmt ops fuel' config From 051f976586a382b6df794ac91c3cb3a2bde2eabf Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 14:42:18 -0700 Subject: [PATCH 08/57] integrate semantics for Call statements which could invoke procedures with CFG as body --- Strata/Languages/Core/StatementSemantics.lean | 91 +++++++++++++++++-- 1 file changed, 85 insertions(+), 6 deletions(-) diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 6d80a0c92b..e6a85f3ddb 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -8,6 +8,7 @@ module public import Strata.DL.Lambda.LExpr public import Strata.DL.Lambda.LExprWF public import Strata.DL.Imperative.StmtSemantics +public import Strata.DL.Imperative.CFGSemantics public import Strata.Languages.Core.CoreGen public import Strata.Languages.Core.Procedure @@ -285,6 +286,86 @@ inductive CoreStepStar ---- CoreStepStar π φ c₁ c₃ +/-- Evaluate the commands in a deterministic basic block, then transfer + control based on the block's terminator. Defined mutually to satisfy + strict positivity (uses `EvalCommand` for command evaluation). -/ +inductive CoreEvalDetBlock + (π : String → Option Procedure) + (φ : CoreEval → PureFunc Expression → CoreEval) : + CoreStore → DetBlock String Command Expression → + CFGConfig String Expression → Prop where + | step_goto_true : + CoreEvalCmds π φ δ σ cs σ' failed → + δ σ c = .some HasBool.tt → + WellFormedSemanticEvalBool δ → + CoreEvalDetBlock π φ + σ ⟨ cs, .condGoto c t e _ ⟩ (.cont t σ' failed) + | step_goto_false : + CoreEvalCmds π φ δ σ cs σ' failed → + δ σ c = .some HasBool.ff → + WellFormedSemanticEvalBool δ → + CoreEvalDetBlock π φ + σ ⟨ cs, .condGoto c t e _ ⟩ (.cont e σ' failed) + | step_terminal : + CoreEvalCmds π φ δ σ cs σ' failed → + CoreEvalDetBlock π φ + σ ⟨ cs, .finish _ ⟩ (.terminal σ' failed) + +/-- Evaluate a list of commands sequentially. Defined mutually because + `EvalCommand` is being defined in the same block. -/ +inductive CoreEvalCmds + (π : String → Option Procedure) + (φ : CoreEval → PureFunc Expression → CoreEval) : + CoreEval → CoreStore → List Command → CoreStore → Bool → Prop where + | eval_cmds_none : + CoreEvalCmds π φ δ σ [] σ false + | eval_cmds_some : + EvalCommand π φ δ σ c σ' failed → + CoreEvalCmds π φ δ σ' cs σ'' failed' → + CoreEvalCmds π φ δ σ (c :: cs) σ'' (failed || failed') + +/-- Single step of a deterministic CFG: look up the current block by label + and evaluate it. Defined mutually for strict positivity. -/ +inductive CoreCFGStep + (π : String → Option Procedure) + (φ : CoreEval → PureFunc Expression → CoreEval) : + DetCFG → CFGConfig String Expression → + CFGConfig String Expression → Prop where + | eval_next : + List.lookup t cfg.blocks = .some b → + CoreEvalDetBlock π φ σ b config → + CoreCFGStep π φ cfg (.cont t σ failed) (updateFailure config failed) + +/-- Reflexive-transitive closure of `CoreCFGStep`. -/ +inductive CoreCFGStepStar + (π : String → Option Procedure) + (φ : CoreEval → PureFunc Expression → CoreEval) : + DetCFG → CFGConfig String Expression → + CFGConfig String Expression → Prop where + | refl : CoreCFGStepStar π φ cfg c c + | step : + CoreCFGStep π φ cfg c₁ c₂ → + CoreCFGStepStar π φ cfg c₂ c₃ → + ---- + CoreCFGStepStar π φ cfg c₁ c₃ + +/-- Execution of a procedure body: either structured (via `CoreStepStar`) + or unstructured CFG (via `CoreCFGStepStar`). -/ +inductive CoreBodyExec + (π : String → Option Procedure) + (φ : CoreEval → PureFunc Expression → CoreEval) : + Procedure.Body → CoreStore → CoreEval → CoreStore → Bool → Prop where + | structured : + CoreStepStar π φ + (.stmts ss ⟨σ, δ, false⟩) + (.terminal ρ') → + CoreBodyExec π φ (.structured ss) σ δ ρ'.store ρ'.hasFailure + | cfg : + CoreCFGStepStar π φ cfg + (.cont cfg.entry σ false) + (.terminal σ' failed) → + CoreBodyExec π φ (.cfg cfg) σ δ σ' failed + inductive EvalCommand (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) : CoreEval → CoreStore → Command → CoreStore → Bool → Prop where | cmd_sem {δ σ c σ' f} : @@ -295,7 +376,7 @@ inductive EvalCommand (π : String → Option Procedure) (φ : CoreEval → Pure /-- Arguments are matched positionally: `inArgs` (from `getInputExprs`) aligns with `p.header.inputs`, and `lhs` (from `getLhs`) aligns with `p.header.outputs`. -/ - | call_sem {δ σ₀ σ inArgs vals oVals σA σAO n p modvals callArgs σ' ρ' md} : + | call_sem {δ σ₀ σ inArgs vals oVals σA σAO n p modvals callArgs σ' σ_final failed md} : π n = .some p → -- inArg exprs + fvar refs for inoutArg ids CallArg.getInputExprs callArgs = inArgs → @@ -317,13 +398,11 @@ inductive EvalCommand (π : String → Option Procedure) (φ : CoreEval → Pure (∀ pre, (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre → isDefinedOver (HasVarsPure.getVars) σAO pre ∧ δ σAO pre = .some HasBool.tt) → - CoreStepStar π φ - (.stmts p.body.stmts ⟨σAO, δ, false⟩) - (.terminal ρ') → + CoreBodyExec π φ p.body σAO δ σ_final failed → (∀ post, (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → isDefinedOver (HasVarsPure.getVars) σAO post ∧ - δ ρ'.store post = .some HasBool.tt) → - ReadValues ρ'.store (ListMap.keys (p.header.outputs)) modvals → + δ σ_final post = .some HasBool.tt) → + ReadValues σ_final (ListMap.keys (p.header.outputs)) modvals → -- positional: modvals[i] written back to lhs[i] UpdateStates σ lhs modvals σ' → ---- From 48a2a32522bc7f8ac3aa9cc972a540c5238d5037 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 14:53:30 -0700 Subject: [PATCH 09/57] CST support for unstructured programs --- .../Core/DDMTransform/FormatCore.lean | 40 ++++++++++++++++++- 1 file changed, 39 insertions(+), 1 deletion(-) diff --git a/Strata/Languages/Core/DDMTransform/FormatCore.lean b/Strata/Languages/Core/DDMTransform/FormatCore.lean index 34eb28f5a5..bb40e9729f 100644 --- a/Strata/Languages/Core/DDMTransform/FormatCore.lean +++ b/Strata/Languages/Core/DDMTransform/FormatCore.lean @@ -869,6 +869,44 @@ partial def invariantsToCST {M} [Inhabited M] let restCST ← invariantsToCST rest pure (.consInvariants default labelAnn exprCST restCST) +/-- Convert a `DetTransferCmd` to a CST statement (if-then-else for condGoto, skip for finish). -/ +partial def transferToCST {M} [Inhabited M] + (t : Imperative.DetTransferCmd String Expression) : ToCSTM M (Option (CoreDDM.Statement M)) := do + match t with + | .condGoto cond lt lf _ => do + let condCST ← lexprToExpr cond 0 + let gotoTrue : CoreDDM.Statement M := .exit_statement default ⟨default, lt⟩ + let gotoFalse : CoreDDM.Statement M := .exit_statement default ⟨default, lf⟩ + let thenBlock : CoreDDM.Block M := .block default ⟨default, #[gotoTrue]⟩ + let elseBlock : Else M := .else1 default (.block default ⟨default, #[gotoFalse]⟩) + pure (some (.if_statement default (.condDet default condCST) thenBlock elseBlock)) + | .finish _ => pure none + +/-- Convert a single `DetBlock` to a CST block (commands + transfer). -/ +partial def detBlockToCST {M} [Inhabited M] + (blk : Imperative.DetBlock String Core.Command Expression) + : ToCSTM M (CoreDDM.Block M) := do + modify ToCSTContext.pushScope + let cmdStmts ← blk.cmds.toArray.mapM (stmtToCST ∘ Imperative.Stmt.cmd) + let transferStmt ← transferToCST blk.transfer + let allStmts := match transferStmt with + | some s => cmdStmts.push s + | none => cmdStmts + modify ToCSTContext.popScope + pure (.block default ⟨default, allStmts⟩) + +/-- Convert a `DetCFG` to a CST block (sequence of labeled blocks). -/ +partial def detCFGToCST {M} [Inhabited M] (cfg : Core.DetCFG) + : ToCSTM M (CoreDDM.Block M) := do + modify ToCSTContext.pushScope + let mut stmts : Array (CoreDDM.Statement M) := #[] + for (label, blk) in cfg.blocks do + let labelAnn : Ann String M := ⟨default, label⟩ + let blockCST ← detBlockToCST blk + stmts := stmts.push (.block_statement default labelAnn blockCST) + modify ToCSTContext.popScope + pure (.block default ⟨default, stmts⟩) + partial def measureToCST {M} [Inhabited M] (measure : Option (Lambda.LExpr CoreLParams.mono)) : ToCSTM M (Ann (Option (Measure M)) M) := do @@ -940,7 +978,7 @@ def procToCST {M} [Inhabited M] (proc : Core.Procedure) : ToCSTM M (Command M) : ⟨default, some (Spec.spec_mk default specAnn)⟩ let bodyCST ← match proc.body with | .structured ss => blockToCST ss - | .cfg _ => blockToCST [] + | .cfg c => detCFGToCST c let body : Ann (Option (CoreDDM.Block M)) M := ⟨default, some bodyCST⟩ modify ToCSTContext.popScope pure (.command_procedure default name typeArgs arguments spec body) From 5d3aba6d1cb892bd864b089a33b53f5f9f9986ce Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 15:05:58 -0700 Subject: [PATCH 10/57] add explicit comments on funcDecl extraction for unstructured program --- Strata/Languages/Core/Core.lean | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/Strata/Languages/Core/Core.lean b/Strata/Languages/Core/Core.lean index 9ded48acec..d9582934e9 100644 --- a/Strata/Languages/Core/Core.lean +++ b/Strata/Languages/Core/Core.lean @@ -95,7 +95,12 @@ def buildEnv (options : VerifyOptions) (program : Program) for func in funcs do E ← E.addFactoryFunc func | .distinct _ es _ => E := { E with distinct := es :: E.distinct } | .proc proc _ => - for stmt in proc.body.stmts.flatMap collectFuncDecls do + let stmts := match proc.body with + | .structured ss => ss + -- CFG bodies cannot contain local function declarations; + -- funcDecl is a structured statement-level construct only. + | .cfg _ => [] + for stmt in stmts.flatMap collectFuncDecls do match E.exprEnv.addFactoryFunc stmt with | .ok σ' => E := { E with exprEnv := σ' } | .error _ => pure () From 1b8a0e585082a7f5f59f330ca69a742f02c14979 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 15:28:01 -0700 Subject: [PATCH 11/57] add ANF comment --- Strata/Transform/ANFEncoder.lean | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Strata/Transform/ANFEncoder.lean b/Strata/Transform/ANFEncoder.lean index e8c741ffa2..4269eb1840 100644 --- a/Strata/Transform/ANFEncoder.lean +++ b/Strata/Transform/ANFEncoder.lean @@ -221,7 +221,10 @@ def anfEncodeProgram (p : Program) : Bool × Program := | .structured ss => let (body', idx') := anfEncodeBody ss idx (.proc { proc with body := .structured body' } md :: acc, idx', changed || idx' > idx) - | .cfg _ => (.proc proc md :: acc, idx, changed) + | .cfg _ => + -- CSE on CFGs would require dominator analysis to determine where to + -- place hoisted var declarations. Skipped for now. + (.proc proc md :: acc, idx, changed) | other => (other :: acc, idx, changed) ) ([], 0, false) (changed, { decls := revDecls.reverse }) From 6c7a61ac5be88c44ddea2d301b497f686504689d Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 15:32:43 -0700 Subject: [PATCH 12/57] alphaEquiv for CFG --- StrataTest/Transform/ProcedureInlining.lean | 57 +++++++++++++++++---- 1 file changed, 47 insertions(+), 10 deletions(-) diff --git a/StrataTest/Transform/ProcedureInlining.lean b/StrataTest/Transform/ProcedureInlining.lean index 5626271343..8041397111 100644 --- a/StrataTest/Transform/ProcedureInlining.lean +++ b/StrataTest/Transform/ProcedureInlining.lean @@ -217,19 +217,56 @@ end private def getStmts (p : Core.Procedure) : List Core.Statement := match p.body with | .structured ss => ss | .cfg _ => [] -private def alphaEquiv (p1 p2:Core.Procedure):Except Format Bool := do - if (getStmts p1).length ≠ (getStmts p2).length then - .error (s!"# statements do not match: in {p1.header.name}, " - ++ s!"inlined fn one has {(getStmts p1).length}" - ++ s!" whereas the answer has {(getStmts p2).length}") +private def alphaEquivCmds (cmds1 cmds2 : List Core.Command) (map : IdMap) + : Except Format IdMap := do + if cmds1.length ≠ cmds2.length then + .error f!"CFG block command count mismatch: {cmds1.length} vs {cmds2.length}" else + (cmds1.zip cmds2).foldlM (fun map (c1, c2) => + alphaEquivStatement (.cmd c1) (.cmd c2) map) map + +private def alphaEquivTransfer (t1 t2 : Imperative.DetTransferCmd String Core.Expression) + (map : IdMap) : Except Format IdMap := do + match t1, t2 with + | .condGoto c1 lt1 lf1 _, .condGoto c2 lt2 lf2 _ => + if ¬ alphaEquivExprs c1 c2 map then + .error f!"CFG transfer condition mismatch" + else + let map ← IdMap.updateLabel map lt1 lt2 + IdMap.updateLabel map lf1 lf2 + | .finish _, .finish _ => .ok map + | _, _ => .error "CFG transfer type mismatch" + +private def alphaEquivCFG (cfg1 cfg2 : Core.DetCFG) (map : IdMap) + : Except Format IdMap := do + let map ← IdMap.updateLabel map cfg1.entry cfg2.entry + if cfg1.blocks.length ≠ cfg2.blocks.length then + .error f!"CFG block count mismatch: {cfg1.blocks.length} vs {cfg2.blocks.length}" + else + (cfg1.blocks.zip cfg2.blocks).foldlM (fun map ((lbl1, blk1), (lbl2, blk2)) => do + let map ← IdMap.updateLabel map lbl1 lbl2 + let map ← alphaEquivCmds blk1.cmds blk2.cmds map + alphaEquivTransfer blk1.transfer blk2.transfer map) map + +private def alphaEquiv (p1 p2:Core.Procedure):Except Format Bool := do + match p1.body, p2.body with + | .structured ss1, .structured ss2 => + if ss1.length ≠ ss2.length then + .error (s!"# statements do not match: in {p1.header.name}, " + ++ s!"inlined fn one has {ss1.length}" + ++ s!" whereas the answer has {ss2.length}") + else + let newmap:IdMap := IdMap.mk ([], []) [] + let m ← List.foldlM (fun (map:IdMap) (s1,s2) => + alphaEquivStatement s1 s2 map) + newmap (ss1.zip ss2) + return ((p1.header.outputs.zip p2.header.outputs).map (fun ((x, _), (y, _)) => alphaEquivIdents x y m)).all id + | .cfg cfg1, .cfg cfg2 => let newmap:IdMap := IdMap.mk ([], []) [] - let stmts := ((getStmts p1).zip (getStmts p2)) - let m ← List.foldlM (fun (map:IdMap) (s1,s2) => - alphaEquivStatement s1 s2 map) - newmap stmts - -- The corresponding outputs should be pairwise α-equivalent + let m ← alphaEquivCFG cfg1 cfg2 newmap return ((p1.header.outputs.zip p2.header.outputs).map (fun ((x, _), (y, _)) => alphaEquivIdents x y m)).all id + | .structured _, .cfg _ => .error "body type mismatch: structured vs cfg" + | .cfg _, .structured _ => .error "body type mismatch: cfg vs structured" From 4ccddf44558e8edde3ac603a5c6a071078e178e0 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 16:06:52 -0700 Subject: [PATCH 13/57] no-op when inlining unstructured procedures --- Strata/Transform/ProcedureInlining.lean | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/Strata/Transform/ProcedureInlining.lean b/Strata/Transform/ProcedureInlining.lean index e40fc94f85..2c366307d2 100644 --- a/Strata/Transform/ProcedureInlining.lean +++ b/Strata/Transform/ProcedureInlining.lean @@ -114,11 +114,11 @@ private def renameAllLocalNames (c:Procedure) -- a later old_id. The iteration is intentionally sequential because each step also -- renames LHS variables and labels. let new_body := List.map (fun (s0:Statement) => - var_map.foldl (fun (s:Statement) (old_id,new_id) => - let s := Statement.substFvar s old_id (.fvar () new_id .none) - let s := Statement.renameLhs s old_id new_id - Statement.replaceLabels s label_map) - s0) bodyStmts + var_map.foldl (fun (s:Statement) (old_id,new_id) => + let s := Statement.substFvar s old_id (.fvar () new_id .none) + let s := Statement.renameLhs s old_id new_id + Statement.replaceLabels s label_map) + s0) bodyStmts let new_header := { c.header with inputs := c.header.inputs.map (fun (id,ty) => match var_map.find? id with @@ -270,7 +270,13 @@ def inlineCallCmd Statement.set lhs_var (.fvar () out_var (.none)) md) outs_lhs_and_sig - let procBodyStmts := match proc.body with | .structured ss => ss | .cfg _ => [] + -- Cannot inline unstructured (CFG) bodies into structured code. + -- CFG-level inlining is a separate, more complex pass that operates + -- entirely in the CFG domain (graph splicing). + let procBodyStmts ← match proc.body with + | .cfg _ => return .none + | .structured ss => pure ss + let stmts:List (Imperative.Stmt Core.Expression Core.Command) := inputInits ++ outputInits ++ Block.setCallSiteMetadata procBodyStmts md From b2958434c59c323d81015e69cedd26266e63d989 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 16:19:32 -0700 Subject: [PATCH 14/57] add more support for CFG handling --- Strata/Languages/Core/Procedure.lean | 9 +++- Strata/Languages/Core/ProcedureType.lean | 11 ++++- Strata/Languages/Core/StatementEval.lean | 52 ++++++++++++++++++------ 3 files changed, 55 insertions(+), 17 deletions(-) diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 8abef6a28f..fd555983f5 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -360,10 +360,15 @@ instance : HasVarsPure Expression Procedure.Body where instance : HasVarsImp Expression Procedure.Body where definedVars b := match b with | .structured ss => HasVarsImp.definedVars ss - | .cfg _ => [] + | .cfg cfgBody => cfgBody.blocks.flatMap fun (_, blk) => + blk.cmds.filterMap fun | .cmd (.init n _ _ _) => some n | _ => none modifiedVars b := match b with | .structured ss => HasVarsImp.modifiedVars ss - | .cfg _ => [] + | .cfg cfgBody => cfgBody.blocks.flatMap fun (_, blk) => + blk.cmds.filterMap fun + | .cmd (.set n _ _) => some n + | .cmd (.init n _ _ _) => some n + | _ => none instance : HasVarsImp Expression Procedure where definedVars := Procedure.definedVars diff --git a/Strata/Languages/Core/ProcedureType.lean b/Strata/Languages/Core/ProcedureType.lean index 42bf81acd7..0fc5f466f4 100644 --- a/Strata/Languages/Core/ProcedureType.lean +++ b/Strata/Languages/Core/ProcedureType.lean @@ -111,8 +111,15 @@ def typeCheck (C : Core.Expression.TyContext) (Env : Core.Expression.TyEnv) (p : -- Type check body. -- Note that `Statement.typeCheck` already reports source locations in - -- error messages. - let bodyStmts := match proc.body with | .structured ss => ss | .cfg _ => [] + -- Type check body. + let bodyStmts := match proc.body with + | .structured ss => ss + -- For now, we skip checking CFG bodies + -- potential TODOs for CFGs: + -- * verify block labels are unique + -- * all variables used are declared/initialized + -- * target labels of transfer commands exist + | .cfg _ => [] let (annotated_body, finalEnv) ← Statement.typeCheck C envAfterPostconds p (.some proc) bodyStmts -- Remove formals and returns from the context -- they ought to be local to diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 241c65f605..70b2fbbb2c 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -762,6 +762,37 @@ Interpret a single procedure call. Importantly, this creates a separate Env to execute the body of the procedure with, which initially only contains input/output variables. + +Execute a CFG by following control flow from the entry block. + Returns the list of commands executed (as statements) for compatibility + with the structured interpreter. -/ +private def runCFG (cfg : Core.DetCFG) (fuel : Nat) (env : Env) + (ops : Imperative.RunOps Expression Command Env) : List Statement × Env := + go cfg.entry fuel env [] +where + go (label : String) (fuel : Nat) (env : Env) (acc : List Statement) : List Statement × Env := + match fuel with + | 0 => (acc.reverse, env) + | fuel' + 1 => + match cfg.blocks.lookup label with + | none => (acc.reverse, env) + | some blk => + -- Execute commands in the block + let cmdStmts := blk.cmds.map (Imperative.Stmt.cmd ·) + let config := Imperative.runStmt ops fuel' (.stmts cmdStmts env) + match config with + | .terminal env' => + -- Evaluate transfer + match blk.transfer with + | .finish _ => (acc.reverse ++ cmdStmts, env') + | .condGoto cond lt lf _ => + match ops.evalExpr env' cond with + | some (.boolConst _ true) => go lt fuel' env' (acc ++ cmdStmts) + | some (.boolConst _ false) => go lf fuel' env' (acc ++ cmdStmts) + | _ => (acc.reverse ++ cmdStmts, env') + | _ => (acc.reverse, env) + +/-- The resulting Env is the original passed in Env with the output variables copied back into it. -/ def Command.runCall (lhs : List Expression.Ident) (procName : String) (args : List Expression.Expr) @@ -812,18 +843,15 @@ def Command.runCall (lhs : List Expression.Ident) (procName : String) (args : Li hasError := fun E => E.error.isSome addError := fun E msg => CmdEval.updateError E (.Misc msg) } - let bodyStmts := match proc.body with - | .structured ss => ss + let callEnvAfter := match proc.body with + | .structured ss => + let config : Imperative.RunConfig Expression Command Env := + .stmts ss callEnv + Imperative.runStmt ops fuel' config | .cfg cfgBody => - -- Interpret CFG by linearizing: execute blocks in order from entry. - -- This is a simple approximation; a full CFG interpreter would - -- follow control flow edges. - cfgBody.blocks.flatMap fun (_, blk) => - blk.cmds.map (Imperative.Stmt.cmd ·) - let config : Imperative.RunConfig Expression Command Env := - .stmts bodyStmts callEnv - let configAfter := Imperative.runStmt ops fuel' config - match configAfter with + -- Interpret CFG by following control flow from the entry block. + .terminal (runCFG cfgBody fuel' callEnv ops).2 + match callEnvAfter with | .terminal callEnv' => match callEnv'.error with | some _ => { E with error := callEnv'.error } @@ -850,5 +878,3 @@ end Statement end Core end -- public section - ---------------------------------------------------------------------- From d184ea0baa336a10c26b8be81af39385bb2a5b7e Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 16:23:48 -0700 Subject: [PATCH 15/57] simplify StatementEval --- Strata/Languages/Core/StatementEval.lean | 27 +++++++++++------------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 70b2fbbb2c..02d2b71a77 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -767,30 +767,27 @@ Execute a CFG by following control flow from the entry block. Returns the list of commands executed (as statements) for compatibility with the structured interpreter. -/ private def runCFG (cfg : Core.DetCFG) (fuel : Nat) (env : Env) - (ops : Imperative.RunOps Expression Command Env) : List Statement × Env := - go cfg.entry fuel env [] + (ops : Imperative.RunOps Expression Command Env) : Env := + go cfg.entry fuel env where - go (label : String) (fuel : Nat) (env : Env) (acc : List Statement) : List Statement × Env := + go (label : String) (fuel : Nat) (env : Env) : Env := match fuel with - | 0 => (acc.reverse, env) + | 0 => env | fuel' + 1 => match cfg.blocks.lookup label with - | none => (acc.reverse, env) + | none => env | some blk => - -- Execute commands in the block let cmdStmts := blk.cmds.map (Imperative.Stmt.cmd ·) - let config := Imperative.runStmt ops fuel' (.stmts cmdStmts env) - match config with + match Imperative.runStmt ops fuel' (.stmts cmdStmts env) with | .terminal env' => - -- Evaluate transfer match blk.transfer with - | .finish _ => (acc.reverse ++ cmdStmts, env') + | .finish _ => env' | .condGoto cond lt lf _ => match ops.evalExpr env' cond with - | some (.boolConst _ true) => go lt fuel' env' (acc ++ cmdStmts) - | some (.boolConst _ false) => go lf fuel' env' (acc ++ cmdStmts) - | _ => (acc.reverse ++ cmdStmts, env') - | _ => (acc.reverse, env) + | some (.boolConst _ true) => go lt fuel' env' + | some (.boolConst _ false) => go lf fuel' env' + | _ => env' + | _ => env /-- The resulting Env is the original passed in Env with the output variables copied back into it. @@ -850,7 +847,7 @@ def Command.runCall (lhs : List Expression.Ident) (procName : String) (args : Li Imperative.runStmt ops fuel' config | .cfg cfgBody => -- Interpret CFG by following control flow from the entry block. - .terminal (runCFG cfgBody fuel' callEnv ops).2 + .terminal (runCFG cfgBody fuel' callEnv ops) match callEnvAfter with | .terminal callEnv' => match callEnv'.error with From 70cda2347edf2d8e4324d616c03af13ea74d0ef8 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 16:33:30 -0700 Subject: [PATCH 16/57] indent --- Strata/Transform/ProcedureInlining.lean | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Strata/Transform/ProcedureInlining.lean b/Strata/Transform/ProcedureInlining.lean index 2c366307d2..6d6c533563 100644 --- a/Strata/Transform/ProcedureInlining.lean +++ b/Strata/Transform/ProcedureInlining.lean @@ -114,11 +114,11 @@ private def renameAllLocalNames (c:Procedure) -- a later old_id. The iteration is intentionally sequential because each step also -- renames LHS variables and labels. let new_body := List.map (fun (s0:Statement) => - var_map.foldl (fun (s:Statement) (old_id,new_id) => - let s := Statement.substFvar s old_id (.fvar () new_id .none) - let s := Statement.renameLhs s old_id new_id - Statement.replaceLabels s label_map) - s0) bodyStmts + var_map.foldl (fun (s:Statement) (old_id,new_id) => + let s := Statement.substFvar s old_id (.fvar () new_id .none) + let s := Statement.renameLhs s old_id new_id + Statement.replaceLabels s label_map) + s0) bodyStmts let new_header := { c.header with inputs := c.header.inputs.map (fun (id,ty) => match var_map.find? id with From 10cb1eb08a9ef029da34953f74b8dcb2e948ff2d Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 16:45:49 -0700 Subject: [PATCH 17/57] Address PR review: remove .stmts, refine Body interface, cleanup - WF.lean: replace .stmts with case-split premises (bodyIsStructured) - Procedure.lean: replace isEmpty with isAbstract/isStructured/isCfg, remove Body.stmts definition - ProcedureInlining test: remove unused getStmts helper - Boole test: use explicit pattern matching with comment - Update all .body.stmts usages to explicit match expressions - Fix ProcBodyVerifyCorrect proof to use new WF structure --- Strata/Languages/Core/Procedure.lean | 21 ++++++++------ Strata/Languages/Core/StatementEval.lean | 2 +- Strata/Languages/Core/WF.lean | 9 +++--- Strata/Transform/CoreSpecification.lean | 4 +-- Strata/Transform/PrecondElim.lean | 6 ++-- Strata/Transform/ProcBodyVerifyCorrect.lean | 23 +++++++-------- .../Languages/Boole/global_readonly_call.lean | 28 ++++++++++--------- StrataTest/Transform/ProcedureInlining.lean | 3 -- 8 files changed, 51 insertions(+), 45 deletions(-) diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index fd555983f5..5eff596b28 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -304,23 +304,28 @@ def Procedure.Body.getCfg : Procedure.Body → Except String DetCFG | .cfg c => .ok c | .structured _ => .error "expected CFG body, got structured" -/-- Extract statements from a structured body, or `[]` for CFG. - Intended for use in Prop contexts where `Except` is inconvenient. -/ -@[simp, expose] def Procedure.Body.stmts : Procedure.Body → List Statement - | .structured ss => ss - | .cfg _ => [] - /-- Get variables referenced in the body. -/ def Procedure.Body.getVars : Procedure.Body → List Expression.Ident | .structured ss => ss.flatMap Imperative.HasVarsPure.getVars | .cfg c => c.blocks.flatMap fun (_, blk) => blk.cmds.flatMap Imperative.HasVarsPure.getVars -/-- Is this body empty (abstract)? -/ -def Procedure.Body.isEmpty : Procedure.Body → Bool +/-- Is this body abstract (no implementation)? Only empty structured bodies + are abstract. CFG bodies always have an implementation. -/ +def Procedure.Body.isAbstract : Procedure.Body → Bool | .structured ss => ss.isEmpty | .cfg _ => false +/-- Does this body have a structured implementation? -/ +def Procedure.Body.isStructured : Procedure.Body → Bool + | .structured _ => true + | .cfg _ => false + +/-- Does this body have a CFG implementation? -/ +def Procedure.Body.isCfg : Procedure.Body → Bool + | .structured _ => false + | .cfg _ => true + /-- A Strata Core procedure: the main verification unit. diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 02d2b71a77..a7084d0dd8 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -800,7 +800,7 @@ def Command.runCall (lhs : List Expression.Ident) (procName : String) (args : Li match Program.Procedure.find? E.program ⟨procName, ()⟩ with | none => CmdEval.updateError E (.Misc s!"procedure '{procName}' not found") | some proc => - if proc.body.isEmpty then CmdEval.updateError E (.Misc s!"procedure '{proc.header.name}' has no body") + if proc.body.isAbstract then CmdEval.updateError E (.Misc s!"procedure '{proc.header.name}' has no body") else match args.mapM (LExpr.run E.exprEnv) with | .error s => CmdEval.updateError E (.Misc s) diff --git a/Strata/Languages/Core/WF.lean b/Strata/Languages/Core/WF.lean index 010631b172..dfc69972d5 100644 --- a/Strata/Languages/Core/WF.lean +++ b/Strata/Languages/Core/WF.lean @@ -138,15 +138,16 @@ structure WFAxiomDeclarationProp (p : Program) (f : Axiom) : Prop where structure WFDistinctDeclarationProp (p : Program) (l : Expression.Ident) (es : List (Expression.Expr)) : Prop where structure WFProcedureProp (p : Program) (d : Procedure) : Prop where - wfstmts : WFStatementsProp p d.body.stmts - wfloclnd : (HasVarsImp.definedVars (P:=Expression) d.body.stmts).Nodup + bodyIsStructured : ∃ ss, d.body = .structured ss + wfstmts : ∀ ss, d.body = .structured ss → WFStatementsProp p ss + wfloclnd : ∀ ss, d.body = .structured ss → (HasVarsImp.definedVars (P:=Expression) ss).Nodup inputsNodup : (ListMap.keys d.header.inputs).Nodup outputsNodup : (ListMap.keys d.header.outputs).Nodup ioNotOld : ∀ id ∈ ListMap.keys d.header.inputs ++ ListMap.keys d.header.outputs, ∀ x, id ≠ CoreIdent.mkOld x 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.stmts + bodyExitsCovered : ∀ ss, d.body = .structured ss → + Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks [] ss structure WFFunctionProp (p : Program) (f : Function) : Prop where structure WFRecFuncBlockProp (p : Program) (fs : List Function) : Prop where diff --git a/Strata/Transform/CoreSpecification.lean b/Strata/Transform/CoreSpecification.lean index f6f18dbdd2..35fa5780b4 100644 --- a/Strata/Transform/CoreSpecification.lean +++ b/Strata/Transform/CoreSpecification.lean @@ -82,7 +82,7 @@ variable (φ : CoreEval → PureFunc Expression → CoreEval) (proc : Procedure) (a : Imperative.AssertId Expression) : Prop := Imperative.Specification.AssertValidWhen (Specification.Lang.core π φ) - (ProcEnvWF proc) (Stmt.block "" proc.body.stmts #[]) a + (ProcEnvWF proc) (Stmt.block "" (match proc.body with | .structured ss => ss | .cfg _ => []) #[]) a /-- A procedure is correct with respect to its specification. @@ -143,7 +143,7 @@ structure ProcedureCorrect (proc : Procedure) (p : Program) : Prop where WF.WFProcedureProp p proc → ∀ (ρ₀ ρ' : Env Expression), ProcEnvWF proc ρ₀ → - CoreStepStar π φ (.stmts proc.body.stmts ρ₀) (.terminal ρ') → + CoreStepStar π φ (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) (.terminal ρ') → (∀ (label : CoreLabel) (check : Procedure.Check), (label, check) ∈ proc.spec.postconditions.toList → check.attr = Procedure.CheckAttr.Default → diff --git a/Strata/Transform/PrecondElim.lean b/Strata/Transform/PrecondElim.lean index 004135db3f..3135694bce 100644 --- a/Strata/Transform/PrecondElim.lean +++ b/Strata/Transform/PrecondElim.lean @@ -387,7 +387,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => p.body.stmts.length | _ => 0) + (match wfDecl with | .proc p _ => (match p.body with | .structured ss => ss.length | .cfg _ => 0) | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty proc.header.name)) return (true, wfDecl :: procDecl :: rest') @@ -407,7 +407,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => p.body.stmts.length | _ => 0) + (match wfDecl with | .proc p _ => (match p.body with | .structured ss => ss.length | .cfg _ => 0) | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty func.name)) return (true, wfDecl :: funcDecl :: rest') @@ -432,7 +432,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => p.body.stmts.length | _ => 0) + (match wfDecl with | .proc p _ => (match p.body with | .structured ss => ss.length | .cfg _ => 0) | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty func.name)) return some wfDecl diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index 865a24dc1a..1b8e21dad4 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -461,7 +461,7 @@ theorem procToVerifyStmt_structure (h_wf_proc : WF.WFProcedureProp p proc) : ∃ (prefixStmts : List Statement), verifyStmt = Stmt.block s!"verify_{proc.header.name.name}" - (prefixStmts ++ [Stmt.block s!"body_{proc.header.name.name}" proc.body.stmts #[]] ++ + (prefixStmts ++ [Stmt.block s!"body_{proc.header.name.name}" (match proc.body with | .structured ss => ss | .cfg _ => []) #[]] ++ ensuresToAsserts proc.spec.postconditions) #[] ∧ (∀ s ∈ prefixStmts, ∃ c, s = Stmt.cmd c) ∧ (∀ ρ₀, Core.Specification.ProcEnvWF proc ρ₀ → @@ -656,7 +656,7 @@ theorem procBodyVerify_procedureCorrect verifyStmt context (block verifyLabel > seq > block bodyLabel). -/ have h_embed_body : ∀ ρ₀ (h_wf : Specification.ProcEnvWF proc ρ₀) (cfg : CoreConfig), - CoreStepStar π φ (.stmts proc.body.stmts ρ₀) cfg → + CoreStepStar π φ (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) cfg → ∃ ρ_init, StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt verifyStmt ρ_init) @@ -712,7 +712,7 @@ theorem procBodyVerify_procedureCorrect -- Unified helper: all asserts reachable from proc.body are valid have body_asserts_valid : ∀ ρ₀ (h_wf : Specification.ProcEnvWF proc ρ₀) (a : AssertId Expression) (cfg : CoreConfig), - CoreStepStar π φ (.stmts proc.body.stmts ρ₀) cfg → + CoreStepStar π φ (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) cfg → coreIsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt := by intro ρ₀ h_wf a cfg h_body h_assert @@ -731,19 +731,20 @@ theorem procBodyVerify_procedureCorrect simp only [Specification.Lang.core, Specification.Lang.imperative] intro ρ₀ cfg (h_wf : Specification.ProcEnvWF proc ρ₀) (h_body : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmt (Stmt.block "" proc.body.stmts #[]) ρ₀) cfg) + (.stmt (Stmt.block "" (match proc.body with | .structured ss => ss | .cfg _ => []) #[]) ρ₀) cfg) (h_assert : coreIsAtAssert cfg a) -- Extract first step: .stmt (block "" body #[]) ρ₀ → .block "" (.stmts body ρ₀) have h_block_star : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.block "" (.stmts proc.body.stmts ρ₀)) cfg := by + (.block "" (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀)) cfg := by cases h_body with | refl => simp [coreIsAtAssert] at h_assert | step _ _ _ hstep hrest => cases hstep; exact hrest -- Body never exits (from WFProcedureProp.bodyExitsCovered) have h_no_exit : ∀ lbl ρ', ¬ StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmts proc.body.stmts ρ₀) (.exiting lbl ρ') := - block_exitsCoveredByBlocks_noEscape Expression (EvalCommand π φ) (EvalPureFunc φ) - proc.body.stmts h_wf_proc.bodyExitsCovered ρ₀ + (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) (.exiting lbl ρ') := + have ⟨ss, hss⟩ := h_wf_proc.bodyIsStructured + have hcov := h_wf_proc.bodyExitsCovered ss hss + hss ▸ block_exitsCoveredByBlocks_noEscape Expression (EvalCommand π φ) (EvalPureFunc φ) ss hcov ρ₀ -- cfg is not terminal or exiting (has an assert) have h_nt : ∀ ρ', cfg ≠ .terminal ρ' := by intro ρ' heq; subst heq; exact coreIsAtAssert_not_terminal ρ' a h_assert @@ -765,18 +766,18 @@ theorem procBodyVerify_procedureCorrect obtain ⟨ρ_init, h_prefix⟩ := h_prefix_trace ρ₀ h_wf -- h_valid: all asserts in body from ρ₀ evaluate to true have h_valid : ∀ (a : AssertId Expression) (cfg : CoreConfig), - CoreStepStar π φ (.stmts proc.body.stmts ρ₀) cfg → + CoreStepStar π φ (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) cfg → coreIsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt := fun a cfg h h' => body_asserts_valid ρ₀ h_wf a cfg h h' -- hasFailure = false have h_nf' : ρ'.hasFailure = Bool.false := Core.core_noFailure_preserved π φ - (.stmts proc.body.stmts ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term + (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term -- wfBool preservation have h_wfb_term : WellFormedSemanticEvalBool ρ'.eval := Core.core_wfBool_preserved π φ h_wf_ext - (.stmts proc.body.stmts ρ₀) (.terminal ρ') h_wf.wfBool h_term + (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) (.terminal ρ') h_wf.wfBool h_term have h_to_post : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt verifyStmt ρ_init) (.block verifyLabel (.stmts postAsserts ρ')) := by diff --git a/StrataTest/Languages/Boole/global_readonly_call.lean b/StrataTest/Languages/Boole/global_readonly_call.lean index 5bcb087121..a76a23812a 100644 --- a/StrataTest/Languages/Boole/global_readonly_call.lean +++ b/StrataTest/Languages/Boole/global_readonly_call.lean @@ -66,7 +66,9 @@ private def callHelper (p : Strata.Program) : Except String (List String) := do return cp.decls.filterMap fun d => match d with | .proc p _ => - p.body.stmts.findSome? fun + -- CFG bodies: call extraction not yet implemented for unstructured programs. + let stmts := match p.body with | .structured ss => ss | .cfg _ => [] + stmts.findSome? fun | .block _ stmts _ => stmts.findSome? fun | .cmd (.call pname args _) => some s!"call {pname}({", ".intercalate (args.map fmtCallArg)})" @@ -141,41 +143,41 @@ spec { VCs: -Label: inc_ensures_1_2424 +Label: inc_ensures_1_2576 Property: assert Assumptions: -inc_requires_0_2406: z@1 > 0 +inc_requires_0_2558: z@1 > 0 Obligation: true -Label: callElimAssert_inc_requires_0_2406_6 +Label: callElimAssert_inc_requires_0_2558_6 Property: assert Assumptions: -main_caller_requires_2_2540: z@3 == 10 -main_caller_requires_3_2560: g@3 == 0 +main_caller_requires_2_2692: z@3 == 10 +main_caller_requires_3_2712: g@3 == 0 Obligation: z@3 > 0 -Label: main_caller_ensures_4_2579 +Label: main_caller_ensures_4_2731 Property: assert Assumptions: -main_caller_requires_2_2540: z@3 == 10 -main_caller_requires_3_2560: g@3 == 0 -callElimAssume_inc_ensures_1_2424_7: g@5 == g@3 + 5 + z@5 +main_caller_requires_2_2692: z@3 == 10 +main_caller_requires_3_2712: g@3 == 0 +callElimAssume_inc_ensures_1_2576_7: g@5 == g@3 + 5 + z@5 Obligation: g@5 == 15 --- info: -Obligation: inc_ensures_1_2424 +Obligation: inc_ensures_1_2576 Property: assert Result: ✅ pass -Obligation: callElimAssert_inc_requires_0_2406_6 +Obligation: callElimAssert_inc_requires_0_2558_6 Property: assert Result: ✅ pass -Obligation: main_caller_ensures_4_2579 +Obligation: main_caller_ensures_4_2731 Property: assert Result: ❓ unknown Model: diff --git a/StrataTest/Transform/ProcedureInlining.lean b/StrataTest/Transform/ProcedureInlining.lean index 8041397111..acae0a2553 100644 --- a/StrataTest/Transform/ProcedureInlining.lean +++ b/StrataTest/Transform/ProcedureInlining.lean @@ -214,9 +214,6 @@ def alphaEquivStatement (s1 s2: Core.Statement) (map:IdMap) end -private def getStmts (p : Core.Procedure) : List Core.Statement := - match p.body with | .structured ss => ss | .cfg _ => [] - private def alphaEquivCmds (cmds1 cmds2 : List Core.Command) (map : IdMap) : Except Format IdMap := do if cmds1.length ≠ cmds2.length then From 58695e5c5ec29c9c8cfe647ccd75a78608e6e32d Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 6 May 2026 17:01:16 -0700 Subject: [PATCH 18/57] Regenerate editor syntax files for new CFG keywords (goto, cfg) --- editors/emacs/core-st-mode.el | 4 ++-- editors/vscode/syntaxes/core-st.tmLanguage.json | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/editors/emacs/core-st-mode.el b/editors/emacs/core-st-mode.el index 6bcfb271d4..9191a4dbf7 100644 --- a/editors/emacs/core-st-mode.el +++ b/editors/emacs/core-st-mode.el @@ -8,8 +8,8 @@ '( "var" "assume" "assert" "cover" "if" "else" "havoc" "invariant" "decreases" "while" "out" "inout" "call" "exit" "free" "ensures" "requires" "spec" "procedure" "type" "const" "function" "inline" - "rec" "axiom" "distinct" "datatype" "old" "forall" "exists" - "program")) + "rec" "axiom" "distinct" "datatype" "goto" "cfg" "old" "forall" + "exists" "program")) (defvar core-st-types '( "bool" "int" "string" "regex" "real" "bv1" "bv8" "bv16" "bv32" diff --git a/editors/vscode/syntaxes/core-st.tmLanguage.json b/editors/vscode/syntaxes/core-st.tmLanguage.json index 44e4208209..1837852e6d 100644 --- a/editors/vscode/syntaxes/core-st.tmLanguage.json +++ b/editors/vscode/syntaxes/core-st.tmLanguage.json @@ -57,7 +57,7 @@ }, "keyword": { "name": "keyword.core-st", - "match": "\\b(var|assume|assert|cover|if|else|havoc|invariant|decreases|while|out|inout|call|exit|free|ensures|requires|spec|procedure|type|const|function|inline|rec|axiom|distinct|datatype|old|forall|exists|program)\\b" + "match": "\\b(var|assume|assert|cover|if|else|havoc|invariant|decreases|while|out|inout|call|exit|free|ensures|requires|spec|procedure|type|const|function|inline|rec|axiom|distinct|datatype|goto|cfg|old|forall|exists|program)\\b" }, "type": { "name": "support.type.core-st", From 39acfc8a935e5d3673a1e5147deb37497a112b44 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 08:32:47 -0700 Subject: [PATCH 19/57] StatementEval returns error on nonexisting label --- Strata/Languages/Core/StatementEval.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index a7084d0dd8..3679eda3c9 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -775,7 +775,7 @@ where | 0 => env | fuel' + 1 => match cfg.blocks.lookup label with - | none => env + | none => CmdEval.updateError env (.Misc s!"runCFG: block '{label}' not found in CFG") | some blk => let cmdStmts := blk.cmds.map (Imperative.Stmt.cmd ·) match Imperative.runStmt ops fuel' (.stmts cmdStmts env) with From 15cfcf0b13e1c2e5f8cbbef19f67e1a2d8c65169 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 10:25:35 -0700 Subject: [PATCH 20/57] Refine unstructured procedure cases, add comments --- Strata/Languages/Core/WF.lean | 4 ++++ Strata/Transform/CoreTransform.lean | 6 ++++++ Strata/Transform/LoopElim.lean | 1 + Strata/Transform/ProcBodyVerify.lean | 9 ++++++++- Strata/Transform/ProcBodyVerifyCorrect.lean | 5 +++++ Strata/Transform/ProcedureInlining.lean | 9 +++++++-- StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean | 9 ++++++++- StrataTest/Languages/Core/Examples/Loops.lean | 4 +++- 8 files changed, 42 insertions(+), 5 deletions(-) diff --git a/Strata/Languages/Core/WF.lean b/Strata/Languages/Core/WF.lean index dfc69972d5..c3ed86de52 100644 --- a/Strata/Languages/Core/WF.lean +++ b/Strata/Languages/Core/WF.lean @@ -137,6 +137,10 @@ structure WFAxiomDeclarationProp (p : Program) (f : Axiom) : Prop where structure WFDistinctDeclarationProp (p : Program) (l : Expression.Ident) (es : List (Expression.Expr)) : Prop where +-- TODO: add WF properties for unstructured programs: +-- * verify block labels are unique +-- * all variables used are declared/initialized +-- * target labels of transfer commands exist structure WFProcedureProp (p : Program) (d : Procedure) : Prop where bodyIsStructured : ∃ ss, d.body = .structured ss wfstmts : ∀ ss, d.body = .structured ss → WFStatementsProp p ss diff --git a/Strata/Transform/CoreTransform.lean b/Strata/Transform/CoreTransform.lean index 3d62e93d1a..904b1adf36 100644 --- a/Strata/Transform/CoreTransform.lean +++ b/Strata/Transform/CoreTransform.lean @@ -332,6 +332,12 @@ def runProgram currentProcedureName := .some proc.header.name.1 }) + -- TODO: A `runCFGRec` counterpart could be added to apply command-level + -- transforms to CFG bodies. Since `f` returns `Option (List Statement)` + -- and a CFG block holds `List Command`, each returned statement would + -- need to be unwrapped as `.cmd`. If `f` returns nested structures + -- (blocks, if-then-else, loops), those can't be represented in a basic + -- block, so such cases would need to be rejected or left untransformed. let bodyStmts ← match proc.body with | .structured ss => pure ss | .cfg _ => pure [] diff --git a/Strata/Transform/LoopElim.lean b/Strata/Transform/LoopElim.lean index cb328493ca..887e1e6cf0 100644 --- a/Strata/Transform/LoopElim.lean +++ b/Strata/Transform/LoopElim.lean @@ -245,6 +245,7 @@ def loopElim (p : Program) : Program × Statistics := | .structured ss => let (body, st) := StateT.run (Block.removeLoopsM ss) {} ((.proc { proc with body := .structured body } md) :: acc, stats.merge st.statistics) + -- CFG bodies have no structured loops; pass through unchanged. | .cfg _ => ((.proc proc md) :: acc, stats) | other => (other :: acc, stats)) ([], {}) ({ decls := decls.reverse }, stats) diff --git a/Strata/Transform/ProcBodyVerify.lean b/Strata/Transform/ProcBodyVerify.lean index f9de6a1b4f..46f74a6237 100644 --- a/Strata/Transform/ProcBodyVerify.lean +++ b/Strata/Transform/ProcBodyVerify.lean @@ -88,7 +88,14 @@ open Core Imperative Transform -- Convert preconditions to assumes let assumes := requiresToAssumes proc.spec.preconditions - let bodyStmts := match proc.body with | .structured ss => ss | .cfg _ => [] + -- ProcBodyVerify expects a structured body: the prefix (inits + assumes) and + -- suffix (postcondition asserts) are statement-level constructs that embed + -- around the body. Unstructured CFG bodies require a different verification + -- strategy (e.g., encoding the contract directly in the CFG). + let bodyStmts ← match proc.body with + | .structured ss => pure ss + | .cfg _ => throw (Strata.DiagnosticModel.fromMessage + "procToVerifyStmt: expected structured body, got CFG") -- Wrap body in labeled block let bodyBlock := Stmt.block bodyLabel bodyStmts #[] diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index 1b8e21dad4..1740dafcc1 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -468,7 +468,9 @@ theorem procToVerifyStmt_structure ∃ ρ_init, Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmts prefixStmts ρ_init) (.terminal ρ₀)) := by + obtain ⟨ss, h_body_eq⟩ := h_wf_proc.bodyIsStructured unfold procToVerifyStmt at h + rw [h_body_eq] at h simp only [bind, ExceptT.bind, ExceptT.mk, ExceptT.run, ExceptT.bindCont, pure, ExceptT.pure, StateT.bind] at h rw [mapM_stateT_pure_eq] at h @@ -483,6 +485,9 @@ theorem procToVerifyStmt_structure (.det (LExpr.fvar () id none)) #[] let assumes := requiresToAssumes proc.spec.preconditions let prefixStmts := inputInits ++ outputOnlyInits ++ oldInoutInits ++ assumes + have h_body_match : (match proc.body with | .structured ss => ss | .cfg _ => []) = ss := by + rw [h_body_eq] + rw [h_body_match] refine ⟨prefixStmts, h_eq.symm, ?_, ?_⟩ · intro s hs simp only [prefixStmts, List.mem_append] at hs diff --git a/Strata/Transform/ProcedureInlining.lean b/Strata/Transform/ProcedureInlining.lean index 6d6c533563..f2f2d0311f 100644 --- a/Strata/Transform/ProcedureInlining.lean +++ b/Strata/Transform/ProcedureInlining.lean @@ -93,9 +93,14 @@ private def renameAllLocalNames (c:Procedure) let var_map: Map Expression.Ident Expression.Ident := [] let proc_name := c.header.name.name - -- Make a map for renaming local variables + -- Extract local names from the body. Although ProcedureInlining only supports + -- structured bodies for inlining, extracting defined variables is a generic + -- facility that supports both structured and CFG bodies. + let lhs_vars := match c.body with + | .structured ss => ss.flatMap (fun (s : Statement) => s.definedVars) + | .cfg cfg => cfg.blocks.flatMap fun (_, blk) => + blk.cmds.flatMap Command.definedVars let bodyStmts := match c.body with | .structured ss => ss | .cfg _ => [] - let lhs_vars := List.flatMap (fun (s:Statement) => s.definedVars) bodyStmts let lhs_vars := lhs_vars ++ c.header.inputs.unzip.fst ++ c.header.outputs.unzip.fst let var_map <- genOldToFreshIdMappings lhs_vars var_map proc_name diff --git a/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean b/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean index 60fbf7e1f9..d0e01422e8 100644 --- a/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean +++ b/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean @@ -344,13 +344,20 @@ private def injectPropertySummary (stmts : List Core.Statement) (msg : String) .cmd (.cmd (.assert label b (md.withPropertySummary msg))) | other => other +-- TODO: This could be split into a two-stage transformation: +-- 1. structured → cfg (via StructuredToUnstructured) +-- 2. cfg → CProverGOTO (always operates on CFG, no pattern matching needed) +-- For now, unstructured bodies are not supported in this test helper. private def coreToGotoJsonWithSummary (p : Strata.Program) (summary : String) : Except Std.Format (Lean.Json × Lean.Json) := do let cprog := translateCore p let Env := Lambda.TEnv.default let procs := cprog.decls.filterMap fun d => d.getProc? let p := procs[0]! - let p' : Core.Procedure := { p with body := .structured (injectPropertySummary (match p.body with | .structured ss => ss | .cfg _ => []) summary) } + let bodyStmts ← match p.body with + | .structured ss => pure ss + | .cfg _ => .error f!"coreToGotoJsonWithSummary: CFG body not supported" + let p' : Core.Procedure := { p with body := .structured (injectPropertySummary bodyStmts summary) } let pname := Core.CoreIdent.toPretty p'.header.name let ctx ← procedureToGotoCtx Env p' let json ← (CoreToGOTO.CProverGOTO.Context.toJson pname ctx.1).mapError (fun e => f!"{e}") diff --git a/StrataTest/Languages/Core/Examples/Loops.lean b/StrataTest/Languages/Core/Examples/Loops.lean index 2b32f78c60..48ca96bec4 100644 --- a/StrataTest/Languages/Core/Examples/Loops.lean +++ b/StrataTest/Languages/Core/Examples/Loops.lean @@ -15,7 +15,9 @@ def singleCFG (p : Program) (n : Nat) : Imperative.CFG String let corePgm : Core.Program := TransM.run Inhabited.default (translateProgram p) |>.fst let proc := match corePgm.decls[n]? with | .some (.proc p _) => p | _ => Inhabited.default - Imperative.stmtsToCFG (match proc.body with | .structured ss => ss | .cfg _ => []) + match proc.body with + | .structured ss => Imperative.stmtsToCFG ss + | .cfg cfg => cfg --------------------------------------------------------------------- From 9d1de97a2bddf0f51a63220a37f5ffa49f22e9c1 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 10:44:27 -0700 Subject: [PATCH 21/57] define variable infrastructures --- Strata/Languages/Core/Procedure.lean | 36 ++++++++++++++++++------ Strata/Languages/Core/ProcedureEval.lean | 13 +++++++-- Strata/Transform/ProcedureInlining.lean | 5 +--- 3 files changed, 38 insertions(+), 16 deletions(-) diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 5eff596b28..8b0580eea4 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -362,33 +362,51 @@ instance : HasVarsPure Expression Procedure where instance : HasVarsPure Expression Procedure.Body where getVars := Procedure.Body.getVars +instance : HasVarsImp Expression DetCFG where + definedVars cfg := cfg.blocks.flatMap fun (_, blk) => + blk.cmds.flatMap Command.definedVars + modifiedVars cfg := cfg.blocks.flatMap fun (_, blk) => + blk.cmds.flatMap Command.modifiedVars + instance : HasVarsImp Expression Procedure.Body where definedVars b := match b with | .structured ss => HasVarsImp.definedVars ss - | .cfg cfgBody => cfgBody.blocks.flatMap fun (_, blk) => - blk.cmds.filterMap fun | .cmd (.init n _ _ _) => some n | _ => none + | .cfg cfgBody => HasVarsImp.definedVars cfgBody modifiedVars b := match b with | .structured ss => HasVarsImp.modifiedVars ss - | .cfg cfgBody => cfgBody.blocks.flatMap fun (_, blk) => - blk.cmds.filterMap fun - | .cmd (.set n _ _) => some n - | .cmd (.init n _ _ _) => some n - | _ => none + | .cfg cfgBody => HasVarsImp.modifiedVars cfgBody instance : HasVarsImp Expression Procedure where definedVars := Procedure.definedVars modifiedVars := Procedure.modifiedVars +def DetCFG.eraseTypes (cfg : DetCFG) : DetCFG := + { cfg with blocks := cfg.blocks.map fun (lbl, blk) => + (lbl, { blk with cmds := blk.cmds.map Command.eraseTypes, + transfer := match blk.transfer with + | .condGoto p lt lf md => .condGoto p.eraseTypes lt lf md + | .finish md => .finish md }) } + +-- DetCFG.stripMetaData clears metadata from transfer commands. Currently, +-- commands inside blocks carry no standalone metadata field, so only +-- transfer metadata is stripped. This mirrors Block.stripMetaData for +-- structured bodies and ensures a uniform interface. +def DetCFG.stripMetaData (cfg : DetCFG) : DetCFG := + { cfg with blocks := cfg.blocks.map fun (lbl, blk) => + (lbl, { blk with transfer := match blk.transfer with + | .condGoto p lt lf _ => .condGoto p lt lf .empty + | .finish _ => .finish .empty }) } + def Procedure.eraseTypes (p : Procedure) : Procedure := let body' := match p.body with | .structured ss => .structured (Statements.eraseTypes ss) - | .cfg c => .cfg c + | .cfg c => .cfg c.eraseTypes { p with body := body', spec := p.spec } def Procedure.stripMetaData (p : Procedure) : Procedure := let body' := match p.body with | .structured ss => .structured (Imperative.Block.stripMetaData ss) - | .cfg c => .cfg c + | .cfg c => .cfg c.stripMetaData { p with body := body' } /-- Transitive variable lookup for procedures. diff --git a/Strata/Languages/Core/ProcedureEval.lean b/Strata/Languages/Core/ProcedureEval.lean index 2fd6d3b0cf..83f81d63f6 100644 --- a/Strata/Languages/Core/ProcedureEval.lean +++ b/Strata/Languages/Core/ProcedureEval.lean @@ -113,9 +113,16 @@ def eval (E : Env) (p : Procedure) : Env × Statistics := /- the assumptions from preconditions are set to have empty metadata -/ (.assume label check.expr check.md)) p.spec.preconditions - let bodyStmts := match p.body with | .structured ss => ss | .cfg _ => [] - let (ssEs, evalStats) := Statement.eval E old_g_subst (precond_assumes ++ bodyStmts ++ postcond_asserts) - (mergeResults E (ssEs.map (fun sE => fixupError sE)), evalStats) + -- Symbolic evaluation of CFG bodies is not yet implemented: it would require + -- control-flow-following with path merging at join points, significantly + -- increasing complexity. For now, only structured bodies are supported. + match p.body with + | .cfg _ => + ({ E with error := some (.Misc + s!"Procedure.eval: symbolic evaluation of CFG bodies is not implemented (procedure '{p.header.name}')") }, {}) + | .structured bodyStmts => + let (ssEs, evalStats) := Statement.eval E old_g_subst (precond_assumes ++ bodyStmts ++ postcond_asserts) + (mergeResults E (ssEs.map (fun sE => fixupError sE)), evalStats) --------------------------------------------------------------------- diff --git a/Strata/Transform/ProcedureInlining.lean b/Strata/Transform/ProcedureInlining.lean index f2f2d0311f..a23f59f979 100644 --- a/Strata/Transform/ProcedureInlining.lean +++ b/Strata/Transform/ProcedureInlining.lean @@ -96,10 +96,7 @@ private def renameAllLocalNames (c:Procedure) -- Extract local names from the body. Although ProcedureInlining only supports -- structured bodies for inlining, extracting defined variables is a generic -- facility that supports both structured and CFG bodies. - let lhs_vars := match c.body with - | .structured ss => ss.flatMap (fun (s : Statement) => s.definedVars) - | .cfg cfg => cfg.blocks.flatMap fun (_, blk) => - blk.cmds.flatMap Command.definedVars + let lhs_vars : List Expression.Ident := Imperative.HasVarsImp.definedVars c.body let bodyStmts := match c.body with | .structured ss => ss | .cfg _ => [] let lhs_vars := lhs_vars ++ c.header.inputs.unzip.fst ++ c.header.outputs.unzip.fst From 7e208055defedf857d924afdd0cd9ef3ed3a4d7a Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 11:40:38 -0700 Subject: [PATCH 22/57] refactor --- Strata/DL/Imperative/BasicBlock.lean | 20 +++++++ Strata/Languages/Core/Procedure.lean | 12 ++--- Strata/Transform/CoreSpecification.lean | 58 +++++++++++++++++++-- Strata/Transform/CoreTransform.lean | 3 +- Strata/Transform/ProcBodyVerifyCorrect.lean | 35 ++++++++----- 5 files changed, 101 insertions(+), 27 deletions(-) diff --git a/Strata/DL/Imperative/BasicBlock.lean b/Strata/DL/Imperative/BasicBlock.lean index c956006655..fc4dafb47a 100644 --- a/Strata/DL/Imperative/BasicBlock.lean +++ b/Strata/DL/Imperative/BasicBlock.lean @@ -80,6 +80,26 @@ 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 + +/-- 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) diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 8b0580eea4..417e2dcebe 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -387,15 +387,11 @@ def DetCFG.eraseTypes (cfg : DetCFG) : DetCFG := | .condGoto p lt lf md => .condGoto p.eraseTypes lt lf md | .finish md => .finish md }) } --- DetCFG.stripMetaData clears metadata from transfer commands. Currently, --- commands inside blocks carry no standalone metadata field, so only --- transfer metadata is stripped. This mirrors Block.stripMetaData for --- structured bodies and ensures a uniform interface. +-- DetCFG.stripMetaData delegates to the generic CFG.stripDetMetaData from +-- BasicBlock.lean. Commands inside blocks carry no standalone metadata field, +-- so only transfer metadata is stripped. def DetCFG.stripMetaData (cfg : DetCFG) : DetCFG := - { cfg with blocks := cfg.blocks.map fun (lbl, blk) => - (lbl, { blk with transfer := match blk.transfer with - | .condGoto p lt lf _ => .condGoto p lt lf .empty - | .finish _ => .finish .empty }) } + Imperative.CFG.stripDetMetaData cfg def Procedure.eraseTypes (p : Procedure) : Procedure := let body' := match p.body with diff --git a/Strata/Transform/CoreSpecification.lean b/Strata/Transform/CoreSpecification.lean index 35fa5780b4..7b1ece5a01 100644 --- a/Strata/Transform/CoreSpecification.lean +++ b/Strata/Transform/CoreSpecification.lean @@ -39,6 +39,47 @@ open Core Imperative Imperative.Specification.Lang.imperative Expression Command (EvalCommand π φ) (EvalPureFunc φ) coreIsAtAssert +/-! ## Core CFG `Lang` bundle -/ + +/-- Configuration for CFG specification: pairs a `CFGConfig` with the eval + function so that `getEnv` can reconstruct a full `Env Expression`. -/ +structure CoreCFGSpecConfig where + cfgConfig : CFGConfig String Expression + eval : CoreEval + +/-- Extract an `Env Expression` from a CFG specification config. -/ +def CoreCFGSpecConfig.toEnv (c : CoreCFGSpecConfig) : Env Expression := + match c.cfgConfig with + | .cont _ σ f => ⟨σ, c.eval, f⟩ + | .terminal σ f => ⟨σ, c.eval, f⟩ + +/-- Assert detection in a CFG: an assert is reachable if the current block + (looked up by the continuation label in a given CFG) contains an assert + command with the matching label and expression. -/ +def coreCFGIsAtAssert (cfg : DetCFG) : CoreCFGSpecConfig → AssertId Expression → Prop + | ⟨.cont lbl _ _, _⟩, aid => + match cfg.blocks.lookup lbl with + | some blk => blk.cmds.any fun + | .cmd (.assert l e _) => l == aid.label && e == aid.expr + | _ => false + | none => False + | ⟨.terminal _ _, _⟩, _ => False + +/-- The `Lang Expression` bundle for Core CFG small-step semantics. -/ +@[expose] def Lang.coreCFG + (π : String → Option Procedure) + (φ : CoreEval → PureFunc Expression → CoreEval) + (cfg : DetCFG) : + Imperative.Specification.Lang Expression where + StmtT := DetCFG + CfgT := CoreCFGSpecConfig + star := fun c₁ c₂ => CoreCFGStepStar π φ cfg c₁.cfgConfig c₂.cfgConfig + stmtCfg := fun _ ρ => ⟨.cont cfg.entry ρ.store false, ρ.eval⟩ + terminalCfg := fun ρ => ⟨.terminal ρ.store ρ.hasFailure, ρ.eval⟩ + exitingCfg := fun _ ρ => ⟨.terminal ρ.store ρ.hasFailure, ρ.eval⟩ + isAtAssert := coreCFGIsAtAssert cfg + getEnv := CoreCFGSpecConfig.toEnv + /-! ## Well-formed program state at the entry of procedure -/ /-- The list of variables that must have been declared, @@ -81,8 +122,13 @@ variable (φ : CoreEval → PureFunc Expression → CoreEval) @[expose] def AssertValidInProcedure (proc : Procedure) (a : Imperative.AssertId Expression) : Prop := - Imperative.Specification.AssertValidWhen (Specification.Lang.core π φ) - (ProcEnvWF proc) (Stmt.block "" (match proc.body with | .structured ss => ss | .cfg _ => []) #[]) a + match proc.body with + | .structured ss => + Imperative.Specification.AssertValidWhen (Specification.Lang.core π φ) + (ProcEnvWF proc) (Stmt.block "" ss #[]) a + | .cfg cfg => + Imperative.Specification.AssertValidWhen (Specification.Lang.coreCFG π φ cfg) + (ProcEnvWF proc) cfg a /-- A procedure is correct with respect to its specification. @@ -138,12 +184,16 @@ variable (φ : CoreEval → PureFunc Expression → CoreEval) structure ProcedureCorrect (proc : Procedure) (p : Program) : Prop where /-- (1) The asserts in the body of proc are valid. -/ assertsValid : ∀ a, AssertValidInProcedure π φ proc a - /-- (2) The postconditions hold on termination. -/ + /-- (2) The postconditions hold on termination. + For structured bodies, termination is witnessed by `CoreStepStar`. + For CFG bodies, use `CoreCFGStepStar` (via `Lang.coreCFG`). -/ postconditionsValid : WF.WFProcedureProp p proc → ∀ (ρ₀ ρ' : Env Expression), ProcEnvWF proc ρ₀ → - CoreStepStar π φ (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) (.terminal ρ') → + CoreStepStar π φ + (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) + (.terminal ρ') → (∀ (label : CoreLabel) (check : Procedure.Check), (label, check) ∈ proc.spec.postconditions.toList → check.attr = Procedure.CheckAttr.Default → diff --git a/Strata/Transform/CoreTransform.lean b/Strata/Transform/CoreTransform.lean index 904b1adf36..0cb66a3fde 100644 --- a/Strata/Transform/CoreTransform.lean +++ b/Strata/Transform/CoreTransform.lean @@ -340,7 +340,8 @@ def runProgram -- block, so such cases would need to be rejected or left untransformed. let bodyStmts ← match proc.body with | .structured ss => pure ss - | .cfg _ => pure [] + | .cfg _ => throw (Strata.DiagnosticModel.fromMessage + s!"runProgram: cannot apply statement-level transform to CFG body (procedure '{proc.header.name.1}')") let (changed, new_body) ← runStmtsRec f bodyStmts if changed then diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index 1740dafcc1..6e12546c47 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -649,8 +649,12 @@ theorem procBodyVerify_procedureCorrect -- Conclusion: ProcedureCorrect holds. Core.Specification.ProcedureCorrect π φ proc p := by + obtain ⟨ss, h_body_eq⟩ := h_wf_proc.bodyIsStructured + have h_body_match : (match proc.body with | .structured ss => ss | .cfg _ => []) = ss := by + rw [h_body_eq] obtain ⟨prefixStmts, h_eq, h_prefix_cmd, h_prefix_trace⟩ := procToVerifyStmt_structure proc p st st' verifyStmt h_transform π φ h_wf_proc + rw [h_body_match] at h_eq let verifyLabel := s!"verify_{proc.header.name.name}" let bodyLabel := s!"body_{proc.header.name.name}" let postAsserts := ensuresToAsserts proc.spec.postconditions @@ -661,7 +665,7 @@ theorem procBodyVerify_procedureCorrect verifyStmt context (block verifyLabel > seq > block bodyLabel). -/ have h_embed_body : ∀ ρ₀ (h_wf : Specification.ProcEnvWF proc ρ₀) (cfg : CoreConfig), - CoreStepStar π φ (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) cfg → + CoreStepStar π φ (.stmts ss ρ₀) cfg → ∃ ρ_init, StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt verifyStmt ρ_init) @@ -717,7 +721,7 @@ theorem procBodyVerify_procedureCorrect -- Unified helper: all asserts reachable from proc.body are valid have body_asserts_valid : ∀ ρ₀ (h_wf : Specification.ProcEnvWF proc ρ₀) (a : AssertId Expression) (cfg : CoreConfig), - CoreStepStar π φ (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) cfg → + CoreStepStar π φ (.stmts ss ρ₀) cfg → coreIsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt := by intro ρ₀ h_wf a cfg h_body h_assert @@ -732,24 +736,25 @@ theorem procBodyVerify_procedureCorrect · ----- Part 1: All asserts in proc.body are valid ----- intro a - unfold Specification.AssertValidInProcedure Specification.AssertValidWhen + unfold Specification.AssertValidInProcedure + rw [h_body_eq] + unfold Specification.AssertValidWhen simp only [Specification.Lang.core, Specification.Lang.imperative] intro ρ₀ cfg (h_wf : Specification.ProcEnvWF proc ρ₀) (h_body : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmt (Stmt.block "" (match proc.body with | .structured ss => ss | .cfg _ => []) #[]) ρ₀) cfg) + (.stmt (Stmt.block "" ss #[]) ρ₀) cfg) (h_assert : coreIsAtAssert cfg a) -- Extract first step: .stmt (block "" body #[]) ρ₀ → .block "" (.stmts body ρ₀) have h_block_star : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.block "" (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀)) cfg := by + (.block "" (.stmts ss ρ₀)) cfg := by cases h_body with | refl => simp [coreIsAtAssert] at h_assert | step _ _ _ hstep hrest => cases hstep; exact hrest -- Body never exits (from WFProcedureProp.bodyExitsCovered) have h_no_exit : ∀ lbl ρ', ¬ StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) (.exiting lbl ρ') := - have ⟨ss, hss⟩ := h_wf_proc.bodyIsStructured - have hcov := h_wf_proc.bodyExitsCovered ss hss - hss ▸ block_exitsCoveredByBlocks_noEscape Expression (EvalCommand π φ) (EvalPureFunc φ) ss hcov ρ₀ + (.stmts ss ρ₀) (.exiting lbl ρ') := + have hcov := h_wf_proc.bodyExitsCovered ss h_body_eq + block_exitsCoveredByBlocks_noEscape Expression (EvalCommand π φ) (EvalPureFunc φ) ss hcov ρ₀ -- cfg is not terminal or exiting (has an assert) have h_nt : ∀ ρ', cfg ≠ .terminal ρ' := by intro ρ' heq; subst heq; exact coreIsAtAssert_not_terminal ρ' a h_assert @@ -768,21 +773,23 @@ theorem procBodyVerify_procedureCorrect · ----- Part 2: Postconditions + hasFailure on termination ----- intro h_wf_proc ρ₀ ρ' h_wf h_term + have h_term_ss : CoreStepStar π φ (.stmts ss ρ₀) (.terminal ρ') := + h_body_match ▸ h_term obtain ⟨ρ_init, h_prefix⟩ := h_prefix_trace ρ₀ h_wf -- h_valid: all asserts in body from ρ₀ evaluate to true have h_valid : ∀ (a : AssertId Expression) (cfg : CoreConfig), - CoreStepStar π φ (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) cfg → + CoreStepStar π φ (.stmts ss ρ₀) cfg → coreIsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt := - fun a cfg h h' => body_asserts_valid ρ₀ h_wf a cfg h h' + fun a cfg h h' => body_asserts_valid ρ₀ h_wf a cfg (h_body_match ▸ h) h' -- hasFailure = false have h_nf' : ρ'.hasFailure = Bool.false := Core.core_noFailure_preserved π φ - (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term + (.stmts ss ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term_ss -- wfBool preservation have h_wfb_term : WellFormedSemanticEvalBool ρ'.eval := Core.core_wfBool_preserved π φ h_wf_ext - (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) (.terminal ρ') h_wf.wfBool h_term + (.stmts ss ρ₀) (.terminal ρ') h_wf.wfBool h_term_ss have h_to_post : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt verifyStmt ρ_init) (.block verifyLabel (.stmts postAsserts ρ')) := by @@ -801,7 +808,7 @@ theorem procBodyVerify_procedureCorrect (ReflTrans_Transitive _ _ _ _ (step_block_enter Expression (EvalCommand π φ) (EvalPureFunc φ) bodyLabel _ #[] ρ₀) (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ bodyLabel - (CoreStepStar_to_StepStmtStar h_term)))) + (CoreStepStar_to_StepStmtStar h_term_ss)))) (ReflTrans_Transitive _ _ _ _ (seq_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ postAsserts (.step _ _ _ .step_block_done (.refl _))) From 03c940e4f7d730cd98ce9dd3df566dab5ddd19fe Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 12:00:59 -0700 Subject: [PATCH 23/57] Precond Elim for CFGs --- Strata/Transform/PrecondElim.lean | 104 +++++++++++++++++++++++------- 1 file changed, 81 insertions(+), 23 deletions(-) diff --git a/Strata/Transform/PrecondElim.lean b/Strata/Transform/PrecondElim.lean index 3135694bce..2473e33b54 100644 --- a/Strata/Transform/PrecondElim.lean +++ b/Strata/Transform/PrecondElim.lean @@ -87,19 +87,12 @@ so expression-level metadata carries no source location. We therefore inherit the enclosing statement's `md` (with `propertySummary` stripped to prevent user-facing messages from leaking into generated checks). -/ -def collectPrecondAsserts (F : @Lambda.Factory CoreLParams) (e : Expression.Expr) +def collectPrecondAssertCmds (F : @Lambda.Factory CoreLParams) (e : Expression.Expr) (labelPrefix : String) (md : Imperative.MetaData Expression) -: List Statement := +: List (Imperative.Cmd Expression) := let wfObs := Lambda.collectWFObligations F e - -- Strip propertySummary: the enclosing statement's user-facing message - -- (e.g., a Python assert message) should not propagate to generated - -- precondition checks for called functions. let md := md.eraseAllElems Imperative.MetaData.propertySummary - -- Use modulo to cycle the precondition index correctly across call sites. - -- For nested calls like SafeSDiv(SafeSDiv(x,y),z), obligations arrive as - -- [inner-0, inner-1, outer-0, outer-1] with the same funcName throughout. - -- Without modulo, the index would be 0,1,2,3 instead of 0,1,0,1. - let (_, _, result) := wfObs.foldl (init := ("", 0, ([] : List Statement))) + let (_, _, result) := wfObs.foldl (init := ("", 0, ([] : List (Imperative.Cmd Expression)))) fun (prevFunc, prevIdx, acc) ob => let rawIdx := if ob.funcName == prevFunc then prevIdx + 1 else 0 let precondCount := F[ob.funcName]?.map (·.preconditions.length) |>.getD 1 @@ -108,32 +101,52 @@ def collectPrecondAsserts (F : @Lambda.Factory CoreLParams) (e : Expression.Expr let md' := match classifyPrecondition ob.funcName precondIdx with | some pt => md.pushElem Imperative.MetaData.propertyType (.msg pt) | none => md - let stmt := Statement.assert + let cmd := Imperative.Cmd.assert s!"{labelPrefix}_calls_{ob.funcName}_{globalIdx}" ob.obligation md' - (ob.funcName, rawIdx, stmt :: acc) + (ob.funcName, rawIdx, cmd :: acc) result.reverse +private def cmdsToStatements (cs : List (Imperative.Cmd Expression)) : List Statement := + cs.map (fun c => Imperative.Stmt.cmd (CmdExt.cmd c)) + +private def cmdsToCommands (cs : List (Imperative.Cmd Expression)) : List Command := + cs.map CmdExt.cmd + +def collectPrecondAsserts (F : @Lambda.Factory CoreLParams) (e : Expression.Expr) +(labelPrefix : String) (md : Imperative.MetaData Expression) +: List Statement := + cmdsToStatements (collectPrecondAssertCmds F e labelPrefix md) + /-- Collect assertions for all expressions in a command. -/ -def collectCmdPrecondAsserts (F : @Lambda.Factory CoreLParams) - (cmd : Imperative.Cmd Expression) : List Statement := +def collectCmdPrecondAssertCmds (F : @Lambda.Factory CoreLParams) + (cmd : Imperative.Cmd Expression) : List (Imperative.Cmd Expression) := match cmd with - | .init _ _ (.det e) md => collectPrecondAsserts F e "init" md + | .init _ _ (.det e) md => collectPrecondAssertCmds F e "init" md | .init _ _ .nondet _ => [] - | .set x (.det e) md => collectPrecondAsserts F e s!"set_{x.name}" md + | .set x (.det e) md => collectPrecondAssertCmds F e s!"set_{x.name}" md | .set _ .nondet _ => [] - | .assert l e md => collectPrecondAsserts F e s!"assert_{l}" md - | .assume l e md => collectPrecondAsserts F e s!"assume_{l}" md - | .cover l e md => collectPrecondAsserts F e s!"cover_{l}" md + | .assert l e md => collectPrecondAssertCmds F e s!"assert_{l}" md + | .assume l e md => collectPrecondAssertCmds F e s!"assume_{l}" md + | .cover l e md => collectPrecondAssertCmds F e s!"cover_{l}" md + +def collectCmdPrecondAsserts (F : @Lambda.Factory CoreLParams) + (cmd : Imperative.Cmd Expression) : List Statement := + cmdsToStatements (collectCmdPrecondAssertCmds F cmd) /-- Collect assertions for call arguments. -/ +def collectCallPrecondAssertCmds (F : @Lambda.Factory CoreLParams) (pname : String) + (args : List Expression.Expr) (md : Imperative.MetaData Expression) + : List (Imperative.Cmd Expression) := + args.flatMap fun arg => collectPrecondAssertCmds F arg s!"call_{pname}_arg" md + def collectCallPrecondAsserts (F : @Lambda.Factory CoreLParams) (pname : String) (args : List Expression.Expr) (md : Imperative.MetaData Expression) : List Statement := - args.flatMap fun arg => collectPrecondAsserts F arg s!"call_{pname}_arg" md + cmdsToStatements (collectCallPrecondAssertCmds F pname args md) /-! ## Processing contract conditions -/ @@ -340,6 +353,46 @@ def transformStmt (s : Statement) decreasing_by all_goals term_by_mem end +/-! ## CFG transformation -/ + +/-- Transform a single command in a CFG block, prepending precondition asserts. -/ +def transformCFGCmd (F : @Lambda.Factory CoreLParams) (cmd : Command) + : Bool × List Command := + match cmd with + | .cmd c => + let asserts := collectCmdPrecondAssertCmds F c + (!asserts.isEmpty, cmdsToCommands asserts ++ [.cmd c]) + | .call pname callArgs md => + let asserts := collectCallPrecondAssertCmds F pname (CallArg.getInputExprs callArgs) md + (!asserts.isEmpty, cmdsToCommands asserts ++ [.call pname callArgs md]) + +/-- Transform all commands in a CFG block. -/ +def transformCFGCmds (F : @Lambda.Factory CoreLParams) (cmds : List Command) + : Bool × List Command := + cmds.foldl (fun (changed, acc) cmd => + let (c, cmds') := transformCFGCmd F cmd + (changed || c, acc ++ cmds')) (false, []) + +/-- Transform a DetBlock: transform commands and add asserts for the transfer condition. -/ +def transformDetBlock (F : @Lambda.Factory CoreLParams) + (blk : Imperative.DetBlock String Command Expression) + : Bool × Imperative.DetBlock String Command Expression := + let (changed, cmds') := transformCFGCmds F blk.cmds + let (transferChanged, transferAsserts) := match blk.transfer with + | .condGoto cond _ _ md => + let asserts := collectPrecondAssertCmds F cond "branch_cond" md + (!asserts.isEmpty, cmdsToCommands asserts) + | .finish _ => (false, []) + (changed || transferChanged, ⟨cmds' ++ transferAsserts, blk.transfer⟩) + +/-- Transform an entire DetCFG. -/ +def transformDetCFG (F : @Lambda.Factory CoreLParams) (cfg : DetCFG) + : Bool × DetCFG := + let (changed, blocks') := cfg.blocks.foldl (fun (changed, acc) (label, blk) => + let (c, blk') := transformDetBlock F blk + (changed || c, acc ++ [(label, blk')])) (false, []) + (changed, { cfg with blocks := blocks' }) + /-! ## Main transformation -/ /-- Add a precondition-WF procedure as a leaf node in the cached call graph. @@ -377,10 +430,15 @@ where match d with | .proc proc md => do let F ← getFactory - let bodyStmts := match proc.body with | .structured ss => ss | .cfg _ => [] - let (changed, body') ← transformStmts bodyStmts + let (changed, body') ← match proc.body with + | .structured ss => do + let (c, ss') ← transformStmts ss + pure (c, Procedure.Body.structured ss') + | .cfg cfg => + let (c, cfg') := transformDetCFG F cfg + pure (c, Procedure.Body.cfg cfg') setFactory F - let proc' := { proc with body := .structured body' } + let proc' := { proc with body := body' } let procDecl := Decl.proc proc' md let (changed', rest') ← transformDecls rest match mkContractWFProc F proc md with From eba79e401256d241a0dba6dbeb3bad3a19f0b869 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 12:09:59 -0700 Subject: [PATCH 24/57] add error branch for renameAllLocalNames in ProcedureInlining --- Strata/Transform/ProcedureInlining.lean | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/Strata/Transform/ProcedureInlining.lean b/Strata/Transform/ProcedureInlining.lean index a23f59f979..adddd674b0 100644 --- a/Strata/Transform/ProcedureInlining.lean +++ b/Strata/Transform/ProcedureInlining.lean @@ -115,12 +115,17 @@ private def renameAllLocalNames (c:Procedure) -- by genOldToFreshIdMappings (counter-based), so a fresh new_id cannot collide with -- a later old_id. The iteration is intentionally sequential because each step also -- renames LHS variables and labels. - let new_body := List.map (fun (s0:Statement) => - var_map.foldl (fun (s:Statement) (old_id,new_id) => - let s := Statement.substFvar s old_id (.fvar () new_id .none) - let s := Statement.renameLhs s old_id new_id - Statement.replaceLabels s label_map) - s0) bodyStmts + let new_body : Procedure.Body ← match c.body with + | .structured bodyStmts => + pure <| .structured (List.map (fun (s0:Statement) => + var_map.foldl (fun (s:Statement) (old_id,new_id) => + let s := Statement.substFvar s old_id (.fvar () new_id .none) + let s := Statement.renameLhs s old_id new_id + Statement.replaceLabels s label_map) + s0) bodyStmts) + | .cfg _ => + throw (Strata.DiagnosticModel.fromMessage + "renameAllLocalNames: CFG body renaming not yet implemented") let new_header := { c.header with inputs := c.header.inputs.map (fun (id,ty) => match var_map.find? id with @@ -131,7 +136,7 @@ private def renameAllLocalNames (c:Procedure) | .some id' => (id',ty) | .none => panic! "unreachable") } - return ({ c with body := .structured new_body, header := new_header }, var_map) + return ({ c with body := new_body, header := new_header }, var_map) /-- Update the call graph after inlining one f(caller) -> g(callee) invocation. -/ From c993332220ab4ffabf9eb441794894645099cba0 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 14:32:52 -0700 Subject: [PATCH 25/57] intermediate proof fix --- Strata/Languages/Core/Procedure.lean | 6 ++++++ Strata/Transform/ProcBodyVerifyCorrect.lean | 15 ++++++++++++--- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 417e2dcebe..1fc21d0445 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -295,16 +295,19 @@ inductive Procedure.Body where deriving Inhabited /-- Extract the structured statements, or error if the body is a CFG. -/ +@[simp, expose] def Procedure.Body.getStructured : Procedure.Body → Except String (List Statement) | .structured ss => .ok ss | .cfg _ => .error "expected structured body, got CFG" /-- Extract the CFG, or error if the body is structured. -/ +@[simp] def Procedure.Body.getCfg : Procedure.Body → Except String DetCFG | .cfg c => .ok c | .structured _ => .error "expected CFG body, got structured" /-- Get variables referenced in the body. -/ +@[simp] def Procedure.Body.getVars : Procedure.Body → List Expression.Ident | .structured ss => ss.flatMap Imperative.HasVarsPure.getVars | .cfg c => c.blocks.flatMap fun (_, blk) => @@ -312,16 +315,19 @@ def Procedure.Body.getVars : Procedure.Body → List Expression.Ident /-- Is this body abstract (no implementation)? Only empty structured bodies are abstract. CFG bodies always have an implementation. -/ +@[simp] def Procedure.Body.isAbstract : Procedure.Body → Bool | .structured ss => ss.isEmpty | .cfg _ => false /-- Does this body have a structured implementation? -/ +@[simp] def Procedure.Body.isStructured : Procedure.Body → Bool | .structured _ => true | .cfg _ => false /-- Does this body have a CFG implementation? -/ +@[simp] def Procedure.Body.isCfg : Procedure.Body → Bool | .structured _ => false | .cfg _ => true diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index 6e12546c47..4a7c18ca7a 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -447,6 +447,16 @@ private theorem mapM_stateT_pure_eq {α β : Type} {σ : Type} {ε : Type} /-! ## Verification Statement Structure -/ +theorem procToVerifyStmt_is_structured + (h : (procToVerifyStmt proc).run st = (Except.ok verifyStmt, st')) : + ∃ ss, proc.body = .structured ss := by + simp [ExceptT.run, procToVerifyStmt] at h + cases hb: proc.body with + | structured ss => simp + | cfg blk => + simp [hb] at h + cases h + /-- Structure: the output of `procToVerifyStmt` is a block `prefix ++ [bodyBlock] ++ postAsserts`, and all prefix statements are `.cmd` (init/assume commands). @@ -468,7 +478,7 @@ theorem procToVerifyStmt_structure ∃ ρ_init, Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmts prefixStmts ρ_init) (.terminal ρ₀)) := by - obtain ⟨ss, h_body_eq⟩ := h_wf_proc.bodyIsStructured + obtain ⟨ss, h_body_eq⟩ := procToVerifyStmt_is_structured h unfold procToVerifyStmt at h rw [h_body_eq] at h simp only [bind, ExceptT.bind, ExceptT.mk, ExceptT.run, ExceptT.bindCont, @@ -648,8 +658,7 @@ theorem procBodyVerify_procedureCorrect (h_wf_proc : WF.WFProcedureProp p proc) : -- Conclusion: ProcedureCorrect holds. Core.Specification.ProcedureCorrect π φ proc p := by - - obtain ⟨ss, h_body_eq⟩ := h_wf_proc.bodyIsStructured + obtain ⟨ss, h_body_eq⟩ := procToVerifyStmt_is_structured h_transform have h_body_match : (match proc.body with | .structured ss => ss | .cfg _ => []) = ss := by rw [h_body_eq] obtain ⟨prefixStmts, h_eq, h_prefix_cmd, h_prefix_trace⟩ := From e6d71f71c6dffbd25a261f7cd8c20f949ae4c6e2 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 14:48:59 -0700 Subject: [PATCH 26/57] fix proof --- Strata/Transform/ProcBodyVerifyCorrect.lean | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index 4a7c18ca7a..5a19f69601 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -469,9 +469,10 @@ theorem procToVerifyStmt_structure (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) (h_wf_proc : WF.WFProcedureProp p proc) : - ∃ (prefixStmts : List Statement), + ∃ (prefixStmts ss : List Statement), + proc.body = .structured ss ∧ verifyStmt = Stmt.block s!"verify_{proc.header.name.name}" - (prefixStmts ++ [Stmt.block s!"body_{proc.header.name.name}" (match proc.body with | .structured ss => ss | .cfg _ => []) #[]] ++ + (prefixStmts ++ [Stmt.block s!"body_{proc.header.name.name}" ss #[]] ++ ensuresToAsserts proc.spec.postconditions) #[] ∧ (∀ s ∈ prefixStmts, ∃ c, s = Stmt.cmd c) ∧ (∀ ρ₀, Core.Specification.ProcEnvWF proc ρ₀ → @@ -495,10 +496,8 @@ theorem procToVerifyStmt_structure (.det (LExpr.fvar () id none)) #[] let assumes := requiresToAssumes proc.spec.preconditions let prefixStmts := inputInits ++ outputOnlyInits ++ oldInoutInits ++ assumes - have h_body_match : (match proc.body with | .structured ss => ss | .cfg _ => []) = ss := by - rw [h_body_eq] - rw [h_body_match] - refine ⟨prefixStmts, h_eq.symm, ?_, ?_⟩ + rw [h_body_eq] + refine ⟨prefixStmts, ss, rfl, h_eq.symm, ?_, ?_⟩ · intro s hs simp only [prefixStmts, List.mem_append] at hs rcases hs with ((hs | hs) | hs) | hs @@ -661,9 +660,12 @@ theorem procBodyVerify_procedureCorrect obtain ⟨ss, h_body_eq⟩ := procToVerifyStmt_is_structured h_transform have h_body_match : (match proc.body with | .structured ss => ss | .cfg _ => []) = ss := by rw [h_body_eq] - obtain ⟨prefixStmts, h_eq, h_prefix_cmd, h_prefix_trace⟩ := + obtain ⟨prefixStmts, ss', h_body, h_eq, h_prefix_cmd, h_prefix_trace⟩ := procToVerifyStmt_structure proc p st st' verifyStmt h_transform π φ h_wf_proc - rw [h_body_match] at h_eq + have h_ss_eq : ss = ss' := by + have := h_body_eq.symm.trans h_body + exact Procedure.Body.structured.inj this + subst h_ss_eq let verifyLabel := s!"verify_{proc.header.name.name}" let bodyLabel := s!"body_{proc.header.name.name}" let postAsserts := ensuresToAsserts proc.spec.postconditions From e5c47930c14a36c0a7bb371455e5db0eca5e7efb Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 14:58:41 -0700 Subject: [PATCH 27/57] comment --- Strata/Transform/ProcBodyVerifyCorrect.lean | 1 + 1 file changed, 1 insertion(+) diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index 5a19f69601..291f9e4a37 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -447,6 +447,7 @@ private theorem mapM_stateT_pure_eq {α β : Type} {σ : Type} {ε : Type} /-! ## Verification Statement Structure -/ +/-- if `procToVerifyStmt` succeeds, then the input procedure has `.structured` body -/ theorem procToVerifyStmt_is_structured (h : (procToVerifyStmt proc).run st = (Except.ok verifyStmt, st')) : ∃ ss, proc.body = .structured ss := by From 3bfd467c0f43e8a9474322393225e843f08d8620 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 15:45:50 -0700 Subject: [PATCH 28/57] fix WFProcedure --- Strata/Languages/Core/WF.lean | 1 - 1 file changed, 1 deletion(-) diff --git a/Strata/Languages/Core/WF.lean b/Strata/Languages/Core/WF.lean index c3ed86de52..3e4648cfd6 100644 --- a/Strata/Languages/Core/WF.lean +++ b/Strata/Languages/Core/WF.lean @@ -142,7 +142,6 @@ structure WFDistinctDeclarationProp (p : Program) (l : Expression.Ident) (es : L -- * all variables used are declared/initialized -- * target labels of transfer commands exist structure WFProcedureProp (p : Program) (d : Procedure) : Prop where - bodyIsStructured : ∃ ss, d.body = .structured ss wfstmts : ∀ ss, d.body = .structured ss → WFStatementsProp p ss wfloclnd : ∀ ss, d.body = .structured ss → (HasVarsImp.definedVars (P:=Expression) ss).Nodup inputsNodup : (ListMap.keys d.header.inputs).Nodup From 6d937fc1d9572232cbe829008b3a8273ef0463b4 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 16:04:51 -0700 Subject: [PATCH 29/57] restore comments --- Strata/Transform/PrecondElim.lean | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/Strata/Transform/PrecondElim.lean b/Strata/Transform/PrecondElim.lean index 2473e33b54..9f12214547 100644 --- a/Strata/Transform/PrecondElim.lean +++ b/Strata/Transform/PrecondElim.lean @@ -91,7 +91,14 @@ def collectPrecondAssertCmds (F : @Lambda.Factory CoreLParams) (e : Expression.E (labelPrefix : String) (md : Imperative.MetaData Expression) : List (Imperative.Cmd Expression) := let wfObs := Lambda.collectWFObligations F e + -- Strip propertySummary: the enclosing statement's user-facing message + -- (e.g., a Python assert message) should not propagate to generated + -- precondition checks for called functions. let md := md.eraseAllElems Imperative.MetaData.propertySummary + -- Use modulo to cycle the precondition index correctly across call sites. + -- For nested calls like SafeSDiv(SafeSDiv(x,y),z), obligations arrive as + -- [inner-0, inner-1, outer-0, outer-1] with the same funcName throughout. + -- Without modulo, the index would be 0,1,2,3 instead of 0,1,0,1. let (_, _, result) := wfObs.foldl (init := ("", 0, ([] : List (Imperative.Cmd Expression)))) fun (prevFunc, prevIdx, acc) ob => let rawIdx := if ob.funcName == prevFunc then prevIdx + 1 else 0 From 9eb49ab387d39eb9010ca1f9ea852739a6e5afd3 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 16:06:55 -0700 Subject: [PATCH 30/57] run out of fuel warning --- Strata/Languages/Core/StatementEval.lean | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 3679eda3c9..8dfdbc7f4a 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -772,7 +772,7 @@ private def runCFG (cfg : Core.DetCFG) (fuel : Nat) (env : Env) where go (label : String) (fuel : Nat) (env : Env) : Env := match fuel with - | 0 => env + | 0 => CmdEval.updateError env (.Misc s!"runCFG: fuel exhausted (possible infinite loop)") | fuel' + 1 => match cfg.blocks.lookup label with | none => CmdEval.updateError env (.Misc s!"runCFG: block '{label}' not found in CFG") @@ -786,7 +786,8 @@ where match ops.evalExpr env' cond with | some (.boolConst _ true) => go lt fuel' env' | some (.boolConst _ false) => go lf fuel' env' - | _ => env' + | _ => CmdEval.updateError env' + (.Misc s!"runCFG: branch condition in block '{label}' did not evaluate to a boolean") | _ => env /-- From 402e43d46527311a2514640bb314955961f7f97d Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 16:07:53 -0700 Subject: [PATCH 31/57] better comments on WF --- Strata/Languages/Core/WF.lean | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Strata/Languages/Core/WF.lean b/Strata/Languages/Core/WF.lean index 3e4648cfd6..251ba4ebcc 100644 --- a/Strata/Languages/Core/WF.lean +++ b/Strata/Languages/Core/WF.lean @@ -137,7 +137,9 @@ structure WFAxiomDeclarationProp (p : Program) (f : Axiom) : Prop where structure WFDistinctDeclarationProp (p : Program) (l : Expression.Ident) (es : List (Expression.Expr)) : Prop where --- TODO: add WF properties for unstructured programs: +-- NOTE: For CFG procedures, the structured-body fields (`wfstmts`, `wfloclnd`, +-- `bodyExitsCovered`) are vacuously satisfied. CFG-specific well-formedness +-- (e.g., label uniqueness, reachability) is not yet captured here: -- * verify block labels are unique -- * all variables used are declared/initialized -- * target labels of transfer commands exist From 18b41d8405efc7e9a068f2315c924091a0478a39 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 16:08:17 -0700 Subject: [PATCH 32/57] error on goto with 2+ targets --- Strata/Languages/Core/DDMTransform/Translate.lean | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index 43c9f8fdb9..4bec040934 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -1628,7 +1628,9 @@ partial def translateTransfer (p : Program) (bindings : TransBindings) (arg : Ar | [l] => let label ← translateIdent String l return .condGoto (Lambda.LExpr.boolConst () Bool.true) label label - | l1 :: l2 :: _ => + | l1 :: l2 :: rest => + if !rest.isEmpty then + TransM.error s!"translateTransfer: goto with more than 2 targets is not supported" let label1 ← translateIdent String l1 let label2 ← translateIdent String l2 let condName := s!"$__nondet_{bindings.gen.var_def}" From d694805a3ad932f370b98f35887e7e7cef6d612a Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 16:21:51 -0700 Subject: [PATCH 33/57] refine type checker for CFG --- Strata/Languages/Core/ProcedureType.lean | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/Strata/Languages/Core/ProcedureType.lean b/Strata/Languages/Core/ProcedureType.lean index 0fc5f466f4..91262bea3f 100644 --- a/Strata/Languages/Core/ProcedureType.lean +++ b/Strata/Languages/Core/ProcedureType.lean @@ -111,16 +111,14 @@ def typeCheck (C : Core.Expression.TyContext) (Env : Core.Expression.TyEnv) (p : -- Type check body. -- Note that `Statement.typeCheck` already reports source locations in - -- Type check body. - let bodyStmts := match proc.body with - | .structured ss => ss - -- For now, we skip checking CFG bodies - -- potential TODOs for CFGs: + -- error messages. + -- For now, we skip checking CFG bodies. Potential TODOs for CFGs: -- * verify block labels are unique -- * all variables used are declared/initialized -- * target labels of transfer commands exist - | .cfg _ => [] - let (annotated_body, finalEnv) ← Statement.typeCheck C envAfterPostconds p (.some proc) bodyStmts + let (annotated_body, finalEnv) ← match proc.body with + | .structured ss => Statement.typeCheck C envAfterPostconds p (.some proc) ss + | .cfg _ => pure ([], envAfterPostconds) -- Remove formals and returns from the context -- they ought to be local to -- the procedure body. @@ -135,7 +133,10 @@ def typeCheck (C : Core.Expression.TyContext) (Env : Core.Expression.TyEnv) (p : outputs := out_mty_sig } let new_spec := { proc.spec with preconditions := finalPreconditions, postconditions := finalPostconditions } - let new_proc := { proc with header := new_hdr, spec := new_spec, body := .structured annotated_body } + let new_body := match proc.body with + | .structured _ => .structured annotated_body + | .cfg c => .cfg c + let new_proc := { proc with header := new_hdr, spec := new_spec, body := new_body } return (new_proc, finalEnv) From 21a86aa6115a217af96875ddbf5f57c43627ac3b Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 16:27:00 -0700 Subject: [PATCH 34/57] simplify --- Strata/Transform/ProcBodyVerifyCorrect.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index 291f9e4a37..d7fa3acac4 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -793,7 +793,7 @@ theorem procBodyVerify_procedureCorrect CoreStepStar π φ (.stmts ss ρ₀) cfg → coreIsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt := - fun a cfg h h' => body_asserts_valid ρ₀ h_wf a cfg (h_body_match ▸ h) h' + fun a cfg h h' => body_asserts_valid ρ₀ h_wf a cfg h h' -- hasFailure = false have h_nf' : ρ'.hasFailure = Bool.false := Core.core_noFailure_preserved π φ From 09973f63a009706d263aab1a923e45fef9165036 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 7 May 2026 16:29:53 -0700 Subject: [PATCH 35/57] refine comments --- Strata/Languages/Core/ObligationExtraction.lean | 6 +++++- Strata/Transform/CoreSpecification.lean | 8 ++++++-- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/Strata/Languages/Core/ObligationExtraction.lean b/Strata/Languages/Core/ObligationExtraction.lean index 72ec40c4fd..e2e8bade8d 100644 --- a/Strata/Languages/Core/ObligationExtraction.lean +++ b/Strata/Languages/Core/ObligationExtraction.lean @@ -98,7 +98,11 @@ def extractFromStatements extractGo pathConditions ss #[] end -/-- Extract proof obligations from a deterministic CFG by walking all blocks. -/ +/-- Extract proof obligations from a deterministic CFG by walking all blocks. + NOTE: Path conditions restart from the global `pc` for each block independently. + Assumes within one block do not propagate to successor blocks. This is conservative + (no false negatives) but means obligations may be harder to discharge than necessary. + TODO: dominator-based path-condition propagation would improve precision. -/ def extractFromDetCFG (pc : PathConditions Expression) (cfg : DetCFG) : Except String (Array (ProofObligation Expression)) := let obs := cfg.blocks.foldl (init := #[]) fun acc (_, blk) => diff --git a/Strata/Transform/CoreSpecification.lean b/Strata/Transform/CoreSpecification.lean index 7b1ece5a01..fc88d8e103 100644 --- a/Strata/Transform/CoreSpecification.lean +++ b/Strata/Transform/CoreSpecification.lean @@ -185,8 +185,12 @@ structure ProcedureCorrect (proc : Procedure) (p : Program) : Prop where /-- (1) The asserts in the body of proc are valid. -/ assertsValid : ∀ a, AssertValidInProcedure π φ proc a /-- (2) The postconditions hold on termination. - For structured bodies, termination is witnessed by `CoreStepStar`. - For CFG bodies, use `CoreCFGStepStar` (via `Lang.coreCFG`). -/ + Currently uses `CoreStepStar` on the structured body. For CFG procedures, + the match yields `[]` making this vacuously true. + TODO: Unify with `CoreBodyExec` to cover CFGs. The obstacle is that + `CoreBodyExec` only exposes terminal `store`/`hasFailure`, not `eval`, + but this proof obtains postcondition validity via the terminal env's eval + (which may differ from the initial eval due to `funcDecl` extensions). -/ postconditionsValid : WF.WFProcedureProp p proc → ∀ (ρ₀ ρ' : Env Expression), From 4305a67d95e88e0f16a65cb5803e5756ca414778 Mon Sep 17 00:00:00 2001 From: David Deng Date: Mon, 11 May 2026 12:24:19 -0700 Subject: [PATCH 36/57] fix: propagate error in runCFG fallthrough and clarify ObligationExtraction comment StatementEval.lean: When Imperative.runStmt returns a non-terminal result (e.g. from inner fuel exhaustion), the catch-all arm silently returned the input environment, discarding all block side effects with no diagnostic. Replace | _ => env with CmdEval.updateError using the .Misc pattern. ObligationExtraction.lean: Rewrite the doc comment on extractFromDetCFG to clarify that path-condition restart causes false alarms (false positives), not just imprecision, and reference dominator-based propagation as follow-up. Co-Authored-By: Claude Opus 4.6 (1M context) --- Strata/Languages/Core/ObligationExtraction.lean | 9 +++++---- Strata/Languages/Core/StatementEval.lean | 3 ++- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/Strata/Languages/Core/ObligationExtraction.lean b/Strata/Languages/Core/ObligationExtraction.lean index e2e8bade8d..3fcdfcf822 100644 --- a/Strata/Languages/Core/ObligationExtraction.lean +++ b/Strata/Languages/Core/ObligationExtraction.lean @@ -99,10 +99,11 @@ def extractFromStatements end /-- Extract proof obligations from a deterministic CFG by walking all blocks. - NOTE: Path conditions restart from the global `pc` for each block independently. - Assumes within one block do not propagate to successor blocks. This is conservative - (no false negatives) but means obligations may be harder to discharge than necessary. - TODO: dominator-based path-condition propagation would improve precision. -/ + Path conditions restart from the global `pc` for each block independently, so + obligations are over-approximated (no false negatives — every real bug is caught). + However, obligations in block B that depend on `assume` from block A will fail to + discharge, surfacing as false alarms (false positives) to the user. + TODO: dominator-based path-condition propagation to reduce false alarms. -/ def extractFromDetCFG (pc : PathConditions Expression) (cfg : DetCFG) : Except String (Array (ProofObligation Expression)) := let obs := cfg.blocks.foldl (init := #[]) fun acc (_, blk) => diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 8dfdbc7f4a..8a0732864e 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -788,7 +788,8 @@ where | some (.boolConst _ false) => go lf fuel' env' | _ => CmdEval.updateError env' (.Misc s!"runCFG: branch condition in block '{label}' did not evaluate to a boolean") - | _ => env + | _ => CmdEval.updateError env + (.Misc s!"runCFG: block '{label}' did not reach terminal (possibly inner-loop fuel exhaustion or unexpected exit)") /-- The resulting Env is the original passed in Env with the output variables copied back into it. From 035fa8be7916df249611d24231baf18c47faad83 Mon Sep 17 00:00:00 2001 From: David Deng Date: Mon, 11 May 2026 12:40:42 -0700 Subject: [PATCH 37/57] test: add end-to-end CFG verification and body preservation tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Test 1 — Type-checking rejection: confirms Core.typeCheck rejects a CFG procedure with "expected structured body, got CFG" diagnostic. Test 2 — CFG body preservation: confirms a parsed CFG procedure retains .cfg body (isCfg=true, isStructured=false) with correct entry label and block count, guarding against the prior bug where type-checking collapsed CFG bodies to .structured []. Co-Authored-By: Claude Opus 4.6 (1M context) --- .../Languages/Core/Tests/CFGParseTests.lean | 76 +++++++++++++++++++ 1 file changed, 76 insertions(+) diff --git a/StrataTest/Languages/Core/Tests/CFGParseTests.lean b/StrataTest/Languages/Core/Tests/CFGParseTests.lean index cd6bb1ae0a..4b5c6da27e 100644 --- a/StrataTest/Languages/Core/Tests/CFGParseTests.lean +++ b/StrataTest/Languages/Core/Tests/CFGParseTests.lean @@ -195,3 +195,79 @@ cfg start { IO.println s!" Block '{lbl}': {blk.cmds.length} cmds, {transferDesc}" | .structured _ => IO.println " ERROR: expected CFG body" | _ => pure () + +/-! ## End-to-end: type-checking rejects CFG procedures + +Regression test for PR #1132: the verifier pipeline (which includes type +checking) should reject CFG bodies with a clear diagnostic rather than +silently producing wrong results. The current rejection comes from +`checkModificationRights`, which calls `Body.getStructured` on a CFG body. -/ + +/-- +info: type-check rejected CFG procedure: expected structured body, got CFG +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure Trivial() +cfg start { + start: { + return; + } +}; +" + match Core.typeCheck .quiet prog with + | .error dm => IO.println s!"type-check rejected CFG procedure: {dm.message}" + | .ok _ => IO.println "ERROR: expected type-check to fail for CFG procedure" + +/-! ## End-to-end: parsed CFG body is preserved, not collapsed + +Regression test for PR #1132: there was a bug where the procedure body was +always stored as `.structured annotated_body` after type checking, erasing +CFG bodies to `.structured []`. The fix preserves `.cfg` bodies. This test +confirms that after parsing, a CFG procedure's body is `.cfg` (not +`.structured []`), guarding against regression in the parser or DDM layer. -/ + +/-- +info: Procedure: Max + body.isCfg = true + body.isStructured = false + CFG preserved: entry=entry, 4 blocks +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure Max(x : int, y : int, out m : int) +spec { + ensures (m >= x); + ensures (m >= y); +} +cfg entry { + entry: { + branch (x >= y) goto then_branch else else_branch; + } + then_branch: { + m := x; + goto done; + } + else_branch: { + m := y; + goto done; + } + done: { + return; + } +}; +" + for d in prog.decls do + match d with + | .proc p _ => + IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" + IO.println s!" body.isCfg = {p.body.isCfg}" + IO.println s!" body.isStructured = {p.body.isStructured}" + match p.body with + | .cfg c => + IO.println s!" CFG preserved: entry={c.entry}, {c.blocks.length} blocks" + | .structured ss => + IO.println s!" ERROR: body collapsed to .structured with {ss.length} statements" + | _ => pure () From 74a09776cb993ca0963ebe3890a479be75958ad5 Mon Sep 17 00:00:00 2001 From: David Deng Date: Mon, 11 May 2026 15:15:55 -0700 Subject: [PATCH 38/57] fix: wrap Procedure.body assignment in TerminationCheck.lean for Body type TerminationCheck.lean (from main) constructs a Procedure with body := stmts, but this branch changed Procedure.body from List Statement to Procedure.Body. Wrap with .structured to fix the merge-queue CI build. Co-Authored-By: Claude Opus 4.6 (1M context) --- Strata/Transform/TerminationCheck.lean | 359 +++++++++++++++++++++++++ 1 file changed, 359 insertions(+) create mode 100644 Strata/Transform/TerminationCheck.lean diff --git a/Strata/Transform/TerminationCheck.lean b/Strata/Transform/TerminationCheck.lean new file mode 100644 index 0000000000..30b53d0121 --- /dev/null +++ b/Strata/Transform/TerminationCheck.lean @@ -0,0 +1,359 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.Transform.CoreTransform +public import Strata.DL.Lambda.AdtRankAxioms +public import Strata.DL.Lambda.TypeFactory +public import Strata.Languages.Core.PipelinePhase + +/-! # Termination Checking for Recursive Functions + +This transformation generates termination-checking procedures for recursive +function blocks. For each `recFuncBlock`, it: + +1. Generates `D..adtRank` UF declarations and per-constructor axioms for the + datatypes used as decreasing measures. +2. Generates a `$$term` procedure per function that asserts `adtRank` decreases + at each recursive call site. +-/ + +public section + +namespace Core +namespace TermCheck + +open Lambda +open Strata (DiagnosticModel FileRange) +open Strata.DL.Util (FuncAttr) +open Core.Transform + +/-- Statistics keys tracked by the termination checking transformation. -/ +inductive Stats where + | termCheckProcsGenerated + | termCheckAssertsEmitted + | adtRankAxiomsGenerated + +#derive_prefixed_toString Stats "TermCheck" + +/-- Suffix for generated termination-checking procedures. -/ +def termSuffix : String := "$$term" + +def termProcName (name : String) : String := s!"{name}{termSuffix}" + +def isTermProc (name : String) : Bool := name.endsWith termSuffix + +/-- Find the decreasing parameter index for a function: explicit `measure` + (from `decreases` clause), or fallback to `@[cases]` (`inlineIfConstr`). -/ +private def getDecreasesIdx (func : Function) : Option Nat := + match func.measure with + | some (.fvar _ id _) => func.inputs.keys.findIdx? (· == id) + | some _ => none + | none => FuncAttr.findInlineIfConstr func.attr + +/-- Extract the datatype name from a monomorphic type. + Precondition: `ty` must be a `.tcons` + (enforced by error checking in `termCheck`). -/ +private def adtNameOf (ty : LMonoTy) : String := + match ty with + | .tcons n _ => n + | _ => "" + +/-- Build the `adtRank(callArg) < adtRank(callerParam)` expression. -/ +private def mkAdtRankLt + (callArg : Expression.Expr) + (callerParam : Expression.Ident) + (callerAdtTy calleeAdtTy : LMonoTy) + : Expression.Expr := + let rank (t: LMonoTy) (e: Expression.Expr) : Expression.Expr := + .app () (.op () (adtRankFuncName (adtNameOf t)) (.some (.arrow t .int))) e + let ltTy : LMonoTy := LMonoTy.arrow .int (LMonoTy.arrow .int .bool) + LExpr.mkApp () (.op () "Int.Lt" (.some ltTy)) [rank calleeAdtTy callArg, rank callerAdtTy (.fvar () callerParam (.some callerAdtTy))] + +/-- Check if an expression contains a call to any operation in the given name list. -/ +private def containsOpCall (e : Expression.Expr) (names : List String) : Bool := + match e with + | .op _ opName _ => opName.name ∈ names + | .app _ fn arg => containsOpCall fn names || containsOpCall arg names + | .ite _ c t f => containsOpCall c names || containsOpCall t names || containsOpCall f names + | .eq _ e1 e2 => containsOpCall e1 names || containsOpCall e2 names + | .abs _ _ _ body => containsOpCall body names + | .quant _ _ _ _ tr body => containsOpCall tr names || containsOpCall body names + | _ => false + +/-- Extract termination obligations from an expression. Path conditions + through `ite` branches are accumulated and wrapped as implications + in the obligation expression, mirroring `collectWFObligations`. -/ +private def extractTermObligations + (body : Expression.Expr) + (recFuncNames : List String) + (callerParam : Expression.Ident) + (callerAdtTy : LMonoTy) + (funcDecreasesMap : List (String × Nat × LMonoTy)) + : Except String (List Expression.Expr) := + go body [] +where + go (e : Expression.Expr) (implications : List (Unit × Expression.Expr)) + : Except String (List Expression.Expr) := + match _he: e with + | .ite _ c t f => do + let cObs ← go c implications + let tObs ← go t (((), c) :: implications) + let notC : Expression.Expr := + LExpr.mkApp () (.op () "Bool.Not" (.some (LMonoTy.arrow .bool .bool))) [c] + let fObs ← go f (((), notC) :: implications) + return cObs ++ tObs ++ fObs + | .app _ fn arg => + match _h : getLFuncCall e with + | (op, args) => do + let argObs ← args.attach.flatMapM fun ⟨a, _⟩ => go a implications + let callObs ← match op with + | .op _ opName _ => + if opName.name ∈ recFuncNames then + match funcDecreasesMap.find? (fun (n, _, _) => n == opName.name) with + | some (_, calleeIdx, calleeAdtTy) => + match args[calleeIdx]? with + | some callArg => + if callArg.hasBVar then + .error s!"termination checking: decreasing argument contains a bound variable" + else if containsOpCall callArg recFuncNames then + .error s!"termination checking: decreasing argument contains a recursive call" + else + let ltExpr := mkAdtRankLt callArg callerParam callerAdtTy calleeAdtTy + .ok [wrapImplications implications ltExpr] + | none => .ok [] + | none => .ok [] + else .ok [] + | _ => do + let fnObs ← go fn implications + let argObs2 ← go arg implications + .ok (fnObs ++ argObs2) + return argObs ++ callObs + | .eq _ e1 e2 => do + let obs1 ← go e1 implications + let obs2 ← go e2 implications + return obs1 ++ obs2 + | .abs _ _ _ body => go body implications + | .quant _ _ _ _ trigger body => do + let obs1 ← go trigger implications + let obs2 ← go body implications + return obs1 ++ obs2 + | _ => .ok [] + termination_by e.sizeOf + decreasing_by + all_goals (try term_by_mem) + rename_i a_in + have h := getLFuncCall_smaller _h a a_in + subst_vars + simp_all + +/-- Build a type substitution that specializes a polymorphic datatype's type + variables to the concrete type arguments used at a call site. + E.g., for `MyList` with `typeArgs = ["a"]` and concrete type `MyList int`, + produces `[("a", int)]`. -/ +private def mkTySubst (tf : @TypeFactory Unit) (concreteTy : LMonoTy) : Subst := + match concreteTy with + | .tcons adtName concreteArgs => + if concreteArgs.isEmpty then [] + else match tf.getType adtName with + | some dt => + if dt.typeArgs.length != concreteArgs.length then [] + else [dt.typeArgs.zip concreteArgs] + | none => [] + | _ => [] -- unreachable: termCheck Step 1 rejects non-.tcons types + +/-- Generate a termination-checking procedure for a single function. + Returns `none` if the function has no recursive calls or no valid + decreasing parameter. The polymorphic `adtRankAxioms` are specialized + to the function's concrete decreasing-parameter type before being + embedded as preconditions. + The resulting procedure should NOT have preconditions checked, since + they will already be checked by the original program, and the generated + axioms do not use partial functions. -/ +private def mkTermCheckProc + (func : Function) + (recFuncNames : List String) + (funcDecreasesMap : List (String × Nat × LMonoTy)) + (adtRankAxioms : List (String × Expression.Expr)) + (tf : @TypeFactory Unit) + (md : Imperative.MetaData Expression) + : Except String (Option (Decl × Nat)) := do + let some decrIdx := getDecreasesIdx func | return none + let inputTys := func.inputs.values + let some decrTy := inputTys[decrIdx]? | return none + let some decrParam := func.inputs.keys[decrIdx]? | return none + let some body := func.body | return none + let obligations ← extractTermObligations body recFuncNames decrParam decrTy + funcDecreasesMap + if obligations.isEmpty then return none + let stmts := obligations.mapIdx fun i ob => + Statement.assert s!"{func.name.name}_terminates_{i}" ob md + -- Filter axioms to only those relevant to this function's decreasing type's + -- mutual datatype block, then specialize polymorphic type args. + let decrAdtName := adtNameOf decrTy + let relevantDtNames : List String := match tf.toList.find? (fun b => b.any (fun d => d.name == decrAdtName)) with + | some block => block.map (·.name) + | none => [decrAdtName] + let relevantAxioms := adtRankAxioms.filter fun (name, _) => + relevantDtNames.any (fun dtName => name.startsWith (adtRankFuncName dtName)) + let tySubst := mkTySubst tf decrTy + let specializedAxioms := relevantAxioms.map fun (name, e) => + (name, e.applySubst tySubst) + return some (.proc { + header := { + name := ⟨termProcName func.name.name, ()⟩ + typeArgs := func.typeArgs + inputs := func.inputs + outputs := [] + noFilter := true + } + spec := { preconditions := + (specializedAxioms.map fun (name, e) => + (name, { expr := e, attr := .Free })) ++ + (func.preconditions.mapIdx fun i p => + (s!"{func.name.name}_requires_{i}", { expr := p.expr, attr := .Free })), + postconditions := [] } + body := .structured stmts + } md, obligations.length) + +/-- Add a termination-check procedure as a leaf node in the cached call graph. -/ +private def addTermProcToCallGraph (name : String) : CoreTransformM Unit := + modify fun σ => match σ.cachedAnalyses.callGraph with + | .some cg => { σ with cachedAnalyses := { σ.cachedAnalyses with + callGraph := .some (cg.addLeafNode name) } } + | .none => σ + +/-- Result of generating adtRank declarations for a mutual datatype block. -/ +private structure AdtRankDecls where + namedDecls : List (String × Decl) + axioms : List (String × Expression.Expr) + +/-- Generate adtRank function declarations and axiom expressions for all + datatypes in the mutual block containing `adtName`. -/ +private def mkAdtRankDecls + (adtName : String) (tf : @TypeFactory Unit) + (md : Imperative.MetaData Expression) + : AdtRankDecls := + match tf.toList.find? (fun b => b.any (fun d => d.name == adtName)) with + | none => ⟨[], []⟩ + | some block => + { namedDecls := block.map fun dt => + (dt.name, Decl.func (mkAdtRankFunc (T := CoreLParams) dt) md) + axioms := block.flatMap fun dt => + let axioms := mkAdtRankAxioms (T := CoreLParams) dt block () + axioms.mapIdx fun i ax => + (s!"{adtRankFuncName dt.name}_{i}", ax) } + +/-- Main transformation: iterate over declarations, generating adtRank axioms + and termination-checking procedures for each `recFuncBlock`. -/ +def termCheck (p : Program) : CoreTransformM (Bool × Program) := do + match (← get).factory with + | .none => return (false, p) + | .some _ => + let (changed, newDecls) ← transformDecls p.decls TypeFactory.default {} + return (changed, { decls := newDecls }) +where + transformDecls (decls : List Decl) (tf : @TypeFactory Unit) + (emittedAdtRank : Std.HashSet String) + : CoreTransformM (Bool × List Decl) := do + match decls with + | [] => return (false, []) + | d :: rest => + match d with + | .recFuncBlock funcs md => do + -- Step 1: error checking (fail-fast: an ill-formed function may + -- invalidate subsequent definitions in the mutual block) + -- Skip polymorphic functions: adtRank axioms are monomorphic, so we + -- cannot generate them for polymorphic datatypes yet. The user-facing + -- error is in Env.addFactoryFunc; when that restriction is lifted, + -- this filter must be updated to handle polymorphic adtRank generation. + let fileRange := Imperative.getFileRange md |>.getD FileRange.unknown + let throwErr (msg : String) : CoreTransformM Unit := + throw (DiagnosticModel.withRange fileRange msg) + for func in funcs do + if func.typeArgs.isEmpty then + match getDecreasesIdx func with + | none => + match func.measure with + | some _ => + throwErr s!"recursive function '{func.name.name}': decreases clause must be a parameter name. Non-structural recursion is not yet supported" + | none => + throwErr s!"recursive function '{func.name.name}' requires a 'decreases' clause or a '@[cases]' parameter for termination checking" + | some idx => + match func.inputs.values[idx]? with + | some (.tcons n _) => + if (tf.getType n).isNone then + throwErr s!"recursive function '{func.name.name}': decreasing parameter type '{n}' is not a known datatype" + | some _ => + throwErr s!"recursive function '{func.name.name}': decreasing parameter must have a datatype type" + | none => + throwErr s!"recursive function '{func.name.name}': decreasing parameter index {idx} is out of range" + -- Step 2: Build a map from function name to (decreasing param index, type). + let funcDecreasesMap := funcs.filterMap fun func => do + if !func.typeArgs.isEmpty then none + let idx ← getDecreasesIdx func + let ty ← func.inputs.values[idx]? + pure (func.name.name, idx, ty) + -- Step 3: Generate adtRank UF declarations and per-constructor axioms. + -- `allAdtRank` is computed once for all datatypes in this block. + -- `newFuncDecls` filters to only UF decls not yet emitted. + -- Each $$term proc filters axioms to its own decreasing type's + -- mutual datatype block (see mkTermCheckProc). + let allAdtNames := funcDecreasesMap.map (fun (_, _, ty) => adtNameOf ty) + |>.eraseDups + let allAdtRank : AdtRankDecls := + let (_, revResults) : Std.HashSet String × List AdtRankDecls := + allAdtNames.foldl (init := ({}, [])) fun (seen, acc) adtName => + if seen.contains adtName then (seen, acc) + else + let r := mkAdtRankDecls adtName tf md + (r.namedDecls.foldl (fun s (n, _) => s.insert n) seen, r :: acc) + let results := revResults.reverse + { namedDecls := results.flatMap (·.namedDecls) + axioms := results.flatMap (·.axioms) } + let newFuncDecls := allAdtRank.namedDecls.filterMap + fun (n, d) => if emittedAdtRank.contains n then none else some d + let emittedAdtRank := allAdtRank.namedDecls.foldl (fun s (n, _) => s.insert n) emittedAdtRank + incrementStat s!"{Stats.adtRankAxiomsGenerated}" allAdtRank.axioms.length + -- Step 4: Generate a $$term procedure per function with adtRank + -- decrease assertions at each recursive call site. + let recNames := funcs.map (·.name.name) + let termDecls ← funcs.filterMapM fun func => do + match mkTermCheckProc func recNames funcDecreasesMap allAdtRank.axioms tf md with + | .error msg => do throwErr msg; return none + | .ok (some (decl, numAsserts)) => do + incrementStat s!"{Stats.termCheckProcsGenerated}" + incrementStat s!"{Stats.termCheckAssertsEmitted}" numAsserts + addTermProcToCallGraph (termProcName func.name.name) + return some decl + | .ok none => return none + -- Step 5: Splice adtRank decls before the rec block, term procs after. + let (changed, rest') ← transformDecls rest tf emittedAdtRank + if newFuncDecls.isEmpty && termDecls.isEmpty then + return (changed, d :: rest') + else + return (true, newFuncDecls ++ [d] ++ termDecls ++ rest') + | .type (.data block) _md => do + let tf' : @TypeFactory Unit := tf.push block + let (changed, rest') ← transformDecls rest tf' emittedAdtRank + return (changed, d :: rest') + | .func _ _ | .proc _ _ | .ax _ _ | .distinct _ _ _ + | .type (.con _) _ | .type (.syn _) _ => do + let (changed, rest') ← transformDecls rest tf emittedAdtRank + return (changed, d :: rest') + +end TermCheck + +/-- TermCheck pipeline phase: generates termination-checking procedures for + recursive functions. Model-preserving because it only adds new + assertions and procedures. -/ +def termCheckPipelinePhase : PipelinePhase := + modelPreservingPipelinePhase "TermCheck" fun prog => do + TermCheck.termCheck prog + +end Core + +end -- public section From 8f0939d52798add494511ba005b2bbbe6aa6d438 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 09:04:59 -0700 Subject: [PATCH 39/57] fix: split postconditionsValid into structured/CFG fields and add CoreBodyExec TODOs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The postconditionsValid field in ProcedureCorrect was vacuously true for CFG procedures — the match expression produced [] for CFGs, making CoreStepStar terminate immediately with rho' = rho0. Split into two explicit fields: - postconditionsValid_structured: for structured bodies, uses CoreStepStar on the statement list (preserves existing proven behavior) - postconditionsValid_cfg: for CFG bodies, uses CoreCFGStepStar directly, making the soundness gap explicit and non-vacuous Updated procBodyVerify_procedureCorrect proof to construct all three fields. The CFG field is discharged by contradiction since procToVerifyStmt only succeeds for structured bodies. Added TODO comments on CoreBodyExec documenting: - Should be wired into postconditionsValid_cfg - The cfg constructor drops terminal eval (limiting postcondition support) - An equivalence theorem structured_iff_CoreStepStar would bridge the two representations Co-Authored-By: Claude Opus 4.6 (1M context) --- Strata/Languages/Core/StatementSemantics.lean | 19 ++++++++- Strata/Transform/CoreSpecification.lean | 39 +++++++++++++------ Strata/Transform/ProcBodyVerifyCorrect.lean | 30 +++++++++----- 3 files changed, 66 insertions(+), 22 deletions(-) diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index e6a85f3ddb..abb091624d 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -350,7 +350,24 @@ inductive CoreCFGStepStar CoreCFGStepStar π φ cfg c₁ c₃ /-- Execution of a procedure body: either structured (via `CoreStepStar`) - or unstructured CFG (via `CoreCFGStepStar`). -/ + or unstructured CFG (via `CoreCFGStepStar`). + + TODO: Wire `CoreBodyExec` into `ProcedureCorrect.postconditionsValid_cfg` + so that CFG postcondition verification goes through this inductive rather than + being handled separately. Currently only used in `EvalCommand.call_sem`. + + TODO: The `cfg` constructor drops terminal `eval` information — after + extracting `store` and `hasFailure` from the terminal CFG configuration, the + `δ` (eval) parameter is discarded. This prevents postcondition proofs that + need the terminal eval (e.g., when `funcDecl` extends the evaluator during + execution). Consider adding a `δ' : CoreEval` output field, or exposing the + full terminal `Env Expression`, to support postcondition reasoning. + + TODO: An equivalence theorem `CoreBodyExec.structured_iff_CoreStepStar` + relating `CoreBodyExec π φ (.structured ss) σ δ σ' f` to the corresponding + `CoreStepStar π φ (.stmts ss ⟨σ, δ, false⟩) (.terminal ⟨σ', δ', f⟩)` would + bridge the two representations and ease the transition to unified + postcondition verification. -/ inductive CoreBodyExec (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) : diff --git a/Strata/Transform/CoreSpecification.lean b/Strata/Transform/CoreSpecification.lean index fc88d8e103..d26d372b5f 100644 --- a/Strata/Transform/CoreSpecification.lean +++ b/Strata/Transform/CoreSpecification.lean @@ -184,24 +184,41 @@ variable (φ : CoreEval → PureFunc Expression → CoreEval) structure ProcedureCorrect (proc : Procedure) (p : Program) : Prop where /-- (1) The asserts in the body of proc are valid. -/ assertsValid : ∀ a, AssertValidInProcedure π φ proc a - /-- (2) The postconditions hold on termination. - Currently uses `CoreStepStar` on the structured body. For CFG procedures, - the match yields `[]` making this vacuously true. - TODO: Unify with `CoreBodyExec` to cover CFGs. The obstacle is that - `CoreBodyExec` only exposes terminal `store`/`hasFailure`, not `eval`, - but this proof obtains postcondition validity via the terminal env's eval - (which may differ from the initial eval due to `funcDecl` extensions). -/ - postconditionsValid : + /-- (2a) The postconditions hold on termination of a **structured** body. + For structured procedures, this uses `CoreStepStar` on the statement list + to show all non-free postconditions evaluate to `true` and `hasFailure` + remains `false`. -/ + postconditionsValid_structured : + ∀ (ss : List Statement), + proc.body = .structured ss → WF.WFProcedureProp p proc → ∀ (ρ₀ ρ' : Env Expression), ProcEnvWF proc ρ₀ → - CoreStepStar π φ - (.stmts (match proc.body with | .structured ss => ss | .cfg _ => []) ρ₀) - (.terminal ρ') → + CoreStepStar π φ (.stmts ss ρ₀) (.terminal ρ') → (∀ (label : CoreLabel) (check : Procedure.Check), (label, check) ∈ proc.spec.postconditions.toList → check.attr = Procedure.CheckAttr.Default → ρ'.eval ρ'.store check.expr = some HasBool.tt) ∧ ρ'.hasFailure = Bool.false + /-- (2b) The postconditions hold on termination of a **CFG** body. + This field is the CFG counterpart of `postconditionsValid_structured`. + It is currently a soundness hole: the previous definition was vacuously + true for CFGs (the match on `proc.body` produced `[]`, forcing an + immediate `rho' = rho0` in `CoreStepStar`). + TODO: Provide a genuine proof once `CoreBodyExec` exposes the full + terminal environment (including `eval`). -/ + postconditionsValid_cfg : + ∀ (cfg : DetCFG), + proc.body = .cfg cfg → + WF.WFProcedureProp p proc → + ∀ (ρ₀ : Env Expression), + ProcEnvWF proc ρ₀ → + ∀ (σ' : CoreStore) (failed : Bool), + CoreCFGStepStar π φ cfg (.cont cfg.entry ρ₀.store false) (.terminal σ' failed) → + (∀ (label : CoreLabel) (check : Procedure.Check), + (label, check) ∈ proc.spec.postconditions.toList → + check.attr = Procedure.CheckAttr.Default → + ρ₀.eval σ' check.expr = some HasBool.tt) ∧ + failed = Bool.false end Core.Specification diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index d7fa3acac4..e5f0a62d6a 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -659,8 +659,6 @@ theorem procBodyVerify_procedureCorrect -- Conclusion: ProcedureCorrect holds. Core.Specification.ProcedureCorrect π φ proc p := by obtain ⟨ss, h_body_eq⟩ := procToVerifyStmt_is_structured h_transform - have h_body_match : (match proc.body with | .structured ss => ss | .cfg _ => []) = ss := by - rw [h_body_eq] obtain ⟨prefixStmts, ss', h_body, h_eq, h_prefix_cmd, h_prefix_trace⟩ := procToVerifyStmt_structure proc p st st' verifyStmt h_transform π φ h_wf_proc have h_ss_eq : ss = ss' := by @@ -744,7 +742,7 @@ theorem procBodyVerify_procedureCorrect rw [h_wrapped_eval, h_wrapped_store] at h_v exact h_v - refine ⟨?_, ?_⟩ + refine ⟨?_, ?_, ?_⟩ · ----- Part 1: All asserts in proc.body are valid ----- intro a @@ -783,10 +781,15 @@ theorem procBodyVerify_procedureCorrect have h_valid := body_asserts_valid ρ₀ h_wf a inner h_inner_core h_assert_inner simpa [Config.getEval, Config.getStore] using h_valid - · ----- Part 2: Postconditions + hasFailure on termination ----- - intro h_wf_proc ρ₀ ρ' h_wf h_term - have h_term_ss : CoreStepStar π φ (.stmts ss ρ₀) (.terminal ρ') := - h_body_match ▸ h_term + · ----- Part 2: Postconditions (structured) + hasFailure on termination ----- + -- The field requires `∀ ss, proc.body = .structured ss → ...`. + -- We know `h_body_eq : proc.body = .structured ss'`. + intro ss_arg h_body_eq_arg _ ρ₀ ρ' h_wf h_term + -- After the outer `subst h_ss_eq : ss = ss'`, `ss'` was eliminated and `ss` + -- remains in scope. Equate ss_arg with ss. + have h_eq_ss : ss_arg = ss := + Procedure.Body.structured.inj (h_body_eq_arg.symm.trans h_body_eq) + rw [h_eq_ss] at h_term obtain ⟨ρ_init, h_prefix⟩ := h_prefix_trace ρ₀ h_wf -- h_valid: all asserts in body from ρ₀ evaluate to true have h_valid : ∀ (a : AssertId Expression) (cfg : CoreConfig), @@ -797,11 +800,11 @@ theorem procBodyVerify_procedureCorrect -- hasFailure = false have h_nf' : ρ'.hasFailure = Bool.false := Core.core_noFailure_preserved π φ - (.stmts ss ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term_ss + (.stmts ss ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term -- wfBool preservation have h_wfb_term : WellFormedSemanticEvalBool ρ'.eval := Core.core_wfBool_preserved π φ h_wf_ext - (.stmts ss ρ₀) (.terminal ρ') h_wf.wfBool h_term_ss + (.stmts ss ρ₀) (.terminal ρ') h_wf.wfBool h_term have h_to_post : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt verifyStmt ρ_init) (.block verifyLabel (.stmts postAsserts ρ')) := by @@ -820,7 +823,7 @@ theorem procBodyVerify_procedureCorrect (ReflTrans_Transitive _ _ _ _ (step_block_enter Expression (EvalCommand π φ) (EvalPureFunc φ) bodyLabel _ #[] ρ₀) (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ bodyLabel - (CoreStepStar_to_StepStmtStar h_term_ss)))) + (CoreStepStar_to_StepStmtStar h_term)))) (ReflTrans_Transitive _ _ _ _ (seq_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ postAsserts (.step _ _ _ .step_block_done (.refl _))) @@ -886,4 +889,11 @@ theorem procBodyVerify_procedureCorrect exact h_all_post_valid _ h_in label check.expr check.md rfl · exact h_nf' + · ----- Part 3: Postconditions (CFG) — vacuously true here ----- + -- `procToVerifyStmt` only succeeds for structured bodies (see + -- `procToVerifyStmt_is_structured`), so `proc.body = .cfg _` contradicts + -- `h_body_eq : proc.body = .structured ss`. + intro cfg h_cfg_eq + exact absurd (h_body_eq.symm.trans h_cfg_eq) (by simp) + end ProcBodyVerifyCorrect From 8e944c77dedb7029030aaa8737d2d63a702246dd Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 09:11:54 -0700 Subject: [PATCH 40/57] refactor: enrich CoreBodyExec with terminal eval and unify postconditionsValid MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add a δ' : CoreEval output parameter to CoreBodyExec so it exposes the terminal evaluator. The structured constructor outputs ρ'.eval; the cfg constructor passes through the initial δ (since CoreCFGStepStar does not track eval changes). This enables unifying postconditionsValid_structured and postconditionsValid_cfg back into a single postconditionsValid field that uses CoreBodyExec to abstract over both body kinds. Updated call_sem to use the terminal eval (δ_final) from CoreBodyExec when checking postconditions, and updated procBodyVerify_procedureCorrect proof to invert the CoreBodyExec.structured constructor and reconcile the initial environment via ProcEnvWF.noFailure. Co-Authored-By: Claude Opus 4.6 (1M context) --- Strata/Languages/Core/StatementSemantics.lean | 31 +++++---------- Strata/Transform/CoreSpecification.lean | 38 +++++-------------- Strata/Transform/ProcBodyVerifyCorrect.lean | 37 +++++++++--------- 3 files changed, 38 insertions(+), 68 deletions(-) diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index abb091624d..01627fd85f 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -352,36 +352,23 @@ inductive CoreCFGStepStar /-- Execution of a procedure body: either structured (via `CoreStepStar`) or unstructured CFG (via `CoreCFGStepStar`). - TODO: Wire `CoreBodyExec` into `ProcedureCorrect.postconditionsValid_cfg` - so that CFG postcondition verification goes through this inductive rather than - being handled separately. Currently only used in `EvalCommand.call_sem`. - - TODO: The `cfg` constructor drops terminal `eval` information — after - extracting `store` and `hasFailure` from the terminal CFG configuration, the - `δ` (eval) parameter is discarded. This prevents postcondition proofs that - need the terminal eval (e.g., when `funcDecl` extends the evaluator during - execution). Consider adding a `δ' : CoreEval` output field, or exposing the - full terminal `Env Expression`, to support postcondition reasoning. - - TODO: An equivalence theorem `CoreBodyExec.structured_iff_CoreStepStar` - relating `CoreBodyExec π φ (.structured ss) σ δ σ' f` to the corresponding - `CoreStepStar π φ (.stmts ss ⟨σ, δ, false⟩) (.terminal ⟨σ', δ', f⟩)` would - bridge the two representations and ease the transition to unified - postcondition verification. -/ + The `cfg` constructor passes through the initial eval `δ` as terminal eval + because `CoreCFGStepStar` does not track eval changes. If CFG execution + ever needs `funcDecl` support, `CoreCFGStepStar` would need enrichment. -/ inductive CoreBodyExec (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) : - Procedure.Body → CoreStore → CoreEval → CoreStore → Bool → Prop where + Procedure.Body → CoreStore → CoreEval → CoreStore → CoreEval → Bool → Prop where | structured : CoreStepStar π φ (.stmts ss ⟨σ, δ, false⟩) (.terminal ρ') → - CoreBodyExec π φ (.structured ss) σ δ ρ'.store ρ'.hasFailure + CoreBodyExec π φ (.structured ss) σ δ ρ'.store ρ'.eval ρ'.hasFailure | cfg : CoreCFGStepStar π φ cfg (.cont cfg.entry σ false) (.terminal σ' failed) → - CoreBodyExec π φ (.cfg cfg) σ δ σ' failed + CoreBodyExec π φ (.cfg cfg) σ δ σ' δ failed inductive EvalCommand (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) : CoreEval → CoreStore → Command → CoreStore → Bool → Prop where @@ -393,7 +380,7 @@ inductive EvalCommand (π : String → Option Procedure) (φ : CoreEval → Pure /-- Arguments are matched positionally: `inArgs` (from `getInputExprs`) aligns with `p.header.inputs`, and `lhs` (from `getLhs`) aligns with `p.header.outputs`. -/ - | call_sem {δ σ₀ σ inArgs vals oVals σA σAO n p modvals callArgs σ' σ_final failed md} : + | call_sem {δ σ₀ σ inArgs vals oVals σA σAO n p modvals callArgs σ' σ_final δ_final failed md} : π n = .some p → -- inArg exprs + fvar refs for inoutArg ids CallArg.getInputExprs callArgs = inArgs → @@ -415,10 +402,10 @@ inductive EvalCommand (π : String → Option Procedure) (φ : CoreEval → Pure (∀ pre, (Procedure.Spec.getCheckExprs p.spec.preconditions).contains pre → isDefinedOver (HasVarsPure.getVars) σAO pre ∧ δ σAO pre = .some HasBool.tt) → - CoreBodyExec π φ p.body σAO δ σ_final failed → + CoreBodyExec π φ p.body σAO δ σ_final δ_final failed → (∀ post, (Procedure.Spec.getCheckExprs p.spec.postconditions).contains post → isDefinedOver (HasVarsPure.getVars) σAO post ∧ - δ σ_final post = .some HasBool.tt) → + δ_final σ_final post = .some HasBool.tt) → ReadValues σ_final (ListMap.keys (p.header.outputs)) modvals → -- positional: modvals[i] written back to lhs[i] UpdateStates σ lhs modvals σ' → diff --git a/Strata/Transform/CoreSpecification.lean b/Strata/Transform/CoreSpecification.lean index d26d372b5f..71a6b936b3 100644 --- a/Strata/Transform/CoreSpecification.lean +++ b/Strata/Transform/CoreSpecification.lean @@ -184,41 +184,21 @@ variable (φ : CoreEval → PureFunc Expression → CoreEval) structure ProcedureCorrect (proc : Procedure) (p : Program) : Prop where /-- (1) The asserts in the body of proc are valid. -/ assertsValid : ∀ a, AssertValidInProcedure π φ proc a - /-- (2a) The postconditions hold on termination of a **structured** body. - For structured procedures, this uses `CoreStepStar` on the statement list - to show all non-free postconditions evaluate to `true` and `hasFailure` - remains `false`. -/ - postconditionsValid_structured : - ∀ (ss : List Statement), - proc.body = .structured ss → - WF.WFProcedureProp p proc → - ∀ (ρ₀ ρ' : Env Expression), - ProcEnvWF proc ρ₀ → - CoreStepStar π φ (.stmts ss ρ₀) (.terminal ρ') → - (∀ (label : CoreLabel) (check : Procedure.Check), - (label, check) ∈ proc.spec.postconditions.toList → - check.attr = Procedure.CheckAttr.Default → - ρ'.eval ρ'.store check.expr = some HasBool.tt) ∧ - ρ'.hasFailure = Bool.false - /-- (2b) The postconditions hold on termination of a **CFG** body. - This field is the CFG counterpart of `postconditionsValid_structured`. - It is currently a soundness hole: the previous definition was vacuously - true for CFGs (the match on `proc.body` produced `[]`, forcing an - immediate `rho' = rho0` in `CoreStepStar`). - TODO: Provide a genuine proof once `CoreBodyExec` exposes the full - terminal environment (including `eval`). -/ - postconditionsValid_cfg : - ∀ (cfg : DetCFG), - proc.body = .cfg cfg → + /-- (2) The postconditions hold on termination. + Uses `CoreBodyExec` to abstract over both structured and CFG bodies. + For structured bodies, the terminal eval `δ'` comes from the terminal + `Env` (may differ from `δ` due to `funcDecl` extensions). For CFG + bodies, `δ' = δ` since `CoreCFGStepStar` does not track eval changes. -/ + postconditionsValid : WF.WFProcedureProp p proc → ∀ (ρ₀ : Env Expression), ProcEnvWF proc ρ₀ → - ∀ (σ' : CoreStore) (failed : Bool), - CoreCFGStepStar π φ cfg (.cont cfg.entry ρ₀.store false) (.terminal σ' failed) → + ∀ (σ' : CoreStore) (δ' : CoreEval) (failed : Bool), + CoreBodyExec π φ proc.body ρ₀.store ρ₀.eval σ' δ' failed → (∀ (label : CoreLabel) (check : Procedure.Check), (label, check) ∈ proc.spec.postconditions.toList → check.attr = Procedure.CheckAttr.Default → - ρ₀.eval σ' check.expr = some HasBool.tt) ∧ + δ' σ' check.expr = some HasBool.tt) ∧ failed = Bool.false end Core.Specification diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index e5f0a62d6a..04e675d457 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -742,7 +742,7 @@ theorem procBodyVerify_procedureCorrect rw [h_wrapped_eval, h_wrapped_store] at h_v exact h_v - refine ⟨?_, ?_, ?_⟩ + refine ⟨?_, ?_⟩ · ----- Part 1: All asserts in proc.body are valid ----- intro a @@ -781,15 +781,25 @@ theorem procBodyVerify_procedureCorrect have h_valid := body_asserts_valid ρ₀ h_wf a inner h_inner_core h_assert_inner simpa [Config.getEval, Config.getStore] using h_valid - · ----- Part 2: Postconditions (structured) + hasFailure on termination ----- - -- The field requires `∀ ss, proc.body = .structured ss → ...`. - -- We know `h_body_eq : proc.body = .structured ss'`. - intro ss_arg h_body_eq_arg _ ρ₀ ρ' h_wf h_term - -- After the outer `subst h_ss_eq : ss = ss'`, `ss'` was eliminated and `ss` - -- remains in scope. Equate ss_arg with ss. - have h_eq_ss : ss_arg = ss := - Procedure.Body.structured.inj (h_body_eq_arg.symm.trans h_body_eq) - rw [h_eq_ss] at h_term + · ----- Part 2: Postconditions + hasFailure on termination ----- + -- The unified field uses CoreBodyExec. Since procToVerifyStmt only + -- succeeds for structured bodies, we invert the CoreBodyExec to get + -- a CoreStepStar witness. + intro _ ρ₀ h_wf σ' δ' failed h_body_exec + -- Invert CoreBodyExec: since proc.body = .structured ss, the only + -- matching constructor is .structured, giving us a CoreStepStar witness. + rw [h_body_eq] at h_body_exec + -- Invert: the .structured constructor builds the initial env as + -- ⟨σ, δ, false⟩. ProcEnvWF gives us ρ₀.hasFailure = false, so + -- ⟨ρ₀.store, ρ₀.eval, false⟩ = ρ₀. + have h_env_eq : (⟨ρ₀.store, ρ₀.eval, false⟩ : Env Expression) = ρ₀ := by + have := h_wf.noFailure; cases ρ₀; simp_all + obtain ⟨ρ', h_term⟩ : ∃ ρ' : Env Expression, + CoreStepStar π φ (.stmts ss ρ₀) (.terminal ρ') ∧ + σ' = ρ'.store ∧ δ' = ρ'.eval ∧ failed = ρ'.hasFailure := by + cases h_body_exec with + | structured h_step => exact ⟨_, h_env_eq ▸ h_step, rfl, rfl, rfl⟩ + obtain ⟨h_term, rfl, rfl, rfl⟩ := h_term obtain ⟨ρ_init, h_prefix⟩ := h_prefix_trace ρ₀ h_wf -- h_valid: all asserts in body from ρ₀ evaluate to true have h_valid : ∀ (a : AssertId Expression) (cfg : CoreConfig), @@ -889,11 +899,4 @@ theorem procBodyVerify_procedureCorrect exact h_all_post_valid _ h_in label check.expr check.md rfl · exact h_nf' - · ----- Part 3: Postconditions (CFG) — vacuously true here ----- - -- `procToVerifyStmt` only succeeds for structured bodies (see - -- `procToVerifyStmt_is_structured`), so `proc.body = .cfg _` contradicts - -- `h_body_eq : proc.body = .structured ss`. - intro cfg h_cfg_eq - exact absurd (h_body_eq.symm.trans h_cfg_eq) (by simp) - end ProcBodyVerifyCorrect From cf067e83a8df45d1c8582cc72c53da82fb6bce02 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 12:58:30 -0700 Subject: [PATCH 41/57] implement type checking for CFG structural checks (unique labels, entry exists, valid targets) and expression-level type-checking. --- Strata/Languages/Core/ProcedureType.lean | 91 +++++++-- .../Languages/Core/Tests/CFGParseTests.lean | 174 ++++++++++++++---- 2 files changed, 218 insertions(+), 47 deletions(-) diff --git a/Strata/Languages/Core/ProcedureType.lean b/Strata/Languages/Core/ProcedureType.lean index 91262bea3f..e82cec8b62 100644 --- a/Strata/Languages/Core/ProcedureType.lean +++ b/Strata/Languages/Core/ProcedureType.lean @@ -16,7 +16,7 @@ public section namespace Core open Std (ToFormat Format format) -open Imperative (MetaData) +open Imperative (MetaData HasVarsImp) open Strata (DiagnosticModel FileRange) namespace Procedure @@ -30,11 +30,10 @@ private def checkNoDuplicates (proc : Procedure) (sourceLoc : FileRange) : private def checkModificationRights (proc : Procedure) (sourceLoc : FileRange) : Except DiagnosticModel Unit := do - let bodyStmts ← proc.body.getStructured.mapError (fun e => DiagnosticModel.withRange sourceLoc f!"{e}") - let modifiedVars := (Imperative.Block.modifiedVars bodyStmts).eraseDups - let definedVars := (Imperative.Block.definedVars bodyStmts).eraseDups + let modifiedVars := (HasVarsImp.modifiedVars (P := Expression) proc.body).eraseDups + let definedVars := (HasVarsImp.definedVars (P := Expression) proc.body).eraseDups let allowedVars := proc.header.outputs.keys ++ definedVars - let disallowed := modifiedVars.filter (fun v => v ∉ allowedVars) + let disallowed := modifiedVars.filter (fun v => !allowedVars.contains v) if !disallowed.isEmpty then .error <| DiagnosticModel.withRange sourceLoc f!"[{proc.header.name}]: This procedure modifies variables it \ is not allowed to!\n\ @@ -51,6 +50,68 @@ private def setupInputEnv (C : Core.Expression.TyContext) (Env : Core.Expression let Env := Env.addInNewestContext inp_lty_sig return (inp_mty_sig, Env) +private def checkUniqueLabels (procName : CoreIdent) (cfg : DetCFG) (sourceLoc : FileRange) : + Except DiagnosticModel Unit := do + let labels := cfg.blocks.map (·.1) + if !labels.Nodup then + let dups := labels.filter (fun l => labels.countP (· == l) > 1) |>.eraseDups + .error <| DiagnosticModel.withRange sourceLoc + f!"[{procName}]: Duplicate block labels in CFG: {dups}" + +private def checkEntryExists (procName : CoreIdent) (cfg : DetCFG) (sourceLoc : FileRange) : + Except DiagnosticModel Unit := do + let labels := cfg.blocks.map (·.1) + if !labels.contains cfg.entry then + .error <| DiagnosticModel.withRange sourceLoc + f!"[{procName}]: Entry label \"{cfg.entry}\" not found in CFG blocks. \ + Available labels: {labels}" + +private def checkTargetLabels (procName : CoreIdent) (cfg : DetCFG) (sourceLoc : FileRange) : + Except DiagnosticModel Unit := do + let labels := cfg.blocks.map (·.1) + for (lbl, blk) in cfg.blocks do + match blk.transfer with + | .condGoto _ lt lf _ => + if !labels.contains lt then + .error <| DiagnosticModel.withRange sourceLoc + f!"[{procName}]: Block \"{lbl}\" branches to unknown label \"{lt}\". \ + Available labels: {labels}" + if !labels.contains lf then + .error <| DiagnosticModel.withRange sourceLoc + f!"[{procName}]: Block \"{lbl}\" branches to unknown label \"{lf}\". \ + Available labels: {labels}" + | .finish _ => pure () + +open Lambda Lambda.LTy.Syntax in +private def typeCheckCFG (C : Core.Expression.TyContext) (Env : Core.Expression.TyEnv) + (P : Program) (proc : Procedure) (cfg : DetCFG) (sourceLoc : FileRange) : + Except DiagnosticModel (DetCFG × Core.Expression.TyEnv) := do + checkUniqueLabels proc.header.name cfg sourceLoc + checkEntryExists proc.header.name cfg sourceLoc + checkTargetLabels proc.header.name cfg sourceLoc + let mut currentEnv := Env + let mut annotatedBlocks : List (String × Imperative.DetBlock String Command Expression) := [] + for (lbl, blk) in cfg.blocks do + let mut cmds' := [] + for cmd in blk.cmds do + let (cmd', newEnv) ← Statement.typeCheckCmd C currentEnv P cmd + currentEnv := newEnv + cmds' := cmds' ++ [cmd'] + let transfer' ← match blk.transfer with + | .condGoto p lt lf md => + let (pa, newEnv) ← LExpr.resolve C currentEnv p + |>.mapError DiagnosticModel.fromFormat + currentEnv := newEnv + if pa.toLMonoTy != mty[bool] then + .error <| DiagnosticModel.withRange sourceLoc + f!"[{proc.header.name}]: Branch condition in block \"{lbl}\" \ + is not of type bool, got {pa.toLMonoTy}" + pure (Imperative.DetTransferCmd.condGoto pa.unresolved lt lf md) + | .finish md => pure (.finish md) + annotatedBlocks := annotatedBlocks ++ [(lbl, { cmds := cmds', transfer := transfer' })] + let annotatedCFG : DetCFG := { entry := cfg.entry, blocks := annotatedBlocks } + return (annotatedCFG, currentEnv) + -- Error message prefix for errors in processing procedure pre/post conditions. def conditionErrorMsgPrefix (procName : CoreIdent) (condName : CoreLabel) (md : MetaData Expression) : DiagnosticModel := @@ -112,13 +173,13 @@ def typeCheck (C : Core.Expression.TyContext) (Env : Core.Expression.TyEnv) (p : -- Type check body. -- Note that `Statement.typeCheck` already reports source locations in -- error messages. - -- For now, we skip checking CFG bodies. Potential TODOs for CFGs: - -- * verify block labels are unique - -- * all variables used are declared/initialized - -- * target labels of transfer commands exist - let (annotated_body, finalEnv) ← match proc.body with - | .structured ss => Statement.typeCheck C envAfterPostconds p (.some proc) ss - | .cfg _ => pure ([], envAfterPostconds) + let (annotated_body, annotated_cfg, finalEnv) ← match proc.body with + | .structured ss => + let (ss', env') ← Statement.typeCheck C envAfterPostconds p (.some proc) ss + pure (ss', none, env') + | .cfg cfgBody => + let (cfg', env') ← typeCheckCFG C envAfterPostconds p proc cfgBody fileRange + pure ([], some cfg', env') -- Remove formals and returns from the context -- they ought to be local to -- the procedure body. @@ -133,9 +194,9 @@ def typeCheck (C : Core.Expression.TyContext) (Env : Core.Expression.TyEnv) (p : outputs := out_mty_sig } let new_spec := { proc.spec with preconditions := finalPreconditions, postconditions := finalPostconditions } - let new_body := match proc.body with - | .structured _ => .structured annotated_body - | .cfg c => .cfg c + let new_body := match annotated_cfg with + | some cfg' => .cfg cfg' + | none => .structured annotated_body let new_proc := { proc with header := new_hdr, spec := new_spec, body := new_body } return (new_proc, finalEnv) diff --git a/StrataTest/Languages/Core/Tests/CFGParseTests.lean b/StrataTest/Languages/Core/Tests/CFGParseTests.lean index 4b5c6da27e..57a6ac58a0 100644 --- a/StrataTest/Languages/Core/Tests/CFGParseTests.lean +++ b/StrataTest/Languages/Core/Tests/CFGParseTests.lean @@ -196,15 +196,10 @@ cfg start { | .structured _ => IO.println " ERROR: expected CFG body" | _ => pure () -/-! ## End-to-end: type-checking rejects CFG procedures - -Regression test for PR #1132: the verifier pipeline (which includes type -checking) should reject CFG bodies with a clear diagnostic rather than -silently producing wrong results. The current rejection comes from -`checkModificationRights`, which calls `Body.getStructured` on a CFG body. -/ +/-! ## End-to-end: type-checking accepts well-formed CFG procedures -/ /-- -info: type-check rejected CFG procedure: expected structured body, got CFG +info: type-check accepted CFG procedure -/ #guard_msgs in #eval do @@ -217,22 +212,13 @@ cfg start { }; " match Core.typeCheck .quiet prog with - | .error dm => IO.println s!"type-check rejected CFG procedure: {dm.message}" - | .ok _ => IO.println "ERROR: expected type-check to fail for CFG procedure" - -/-! ## End-to-end: parsed CFG body is preserved, not collapsed + | .error dm => IO.println s!"ERROR: type-check rejected CFG procedure: {dm.message}" + | .ok _ => IO.println "type-check accepted CFG procedure" -Regression test for PR #1132: there was a bug where the procedure body was -always stored as `.structured annotated_body` after type checking, erasing -CFG bodies to `.structured []`. The fix preserves `.cfg` bodies. This test -confirms that after parsing, a CFG procedure's body is `.cfg` (not -`.structured []`), guarding against regression in the parser or DDM layer. -/ +/-! ## End-to-end: type-checking accepts Max (branches + assignments) -/ /-- -info: Procedure: Max - body.isCfg = true - body.isStructured = false - CFG preserved: entry=entry, 4 blocks +info: type-check accepted Max with CFG body preserved (4 blocks) -/ #guard_msgs in #eval do @@ -259,15 +245,139 @@ cfg entry { } }; " - for d in prog.decls do - match d with - | .proc p _ => - IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" - IO.println s!" body.isCfg = {p.body.isCfg}" - IO.println s!" body.isStructured = {p.body.isStructured}" - match p.body with - | .cfg c => - IO.println s!" CFG preserved: entry={c.entry}, {c.blocks.length} blocks" - | .structured ss => - IO.println s!" ERROR: body collapsed to .structured with {ss.length} statements" - | _ => pure () + match Core.typeCheck .quiet prog with + | .error dm => IO.println s!"ERROR: {dm.message}" + | .ok prog' => + for d in prog'.decls do + match d with + | .proc p _ => + match p.body with + | .cfg c => + IO.println s!"type-check accepted Max with CFG body preserved ({c.blocks.length} blocks)" + | .structured ss => + IO.println s!"ERROR: body collapsed to .structured with {ss.length} statements" + | _ => pure () + +/-! ## End-to-end: type-checking accepts CountUp (loop pattern with init) -/ + +/-- +info: type-check accepted CountUp +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure CountUp(n : int, out y : int) +spec { + requires (n >= 0); +} +cfg entry { + entry: { + y := 0; + goto loop; + } + loop: { + branch (y < n) goto body else done; + } + body: { + y := y + 1; + goto loop; + } + done: { + return; + } +}; +" + match Core.typeCheck .quiet prog with + | .error dm => IO.println s!"ERROR: {dm.message}" + | .ok _ => IO.println "type-check accepted CountUp" + +/-! ## Error: duplicate block labels -/ + +/-- +info: rejected: Duplicate block labels in CFG +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure Bad() +cfg start { + start: { return; } + start: { return; } +}; +" + match Core.typeCheck .quiet prog with + | .error dm => + if dm.message.contains "Duplicate block labels" then + IO.println "rejected: Duplicate block labels in CFG" + else + IO.println s!"ERROR: unexpected message: {dm.message}" + | .ok _ => IO.println "ERROR: expected type-check to fail" + +/-! ## Error: unknown target label -/ + +/-- +info: rejected: branches to unknown label +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure Bad(out y : int) +cfg start { + start: { + y := 0; + goto nonexistent; + } +}; +" + match Core.typeCheck .quiet prog with + | .error dm => + if dm.message.contains "branches to unknown label" then + IO.println "rejected: branches to unknown label" + else + IO.println s!"ERROR: unexpected message: {dm.message}" + | .ok _ => IO.println "ERROR: expected type-check to fail" + +/-! ## Error: type mismatch in CFG command -/ + +/-- +info: rejected: type error in CFG command +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure Bad(x : bool, out y : int) +cfg start { + start: { + y := x; + return; + } +}; +" + match Core.typeCheck .quiet prog with + | .error _ => + IO.println "rejected: type error in CFG command" + | .ok _ => IO.println "ERROR: expected type-check to fail" + +/-! ## Error: modification rights violation in CFG -/ + +/-- +info: rejected: modifies disallowed variable +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure Bad(x : int) +cfg start { + start: { + x := 42; + return; + } +}; +" + match Core.typeCheck .quiet prog with + | .error dm => + if dm.message.contains "modifies variables" then + IO.println "rejected: modifies disallowed variable" + else + IO.println s!"ERROR: unexpected message: {dm.message}" + | .ok _ => IO.println "ERROR: expected type-check to fail" From 39afe3e0b7d5ab2eb405a426df9fff1e75c2a51e Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 13:57:49 -0700 Subject: [PATCH 42/57] Implement symbolic executor for CFG - Uses a fuel-measure and throws error on running out of fuel - No path-merging - Added #guard_msg tests 1. Trivial CFG (single finish block) 2. Linear CFG (assignment + goto + postcondition holds) 3. Missing block error 4. Fuel exhaustion on loop back-edge 5. Postcondition failure (non-trivial proof obligation) 6. Diamond CFG with symbolic branch (two paths, two proof obligations with path conditions) --- Strata/Languages/Core/ProcedureEval.lean | 97 ++++++- .../Core/Tests/ProcedureEvalCFGTests.lean | 257 ++++++++++++++++++ 2 files changed, 348 insertions(+), 6 deletions(-) create mode 100644 StrataTest/Languages/Core/Tests/ProcedureEvalCFGTests.lean diff --git a/Strata/Languages/Core/ProcedureEval.lean b/Strata/Languages/Core/ProcedureEval.lean index 83f81d63f6..eaeece8e43 100644 --- a/Strata/Languages/Core/ProcedureEval.lean +++ b/Strata/Languages/Core/ProcedureEval.lean @@ -58,6 +58,92 @@ private def mergeResults (fallback : Env) (results : List Env) : Env := deferred := allDeferred, exprEnv := { E.exprEnv with config := { E.exprEnv.config with usedNames := mergedNames } } } +private def evalBlockCmds (E : Env) (old_var_subst : SubstMap) + (cmds : List Command) : Env := + cmds.foldl (fun env cmd => + if env.error.isSome then env + else (Statement.Command.eval env old_var_subst cmd).snd) E + +private def evalCFGStep (cfg : DetCFG) (old_var_subst : SubstMap) + (active : List (String × Env)) : + List (String × Env) × List Env × Statistics := + active.foldl (fun (newActive, finished, stats) (label, env) => + if env.error.isSome then + (newActive, env :: finished, stats) + else + match cfg.blocks.lookup label with + | none => + let env' := { env with error := some (.Misc + s!"evalCFG: block '{label}' not found in CFG") } + (newActive, env' :: finished, stats) + | some blk => + let env' := evalBlockCmds env old_var_subst blk.cmds + if env'.error.isSome then + (newActive, env' :: finished, stats) + else + let stats := stats.increment s!"{Evaluator.Stats.simulatedStmts}" + match blk.transfer with + | .finish _ => + (newActive, env' :: finished, stats) + | .condGoto cond lt lf _ => + let cond' := env'.exprEval cond + match cond' with + | .true _ => ((lt, env') :: newActive, finished, stats) + | .false _ => ((lf, env') :: newActive, finished, stats) + | _ => + let label_t := toString (f!"") + let label_f := toString (f!"") + let env_t := { env' with pathConditions := + (env'.pathConditions.addInNewest + [.assumption label_t cond']) } + let env_f := { env' with pathConditions := + (env'.pathConditions.addInNewest + [.assumption label_f + (Lambda.LExpr.ite () cond' (LExpr.false ()) (LExpr.true ()))]) } + ((lt, env_t) :: (lf, env_f) :: newActive, finished, stats)) + ([], [], {}) + +private def evalCFGBlocks (cfg : DetCFG) (old_var_subst : SubstMap) + (fuel : Nat) (active : List (String × Env)) (finished : List Env) + (stats : Statistics) : List Env × Statistics := + match active with + | [] => (finished, stats) + | _ => + match fuel with + | 0 => + let errorEnvs := active.map fun (_, e) => + { e with error := some .OutOfFuel } + (errorEnvs ++ finished, + stats.increment s!"{Evaluator.Stats.simulatingStmtHitOutOfFuel}" active.length) + | fuel' + 1 => + let (newActive, newFinished, stepStats) := + evalCFGStep cfg old_var_subst active + evalCFGBlocks cfg old_var_subst fuel' newActive + (newFinished ++ finished) (stats.merge stepStats) + termination_by fuel + +private def evalCFGBody (E : Env) (old_var_subst : SubstMap) + (precond_assumes postcond_asserts : Statements) + (cfg : DetCFG) (fuel : Nat) : List Env × Statistics := + let (preEnvs, preStats) := Statement.eval E old_var_subst precond_assumes + let init₁ : List Env × Statistics := ([], {}) + let (cfgResults, cfgStats) := + preEnvs.foldl (fun acc preEnv => + let (accEnvs, accStats) := acc + let (envs, stats) := + evalCFGBlocks cfg old_var_subst fuel [(cfg.entry, preEnv)] [] {} + (accEnvs ++ envs, Statistics.merge accStats stats)) init₁ + let init₂ : List Env × Statistics := ([], {}) + let (postResults, postStats) := + cfgResults.foldl (fun acc cfgEnv => + let (accEnvs, accStats) := acc + if cfgEnv.error.isSome then + (cfgEnv :: accEnvs, accStats) + else + let (envs, stats) := Statement.eval cfgEnv old_var_subst postcond_asserts + (accEnvs ++ envs, Statistics.merge accStats stats)) init₂ + (postResults, Statistics.merge preStats (Statistics.merge cfgStats postStats)) + /-- Evaluate a single procedure: generate fresh variables for parameters, execute the body, check postconditions, and collect proof obligations. @@ -113,13 +199,12 @@ def eval (E : Env) (p : Procedure) : Env × Statistics := /- the assumptions from preconditions are set to have empty metadata -/ (.assume label check.expr check.md)) p.spec.preconditions - -- Symbolic evaluation of CFG bodies is not yet implemented: it would require - -- control-flow-following with path merging at join points, significantly - -- increasing complexity. For now, only structured bodies are supported. match p.body with - | .cfg _ => - ({ E with error := some (.Misc - s!"Procedure.eval: symbolic evaluation of CFG bodies is not implemented (procedure '{p.header.name}')") }, {}) + | .cfg cfgBody => + let fuel := cfgBody.blocks.length * 100 + let (ssEs, evalStats) := + evalCFGBody E old_g_subst precond_assumes postcond_asserts cfgBody fuel + (mergeResults E (ssEs.map (fun sE => fixupError sE)), evalStats) | .structured bodyStmts => let (ssEs, evalStats) := Statement.eval E old_g_subst (precond_assumes ++ bodyStmts ++ postcond_asserts) (mergeResults E (ssEs.map (fun sE => fixupError sE)), evalStats) diff --git a/StrataTest/Languages/Core/Tests/ProcedureEvalCFGTests.lean b/StrataTest/Languages/Core/Tests/ProcedureEvalCFGTests.lean new file mode 100644 index 0000000000..6cbc99b177 --- /dev/null +++ b/StrataTest/Languages/Core/Tests/ProcedureEvalCFGTests.lean @@ -0,0 +1,257 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.Core.ProcedureEval + +namespace Core + +section CFGEvalTests + +open Std (ToFormat Format format) +open Procedure Statement Lambda Lambda.LTy.Syntax Lambda.LExpr.SyntaxMono Core.Syntax +open Imperative + +private def cfgEval (p : Procedure) : String := + let E := Env.init (empty_factory := true) + let (E, _stats) := eval E p + toString (format E) + +/-! ## Trivial CFG: single block with finish, no parameters -/ + +/-- +info: Error: +none +Subst Map: + +Expression Env: +State: + + +Evaluation Config: +Eval Depth: 200 +Factory Functions: + + + +Datatypes: + +Path Conditions: + + +Warnings: +[] +Deferred Proof Obligations: +-/ +#guard_msgs in +#eval IO.println (cfgEval + { header := {name := "Trivial", typeArgs := [], inputs := [], outputs := [] }, + spec := { preconditions := [], postconditions := [] }, + body := .cfg { entry := "start", + blocks := [("start", { cmds := [], transfer := .finish })] } }) + +/-! ## Linear CFG: assignment via goto, postcondition holds -/ + +/-- +info: Error: +none +Subst Map: + +Expression Env: +State: + + +Evaluation Config: +Eval Depth: 200 +Factory Functions: + + + +Datatypes: + +Path Conditions: + + +Warnings: +[] +Deferred Proof Obligations: +Label: y_eq_42 +Property: assert +Assumptions: + +Proof Obligation: +true +-/ +#guard_msgs in +#eval IO.println (cfgEval + { header := {name := "Linear", typeArgs := [], + inputs := [], outputs := [("y", mty[int])] }, + spec := { preconditions := [], + postconditions := [("y_eq_42", ⟨eb[y == #42], .Default, #[]⟩)] }, + body := .cfg { entry := "entry", + blocks := [ + ("entry", { cmds := [CmdExt.cmd (Cmd.set "y" (.det eb[#42]) .empty)], + transfer := .goto "done" }), + ("done", { cmds := [], transfer := .finish }) + ] } }) + +/-! ## Missing block error -/ + +/-- +info: Error: +some [ERROR] evalCFG: block 'nonexistent' not found in CFG +Subst Map: + +Expression Env: +State: +[] + +Evaluation Config: +Eval Depth: 200 +Factory Functions: + + + +Datatypes: + +Path Conditions: + + + +Warnings: +[] +Deferred Proof Obligations: +-/ +#guard_msgs in +#eval IO.println (cfgEval + { header := {name := "MissingBlock", typeArgs := [], inputs := [], outputs := [] }, + spec := { preconditions := [], postconditions := [] }, + body := .cfg { entry := "start", + blocks := [("start", { cmds := [], + transfer := .goto "nonexistent" })] } }) + +/-! ## Fuel exhaustion: loop back-edge -/ + +/-- +info: has error: true +-/ +#guard_msgs in +#eval do + let E := Env.init (empty_factory := true) + let p : Procedure := + { header := {name := "Loop", typeArgs := [], + inputs := [], outputs := [("y", mty[int])] }, + spec := { preconditions := [], postconditions := [] }, + body := .cfg { entry := "loop", + blocks := [ + ("loop", { cmds := [CmdExt.cmd (Cmd.set "y" (.det eb[#1]) .empty)], + transfer := .goto "loop" }) + ] } } + let (E, _stats) := eval E p + IO.println s!"has error: {E.error.isSome}" + +/-! ## Postcondition failure: non-trivial proof obligation -/ + +/-- +info: Error: +none +Subst Map: + +Expression Env: +State: + + +Evaluation Config: +Eval Depth: 200 +Factory Functions: + + + +Datatypes: + +Path Conditions: + + +Warnings: +[] +Deferred Proof Obligations: +Label: y_eq_0 +Property: assert +Assumptions: + +Proof Obligation: +false +-/ +#guard_msgs in +#eval IO.println (cfgEval + { header := {name := "PostFail", typeArgs := [], + inputs := [], outputs := [("y", mty[int])] }, + spec := { preconditions := [], + postconditions := [("y_eq_0", ⟨eb[y == #0], .Default, #[]⟩)] }, + body := .cfg { entry := "entry", + blocks := [ + ("entry", { cmds := [CmdExt.cmd (Cmd.set "y" (.det eb[#42]) .empty)], + transfer := .finish }) + ] } }) + +/-! ## Diamond CFG: symbolic branch produces two proof obligations -/ + +/-- +info: Error: +none +Subst Map: + +Expression Env: +State: + + +Evaluation Config: +Eval Depth: 200 +Factory Functions: + + + +Datatypes: + +Path Conditions: + + +Warnings: +[] +Deferred Proof Obligations: +Label: y_ge_0 +Property: assert +Assumptions: +(= 0>, x@1 >= 0) +Proof Obligation: +x@1 >= 0 + +Label: y_ge_0 +Property: assert +Assumptions: +(= 0)>, if x@1 >= 0 then false else true) +Proof Obligation: +0 - x@1 >= 0 +-/ +#guard_msgs in +#eval IO.println (cfgEval + { header := {name := "Diamond", typeArgs := [], + inputs := [("x", mty[int])], + outputs := [("y", mty[int])] }, + spec := { preconditions := [], + postconditions := [("y_ge_0", ⟨eb[((~Int.Ge y) #0)], .Default, #[]⟩)] }, + body := .cfg { entry := "entry", + blocks := [ + ("entry", { cmds := [], + transfer := .condGoto eb[((~Int.Ge x) #0)] "pos" "neg" }), + ("pos", { cmds := [CmdExt.cmd (Cmd.set "y" (.det eb[x]) .empty)], + transfer := .goto "done" }), + ("neg", { cmds := [CmdExt.cmd (Cmd.set "y" (.det eb[((~Int.Sub #0) x)]) .empty)], + transfer := .goto "done" }), + ("done", { cmds := [], transfer := .finish }) + ] } }) + +end CFGEvalTests +end Core From c1299b8825178403daa39548441f7c1d3379d8c9 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 14:29:16 -0700 Subject: [PATCH 43/57] abstract collectCmds --- Strata/Languages/Core/StatementEval.lean | 52 ++++++++---------------- 1 file changed, 17 insertions(+), 35 deletions(-) diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 8a0732864e..9443b1e69a 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -249,52 +249,34 @@ def Statements.containsAsserts (ss : Statements) : Bool := (fun c => match c with | .assert _ _ _ => true | _ => false) ss mutual -/-- -Collect all `cover` commands from a statement `s` with their labels and metadata. --/ -def Statement.collectCovers (s : Statement) : List (String × Imperative.MetaData Expression) := +def Statement.collectCmds (f : Imperative.Cmd Expression → Option α) (s : Statement) : List α := match s with - | .cmd (.cmd (.cover label _expr md)) => [(label, md)] + | .cmd (.cmd c) => (f c).toList | .cmd _ => [] - | .block _ inner_ss _ => Statements.collectCovers inner_ss - | .ite _ then_ss else_ss _ => Statements.collectCovers then_ss ++ Statements.collectCovers else_ss - | .loop _ _ _ body_ss _ => Statements.collectCovers body_ss - | .funcDecl _ _ | .exit _ _ | .typeDecl _ _ => [] -- Function/type declarations and exits don't contain cover commands + | .block _ inner_ss _ => Statements.collectCmds f inner_ss + | .ite _ then_ss else_ss _ => Statements.collectCmds f then_ss ++ Statements.collectCmds f else_ss + | .loop _ _ _ body_ss _ => Statements.collectCmds f body_ss + | .funcDecl _ _ | .exit _ _ | .typeDecl _ _ => [] termination_by Imperative.Stmt.sizeOf s -/-- -Collect all `cover` commands from statements `ss` with their labels and metadata. --/ -def Statements.collectCovers (ss : Statements) : List (String × Imperative.MetaData Expression) := +def Statements.collectCmds (f : Imperative.Cmd Expression → Option α) (ss : Statements) : List α := match ss with | [] => [] | s :: ss => - Statement.collectCovers s ++ Statements.collectCovers ss + Statement.collectCmds f s ++ Statements.collectCmds f ss termination_by Imperative.Block.sizeOf ss end -mutual -/-- -Collect all `assert` commands from a statement `s` with their labels and metadata. --/ +def Statement.collectCovers (s : Statement) : List (String × Imperative.MetaData Expression) := + Statement.collectCmds (fun | .cover label _expr md => some (label, md) | _ => none) s + +def Statements.collectCovers (ss : Statements) : List (String × Imperative.MetaData Expression) := + Statements.collectCmds (fun | .cover label _expr md => some (label, md) | _ => none) ss + def Statement.collectAsserts (s : Statement) : List (String × Imperative.MetaData Expression) := - match s with - | .cmd (.cmd (.assert label _expr md)) => [(label, md)] - | .cmd _ => [] - | .block _ inner_ss _ => Statements.collectAsserts inner_ss - | .ite _ then_ss else_ss _ => Statements.collectAsserts then_ss ++ Statements.collectAsserts else_ss - | .loop _ _ _ body_ss _ => Statements.collectAsserts body_ss - | .funcDecl _ _ | .exit _ _ | .typeDecl _ _ => [] -- Function/type declarations and exits don't contain assert commands - termination_by Imperative.Stmt.sizeOf s -/-- -Collect all `assert` commands from statements `ss` with their labels and metadata. --/ + Statement.collectCmds (fun | .assert label _expr md => some (label, md) | _ => none) s + def Statements.collectAsserts (ss : Statements) : List (String × Imperative.MetaData Expression) := - match ss with - | [] => [] - | s :: ss => - Statement.collectAsserts s ++ Statements.collectAsserts ss - termination_by Imperative.Block.sizeOf ss -end + Statements.collectCmds (fun | .assert label _expr md => some (label, md) | _ => none) ss /-- Create cover obligations for covers in an unreachable (dead) branch, including From b9334dccf86d862228a61ae79b43491d55ca1e35 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 15:10:10 -0700 Subject: [PATCH 44/57] add more documentation/better abstraction --- Strata/Languages/Core/DDMTransform/Grammar.lean | 4 +++- Strata/Languages/Core/DDMTransform/Translate.lean | 6 ++++++ Strata/Languages/Core/Procedure.lean | 4 ++++ Strata/Languages/Core/ProcedureEval.lean | 3 +++ Strata/Languages/Core/ProcedureType.lean | 5 +++++ Strata/Transform/PrecondElim.lean | 6 +++--- 6 files changed, 24 insertions(+), 4 deletions(-) diff --git a/Strata/Languages/Core/DDMTransform/Grammar.lean b/Strata/Languages/Core/DDMTransform/Grammar.lean index 8c15ccd6e5..123679eb73 100644 --- a/Strata/Languages/Core/DDMTransform/Grammar.lean +++ b/Strata/Languages/Core/DDMTransform/Grammar.lean @@ -463,7 +463,9 @@ op command_datatypes (datatypes : NewlineSepBy DatatypeDecl) : Command => // Transfer commands: how a basic block ends category Transfer; -// Goto: one target = unconditional, multiple targets = nondeterministic choice +// Goto: one target = unconditional, two targets = nondeterministic choice. +// The grammar accepts any number of comma-separated labels, but the translator +// currently supports at most 2 (see translateTransfer in Translate.lean). op transfer_goto (labels : CommaSepBy Ident) : Transfer => "goto " labels ";"; diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index 484c4ecb90..a47b094035 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -1633,6 +1633,12 @@ partial def translateTransfer (p : Program) (bindings : TransBindings) (arg : Ar TransM.error s!"translateTransfer: goto with more than 2 targets is not supported" let label1 ← translateIdent String l1 let label2 ← translateIdent String l2 + -- Nondeterministic choice: introduce an unbound free variable as the branch + -- condition. The symbolic evaluator returns the fvar unchanged (via findD), + -- which is neither .true nor .false, causing evalCFGStep to fork into both + -- paths with complementary path conditions. The concrete interpreter (runCFG) + -- will error on this, which is expected — nondeterministic gotos are only + -- meaningful under symbolic execution. let condName := s!"$__nondet_{bindings.gen.var_def}" return .condGoto (Lambda.LExpr.fvar () ⟨condName, ()⟩ none) label1 label2 | q`Core.transfer_cond_goto => diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 1fc21d0445..59c815adda 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -332,6 +332,10 @@ def Procedure.Body.isCfg : Procedure.Body → Bool | .structured _ => false | .cfg _ => true +def Procedure.Body.structuredLength : Procedure.Body → Nat + | .structured ss => ss.length + | .cfg _ => 0 + /-- A Strata Core procedure: the main verification unit. diff --git a/Strata/Languages/Core/ProcedureEval.lean b/Strata/Languages/Core/ProcedureEval.lean index eaeece8e43..3accc1c204 100644 --- a/Strata/Languages/Core/ProcedureEval.lean +++ b/Strata/Languages/Core/ProcedureEval.lean @@ -201,6 +201,9 @@ def eval (E : Env) (p : Procedure) : Env × Statistics := p.spec.preconditions match p.body with | .cfg cfgBody => + -- 100 iterations per block: enough to unroll moderate loops while keeping + -- symbolic execution bounded. Fuel is consumed per block visit, so a + -- single-block loop unrolls ~100 times and a 4-block diamond uses ~400. let fuel := cfgBody.blocks.length * 100 let (ssEs, evalStats) := evalCFGBody E old_g_subst precond_assumes postcond_asserts cfgBody fuel diff --git a/Strata/Languages/Core/ProcedureType.lean b/Strata/Languages/Core/ProcedureType.lean index e82cec8b62..27c9a69f1e 100644 --- a/Strata/Languages/Core/ProcedureType.lean +++ b/Strata/Languages/Core/ProcedureType.lean @@ -82,6 +82,11 @@ private def checkTargetLabels (procName : CoreIdent) (cfg : DetCFG) (sourceLoc : Available labels: {labels}" | .finish _ => pure () +-- Type environment flows sequentially through all blocks in list order, +-- regardless of control-flow reachability. This is a sound over-approximation: +-- it may accept a program that uses an uninitialized variable at runtime (the +-- verifier will still catch the error), but it never misses a real type error. +-- Per-block scoping would require a dataflow fixpoint over the CFG. open Lambda Lambda.LTy.Syntax in private def typeCheckCFG (C : Core.Expression.TyContext) (Env : Core.Expression.TyEnv) (P : Program) (proc : Procedure) (cfg : DetCFG) (sourceLoc : FileRange) : diff --git a/Strata/Transform/PrecondElim.lean b/Strata/Transform/PrecondElim.lean index 042b8b3cf8..8b1b8bb2af 100644 --- a/Strata/Transform/PrecondElim.lean +++ b/Strata/Transform/PrecondElim.lean @@ -457,7 +457,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => (match p.body with | .structured ss => ss.length | .cfg _ => 0) | _ => 0) + (match wfDecl with | .proc p _ => p.body.structuredLength | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty proc.header.name)) return (true, wfDecl :: procDecl :: rest') @@ -477,7 +477,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => (match p.body with | .structured ss => ss.length | .cfg _ => 0) | _ => 0) + (match wfDecl with | .proc p _ => p.body.structuredLength | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty func.name)) return (true, wfDecl :: funcDecl :: rest') @@ -502,7 +502,7 @@ where | some wfDecl => do incrementStat s!"{Stats.wfProceduresGenerated}" incrementStat s!"{Stats.wfProcedureBodyStmtsEmitted}" - (match wfDecl with | .proc p _ => (match p.body with | .structured ss => ss.length | .cfg _ => 0) | _ => 0) + (match wfDecl with | .proc p _ => p.body.structuredLength | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty func.name)) return some wfDecl From 4d29cde63ccb04832b99eb6dc90a03ab2faefdcb Mon Sep 17 00:00:00 2001 From: David Deng Date: Fri, 8 May 2026 09:56:00 -0700 Subject: [PATCH 45/57] add metadata to unstructured programs --- Strata/DL/Imperative/BasicBlock.lean | 4 ++-- .../Transform/StructuredToUnstructured.lean | 18 +++++++-------- StrataTest/Languages/Core/Examples/Exit.lean | 22 +++++++++---------- StrataTest/Languages/Core/Examples/Loops.lean | 8 +++---- 4 files changed, 26 insertions(+), 26 deletions(-) diff --git a/Strata/DL/Imperative/BasicBlock.lean b/Strata/DL/Imperative/BasicBlock.lean index fc4dafb47a..416c587a64 100644 --- a/Strata/DL/Imperative/BasicBlock.lean +++ b/Strata/DL/Imperative/BasicBlock.lean @@ -40,8 +40,8 @@ inductive DetTransferCmd (Label : Type) (P : PureExpr) where model it instead using `condGoto`. By defining this function, we can easily create unconditional jumps, and future proof against the possibility of adding it as a constructor in the future. -/ -def DetTransferCmd.goto [HasBool P] (l : Label) : DetTransferCmd Label P := - condGoto HasBool.tt l l +def DetTransferCmd.goto [HasBool P] (l : Label) (md : MetaData P := .empty) : 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 diff --git a/Strata/Transform/StructuredToUnstructured.lean b/Strata/Transform/StructuredToUnstructured.lean index eb8d3e9558..60b9165aff 100644 --- a/Strata/Transform/StructuredToUnstructured.lean +++ b/Strata/Transform/StructuredToUnstructured.lean @@ -65,7 +65,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. @@ -77,9 +77,9 @@ match ss with -- Empty accumulated block pure (accumEntry, accumBlocks ++ bbs ++ bsNext) else - let b := (l, { cmds := [], transfer := .goto bl }) + let b := (l, { cmds := [], transfer := .goto bl md }) pure (l, accumBlocks ++ [b] ++ bbs ++ bsNext) -| .ite c tss fss _md :: rest => do +| .ite c tss fss md :: rest => do -- Process rest first let (kNext, bsNext) ← stmtsToBlocks k rest exitConts [] -- Create ite block @@ -95,9 +95,9 @@ match ss with let initCmd := HasInit.init ident HasBool.boolTy .nondet MetaData.empty 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 @@ -135,7 +135,7 @@ match ss with -- 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 md }) let (accumEntry, accumBlocks) ← flushCmds "before_loop$" accum .none lentry pure (accumEntry, accumBlocks ++ [b] ++ bbs ++ decreaseBlocks ++ bsNext) | .nondet => do @@ -143,10 +143,10 @@ match ss with let ident := HasIdent.ident (P := P) freshName let initCmd := HasInit.init ident HasBool.boolTy .nondet MetaData.empty let b := (lentry, { cmds := [initCmd] ++ invCmds ++ measureCmds, - transfer := .condGoto (HasFvar.mkFvar ident) bl kNext }) + transfer := .condGoto (HasFvar.mkFvar ident) bl kNext md }) let (accumEntry, accumBlocks) ← flushCmds "before_loop$" accum .none lentry pure (accumEntry, accumBlocks ++ [b] ++ bbs ++ decreaseBlocks ++ bsNext) -| .exit l? _md :: _ => do +| .exit l? md :: _ => do -- Find the continuation of the block labeled `l`, or the most recently-added -- block if `l` is `.none`. let bk := @@ -167,7 +167,7 @@ match ss with match l? with | .some l => s!"block${l}$" | .none => "block$" - flushCmds exitName accum .none bk + flushCmds exitName accum (.some (.goto bk md)) bk def stmtsToCFGM [HasBool P] [HasPassiveCmds P CmdT] [HasInit P CmdT] diff --git a/StrataTest/Languages/Core/Examples/Exit.lean b/StrataTest/Languages/Core/Examples/Exit.lean index 53dedb039d..7d9b7529f4 100644 --- a/StrataTest/Languages/Core/Examples/Exit.lean +++ b/StrataTest/Languages/Core/Examples/Exit.lean @@ -116,10 +116,10 @@ Result: ✅ pass info: Entry: l1 l1: - condGoto true block$l1$_2 block$l1$_2 + #[<[fileRange]: :387-502>] condGoto true block$l1$_2 block$l1$_2 block$l1$_2: assert [a1]: x == x; - condGoto true l$_1 l$_1 + #[<[fileRange]: :426-434>] condGoto true l$_1 l$_1 l$_1: assert [a3]: x == x; condGoto true end$_0 end$_0 @@ -133,29 +133,29 @@ end$_0: info: Entry: l5 l5: - condGoto true l4 l4 + #[<[fileRange]: :577-1056>] condGoto true l4 l4 l4: - condGoto true l4_before l4_before + #[<[fileRange]: :589-1050>] condGoto true l4_before l4_before l4_before: - condGoto true l3_before l3_before + #[<[fileRange]: :603-996>] condGoto true l3_before l3_before l3_before: - condGoto true l1 l1 + #[<[fileRange]: :626-933>] condGoto true l1 l1 l1: - condGoto true ite$_5 ite$_5 + #[<[fileRange]: :651-835>] condGoto true ite$_5 ite$_5 ite$_5: assert [a4]: x == x; - condGoto x > 0 block$l5$_2 block$l5$_1 + #[<[fileRange]: :706-821>] condGoto x > 0 block$l5$_2 block$l5$_1 l2: - condGoto true l$_3 l$_3 + #[<[fileRange]: :848-921>] 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 + #[<[fileRange]: :978-986>] condGoto true end$_0 end$_0 block$l5$_1: assert [a7]: x <= 0; - condGoto true end$_0 end$_0 + #[<[fileRange]: :1034-1042>] condGoto true end$_0 end$_0 end$_0: finish -/ diff --git a/StrataTest/Languages/Core/Examples/Loops.lean b/StrataTest/Languages/Core/Examples/Loops.lean index 48ca96bec4..44ea57ac5b 100644 --- a/StrataTest/Languages/Core/Examples/Loops.lean +++ b/StrataTest/Languages/Core/Examples/Loops.lean @@ -54,7 +54,7 @@ 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 + #[<[fileRange]: :813-919>] condGoto i < n l$_4 end$_0 l$_4: i := i + 1; condGoto true measure_decrease$_3 measure_decrease$_3 @@ -142,7 +142,7 @@ 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 + #[<[fileRange]: :2438-2594>] condGoto i < n l$_4 end$_0 l$_4: i := i + 1; s := s + i; @@ -389,7 +389,7 @@ 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 + #[<[fileRange]: :8059-8312>] condGoto x < n before_loop$_11 end$_0 before_loop$_11: y := 0; condGoto true loop_entry$_5 loop_entry$_5 @@ -399,7 +399,7 @@ 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 + #[<[fileRange]: :8179-8292>] condGoto y < x l$_8 l$_4 l$_8: y := y + 1; condGoto true measure_decrease$_7 measure_decrease$_7 From 6f2aca046eed2ec970295d04e96864e878cec6f1 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 15:54:25 -0700 Subject: [PATCH 46/57] feat: preserve loop contracts in CFG transfer metadata During structured-to-CFG lowering, loop invariants and decreases measures were only preserved as lowered assert commands, losing the connection to the original spec. Downstream CFG passes that need to recover the contract (e.g., for invariant inference or refinement) had no way to distinguish spec-level asserts from user asserts. Add `MetaData.specLoopInvariant` and `MetaData.specDecreases` fields and attach them to the loop entry block's transfer command metadata. The existing assert lowering is preserved (both representations coexist), so this is a non-breaking addition. Co-Authored-By: Claude Opus 4.6 (1M context) --- Strata/DL/Imperative/MetaData.lean | 8 + .../Transform/StructuredToUnstructured.lean | 12 +- StrataTest/Languages/Core/Examples/Loops.lean | 22 ++- .../StructuredToUnstructuredTests.lean | 152 ++++++++++++++++++ 4 files changed, 188 insertions(+), 6 deletions(-) create mode 100644 StrataTest/Transform/StructuredToUnstructuredTests.lean diff --git a/Strata/DL/Imperative/MetaData.lean b/Strata/DL/Imperative/MetaData.lean index dff78ea614..a8000b0e78 100644 --- a/Strata/DL/Imperative/MetaData.lean +++ b/Strata/DL/Imperative/MetaData.lean @@ -303,6 +303,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/Transform/StructuredToUnstructured.lean b/Strata/Transform/StructuredToUnstructured.lean index 60b9165aff..74eb52a8b3 100644 --- a/Strata/Transform/StructuredToUnstructured.lean +++ b/Strata/Transform/StructuredToUnstructured.lean @@ -132,10 +132,18 @@ match ss with if srcLabel.isEmpty then StringGenState.gen "inv$" else pure srcLabel pure (HasPassiveCmds.assert assertLabel i MetaData.empty)) + -- 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 md }) + 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 @@ -143,7 +151,7 @@ match ss with let ident := HasIdent.ident (P := P) freshName let initCmd := HasInit.init ident HasBool.boolTy .nondet MetaData.empty let b := (lentry, { cmds := [initCmd] ++ invCmds ++ measureCmds, - transfer := .condGoto (HasFvar.mkFvar ident) bl kNext md }) + 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 diff --git a/StrataTest/Languages/Core/Examples/Loops.lean b/StrataTest/Languages/Core/Examples/Loops.lean index 44ea57ac5b..e7c61e08dc 100644 --- a/StrataTest/Languages/Core/Examples/Loops.lean +++ b/StrataTest/Languages/Core/Examples/Loops.lean @@ -54,7 +54,10 @@ 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); - #[<[fileRange]: :813-919>] condGoto i < n l$_4 end$_0 + #[<[fileRange]: :869-975>, + <[#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 @@ -142,7 +145,11 @@ 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); - #[<[fileRange]: :2438-2594>] condGoto i < n l$_4 end$_0 + #[<[fileRange]: :2589-2745>, + <[#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; @@ -389,7 +396,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); - #[<[fileRange]: :8059-8312>] condGoto x < n before_loop$_11 end$_0 + #[<[fileRange]: :8358-8611>, + <[#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 @@ -399,7 +410,10 @@ 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); - #[<[fileRange]: :8179-8292>] condGoto y < x l$_8 l$_4 + #[<[fileRange]: :8478-8591>, + <[#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 diff --git a/StrataTest/Transform/StructuredToUnstructuredTests.lean b/StrataTest/Transform/StructuredToUnstructuredTests.lean new file mode 100644 index 0000000000..872923fb28 --- /dev/null +++ b/StrataTest/Transform/StructuredToUnstructuredTests.lean @@ -0,0 +1,152 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Transform.StructuredToUnstructured +import Strata.DL.Lambda.Lambda + +/-! ## Tests for loop contract metadata preservation in StructuredToUnstructured -/ + +section +open Std (ToFormat Format format) +open Lambda.LTy.Syntax +open Imperative (MetaData MetaDataElem) + +private abbrev TP : Lambda.LExprParams := ⟨Unit, Unit⟩ + +private abbrev P : Imperative.PureExpr := + { Ident := TP.Identifier, + Expr := Lambda.LExprT TP.mono, + Ty := Lambda.LMonoTy, + ExprMetadata := TP.Metadata, + TyEnv := @Lambda.TEnv TP.IDMeta, + TyContext := @Lambda.LContext TP, + EvalEnv := Lambda.LState TP + EqIdent := inferInstanceAs (DecidableEq TP.Identifier) } + +private abbrev mdB : Lambda.Typed Unit := { underlying := (), type := mty[bool] } + +instance : Imperative.HasBool P where + tt := .const mdB (.boolConst true) + ff := .const mdB (.boolConst false) + tt_is_not_ff := by simp + boolTy := mty[bool] + +instance : Imperative.HasIdent P where + ident s := ⟨s, ()⟩ + +instance : Imperative.HasFvar P where + mkFvar := (.fvar mdB · none) + getFvar | .fvar _ v _ => some v | _ => none + +instance : Imperative.HasIntOrder P where + eq e1 e2 := .eq mdB e1 e2 + lt e1 e2 := .app mdB (.app mdB (.op mdB ⟨"Int.Lt", ()⟩ none) e1) e2 + zero := .intConst mdB 0 + intTy := mty[int] + +instance : Imperative.HasNot P where + not e := .app mdB (.op mdB ⟨"Bool.Not", ()⟩ none) e + +instance : Imperative.HasPassiveCmds P (Imperative.Cmd P) where + assert l e md := .assert l e md + assume l e md := .assume l e md + +instance : Imperative.HasInit P (Imperative.Cmd P) where + init i ty e md := .init i ty e md + +private def mkFvar (name : String) : P.Expr := .fvar mdB ⟨name, ()⟩ none +private def trueExpr : P.Expr := .const mdB (.boolConst true) + +private abbrev Stmt' := Imperative.Stmt P (Imperative.Cmd P) +private abbrev CFG' := Imperative.CFG String (Imperative.DetBlock String (Imperative.Cmd P) P) + +private def toCFG (ss : List Stmt') : CFG' := Imperative.stmtsToCFG ss + +private def findLoopEntry (cfg : CFG') : + Option (Imperative.DetBlock String (Imperative.Cmd P) P) := + cfg.blocks.find? (fun (lbl, _) => lbl.startsWith "loop_entry$") |>.map (·.2) + +private def getTransferMd (blk : Imperative.DetBlock String (Imperative.Cmd P) P) : + MetaData P := + match blk.transfer with + | .condGoto _ _ _ md => md + | .finish md => md + +private def countField (md : MetaData P) (fld : MetaDataElem.Field P) : Nat := + md.filter (fun e => e.fld == fld) |>.size + +private def loopEntryMd (ss : List Stmt') : MetaData P := + match findLoopEntry (toCFG ss) with + | some blk => getTransferMd blk + | none => .empty + +private def setCmd (name : String) : Imperative.Cmd P := + .set ⟨name, ()⟩ (.det (mkFvar name)) .empty + +/-! ### Simple loop with one invariant: specLoopInvariant in transfer metadata -/ + +#guard countField (loopEntryMd [ + .loop (.det trueExpr) none [("inv0", mkFvar "x")] [.cmd (setCmd "x")] .empty + ]) MetaData.specLoopInvariant == 1 + +/-! ### Loop with multiple invariants: one entry per invariant -/ + +#guard countField (loopEntryMd [ + .loop (.det trueExpr) none [("inv_a", mkFvar "a"), ("inv_b", mkFvar "b")] + [.cmd (setCmd "x")] .empty + ]) MetaData.specLoopInvariant == 2 + +/-! ### Loop with decreases measure: specDecreases in metadata -/ + +#guard countField (loopEntryMd [ + .loop (.det trueExpr) (some (mkFvar "n")) [("inv", mkFvar "x")] + [.cmd (setCmd "x")] .empty + ]) MetaData.specDecreases == 1 + +/-! ### Loop with both invariants and decreases -/ + +#guard + let md := loopEntryMd [ + .loop (.det trueExpr) (some (mkFvar "n")) [("inv_a", mkFvar "a"), ("inv_b", mkFvar "b")] + [.cmd (setCmd "x")] .empty + ] + countField md MetaData.specLoopInvariant == 2 && + countField md MetaData.specDecreases == 1 + +/-! ### Loop without contract: no spec metadata in transfer -/ + +#guard + let md := loopEntryMd [ + .loop (.det trueExpr) none [] [.cmd (setCmd "x")] .empty + ] + countField md MetaData.specLoopInvariant == 0 && + countField md MetaData.specDecreases == 0 + +/-! ### Invariant assert commands still emitted (both behaviors coexist) -/ + +#guard + let cfg := toCFG [ + .loop (.det trueExpr) none [("my_inv", mkFvar "x")] + [.cmd (setCmd "x")] .empty + ] + match findLoopEntry cfg with + | some blk => blk.cmds.any (fun cmd => + match cmd with + | .assert label _ _ => label == "my_inv" + | _ => false) + | none => false + +/-! ### Nondet loop guard: contract metadata still present -/ + +#guard + let md := loopEntryMd [ + .loop .nondet (some (mkFvar "n")) [("inv", mkFvar "x")] + [.cmd (setCmd "x")] .empty + ] + countField md MetaData.specLoopInvariant == 1 && + countField md MetaData.specDecreases == 1 + +end From 6d2582c5ac985f580bd04918be6a1c20c2273004 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 15:59:30 -0700 Subject: [PATCH 47/57] fix: split transfer_goto grammar to enforce 1 or 2 targets at parse time MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The grammar previously accepted `goto label1, label2, ..., labelN;` via CommaSepBy, but the translator rejected >2 targets at translation time. This meant users could write syntactically valid programs that failed during elaboration with a confusing error. Split into two grammar ops: - `transfer_goto (label : Ident)` — unconditional goto (1 target) - `transfer_nondet_goto (label1 : Ident, label2 : Ident)` — nondet (2 targets) The concrete syntax is unchanged: `goto a;` and `goto a, b;` parse as before. `goto a, b, c;` now fails at parse time with a clear syntax error instead of passing through to translation. Co-Authored-By: Claude Opus 4.6 (1M context) --- .../Languages/Core/DDMTransform/Grammar.lean | 12 ++++--- .../Core/DDMTransform/Translate.lean | 33 ++++++++----------- 2 files changed, 20 insertions(+), 25 deletions(-) diff --git a/Strata/Languages/Core/DDMTransform/Grammar.lean b/Strata/Languages/Core/DDMTransform/Grammar.lean index 123679eb73..26536ed53e 100644 --- a/Strata/Languages/Core/DDMTransform/Grammar.lean +++ b/Strata/Languages/Core/DDMTransform/Grammar.lean @@ -463,11 +463,13 @@ op command_datatypes (datatypes : NewlineSepBy DatatypeDecl) : Command => // Transfer commands: how a basic block ends category Transfer; -// Goto: one target = unconditional, two targets = nondeterministic choice. -// The grammar accepts any number of comma-separated labels, but the translator -// currently supports at most 2 (see translateTransfer in Translate.lean). -op transfer_goto (labels : CommaSepBy Ident) : Transfer => - "goto " labels ";"; +// Unconditional goto: exactly one target. +op transfer_goto (label : Ident) : Transfer => + "goto " label ";"; + +// Nondeterministic goto: exactly two targets chosen nondeterministically. +op transfer_nondet_goto (label1 : Ident, label2 : Ident) : Transfer => + "goto " label1 ", " label2 ";"; // Conditional goto (deterministic: condition selects between two targets) // NOTE: We use "branch" instead of "if" to avoid ambiguity with the diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index a47b094035..48e6d57d34 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -1621,26 +1621,19 @@ partial def translateTransfer (p : Program) (bindings : TransBindings) (arg : Ar | TransM.error s!"translateTransfer expected op {repr arg}" match op.name with | q`Core.transfer_goto => - let .seq _ .comma labels := op.args[0]! - | TransM.error s!"translateTransfer goto expected comma-sep labels" - match labels.toList with - | [] => return .finish - | [l] => - let label ← translateIdent String l - return .condGoto (Lambda.LExpr.boolConst () Bool.true) label label - | l1 :: l2 :: rest => - if !rest.isEmpty then - TransM.error s!"translateTransfer: goto with more than 2 targets is not supported" - let label1 ← translateIdent String l1 - let label2 ← translateIdent String l2 - -- Nondeterministic choice: introduce an unbound free variable as the branch - -- condition. The symbolic evaluator returns the fvar unchanged (via findD), - -- which is neither .true nor .false, causing evalCFGStep to fork into both - -- paths with complementary path conditions. The concrete interpreter (runCFG) - -- will error on this, which is expected — nondeterministic gotos are only - -- meaningful under symbolic execution. - let condName := s!"$__nondet_{bindings.gen.var_def}" - return .condGoto (Lambda.LExpr.fvar () ⟨condName, ()⟩ none) label1 label2 + let label ← translateIdent String op.args[0]! + return .condGoto (Lambda.LExpr.boolConst () Bool.true) label label + | q`Core.transfer_nondet_goto => + let label1 ← translateIdent String op.args[0]! + let label2 ← translateIdent String op.args[1]! + -- Nondeterministic choice: introduce an unbound free variable as the branch + -- condition. The symbolic evaluator returns the fvar unchanged (via findD), + -- which is neither .true nor .false, causing evalCFGStep to fork into both + -- paths with complementary path conditions. The concrete interpreter (runCFG) + -- will error on this, which is expected — nondeterministic gotos are only + -- meaningful under symbolic execution. + let condName := s!"$__nondet_{bindings.gen.var_def}" + return .condGoto (Lambda.LExpr.fvar () ⟨condName, ()⟩ none) label1 label2 | q`Core.transfer_cond_goto => let cond ← translateExpr p bindings op.args[0]! let lt ← translateIdent String op.args[1]! From 11f11ebd5bfc9e49d48013f1a1d550d8cff2278b Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 16:02:53 -0700 Subject: [PATCH 48/57] fix: increment var_def counter when generating nondet goto fvar translateTransfer now increments the var_def counter after reading it for the $__nondet_N variable name, so multiple nondeterministic gotos in the same procedure get distinct names. Co-Authored-By: Claude Opus 4.6 (1M context) --- Strata/Languages/Core/DDMTransform/Translate.lean | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index 48e6d57d34..f2daa8ac4f 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -1611,18 +1611,19 @@ def translateBlockCommand (p : Program) (bindings : TransBindings) (op : Operati /-- Translate a transfer command from the CFG syntax -/ +private instance : Inhabited TransBindings := ⟨{}⟩ private instance : Inhabited (Imperative.DetTransferCmd String Core.Expression) := ⟨.finish⟩ private instance : Inhabited (Imperative.BasicBlock (Imperative.DetTransferCmd String Core.Expression) Core.Command) := ⟨⟨[], .finish⟩⟩ private instance : Inhabited (Imperative.CFG String (Imperative.DetBlock String Core.Command Core.Expression)) := ⟨⟨"", []⟩⟩ partial def translateTransfer (p : Program) (bindings : TransBindings) (arg : Arg) : - TransM (Imperative.DetTransferCmd String Core.Expression) := do + TransM (Imperative.DetTransferCmd String Core.Expression × TransBindings) := do let .op op := arg | TransM.error s!"translateTransfer expected op {repr arg}" match op.name with | q`Core.transfer_goto => let label ← translateIdent String op.args[0]! - return .condGoto (Lambda.LExpr.boolConst () Bool.true) label label + return (.condGoto (Lambda.LExpr.boolConst () Bool.true) label label, bindings) | q`Core.transfer_nondet_goto => let label1 ← translateIdent String op.args[0]! let label2 ← translateIdent String op.args[1]! @@ -1633,14 +1634,15 @@ partial def translateTransfer (p : Program) (bindings : TransBindings) (arg : Ar -- will error on this, which is expected — nondeterministic gotos are only -- meaningful under symbolic execution. let condName := s!"$__nondet_{bindings.gen.var_def}" - return .condGoto (Lambda.LExpr.fvar () ⟨condName, ()⟩ none) label1 label2 + let bindings := incrNum .var_def bindings + return (.condGoto (Lambda.LExpr.fvar () ⟨condName, ()⟩ none) label1 label2, bindings) | q`Core.transfer_cond_goto => let cond ← translateExpr p bindings op.args[0]! let lt ← translateIdent String op.args[1]! let lf ← translateIdent String op.args[2]! - return .condGoto cond lt lf + return (.condGoto cond lt lf, bindings) | q`Core.transfer_return => - return .finish + return (.finish, bindings) | _ => TransM.error s!"translateTransfer: unknown transfer {repr op.name}" /-- Translate a single CFG block -/ @@ -1664,7 +1666,7 @@ partial def translateCFGBlock (p : Program) (bindings : TransBindings) (arg : Ar match stmt with | .cmd c => cmds := cmds.push c | _ => TransM.error s!"translateCFGBlock: only commands allowed in CFG blocks, got statement" - let transfer ← translateTransfer p bindings op.args[2]! + let (transfer, _) ← translateTransfer p bindings op.args[2]! return (label, ⟨cmds.toList, transfer⟩) /-- Translate a list of CFG blocks -/ From 7f0d3b9322a4d389db0872c2f53de9301454cba0 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 16:24:17 -0700 Subject: [PATCH 49/57] Fix binding bug in CFG Parser --- .../Core/DDMTransform/Translate.lean | 26 ++++----- .../Languages/Core/Tests/CFGParseTests.lean | 54 +++++++++++++++++++ 2 files changed, 67 insertions(+), 13 deletions(-) diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index f2daa8ac4f..abdd7df1b9 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -1647,7 +1647,7 @@ partial def translateTransfer (p : Program) (bindings : TransBindings) (arg : Ar /-- Translate a single CFG block -/ partial def translateCFGBlock (p : Program) (bindings : TransBindings) (arg : Arg) : - TransM (String × Imperative.BasicBlock (Imperative.DetTransferCmd String Core.Expression) Core.Command) := do + TransM (String × Imperative.BasicBlock (Imperative.DetTransferCmd String Core.Expression) Core.Command × TransBindings) := do let .op op := arg | TransM.error s!"translateCFGBlock expected op {repr arg}" let label ← translateIdent String op.args[0]! @@ -1666,32 +1666,32 @@ partial def translateCFGBlock (p : Program) (bindings : TransBindings) (arg : Ar match stmt with | .cmd c => cmds := cmds.push c | _ => TransM.error s!"translateCFGBlock: only commands allowed in CFG blocks, got statement" - let (transfer, _) ← translateTransfer p bindings op.args[2]! - return (label, ⟨cmds.toList, transfer⟩) + let (transfer, bindings') ← translateTransfer p bindings op.args[2]! + return (label, ⟨cmds.toList, transfer⟩, bindings') /-- Translate a list of CFG blocks -/ partial def translateCFGBlocks (p : Program) (bindings : TransBindings) (arg : Arg) : - TransM (List (String × Imperative.BasicBlock (Imperative.DetTransferCmd String Core.Expression) Core.Command)) := do + TransM (List (String × Imperative.BasicBlock (Imperative.DetTransferCmd String Core.Expression) Core.Command) × TransBindings) := do let .op op := arg | TransM.error s!"translateCFGBlocks expected op {repr arg}" match op.name with | q`Core.cfg_blocks_one => - let block ← translateCFGBlock p bindings op.args[0]! - return [block] + let (label, blk, bindings) ← translateCFGBlock p bindings op.args[0]! + return ([(label, blk)], bindings) | q`Core.cfg_blocks_cons => - let block ← translateCFGBlock p bindings op.args[0]! - let rest ← translateCFGBlocks p bindings op.args[1]! - return block :: rest + let (label, blk, bindings) ← translateCFGBlock p bindings op.args[0]! + let (rest, bindings) ← translateCFGBlocks p bindings op.args[1]! + return ((label, blk) :: rest, bindings) | _ => TransM.error s!"translateCFGBlocks: unknown {repr op.name}" /-- Translate a CFG body -/ partial def translateCFGBody (p : Program) (bindings : TransBindings) (arg : Arg) : - TransM (Imperative.CFG String (Imperative.DetBlock String Core.Command Core.Expression)) := do + TransM (Imperative.CFG String (Imperative.DetBlock String Core.Command Core.Expression) × TransBindings) := do let .op op := arg | TransM.error s!"translateCFGBody expected op {repr arg}" let entry ← translateIdent String op.args[0]! - let blocks ← translateCFGBlocks p bindings op.args[1]! - return { entry := entry, blocks := blocks } + let (blocks, bindings) ← translateCFGBlocks p bindings op.args[1]! + return ({ entry := entry, blocks := blocks }, bindings) /-- Translate a procedure with CFG body -/ def translateCFGProcedure (p : Program) (bindings : TransBindings) (op : Operation) : @@ -1711,7 +1711,7 @@ def translateCFGProcedure (p : Program) (bindings : TransBindings) (op : Operati | TransM.error s!"translateCFGProcedure spec expected: {repr op.args[3]!}" let (requires, ensures) ← if speca.isSome then translateSpec p pname bindings speca.get! else pure ([], []) - let cfg ← translateCFGBody p bindings op.args[4]! + let (cfg, bindings) ← translateCFGBody p bindings op.args[4]! let origBindings := { origBindings with gen := bindings.gen } let md ← getOpMetaData op return (.proc { header := { name := pname, diff --git a/StrataTest/Languages/Core/Tests/CFGParseTests.lean b/StrataTest/Languages/Core/Tests/CFGParseTests.lean index 57a6ac58a0..23be9d534f 100644 --- a/StrataTest/Languages/Core/Tests/CFGParseTests.lean +++ b/StrataTest/Languages/Core/Tests/CFGParseTests.lean @@ -381,3 +381,57 @@ cfg start { else IO.println s!"ERROR: unexpected message: {dm.message}" | .ok _ => IO.println "ERROR: expected type-check to fail" + +/-! ## Multiple nondet gotos get distinct condition variables -/ + +open Std (format) in +private def getTransferCondStr (blk : Imperative.DetBlock String Core.Command Core.Expression) + : Option String := + match blk.transfer with + | .condGoto cond l1 l2 _ => + if l1 != l2 then some (toString (format cond)) else none + | _ => none + +/-- +info: nondet condition names are distinct across blocks +-/ +#guard_msgs in +#eval do + let prog ← parseCoreText " +procedure MultiNondet(out y : int) +cfg entry { + entry: { + goto a, b; + } + a: { + goto c, d; + } + b: { + y := 1; + goto done; + } + c: { + y := 2; + goto done; + } + d: { + y := 3; + goto done; + } + done: { + return; + } +}; +" + for d in prog.decls do + match d with + | .proc p _ => + match p.body with + | .cfg cfg => + let condNames := cfg.blocks.filterMap fun (pair : String × _) => getTransferCondStr pair.2 + if condNames.length == 2 && condNames.Nodup then + IO.println "nondet condition names are distinct across blocks" + else + IO.println s!"ERROR: expected 2 distinct nondet conditions, got {condNames}" + | .structured _ => IO.println "ERROR: expected CFG body" + | _ => pure () From 12b0295c3b30696dddd906ed0ea70ff4041e2f02 Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 16:37:38 -0700 Subject: [PATCH 50/57] fix comments --- Strata/Languages/Core/Procedure.lean | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 59c815adda..8f1df314d2 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -397,9 +397,9 @@ def DetCFG.eraseTypes (cfg : DetCFG) : DetCFG := | .condGoto p lt lf md => .condGoto p.eraseTypes lt lf md | .finish md => .finish md }) } --- DetCFG.stripMetaData delegates to the generic CFG.stripDetMetaData from --- BasicBlock.lean. Commands inside blocks carry no standalone metadata field, --- so only transfer metadata is stripped. +-- Only transfer metadata is stripped because command metadata (on assert, +-- assume, init, set, cover) is not included in formatted output — formatCmd +-- discards it. Transfer metadata, however, appears in CFG formatting. def DetCFG.stripMetaData (cfg : DetCFG) : DetCFG := Imperative.CFG.stripDetMetaData cfg From b0640fd85de67dc89b0e2a5e31884ecf57fa470b Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 12 May 2026 16:41:00 -0700 Subject: [PATCH 51/57] refactor: use Procedure.Body.getStructured instead of raw match Replace 5 instances of the "match body with structured/cfg-error" pattern with the existing getStructured helper, which was defined but unused. Uses .mapError where the caller's error type differs from Except String. Co-Authored-By: Claude Opus 4.6 (1M context) --- Strata/Backends/CBMC/CoreToCBMC.lean | 4 +--- Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean | 4 +--- Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean | 4 +--- Strata/Transform/ProcBodyVerify.lean | 5 +---- StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean | 4 +--- 5 files changed, 5 insertions(+), 16 deletions(-) diff --git a/Strata/Backends/CBMC/CoreToCBMC.lean b/Strata/Backends/CBMC/CoreToCBMC.lean index d8d7e67984..e8ceee5a9a 100644 --- a/Strata/Backends/CBMC/CoreToCBMC.lean +++ b/Strata/Backends/CBMC/CoreToCBMC.lean @@ -346,9 +346,7 @@ def createImplementationSymbolFromAST (func : Core.Procedure) : Except String CB -- For now, keep the hardcoded implementation but use function name from AST let loc : SourceLoc := { functionName := (func.header.name.toPretty), lineNum := "1" } - let bodyStmts ← match func.body with - | .structured ss => .ok ss - | .cfg _ => .error "Cannot translate unstructured CFG body to CBMC JSON format" + let bodyStmts ← func.body.getStructured let stmtJsons ← (bodyStmts.mapM (stmtToJson (I:=CoreLParams) · loc)) let implValue := Json.mkObj [ diff --git a/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean index 34db25bd34..8821ffc7ee 100644 --- a/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean +++ b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean @@ -204,9 +204,7 @@ def transformToGoto (cprog : Core.Program) : Except Format CProverGOTO.Context : -- TODO: This pass could be split into a two-stage transformation: -- 1. structured → cfg (via StructuredToUnstructured) -- 2. cfg → CProverGOTO (always operates on CFG, no pattern matching needed) - let bodyStmts ← match p.body with - | .structured ss => pure ss - | .cfg _ => throw f!"CFG body not supported for GOTO translation" + let bodyStmts ← p.body.getStructured.mapError fun s => f!"{s}" let cmds ← bodyStmts.mapM (fun b => match b with | .cmd (.cmd c) => return c diff --git a/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean b/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean index a3fd851dc1..5c03e8727e 100644 --- a/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean +++ b/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean @@ -262,9 +262,7 @@ def procedureToGotoCtx -- TODO: This pass could be split into a two-stage transformation: -- 1. structured → cfg (via StructuredToUnstructured) -- 2. cfg → CProverGOTO (always operates on CFG, no pattern matching needed) - let bodyStmts ← match p.body with - | .structured ss => pure ss - | .cfg _ => throw f!"CFG body not supported for GOTO pipeline" + let bodyStmts ← p.body.getStructured.mapError fun s => f!"{s}" let (liftedFuncs, body) ← collectFuncDecls bodyStmts let pname := Core.CoreIdent.toPretty p.header.name if !p.header.typeArgs.isEmpty then diff --git a/Strata/Transform/ProcBodyVerify.lean b/Strata/Transform/ProcBodyVerify.lean index 46f74a6237..64503b9f71 100644 --- a/Strata/Transform/ProcBodyVerify.lean +++ b/Strata/Transform/ProcBodyVerify.lean @@ -92,10 +92,7 @@ open Core Imperative Transform -- suffix (postcondition asserts) are statement-level constructs that embed -- around the body. Unstructured CFG bodies require a different verification -- strategy (e.g., encoding the contract directly in the CFG). - let bodyStmts ← match proc.body with - | .structured ss => pure ss - | .cfg _ => throw (Strata.DiagnosticModel.fromMessage - "procToVerifyStmt: expected structured body, got CFG") + let bodyStmts ← proc.body.getStructured.mapError Strata.DiagnosticModel.fromMessage -- Wrap body in labeled block let bodyBlock := Stmt.block bodyLabel bodyStmts #[] diff --git a/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean b/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean index d0e01422e8..cca938708b 100644 --- a/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean +++ b/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean @@ -354,9 +354,7 @@ private def coreToGotoJsonWithSummary (p : Strata.Program) (summary : String) : let Env := Lambda.TEnv.default let procs := cprog.decls.filterMap fun d => d.getProc? let p := procs[0]! - let bodyStmts ← match p.body with - | .structured ss => pure ss - | .cfg _ => .error f!"coreToGotoJsonWithSummary: CFG body not supported" + let bodyStmts ← p.body.getStructured.mapError fun s => f!"{s}" let p' : Core.Procedure := { p with body := .structured (injectPropertySummary bodyStmts summary) } let pname := Core.CoreIdent.toPretty p'.header.name let ctx ← procedureToGotoCtx Env p' From b9bb6bb0ea4ad7d3da87b5afbc3dc1d7dbf94051 Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 13 May 2026 11:39:51 -0700 Subject: [PATCH 52/57] simplify CFG Eval --- Strata/Languages/Core/ProcedureEval.lean | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/Strata/Languages/Core/ProcedureEval.lean b/Strata/Languages/Core/ProcedureEval.lean index 3accc1c204..d29a40a120 100644 --- a/Strata/Languages/Core/ProcedureEval.lean +++ b/Strata/Languages/Core/ProcedureEval.lean @@ -91,8 +91,9 @@ private def evalCFGStep (cfg : DetCFG) (old_var_subst : SubstMap) | .true _ => ((lt, env') :: newActive, finished, stats) | .false _ => ((lf, env') :: newActive, finished, stats) | _ => - let label_t := toString (f!"") - let label_f := toString (f!"") + let condErased := cond.eraseTypes + let label_t := toString (f!"") + let label_f := toString (f!"") let env_t := { env' with pathConditions := (env'.pathConditions.addInNewest [.assumption label_t cond']) } @@ -126,23 +127,23 @@ private def evalCFGBody (E : Env) (old_var_subst : SubstMap) (precond_assumes postcond_asserts : Statements) (cfg : DetCFG) (fuel : Nat) : List Env × Statistics := let (preEnvs, preStats) := Statement.eval E old_var_subst precond_assumes - let init₁ : List Env × Statistics := ([], {}) - let (cfgResults, cfgStats) := + let emptyAcc : List Env × Statistics := ([], {}) + let (cfgResultsRev, cfgStats) := preEnvs.foldl (fun acc preEnv => let (accEnvs, accStats) := acc let (envs, stats) := evalCFGBlocks cfg old_var_subst fuel [(cfg.entry, preEnv)] [] {} - (accEnvs ++ envs, Statistics.merge accStats stats)) init₁ - let init₂ : List Env × Statistics := ([], {}) - let (postResults, postStats) := + (envs.reverse ++ accEnvs, accStats.merge stats)) emptyAcc + let cfgResults := cfgResultsRev.reverse + let (postResultsRev, postStats) := cfgResults.foldl (fun acc cfgEnv => let (accEnvs, accStats) := acc if cfgEnv.error.isSome then (cfgEnv :: accEnvs, accStats) else let (envs, stats) := Statement.eval cfgEnv old_var_subst postcond_asserts - (accEnvs ++ envs, Statistics.merge accStats stats)) init₂ - (postResults, Statistics.merge preStats (Statistics.merge cfgStats postStats)) + (envs.reverse ++ accEnvs, accStats.merge stats)) emptyAcc + (postResultsRev.reverse, preStats.merge (cfgStats.merge postStats)) /-- Evaluate a single procedure: generate fresh variables for parameters, From 63181c964dc0fe526583db18c94302bab891677f Mon Sep 17 00:00:00 2001 From: David Deng Date: Wed, 13 May 2026 13:10:48 -0700 Subject: [PATCH 53/57] feat: add CFG-based Core-to-GOTO pipeline alongside direct path MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add `procedureToGotoCtxViaCFG`, a parallel pipeline that translates Core procedures to CProver GOTO via the CFG representation: Structured body → stmtsToCFG → coreCFGToGotoTransform → GOTO CFG body → coreCFGToGotoTransform → GOTO This coexists with the existing direct path in `procedureToGotoCtx`, which remains unchanged. Changes: 1. CFGToCProverGOTO.lean — close two gaps in `detCFGToGotoTransform`: - Source locations: transfer command metadata is now used to derive source locations via `metadataToSourceLoc` (previously ignored as `_md`). - Loop contracts: backward-edge GOTOs targeting loop entry blocks are annotated with `#spec_loop_invariant` and `#spec_decreases` named fields on the guard, matching CBMC's DFCC expectations. A post- processing pass detects loop entries (by presence of contract metadata on their condGoto transfer) and annotates GOTOs whose target location ≤ source location (i.e., backward edges). 2. CoreToGOTOPipeline.lean — make `renameIdent`, `renameExpr`, `renameCmd`, and `collectFuncDecls` non-private so the new pipeline can reuse them. 3. CoreCFGToGOTOPipeline.lean (new) — contains: - Rename helpers for Core commands (`CmdExt`): `renameCoreCommand`, `renameCoreStmt`, `renameCoreDetCFG`. - `coreCFGToGotoTransform`: Core-specific CFG-to-GOTO translation that handles `CmdExt.call` (emits FUNCTION_CALL instructions) and delegates `CmdExt.cmd` to `Cmd.toGotoInstructions`. Also handles source locations and loop contract annotation. - `procedureToGotoCtxViaCFG`: full pipeline wrapper mirroring `procedureToGotoCtx` — renaming, type environment, axioms, distinct declarations, contracts, lifted functions — but routing through `stmtsToCFG` + `coreCFGToGotoTransform`. 4. E2E_CFGPipeline.lean (new) — 11 equivalence tests that run both pipelines on the same Core programs and compare: - Semantic instruction types (DECL, ASSIGN, ASSERT, ASSUME, etc.) match between direct and CFG paths. - Contract annotations (#spec_requires, #spec_ensures) match. - Both paths produce valid, non-null JSON output. Test programs cover: simple assert, var decl/assign, if-then-else, contracts, axioms/distinct, free specs, cover, bitvector ops, assume, multiple commands, and CFG-only output validation. Co-Authored-By: Claude Opus 4.6 (1M context) --- Strata/Backends/CBMC/GOTO.lean | 1 + .../CBMC/GOTO/CoreCFGToGOTOPipeline.lean | 304 ++++++++++++++++++ .../CBMC/GOTO/CoreToGOTOPipeline.lean | 8 +- Strata/DL/Imperative/CFGToCProverGOTO.lean | 77 +++-- .../Backends/CBMC/GOTO/E2E_CFGPipeline.lean | 296 +++++++++++++++++ 5 files changed, 642 insertions(+), 44 deletions(-) create mode 100644 Strata/Backends/CBMC/GOTO/CoreCFGToGOTOPipeline.lean create mode 100644 StrataTest/Backends/CBMC/GOTO/E2E_CFGPipeline.lean diff --git a/Strata/Backends/CBMC/GOTO.lean b/Strata/Backends/CBMC/GOTO.lean index 132440f8af..77eab4f29e 100644 --- a/Strata/Backends/CBMC/GOTO.lean +++ b/Strata/Backends/CBMC/GOTO.lean @@ -5,6 +5,7 @@ -/ module +import Strata.Backends.CBMC.GOTO.CoreCFGToGOTOPipeline import Strata.Backends.CBMC.GOTO.CoreToCProverGOTO import Strata.Backends.CBMC.GOTO.CoreToGOTOPipeline import Strata.Backends.CBMC.GOTO.DefaultSymbols diff --git a/Strata/Backends/CBMC/GOTO/CoreCFGToGOTOPipeline.lean b/Strata/Backends/CBMC/GOTO/CoreCFGToGOTOPipeline.lean new file mode 100644 index 0000000000..889210f62d --- /dev/null +++ b/Strata/Backends/CBMC/GOTO/CoreCFGToGOTOPipeline.lean @@ -0,0 +1,304 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.Backends.CBMC.CollectSymbols +public import Strata.Backends.CBMC.GOTO.CoreToCProverGOTO +import Strata.Backends.CBMC.GOTO.CoreToGOTOPipeline +import Strata.Transform.StructuredToUnstructured + +/-! ## Core-to-GOTO translation via CFG + +Alternative pipeline that translates Core procedures to CProver GOTO by going +through the CFG representation: + +- **Structured body** → `stmtsToCFG` → `coreCFGToGotoTransform` +- **CFG body** → `coreCFGToGotoTransform` + +This coexists with the direct path in `CoreToGOTOPipeline.lean`. +-/ + +namespace Strata + +public section + +/-! ### Rename helpers for Core commands (CmdExt) -/ + +private def renameCoreCallArg + (rn : Std.HashMap String String) + : Core.CallArg Core.Expression → Core.CallArg Core.Expression + | .inArg e => .inArg (renameExpr rn e) + | .inoutArg id => .inoutArg (renameIdent rn id) + | .outArg id => .outArg (renameIdent rn id) + +private def renameCoreCommand + (rn : Std.HashMap String String) + : Core.Command → Core.Command + | .cmd c => .cmd (renameCmd rn c) + | .call procName callArgs md => + .call procName (callArgs.map (renameCoreCallArg rn)) md + +private partial def renameCoreStmt + (rn : Std.HashMap String String) + : Core.Statement → Core.Statement + | .cmd c => .cmd (renameCoreCommand rn c) + | .block l stmts md => + .block l (stmts.map (renameCoreStmt rn)) md + | .ite c t e md => + .ite (c.map (renameExpr rn)) (t.map (renameCoreStmt rn)) (e.map (renameCoreStmt rn)) md + | .loop g m i body md => + .loop (g.map (renameExpr rn)) (m.map (renameExpr rn)) + (i.map (fun (l, e) => (l, renameExpr rn e))) + (body.map (renameCoreStmt rn)) md + | .exit l md => .exit l md + | .funcDecl d md => .funcDecl d md + | .typeDecl tc md => .typeDecl tc md + +private def renameCoreDetCFG + (rn : Std.HashMap String String) + (cfg : Core.DetCFG) : Core.DetCFG := + { cfg with blocks := cfg.blocks.map fun (label, block) => + (label, { cmds := block.cmds.map (renameCoreCommand rn), + transfer := match block.transfer with + | .condGoto cond lt lf md => + .condGoto (renameExpr rn cond) lt lf md + | .finish md => .finish md }) } + +/-! ### Core-specific CFG-to-GOTO translation -/ + +/-- +Translate a Core `DetCFG` to CProver GOTO instructions. + +Like `detCFGToGotoTransform` but handles `Core.Command` (which includes +`CmdExt.call`). The CFG should already have identifiers renamed via +`renameCoreDetCFG`. +-/ +def coreCFGToGotoTransform + (_Env : Core.Expression.TyEnv) (functionName : String) + (cfg : Core.DetCFG) + (trans : Imperative.GotoTransform Core.Expression.TyEnv) + : Except Std.Format (Imperative.GotoTransform Core.Expression.TyEnv) := do + let toExpr := Lambda.LExpr.toGotoExprCtx + (TBase := ⟨Core.ExpressionMetadata, Unit⟩) [] + -- Verify entry block is first + match cfg.blocks with + | (firstLabel, _) :: _ => + if firstLabel != cfg.entry then + throw f!"[coreCFGToGotoTransform] Entry label '{cfg.entry}' does not match \ + first block label '{firstLabel}'." + | [] => pure () + let mut trans := trans + let mut pendingPatches : Array (Nat × String) := #[] + let mut labelMap : Std.HashMap String Nat := {} + let mut loopContracts : Std.HashMap String (Imperative.MetaData Core.Expression) := {} + for (label, block) in cfg.blocks do + labelMap := labelMap.insert label trans.nextLoc + let srcLoc : CProverGOTO.SourceLocation := + { CProverGOTO.SourceLocation.nil with function := functionName } + trans := Imperative.emitLabel label srcLoc trans + -- Translate each command + for cmd in block.cmds do + match cmd with + | .cmd c => + trans ← Imperative.Cmd.toGotoInstructions trans.T functionName c trans + | .call procName callArgs _md => + let lhs := Core.CallArg.getLhs callArgs + let args := Core.CallArg.getInputExprs callArgs + let argExprs ← args.mapM toExpr + let lhsExpr := match lhs with + | id :: _ => + let name := Core.CoreIdent.toPretty id + let ty := match trans.T.context.types.find? id with + | some lty => + match lty.toMonoTypeUnsafe.toGotoType with + | .ok gty => gty + | .error _ => + dbg_trace s!"warning: type conversion failed for {name}, defaulting to Integer" + .Integer + | none => + dbg_trace s!"warning: no type found for {name}, defaulting to Integer" + .Integer + CProverGOTO.Expr.symbol name ty + | [] => CProverGOTO.Expr.symbol "" .Empty + let calleeExpr := CProverGOTO.Expr.symbol procName + (CProverGOTO.Ty.mkCode (argExprs.map (·.type)) lhsExpr.type) + let callCode := CProverGOTO.Code.functionCall lhsExpr calleeExpr argExprs + let inst : CProverGOTO.Instruction := + { type := .FUNCTION_CALL, code := callCode, locationNum := trans.nextLoc } + trans := { trans with + instructions := trans.instructions.push inst + nextLoc := trans.nextLoc + 1 } + -- Translate the transfer command + match block.transfer with + | .condGoto cond lt lf md => + let transferSrcLoc := Imperative.metadataToSourceLoc md functionName trans.sourceText + let cond_expr ← toExpr cond + let hasLoopContract := md.any fun elem => + elem.fld == Imperative.MetaData.specLoopInvariant || + elem.fld == Imperative.MetaData.specDecreases + if hasLoopContract then + loopContracts := loopContracts.insert label md + let (trans', falseIdx) := + Imperative.emitCondGoto (CProverGOTO.Expr.not cond_expr) transferSrcLoc trans + trans := trans' + pendingPatches := pendingPatches.push (falseIdx, lf) + let (trans', trueIdx) := Imperative.emitUncondGoto transferSrcLoc trans + trans := trans' + pendingPatches := pendingPatches.push (trueIdx, lt) + | .finish _md => + pure () + -- Second pass: resolve labels and annotate backward-edge GOTOs with loop contracts + let mut resolvedPatches : List (Nat × Nat) := [] + for (idx, label) in pendingPatches do + match labelMap[label]? with + | some targetLoc => + resolvedPatches := (idx, targetLoc) :: resolvedPatches + if let some md := loopContracts[label]? then + let instLoc := trans.instructions[idx]!.locationNum + if targetLoc ≤ instLoc then + let mut guard := trans.instructions[idx]!.guard + for elem in md do + if elem.fld == Imperative.MetaData.specLoopInvariant then + if let .expr e := elem.value then + let gotoExpr ← toExpr e + guard := guard.setNamedField "#spec_loop_invariant" gotoExpr + if elem.fld == Imperative.MetaData.specDecreases then + if let .expr e := elem.value then + let gotoExpr ← toExpr e + guard := guard.setNamedField "#spec_decreases" gotoExpr + trans := { trans with + instructions := trans.instructions.set! idx + { trans.instructions[idx]! with guard := guard } } + | none => + throw f!"[coreCFGToGotoTransform] Unresolved label '{label}' referenced \ + by GOTO at instruction index {idx}." + return Imperative.patchGotoTargets trans resolvedPatches + +/-! ### Pipeline wrapper -/ + +/-- +Translate a Core procedure to CProver GOTO via the CFG representation. + +Mirrors `procedureToGotoCtx` but routes through `stmtsToCFG` + +`coreCFGToGotoTransform` instead of the direct Stmt-to-GOTO path. +-/ +def procedureToGotoCtxViaCFG + (Env : Core.Expression.TyEnv) (p : Core.Procedure) + (sourceText : Option String := none) + (axioms : List Core.Axiom := []) + (distincts : + List (Core.Expression.Ident × List Core.Expression.Expr) := []) + : Except Std.Format + (CoreToGOTO.CProverGOTO.Context × List Core.Function) := do + let pname := Core.CoreIdent.toPretty p.header.name + if !p.header.typeArgs.isEmpty then + .error f!"[procedureToGotoCtxViaCFG] Polymorphic procedures unsupported." + let ret_ty := CProverGOTO.Ty.Empty + let formals := p.header.inputs.keys.map Core.CoreIdent.toPretty + let formals_tys ← p.header.inputs.values.mapM Lambda.LMonoTy.toGotoType + let new_formals := formals.map (CProverGOTO.mkFormalSymbol pname ·) + let formals_tys : Map String CProverGOTO.Ty := formals.zip formals_tys + let outputs := p.header.outputs.keys.map Core.CoreIdent.toPretty + let new_outputs := outputs.map (CProverGOTO.mkLocalSymbol pname ·) + let locals_from_body := match p.body with + | .structured ss => (Imperative.Block.definedVars ss).map Core.CoreIdent.toPretty + | .cfg c => c.blocks.flatMap (fun (_, blk) => + blk.cmds.flatMap Core.Command.definedVars) + |>.map Core.CoreIdent.toPretty + let new_locals := locals_from_body.map (CProverGOTO.mkLocalSymbol pname ·) + let rn : Std.HashMap String String := + (formals.zip new_formals ++ outputs.zip new_outputs ++ locals_from_body.zip new_locals).foldl + (init := {}) fun m (k, v) => m.insert k v + -- Seed the type environment with renamed input and output parameter types + let inputEntries : Map Core.Expression.Ident Core.Expression.Ty := + (new_formals.zip p.header.inputs.values).map fun (n, ty) => + (((n : Core.CoreIdent)), .forAll [] ty) + let outputEntries : Map Core.Expression.Ident Core.Expression.Ty := + (new_outputs.zip p.header.outputs.values).map fun (n, ty) => + (((n : Core.CoreIdent)), .forAll [] ty) + let Env' : Core.Expression.TyEnv := + Lambda.TEnv.addInNewestContext (T := ⟨Core.ExpressionMetadata, Unit⟩) + Env (inputEntries ++ outputEntries) + -- Emit axioms as ASSUME instructions + let mut axiomInsts : Array CProverGOTO.Instruction := #[] + let mut axiomLoc : Nat := 0 + for ax in axioms do + let gotoExpr ← Lambda.LExpr.toGotoExprCtx + (TBase := ⟨Core.ExpressionMetadata, Unit⟩) [] ax.e + if gotoExpr.hasUnsupportedQuantifierTypes then continue + axiomInsts := axiomInsts.push + { type := .ASSUME, locationNum := axiomLoc, + guard := gotoExpr, + sourceLoc := { CProverGOTO.SourceLocation.nil with + function := pname, comment := s!"axiom {ax.name}" } } + axiomLoc := axiomLoc + 1 + -- Emit distinct declarations as pairwise != ASSUME instructions + for (dname, exprs) in distincts do + let gotoExprs ← exprs.mapM + (Lambda.LExpr.toGotoExprCtx (TBase := ⟨Core.ExpressionMetadata, Unit⟩) []) + for i in List.range gotoExprs.length do + for j in List.range gotoExprs.length do + if i < j then + let ei := gotoExprs[i]! + let ej := gotoExprs[j]! + let neqExpr : CProverGOTO.Expr := + { id := .binary .NotEqual, type := .Boolean, operands := [ei, ej] } + let srcLoc : CProverGOTO.SourceLocation := + { CProverGOTO.SourceLocation.nil with + function := pname + comment := s!"distinct {Core.CoreIdent.toPretty dname}" } + axiomInsts := axiomInsts.push + { type := .ASSUME, locationNum := axiomLoc, guard := neqExpr, sourceLoc := srcLoc } + axiomLoc := axiomLoc + 1 + -- Build the CFG (from structured body or use existing CFG) + let (cfg, liftedFuncs) ← match p.body with + | .structured ss => do + let (liftedFuncs, body) ← collectFuncDecls ss + let renamedBody := body.map (renameCoreStmt rn) + let cfg := Imperative.stmtsToCFG renamedBody + pure (cfg, liftedFuncs) + | .cfg c => do + let cfg := renameCoreDetCFG rn c + pure (cfg, []) + -- Translate CFG to GOTO + let ans ← coreCFGToGotoTransform Env' pname cfg + { instructions := axiomInsts, nextLoc := axiomLoc, T := Env', sourceText := sourceText } + let ending_insts : Array CProverGOTO.Instruction := + #[{ type := .END_FUNCTION, locationNum := ans.nextLoc + 1 }] + let pgm := { name := pname, + parameterIdentifiers := new_formals.toArray, + instructions := ans.instructions ++ ending_insts } + -- Translate procedure contracts + let mut contracts : List (String × Lean.Json) := [] + let preExprs := p.spec.preconditions.values.filter (fun c => c.attr == .Default) + |>.map (fun c => renameExpr rn c.expr) + let postExprs := p.spec.postconditions.values.filter (fun c => c.attr == .Default) + |>.map (fun c => renameExpr rn c.expr) + let toGotoExpr := Lambda.LExpr.toGotoExprCtx + (TBase := ⟨Core.ExpressionMetadata, Unit⟩) [] + if !preExprs.isEmpty then + let preGoto ← preExprs.mapM toGotoExpr + let preJson ← (preGoto.mapM CProverGOTO.exprToJson).mapError (fun e => f!"{e}") + contracts := contracts ++ [("#spec_requires", + Lean.Json.mkObj [("id", ""), ("sub", Lean.Json.arr preJson.toArray)])] + if !postExprs.isEmpty then + let postGoto ← postExprs.mapM toGotoExpr + let postJson ← (postGoto.mapM CProverGOTO.exprToJson).mapError (fun e => f!"{e}") + contracts := contracts ++ [("#spec_ensures", + Lean.Json.mkObj [("id", ""), ("sub", Lean.Json.arr postJson.toArray)])] + -- Build localTypes map for output parameters + let output_tys ← p.header.outputs.values.mapM Lambda.LMonoTy.toGotoType + let localTypes : Std.HashMap String CProverGOTO.Ty := + (outputs.zip output_tys).foldl (init := {}) fun m (k, v) => m.insert k v + let ctx : CoreToGOTO.CProverGOTO.Context := + { program := pgm, formals := formals_tys, ret := ret_ty, + locals := outputs ++ locals_from_body, contracts := contracts, + localTypes := localTypes } + return (ctx, liftedFuncs) + +end -- public section + +end Strata diff --git a/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean b/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean index 5c03e8727e..08cc27ec17 100644 --- a/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean +++ b/Strata/Backends/CBMC/GOTO/CoreToGOTOPipeline.lean @@ -40,12 +40,12 @@ namespace Strata public section -private def renameIdent (rn : Std.HashMap String String) (id : Core.CoreIdent) : Core.CoreIdent := +def renameIdent (rn : Std.HashMap String String) (id : Core.CoreIdent) : Core.CoreIdent := match rn[id.name]? with | some new => ⟨new, id.metadata⟩ | none => id -private partial def renameExpr +partial def renameExpr (rn : Std.HashMap String String) : Core.Expression.Expr → Core.Expression.Expr | .fvar m name ty => .fvar m (renameIdent rn name) ty @@ -56,7 +56,7 @@ private partial def renameExpr | .eq m e1 e2 => .eq m (renameExpr rn e1) (renameExpr rn e2) | e => e -private def renameCmd +def renameCmd (rn : Std.HashMap String String) : Imperative.Cmd Core.Expression → Imperative.Cmd Core.Expression | .init name ty e md => .init (renameIdent rn name) ty (e.map (renameExpr rn)) md @@ -102,7 +102,7 @@ private def hasCallStmt : List Core.Statement → Bool Collect all funcDecl statements from a procedure body (recursively) and return them as Core.Functions, stripping them from the body. -/ -private def collectFuncDecls : List Core.Statement → +def collectFuncDecls : List Core.Statement → Except Std.Format (List Core.Function × List Core.Statement) | [] => return ([], []) | .funcDecl decl _ :: rest => do diff --git a/Strata/DL/Imperative/CFGToCProverGOTO.lean b/Strata/DL/Imperative/CFGToCProverGOTO.lean index 4faeb5f1db..8b3ad750bf 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,64 @@ 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 + -- 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/StrataTest/Backends/CBMC/GOTO/E2E_CFGPipeline.lean b/StrataTest/Backends/CBMC/GOTO/E2E_CFGPipeline.lean new file mode 100644 index 0000000000..93f540876b --- /dev/null +++ b/StrataTest/Backends/CBMC/GOTO/E2E_CFGPipeline.lean @@ -0,0 +1,296 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +import Strata.Backends.CBMC.CollectSymbols +import Strata.Backends.CBMC.GOTO.CoreCFGToGOTOPipeline +import Strata.Backends.CBMC.GOTO.CoreToGOTOPipeline + +/-! ## Equivalence tests: direct path vs. CFG path + +Run both `procedureToGotoCtx` (direct) and `procedureToGotoCtxViaCFG` (CFG) +on the same programs and compare outputs. + +The CFG path produces additional GOTO instructions for explicit block-to-block +transfers that the direct path handles implicitly via fall-through. Comparisons +therefore focus on **semantic** instructions (DECL, ASSIGN, ASSERT, ASSUME, +FUNCTION_CALL, END_FUNCTION) and contract annotations, ignoring cosmetic GOTO +and LOCATION differences. +-/ + +open Strata + +private def translateCore (p : Strata.Program) : Core.Program := + (TransM.run Inhabited.default (translateProgram p)).fst + +/-! ### Instruction-level comparison helpers -/ + +private def isSemanticInst (inst : CProverGOTO.Instruction) : Bool := + match inst.type with + | .DECL | .ASSIGN | .ASSERT | .ASSUME | .FUNCTION_CALL + | .SET_RETURN_VALUE | .END_FUNCTION => true + | _ => false + +private def compareSemanticInstructions + (directInsts cfgInsts : Array CProverGOTO.Instruction) + : Except String Unit := do + let dSemantic := directInsts.filter isSemanticInst + let cSemantic := cfgInsts.filter isSemanticInst + if dSemantic.size != cSemantic.size then + throw s!"Semantic instruction count mismatch: direct={dSemantic.size} cfg={cSemantic.size}" + for i in List.range dSemantic.size do + if dSemantic[i]!.type != cSemantic[i]!.type then + throw s!"Semantic instruction type mismatch at index {i}: \ + direct={dSemantic[i]!.type} cfg={cSemantic[i]!.type}" + return () + +/-! ### Pipeline runners -/ + +private def runDirectPipeline (cprog : Core.Program) (procName : String := "main") + : Except Std.Format (CoreToGOTO.CProverGOTO.Context × List Core.Function) := do + let Env := Lambda.TEnv.default + let procs := cprog.decls.filterMap fun d => d.getProc? + let axioms := cprog.decls.filterMap fun d => d.getAxiom? + let distincts := cprog.decls.filterMap fun d => match d with + | .distinct name es _ => some (name, es) | _ => none + let some proc := procs.find? (fun p => Core.CoreIdent.toPretty p.header.name == procName) + | .error f!"procedure {procName} not found" + procedureToGotoCtx Env proc (axioms := axioms) (distincts := distincts) + +private def runCFGPipeline (cprog : Core.Program) (procName : String := "main") + : Except Std.Format (CoreToGOTO.CProverGOTO.Context × List Core.Function) := do + let Env := Lambda.TEnv.default + let procs := cprog.decls.filterMap fun d => d.getProc? + let axioms := cprog.decls.filterMap fun d => d.getAxiom? + let distincts := cprog.decls.filterMap fun d => match d with + | .distinct name es _ => some (name, es) | _ => none + let some proc := procs.find? (fun p => Core.CoreIdent.toPretty p.header.name == procName) + | .error f!"procedure {procName} not found" + procedureToGotoCtxViaCFG Env proc (axioms := axioms) (distincts := distincts) + +private def toJson (ctx : CoreToGOTO.CProverGOTO.Context) (pname : String) + : Except Std.Format (Lean.Json × Lean.Json) := do + let json ← (CoreToGOTO.CProverGOTO.Context.toJson pname ctx).mapError (fun e => f!"{e}") + return (json.symtab, json.goto) + +/-- Run both pipelines and compare semantic instructions + contracts + JSON validity. -/ +private def testEquivalence (prog : Strata.Program) (procName : String := "main") + : IO Unit := do + let cprog := translateCore prog + let directResult := runDirectPipeline cprog procName + let cfgResult := runCFGPipeline cprog procName + match directResult, cfgResult with + | .error e, _ => IO.throwServerError s!"Direct pipeline failed: {e}" + | _, .error e => IO.throwServerError s!"CFG pipeline failed: {e}" + | .ok (dctx, _), .ok (cctx, _) => + -- Instruction-level: compare semantic instructions (ignoring GOTO/LOCATION) + match compareSemanticInstructions dctx.program.instructions cctx.program.instructions with + | .error e => IO.throwServerError s!"Instruction mismatch: {e}" + | .ok () => pure () + -- Contract annotations must match + if dctx.contracts.length != cctx.contracts.length then + IO.throwServerError s!"Contract count mismatch: direct={dctx.contracts.length} cfg={cctx.contracts.length}" + for (dk, dv) in dctx.contracts do + match cctx.contracts.find? (·.1 == dk) with + | some (_, cv) => + if dv != cv then + IO.throwServerError s!"Contract value mismatch for {dk}" + | none => + IO.throwServerError s!"Contract key {dk} missing from CFG path" + -- JSON-level: both produce valid, non-null output + let pname := "main" + match toJson dctx pname, toJson cctx pname with + | .error e, _ => IO.throwServerError s!"Direct JSON failed: {e}" + | _, .error e => IO.throwServerError s!"CFG JSON failed: {e}" + | .ok (dSym, dGoto), .ok (cSym, cGoto) => + assert! dSym != Lean.Json.null + assert! cSym != Lean.Json.null + assert! dGoto != Lean.Json.null + assert! cGoto != Lean.Json.null + +------------------------------------------------------------------------------- + +-- Test 1: Simple assert +def CFGEq_SimpleAssert := +#strata +program Core; +procedure main(x : int) { + assert (x > 0); +}; +#end + +#eval testEquivalence CFGEq_SimpleAssert + +------------------------------------------------------------------------------- + +-- Test 2: Variable declaration and assignment +def CFGEq_VarDeclAssign := +#strata +program Core; +procedure main(x : int) { + var z : int := x + 1; + assert (z > 0); +}; +#end + +#eval testEquivalence CFGEq_VarDeclAssign + +------------------------------------------------------------------------------- + +-- Test 3: If-then-else +def CFGEq_IfThenElse := +#strata +program Core; +procedure main(x : int) { + var r : int; + if (x > 0) { + r := 1; + } else { + r := 0; + } + assert (r >= 0); +}; +#end + +#eval testEquivalence CFGEq_IfThenElse + +------------------------------------------------------------------------------- + +-- Test 4: Preconditions and postconditions +def CFGEq_Contracts := +#strata +program Core; +procedure main(x : int) +spec { + requires (x > 0); + ensures (x >= 0); +} { + assert (x > 0); +}; +#end + +#eval testEquivalence CFGEq_Contracts + +------------------------------------------------------------------------------- + +-- Test 5: Axioms and distinct declarations +def CFGEq_AxiomDistinct := +#strata +program Core; +const a : int; +const b : int; +axiom [ax1]: (a > 0); +distinct [ab]: [a, b]; +procedure main() { + assert (a != b); +}; +#end + +#eval testEquivalence CFGEq_AxiomDistinct + +------------------------------------------------------------------------------- + +-- Test 6: Free specs are skipped (same in both paths) +def CFGEq_FreeSpecs := +#strata +program Core; +procedure main(x : int) +spec { + free requires (x > 10); + requires (x >= 0); + free ensures (x > 5); + ensures (x >= 0); +} { + assert (x >= 0); +}; +#end + +#eval testEquivalence CFGEq_FreeSpecs + +------------------------------------------------------------------------------- + +-- Test 7: Cover command +def CFGEq_Cover := +#strata +program Core; +procedure main(x : int) { + cover (x > 0); +}; +#end + +#eval testEquivalence CFGEq_Cover + +------------------------------------------------------------------------------- + +-- Test 8: Bitvector operations +def CFGEq_BVOps := +#strata +program Core; +procedure main(x : bv32, y : bv32) { + var z : bv32 := x + y; + assert (z > bv{32}(0)); +}; +#end + +#eval testEquivalence CFGEq_BVOps + +------------------------------------------------------------------------------- + +-- Test 9: Assume command +def CFGEq_Assume := +#strata +program Core; +procedure main(x : int) { + assume (x > 0); + assert (x > 0); +}; +#end + +#eval testEquivalence CFGEq_Assume + +------------------------------------------------------------------------------- + +-- Test 10: Multiple sequential commands +def CFGEq_MultipleCommands := +#strata +program Core; +procedure main(x : int) { + var a : int := x + 1; + var b : int := a + 2; + assert (b > x); +}; +#end + +#eval testEquivalence CFGEq_MultipleCommands + +------------------------------------------------------------------------------- + +-- Test 11: CFG path only — verify the CFG-only pipeline produces valid output +-- (no direct path comparison since .cfg bodies aren't supported by the direct path) +#eval do + let prog := + #strata + program Core; + procedure main(x : int) { + var r : int; + if (x > 0) { + r := 1; + } else { + r := 0; + } + assert (r >= 0); + }; + #end + let cprog := translateCore prog + match runCFGPipeline cprog with + | .error e => IO.throwServerError s!"CFG pipeline failed: {e}" + | .ok (ctx, _) => + match toJson ctx "main" with + | .error e => IO.throwServerError s!"JSON failed: {e}" + | .ok (symtab, goto) => + assert! symtab != Lean.Json.null + assert! goto != Lean.Json.null + let gotoStr := goto.pretty + assert! (gotoStr.splitOn "GOTO").length > 1 + assert! (gotoStr.splitOn "ASSERT").length > 1 From 891d1c4b579e82b75b1b838bd8cf4b27268c03d3 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 14 May 2026 12:05:48 -0700 Subject: [PATCH 54/57] fix comments --- .../Core/DDMTransform/FormatCore.lean | 77 ++++++++++-------- Strata/Transform/ProcedureInlining.lean | 3 +- .../Languages/Core/Tests/CFGParseTests.lean | 81 ++++++------------- 3 files changed, 69 insertions(+), 92 deletions(-) diff --git a/Strata/Languages/Core/DDMTransform/FormatCore.lean b/Strata/Languages/Core/DDMTransform/FormatCore.lean index bb40e9729f..7856641f5c 100644 --- a/Strata/Languages/Core/DDMTransform/FormatCore.lean +++ b/Strata/Languages/Core/DDMTransform/FormatCore.lean @@ -869,43 +869,48 @@ partial def invariantsToCST {M} [Inhabited M] let restCST ← invariantsToCST rest pure (.consInvariants default labelAnn exprCST restCST) -/-- Convert a `DetTransferCmd` to a CST statement (if-then-else for condGoto, skip for finish). -/ +/-- Convert a `DetTransferCmd` to its CFG-specific CST `Transfer` node. -/ partial def transferToCST {M} [Inhabited M] - (t : Imperative.DetTransferCmd String Expression) : ToCSTM M (Option (CoreDDM.Statement M)) := do + (t : Imperative.DetTransferCmd String Expression) : ToCSTM M (CoreDDM.Transfer M) := do match t with - | .condGoto cond lt lf _ => do - let condCST ← lexprToExpr cond 0 - let gotoTrue : CoreDDM.Statement M := .exit_statement default ⟨default, lt⟩ - let gotoFalse : CoreDDM.Statement M := .exit_statement default ⟨default, lf⟩ - let thenBlock : CoreDDM.Block M := .block default ⟨default, #[gotoTrue]⟩ - let elseBlock : Else M := .else1 default (.block default ⟨default, #[gotoFalse]⟩) - pure (some (.if_statement default (.condDet default condCST) thenBlock elseBlock)) - | .finish _ => pure none - -/-- Convert a single `DetBlock` to a CST block (commands + transfer). -/ + | .condGoto cond lt lf _ => + if lt == lf then + pure (.transfer_goto default ⟨default, lt⟩) + else + match cond with + | .fvar _ id _ => + if id.name.startsWith "$__nondet_" then + pure (.transfer_nondet_goto default ⟨default, lt⟩ ⟨default, lf⟩) + else + let condCST ← lexprToExpr cond 0 + pure (.transfer_cond_goto default condCST ⟨default, lt⟩ ⟨default, lf⟩) + | _ => + let condCST ← lexprToExpr cond 0 + pure (.transfer_cond_goto default condCST ⟨default, lt⟩ ⟨default, lf⟩) + | .finish _ => pure (.transfer_return default) + +/-- Convert a single `DetBlock` to a CST `CFGBlock`. -/ partial def detBlockToCST {M} [Inhabited M] - (blk : Imperative.DetBlock String Core.Command Expression) - : ToCSTM M (CoreDDM.Block M) := do + (label : String) (blk : Imperative.DetBlock String Core.Command Expression) + : ToCSTM M (CoreDDM.CFGBlock M) := do modify ToCSTContext.pushScope let cmdStmts ← blk.cmds.toArray.mapM (stmtToCST ∘ Imperative.Stmt.cmd) - let transferStmt ← transferToCST blk.transfer - let allStmts := match transferStmt with - | some s => cmdStmts.push s - | none => cmdStmts + let transfer ← transferToCST blk.transfer modify ToCSTContext.popScope - pure (.block default ⟨default, allStmts⟩) + pure (.cfg_block default ⟨default, label⟩ ⟨default, cmdStmts⟩ transfer) -/-- Convert a `DetCFG` to a CST block (sequence of labeled blocks). -/ +/-- Convert a `DetCFG` to a CST `CFGBody`. -/ partial def detCFGToCST {M} [Inhabited M] (cfg : Core.DetCFG) - : ToCSTM M (CoreDDM.Block M) := do - modify ToCSTContext.pushScope - let mut stmts : Array (CoreDDM.Statement M) := #[] - for (label, blk) in cfg.blocks do - let labelAnn : Ann String M := ⟨default, label⟩ - let blockCST ← detBlockToCST blk - stmts := stmts.push (.block_statement default labelAnn blockCST) - modify ToCSTContext.popScope - pure (.block default ⟨default, stmts⟩) + : ToCSTM M (CoreDDM.CFGBody M) := do + let cfgBlocks ← cfg.blocks.mapM fun (label, blk) => detBlockToCST label blk + let blocks := cfgBlocks.foldr (init := none) fun blk acc => + match acc with + | none => some (.cfg_blocks_one default blk) + | some rest => some (.cfg_blocks_cons default blk rest) + match blocks with + | some bs => pure (.cfg_body default ⟨default, cfg.entry⟩ bs) + | none => pure (.cfg_body default ⟨default, cfg.entry⟩ + (.cfg_blocks_one default (.cfg_block default ⟨default, cfg.entry⟩ ⟨default, #[]⟩ (.transfer_return default)))) partial def measureToCST {M} [Inhabited M] (measure : Option (Lambda.LExpr CoreLParams.mono)) : @@ -976,12 +981,16 @@ def procToCST {M} [Inhabited M] (proc : Core.Procedure) : ToCSTM M (Command M) : ⟨default, none⟩ else ⟨default, some (Spec.spec_mk default specAnn)⟩ - let bodyCST ← match proc.body with - | .structured ss => blockToCST ss - | .cfg c => detCFGToCST c - let body : Ann (Option (CoreDDM.Block M)) M := ⟨default, some bodyCST⟩ + let cmd ← match proc.body with + | .structured ss => + let bodyCST ← blockToCST ss + let body : Ann (Option (CoreDDM.Block M)) M := ⟨default, some bodyCST⟩ + pure (.command_procedure default name typeArgs arguments spec body) + | .cfg c => + let cfgBody ← detCFGToCST c + pure (.command_cfg_procedure default name typeArgs arguments spec cfgBody) modify ToCSTContext.popScope - pure (.command_procedure default name typeArgs arguments spec body) + pure cmd -- Recreate enough of `GlobalContext` from `ToCSTContext` obtained from -- `programToCST`, purely for formatting. diff --git a/Strata/Transform/ProcedureInlining.lean b/Strata/Transform/ProcedureInlining.lean index adddd674b0..a0360a0f3c 100644 --- a/Strata/Transform/ProcedureInlining.lean +++ b/Strata/Transform/ProcedureInlining.lean @@ -281,7 +281,8 @@ def inlineCallCmd -- CFG-level inlining is a separate, more complex pass that operates -- entirely in the CFG domain (graph splicing). let procBodyStmts ← match proc.body with - | .cfg _ => return .none + | .cfg _ => throw (Strata.DiagnosticModel.fromMessage + "cannot inline procedure with CFG body into structured code") | .structured ss => pure ss let stmts:List (Imperative.Stmt Core.Expression Core.Command) diff --git a/StrataTest/Languages/Core/Tests/CFGParseTests.lean b/StrataTest/Languages/Core/Tests/CFGParseTests.lean index 23be9d534f..263040833f 100644 --- a/StrataTest/Languages/Core/Tests/CFGParseTests.lean +++ b/StrataTest/Languages/Core/Tests/CFGParseTests.lean @@ -22,15 +22,31 @@ private def parseCoreText (input : String) : IO Core.Program := do | .ok program => pure program | .error msg => throw (IO.userError msg) +private def printCFGProcInfo (prog : Core.Program) : IO Unit := do + for d in prog.decls do + match d with + | .proc p _ => + IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" + match p.body with + | .cfg c => + IO.println s!" CFG entry: {c.entry}, {c.blocks.length} blocks" + for (lbl, blk) in c.blocks do + let transferDesc := match blk.transfer with + | .condGoto _ l1 l2 _ => if l1 == l2 then s!"goto {l1}" else s!"branch → {l1}/{l2}" + | .finish _ => "return" + IO.println s!" Block '{lbl}': {blk.cmds.length} cmds, {transferDesc}" + | .structured _ => IO.println " ERROR: expected CFG body" + | _ => pure () + /-! ## Deterministic CFG with conditional branch -/ /-- info: Procedure: Max CFG entry: entry, 4 blocks - Block 'entry': 0 cmds - Block 'then_branch': 1 cmds - Block 'else_branch': 1 cmds - Block 'done': 0 cmds + Block 'entry': 0 cmds, branch → then_branch/else_branch + Block 'then_branch': 1 cmds, goto done + Block 'else_branch': 1 cmds, goto done + Block 'done': 0 cmds, return -/ #guard_msgs in #eval do @@ -57,17 +73,7 @@ cfg entry { } }; " - for d in prog.decls do - match d with - | .proc p _ => - IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" - match p.body with - | .cfg c => - IO.println s!" CFG entry: {c.entry}, {c.blocks.length} blocks" - for (lbl, blk) in c.blocks do - IO.println s!" Block '{lbl}': {blk.cmds.length} cmds" - | .structured _ => IO.println " ERROR: expected CFG body" - | _ => pure () + printCFGProcInfo prog /-! ## Nondeterministic CFG with multi-target goto -/ @@ -100,20 +106,7 @@ cfg entry { } }; " - for d in prog.decls do - match d with - | .proc p _ => - IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" - match p.body with - | .cfg c => - IO.println s!" CFG entry: {c.entry}, {c.blocks.length} blocks" - for (lbl, blk) in c.blocks do - let transferDesc := match blk.transfer with - | .condGoto _ l1 l2 _ => if l1 == l2 then s!"goto {l1}" else s!"branch → {l1}/{l2}" - | .finish _ => "return" - IO.println s!" Block '{lbl}': {blk.cmds.length} cmds, {transferDesc}" - | .structured _ => IO.println " ERROR: expected CFG body" - | _ => pure () + printCFGProcInfo prog /-! ## CFG loop pattern -/ @@ -149,20 +142,7 @@ cfg entry { } }; " - for d in prog.decls do - match d with - | .proc p _ => - IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" - match p.body with - | .cfg c => - IO.println s!" CFG entry: {c.entry}, {c.blocks.length} blocks" - for (lbl, blk) in c.blocks do - let transferDesc := match blk.transfer with - | .condGoto _ l1 l2 _ => if l1 == l2 then s!"goto {l1}" else s!"branch → {l1}/{l2}" - | .finish _ => "return" - IO.println s!" Block '{lbl}': {blk.cmds.length} cmds, {transferDesc}" - | .structured _ => IO.println " ERROR: expected CFG body" - | _ => pure () + printCFGProcInfo prog /-! ## Empty block (just a transfer) -/ @@ -181,20 +161,7 @@ cfg start { } }; " - for d in prog.decls do - match d with - | .proc p _ => - IO.println s!"Procedure: {Core.CoreIdent.toPretty p.header.name}" - match p.body with - | .cfg c => - IO.println s!" CFG entry: {c.entry}, {c.blocks.length} blocks" - for (lbl, blk) in c.blocks do - let transferDesc := match blk.transfer with - | .condGoto _ l1 l2 _ => if l1 == l2 then s!"goto {l1}" else s!"branch → {l1}/{l2}" - | .finish _ => "return" - IO.println s!" Block '{lbl}': {blk.cmds.length} cmds, {transferDesc}" - | .structured _ => IO.println " ERROR: expected CFG body" - | _ => pure () + printCFGProcInfo prog /-! ## End-to-end: type-checking accepts well-formed CFG procedures -/ From 86e4600073f90884ddab2b23c38ea098c5883f50 Mon Sep 17 00:00:00 2001 From: David Deng Date: Thu, 14 May 2026 13:40:07 -0700 Subject: [PATCH 55/57] Elimiate unnecessary constructor --- Strata/Languages/Core/StatementSemantics.lean | 31 +++++++++---------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 01627fd85f..0f1a707ce6 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -288,7 +288,14 @@ inductive CoreStepStar /-- Evaluate the commands in a deterministic basic block, then transfer control based on the block's terminator. Defined mutually to satisfy - strict positivity (uses `EvalCommand` for command evaluation). -/ + strict positivity (uses `EvalCommand` for command evaluation). + + This mirrors `Imperative.EvalDetBlock` but cannot directly reuse it: + Lean's kernel rejects nested inductives whose parameters reference local + variables of the mutual block (`EvalCommand` here). Since `EvalDetBlock` + internally uses `EvalCmds` (another inductive), passing `EvalCommand` as + its `EvalCmd` parameter creates a nested inductive dependency that the + kernel disallows. -/ inductive CoreEvalDetBlock (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) : @@ -324,19 +331,8 @@ inductive CoreEvalCmds CoreEvalCmds π φ δ σ' cs σ'' failed' → CoreEvalCmds π φ δ σ (c :: cs) σ'' (failed || failed') -/-- Single step of a deterministic CFG: look up the current block by label - and evaluate it. Defined mutually for strict positivity. -/ -inductive CoreCFGStep - (π : String → Option Procedure) - (φ : CoreEval → PureFunc Expression → CoreEval) : - DetCFG → CFGConfig String Expression → - CFGConfig String Expression → Prop where - | eval_next : - List.lookup t cfg.blocks = .some b → - CoreEvalDetBlock π φ σ b config → - CoreCFGStep π φ cfg (.cont t σ failed) (updateFailure config failed) - -/-- Reflexive-transitive closure of `CoreCFGStep`. -/ +/-- Reflexive-transitive closure of CFG steps for the Core language. Each + step looks up a block by label and evaluates it via `CoreEvalDetBlock`. -/ inductive CoreCFGStepStar (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) : @@ -344,10 +340,11 @@ inductive CoreCFGStepStar CFGConfig String Expression → Prop where | refl : CoreCFGStepStar π φ cfg c c | step : - CoreCFGStep π φ cfg c₁ c₂ → - CoreCFGStepStar π φ cfg c₂ c₃ → + List.lookup t cfg.blocks = .some b → + CoreEvalDetBlock π φ σ b config → + CoreCFGStepStar π φ cfg (updateFailure config failed) c₃ → ---- - CoreCFGStepStar π φ cfg c₁ c₃ + CoreCFGStepStar π φ cfg (.cont t σ failed) c₃ /-- Execution of a procedure body: either structured (via `CoreStepStar`) or unstructured CFG (via `CoreCFGStepStar`). From 475971218ab99e2a8cebffeabd87450c73a6c36b Mon Sep 17 00:00:00 2001 From: David Deng Date: Fri, 15 May 2026 09:09:23 -0700 Subject: [PATCH 56/57] Htd/unstructured procedure experiment (#1169) Localized merge. --------- Co-authored-by: David Deng --- Strata/DL/Imperative/CFGSemantics.lean | 87 +++++++++---------- Strata/Languages/Core/StatementSemantics.lean | 55 ++---------- .../Tests/NestedInductiveRestriction.lean | 68 +++++++++++++++ 3 files changed, 117 insertions(+), 93 deletions(-) create mode 100644 StrataTest/Languages/Core/Tests/NestedInductiveRestriction.lean diff --git a/Strata/DL/Imperative/CFGSemantics.lean b/Strata/DL/Imperative/CFGSemantics.lean index f472e56d04..61bc0af1a3 100644 --- a/Strata/DL/Imperative/CFGSemantics.lean +++ b/Strata/DL/Imperative/CFGSemantics.lean @@ -23,18 +23,6 @@ This module defines small-step operational semantics for the Imperative dialect's control-flow graph representation. -/ -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 @@ -49,11 +37,24 @@ inductive CFGConfig (l : Type) (P : PureExpr): Type where /-- 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. -/ +/-- Monotonically update the `failure` flag in a `CFGConfig`. It will be set to +`true` if the provided Boolean is `true`. -/ +def updateFailure : CFGConfig l P → Bool → CFGConfig l P +| .cont t σ failed, failed' => .cont t σ (failed || failed') +| .terminal σ failed, failed' => .terminal σ (failed || failed') + +/-- Small-step operational semantics for deterministic basic blocks. Evaluates +commands sequentially, then transfers control based on the block's terminator. + +This is a single recursive inductive that combines command evaluation with +transfer semantics. The `cmd` constructor evaluates one command and recurses +on the remaining commands. The terminal constructors handle the transfer once +all commands are exhausted. + +Structuring it this way (rather than delegating to a separate `EvalCmds` +inductive) ensures that `EvalCmd` is referenced directly in a constructor, +which is required for Lean 4's kernel to accept this type as a nested +inductive in mutual blocks. -/ inductive EvalDetBlock {CmdT : Type} (P : PureExpr) @@ -62,31 +63,31 @@ inductive EvalDetBlock [HasNot P] : SemanticStore P → DetBlock l CmdT P → CFGConfig l P → Prop where - | step_goto_true : - EvalCmds P EvalCmd δ σ cs σ' failed → + | cmd : + EvalCmd δ σ c σ' failed → + EvalDetBlock P EvalCmd extendEval σ' ⟨cs, transfer⟩ config → + EvalDetBlock P EvalCmd extendEval + σ ⟨ c :: cs, transfer ⟩ (updateFailure config failed) + + | goto_true : δ σ c = .some HasBool.tt → WellFormedSemanticEvalBool δ → EvalDetBlock P EvalCmd extendEval - σ ⟨ cs, .condGoto c t e _ ⟩ (.cont t σ' failed) + σ ⟨ [], .condGoto c t e _ ⟩ (.cont t σ false) - | step_goto_false : - EvalCmds P EvalCmd δ σ cs σ' failed → + | goto_false : δ σ c = .some HasBool.ff → WellFormedSemanticEvalBool δ → EvalDetBlock P EvalCmd extendEval - σ ⟨ cs, .condGoto c t e _ ⟩ (.cont e σ' failed) + σ ⟨ [], .condGoto c t e _ ⟩ (.cont e σ false) - | step_terminal : - EvalCmds P EvalCmd δ σ cs σ' failed → + | terminal : EvalDetBlock P EvalCmd extendEval - σ ⟨ cs, .finish _ ⟩ (.terminal σ' failed) + σ ⟨ [], .finish _ ⟩ (.terminal σ false) /-- -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. +Small-step operational semantics for non-deterministic basic blocks. Evaluates +commands sequentially, then transfers control nondeterministically. -/ inductive EvalNondetBlock {CmdT : Type} @@ -96,24 +97,20 @@ inductive EvalNondetBlock [HasNot P] : SemanticStore P → NondetBlock l CmdT P → CFGConfig l P → Prop where - | step_goto_none : - EvalCmds P EvalCmd δ σ cs σ' failed → + | cmd : + EvalCmd δ σ c σ' failed → + EvalNondetBlock P EvalCmd extendEval σ' ⟨cs, transfer⟩ config → EvalNondetBlock P EvalCmd extendEval - σ ⟨ cs, .goto [] _ ⟩ (.terminal σ' failed) + σ ⟨ c :: cs, transfer ⟩ (updateFailure config failed) - | step_goto_some : - EvalCmds P EvalCmd δ σ cs σ' failed → - lt ∈ ls → + | goto_none : EvalNondetBlock P EvalCmd extendEval - σ ⟨ cs, .goto ls _ ⟩ (.cont lt σ' failed) + σ ⟨ [], .goto [] _ ⟩ (.terminal σ false) -/-- -Monotonically update the `failure` flag in a `CFGConfig`. It will be set to -`true` if the provided Boolean is `true`. --/ -def updateFailure : CFGConfig l P → Bool → CFGConfig l P -| .cont t σ failed, failed' => .cont t σ (failed || failed') -| .terminal σ failed, failed' => .terminal σ (failed || failed') + | goto_some : + lt ∈ ls → + EvalNondetBlock P EvalCmd extendEval + σ ⟨ [], .goto ls _ ⟩ (.cont lt σ false) /-- Operational semantics to step between two configurations of a control-flow diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 0f1a707ce6..8799cff4ca 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -286,53 +286,12 @@ inductive CoreStepStar ---- CoreStepStar π φ c₁ c₃ -/-- Evaluate the commands in a deterministic basic block, then transfer - control based on the block's terminator. Defined mutually to satisfy - strict positivity (uses `EvalCommand` for command evaluation). - - This mirrors `Imperative.EvalDetBlock` but cannot directly reuse it: - Lean's kernel rejects nested inductives whose parameters reference local - variables of the mutual block (`EvalCommand` here). Since `EvalDetBlock` - internally uses `EvalCmds` (another inductive), passing `EvalCommand` as - its `EvalCmd` parameter creates a nested inductive dependency that the - kernel disallows. -/ -inductive CoreEvalDetBlock - (π : String → Option Procedure) - (φ : CoreEval → PureFunc Expression → CoreEval) : - CoreStore → DetBlock String Command Expression → - CFGConfig String Expression → Prop where - | step_goto_true : - CoreEvalCmds π φ δ σ cs σ' failed → - δ σ c = .some HasBool.tt → - WellFormedSemanticEvalBool δ → - CoreEvalDetBlock π φ - σ ⟨ cs, .condGoto c t e _ ⟩ (.cont t σ' failed) - | step_goto_false : - CoreEvalCmds π φ δ σ cs σ' failed → - δ σ c = .some HasBool.ff → - WellFormedSemanticEvalBool δ → - CoreEvalDetBlock π φ - σ ⟨ cs, .condGoto c t e _ ⟩ (.cont e σ' failed) - | step_terminal : - CoreEvalCmds π φ δ σ cs σ' failed → - CoreEvalDetBlock π φ - σ ⟨ cs, .finish _ ⟩ (.terminal σ' failed) - -/-- Evaluate a list of commands sequentially. Defined mutually because - `EvalCommand` is being defined in the same block. -/ -inductive CoreEvalCmds - (π : String → Option Procedure) - (φ : CoreEval → PureFunc Expression → CoreEval) : - CoreEval → CoreStore → List Command → CoreStore → Bool → Prop where - | eval_cmds_none : - CoreEvalCmds π φ δ σ [] σ false - | eval_cmds_some : - EvalCommand π φ δ σ c σ' failed → - CoreEvalCmds π φ δ σ' cs σ'' failed' → - CoreEvalCmds π φ δ σ (c :: cs) σ'' (failed || failed') - -/-- Reflexive-transitive closure of CFG steps for the Core language. Each - step looks up a block by label and evaluates it via `CoreEvalDetBlock`. -/ +/-- Reflexive-transitive closure of CFG steps for the Core language. + Each step looks up a block by label and evaluates it using the generic + `Imperative.EvalDetBlock` instantiated with `EvalCommand`. This works + because `EvalDetBlock` has a `_enableNesting` constructor that directly + references `EvalCmd`, satisfying the Lean kernel's nested inductive + requirement. See `StrataTest/Languages/Core/Tests/NestedInductiveRestriction.lean`. -/ inductive CoreCFGStepStar (π : String → Option Procedure) (φ : CoreEval → PureFunc Expression → CoreEval) : @@ -341,7 +300,7 @@ inductive CoreCFGStepStar | refl : CoreCFGStepStar π φ cfg c c | step : List.lookup t cfg.blocks = .some b → - CoreEvalDetBlock π φ σ b config → + Imperative.EvalDetBlock Expression (EvalCommand π φ) (EvalPureFunc φ) σ b config → CoreCFGStepStar π φ cfg (updateFailure config failed) c₃ → ---- CoreCFGStepStar π φ cfg (.cont t σ failed) c₃ diff --git a/StrataTest/Languages/Core/Tests/NestedInductiveRestriction.lean b/StrataTest/Languages/Core/Tests/NestedInductiveRestriction.lean new file mode 100644 index 0000000000..ed6760400b --- /dev/null +++ b/StrataTest/Languages/Core/Tests/NestedInductiveRestriction.lean @@ -0,0 +1,68 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +/-! # Lean 4 Nested Inductive Restriction in Mutual Blocks + +This file demonstrates why `CoreEvalDetBlock` and `CoreEvalCmds` in +`StatementSemantics.lean` cannot directly reuse the generic +`Imperative.EvalDetBlock` and `Imperative.EvalCmds`. + +## The Rule + +Passing a mutual inductive (partially applied) as a parameter to an external +inductive works IF that external inductive uses the parameter **directly** in +its own constructors. It FAILS if the external inductive delegates to yet +another inductive parameterized by the same slot. + +## Application to CFG Semantics + +- `Imperative.StepStmt` uses `EvalCmd` directly → `CoreStepStar` can use + `StepStmt Expression (EvalCommand π φ)` ✓ +- `Imperative.EvalDetBlock` delegates to `Imperative.EvalCmds` (another + inductive) → cannot use `EvalDetBlock Expression (EvalCommand π φ)` ✗ + +This forces us to duplicate `EvalDetBlock`/`EvalCmds` as `CoreEvalDetBlock`/ +`CoreEvalCmds` inside the mutual block. +-/ + +-- External inductive that uses EvalCmd DIRECTLY in its own constructor +inductive DirectUse (α : Type) (EvalCmd : α → Nat → Nat → Prop) : Nat → Nat → Prop where + | mk : EvalCmd a σ σ' → DirectUse α EvalCmd σ σ' + +-- External inductive that DELEGATES to another inductive (EvalList) +inductive EvalList (α : Type) (EvalCmd : α → Nat → Nat → Prop) : Nat → Nat → Prop where + | nil : EvalCmd a σ σ' → EvalList α EvalCmd σ σ + | cons : EvalList α EvalCmd σ σ' → EvalList α EvalCmd σ σ' + +inductive EvalList' (α : Type) (EvalCmd : α → Nat → Nat → Prop) : Nat → Nat → Prop where + -- EvalList' is not directly using EvalCmd (the commented-out nil constructor directly uses it), so can't be nested in BadStar + -- | nil : EvalCmd a σ σ' → EvalList' α EvalCmd σ σ' + | cons : EvalList α EvalCmd σ σ' → EvalList' α EvalCmd σ σ' + +-- ✓ WORKS: DirectUse uses EvalCmd in its own constructor only +mutual +inductive GoodStar (n : Nat) : Nat → Nat → Prop where + | refl : GoodStar n c c + | step : DirectUse Nat (GoodCmd n) c₁ c₂ → GoodStar n c₂ c₃ → GoodStar n c₁ c₃ + +inductive GoodCmd (n : Nat) : Nat → Nat → Nat → Prop where + | call : GoodStar n σ σ' → GoodCmd n x σ σ' +end + +-- ✗ FAILS: EvalList' references EvalList internally, creating a nested +-- inductive chain. Uncomment to see the error: +-- "(kernel) invalid nested inductive datatype 'EvalList'', +-- nested inductive datatypes parameters cannot contain local variables." +/- +mutual +inductive BadStar (n : Nat) : Nat → Nat → Prop where + | refl : BadStar n c c + | step : EvalList' Nat (BadCmd n) c₁ c₂ → BadStar n c₂ c₃ → BadStar n c₁ c₃ + +inductive BadCmd (n : Nat) : Nat → Nat → Nat → Prop where + | call : BadStar n σ σ' → BadCmd n x σ σ' +end +-/ From 6b3c0653e5ae23c8b69ee89c45d623331adcc9ed Mon Sep 17 00:00:00 2001 From: David Deng Date: Mon, 18 May 2026 14:56:23 -0700 Subject: [PATCH 57/57] bump maxRecDepth --- Strata/Languages/Core/DDMTransform/Grammar.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Strata/Languages/Core/DDMTransform/Grammar.lean b/Strata/Languages/Core/DDMTransform/Grammar.lean index a7531297dd..3680ec9524 100644 --- a/Strata/Languages/Core/DDMTransform/Grammar.lean +++ b/Strata/Languages/Core/DDMTransform/Grammar.lean @@ -25,7 +25,7 @@ namespace Strata -- Sequence operations and lambda/application syntax increase the grammar size enough -- to require higher recursion and heartbeat limits. -set_option maxRecDepth 10000 +set_option maxRecDepth 20000 set_option maxHeartbeats 400000 /- DDM support for parsing and pretty-printing Strata Core -/