From 12e7e3e0794b9472e5021bc2a4da3ab43af27e0f Mon Sep 17 00:00:00 2001 From: David Deng Date: Tue, 5 May 2026 11:24:59 -0700 Subject: [PATCH 01/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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/64] 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 0fcdc25a7d0321e1a5a84c382838346b230d6973 Mon Sep 17 00:00:00 2001 From: Aaron Tomb Date: Thu, 14 May 2026 14:44:26 -0700 Subject: [PATCH 56/64] Add PR template warning about repository split (#1166) Add a pull request description template that warns about the upcoming repository split. By submitting this pull request, I confirm that you can use, modify, copy, and redistribute this contribution, under the terms of your choice. --- .github/pull_request_template.md | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 .github/pull_request_template.md diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md new file mode 100644 index 0000000000..268728fdc7 --- /dev/null +++ b/.github/pull_request_template.md @@ -0,0 +1,7 @@ +**Warning:** This repository will shortly undergo a split into several separate repositories. If you're creating a PR that crosses the boundaries between these repositories, you may want to hold off until the split is complete or be prepared to rework your PR into multiple PRs once the split is complete. + +The code that will be moved includes: +- Strata/DDM/* +- Strata/Languages/Boole/* +- Strata/Languages/Python/* along with Tools/Python/* +- Tools/BoogieToStrata \ No newline at end of file From 475971218ab99e2a8cebffeabd87450c73a6c36b Mon Sep 17 00:00:00 2001 From: David Deng Date: Fri, 15 May 2026 09:09:23 -0700 Subject: [PATCH 57/64] 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 99b84e5d74622f629800fa147bca9e9064c7aa53 Mon Sep 17 00:00:00 2001 From: Michael Tautschnig Date: Fri, 15 May 2026 20:37:59 +0200 Subject: [PATCH 58/64] lake: build Strata lib as a test-driver dependency (#1138) The `StrataTestMain` test driver spawns `lean` on files under `StrataTestExtra/`, which is not declared as a `lean_lib`. Some of those files (e.g. `DDM/Integration/Java/TestGen.lean`) import modules from the `Strata` library that are not in `StrataTest`'s transitive closure, most notably `Strata.DDM.Integration.Java`. Before this change, `lake test` on a clean `.lake` would only build the closure reachable from `StrataTest` and then fail at subprocess time with: error: object file '.../Strata/DDM/Integration/Java.olean' of module Strata.DDM.Integration.Java does not exist Running `lake build` first masked the bug because the `Strata` library is in `defaultTargets`. Add `Strata` to the `needs` list of `StrataTestMain` so Lake builds the full `Strata` library before the test driver runs, regardless of whether `lake build` was run beforehand. By submitting this pull request, I confirm that you can use, modify, copy, and redistribute this contribution, under the terms of your choice. Co-authored-by: Kiro --- lakefile.toml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lakefile.toml b/lakefile.toml index b59a11c9e8..5110d270ac 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -27,7 +27,12 @@ globs = ["StrataTest.+"] [[lean_exe]] name = "StrataTestMain" root = "Scripts.StrataTestMain" -needs = ["StrataTest"] +# `Strata` is listed explicitly because the driver spawns `lean` on files +# under `StrataTestExtra/` (which is not a `lean_lib`). Those files import +# modules from the `Strata` library that are not in `StrataTest`'s transitive +# closure (e.g., `Strata.DDM.Integration.Java`), so without this the oleans +# would be missing when running `lake test` from a clean `.lake`. +needs = ["Strata", "StrataTest"] [[lean_exe]] name = "StrataToCBMC" From 8acaa4b56f3dee63b8e56da1a682e0ef4e6b2849 Mon Sep 17 00:00:00 2001 From: Juneyoung Lee <136006969+aqjune-aws@users.noreply.github.com> Date: Fri, 15 May 2026 15:39:21 -0500 Subject: [PATCH 59/64] The small-step semantics of Imperative must have scoped var init, remove unlabeled exit from Core (#1141) *Issue #, if available:* Closes https://github.com/strata-org/Strata/issues/372 *Description of changes:* Formalizing scoped variable initialization: - Adds scoped environment semantics to blocks: step_block_done now projects the store through the parent store via projectStore, discarding block-local variables on exit. This applies to both StepStmt (deterministic) and StepKleene (nondeterministic). - Adds PostWF helper definition in Specification.lean for postcondition stability under projectStore. - Adds .block constructor to KleeneStmt and corresponding step_block/step_block_body/step_block_done to StepKleene, mirroring the deterministic block semantics. - Changes StmtToKleeneStmt (.block _ bss _) to produce .block b (wrapping in a Kleene block), so the Kleene translation preserves scoping. Removing unlabeled `exit` command (`exit;`, not `exit lbl;`): - The unlabeled `exit` command doesn't have clear meaning when it is inside `while`. In `while cond { ... exit; ... }`, is `exit` equivalent to `continue` or `break` in C/Python? No translation to Core was introducing the unlabeled `exit`, and the small-step semantics wasn't clear about the meaning of `exit` inside a loop. - The type checker of Core (Strata/Languages/Core/StatementType.lean) fails when an unlabeled `exit` appears inside the body of a while loop / if statement (unless it is wrapped by another nested block), but the DDM syntax of core allows it, so from user's perspective this gap is kind of surprising. - This patch removes the unlabeled `exit` case because it can always be simulated by a labeled block + labeled exit. On top of this, this also renames `touchedVars` to `modifiedOrDefinedVars` for clarity, and instead makes `touchedVars` all vars that are read + modified + defined. ### How to review? - Strata/DL/Imperative/StmtSemantics.lean has the most important update: the `.block` constructor now has the input store which will be used to 'project' the output store to the variables that have been defined before. Also, any block-exiting small steps like `step_block_done` will do the projection, to define variables which were defined inside the inner scope. - Correspondingly, the Kleene language was updated to add a notion of block and scoping to its syntax and semantics, otherwise DetToKleene doesn't prove. (Strata/DL/Imperative/KleeneStmt.lean, Strata/DL/Imperative/KleeneStmtSemantics.lean) - StrataTest/DL/Imperative/StepStmtTest.lean has a few new tests that show scoping works well. - DetToKleeneCorrect.lean and ProcBodyVerifyCorrect.lean shows that the top-level statements are not touched after this update. - Strata/DL/Imperative/HasVars.lean has the `touchedVars` update and Strata/Languages/Core/StatementSemantics.lean has some additional well-formedness about evaluator extension that are useful. By submitting this pull request, I confirm that you can use, modify, copy, and redistribute this contribution, under the terms of your choice. --- Strata/DL/Imperative/Cmd.lean | 2 +- Strata/DL/Imperative/CmdSemantics.lean | 4 +- Strata/DL/Imperative/HasVars.lean | 4 +- .../DL/Imperative/KleeneSemanticsProps.lean | 22 + Strata/DL/Imperative/KleeneStmt.lean | 8 + Strata/DL/Imperative/KleeneStmtSemantics.lean | 36 +- Strata/DL/Imperative/SemanticsProps.lean | 1 - Strata/DL/Imperative/Stmt.lean | 74 ++-- Strata/DL/Imperative/StmtEval.lean | 7 +- Strata/DL/Imperative/StmtSemantics.lean | 382 +++++++++-------- Strata/Languages/Boole/Verify.lean | 2 - .../Core/DDMTransform/FormatCore.lean | 8 +- .../Languages/Core/DDMTransform/Grammar.lean | 1 - .../Core/DDMTransform/Translate.lean | 5 +- Strata/Languages/Core/Procedure.lean | 6 +- Strata/Languages/Core/Statement.lean | 24 +- Strata/Languages/Core/StatementSemantics.lean | 9 +- .../Core/StatementSemanticsProps.lean | 178 ++++++-- Strata/Languages/Core/StatementType.lean | 17 +- Strata/Languages/Core/WF.lean | 4 +- .../Laurel/LaurelToCoreTranslator.lean | 6 +- Strata/Languages/Python/PythonToCore.lean | 8 +- Strata/Transform/CallElimCorrect.lean | 2 +- Strata/Transform/CoreSpecification.lean | 2 + Strata/Transform/DetToKleene.lean | 2 +- Strata/Transform/DetToKleeneCorrect.lean | 297 +++++++------ Strata/Transform/ProcBodyVerifyCorrect.lean | 99 +++-- Strata/Transform/ProcedureInlining.lean | 2 +- Strata/Transform/Specification.lean | 41 +- .../Transform/StructuredToUnstructured.lean | 22 +- .../Backends/CBMC/GOTO/ToCProverGOTO.lean | 2 +- StrataTest/DL/Imperative/FormatStmtTest.lean | 6 +- StrataTest/DL/Imperative/StepStmtTest.lean | 401 ++++++++++++++++-- StrataTest/Transform/ProcedureInlining.lean | 7 +- docs/verso/LangDefDoc.lean | 3 +- 35 files changed, 1117 insertions(+), 577 deletions(-) diff --git a/Strata/DL/Imperative/Cmd.lean b/Strata/DL/Imperative/Cmd.lean index df62a0b4c4..24da7fce49 100644 --- a/Strata/DL/Imperative/Cmd.lean +++ b/Strata/DL/Imperative/Cmd.lean @@ -183,7 +183,7 @@ instance (P : PureExpr) : HasVarsImp P (Cmds P) where definedVars := Cmds.definedVars modifiedVars := Cmds.modifiedVars -- order matters for Havoc, so needs to override the default - touchedVars := List.flatMap HasVarsImp.touchedVars + modifiedOrDefinedVars := List.flatMap HasVarsImp.modifiedOrDefinedVars --------------------------------------------------------------------- diff --git a/Strata/DL/Imperative/CmdSemantics.lean b/Strata/DL/Imperative/CmdSemantics.lean index 11392f9073..a2da7a8607 100644 --- a/Strata/DL/Imperative/CmdSemantics.lean +++ b/Strata/DL/Imperative/CmdSemantics.lean @@ -44,7 +44,7 @@ when the command signals a failure. /-- ### Well-Formedness of `SemanticStore`s -/ -def isDefined {P : PureExpr} (σ : SemanticStore P) (vs : List P.Ident) : Prop := +@[expose] def isDefined {P : PureExpr} (σ : SemanticStore P) (vs : List P.Ident) : Prop := ∀ v, v ∈ vs → (σ v).isSome = true def isNotDefined {P : PureExpr} (σ : SemanticStore P) (vs : List P.Ident) : Prop := @@ -239,7 +239,7 @@ def WellFormedSemanticEvalVal {P : PureExpr} [HasVal P] @[expose] def WellFormedSemanticEvalVar {P : PureExpr} [HasFvar P] (δ : SemanticEval P) : Prop := (∀ e v σ, HasFvar.getFvar e = some v → δ σ e = σ v) -def WellFormedSemanticEvalExprCongr {P : PureExpr} [HasVarsPure P P.Expr] (δ : SemanticEval P) +@[expose] def WellFormedSemanticEvalExprCongr {P : PureExpr} [HasVarsPure P P.Expr] (δ : SemanticEval P) : Prop := ∀ e σ σ', (∀ x ∈ HasVarsPure.getVars e, σ x = σ' x) → δ σ e = δ σ' e /-- diff --git a/Strata/DL/Imperative/HasVars.lean b/Strata/DL/Imperative/HasVars.lean index 865196658f..5cc92a66c8 100644 --- a/Strata/DL/Imperative/HasVars.lean +++ b/Strata/DL/Imperative/HasVars.lean @@ -21,7 +21,7 @@ class HasVarsPure (P : PureExpr) (α : Type) where class HasVarsImp (P : PureExpr) (α : Type) where definedVars : α → List P.Ident modifiedVars : α → List P.Ident - touchedVars : α → List P.Ident + modifiedOrDefinedVars : α → List P.Ident := λ e ↦ definedVars e ++ modifiedVars e --------------------------------------------------------------------- @@ -42,7 +42,7 @@ class HasVarsTrans definedVarsTrans : (String → Option PT) → α → List P.Ident modifiedVarsTrans : (String → Option PT) → α → List P.Ident getVarsTrans : (String → Option PT) → α → List P.Ident - touchedVarsTrans : (String → Option PT) → α → List P.Ident + modifiedOrDefinedVarsTrans : (String → Option PT) → α → List P.Ident allVarsTrans : (String → Option PT) → α → List P.Ident := λ π a ↦ modifiedVarsTrans π a ++ getVarsTrans π a diff --git a/Strata/DL/Imperative/KleeneSemanticsProps.lean b/Strata/DL/Imperative/KleeneSemanticsProps.lean index fa3b6a579d..11b8b1a667 100644 --- a/Strata/DL/Imperative/KleeneSemanticsProps.lean +++ b/Strata/DL/Imperative/KleeneSemanticsProps.lean @@ -36,6 +36,28 @@ theorem eval_tt_is_tt /-! ## Kleene small-step helpers -/ +omit [HasVal P] [HasBoolVal P] in +theorem kleene_block_inner_star + (σ_parent : SemanticStore P) + (inner inner' : KleeneConfig P (Cmd P)) + (h : StepKleeneStar P (EvalCmd P) inner inner') : + StepKleeneStar P (EvalCmd P) (.block σ_parent inner) (.block σ_parent inner') := by + induction h with + | refl => exact .refl _ + | step _ mid _ hstep _ ih => exact .step _ _ _ (.step_block_body hstep) ih + +omit [HasVal P] [HasBoolVal P] in +/-- Lift an inner execution through a block wrapper to terminal (with projection). -/ +theorem kleene_block_terminal + (σ_parent : SemanticStore P) + (inner : KleeneConfig P (Cmd P)) (ρ' : Env P) + (h : StepKleeneStar P (EvalCmd P) inner (.terminal ρ')) : + StepKleeneStar P (EvalCmd P) (.block σ_parent inner) + (.terminal { ρ' with store := projectStore σ_parent ρ'.store }) := + ReflTrans_Transitive _ _ _ _ + (kleene_block_inner_star σ_parent inner (.terminal ρ') h) + (.step _ _ _ .step_block_done (.refl _)) + omit [HasVal P] [HasBoolVal P] in theorem kleene_seq_inner_star (inner inner' : KleeneConfig P (Cmd P)) (s2 : KleeneStmt P (Cmd P)) diff --git a/Strata/DL/Imperative/KleeneStmt.lean b/Strata/DL/Imperative/KleeneStmt.lean index f7c82f8497..faa049dd3f 100644 --- a/Strata/DL/Imperative/KleeneStmt.lean +++ b/Strata/DL/Imperative/KleeneStmt.lean @@ -41,6 +41,11 @@ inductive KleeneStmt (P : PureExpr) (Cmd : Type) : Type where | choice (s1 s2 : KleeneStmt P Cmd) /-- Execute `s` an arbitrary number of times (possibly zero). -/ | loop (s : KleeneStmt P Cmd) + /-- Execute `s` in a scoped block: variables initialized inside are + projected away on exit (matching the deterministic `.block` semantics). + There is no label unlike Imperative.Stmt.block because KleeneStmt doesn't + have .exit. -/ + | block (s : KleeneStmt P Cmd) deriving Inhabited abbrev KleeneStmt.init {P : PureExpr} (name : P.Ident) (ty : P.Ty) (expr : P.Expr) (md : MetaData P) := @@ -62,6 +67,7 @@ def KleeneStmt.definedVars [HasVarsImp P C] (s : KleeneStmt P C) : List P.Ident | .seq s1 s2 => KleeneStmt.definedVars s1 ++ KleeneStmt.definedVars s2 | .choice s1 s2 => KleeneStmt.definedVars s1 ++ KleeneStmt.definedVars s2 | .loop s => KleeneStmt.definedVars s + | .block s => KleeneStmt.definedVars s def KleeneStmts.definedVars [HasVarsImp P C] (ss : List (KleeneStmt P C)) : List P.Ident := match ss with @@ -77,6 +83,7 @@ def KleeneStmt.modifiedVars [HasVarsImp P C] (s : KleeneStmt P C) : List P.Ident | .seq s1 s2 => KleeneStmt.modifiedVars s1 ++ KleeneStmt.modifiedVars s2 | .choice s1 s2 => KleeneStmt.modifiedVars s1 ++ KleeneStmt.modifiedVars s2 | .loop s => KleeneStmt.modifiedVars s + | .block s => KleeneStmt.modifiedVars s def KleeneStmts.modifiedVars [HasVarsImp P C] (ss : List (KleeneStmt P C)) : List P.Ident := match ss with @@ -101,6 +108,7 @@ def formatKleeneStmt (P : PureExpr) (s : KleeneStmt P C) | .seq s1 s2 => f!"({formatKleeneStmt P s1}) ; ({formatKleeneStmt P s2})" | .choice s1 s2 => f!"({formatKleeneStmt P s1}) | ({formatKleeneStmt P s2})" | .loop s => f!"({formatKleeneStmt P s})*" + | .block s => f!"block({formatKleeneStmt P s})" instance [ToFormat P.Ident] [ToFormat P.Expr] [ToFormat P.Ty] [ToFormat C] : ToFormat (KleeneStmt P C) where diff --git a/Strata/DL/Imperative/KleeneStmtSemantics.lean b/Strata/DL/Imperative/KleeneStmtSemantics.lean index 7b70ba065b..4152be0a2f 100644 --- a/Strata/DL/Imperative/KleeneStmtSemantics.lean +++ b/Strata/DL/Imperative/KleeneStmtSemantics.lean @@ -17,7 +17,7 @@ public section /-! # Small-step semantics for non-deterministic statements A configuration is either executing a `KleeneStmt`, sequencing two parts -(left config + right continuation), or terminated. +(left config + right continuation), a block context, or terminated. -/ /-- Configurations for small-step execution of `KleeneStmt`. -/ @@ -28,6 +28,9 @@ inductive KleeneConfig (P : PureExpr) (CmdT : Type) : Type where | seq : KleeneConfig P CmdT → KleeneStmt P CmdT → KleeneConfig P CmdT /-- Execution has finished. -/ | terminal : Env P → KleeneConfig P CmdT + /-- A block context for scoping. The `SemanticStore P` is the parent store; + on exit, variables init'd inside are projected away. -/ + | block : SemanticStore P → KleeneConfig P CmdT → KleeneConfig P CmdT /-! ## Configuration accessors -/ @@ -35,16 +38,19 @@ inductive KleeneConfig (P : PureExpr) (CmdT : Type) : Type where | .stmt _ ρ => ρ.store | .seq inner _ => inner.getStore | .terminal ρ => ρ.store + | .block _ inner => inner.getStore @[expose] def KleeneConfig.getEval : KleeneConfig P CmdT → SemanticEval P | .stmt _ ρ => ρ.eval | .seq inner _ => inner.getEval | .terminal ρ => ρ.eval + | .block _ inner => inner.getEval @[expose] def KleeneConfig.getEnv : KleeneConfig P CmdT → Env P | .stmt _ ρ => ρ | .seq inner _ => inner.getEnv | .terminal ρ => ρ + | .block _ inner => inner.getEnv /-! ## Single-step relation -/ @@ -89,11 +95,21 @@ inductive StepKleene (.stmt (.loop s) ρ) (.terminal ρ) - /-- A loop can execute one iteration then continue looping. -/ + /-- A loop can execute one iteration then continue looping. + Each iteration's body runs in its own block scope, sequenced with the + recursive loop step. When the body's block terminates, projection drops + any variables initialized inside the body, so the next iteration starts + with the same `isSome`-domain as the loop entry. -/ | step_loop_step : StepKleene EvalCmd (.stmt (.loop s) ρ) - (.seq (.stmt s ρ) (.loop s)) + (.seq (.block ρ.store (.stmt s ρ)) (.loop s)) + + /-- A block statement enters a block context, saving the parent store. -/ + | step_block : + StepKleene EvalCmd + (.stmt (.block s) ρ) + (.block ρ.store (.stmt s ρ)) /-- A seq context steps its inner config forward. -/ | step_seq_inner : @@ -110,6 +126,20 @@ inductive StepKleene (.seq (.terminal ρ') s2) (.stmt s2 ρ') + /-- A block context steps its inner config forward. -/ + | step_block_body : + StepKleene EvalCmd inner inner' → + ---- + StepKleene EvalCmd + (.block σ_parent inner) + (.block σ_parent inner') + + /-- When a block's inner config reaches terminal, project the store. -/ + | step_block_done : + StepKleene EvalCmd + (.block σ_parent (.terminal ρ')) + (.terminal { ρ' with store := projectStore σ_parent ρ'.store }) + end /-! ## Multi-step relation -/ diff --git a/Strata/DL/Imperative/SemanticsProps.lean b/Strata/DL/Imperative/SemanticsProps.lean index 7a8f8b21a8..772aa9c4bb 100644 --- a/Strata/DL/Imperative/SemanticsProps.lean +++ b/Strata/DL/Imperative/SemanticsProps.lean @@ -137,7 +137,6 @@ private theorem step_hasFailure_monotone | step_seq_exit => exact hf | step_block_body _ ih => exact ih hf | step_block_done => exact hf - | step_block_exit_none => exact hf | step_block_exit_match _ => exact hf | step_block_exit_mismatch _ => exact hf diff --git a/Strata/DL/Imperative/Stmt.lean b/Strata/DL/Imperative/Stmt.lean index c60e02312c..821ecf0d9d 100644 --- a/Strata/DL/Imperative/Stmt.lean +++ b/Strata/DL/Imperative/Stmt.lean @@ -43,10 +43,9 @@ inductive Stmt (P : PureExpr) (Cmd : Type) : Type where | loop (guard : ExprOrNondet P) (measure : Option P.Expr) (invariants : List (String × P.Expr)) (body : List (Stmt P Cmd)) (md : MetaData P) - /-- An exit statement that transfers control out of the nearest enclosing - block with the given label. If no label is provided, exits the nearest - enclosing block. -/ - | exit (label : Option String) (md : MetaData P) + /-- An exit statement that transfers control out of the enclosing block + with the given label. -/ + | exit (label : String) (md : MetaData P) /-- A function declaration within a statement block. -/ | funcDecl (decl : PureFunc P) (md : MetaData P) /-- A type declaration within a statement block. -/ @@ -80,7 +79,7 @@ def Stmt.inductionOn {P : PureExpr} {Cmd : Type} (body : List (Stmt P Cmd)) (md : MetaData P), (∀ s, s ∈ body → motive s) → motive (Stmt.loop guard measure invariant body md)) - (exit_case : ∀ (label : Option String) (md : MetaData P), + (exit_case : ∀ (label : String) (md : MetaData P), motive (Stmt.exit label md)) (funcDecl_case : ∀ (decl : PureFunc P) (md : MetaData P), motive (Stmt.funcDecl decl md)) @@ -304,31 +303,40 @@ mutual /-- Get all variables modified/defined by the statement `s`. Note that we need a separate function because order matters here for sub-blocks -/ -@[simp] -def Stmt.touchedVars [HasVarsImp P C] (s : Stmt P C) : List P.Ident := +def Stmt.modifiedOrDefinedVars [HasVarsImp P C] (s : Stmt P C) : List P.Ident := match s with - | .block _ bss _ => Block.touchedVars bss - | .ite _ tbss ebss _ => Block.touchedVars tbss ++ Block.touchedVars ebss + | .block _ bss _ => Block.modifiedOrDefinedVars bss + | .ite _ tbss ebss _ => Block.modifiedOrDefinedVars tbss ++ Block.modifiedOrDefinedVars ebss | _ => Stmt.definedVars s ++ Stmt.modifiedVars s -@[simp] -def Block.touchedVars [HasVarsImp P C] (ss : Block P C) : List P.Ident := +def Block.modifiedOrDefinedVars [HasVarsImp P C] (ss : Block P C) : List P.Ident := match ss with | [] => [] - | s :: srest => Stmt.touchedVars s ++ Block.touchedVars srest + | s :: srest => Stmt.modifiedOrDefinedVars s ++ Block.modifiedOrDefinedVars srest +end + +mutual +/-- Get all variables touched (modified, defined, or read) by the statement `s`. -/ +def Stmt.touchedVars [HasVarsImp P C] [HasVarsPure P P.Expr] [HasVarsPure P C] + (s : Stmt P C) : List P.Ident := + Stmt.modifiedOrDefinedVars s ++ Stmt.getVars s + +def Block.touchedVars [HasVarsImp P C] [HasVarsPure P P.Expr] [HasVarsPure P C] + (ss : Block P C) : List P.Ident := + Block.modifiedOrDefinedVars ss ++ Block.getVars ss end instance (P : PureExpr) [HasVarsImp P C] : HasVarsImp P (Stmt P C) where definedVars := Stmt.definedVars modifiedVars := Stmt.modifiedVars -- order matters for Havoc, so needs to override the default - touchedVars := Stmt.touchedVars + modifiedOrDefinedVars := Stmt.modifiedOrDefinedVars instance (P : PureExpr) [HasVarsImp P C] : HasVarsImp P (Block P C) where definedVars := Block.definedVars modifiedVars := Block.modifiedVars -- order matters for Havoc, so needs to override the default - touchedVars := Block.touchedVars + modifiedOrDefinedVars := Block.modifiedOrDefinedVars --------------------------------------------------------------------- @@ -356,9 +364,7 @@ def formatStmt (P : PureExpr) (s : Stmt P C) let beforeBody := nestD f!"{line}{guard}{line}({measure}){line}{invFmt}" let children := group f!"{beforeBody}{line}{body}" f!"{md}while{children}" - | .exit label md => match label with - | some l => f!"{md}exit {l}" - | none => f!"{md}exit" + | .exit label md => f!"{md}exit {label}" | .funcDecl _ md => f!"{md}funcDecl " | .typeDecl tc md => f!"{md}type {tc.name} (arity {tc.numargs})" @@ -390,29 +396,24 @@ instance [ToFormat P.Ident] [ToFormat P.Expr] [ToFormat P.Ty] [ToFormat C] by an enclosing `block` — either within `s` itself or with a label in `labels` (representing blocks that enclose `s` externally). -When `s.exitsCoveredByBlocks []`, execution of `s` can never produce `.exiting`. - -The labels have type `Option String` (not `String`) so that `exit` without -destination block label can be considered as covered even when it is surrounded -by unlabeled blocks (`[None]`). -/ +When `s.exitsCoveredByBlocks []`, execution of `s` can never produce `.exiting`. -/ -@[expose] def Stmt.exitsCoveredByBlocks : List (Option String) → Stmt P CmdT → Prop +@[expose] def Stmt.exitsCoveredByBlocks : List String → Stmt P CmdT → Prop | _, .cmd _ => True - | labels, .block l ss _ => Block.exitsCoveredByBlocks (.some l :: labels) ss + | labels, .block l ss _ => Block.exitsCoveredByBlocks (l :: labels) ss | labels, .ite _ tss ess _ => Block.exitsCoveredByBlocks labels tss ∧ Block.exitsCoveredByBlocks labels ess | labels, .loop _ _ _ body _ => Block.exitsCoveredByBlocks labels body - | labels, .exit none _ => labels.length > 0 - | labels, .exit (some l) _ => .some l ∈ labels + | labels, .exit l _ => l ∈ labels | _, .funcDecl _ _ => True | _, .typeDecl _ _ => True where - Block.exitsCoveredByBlocks : List (Option String) → List (Stmt P CmdT) → Prop + Block.exitsCoveredByBlocks : List String → List (Stmt P CmdT) → Prop | _, [] => True | labels, s :: ss => Stmt.exitsCoveredByBlocks labels s ∧ Block.exitsCoveredByBlocks labels ss theorem block_exitsCoveredByBlocks_append {P : PureExpr} {CmdT : Type} - (labels : List (Option String)) (ss₁ ss₂ : List (Stmt P CmdT)) + (labels : List String) (ss₁ ss₂ : List (Stmt P CmdT)) (h₁ : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss₁) (h₂ : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss₂) : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels (ss₁ ++ ss₂) := by @@ -424,7 +425,7 @@ theorem block_exitsCoveredByBlocks_append can only help. -/ theorem exitsCoveredByBlocks_weaken {P : PureExpr} {CmdT : Type} - (labels₁ labels₂ : List (Option String)) + (labels₁ labels₂ : List String) (hsub : ∀ l, l ∈ labels₁ → l ∈ labels₂) : (∀ (s : Stmt P CmdT), s.exitsCoveredByBlocks labels₁ → s.exitsCoveredByBlocks labels₂) ∧ @@ -449,8 +450,8 @@ theorem exitsCoveredByBlocks_weaken | cmd _ => intros; trivial | block l ss _ ih => intro labels₁ labels₂ hsub h - show Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks (.some l :: labels₂) ss - exact ih (.some l :: labels₁) (.some l :: labels₂) + show Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks (l :: labels₂) ss + exact ih (l :: labels₁) (l :: labels₂) (fun x hx => by cases hx with | head => exact .head _ | tail _ hm => exact .tail _ (hsub x hm)) @@ -461,14 +462,9 @@ theorem exitsCoveredByBlocks_weaken | loop _ _ _ body _ ih => intro labels₁ labels₂ hsub h exact ih labels₁ labels₂ hsub h - | exit label _ => + | exit l _ => intro labels₁ labels₂ hsub h - cases label with - | none => - show labels₂.length > 0 - exact List.length_pos_iff_exists_mem.mpr - (let ⟨x, hx⟩ := List.length_pos_iff_exists_mem.mp h; ⟨x, hsub x hx⟩) - | some l => exact hsub (.some l) h + exact hsub l h | funcDecl _ _ => intros; trivial | typeDecl _ _ => intros; trivial | nil => intros; trivial @@ -480,7 +476,7 @@ theorem exitsCoveredByBlocks_weaken for any labels (since `.cmd` has no exit statements). -/ theorem all_cmd_exitsCoveredByBlocks {P : PureExpr} {CmdT : Type} - (labels : List (Option String)) (ss : List (Stmt P CmdT)) + (labels : List String) (ss : List (Stmt P CmdT)) (h : ∀ s ∈ ss, ∃ c, s = Stmt.cmd c) : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss := by induction ss with diff --git a/Strata/DL/Imperative/StmtEval.lean b/Strata/DL/Imperative/StmtEval.lean index 9acf45668e..f09895a74c 100644 --- a/Strata/DL/Imperative/StmtEval.lean +++ b/Strata/DL/Imperative/StmtEval.lean @@ -23,7 +23,7 @@ inductive RunConfig (P : PureExpr) (CmdT : Type) (S : Type) where | stmt : Stmt P CmdT → S → RunConfig P CmdT S | stmts : List (Stmt P CmdT) → S → RunConfig P CmdT S | terminal : S → RunConfig P CmdT S - | exiting : Option String → S → RunConfig P CmdT S + | exiting : String → S → RunConfig P CmdT S | block : String → RunConfig P CmdT S → RunConfig P CmdT S | seq : RunConfig P CmdT S → List (Stmt P CmdT) → RunConfig P CmdT S @@ -96,10 +96,9 @@ def runStep [BEq P.Expr] [HasBool P] | .block label inner => match inner with | .terminal ρ' => .terminal (ops.popScope ρ') - | .exiting .none ρ' => .terminal (ops.popScope ρ') - | .exiting (.some l) ρ' => + | .exiting l ρ' => if l == label then .terminal (ops.popScope ρ') - else .exiting (.some l) (ops.popScope ρ') + else .exiting l (ops.popScope ρ') | _ => .block label (runStep ops inner) def runStmt [BEq P.Expr] [HasBool P] diff --git a/Strata/DL/Imperative/StmtSemantics.lean b/Strata/DL/Imperative/StmtSemantics.lean index 3b9da68ab7..68a7dd2993 100644 --- a/Strata/DL/Imperative/StmtSemantics.lean +++ b/Strata/DL/Imperative/StmtSemantics.lean @@ -66,12 +66,14 @@ inductive Config (P : PureExpr) (CmdT : Type) : Type where /-- A terminal configuration, indicating that execution has finished. -/ | terminal : Env P → Config P CmdT /-- An exiting configuration, indicating that an exit statement was encountered. - The optional label identifies which block to exit to. -/ - | exiting : Option String → Env P → Config P CmdT + The label identifies which block to exit to. -/ + | exiting : String → Env P → Config P CmdT /-- A block context: execute the inner config, then consume matching exits. The label is `Option String` — `none` denotes an unnamed block that only - catches unlabeled exits. -/ - | block : Option String → Config P CmdT → Config P CmdT + catches unlabeled exits. The `SemanticStore P` is the parent store at + block entry; on exit, the result is projected through it so that + variables initialized inside the block are not visible outside. -/ + | block : Option String → SemanticStore P → Config P CmdT → Config P CmdT /-- A sequence context: execute the first statement (as a sub-config), then continue with the remaining statements. -/ | seq : Config P CmdT → List (Stmt P CmdT) → Config P CmdT @@ -86,7 +88,7 @@ variable {P : PureExpr} {CmdT : Type} | .stmts _ ρ => ρ | .terminal ρ => ρ | .exiting _ ρ => ρ - | .block _ inner => inner.getEnv + | .block _ _ inner => inner.getEnv | .seq inner _ => inner.getEnv /-- Extract the store from a configuration. -/ @@ -130,7 +132,7 @@ where | .stmts ss _, label => Stmt.noMatchingAssert.Stmts.noMatchingAssert ss label | .terminal _, _ => True | .exiting _ _, _ => True - | .block _ inner, label => inner.noMatchingAssert label + | .block _ _ inner, label => inner.noMatchingAssert label | .seq inner ss, label => inner.noMatchingAssert label ∧ Stmt.noMatchingAssert.Stmts.noMatchingAssert ss label @@ -140,20 +142,31 @@ def Config.noFuncDecl : Config P CmdT → Prop | .stmts ss _ => Block.noFuncDecl ss = true | .terminal _ => True | .exiting _ _ => True - | .block _ inner => Config.noFuncDecl inner + | .block _ _ inner => Config.noFuncDecl inner | .seq inner ss => Config.noFuncDecl inner ∧ Block.noFuncDecl ss = true -/-- Extend `exitsCoveredByBlocks` to configurations. -/ -@[expose] def Config.exitsCoveredByBlocks : List (Option String) → Config P CmdT → Prop +/-- Extend `exitsCoveredByBlocks` to configurations. + + The label list has type `List String` (matching `Stmt.exit`'s mandatory-label + AST). An anonymous (`.none`) `Config.block` (introduced by the loop/if's body + wrapper) does NOT contribute a label — labeled exits cannot match `.none`, + and unlabeled exits do not exist as user statements. -/ +@[expose] def Config.exitsCoveredByBlocks : List String → Config P CmdT → Prop | labels, .stmt s _ => s.exitsCoveredByBlocks labels | labels, .stmts ss _ => Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss | _, .terminal _ => True - | labels, .exiting none _ => labels.length > 0 - | labels, .exiting (some l) _ => .some l ∈ labels - | labels, .block l inner => Config.exitsCoveredByBlocks (l :: labels) inner + | labels, .exiting l _ => l ∈ labels + | labels, .block none _ inner => Config.exitsCoveredByBlocks labels inner + | labels, .block (some l) _ inner => Config.exitsCoveredByBlocks (l :: labels) inner | labels, .seq inner ss => Config.exitsCoveredByBlocks labels inner ∧ Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks labels ss +/-- Project an inner store through a parent store: keep the inner value only + for variables that were already defined in the parent. Variables that were + not defined in the parent (i.e., init'd inside the block) become `none`. -/ +@[expose] def projectStore (σ_parent σ_inner : SemanticStore P) : SemanticStore P := + fun x => if (σ_parent x).isSome then σ_inner x else none + /-! ## Single-step relation -/ section @@ -184,11 +197,13 @@ inductive StepStmt /-- A labeled block steps to a block context that wraps its body as `.stmts`. The AST label `label : String` is lifted into `.some label` for the - `Config.block` wrapper (whose label is `Option String`). -/ + `Config.block` wrapper (whose label is `Option String`). + The parent store `ρ.store` is saved so that block-local variables + can be popped on exit. -/ | step_block : StepStmt EvalCmd extendEval (.stmt (.block label ss _) ρ) - (.block (.some label) (.stmts ss ρ)) + (.block (.some label) ρ.store (.stmts ss ρ)) /-- If the condition of an `ite` statement evaluates to true, step to the then branch. -/ @@ -231,9 +246,11 @@ inductive StepStmt labeled pairs `(String × P.Expr)`; only the expression part is evaluated. - The body+recursion is wrapped in an unnamed `.block`, so an unlabeled - `exit` inside the body terminates the loop (and nothing else), while a - labeled `exit` propagates past the loop. -/ + The body alone is wrapped in an unnamed `.block`, sequenced with the + recursive loop. This means each iteration runs the body in its own + block scope: variables `init`'d inside body are projected away at the + end of each iteration, allowing the next iteration's body to re-`init` + the same names. -/ | step_loop_enter {hasInvFailure : Bool} : ρ.eval ρ.store g = .some HasBool.tt → (∀ le ∈ inv, ρ.eval ρ.store le.2 = .some HasBool.tt ∨ @@ -243,8 +260,10 @@ inductive StepStmt ---- StepStmt EvalCmd extendEval (.stmt (.loop (.det g) m inv body md) ρ) - (.block .none (.stmts (body ++ [.loop (.det g) m inv body md]) - { ρ with hasFailure := ρ.hasFailure || hasInvFailure })) + (.seq + (.block .none ρ.store (.stmts body + { ρ with hasFailure := ρ.hasFailure || hasInvFailure })) + [.loop (.det g) m inv body md]) /-- If a loop guard is false, terminate the loop. As with `step_loop_enter`, invariants must be boolean-valued and any `ff` result flips `hasFailure`. -/ @@ -261,16 +280,18 @@ inductive StepStmt /-- Non-deterministic loop: enter the body. Same invariant-boolean condition as the deterministic case. As with the det variant, the - body is wrapped in an unnamed `.block` so that an unlabeled `exit` - terminates just the loop. -/ + body alone is wrapped in an unnamed `.block` and sequenced with the + recursive loop, giving each iteration its own block scope. -/ | step_loop_nondet_enter {hasInvFailure : Bool} : (∀ le ∈ inv, ρ.eval ρ.store le.2 = .some HasBool.tt ∨ ρ.eval ρ.store le.2 = .some HasBool.ff) → (hasInvFailure ↔ ∃ le ∈ inv, ρ.eval ρ.store le.2 = .some HasBool.ff) → StepStmt EvalCmd extendEval (.stmt (.loop .nondet m inv body md) ρ) - (.block .none (.stmts (body ++ [.loop .nondet m inv body md]) - { ρ with hasFailure := ρ.hasFailure || hasInvFailure })) + (.seq + (.block .none ρ.store (.stmts body + { ρ with hasFailure := ρ.hasFailure || hasInvFailure })) + [.loop .nondet m inv body md]) /-- Non-deterministic loop: exit the loop. -/ | step_loop_nondet_exit {hasInvFailure : Bool} : @@ -340,39 +361,37 @@ inductive StepStmt StepStmt EvalCmd extendEval inner inner' → ---- StepStmt EvalCmd extendEval - (.block label inner) - (.block label inner') + (.block label σ_parent inner) + (.block label σ_parent inner') - /-- When a block's inner body reaches terminal, the block terminates. -/ + /-- When a block's inner body reaches terminal, the block terminates. + The resulting store is projected through the parent store: only variables + that existed before the block keep their (possibly updated) values; + variables initialized inside the block are discarded. -/ | step_block_done : StepStmt EvalCmd extendEval - (.block label (.terminal ρ')) - (.terminal ρ') - - /-- When a block's inner body exits with no label, the block consumes the exit - (regardless of the block's own label). -/ - | step_block_exit_none : - StepStmt EvalCmd extendEval - (.block label (.exiting .none ρ')) - (.terminal ρ') + (.block label σ_parent (.terminal ρ')) + (.terminal { ρ' with store := projectStore σ_parent ρ'.store }) - /-- When a block's inner body exits with a matching label, the block consumes it. -/ + /-- When a block's inner body exits with a matching label, the block consumes it. + Store is projected. -/ | step_block_exit_match : label = .some l → ---- StepStmt EvalCmd extendEval - (.block label (.exiting (.some l) ρ')) - (.terminal ρ') + (.block label σ_parent (.exiting l ρ')) + (.terminal { ρ' with store := projectStore σ_parent ρ'.store }) /-- When a block's inner body exits with a non-matching label, the exit propagates. - "Non-matching" covers both the unnamed-block (`.none`) case and any other - mismatched `some` label. -/ + Includes the case where the block's own label is `.none` (anonymous loop/ite + wrapper, which never matches a labeled exit) as well as any other mismatched + `.some` label. Store is projected since we're leaving this block. -/ | step_block_exit_mismatch : label ≠ .some l → ---- StepStmt EvalCmd extendEval - (.block label (.exiting (.some l) ρ')) - (.exiting (.some l) ρ') + (.block label σ_parent (.exiting l ρ')) + (.exiting l { ρ' with store := projectStore σ_parent ρ'.store }) end @@ -462,8 +481,9 @@ theorem seq_inner_star theorem block_inner_star (inner inner' : Config P CmdT) (label : Option String) + (σ_parent : SemanticStore P) (h : StepStmtStar P EvalCmd extendEval inner inner') : - StepStmtStar P EvalCmd extendEval (.block label inner) (.block label inner') := by + StepStmtStar P EvalCmd extendEval (.block label σ_parent inner) (.block label σ_parent inner') := by induction h with | refl => exact .refl _ | step _ mid _ hstep _ ih => exact .step _ _ _ (.step_block_body hstep) ih @@ -525,7 +545,7 @@ theorem seq_reaches_terminal /-- Invert a seq execution reaching exiting: either the inner exited (propagated), or the inner terminated and the tail exited. -/ theorem seq_reaches_exiting - {inner : Config P CmdT} {ss : List (Stmt P CmdT)} {lbl : Option String} {ρ' : Env P} + {inner : Config P CmdT} {ss : List (Stmt P CmdT)} {lbl : String} {ρ' : Env P} (hstar : StepStmtStar P EvalCmd extendEval (.seq inner ss) (.exiting lbl ρ')) : (StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ')) ∨ (∃ ρ₁, StepStmtStar P EvalCmd extendEval inner (.terminal ρ₁) ∧ @@ -550,16 +570,21 @@ theorem seq_reaches_exiting | step_seq_exit => exact .inl (htgt ▸ hrest) /-- Invert a block execution reaching terminal: the inner either - terminated or exited (caught by the block). -/ + terminated or exited (caught by the block). In both cases the inner + reaches a config whose env projects to `ρ'` via the parent store. -/ theorem block_reaches_terminal - {inner : Config P CmdT} {l : Option String} {ρ' : Env P} - (hstar : StepStmtStar P EvalCmd extendEval (.block l inner) (.terminal ρ')) : - StepStmtStar P EvalCmd extendEval inner (.terminal ρ') ∨ - (∃ lbl, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ')) := by + {inner : Config P CmdT} {l : Option String} {σ_parent : SemanticStore P} {ρ' : Env P} + (hstar : StepStmtStar P EvalCmd extendEval (.block l σ_parent inner) (.terminal ρ')) : + (∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.terminal ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store }) ∨ + (∃ lbl ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store }) := by suffices ∀ src tgt, StepStmtStar P EvalCmd extendEval src tgt → - ∀ inner ρ', src = .block l inner → tgt = .terminal ρ' → - StepStmtStar P EvalCmd extendEval inner (.terminal ρ') ∨ - (∃ lbl, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ')) from + ∀ inner ρ', src = .block l σ_parent inner → tgt = .terminal ρ' → + (∃ ρ_inner, StepStmtStar P EvalCmd extendEval inner (.terminal ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store }) ∨ + (∃ lbl ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store }) from this _ _ hstar _ _ rfl rfl intro src tgt hstar_g induction hstar_g with @@ -569,29 +594,30 @@ theorem block_reaches_terminal cases hstep with | step_block_body h => match ih _ _ rfl htgt with - | .inl hterm => exact .inl (.step _ _ _ h hterm) - | .inr ⟨lbl, hexit⟩ => exact .inr ⟨lbl, .step _ _ _ h hexit⟩ - | step_block_done => subst htgt; exact .inl hrest - | step_block_exit_none => + | .inl ⟨ρ_inner, hterm, heq⟩ => exact .inl ⟨ρ_inner, .step _ _ _ h hterm, heq⟩ + | .inr ⟨lbl, ρ_inner, hexit, heq⟩ => exact .inr ⟨lbl, ρ_inner, .step _ _ _ h hexit, heq⟩ + | step_block_done => subst htgt; cases hrest with - | refl => exact .inr ⟨.none, .refl _⟩ + | refl => exact .inl ⟨_, .refl _, rfl⟩ | step _ _ _ h _ => cases h | step_block_exit_match => subst htgt; cases hrest with - | refl => exact .inr ⟨.some _, .refl _⟩ + | refl => exact .inr ⟨_, _, .refl _, rfl⟩ | step _ _ _ h _ => cases h | step_block_exit_mismatch => subst htgt; cases hrest with | step _ _ _ h _ => cases h /-- Invert a block execution reaching exiting: the inner must have - exited with a label that didn't match the block. -/ + exited with a label that didn't match the block. The env is projected. -/ theorem block_reaches_exiting - {inner : Config P CmdT} {l : Option String} {lbl : Option String} {ρ' : Env P} - (hstar : StepStmtStar P EvalCmd extendEval (.block l inner) (.exiting lbl ρ')) : - ∃ lbl_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl_inner ρ') := by + {inner : Config P CmdT} {l : Option String} {σ_parent : SemanticStore P} {lbl : String} {ρ' : Env P} + (hstar : StepStmtStar P EvalCmd extendEval (.block l σ_parent inner) (.exiting lbl ρ')) : + ∃ lbl_inner ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl_inner ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } := by suffices ∀ src tgt, StepStmtStar P EvalCmd extendEval src tgt → - ∀ inner lbl ρ', src = .block l inner → tgt = .exiting lbl ρ' → - ∃ lbl_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl_inner ρ') from + ∀ inner lbl ρ', src = .block l σ_parent inner → tgt = .exiting lbl ρ' → + ∃ lbl_inner ρ_inner, StepStmtStar P EvalCmd extendEval inner (.exiting lbl_inner ρ_inner) ∧ + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } from this _ _ hstar _ _ _ rfl rfl intro src tgt hstar_g induction hstar_g with @@ -600,19 +626,14 @@ theorem block_reaches_exiting intro inner lbl ρ' hsrc htgt; subst hsrc cases hstep with | step_block_body h => - have ⟨lbl_inner, hexit⟩ := ih _ _ _ rfl htgt - exact ⟨lbl_inner, .step _ _ _ h hexit⟩ - | step_block_done => - subst htgt; cases hrest with | step _ _ _ h _ => cases h - | step_block_exit_none => - subst htgt; cases hrest with | step _ _ _ h _ => cases h - | step_block_exit_match => - subst htgt; cases hrest with | step _ _ _ h _ => cases h + have ⟨lbl_inner, ρ_inner, hexit, heq⟩ := ih _ _ _ rfl htgt + exact ⟨lbl_inner, ρ_inner, .step _ _ _ h hexit, heq⟩ | step_block_exit_mismatch => - subst htgt - cases hrest with - | refl => exact ⟨_, .refl _⟩ + subst htgt; cases hrest with + | refl => exact ⟨_, _, .refl _, rfl⟩ | step _ _ _ h _ => cases h + | step_block_done | step_block_exit_match => + subst htgt; cases hrest with | step _ _ _ h _ => cases h /-! ## Trace construction helpers -/ @@ -621,7 +642,7 @@ theorem block_reaches_exiting theorem step_block_enter (l : String) (body : List (Stmt P CmdT)) (md : MetaData P) (ρ : Env P) : StepStmtStar P EvalCmd extendEval - (.stmt (.block l body md) ρ) (.block (.some l) (.stmts body ρ)) := + (.stmt (.block l body md) ρ) (.block (.some l) ρ.store (.stmts body ρ)) := .step _ _ _ .step_block (.refl _) /-- If a prefix of a statement list terminates, the full list steps @@ -686,7 +707,7 @@ private def ConfigSE : Config P CmdT → Config P CmdT → Prop | .stmts ss₁ ρ₁, .stmts ss₂ ρ₂ => ss₁ = ss₂ ∧ ρ₁.store = ρ₂.store ∧ ρ₁.eval = ρ₂.eval | .terminal ρ₁, .terminal ρ₂ => ρ₁.store = ρ₂.store ∧ ρ₁.eval = ρ₂.eval | .exiting l₁ ρ₁, .exiting l₂ ρ₂ => l₁ = l₂ ∧ ρ₁.store = ρ₂.store ∧ ρ₁.eval = ρ₂.eval - | .block l₁ i₁, .block l₂ i₂ => l₁ = l₂ ∧ ConfigSE i₁ i₂ + | .block l₁ σ₁ i₁, .block l₂ σ₂ i₂ => l₁ = l₂ ∧ σ₁ = σ₂ ∧ ConfigSE i₁ i₂ | .seq i₁ ss₁, .seq i₂ ss₂ => ss₁ = ss₂ ∧ ConfigSE i₁ i₂ | _, _ => False @@ -746,47 +767,46 @@ private def step_simulation | _ => exact nomatch heq | step_block_body h => cases c₂ with - | block _ i₂ => + | block _ _ i₂ => have hrs := heq.1; subst hrs - have ⟨c₂', h₂, heq₂⟩ := step_simulation _ _ _ h heq.2 - exact ⟨_, .step_block_body h₂, ⟨rfl, heq₂⟩⟩ + have hσ := heq.2.1; subst hσ + have ⟨c₂', h₂, heq₂⟩ := step_simulation _ _ _ h heq.2.2 + exact ⟨_, .step_block_body h₂, ⟨rfl, rfl, heq₂⟩⟩ | _ => exact nomatch heq | step_block_done => cases c₂ with - | block _ i₂ => + | block _ _ i₂ => have hrs := heq.1; subst hrs + have hσ := heq.2.1; subst hσ cases i₂ with - | terminal ρ₂ => exact ⟨_, .step_block_done, ⟨heq.2.1, heq.2.2⟩⟩ - | _ => exact nomatch heq.2 - | _ => exact nomatch heq - | step_block_exit_none => - cases c₂ with - | block _ i₂ => - cases i₂ with - | exiting l₂ ρ₂ => - have hl := heq.2.1; cases hl - exact ⟨_, .step_block_exit_none, ⟨heq.2.2.1, heq.2.2.2⟩⟩ - | _ => exact nomatch heq.2 + | terminal ρ₂ => + have hse := heq.2.2 + exact ⟨_, .step_block_done, ⟨congrArg (projectStore _) hse.1, hse.2⟩⟩ + | _ => exact nomatch heq.2.2 | _ => exact nomatch heq | step_block_exit_match hl => cases c₂ with - | block _ i₂ => + | block _ _ i₂ => have hlb := heq.1; subst hlb + have hσ := heq.2.1; subst hσ cases i₂ with | exiting l₂ ρ₂ => - have hl₂ := heq.2.1; subst hl₂ - exact ⟨_, .step_block_exit_match hl, ⟨heq.2.2.1, heq.2.2.2⟩⟩ - | _ => exact nomatch heq.2 + have hl₂ := heq.2.2.1; subst hl₂ + have hse := heq.2.2.2 + exact ⟨_, .step_block_exit_match hl, ⟨congrArg (projectStore _) hse.1, hse.2⟩⟩ + | _ => exact nomatch heq.2.2 | _ => exact nomatch heq | step_block_exit_mismatch hl => cases c₂ with - | block _ i₂ => + | block _ _ i₂ => have hlb := heq.1; subst hlb + have hσ := heq.2.1; subst hσ cases i₂ with | exiting l₂ ρ₂ => - have hl₂ := heq.2.1; subst hl₂ - exact ⟨_, .step_block_exit_mismatch hl, ⟨rfl, heq.2.2.1, heq.2.2.2⟩⟩ - | _ => exact nomatch heq.2 + have hl₂ := heq.2.2.1; subst hl₂ + have hse := heq.2.2.2 + exact ⟨_, .step_block_exit_mismatch hl, ⟨rfl, congrArg (projectStore _) hse.1, hse.2⟩⟩ + | _ => exact nomatch heq.2.2 | _ => exact nomatch heq /-- The terminal state's store and eval are independent of the starting @@ -817,9 +837,30 @@ theorem smallStep_hasFailure_irrel /-! ## Well-paired exits: preservation and no-escape -/ +omit [HasBool P] [HasNot P] in +/-- Helper: when the inner of a block reaches `.exiting l` and the + block's label (if some) doesn't match `l`, then `l` must be in the outer + labels list. The conclusion is `l ∈ labels`, which is exactly the + `Config.exitsCoveredByBlocks` of `.exiting l ρ''` for any ρ''. -/ +private theorem block_exit_mismatch_unfold {labels : List String} + {label : Option String} {σ_parent : SemanticStore P} {l : String} {ρ' ρ'' : Env P} + (h : Config.exitsCoveredByBlocks labels + (.block label σ_parent (.exiting l ρ' : Config P CmdT))) + (hne : label ≠ .some l) : + Config.exitsCoveredByBlocks labels (.exiting l ρ'' : Config P CmdT) := by + show l ∈ labels + cases label with + | none => exact h + | some lb => + have h' : l ∈ lb :: labels := h + rw [List.mem_cons] at h' + rcases h' with hh | hh + · exact absurd (by rw [hh]) hne + · exact hh + /-- A single step preserves `Config.exitsCoveredByBlocks`. -/ private theorem step_preserves_exitsCoveredByBlocks - (labels : List (Option String)) + (labels : List String) (c₁ c₂ : Config P CmdT) (hstep : StepStmt P EvalCmd extendEval c₁ c₂) (hwp : c₁.exitsCoveredByBlocks labels) : @@ -839,27 +880,21 @@ private theorem step_preserves_exitsCoveredByBlocks | step_ite_nondet_false => intro _ hwp; exact hwp.2 | step_loop_enter _ _ => intro labels hwp - -- Goal: (.block .none (.stmts (body ++ [.loop ...]) ρ')) covers labels - -- ↔ .stmts (body ++ [...]) covers (none :: labels). + -- Goal: .seq (.block .none ρ.store (.stmts body ρ')) [.loop ...] covers labels. + -- The .block .none label doesn't extend the labels list (Config.exitsCoveredByBlocks's + -- .block none case just descends). simp only [Config.exitsCoveredByBlocks, Stmt.exitsCoveredByBlocks] at hwp ⊢ - have hbody := (exitsCoveredByBlocks_weaken (P := P) (CmdT := CmdT) - labels (.none :: labels) (fun l hl => .tail _ hl)).2 _ hwp - exact block_exitsCoveredByBlocks_append (P := P) (CmdT := CmdT) (.none :: labels) _ _ - hbody ⟨hbody, True.intro⟩ + exact ⟨hwp, hwp, True.intro⟩ | step_loop_exit => intro _ _; trivial | step_loop_nondet_enter => intro labels hwp simp only [Config.exitsCoveredByBlocks, Stmt.exitsCoveredByBlocks] at hwp ⊢ - have hbody := (exitsCoveredByBlocks_weaken (P := P) (CmdT := CmdT) - labels (.none :: labels) (fun l hl => .tail _ hl)).2 _ hwp - exact block_exitsCoveredByBlocks_append (P := P) (CmdT := CmdT) (.none :: labels) _ _ - hbody ⟨hbody, True.intro⟩ + exact ⟨hwp, hwp, True.intro⟩ | step_loop_nondet_exit => intro _ _; trivial | step_exit => intro labels hwp - -- hwp is about .stmt (.exit lbl md) but goal is about .exiting lbl - -- Both pattern-match on the Option lbl; case split to reduce. - revert hwp; cases ‹Option String› <;> exact id + -- hwp : l ∈ labels (from .stmt (.exit l)), goal: .exiting (.some l) covers labels = l ∈ labels + exact hwp | step_funcDecl => intro _ _; trivial | step_typeDecl => intro _ _; trivial | step_stmts_nil => intro _ _; trivial @@ -867,14 +902,17 @@ private theorem step_preserves_exitsCoveredByBlocks | step_seq_inner _ ih => intro labels hwp; exact ⟨ih labels hwp.1, hwp.2⟩ | step_seq_done => intro _ hwp; exact hwp.2 | step_seq_exit => intro _ hwp; exact hwp.1 - | step_block_body _ ih => intro labels hwp; exact ih _ hwp + | step_block_body _ ih => + intro labels hwp + rename_i inner inner' label σ_parent _ + cases label with + | none => exact ih labels hwp + | some l => exact ih (l :: labels) hwp | step_block_done => intro _ _; trivial - | step_block_exit_none => intro _ _; trivial | step_block_exit_match => intro _ _; trivial | step_block_exit_mismatch hne => intro labels hwp - simp only [Config.exitsCoveredByBlocks, List.mem_cons] at hwp ⊢ - exact hwp.resolve_left (fun h => hne (h ▸ rfl)) + exact block_exit_mismatch_unfold (P := P) (CmdT := CmdT) hwp hne /-- Well-paired statements cannot escape via `.exiting`: if all exits in `s` are caught by enclosing blocks @@ -882,21 +920,17 @@ private theorem step_preserves_exitsCoveredByBlocks theorem exitsCoveredByBlocks_noEscape (s : Stmt P CmdT) (hwp : s.exitsCoveredByBlocks []) : - ∀ (ρ : Env P) (lbl : Option String) (ρ' : Env P), + ∀ (ρ : Env P) (lbl : String) (ρ' : Env P), ¬ StepStmtStar P EvalCmd extendEval (.stmt s ρ) (.exiting lbl ρ') := by intro ρ lbl ρ' hstar -- Prove Config.exitsCoveredByBlocks [] is preserved, then show .exiting contradicts it. suffices ∀ c₁ c₂, - c₁.exitsCoveredByBlocks ([] : List (Option String)) → + c₁.exitsCoveredByBlocks ([] : List String) → StepStmtStar P EvalCmd extendEval c₁ c₂ → - c₂.exitsCoveredByBlocks ([] : List (Option String)) by + c₂.exitsCoveredByBlocks ([] : List String) by have hwp' := this _ _ (show Config.exitsCoveredByBlocks [] (.stmt s ρ) from hwp) hstar - -- Config.exitsCoveredByBlocks [] (.exiting lbl ρ') requires: - -- lbl = none → [].length > 0 (False) - -- lbl = some l → l ∈ [] (False) - cases lbl with - | none => exact absurd hwp' (by simp [Config.exitsCoveredByBlocks]) - | some l => exact absurd hwp' (by simp [Config.exitsCoveredByBlocks]) + -- Config.exitsCoveredByBlocks [] (.exiting lbl ρ') requires lbl ∈ [] (False). + exact absurd hwp' (by simp [Config.exitsCoveredByBlocks]) intro c₁ c₂ hwp_c hstar_c induction hstar_c with | refl => exact hwp_c @@ -909,17 +943,15 @@ theorem exitsCoveredByBlocks_noEscape theorem block_exitsCoveredByBlocks_noEscape (bss : List (Stmt P CmdT)) (hwp : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks [] bss) : - ∀ (ρ : Env P) (lbl : Option String) (ρ' : Env P), + ∀ (ρ : Env P) (lbl : String) (ρ' : Env P), ¬ StepStmtStar P EvalCmd extendEval (.stmts bss ρ) (.exiting lbl ρ') := by intro ρ lbl ρ' hstar suffices ∀ c₁ c₂, - c₁.exitsCoveredByBlocks ([] : List (Option String)) → + c₁.exitsCoveredByBlocks ([] : List String) → StepStmtStar P EvalCmd extendEval c₁ c₂ → - c₂.exitsCoveredByBlocks ([] : List (Option String)) by + c₂.exitsCoveredByBlocks ([] : List String) by have hwp' := this _ _ (show Config.exitsCoveredByBlocks [] (.stmts bss ρ) from hwp) hstar - cases lbl with - | none => exact absurd hwp' (by simp [Config.exitsCoveredByBlocks]) - | some l => exact absurd hwp' (by simp [Config.exitsCoveredByBlocks]) + exact absurd hwp' (by simp [Config.exitsCoveredByBlocks]) intro c₁ c₂ hwp_c hstar_c induction hstar_c with | refl => exact hwp_c @@ -930,20 +962,20 @@ theorem block_exitsCoveredByBlocks_noEscape and `cfg` is neither terminal nor exiting, then `cfg = .block l inner'` for some `inner'` with `inner →* inner'`. -/ theorem block_star_extract_inner - {l : Option String} {inner cfg : Config P CmdT} - (h_star : StepStmtStar P EvalCmd extendEval (.block l inner) cfg) + {l : Option String} {σ_parent : SemanticStore P} {inner cfg : Config P CmdT} + (h_star : StepStmtStar P EvalCmd extendEval (.block l σ_parent inner) cfg) (h_no_exit : ∀ lbl ρ', ¬ StepStmtStar P EvalCmd extendEval inner (.exiting lbl ρ')) (h_not_terminal : ∀ ρ', cfg ≠ .terminal ρ') (h_not_exiting : ∀ lbl ρ', cfg ≠ .exiting lbl ρ') : - ∃ inner', cfg = .block l inner' ∧ + ∃ inner', cfg = .block l σ_parent inner' ∧ StepStmtStar P EvalCmd extendEval inner inner' := by suffices ∀ c₁ c₂, StepStmtStar P EvalCmd extendEval c₁ c₂ → - ∀ inner₀, c₁ = .block l inner₀ → + ∀ inner₀, c₁ = .block l σ_parent inner₀ → (∀ lbl ρ', ¬ StepStmtStar P EvalCmd extendEval inner₀ (.exiting lbl ρ')) → (∀ ρ', c₂ ≠ .terminal ρ') → (∀ lbl ρ', c₂ ≠ .exiting lbl ρ') → - ∃ inner', c₂ = .block l inner' ∧ + ∃ inner', c₂ = .block l σ_parent inner' ∧ StepStmtStar P EvalCmd extendEval inner₀ inner' from this _ _ h_star _ rfl h_no_exit h_not_terminal h_not_exiting intro c₁ c₂ h_star @@ -961,7 +993,6 @@ theorem block_star_extract_inner cases hrest with | refl => exact absurd rfl (h_nt _) | step _ _ _ h _ => exact nomatch h - | step_block_exit_none => exact absurd (.refl _) (h_ne _ _) | step_block_exit_match => exact absurd (.refl _) (h_ne _ _) | step_block_exit_mismatch => exact absurd (.refl _) (h_ne _ _) @@ -1003,38 +1034,20 @@ private theorem step_preserves_eval_noFuncDecl exact ⟨rfl, hnofd.2⟩ | step_loop_enter => intro hnofd - refine ⟨rfl, ?_⟩ - simp only [Config.noFuncDecl, Stmt.noFuncDecl] at hnofd ⊢ - -- Need: Block.noFuncDecl (body ++ [loop]) from Block.noFuncDecl body - have h_append : ∀ (ss₁ ss₂ : List (Stmt P CmdT)), - Block.noFuncDecl ss₁ = true → Block.noFuncDecl ss₂ = true → - Block.noFuncDecl (ss₁ ++ ss₂) = true := by - intro ss₁; induction ss₁ with - | nil => intro _ _ h; exact h - | cons s ss ih => - intro ss₂ h₁ h₂ - simp only [Block.noFuncDecl] at h₁ ⊢ - cases hs : Stmt.noFuncDecl s - · simp [hs] at h₁ - · simp_all [Block.noFuncDecl] - exact h_append _ _ hnofd (by simp [Block.noFuncDecl, Stmt.noFuncDecl, hnofd]) + refine ⟨rfl, ?_, ?_⟩ + · -- Goal: inner Config has noFuncDecl + simp only [Config.noFuncDecl, Stmt.noFuncDecl] at hnofd ⊢ + exact hnofd + · -- Goal: rest = [loop ...] has Block.noFuncDecl + simp only [Config.noFuncDecl, Stmt.noFuncDecl] at hnofd ⊢ + simp [Block.noFuncDecl, Stmt.noFuncDecl, hnofd] | step_loop_exit => intro _; exact ⟨rfl, trivial⟩ | step_loop_nondet_enter => intro hnofd - refine ⟨rfl, ?_⟩ - simp only [Config.noFuncDecl, Stmt.noFuncDecl] at hnofd ⊢ - have h_append : ∀ (ss₁ ss₂ : List (Stmt P CmdT)), - Block.noFuncDecl ss₁ = true → Block.noFuncDecl ss₂ = true → - Block.noFuncDecl (ss₁ ++ ss₂) = true := by - intro ss₁; induction ss₁ with - | nil => intro _ _ h; exact h - | cons s ss ih => - intro ss₂ h₁ h₂ - simp only [Block.noFuncDecl] at h₁ ⊢ - cases hs : Stmt.noFuncDecl s - · simp [hs] at h₁ - · simp_all [Block.noFuncDecl] - exact h_append _ _ hnofd (by simp [Block.noFuncDecl, Stmt.noFuncDecl, hnofd]) + refine ⟨rfl, ?_, ?_⟩ + · simp only [Config.noFuncDecl, Stmt.noFuncDecl] at hnofd ⊢; exact hnofd + · simp only [Config.noFuncDecl, Stmt.noFuncDecl] at hnofd ⊢ + simp [Block.noFuncDecl, Stmt.noFuncDecl, hnofd] | step_loop_nondet_exit => intro _; exact ⟨rfl, trivial⟩ | step_exit => intro _; exact ⟨rfl, trivial⟩ | step_funcDecl => @@ -1054,7 +1067,6 @@ private theorem step_preserves_eval_noFuncDecl | step_seq_exit => intro _; exact ⟨rfl, trivial⟩ | step_block_body _ ih => intro hnofd; exact ih hnofd | step_block_done => intro _; exact ⟨rfl, trivial⟩ - | step_block_exit_none => intro _; exact ⟨rfl, trivial⟩ | step_block_exit_match => intro _; exact ⟨rfl, trivial⟩ | step_block_exit_mismatch => intro _; exact ⟨rfl, trivial⟩ @@ -1134,7 +1146,7 @@ structure AssertId where aid.label = label ∧ aid.expr = expr | .stmt (.loop _ _ inv _ _) _, aid => (aid.label, aid.expr) ∈ inv | .stmts ((.loop _ _ inv _ _) :: _) _, aid => (aid.label, aid.expr) ∈ inv - | .block _ inner, aid => isAtAssert inner aid + | .block _ _ inner, aid => isAtAssert inner aid | .seq inner _, aid => isAtAssert inner aid | _, _ => False @@ -1175,7 +1187,7 @@ private theorem noMatchingAssert_not_isAtAssert intro hat exact hno.1.1 label expr hat rfl | .terminal _ | .exiting _ _ => simp [isAtAssert] - | .block _ inner => exact noMatchingAssert_not_isAtAssert inner label expr hno + | .block _ _ inner => exact noMatchingAssert_not_isAtAssert inner label expr hno | .seq inner _ => exact noMatchingAssert_not_isAtAssert inner label expr hno.1 omit [HasFvar P] [HasBool P] [HasNot P] in @@ -1204,16 +1216,14 @@ private def step_preserves_noMatchingAssert | step_ite_nondet_true => exact hno.1 | step_ite_nondet_false => exact hno.2 | step_loop_enter => + -- New shape: .seq (.block .none ρ.store (.stmts body ρ')) [loop] + -- noMatchingAssert: inner covers, AND [loop] covers. simp only [Config.noMatchingAssert, Stmt.noMatchingAssert] at hno ⊢ - apply stmts_noMatchingAssert_append - · exact hno.2 - · exact ⟨hno, True.intro⟩ + exact ⟨hno.2, hno, True.intro⟩ | step_loop_exit => trivial | step_loop_nondet_enter => simp only [Config.noMatchingAssert, Stmt.noMatchingAssert] at hno ⊢ - apply stmts_noMatchingAssert_append - · exact hno.2 - · exact ⟨hno, True.intro⟩ + exact ⟨hno.2, hno, True.intro⟩ | step_loop_nondet_exit => trivial | step_exit => trivial | step_funcDecl => trivial @@ -1230,7 +1240,6 @@ private def step_preserves_noMatchingAssert have := step_preserves_noMatchingAssert (c₁ := _) (c₂ := _) (label := _) h hno exact this | step_block_done => trivial - | step_block_exit_none => trivial | step_block_exit_match => trivial | step_block_exit_mismatch => trivial @@ -1261,13 +1270,13 @@ theorem noMatchingAssert_implies_no_reachable_assert then the config must be `.block label inner` where `inner` is reachable from the block's body and satisfies `isAtAssert`. -/ theorem block_isAtAssert_inner - (label : String) (inner₀ cfg : Config P (Cmd P)) (a : AssertId P) - (hstar : StepStmtStar P (EvalCmd P) extendEval (.block label inner₀) cfg) + (label : String) (σ_parent : SemanticStore P) (inner₀ cfg : Config P (Cmd P)) (a : AssertId P) + (hstar : StepStmtStar P (EvalCmd P) extendEval (.block label σ_parent inner₀) cfg) (hat : isAtAssert P cfg a) : - ∃ inner, cfg = .block label inner ∧ + ∃ inner, cfg = .block label σ_parent inner ∧ StepStmtStar P (EvalCmd P) extendEval inner₀ inner ∧ isAtAssert P inner a := by - generalize hsrc : Config.block label inner₀ = src at hstar + generalize hsrc : Config.block label σ_parent inner₀ = src at hstar induction hstar generalizing inner₀ with | refl => subst hsrc; exact ⟨inner₀, rfl, .refl _, hat⟩ | step _ mid _ hstep hrest ih => @@ -1278,9 +1287,6 @@ theorem block_isAtAssert_inner | step_block_done => cases hrest with | refl => exact absurd hat (by simp [isAtAssert]) | step _ _ _ h _ => exact absurd h (by intro h; cases h) - | step_block_exit_none => cases hrest with - | refl => exact absurd hat (by simp [isAtAssert]) - | step _ _ _ h _ => exact absurd h (by intro h; cases h) | step_block_exit_match => cases hrest with | refl => exact absurd hat (by simp [isAtAssert]) | step _ _ _ h _ => exact absurd h (by intro h; cases h) @@ -1412,8 +1418,8 @@ theorem step_preserves_noFailure IsAtAssert (.stmt (.loop g m inv body md) ρ) ⟨lbl, e⟩) (h_IsAtAssert_seq : ∀ {inner ss a}, IsAtAssert inner a → IsAtAssert (.seq inner ss) a) - (h_IsAtAssert_block : ∀ {label inner a}, - IsAtAssert inner a → IsAtAssert (.block label inner) a) + (h_IsAtAssert_block : ∀ {label σ_parent inner a}, + IsAtAssert inner a → IsAtAssert (.block label σ_parent inner) a) (c₁ c₂ : Config P CmdT) (hv : ∀ a cfg, StepStmtStar P EvalCmd extendEval c₁ cfg → IsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt) @@ -1448,7 +1454,7 @@ theorem step_preserves_noFailure | step_block_body h ih => exact ih (fun a cfg hr hat => - hv a (.block _ cfg) (block_inner_star P EvalCmd extendEval _ _ _ hr) (h_IsAtAssert_block hat)) hnf + hv a (.block _ _ cfg) (block_inner_star P EvalCmd extendEval _ _ _ _ hr) (h_IsAtAssert_block hat)) hnf | _ => intros; exact hnf theorem allAssertsValid_preserves_noFailure diff --git a/Strata/Languages/Boole/Verify.lean b/Strata/Languages/Boole/Verify.lean index d219d96c50..8e21563365 100644 --- a/Strata/Languages/Boole/Verify.lean +++ b/Strata/Languages/Boole/Verify.lean @@ -540,8 +540,6 @@ def toCoreStmt (s : BooleDDM.Statement SourceRange) : TranslateM Core.Statement return .block l (← withBVars [] (toCoreBlock b)) (← toCoreMetaData m) | .exit_statement m ⟨_, l⟩ => return .exit l (← toCoreMetaData m) - | .exit_unlabeled_statement m => - return .exit none (← toCoreMetaData m) | .typeDecl_statement m ⟨_, n⟩ ⟨_, args?⟩ => let params := match args? with | none => [] diff --git a/Strata/Languages/Core/DDMTransform/FormatCore.lean b/Strata/Languages/Core/DDMTransform/FormatCore.lean index 639c5f355f..0af86ae9b8 100644 --- a/Strata/Languages/Core/DDMTransform/FormatCore.lean +++ b/Strata/Languages/Core/DDMTransform/FormatCore.lean @@ -828,12 +828,8 @@ partial def stmtToCST {M} [Inhabited M] (s : Core.Statement) | .nondet => pure (.while_statement default (.condNondet default) measureCST invs bodyCST) | .exit label _md => do - match label with - | some l => - let labelAnn : Ann String M := ⟨default, l⟩ - pure (.exit_statement default labelAnn) - | none => - pure (.exit_unlabeled_statement default) + let labelAnn : Ann String M := ⟨default, label⟩ + pure (.exit_statement default labelAnn) | .funcDecl decl _md => funcDeclToStatement decl | .typeDecl tc _md => let nameAnn : Ann String M := ⟨default, tc.name⟩ diff --git a/Strata/Languages/Core/DDMTransform/Grammar.lean b/Strata/Languages/Core/DDMTransform/Grammar.lean index fe27348ebc..206b72e7d5 100644 --- a/Strata/Languages/Core/DDMTransform/Grammar.lean +++ b/Strata/Languages/Core/DDMTransform/Grammar.lean @@ -289,7 +289,6 @@ op call_statement (f : Ident, args : CommaSepBy CallArg) : Statement => op block (c : NewlineSepBy Statement) : Block => "{\n " indent(2, c) "\n}"; op block_statement (label : Ident, b : Block) : Statement => label ": " b:0; op exit_statement (label : Ident) : Statement => "exit " label ";"; -op exit_unlabeled_statement : Statement => "exit;"; category SpecElt; category Free; diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index 7461355762..9e6ed5a8f8 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -1335,10 +1335,7 @@ partial def translateStmt (p : Program) (bindings : TransBindings) (arg : Arg) : | q`Core.exit_statement, #[la] => let l ← translateIdent String la let md ← getOpMetaData op - return ([.exit (some l) md], bindings) - | q`Core.exit_unlabeled_statement, #[] => - let md ← getOpMetaData op - return ([.exit none md], bindings) + return ([.exit l md], bindings) | q`Core.funcDecl_statement, #[namea, _typeArgsa, bindingsa, returna, precondsa, bodya, _inlinea] => let name ← translateIdent Core.CoreIdent namea let inputs ← translateMonoDeclList bindings bindingsa diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 154711b3c4..90b00cce92 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -351,7 +351,7 @@ instance : HasVarsProcTrans Expression Procedure where modifiedVarsTrans := Procedure.modifiedVarsTrans getVarsTrans := Procedure.getVarsTrans definedVarsTrans := λ _ _ ↦ [] -- procedures cannot define global variables - touchedVarsTrans := Procedure.modifiedVarsTrans + modifiedOrDefinedVarsTrans := Procedure.modifiedVarsTrans allVarsTrans := λ π p ↦ Procedure.getVarsTrans π p ++ Procedure.modifiedVarsTrans π p @@ -360,14 +360,14 @@ instance : HasVarsTrans Expression Statement Procedure where modifiedVarsTrans := Statement.modifiedVarsTrans getVarsTrans := Statement.getVarsTrans definedVarsTrans := Statement.definedVarsTrans - touchedVarsTrans := Statement.touchedVarsTrans + modifiedOrDefinedVarsTrans := Statement.modifiedOrDefinedVarsTrans allVarsTrans := Statement.allVarsTrans instance : HasVarsTrans Expression (List Statement) Procedure where modifiedVarsTrans := Statements.modifiedVarsTrans getVarsTrans := Statements.getVarsTrans definedVarsTrans := Statements.definedVarsTrans - touchedVarsTrans := Statements.touchedVarsTrans + modifiedOrDefinedVarsTrans := Statements.modifiedOrDefinedVarsTrans allVarsTrans := Statements.allVarsTrans end diff --git a/Strata/Languages/Core/Statement.lean b/Strata/Languages/Core/Statement.lean index 31a0dc97e4..d221db67d6 100644 --- a/Strata/Languages/Core/Statement.lean +++ b/Strata/Languages/Core/Statement.lean @@ -215,24 +215,24 @@ def Command.modifiedVars (c : Command) : List Expression.Ident := | .cmd c => c.modifiedVars | .call _ args _ => CallArg.getLhs args -def Command.touchedVars (c : Command) : List Expression.Ident := +def Command.modifiedOrDefinedVars (c : Command) : List Expression.Ident := Command.definedVars c ++ Command.modifiedVars c instance : HasVarsImp Expression Command where definedVars := Command.definedVars modifiedVars := Command.modifiedVars - touchedVars := Command.touchedVars + modifiedOrDefinedVars := Command.modifiedOrDefinedVars instance : HasVarsImp Expression Statement where definedVars := Stmt.definedVars modifiedVars := Stmt.modifiedVars - touchedVars := Stmt.touchedVars + modifiedOrDefinedVars := Stmt.modifiedOrDefinedVars instance : HasVarsImp Expression (List Statement) where definedVars := Block.definedVars modifiedVars := Block.modifiedVars -- order matters for Havoc, so needs to override the default - touchedVars := Block.touchedVars + modifiedOrDefinedVars := Block.modifiedOrDefinedVars --------------------------------------------------------------------- @@ -339,8 +339,8 @@ def Statements.definedVarsTrans Block.definedVars s mutual -/-- get all variables touched by the statement `s`. -/ -def Statement.touchedVarsTrans +/-- get all variables modified or defined by the statement `s` (write-set, transitive). -/ +def Statement.modifiedOrDefinedVarsTrans {ProcType : Type} [HasVarsProcTrans Expression ProcType] (π : String → Option ProcType) (s : Statement) @@ -348,26 +348,26 @@ def Statement.touchedVarsTrans match s with | .cmd cmd => Command.definedVarsTrans π cmd ++ Command.modifiedVarsTrans π cmd | .exit _ _ => [] - | .block _ bss _ => Statements.touchedVarsTrans π bss - | .ite _ tbss ebss _ => Statements.touchedVarsTrans π tbss ++ Statements.touchedVarsTrans π ebss - | .loop _ _ _ bss _ => Statements.touchedVarsTrans π bss + | .block _ bss _ => Statements.modifiedOrDefinedVarsTrans π bss + | .ite _ tbss ebss _ => Statements.modifiedOrDefinedVarsTrans π tbss ++ Statements.modifiedOrDefinedVarsTrans π ebss + | .loop _ _ _ bss _ => Statements.modifiedOrDefinedVarsTrans π bss | .funcDecl decl _ => [decl.name] -- Function declaration touches (defines) the function name | .typeDecl _ _ => [] -- Type declarations don't touch variables -def Statements.touchedVarsTrans +def Statements.modifiedOrDefinedVarsTrans {ProcType : Type} [HasVarsProcTrans Expression ProcType] (π : String → Option ProcType) (ss : Statements) : List Expression.Ident := match ss with | [] => [] - | s :: srest => Statement.touchedVarsTrans π s ++ Statements.touchedVarsTrans π srest + | s :: srest => Statement.modifiedOrDefinedVarsTrans π s ++ Statements.modifiedOrDefinedVarsTrans π srest end def Statement.allVarsTrans [HasVarsProcTrans Expression ProcType] (π : String → Option ProcType) (s : Statement) := - Statement.getVarsTrans π s ++ Statement.touchedVarsTrans π s + Statement.getVarsTrans π s ++ Statement.modifiedOrDefinedVarsTrans π s def Statements.allVarsTrans [HasVarsProcTrans Expression ProcType] diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 513a72a11f..233cffd42d 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -375,7 +375,7 @@ def withOldBindings aid.label = label ∧ aid.expr = expr | .stmt (.loop _ _ inv _ _) _, aid => (aid.label, aid.expr) ∈ inv | .stmts ((.loop _ _ inv _ _) :: _) _, aid => (aid.label, aid.expr) ∈ inv - | .block _ inner, aid => coreIsAtAssert inner aid + | .block _ _ inner, aid => coreIsAtAssert inner aid | .seq inner _, aid => coreIsAtAssert inner aid | _, _ => False @@ -390,6 +390,13 @@ def withOldBindings structure WFEvalExtension (φ : CoreEval → Imperative.PureFunc Expression → CoreEval) : Prop where preserves_wfBool : ∀ δ σ decl, Imperative.WellFormedSemanticEvalBool δ → Imperative.WellFormedSemanticEvalBool (EvalPureFunc φ δ σ decl) + preserves_wfVar : ∀ δ σ decl, Imperative.WellFormedSemanticEvalVar δ → + Imperative.WellFormedSemanticEvalVar (EvalPureFunc φ δ σ decl) + preserves_wfCong : ∀ δ σ decl, WellFormedCoreEvalCong δ → + WellFormedCoreEvalCong (EvalPureFunc φ δ σ decl) + preserves_wfExprCongr : ∀ δ σ decl, + @Imperative.WellFormedSemanticEvalExprCongr Expression _ δ → + @Imperative.WellFormedSemanticEvalExprCongr Expression _ (EvalPureFunc φ δ σ decl) --------------------------------------------------------------------- diff --git a/Strata/Languages/Core/StatementSemanticsProps.lean b/Strata/Languages/Core/StatementSemanticsProps.lean index c0d6e51ed2..273ad23d60 100644 --- a/Strata/Languages/Core/StatementSemanticsProps.lean +++ b/Strata/Languages/Core/StatementSemanticsProps.lean @@ -1762,9 +1762,9 @@ theorem EvalCmdDefMonotone' : theorem EvalCmdTouch [HasVal P] [HasFvar P] [HasBool P] [HasBoolVal P] [HasNot P] : EvalCmd P δ σ c σ' f → - TouchVars σ (HasVarsImp.touchedVars c) σ' := by + TouchVars σ (HasVarsImp.modifiedOrDefinedVars c) σ' := by intro Heval - induction Heval <;> simp [HasVarsImp.touchedVars, Cmd.definedVars, Cmd.modifiedVars] + induction Heval <;> simp [HasVarsImp.modifiedOrDefinedVars, Cmd.definedVars, Cmd.modifiedVars] case eval_init x' δ σ x v σ' σ₀ e Hsm Hup Hwf => apply TouchVars.init_some Hup constructor @@ -2211,10 +2211,10 @@ theorem CoreStepStar_rec CoreStepStar π φ c₂ c₃ → motive c₂ c₃ → motive c₁ c₃) {c₁ c₂ : CoreConfig} (h : CoreStepStar π φ c₁ c₂) : motive c₁ c₂ := by - suffices ∀ c₁ c₂, + suffices h_gen : ∀ c₁ c₂, Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → motive c₁ c₂ by - exact this _ _ (CoreStepStar_to_StepStmtStar h) + exact h_gen _ _ (CoreStepStar_to_StepStmtStar h) intro c₁ c₂ h' induction h' with | refl => exact h_refl _ @@ -2249,11 +2249,11 @@ theorem core_seq_inner_star theorem core_block_inner_star {π : String → Option Procedure} {φ : CoreEval → PureFunc Expression → CoreEval} - (inner inner' : CoreConfig) (label : Option String) + (inner inner' : CoreConfig) (label : Option String) (σ_parent : SemanticStore Expression) (h : CoreStepStar π φ inner inner') : - CoreStepStar π φ (.block label inner) (.block label inner') := + CoreStepStar π φ (.block label σ_parent inner) (.block label σ_parent inner') := StepStmtStar_to_CoreStepStar - (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) inner inner' label + (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) inner inner' label σ_parent (CoreStepStar_to_StepStmtStar h)) /-- Lift `seq_reaches_terminal` from `StepStmtStar` to `CoreStepStar`. -/ @@ -2282,33 +2282,13 @@ theorem core_step_preserves_wfBool (hstep : CoreStep π φ c₁ c₂) : WellFormedSemanticEvalBool c₂.getEnv.eval := by induction hstep with - | step_cmd hcmd => - cases hcmd with - | cmd_sem _ => simp [Config.getEnv]; exact hwf - | @call_sem _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => - simp only [Config.getEnv]; exact hwf + | step_cmd hcmd => cases hcmd with + | cmd_sem _ | call_sem _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => + simp [Config.getEnv]; exact hwf | step_block => simp [Config.getEnv]; exact hwf - | step_ite_true _ _ => exact hwf - | step_ite_false _ _ => exact hwf - | step_loop_enter _ _ => exact hwf - | step_loop_exit _ _ => exact hwf - | step_ite_nondet_true => exact hwf - | step_ite_nondet_false => exact hwf - | step_loop_nondet_enter => exact hwf - | step_loop_nondet_exit => exact hwf - | step_exit => exact hwf | step_funcDecl => simp [Config.getEnv]; exact h_wf_ext.preserves_wfBool _ _ _ hwf - | step_typeDecl => exact hwf - | step_stmts_nil => exact hwf - | step_stmts_cons => exact hwf - | step_seq_inner _ ih => exact ih hwf - | step_seq_done => exact hwf - | step_seq_exit => exact hwf - | step_block_body _ ih => exact ih hwf - | step_block_done => exact hwf - | step_block_exit_none => exact hwf - | step_block_exit_match _ => exact hwf - | step_block_exit_mismatch _ => exact hwf + | step_seq_inner _ ih | step_block_body _ ih => exact ih hwf + | _ => exact hwf theorem core_wfBool_preserved (h_wf_ext : WFEvalExtension φ) @@ -2316,16 +2296,134 @@ theorem core_wfBool_preserved (hwf₀ : WellFormedSemanticEvalBool c₁.getEnv.eval) (hstar : CoreStepStar π φ c₁ c₂) : WellFormedSemanticEvalBool c₂.getEnv.eval := by - suffices ∀ c₁ c₂, WellFormedSemanticEvalBool c₁.getEnv.eval → + suffices h_gen : ∀ c₁ c₂, WellFormedSemanticEvalBool c₁.getEnv.eval → Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → WellFormedSemanticEvalBool c₂.getEnv.eval from - this c₁ c₂ hwf₀ (CoreStepStar_to_StepStmtStar hstar) + h_gen c₁ c₂ hwf₀ (CoreStepStar_to_StepStmtStar hstar) intro c₁ c₂ hwf₀ h induction h with | refl => exact hwf₀ | step _ _ _ hstep _ ih => exact ih (core_step_preserves_wfBool π φ h_wf_ext _ _ hwf₀ hstep) +theorem core_step_preserves_wfVar + (h_wf_ext : WFEvalExtension φ) + (c₁ c₂ : CoreConfig) + (hwf : WellFormedSemanticEvalVar c₁.getEnv.eval) + (hstep : CoreStep π φ c₁ c₂) : + WellFormedSemanticEvalVar c₂.getEnv.eval := by + induction hstep with + | step_cmd hcmd => cases hcmd with + | cmd_sem _ | call_sem _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => + simp [Config.getEnv]; exact hwf + | step_block => simp [Config.getEnv]; exact hwf + | step_funcDecl => simp [Config.getEnv]; exact h_wf_ext.preserves_wfVar _ _ _ hwf + | step_seq_inner _ ih | step_block_body _ ih => exact ih hwf + | _ => exact hwf + +theorem core_wfVar_preserved + (h_wf_ext : WFEvalExtension φ) + (c₁ c₂ : CoreConfig) + (hwf₀ : WellFormedSemanticEvalVar c₁.getEnv.eval) + (hstar : CoreStepStar π φ c₁ c₂) : + WellFormedSemanticEvalVar c₂.getEnv.eval := by + suffices h_gen : ∀ c₁ c₂, WellFormedSemanticEvalVar c₁.getEnv.eval → + Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → + WellFormedSemanticEvalVar c₂.getEnv.eval from + h_gen c₁ c₂ hwf₀ (CoreStepStar_to_StepStmtStar hstar) + intro c₁ c₂ hwf₀ h + induction h with + | refl => exact hwf₀ + | step _ _ _ hstep _ ih => + exact ih (core_step_preserves_wfVar π φ h_wf_ext _ _ hwf₀ hstep) + +theorem core_step_preserves_wfCong + (h_wf_ext : WFEvalExtension φ) + (c₁ c₂ : CoreConfig) + (hwf : WellFormedCoreEvalCong c₁.getEnv.eval) + (hstep : CoreStep π φ c₁ c₂) : + WellFormedCoreEvalCong c₂.getEnv.eval := by + induction hstep with + | step_cmd hcmd => cases hcmd with + | cmd_sem _ | call_sem _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => + simp [Config.getEnv]; exact hwf + | step_block => simp [Config.getEnv]; exact hwf + | step_funcDecl => simp [Config.getEnv]; exact h_wf_ext.preserves_wfCong _ _ _ hwf + | step_seq_inner _ ih | step_block_body _ ih => exact ih hwf + | _ => exact hwf + +theorem core_wfCong_preserved + (h_wf_ext : WFEvalExtension φ) + (c₁ c₂ : CoreConfig) + (hwf₀ : WellFormedCoreEvalCong c₁.getEnv.eval) + (hstar : CoreStepStar π φ c₁ c₂) : + WellFormedCoreEvalCong c₂.getEnv.eval := by + suffices h_gen : ∀ c₁ c₂, WellFormedCoreEvalCong c₁.getEnv.eval → + Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → + WellFormedCoreEvalCong c₂.getEnv.eval from + h_gen c₁ c₂ hwf₀ (CoreStepStar_to_StepStmtStar hstar) + intro c₁ c₂ hwf₀ h + induction h with + | refl => exact hwf₀ + | step _ _ _ hstep _ ih => + exact ih (core_step_preserves_wfCong π φ h_wf_ext _ _ hwf₀ hstep) + +theorem core_step_preserves_wfExprCongr + (h_wf_ext : WFEvalExtension φ) + (c₁ c₂ : CoreConfig) + (hwf : @Imperative.WellFormedSemanticEvalExprCongr Expression _ c₁.getEnv.eval) + (hstep : CoreStep π φ c₁ c₂) : + @Imperative.WellFormedSemanticEvalExprCongr Expression _ c₂.getEnv.eval := by + induction hstep with + | step_cmd hcmd => cases hcmd with + | cmd_sem _ | call_sem _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => + simp [Config.getEnv]; exact hwf + | step_block => simp [Config.getEnv]; exact hwf + | step_funcDecl => simp [Config.getEnv]; exact h_wf_ext.preserves_wfExprCongr _ _ _ hwf + | step_seq_inner _ ih | step_block_body _ ih => exact ih hwf + | _ => exact hwf + +theorem core_wfExprCongr_preserved + (h_wf_ext : WFEvalExtension φ) + (c₁ c₂ : CoreConfig) + (hwf₀ : @Imperative.WellFormedSemanticEvalExprCongr Expression _ c₁.getEnv.eval) + (hstar : CoreStepStar π φ c₁ c₂) : + @Imperative.WellFormedSemanticEvalExprCongr Expression _ c₂.getEnv.eval := by + suffices h_gen : ∀ c₁ c₂, + @Imperative.WellFormedSemanticEvalExprCongr Expression _ c₁.getEnv.eval → + Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → + @Imperative.WellFormedSemanticEvalExprCongr Expression _ c₂.getEnv.eval from + h_gen c₁ c₂ hwf₀ (CoreStepStar_to_StepStmtStar hstar) + intro c₁ c₂ hwf₀ h + induction h with + | refl => exact hwf₀ + | step _ _ _ hstep _ ih => + exact ih (core_step_preserves_wfExprCongr π φ h_wf_ext _ _ hwf₀ hstep) + +/-! ## projectStore and expression evaluation -/ + +/-- If an expression evaluates in the projected store, it evaluates identically + in the full store. The projected store only removes variables, and expression + evaluation depends only on the variables it references. -/ +theorem eval_projectStore_to_full + {δ : CoreEval} {σ₀ σ : SemanticStore Expression} + {e : Expression.Expr} {v : Expression.Expr} + (h_eval : δ (projectStore σ₀ σ) e = some v) + (h_wfVar : WellFormedSemanticEvalVar δ) + (h_wfCong : WellFormedCoreEvalCong δ) + (h_wfExprCongr : WellFormedSemanticEvalExprCongr δ) : + δ σ e = some v := by + have h_def := EvalExpressionIsDefined h_wfCong h_wfVar + (show (δ (projectStore σ₀ σ) e).isSome from by rw [h_eval]; simp) + have h_agree : ∀ x ∈ HasVarsPure.getVars e, (projectStore σ₀ σ) x = σ x := by + intro x hx + have h_x_def : (projectStore σ₀ σ x).isSome = true := h_def x hx + simp only [projectStore] at h_x_def ⊢ + split + · rfl + · next h_neg => simp [h_neg] at h_x_def + rw [← h_wfExprCongr e (projectStore σ₀ σ) σ h_agree]; exact h_eval + /-! ## Assert-only blocks preserve store -/ theorem stmts_allAssert_preserves_store @@ -2348,12 +2446,12 @@ theorem stmts_allAssert_preserves_store | step_stmts_cons => have ⟨ρ₁, h_s, h_r⟩ := core_seq_reaches_terminal h_rest have h_store₁ : ρ₁.store = ρ.store := by - suffices ∀ (c₁ c₂ : CoreConfig), + suffices h_gen : ∀ (c₁ c₂ : CoreConfig), CoreStepStar π φ c₁ c₂ → c₁ = .stmt (Statement.assert l e md) ρ → c₂ = .terminal ρ₁ → ρ₁.store = ρ.store by - exact this _ _ h_s rfl rfl + exact h_gen _ _ h_s rfl rfl intro c₁ c₂ hstar heq₁ heq₂ subst heq₁ cases hstar with @@ -2391,8 +2489,8 @@ private theorem coreIsAtAssert_seq_of_inner (h : coreIsAtAssert inner a) : coreIsAtAssert (.seq inner ss) a := h private theorem coreIsAtAssert_block_of_inner - {label} {inner : CoreConfig} {a} - (h : coreIsAtAssert inner a) : coreIsAtAssert (.block label inner) a := h + {label} {σ_parent} {inner : CoreConfig} {a} + (h : coreIsAtAssert inner a) : coreIsAtAssert (.block label σ_parent inner) a := h private theorem evalCommand_failure_implies_assert_ff {π : String → Option Procedure} {φ : CoreEval → PureFunc Expression → CoreEval} @@ -2415,7 +2513,7 @@ theorem core_noFailure_preserved (hf₀ : c₁.getEnv.hasFailure = Bool.false) (hstar : CoreStepStar π φ c₁ c₂) : c₂.getEnv.hasFailure = Bool.false := by - suffices ∀ c₁ c₂, + suffices h_gen : ∀ c₁ c₂, (∀ (a : AssertId Expression) (cfg : CoreConfig), CoreStepStar π φ c₁ cfg → coreIsAtAssert cfg a → @@ -2423,7 +2521,7 @@ theorem core_noFailure_preserved c₁.getEnv.hasFailure = Bool.false → Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) c₁ c₂ → c₂.getEnv.hasFailure = Bool.false from - this c₁ c₂ hvalid hf₀ (CoreStepStar_to_StepStmtStar hstar) + h_gen c₁ c₂ hvalid hf₀ (CoreStepStar_to_StepStmtStar hstar) intro c₁ c₂ hvalid hf₀ h induction h with | refl => exact hf₀ diff --git a/Strata/Languages/Core/StatementType.lean b/Strata/Languages/Core/StatementType.lean index 3f631bab46..979b6ad95b 100644 --- a/Strata/Languages/Core/StatementType.lean +++ b/Strata/Languages/Core/StatementType.lean @@ -181,20 +181,13 @@ where -- Add source location to error messages. .error (errorWithSourceLoc e md) - | .exit label md => do try + | .exit l md => do try match op with | .some _ => - match label with - | .none => - if labels.isEmpty then - .error <| md.toDiagnosticF f!"{s}: exit occurs outside any block." - else - .ok (s, Env, C) - | .some l => - if labels.contains l then - .ok (s, Env, C) - else - .error <| md.toDiagnosticF f!"{s}: exit label \"{l}\" does not match any enclosing block." + if labels.contains l then + .ok (s, Env, C) + else + .error <| md.toDiagnosticF f!"{s}: exit label \"{l}\" does not match any enclosing block." | .none => .error <| md.toDiagnosticF f!"{s} occurs outside a procedure." catch e => -- Add source location to error messages. diff --git a/Strata/Languages/Core/WF.lean b/Strata/Languages/Core/WF.lean index 85fc2f110f..0b5f655441 100644 --- a/Strata/Languages/Core/WF.lean +++ b/Strata/Languages/Core/WF.lean @@ -69,7 +69,7 @@ structure WFifProp (Cmd : Type) (p : Program) (cond : ExprOrNondet Expression structure WFloopProp (Cmd : Type) (p : Program) (guard : ExprOrNondet Expression) (measure : Option Expression.Expr) (invariant : List (String × Expression.Expr)) (b : Block) : Prop where -structure WFexitProp (p : Program) (label : Option String) : Prop where +structure WFexitProp (p : Program) (label : String) : Prop where /-- Well-formedness for local function declarations. Checks that function parameter names are unique. @@ -94,7 +94,7 @@ def WFStatementProp (p : Program) (stmt : Statement) : Prop := match stmt with | .loop (guard : ExprOrNondet Expression) (measure : Option Expression.Expr) (invariant : List (String × Expression.Expr)) (body : Block) _ => WFloopProp (CmdExt Expression) p guard measure invariant body - | .exit (label : Option String) _ => WFexitProp p label + | .exit (label : String) _ => WFexitProp p label | .funcDecl decl _ => WFfuncDeclProp p decl | .typeDecl _ _ => True -- Type declarations are always well-formed diff --git a/Strata/Languages/Laurel/LaurelToCoreTranslator.lean b/Strata/Languages/Laurel/LaurelToCoreTranslator.lean index 1a9c78e081..66f57af768 100644 --- a/Strata/Languages/Laurel/LaurelToCoreTranslator.lean +++ b/Strata/Languages/Laurel/LaurelToCoreTranslator.lean @@ -492,11 +492,11 @@ def translateStmt (stmt : StmtExprMd) | .Return valueOpt => match valueOpt with | none => - return [.exit (some "$body") md] + return [.exit "$body" md] | some _ => emitDiagnostic $ md.toDiagnostic "Return statement with value should have been eliminated by EliminateValueReturns pass" DiagnosticType.StrataBug modify fun s => { s with coreProgramHasSuperfluousErrors := true } - return [.exit (some "$body") md] + return [.exit "$body" md] | .While cond invariants decreasesExpr body => let condExpr ← translateExpr cond let invExprs ← invariants.mapM (fun i => do return ("", ← translateExpr i)) @@ -504,7 +504,7 @@ def translateStmt (stmt : StmtExprMd) let bodyStmts ← translateStmt body return [Imperative.Stmt.loop (.det condExpr) decreasingExprCore invExprs bodyStmts md] | .Exit target => - return [Imperative.Stmt.exit (some target) md] + return [Imperative.Stmt.exit target md] | .Hole _ _ => -- Hole in statement position: treat as havoc (no-op). -- This can occur when an unmodeled call's Block is flattened. diff --git a/Strata/Languages/Python/PythonToCore.lean b/Strata/Languages/Python/PythonToCore.lean index cceb2c563e..4a77ea4c35 100644 --- a/Strata/Languages/Python/PythonToCore.lean +++ b/Strata/Languages/Python/PythonToCore.lean @@ -318,7 +318,7 @@ def noneOrExpr (translation_ctx : TranslationContext) (fname n : String) (e: Cor def handleCallThrow (jmp_target : String) : Core.Statement := let cond := .app () (.op () "ExceptOrNone..isExceptOrNone_mk_code" none) (.fvar () "maybe_except" none) - .ite (.det cond) [.exit (some jmp_target) .empty] [] .empty + .ite (.det cond) [.exit jmp_target .empty] [] .empty def deduplicateTypeAnnotations (l : List (String × Option String)) : List (String × String) := Id.run do let mut m : Map String String := [] @@ -623,7 +623,7 @@ partial def exceptHandlersToCore (jmp_targets: List String) (translation_ctx: Tr | .none => [.set "exception_ty_matches" (.boolConst () false) md] let cond := .fvar () "exception_ty_matches" none - let body_if_matches := body.val.toList.flatMap (λ s => (PyStmtToCore jmp_targets.tail! translation_ctx s).fst) ++ [.exit (some jmp_targets[1]!) md] + let body_if_matches := body.val.toList.flatMap (λ s => (PyStmtToCore jmp_targets.tail! translation_ctx s).fst) ++ [.exit jmp_targets[1]! md] set_ex_ty_matches ++ [.ite (.det cond) body_if_matches [] md] partial def handleFunctionCall (lhs: List Core.Expression.Ident) @@ -723,8 +723,8 @@ partial def PyStmtToCore (jmp_targets: List String) (translation_ctx : Translati ([.ite (.det (PyExprToCore guard_ctx test).expr) (ArrPyStmtToCore translation_ctx then_b.val).fst (ArrPyStmtToCore translation_ctx else_b.val).fst md], none) | .Return _ v => match v.val with - | .some v => ([.set "ret" (PyExprToCore translation_ctx v).expr md, .exit (some jmp_targets[0]!) md], none) -- TODO: need to thread return value name here. For now, assume "ret" - | .none => ([.exit (some jmp_targets[0]!) md], none) + | .some v => ([.set "ret" (PyExprToCore translation_ctx v).expr md, .exit jmp_targets[0]! md], none) -- TODO: need to thread return value name here. For now, assume "ret" + | .none => ([.exit jmp_targets[0]! md], none) | .For _ tgt itr body _ _ => -- Do one unrolling: let guard := .app () (Core.coreOpExpr (.bool .Not)) (.eq () (.app () (.op () "dict_str_any_length" none) (PyExprToCore default itr).expr) (.intConst () 0)) diff --git a/Strata/Transform/CallElimCorrect.lean b/Strata/Transform/CallElimCorrect.lean index 2166049b8a..5b7c165ca7 100644 --- a/Strata/Transform/CallElimCorrect.lean +++ b/Strata/Transform/CallElimCorrect.lean @@ -3461,7 +3461,7 @@ theorem callElimStatementCorrect [LawfulBEq Expression.Expr] : simp [Imperative.isDefinedOver, Imperative.HasVarsTrans.allVarsTrans, Statement.allVarsTrans, - Statement.touchedVarsTrans, + Statement.modifiedOrDefinedVarsTrans, Command.definedVarsTrans, Command.definedVars, Command.modifiedVarsTrans, diff --git a/Strata/Transform/CoreSpecification.lean b/Strata/Transform/CoreSpecification.lean index 2b5e4fa475..aef7675338 100644 --- a/Strata/Transform/CoreSpecification.lean +++ b/Strata/Transform/CoreSpecification.lean @@ -60,6 +60,8 @@ open Core Imperative structure ProcEnvWF (proc : Procedure) (ρ : Env Expression) : Prop where wfVar : WellFormedSemanticEvalVar ρ.eval wfBool : WellFormedSemanticEvalBool ρ.eval + wfCong : WellFormedCoreEvalCong ρ.eval + wfExprCongr : WellFormedSemanticEvalExprCongr ρ.eval storeDefined : ∀ id ∈ procVerifyInitIdents proc, (ρ.store id).isSome -- When a procedure is called, the value of "old g" must be equal to "g" -- for in-out parameters. diff --git a/Strata/Transform/DetToKleene.lean b/Strata/Transform/DetToKleene.lean index 0a021535c9..a4d59777e8 100644 --- a/Strata/Transform/DetToKleene.lean +++ b/Strata/Transform/DetToKleene.lean @@ -27,7 +27,7 @@ def StmtToKleeneStmt {P : PureExpr} [Imperative.HasBool P] [HasNot P] Option (Imperative.KleeneStmt P (Cmd P)) := match st with | .cmd cmd => some (.cmd cmd) - | .block _ bss _ => BlockToKleeneStmt bss + | .block _ bss _ => do let b ← BlockToKleeneStmt bss; return .block b | .ite cond tss ess md => do let t ← BlockToKleeneStmt tss let e ← BlockToKleeneStmt ess diff --git a/Strata/Transform/DetToKleeneCorrect.lean b/Strata/Transform/DetToKleeneCorrect.lean index fac861335a..a28684733d 100644 --- a/Strata/Transform/DetToKleeneCorrect.lean +++ b/Strata/Transform/DetToKleeneCorrect.lean @@ -38,6 +38,7 @@ abbrev Lang.det (extendEval : ExtendEval P) : Lang P := def isAtKleeneAssert : KleeneConfig P (Cmd P) → AssertId P → Prop | .stmt (.cmd (.assert label expr _)) _, a => a.label = label ∧ a.expr = expr | .seq inner _, a => isAtKleeneAssert inner a + | .block _ inner, a => isAtKleeneAssert inner a | _, _ => False abbrev Lang.kleene : Lang P where @@ -137,15 +138,19 @@ private theorem block_transform_some omit [HasFvar P] [HasVal P] [HasBoolVal P] in private theorem stmtToKleene_some_exitsCovered - (labels : List (Option String)) + (labels : List String) (st : Stmt P (Cmd P)) (ns : KleeneStmt P (Cmd P)) (ht : StmtToKleeneStmt st = some ns) : Stmt.exitsCoveredByBlocks (P := P) (CmdT := Cmd P) labels st := by match st with | .cmd _ => simp [Stmt.exitsCoveredByBlocks] | .block l bss _ => - simp [Stmt.exitsCoveredByBlocks]; rw [StmtToKleeneStmt.eq_2] at ht - exact blockHelper (l :: labels) bss ns ht + simp [StmtToKleeneStmt] at ht + match hb : BlockToKleeneStmt bss, ht with + | some b, ht => + simp at ht; subst ht + simp [Stmt.exitsCoveredByBlocks] + exact blockHelper (l :: labels) bss b hb | .ite cond tss ess md => match cond with | .det _ => @@ -170,7 +175,7 @@ private theorem stmtToKleene_some_exitsCovered | .exit _ _ => simp [StmtToKleeneStmt.eq_6] at ht | .funcDecl _ _ => simp [StmtToKleeneStmt.eq_7] at ht where - blockHelper (labels : List (Option String)) (bss : List (Stmt P (Cmd P))) (ns : KleeneStmt P (Cmd P)) + blockHelper (labels : List String) (bss : List (Stmt P (Cmd P))) (ns : KleeneStmt P (Cmd P)) (ht : BlockToKleeneStmt bss = some ns) : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks (P := P) (CmdT := Cmd P) labels bss := by match bss with @@ -190,8 +195,12 @@ private theorem stmtToKleene_some_noFuncDecl match st with | .cmd _ => simp [Stmt.noFuncDecl] | .block _ bss _ => - simp [Stmt.noFuncDecl]; rw [StmtToKleeneStmt.eq_2] at ht - exact blockHelper bss ns ht + simp [StmtToKleeneStmt] at ht + match hb : BlockToKleeneStmt bss, ht with + | some b, ht => + simp at ht; subst ht + simp [Stmt.noFuncDecl] + exact blockHelper bss b hb | .ite cond tss ess md => match cond with | .det _ => @@ -263,42 +272,31 @@ omit [HasVal P] [HasBoolVal P] in exit: the inner reaches terminal with a strictly shorter derivation. -/ private theorem blockT_reaches_terminal_noExit (extendEval : ExtendEval P) - {inner : Config P (Cmd P)} {l : Option String} {ρ' : Env P} - (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.block l inner) (.terminal ρ')) + {inner : Config P (Cmd P)} {l : Option String} {σ_parent : SemanticStore P} {ρ' : Env P} + (hstar : ReflTransT (StepStmt P (EvalCmd P) extendEval) (.block l σ_parent inner) (.terminal ρ')) (h_no_exit : ∀ lbl ρ_x, ¬ StepStmtStar P (EvalCmd P) extendEval inner (.exiting lbl ρ_x)) : - ∃ (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.terminal ρ')), + ∃ (ρ_inner : Env P) (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.terminal ρ_inner)), + ρ' = { ρ_inner with store := projectStore σ_parent ρ_inner.store } ∧ h.len < hstar.len := by - suffices ∀ src tgt (hstar_g : ReflTransT (StepStmt P (EvalCmd P) extendEval) src tgt), - ∀ inner ρ', src = .block l inner → tgt = .terminal ρ' → - (∀ lbl ρ_x, - ¬ StepStmtStar P (EvalCmd P) extendEval inner (.exiting lbl ρ_x)) → - ∃ (h : ReflTransT (StepStmt P (EvalCmd P) extendEval) inner (.terminal ρ')), - h.len < hstar_g.len from - this _ _ hstar _ _ rfl rfl h_no_exit - intro src tgt hstar_g - induction hstar_g with - | refl => intro _ _ hsrc htgt _; subst hsrc; cases htgt - | step _ mid _ hstep hrest ih => - intro inner ρ' hsrc htgt h_ne; subst hsrc - cases hstep with - | step_block_body h => - have h_ne' : ∀ lbl ρ_x, ¬ StepStmtStar P (EvalCmd P) extendEval _ (.exiting lbl ρ_x) := - fun lbl ρ_x hx => h_ne lbl ρ_x (.step _ _ _ h hx) - have ⟨h_inner, hlen⟩ := ih _ _ rfl htgt h_ne' - exact ⟨.step _ _ _ h h_inner, by simp [ReflTransT.len]; omega⟩ - | step_block_done => - subst htgt - exact ⟨hrest, by simp [ReflTransT.len]⟩ - | step_block_exit_none => - subst htgt - exact absurd (.refl _) (h_ne _ _) - | step_block_exit_match => - subst htgt - exact absurd (.refl _) (h_ne _ _) - | step_block_exit_mismatch => - subst htgt - cases hrest with | step _ _ _ h _ => cases h + match hstar with + | .step _ (.block _ _ inner₁) _ (.step_block_body h) hrest => + have h_no_exit' : ∀ lbl ρ_x, + ¬ StepStmtStar P (EvalCmd P) extendEval inner₁ (.exiting lbl ρ_x) := by + intro lbl ρ_x hinner₁ + exact h_no_exit lbl ρ_x (.step _ _ _ h hinner₁) + have ⟨ρ_inner, hterm, heq, hlen⟩ := blockT_reaches_terminal_noExit extendEval hrest h_no_exit' + exact ⟨ρ_inner, .step _ _ _ h hterm, heq, by simp [ReflTransT.len]; omega⟩ + | .step _ _ _ .step_block_done hrest => + match hrest with + | .refl _ => exact ⟨_, .refl _, rfl, by simp [ReflTransT.len]⟩ + | .step _ _ _ h _ => exact nomatch h + | .step _ _ _ (.step_block_exit_match _) hrest => + exfalso + exact h_no_exit _ _ (.refl _) + | .step _ _ _ (.step_block_exit_mismatch _) hrest => + match hrest with + | .step _ _ _ h _ => exact nomatch h omit [HasVal P] [HasBoolVal P] in private theorem stmtsT_append_terminal @@ -367,7 +365,7 @@ private def loop_sim (hlen : hstarT.len ≤ n) : StepKleeneStar P (EvalCmd P) (.stmt (.loop (.seq (.cmd (.assume "guard" g md)) b)) ρ₀) (.terminal ρ') := by - induction n generalizing ρ₀ with + induction n generalizing ρ₀ ρ' with | zero => -- hstarT of length 0 = refl, impossible since src ≠ tgt. match hstarT, hlen with @@ -390,46 +388,69 @@ private def loop_sim subst h_no let ρ₀' : Env P := {ρ₀ with hasFailure := ρ₀.hasFailure || false} have hρ₀_eq : ρ₀' = ρ₀ := by simp [ρ₀', Bool.or_false] - -- hrest is (.block .none (.stmts (body ++ [loop]) ρ₀')) →*T .terminal ρ'. - -- Unwrap the block layer. The inner config cannot reach .exiting since - -- `hcov` ensures body has no escaping exits, and the trailing `[loop]` - -- also cannot exit. - have h_noescape_body : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks - (P := P) (CmdT := Cmd P) ([] : List (Option String)) (body ++ [.loop (.det g) m [] body md]) := - block_exitsCoveredByBlocks_append (P := P) (CmdT := Cmd P) [] body _ hcov - ⟨hcov, True.intro⟩ - have h_ne : ∀ lbl ρ_x, - ¬ StepStmtStar P (EvalCmd P) extendEval - (.stmts (body ++ [.loop (.det g) m [] body md]) ρ₀') (.exiting lbl ρ_x) := - block_exitsCoveredByBlocks_noEscape P (EvalCmd P) extendEval - (body ++ [.loop (.det g) m [] body md]) h_noescape_body ρ₀' - have ⟨hrest', hlen_inner⟩ := - blockT_reaches_terminal_noExit extendEval hrest h_ne - have ⟨ρ₁, hbody, hloop_stmtT, hlen_dec⟩ := - stmtsT_append_terminal extendEval body (.loop (.det g) m [] body md) ρ₀' ρ' hrest' hcov - -- Convert hbody from (...ρ₀') to (...ρ₀) via hρ₀_eq. - have hbody' : StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ₁) := - hρ₀_eq ▸ hbody - have kleene_body := sim_body ρ₀ ρ₁ hwfb hwfv hbody' - have heval_eq : ρ₁.eval = ρ₀.eval := - smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval - body ρ₀ ρ₁ hnofd_body hbody' - have hwfv₁ : WellFormedSemanticEvalVal ρ₁.eval := heval_eq ▸ hwfv - have h_assume := kleene_assume_terminal (P := P) (label := "guard") (md := md) hg hwfb - have h_iter : StepKleeneStar P (EvalCmd P) - (.stmt (.seq (.cmd (.assume "guard" g md)) b) ρ₀) (.terminal ρ₁) := - kleene_seq_terminal _ b ρ₀ ρ₀ ρ₁ h_assume kleene_body - have hloop_len : hloop_stmtT.len ≤ n := by - simp [ReflTransT.len] at hlen - have := hlen_dec - have := hlen_inner - omega - have kleene_loop := ih ρ₁ hwfv₁ hloop_stmtT hloop_len - exact .step _ _ _ .step_loop_step - (ReflTrans_Transitive _ _ _ _ - (kleene_seq_inner_star _ _ - (.loop (.seq (.cmd (.assume "guard" g md)) b)) h_iter) - (.step _ _ _ .step_seq_done kleene_loop)) + -- New shape: hrest : .seq (.block .none ρ₀'.store (.stmts body ρ₀')) [loop] →*T .terminal ρ'. + -- Step 1: Split via seqT_reaches_terminal: + have ⟨ρ_block, h_block_term, h_loop_stmts, hlen_seq⟩ := + seqT_reaches_terminal extendEval hrest + -- Step 2: Unwrap the block. Body cannot exit (by hcov). + have h_noescape_body : ∀ lbl ρ_x, + ¬ StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀') (.exiting lbl ρ_x) := + block_exitsCoveredByBlocks_noEscape P (EvalCmd P) extendEval body hcov ρ₀' + have ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_reaches_terminal_noExit extendEval h_block_term h_noescape_body + -- Step 3: Decompose [loop] ρ_block via stmtsT_cons_terminal. + have ⟨ρ_x, h_loop_T_T, h_nil, hlen_cons⟩ := + stmtsT_cons_terminal extendEval h_loop_stmts + -- h_nil is .stmts [] ρ_x →*T .terminal ρ' — must be step_stmts_nil + refl. + have hρ_x_eq : ρ_x = ρ' := by + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + subst hρ_x_eq + -- Now: h_inner_term : .stmts body ρ₀' →*T .terminal ρ_inner + -- heq_ρ_block : ρ_block = { ρ_inner with store := projectStore ρ₀'.store ρ_inner.store } + -- h_loop_T_T : .stmt (.loop ...) ρ_block →*T .terminal ρ' + have h_assume : StepKleeneStar P (EvalCmd P) + (.stmt (.cmd (.assume "guard" g md)) ρ₀) (.terminal ρ₀) := + kleene_assume_terminal hg hwfb + have hterm_body_eq : StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ_inner) := + hρ₀_eq ▸ reflTransT_to_prop h_inner_term + have h_sim_body : StepKleeneStar P (EvalCmd P) (.stmt b ρ₀) (.terminal ρ_inner) := + sim_body ρ₀ ρ_inner hwfb hwfv hterm_body_eq + have h_kleene_assume_b : StepKleeneStar P (EvalCmd P) + (.stmt (.seq (.cmd (.assume "guard" g md)) b) ρ₀) (.terminal ρ_inner) := + kleene_seq_terminal _ b ρ₀ ρ₀ ρ_inner h_assume h_sim_body + have hwfv_inner : WellFormedSemanticEvalVal ρ_inner.eval := by + have := block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ₀ ρ_inner hnofd_body hterm_body_eq + rw [this]; exact hwfv + have hwfv_block : WellFormedSemanticEvalVal ρ_block.eval := by + rw [heq_ρ_block]; exact hwfv_inner + have h_kleene_loop : StepKleeneStar P (EvalCmd P) + (.stmt (.loop (.seq (.cmd (.assume "guard" g md)) b)) ρ_block) (.terminal _) := + ih ρ_block _ hwfv_block h_loop_T_T (by simp [ReflTransT.len] at hlen; omega) + -- Build Kleene execution: step_loop_step → .seq (.block ρ₀.store (.stmt (assume; b) ρ₀)) (.loop ...) + -- Then use seq+block to reach (.terminal ρ_block) via h_kleene_assume_b + project. + have heq_ρ_block_full : ρ_block = + { ρ_inner with store := projectStore ρ₀.store ρ_inner.store } := by + have : ρ₀'.store = ρ₀.store := by rw [hρ₀_eq] + rw [heq_ρ_block, this] + have h_block_to_ρ_block : StepKleeneStar P (EvalCmd P) + (.block ρ₀.store (.stmt (.seq (.cmd (.assume "guard" g md)) b) ρ₀)) + (.terminal ρ_block) := by + rw [heq_ρ_block_full] + exact kleene_block_terminal ρ₀.store _ ρ_inner h_kleene_assume_b + have h_seq_to_ρ' : StepKleeneStar P (EvalCmd P) + (.seq (.block ρ₀.store (.stmt (.seq (.cmd (.assume "guard" g md)) b) ρ₀)) + (.loop (.seq (.cmd (.assume "guard" g md)) b))) + (.terminal _) := + ReflTrans_Transitive _ _ _ _ + (ReflTrans_Transitive _ _ _ _ + (kleene_seq_inner_star _ _ (.loop _) h_block_to_ρ_block) + (.step _ _ _ .step_seq_done (.refl _))) + h_kleene_loop + exact .step _ _ _ .step_loop_step h_seq_to_ρ' /-- Kleene loop simulation: the loop body is executed zero or more times non-deterministically. -/ @@ -452,7 +473,7 @@ private def loop_sim_kleene (hlen : hstarT.len ≤ n) : StepKleeneStar P (EvalCmd P) (.stmt (.loop b) ρ₀) (.terminal ρ') := by - induction n generalizing ρ₀ with + induction n generalizing ρ₀ ρ' with | zero => match hstarT, hlen with | .step _ _ _ _ _, hlen => simp [ReflTransT.len] at hlen @@ -474,38 +495,58 @@ private def loop_sim_kleene subst h_no let ρ₀' : Env P := {ρ₀ with hasFailure := ρ₀.hasFailure || false} have hρ₀_eq : ρ₀' = ρ₀ := by simp [ρ₀', Bool.or_false] - -- Unwrap the .block .none wrapper; see loop_sim for details. - have h_noescape_body : Stmt.exitsCoveredByBlocks.Block.exitsCoveredByBlocks - (P := P) (CmdT := Cmd P) ([] : List (Option String)) (body ++ [.loop .nondet m [] body md]) := - block_exitsCoveredByBlocks_append (P := P) (CmdT := Cmd P) [] body _ hcov - ⟨hcov, True.intro⟩ - have h_ne : ∀ lbl ρ_x, - ¬ StepStmtStar P (EvalCmd P) extendEval - (.stmts (body ++ [.loop .nondet m [] body md]) ρ₀') (.exiting lbl ρ_x) := - block_exitsCoveredByBlocks_noEscape P (EvalCmd P) extendEval - (body ++ [.loop .nondet m [] body md]) h_noescape_body ρ₀' - have ⟨hrest', hlen_inner⟩ := - blockT_reaches_terminal_noExit extendEval hrest h_ne - have ⟨ρ₁, hbody, hloop_stmtT, hlen_dec⟩ := - stmtsT_append_terminal extendEval body (.loop .nondet m [] body md) ρ₀' ρ' hrest' hcov - have hbody' : StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ₁) := - hρ₀_eq ▸ hbody - have kleene_body := sim_body ρ₀ ρ₁ hwfb hwfv hbody' - have heval_eq : ρ₁.eval = ρ₀.eval := - smallStep_noFuncDecl_preserves_eval_block P (EvalCmd P) extendEval - body ρ₀ ρ₁ hnofd_body hbody' - have hwfb₁ : WellFormedSemanticEvalBool ρ₁.eval := heval_eq ▸ hwfb - have hwfv₁ : WellFormedSemanticEvalVal ρ₁.eval := heval_eq ▸ hwfv - have hloop_len : hloop_stmtT.len ≤ n := by - simp [ReflTransT.len] at hlen - have := hlen_dec - have := hlen_inner - omega - have kleene_loop := ih ρ₁ hwfb₁ hwfv₁ hloop_stmtT hloop_len - exact .step _ _ _ .step_loop_step - (ReflTrans_Transitive _ _ _ _ - (kleene_seq_inner_star _ _ (.loop b) kleene_body) - (.step _ _ _ .step_seq_done kleene_loop)) + -- New shape: hrest : .seq (.block .none ρ₀'.store (.stmts body ρ₀')) [loop] →*T .terminal ρ' + have ⟨ρ_block, h_block_term, h_loop_stmts, hlen_seq⟩ := + seqT_reaches_terminal extendEval hrest + have h_noescape_body : ∀ lbl ρ_x, + ¬ StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀') (.exiting lbl ρ_x) := + block_exitsCoveredByBlocks_noEscape P (EvalCmd P) extendEval body hcov ρ₀' + have ⟨ρ_inner, h_inner_term, heq_ρ_block, hlen_inner⟩ := + blockT_reaches_terminal_noExit extendEval h_block_term h_noescape_body + have ⟨ρ_x, h_loop_T_T, h_nil, hlen_cons⟩ := + stmtsT_cons_terminal extendEval h_loop_stmts + have hρ_x_eq : ρ_x = ρ' := by + match h_nil with + | .step _ _ _ .step_stmts_nil hr2 => + match hr2 with + | .refl _ => rfl + | .step _ _ _ h _ => exact nomatch h + subst hρ_x_eq + have hterm_body_eq : StepStmtStar P (EvalCmd P) extendEval (.stmts body ρ₀) (.terminal ρ_inner) := + hρ₀_eq ▸ reflTransT_to_prop h_inner_term + have h_sim_body : StepKleeneStar P (EvalCmd P) (.stmt b ρ₀) (.terminal ρ_inner) := + sim_body ρ₀ ρ_inner hwfb hwfv hterm_body_eq + have hwfv_inner : WellFormedSemanticEvalVal ρ_inner.eval := by + have := block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ₀ ρ_inner hnofd_body hterm_body_eq + rw [this]; exact hwfv + have hwfb_inner : WellFormedSemanticEvalBool ρ_inner.eval := by + have := block_noFuncDecl_preserves_eval P (EvalCmd P) extendEval body ρ₀ ρ_inner hnofd_body hterm_body_eq + rw [this]; exact hwfb + have hwfv_block : WellFormedSemanticEvalVal ρ_block.eval := by + rw [heq_ρ_block]; exact hwfv_inner + have hwfb_block : WellFormedSemanticEvalBool ρ_block.eval := by + rw [heq_ρ_block]; exact hwfb_inner + have h_kleene_loop : StepKleeneStar P (EvalCmd P) + (.stmt (.loop b) ρ_block) (.terminal _) := + ih ρ_block _ hwfb_block hwfv_block h_loop_T_T (by simp [ReflTransT.len] at hlen; omega) + have heq_ρ_block_full : ρ_block = + { ρ_inner with store := projectStore ρ₀.store ρ_inner.store } := by + have : ρ₀'.store = ρ₀.store := by rw [hρ₀_eq] + rw [heq_ρ_block, this] + have h_block_to_ρ_block : StepKleeneStar P (EvalCmd P) + (.block ρ₀.store (.stmt b ρ₀)) + (.terminal ρ_block) := by + rw [heq_ρ_block_full] + exact kleene_block_terminal ρ₀.store _ ρ_inner h_sim_body + have h_seq_to_ρ' : StepKleeneStar P (EvalCmd P) + (.seq (.block ρ₀.store (.stmt b ρ₀)) (.loop b)) + (.terminal _) := + ReflTrans_Transitive _ _ _ _ + (ReflTrans_Transitive _ _ _ _ + (kleene_seq_inner_star _ _ (.loop _) h_block_to_ρ_block) + (.step _ _ _ .step_seq_done (.refl _))) + h_kleene_loop + exact .step _ _ _ .step_loop_step h_seq_to_ρ' /-! ## Core simulation by strong induction on statement/block size -/ @@ -561,18 +602,24 @@ private theorem simulation | step _ _ _ h _ => exact nomatch h | .block _l bss _md => - rw [StmtToKleeneStmt.eq_2] at ht - cases hstar with - | step _ _ _ h1 r1 => cases h1 with - | step_block => - match block_reaches_terminal P (EvalCmd P) extendEval r1 with - | .inl hterm => - have : Block.sizeOf bss ≤ n := by - simp_all [Stmt.sizeOf]; omega - exact ih.2 bss ns this ht ρ₀ ρ' hwfb hwfv hterm - | .inr ⟨lbl, hexit⟩ => - exact absurd hexit (block_exitsCoveredByBlocks_noEscape P (EvalCmd P) extendEval bss - (stmtToKleene_some_exitsCovered.blockHelper [] bss ns ht) ρ₀ lbl ρ') + simp [StmtToKleeneStmt] at ht + match hb : BlockToKleeneStmt bss, ht with + | some b, ht => + simp at ht; subst ht + cases hstar with + | step _ _ _ h1 r1 => cases h1 with + | step_block => + match block_reaches_terminal P (EvalCmd P) extendEval r1 with + | .inl ⟨ρ_inner, hterm, heq_ρ'⟩ => + have hsz_bss : Block.sizeOf bss ≤ n := by + simp_all [Stmt.sizeOf]; omega + subst heq_ρ' + exact .step _ _ _ .step_block + (kleene_block_terminal ρ₀.store _ ρ_inner + (ih.2 bss b hsz_bss hb ρ₀ ρ_inner hwfb hwfv hterm)) + | .inr ⟨lbl, ρ_inner, hexit, _⟩ => + exact absurd hexit (block_exitsCoveredByBlocks_noEscape P (EvalCmd P) extendEval bss + (stmtToKleene_some_exitsCovered.blockHelper [] bss b hb) ρ₀ lbl ρ_inner) | .ite cond tss ess md => match cond with diff --git a/Strata/Transform/ProcBodyVerifyCorrect.lean b/Strata/Transform/ProcBodyVerifyCorrect.lean index cf64ee7633..515f44dee2 100644 --- a/Strata/Transform/ProcBodyVerifyCorrect.lean +++ b/Strata/Transform/ProcBodyVerifyCorrect.lean @@ -25,7 +25,7 @@ open Core Core.ProcBodyVerify Imperative Lambda Transform Core.WF private theorem coreIsAtAssert_not_terminal (ρ : Env Expression) (a : AssertId Expression) : ¬ coreIsAtAssert (.terminal ρ) a := by simp [coreIsAtAssert] -private theorem coreIsAtAssert_not_exiting (lbl : Option String) (ρ : Env Expression) (a : AssertId Expression) : +private theorem coreIsAtAssert_not_exiting (lbl : String) (ρ : Env Expression) (a : AssertId Expression) : ¬ coreIsAtAssert (.exiting lbl ρ) a := by simp [coreIsAtAssert] /-! ## Input Environment Reconstruction, from the prefix statements of ProcBodyVerify @@ -660,14 +660,14 @@ theorem procBodyVerify_procedureCorrect ∃ ρ_init, StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt verifyStmt ρ_init) - (.block verifyLabel (.seq (.block bodyLabel cfg) postAsserts)) := by + (.block (.some verifyLabel) ρ_init.store (.seq (.block (.some bodyLabel) ρ₀.store cfg) postAsserts)) := by intro ρ₀ h_wf cfg h_body obtain ⟨ρ_init, h_prefix⟩ := h_prefix_trace ρ₀ h_wf exact ⟨ρ_init, by rw [h_eq] exact ReflTrans_Transitive _ _ _ _ (step_block_enter Expression (EvalCommand π φ) (EvalPureFunc φ) verifyLabel _ #[] ρ_init) - (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ verifyLabel + (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ (.some verifyLabel) ρ_init.store (ReflTrans_Transitive _ _ _ _ (by rw [List.append_assoc] exact stmts_prefix_terminal_append Expression (EvalCommand π φ) (EvalPureFunc φ) @@ -677,27 +677,27 @@ theorem procBodyVerify_procedureCorrect (seq_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ postAsserts (ReflTrans_Transitive _ _ _ _ (step_block_enter Expression (EvalCommand π φ) (EvalPureFunc φ) bodyLabel _ #[] ρ₀) - (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ bodyLabel + (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ (.some bodyLabel) ρ₀.store (CoreStepStar_to_StepStmtStar h_body)))))))⟩ /- Helper: coreIsAtAssert and getEval/getStore are preserved through the verifyStmt wrapping (block > seq > block). -/ - have h_wrapped_assert : ∀ (cfg : CoreConfig) (a : AssertId Expression), + have h_wrapped_assert : ∀ (σ_v σ_b : SemanticStore Expression) (cfg : CoreConfig) (a : AssertId Expression), coreIsAtAssert cfg a → - coreIsAtAssert (.block verifyLabel (.seq (.block bodyLabel cfg) postAsserts)) a := by - intro cfg a h + coreIsAtAssert (.block (.some verifyLabel) σ_v (.seq (.block (.some bodyLabel) σ_b cfg) postAsserts)) a := by + intro σ_v σ_b cfg a h simp only [coreIsAtAssert] exact h - have h_wrapped_eval : ∀ (cfg : CoreConfig), - Config.getEval (.block verifyLabel (.seq (.block bodyLabel cfg) postAsserts)) = + have h_wrapped_eval : ∀ (σ_v σ_b : SemanticStore Expression) (cfg : CoreConfig), + Config.getEval (.block (.some verifyLabel) σ_v (.seq (.block (.some bodyLabel) σ_b cfg) postAsserts)) = Config.getEval cfg := by - intro cfg; simp [Config.getEval, Config.getEnv] + intro σ_v σ_b cfg; simp [Config.getEval, Config.getEnv] - have h_wrapped_store : ∀ (cfg : CoreConfig), - Config.getStore (.block verifyLabel (.seq (.block bodyLabel cfg) postAsserts)) = + have h_wrapped_store : ∀ (σ_v σ_b : SemanticStore Expression) (cfg : CoreConfig), + Config.getStore (.block (.some verifyLabel) σ_v (.seq (.block (.some bodyLabel) σ_b cfg) postAsserts)) = Config.getStore cfg := by - intro cfg; simp [Config.getStore, Config.getEnv] + intro σ_v σ_b cfg; simp [Config.getStore, Config.getEnv] -- Unfold h_correct for easier application have h_correct' : ∀ (a : AssertId Expression) (ρ_init : Env Expression) @@ -716,10 +716,10 @@ theorem procBodyVerify_procedureCorrect coreIsAtAssert cfg a → cfg.getEval cfg.getStore a.expr = some HasBool.tt := by intro ρ₀ h_wf a cfg h_body h_assert - obtain ⟨_, h_vt⟩ := h_embed_body ρ₀ h_wf cfg h_body - have h_v := h_correct' a _ - (.block verifyLabel (.seq (.block bodyLabel cfg) postAsserts)) - h_vt (h_wrapped_assert cfg a h_assert) + obtain ⟨ρ_init, h_vt⟩ := h_embed_body ρ₀ h_wf cfg h_body + have h_v := h_correct' a ρ_init + (.block (.some verifyLabel) ρ_init.store (.seq (.block (.some bodyLabel) ρ₀.store cfg) postAsserts)) + h_vt (h_wrapped_assert ρ_init.store ρ₀.store cfg a h_assert) rw [h_wrapped_eval, h_wrapped_store] at h_v exact h_v @@ -733,9 +733,9 @@ theorem procBodyVerify_procedureCorrect (h_body : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmt (Stmt.block "" proc.body #[]) ρ₀) cfg) (h_assert : coreIsAtAssert cfg a) - -- Extract first step: .stmt (block "" body #[]) ρ₀ → .block "" (.stmts body ρ₀) + -- Extract first step: .stmt (block "" body #[]) ρ₀ → .block (.some "") ρ₀.store (.stmts body ρ₀) have h_block_star : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.block "" (.stmts proc.body ρ₀)) cfg := by + (.block (.some "") ρ₀.store (.stmts proc.body ρ₀)) cfg := by cases h_body with | refl => simp [coreIsAtAssert] at h_assert | step _ _ _ hstep hrest => cases hstep; exact hrest @@ -778,12 +778,16 @@ theorem procBodyVerify_procedureCorrect Core.core_wfBool_preserved π φ h_wf_ext (.stmts proc.body ρ₀) (.terminal ρ') h_wf.wfBool h_term + -- After the body block terminates via step_block_done, the store is projected. + -- We define the projected env. + let ρ_proj : Env Expression := { ρ' with store := projectStore ρ₀.store ρ'.store } + have h_to_post : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmt verifyStmt ρ_init) (.block verifyLabel (.stmts postAsserts ρ')) := by + (.stmt verifyStmt ρ_init) (.block (.some verifyLabel) ρ_init.store (.stmts postAsserts ρ_proj)) := by rw [h_eq] exact ReflTrans_Transitive _ _ _ _ (step_block_enter Expression (EvalCommand π φ) (EvalPureFunc φ) verifyLabel _ #[] ρ_init) - (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ verifyLabel + (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ (.some verifyLabel) ρ_init.store (ReflTrans_Transitive _ _ _ _ (by rw [List.append_assoc] exact stmts_prefix_terminal_append Expression (EvalCommand π φ) (EvalPureFunc φ) @@ -794,21 +798,38 @@ theorem procBodyVerify_procedureCorrect (seq_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ postAsserts (ReflTrans_Transitive _ _ _ _ (step_block_enter Expression (EvalCommand π φ) (EvalPureFunc φ) bodyLabel _ #[] ρ₀) - (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ bodyLabel + (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ (.some bodyLabel) ρ₀.store (CoreStepStar_to_StepStmtStar h_term)))) (ReflTrans_Transitive _ _ _ _ (seq_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ postAsserts (.step _ _ _ .step_block_done (.refl _))) (.step _ _ _ .step_seq_done (.refl _))))))) - -- Show every postcondition assert evaluates to true - -- by induction on the suffix of postAsserts + + have h_proj_store_agree : ∀ x, (ρ₀.store x).isSome → + ρ_proj.store x = ρ'.store x := by + intro x hx + simp only [ρ_proj, projectStore] + simp [hx] + + have h_proj_eval : ρ_proj.eval = ρ'.eval := rfl + have h_proj_hasFailure : ρ_proj.hasFailure = ρ'.hasFailure := rfl + have h_wfVar_term : WellFormedSemanticEvalVar ρ'.eval := + Core.core_wfVar_preserved π φ h_wf_ext + (.stmts proc.body ρ₀) (.terminal ρ') h_wf.wfVar h_term + have h_wfCong_term : Core.WellFormedCoreEvalCong ρ'.eval := + Core.core_wfCong_preserved π φ h_wf_ext + (.stmts proc.body ρ₀) (.terminal ρ') h_wf.wfCong h_term + have h_wfExprCongr_term : WellFormedSemanticEvalExprCongr ρ'.eval := + Core.core_wfExprCongr_preserved π φ h_wf_ext + (.stmts proc.body ρ₀) (.terminal ρ') h_wf.wfExprCongr h_term + have h_all_post_valid : ∀ s ∈ postAsserts, ∀ l e md, s = Statement.assert l e md → ρ'.eval ρ'.store e = some HasBool.tt := by suffices h_sfx : ∀ (sfx : List Statement), (∀ s ∈ sfx, ∃ l e md, s = Statement.assert l e md) → StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmt verifyStmt ρ_init) (.block verifyLabel (.stmts sfx ρ')) → + (.stmt verifyStmt ρ_init) (.block (.some verifyLabel) ρ_init.store (.stmts sfx ρ_proj)) → ∀ s ∈ sfx, ∀ l e md, s = Statement.assert l e md → ρ'.eval ρ'.store e = some HasBool.tt by @@ -822,33 +843,35 @@ theorem procBodyVerify_procedureCorrect have ⟨lh, eh, mdh, h_hd_eq⟩ := h_all_assert hd (.head _) subst h_hd_eq have h_at_head : coreIsAtAssert - (.block verifyLabel (.stmts (Statement.assert lh eh mdh :: tl) ρ')) + (.block (.some verifyLabel) ρ_init.store (.stmts (Statement.assert lh eh mdh :: tl) ρ_proj)) ⟨lh, eh⟩ := by simp only [coreIsAtAssert]; exact ⟨trivial, trivial⟩ - have h_head_eval := h_correct' ⟨lh, eh⟩ ρ_init _ h_trace h_at_head - simp only [Config.getEval, Config.getStore] at h_head_eval + have h_head_eval_proj := h_correct' ⟨lh, eh⟩ ρ_init _ h_trace h_at_head + simp only [Config.getEval, Config.getStore] at h_head_eval_proj + have h_head_eval : ρ'.eval ρ'.store eh = some HasBool.tt := + eval_projectStore_to_full h_head_eval_proj h_wfVar_term h_wfCong_term h_wfExprCongr_term cases h_mem with | head _ => injection h_s_eq with h1; injection h1 with h2 injection h2 with _ h3; subst h3; exact h_head_eval | tail _ h_in_tl => have h_assert_step : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmt (Statement.assert lh eh mdh) ρ') (.terminal ρ') := by + (.stmt (Statement.assert lh eh mdh) ρ_proj) (.terminal ρ_proj) := by have h1 : StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) - (.stmt (Statement.assert lh eh mdh) ρ') - (.terminal ⟨ρ'.store, ρ'.eval, ρ'.hasFailure || false⟩) := + (.stmt (Statement.assert lh eh mdh) ρ_proj) + (.terminal ⟨ρ_proj.store, ρ_proj.eval, ρ_proj.hasFailure || false⟩) := .step _ _ _ - (.step_cmd (@EvalCommand.cmd_sem π φ ρ'.eval ρ'.store - (Cmd.assert lh eh mdh) ρ'.store false - (EvalCmd.eval_assert_pass h_head_eval h_wfb_term))) + (.step_cmd (@EvalCommand.cmd_sem π φ ρ_proj.eval ρ_proj.store + (Cmd.assert lh eh mdh) ρ_proj.store false + (EvalCmd.eval_assert_pass h_head_eval_proj (by rw [h_proj_eval]; exact h_wfb_term)))) (.refl _) - have h2 : (⟨ρ'.store, ρ'.eval, ρ'.hasFailure || false⟩ : Env Expression) = ρ' := by - cases ρ'; simp [Bool.or_false] + have h2 : (⟨ρ_proj.store, ρ_proj.eval, ρ_proj.hasFailure || false⟩ : Env Expression) = ρ_proj := by + cases ρ'; simp [ρ_proj, Bool.or_false] rw [h2] at h1; exact h1 have h_trace_tl := ReflTrans_Transitive _ _ _ _ h_trace - (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ verifyLabel + (block_inner_star Expression (EvalCommand π φ) (EvalPureFunc φ) _ _ (.some verifyLabel) ρ_init.store (stmts_cons_step Expression (EvalCommand π φ) (EvalPureFunc φ) - (Statement.assert lh eh mdh) tl ρ' ρ' h_assert_step)) + (Statement.assert lh eh mdh) tl ρ_proj ρ_proj h_assert_step)) exact ih (fun s' hs' => h_all_assert s' (.tail _ hs')) h_trace_tl s h_in_tl l e md h_s_eq -- Prove postconditions hold and hasFailure is false diff --git a/Strata/Transform/ProcedureInlining.lean b/Strata/Transform/ProcedureInlining.lean index 38629b6399..752e626aa6 100644 --- a/Strata/Transform/ProcedureInlining.lean +++ b/Strata/Transform/ProcedureInlining.lean @@ -64,7 +64,7 @@ def Statement.replaceLabels | .some s' => s' match s with | .block lbl b m => .block (app lbl) (Block.replaceLabels b map) m - | .exit lbl m => .exit (lbl.map app) m + | .exit lbl m => .exit (app lbl) m | .ite cond thenb elseb m => .ite cond (Block.replaceLabels thenb map) (Block.replaceLabels elseb map) m | .loop g measure inv body m => diff --git a/Strata/Transform/Specification.lean b/Strata/Transform/Specification.lean index 14fae6d005..67f05c5045 100644 --- a/Strata/Transform/Specification.lean +++ b/Strata/Transform/Specification.lean @@ -91,7 +91,7 @@ structure Lang (P : PureExpr) [HasFvar P] [HasBool P] [HasNot P] where /-- Terminal configuration. -/ terminalCfg : Env P → CfgT /-- Exiting configuration. -/ - exitingCfg : Option String → Env P → CfgT + exitingCfg : String → Env P → CfgT /-- Assert detection in configurations. -/ isAtAssert : CfgT → AssertId P → Prop /-- Extract env from a configuration. -/ @@ -287,18 +287,32 @@ theorem seq_cons {s : Stmt P CmdT} {ss : List (Stmt P CmdT)} exact h₂ ρ₁ ρ' hmid (hwfb_preserved ρ₁ hterm_s) hf₁ (.inr ⟨lbl, hexit_ss⟩) omit [HasVal P] in -/-- Lift a `TripleBlock` to a `Triple` by wrapping in a block. -/ +/-- A postcondition is well-formed if it is stable under `projectStore`. -/ +def PostWF (Post : Env P → Prop) : Prop := + ∀ ρ σ_parent, Post ρ → ρ.hasFailure = false → + Post { ρ with store := projectStore σ_parent ρ.store } ∧ + ({ ρ with store := projectStore σ_parent ρ.store } : Env P).hasFailure = false + +omit [HasVal P] in +/-- Lift a `TripleBlock` to a `Triple` by wrapping in a block. + The postcondition `Post` is required to be stable under `projectStore` + (it only references variables defined before the block). -/ theorem TripleBlock.toTriple {ss : List (Stmt P CmdT)} {l : String} {md : MetaData P} {Pre Post : Env P → Prop} - (h : TripleBlock evalCmd extendEval Pre ss Post) : + (h : TripleBlock evalCmd extendEval Pre ss Post) + (hpost_proj : PostWF Post) : Triple (Lang.imperative P CmdT evalCmd extendEval isAtAssertFn) Pre (.block l ss md) Post := by intro ρ₀ ρ' hpre hwfb hf₀ hstar cases hstar with | step _ _ _ hstep hrest => cases hstep with | step_block => match block_reaches_terminal P evalCmd extendEval hrest with - | .inl hterm => exact h ρ₀ ρ' hpre hwfb hf₀ (.inl hterm) - | .inr ⟨lbl, hexit_inner⟩ => exact h ρ₀ ρ' hpre hwfb hf₀ (.inr ⟨lbl, hexit_inner⟩) + | .inl ⟨ρ_inner, hterm, heq⟩ => + have ⟨hpost, hf⟩ := h ρ₀ ρ_inner hpre hwfb hf₀ (.inl hterm) + subst heq; exact hpost_proj ρ_inner _ hpost hf + | .inr ⟨lbl, ρ_inner, hexit, heq⟩ => + have ⟨hpost, hf⟩ := h ρ₀ ρ_inner hpre hwfb hf₀ (.inr ⟨lbl, hexit⟩) + subst heq; exact hpost_proj ρ_inner _ hpost hf omit [HasVal P] in /-- Lift a `Triple` to a `TripleBlock` for a singleton list. -/ @@ -335,9 +349,10 @@ theorem Triple.toTripleBlock {s : Stmt P CmdT} omit [HasVal P] in /-- Empty block is skip. -/ -theorem skip (l : String) (md : MetaData P) (Pre : Env P → Prop) : +theorem skip (l : String) (md : MetaData P) (Pre : Env P → Prop) + (hpre_proj : PostWF Pre) : Triple (Lang.imperative P CmdT evalCmd extendEval isAtAssertFn) Pre (.block l [] md) Pre := - TripleBlock.toTriple evalCmd extendEval isAtAssertFn (skip_block evalCmd extendEval Pre) + TripleBlock.toTriple evalCmd extendEval isAtAssertFn (skip_block evalCmd extendEval Pre) hpre_proj omit [HasVal P] in /-- If-then-else rule. -/ @@ -397,7 +412,7 @@ theorem hoareTriple_implies_assertValid cases hstep with | step_block => have ⟨inner, heq_cfg, hinner_star, hat_inner⟩ := - block_isAtAssert_inner P' extendEval _ _ _ _ hrest hat + block_isAtAssert_inner P' extendEval _ _ _ _ _ hrest hat subst heq_cfg cases hinner_star with | refl => exact absurd hat_inner (by simp [isAtAssert]) @@ -494,9 +509,9 @@ theorem allAssertsValid_implies_hoareTriple .step _ _ _ StepStmt.step_stmts_cons (.refl _) have h3 := seq_inner_star P' (EvalCmd P') extendEval _ _ [assert_stmt] hstar_st have h_inner := ReflTrans_Transitive _ _ _ _ (ReflTrans_Transitive _ _ _ _ h1 h2) h3 - have h_block := block_inner_star P' (EvalCmd P') extendEval _ _ block_label h_inner + have h_block := block_inner_star P' (EvalCmd P') extendEval _ _ (.some block_label) ρ₀.store h_inner have h_start : StepStmtStar P' (EvalCmd P') extendEval - (.stmt (.block block_label body block_md) ρ₀) (.block block_label (.stmts body ρ₀)) := + (.stmt (.block block_label body block_md) ρ₀) (.block (.some block_label) ρ₀.store (.stmts body ρ₀)) := .step _ _ _ StepStmt.step_block (.refl _) have h_full := ReflTrans_Transitive _ _ _ _ h_start h_block have h_result := hvalid a ρ₀ _ trivial h_full hat @@ -514,12 +529,12 @@ theorem allAssertsValid_implies_hoareTriple (.stmts [assert_stmt] ρ') (.seq (.stmt assert_stmt ρ') []) := .step _ _ _ StepStmt.step_stmts_cons (.refl _) have h_inner := ReflTrans_Transitive _ _ _ _ (ReflTrans_Transitive _ _ _ _ h1 h2) h3 - have h_block := block_inner_star P' (EvalCmd P') extendEval _ _ block_label h_inner + have h_block := block_inner_star P' (EvalCmd P') extendEval _ _ (.some block_label) ρ₀.store h_inner have h_start : StepStmtStar P' (EvalCmd P') extendEval - (.stmt (.block block_label body block_md) ρ₀) (.block block_label (.stmts body ρ₀)) := + (.stmt (.block block_label body block_md) ρ₀) (.block (.some block_label) ρ₀.store (.stmts body ρ₀)) := .step _ _ _ StepStmt.step_block (.refl _) have h_full := ReflTrans_Transitive _ _ _ _ h_start h_block - have h_at : isAtAssert P' (.block block_label (.seq (.stmt assert_stmt ρ') [])) ⟨post_label, post_expr⟩ := by + have h_at : isAtAssert P' (.block (.some block_label) ρ₀.store (.seq (.stmt assert_stmt ρ') [])) ⟨post_label, post_expr⟩ := by simp [isAtAssert, assert_stmt] have h_result := hvalid ⟨post_label, post_expr⟩ ρ₀ _ trivial h_full h_at dsimp [Config.getEval, Config.getStore, Config.getEnv] at h_result diff --git a/Strata/Transform/StructuredToUnstructured.lean b/Strata/Transform/StructuredToUnstructured.lean index eb8d3e9558..1ae2e9945a 100644 --- a/Strata/Transform/StructuredToUnstructured.lean +++ b/Strata/Transform/StructuredToUnstructured.lean @@ -146,27 +146,17 @@ match ss with transfer := .condGoto (HasFvar.mkFvar ident) bl kNext }) let (accumEntry, accumBlocks) ← flushCmds "before_loop$" accum .none lentry pure (accumEntry, accumBlocks ++ [b] ++ bbs ++ decreaseBlocks ++ bsNext) -| .exit l? _md :: _ => do - -- Find the continuation of the block labeled `l`, or the most recently-added - -- block if `l` is `.none`. +| .exit l _md :: _ => do + -- Find the continuation of the block labeled `l`. let bk := - match (l?, exitConts) with + match exitConts.lookup (.some l) with + | .some k => k -- Just keep going if this is an invalid exit. We assume a prior -- check to avoid this. - | (.none, []) => k - | (.none, (_, k) :: _) => k - | (.some l, _) => - match exitConts.lookup (.some l) with - | .some k => k - -- Just keep going if this is an invalid exit. We assume a prior - -- check to avoid this. - | .none => k + | .none => k -- Flush the accumulated commands, going to the continuation calculated above. -- Any statements after the `.exit` are skipped. - let exitName := - match l? with - | .some l => s!"block${l}$" - | .none => "block$" + let exitName := s!"block${l}$" flushCmds exitName accum .none bk def stmtsToCFGM diff --git a/StrataTest/Backends/CBMC/GOTO/ToCProverGOTO.lean b/StrataTest/Backends/CBMC/GOTO/ToCProverGOTO.lean index 7a168fc6b7..4f74eae46b 100644 --- a/StrataTest/Backends/CBMC/GOTO/ToCProverGOTO.lean +++ b/StrataTest/Backends/CBMC/GOTO/ToCProverGOTO.lean @@ -245,7 +245,7 @@ info: ok: #[LOCATION 0, /-- Test exit statement transformation -/ def ExampleStmt5 : List (Imperative.Stmt LExprTP (Imperative.Cmd LExprTP)) := [.cmd (.init (Lambda.Identifier.mk "x" ()) mty[bv32] (.det (.const { underlying := (), type := mty[bv32] } (.bitvecConst 32 0))) {}), - .exit (some "target_label") {}, + .exit "target_label" {}, .cmd (.set (Lambda.Identifier.mk "x" ()) (.det (.const { underlying := (), type := mty[bv32] } (.bitvecConst 32 10))) {}), .block "target_label" [.cmd (.set (Lambda.Identifier.mk "x" ()) (.det (.const { underlying := (), type := mty[bv32] } (.bitvecConst 32 20))) {})] diff --git a/StrataTest/DL/Imperative/FormatStmtTest.lean b/StrataTest/DL/Imperative/FormatStmtTest.lean index 96f40aca0e..3b4062c932 100644 --- a/StrataTest/DL/Imperative/FormatStmtTest.lean +++ b/StrataTest/DL/Imperative/FormatStmtTest.lean @@ -147,11 +147,7 @@ info: while -- 14. exit with label /-- info: exit target -/ -#guard_msgs in #eval! format (Stmt.exit (some "target") .empty : S) - --- 14b. exit without label -/-- info: exit -/ -#guard_msgs in #eval! format (Stmt.exit none .empty : S) +#guard_msgs in #eval! format (Stmt.exit "target" .empty : S) -- 15. funcDecl /-- info: funcDecl -/ diff --git a/StrataTest/DL/Imperative/StepStmtTest.lean b/StrataTest/DL/Imperative/StepStmtTest.lean index d10ec30778..ec26045867 100644 --- a/StrataTest/DL/Imperative/StepStmtTest.lean +++ b/StrataTest/DL/Imperative/StepStmtTest.lean @@ -104,42 +104,80 @@ def noCmd : EvalCmdParam MiniPureExpr CmdT := fun _ _ _ _ _ => False --------------------------------------------------------------------- -/-! ## Test: `loop { exit }` exactly exits the loop, not the outer block. +/-! ## Test: `block "L" { loop { exit "L" } }` exits the loop via labeled exit. -A minimal program `loop { exit }` is shown to step to `.terminal`. This -verifies that an unlabeled `exit` inside the body terminates just the -loop (and not the enclosing block). +The `exit "L"` propagates out of body's per-iteration block and the loop's +recursive step (mismatch propagates), reaching the labeled outer block. -/ -/-- The test program: a deterministic `while (true)` loop whose only body - statement is an unlabeled `exit`. -/ +/-- The test program: a labeled outer block containing a deterministic + `while (true)` loop whose body is `exit "L"`. -/ def prog : Stmt MiniPureExpr CmdT := - .loop (.det .tt) none [] [.exit none .empty] .empty + .block "L" + [.loop (.det .tt) none [] [.exit "L" .empty] .empty] + .empty /-- The test: `.stmt prog ρ₀ →* .terminal ρ₀` -/ theorem progReachesTerminal : StepStmtStar MiniPureExpr noCmd miniExtendEval (.stmt prog ρ₀) (.terminal ρ₀) := by - -- Each step explicitly named; Lean fills the rest. have htt : ρ₀.eval ρ₀.store HasBool.tt = some HasBool.tt := rfl - -- Step 1: step_loop_enter with hasInvFailure = false. + -- Step 1: step_block — enter the outer labeled block. + refine .step _ _ _ StepStmt.step_block ?_ + -- Step 2: step_block_body step_stmts_cons. + refine .step _ _ _ (StepStmt.step_block_body StepStmt.step_stmts_cons) ?_ + -- Step 3: step_block_body (step_seq_inner step_loop_enter). refine .step _ _ _ - (StepStmt.step_loop_enter (hasInvFailure := false) htt ?inv_bool ?inv_iff - miniEval_wfBool) ?rest + (StepStmt.step_block_body + (StepStmt.step_seq_inner + (StepStmt.step_loop_enter (hasInvFailure := false) htt ?inv_bool ?inv_iff + miniEval_wfBool))) ?_ · intro _ hmem; nomatch hmem · constructor <;> intro h · cases h · rcases h with ⟨_, hmem, _⟩; nomatch hmem - -- Post-state: ρ₀' = {ρ₀ with hasFailure := ρ₀.hasFailure || false} definitionally equal to ρ₀. - -- Step 2: step_block_body (step_stmts_cons). - refine .step _ _ _ (StepStmt.step_block_body StepStmt.step_stmts_cons) ?rest2 - -- Step 3: step_block_body (step_seq_inner step_exit). + -- Now: outer block (L) > seq > seq > body's block (.none) > stmts [exit "L"] + -- Step 4: descend into the inner seq, then into the body's block, + -- then through stmts_cons. + refine .step _ _ _ + (StepStmt.step_block_body + (StepStmt.step_seq_inner + (StepStmt.step_seq_inner + (StepStmt.step_block_body StepStmt.step_stmts_cons)))) ?_ + -- Step 5: fire the exit "L". + refine .step _ _ _ + (StepStmt.step_block_body + (StepStmt.step_seq_inner + (StepStmt.step_seq_inner + (StepStmt.step_block_body + (StepStmt.step_seq_inner StepStmt.step_exit))))) ?_ + -- Step 6: step_seq_exit (inner-most seq propagates the exiting). + refine .step _ _ _ + (StepStmt.step_block_body + (StepStmt.step_seq_inner + (StepStmt.step_seq_inner + (StepStmt.step_block_body StepStmt.step_seq_exit)))) ?_ + -- Step 7: body's `.block .none` mismatches "L" — propagate via step_block_exit_mismatch. + refine .step _ _ _ + (StepStmt.step_block_body + (StepStmt.step_seq_inner + (StepStmt.step_seq_inner + (StepStmt.step_block_exit_mismatch (by intro h; cases h))))) ?_ + -- Step 8-9: propagate exiting through outer seq layers. + refine .step _ _ _ + (StepStmt.step_block_body + (StepStmt.step_seq_inner StepStmt.step_seq_exit)) ?_ refine .step _ _ _ - (StepStmt.step_block_body (StepStmt.step_seq_inner StepStmt.step_exit)) ?rest3 - -- Step 4: step_block_body step_seq_exit. - refine .step _ _ _ (StepStmt.step_block_body StepStmt.step_seq_exit) ?rest4 - -- Step 5: step_block_exit_none. - exact .step _ _ _ StepStmt.step_block_exit_none (.refl _) + (StepStmt.step_block_body StepStmt.step_seq_exit) ?_ + -- Step 10: outer block "L" matches the exit label. + -- The store projection equals ρ₀.store since no inits happened. + have hproj : projectStore (P := MiniPureExpr) ρ₀.store ρ₀.store = ρ₀.store := by + funext x + simp [projectStore] + intro h; rfl + conv => rhs; rw [show ρ₀ = { ρ₀ with store := projectStore ρ₀.store ρ₀.store } from by + simp [hproj]] + exact .step _ _ _ (StepStmt.step_block_exit_match rfl) (.refl _) --------------------------------------------------------------------- @@ -148,7 +186,7 @@ theorem progReachesTerminal : def progIteThen : Stmt MiniPureExpr CmdT := .block "L" - [.ite (.det .tt) [.exit none .empty] [] .empty] + [.ite (.det .tt) [.exit "L" .empty] [] .empty] .empty /-- The test: `.stmt progIteThen ρ₀ →* .terminal ρ₀` via the `then` branch. -/ @@ -156,29 +194,26 @@ theorem progIteThenReachesTerminal : StepStmtStar MiniPureExpr noCmd miniExtendEval (.stmt progIteThen ρ₀) (.terminal ρ₀) := by have htt : ρ₀.eval ρ₀.store HasBool.tt = some HasBool.tt := rfl - -- Step 1: step_block — enter the outer block. - refine .step _ _ _ StepStmt.step_block ?rest1 - -- Step 2: step_block_body (step_stmts_cons) — break the singleton stmts list. - refine .step _ _ _ (StepStmt.step_block_body StepStmt.step_stmts_cons) ?rest2 - -- Step 3: step_block_body (step_seq_inner step_ite_true) — take the then branch. + refine .step _ _ _ StepStmt.step_block ?_ + refine .step _ _ _ (StepStmt.step_block_body StepStmt.step_stmts_cons) ?_ refine .step _ _ _ (StepStmt.step_block_body - (StepStmt.step_seq_inner (StepStmt.step_ite_true htt miniEval_wfBool))) ?rest3 - -- Step 4: step_block_body (step_seq_inner step_stmts_cons) — destructure the then body. + (StepStmt.step_seq_inner (StepStmt.step_ite_true htt miniEval_wfBool))) ?_ refine .step _ _ _ - (StepStmt.step_block_body (StepStmt.step_seq_inner StepStmt.step_stmts_cons)) ?rest4 - -- Step 5: step_block_body (step_seq_inner (step_seq_inner step_exit)) — fire the exit. + (StepStmt.step_block_body (StepStmt.step_seq_inner StepStmt.step_stmts_cons)) ?_ refine .step _ _ _ (StepStmt.step_block_body - (StepStmt.step_seq_inner (StepStmt.step_seq_inner StepStmt.step_exit))) ?rest5 - -- Step 6: step_block_body (step_seq_inner step_seq_exit) — propagate past the inner seq. + (StepStmt.step_seq_inner (StepStmt.step_seq_inner StepStmt.step_exit))) ?_ refine .step _ _ _ (StepStmt.step_block_body - (StepStmt.step_seq_inner StepStmt.step_seq_exit)) ?rest6 - -- Step 7: step_block_body step_seq_exit — propagate past the outer seq. - refine .step _ _ _ (StepStmt.step_block_body StepStmt.step_seq_exit) ?rest7 - -- Step 8: step_block_exit_none — the outer block catches the unlabeled exit. - exact .step _ _ _ StepStmt.step_block_exit_none (.refl _) + (StepStmt.step_seq_inner StepStmt.step_seq_exit)) ?_ + refine .step _ _ _ (StepStmt.step_block_body StepStmt.step_seq_exit) ?_ + -- Outer block "L" matches the labeled exit; project store (identity here). + have hproj : projectStore (P := MiniPureExpr) ρ₀.store ρ₀.store = ρ₀.store := by + funext x; simp [projectStore]; intro _; rfl + conv => rhs; rw [show ρ₀ = { ρ₀ with store := projectStore ρ₀.store ρ₀.store } from by + simp [hproj]] + exact .step _ _ _ (StepStmt.step_block_exit_match rfl) (.refl _) --------------------------------------------------------------------- @@ -187,7 +222,7 @@ theorem progIteThenReachesTerminal : def progIteElse : Stmt MiniPureExpr CmdT := .block "L" - [.ite (.det .ff) [] [.exit none .empty] .empty] + [.ite (.det .ff) [] [.exit "L" .empty] .empty] .empty /-- The test: `.stmt progIteElse ρ₀ →* .terminal ρ₀` via the `else` branch. -/ @@ -210,7 +245,295 @@ theorem progIteElseReachesTerminal : (StepStmt.step_block_body (StepStmt.step_seq_inner StepStmt.step_seq_exit)) ?rest6 refine .step _ _ _ (StepStmt.step_block_body StepStmt.step_seq_exit) ?rest7 - exact .step _ _ _ StepStmt.step_block_exit_none (.refl _) + -- Outer block "L" matches the labeled exit; project store (identity here). + have hproj : projectStore (P := MiniPureExpr) ρ₀.store ρ₀.store = ρ₀.store := by + funext x; simp [projectStore]; intro _; rfl + conv => rhs; rw [show ρ₀ = { ρ₀ with store := projectStore ρ₀.store ρ₀.store } from by + simp [hproj]] + exact .step _ _ _ (StepStmt.step_block_exit_match rfl) (.refl _) + +--------------------------------------------------------------------- + +/-- Now extend `Expr` to include a variable reference so we can test + that `getVars` picks up read variables. -/ +inductive Expr2 where + | tt + | ff + | not (e : Expr2) + | var (name : String) + deriving DecidableEq, Repr, Inhabited + +abbrev MiniPureExpr2 : PureExpr := + { Ident := String, + EqIdent := instDecidableEqString, + Expr := Expr2, + Ty := Ty, + ExprMetadata := Unit, + TyEnv := Unit, + TyContext := Unit, + EvalEnv := Unit } + +instance : HasBool MiniPureExpr2 where + tt := .tt + ff := .ff + tt_is_not_ff := by intro h; cases h + boolTy := .Bool + +instance : HasNot MiniPureExpr2 where + not := .not + +/-- Get free variables from `Expr2`. -/ +def Expr2.getVars : Expr2 → List String + | .var n => [n] + | .not e => e.getVars + | _ => [] + +/-- `HasVarsPure` for `Expr2`: only `.var` contributes a variable. -/ +instance : HasVarsPure MiniPureExpr2 Expr2 where + getVars := Expr2.getVars + +instance : HasVarsPure MiniPureExpr2 (Cmd MiniPureExpr2) where + getVars := Cmd.getVars + +/-- Test: `set x := var "y"` has `modifiedOrDefinedVars = ["x"]` (write-set only) + but `touchedVars = ["x", "y"]` (includes the read variable "y"). -/ +example : (Stmt.cmd (P := MiniPureExpr2) + (Cmd.set (P := MiniPureExpr2) "x" (.det (.var "y")) .empty)).modifiedOrDefinedVars + = ["x"] := by native_decide + +example : (Stmt.cmd (P := MiniPureExpr2) + (Cmd.set (P := MiniPureExpr2) "x" (.det (.var "y")) .empty)).touchedVars + = ["x", "y"] := by native_decide + +/-- Test: `init z : Bool := var "w"` has `modifiedOrDefinedVars = ["z"]` + but `touchedVars = ["z", "w"]`. -/ +example : (Stmt.cmd (P := MiniPureExpr2) + (Cmd.init (P := MiniPureExpr2) "z" .Bool (.det (.var "w")) .empty)).modifiedOrDefinedVars + = ["z"] := by native_decide + +example : (Stmt.cmd (P := MiniPureExpr2) + (Cmd.init (P := MiniPureExpr2) "z" .Bool (.det (.var "w")) .empty)).touchedVars + = ["z", "w"] := by native_decide + +/-- Test: Block touchedVars includes both read and write vars from all stmts. -/ +example : (Block.touchedVars (P := MiniPureExpr2) (C := Cmd MiniPureExpr2) + [.cmd (Cmd.init (P := MiniPureExpr2) "a" .Bool (.det (.var "b")) .empty), + .cmd (Cmd.set (P := MiniPureExpr2) "c" (.det (.var "d")) .empty)]) + = ["a", "c", "b", "d"] := by native_decide + +example : (Block.modifiedOrDefinedVars (P := MiniPureExpr2) (C := Cmd MiniPureExpr2) + [.cmd (Cmd.init (P := MiniPureExpr2) "a" .Bool (.det (.var "b")) .empty), + .cmd (Cmd.set (P := MiniPureExpr2) "c" (.det (.var "d")) .empty)]) + = ["a", "c"] := by native_decide + +--------------------------------------------------------------------- + +/-! ## Block scoping tests + +Verify that variables `init`'d inside a block are not visible after the +block exits. We step through a program and verify the terminal store +has `none` for block-local variables thanks to `projectStore`. -/ + +/-- A `HasFvar` instance for `MiniPureExpr` — needed by `EvalCmd`. -/ +instance : HasFvar MiniPureExpr where + mkFvar _ := .tt -- unused but required + getFvar _ := none -- no expression is a free variable reference + +/-- `WellFormedSemanticEvalVar` for `miniEval` — trivially holds since + `getFvar` always returns `none`. -/ +theorem miniEval_wfVar : WellFormedSemanticEvalVar (P := MiniPureExpr) miniEval := by + unfold WellFormedSemanticEvalVar + intro e v σ hfv + simp [HasFvar.getFvar] at hfv + +/-- The standard `EvalCmd` for `Cmd MiniPureExpr`. -/ +def stdEvalCmd : EvalCmdParam MiniPureExpr (Cmd MiniPureExpr) := + EvalCmd MiniPureExpr + +/-- A store where "x" is defined (maps to `.tt`), everything else is `none`. -/ +def storeWithX : SemanticStore MiniPureExpr := + fun v => if v == "x" then some .tt else none + +/-- Env with "x" defined. -/ +def ρ_x : Env MiniPureExpr := + { store := storeWithX, eval := miniEval, hasFailure := false } + +/-- Program: `block B { init y : Bool := tt }`. + After stepping, "y" should not be visible (projected away). -/ +def progBlockScope : Stmt MiniPureExpr (Cmd MiniPureExpr) := + .block "B" [.cmd (.init "y" .Bool (.det .tt) .empty)] .empty + +/-- Store that has both "x" and "y" defined. -/ +def storeWithXY : SemanticStore MiniPureExpr := + fun v => if v == "x" then some .tt + else if v == "y" then some .tt + else none + +/-- Helper: storeWithXY agrees with storeWithX on all variables except "y". -/ +private theorem storeWithXY_frame : + ∀ v : String, "y" ≠ v → storeWithXY v = storeWithX v := by + intro v hne + unfold storeWithXY storeWithX + simp only [beq_iff_eq] + split + · simp + · split + · rename_i heq; exact absurd heq.symm hne + · rfl + +/-- After the block exits, the store should have "x" defined but "y" = none. -/ +theorem blockScopeTest : + StepStmtStar MiniPureExpr stdEvalCmd miniExtendEval + (.stmt progBlockScope ρ_x) + (.terminal { store := storeWithX, eval := miniEval, hasFailure := false }) := by + -- Step 1: step_block — enter the block, saving ρ_x.store as σ_parent. + refine .step _ _ _ StepStmt.step_block ?_ + -- Step 2: step_block_body (step_stmts_cons) — process the singleton list. + refine .step _ _ _ (StepStmt.step_block_body StepStmt.step_stmts_cons) ?_ + -- Step 3: step_block_body (step_seq_inner step_cmd) — evaluate `init y := tt`. + refine .step _ _ _ + (StepStmt.step_block_body + (StepStmt.step_seq_inner + (StepStmt.step_cmd + (EvalCmd.eval_init (P := MiniPureExpr) + (show miniEval storeWithX .tt = some .tt from rfl) + (InitState.init + (show storeWithX "y" = none from rfl) + (show storeWithXY "y" = some .tt from rfl) + storeWithXY_frame) + miniEval_wfVar)))) ?_ + -- Step 4: step_block_body (step_seq_done) — seq is done, go to stmts []. + refine .step _ _ _ + (StepStmt.step_block_body StepStmt.step_seq_done) ?_ + -- Step 5: step_block_body (step_stmts_nil) — empty list becomes terminal. + refine .step _ _ _ + (StepStmt.step_block_body StepStmt.step_stmts_nil) ?_ + -- Step 6: step_block_done — project store. + have hproj : projectStore (P := MiniPureExpr) storeWithX storeWithXY = storeWithX := by + ext v + simp [projectStore, storeWithX, storeWithXY] + split <;> simp_all + conv => rhs; rw [show Env.mk storeWithX miniEval false = + { (Env.mk storeWithXY miniEval false) with store := projectStore storeWithX storeWithXY } + from by simp [hproj]] + exact .step _ _ _ StepStmt.step_block_done (.refl _) + +/-- Directly verify that `projectStore` maps "y" to `none`. -/ +example : projectStore (P := MiniPureExpr) storeWithX storeWithXY "y" = none := by + simp [projectStore, storeWithX, Option.isSome] + +/-- Directly verify that `projectStore` preserves "x". -/ +example : projectStore (P := MiniPureExpr) storeWithX storeWithXY "x" = some .tt := by + simp [projectStore, storeWithX, storeWithXY, Option.isSome] + +--------------------------------------------------------------------- + +/-! ## Loop scoping tests + +Verify that variables `init`'d inside a loop body are scoped to each +iteration. The loop body is wrapped in an anonymous block, so after +each iteration the init'd variable is projected away. -/ + +/-- Program: `loop (nondet) { init y := tt }`. + The loop enters one iteration, inits y, then exits on the next iteration. + The anonymous block wrapper projects "y" away. -/ +def progLoopScope : Stmt MiniPureExpr (Cmd MiniPureExpr) := + .loop .nondet none [] [.cmd (.init "y" .Bool (.det .tt) .empty)] .empty + +/-- After stepping the loop through one iteration and exiting, the final + store should still be `storeWithX` (the variable "y" is projected away + by the per-iteration anonymous block). With the new semantics, each + iteration's body runs in its own block scope. -/ +theorem loopScopeTest : + StepStmtStar MiniPureExpr stdEvalCmd miniExtendEval + (.stmt progLoopScope ρ_x) + (.terminal { store := storeWithX, eval := miniEval, hasFailure := false }) := by + -- Step 1: step_loop_nondet_enter — produces: + -- .seq (.block .none ρ_x.store (.stmts [init y] ρ_x')) [loop ...] + refine .step _ _ _ + (StepStmt.step_loop_nondet_enter (hasInvFailure := false) ?_ ?_) ?_ + · intro _ hmem; nomatch hmem + · constructor <;> intro h + · cases h + · rcases h with ⟨_, hmem, _⟩; nomatch hmem + -- Step 2: step_seq_inner (step_block_body step_stmts_cons) + refine .step _ _ _ + (StepStmt.step_seq_inner + (StepStmt.step_block_body StepStmt.step_stmts_cons)) ?_ + -- Step 3: step_seq_inner (step_block_body (step_seq_inner step_cmd)) — init y + refine .step _ _ _ + (StepStmt.step_seq_inner + (StepStmt.step_block_body + (StepStmt.step_seq_inner + (StepStmt.step_cmd + (EvalCmd.eval_init (P := MiniPureExpr) + (show miniEval storeWithX .tt = some .tt from rfl) + (InitState.init + (show storeWithX "y" = none from rfl) + (show storeWithXY "y" = some .tt from rfl) + storeWithXY_frame) + miniEval_wfVar))))) ?_ + -- Step 4: step_seq_inner (step_block_body step_seq_done) — inner stmt terminal + refine .step _ _ _ + (StepStmt.step_seq_inner + (StepStmt.step_block_body StepStmt.step_seq_done)) ?_ + -- Step 5: step_seq_inner (step_block_body step_stmts_nil) + refine .step _ _ _ + (StepStmt.step_seq_inner + (StepStmt.step_block_body StepStmt.step_stmts_nil)) ?_ + -- Step 6: step_seq_inner step_block_done — body's block projects, dropping "y" + refine .step _ _ _ + (StepStmt.step_seq_inner StepStmt.step_block_done) ?_ + -- After projection, env's store is projectStore storeWithX storeWithXY = storeWithX + have hproj : projectStore (P := MiniPureExpr) storeWithX storeWithXY = storeWithX := by + funext v + simp [projectStore, storeWithX, storeWithXY] + split <;> simp_all + -- Step 7: step_seq_done — seq advances with projected env to [loop ...] + refine .step _ _ _ StepStmt.step_seq_done ?_ + -- Step 8: step_stmts_cons + refine .step _ _ _ StepStmt.step_stmts_cons ?_ + -- Step 9: step_seq_inner step_loop_nondet_exit + refine .step _ _ _ + (StepStmt.step_seq_inner + (StepStmt.step_loop_nondet_exit (hasInvFailure := false) ?_ ?_)) ?_ + · intro _ hmem; nomatch hmem + · constructor <;> intro h + · cases h + · rcases h with ⟨_, hmem, _⟩; nomatch hmem + -- Step 10: step_seq_done + refine .step _ _ _ StepStmt.step_seq_done ?_ + -- Step 11: step_stmts_nil — final terminal + -- The final env's store should be storeWithX after the projection. + -- Need to reconcile the env shape. + conv => rhs; rw [show Env.mk storeWithX miniEval false = + { Env.mk (projectStore storeWithX storeWithXY) miniEval false with + hasFailure := false || false } from by simp [hproj, Bool.or_false]] + exact .step _ _ _ StepStmt.step_stmts_nil (.refl _) + +--------------------------------------------------------------------- + +/-! ## Test: re-init inside an if-branch gets stuck + +`init x := tt; if tt { init x := ff }` gets stuck at the second `init x` +because `InitState` requires the variable to be undefined (`σ x = none`), +but after the first `init`, `x` is already `some .tt`. This confirms that +block scoping is necessary to re-use a variable name. -/ + +def progReinitStuck : List (Stmt MiniPureExpr (Cmd MiniPureExpr)) := + [.cmd (.init "x" .Bool (.det .tt) .empty), + .ite (.det .tt) [.cmd (.init "x" .Bool (.det .ff) .empty)] [] .empty] + +/-- After executing `init x := tt`, the inner `init x := ff` cannot step + because `InitState` requires `σ "x" = none` but `σ "x" = some .tt`. + We show no single step is possible from this configuration. -/ +theorem reinit_stuck : + ¬ ∃ c₂, StepStmt MiniPureExpr stdEvalCmd miniExtendEval + (.stmt (.cmd (.init "x" .Bool (.det .ff) .empty)) ρ_x) c₂ := by + intro ⟨c₂, hstep⟩ + match hstep with + | .step_cmd (.eval_init _ (.init h_none _ _) _) => + exact absurd h_none (by simp [ρ_x, storeWithX]) --------------------------------------------------------------------- diff --git a/StrataTest/Transform/ProcedureInlining.lean b/StrataTest/Transform/ProcedureInlining.lean index 2697471f1f..a7c7c08f4a 100644 --- a/StrataTest/Transform/ProcedureInlining.lean +++ b/StrataTest/Transform/ProcedureInlining.lean @@ -151,11 +151,8 @@ def alphaEquivStatement (s1 s2: Core.Statement) (map:IdMap) .error "invariant does not match" else alphaEquivBlock b1 b2 map - | .exit lbl1 _, .exit lbl2 _ => - match lbl1, lbl2 with - | some l1, some l2 => IdMap.updateLabel map l1 l2 - | none, none => .ok map - | _, _ => mk_err "exit label mismatch" + | .exit l1 _, .exit l2 _ => + IdMap.updateLabel map l1 l2 | .cmd c1, .cmd c2 => match c1, c2 with diff --git a/docs/verso/LangDefDoc.lean b/docs/verso/LangDefDoc.lean index e2aac86773..23ec99c16e 100644 --- a/docs/verso/LangDefDoc.lean +++ b/docs/verso/LangDefDoc.lean @@ -242,8 +242,7 @@ arrangements, including sequencing, alternation, and iteration. Sequencing statements occurs by grouping them into blocks. Loops can be annotated with optional invariants and decreasing measures, which can be used for deductive verification. An `exit` statement transfers control out of the nearest -enclosing block with a matching label, or, if no label is provided, the nearest -enclosing block. In addition, statements include +enclosing block with a matching label. In addition, statements include `funcDecl` for local function declarations (which extend the expression evaluator within a scope) and `typeDecl` for local type declarations. From a5d36ed967983057d9cf0929da176f00c689e82e Mon Sep 17 00:00:00 2001 From: Michael Tautschnig Date: Fri, 15 May 2026 22:43:24 +0200 Subject: [PATCH 60/64] Support SMT string literals and common string ops in translateTerm (#1109) translateSort already handles .prim .string, but translateTerm had no arm for .prim (.string _): any SMT string literal produced by the encoder would fall through to the catch-all and raise 'unsupported term'. Add the missing arm plus the two string operations already supported in Denote.lean so that the two translators agree on the end-to-end-supported subset. Specifically, add arms for: - .prim (.string s) -> (mkString, toExpr s) - .app .str_length [s] _ -> (mkInt, Int.ofNat s.length) - .app .str_concat as _ -> (mkString, leftAssocOp mkStringAppend as) mkStringAppend uses instHAppendOfAppend + instAppendString, which is the same instance chain Lean elaborates inferInstance to for HAppend String String String. Regression tests in StrataTest/DL/SMT/TranslateTests.lean cover all three arms; each fails on origin/main (catch-all throw observable via #guard_msgs mismatch) and passes with this change. I additionally verified under a Meta.check-enabled harness that the produced Expr type-checks in the kernel, so the (fst = mkString/mkInt, snd = ...) pairs are internally consistent. By submitting this pull request, I confirm that you can use, modify, copy, and redistribute this contribution, under the terms of your choice. --------- Co-authored-by: Kiro Co-authored-by: keyboardDrummer-bot --- Strata/DL/SMT/Translate.lean | 46 +++++++++++++++++++ StrataTest/DL/SMT/TranslateTests.lean | 66 +++++++++++++++++++++++++++ 2 files changed, 112 insertions(+) diff --git a/Strata/DL/SMT/Translate.lean b/Strata/DL/SMT/Translate.lean index 465a61dd01..c6de9007fa 100644 --- a/Strata/DL/SMT/Translate.lean +++ b/Strata/DL/SMT/Translate.lean @@ -243,6 +243,30 @@ private def mkBitVecAppend (w v : Nat) : Expr := (mkBitVec w) (mkBitVec v) (mkBitVec (w + v)) (mkApp2 (.const ``BitVec.instHAppendHAddNat []) (toExpr w) (toExpr v)) +private def mkStringAppend : Expr := + mkApp4 (.const ``HAppend.hAppend [0, 0, 0]) + mkString mkString mkString + (mkApp2 (.const ``instHAppendOfAppend [0]) mkString + (.const ``instAppendString [])) + +/-- +Length of a string as an `Int` (via `Int.ofNat`), matching the semantics used +in `Denote.lean`. +-/ +private def mkStringLength (s : Expr) : Expr := + .app (.const ``Int.ofNat []) (.app (.const ``String.length []) s) + +/-- +Throw unless `α` is the Lean `String` type (as produced by `mkString`). Used +to guard string-theory operations so that a malformed SMT term such as +`(.app .str_length [.prim (.int 0)] ...)` is rejected up front, matching the +behaviour of `Denote.denoteTerm`. +-/ +private def expectString (α : Expr) : TranslateM Unit := + match α with + | .const ``String [] => return () + | _ => throw m!"Error: expected String type, got '{α}'" + def symbolToName (s : String) : Name := -- Quote the string if a natural translation to Name fails if s.toName == .anonymous then @@ -496,6 +520,28 @@ def translateTerm (t : SMT.Term) : TranslateM (Expr × Expr) := do let (α, x) ← translateTerm x let w ← getBitVecWidth α return (mkBitVec (w + i), mkApp3 (.const ``BitVec.zeroExtend []) (toExpr w) (toExpr (w + i)) x) + -- SMT-Lib theory of strings + | .prim (.string s) => + return (mkString, toExpr s) + | .app .str_length [s] _ => + let (α, s) ← translateTerm s + expectString α + return (mkInt, mkStringLength s) + | .app .str_concat as _ => + -- `Denote.leftAssoc` requires at least two operands and checks that each + -- operand has the expected type. Mirror that here rather than delegating + -- to `leftAssocOp`, which does neither. + let a :: b :: as := as + | throw m!"Error: str_concat expects at least two operands, got '{as.length}'" + let (α, a) ← translateTerm a + expectString α + let (β, b) ← translateTerm b + expectString β + let as ← as.mapM fun t => do + let (γ, e) ← translateTerm t + expectString γ + return e + return (mkString, as.foldl (mkApp2 mkStringAppend) (mkApp2 mkStringAppend a b)) | t => throw m!"Error: unsupported term '{repr t}'" where leftAssocOp (op : Expr) (as : List SMT.Term) : TranslateM (Expr × Expr) := do diff --git a/StrataTest/DL/SMT/TranslateTests.lean b/StrataTest/DL/SMT/TranslateTests.lean index 79810f8b13..43c7c93611 100644 --- a/StrataTest/DL/SMT/TranslateTests.lean +++ b/StrataTest/DL/SMT/TranslateTests.lean @@ -74,3 +74,69 @@ info: ∀ (α : Type → Type → Type) [inst : ∀ (α_1 α_2 : Type), Nonempty let inner := .app .ite [c, (.prim (.int 1)), (.prim (.int 2))] (.prim .int) let outer := .app .ite [c, inner, (.prim (.int 3))] (.prim .int) elabQuery {} [] (.app .eq [outer, (.prim (.int 1))] (.prim .bool)) + +-- SMT-Lib theory of strings: literals and the operations supported by +-- `Denote.lean` (`str_length`, `str_concat`). + +/-- info: "hi" = "hi" -/ +#guard_msgs in +#eval + elabQuery {} [] (.app .eq [(.prim (.string "hi")), (.prim (.string "hi"))] (.prim .bool)) + +/-- info: Int.ofNat "hello".length = 5 -/ +#guard_msgs in +#eval + elabQuery {} [] + (.app .eq [(.app .str_length [(.prim (.string "hello"))] (.prim .int)), (.prim (.int 5))] + (.prim .bool)) + +/-- info: "hi" ++ " there" = "hi there" -/ +#guard_msgs in +#eval + elabQuery {} [] + (.app .eq [(.app .str_concat [(.prim (.string "hi")), (.prim (.string " there"))] (.prim .string)), + (.prim (.string "hi there"))] + (.prim .bool)) + +/-- info: "a" ++ "b" ++ "c" = "abc" -/ +#guard_msgs in +#eval + elabQuery {} [] + (.app .eq + [(.app .str_concat + [(.prim (.string "a")), (.prim (.string "b")), (.prim (.string "c"))] + (.prim .string)), + (.prim (.string "abc"))] + (.prim .bool)) + +-- Malformed string terms are rejected up front, matching `Denote.denoteTerm`. +-- Using `.prim (.bool _)` (which translates to type `Prop`) for the +-- non-string operand keeps the expected error message stable independent of +-- how `.prim (.int _)` happens to be typed by the translator. + +/-- error: Error: expected String type, got 'Prop' -/ +#guard_msgs in +#eval + elabQuery {} [] + (.app .eq + [(.app .str_length [(.prim (.bool true))] (.prim .int)), + (.prim (.int 0))] + (.prim .bool)) + +/-- error: Error: str_concat expects at least two operands, got '1' -/ +#guard_msgs in +#eval + elabQuery {} [] + (.app .eq + [(.app .str_concat [(.prim (.string "hi"))] (.prim .string)), + (.prim (.string "hi"))] + (.prim .bool)) + +/-- error: Error: expected String type, got 'Prop' -/ +#guard_msgs in +#eval + elabQuery {} [] + (.app .eq + [(.app .str_concat [(.prim (.bool true)), (.prim (.string "hi"))] (.prim .string)), + (.prim (.string "hi"))] + (.prim .bool)) From 50b0e124ffe0b88a8d4572fc2411166b16964245 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mika=C3=ABl=20Mayer?= Date: Fri, 15 May 2026 15:59:05 -0500 Subject: [PATCH 61/64] feat: introduce Provenance type and migrate metadata from FileRange (#1140) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes #1139 Introduces a `Provenance` type that fully replaces `FileRange` and `SourceRange` as the canonical way to store source locations in metadata. This structurally eliminates the "SourceRange without file name" problem. The `Provenance` type has two constructors: - `Provenance.loc uri range` — a real source location (always requires both URI and range) - `Provenance.synthesized origin` — a node created programmatically, with a `SynthesizedOrigin` inductive type A `SynthesizedOrigin` inductive enforces that only canonical origins are used (`smtEncode`, `nondetIte`, `laurelParse`, `laurel`, `laurelToCore`, `structuredToUnstructured`), preventing typos and duplicates at the type level. Key changes: - The `.fileRange` variant is removed from `MetaDataElem.Value` — all metadata values now use `.provenance` exclusively - `MetaData.ofSourceRange` emits only a provenance element - `getProvenance` is the single source of truth for reading source locations from metadata - `setCallSiteFileRange` works directly with `Provenance` instead of roundtripping through `FileRange` - `getFileRange` delegates to `getProvenance` for extraction - `FileRange.unknown` and `SourceRange.none` eliminated from metadata construction - SMT DDM translator uses `smtAnn` combinator to reduce annotation boilerplate - SARIF output uses `getFileRange` (which reads provenance) `FileRange` remains as a utility struct for extraction and formatting (e.g., in `DiagnosticModel`), but is no longer a metadata value type. Existing tests pass unchanged. ## Follow-up - Migrate the B3, Boole, and Python grammar ASTs from using `SourceRange` as their annotation type parameter to `Provenance`. This would allow combining multiple files at the AST level and enable proper provenance tracking through translation passes. --- .../Backends/CBMC/GOTO/CoreToCProverGOTO.lean | 2 +- Strata/DL/Imperative/MetaData.lean | 81 ++++--- Strata/DL/SMT/DDMTransform/Translate.lean | 213 +++++++++--------- Strata/Languages/Boole/Verify.lean | 4 +- .../C_Simp/DDMTransform/Translate.lean | 5 +- .../Core/DDMTransform/Translate.lean | 5 +- Strata/Languages/Core/SarifOutput.lean | 15 +- Strata/Languages/Core/StatementEval.lean | 4 +- .../ConcreteToAbstractTreeTranslator.lean | 4 +- Strata/Languages/Laurel/Laurel.lean | 5 +- .../Laurel/LaurelToCoreTranslator.lean | 8 +- Strata/Languages/Laurel/TypeHierarchy.lean | 7 +- Strata/Languages/Python/PythonToCore.lean | 4 +- Strata/Languages/Python/PythonToLaurel.lean | 2 +- .../Transform/StructuredToUnstructured.lean | 17 +- Strata/Util/Provenance.lean | 63 ++++++ .../Languages/Core/Tests/SMTEncoderTests.lean | 3 +- .../Core/Tests/SarifOutputTests.lean | 8 +- 18 files changed, 265 insertions(+), 185 deletions(-) create mode 100644 Strata/Util/Provenance.lean diff --git a/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean index bd353e0895..a0ef4725c2 100644 --- a/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean +++ b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean @@ -108,8 +108,8 @@ def convertMetaData (md : Imperative.MetaData Core.Expression) match elem.fld with | .label l => match elem.value with | .msg s => some ⟨.label l, .msg s⟩ - | .fileRange r => some ⟨.label l, .fileRange r⟩ | .switch b => some ⟨.label l, .switch b⟩ + | .provenance p => some ⟨.label l, .provenance p⟩ | .expr _ => none | .var _ => none diff --git a/Strata/DL/Imperative/MetaData.lean b/Strata/DL/Imperative/MetaData.lean index dff78ea614..f3d3a384d1 100644 --- a/Strata/DL/Imperative/MetaData.lean +++ b/Strata/DL/Imperative/MetaData.lean @@ -8,9 +8,10 @@ module public import Strata.DL.Imperative.PureExpr public import Strata.DL.Util.DecidableEq public import Strata.Util.FileRange +public import Strata.Util.Provenance namespace Imperative -open Strata +open Strata (DiagnosticModel DiagnosticType FileRange Provenance Uri SourceRange) public section @@ -69,23 +70,23 @@ instance [Repr P.Ident] : Repr (MetaDataElem.Field P) where | .label s => f!"MetaDataElem.Field.label {s}" Repr.addAppParen res prec -/-- A metadata value, which can be either an expression, a message, or a fileRange -/ +/-- A metadata value, which can be either an expression, a message, a switch, or a provenance. -/ inductive MetaDataElem.Value (P : PureExpr) where /-- Metadata value in the form of a structured expression. -/ | expr (e : P.Expr) /-- Metadata value in the form of an arbitrary string. -/ | msg (s : String) - /-- Metadata value in the form of a fileRange. -/ - | fileRange (r: FileRange) /-- Metadata value in the form of a boolean switch. -/ | switch (b : Bool) + /-- Metadata value in the form of a provenance (source location or synthesized origin). -/ + | provenance (p : Provenance) instance [ToFormat P.Expr] : ToFormat (MetaDataElem.Value P) where format f := match f with | .expr e => f!"{e}" | .msg s => f!"{s}" - | .fileRange r => f!"{r}" | .switch b => f!"{b}" + | .provenance p => f!"{p}" instance [Repr P.Expr] : Repr (MetaDataElem.Value P) where reprPrec v prec := @@ -93,16 +94,16 @@ instance [Repr P.Expr] : Repr (MetaDataElem.Value P) where match v with | .expr e => f!".expr {reprPrec e prec}" | .msg s => f!".msg {s}" - | .fileRange fr => f!".fileRange {fr}" | .switch b => f!".switch {repr b}" + | .provenance p => f!".provenance {repr p}" Repr.addAppParen res prec def MetaDataElem.Value.beq [BEq P.Expr] (v1 v2 : MetaDataElem.Value P) := match v1, v2 with | .expr e1, .expr e2 => e1 == e2 | .msg m1, .msg m2 => m1 == m2 - | .fileRange r1, .fileRange r2 => r1 == r2 | .switch b1, .switch b2 => b1 == b2 + | .provenance p1, .provenance p2 => p1 == p2 | _, _ => false instance [BEq P.Expr] : BEq (MetaDataElem.Value P) where @@ -178,7 +179,8 @@ instance [Repr P.Expr] [Repr P.Ident] : Repr (MetaDataElem P) where /-! ### Common metadata fields -/ @[match_pattern] -abbrev MetaData.fileRange : MetaDataElem.Field P := .label "fileRange" +abbrev MetaData.provenanceField : MetaDataElem.Field P := .label "provenance" + @[match_pattern] abbrev MetaData.reachCheck : MetaDataElem.Field P := .label "reachCheck" @[match_pattern] @@ -222,18 +224,31 @@ def MetaData.hasSatisfiabilityCheck {P : PureExpr} [BEq P.Ident] (md : MetaData | _ => false | none => false +/-- Get the provenance from metadata. -/ +def getProvenance {P : PureExpr} [BEq P.Ident] (md : MetaData P) : Option Provenance := do + let elem ← md.findElem Imperative.MetaData.provenanceField + match elem.value with + | .provenance p => some p + | _ => none + def getFileRange {P : PureExpr} [BEq P.Ident] (md: MetaData P) : Option FileRange := do - let fileRangeElement <- md.findElem Imperative.MetaData.fileRange - match fileRangeElement.value with - | .fileRange fileRange => - some fileRange - | _ => none + let p ← getProvenance md + p.toFileRange + +/-- Create metadata with a provenance element. -/ +def MetaData.ofProvenance {P : PureExpr} (p : Provenance) : MetaData P := + #[{ fld := MetaData.provenanceField, value := .provenance p }] + +/-- Create metadata from a source range and URI, storing provenance. -/ +def MetaData.ofSourceRange {P : PureExpr} (uri : Uri) (sr : SourceRange) : MetaData P := + MetaData.ofProvenance (Provenance.ofSourceRange uri sr) /-- Create a DiagnosticModel from metadata and a message. - Uses the file range from metadata if available, otherwise uses a default location. -/ + Uses provenance or file range from metadata if available, otherwise uses a default location. -/ def MetaData.toDiagnostic {P : PureExpr} [BEq P.Ident] (md : MetaData P) (msg : String) (type : DiagnosticType := DiagnosticType.UserError): DiagnosticModel := - match getFileRange md with - | some fr => DiagnosticModel.withRange fr msg type + match getProvenance md with + | some (.loc uri range) => DiagnosticModel.withRange { file := uri, range } msg type + | some (.synthesized _) => DiagnosticModel.fromMessage msg type | none => DiagnosticModel.fromMessage msg type /-- Create a DiagnosticModel from metadata and a Format message. -/ @@ -261,7 +276,16 @@ def getRelatedFileRanges {P : PureExpr} [BEq P.Ident] (md: MetaData P) : Array F md.filterMap fun elem => if elem.fld == Imperative.MetaData.relatedFileRange then match elem.value with - | .fileRange fr => some fr + | .provenance p => p.toFileRange + | _ => none + else none + +/-- Get all related provenances from metadata, in order. -/ +private def getRelatedProvenances {P : PureExpr} [BEq P.Ident] (md: MetaData P) : Array Provenance := + md.filterMap fun elem => + if elem.fld == Imperative.MetaData.relatedFileRange then + match elem.value with + | .provenance p => some p | _ => none else none @@ -270,20 +294,21 @@ def MetaData.eraseAllElems {P : PureExpr} [BEq P.Ident] (md : MetaData P) (fld : MetaDataElem.Field P) : MetaData P := md.filter (fun e => !(e.fld == fld)) -/-- Replace the primary file range with a new one, shifting existing related - file ranges and prepending the old primary range. -/ +/-- Replace the primary provenance with a new one, shifting existing related + provenances and prepending the old primary provenance. -/ def MetaData.setCallSiteFileRange {P : PureExpr} [BEq P.Ident] (md : MetaData P) (callSiteRange : MetaData P) : MetaData P := - match getFileRange callSiteRange, getFileRange md with - | some csRange, some origRange => - let existingRelated := getRelatedFileRanges md - let md := md.eraseElem MetaData.fileRange + match getProvenance callSiteRange, getProvenance md with + | some csProv, some origProv => + let existingRelated := getRelatedProvenances md + let md := md.eraseElem MetaData.provenanceField let md := md.eraseAllElems MetaData.relatedFileRange - let md := md.pushElem MetaData.fileRange (.fileRange csRange) - let md := md.pushElem MetaData.relatedFileRange (.fileRange origRange) - existingRelated.foldl (fun md fr => md.pushElem MetaData.relatedFileRange (.fileRange fr)) md - | some csRange, none => - md.pushElem MetaData.fileRange (.fileRange csRange) + let md := md.pushElem MetaData.provenanceField (.provenance csProv) + let md := md.pushElem MetaData.relatedFileRange (.provenance origProv) + existingRelated.foldl (fun md p => md.pushElem MetaData.relatedFileRange (.provenance p)) md + | some csProv, none => + let md := md.eraseElem MetaData.provenanceField + md.pushElem MetaData.provenanceField (.provenance csProv) | none, _ => md /-- Metadata field for property type classification (e.g., "divisionByZero"). -/ diff --git a/Strata/DL/SMT/DDMTransform/Translate.lean b/Strata/DL/SMT/DDMTransform/Translate.lean index 87b062a1bb..740314bc4c 100644 --- a/Strata/DL/SMT/DDMTransform/Translate.lean +++ b/Strata/DL/SMT/DDMTransform/Translate.lean @@ -7,6 +7,7 @@ module public import Strata.DL.SMT.DDMTransform.Parse public import Strata.DL.SMT.Term +public import Strata.Util.Provenance public import Strata.Util.Tactics import Strata.DDM.Elab.LoadedDialects @@ -16,87 +17,91 @@ public section namespace SMTDDM -private def mkQualifiedIdent (s:String):QualifiedIdent SourceRange := - .qualifiedIdentImplicit SourceRange.none (Ann.mk SourceRange.none s) +/-- Annotation used for all synthesized SMT DDM nodes. -/ +private abbrev smtProv : Provenance := .synthesized .smtEncode -private def mkSimpleSymbol (s:String):SimpleSymbol SourceRange := +/-- Wrap a value with the SMT provenance annotation. -/ +private abbrev smtAnn (v : α) : Ann α Provenance := Ann.mk smtProv v + +private def mkQualifiedIdent (s:String):QualifiedIdent Provenance := + .qualifiedIdentImplicit smtProv (smtAnn s) + +private def mkSimpleSymbol (s:String):SimpleSymbol Provenance := match List.find? (fun (_,sym) => sym = s) specialCharsInSimpleSymbol with | .some (name,_) => -- This needs hard-coded for now. (match name with - | "plus" => .simple_symbol_plus SourceRange.none - | "minus" => .simple_symbol_minus SourceRange.none - | "star" => .simple_symbol_star SourceRange.none - | "eq" => .simple_symbol_eq SourceRange.none - | "percent" => .simple_symbol_percent SourceRange.none - | "questionmark" => .simple_symbol_questionmark SourceRange.none - | "period" => .simple_symbol_period SourceRange.none - | "tilde" => .simple_symbol_tilde SourceRange.none - | "amp" => .simple_symbol_amp SourceRange.none - | "caret" => .simple_symbol_caret SourceRange.none - | "lt" => .simple_symbol_lt SourceRange.none - | "gt" => .simple_symbol_gt SourceRange.none - | "at" => .simple_symbol_at SourceRange.none - | "le" => .simple_symbol_le SourceRange.none - | "ge" => .simple_symbol_ge SourceRange.none - | "implies" => .simple_symbol_implies SourceRange.none + | "plus" => .simple_symbol_plus smtProv + | "minus" => .simple_symbol_minus smtProv + | "star" => .simple_symbol_star smtProv + | "eq" => .simple_symbol_eq smtProv + | "percent" => .simple_symbol_percent smtProv + | "questionmark" => .simple_symbol_questionmark smtProv + | "period" => .simple_symbol_period smtProv + | "tilde" => .simple_symbol_tilde smtProv + | "amp" => .simple_symbol_amp smtProv + | "caret" => .simple_symbol_caret smtProv + | "lt" => .simple_symbol_lt smtProv + | "gt" => .simple_symbol_gt smtProv + | "at" => .simple_symbol_at smtProv + | "le" => .simple_symbol_le smtProv + | "ge" => .simple_symbol_ge smtProv + | "implies" => .simple_symbol_implies smtProv | _ => panic! s!"Unknown simple symbol: {name}") | .none => - .simple_symbol_qid SourceRange.none (mkQualifiedIdent s) + .simple_symbol_qid smtProv (mkQualifiedIdent s) -private def mkSymbol (s:String):Symbol SourceRange := - .symbol SourceRange.none (mkSimpleSymbol s) +private def mkSymbol (s:String):Symbol Provenance := + .symbol smtProv (mkSimpleSymbol s) -private def mkIdentifier (s:String):SMTIdentifier SourceRange := - .iden_simple SourceRange.none (mkSymbol s) +private def mkIdentifier (s:String):SMTIdentifier Provenance := + .iden_simple smtProv (mkSymbol s) private def translateFromTermPrim (t:SMT.TermPrim): - Except String (SMTDDM.Term SourceRange) := do - let srnone := SourceRange.none + Except String (SMTDDM.Term Provenance) := do match t with | .bool b => - let ss:SimpleSymbol SourceRange := - if b then .simple_symbol_tt srnone else .simple_symbol_ff srnone - return (.qual_identifier srnone - (.qi_ident srnone (.iden_simple srnone (.symbol srnone ss)))) + let ss:SimpleSymbol Provenance := + if b then .simple_symbol_tt smtProv else .simple_symbol_ff smtProv + return (.qual_identifier smtProv + (.qi_ident smtProv (.iden_simple smtProv (.symbol smtProv ss)))) | .int i => let abs_i := if i < 0 then -i else i if i >= 0 then - return .spec_constant_term srnone (.sc_numeral srnone abs_i.toNat) + return .spec_constant_term smtProv (.sc_numeral smtProv abs_i.toNat) else -- SMT-LIB represents negative integers as (- N), i.e. unary minus -- applied to the absolute value. - let posTerm := Term.spec_constant_term srnone (.sc_numeral srnone abs_i.toNat) - return .qual_identifier_args srnone - (.qi_ident srnone (mkIdentifier "-")) - (Ann.mk srnone #[posTerm]) + let posTerm := Term.spec_constant_term smtProv (.sc_numeral smtProv abs_i.toNat) + return .qual_identifier_args smtProv + (.qi_ident smtProv (mkIdentifier "-")) + (smtAnn #[posTerm]) | .real dec => - return .spec_constant_term srnone (.sc_decimal srnone dec) + return .spec_constant_term smtProv (.sc_decimal smtProv dec) | .bitvec (n := n) bv => let bvty := mkSymbol (s!"bv{bv.toNat}") - let val:Index SourceRange := .ind_numeral srnone n - return (.qual_identifier srnone - (.qi_ident srnone (.iden_indexed srnone bvty (Ann.mk srnone #[val])))) + let val:Index Provenance := .ind_numeral smtProv n + return (.qual_identifier smtProv + (.qi_ident smtProv (.iden_indexed smtProv bvty (smtAnn #[val])))) | .string s => - return .spec_constant_term srnone (.sc_str srnone s) + return .spec_constant_term smtProv (.sc_str smtProv s) -- List of SMTSort to Array. -private def translateFromSMTSortList (l: List (SMTSort SourceRange)): - Array (SMTSort SourceRange) := +private def translateFromSMTSortList (l: List (SMTSort Provenance)): + Array (SMTSort Provenance) := l.toArray private def translateFromTermType (t:SMT.TermType): - Except String (SMTDDM.SMTSort SourceRange) := do - let srnone := SourceRange.none + Except String (SMTDDM.SMTSort Provenance) := do match t with | .prim tp => match tp with | .bitvec n => - let idx : Index SourceRange := .ind_numeral srnone n - return (.smtsort_ident srnone - (.iden_indexed srnone + let idx : Index Provenance := .ind_numeral smtProv n + return (.smtsort_ident smtProv + (.iden_indexed smtProv (mkSymbol "BitVec") - (Ann.mk srnone #[idx]))) + (smtAnn #[idx]))) | .trigger => throw "don't know how to translate a trigger type" | _ => @@ -107,122 +112,116 @@ private def translateFromTermType (t:SMT.TermType): | .string => .ok "String" | .regex => .ok "RegLan" | _ => throw "unreachable" - return .smtsort_ident srnone (mkIdentifier res) + return .smtsort_ident smtProv (mkIdentifier res) | .option ty => let argty ← translateFromTermType ty - return .smtsort_param srnone (mkIdentifier "Option") (Ann.mk srnone #[argty]) + return .smtsort_param smtProv (mkIdentifier "Option") (smtAnn #[argty]) | .constr id args => let argtys <- args.mapM translateFromTermType let argtys_array := translateFromSMTSortList argtys if argtys_array.isEmpty then - return .smtsort_ident srnone (mkIdentifier id) + return .smtsort_ident smtProv (mkIdentifier id) else - return .smtsort_param srnone (mkIdentifier id) (Ann.mk srnone argtys_array) + return .smtsort_param smtProv (mkIdentifier id) (smtAnn argtys_array) -- Helper: convert an Index to an SExpr -private def indexToSExpr (idx : SMTDDM.Index SourceRange) - : SMTDDM.SExpr SourceRange := - let srnone := SourceRange.none +private def indexToSExpr (idx : SMTDDM.Index Provenance) + : SMTDDM.SExpr Provenance := match idx with - | .ind_numeral _ n => .se_spec_const srnone (.sc_numeral srnone n) - | .ind_symbol _ sym => .se_symbol srnone sym + | .ind_numeral _ n => .se_spec_const smtProv (.sc_numeral smtProv n) + | .ind_symbol _ sym => .se_symbol smtProv sym -- Helper: convert an indexed identifier to an SExpr: (_ sym idx1 idx2 ...) -private def indexedIdentToSExpr (sym : SMTDDM.Symbol SourceRange) - (indices : Ann (Array (SMTDDM.Index SourceRange)) SourceRange) - : SMTDDM.SExpr SourceRange := - let srnone := SourceRange.none - let underscoreSym := SMTDDM.SExpr.se_symbol srnone (mkSymbol "_") +private def indexedIdentToSExpr (sym : SMTDDM.Symbol Provenance) + (indices : Ann (Array (SMTDDM.Index Provenance)) Provenance) + : SMTDDM.SExpr Provenance := + let underscoreSym := SMTDDM.SExpr.se_symbol smtProv (mkSymbol "_") let idxSExprs := indices.val.toList.map indexToSExpr - .se_ls srnone (Ann.mk srnone ((underscoreSym :: .se_symbol srnone sym :: idxSExprs).toArray)) + .se_ls smtProv (smtAnn ((underscoreSym :: .se_symbol smtProv sym :: idxSExprs).toArray)) -- Helper: convert an SMTSort to an SExpr for use in pattern attributes -private def sortToSExpr (s : SMTDDM.SMTSort SourceRange) - : Except String (SMTDDM.SExpr SourceRange) := do - let srnone := SourceRange.none +private def sortToSExpr (s : SMTDDM.SMTSort Provenance) + : Except String (SMTDDM.SExpr Provenance) := do match s with - | .smtsort_ident _ (.iden_simple _ sym) => return .se_symbol srnone sym + | .smtsort_ident _ (.iden_simple _ sym) => return .se_symbol smtProv sym | .smtsort_ident _ (.iden_indexed _ sym indices) => return indexedIdentToSExpr sym indices | .smtsort_param _ (.iden_simple _ sym) args => let argsSExpr ← args.val.toList.mapM sortToSExpr - return .se_ls srnone (Ann.mk srnone ((.se_symbol srnone sym :: argsSExpr).toArray)) + return .se_ls smtProv (smtAnn ((.se_symbol smtProv sym :: argsSExpr).toArray)) | _ => throw s!"Doesn't know how to convert sort {repr s} to SMTDDM.SExpr" termination_by SizeOf.sizeOf s decreasing_by cases args; simp_all; term_by_mem -- Helper: convert a QualIdentifier to an SExpr for use in pattern attributes -private def qiToSExpr (qi : SMTDDM.QualIdentifier SourceRange) - : Except String (SMTDDM.SExpr SourceRange) := do - let srnone := SourceRange.none +private def qiToSExpr (qi : SMTDDM.QualIdentifier Provenance) + : Except String (SMTDDM.SExpr Provenance) := do match qi with - | .qi_ident _ (.iden_simple _ sym) => pure (.se_symbol srnone sym) + | .qi_ident _ (.iden_simple _ sym) => pure (.se_symbol smtProv sym) | .qi_ident _ (.iden_indexed _ sym indices) => pure (indexedIdentToSExpr sym indices) | .qi_isort _ (.iden_simple _ sym) sort => let sortSExpr ← sortToSExpr sort - let asSym := SMTDDM.SExpr.se_symbol srnone (mkSymbol "as") - pure (.se_ls srnone (Ann.mk srnone #[asSym, .se_symbol srnone sym, sortSExpr])) + let asSym := SMTDDM.SExpr.se_symbol smtProv (mkSymbol "as") + pure (.se_ls smtProv (smtAnn #[asSym, .se_symbol smtProv sym, sortSExpr])) | _ => throw s!"Doesn't know how to convert QI {repr qi} to SMTDDM.SExpr" -- Helper function to convert a SMTDDM.Term to SExpr for use in pattern attributes -def termToSExpr (t : SMTDDM.Term SourceRange) - : Except String (SMTDDM.SExpr SourceRange) := do - let srnone := SourceRange.none +def termToSExpr (t : SMTDDM.Term Provenance) + : Except String (SMTDDM.SExpr Provenance) := do match t with | .qual_identifier _ qi => qiToSExpr qi | .qual_identifier_args _ qi args => let qiSExpr ← qiToSExpr qi let argsSExpr ← args.val.mapM termToSExpr - return .se_ls srnone (Ann.mk srnone ((qiSExpr :: argsSExpr.toList).toArray)) - | .spec_constant_term _ s => return .se_spec_const srnone s + return .se_ls smtProv (smtAnn ((qiSExpr :: argsSExpr.toList).toArray)) + | .spec_constant_term _ s => return .se_spec_const smtProv s | _ => throw s!"Doesn't know how to convert {repr t} to SMTDDM.SExpr" decreasing_by cases args; term_by_mem -partial def translateFromTerm (t:SMT.Term): Except String (SMTDDM.Term SourceRange) := do - let srnone := SourceRange.none +partial def translateFromTerm (t:SMT.Term): Except String (SMTDDM.Term Provenance) := do match t with | .prim p => translateFromTermPrim p | .var v => - return .qual_identifier srnone (.qi_ident srnone (.iden_simple srnone - (.symbol srnone (mkSimpleSymbol v.id)))) + return .qual_identifier smtProv (.qi_ident smtProv (.iden_simple smtProv + (.symbol smtProv (mkSimpleSymbol v.id)))) | .none _ | .some _ => throw "don't know how to translate none and some" | .app op args retTy => let args' <- args.mapM translateFromTerm let args_array := args'.toArray - let mk_qual_identifier (qi:QualIdentifier SourceRange) : SMTDDM.Term SourceRange := + let mk_qual_identifier (qi:QualIdentifier Provenance) : SMTDDM.Term Provenance := if args_array.isEmpty then - (.qual_identifier srnone qi) + (.qual_identifier smtProv qi) else - (.qual_identifier_args srnone qi (Ann.mk srnone args_array)) + (.qual_identifier_args smtProv qi (smtAnn args_array)) -- Datatype constructors need (as Name RetType) qualification for SMT-LIB match op with | .datatype_op .constructor name => let retSort ← translateFromTermType retTy - let qi := QualIdentifier.qi_isort srnone (mkIdentifier name) retSort + let qi := QualIdentifier.qi_isort smtProv (mkIdentifier name) retSort return mk_qual_identifier qi | .bv (.zero_extend n) => - let iden := SMTIdentifier.iden_indexed srnone (mkSymbol "zero_extend") - (Ann.mk srnone #[.ind_numeral srnone n]) - return mk_qual_identifier (.qi_ident srnone iden) + let iden := SMTIdentifier.iden_indexed smtProv (mkSymbol "zero_extend") + (smtAnn #[.ind_numeral smtProv n]) + return mk_qual_identifier (.qi_ident smtProv iden) | .str (.re_index n) => - let iden := SMTIdentifier.iden_indexed srnone (mkSymbol "re.^") - (Ann.mk srnone #[.ind_numeral srnone n]) - return mk_qual_identifier (.qi_ident srnone iden) + let iden := SMTIdentifier.iden_indexed smtProv (mkSymbol "re.^") + (smtAnn #[.ind_numeral smtProv n]) + return mk_qual_identifier (.qi_ident smtProv iden) | .str (.re_loop n₁ n₂) => - let iden := SMTIdentifier.iden_indexed srnone (mkSymbol "re.loop") - (Ann.mk srnone #[.ind_numeral srnone n₁, .ind_numeral srnone n₂]) - return mk_qual_identifier (.qi_ident srnone iden) + let iden := SMTIdentifier.iden_indexed smtProv (mkSymbol "re.loop") + (smtAnn #[.ind_numeral smtProv n₁, .ind_numeral smtProv n₂]) + return mk_qual_identifier (.qi_ident smtProv iden) | _ => - return mk_qual_identifier (.qi_ident srnone (mkIdentifier op.mkName)) + return mk_qual_identifier (.qi_ident smtProv (mkIdentifier op.mkName)) | .quant qkind args tr body => - let args_sorted:List (SMTDDM.SortedVar SourceRange) <- + let args_sorted:List (SMTDDM.SortedVar Provenance) <- args.mapM (fun ⟨name,ty⟩ => do let ty' <- translateFromTermType ty - return .sorted_var srnone (mkSymbol name) ty') + return .sorted_var smtProv (mkSymbol name) ty') let args_array := args_sorted.toArray if args_array.isEmpty then throw "empty quantifier" @@ -241,7 +240,7 @@ partial def translateFromTerm (t:SMT.Term): Except String (SMTDDM.Term SourceRan -- .app .triggers [.app .triggers group₁ .trigger, .app .triggers group₂ .trigger, ...] .trigger -- Each inner .app .triggers represents one :pattern group. -- If a trigger term is NOT .app .triggers, treat it as a single-term group. - let mut patternAttrs : Array (SMTDDM.Attribute SourceRange) := #[] + let mut patternAttrs : Array (SMTDDM.Attribute Provenance) := #[] for trigTerm in triggerTerms do let sexprs ← match trigTerm with | .app .triggers its _ => do @@ -250,22 +249,22 @@ partial def translateFromTerm (t:SMT.Term): Except String (SMTDDM.Term SourceRan | other => do let ddmTerm ← translateFromTerm other pure [← termToSExpr ddmTerm] - let attr : SMTDDM.Attribute SourceRange := - .att_kw srnone - (.kw_symbol srnone (mkSimpleSymbol "pattern")) - (Ann.mk srnone (some (.av_sel srnone (Ann.mk srnone sexprs.toArray)))) + let attr : SMTDDM.Attribute Provenance := + .att_kw smtProv + (.kw_symbol smtProv (mkSimpleSymbol "pattern")) + (smtAnn (some (.av_sel smtProv (smtAnn sexprs.toArray)))) patternAttrs := patternAttrs.push attr -- Wrap body with bang operator and pattern attributes - pure (.bang srnone body (Ann.mk srnone patternAttrs)) + pure (.bang smtProv body (smtAnn patternAttrs)) | _ => -- Unexpected trigger format - return body as-is pure body match qkind with | .all => - return .forall_smt srnone (Ann.mk srnone args_array) bodyWithPattern + return .forall_smt smtProv (smtAnn args_array) bodyWithPattern | .exist => - return .exists_smt srnone (Ann.mk srnone args_array) bodyWithPattern + return .exists_smt smtProv (smtAnn args_array) bodyWithPattern private def dummy_prg_for_toString := diff --git a/Strata/Languages/Boole/Verify.lean b/Strata/Languages/Boole/Verify.lean index 8e21563365..5c237ab6e5 100644 --- a/Strata/Languages/Boole/Verify.lean +++ b/Strata/Languages/Boole/Verify.lean @@ -161,9 +161,7 @@ private def constructorListToList : BooleDDM.ConstructorList SourceRange → Lis private def toCoreMetaData (sr : SourceRange) : TranslateM (Imperative.MetaData Core.Expression) := do let file := (← get).fileName - let uri : Uri := .file file - let fileRangeElt := ⟨Imperative.MetaData.fileRange, .fileRange ⟨uri, sr⟩⟩ - return #[fileRangeElt] + return Imperative.MetaData.ofSourceRange (.file file) sr private def mkCoreApp (op : Core.Expression.Expr) (args : List Core.Expression.Expr) : Core.Expression.Expr := Lambda.LExpr.mkApp () op args diff --git a/Strata/Languages/C_Simp/DDMTransform/Translate.lean b/Strata/Languages/C_Simp/DDMTransform/Translate.lean index 9a8b6ede54..5b1493e6e6 100644 --- a/Strata/Languages/C_Simp/DDMTransform/Translate.lean +++ b/Strata/Languages/C_Simp/DDMTransform/Translate.lean @@ -54,10 +54,7 @@ def TransM.error [Inhabited α] (msg : String) : TransM α := do /- Metadata -/ def sourceRangeToMetaData (ictx : InputContext) (sr : SourceRange) : Imperative.MetaData C_Simp.Expression := - let file := ictx.fileName - let uri : Uri := .file file - let fileRangeElt := ⟨ MetaData.fileRange, .fileRange ⟨ uri, sr ⟩ ⟩ - #[fileRangeElt] + Imperative.MetaData.ofSourceRange (.file ictx.fileName) sr def getOpMetaData (op : Operation) : TransM (Imperative.MetaData C_Simp.Expression) := return sourceRangeToMetaData (← StateT.get).inputCtx op.ann diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index 9e6ed5a8f8..3eeb98ac4d 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -51,10 +51,7 @@ def TransM.error [Inhabited α] (msg : String) : TransM α := do /- Metadata -/ def SourceRange.toMetaData (ictx : InputContext) (sr : SourceRange) : Imperative.MetaData Core.Expression := - let file := ictx.fileName - let uri: Uri := .file file - let fileRangeElt := ⟨ MetaData.fileRange, .fileRange ⟨ uri, sr ⟩ ⟩ - #[fileRangeElt] + Imperative.MetaData.ofSourceRange (.file ictx.fileName) sr def getOpMetaData (op : Operation) : TransM (Imperative.MetaData Core.Expression) := return op.ann.toMetaData (← StateT.get).inputCtx diff --git a/Strata/Languages/Core/SarifOutput.lean b/Strata/Languages/Core/SarifOutput.lean index b950aa5fa4..6e69cf014b 100644 --- a/Strata/Languages/Core/SarifOutput.lean +++ b/Strata/Languages/Core/SarifOutput.lean @@ -77,15 +77,12 @@ def outcomeToMessage (outcome : VCOutcome) : String := /-- Extract location information from metadata -/ def extractLocation (files : Map Strata.Uri Lean.FileMap) (md : Imperative.MetaData Expression) : Option Location := do - let fileRangeElem ← md.findElem Imperative.MetaData.fileRange - match fileRangeElem.value with - | .fileRange fr => - let fileMap ← files.find? fr.file - let startPos := fileMap.toPosition fr.range.start - let uri := match fr.file with - | .file path => path - pure { uri, startLine := startPos.line, startColumn := startPos.column } - | _ => none + let fr ← Imperative.getFileRange md + let fileMap ← files.find? fr.file + let startPos := fileMap.toPosition fr.range.start + let uri := match fr.file with + | .file path => path + pure { uri, startLine := startPos.line, startColumn := startPos.column } /-- Convert PropertyType to a property classification string for SARIF output -/ def propertyTypeToClassification : Imperative.PropertyType → String diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 267dad9452..ce2b35a975 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -585,8 +585,8 @@ private def evalOneStmt (old_var_subst : SubstMap) | .nondet => let freshName : CoreIdent := ⟨s!"$__nondet_cond_{Ewn.env.pathConditions.length}", ()⟩ let freshVar : Expression.Expr := .fvar () freshName none - let initStmt := Statement.init freshName (.forAll [] (.tcons "bool" [])) .nondet Imperative.MetaData.empty - let iteStmt := Imperative.Stmt.ite (.det freshVar) then_ss else_ss Imperative.MetaData.empty + let initStmt := Statement.init freshName (.forAll [] (.tcons "bool" [])) .nondet (Imperative.MetaData.ofProvenance (.synthesized .nondetIte)) + let iteStmt := Imperative.Stmt.ite (.det freshVar) then_ss else_ss (Imperative.MetaData.ofProvenance (.synthesized .nondetIte)) evalSub Ewn [initStmt, iteStmt] nextSplitId | .det c => let cond' := Ewn.env.exprEval c diff --git a/Strata/Languages/Laurel/Grammar/ConcreteToAbstractTreeTranslator.lean b/Strata/Languages/Laurel/Grammar/ConcreteToAbstractTreeTranslator.lean index 8d3dcdc460..cf8545d95d 100644 --- a/Strata/Languages/Laurel/Grammar/ConcreteToAbstractTreeTranslator.lean +++ b/Strata/Languages/Laurel/Grammar/ConcreteToAbstractTreeTranslator.lean @@ -45,8 +45,8 @@ private def getArgFileRange (arg : Arg) : TransM (Option FileRange) := do def getArgMetaData (arg : Arg) : TransM (Imperative.MetaData Core.Expression) := do return match (← get).uri with - | some uri => #[⟨Imperative.MetaData.fileRange, .fileRange (SourceRange.toFileRange uri arg.ann)⟩] - | none => #[⟨Imperative.MetaData.fileRange, .fileRange FileRange.unknown⟩] + | some uri => Imperative.MetaData.ofSourceRange uri arg.ann + | none => Imperative.MetaData.ofProvenance (.synthesized .laurelParse) def checkOp (op : Strata.Operation) (name : QualifiedIdent) (argc : Nat) : TransM Unit := do diff --git a/Strata/Languages/Laurel/Laurel.lean b/Strata/Languages/Laurel/Laurel.lean index a5cd11439c..86ae83d022 100644 --- a/Strata/Languages/Laurel/Laurel.lean +++ b/Strata/Languages/Laurel/Laurel.lean @@ -377,8 +377,9 @@ def Condition.mapCondition (f : AstNode StmtExpr → AstNode StmtExpr) (c : Cond /-- Build Core metadata from an optional source location. -/ def fileRangeToCoreMd (source : Option FileRange) : Imperative.MetaData Core.Expression := - let fr := source.getD FileRange.unknown - Imperative.MetaData.empty.pushElem Imperative.MetaData.fileRange (.fileRange fr) + match source with + | some fr => Imperative.MetaData.ofSourceRange fr.file fr.range + | none => Imperative.MetaData.ofProvenance (.synthesized .laurel) /-- Build Core metadata from an AstNode's source location. -/ def astNodeToCoreMd (node : AstNode α) : Imperative.MetaData Core.Expression := diff --git a/Strata/Languages/Laurel/LaurelToCoreTranslator.lean b/Strata/Languages/Laurel/LaurelToCoreTranslator.lean index 66f57af768..beb50ad9b0 100644 --- a/Strata/Languages/Laurel/LaurelToCoreTranslator.lean +++ b/Strata/Languages/Laurel/LaurelToCoreTranslator.lean @@ -44,7 +44,7 @@ open Lambda (LMonoTy LTy LExpr) public section private def mdWithUnknownLoc : Imperative.MetaData Core.Expression := - #[⟨Imperative.MetaData.fileRange, .fileRange FileRange.unknown⟩] + Imperative.MetaData.ofProvenance (.synthesized .laurelToCore) def isFieldName (fieldNames : List Identifier) (name : Identifier) : Bool := fieldNames.contains name @@ -316,8 +316,10 @@ def translateExpr (expr : StmtExprMd) all_goals (have := AstNode.sizeOf_val_lt expr; term_by_mem) def getNameFromMd (md : Imperative.MetaData Core.Expression): String := - let fileRange := (Imperative.getFileRange md).getD (dbg_trace "BUG: metadata without a filerange"; default) - s!"({fileRange.range.start})" + match Imperative.getProvenance md with + | some (.loc _ range) => s!"({range.start})" + | some (.synthesized _) => "(0)" + | none => "(unknown)" def defaultExprForType (ty : HighTypeMd) : TranslateM Core.Expression.Expr := do match ty.val with diff --git a/Strata/Languages/Laurel/TypeHierarchy.lean b/Strata/Languages/Laurel/TypeHierarchy.lean index 263875f606..411c61b95f 100644 --- a/Strata/Languages/Laurel/TypeHierarchy.lean +++ b/Strata/Languages/Laurel/TypeHierarchy.lean @@ -126,8 +126,11 @@ private def checkDiamondFieldAccess (model : SemanticModel) (target : StmtExprMd match (computeExprType model target).val with | .UserDefined typeName => if isDiamondInheritedField model typeName fieldName then - let fileRange := source.getD FileRange.unknown - [DiagnosticModel.withRange fileRange s!"fields that are inherited multiple times can not be accessed."] + match source with + | some fileRange => + [DiagnosticModel.withRange fileRange s!"fields that are inherited multiple times can not be accessed."] + | none => + [DiagnosticModel.fromMessage s!"fields that are inherited multiple times can not be accessed."] else [] | _ => [] diff --git a/Strata/Languages/Python/PythonToCore.lean b/Strata/Languages/Python/PythonToCore.lean index 4a77ea4c35..5641277d32 100644 --- a/Strata/Languages/Python/PythonToCore.lean +++ b/Strata/Languages/Python/PythonToCore.lean @@ -101,9 +101,7 @@ deriving Inhabited /-- Create metadata from a SourceRange for attaching to Core statements. -/ def sourceRangeToMetaData (filePath : String) (sr : SourceRange) : Imperative.MetaData Core.Expression := - let uri : Uri := .file filePath - let fileRangeElt := ⟨ Imperative.MetaData.fileRange, .fileRange ⟨ uri, sr ⟩ ⟩ - #[fileRangeElt] + Imperative.MetaData.ofSourceRange (.file filePath) sr ------------------------------------------------------------------------------- diff --git a/Strata/Languages/Python/PythonToLaurel.lean b/Strata/Languages/Python/PythonToLaurel.lean index 0622ad6473..0310fb473f 100644 --- a/Strata/Languages/Python/PythonToLaurel.lean +++ b/Strata/Languages/Python/PythonToLaurel.lean @@ -170,7 +170,7 @@ private def guardProp {p : Prop} [Decidable p] (msg : String) /-! ## Helper Functions -/ -/-- Create metadata from a SourceRange for attaching to Laurel statements. -/ +/-- Create a FileRange from a SourceRange for attaching to Laurel statements. -/ def sourceRangeToFileRange (filePath : String) (sr : SourceRange) : FileRange := let uri : Uri := .file filePath ⟨ uri, sr ⟩ diff --git a/Strata/Transform/StructuredToUnstructured.lean b/Strata/Transform/StructuredToUnstructured.lean index 1ae2e9945a..94b345d25f 100644 --- a/Strata/Transform/StructuredToUnstructured.lean +++ b/Strata/Transform/StructuredToUnstructured.lean @@ -43,6 +43,9 @@ def flushCmds let b := (l, { cmds := accum.reverse, transfer := tr?.getD (.goto k) }) pure (l, [b]) +private abbrev synthesizedMd {P : PureExpr} : MetaData P := + MetaData.ofProvenance (.synthesized .structuredToUnstructured) + /-- Translate a list of statements to basic blocks, accumulating commands -/ def stmtsToBlocks [HasBool P] [HasPassiveCmds P CmdT] [HasInit P CmdT] @@ -92,7 +95,7 @@ match ss with | .nondet => do let freshName ← StringGenState.gen "$__nondet_ite$" let ident := HasIdent.ident (P := P) freshName - let initCmd := HasInit.init ident HasBool.boolTy .nondet MetaData.empty + let initCmd := HasInit.init ident HasBool.boolTy .nondet synthesizedMd pure (HasFvar.mkFvar ident, [initCmd]) let (accumEntry, accumBlocks) ← flushCmds "ite$" (accum ++ extraCmds) (.some (.condGoto condExpr tl fl)) l @@ -111,13 +114,13 @@ match ss with let mLabel ← StringGenState.gen "loop_measure$" let mIdent := HasIdent.ident mLabel let mOldExpr := HasFvar.mkFvar mIdent - let initCmd := HasInit.init mIdent HasIntOrder.intTy .nondet MetaData.empty + let initCmd := HasInit.init mIdent HasIntOrder.intTy .nondet synthesizedMd let assumeCmd := HasPassiveCmds.assume s!"assume_{mLabel}" - (HasIntOrder.eq mOldExpr mExpr) MetaData.empty + (HasIntOrder.eq mOldExpr mExpr) synthesizedMd let lbCmd := HasPassiveCmds.assert s!"measure_lb_{mLabel}" - (HasNot.not (HasIntOrder.lt mOldExpr HasIntOrder.zero)) MetaData.empty + (HasNot.not (HasIntOrder.lt mOldExpr HasIntOrder.zero)) synthesizedMd let decCmd := HasPassiveCmds.assert s!"measure_decrease_{mLabel}" - (HasIntOrder.lt mExpr mOldExpr) MetaData.empty + (HasIntOrder.lt mExpr mOldExpr) synthesizedMd let ldec ← StringGenState.gen "measure_decrease$" let decBlock := (ldec, { cmds := [decCmd], transfer := .goto lentry }) pure ([initCmd, assumeCmd, lbCmd], ldec, [decBlock]) @@ -131,7 +134,7 @@ match ss with let assertLabel ← if srcLabel.isEmpty then StringGenState.gen "inv$" else pure srcLabel - pure (HasPassiveCmds.assert assertLabel i MetaData.empty)) + pure (HasPassiveCmds.assert assertLabel i synthesizedMd)) -- For nondet guards, introduce a fresh boolean variable match c with | .det e => @@ -141,7 +144,7 @@ match ss with | .nondet => do let freshName ← StringGenState.gen "$__nondet_loop$" let ident := HasIdent.ident (P := P) freshName - let initCmd := HasInit.init ident HasBool.boolTy .nondet MetaData.empty + let initCmd := HasInit.init ident HasBool.boolTy .nondet synthesizedMd let b := (lentry, { cmds := [initCmd] ++ invCmds ++ measureCmds, transfer := .condGoto (HasFvar.mkFvar ident) bl kNext }) let (accumEntry, accumBlocks) ← flushCmds "before_loop$" accum .none lentry diff --git a/Strata/Util/Provenance.lean b/Strata/Util/Provenance.lean new file mode 100644 index 0000000000..d5fc4d7bb0 --- /dev/null +++ b/Strata/Util/Provenance.lean @@ -0,0 +1,63 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ +module + +public import Strata.Util.FileRange + +public section +namespace Strata + +/-- Canonical synthesized provenance origins. -/ +inductive SynthesizedOrigin where + | smtEncode + | nondetIte + | laurelParse + | laurel + | laurelToCore + | structuredToUnstructured + deriving DecidableEq, Repr, Inhabited + +instance : Std.ToFormat SynthesizedOrigin where + format + | .smtEncode => "smt-encode" + | .nondetIte => "nondet-ite" + | .laurelParse => "laurel-parse" + | .laurel => "laurel" + | .laurelToCore => "laurel-to-core" + | .structuredToUnstructured => "structured-to-unstructured" + +/-- Provenance tracks where an AST node originated from — either a real source +location or a synthesized origin (e.g., from a translator or encoding pass). -/ +inductive Provenance where + /-- A real source location with file and byte range. -/ + | loc (uri : Uri) (range : SourceRange) + /-- A synthesized node with a description of what created it. -/ + | synthesized (origin : SynthesizedOrigin) + deriving DecidableEq, Repr, Inhabited + +namespace Provenance + +/-- Convert a Provenance to a FileRange, if it has a real location. -/ +def toFileRange : Provenance → Option FileRange + | .loc uri range => some { file := uri, range } + | .synthesized _ => none + +/-- Convert a FileRange to a Provenance. -/ +def ofFileRange (fr : FileRange) : Provenance := + .loc fr.file fr.range + +/-- Convert a SourceRange and Uri to a Provenance. -/ +def ofSourceRange (uri : Uri) (sr : SourceRange) : Provenance := + .loc uri sr + +instance : Std.ToFormat Provenance where + format + | .loc uri range => f!"{uri}:{range}" + | .synthesized origin => f!"" + +end Provenance +end Strata +end diff --git a/StrataTest/Languages/Core/Tests/SMTEncoderTests.lean b/StrataTest/Languages/Core/Tests/SMTEncoderTests.lean index e0bf1d3622..979e09a3d4 100644 --- a/StrataTest/Languages/Core/Tests/SMTEncoderTests.lean +++ b/StrataTest/Languages/Core/Tests/SMTEncoderTests.lean @@ -406,8 +406,7 @@ private def summaryMd (summary : String) : Imperative.MetaData Core.Expression : /-- Metadata carrying only a file range (no property summary); used to exercise `addLocationInfo`. -/ private def fileRangeMd (file : String) : Imperative.MetaData Core.Expression := - let fr : Strata.FileRange := ⟨.file file, Strata.SourceRange.none⟩ - Imperative.MetaData.empty.pushElem Imperative.MetaData.fileRange (.fileRange fr) + Imperative.MetaData.ofProvenance (Strata.Provenance.ofSourceRange (.file file) Strata.SourceRange.none) /-! Embedded double quotes in the property summary must be doubled (`""`). -/ /-- diff --git a/StrataTest/Languages/Core/Tests/SarifOutputTests.lean b/StrataTest/Languages/Core/Tests/SarifOutputTests.lean index 7ac1104fb9..98c8cac9b0 100644 --- a/StrataTest/Languages/Core/Tests/SarifOutputTests.lean +++ b/StrataTest/Languages/Core/Tests/SarifOutputTests.lean @@ -36,15 +36,13 @@ def makeMetadata (file : String) (_line _col : Nat) : MetaData Expression := let uri := Strata.Uri.file file -- Create a 1D range (byte offsets). For testing, we use simple offsets. let range : Strata.SourceRange := { start := ⟨0⟩, stop := ⟨10⟩ } - let fr : Strata.FileRange := { file := uri, range := range } - #[{ fld := Imperative.MetaData.fileRange, value := .fileRange fr }] + Imperative.MetaData.ofProvenance (Strata.Provenance.ofSourceRange uri range) /-- Create metadata with a specific byte offset for the file range start. -/ def makeMetadataAt (file : String) (startByte : Nat) : MetaData Expression := let uri := Strata.Uri.file file let range : Strata.SourceRange := { start := ⟨startByte⟩, stop := ⟨startByte + 10⟩ } - let fr : Strata.FileRange := { file := uri, range := range } - #[{ fld := Imperative.MetaData.fileRange, value := .fileRange fr }] + Imperative.MetaData.ofProvenance (Strata.Provenance.ofSourceRange uri range) /-- Create a simple FileMap for testing -/ def makeFileMap : Lean.FileMap := @@ -122,7 +120,7 @@ def makeVCResult (label : String) (outcome : VCOutcome) -- Test location extraction from metadata with wrong value type #guard let md : MetaData Expression := #[ - { fld := Imperative.MetaData.fileRange, value := .msg "not a fileRange" } + { fld := Imperative.MetaData.provenanceField, value := .msg "not a provenance" } ] let files := makeFilesMap "/test/file.st" (extractLocation files md == none) From 1d47569157ef886f95f2a32e5b298887d9baeb9e Mon Sep 17 00:00:00 2001 From: thanhnguyen-aws Date: Mon, 18 May 2026 08:38:13 -0700 Subject: [PATCH 62/64] Fix bug: ADT constructors do not change `Map` to `Array` when using useArrayTheory option. (#1145) *Description of changes:* **Bug:** When `useArrayTheory` is enabled, the SMT encoder correctly converts `Map` types to `Array` in variable declarations and function signatures, but it did *not* perform this conversion for fields inside ADT (algebraic data type) constructor declarations. This caused a type mismatch: a datatype field would be declared with type `Map` while the rest of the encoding used `Array`. **Fix:** Thread the `useArrayTheory` flag through the datatype emission pipeline: - `lMonoTyToTermType` now accepts `useArrayTheory` and converts `Map` to `Array` when enabled. - `datatypeConstructorsToSMT` passes the flag to `lMonoTyToTermType`. - `SMT.Context.emitDatatypes` accepts and forwards the flag. - `encodeCore` in `Verifier.lean` passes `options.useArrayTheory` to `emitDatatypes`. **Test:** Added a unit test in `SMTEncoderDatatypeTest.lean` that verifies a datatype with a `Map`-typed field emits `(Array Int Int)` when `useArrayTheory=true` and `(Map Int Int)` when `useArrayTheory=false`. By submitting this pull request, I confirm that you can use, modify, copy, and redistribute this contribution, under the terms of your choice. --------- Co-authored-by: keyboardDrummer-bot --- Strata/Languages/Core/SMTEncoder.lean | 22 +++--- Strata/Languages/Core/Verifier.lean | 5 +- .../Core/Tests/SMTEncoderDatatypeTest.lean | 72 +++++++++++++++++-- 3 files changed, 83 insertions(+), 16 deletions(-) diff --git a/Strata/Languages/Core/SMTEncoder.lean b/Strata/Languages/Core/SMTEncoder.lean index 0668322f5c..59476c1de8 100644 --- a/Strata/Languages/Core/SMTEncoder.lean +++ b/Strata/Languages/Core/SMTEncoder.lean @@ -95,7 +95,7 @@ def SMT.Context.withTypeFactory (ctx : SMT.Context) (tf : @Lambda.TypeFactory Co Helper function to convert LMonoTy to TermType for datatype constructor fields. Handles monomorphic types and type variables (as `.constr tv []`). -/ -private def lMonoTyToTermType (ty : LMonoTy) : TermType := +private def lMonoTyToTermType (useArrayTheory : Bool := false) (ty : LMonoTy) : TermType := match ty with | .bitvec n => .bitvec n | .tcons "bool" [] => .bool @@ -103,14 +103,18 @@ private def lMonoTyToTermType (ty : LMonoTy) : TermType := | .tcons "real" [] => .real | .tcons "string" [] => .string | .tcons "regex" [] => .regex - | .tcons name args => .constr name (args.map lMonoTyToTermType) + | .tcons name args => + if name == "Map" && useArrayTheory then + .constr "Array" (args.map $ lMonoTyToTermType useArrayTheory) + else + .constr name (args.map $ lMonoTyToTermType useArrayTheory) | .ftvar tv => .constr tv [] /-- Convert a datatype's constructors to typed SMT constructors. -/ -private def datatypeConstructorsToSMT (d : LDatatype CoreLParams.IDMeta) : List SMTConstructor := +private def datatypeConstructorsToSMT (d : LDatatype CoreLParams.IDMeta) (useArrayTheory : Bool := false): List SMTConstructor := d.constrs.map fun c => let fields := c.args.map fun (name, fieldTy) => - (d.name ++ ".." ++ name.name, lMonoTyToTermType fieldTy) + (d.name ++ ".." ++ name.name, lMonoTyToTermType useArrayTheory fieldTy) { name := c.name.name, args := fields } /-- Ensures that all datatypes in the SMT encoding do not have arrow-typed @@ -133,7 +137,7 @@ Uses the TypeFactory ordering (already topologically sorted). Only emits datatypes that have been seen (added via addDatatype). Single-element blocks use declare-datatype, multi-element blocks use declare-datatypes. -/ -def SMT.Context.emitDatatypes (ctx : SMT.Context) : Strata.SMT.SolverM Unit := do +def SMT.Context.emitDatatypes (ctx : SMT.Context) (useArrayTheory : Bool := false): Strata.SMT.SolverM Unit := do match validateDatatypesForSMT ctx.typeFactory ctx.seenDatatypes with | .error msg => throw (IO.userError (toString msg)) | .ok () => pure () @@ -142,10 +146,10 @@ def SMT.Context.emitDatatypes (ctx : SMT.Context) : Strata.SMT.SolverM Unit := d match usedBlock with | [] => pure () | [d] => - let constructors := datatypeConstructorsToSMT d + let constructors := datatypeConstructorsToSMT d useArrayTheory Strata.SMT.Solver.declareDatatype d.name d.typeArgs constructors | _ => - let dts := usedBlock.map fun d => (d.name, d.typeArgs, datatypeConstructorsToSMT d) + let dts := usedBlock.map fun d => (d.name, d.typeArgs, datatypeConstructorsToSMT d useArrayTheory) Strata.SMT.Solver.declareDatatypes dts @[expose] abbrev BoundVars := List (String × TermType) @@ -639,7 +643,7 @@ partial def toSMTOp (E : Env) (fn : CoreIdent) (fnty : LMonoTy) (ctx : SMT.Conte -- `.bvar`s. Use substFvarsLifting to properly lift indices under binders. let bvars := (List.range formals.length).map (fun i => LExpr.bvar () i) let body := LExpr.substFvarsLifting body (formals.zip bvars) - let (term, ctx) ← toSMTTerm E bvs body ctx + let (term, ctx) ← toSMTTerm E bvs body ctx useArrayTheory .ok (ctx.addIF uf term, !ctx.ifs.contains ({ uf := uf, body := term })) -- For recursive functions, generate per-constructor axioms let recAxioms ← if func.isRecursive && isNew then @@ -664,7 +668,7 @@ partial def toSMTOp (E : Env) (fn : CoreIdent) (fnty : LMonoTy) (ctx : SMT.Conte let savedSubst := ctx.tySubst let ctx ← allAxioms.foldlM (fun acc_ctx (ax: LExpr CoreLParams.mono) => do let current_axiom_ctx := acc_ctx.addSubst smt_ty_inst - let (axiom_term, new_ctx) ← toSMTTerm E [] ax current_axiom_ctx + let (axiom_term, new_ctx) ← toSMTTerm E [] ax current_axiom_ctx useArrayTheory .ok (new_ctx.addAxiom axiom_term) ) ctx let ctx := ctx.restoreSubst savedSubst diff --git a/Strata/Languages/Core/Verifier.lean b/Strata/Languages/Core/Verifier.lean index 92a07e3934..c4b1fb0026 100644 --- a/Strata/Languages/Core/Verifier.lean +++ b/Strata/Languages/Core/Verifier.lean @@ -52,6 +52,7 @@ when needed for the validity check (line 64 for check-sat-assuming, line 77 for def encodeCore (ctx : Core.SMT.Context) (prelude : SolverM Unit) (assumptionTerms : List Term) (obligationTerm : Term) (md : Imperative.MetaData Core.Expression) + (useArrayTheory : Bool := false) (satisfiabilityCheck validityCheck : Bool) (label : String) (varDefinitions : List Core.VarDefinition := []) @@ -60,7 +61,7 @@ def encodeCore (ctx : Core.SMT.Context) (prelude : SolverM Unit) Solver.setLogic "ALL" prelude let _ ← ctx.sorts.mapM (fun s => Solver.declareSort s.name s.arity) - ctx.emitDatatypes + ctx.emitDatatypes useArrayTheory let varDefNames := varDefinitions.map (·.name) let varDeclNames := varDeclarations.map (·.name) let managedNames := varDefNames ++ varDeclNames @@ -219,7 +220,7 @@ def dischargeObligation Imperative.SMT.dischargeObligation (P := Core.Expression) (Strata.SMT.Encoder.encodeCore ctx (getSolverPrelude options.solver) - assumptionTerms obligationTerm md satisfiabilityCheck validityCheck + assumptionTerms obligationTerm md options.useArrayTheory satisfiabilityCheck validityCheck (label := label) (varDefinitions := varDefinitions) (varDeclarations := varDeclarations)) (typedVarToSMTFn ctx) vars diff --git a/StrataTest/Languages/Core/Tests/SMTEncoderDatatypeTest.lean b/StrataTest/Languages/Core/Tests/SMTEncoderDatatypeTest.lean index 1dd7ff5a6c..0f1d023365 100644 --- a/StrataTest/Languages/Core/Tests/SMTEncoderDatatypeTest.lean +++ b/StrataTest/Languages/Core/Tests/SMTEncoderDatatypeTest.lean @@ -71,13 +71,13 @@ def treeDatatype : LDatatype Unit := Convert an expression to full SMT string including datatype declarations. `blocks` is a list of mutual blocks (each block is a list of mutually recursive datatypes). -/ -def toSMTStringWithDatatypeBlocks (e : LExpr CoreLParams.mono) (blocks : List (List (LDatatype Unit))) : IO String := do +def toSMTStringWithDatatypeBlocks (e : LExpr CoreLParams.mono) (blocks : List (List (LDatatype Unit))) (useArrayTheory : Bool := false): IO String := do match Env.init.addDatatypes blocks with | .error msg => return s!"Error creating environment: {msg}" | .ok env => -- Set the TypeFactory for correct datatype emission ordering let ctx := SMT.Context.default.withTypeFactory env.datatypes - match toSMTTerm env [] e ctx with + match toSMTTerm env [] e ctx useArrayTheory with | .error err => return err.pretty | .ok (smt, ctx) => -- Emit the full SMT output including datatype declarations @@ -85,7 +85,7 @@ def toSMTStringWithDatatypeBlocks (e : LExpr CoreLParams.mono) (blocks : List (L let solver ← Strata.SMT.Solver.bufferWriter b match (← ((do -- First emit datatypes - ctx.emitDatatypes + ctx.emitDatatypes useArrayTheory -- Then encode the term let _ ← (Strata.SMT.Encoder.encodeTerm smt).run Strata.SMT.EncoderState.init pure () @@ -102,8 +102,8 @@ def toSMTStringWithDatatypeBlocks (e : LExpr CoreLParams.mono) (blocks : List (L Convert an expression to full SMT string including datatype declarations. Each datatype is treated as its own (non-mutual) block. -/ -def toSMTStringWithDatatypes (e : LExpr CoreLParams.mono) (datatypes : List (LDatatype Unit)) : IO String := - toSMTStringWithDatatypeBlocks e (datatypes.map (fun d => [d])) +def toSMTStringWithDatatypes (e : LExpr CoreLParams.mono) (datatypes : List (LDatatype Unit)) (useArrayTheory : Bool := false): IO String := + toSMTStringWithDatatypeBlocks e (datatypes.map (fun d => [d])) useArrayTheory /-! ## Test Cases with Guard Messages -/ @@ -511,6 +511,68 @@ info: (declare-datatype IntList ( [[intListDatatype]] listLenFunc +/-- Container = MkContainer (data: Map int int) -/ +def containerWithMapDatatype : LDatatype Unit := + { name := "Container" + typeArgs := [] + constrs := [ + { name := ⟨"MkContainer", ()⟩, + args := [(⟨"data", ()⟩, .tcons "Map" [.int, .int])], + testerName := "Container..isMkContainer" } + ] + constrs_ne := by decide } + +-- Test: ADT constructor field with Map type should emit Array when useArrayTheory=true +/-- +info: (declare-datatype Container ( + (MkContainer (Container..data (Array Int Int))))) +; c +(declare-const c Container) +-/ +#guard_msgs in +#eval format <$> toSMTStringWithDatatypes + (.fvar () (⟨"c", ()⟩) (.some (.tcons "Container" []))) + [containerWithMapDatatype] true + +-- Test: Same datatype without useArrayTheory should keep Map +/-- +info: (declare-datatype Container ( + (MkContainer (Container..data (Map Int Int))))) +; c +(declare-const c Container) +-/ +#guard_msgs in +#eval format <$> toSMTStringWithDatatypes + (.fvar () (⟨"c", ()⟩) (.some (.tcons "Container" []))) + [containerWithMapDatatype] + +-- Test: ADT testers with Map type should emit Array when useArrayTheory=true +/-- +info: (declare-datatype Container ( + (MkContainer (Container..data (Array Int Int))))) +; xs +(declare-const xs Container) +-/ +#guard_msgs in +#eval format <$> toSMTStringWithDatatypes + (.app () (.op () (⟨"Container..isMkContainer", ()⟩) (.some (.arrow (.tcons "Container" []) .bool))) + (.fvar () (⟨"xs", ()⟩) (.some (.tcons "Container" [])))) + [containerWithMapDatatype] true + +-- Test: ADT destructors with Map type should emit Array when useArrayTheory=true +/-- +info: (declare-datatype Container ( + (MkContainer (Container..data (Array Int Int))))) +; xs +(declare-const xs Container) +-/ +#guard_msgs in +#eval format <$> toSMTStringWithDatatypes + (.app () (.op () (⟨"Container..data", ()⟩) (.some (.arrow (.tcons "Container" []) (.tcons "Map" [.int, .int])))) + (.fvar () (⟨"xs", ()⟩) (.some (.tcons "Container" [])))) + [containerWithMapDatatype] true + + end DatatypeTests end Core From 75e806ee2edff78aa46fc5af00e53ff3e11c6731 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mika=C3=ABl=20Mayer?= Date: Mon, 18 May 2026 10:41:54 -0500 Subject: [PATCH 63/64] Core.formatProgram to produce round-trip-parseable output for all constructs (#1165) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes #1158 Supersedes #1036 ## Summary Fixes several issues with `Core.formatProgram` that prevented round-trip parsing: 1. **`inline function` formatted without space** — The `inline` grammar op now includes a trailing space, preventing `inlinefunction` concatenation. The formatter also now emits the `inline` attribute when present on functions. 2. **Quantifier variable names** — The formatter now uses the `prettyName` field from `LExpr.quant` instead of generating `__qN` names, preserving the original variable names through formatting. 3. **Overflow predicates** — Added grammar entries, formatter handling, parser entries, and Factory operations for all bitvector overflow predicates (`SNegOverflow`, `UNegOverflow`, `SAddOverflow`, `SSubOverflow`, `SMulOverflow`, `SDivOverflow`, `UAddOverflow`, `USubOverflow`, `UMulOverflow`). `SNegOverflow` and `UNegOverflow` use distinct grammar entries (`Bv.SNegOverflow` / `Bv.UNegOverflow`) to preserve their different semantics through roundtrip. The translate direction correctly dispatches overflow ops by type parameter (bv1/bv8/bv16/bv32/bv64), logging an error for unsupported widths. 4. **Array assignment (`lhsArray`)** — Implemented `m[k] := v` translation in both directions: the parser decomposes nested LHS into base identifier + indices and builds `map_update` expressions; the formatter detects the `map_update(var, idx, val)` pattern and produces `lhsArray` syntax. 5. **`Sequence.empty`** — Added grammar entry with explicit type annotation syntax (`Sequence.empty()`), plus translate and format handling, resolving the 0-ary polymorphic function limitation for this operation. Includes solver verification tests (cherry-picked from #1036) covering basic usage and various element types. 6. **Datatype roundtrip** — Verified that datatype formatting roundtrips correctly (the extra-parentheses issue noted earlier is resolved). 7. **Roundtrip test infrastructure** — Added `RoundtripTest.lean` that verifies parse → format → re-parse → re-format produces stable output for types, functions, procedures, inline functions, parameterized type arguments, datatypes, array assignments, and `Sequence.empty`. 8. **`getLFuncCall` reuse** — Refactored `lappToExpr` and `decomposeMapUpdate` to use `getLFuncCall` for decomposing nested applications, reducing code duplication with the existing utility. ## Testing - All existing tests pass (with expected output updates for the formatting improvements) - New roundtrip tests verify types, functions, procedures, inline functions, parameterized type arguments, datatypes, lhsArray, and Sequence.empty - Solver verification tests for Sequence.empty (from #1036) pass ## Remaining limitations - Bitvector operations with widths beyond 1/8/16/32/64 log an error and fall back to bv64 (requires grammar-level type entries per width) --------- Co-authored-by: Aaron Tomb --- ...evantAxioms.removeIrrelevantAxioms.core.st | 6 +- .../Languages/Core/DDMTransform/ASTtoCST.lean | 4 +- .../Core/DDMTransform/FormatCore.lean | 130 +++++++--- .../Languages/Core/DDMTransform/Grammar.lean | 18 +- .../Core/DDMTransform/Translate.lean | 118 ++++++++- Strata/Languages/Core/Factory.lean | 6 +- .../Languages/Core/Examples/AdvancedMaps.lean | 8 +- .../Core/Examples/AdvancedQuantifiers.lean | 4 +- .../Languages/Core/Examples/Axioms.lean | 16 +- .../Core/Examples/FunctionPreconditions.lean | 2 +- StrataTest/Languages/Core/Examples/Loops.lean | 1 + .../Languages/Core/Examples/Quantifiers.lean | 56 ++--- .../Examples/QuantifiersWithTypeAliases.lean | 16 +- StrataTest/Languages/Core/Examples/Seq.lean | 166 +++++++++++++ .../Core/Examples/SubstFvarsCaptureTests.lean | 4 +- .../Examples/TypeVarImplicitlyQuantified.lean | 8 +- .../Languages/Core/Tests/GeneratedLabels.lean | 16 +- .../Core/Tests/LambdaHigherOrderTests.lean | 2 +- .../Tests/MutualRecursiveFunctionTests.lean | 16 +- .../Core/Tests/ProgramEvalTests.lean | 100 ++++---- .../Core/Tests/QuantifierBvarIndexTest.lean | 4 +- .../Core/Tests/RecursiveFunctionTests.lean | 24 +- .../Languages/Core/Tests/RoundtripTest.lean | 235 ++++++++++++++++++ .../Core/Tests/TerminationCheckTests.lean | 104 ++++---- .../Languages/Core/Tests/TestASTtoCST.lean | 24 +- editors/emacs/core-st-mode.el | 16 +- .../vscode/syntaxes/core-st.tmLanguage.json | 2 +- 27 files changed, 836 insertions(+), 270 deletions(-) create mode 100644 StrataTest/Languages/Core/Tests/RoundtripTest.lean diff --git a/Examples/expected/IrrelevantAxioms.removeIrrelevantAxioms.core.st b/Examples/expected/IrrelevantAxioms.removeIrrelevantAxioms.core.st index 3b5e32dd3d..21fde32b64 100644 --- a/Examples/expected/IrrelevantAxioms.removeIrrelevantAxioms.core.st +++ b/Examples/expected/IrrelevantAxioms.removeIrrelevantAxioms.core.st @@ -1,11 +1,11 @@ program Core; function f (x : int) : int; -axiom [f_positive]: forall __q0 : int :: f(__q0) > 0; -axiom [f_monotone]: forall __q0 : int :: forall __q1 : int :: __q0 < __q1 ==> f(__q0) < f(__q1); +axiom [f_positive]: forall x : int :: f(x) > 0; +axiom [f_monotone]: forall x : int :: forall y : int :: x < y ==> f(x) < f(y); function g (x : int) : int; function h (x : int) : int; -axiom [h_def]: forall __q0 : int :: h(__q0) == f(__q0) + 1; +axiom [h_def]: forall x : int :: h(x) == f(x) + 1; procedure TestF (x : int, out result : int) spec { ensures [result_positive]: result > 0; diff --git a/Strata/Languages/Core/DDMTransform/ASTtoCST.lean b/Strata/Languages/Core/DDMTransform/ASTtoCST.lean index b74f973594..805805f413 100644 --- a/Strata/Languages/Core/DDMTransform/ASTtoCST.lean +++ b/Strata/Languages/Core/DDMTransform/ASTtoCST.lean @@ -195,7 +195,9 @@ def funcToCST {M} [Inhabited M] -- Convert preconditions let preconds ← precondsToSpecElts func.preconditions let bodyExpr ← lexprToExpr body 0 - let inline? : Ann (Option (Inline M)) M := ⟨default, none⟩ + let inline? : Ann (Option (Inline M)) M := + if func.attr.any (· == .inline) then ⟨default, some (.inline default)⟩ + else ⟨default, none⟩ pure (.command_fndef default name typeArgs b r preconds bodyExpr inline?) modify ToCSTContext.popScope -- Register function name as free variable. diff --git a/Strata/Languages/Core/DDMTransform/FormatCore.lean b/Strata/Languages/Core/DDMTransform/FormatCore.lean index 0af86ae9b8..0bc517fd8a 100644 --- a/Strata/Languages/Core/DDMTransform/FormatCore.lean +++ b/Strata/Languages/Core/DDMTransform/FormatCore.lean @@ -37,8 +37,6 @@ Known issues: translation in the latter's metadata field and recover them in the future. - Misc. formatting issues - -- Remove extra parentheses around constructors in datatypes, assignments, - etc. -- Remove extra indentation from the last brace of a block or the `end` keyword of a mutual block. -/ @@ -295,11 +293,21 @@ def handleZeroaryOps {M} [Inhabited M] (name : String) | .re .All => pure (.re_all default) | .re .AllChar => pure (.re_allchar default) | .re .None => pure (.re_none default) - -- TODO: seq_empty is not yet parseable (see Grammar.lean); handle here when added. | _ => do ToCSTM.logError "lopToExpr" "0-ary op not found" name pure (.re_none default) +/-- Convert a bitvector width to the corresponding CoreType, logging an error and + falling back to bv64 for unsupported widths. -/ +def bvTypeOfWidth {M} [Inhabited M] (caller : String) (w : Nat) : ToCSTM M (CoreType M) := + match w with + | 1 => pure (CoreType.bv1 default) | 8 => pure (.bv8 default) + | 16 => pure (.bv16 default) | 32 => pure (.bv32 default) + | 64 => pure (.bv64 default) + | _ => do + ToCSTM.logError caller s!"unsupported BV width {w}" (toString w) + pure (.bv64 default) + /-- Handle unary operations -/ def handleUnaryOps {M} [Inhabited M] (name : String) (arg : CoreDDM.Expr M) : ToCSTM M (CoreDDM.Expr M) := @@ -338,8 +346,13 @@ def handleUnaryOps {M} [Inhabited M] (name : String) (arg : CoreDDM.Expr M) | .bv ⟨16, .SafeNeg⟩ | .bv ⟨16, .SafeUNeg⟩ => pure (.safeneg_expr default (.bv16 default) arg) | .bv ⟨32, .SafeNeg⟩ | .bv ⟨32, .SafeUNeg⟩ => pure (.safeneg_expr default (.bv32 default) arg) | .bv ⟨64, .SafeNeg⟩ | .bv ⟨64, .SafeUNeg⟩ => pure (.safeneg_expr default (.bv64 default) arg) - -- Overflow predicates: approximated as Bool.Not for CST printing - | .bv ⟨_, .SNegOverflow⟩ | .bv ⟨_, .UNegOverflow⟩ => pure (.not default arg) + -- Overflow predicates + | .bv ⟨w, .SNegOverflow⟩ => do + let bvTy ← bvTypeOfWidth "handleUnaryOps" w + pure (.bv_neg_overflow default bvTy arg) + | .bv ⟨w, .UNegOverflow⟩ => do + let bvTy ← bvTypeOfWidth "handleUnaryOps" w + pure (.bv_uneg_overflow default bvTy arg) -- Bitvector extract ops | .bvExtract 8 7 7 => pure (.bvextract_7_7 default arg) | .bvExtract 16 15 15 => pure (.bvextract_15_15 default arg) @@ -386,14 +399,14 @@ def bvBinaryOpMap {M} [Inhabited M] : (.SafeUAdd, fun ty arg1 arg2 => .safeadd_expr default ty arg1 arg2), (.SafeUSub, fun ty arg1 arg2 => .safesub_expr default ty arg1 arg2), (.SafeUMul, fun ty arg1 arg2 => .safemul_expr default ty arg1 arg2), - -- Overflow predicates: approximated as boolean ops for CST printing - (.SAddOverflow, fun _ty arg1 arg2 => .le default _ty arg1 arg2), - (.SSubOverflow, fun _ty arg1 arg2 => .le default _ty arg1 arg2), - (.SMulOverflow, fun _ty arg1 arg2 => .le default _ty arg1 arg2), - (.SDivOverflow, fun _ty arg1 arg2 => .le default _ty arg1 arg2), - (.UAddOverflow, fun _ty arg1 arg2 => .le default _ty arg1 arg2), - (.USubOverflow, fun _ty arg1 arg2 => .le default _ty arg1 arg2), - (.UMulOverflow, fun _ty arg1 arg2 => .le default _ty arg1 arg2) + -- Overflow predicates + (.SAddOverflow, fun ty arg1 arg2 => .bv_sadd_overflow default ty arg1 arg2), + (.SSubOverflow, fun ty arg1 arg2 => .bv_ssub_overflow default ty arg1 arg2), + (.SMulOverflow, fun ty arg1 arg2 => .bv_smul_overflow default ty arg1 arg2), + (.SDivOverflow, fun ty arg1 arg2 => .bv_sdiv_overflow default ty arg1 arg2), + (.UAddOverflow, fun ty arg1 arg2 => .bv_uadd_overflow default ty arg1 arg2), + (.USubOverflow, fun ty arg1 arg2 => .bv_usub_overflow default ty arg1 arg2), + (.UMulOverflow, fun ty arg1 arg2 => .bv_umul_overflow default ty arg1 arg2) ] /-- Map from bitvector sizes to their corresponding type constructors -/ @@ -551,11 +564,19 @@ partial def lexprToExpr {M} [Inhabited M] pure (.fvar default (ctx.allFreeVars.size)) | .ite _ c t f => liteToExpr c t f qLevel | .eq _ e1 e2 => leqToExpr e1 e2 qLevel - | .op _ name _ => lopToExpr name.name [] + | .op _ name ty => do + -- seq_empty needs the type annotation to render the explicit type parameter + if name.name == "Sequence.empty" then + let tyCST ← match ty with + | some (.tcons "Sequence" [ety]) => lmonoTyToCoreType ety + | _ => pure (CoreType.tvar default unknownTypeVar) + pure (.seq_empty default tyCST) + else + lopToExpr name.name [] | .app _ _ _ => lappToExpr e qLevel | .abs _ prettyName ty body => labsToExpr prettyName ty body (qLevel + 1) - | .quant _ qkind _ ty trigger body => - lquantToExpr qkind ty trigger body (qLevel + 1) + | .quant _ qkind prettyName ty trigger body => + lquantToExpr qkind prettyName ty trigger body (qLevel + 1) /-- Extract trigger patterns from Lambda's trigger expression representation -/ partial def extractTriggerPatterns {M} [Inhabited M] @@ -609,11 +630,13 @@ partial def labsToExpr {M} [Inhabited M] pure (.lambda default tyExpr dl bodyExpr) partial def lquantToExpr {M} [Inhabited M] - (qkind : Lambda.QuantifierKind) (ty : Option Lambda.LMonoTy) + (qkind : Lambda.QuantifierKind) (prettyName : String) + (ty : Option Lambda.LMonoTy) (trigger : Lambda.LExpr CoreLParams.mono) (body : Lambda.LExpr CoreLParams.mono) (qLevel : Nat) : ToCSTM M (CoreDDM.Expr M) := do - let name : Ann String M := ⟨default, mkQuantVarName (qLevel - 1)⟩ + let varName := if prettyName.isEmpty then mkQuantVarName (qLevel - 1) else prettyName + let name : Ann String M := ⟨default, varName⟩ modify ToCSTContext.pushScope modify (·.addScopedBoundVars #[name.val]) let tyExpr ← match ty with @@ -661,23 +684,23 @@ partial def leqToExpr {M} [Inhabited M] partial def lappToExpr {M} [Inhabited M] (e : Lambda.LExpr CoreLParams.mono) - (qLevel : Nat) (acc : List (CoreDDM.Expr M) := []) - : ToCSTM M (CoreDDM.Expr M) := - match e with - | .app _ (.app m fn e1) e2 => do - let e2Expr ← lexprToExpr e2 qLevel - lappToExpr (.app m fn e1) qLevel (e2Expr :: acc) - | .app _ (.op _ fn _) e1 => do - let e1Expr ← lexprToExpr e1 qLevel - lopToExpr fn.name (e1Expr :: acc) - | .app _ fn e1 => do + (qLevel : Nat) + : ToCSTM M (CoreDDM.Expr M) := do + let (head, args) := Lambda.getLFuncCall e + match head with + | .op _ fn _ => + let argExprs ← args.mapM (lexprToExpr · qLevel) + lopToExpr fn.name argExprs + | .app _ fn arg => + -- getLFuncCall couldn't decompose further (fn is not .app or .op) let fnCST ← lexprToExpr fn qLevel - let e1Expr ← lexprToExpr e1 qLevel - pure <| (e1Expr :: acc).foldl (fun fnAcc arg => .app default fnAcc arg) fnCST - | _ => do - -- Non-application head (e.g. lambda applied to arguments) - let eCST ← lexprToExpr e qLevel - pure <| acc.foldl (fun fnAcc arg => .app default fnAcc arg) eCST + let argCST ← lexprToExpr arg qLevel + let argExprs ← args.mapM (lexprToExpr · qLevel) + pure <| (argCST :: argExprs).foldl (fun fnAcc a => .app default fnAcc a) fnCST + | _ => + let fnCST ← lexprToExpr head qLevel + let argExprs ← args.mapM (lexprToExpr · qLevel) + pure <| argExprs.foldl (fun fnAcc arg => .app default fnAcc arg) fnCST end /-- Convert preconditions to CST spec elements -/ @@ -717,7 +740,9 @@ def funcDeclToStatement {M} [Inhabited M] (decl : Imperative.PureFunc Expression let paramNames := results.map (·.2) let b : Bindings M := .mkBindings default ⟨default, bindings⟩ let r ← lTyToCoreType decl.output - let inline? : Ann (Option (Inline M)) M := ⟨default, none⟩ + let inline? : Ann (Option (Inline M)) M := + if decl.attr.any (· == .inline) then ⟨default, some (.inline default)⟩ + else ⟨default, none⟩ -- Add formals to the context modify (·.addScopedBoundVars (reverse? := false) paramNames) -- Convert preconditions @@ -735,6 +760,24 @@ def funcDeclToStatement {M} [Inhabited M] (decl : Imperative.PureFunc Expression modify (·.pushBoundVar name.val) pure (.funcDecl_statement default name typeArgs b r preconds bodyExpr inline?) +/-- Decompose a single-level `map_update(base, idx, val)` where `base` is (or starts + with) an fvar matching `varName`. Returns `(indices, innerVal)` with indices + in left-to-right order, or `none` if the expression is not this pattern. -/ +private def decomposeMapUpdate (varName : String) + (e : Lambda.LExpr CoreLParams.mono) + : Option (List (Lambda.LExpr CoreLParams.mono) × Lambda.LExpr CoreLParams.mono) := + let (head, args) := Lambda.getLFuncCall e + match head, args with + | .op _ opName _, [base, idx, val] => + if opName.name == "update" then + match base with + | .fvar _ ident _ => + if ident.name == varName then some ([idx], val) + else none + | _ => none + else none + | _, _ => none + mutual /-- Convert `Core.Statement` to `CoreDDM.Statement` -/ partial def stmtToCST {M} [Inhabited M] (s : Core.Statement) @@ -758,9 +801,20 @@ partial def stmtToCST {M} [Inhabited M] (s : Core.Statement) modify (·.pushBoundVar name.toPretty) pure result | .set name expr _md => do - let lhs := Lhs.lhsIdent default ⟨default, name.name⟩ - let exprCST ← lexprToExpr expr 0 - -- Type annotation required by CST but not semantically used. + -- Detect map_update(name, idx, val) pattern to produce lhsArray syntax + let (lhs, exprCST) ← match decomposeMapUpdate name.name expr with + | some (idxs, val) => do + let baseLhs := Lhs.lhsIdent default ⟨default, name.name⟩ + let lhs ← idxs.foldlM (init := baseLhs) fun acc idx => do + let idxCST ← lexprToExpr idx 0 + let tyCST := CoreType.tvar default unknownTypeVar + pure (Lhs.lhsArray default tyCST acc idxCST) + let valCST ← lexprToExpr val 0 + pure (lhs, valCST) + | none => do + let lhs := Lhs.lhsIdent default ⟨default, name.name⟩ + let exprCST ← lexprToExpr expr 0 + pure (lhs, exprCST) let tyCST := CoreType.tvar default unknownTypeVar pure (.assign default tyCST lhs exprCST) | .havoc name _md => do diff --git a/Strata/Languages/Core/DDMTransform/Grammar.lean b/Strata/Languages/Core/DDMTransform/Grammar.lean index 206b72e7d5..0375a10596 100644 --- a/Strata/Languages/Core/DDMTransform/Grammar.lean +++ b/Strata/Languages/Core/DDMTransform/Grammar.lean @@ -103,9 +103,9 @@ fn map_get (K : Type, V : Type, m : Map K V, k : K) : V => m "[" k "]"; fn map_set (K : Type, V : Type, m : Map K V, k : K, v : V) : Map K V => m "[" k ":=" v "]"; -// TODO: seq_empty is not yet supported in the grammar because the DDM parser -// cannot currently handle 0-ary polymorphic functions (no arguments to infer -// the type parameter from). The Factory definition exists for programmatic use. +// seq_empty uses explicit type annotation syntax since there are no value +// arguments to infer the type parameter from. +fn seq_empty (A : Type) : Sequence A => "Sequence.empty" "<" A ">" "(" ")"; fn seq_length (A : Type, s : Sequence A) : int => "Sequence.length" "(" s ")"; fn seq_select (A : Type, s : Sequence A, i : int) : A => "Sequence.select" "(" s ", " i ")"; fn seq_append (A : Type, s1 : Sequence A, s2 : Sequence A) : Sequence A => @@ -188,6 +188,16 @@ fn bvsle (tp : Type, a : tp, b : tp) : bool => @[prec(20), leftassoc] a " <=s " fn bvsgt (tp : Type, a : tp, b : tp) : bool => @[prec(20), leftassoc] a " >s " b; fn bvsge (tp : Type, a : tp, b : tp) : bool => @[prec(20), leftassoc] a " >=s " b; +fn bv_neg_overflow (tp : Type, a : tp) : bool => "Bv.SNegOverflow" "(" a ")"; +fn bv_uneg_overflow (tp : Type, a : tp) : bool => "Bv.UNegOverflow" "(" a ")"; +fn bv_sadd_overflow (tp : Type, a : tp, b : tp) : bool => "Bv.SAddOverflow" "(" a ", " b ")"; +fn bv_ssub_overflow (tp : Type, a : tp, b : tp) : bool => "Bv.SSubOverflow" "(" a ", " b ")"; +fn bv_smul_overflow (tp : Type, a : tp, b : tp) : bool => "Bv.SMulOverflow" "(" a ", " b ")"; +fn bv_sdiv_overflow (tp : Type, a : tp, b : tp) : bool => "Bv.SDivOverflow" "(" a ", " b ")"; +fn bv_uadd_overflow (tp : Type, a : tp, b : tp) : bool => "Bv.UAddOverflow" "(" a ", " b ")"; +fn bv_usub_overflow (tp : Type, a : tp, b : tp) : bool => "Bv.USubOverflow" "(" a ", " b ")"; +fn bv_umul_overflow (tp : Type, a : tp, b : tp) : bool => "Bv.UMulOverflow" "(" a ", " b ")"; + fn bvconcat8 (a : bv8, b : bv8) : bv16 => "bvconcat{8}{8}" "(" a ", " b ")"; fn bvconcat16 (a : bv16, b : bv16) : bv32 => "bvconcat{16}{16}" "(" a ", " b ")"; fn bvconcat32 (a : bv32, b : bv32) : bv64 => "bvconcat{32}{32}" "(" a ", " b ")"; @@ -354,7 +364,7 @@ op command_fndecl (name : Ident, "function " name typeArgs b " : " r ";\n"; category Inline; -op inline () : Inline => "inline"; +op inline () : Inline => "inline "; // Note: when editing command_fndef, consider whether recfn_decl needs // matching edits. diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index 3eeb98ac4d..1fa2b4fe95 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -355,14 +355,6 @@ def translateTypeDecl (bindings : TransBindings) (op : Operation) : --------------------------------------------------------------------- -def translateLhs (arg : Arg) : TransM Core.CoreIdent := do - let .op op := arg - | TransM.error s!"translateLhs expected op {repr arg}" - match op.name, op.args with - | q`Core.lhsIdent, #[id] => translateIdent Core.CoreIdent id - -- (TODO) Implement lhsArray. - | _, _ => TransM.error s!"translateLhs: unimplemented for {repr arg}" - def translateBindMk (bindings : TransBindings) (arg : Arg) : TransM (Core.CoreIdent × List TyIdentifier × LMonoTy) := do let .op op := arg @@ -664,6 +656,52 @@ def translateFn (ty? : Option LMonoTy) (q : QualifiedIdent) : TransM Core.Expres | _, q`Core.bvextract_15_0_64 => return Core.bv64Extract_15_0_Op | _, q`Core.bvextract_31_0_64 => return Core.bv64Extract_31_0_Op + | .some .bv1, q`Core.bv_neg_overflow => return Core.bv1SNegOverflowOp + | .some .bv1, q`Core.bv_uneg_overflow => return Core.bv1UNegOverflowOp + | .some .bv1, q`Core.bv_sadd_overflow => return Core.bv1SAddOverflowOp + | .some .bv1, q`Core.bv_ssub_overflow => return Core.bv1SSubOverflowOp + | .some .bv1, q`Core.bv_smul_overflow => return Core.bv1SMulOverflowOp + | .some .bv1, q`Core.bv_sdiv_overflow => return Core.bv1SDivOverflowOp + | .some .bv1, q`Core.bv_uadd_overflow => return Core.bv1UAddOverflowOp + | .some .bv1, q`Core.bv_usub_overflow => return Core.bv1USubOverflowOp + | .some .bv1, q`Core.bv_umul_overflow => return Core.bv1UMulOverflowOp + | .some .bv8, q`Core.bv_neg_overflow => return Core.bv8SNegOverflowOp + | .some .bv8, q`Core.bv_uneg_overflow => return Core.bv8UNegOverflowOp + | .some .bv8, q`Core.bv_sadd_overflow => return Core.bv8SAddOverflowOp + | .some .bv8, q`Core.bv_ssub_overflow => return Core.bv8SSubOverflowOp + | .some .bv8, q`Core.bv_smul_overflow => return Core.bv8SMulOverflowOp + | .some .bv8, q`Core.bv_sdiv_overflow => return Core.bv8SDivOverflowOp + | .some .bv8, q`Core.bv_uadd_overflow => return Core.bv8UAddOverflowOp + | .some .bv8, q`Core.bv_usub_overflow => return Core.bv8USubOverflowOp + | .some .bv8, q`Core.bv_umul_overflow => return Core.bv8UMulOverflowOp + | .some .bv16, q`Core.bv_neg_overflow => return Core.bv16SNegOverflowOp + | .some .bv16, q`Core.bv_uneg_overflow => return Core.bv16UNegOverflowOp + | .some .bv16, q`Core.bv_sadd_overflow => return Core.bv16SAddOverflowOp + | .some .bv16, q`Core.bv_ssub_overflow => return Core.bv16SSubOverflowOp + | .some .bv16, q`Core.bv_smul_overflow => return Core.bv16SMulOverflowOp + | .some .bv16, q`Core.bv_sdiv_overflow => return Core.bv16SDivOverflowOp + | .some .bv16, q`Core.bv_uadd_overflow => return Core.bv16UAddOverflowOp + | .some .bv16, q`Core.bv_usub_overflow => return Core.bv16USubOverflowOp + | .some .bv16, q`Core.bv_umul_overflow => return Core.bv16UMulOverflowOp + | .some .bv32, q`Core.bv_neg_overflow => return Core.bv32SNegOverflowOp + | .some .bv32, q`Core.bv_uneg_overflow => return Core.bv32UNegOverflowOp + | .some .bv32, q`Core.bv_sadd_overflow => return Core.bv32SAddOverflowOp + | .some .bv32, q`Core.bv_ssub_overflow => return Core.bv32SSubOverflowOp + | .some .bv32, q`Core.bv_smul_overflow => return Core.bv32SMulOverflowOp + | .some .bv32, q`Core.bv_sdiv_overflow => return Core.bv32SDivOverflowOp + | .some .bv32, q`Core.bv_uadd_overflow => return Core.bv32UAddOverflowOp + | .some .bv32, q`Core.bv_usub_overflow => return Core.bv32USubOverflowOp + | .some .bv32, q`Core.bv_umul_overflow => return Core.bv32UMulOverflowOp + | .some .bv64, q`Core.bv_neg_overflow => return Core.bv64SNegOverflowOp + | .some .bv64, q`Core.bv_uneg_overflow => return Core.bv64UNegOverflowOp + | .some .bv64, q`Core.bv_sadd_overflow => return Core.bv64SAddOverflowOp + | .some .bv64, q`Core.bv_ssub_overflow => return Core.bv64SSubOverflowOp + | .some .bv64, q`Core.bv_smul_overflow => return Core.bv64SMulOverflowOp + | .some .bv64, q`Core.bv_sdiv_overflow => return Core.bv64SDivOverflowOp + | .some .bv64, q`Core.bv_uadd_overflow => return Core.bv64UAddOverflowOp + | .some .bv64, q`Core.bv_usub_overflow => return Core.bv64USubOverflowOp + | .some .bv64, q`Core.bv_umul_overflow => return Core.bv64UMulOverflowOp + | _, q`Core.str_len => return Core.strLengthOp | _, q`Core.str_concat => return Core.strConcatOp | _, q`Core.str_substr => return Core.strSubstrOp @@ -845,6 +883,13 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : | .fn _ q`Core.re_all, [] => let fn ← translateFn .none q`Core.re_all return fn + -- Sequence.empty (1 type arg, 0 value args) + | .fn _ q`Core.seq_empty, [_atp] => + let ety ← translateLMonoTy bindings _atp + let fn : LExpr Core.CoreLParams.mono := + Core.coreOpExpr (.seq .Empty) + (.some (Core.seqTy ety)) + return fn -- Unary function applications | .fn _ fni, [xa] => match fni with @@ -877,6 +922,16 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : let fn ← translateFn ty q`Core.safeneg_expr let x ← translateExpr p bindings xa return .mkApp () fn [x] + | .fn _ q`Core.bv_neg_overflow, [tpa, xa] => + let ty ← translateLMonoTy bindings (dealiasTypeArg p tpa) + let fn ← translateFn ty q`Core.bv_neg_overflow + let x ← translateExpr p bindings xa + return .mkApp () fn [x] + | .fn _ q`Core.bv_uneg_overflow, [tpa, xa] => + let ty ← translateLMonoTy bindings (dealiasTypeArg p tpa) + let fn ← translateFn ty q`Core.bv_uneg_overflow + let x ← translateExpr p bindings xa + return .mkApp () fn [x] -- Strings | .fn _ q`Core.str_concat, [xa, ya] => let x ← translateExpr p bindings xa @@ -910,7 +965,6 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : let x ← translateExpr p bindings xa return .mkApp () fn [m, i, x] -- Seq operations - -- TODO: seq_empty is not yet parseable (see Grammar.lean); handle here when added. | .fn _ q`Core.seq_length, [_atp, sa] => let ety ← translateLMonoTy bindings _atp let fn : LExpr Core.CoreLParams.mono := @@ -1042,7 +1096,14 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : | q`Core.bvsle | q`Core.bvslt | q`Core.bvsgt - | q`Core.bvsge => + | q`Core.bvsge + | q`Core.bv_sadd_overflow + | q`Core.bv_ssub_overflow + | q`Core.bv_smul_overflow + | q`Core.bv_sdiv_overflow + | q`Core.bv_uadd_overflow + | q`Core.bv_usub_overflow + | q`Core.bv_umul_overflow => let ty ← translateLMonoTy bindings (dealiasTypeArg p tpa) if ¬ isArithTy ty then TransM.error s!"translateExpr unexpected type for {repr fni}: {repr args}" @@ -1225,6 +1286,36 @@ private def translateCondBool (p : Program) (bindings : TransBindings) (a : Arg) | q`Core.condDet, #[ca] => pure (.det (← translateExpr p bindings ca)) | _, _ => TransM.error s!"translateCondBool: unexpected {repr op.name}" +/-- Build a nested map-update expression: `nestMapUpdate base [i1, i2] v` produces + `map_update(base, i1, map_update(map_select(base, i1), i2, v))`. -/ +private def nestMapUpdate (base : Core.Expression.Expr) (idxs : List Core.Expression.Expr) + (rhs : Core.Expression.Expr) : Core.Expression.Expr := + let selectOp := Core.coreOpExpr (.map .Select) + let updateOp := Core.coreOpExpr (.map .Update) + match idxs with + | [] => rhs + | [i] => .mkApp () updateOp [base, i, rhs] + | i :: rest => + let inner := .mkApp () selectOp [base, i] + let updatedInner := nestMapUpdate inner rest rhs + .mkApp () updateOp [base, i, updatedInner] + +/-- Decompose an LHS into a base identifier and a (reversed) list of index + expressions. For `m[k1][k2]`, returns `(m, [k2, k1])`. -/ +partial def translateLhsParts (p : Program) (bindings : TransBindings) (arg : Arg) : + TransM (Core.CoreIdent × List Core.Expression.Expr) := do + let .op op := arg + | TransM.error s!"translateLhsParts expected op {repr arg}" + match op.name, op.args with + | q`Core.lhsIdent, #[id] => + let ident ← translateIdent Core.CoreIdent id + return (ident, []) + | q`Core.lhsArray, #[_tpa, lhsa, idxa] => + let (ident, idxsRev) ← translateLhsParts p bindings lhsa + let idx ← translateExpr p bindings idxa + return (ident, idx :: idxsRev) + | _, _ => TransM.error s!"translateLhsParts: unimplemented for {repr arg}" + mutual partial def translateFnPreconds (p : Program) (name : Core.CoreIdent) (bindings : TransBindings) (arg : Arg) : TransM (List (Strata.DL.Util.FuncPrecondition Core.Expression.Expr Core.Expression.ExprMetadata)) := do @@ -1255,10 +1346,13 @@ partial def translateStmt (p : Program) (bindings : TransBindings) (arg : Arg) : | q`Core.initStatement, args => translateInitStatement p bindings args (← getOpMetaData op) | q`Core.assign, #[_tpa, lhsa, ea] => - let lhs ← translateLhs lhsa + let (lhs, idxsRev) ← translateLhsParts p bindings lhsa let val ← translateExpr p bindings ea let md ← getOpMetaData op - return ([.set lhs val md], bindings) + let rhs := match idxsRev.reverse with + | [] => val + | idxs => nestMapUpdate (.fvar () lhs none) idxs val + return ([.set lhs rhs md], bindings) | q`Core.havoc_statement, #[ida] => let id ← translateIdent Core.CoreIdent ida let md ← getOpMetaData op diff --git a/Strata/Languages/Core/Factory.lean b/Strata/Languages/Core/Factory.lean index ef99656a5b..0fedf025c4 100644 --- a/Strata/Languages/Core/Factory.lean +++ b/Strata/Languages/Core/Factory.lean @@ -432,9 +432,9 @@ def seqLengthFunc : WFLFunc CoreLParams := ]) /- An empty `Sequence` constructor with type `∀a. Sequence a`. - NOTE: This is registered in the Factory for programmatic use, but is not yet - parseable from `.st` files because the DDM grammar cannot currently handle - 0-ary polymorphic functions (no arguments to infer the type parameter from). -/ + `Sequence.empty()` returns an empty sequence of element type `A`. + The `` is surface syntax produced by Grammar.lean and consumed by + Translate.lean; this function itself takes no value parameters. -/ def seqEmptyFunc : WFLFunc CoreLParams := polyUneval "Sequence.empty" ["a"] [] (seqTy mty[%a]) (axioms := [ diff --git a/StrataTest/Languages/Core/Examples/AdvancedMaps.lean b/StrataTest/Languages/Core/Examples/AdvancedMaps.lean index 1de2d946c6..1af27aa0fc 100644 --- a/StrataTest/Languages/Core/Examples/AdvancedMaps.lean +++ b/StrataTest/Languages/Core/Examples/AdvancedMaps.lean @@ -59,15 +59,15 @@ spec { requires [P_requires_1]: c[0] == a; } { assert [c_0_eq_a]: c[0] == a; - c := c[1:=a]; + c[1] := a; assert [c_1_eq_a]: c[1] == a; assert [a0eq0]: a[0] == 0; - a := a[1:=1]; + a[1] := 1; assert [a1eq1]: a[1] == 1; - a := a[0:=1]; + a[0] := 1; assert [a0eq1]: a[0] == 1; assert [a0neq2]: !(a[0] == 2); - b := b[true:=-1]; + b[true] := -1; assert [bTrueEqTrue]: b[true] == -1; assert [mix]: a[1] == -(b[true]); }; diff --git a/StrataTest/Languages/Core/Examples/AdvancedQuantifiers.lean b/StrataTest/Languages/Core/Examples/AdvancedQuantifiers.lean index 758a8a0a5f..aac3dcd880 100644 --- a/StrataTest/Languages/Core/Examples/AdvancedQuantifiers.lean +++ b/StrataTest/Languages/Core/Examples/AdvancedQuantifiers.lean @@ -32,14 +32,14 @@ VCs: Label: a Property: assert Assumptions: -mapAllValues0: forall __q0 : (Map int int) :: forall __q1 : int :: __q0[__q1] == 0 +mapAllValues0: forall m : (Map int int) :: forall k : int :: m[k] == 0 Obligation: mArg@1[kArg@1] == 0 Label: Update_ensures_0 Property: assert Assumptions: -mapAllValues0: forall __q0 : (Map int int) :: forall __q1 : int :: __q0[__q1] == 0 +mapAllValues0: forall m : (Map int int) :: forall k : int :: m[k] == 0 Obligation: mArg@1[kArg@1] == 0 diff --git a/StrataTest/Languages/Core/Examples/Axioms.lean b/StrataTest/Languages/Core/Examples/Axioms.lean index a763936907..6ed5ff4f5c 100644 --- a/StrataTest/Languages/Core/Examples/Axioms.lean +++ b/StrataTest/Languages/Core/Examples/Axioms.lean @@ -51,7 +51,7 @@ Property: assert Assumptions: a1: x == 5 a2: y == 2 -f1: forall __q0 : int :: f(__q0) > __q0 +f1: forall y : int :: f(y) > y Obligation: x > y @@ -60,7 +60,7 @@ Property: assert Assumptions: a1: x == 5 a2: y == 2 -f1: forall __q0 : int :: f(__q0) > __q0 +f1: forall y : int :: f(y) > y Obligation: f(x + y) > 7 @@ -69,7 +69,7 @@ Property: assert Assumptions: a1: x == 5 a2: y == 2 -f1: forall __q0 : int :: f(__q0) > __q0 +f1: forall y : int :: f(y) > y Obligation: y == 2 @@ -78,7 +78,7 @@ Property: assert Assumptions: a1: x == 5 a2: y == 2 -f1: forall __q0 : int :: f(__q0) > __q0 +f1: forall y : int :: f(y) > y Obligation: f(y) > y @@ -139,10 +139,10 @@ VCs: Label: axiomPgm2_main_assert Property: assert Assumptions: -f_g_ax: forall __q0 : int :: { f(__q0) } - f(__q0) == g(__q0) + 1 -g_ax: forall __q0 : int :: { g(__q0), f(__q0) } - g(__q0) == __q0 * 2 +f_g_ax: forall x : int :: { f(x) } + f(x) == g(x) + 1 +g_ax: forall x : int :: { g(x), f(x) } + g(x) == x * 2 Obligation: x@1 >= 0 ==> f(x@1) > x@1 diff --git a/StrataTest/Languages/Core/Examples/FunctionPreconditions.lean b/StrataTest/Languages/Core/Examples/FunctionPreconditions.lean index a33b03a92c..04f09ead9b 100644 --- a/StrataTest/Languages/Core/Examples/FunctionPreconditions.lean +++ b/StrataTest/Languages/Core/Examples/FunctionPreconditions.lean @@ -415,7 +415,7 @@ Property: assert Assumptions: precond_allPositiveDiv_0: y@2 >= 0 Obligation: -forall __q0 : int :: __q0 > 0 ==> !(__q0 == 0) +forall x : int :: x > 0 ==> !(x == 0) --- info: diff --git a/StrataTest/Languages/Core/Examples/Loops.lean b/StrataTest/Languages/Core/Examples/Loops.lean index 729c9c9a23..ddcddd7c62 100644 --- a/StrataTest/Languages/Core/Examples/Loops.lean +++ b/StrataTest/Languages/Core/Examples/Loops.lean @@ -384,6 +384,7 @@ loop_entry$_1: -- Errors encountered during conversion: Unsupported construct in lopToExpr: 0-ary op not found: top Context: Global scope: + freeVars: [n] 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); diff --git a/StrataTest/Languages/Core/Examples/Quantifiers.lean b/StrataTest/Languages/Core/Examples/Quantifiers.lean index 6436514ca4..825a5dd4d4 100644 --- a/StrataTest/Languages/Core/Examples/Quantifiers.lean +++ b/StrataTest/Languages/Core/Examples/Quantifiers.lean @@ -54,17 +54,17 @@ VCs: Label: good_assert Property: assert Obligation: -forall __q0 : int :: !(__q0 == __q0 + 1) +forall l : int :: !(l == l + 1) Label: good Property: assert Obligation: -forall __q0 : int :: exists __q1 : int :: x@1 + 1 + (__q1 + __q0) == __q0 + (__q1 + (x@1 + 1)) +forall y : int :: exists z : int :: x@1 + 1 + (z + y) == y + (z + (x@1 + 1)) Label: bad Property: assert Obligation: -forall __q0 : int :: __q0 < x@1 +forall q : int :: q < x@1 --- info: @@ -93,42 +93,42 @@ VCs: Label: trigger_assert Property: assert Assumptions: -f_pos: forall __q0 : int :: { f(__q0) } - f(__q0) > 0 -g_neg: forall __q0 : int :: forall __q1 : int :: { g(__q0, __q1) } - __q0 > 0 ==> g(__q0, __q1) < 0 -f_and_g: forall __q0 : int :: forall __q1 : int :: { g(__q0, __q1), f(__q0) } - g(__q0, __q1) < f(__q0) -f_and_g2: forall __q0 : int :: forall __q1 : int :: { g(__q0, __q1), f(__q0) } - g(__q0, __q1) < f(__q0) +f_pos: forall x : int :: { f(x) } + f(x) > 0 +g_neg: forall x : int :: forall y : int :: { g(x, y) } + x > 0 ==> g(x, y) < 0 +f_and_g: forall x : int :: forall y : int :: { g(x, y), f(x) } + g(x, y) < f(x) +f_and_g2: forall x : int :: forall y : int :: { g(x, y), f(x) } + g(x, y) < f(x) Obligation: f(x@1) > 0 Label: multi_trigger_assert Property: assert Assumptions: -f_pos: forall __q0 : int :: { f(__q0) } - f(__q0) > 0 -g_neg: forall __q0 : int :: forall __q1 : int :: { g(__q0, __q1) } - __q0 > 0 ==> g(__q0, __q1) < 0 -f_and_g: forall __q0 : int :: forall __q1 : int :: { g(__q0, __q1), f(__q0) } - g(__q0, __q1) < f(__q0) -f_and_g2: forall __q0 : int :: forall __q1 : int :: { g(__q0, __q1), f(__q0) } - g(__q0, __q1) < f(__q0) +f_pos: forall x : int :: { f(x) } + f(x) > 0 +g_neg: forall x : int :: forall y : int :: { g(x, y) } + x > 0 ==> g(x, y) < 0 +f_and_g: forall x : int :: forall y : int :: { g(x, y), f(x) } + g(x, y) < f(x) +f_and_g2: forall x : int :: forall y : int :: { g(x, y), f(x) } + g(x, y) < f(x) Obligation: -forall __q0 : int :: g(x@1, __q0) < f(x@1) +forall y : int :: g(x@1, y) < f(x@1) Label: f_and_g Property: assert Assumptions: -f_pos: forall __q0 : int :: { f(__q0) } - f(__q0) > 0 -g_neg: forall __q0 : int :: forall __q1 : int :: { g(__q0, __q1) } - __q0 > 0 ==> g(__q0, __q1) < 0 -f_and_g: forall __q0 : int :: forall __q1 : int :: { g(__q0, __q1), f(__q0) } - g(__q0, __q1) < f(__q0) -f_and_g2: forall __q0 : int :: forall __q1 : int :: { g(__q0, __q1), f(__q0) } - g(__q0, __q1) < f(__q0) +f_pos: forall x : int :: { f(x) } + f(x) > 0 +g_neg: forall x : int :: forall y : int :: { g(x, y) } + x > 0 ==> g(x, y) < 0 +f_and_g: forall x : int :: forall y : int :: { g(x, y), f(x) } + g(x, y) < f(x) +f_and_g2: forall x : int :: forall y : int :: { g(x, y), f(x) } + g(x, y) < f(x) Obligation: g(f(x@1), x@1) < 0 diff --git a/StrataTest/Languages/Core/Examples/QuantifiersWithTypeAliases.lean b/StrataTest/Languages/Core/Examples/QuantifiersWithTypeAliases.lean index cfebbf7c50..ac60917729 100644 --- a/StrataTest/Languages/Core/Examples/QuantifiersWithTypeAliases.lean +++ b/StrataTest/Languages/Core/Examples/QuantifiersWithTypeAliases.lean @@ -42,10 +42,10 @@ type Ref; type Field; type Struct := Map Field int; type Heap := Map Ref Struct; -axiom [axiom_0]: forall __q0 : Struct :: forall __q1 : Field :: forall __q2 : Field :: forall __q3 : int :: !(__q1 == __q2) ==> __q0[__q1] == (__q0[__q2:=__q3])[__q1]; -axiom [axiom_1]: forall __q0 : Struct :: forall __q1 : Field :: forall __q2 : int :: (__q0[__q1:=__q2])[__q1] == __q2; -axiom [axiom_2]: forall __q0 : Heap :: forall __q1 : Ref :: forall __q2 : Ref :: forall __q3 : Struct :: !(__q1 == __q2) ==> __q0[__q1] == (__q0[__q2:=__q3])[__q1]; -axiom [axiom_3]: forall __q0 : Heap :: forall __q1 : Ref :: forall __q2 : Struct :: (__q0[__q1:=__q2])[__q1] == __q2; +axiom [axiom_0]: forall m : Struct :: forall okk : Field :: forall kk : Field :: forall vv : int :: !(okk == kk) ==> m[okk] == (m[kk:=vv])[okk]; +axiom [axiom_1]: forall m : Struct :: forall kk : Field :: forall vv : int :: (m[kk:=vv])[kk] == vv; +axiom [axiom_2]: forall m : Heap :: forall okk : Ref :: forall kk : Ref :: forall vv : Struct :: !(okk == kk) ==> m[okk] == (m[kk:=vv])[okk]; +axiom [axiom_3]: forall m : Heap :: forall kk : Ref :: forall vv : Struct :: (m[kk:=vv])[kk] == vv; procedure test (h : Heap, ref : Ref, field : Field) { var newH : Heap := h[ref:=(h[ref])[field:=(h[ref])[field] + 1]]; @@ -64,10 +64,10 @@ VCs: Label: assert0 Property: assert Assumptions: -axiom_0: forall __q0 : (Map Field int) :: forall __q1 : Field :: forall __q2 : Field :: forall __q3 : int :: !(__q1 == __q2) ==> __q0[__q1] == (__q0[__q2:=__q3])[__q1] -axiom_1: forall __q0 : (Map Field int) :: forall __q1 : Field :: forall __q2 : int :: (__q0[__q1:=__q2])[__q1] == __q2 -axiom_2: forall __q0 : (Map Ref (Map Field int)) :: forall __q1 : Ref :: forall __q2 : Ref :: forall __q3 : (Map Field int) :: !(__q1 == __q2) ==> __q0[__q1] == (__q0[__q2:=__q3])[__q1] -axiom_3: forall __q0 : (Map Ref (Map Field int)) :: forall __q1 : Ref :: forall __q2 : (Map Field int) :: (__q0[__q1:=__q2])[__q1] == __q2 +axiom_0: forall m : (Map Field int) :: forall okk : Field :: forall kk : Field :: forall vv : int :: !(okk == kk) ==> m[okk] == (m[kk:=vv])[okk] +axiom_1: forall m : (Map Field int) :: forall kk : Field :: forall vv : int :: (m[kk:=vv])[kk] == vv +axiom_2: forall m : (Map Ref (Map Field int)) :: forall okk : Ref :: forall kk : Ref :: forall vv : (Map Field int) :: !(okk == kk) ==> m[okk] == (m[kk:=vv])[okk] +axiom_3: forall m : (Map Ref (Map Field int)) :: forall kk : Ref :: forall vv : (Map Field int) :: (m[kk:=vv])[kk] == vv Obligation: ((h@1[ref@1:=(h@1[ref@1])[field@1:=(h@1[ref@1])[field@1] + 1]])[ref@1])[field@1] == (h@1[ref@1])[field@1] + 1 diff --git a/StrataTest/Languages/Core/Examples/Seq.lean b/StrataTest/Languages/Core/Examples/Seq.lean index c7e3c32b8e..937c40858d 100644 --- a/StrataTest/Languages/Core/Examples/Seq.lean +++ b/StrataTest/Languages/Core/Examples/Seq.lean @@ -305,3 +305,169 @@ Result: ✅ pass #eval verify seqOpsPgm --------------------------------------------------------------------- + +---------------------------------------------------------------------- +-- Tests for Sequence.empty() syntax (issue #1027) +---------------------------------------------------------------------- + +private def seqEmptyPgm := +#strata +program Core; + +procedure SeqEmpty() +{ + var s : Sequence int; + + // Create an empty sequence using Sequence.empty syntax + s := Sequence.empty(); + assert [empty_length]: Sequence.length(s) == 0; + + // Build on top of an empty sequence + s := Sequence.build(Sequence.empty(), 42); + assert [build_on_empty_length]: Sequence.length(s) == 1; + assert [build_on_empty_elem]: Sequence.select(s, 0) == 42; +}; +#end + +/-- info: true -/ +#guard_msgs in +-- No errors in translation. +#eval TransM.run Inhabited.default (translateProgram seqEmptyPgm) |>.snd |>.isEmpty + +/-- +info: program Core; + +procedure SeqEmpty () +{ + var s : (Sequence int); + s := Sequence.empty(); + assert [empty_length]: Sequence.length(s) == 0; + s := Sequence.build(Sequence.empty(), 42); + assert [build_on_empty_length]: Sequence.length(s) == 1; + assert [build_on_empty_elem]: Sequence.select(s, 0) == 42; +}; +-/ +#guard_msgs in +#eval TransM.run Inhabited.default (translateProgram seqEmptyPgm) |>.fst + +/-- +info: [Strata.Core] Type checking succeeded. + + +VCs: +Label: empty_length +Property: assert +Obligation: +Sequence.length(Sequence.empty()) == 0 + +Label: build_on_empty_length +Property: assert +Obligation: +Sequence.length(Sequence.build(Sequence.empty(), 42)) == 1 + +Label: build_on_empty_elem +Property: assert +Obligation: +Sequence.select(Sequence.build(Sequence.empty(), 42), 0) == 42 + +--- +info: +Obligation: empty_length +Property: assert +Result: ✅ pass + +Obligation: build_on_empty_length +Property: assert +Result: ✅ pass + +Obligation: build_on_empty_elem +Property: assert +Result: ✅ pass +-/ +#guard_msgs in +#eval verify seqEmptyPgm + +---------------------------------------------------------------------- + +-- Exercise various element types for Sequence.empty(). +private def seqEmptyTypesPgm := +#strata +program Core; + +procedure SeqEmptyTypes() +{ + var sb : Sequence bool; + var ssi : Sequence (Sequence int); + var smi : Sequence (Map int bool); + + sb := Sequence.empty(); + ssi := Sequence.empty(); + smi := Sequence.empty(); + + assert [bool_len]: Sequence.length(sb) == 0; + assert [seq_seq_len]: Sequence.length(ssi) == 0; + assert [seq_map_len]: Sequence.length(smi) == 0; +}; +#end + +/-- info: true -/ +#guard_msgs in +#eval TransM.run Inhabited.default (translateProgram seqEmptyTypesPgm) |>.snd |>.isEmpty + +/-- +info: program Core; + +procedure SeqEmptyTypes () +{ + var sb : (Sequence bool); + var ssi : (Sequence (Sequence int)); + var smi : (Sequence (Map int bool)); + sb := Sequence.empty(); + ssi := Sequence.empty(); + smi := Sequence.empty(); + assert [bool_len]: Sequence.length(sb) == 0; + assert [seq_seq_len]: Sequence.length(ssi) == 0; + assert [seq_map_len]: Sequence.length(smi) == 0; +}; +-/ +#guard_msgs in +#eval TransM.run Inhabited.default (translateProgram seqEmptyTypesPgm) |>.fst + +/-- +info: [Strata.Core] Type checking succeeded. + + +VCs: +Label: bool_len +Property: assert +Obligation: +Sequence.length(Sequence.empty()) == 0 + +Label: seq_seq_len +Property: assert +Obligation: +Sequence.length(Sequence.empty()) == 0 + +Label: seq_map_len +Property: assert +Obligation: +Sequence.length(Sequence.empty()) == 0 + +--- +info: +Obligation: bool_len +Property: assert +Result: ✅ pass + +Obligation: seq_seq_len +Property: assert +Result: ✅ pass + +Obligation: seq_map_len +Property: assert +Result: ✅ pass +-/ +#guard_msgs in +#eval verify seqEmptyTypesPgm + +---------------------------------------------------------------------- diff --git a/StrataTest/Languages/Core/Examples/SubstFvarsCaptureTests.lean b/StrataTest/Languages/Core/Examples/SubstFvarsCaptureTests.lean index 042d88705e..03e9b3e795 100644 --- a/StrataTest/Languages/Core/Examples/SubstFvarsCaptureTests.lean +++ b/StrataTest/Languages/Core/Examples/SubstFvarsCaptureTests.lean @@ -114,11 +114,11 @@ private def actualsBvar : List (LExpr CoreLParams.mono) := [.bvar () 0] -- Correct (with lifting): `forall z :: bvar 1 > bvar 0` (bvar 1 = outer y). -- The "out of bounds" error is expected: bvar!1 is only in-bounds when the iterated version incorrectly captures it. /-- -info: forall __q0 : int :: bvar!1 > __q0 +info: forall z : int :: bvar!1 > z -- Errors: Unsupported construct in lexprToExpr: bvar index out of bounds: 1 Context: Global scope: Scope 1: - boundVars: [__q0] + boundVars: [z] -/ #guard_msgs in #eval Std.ToFormat.format (substitutePrecondition precondBvar formalsBvar actualsBvar) diff --git a/StrataTest/Languages/Core/Examples/TypeVarImplicitlyQuantified.lean b/StrataTest/Languages/Core/Examples/TypeVarImplicitlyQuantified.lean index ff5296a0df..1c580bbf23 100644 --- a/StrataTest/Languages/Core/Examples/TypeVarImplicitlyQuantified.lean +++ b/StrataTest/Languages/Core/Examples/TypeVarImplicitlyQuantified.lean @@ -45,10 +45,10 @@ info: ok: program Core; type set := Map int bool; function diff (a : Map int bool, b : Map int bool) : Map int bool; function lambda_0 (l_0 : bool, l_1 : int, l_2 : int) : Map int int; -axiom [a1]: forall __q0 : (Map int bool) :: forall __q1 : (Map int bool) :: { diff(__q0, __q1) } - diff(__q0, __q1) == diff(__q1, __q0); -axiom [a2]: forall __q0 : bool :: forall __q1 : int :: forall __q2 : int :: forall __q3 : int :: { (lambda_0(__q0, __q1, __q2))[__q3] } - (lambda_0(__q0, __q1, __q2))[__q3] == (lambda_0(__q0, __q2, __q1))[__q3]; +axiom [a1]: forall a : (Map int bool) :: forall b : (Map int bool) :: { diff(a, b) } + diff(a, b) == diff(b, a); +axiom [a2]: forall l_0 : bool :: forall l_1 : int :: forall l_2 : int :: forall y : int :: { (lambda_0(l_0, l_1, l_2))[y] } + (lambda_0(l_0, l_1, l_2))[y] == (lambda_0(l_0, l_2, l_1))[y]; -/ #guard_msgs in #eval Core.typeCheck .default core_pgm.fst diff --git a/StrataTest/Languages/Core/Tests/GeneratedLabels.lean b/StrataTest/Languages/Core/Tests/GeneratedLabels.lean index 1b5992dbc3..b97363ab5b 100644 --- a/StrataTest/Languages/Core/Tests/GeneratedLabels.lean +++ b/StrataTest/Languages/Core/Tests/GeneratedLabels.lean @@ -40,10 +40,10 @@ type Ref; type Field; type Struct := Map Field int; type Heap := Map Ref Struct; -axiom [axiom_0]: forall __q0 : Struct :: forall __q1 : Field :: forall __q2 : Field :: forall __q3 : int :: !(__q1 == __q2) ==> __q0[__q1] == (__q0[__q2:=__q3])[__q1]; -axiom [axiom_1]: forall __q0 : Struct :: forall __q1 : Field :: forall __q2 : int :: (__q0[__q1:=__q2])[__q1] == __q2; -axiom [axiom_2]: forall __q0 : Heap :: forall __q1 : Ref :: forall __q2 : Ref :: forall __q3 : Struct :: !(__q1 == __q2) ==> __q0[__q1] == (__q0[__q2:=__q3])[__q1]; -axiom [axiom_3]: forall __q0 : Heap :: forall __q1 : Ref :: forall __q2 : Struct :: (__q0[__q1:=__q2])[__q1] == __q2; +axiom [axiom_0]: forall m : Struct :: forall okk : Field :: forall kk : Field :: forall vv : int :: !(okk == kk) ==> m[okk] == (m[kk:=vv])[okk]; +axiom [axiom_1]: forall m : Struct :: forall kk : Field :: forall vv : int :: (m[kk:=vv])[kk] == vv; +axiom [axiom_2]: forall m : Heap :: forall okk : Ref :: forall kk : Ref :: forall vv : Struct :: !(okk == kk) ==> m[okk] == (m[kk:=vv])[okk]; +axiom [axiom_3]: forall m : Heap :: forall kk : Ref :: forall vv : Struct :: (m[kk:=vv])[kk] == vv; procedure test (h : Heap, ref : Ref, field : Field) { var newH : Heap := h[ref:=(h[ref])[field:=(h[ref])[field] + 1]]; @@ -61,10 +61,10 @@ VCs: Label: assert_0 Property: assert Assumptions: -axiom_0: forall __q0 : (Map Field int) :: forall __q1 : Field :: forall __q2 : Field :: forall __q3 : int :: !(__q1 == __q2) ==> __q0[__q1] == (__q0[__q2:=__q3])[__q1] -axiom_1: forall __q0 : (Map Field int) :: forall __q1 : Field :: forall __q2 : int :: (__q0[__q1:=__q2])[__q1] == __q2 -axiom_2: forall __q0 : (Map Ref (Map Field int)) :: forall __q1 : Ref :: forall __q2 : Ref :: forall __q3 : (Map Field int) :: !(__q1 == __q2) ==> __q0[__q1] == (__q0[__q2:=__q3])[__q1] -axiom_3: forall __q0 : (Map Ref (Map Field int)) :: forall __q1 : Ref :: forall __q2 : (Map Field int) :: (__q0[__q1:=__q2])[__q1] == __q2 +axiom_0: forall m : (Map Field int) :: forall okk : Field :: forall kk : Field :: forall vv : int :: !(okk == kk) ==> m[okk] == (m[kk:=vv])[okk] +axiom_1: forall m : (Map Field int) :: forall kk : Field :: forall vv : int :: (m[kk:=vv])[kk] == vv +axiom_2: forall m : (Map Ref (Map Field int)) :: forall okk : Ref :: forall kk : Ref :: forall vv : (Map Field int) :: !(okk == kk) ==> m[okk] == (m[kk:=vv])[okk] +axiom_3: forall m : (Map Ref (Map Field int)) :: forall kk : Ref :: forall vv : (Map Field int) :: (m[kk:=vv])[kk] == vv Obligation: ((h@1[ref@1:=(h@1[ref@1])[field@1:=(h@1[ref@1])[field@1] + 1]])[ref@1])[field@1] == (h@1[ref@1])[field@1] + 1 diff --git a/StrataTest/Languages/Core/Tests/LambdaHigherOrderTests.lean b/StrataTest/Languages/Core/Tests/LambdaHigherOrderTests.lean index 379e681eda..fe93e8e0e8 100644 --- a/StrataTest/Languages/Core/Tests/LambdaHigherOrderTests.lean +++ b/StrataTest/Languages/Core/Tests/LambdaHigherOrderTests.lean @@ -93,7 +93,7 @@ info: [Strata.Core] Type checking succeeded. --- info: ok: program Core; -function apply (f : int -> int, x : int) : int { +inline function apply (f : int -> int, x : int) : int { f(x) } procedure TestLambdaApply (out result : int) diff --git a/StrataTest/Languages/Core/Tests/MutualRecursiveFunctionTests.lean b/StrataTest/Languages/Core/Tests/MutualRecursiveFunctionTests.lean index 10173ed316..9de26a834c 100644 --- a/StrataTest/Languages/Core/Tests/MutualRecursiveFunctionTests.lean +++ b/StrataTest/Languages/Core/Tests/MutualRecursiveFunctionTests.lean @@ -66,20 +66,20 @@ Obligation: Label: isEven_terminates_0 Property: assert Assumptions: -MyNat..adtRank_0: forall __q0 : MyNat :: { MyNat..adtRank(__q0) } - MyNat..adtRank(__q0) >= 0 -MyNat..adtRank_1: forall __q0 : MyNat :: { MyNat..adtRank(Succ(__q0)) } - MyNat..adtRank(__q0) < MyNat..adtRank(Succ(__q0)) +MyNat..adtRank_0: forall x : MyNat :: { MyNat..adtRank(x) } + MyNat..adtRank(x) >= 0 +MyNat..adtRank_1: forall pred : MyNat :: { MyNat..adtRank(Succ(pred)) } + MyNat..adtRank(pred) < MyNat..adtRank(Succ(pred)) Obligation: !(MyNat..isZero(n@3)) ==> MyNat..adtRank(MyNat..pred(n@3)) < MyNat..adtRank(n@3) Label: isOdd_terminates_0 Property: assert Assumptions: -MyNat..adtRank_0: forall __q0 : MyNat :: { MyNat..adtRank(__q0) } - MyNat..adtRank(__q0) >= 0 -MyNat..adtRank_1: forall __q0 : MyNat :: { MyNat..adtRank(Succ(__q0)) } - MyNat..adtRank(__q0) < MyNat..adtRank(Succ(__q0)) +MyNat..adtRank_0: forall x : MyNat :: { MyNat..adtRank(x) } + MyNat..adtRank(x) >= 0 +MyNat..adtRank_1: forall pred : MyNat :: { MyNat..adtRank(Succ(pred)) } + MyNat..adtRank(pred) < MyNat..adtRank(Succ(pred)) Obligation: !(MyNat..isZero(n@4)) ==> MyNat..adtRank(MyNat..pred(n@4)) < MyNat..adtRank(n@4) diff --git a/StrataTest/Languages/Core/Tests/ProgramEvalTests.lean b/StrataTest/Languages/Core/Tests/ProgramEvalTests.lean index d9ee5b06a5..51d905cbd8 100644 --- a/StrataTest/Languages/Core/Tests/ProgramEvalTests.lean +++ b/StrataTest/Languages/Core/Tests/ProgramEvalTests.lean @@ -268,115 +268,115 @@ func Bv64.UAddOverflow : ((x : bv64) (y : bv64)) → bool; func Bv64.USubOverflow : ((x : bv64) (y : bv64)) → bool; func Bv64.UMulOverflow : ((x : bv64) (y : bv64)) → bool; func Bv1.SafeAdd : ((x : bv1) (y : bv1)) → bv1 - requires !(x <= y); + requires !(Bv.SAddOverflow(x, y)); func Bv1.SafeSub : ((x : bv1) (y : bv1)) → bv1 - requires !(x <= y); + requires !(Bv.SSubOverflow(x, y)); func Bv1.SafeMul : ((x : bv1) (y : bv1)) → bv1 - requires !(x <= y); + requires !(Bv.SMulOverflow(x, y)); func Bv1.SafeNeg : ((x : bv1)) → bv1 - requires !(!x); + requires !(Bv.SNegOverflow(x)); func Bv1.SafeUAdd : ((x : bv1) (y : bv1)) → bv1 - requires !(x <= y); + requires !(Bv.UAddOverflow(x, y)); func Bv1.SafeUSub : ((x : bv1) (y : bv1)) → bv1 - requires !(x <= y); + requires !(Bv.USubOverflow(x, y)); func Bv1.SafeUMul : ((x : bv1) (y : bv1)) → bv1 - requires !(x <= y); + requires !(Bv.UMulOverflow(x, y)); func Bv1.SafeUNeg : ((x : bv1)) → bv1 - requires !(!x); + requires !(Bv.UNegOverflow(x)); func Bv8.SafeAdd : ((x : bv8) (y : bv8)) → bv8 - requires !(x <= y); + requires !(Bv.SAddOverflow(x, y)); func Bv8.SafeSub : ((x : bv8) (y : bv8)) → bv8 - requires !(x <= y); + requires !(Bv.SSubOverflow(x, y)); func Bv8.SafeMul : ((x : bv8) (y : bv8)) → bv8 - requires !(x <= y); + requires !(Bv.SMulOverflow(x, y)); func Bv8.SafeNeg : ((x : bv8)) → bv8 - requires !(!x); + requires !(Bv.SNegOverflow(x)); func Bv8.SafeUAdd : ((x : bv8) (y : bv8)) → bv8 - requires !(x <= y); + requires !(Bv.UAddOverflow(x, y)); func Bv8.SafeUSub : ((x : bv8) (y : bv8)) → bv8 - requires !(x <= y); + requires !(Bv.USubOverflow(x, y)); func Bv8.SafeUMul : ((x : bv8) (y : bv8)) → bv8 - requires !(x <= y); + requires !(Bv.UMulOverflow(x, y)); func Bv8.SafeUNeg : ((x : bv8)) → bv8 - requires !(!x); + requires !(Bv.UNegOverflow(x)); func Bv16.SafeAdd : ((x : bv16) (y : bv16)) → bv16 - requires !(x <= y); + requires !(Bv.SAddOverflow(x, y)); func Bv16.SafeSub : ((x : bv16) (y : bv16)) → bv16 - requires !(x <= y); + requires !(Bv.SSubOverflow(x, y)); func Bv16.SafeMul : ((x : bv16) (y : bv16)) → bv16 - requires !(x <= y); + requires !(Bv.SMulOverflow(x, y)); func Bv16.SafeNeg : ((x : bv16)) → bv16 - requires !(!x); + requires !(Bv.SNegOverflow(x)); func Bv16.SafeUAdd : ((x : bv16) (y : bv16)) → bv16 - requires !(x <= y); + requires !(Bv.UAddOverflow(x, y)); func Bv16.SafeUSub : ((x : bv16) (y : bv16)) → bv16 - requires !(x <= y); + requires !(Bv.USubOverflow(x, y)); func Bv16.SafeUMul : ((x : bv16) (y : bv16)) → bv16 - requires !(x <= y); + requires !(Bv.UMulOverflow(x, y)); func Bv16.SafeUNeg : ((x : bv16)) → bv16 - requires !(!x); + requires !(Bv.UNegOverflow(x)); func Bv32.SafeAdd : ((x : bv32) (y : bv32)) → bv32 - requires !(x <= y); + requires !(Bv.SAddOverflow(x, y)); func Bv32.SafeSub : ((x : bv32) (y : bv32)) → bv32 - requires !(x <= y); + requires !(Bv.SSubOverflow(x, y)); func Bv32.SafeMul : ((x : bv32) (y : bv32)) → bv32 - requires !(x <= y); + requires !(Bv.SMulOverflow(x, y)); func Bv32.SafeNeg : ((x : bv32)) → bv32 - requires !(!x); + requires !(Bv.SNegOverflow(x)); func Bv32.SafeUAdd : ((x : bv32) (y : bv32)) → bv32 - requires !(x <= y); + requires !(Bv.UAddOverflow(x, y)); func Bv32.SafeUSub : ((x : bv32) (y : bv32)) → bv32 - requires !(x <= y); + requires !(Bv.USubOverflow(x, y)); func Bv32.SafeUMul : ((x : bv32) (y : bv32)) → bv32 - requires !(x <= y); + requires !(Bv.UMulOverflow(x, y)); func Bv32.SafeUNeg : ((x : bv32)) → bv32 - requires !(!x); + requires !(Bv.UNegOverflow(x)); func Bv64.SafeAdd : ((x : bv64) (y : bv64)) → bv64 - requires !(x <= y); + requires !(Bv.SAddOverflow(x, y)); func Bv64.SafeSub : ((x : bv64) (y : bv64)) → bv64 - requires !(x <= y); + requires !(Bv.SSubOverflow(x, y)); func Bv64.SafeMul : ((x : bv64) (y : bv64)) → bv64 - requires !(x <= y); + requires !(Bv.SMulOverflow(x, y)); func Bv64.SafeNeg : ((x : bv64)) → bv64 - requires !(!x); + requires !(Bv.SNegOverflow(x)); func Bv64.SafeUAdd : ((x : bv64) (y : bv64)) → bv64 - requires !(x <= y); + requires !(Bv.UAddOverflow(x, y)); func Bv64.SafeUSub : ((x : bv64) (y : bv64)) → bv64 - requires !(x <= y); + requires !(Bv.USubOverflow(x, y)); func Bv64.SafeUMul : ((x : bv64) (y : bv64)) → bv64 - requires !(x <= y); + requires !(Bv.UMulOverflow(x, y)); func Bv64.SafeUNeg : ((x : bv64)) → bv64 - requires !(!x); + requires !(Bv.UNegOverflow(x)); func Bv1.SafeSDiv : ((x : bv1) (y : bv1)) → bv1 requires !(y == bv{1}(0)) - requires !(x <= y); + requires !(Bv.SDivOverflow(x, y)); func Bv1.SafeSMod : ((x : bv1) (y : bv1)) → bv1 requires !(y == bv{1}(0)) - requires !(x <= y); + requires !(Bv.SDivOverflow(x, y)); func Bv8.SafeSDiv : ((x : bv8) (y : bv8)) → bv8 requires !(y == bv{8}(0)) - requires !(x <= y); + requires !(Bv.SDivOverflow(x, y)); func Bv8.SafeSMod : ((x : bv8) (y : bv8)) → bv8 requires !(y == bv{8}(0)) - requires !(x <= y); + requires !(Bv.SDivOverflow(x, y)); func Bv16.SafeSDiv : ((x : bv16) (y : bv16)) → bv16 requires !(y == bv{16}(0)) - requires !(x <= y); + requires !(Bv.SDivOverflow(x, y)); func Bv16.SafeSMod : ((x : bv16) (y : bv16)) → bv16 requires !(y == bv{16}(0)) - requires !(x <= y); + requires !(Bv.SDivOverflow(x, y)); func Bv32.SafeSDiv : ((x : bv32) (y : bv32)) → bv32 requires !(y == bv{32}(0)) - requires !(x <= y); + requires !(Bv.SDivOverflow(x, y)); func Bv32.SafeSMod : ((x : bv32) (y : bv32)) → bv32 requires !(y == bv{32}(0)) - requires !(x <= y); + requires !(Bv.SDivOverflow(x, y)); func Bv64.SafeSDiv : ((x : bv64) (y : bv64)) → bv64 requires !(y == bv{64}(0)) - requires !(x <= y); + requires !(Bv.SDivOverflow(x, y)); func Bv64.SafeSMod : ((x : bv64) (y : bv64)) → bv64 requires !(y == bv{64}(0)) - requires !(x <= y); + requires !(Bv.SDivOverflow(x, y)); Datatypes: diff --git a/StrataTest/Languages/Core/Tests/QuantifierBvarIndexTest.lean b/StrataTest/Languages/Core/Tests/QuantifierBvarIndexTest.lean index 4a806af60e..492b8a493b 100644 --- a/StrataTest/Languages/Core/Tests/QuantifierBvarIndexTest.lean +++ b/StrataTest/Languages/Core/Tests/QuantifierBvarIndexTest.lean @@ -36,7 +36,7 @@ info: [Strata.Core] Type checking succeeded. info: ok: program Core; function apply (f : int -> int, x : int) : int; -axiom [axiom_0]: forall __q0 : int -> int :: forall __q1 : int :: apply(__q0, __q1) == __q0(__q1); +axiom [axiom_0]: forall f : int -> int :: forall x : int :: apply(f, x) == f(x); -/ #guard_msgs in #eval (Std.format ((Core.typeCheck .default (translate axiomApplyBoundVar).stripMetaData))) @@ -71,7 +71,7 @@ function apply (f : int -> int, x : int) : int { } procedure Check (out result : bool) spec { - ensures [Check_ensures_0]: result == forall __q0 : int -> int :: forall __q1 : int :: apply(__q0, __q1) == __q0(__q1); + ensures [Check_ensures_0]: result == forall f : int -> int :: forall x : int :: apply(f, x) == f(x); } { result := true; }; diff --git a/StrataTest/Languages/Core/Tests/RecursiveFunctionTests.lean b/StrataTest/Languages/Core/Tests/RecursiveFunctionTests.lean index c27eac0880..43f6f1e761 100644 --- a/StrataTest/Languages/Core/Tests/RecursiveFunctionTests.lean +++ b/StrataTest/Languages/Core/Tests/RecursiveFunctionTests.lean @@ -61,10 +61,10 @@ Obligation: Label: listLen_terminates_0 Property: assert Assumptions: -IntList..adtRank_0: forall __q0 : IntList :: { IntList..adtRank(__q0) } - IntList..adtRank(__q0) >= 0 -IntList..adtRank_1: forall __q0 : int :: forall __q1 : IntList :: { IntList..adtRank(Cons(__q0, __q1)) } - IntList..adtRank(__q1) < IntList..adtRank(Cons(__q0, __q1)) +IntList..adtRank_0: forall x : IntList :: { IntList..adtRank(x) } + IntList..adtRank(x) >= 0 +IntList..adtRank_1: forall hd : int :: forall tl : IntList :: { IntList..adtRank(Cons(hd, tl)) } + IntList..adtRank(tl) < IntList..adtRank(Cons(hd, tl)) Obligation: !(IntList..isNil(xs@2)) ==> IntList..adtRank(IntList..tl(xs@2)) < IntList..adtRank(xs@2) @@ -168,10 +168,10 @@ Obligation: Label: listLen_terminates_0 Property: assert Assumptions: -IntList..adtRank_0: forall __q0 : IntList :: { IntList..adtRank(__q0) } - IntList..adtRank(__q0) >= 0 -IntList..adtRank_1: forall __q0 : int :: forall __q1 : IntList :: { IntList..adtRank(Cons(__q0, __q1)) } - IntList..adtRank(__q1) < IntList..adtRank(Cons(__q0, __q1)) +IntList..adtRank_0: forall x : IntList :: { IntList..adtRank(x) } + IntList..adtRank(x) >= 0 +IntList..adtRank_1: forall hd : int :: forall tl : IntList :: { IntList..adtRank(Cons(hd, tl)) } + IntList..adtRank(tl) < IntList..adtRank(Cons(hd, tl)) Obligation: !(IntList..isNil(xs@2)) ==> IntList..adtRank(IntList..tl(xs@2)) < IntList..adtRank(xs@2) @@ -360,10 +360,10 @@ Obligation: Label: listLen_terminates_0 Property: assert Assumptions: -IntList..adtRank_0: forall __q0 : IntList :: { IntList..adtRank(__q0) } - IntList..adtRank(__q0) >= 0 -IntList..adtRank_1: forall __q0 : int :: forall __q1 : IntList :: { IntList..adtRank(Cons(__q0, __q1)) } - IntList..adtRank(__q1) < IntList..adtRank(Cons(__q0, __q1)) +IntList..adtRank_0: forall x : IntList :: { IntList..adtRank(x) } + IntList..adtRank(x) >= 0 +IntList..adtRank_1: forall hd : int :: forall tl : IntList :: { IntList..adtRank(Cons(hd, tl)) } + IntList..adtRank(tl) < IntList..adtRank(Cons(hd, tl)) Obligation: !(IntList..isNil(xs@2)) ==> IntList..adtRank(IntList..tl(xs@2)) < IntList..adtRank(xs@2) diff --git a/StrataTest/Languages/Core/Tests/RoundtripTest.lean b/StrataTest/Languages/Core/Tests/RoundtripTest.lean new file mode 100644 index 0000000000..4ff9c9d88a --- /dev/null +++ b/StrataTest/Languages/Core/Tests/RoundtripTest.lean @@ -0,0 +1,235 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.Core.DDMTransform.ASTtoCST +import Strata.Languages.Core.DDMTransform.Translate +import Strata.DDM.Elab +import Strata.DDM.BuiltinDialects.Init + +/-! +# Core Roundtrip Tests + +Tests that `Core.formatProgram` produces output that can be parsed back to the +same AST. The roundtrip is: parse → translate → format → re-parse → re-translate +→ compare. +-/ + +namespace Strata.Test.Roundtrip + +open Strata +open Strata.CoreDDM +open Core +open Lean.Parser (InputContext) + +/-- Parse a string as a Core program and translate to AST. -/ +private def parseAndTranslate (input : String) : IO Core.Program := do + let dialects := Strata.Elab.LoadedDialects.ofDialects! #[initDialect, Core] + -- Strip "program Core;\n\n" header if present + let body := if input.startsWith "program Core;\n\n" then + (input.drop "program Core;\n\n".length).toString + else input + let inputCtx := Strata.Parser.stringInputContext ⟨"roundtrip-test"⟩ body + let strataProgram ← Strata.Elab.parseStrataProgramFromDialect dialects "Core" inputCtx + let (ast, errs) := TransM.run Inhabited.default (translateProgram strataProgram) + if !errs.isEmpty then + throw (IO.userError s!"Translation errors: {errs}") + pure ast + +/-- Perform a roundtrip test: parse → format → re-parse → compare. + Prints OK or FAIL with details. -/ +def roundtrip (program : Strata.Program) : IO Unit := do + -- First pass: translate to AST + let (ast1, errs1) := TransM.run Inhabited.default (translateProgram program) + if !errs1.isEmpty then + IO.println s!"FAIL: First translation errors: {errs1}" + return + -- Format back to text + let formatted := (Core.formatProgram ast1).pretty + -- Second pass: re-parse and re-translate + let ast2 ← parseAndTranslate formatted + -- Compare: format both ASTs and check they match + let formatted2 := (Core.formatProgram ast2).pretty + if formatted == formatted2 then + IO.println "OK" + else + IO.println s!"FAIL: Roundtrip mismatch.\nFirst format:\n{formatted}\nSecond format:\n{formatted2}" + +------------------------------------------------------------------------------- +-- Test: Basic types and type aliases +------------------------------------------------------------------------------- + +private def testTypesRoundtrip : Program := +#strata +program Core; + +type T0; +type Byte := bv8; +type IntMap := Map int int; +type T1 (x : Type); +type MyMap (a : Type, b : Type); +type Foo (a : Type, b : Type) := Map b a; +#end + +/-- info: OK -/ +#guard_msgs in +#eval roundtrip testTypesRoundtrip + +------------------------------------------------------------------------------- +-- Test: Polymorphic datatypes with parameterized types +------------------------------------------------------------------------------- + +private def testDatatypesRoundtrip : Program := +#strata +program Core; + +datatype List (a : Type) { + Nil(), + Cons(head : a, tail : List a) +}; + +datatype Tree (a : Type) { + Leaf(val : a), + Node(left : Tree a, right : Tree a) +}; +#end + +/-- +info: program Core; + +datatype List (a : Type) { + Nil(), + Cons(head : a, tail : List a) +}; +datatype Tree (a : Type) { + Leaf(val : a), + Node(left : Tree a, right : Tree a) +}; +-/ +#guard_msgs in +#eval do + let (ast, _) := TransM.run Inhabited.default (translateProgram testDatatypesRoundtrip) + IO.println f!"{Core.formatProgram ast}" + +/-- info: OK -/ +#guard_msgs in +#eval roundtrip testDatatypesRoundtrip + +------------------------------------------------------------------------------- +-- Test: Functions and axioms with quantifiers +------------------------------------------------------------------------------- + +private def testFunctionsRoundtrip : Program := +#strata +program Core; + +function f1(x : int) : int; +axiom [f1_ax]: (forall x : int :: f1(x) > x); + +function f2(x : int, y : bool) : bool; +axiom [f2_ax]: (forall x : int, y : bool :: + {f2(x, true), f2(x, false)} + f2(x, true) == true); + +function f3(x : T1) : Map T1 T2; +#end + +/-- info: OK -/ +#guard_msgs in +#eval roundtrip testFunctionsRoundtrip + +------------------------------------------------------------------------------- +-- Test: Procedures with specs +------------------------------------------------------------------------------- + +private def testProceduresRoundtrip : Program := +#strata +program Core; + +procedure Test(x : bool, out y : bool) +spec { + requires x == true; + ensures y == x; +} { + y := x; +}; +#end + +/-- info: OK -/ +#guard_msgs in +#eval roundtrip testProceduresRoundtrip + +------------------------------------------------------------------------------- +-- Test: Inline functions +------------------------------------------------------------------------------- + +private def testInlineFunctionRoundtrip : Program := +#strata +program Core; + +inline function double(x : int) : int { + x + x +} +#end + +/-- info: OK -/ +#guard_msgs in +#eval roundtrip testInlineFunctionRoundtrip + +------------------------------------------------------------------------------- +-- Test: Parameterized type arguments (the reversed-args bug) +------------------------------------------------------------------------------- + +private def testTypeArgsRoundtrip : Program := +#strata +program Core; + +type Pair (a : Type, b : Type); + +function f(x : Pair int bool) : int; +function g(x : Map int bool) : int; +#end + +/-- info: OK -/ +#guard_msgs in +#eval roundtrip testTypeArgsRoundtrip + +------------------------------------------------------------------------------- +-- Test: Array assignment (lhsArray: m[k] := v) +------------------------------------------------------------------------------- + +private def testLhsArrayRoundtrip : Program := +#strata +program Core; + +procedure MapUpdate(m : Map int int, out m : Map int int) +spec { + ensures true; +} { + m[0] := 1; +}; +#end + +/-- info: OK -/ +#guard_msgs in +#eval roundtrip testLhsArrayRoundtrip + +------------------------------------------------------------------------------- +-- Test: Sequence.empty with explicit type annotation +------------------------------------------------------------------------------- + +private def testSeqEmptyRoundtrip : Program := +#strata +program Core; + +function f(s : Sequence int) : bool; +axiom [f_ax]: f(Sequence.empty()) == true; +#end + +/-- info: OK -/ +#guard_msgs in +#eval roundtrip testSeqEmptyRoundtrip + +end Strata.Test.Roundtrip diff --git a/StrataTest/Languages/Core/Tests/TerminationCheckTests.lean b/StrataTest/Languages/Core/Tests/TerminationCheckTests.lean index 3de20d743a..48486280af 100644 --- a/StrataTest/Languages/Core/Tests/TerminationCheckTests.lean +++ b/StrataTest/Languages/Core/Tests/TerminationCheckTests.lean @@ -54,10 +54,10 @@ Obligation: Label: listLen_terminates_0 Property: assert Assumptions: -IntList..adtRank_0: forall __q0 : IntList :: { IntList..adtRank(__q0) } - IntList..adtRank(__q0) >= 0 -IntList..adtRank_1: forall __q0 : int :: forall __q1 : IntList :: { IntList..adtRank(Cons(__q0, __q1)) } - IntList..adtRank(__q1) < IntList..adtRank(Cons(__q0, __q1)) +IntList..adtRank_0: forall x : IntList :: { IntList..adtRank(x) } + IntList..adtRank(x) >= 0 +IntList..adtRank_1: forall hd : int :: forall tl : IntList :: { IntList..adtRank(Cons(hd, tl)) } + IntList..adtRank(tl) < IntList..adtRank(Cons(hd, tl)) Obligation: !(IntList..isNil(xs@2)) ==> IntList..adtRank(IntList..tl(xs@2)) < IntList..adtRank(xs@2) @@ -320,10 +320,10 @@ Obligation: Label: listLen_terminates_0 Property: assert Assumptions: -IntList..adtRank_0: forall __q0 : IntList :: { IntList..adtRank(__q0) } - IntList..adtRank(__q0) >= 0 -IntList..adtRank_1: forall __q0 : int :: forall __q1 : IntList :: { IntList..adtRank(Cons(__q0, __q1)) } - IntList..adtRank(__q1) < IntList..adtRank(Cons(__q0, __q1)) +IntList..adtRank_0: forall x : IntList :: { IntList..adtRank(x) } + IntList..adtRank(x) >= 0 +IntList..adtRank_1: forall hd : int :: forall tl : IntList :: { IntList..adtRank(Cons(hd, tl)) } + IntList..adtRank(tl) < IntList..adtRank(Cons(hd, tl)) Obligation: !(IntList..isNil(xs@2)) ==> IntList..adtRank(IntList..tl(xs@2)) < IntList..adtRank(xs@2) @@ -340,10 +340,10 @@ Obligation: Label: listSum_terminates_0 Property: assert Assumptions: -IntList..adtRank_0: forall __q0 : IntList :: { IntList..adtRank(__q0) } - IntList..adtRank(__q0) >= 0 -IntList..adtRank_1: forall __q0 : int :: forall __q1 : IntList :: { IntList..adtRank(Cons(__q0, __q1)) } - IntList..adtRank(__q1) < IntList..adtRank(Cons(__q0, __q1)) +IntList..adtRank_0: forall x : IntList :: { IntList..adtRank(x) } + IntList..adtRank(x) >= 0 +IntList..adtRank_1: forall hd : int :: forall tl : IntList :: { IntList..adtRank(Cons(hd, tl)) } + IntList..adtRank(tl) < IntList..adtRank(Cons(hd, tl)) Obligation: !(IntList..isNil(xs@4)) ==> IntList..adtRank(IntList..tl(xs@4)) < IntList..adtRank(xs@4) @@ -449,42 +449,42 @@ Obligation: Label: treeSize_terminates_0 Property: assert Assumptions: -Tree..adtRank_0: forall __q0 : Tree :: { Tree..adtRank(__q0) } - Tree..adtRank(__q0) >= 0 -Tree..adtRank_1: forall __q0 : Tree :: forall __q1 : Tree :: { Tree..adtRank(Branch(__q0, __q1)) } - Tree..adtRank(__q0) < Tree..adtRank(Branch(__q0, __q1)) -Tree..adtRank_2: forall __q0 : Tree :: forall __q1 : Tree :: { Tree..adtRank(Branch(__q0, __q1)) } - Tree..adtRank(__q1) < Tree..adtRank(Branch(__q0, __q1)) -Tree..adtRank_3: forall __q0 : int :: forall __q1 : Tree :: { Tree..adtRank(Chain(__q0, __q1)) } - Tree..adtRank(__q1) < Tree..adtRank(Chain(__q0, __q1)) +Tree..adtRank_0: forall x : Tree :: { Tree..adtRank(x) } + Tree..adtRank(x) >= 0 +Tree..adtRank_1: forall left : Tree :: forall right : Tree :: { Tree..adtRank(Branch(left, right)) } + Tree..adtRank(left) < Tree..adtRank(Branch(left, right)) +Tree..adtRank_2: forall left : Tree :: forall right : Tree :: { Tree..adtRank(Branch(left, right)) } + Tree..adtRank(right) < Tree..adtRank(Branch(left, right)) +Tree..adtRank_3: forall head : int :: forall tail : Tree :: { Tree..adtRank(Chain(head, tail)) } + Tree..adtRank(tail) < Tree..adtRank(Chain(head, tail)) Obligation: Tree..isBranch(t@2) ==> !(Tree..isLeaf(t@2)) ==> Tree..adtRank(Tree..left(t@2)) < Tree..adtRank(t@2) Label: treeSize_terminates_1 Property: assert Assumptions: -Tree..adtRank_0: forall __q0 : Tree :: { Tree..adtRank(__q0) } - Tree..adtRank(__q0) >= 0 -Tree..adtRank_1: forall __q0 : Tree :: forall __q1 : Tree :: { Tree..adtRank(Branch(__q0, __q1)) } - Tree..adtRank(__q0) < Tree..adtRank(Branch(__q0, __q1)) -Tree..adtRank_2: forall __q0 : Tree :: forall __q1 : Tree :: { Tree..adtRank(Branch(__q0, __q1)) } - Tree..adtRank(__q1) < Tree..adtRank(Branch(__q0, __q1)) -Tree..adtRank_3: forall __q0 : int :: forall __q1 : Tree :: { Tree..adtRank(Chain(__q0, __q1)) } - Tree..adtRank(__q1) < Tree..adtRank(Chain(__q0, __q1)) +Tree..adtRank_0: forall x : Tree :: { Tree..adtRank(x) } + Tree..adtRank(x) >= 0 +Tree..adtRank_1: forall left : Tree :: forall right : Tree :: { Tree..adtRank(Branch(left, right)) } + Tree..adtRank(left) < Tree..adtRank(Branch(left, right)) +Tree..adtRank_2: forall left : Tree :: forall right : Tree :: { Tree..adtRank(Branch(left, right)) } + Tree..adtRank(right) < Tree..adtRank(Branch(left, right)) +Tree..adtRank_3: forall head : int :: forall tail : Tree :: { Tree..adtRank(Chain(head, tail)) } + Tree..adtRank(tail) < Tree..adtRank(Chain(head, tail)) Obligation: Tree..isBranch(t@2) ==> !(Tree..isLeaf(t@2)) ==> Tree..adtRank(Tree..right(t@2)) < Tree..adtRank(t@2) Label: treeSize_terminates_2 Property: assert Assumptions: -Tree..adtRank_0: forall __q0 : Tree :: { Tree..adtRank(__q0) } - Tree..adtRank(__q0) >= 0 -Tree..adtRank_1: forall __q0 : Tree :: forall __q1 : Tree :: { Tree..adtRank(Branch(__q0, __q1)) } - Tree..adtRank(__q0) < Tree..adtRank(Branch(__q0, __q1)) -Tree..adtRank_2: forall __q0 : Tree :: forall __q1 : Tree :: { Tree..adtRank(Branch(__q0, __q1)) } - Tree..adtRank(__q1) < Tree..adtRank(Branch(__q0, __q1)) -Tree..adtRank_3: forall __q0 : int :: forall __q1 : Tree :: { Tree..adtRank(Chain(__q0, __q1)) } - Tree..adtRank(__q1) < Tree..adtRank(Chain(__q0, __q1)) +Tree..adtRank_0: forall x : Tree :: { Tree..adtRank(x) } + Tree..adtRank(x) >= 0 +Tree..adtRank_1: forall left : Tree :: forall right : Tree :: { Tree..adtRank(Branch(left, right)) } + Tree..adtRank(left) < Tree..adtRank(Branch(left, right)) +Tree..adtRank_2: forall left : Tree :: forall right : Tree :: { Tree..adtRank(Branch(left, right)) } + Tree..adtRank(right) < Tree..adtRank(Branch(left, right)) +Tree..adtRank_3: forall head : int :: forall tail : Tree :: { Tree..adtRank(Chain(head, tail)) } + Tree..adtRank(tail) < Tree..adtRank(Chain(head, tail)) Obligation: !(Tree..isBranch(t@2)) ==> !(Tree..isLeaf(t@2)) ==> Tree..adtRank(Tree..tail(t@2)) < Tree..adtRank(t@2) @@ -581,10 +581,10 @@ Obligation: Label: intListLen_terminates_0 Property: assert Assumptions: -MyList..adtRank_0: forall __q0 : (MyList int) :: { MyList..adtRank(__q0) } - MyList..adtRank(__q0) >= 0 -MyList..adtRank_1: forall __q0 : int :: forall __q1 : (MyList int) :: { MyList..adtRank(Cons(__q0, __q1)) } - MyList..adtRank(__q1) < MyList..adtRank(Cons(__q0, __q1)) +MyList..adtRank_0: forall x : (MyList int) :: { MyList..adtRank(x) } + MyList..adtRank(x) >= 0 +MyList..adtRank_1: forall hd : int :: forall tl : (MyList int) :: { MyList..adtRank(Cons(hd, tl)) } + MyList..adtRank(tl) < MyList..adtRank(Cons(hd, tl)) Obligation: !(MyList..isNil(xs@2)) ==> MyList..adtRank(MyList..tl(xs@2)) < MyList..adtRank(xs@2) @@ -674,10 +674,10 @@ Obligation: Label: zipLen_terminates_0 Property: assert Assumptions: -IntList..adtRank_0: forall __q0 : IntList :: { IntList..adtRank(__q0) } - IntList..adtRank(__q0) >= 0 -IntList..adtRank_1: forall __q0 : int :: forall __q1 : IntList :: { IntList..adtRank(Cons(__q0, __q1)) } - IntList..adtRank(__q1) < IntList..adtRank(Cons(__q0, __q1)) +IntList..adtRank_0: forall x : IntList :: { IntList..adtRank(x) } + IntList..adtRank(x) >= 0 +IntList..adtRank_1: forall hd : int :: forall tl : IntList :: { IntList..adtRank(Cons(hd, tl)) } + IntList..adtRank(tl) < IntList..adtRank(Cons(hd, tl)) Obligation: !(IntList..isNil(ys@2)) ==> !(IntList..isNil(xs@2)) ==> IntList..adtRank(IntList..tl(ys@2)) < IntList..adtRank(ys@2) @@ -1151,20 +1151,20 @@ Obligation: Label: listLen_terminates_0 Property: assert Assumptions: -IntList..adtRank_0: forall __q0 : IntList :: { IntList..adtRank(__q0) } - IntList..adtRank(__q0) >= 0 -IntList..adtRank_1: forall __q0 : int :: forall __q1 : IntList :: { IntList..adtRank(Cons(__q0, __q1)) } - IntList..adtRank(__q1) < IntList..adtRank(Cons(__q0, __q1)) +IntList..adtRank_0: forall x : IntList :: { IntList..adtRank(x) } + IntList..adtRank(x) >= 0 +IntList..adtRank_1: forall hd : int :: forall tl : IntList :: { IntList..adtRank(Cons(hd, tl)) } + IntList..adtRank(tl) < IntList..adtRank(Cons(hd, tl)) Obligation: !(IntList..isNil(xs@2)) ==> IntList..adtRank(IntList..tl(xs@2)) < IntList..adtRank(xs@2) Label: natToInt_terminates_0 Property: assert Assumptions: -MyNat..adtRank_0: forall __q0 : MyNat :: { MyNat..adtRank(__q0) } - MyNat..adtRank(__q0) >= 0 -MyNat..adtRank_1: forall __q0 : MyNat :: { MyNat..adtRank(Succ(__q0)) } - MyNat..adtRank(__q0) < MyNat..adtRank(Succ(__q0)) +MyNat..adtRank_0: forall x : MyNat :: { MyNat..adtRank(x) } + MyNat..adtRank(x) >= 0 +MyNat..adtRank_1: forall pred : MyNat :: { MyNat..adtRank(Succ(pred)) } + MyNat..adtRank(pred) < MyNat..adtRank(Succ(pred)) Obligation: !(MyNat..isZero(n@2)) ==> MyNat..adtRank(MyNat..pred(n@2)) < MyNat..adtRank(n@2) diff --git a/StrataTest/Languages/Core/Tests/TestASTtoCST.lean b/StrataTest/Languages/Core/Tests/TestASTtoCST.lean index 57b1251bec..981a7fc688 100644 --- a/StrataTest/Languages/Core/Tests/TestASTtoCST.lean +++ b/StrataTest/Languages/Core/Tests/TestASTtoCST.lean @@ -119,17 +119,17 @@ info: program Core; function fooConst () : int; axiom [fooConst_value]: fooConst == 5; function f1 (x : int) : int; -axiom [f1_ax1]: forall __q0 : int :: { f1(__q0) } - f1(__q0) > __q0; -axiom [f1_ax2_no_trigger]: forall __q0 : int :: f1(__q0) > __q0; +axiom [f1_ax1]: forall x : int :: { f1(x) } + f1(x) > x; +axiom [f1_ax2_no_trigger]: forall x : int :: f1(x) > x; function f2 (x : int, y : bool) : bool; -axiom [f2_ax]: forall __q0 : int :: forall __q1 : bool :: { f2(__q0, true), f2(__q0, false) } - f2(__q0, true) == true; +axiom [f2_ax]: forall x : int :: forall y : bool :: { f2(x, true), f2(x, false) } + f2(x, true) == true; function f3 (x : int, y : bool, z : regex) : bool; -axiom [f3_ax]: forall __q0 : int :: forall __q1 : bool :: forall __q2 : regex :: { f3(__q0, __q1, __q2), f2(__q0, __q1) } - f3(__q0, __q1, __q2) == f2(__q0, __q1); +axiom [f3_ax]: forall x : int :: forall y : bool :: forall z : regex :: { f3(x, y, z), f2(x, y) } + f3(x, y, z) == f2(x, y); function f4 (x : T1) : Map T1 T2; -axiom [foo_ax]: forall __q0 : int :: (f4(__q0))[1] == true; +axiom [foo_ax]: forall x : int :: (f4(x))[1] == true; function f5 (x : T1, y : T2) : T1 { x } @@ -425,8 +425,8 @@ info: program Core; procedure find_max (nums : Map bv64 bv32, nums_len : bv64, out ret : bv32) spec { requires [find_max_requires_0]: nums_len > bv{64}(0); - ensures [find_max_ensures_1]: forall __q0 : bv64 :: bv{64}(0) <= __q0 && __q0 < nums_len ==> ret >=s nums[__q0]; - ensures [find_max_ensures_2]: exists __q0 : bv64 :: bv{64}(0) <= __q0 && __q0 < nums_len && ret == nums[__q0]; + ensures [find_max_ensures_1]: forall x0 : bv64 :: bv{64}(0) <= x0 && x0 < nums_len ==> ret >=s nums[x0]; + ensures [find_max_ensures_2]: exists x0 : bv64 :: bv{64}(0) <= x0 && x0 < nums_len && ret == nums[x0]; } { var max : bv32; var i : bv64; @@ -436,8 +436,8 @@ spec { invariant nums_len > bv{64}(0) invariant bv{64}(0) <= i invariant i <= nums_len - invariant forall __q0 : bv64 :: bv{64}(0) <= __q0 && __q0 < i ==> max >=s nums[__q0] - invariant exists __q0 : bv64 :: bv{64}(0) <= __q0 && __q0 < i && max == nums[__q0] + invariant forall x0 : bv64 :: bv{64}(0) <= x0 && x0 < i ==> max >=s nums[x0] + invariant exists x0 : bv64 :: bv{64}(0) <= x0 && x0 < i && max == nums[x0] { if (nums[i] >s max) { max := nums[i]; diff --git a/editors/emacs/core-st-mode.el b/editors/emacs/core-st-mode.el index 6bcfb271d4..f2cffc48e1 100644 --- a/editors/emacs/core-st-mode.el +++ b/editors/emacs/core-st-mode.el @@ -22,12 +22,16 @@ '( "div" "mod" "sdiv" "smod" "safesdiv" "safesmod")) (defvar core-st-builtins - '( "Sequence.length" "Sequence.select" "Sequence.append" - "Sequence.build" "Sequence.update" "Sequence.contains" - "Sequence.take" "Sequence.drop" "str.len" "str.concat" "str.substr" - "str.to.re" "str.in.re" "str.prefixof" "str.suffixof" "re.allchar" - "re.all" "re.range" "re.concat" "re.*" "re.+" "re.loop" "re.union" - "re.inter" "re.comp" "re.none" "Int.DivT" "Int.ModT")) + '( "Sequence.empty" "Sequence.length" "Sequence.select" + "Sequence.append" "Sequence.build" "Sequence.update" + "Sequence.contains" "Sequence.take" "Sequence.drop" "str.len" + "str.concat" "str.substr" "str.to.re" "str.in.re" "str.prefixof" + "str.suffixof" "re.allchar" "re.all" "re.range" "re.concat" "re.*" + "re.+" "re.loop" "re.union" "re.inter" "re.comp" "re.none" + "Int.DivT" "Int.ModT" "Bv.SNegOverflow" "Bv.UNegOverflow" + "Bv.SAddOverflow" "Bv.SSubOverflow" "Bv.SMulOverflow" + "Bv.SDivOverflow" "Bv.UAddOverflow" "Bv.USubOverflow" + "Bv.UMulOverflow")) ;; Font-lock rules (defvar core-st-font-lock-keywords diff --git a/editors/vscode/syntaxes/core-st.tmLanguage.json b/editors/vscode/syntaxes/core-st.tmLanguage.json index 44e4208209..8a1dd9e289 100644 --- a/editors/vscode/syntaxes/core-st.tmLanguage.json +++ b/editors/vscode/syntaxes/core-st.tmLanguage.json @@ -84,7 +84,7 @@ ] }, "function-call": { - "match": "\\b(Sequence\\.length|Sequence\\.select|Sequence\\.append|Sequence\\.build|Sequence\\.update|Sequence\\.contains|Sequence\\.take|Sequence\\.drop|str\\.len|str\\.concat|str\\.substr|str\\.to\\.re|str\\.in\\.re|str\\.prefixof|str\\.suffixof|re\\.allchar|re\\.all|re\\.range|re\\.concat|re\\.\\*|re\\.\\+|re\\.loop|re\\.union|re\\.inter|re\\.comp|re\\.none|Int\\.DivT|Int\\.ModT|bvconcat\\{[0-9]+\\}\\{[0-9]+\\}|bvextract\\{[0-9]+\\}\\{[0-9]+\\}\\{[0-9]+\\})\\b", + "match": "\\b(Sequence\\.empty|Sequence\\.length|Sequence\\.select|Sequence\\.append|Sequence\\.build|Sequence\\.update|Sequence\\.contains|Sequence\\.take|Sequence\\.drop|str\\.len|str\\.concat|str\\.substr|str\\.to\\.re|str\\.in\\.re|str\\.prefixof|str\\.suffixof|re\\.allchar|re\\.all|re\\.range|re\\.concat|re\\.\\*|re\\.\\+|re\\.loop|re\\.union|re\\.inter|re\\.comp|re\\.none|Int\\.DivT|Int\\.ModT|Bv\\.SNegOverflow|Bv\\.UNegOverflow|Bv\\.SAddOverflow|Bv\\.SSubOverflow|Bv\\.SMulOverflow|Bv\\.SDivOverflow|Bv\\.UAddOverflow|Bv\\.USubOverflow|Bv\\.UMulOverflow|bvconcat\\{[0-9]+\\}\\{[0-9]+\\}|bvextract\\{[0-9]+\\}\\{[0-9]+\\}\\{[0-9]+\\})\\b", "captures": { "1": { "name": "support.function.builtin.core-st" } } From 6b3c0653e5ae23c8b69ee89c45d623331adcc9ed Mon Sep 17 00:00:00 2001 From: David Deng Date: Mon, 18 May 2026 14:56:23 -0700 Subject: [PATCH 64/64] 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 -/