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 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/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/Backends/CBMC/CoreToCBMC.lean b/Strata/Backends/CBMC/CoreToCBMC.lean index 04617c385c..e8ceee5a9a 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.mapM (stmtToJson (I:=CoreLParams) · loc)) + let bodyStmts ← func.body.getStructured + let stmtJsons ← (bodyStmts.mapM (stmtToJson (I:=CoreLParams) · loc)) let implValue := Json.mkObj [ ("id", "code"), 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/CoreToCProverGOTO.lean b/Strata/Backends/CBMC/GOTO/CoreToCProverGOTO.lean index bd353e0895..de2a53559a 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 @@ -201,7 +201,11 @@ 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 + -- 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 ← p.body.getStructured.mapError fun s => f!"{s}" + 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 +222,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 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 2cc5e57433..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 @@ -259,7 +259,11 @@ 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 + -- 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 ← 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 .error f!"[procedureToGotoCtx] Polymorphic procedures unsupported." diff --git a/Strata/DL/Imperative/BasicBlock.lean b/Strata/DL/Imperative/BasicBlock.lean index c956006655..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 @@ -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/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/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/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/MetaData.lean b/Strata/DL/Imperative/MetaData.lean index dff78ea614..9630955c9c 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"). -/ @@ -303,6 +328,14 @@ def MetaData.getPropertyType {P : PureExpr} [BEq P.Ident] (md : MetaData P) : Op | _ => none | none => none +/-- Metadata field for a loop invariant expression preserved during structured-to-CFG + lowering. Multiple entries may appear when a loop has multiple invariants. -/ +def MetaData.specLoopInvariant : MetaDataElem.Field P := .label "#spec_loop_invariant" + +/-- Metadata field for a loop decreases (measure) expression preserved during + structured-to-CFG lowering. -/ +def MetaData.specDecreases : MetaDataElem.Field P := .label "#spec_decreases" + /-- Metadata field for property summaries attached to assert/requires/ensures clauses. -/ def MetaData.propertySummary : MetaDataElem.Field P := .label "propertySummary" diff --git a/Strata/DL/Imperative/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/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/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/Strata/Languages/Boole/Verify.lean b/Strata/Languages/Boole/Verify.lean index d219d96c50..7bc2e5f084 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 @@ -540,8 +538,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 => [] @@ -750,6 +746,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`. @@ -810,7 +807,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,8 +879,10 @@ 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_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/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/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..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,9 +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 := - extractCallsFromStatements proc.body + match proc.body with + | .structured ss => extractCallsFromStatements ss + | .cfg c => extractCallsFromDetCFG c @[expose] abbrev ProcedureCG := CallGraph @[expose] abbrev FunctionCG := CallGraph diff --git a/Strata/Languages/Core/Core.lean b/Strata/Languages/Core/Core.lean index e600ad3601..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.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 () @@ -174,7 +179,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/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 639c5f355f..32e6975253 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 @@ -828,12 +882,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⟩ @@ -869,6 +919,49 @@ partial def invariantsToCST {M} [Inhabited M] let restCST ← invariantsToCST rest pure (.consInvariants default labelAnn exprCST restCST) +/-- Convert a `DetTransferCmd` to its CFG-specific CST `Transfer` node. -/ +partial def transferToCST {M} [Inhabited M] + (t : Imperative.DetTransferCmd String Expression) : ToCSTM M (CoreDDM.Transfer M) := do + match t with + | .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] + (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 transfer ← transferToCST blk.transfer + modify ToCSTContext.popScope + pure (.cfg_block default ⟨default, label⟩ ⟨default, cmdStmts⟩ transfer) + +/-- Convert a `DetCFG` to a CST `CFGBody`. -/ +partial def detCFGToCST {M} [Inhabited M] (cfg : Core.DetCFG) + : 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)) : ToCSTM M (Ann (Option (Measure M)) M) := do @@ -938,10 +1031,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 ← blockToCST proc.body - 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/Languages/Core/DDMTransform/Grammar.lean b/Strata/Languages/Core/DDMTransform/Grammar.lean index fe27348ebc..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 -/ @@ -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 ")"; @@ -289,7 +299,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; @@ -355,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. @@ -456,6 +465,59 @@ 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; + +// 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 +// 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 ";"; + +// 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 7461355762..0a7cf0bd37 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 @@ -358,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 @@ -667,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 @@ -848,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 @@ -880,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 @@ -913,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 := @@ -1045,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}" @@ -1228,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 @@ -1258,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 @@ -1335,10 +1426,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 @@ -1583,7 +1671,7 @@ def translateProcedure (p : Program) (bindings : TransBindings) (op : Operation) outputs := ret }, spec := { preconditions := requires, postconditions := ensures }, - body := body + body := .structured body } md, origBindings) @@ -1602,13 +1690,131 @@ def translateBlockCommand (p : Program) (bindings : TransBindings) (op : Operati outputs := [] }, spec := { preconditions := [], postconditions := [] }, - body := body + body := .structured body } md, bindings) --------------------------------------------------------------------- +/-- 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 × 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, bindings) + | 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}" + 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, bindings) + | q`Core.transfer_return => + return (.finish, bindings) + | _ => 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 × TransBindings) := 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, 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) × TransBindings) := do + let .op op := arg + | TransM.error s!"translateCFGBlocks expected op {repr arg}" + match op.name with + | q`Core.cfg_blocks_one => + let (label, blk, bindings) ← translateCFGBlock p bindings op.args[0]! + return ([(label, blk)], bindings) + | q`Core.cfg_blocks_cons => + 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) × TransBindings) := do + let .op op := arg + | TransM.error s!"translateCFGBody expected op {repr arg}" + let entry ← translateIdent String op.args[0]! + 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) : + 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, bindings) ← 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 @@ -2026,6 +2232,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/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/Strata/Languages/Core/ObligationExtraction.lean b/Strata/Languages/Core/ObligationExtraction.lean index 34eb371291..3fcdfcf822 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,6 +98,21 @@ def extractFromStatements extractGo pathConditions ss #[] end +/-- Extract proof obligations from a deterministic CFG by walking all blocks. + 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) => + 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 @@ -103,7 +124,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 + let obs ← match proc.body with + | .structured ss => extractFromStatements globalPc ss + | .cfg c => extractFromDetCFG globalPc c .ok (axiomPc, allObs ++ obs) | _ => .ok (axiomPc, allObs) return allObs @@ -124,8 +147,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 @@ -140,8 +161,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. -/ diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index 154711b3c4..7f8c7255a1 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,78 @@ 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. -/ +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 : DetCFG → Procedure.Body + 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) => + blk.cmds.flatMap Imperative.HasVarsPure.getVars + +/-- 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 + +def Procedure.Body.structuredLength : Procedure.Body → Nat + | .structured ss => ss.length + | .cfg _ => 0 + /-- 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 +364,56 @@ 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.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 := 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 => HasVarsImp.definedVars cfgBody + modifiedVars b := match b with + | .structured ss => HasVarsImp.modifiedVars ss + | .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 }) } + +-- 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 + 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.eraseTypes + { 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.stripMetaData + { p with body := body' } /-- Transitive variable lookup for procedures. This is a version that looks into the body, @@ -351,7 +444,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 +453,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/ProcedureEval.lean b/Strata/Languages/Core/ProcedureEval.lean index 9ea328f41b..d29a40a120 100644 --- a/Strata/Languages/Core/ProcedureEval.lean +++ b/Strata/Languages/Core/ProcedureEval.lean @@ -58,6 +58,93 @@ 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 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']) } + 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 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)] [] {} + (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 + (envs.reverse ++ accEnvs, accStats.merge stats)) emptyAcc + (postResultsRev.reverse, preStats.merge (cfgStats.merge postStats)) + /-- Evaluate a single procedure: generate fresh variables for parameters, execute the body, check postconditions, and collect proof obligations. @@ -113,8 +200,18 @@ 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) - (mergeResults E (ssEs.map (fun sE => fixupError sE)), evalStats) + 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 + (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/Strata/Languages/Core/ProcedureType.lean b/Strata/Languages/Core/ProcedureType.lean index 9b5b9bdbed..27c9a69f1e 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,10 +30,10 @@ 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 := (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\ @@ -50,6 +50,73 @@ 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 () + +-- 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) : + 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 := @@ -111,7 +178,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. - let (annotated_body, finalEnv) ← Statement.typeCheck C envAfterPostconds p (.some proc) proc.body + 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. @@ -126,7 +199,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 := annotated_body } + 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/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/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/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/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 267dad9452..cab6c0459b 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 @@ -585,8 +567,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 @@ -762,6 +744,36 @@ 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) : Env := + go cfg.entry fuel env +where + go (label : String) (fuel : Nat) (env : Env) : Env := + match fuel with + | 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") + | some blk => + let cmdStmts := blk.cmds.map (Imperative.Stmt.cmd ·) + match Imperative.runStmt ops fuel' (.stmts cmdStmts env) with + | .terminal env' => + match blk.transfer with + | .finish _ => env' + | .condGoto cond lt lf _ => + match ops.evalExpr env' cond with + | some (.boolConst _ true) => go lt fuel' env' + | some (.boolConst _ false) => go lf fuel' env' + | _ => CmdEval.updateError env' + (.Misc s!"runCFG: branch condition in block '{label}' did not evaluate to a boolean") + | _ => 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. -/ def Command.runCall (lhs : List Expression.Ident) (procName : String) (args : List Expression.Expr) @@ -772,7 +784,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) @@ -812,10 +824,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 config : Imperative.RunConfig Expression Command Env := - .stmts proc.body callEnv - let configAfter := Imperative.runStmt ops fuel' config - match configAfter with + 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 following control flow from the entry block. + .terminal (runCFG cfgBody fuel' callEnv ops) + match callEnvAfter with | .terminal callEnv' => match callEnv'.error with | some _ => { E with error := callEnv'.error } @@ -842,5 +859,3 @@ end Statement end Core end -- public section - ---------------------------------------------------------------------- diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index 513a72a11f..e0ee78c235 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,46 @@ inductive CoreStepStar ---- CoreStepStar π φ c₁ c₃ +/-- 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) : + DetCFG → CFGConfig String Expression → + CFGConfig String Expression → Prop where + | refl : CoreCFGStepStar π φ cfg c c + | step : + List.lookup t cfg.blocks = .some b → + Imperative.EvalDetBlock Expression (EvalCommand π φ) (EvalPureFunc φ) σ b config → + CoreCFGStepStar π φ cfg (updateFailure config failed) c₃ → + ---- + CoreCFGStepStar π φ cfg (.cont t σ failed) c₃ + +/-- Execution of a procedure body: either structured (via `CoreStepStar`) + or unstructured CFG (via `CoreCFGStepStar`). + + 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 → CoreEval → Bool → Prop where + | structured : + CoreStepStar π φ + (.stmts ss ⟨σ, δ, false⟩) + (.terminal ρ') → + CoreBodyExec π φ (.structured ss) σ δ ρ'.store ρ'.eval ρ'.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 +336,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 δ_final failed md} : π n = .some p → -- inArg exprs + fvar refs for inoutArg ids CallArg.getInputExprs callArgs = inArgs → @@ -317,13 +358,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 ⟨σAO, δ, false⟩) - (.terminal ρ') → + CoreBodyExec π φ p.body σAO δ σ_final δ_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 σ_final post = .some HasBool.tt) → + ReadValues σ_final (ListMap.keys (p.header.outputs)) modvals → -- positional: modvals[i] written back to lhs[i] UpdateStates σ lhs modvals σ' → ---- @@ -375,7 +414,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 +429,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/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/Strata/Languages/Core/WF.lean b/Strata/Languages/Core/WF.lean index 85fc2f110f..16783a4efe 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 @@ -137,16 +137,22 @@ structure WFAxiomDeclarationProp (p : Program) (f : Axiom) : Prop where structure WFDistinctDeclarationProp (p : Program) (l : Expression.Ident) (es : List (Expression.Expr)) : Prop where +-- 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 structure WFProcedureProp (p : Program) (d : Procedure) : Prop where - wfstmts : WFStatementsProp p d.body - wfloclnd : (HasVarsImp.definedVars (P:=Expression) d.body).Nodup + 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 + 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/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 1a9c78e081..c4a1c9cf8b 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 @@ -492,11 +494,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 +506,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. @@ -579,7 +581,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/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 cceb2c563e..541f68b7c0 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 ------------------------------------------------------------------------------- @@ -318,7 +316,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 +621,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 +721,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)) @@ -792,7 +790,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 +821,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/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/ANFEncoder.lean b/Strata/Transform/ANFEncoder.lean index 39390bb321..4269eb1840 100644 --- a/Strata/Transform/ANFEncoder.lean +++ b/Strata/Transform/ANFEncoder.lean @@ -217,8 +217,14 @@ 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) + 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 _ => + -- 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 }) 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..7cd9833088 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, @@ -60,6 +101,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. @@ -81,8 +124,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 "" proc.body #[]) 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,16 +186,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 - /-- (2) The postconditions hold on termination. -/ + /-- (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), + ∀ (ρ₀ : Env Expression), ProcEnvWF proc ρ₀ → - CoreStepStar π φ (.stmts proc.body ρ₀) (.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 + ∀ (σ' : 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 → + δ' σ' check.expr = some HasBool.tt) ∧ + failed = Bool.false end Core.Specification diff --git a/Strata/Transform/CoreTransform.lean b/Strata/Transform/CoreTransform.lean index d621676ee0..0cb66a3fde 100644 --- a/Strata/Transform/CoreTransform.lean +++ b/Strata/Transform/CoreTransform.lean @@ -332,10 +332,20 @@ def runProgram currentProcedureName := .some proc.header.name.1 }) - let (changed, new_body) ← runStmtsRec f proc.body + -- 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 _ => 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 - 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/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/LoopElim.lean b/Strata/Transform/LoopElim.lean index efbee4a8cd..887e1e6cf0 100644 --- a/Strata/Transform/LoopElim.lean +++ b/Strata/Transform/LoopElim.lean @@ -241,8 +241,12 @@ 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) + 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 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/PrecondElim.lean b/Strata/Transform/PrecondElim.lean index ee77df3440..8b1b8bb2af 100644 --- a/Strata/Transform/PrecondElim.lean +++ b/Strata/Transform/PrecondElim.lean @@ -88,9 +88,9 @@ 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 @@ -100,7 +100,7 @@ def collectPrecondAsserts (F : @Lambda.Factory CoreLParams) (e : Expression.Expr -- 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 @@ -109,32 +109,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 -/ @@ -175,7 +195,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 @@ -231,7 +251,7 @@ def mkFuncWFProc (F : @Lambda.Factory CoreLParams) (func : Function) noFilter := true } spec := { preconditions := [], postconditions := [] } - body := wfStmts + body := .structured wfStmts } md) /-! ## Statement transformation -/ @@ -341,6 +361,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. @@ -382,7 +442,13 @@ where return (changed, d :: rest') else let F ← getFactory - let (changed, body') ← transformStmts proc.body + 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 := body' } let procDecl := Decl.proc proc' md @@ -391,7 +457,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.structuredLength | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty proc.header.name)) return (true, wfDecl :: procDecl :: rest') @@ -411,7 +477,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.structuredLength | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty func.name)) return (true, wfDecl :: funcDecl :: rest') @@ -436,7 +502,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.structuredLength | _ => 0) addWFProcToCallGraph (wfProcName (CoreIdent.toPretty func.name)) return some wfDecl diff --git a/Strata/Transform/ProcBodyVerify.lean b/Strata/Transform/ProcBodyVerify.lean index aa68c38a96..64503b9f71 100644 --- a/Strata/Transform/ProcBodyVerify.lean +++ b/Strata/Transform/ProcBodyVerify.lean @@ -88,8 +88,13 @@ open Core Imperative Transform -- Convert preconditions to assumes let assumes := requiresToAssumes proc.spec.preconditions + -- 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 ← proc.body.getStructured.mapError Strata.DiagnosticModel.fromMessage -- Wrap body in labeled block - let bodyBlock := Stmt.block bodyLabel proc.body #[] + 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 cf64ee7633..3e8ac3d73f 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 @@ -447,6 +447,17 @@ 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 + 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). @@ -459,16 +470,19 @@ 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}" proc.body #[]] ++ + (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 ρ₀ → ∃ ρ_init, Imperative.StepStmtStar Expression (EvalCommand π φ) (EvalPureFunc φ) (.stmts prefixStmts ρ_init) (.terminal ρ₀)) := by + 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, pure, ExceptT.pure, StateT.bind] at h rw [mapM_stateT_pure_eq] at h @@ -483,7 +497,8 @@ theorem procToVerifyStmt_structure (.det (LExpr.fvar () id none)) #[] let assumes := requiresToAssumes proc.spec.preconditions let prefixStmts := inputInits ++ outputOnlyInits ++ oldInoutInits ++ assumes - 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 @@ -643,9 +658,13 @@ theorem procBodyVerify_procedureCorrect (h_wf_proc : WF.WFProcedureProp p proc) : -- Conclusion: ProcedureCorrect holds. Core.Specification.ProcedureCorrect π φ proc p := by - - obtain ⟨prefixStmts, h_eq, h_prefix_cmd, h_prefix_trace⟩ := + obtain ⟨ss, h_body_eq⟩ := procToVerifyStmt_is_structured h_transform + 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 + 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 @@ -656,18 +675,18 @@ 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 ss ρ₀) cfg → ∃ ρ_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 +696,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) @@ -712,14 +731,14 @@ 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 ss ρ₀) cfg → 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 @@ -727,23 +746,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 "" proc.body #[]) ρ₀) cfg) + (.stmt (Stmt.block "" ss #[]) ρ₀) 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 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 proc.body ρ₀) (.exiting lbl ρ') := - block_exitsCoveredByBlocks_noEscape Expression (EvalCommand π φ) (EvalPureFunc φ) - proc.body h_wf_proc.bodyExitsCovered ρ₀ + (.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 @@ -761,29 +782,50 @@ theorem procBodyVerify_procedureCorrect simpa [Config.getEval, Config.getStore] using h_valid · ----- Part 2: Postconditions + hasFailure on termination ----- - intro h_wf_proc ρ₀ ρ' h_wf h_term + -- 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), - CoreStepStar π φ (.stmts proc.body ρ₀) 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' -- hasFailure = false have h_nf' : ρ'.hasFailure = Bool.false := Core.core_noFailure_preserved π φ - (.stmts proc.body ρ₀) (.terminal ρ') h_valid h_wf.noFailure h_term + (.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 proc.body ρ₀) (.terminal ρ') h_wf.wfBool h_term + (.stmts ss ρ₀) (.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 +836,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 ss ρ₀) (.terminal ρ') h_wf.wfVar h_term + have h_wfCong_term : Core.WellFormedCoreEvalCong ρ'.eval := + Core.core_wfCong_preserved π φ h_wf_ext + (.stmts ss ρ₀) (.terminal ρ') h_wf.wfCong h_term + have h_wfExprCongr_term : WellFormedSemanticEvalExprCongr ρ'.eval := + Core.core_wfExprCongr_preserved π φ h_wf_ext + (.stmts ss ρ₀) (.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 +881,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..728727d661 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 => @@ -93,14 +93,17 @@ 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 - let lhs_vars := List.flatMap (fun (s:Statement) => s.definedVars) c.body + -- 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 : 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 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) bodyStmts -- Reuse genOldToFreshIdMappings by introducing dummy data to Identifier let label_ids:List Expression.Ident := labels.map (fun s => { name:=s, metadata := () }) @@ -112,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) c.body + 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 @@ -269,9 +277,17 @@ def inlineCallCmd Statement.set lhs_var (.fvar () out_var (.none)) md) outs_lhs_and_sig + -- 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 _ => 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) := inputInits ++ outputInits - ++ Block.setCallSiteMetadata proc.body md + ++ Block.setCallSiteMetadata procBodyStmts md ++ outputSetStmts -- Update CallGraph if available 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..8782fff782 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] @@ -65,7 +68,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 +80,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 @@ -92,12 +95,12 @@ 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 + (.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 @@ -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,43 +134,41 @@ 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)) + -- Attach loop contract (invariants + measure) to the transfer metadata so + -- downstream CFG passes can recover the original spec without relying on the + -- lowered assert commands alone. + let contractMd := is.foldl (fun md (_, inv) => + md.pushElem MetaData.specLoopInvariant (.expr inv)) md + let contractMd := match m with + | some mExpr => contractMd.pushElem MetaData.specDecreases (.expr mExpr) + | none => contractMd -- For nondet guards, introduce a fresh boolean variable match c with | .det e => - let b := (lentry, { cmds := invCmds ++ measureCmds, transfer := .condGoto e bl kNext }) + let b := (lentry, { cmds := invCmds ++ measureCmds, transfer := .condGoto e bl kNext contractMd }) let (accumEntry, accumBlocks) ← flushCmds "before_loop$" accum .none lentry pure (accumEntry, accumBlocks ++ [b] ++ bbs ++ decreaseBlocks ++ bsNext) | .nondet => do 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 }) + transfer := .condGoto (HasFvar.mkFvar ident) bl kNext contractMd }) let (accumEntry, accumBlocks) ← flushCmds "before_loop$" accum .none lentry pure (accumEntry, accumBlocks ++ [b] ++ bbs ++ decreaseBlocks ++ bsNext) -| .exit l? _md :: _ => do - -- Find the continuation of the block labeled `l`, 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$" - flushCmds exitName accum .none bk + let exitName := s!"block${l}$" + flushCmds exitName accum (.some (.goto bk md)) bk def stmtsToCFGM [HasBool P] [HasPassiveCmds P CmdT] [HasInit P CmdT] diff --git a/Strata/Transform/TerminationCheck.lean b/Strata/Transform/TerminationCheck.lean index ddc8065a7c..30b53d0121 100644 --- a/Strata/Transform/TerminationCheck.lean +++ b/Strata/Transform/TerminationCheck.lean @@ -216,7 +216,7 @@ private def mkTermCheckProc (func.preconditions.mapIdx fun i p => (s!"{func.name.name}_requires_{i}", { expr := p.expr, attr := .Free })), postconditions := [] } - body := stmts + body := .structured stmts } md, obligations.length) /-- Add a termination-check procedure as a leaf node in the cached call graph. -/ 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/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 diff --git a/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean b/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean index a33056b01b..cca938708b 100644 --- a/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean +++ b/StrataTest/Backends/CBMC/GOTO/E2E_CoreToGOTO.lean @@ -344,13 +344,18 @@ 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 := injectPropertySummary p.body summary } + 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' let json ← (CoreToGOTO.CProverGOTO.Context.toJson pname ctx.1).mapError (fun e => f!"{e}") 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/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)) diff --git a/StrataTest/Languages/Boole/global_readonly_call.lean b/StrataTest/Languages/Boole/global_readonly_call.lean index a0445f8753..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.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_2418 +Label: inc_ensures_1_2576 Property: assert Assumptions: -inc_requires_0_2400: z@1 > 0 +inc_requires_0_2558: z@1 > 0 Obligation: true -Label: callElimAssert_inc_requires_0_2400_6 +Label: callElimAssert_inc_requires_0_2558_6 Property: assert Assumptions: -main_caller_requires_2_2534: z@3 == 10 -main_caller_requires_3_2554: 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_2573 +Label: main_caller_ensures_4_2731 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_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_2418 +Obligation: inc_ensures_1_2576 Property: assert Result: ✅ pass -Obligation: callElimAssert_inc_requires_0_2400_6 +Obligation: callElimAssert_inc_requires_0_2558_6 Property: assert Result: ✅ pass -Obligation: main_caller_ensures_4_2573 +Obligation: main_caller_ensures_4_2731 Property: assert Result: ❓ unknown Model: 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/Exit.lean b/StrataTest/Languages/Core/Examples/Exit.lean index 53dedb039d..f33cccc1aa 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 + #[<[provenance]: :387-502>] condGoto true block$l1$_2 block$l1$_2 block$l1$_2: assert [a1]: x == x; - condGoto true l$_1 l$_1 + #[<[provenance]: :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 + #[<[provenance]: :577-1056>] condGoto true l4 l4 l4: - condGoto true l4_before l4_before + #[<[provenance]: :589-1050>] condGoto true l4_before l4_before l4_before: - condGoto true l3_before l3_before + #[<[provenance]: :603-996>] condGoto true l3_before l3_before l3_before: - condGoto true l1 l1 + #[<[provenance]: :626-933>] condGoto true l1 l1 l1: - condGoto true ite$_5 ite$_5 + #[<[provenance]: :651-835>] condGoto true ite$_5 ite$_5 ite$_5: assert [a4]: x == x; - condGoto x > 0 block$l5$_2 block$l5$_1 + #[<[provenance]: :706-821>] condGoto x > 0 block$l5$_2 block$l5$_1 l2: - condGoto true l$_3 l$_3 + #[<[provenance]: :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 + #[<[provenance]: :978-986>] condGoto true end$_0 end$_0 block$l5$_1: assert [a7]: x <= 0; - condGoto true end$_0 end$_0 + #[<[provenance]: :1034-1042>] condGoto true end$_0 end$_0 end$_0: finish -/ 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..7881a6d710 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 proc.body + match proc.body with + | .structured ss => Imperative.stmtsToCFG ss + | .cfg cfg => cfg --------------------------------------------------------------------- @@ -52,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); - condGoto i < n l$_4 end$_0 + #[<[provenance]: :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 @@ -140,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); - condGoto i < n l$_4 end$_0 + #[<[provenance]: :2590-2746>, + <[#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; @@ -384,10 +393,15 @@ 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); - condGoto x < n before_loop$_11 end$_0 + #[<[provenance]: :8360-8613>, + <[#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 @@ -397,7 +411,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); - condGoto y < x l$_8 l$_4 + #[<[provenance]: :8480-8593>, + <[#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/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/CFGParseTests.lean b/StrataTest/Languages/Core/Tests/CFGParseTests.lean new file mode 100644 index 0000000000..263040833f --- /dev/null +++ b/StrataTest/Languages/Core/Tests/CFGParseTests.lean @@ -0,0 +1,404 @@ +/- + 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) + +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, 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 + 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; + } +}; +" + printCFGProcInfo prog + +/-! ## 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; + } +}; +" + printCFGProcInfo prog + +/-! ## 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; + } +}; +" + printCFGProcInfo prog + +/-! ## 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; + } +}; +" + printCFGProcInfo prog + +/-! ## End-to-end: type-checking accepts well-formed CFG procedures -/ + +/-- +info: type-check accepted CFG procedure +-/ +#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!"ERROR: type-check rejected CFG procedure: {dm.message}" + | .ok _ => IO.println "type-check accepted CFG procedure" + +/-! ## End-to-end: type-checking accepts Max (branches + assignments) -/ + +/-- +info: type-check accepted Max with CFG body preserved (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; + } +}; +" + 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" + +/-! ## 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 () 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/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 +-/ 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 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..3728d1c3f9 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: @@ -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/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/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 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) 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/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/StrataTest/Transform/ProcedureInlining.lean b/StrataTest/Transform/ProcedureInlining.lean index 2697471f1f..abaa58e3e4 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 @@ -214,19 +211,56 @@ 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 - .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}") +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 := (p1.body.zip p2.body) - 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" 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 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. diff --git a/editors/emacs/core-st-mode.el b/editors/emacs/core-st-mode.el index 6bcfb271d4..7501a1dc53 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" @@ -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..5084e50e1d 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", @@ -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" } } 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"