tala-core (empty) → 0.1.0
raw patch · 43 files changed
+12656/−0 lines, 43 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, criterion, deepseq, filepath, mtl, tala-core, tala-syntax
Files
- Benches/Main.hs +602/−0
- LICENSE +373/−0
- LICENSE-EXCEPTION +81/−0
- src/Progmasoft/Tala/Core.hs +241/−0
- src/Progmasoft/Tala/Core/Artifact.hs +73/−0
- src/Progmasoft/Tala/Core/CorePrep.hs +629/−0
- src/Progmasoft/Tala/Core/CorePrep/Verifier.hs +311/−0
- src/Progmasoft/Tala/Core/CorePrep/Wire.hs +23/−0
- src/Progmasoft/Tala/Core/CorePrep/Wire/Decode.hs +421/−0
- src/Progmasoft/Tala/Core/CorePrep/Wire/Encode.hs +392/−0
- src/Progmasoft/Tala/Core/CorePrep/Wire/Format.hs +116/−0
- src/Progmasoft/Tala/Core/Monomorphization.hs +252/−0
- src/Progmasoft/Tala/Core/Monomorphization/Discovery.hs +177/−0
- src/Progmasoft/Tala/Core/Monomorphization/Graph.hs +220/−0
- src/Progmasoft/Tala/Core/Monomorphization/Types.hs +226/−0
- src/Progmasoft/Tala/Core/Optimizer.hs +54/−0
- src/Progmasoft/Tala/Core/Optimizer/Analysis.hs +241/−0
- src/Progmasoft/Tala/Core/Optimizer/Constant.hs +395/−0
- src/Progmasoft/Tala/Core/Optimizer/ControlFlow.hs +112/−0
- src/Progmasoft/Tala/Core/Optimizer/EffectInference.hs +271/−0
- src/Progmasoft/Tala/Core/Optimizer/Floating.hs +447/−0
- src/Progmasoft/Tala/Core/Optimizer/Inline.hs +454/−0
- src/Progmasoft/Tala/Core/Optimizer/IntegerFacts.hs +968/−0
- src/Progmasoft/Tala/Core/Optimizer/Liveness.hs +220/−0
- src/Progmasoft/Tala/Core/Optimizer/Pipeline.hs +99/−0
- src/Progmasoft/Tala/Core/Optimizer/Types.hs +154/−0
- src/Progmasoft/Tala/Core/Scalar.hs +116/−0
- src/Progmasoft/Tala/Core/Specialization.hs +175/−0
- src/Progmasoft/Tala/Core/Symbols.hs +92/−0
- src/Progmasoft/Tala/Core/Template.hs +284/−0
- src/Progmasoft/Tala/Core/Verifier.hs +454/−0
- src/Progmasoft/Tala/Core/Wire.hs +912/−0
- src/Progmasoft/Tala/Desugarer.hs +1283/−0
- src/Progmasoft/Tala/Desugarer/Boundary.hs +218/−0
- src/Progmasoft/Tala/Desugarer/Branching.hs +293/−0
- src/Progmasoft/Tala/Desugarer/Captures.hs +87/−0
- src/Progmasoft/Tala/Desugarer/Effects.hs +121/−0
- src/Progmasoft/Tala/Desugarer/Handing.hs +308/−0
- src/Progmasoft/Tala/Desugarer/Laziness.hs +262/−0
- src/Progmasoft/Tala/Desugarer/Sequencing.hs +172/−0
- src/Progmasoft/Tala/Desugarer/Symbols.hs +129/−0
- src/Progmasoft/Tala/Desugarer/Workers.hs +101/−0
- tala-core.cabal +97/−0
+ Benches/Main.hs view
@@ -0,0 +1,602 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +module Main (main) where + +import Control.DeepSeq (NFData (rnf)) +import Criterion.Main +import Data.Word (Word8) +import System.IO (hSetEncoding, stdout, utf8) +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.CorePrep +import Progmasoft.Tala.Core.CorePrep.Verifier +import Progmasoft.Tala.Core.CorePrep.Wire +import Progmasoft.Tala.Core.Optimizer +import Progmasoft.Tala.Core.Verifier +import Progmasoft.Tala.Core.Wire + +-- Production IR intentionally does not carry evaluation-strategy instances. +-- Fixture owners force the complete derived representation before Criterion +-- starts sampling without adding benchmark-only instances to compiler types. +newtype CoreModules = CoreModules [(Int, CoreModule)] + +newtype CorePrepModules = CorePrepModules [(Int, CorePrepModule)] + +instance NFData CoreModules where + rnf (CoreModules values) = rnf (show values) + +instance NFData CorePrepModules where + rnf (CorePrepModules values) = rnf (show values) + +main :: IO () +main = do + -- Criterion uses the microsecond symbol in its progress output. Windows can + -- otherwise inherit a legacy console encoding and abort after a successful + -- sample, so the harness owns its output encoding explicitly. + hSetEncoding stdout utf8 + defaultMain + [ bgroup + "Core" + [ env (pure (CoreModules (fixtures sizes))) $ \modules -> + bgroup "Verify" [benchAt size verifyDigest (coreModuleAt size modules) | size <- sizes] + , env (pure (CoreModules (fixtures sizes))) $ \modules -> + bgroup "Encode" [benchAt size encodeDigest (coreModuleAt size modules) | size <- sizes] + , env (traverse encodedFixture sizes) $ \documents -> + bgroup "Decode" [benchAt size decodeDigest (documentAt size documents) | size <- sizes] + , env (pure (CoreModules (inlineFixtures inlineSizes))) $ \modules -> + bgroup "InlineLinearBody" [benchAt size optimizeDigest (coreModuleAt size modules) | size <- inlineSizes] + , env (pure (CoreModules (floatingFixtures floatingSizes))) $ \modules -> + bgroup "ConstantFoldFloating" [benchAt size floatingOptimizeDigest (coreModuleAt size modules) | size <- floatingSizes] + , env (pure (CoreModules (integerFixtures integerSizes))) $ \modules -> + bgroup "ConstantFoldInteger" [benchAt size integerOptimizeDigest (coreModuleAt size modules) | size <- integerSizes] + , env (pure (CoreModules (guardedDivisionFixtures flowSizes))) $ \modules -> + bgroup "GuardedIntegerEffects" [benchAt size integerOptimizeDigest (coreModuleAt size modules) | size <- flowSizes] + , env (pure (CoreModules (contradictoryPathFixtures flowSizes))) $ \modules -> + bgroup "ContradictoryIntegerPaths" [benchAt size integerOptimizeDigest (coreModuleAt size modules) | size <- flowSizes] + , env (pure (CoreModules (loopFixtures flowSizes))) $ \modules -> + bgroup "LoopIntegerFacts" [benchAt size integerOptimizeDigest (coreModuleAt size modules) | size <- flowSizes] + , env (verifiedFixtures makeNestedLoopModule loopDepths) $ \modules -> + bgroup "NestedLoopIntegerFacts" [benchAt size integerOptimizeDigest (coreModuleAt size modules) | size <- loopDepths] + , env (verifiedFixtures makeChainModule chainSizes) $ \modules -> + bgroup "EncodeChain" [benchAt size encodeDigest (coreModuleAt size modules) | size <- chainSizes] + ] + , bgroup + "CorePrep" + [ env (pure (CoreModules (preparedFixtures sizes))) $ \modules -> + bgroup "Prepare" [benchAt size prepareDigest (coreModuleAt size modules) | size <- sizes] + , env (pure (CoreModules (loopFixtures sizes))) $ \modules -> + bgroup "PrepareLoops" [benchAt size prepareDigest (coreModuleAt size modules) | size <- sizes] + , env (CorePrepModules <$> traverse preparedFixture sizes) $ \modules -> + bgroup "Verify" [benchAt size verifyPrepDigest (corePrepModuleAt size modules) | size <- sizes] + , env (CorePrepModules <$> traverse preparedFixture sizes) $ \modules -> + bgroup "Encode" [benchAt size encodePrepDigest (corePrepModuleAt size modules) | size <- sizes] + , env (traverse preparedDocument sizes) $ \documents -> + bgroup "Decode" [benchAt size decodePrepDigest (documentAt size documents) | size <- sizes] + , env (verifiedFixtures makeChainModule chainSizes) $ \modules -> + bgroup "PrepareChain" [benchAt size prepareDigest (coreModuleAt size modules) | size <- chainSizes] + , env (verifiedFixtures makeSequenceModule chainSizes) $ \modules -> + bgroup "PrepareSequence" [benchAt size prepareDigest (coreModuleAt size modules) | size <- chainSizes] + , env (CorePrepModules <$> traverse (preparedFrom makeChainModule) chainSizes) $ \modules -> + bgroup "VerifyChain" [benchAt size verifyPrepDigest (corePrepModuleAt size modules) | size <- chainSizes] + , env (CorePrepModules <$> traverse (preparedFrom makeSequenceModule) chainSizes) $ \modules -> + bgroup "VerifySequence" [benchAt size verifyPrepDigest (corePrepModuleAt size modules) | size <- chainSizes] + ] + ] + where + sizes = [8, 32, 128, 512] + inlineSizes = [8, 32, 128, 256] + floatingSizes = [8, 32, 128, 512] + integerSizes = [8, 32, 128, 512, 1024, 2048] + flowSizes = [8, 32, 128, 512, 1024] + -- Levels of loops nested in each other. The loop analysis once + -- repeated the analysis of an inner loop for every pass over the + -- loop around it, so each level multiplied the time. + loopDepths = [2, 4, 8, 12, 16] + -- Links of an `else if` chain and statements of a sequence of `if` + -- statements. Each doubling should double the time. + chainSizes = [256, 512, 1024, 2048] + +benchAt :: Int -> (a -> Int) -> a -> Benchmark +benchAt size measure input = bench (show size) (whnf measure input) + +-- The size key selects a stable value owned by one Criterion environment. This +-- keeps fixture construction out of the timed expression without relying on +-- global CAF evaluation order. +moduleAt :: Int -> [(Int, a)] -> a +moduleAt requested values = case lookup requested values of + Just value -> value + Nothing -> error "benchmark fixture size was not prepared" + +coreModuleAt :: Int -> CoreModules -> CoreModule +coreModuleAt requested (CoreModules values) = moduleAt requested values + +corePrepModuleAt :: Int -> CorePrepModules -> CorePrepModule +corePrepModuleAt requested (CorePrepModules values) = moduleAt requested values + +documentAt :: Int -> [(Int, [a])] -> [a] +documentAt = moduleAt + +fixtures :: [Int] -> [(Int, CoreModule)] +fixtures = map (\size -> (size, makeCoreModule size)) + +preparedFixtures :: [Int] -> [(Int, CoreModule)] +preparedFixtures = fixtures + +{- | This fixture isolates Core-to-CorePrep cost for structured loops, including +nested conditionals and explicit transfers in the loop body. +-} +loopFixtures :: [Int] -> [(Int, CoreModule)] +loopFixtures = map (\size -> (size, makeLoopModule size)) + +makeLoopModule :: Int -> CoreModule +makeLoopModule count = + CoreModule (QualifiedName [Identifier "LoopBenchmark"]) (map makeLoopFunction [0 .. count - 1]) + where + makeLoopFunction index = + let base = index * 4 + 1 + functionName = name base "LoopFunction" + valueName = name (base + 1) "value" + value = CoreVariable valueName intType + lessThan bound = CorePrimitive CoreLessThan [value, integer bound] boolType + increment = CorePrimitive CoreAdd [value, integer 1] intType + skippedValue = CorePrimitive CoreEqual [value, integer 2] boolType + stoppedValue = CorePrimitive CoreEqual [value, integer 7] boolType + body = + [ CoreBind (CoreBinding valueName intType True (integer 0)) + , CoreWhile + (lessThan 5) + [ CoreAssign valueName increment + , CoreIf skippedValue [CoreContinue] [] + ] + , CoreDoWhile + [ CoreAssign valueName increment + , CoreIf stoppedValue [CoreBreak] [] + ] + (lessThan 9) + , CoreFor + (lessThan 12) + [ CoreAssign valueName increment + , CoreIf skippedValue [CoreContinue] [] + ] + [CoreAssign valueName increment] + , CoreReturn value + ] + in CoreFunction functionName [] intType body + +{- | Fixtures that must verify: a benchmark of a rejected module would time +the rejection. +-} +verifiedFixtures :: (Int -> CoreModule) -> [Int] -> IO CoreModules +verifiedFixtures make requested = CoreModules <$> traverse verified requested + where + verified size = case verifyCore (make size) of + Left diagnostics -> fail (show diagnostics) + Right value -> pure (size, value) + +preparedFrom :: (Int -> CoreModule) -> Int -> IO (Int, CorePrepModule) +preparedFrom make size = case prepareCore (make size) of + Left diagnostics -> fail (show diagnostics) + Right value -> case verifyCorePrep value of + Left diagnostics -> fail (show diagnostics) + Right verified -> pure (size, verified) + +{- | Loops nested to the given depth, each counting to a parameter, around +one statement: the workload of the loop fixed point of the integer analysis. +-} +makeNestedLoopModule :: Int -> CoreModule +makeNestedLoopModule depth = + CoreModule + (QualifiedName [Identifier "NestedLoopBenchmark"]) + [ CoreFunction + (name 1 "Count") + [(limitName, intType)] + intType + (CoreBind (CoreBinding totalName intType True (integer 0)) : loopAt 0 ++ [CoreReturn total]) + ] + where + limitName = name 2 "limit" + totalName = name 3 "total" + total = CoreVariable totalName intType + counterName level = name (4 + level) "counter" + counter level = CoreVariable (counterName level) intType + increment value = CorePrimitive CoreAdd [value, integer 1] intType + loopAt level + | level == depth = [CoreAssign totalName (increment total)] + | otherwise = + [ CoreBind (CoreBinding (counterName level) intType True (integer 0)) + , CoreWhile + (CorePrimitive CoreLessThan [counter level, CoreVariable limitName intType] boolType) + (CoreAssign (counterName level) (increment (counter level)) : loopAt (level + 1)) + ] + +{- | An `else if` chain: every false branch holds the next link, so the +statements nest as deep as the chain is long. +-} +makeChainModule :: Int -> CoreModule +makeChainModule links = + CoreModule + (QualifiedName [Identifier "ChainBenchmark"]) + [CoreFunction (name 1 "Pick") [(valueName, intType)] intType (chainFrom 0)] + where + valueName = name 2 "value" + chainFrom index + | index == links = [CoreReturn (integer 0)] + | otherwise = + [ CoreIf + (CorePrimitive CoreEqual [CoreVariable valueName intType, integer (toInteger index)] boolType) + [CoreReturn (integer (toInteger index * 3 + 1))] + (chainFrom (index + 1)) + ] + +-- | The same tests as a sequence of `if` statements, which do not nest. +makeSequenceModule :: Int -> CoreModule +makeSequenceModule count = + CoreModule + (QualifiedName [Identifier "SequenceBenchmark"]) + [ CoreFunction + (name 1 "Sum") + [(valueName, intType)] + intType + (CoreBind (CoreBinding totalName intType True (integer 0)) : map test [0 .. count - 1] ++ [CoreReturn total]) + ] + where + valueName = name 2 "value" + totalName = name 3 "total" + total = CoreVariable totalName intType + test index = + CoreIf + (CorePrimitive CoreEqual [CoreVariable valueName intType, integer (toInteger index)] boolType) + [CoreAssign totalName (CorePrimitive CoreAdd [total, integer (toInteger index)] intType)] + [] + +inlineFixtures :: [Int] -> [(Int, CoreModule)] +inlineFixtures = map (\size -> (size, makeInlineModule size)) + +-- The timed optimizer receives a verified nested expression containing only +-- binary64 literals. Fixture construction is kept in Criterion's environment; +-- the varying size measures rational parsing, target rounding, shortest +-- round-trip rendering, and fixed-point stability as one real Core workload. +floatingFixtures :: [Int] -> [(Int, CoreModule)] +floatingFixtures = map (\size -> (size, makeFloatingModule size)) + +-- This workload keeps construction outside Criterion's sample and drives the +-- real fixed-point optimizer through integer power, shifts, bitwise operations, +-- and addition at a 128-bit destination width. +integerFixtures :: [Int] -> [(Int, CoreModule)] +integerFixtures = map (\size -> (size, makeIntegerModule size)) + +-- These fixtures target the forward abstract interpreter rather than constant +-- folding: every divide uses a variable, and safety is available only on a +-- condition edge. Keeping construction in Criterion's environment makes the +-- timed region reflect the production optimizer's proof and effect passes. +guardedDivisionFixtures :: [Int] -> [(Int, CoreModule)] +guardedDivisionFixtures = map (\size -> (size, makeGuardedDivisionModule size)) + +contradictoryPathFixtures :: [Int] -> [(Int, CoreModule)] +contradictoryPathFixtures = map (\size -> (size, makeContradictoryPathModule size)) + +makeGuardedDivisionModule :: Int -> CoreModule +makeGuardedDivisionModule size = + CoreModule + (QualifiedName [Identifier "Core", Identifier "GuardedIntegerFlowBenchmarks"]) + [ CoreFunction + functionName + [(divisorName, integerType)] + integerType + [ CoreIf + (CorePrimitive CoreNotEqual [divisor, typedInteger 0] boolType) + (replicate size (CoreEvaluate division)) + [CoreReturn (typedInteger 0)] + , CoreReturn (typedInteger 1) + ] + ] + where + functionName = resolvedName 1 "Evaluate" + divisorName = resolvedName 2 "divisor" + divisor = CoreVariable divisorName integerType + integerType = namedType "int" + typedInteger value = CoreLiteral (CoreInteger value) integerType + division = CorePrimitive CoreDivide [typedInteger 42, divisor] integerType + +makeContradictoryPathModule :: Int -> CoreModule +makeContradictoryPathModule size = + CoreModule + (QualifiedName [Identifier "Core", Identifier "ContradictoryIntegerFlowBenchmarks"]) + [ CoreFunction + functionName + [(valueName, integerType)] + integerType + [ CoreIf condition (replicate size (CoreEvaluate impossibleDivision)) [CoreReturn (typedInteger 0)] + , CoreReturn (typedInteger 1) + ] + ] + where + functionName = resolvedName 1 "Evaluate" + valueName = resolvedName 2 "value" + integerType = namedType "int" + value = CoreVariable valueName integerType + typedInteger number = CoreLiteral (CoreInteger number) integerType + condition = + CorePrimitive + CoreLogicalAnd + [ CorePrimitive CoreGreaterThan [value, typedInteger 11] boolType + , CorePrimitive CoreLessThan [value, typedInteger 12] boolType + ] + boolType + impossibleDivision = CorePrimitive CoreDivide [typedInteger 42, value] integerType + +resolvedName :: Int -> String -> ResolvedName +resolvedName symbol spelling = ResolvedName (SymbolId symbol) (Identifier spelling) + +makeIntegerModule :: Int -> CoreModule +makeIntegerModule size = + CoreModule + (QualifiedName [Identifier "Core", Identifier "IntegerBenchmarks"]) + [ CoreFunction + (ResolvedName (SymbolId 1) (Identifier "Evaluate")) + [] + integerType + [CoreReturn expression] + ] + where + integerType = namedType "ulongint" + expression = foldl appendIntegerOperations (typedInteger 0) [0 .. size - 1] + appendIntegerOperations accumulated index = + let base = toInteger (2 + index `mod` 3) + power = CorePrimitive CorePower [typedInteger base, typedInteger 7] integerType + shifted = CorePrimitive CoreShiftLeft [power, typedInteger (toInteger (index `mod` 8))] integerType + mixed = CorePrimitive CoreBitwiseXor [accumulated, shifted] integerType + in CorePrimitive CoreAdd [mixed, typedInteger 1] integerType + typedInteger value = CoreLiteral (CoreInteger value) integerType + +makeFloatingModule :: Int -> CoreModule +makeFloatingModule size = + CoreModule + (QualifiedName [Identifier "Core", Identifier "FloatingBenchmarks"]) + [ CoreFunction + (ResolvedName (SymbolId 1) (Identifier "Evaluate")) + [] + (namedType "float") + [CoreReturn (foldl addLiteral (CoreLiteral (CoreFloating "0.1") (namedType "float")) [1 .. size])] + ] + where + addLiteral accumulated _ = + CorePrimitive + CoreAdd + [accumulated, CoreLiteral (CoreFloating "0.1") (namedType "float")] + (namedType "float") + +encodedFixture :: Int -> IO (Int, [Word8]) +encodedFixture size = case verifyCore (makeCoreModule size) of + Left diagnostics -> fail (show diagnostics) + Right verified -> case encodeCore defaultCoreWireLimits verified of + Left failure -> fail (show failure) + Right bytes -> pure (size, bytes) + +preparedFixture :: Int -> IO (Int, CorePrepModule) +preparedFixture size = case prepareCore (makeCoreModule size) of + Left diagnostics -> fail (show diagnostics) + Right value -> case verifyCorePrep value of + Left diagnostics -> fail (show diagnostics) + Right verified -> pure (size, verified) + +preparedDocument :: Int -> IO (Int, [Word8]) +preparedDocument size = do + (_, prepared) <- preparedFixture size + case encodeCorePrep prepared of + Left failure -> fail (show failure) + Right bytes -> pure (size, bytes) + +verifyDigest :: CoreModule -> Int +verifyDigest value = either length coreDigest (verifyCore value) + +encodeDigest :: CoreModule -> Int +encodeDigest value = either (length . show) length (encodeCore defaultCoreWireLimits value) + +decodeDigest :: [Word8] -> Int +decodeDigest bytes = either (length . show) coreDigest (decodeCore defaultCoreWireLimits bytes) + +-- Measure the production verifier/effect/inliner fixed point. Fixture creation +-- remains in Criterion's environment and is not charged to the sample. +optimizeDigest :: CoreModule -> Int +optimizeDigest value = case optimizeCoreWith inlineBenchmarkOptions value of + Left diagnostics -> length diagnostics + Right result -> + coreDigest (optimizedCore result) + + optimizationIterations result + + sum (map inlineRewrittenCalls (optimizationInlineReports result)) + +floatingOptimizeDigest :: CoreModule -> Int +floatingOptimizeDigest value = either length (coreDigest . optimizedCore) (optimizeCoreWith defaultOptimizerOptions value) + +integerOptimizeDigest :: CoreModule -> Int +integerOptimizeDigest value = either length (coreDigest . optimizedCore) (optimizeCoreWith defaultOptimizerOptions value) + +inlineBenchmarkOptions :: OptimizerOptions +inlineBenchmarkOptions = + defaultOptimizerOptions + { optimizerConstantPropagation = False + , optimizerControlFlowSimplification = False + , optimizerDeadCodeElimination = False + } + +prepareDigest :: CoreModule -> Int +prepareDigest value = either length corePrepDigest (prepareCore value) + +verifyPrepDigest :: CorePrepModule -> Int +verifyPrepDigest value = either length corePrepDigest (verifyCorePrep value) + +encodePrepDigest :: CorePrepModule -> Int +encodePrepDigest value = either (length . show) length (encodeCorePrep value) + +decodePrepDigest :: [Word8] -> Int +decodePrepDigest bytes = either (length . show) corePrepDigest (decodeCorePrep bytes) + +-- A structural digest forces every recursive container without allocating the +-- large intermediate String produced by show. The traversal is intentionally +-- simple and shared by operations whose result is an IR value. +coreDigest :: CoreModule -> Int +coreDigest value = sum (map functionDigest (coreModuleFunctions value)) + +functionDigest :: CoreFunction -> Int +functionDigest value = + 1 + + length (coreFunctionParameters value) + + sum (map statementDigest (coreFunctionBody value)) + +statementDigest :: CoreStatement -> Int +statementDigest statement = case statement of + CoreBind binding -> 1 + expressionDigest (coreBindingValue binding) + CoreAssign _ expression -> 1 + expressionDigest expression + CoreReturn expression -> 1 + expressionDigest expression + CoreIf condition whenTrue whenFalse -> + 1 + expressionDigest condition + sum (map statementDigest whenTrue) + sum (map statementDigest whenFalse) + CoreEvaluate expression -> 1 + expressionDigest expression + CoreWhile condition body -> 1 + expressionDigest condition + sum (map statementDigest body) + CoreDoWhile body condition -> 1 + sum (map statementDigest body) + expressionDigest condition + CoreFor condition body update -> + 1 + + expressionDigest condition + + sum (map statementDigest body) + + sum (map statementDigest update) + CoreBreak -> 1 + CoreContinue -> 1 + +expressionDigest :: CoreExpression -> Int +expressionDigest expression = case expression of + CoreVariable _ _ -> 1 + CoreLiteral _ _ -> 1 + CoreApply callee arguments _ -> 1 + expressionDigest callee + sum (map expressionDigest arguments) + CorePrimitive _ arguments _ -> 1 + sum (map expressionDigest arguments) + CoreLet _ _ value body _ -> 1 + expressionDigest value + expressionDigest body + CoreConditional condition whenTrue whenFalse _ -> + 1 + sum (map expressionDigest [condition, whenTrue, whenFalse]) + CoreClosure captures parameters _ body _ -> + 1 + + length parameters + + sum (map captureDigest captures) + + sum (map statementDigest body) + +captureDigest :: CoreCapture -> Int +captureDigest capture = 1 + expressionDigest (coreCaptureValue capture) + +corePrepDigest :: CorePrepModule -> Int +corePrepDigest value = sum (map prepFunctionDigest (corePrepModuleFunctions value)) + +prepFunctionDigest :: CorePrepFunction -> Int +prepFunctionDigest value = + 1 + + length (corePrepFunctionParameters value) + + sum (map blockDigest (corePrepFunctionBlocks value)) + +blockDigest :: CorePrepBlock -> Int +blockDigest value = + 1 + + sum (map instructionDigest (corePrepBlockInstructions value)) + + terminatorDigest (corePrepBlockTerminator value) + +instructionDigest :: CorePrepInstruction -> Int +instructionDigest instruction = case instruction of + CorePrepBind _ _ _ operation -> 1 + operationDigest operation + CorePrepAssign _ atom -> 1 + atomDigest atom + CorePrepEvaluate operation -> 1 + operationDigest operation + +operationDigest :: CorePrepOperation -> Int +operationDigest operation = case operation of + CorePrepCopy atom -> 1 + atomDigest atom + CorePrepCall callee arguments -> 1 + atomDigest callee + sum (map atomDigest arguments) + CorePrepPrimitive _ arguments -> 1 + sum (map atomDigest arguments) + CorePrepMakeClosure _ captures -> 1 + sum (map prepCaptureDigest captures) + +prepCaptureDigest :: CorePrepCapture -> Int +prepCaptureDigest (CorePrepCapture _ _ _ atom) = 1 + atomDigest atom + +atomDigest :: CorePrepAtom -> Int +atomDigest atom = case atom of + CorePrepVariable _ _ -> 1 + CorePrepLiteral _ _ -> 1 + +terminatorDigest :: CorePrepTerminator -> Int +terminatorDigest terminator = case terminator of + CorePrepReturn atom -> 1 + atomDigest atom + CorePrepBranch atom _ _ -> 1 + atomDigest atom + CorePrepJump _ -> 1 + CorePrepUnreachable -> 1 + +makeCoreModule :: Int -> CoreModule +makeCoreModule count = CoreModule (QualifiedName [Identifier "Benchmark"]) (map makeFunction [0 .. count - 1]) + +-- Each call expands a two-binding linear helper. Function and local symbols are +-- globally disjoint so the benchmark measures fresh allocation and cloning, +-- not malformed-input rejection. +makeInlineModule :: Int -> CoreModule +makeInlineModule count = + CoreModule + (QualifiedName [Identifier "InlineBenchmark"]) + (inlineHelper : map makeCaller [0 .. count - 1]) + where + helperName = name 1 "ScaleAndBias" + parameterName = name 2 "input" + firstName = name 3 "scaled" + secondName = name 4 "biased" + inlineHelper = + CoreFunction + helperName + [(parameterName, intType)] + intType + [ CoreBind + ( CoreBinding + firstName + intType + False + (CorePrimitive CoreMultiply [CoreVariable parameterName intType, integer 2] intType) + ) + , CoreBind + ( CoreBinding + secondName + intType + False + (CorePrimitive CoreAdd [CoreVariable firstName intType, integer 1] intType) + ) + , CoreReturn (CoreVariable secondName intType) + ] + makeCaller index = + let base = index * 3 + 100 + argumentName = name (base + 1) "argument" + callerName = name (base + 2) "Caller" + argument = CorePrimitive CoreAdd [integer (toInteger index), integer 7] intType + applied = + CoreApply + (CoreVariable helperName (FunctionType [intType] intType)) + [argument] + intType + in CoreFunction + callerName + [] + intType + [ CoreBind (CoreBinding argumentName intType False applied) + , CoreReturn (CoreVariable argumentName intType) + ] + +makeFunction :: Int -> CoreFunction +makeFunction index = + CoreFunction + (name base "Function") + [] + intType + [ CoreBind (CoreBinding valueName intType True sumValue) + , CoreIf comparison [CoreAssign valueName (integer 2)] [CoreAssign valueName (integer 0)] + , CoreReturn (CoreVariable valueName intType) + ] + where + base = index * 4 + 1 + valueName = name (base + 1) "value" + sumValue = CorePrimitive CoreAdd [integer (toInteger index), integer 1] intType + comparison = CorePrimitive CoreGreaterEqual [CoreVariable valueName intType, integer 1] boolType + +name :: Int -> String -> ResolvedName +name identifier spelling = ResolvedName (SymbolId identifier) (Identifier spelling) + +integer :: Integer -> CoreExpression +integer value = CoreLiteral (CoreInteger value) intType
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0.
+ LICENSE-EXCEPTION view
@@ -0,0 +1,81 @@+Progmasoft Linking Exception, Version 1.1 + +This Exception is an additional permission to the Mozilla Public License, version 2.0 ("MPL-2.0"). It is intended to preserve MPL-2.0's file-level obligations for Covered Software while removing doubt about combining that software with independent code. Capitalized terms not defined here have the meanings given in MPL-2.0. + +1. Definitions + +"Independent Component" means software contained in one or more Source Code Form files that neither contain Covered Software nor are Modifications of Covered Software. A component does not cease to be independent merely because compilation, static or dynamic linking, loading, packaging, or deployment places its Executable Form in the same file, process, address space, archive, image, or distribution as Covered Software. + +"Combined Work" means a Larger Work that combines Covered Software with one or more Independent Components by any technical means, including static or dynamic linking, loading, embedding, plugins, extensions, language bindings, an API, ABI, FFI boundary, command-line interface, protocol, inter-process communication mechanism, or file format. + +"Output" means material produced by executing Covered Software, including generated source, object code, executable code, intermediate representations, documentation, reports, diagnostics, formatted text, and analysis results. + +2. Additional Permission for Combined Works + +Subject to compliance with MPL-2.0 for the Covered Software, each recipient has a worldwide, royalty-free, non-exclusive, irrevocable additional copyright permission to create, reproduce, use, modify, display, perform, make available, and distribute a Combined Work under terms of the recipient's choice, including proprietary or closed-source terms. + +Those chosen terms may govern Independent Components and other portions of the Combined Work, but must not restrict or alter any recipient's rights in the Covered Software under MPL-2.0 and this Exception. No distributor is required to relicense an Independent Component merely because it forms part of a Combined Work. + +3. Boundary of Covered Software + +Linking, loading, calling, communicating with, packaging, installing, or distributing an Independent Component with Covered Software does not, by itself: + +(a) make the Independent Component Covered Software or a Modification; +(b) subject the Independent Component's Source Code Form to MPL-2.0; or +(c) expand MPL-2.0 beyond files that are Covered Software or Modifications under MPL-2.0. + +If Source Code Form from Covered Software is copied into another file, or a new Source Code Form file contains Covered Software, MPL-2.0 determines whether that file is a Modification. Labels, file extensions, build boundaries, code generation, or later separation of files do not avoid that determination. + +4. Outputs + +An Output does not become Covered Software merely because Covered Software produced, transformed, linked, or processed it. The copyright license chosen for input material does not change merely because Covered Software processes that material. + +If an Output contains copyrightable Source Code Form or other copyrightable material copied or derived from Covered Software, this Exception does not remove MPL-2.0 obligations from that incorporated material. Facts, ideas, interfaces, names, signatures, diagnostics, and other material not protected by copyright are not converted into Covered Software by this Exception. + +5. Preservation of MPL-2.0 Obligations + +This Exception does not remove, replace, waive, or narrow any MPL-2.0 obligation applicable to Covered Software. In particular: + +(a) Covered Software in Source Code Form and every Modification remain subject to MPL-2.0; +(b) distribution in Executable Form remains subject to MPL-2.0 Section 3.2, including the obligation to inform recipients how to obtain the corresponding Source Code Form when that section applies; +(c) notices protected by MPL-2.0 Section 3.4 must be retained; and +(d) this Exception grants no permission to withhold Source Code Form that MPL-2.0 requires to be made available. + +Distribution of a Combined Work under terms of choice is permission for the Combined Work as a whole and its Independent Components. It is not permission to relicense a Covered Software file. + +6. Packaging and Deployment + +Placing Covered Software and an Independent Component in the same archive, package, installer, application bundle, container image, firmware image, distribution medium, hosted deployment, or process does not change their respective copyright licenses. Network interaction or operation as separate processes is not required for independence. + +7. Direct Grant to Recipients + +The additional permission in this Exception is granted directly by the copyright holders applying it to every recipient of the applicable Covered Software. A distributor need not sublicense this Exception. Distribution through one or more intermediaries does not reduce the permission, and termination of an upstream distributor's rights does not terminate rights already received by a compliant downstream recipient. + +8. Termination and Reinstatement + +This Exception has no separate patent-litigation, field-of-use, combination, or compatibility termination condition. A recipient may exercise it only while entitled to exercise the corresponding MPL-2.0 copyright rights. If those rights terminate under MPL-2.0 Section 5.1, exercise of this Exception for the affected Covered Software is suspended to the same extent and is reinstated when, and to the extent that, the MPL-2.0 rights are reinstated. + +A recipient may elect to use Covered Software under MPL-2.0 without relying on this Exception. + +9. Other Rights + +This Exception grants copyright permission only. It grants no trademark, trade dress, service mark, publicity, confidential-information, or patent rights. Patent rights, if any, arise only under MPL-2.0 or a separately applicable patent grant. Nothing in this Exception limits rights arising independently under exhaustion, fair use, fair dealing, implied license, estoppel, or other applicable law. + +10. Relationship to MPL-2.0 + +MPL-2.0 and this Exception are read together. If this Exception and MPL-2.0 cannot both be given effect with respect to the creation or distribution of a Combined Work, this Exception controls only to the minimum extent necessary to provide the additional permission stated in Sections 2 through 6. MPL-2.0 controls in every other respect. + +Nothing here changes whether Covered Software is "Incompatible With Secondary Licenses" or changes the operation of MPL-2.0 Section 3.3 for a work governed by a Secondary License. + +11. Applicability and Version + +This Exception applies only to a file that expressly identifies it with this exact SPDX license expression: + +MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +Reference to Version 1.1 does not incorporate any later version. A copy of this text supplied in a repository or distribution identifies the permission; the per-file expression determines which files receive it. + +12. Severability + +If any provision of this Exception is held unenforceable, it shall be reformed only to the minimum extent necessary to make it enforceable. If reformation is unavailable, that provision is severed and the remaining provisions continue to the maximum extent permitted by law. +
+ src/Progmasoft/Tala/Core.hs view
@@ -0,0 +1,241 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 +{-# LANGUAGE PatternSynonyms #-} + +{- | Target-independent, verified compiler IR retained before CorePrep. +Expressions carry explicit result types and statements preserve source-level +control flow so later passes can introduce blocks without re-parsing source. +-} +module Progmasoft.Tala.Core + ( CoreLiteral (..) + , CorePrimitive (..) + , CoreCapture (..) + , CoreExpression (..) + , CoreStatement (..) + , CoreBinding (..) + , CoreFunction (..) + , CoreModule (.., CoreModule) + , expressionType + ) where + +import Progmasoft.Tala.AST (CaptureMode, QualifiedName, ResolvedName, Type) + +-- | Literal values representable in the typed Core expression graph. +data CoreLiteral + = -- | Exact arbitrary-precision integer value. + CoreInteger Integer + | -- | Canonical floating-point spelling. + CoreFloating String + | -- | Unicode scalar sequence. + CoreString String + | -- | Boolean value. + CoreBoolean Bool + | -- | The unique unit value. + CoreUnit + | -- | Null reference literal. + CoreNull + deriving (Eq, Ord, Read, Show) + +-- | Primitive operations with explicit operand and result nodes in Core. +data CorePrimitive + = -- | Numeric addition. + CoreAdd + | -- | Numeric subtraction. + CoreSubtract + | -- | Numeric multiplication. + CoreMultiply + | -- | Truncating division. + CoreDivide + | {- | Rounded division @//@: nearest integer, halves away from zero. The + constructor keeps its historical name; it never floors. + -} + CoreFloorDivide + | -- | Remainder operation. + CoreRemainder + | -- | Ordered less-than comparison. + CoreLessThan + | -- | Ordered less-than-or-equal comparison. + CoreLessEqual + | -- | Ordered greater-than comparison. + CoreGreaterThan + | -- | Ordered greater-than-or-equal comparison. + CoreGreaterEqual + | -- | Value equality comparison. + CoreEqual + | -- | Value inequality comparison. + CoreNotEqual + | -- | Short-circuit logical conjunction. + CoreLogicalAnd + | -- | Short-circuit logical disjunction. + CoreLogicalOr + | -- | Numeric unary negation. + CoreNegate + | -- | Logical Boolean negation. + CoreLogicalNot + | -- | Integer or floating power operation. + CorePower + | -- | Integer left shift. + CoreShiftLeft + | -- | Integer right shift as defined by operand type. + CoreShiftRight + | -- | Integer bitwise conjunction. + CoreBitwiseAnd + | -- | Integer bitwise exclusive-or. + CoreBitwiseXor + | -- | Integer bitwise disjunction. + CoreBitwiseOr + | -- | Integer bitwise complement. + CoreBitwiseNot + | -- | Runtime type-membership predicate. + CoreTypeIs + | {- | A callable that remembers its result. + + The operand is a callable without parameters. The result is a callable + of the same type that calls the operand the first time it is called, + keeps what the operand returned, and returns that again on every later + call without calling the operand. Every copy of the result shares the + one remembered value. This is the suspended computation of evaluation + by need: a value that is computed when it is first needed, at most + once, wherever the need arises. + -} + CoreMemoize + | {- | A call of a function of the runtime. + + The first operand is an integer literal, the identity of the function + in the catalog of "Progmasoft.Tala.RuntimeCall"; the operands after it + are the arguments. The function is fixed when the program is compiled: + the first operand is never a value that is computed. + -} + CoreRuntimeCall + deriving (Eq, Ord, Read, Show) + +-- | Typed expression graph consumed by Core verification and optimization. +data CoreExpression + = -- | Reference to a resolved local or function symbol. + CoreVariable ResolvedName Type + | -- | Literal payload with its semantic type. + CoreLiteral CoreLiteral Type + | -- | Callable application with ordered arguments. + CoreApply CoreExpression [CoreExpression] Type + | -- | Primitive operation and ordered operands. + CorePrimitive CorePrimitive [CoreExpression] Type + | -- CoreLet is expression-local sequencing. Pattern lowering uses it to + -- evaluate a potentially effectful subject exactly once before testing + -- several alternatives. + + -- | Bind one expression result before evaluating the continuation. + CoreLet ResolvedName Type CoreExpression CoreExpression Type + | {- | Conditional expression: test the condition in Boolean context, then + evaluate exactly one of the two arms and yield its value. The arm that + is not selected is never evaluated, so its calls, failures and + non-termination do not happen. Both arms have the result type. This is + the Core form of source @condition ? first : second@ and, combined + with 'CoreLet', of @left ?: fallback@. + -} + CoreConditional CoreExpression CoreExpression CoreExpression Type + | -- | Closure with captures, parameters, body, and callable type. + CoreClosure + [CoreCapture] + [(ResolvedName, Type)] + Type + [CoreStatement] + Type + deriving (Eq, Ord, Read, Show) + +-- | Captured source binding and the expression used to materialize its value. +data CoreCapture = CoreCapture + { coreCaptureMode :: CaptureMode + -- ^ Ownership mode selected by closure analysis. + , coreCaptureName :: ResolvedName + -- ^ Resolved identity of the captured binding. + , coreCaptureType :: Type + -- ^ Type expected by the closure environment. + , coreCaptureValue :: CoreExpression + -- ^ Expression evaluated at closure creation. + } + deriving (Eq, Ord, Read, Show) + +{- | Structured, verified statements retained until CorePrep constructs the +control-flow graph. Loop forms remain explicit so that optimizers can preserve +condition, body, update, and innermost-transfer ordering without reconstructing +source semantics from basic blocks. +-} +data CoreStatement + = CoreBind CoreBinding + | CoreAssign ResolvedName CoreExpression + | CoreReturn CoreExpression + | CoreIf CoreExpression [CoreStatement] [CoreStatement] + | CoreEvaluate CoreExpression + | CoreWhile CoreExpression [CoreStatement] + | CoreDoWhile [CoreStatement] CoreExpression + | CoreFor CoreExpression [CoreStatement] [CoreStatement] + | CoreBreak + | CoreContinue + deriving (Eq, Ord, Read, Show) + +-- | Local declaration with resolved identity, mutability, and initializer. +data CoreBinding = CoreBinding + { coreBindingName :: ResolvedName + -- ^ Symbol introduced by the binding. + , coreBindingType :: Type + -- ^ Declared semantic type. + , coreBindingMutable :: Bool + -- ^ Whether later assignment is permitted. + , coreBindingValue :: CoreExpression + -- ^ Initial value expression. + } + deriving (Eq, Ord, Read, Show) + +-- | Top-level or member callable lowered into target-independent Core. +data CoreFunction = CoreFunction + { coreFunctionName :: ResolvedName + -- ^ Resolved function symbol. + , coreFunctionParameters :: [(ResolvedName, Type)] + -- ^ Parameters in call order. + , coreFunctionReturnType :: Type + -- ^ Declared result type. + , coreFunctionBody :: [CoreStatement] + -- ^ Function statements in source order. + } + deriving (Eq, Ord, Read, Show) + +{- | Source ownership is deliberately side metadata rather than syntax or +semantics. Function identities remain stable while the optimizer rewrites +bodies, and the native backend can partition definitions without guessing +from declaration spelling or filesystem layout. +The named data constructor carries compiler provenance. The two-argument +pattern below preserves the long-standing source-level construction API for +hand-written Core fixtures; project compilation uses CoreModuleWithSources. +-} + +-- | Verified module plus source ownership metadata used by project builds. +data CoreModule = CoreModuleWithSources + { coreModuleName :: QualifiedName + -- ^ Fully qualified module name. + , coreModuleFunctions :: [CoreFunction] + -- ^ Functions emitted by this unit. + , coreModuleSourceFiles :: [FilePath] + -- ^ Source files included in the compilation. + , coreModuleFunctionSources :: [(Int, FilePath)] + -- ^ Function indices mapped to their source file. + } + deriving (Eq, Ord, Read, Show) + +-- | Construct or match a Core module without explicit source ownership data. +pattern CoreModule :: QualifiedName -> [CoreFunction] -> CoreModule +pattern CoreModule name functions <- CoreModuleWithSources name functions _ _ + where + CoreModule name functions = CoreModuleWithSources name functions [] [] + +{-# COMPLETE CoreModule #-} + +-- | Read the explicit result type stored on any Core expression node. +expressionType :: CoreExpression -> Type +expressionType expression = case expression of + CoreVariable _ value -> value + CoreLiteral _ value -> value + CoreApply _ _ value -> value + CorePrimitive _ _ value -> value + CoreLet _ _ _ _ value -> value + CoreConditional _ _ _ value -> value + CoreClosure _ _ _ _ value -> value
+ src/Progmasoft/Tala/Core/Artifact.hs view
@@ -0,0 +1,73 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Bounded, verified persistence for standalone Core artifacts. +Readers decode and semantically verify before returning a module; writers +verify before encoding so invalid compiler state never becomes a trusted file. +-} +module Progmasoft.Tala.Core.Artifact + ( CoreArtifactError (..) + , readCoreArtifact + , readCoreArtifactWith + , writeCoreArtifact + , writeCoreArtifactWith + ) where + +import Control.Exception (IOException, try) +import Data.ByteString qualified as ByteString +import System.FilePath (takeExtension) +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Verifier +import Progmasoft.Tala.Core.Wire +import Progmasoft.Tala.Diagnostic (diagnosticCode, diagnosticMessage) + +-- | Path, wire, semantic, or filesystem failure while handling a Core file. +data CoreArtifactError + = -- | Artifact path does not use the required @.core@ extension. + InvalidCoreArtifactPath FilePath + | -- | The byte document failed wire decoding or encoding. + CoreArtifactWireError CoreWireError + | -- | Decoded Core failed semantic verification. + CoreArtifactVerificationError [String] + | -- | Filesystem operation failed at this path. + CoreArtifactIOError FilePath String + deriving (Eq, Ord, Read, Show) + +-- | Read, decode, and verify a Core artifact using default wire ceilings. +readCoreArtifact :: FilePath -> IO (Either CoreArtifactError CoreModule) +readCoreArtifact = readCoreArtifactWith defaultCoreWireLimits + +-- | Read and verify a Core artifact under caller-selected resource limits. +readCoreArtifactWith :: CoreWireLimits -> FilePath -> IO (Either CoreArtifactError CoreModule) +readCoreArtifactWith limits path + | takeExtension path /= ".core" = pure (Left (InvalidCoreArtifactPath path)) + | otherwise = do + loaded <- try (ByteString.readFile path) :: IO (Either IOException ByteString.ByteString) + pure $ case loaded of + Left issue -> Left (CoreArtifactIOError path (show issue)) + Right bytes -> case decodeCore limits (ByteString.unpack bytes) of + Left issue -> Left (CoreArtifactWireError issue) + Right moduleValue -> verify moduleValue + +-- | Verify and write a Core module using default wire ceilings. +writeCoreArtifact :: FilePath -> CoreModule -> IO (Either CoreArtifactError ()) +writeCoreArtifact = writeCoreArtifactWith defaultCoreWireLimits + +-- | Verify and write a Core module under caller-selected resource limits. +writeCoreArtifactWith :: CoreWireLimits -> FilePath -> CoreModule -> IO (Either CoreArtifactError ()) +writeCoreArtifactWith limits path moduleValue + | takeExtension path /= ".core" = pure (Left (InvalidCoreArtifactPath path)) + | otherwise = case verify moduleValue >>= encode of + Left issue -> pure (Left issue) + Right bytes -> do + written <- try (ByteString.writeFile path (ByteString.pack bytes)) :: IO (Either IOException ()) + pure $ either (Left . CoreArtifactIOError path . show) (const (Right ())) written + where + encode value = either (Left . CoreArtifactWireError) Right (encodeCore limits value) + +verify :: CoreModule -> Either CoreArtifactError CoreModule +verify moduleValue = case verifyCore moduleValue of + Left problems -> Left (CoreArtifactVerificationError (map diagnosticText problems)) + Right verified -> Right verified + where + diagnosticText diagnostic = diagnosticCode diagnostic ++ ": " ++ diagnosticMessage diagnostic
+ src/Progmasoft/Tala/Core/CorePrep.hs view
@@ -0,0 +1,629 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Normalize tree-shaped Core into typed operations and explicit basic blocks. + +CorePrep preserves Core identity and evaluation order while making control flow +and storage actions visible to native Xpp lowering. It is an internal adapter, +not a user-selectable emission format or an optimization owner. +-} +module Progmasoft.Tala.Core.CorePrep + ( CorePrepAtom (..) + , CorePrepCapture (..) + , CorePrepOperation (..) + , CorePrepInstruction (..) + , CorePrepTerminator (..) + , CorePrepBlock (..) + , CorePrepFunction (..) + , CorePrepModule (..) + , prepareCore + ) where + +import Data.Map.Strict qualified as Map +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Scalar (isCoreFloatingType) +import Progmasoft.Tala.Core.Verifier (verifyCore) +import Progmasoft.Tala.Diagnostic + +-- | A value already reduced to a symbol reference or a literal constant. +data CorePrepAtom = CorePrepVariable ResolvedName Type | CorePrepLiteral CoreLiteral Type + deriving (Eq, Ord, Read, Show) + +-- | One atom-only computation; nested expressions have already been sequenced. +data CorePrepOperation + = CorePrepCopy CorePrepAtom + | CorePrepCall CorePrepAtom [CorePrepAtom] + | CorePrepPrimitive CorePrimitive [CorePrepAtom] + | CorePrepMakeClosure ResolvedName [CorePrepCapture] + deriving (Eq, Ord, Read, Show) + +-- | Closure environment slot with its source ownership mode and initializer. +data CorePrepCapture = CorePrepCapture CaptureMode ResolvedName Type CorePrepAtom + deriving (Eq, Ord, Read, Show) + +-- | A storage definition or side effect that executes in block order. +data CorePrepInstruction + = CorePrepBind ResolvedName Type Bool CorePrepOperation + | CorePrepAssign ResolvedName CorePrepAtom + | CorePrepEvaluate CorePrepOperation + deriving (Eq, Ord, Read, Show) + +-- | The control transfer that closes a prepared basic block. +data CorePrepTerminator + = CorePrepReturn CorePrepAtom + | CorePrepBranch CorePrepAtom Int Int + | CorePrepJump Int + | CorePrepUnreachable + deriving (Eq, Ord, Read, Show) + +-- | A deterministic block identifier, ordered instructions, and final transfer. +data CorePrepBlock = CorePrepBlock + { corePrepBlockId :: Int + , corePrepBlockInstructions :: [CorePrepInstruction] + , corePrepBlockTerminator :: CorePrepTerminator + } + deriving (Eq, Ord, Read, Show) + +-- | Function signature plus entry block and deterministic control-flow body. +data CorePrepFunction = CorePrepFunction + { corePrepFunctionName :: ResolvedName + , corePrepFunctionSourceFile :: FilePath + , corePrepFunctionParameters :: [(ResolvedName, Type)] + , corePrepFunctionReturnType :: Type + , corePrepFunctionEntry :: Int + , corePrepFunctionBlocks :: [CorePrepBlock] + } + deriving (Eq, Ord, Read, Show) + +-- | Module identity, prepared functions, and source files retained as provenance. +data CorePrepModule = CorePrepModule + { corePrepModuleName :: QualifiedName + , corePrepModuleFunctions :: [CorePrepFunction] + , corePrepModuleSourceFiles :: [FilePath] + } + deriving (Eq, Ord, Read, Show) + +data PrepState = PrepState + { nextTemporary :: Int + , nextBlock :: Int + , pendingFunctions :: [(CoreFunction, FilePath)] + , currentSourceFile :: FilePath + , loopTargets :: [(Int, Int)] + -- ^ Innermost first; each pair is the @break@ exit and @continue@ target. + } + +-- An OpenBlock is the current continuation while expressions are being +-- atomized. Most expressions only append instructions, but short-circuit +-- expressions close the current block, emit a conditional region, and return +-- a fresh join block. Keeping that distinction explicit prevents a nested +-- logical expression from being flattened back into eager instruction order. +data OpenBlock = OpenBlock + { openBlockId :: Int + , openBlockInstructions :: [CorePrepInstruction] + {- ^ Newest first, so that appending one is constant time; 'closeBlock' + puts them in execution order. + -} + } + +{- | Adapt one verified Core module without changing its source-level semantics. +Fresh IDs start above every Core ID so generated temporaries cannot alias +declarations, locals, parameters, or captures already present in the module. +-} +prepareCore :: CoreModule -> Either [Diagnostic] CorePrepModule +prepareCore moduleValue = + do + verified <- verifyCore moduleValue + let seed = 1 + maximum (0 : concatMap symbolIds (coreModuleFunctions verified)) + sourceOwners = Map.fromList (coreModuleFunctionSources verified) + sourceOf function = + Map.findWithDefault + "" + (symbolIdValue (resolvedSymbol (coreFunctionName function))) + sourceOwners + initial = PrepState seed 1 [] "" [] + work = [(function, sourceOf function) | function <- coreModuleFunctions verified] + (functions, _) = prepareFunctionQueue initial work + pure (CorePrepModule (coreModuleName verified) functions (coreModuleSourceFiles verified)) + +-- Closure conversion yields lifted functions together with their source +-- owner. They are prepared after every function that was already waiting, in +-- the order they were found, and the functions lifted out of them after +-- those: that supports nested closures without a separate whole-module pass +-- or a filename guess. +-- +-- The lifted functions wait in batches of their own, newest first. Appending +-- them to the functions still waiting wrapped that list once more for every +-- function prepared, also when nothing was lifted, and taking the next +-- function then cost time with the number of functions before it. +prepareFunctionQueue :: PrepState -> [(CoreFunction, FilePath)] -> ([CorePrepFunction], PrepState) +prepareFunctionQueue initial work = go initial work [] + where + go state [] [] = ([], state) + go state [] lifted = go state (concat (reverse lifted)) [] + go state ((function, sourceFile) : remaining) lifted = + let (prepared, afterFunction) = prepareFunction (state {nextBlock = 1, currentSourceFile = sourceFile}) function + pending = pendingFunctions afterFunction + nextState = afterFunction {pendingFunctions = []} + (later, final) = go nextState remaining (if null pending then lifted else pending : lifted) + in (prepared : later, final) + +prepareFunction :: PrepState -> CoreFunction -> (CorePrepFunction, PrepState) +prepareFunction state function = + let (blocks, after) = + prepareStatementsTo fallingOff (state {loopTargets = []}) (OpenBlock 0 []) (coreFunctionBody function) [] + in ( CorePrepFunction + (coreFunctionName function) + (currentSourceFile state) + (coreFunctionParameters function) + (coreFunctionReturnType function) + 0 + blocks + , after + ) + where + -- A function without a result may end without a return: reaching + -- the end of its body returns. A function with a result returns on + -- every path, which Core verification has established, so the end + -- of its body is not reached and is marked as such. + fallingOff + | coreFunctionReturnType function == unitType = CorePrepReturn (CorePrepLiteral CoreUnit unitType) + | otherwise = CorePrepUnreachable + +{- | Every symbol identity a function mentions. + +The identities are prepended to an accumulator. Appending the lists of the +operands instead would copy the identities of a first operand once for every +operator above it, which is quadratic in the length of an operator chain. +-} +symbolIds :: CoreFunction -> [Int] +symbolIds function = + symbolIdValue (resolvedSymbol (coreFunctionName function)) + : map (symbolIdValue . resolvedSymbol . fst) (coreFunctionParameters function) + ++ statementsSymbolIds (coreFunctionBody function) [] + +statementsSymbolIds :: [CoreStatement] -> [Int] -> [Int] +statementsSymbolIds statements rest = foldr statementSymbolIds rest statements + +statementSymbolIds :: CoreStatement -> [Int] -> [Int] +statementSymbolIds statement rest = case statement of + CoreBind binding -> symbol (coreBindingName binding) : expressionSymbolIds (coreBindingValue binding) rest + CoreAssign name expression -> symbol name : expressionSymbolIds expression rest + CoreReturn expression -> expressionSymbolIds expression rest + CoreIf condition trueBranch falseBranch -> + expressionSymbolIds condition (statementsSymbolIds trueBranch (statementsSymbolIds falseBranch rest)) + CoreWhile condition body -> expressionSymbolIds condition (statementsSymbolIds body rest) + CoreDoWhile body condition -> statementsSymbolIds body (expressionSymbolIds condition rest) + CoreFor condition body update -> + expressionSymbolIds condition (statementsSymbolIds body (statementsSymbolIds update rest)) + CoreBreak -> rest + CoreContinue -> rest + CoreEvaluate expression -> expressionSymbolIds expression rest + where + symbol = symbolIdValue . resolvedSymbol + +expressionSymbolIds :: CoreExpression -> [Int] -> [Int] +expressionSymbolIds expression rest = case expression of + CoreVariable name _ -> symbol name : rest + CoreLiteral _ _ -> rest + CoreApply callee arguments _ -> expressionSymbolIds callee (expressions arguments rest) + CorePrimitive _ arguments _ -> expressions arguments rest + CoreLet name _ value body _ -> symbol name : expressionSymbolIds value (expressionSymbolIds body rest) + CoreConditional condition whenTrue whenFalse _ -> expressions [condition, whenTrue, whenFalse] rest + CoreClosure captures parameters _ body _ -> + map (symbol . coreCaptureName) captures + ++ expressions + (map coreCaptureValue captures) + (map (symbol . fst) parameters ++ statementsSymbolIds body rest) + where + symbol = symbolIdValue . resolvedSymbol + expressions values after = foldr expressionSymbolIds after values + +{- | Lower statements into blocks, ending the last open block with the given +terminator and placing the given blocks after the ones produced. + +Both arguments exist so that the work is linear in the size of the body. A +branch or a loop body falls through to a known block; passing that jump down +ends the region with it directly, where patching the blocks afterwards would +visit every block of a nested region once per enclosing region. The blocks +that follow are passed in so that they are consed onto, where appending them +would copy the blocks of a nested region once per enclosing region; an +@else if@ chain is such a nest, one level per link. + +Only the last block of a region can be left open: a @return@, @break@ or +@continue@ closes its block and drops the statements after it, and every +nested region is closed by its own terminator. +-} +prepareStatementsTo :: + CorePrepTerminator -> PrepState -> OpenBlock -> [CoreStatement] -> [CorePrepBlock] -> ([CorePrepBlock], PrepState) +prepareStatementsTo end state open [] rest = (closeBlock open end : rest, state) +prepareStatementsTo end state open (statement : remaining) rest = case statement of + CoreBind binding -> + let (closed, continued, operation, after) = atomizeOperation state open (coreBindingValue binding) + instruction = CorePrepBind (coreBindingName binding) (coreBindingType binding) (coreBindingMutable binding) operation + (later, final) = prepareStatementsTo end after (appendInstruction continued instruction) remaining rest + in (closed ++ later, final) + CoreAssign name value -> + let (closed, continued, atom, after) = atomize state open value + (later, final) = prepareStatementsTo end after (appendInstruction continued (CorePrepAssign name atom)) remaining rest + in (closed ++ later, final) + CoreEvaluate value + | discardsItsOperation value -> + let (closed, continued, operation, after) = atomizeOperation state open value + (later, final) = + prepareStatementsTo end after (appendInstruction continued (CorePrepEvaluate operation)) remaining rest + in (closed ++ later, final) + | otherwise -> + -- Only a call may be an instruction whose result is dropped. + -- Any other value is computed into an ordinary temporary, so + -- its operands still run and may trap, and the unused atom is + -- ignored. + let (closed, continued, _, after) = atomize state open value + (later, final) = prepareStatementsTo end after continued remaining rest + in (closed ++ later, final) + CoreReturn value -> + let (closed, continued, atom, after) = atomize state open value + in (closed ++ closeBlock continued (CorePrepReturn atom) : rest, after) + CoreIf condition trueBranch falseBranch -> + let (conditionBlocks, conditionOpen, conditionAtom, afterCondition) = atomize state open condition + (booleanOpen, booleanAtom, afterBoolean) = booleanizeAtom afterCondition conditionOpen conditionAtom + trueId = nextBlock afterBoolean + falseId = trueId + 1 + joinId = falseId + 1 + branchState = afterBoolean {nextBlock = joinId + 1} + -- The states are threaded in source order. The block lists are + -- built back to front: each region is consed onto the blocks + -- that follow it, which laziness allows although those depend + -- on a later state. + (trueBlocks, afterTrue) = prepareBranchTo branchState trueId joinId trueBranch falseBlocks + (falseBlocks, afterFalse) = prepareBranchTo afterTrue falseId joinId falseBranch tailBlocks + header = closeBlock booleanOpen (CorePrepBranch booleanAtom trueId falseId) + (tailBlocks, final) = prepareStatementsTo end afterFalse (OpenBlock joinId []) remaining rest + in (conditionBlocks ++ header : trueBlocks, final) + CoreWhile condition body -> + let (loopBlocks, exitOpen, afterLoop) = prepareWhile state open condition body + (tailBlocks, final) = prepareStatementsTo end afterLoop exitOpen remaining rest + in (loopBlocks ++ tailBlocks, final) + CoreDoWhile body condition -> + let (loopBlocks, exitOpen, afterLoop) = prepareDoWhile state open body condition + (tailBlocks, final) = prepareStatementsTo end afterLoop exitOpen remaining rest + in (loopBlocks ++ tailBlocks, final) + CoreFor condition body update -> + let (loopBlocks, exitOpen, afterLoop) = prepareFor state open condition body update + (tailBlocks, final) = prepareStatementsTo end afterLoop exitOpen remaining rest + in (loopBlocks ++ tailBlocks, final) + CoreBreak -> onto (closeLoopControl state open True) + CoreContinue -> onto (closeLoopControl state open False) + where + onto (blocks, after) = (blocks ++ rest, after) + +{- | Close the current block at the innermost loop transfer destination. +The Boolean selects @break@ (exit) versus @continue@ (continuation point); +Core verification rejects either transfer when this stack is empty. +-} +closeLoopControl :: PrepState -> OpenBlock -> Bool -> ([CorePrepBlock], PrepState) +closeLoopControl state open isBreak = case loopTargets state of + (breakTarget, continueTarget) : _ -> + let target = if isBreak then breakTarget else continueTarget + in ([closeBlock open (CorePrepJump target)], state) + [] -> ([closeBlock open CorePrepUnreachable], state) + +-- | Lower a pre-test loop and route its body fallthrough to the condition. +prepareWhile :: + PrepState -> + OpenBlock -> + CoreExpression -> + [CoreStatement] -> + ([CorePrepBlock], OpenBlock, PrepState) +prepareWhile state incoming condition body = + let conditionId = nextBlock state + bodyId = conditionId + 1 + exitId = bodyId + 1 + reserved = state {nextBlock = exitId + 1} + entry = closeBlock incoming (CorePrepJump conditionId) + (conditionBlocks, conditionOpen, atom, afterCondition) = + atomize reserved (OpenBlock conditionId []) condition + (booleanOpen, predicate, afterBoolean) = booleanizeAtom afterCondition conditionOpen atom + branch = closeBlock booleanOpen (CorePrepBranch predicate bodyId exitId) + bodyState = afterBoolean {loopTargets = (exitId, conditionId) : loopTargets afterBoolean} + (bodyEnd, afterBody) = prepareStatementsTo (CorePrepJump conditionId) bodyState (OpenBlock bodyId []) body [] + finalState = afterBody {loopTargets = loopTargets state} + in ([entry] ++ conditionBlocks ++ [branch] ++ bodyEnd, OpenBlock exitId [], finalState) + +-- | Lower a post-test loop so even its first entered body reaches the test. +prepareDoWhile :: + PrepState -> + OpenBlock -> + [CoreStatement] -> + CoreExpression -> + ([CorePrepBlock], OpenBlock, PrepState) +prepareDoWhile state incoming body condition = + let bodyId = nextBlock state + conditionId = bodyId + 1 + exitId = conditionId + 1 + reserved = state {nextBlock = exitId + 1} + entry = closeBlock incoming (CorePrepJump bodyId) + bodyState = reserved {loopTargets = (exitId, conditionId) : loopTargets state} + (bodyEnd, afterBody) = prepareStatementsTo (CorePrepJump conditionId) bodyState (OpenBlock bodyId []) body [] + (conditionBlocks, conditionOpen, atom, afterCondition) = + atomize afterBody (OpenBlock conditionId []) condition + (booleanOpen, predicate, afterBoolean) = booleanizeAtom afterCondition conditionOpen atom + branch = closeBlock booleanOpen (CorePrepBranch predicate bodyId exitId) + finalState = afterBoolean {loopTargets = loopTargets state} + in ([entry] ++ bodyEnd ++ conditionBlocks ++ [branch], OpenBlock exitId [], finalState) + +-- | Lower a classic loop with a dedicated update block used by @continue@. +prepareFor :: + PrepState -> + OpenBlock -> + CoreExpression -> + [CoreStatement] -> + [CoreStatement] -> + ([CorePrepBlock], OpenBlock, PrepState) +prepareFor state incoming condition body update = + let conditionId = nextBlock state + bodyId = conditionId + 1 + updateId = bodyId + 1 + exitId = updateId + 1 + reserved = state {nextBlock = exitId + 1} + entry = closeBlock incoming (CorePrepJump conditionId) + (conditionBlocks, conditionOpen, atom, afterCondition) = + atomize reserved (OpenBlock conditionId []) condition + (booleanOpen, predicate, afterBoolean) = booleanizeAtom afterCondition conditionOpen atom + branch = closeBlock booleanOpen (CorePrepBranch predicate bodyId exitId) + bodyState = afterBoolean {loopTargets = (exitId, updateId) : loopTargets afterBoolean} + (bodyEnd, afterBody) = prepareStatementsTo (CorePrepJump updateId) bodyState (OpenBlock bodyId []) body [] + updateState = afterBody {loopTargets = (exitId, updateId) : loopTargets state} + (updateEnd, afterUpdate) = + prepareStatementsTo (CorePrepJump conditionId) updateState (OpenBlock updateId []) update [] + finalState = afterUpdate {loopTargets = loopTargets state} + in ([entry] ++ conditionBlocks ++ [branch] ++ bodyEnd ++ updateEnd, OpenBlock exitId [], finalState) + +{- | Whether an evaluated expression lowers to one result-discarding +instruction. The record has no result type on the wire; a reader recovers +it from the callee, which only a call has. A discarded closure creation is +therefore bound like any other value. +-} +discardsItsOperation :: CoreExpression -> Bool +discardsItsOperation expression = case expression of + CoreApply {} -> True + _ -> False + +appendInstruction :: OpenBlock -> CorePrepInstruction -> OpenBlock +appendInstruction open instruction = + open {openBlockInstructions = instruction : openBlockInstructions open} + +closeBlock :: OpenBlock -> CorePrepTerminator -> CorePrepBlock +closeBlock open terminator = + CorePrepBlock (openBlockId open) (reverse (openBlockInstructions open)) terminator + +-- Numeric conditions are a source-language convenience. Core retains their +-- numeric type for optimization, while CorePrep makes the zero comparison +-- explicit so every native branch still consumes a canonical bool atom. The +-- zero has the literal form of the operand type, a floating zero for a +-- floating operand, exactly as the native adapter spells it. +booleanizeAtom :: PrepState -> OpenBlock -> CorePrepAtom -> (OpenBlock, CorePrepAtom, PrepState) +booleanizeAtom state open atom + | corePrepAtomType atom == boolType = (open, atom, state) + | otherwise = + let identifier = nextTemporary state + temporary = ResolvedName (SymbolId identifier) (Identifier ("$condition" ++ show identifier)) + zero = zeroAtom (corePrepAtomType atom) + instruction = CorePrepBind temporary boolType False (CorePrepPrimitive CoreNotEqual [atom, zero]) + in (appendInstruction open instruction, CorePrepVariable temporary boolType, state {nextTemporary = identifier + 1}) + +booleanizeMany :: PrepState -> OpenBlock -> [CorePrepAtom] -> (OpenBlock, [CorePrepAtom], PrepState) +booleanizeMany state open [] = (open, [], state) +booleanizeMany state open (atom : remaining) = + let (continued, boolean, after) = booleanizeAtom state open atom + (finalOpen, later, final) = booleanizeMany after continued remaining + in (finalOpen, boolean : later, final) + +corePrepAtomType :: CorePrepAtom -> Type +corePrepAtomType atom = case atom of + CorePrepVariable _ valueType -> valueType + CorePrepLiteral _ valueType -> valueType + +-- | Lower one branch of a conditional: it falls through to the join block. +prepareBranchTo :: PrepState -> Int -> Int -> [CoreStatement] -> [CorePrepBlock] -> ([CorePrepBlock], PrepState) +prepareBranchTo state blockId joinId = + prepareStatementsTo (CorePrepJump joinId) state (OpenBlock blockId []) + +atomize :: PrepState -> OpenBlock -> CoreExpression -> ([CorePrepBlock], OpenBlock, CorePrepAtom, PrepState) +atomize state open expression = case expression of + CoreVariable name valueType -> ([], open, CorePrepVariable name valueType, state) + CoreLiteral literal valueType -> ([], open, CorePrepLiteral literal valueType, state) + CoreLet name valueType value body _ -> + let (valueBlocks, valueOpen, valueOperation, afterValue) = atomizeOperation state open value + boundOpen = appendInstruction valueOpen (CorePrepBind name valueType False valueOperation) + (bodyBlocks, bodyOpen, bodyAtom, afterBody) = atomize afterValue boundOpen body + in (valueBlocks ++ bodyBlocks, bodyOpen, bodyAtom, afterBody) + CorePrimitive primitive [left, right] _ + | primitive == CoreLogicalAnd || primitive == CoreLogicalOr -> + atomizeShortCircuit state open primitive left right + CoreConditional condition whenTrue whenFalse valueType -> + atomizeConditional state open condition whenTrue whenFalse valueType + _ -> + let (closed, continued, operation, afterOperation) = atomizeOperation state open expression + temporary = + ResolvedName (SymbolId (nextTemporary afterOperation)) (Identifier ("$coreprep" ++ show (nextTemporary afterOperation))) + valueType = expressionType expression + instruction = CorePrepBind temporary valueType False operation + in ( closed + , appendInstruction continued instruction + , CorePrepVariable temporary valueType + , afterOperation {nextTemporary = nextTemporary afterOperation + 1} + ) + +atomizeOperation :: + PrepState -> OpenBlock -> CoreExpression -> ([CorePrepBlock], OpenBlock, CorePrepOperation, PrepState) +atomizeOperation state open expression = case expression of + CoreVariable name valueType -> ([], open, CorePrepCopy (CorePrepVariable name valueType), state) + CoreLiteral literal valueType -> ([], open, CorePrepCopy (CorePrepLiteral literal valueType), state) + CorePrimitive primitive [left, right] _ + | primitive == CoreLogicalAnd || primitive == CoreLogicalOr -> + let (closed, continued, atom, after) = atomizeShortCircuit state open primitive left right + in (closed, continued, CorePrepCopy atom, after) + CoreConditional condition whenTrue whenFalse valueType -> + let (closed, continued, atom, after) = atomizeConditional state open condition whenTrue whenFalse valueType + in (closed, continued, CorePrepCopy atom, after) + CoreApply callee arguments _ -> + let (calleeBlocks, calleeOpen, calleeAtom, afterCallee) = atomize state open callee + (argumentBlocks, argumentOpen, argumentAtoms, afterArguments) = atomizeMany afterCallee calleeOpen arguments + in (calleeBlocks ++ argumentBlocks, argumentOpen, CorePrepCall calleeAtom argumentAtoms, afterArguments) + CorePrimitive primitive arguments _ -> + let (closed, continued, atoms, after) = atomizeMany state open arguments + logical = primitive `elem` [CoreLogicalAnd, CoreLogicalOr, CoreLogicalNot] + (finalOpen, preparedAtoms, final) = + if logical then booleanizeMany after continued atoms else (continued, atoms, after) + in (closed, finalOpen, CorePrepPrimitive primitive preparedAtoms, final) + CoreLet name valueType value body _ -> + let (valueBlocks, valueOpen, valueOperation, afterValue) = atomizeOperation state open value + boundOpen = appendInstruction valueOpen (CorePrepBind name valueType False valueOperation) + (bodyBlocks, bodyOpen, bodyAtom, afterBody) = atomize afterValue boundOpen body + in (valueBlocks ++ bodyBlocks, bodyOpen, CorePrepCopy bodyAtom, afterBody) + CoreClosure captures parameters returnType body _ -> + let closureId = nextTemporary state + closureName = + ResolvedName (SymbolId closureId) (Identifier ("$closure" ++ show closureId)) + (captureBlocks, captureOpen, preparedCaptures, afterCaptures) = + atomizeCaptures + (state {nextTemporary = closureId + 1}) + open + captures + hiddenParameters = [(coreCaptureName capture, coreCaptureType capture) | capture <- captures] + lifted = CoreFunction closureName (hiddenParameters ++ parameters) returnType body + finalState = + afterCaptures + { pendingFunctions = pendingFunctions afterCaptures ++ [(lifted, currentSourceFile afterCaptures)] + } + in (captureBlocks, captureOpen, CorePrepMakeClosure closureName preparedCaptures, finalState) + +-- Logical conjunction and disjunction are control flow, not ordinary eager +-- primitive instructions. The result slot is initialized before branching and +-- overwritten only on the path that evaluates the right operand. Consequently +-- every join predecessor carries an initialized Bool without requiring a phi +-- node in CorePrep's storage-oriented IR. +atomizeShortCircuit :: + PrepState -> + OpenBlock -> + CorePrimitive -> + CoreExpression -> + CoreExpression -> + ([CorePrepBlock], OpenBlock, CorePrepAtom, PrepState) +atomizeShortCircuit state open primitive left right = + let (leftBlocks, leftOpen, leftAtom, afterLeft) = atomize state open left + (conditionOpen, conditionAtom, afterCondition) = booleanizeAtom afterLeft leftOpen leftAtom + resultId = nextTemporary afterCondition + resultName = ResolvedName (SymbolId resultId) (Identifier ("$shortcircuit" ++ show resultId)) + resultAtom = CorePrepVariable resultName boolType + defaultValue = CorePrepLiteral (CoreBoolean (primitive == CoreLogicalOr)) boolType + initializedOpen = + appendInstruction conditionOpen (CorePrepBind resultName boolType True (CorePrepCopy defaultValue)) + rightId = nextBlock afterCondition + joinId = rightId + 1 + afterReservation = + afterCondition + { nextTemporary = resultId + 1 + , nextBlock = joinId + 1 + } + branch = + if primitive == CoreLogicalAnd + then CorePrepBranch conditionAtom rightId joinId + else CorePrepBranch conditionAtom joinId rightId + header = closeBlock initializedOpen branch + (rightBlocks, rightOpen, rightAtom, afterRight) = + atomize afterReservation (OpenBlock rightId []) right + (booleanRightOpen, booleanRight, final) = booleanizeAtom afterRight rightOpen rightAtom + assignedRight = appendInstruction booleanRightOpen (CorePrepAssign resultName booleanRight) + rightExit = closeBlock assignedRight (CorePrepJump joinId) + in ( leftBlocks ++ [header] ++ rightBlocks ++ [rightExit] + , OpenBlock joinId [] + , resultAtom + , final + ) + +{- | Lower a conditional expression to a two-way branch over a result slot. + +Exactly one arm is evaluated. The slot is bound before the branch with the +neutral literal of its type and each arm overwrites it on its own path, so +the join block reads an initialized value from either predecessor without a +phi node. The neutral value is never observable: no path reaches the join +without passing through one of the two assignments. +-} +atomizeConditional :: + PrepState -> + OpenBlock -> + CoreExpression -> + CoreExpression -> + CoreExpression -> + Type -> + ([CorePrepBlock], OpenBlock, CorePrepAtom, PrepState) +atomizeConditional state open condition whenTrue whenFalse valueType = + let (conditionBlocks, conditionOpen, conditionAtom, afterCondition) = atomize state open condition + (booleanOpen, predicate, afterBoolean) = booleanizeAtom afterCondition conditionOpen conditionAtom + resultId = nextTemporary afterBoolean + resultName = ResolvedName (SymbolId resultId) (Identifier ("$conditional" ++ show resultId)) + initializedOpen = + appendInstruction + booleanOpen + (CorePrepBind resultName valueType True (CorePrepCopy (neutralAtom valueType))) + trueId = nextBlock afterBoolean + falseId = trueId + 1 + joinId = falseId + 1 + afterReservation = + afterBoolean + { nextTemporary = resultId + 1 + , nextBlock = joinId + 1 + } + header = closeBlock initializedOpen (CorePrepBranch predicate trueId falseId) + (trueBlocks, trueExit, afterTrue) = prepareArm afterReservation trueId whenTrue + (falseBlocks, falseExit, afterFalse) = prepareArm afterTrue falseId whenFalse + prepareArm armState armId arm = + let (armBlocks, armOpen, armAtom, afterArm) = atomize armState (OpenBlock armId []) arm + assigned = appendInstruction armOpen (CorePrepAssign resultName armAtom) + in (armBlocks, closeBlock assigned (CorePrepJump joinId), afterArm) + in ( conditionBlocks ++ [header] ++ trueBlocks ++ [trueExit] ++ falseBlocks ++ [falseExit] + , OpenBlock joinId [] + , CorePrepVariable resultName valueType + , afterFalse + ) + +-- | Literal that initializes a storage slot before its first real assignment. +neutralAtom :: Type -> CorePrepAtom +neutralAtom valueType + | valueType == boolType = CorePrepLiteral (CoreBoolean False) valueType + | otherwise = zeroAtom valueType + +{- | Zero of a numeric type, spelled as the native adapter spells its slot +initializer: a floating zero is a floating literal, not an integer payload +under a floating type. +-} +zeroAtom :: Type -> CorePrepAtom +zeroAtom valueType + | isCoreFloatingType valueType = CorePrepLiteral (CoreFloating "0") valueType + | otherwise = CorePrepLiteral (CoreInteger 0) valueType + +atomizeMany :: PrepState -> OpenBlock -> [CoreExpression] -> ([CorePrepBlock], OpenBlock, [CorePrepAtom], PrepState) +atomizeMany state open [] = ([], open, [], state) +atomizeMany state open (value : remaining) = + let (closed, continued, atom, after) = atomize state open value + (laterBlocks, finalOpen, atoms, final) = atomizeMany after continued remaining + in (closed ++ laterBlocks, finalOpen, atom : atoms, final) + +atomizeCaptures :: + PrepState -> + OpenBlock -> + [CoreCapture] -> + ([CorePrepBlock], OpenBlock, [CorePrepCapture], PrepState) +atomizeCaptures state open [] = ([], open, [], state) +atomizeCaptures state open (capture : remaining) = + let (closed, continued, atom, afterValue) = atomize state open (coreCaptureValue capture) + prepared = + CorePrepCapture + (coreCaptureMode capture) + (coreCaptureName capture) + (coreCaptureType capture) + atom + (laterBlocks, finalOpen, laterCaptures, final) = atomizeCaptures afterValue continued remaining + in (closed ++ laterBlocks, finalOpen, prepared : laterCaptures, final)
+ src/Progmasoft/Tala/Core/CorePrep/Verifier.hs view
@@ -0,0 +1,311 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Structural verifier for lowered CorePrep control flow and storage. +Verification is required after decoding artifacts and before native lowering. +-} +module Progmasoft.Tala.Core.CorePrep.Verifier (verifyCorePrep) where + +import Data.IntSet qualified as IntSet +import Data.Set qualified as Set +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core qualified as Core +import Progmasoft.Tala.Core.CorePrep +import Progmasoft.Tala.Core.Template +import Progmasoft.Tala.Diagnostic +import Progmasoft.Tala.RuntimeCall + +-- | Return the unchanged module when valid, or every discovered invariant error. +verifyCorePrep :: CorePrepModule -> Either [Diagnostic] CorePrepModule +verifyCorePrep moduleValue = + let problems = + duplicateFunctions (corePrepModuleFunctions moduleValue) + ++ concatMap verifyFunction (corePrepModuleFunctions moduleValue) + in if null problems then Right moduleValue else Left problems + +duplicateFunctions :: [CorePrepFunction] -> [Diagnostic] +duplicateFunctions functions = duplicateIds "TAC0001" "duplicate CorePrep function symbol" (map (resolvedSymbol . corePrepFunctionName) functions) + +verifyFunction :: CorePrepFunction -> [Diagnostic] +verifyFunction function = + let blocks = corePrepFunctionBlocks function + blockIds = map corePrepBlockId blocks + parameterIds = map (resolvedSymbol . fst) (corePrepFunctionParameters function) + definitionIds = concatMap blockDefinitions blocks + in missingEntry blockIds + ++ verifyType "function result" (corePrepFunctionReturnType function) + ++ concatMap (verifyParameterType . snd) (corePrepFunctionParameters function) + ++ duplicateIds "TAC0003" "duplicate CorePrep block id" blockIds + ++ duplicateIds "TAC0004" "duplicate CorePrep parameter symbol" parameterIds + ++ duplicateIds "TAC0005" "CorePrep symbol is defined more than once" (parameterIds ++ definitionIds) + ++ concatMap (verifyBlock (IntSet.fromList blockIds)) blocks + where + verifyParameterType = verifyType "function parameter" + missingEntry ids = + if corePrepFunctionEntry function `elem` ids + then [] + else [problem "TAC0002" "CorePrep function entry block does not exist"] + +blockDefinitions :: CorePrepBlock -> [SymbolId] +blockDefinitions block = [resolvedSymbol name | CorePrepBind name _ _ _ <- corePrepBlockInstructions block] + +verifyBlock :: IntSet.IntSet -> CorePrepBlock -> [Diagnostic] +verifyBlock blockIds block = + concatMap verifyInstruction (corePrepBlockInstructions block) + ++ verifyTerminator blockIds (corePrepBlockTerminator block) + +verifyInstruction :: CorePrepInstruction -> [Diagnostic] +verifyInstruction instruction = case instruction of + CorePrepBind _ valueType _ operation -> verifyType "binding" valueType ++ verifyOperation valueType operation + CorePrepAssign _ atom -> verifyAtom atom + CorePrepEvaluate operation -> verifyOperation ErrorType operation + +verifyOperation :: Type -> CorePrepOperation -> [Diagnostic] +verifyOperation resultType operation = case operation of + CorePrepCopy atom -> verifyAtom atom ++ resultMismatch (atomType atom) + CorePrepCall callee arguments -> verifyAtom callee ++ concatMap verifyAtom arguments + CorePrepPrimitive primitive atoms -> concatMap verifyAtom atoms ++ verifyPrimitive primitive atoms resultType + CorePrepMakeClosure function captures -> + invalidFunction function + ++ concatMap verifyCapture captures + ++ closureResultMismatch resultType + where + resultMismatch valueType = + if resultType == ErrorType || resultType == valueType + then [] + else [problem "TAC0006" "CorePrep copy result type does not match its atom"] + invalidFunction name = [problem "TAC0013" "CorePrep closure function symbol must be positive" | symbolIdValue (resolvedSymbol name) <= 0] + closureResultMismatch valueType = case valueType of + FunctionType _ _ -> [] + ErrorType -> [] + _ -> [problem "TAC0014" "CorePrep closure result must have a callable type"] + +verifyCapture :: CorePrepCapture -> [Diagnostic] +verifyCapture (CorePrepCapture mode name valueType atom) = + [problem "TAC0015" "CorePrep capture symbol must be positive" | symbolIdValue (resolvedSymbol name) <= 0] + ++ [problem "TAC0016" "CorePrep capture has an unresolved type" | valueType == ErrorType] + ++ [problem "TAC0017" "CorePrep capture atom type does not match its slot" | atomType atom /= valueType] + ++ [ problem "TAC0018" "non-owning capture requires an AARC reference value" + | mode /= StrongCapture && not (aarcReference valueType) + ] + ++ verifyType "capture" valueType + ++ verifyAtom atom + where + -- Core currently lacks nominal-declaration metadata, so every resolved + -- named type remains conservatively reference-like at this boundary. + aarcReference value = case value of + FunctionType _ _ -> True + NamedType _ _ -> value /= unitType && value /= boolType && value /= intType + _ -> False + +verifyPrimitive :: Core.CorePrimitive -> [CorePrepAtom] -> Type -> [Diagnostic] +verifyPrimitive Core.CoreRuntimeCall atoms resultType = + -- The first atom names the function; the rest are its arguments. + case runtimeCallDefect named (map atomType (drop 1 atoms)) resultType of + Just defect -> [problem "TAC0026" ("CorePrep " ++ runtimeDefectText defect)] + Nothing -> [] + where + named = case atoms of + CorePrepLiteral (Core.CoreInteger identity) valueType : _ | valueType == intType -> runtimeFunctionOf identity + _ -> Nothing +verifyPrimitive primitive atoms resultType + | length atoms /= expectedArity = [problem "TAC0007" "CorePrep primitive has the wrong arity"] + | any ((== ErrorType) . atomType) atoms = [problem "TAC0008" "CorePrep primitive contains an unresolved type"] + | otherwise = operandProblems ++ resultProblems + where + expectedArity = + if primitive `elem` [Core.CoreNegate, Core.CoreLogicalNot, Core.CoreBitwiseNot, Core.CoreMemoize] then 1 else 2 + comparisonOrLogical = + if primitive + `elem` [ Core.CoreLessThan + , Core.CoreLessEqual + , Core.CoreGreaterThan + , Core.CoreGreaterEqual + , Core.CoreEqual + , Core.CoreNotEqual + , Core.CoreLogicalAnd + , Core.CoreLogicalOr + , Core.CoreLogicalNot + , Core.CoreTypeIs + ] + then True + else False + operandTypes = map atomType atoms + firstType = case operandTypes of valueType : _ -> valueType; [] -> ErrorType + operandsAgree = all (== firstType) operandTypes + logical = primitive `elem` [Core.CoreLogicalAnd, Core.CoreLogicalOr, Core.CoreLogicalNot] + integerOnly = + primitive + `elem` [ Core.CoreShiftLeft + , Core.CoreShiftRight + , Core.CoreBitwiseAnd + , Core.CoreBitwiseXor + , Core.CoreBitwiseOr + , Core.CoreBitwiseNot + ] + numeric = all isNumericType operandTypes + integer = all isIntegerType operandTypes + booleanContext = all (\valueType -> valueType == boolType || isNumericType valueType) operandTypes + negatable = isSignedIntegerType firstType || isFloatingType firstType + operandProblems + | primitive == Core.CoreTypeIs = case operandTypes of + [subjectType, identityType] + | referenceLike subjectType && typeSpelling identityType == "uint" -> [] + | otherwise -> [problem "TAC0024" "CorePrep type test requires a reference subject and uint identity"] + _ -> [] + | primitive == Core.CoreMemoize = case operandTypes of + [FunctionType [] result] | result == boolType || isNumericType result -> [] + _ -> + [ problem + "TAC0025" + "CorePrep memoization requires a callable without parameters whose result is bool or numeric" + ] + | not operandsAgree = [problem "TAC0019" "CorePrep primitive operand types do not agree"] + | logical && not booleanContext = [problem "TAC0020" "CorePrep logical primitive requires bool or numeric operands"] + | integerOnly && not integer = [problem "TAC0022" "CorePrep bitwise primitive requires integer operands"] + | primitive == Core.CoreNegate && not negatable = + [problem "TAC0021" "CorePrep negation requires a signed integer or floating operand"] + | not logical && not numeric && primitive `notElem` [Core.CoreEqual, Core.CoreNotEqual] = + [problem "TAC0022" "CorePrep arithmetic or ordering primitive requires numeric operands"] + | otherwise = [] + expectedResult + | comparisonOrLogical = boolType + | primitive == Core.CoreFloorDivide && isFloatingType firstType = intType + | otherwise = firstType + -- Evaluate deliberately discards a primitive's value, so it carries + -- the ErrorType sentinel instead of the primitive's result type. + resultProblems + | resultType == ErrorType = [] + | resultType == expectedResult = [] + | otherwise = [problem "TAC0009" "CorePrep primitive result type is inconsistent"] + referenceLike valueType = case valueType of + FunctionType _ _ -> True + NamedType _ _ -> not (isNumericType valueType) && valueType /= unitType + _ -> False + +verifyTerminator :: IntSet.IntSet -> CorePrepTerminator -> [Diagnostic] +verifyTerminator blockIds terminator = case terminator of + CorePrepReturn atom -> verifyAtom atom + CorePrepBranch atom trueTarget falseTarget -> verifyAtom atom ++ requireBool atom ++ targets [trueTarget, falseTarget] + CorePrepJump target -> targets [target] + CorePrepUnreachable -> [] + where + targets values = + [ problem "TAC0010" "CorePrep terminator targets a missing block" + | any (`IntSet.notMember` blockIds) values + ] + requireBool atom = [problem "TAC0011" "CorePrep branch condition must be bool" | atomType atom /= boolType] + +verifyAtom :: CorePrepAtom -> [Diagnostic] +verifyAtom atom = + [problem "TAC0012" "CorePrep atom has an unresolved type" | atomType atom == ErrorType] + ++ verifyType "atom" (atomType atom) + ++ case atom of + CorePrepLiteral literal valueType -> verifyLiteral literal valueType + CorePrepVariable _ _ -> [] + +verifyLiteral :: Core.CoreLiteral -> Type -> [Diagnostic] +verifyLiteral literal valueType = + [problem "TAC0023" "CorePrep literal payload does not match its declared scalar type" | not matches] + where + matches = case literal of + Core.CoreInteger value -> integerFits valueType value + Core.CoreFloating spelling -> isFloatingType valueType && validFloatingSpelling spelling + Core.CoreString _ -> valueType == stringType + Core.CoreBoolean _ -> valueType == boolType + Core.CoreUnit -> valueType == unitType + Core.CoreNull -> referenceLike valueType + referenceLike value = case value of + FunctionType _ _ -> True + NamedType _ _ -> not (isNumericType value) && value /= unitType + _ -> False + +typeSpelling :: Type -> String +typeSpelling (NamedType (QualifiedName [Identifier name]) []) = name +typeSpelling _ = "" + +integerWidths :: [(String, Bool, Int)] +integerWidths = + [ ("char", False, 32) + , ("byte", True, 8) + , ("short", True, 16) + , ("long", True, 32) + , ("int", True, 64) + , ("longint", True, 128) + , ("ubyte", False, 8) + , ("ushort", False, 16) + , ("ulong", False, 32) + , ("uint", False, 64) + , ("ulongint", False, 128) + ] + +integerFits :: Type -> Integer -> Bool +integerFits valueType value = case [(signed, width) | (name, signed, width) <- integerWidths, name == typeSpelling valueType] of + [(True, width)] -> value >= negate (2 ^ (width - 1)) && value <= 2 ^ (width - 1) - 1 + [(False, width)] -> value >= 0 && value <= 2 ^ width - 1 + _ -> False + +isIntegerType :: Type -> Bool +isIntegerType valueType = any (\(name, _, _) -> name == typeSpelling valueType) integerWidths + +isSignedIntegerType :: Type -> Bool +isSignedIntegerType valueType = any (\(name, signed, _) -> signed && name == typeSpelling valueType) integerWidths + +isFloatingType :: Type -> Bool +isFloatingType valueType = typeSpelling valueType `elem` ["sfloat", "lfloat", "float", "double"] + +isNumericType :: Type -> Bool +isNumericType valueType = isIntegerType valueType || isFloatingType valueType + +validFloatingSpelling :: String -> Bool +validFloatingSpelling spelling + | spelling `elem` ["nan", "+nan", "-nan", "inf", "+inf", "-inf"] = True + | otherwise = case stripSign spelling of + [] -> False + unsignedSpelling -> + let (mantissa, exponentPart) = break (`elem` "eE") unsignedSpelling + in validSignificand mantissa && validExponent exponentPart + where + stripSign ('+' : remaining) = remaining + stripSign ('-' : remaining) = remaining + stripSign value = value + validSignificand value = case break (== '.') value of + (whole, []) -> not (null whole) && all digit whole + (whole, _ : fraction) -> (not (null whole) || not (null fraction)) && all digit whole && all digit fraction + validExponent [] = True + validExponent (_ : remaining) = case stripSign remaining of + [] -> False + digits -> all digit digits + digit character = character >= '0' && character <= '9' + +atomType :: CorePrepAtom -> Type +atomType atom = case atom of CorePrepVariable _ valueType -> valueType; CorePrepLiteral _ valueType -> valueType + +-- CorePrep may be constructed directly by tests and tooling, so it cannot +-- rely on the Core verifier having run. Revalidating structural template keys +-- here makes the stage boundary self-contained and protects Xpp lowering from +-- malformed fixed-array and value-parameter payloads. +verifyType :: String -> Type -> [Diagnostic] +verifyType context valueType = map templateProblem (validateTemplateType 128 valueType) + where + templateProblem issue = + problem + "TAC0024" + ( "invalid CorePrep " + ++ context + ++ " template type at " + ++ renderPath (templateIssuePath issue) + ++ ": " + ++ templateIssueMessage issue + ) + renderPath [] = "the type root" + renderPath indexes = "argument " ++ concatMap (\index -> "[" ++ show index ++ "]") indexes + +-- A function may have tens of thousands of blocks and symbols, so the +-- distinct values are counted through a set rather than by comparing every +-- pair. +duplicateIds :: (Ord a) => String -> String -> [a] -> [Diagnostic] +duplicateIds code message values = [problem code message | length values /= Set.size (Set.fromList values)] + +problem :: String -> String -> Diagnostic +problem code message = Diagnostic CorePrepStage Error code Nothing message
+ src/Progmasoft/Tala/Core/CorePrep/Wire.hs view
@@ -0,0 +1,23 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Public facade combining CorePrep wire encoding, decoding, and schema types. +The binary format is an internal compiler boundary and is not a user-facing +emission format. +-} +module Progmasoft.Tala.Core.CorePrep.Wire + ( encodeCorePrep + , encodeCorePrepWith + , decodeCorePrep + , decodeCorePrepWith + , WireVersion (..) + , currentWireVersion + , WireLimits (..) + , defaultWireLimits + , WireErrorKind (..) + , WireError (..) + ) where + +import Progmasoft.Tala.Core.CorePrep.Wire.Decode +import Progmasoft.Tala.Core.CorePrep.Wire.Encode +import Progmasoft.Tala.Core.CorePrep.Wire.Format
+ src/Progmasoft/Tala/Core/CorePrep/Wire/Decode.hs view
@@ -0,0 +1,421 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Strict bounded decoder for untrusted CorePrep wire documents. + +Every count, scalar, nesting depth, version, and trailing byte is validated +before the decoded module is returned to native compiler code. +-} +module Progmasoft.Tala.Core.CorePrep.Wire.Decode (decodeCorePrep, decodeCorePrepWith) where + +import Data.Bits (Bits, shiftL, (.|.)) +import Data.Char (chr) +import Data.Word (Word16, Word32, Word64, Word8) +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.CorePrep +import Progmasoft.Tala.Core.CorePrep.Wire.Format + +data DecoderState = DecoderState + { remainingBytes :: [Word8] + , consumedBytes :: Int + , decoderLimits :: WireLimits + } + +newtype Decoder a = Decoder {runDecoder :: DecoderState -> Either WireError (a, DecoderState)} + +instance Functor Decoder where + fmap transform parser = Decoder $ \state -> do + (value, next) <- runDecoder parser state + pure (transform value, next) + +instance Applicative Decoder where + pure value = Decoder $ \state -> Right (value, state) + functionParser <*> valueParser = Decoder $ \state -> do + (function, afterFunction) <- runDecoder functionParser state + (value, afterValue) <- runDecoder valueParser afterFunction + pure (function value, afterValue) + +instance Monad Decoder where + parser >>= nextParser = Decoder $ \state -> do + (value, afterValue) <- runDecoder parser state + runDecoder (nextParser value) afterValue + +-- | Decode using the standard finite wire limits. +decodeCorePrep :: [Word8] -> Either WireError CorePrepModule +decodeCorePrep = decodeCorePrepWith defaultWireLimits + +-- | Decode using caller-selected limits and reject incomplete or trailing data. +decodeCorePrepWith :: WireLimits -> [Word8] -> Either WireError CorePrepModule +decodeCorePrepWith limits bytes + | length bytes > maximumWireBytes limits = + Left (wireError LimitExceeded 0 "wire byte length" "input exceeds configured byte limit") + | otherwise = do + (moduleValue, finalState) <- runDecoder decodeDocument (DecoderState bytes 0 limits) + if null (remainingBytes finalState) + then Right moduleValue + else Left (wireError TrailingInput (consumedBytes finalState) "document" "bytes remain after CorePrep module") + +decodeDocument :: Decoder CorePrepModule +decodeDocument = do + magic <- takeBytes "magic" 4 + require (magic == wireMagic) InvalidMagic "magic" "input is not a Tala CorePrep wire document" + version <- readWord16 "version" + require + (version == wireVersionNumber currentWireVersion) + UnsupportedVersion + "version" + ("unsupported CorePrep wire version " ++ show version) + flags <- readWord16 "flags" + require (flags == 0) InvalidTag "flags" "reserved wire flags must be zero" + decodeModule + +decodeModule :: Decoder CorePrepModule +decodeModule = do + name <- decodeQualifiedName + sources <- decodeVector "source file count" maximumFunctions (decodeText "source file") + functions <- decodeVector "function count" maximumFunctions decodeFunction + pure (CorePrepModule name functions sources) + +decodeFunction :: Decoder CorePrepFunction +decodeFunction = + CorePrepFunction + <$> decodeResolvedName "function symbol" + <*> decodeText "function source file" + <*> decodeVector "parameter count" maximumParametersPerFunction decodeParameter + <*> decodeType + <*> decodeBlockId "entry block" + <*> decodeVector "block count" maximumBlocksPerFunction decodeBlock + +decodeParameter :: Decoder (ResolvedName, Type) +decodeParameter = (,) <$> decodeResolvedName "parameter symbol" <*> decodeType + +decodeBlock :: Decoder CorePrepBlock +decodeBlock = + CorePrepBlock + <$> decodeBlockId "block id" + <*> decodeVector "instruction count" maximumInstructionsPerBlock decodeInstruction + <*> decodeTerminator + +decodeInstruction :: Decoder CorePrepInstruction +decodeInstruction = do + tag <- readWord8 "instruction tag" + case tag of + 0 -> + CorePrepBind + <$> decodeResolvedName "binding symbol" + <*> decodeType + <*> decodeBool "binding mutability" + <*> decodeOperation + 1 -> CorePrepAssign <$> decodeResolvedName "assignment symbol" <*> decodeAtom + 2 -> CorePrepEvaluate <$> decodeOperation + _ -> invalidTag "instruction tag" tag + +decodeOperation :: Decoder CorePrepOperation +decodeOperation = do + tag <- readWord8 "operation tag" + case tag of + 18 -> + CorePrepMakeClosure + <$> decodeResolvedName "closure function symbol" + <*> decodeVector "closure capture count" maximumOperandsPerInstruction decodeCapture + _ -> do + atoms <- decodeVector "operand count" maximumOperandsPerInstruction decodeAtom + case tag of + 0 -> case atoms of [atom] -> pure (CorePrepCopy atom); _ -> invalidArity "copy" 1 (length atoms) + 1 -> case atoms of callee : arguments -> pure (CorePrepCall callee arguments); [] -> invalidArity "call" 1 0 + _ -> case tagPrimitive tag of + Just primitive -> pure (CorePrepPrimitive primitive atoms) + Nothing -> invalidTag "operation tag" tag + +decodeCapture :: Decoder CorePrepCapture +decodeCapture = do + mode <- readWord8 "capture mode" >>= decodeCaptureMode + name <- decodeResolvedName "capture symbol" + valueType <- decodeType + atom <- decodeAtom + pure (CorePrepCapture mode name valueType atom) + +decodeCaptureMode :: Word8 -> Decoder CaptureMode +decodeCaptureMode tag = case tag of + 0 -> pure StrongCapture + 1 -> pure WeakCapture + 2 -> pure UnownedCapture + _ -> invalidTag "capture mode" tag + +decodeAtom :: Decoder CorePrepAtom +decodeAtom = do + tag <- readWord8 "atom tag" + valueType <- decodeType + case tag of + 0 -> CorePrepVariable <$> decodeResolvedName "variable symbol" <*> pure valueType + 1 -> CorePrepLiteral <$> decodeLiteral valueType <*> pure valueType + _ -> invalidTag "atom tag" tag + +decodeLiteral :: Type -> Decoder CoreLiteral +decodeLiteral valueType = do + tag <- readWord8 "literal tag" + case tag of + 0 | valueType == unitType -> pure CoreUnit + 1 | valueType == boolType -> CoreBoolean <$> decodeBool "boolean literal" + 2 | typeName valueType == "char" || typeName valueType `elem` integerTypeNames -> CoreInteger <$> decodeInteger + 3 | valueType == stringType -> CoreString <$> decodeText "string literal" + 4 | typeName valueType `elem` floatingTypeNames -> CoreFloating <$> decodeAscii "floating literal" + 5 | referenceLike valueType -> pure CoreNull + _ -> failAt UnsupportedType "literal" "literal tag does not match its declared type" + where + referenceLike value = case value of + FunctionType _ _ -> True + NamedType _ _ -> typeName value `notElem` integerTypeNames ++ floatingTypeNames ++ ["char", "bool", "unit"] + _ -> False + +decodeTerminator :: Decoder CorePrepTerminator +decodeTerminator = do + tag <- readWord8 "terminator tag" + case tag of + 0 -> CorePrepReturn <$> decodeAtom + 1 -> CorePrepBranch <$> decodeAtom <*> decodeBlockId "true target" <*> decodeBlockId "false target" + 2 -> CorePrepJump <$> decodeBlockId "jump target" + 3 -> pure CorePrepUnreachable + _ -> invalidTag "terminator tag" tag + +decodeResolvedName :: String -> Decoder ResolvedName +decodeResolvedName context = do + raw <- readWord64 context + require (raw > 0) InvalidSymbol context "symbol id must be positive" + require (raw <= fromIntegral (maxBound :: Int)) InvalidSymbol context "symbol id exceeds host Int range" + spelling <- decodeText (context ++ " spelling") + pure (ResolvedName (SymbolId (fromIntegral raw)) (Identifier spelling)) + +decodeQualifiedName :: Decoder QualifiedName +decodeQualifiedName = + QualifiedName + <$> decodeVectorWithMaximum + "qualified name part count" + 65535 + (Identifier <$> decodeText "qualified name part") + +decodeType :: Decoder Type +decodeType = decodeTypeAt 0 + +decodeTypeAt :: Int -> Decoder Type +decodeTypeAt depth = do + limits <- currentLimits + require (depth <= maximumTypeDepth limits) LimitExceeded "type" "type nesting exceeds configured limit" + tag <- readWord8 "type tag" + case tag of + 0 -> pure unitType + 1 -> pure boolType + 2 -> pure intType + 4 -> pure stringType + 3 -> pure (namedScalar "long") + 5 -> + FunctionType + <$> decodeVectorWithMaximum "function type parameter count" 65535 (decodeTypeAt (depth + 1)) + <*> decodeTypeAt (depth + 1) + 6 -> + NamedType + <$> decodeQualifiedName + <*> decodeVectorWithMaximum "template argument count" 65535 (decodeTemplateArgument (depth + 1)) + 7 -> TypeVariable <$> decodeResolvedName "type variable symbol" + 8 -> pure (namedScalar "char") + 9 -> pure (namedScalar "byte") + 10 -> pure (namedScalar "short") + 11 -> pure (namedScalar "longint") + 12 -> pure (namedScalar "ubyte") + 13 -> pure (namedScalar "ushort") + 14 -> pure (namedScalar "ulong") + 15 -> pure (namedScalar "uint") + 16 -> pure (namedScalar "ulongint") + 17 -> pure (namedScalar "sfloat") + 18 -> pure (namedScalar "lfloat") + 19 -> pure (namedScalar "float") + 20 -> pure (namedScalar "double") + _ -> invalidTag "type tag" tag + +decodeTemplateArgument :: Int -> Decoder TemplateArgument +decodeTemplateArgument depth = do + tag <- readWord8 "template argument tag" + case tag of + 0 -> TypeTemplateArgument <$> decodeTypeAt depth + 1 -> ValueTemplateArgument . IntegerTemplateValue <$> decodeInteger + 2 -> ValueTemplateArgument . BooleanTemplateValue <$> decodeBool "template boolean value" + 3 -> ValueTemplateArgument . CharacterTemplateValue <$> decodeInteger + 4 -> ValueTemplateArgument . TemplateValueParameter <$> decodeResolvedName "template value parameter" + _ -> invalidTag "template argument tag" tag + +namedScalar :: String -> Type +namedScalar name = NamedType (QualifiedName [Identifier name]) [] + +typeName :: Type -> String +typeName (NamedType (QualifiedName [Identifier name]) []) = name +typeName _ = "" + +integerTypeNames :: [String] +integerTypeNames = ["byte", "short", "long", "int", "longint", "ubyte", "ushort", "ulong", "uint", "ulongint"] + +floatingTypeNames :: [String] +floatingTypeNames = ["sfloat", "lfloat", "float", "double"] + +decodeBlockId :: String -> Decoder Int +decodeBlockId context = fromIntegral <$> readWord32 context + +decodeVector :: String -> (WireLimits -> Int) -> Decoder a -> Decoder [a] +decodeVector context selectLimit parser = do + limits <- currentLimits + decodeVectorWithMaximum context (selectLimit limits) parser + +decodeVectorWithMaximum :: String -> Int -> Decoder a -> Decoder [a] +decodeVectorWithMaximum context maximumCount parser = do + rawCount <- readWord32 context + require + (toInteger rawCount <= toInteger maximumCount) + LimitExceeded + context + ("count " ++ show rawCount ++ " exceeds limit " ++ show maximumCount) + sequence (replicate (fromIntegral rawCount) parser) + +decodeText :: String -> Decoder String +decodeText context = do + limits <- currentLimits + count <- readWord32 (context ++ " length") + require + (toInteger count <= toInteger (maximumStringCodePoints limits)) + LimitExceeded + context + "text exceeds configured code point limit" + sequence (replicate (fromIntegral count) (decodeCodePoint context)) + +decodeInteger :: Decoder Integer +decodeInteger = do + negative <- decodeBool "integer sign" + limits <- currentLimits + count <- readWord32 "integer magnitude length" + require + (toInteger count <= toInteger (maximumNumericBytes limits)) + LimitExceeded + "integer magnitude" + "integer magnitude exceeds configured byte limit" + magnitude <- takeBytes "integer magnitude" (fromIntegral count) + require (canonicalMagnitude magnitude) InvalidInteger "integer magnitude" "integer magnitude is not canonical" + require (not negative || not (null magnitude)) InvalidInteger "integer sign" "zero cannot have a negative sign" + let value = foldl (\result octet -> result * 256 + fromIntegral octet) 0 magnitude + pure (if negative then negate value else value) + where + canonicalMagnitude [] = True + canonicalMagnitude (first : _) = first /= 0 + +decodeAscii :: String -> Decoder String +decodeAscii context = do + limits <- currentLimits + count <- readWord32 (context ++ " length") + require + (toInteger count <= toInteger (maximumNumericBytes limits)) + LimitExceeded + context + "numeric spelling exceeds configured byte limit" + bytes <- takeBytes context (fromIntegral count) + require (all (<= 0x7f) bytes) InvalidInteger context "numeric spelling must contain ASCII characters only" + pure (map (chr . fromIntegral) bytes) + +decodeCodePoint :: String -> Decoder Char +decodeCodePoint context = do + value <- readWord32 context + require + (value <= 0x10ffff && not (value >= 0xd800 && value <= 0xdfff)) + InvalidCodePoint + context + "wire text contains a non-scalar Unicode code point" + pure (chr (fromIntegral value)) + +decodeBool :: String -> Decoder Bool +decodeBool context = do + value <- readWord8 context + case value of + 0 -> pure False + 1 -> pure True + _ -> failAt InvalidBoolean context ("invalid boolean byte " ++ show value) + +tagPrimitive :: Word8 -> Maybe CorePrimitive +tagPrimitive tag = case tag of + 2 -> Just CoreAdd + 3 -> Just CoreSubtract + 4 -> Just CoreMultiply + 5 -> Just CoreDivide + 6 -> Just CoreFloorDivide + 7 -> Just CoreRemainder + 8 -> Just CoreLessThan + 9 -> Just CoreLessEqual + 10 -> Just CoreGreaterThan + 11 -> Just CoreGreaterEqual + 12 -> Just CoreEqual + 13 -> Just CoreNotEqual + 14 -> Just CoreLogicalAnd + 15 -> Just CoreLogicalOr + 16 -> Just CoreNegate + 17 -> Just CoreLogicalNot + 19 -> Just CorePower + 20 -> Just CoreShiftLeft + 21 -> Just CoreShiftRight + 22 -> Just CoreBitwiseAnd + 23 -> Just CoreBitwiseXor + 24 -> Just CoreBitwiseOr + 25 -> Just CoreBitwiseNot + 26 -> Just CoreTypeIs + 27 -> Just CoreMemoize + 28 -> Just CoreRuntimeCall + _ -> Nothing + +invalidTag :: String -> Word8 -> Decoder a +invalidTag context tag = failAt InvalidTag context ("unknown tag " ++ show tag) + +invalidArity :: String -> Int -> Int -> Decoder a +invalidArity context expected actual = + failAt + InvalidCount + context + ("expected " ++ show expected ++ " operand(s), found " ++ show actual) + +currentLimits :: Decoder WireLimits +currentLimits = Decoder $ \state -> Right (decoderLimits state, state) + +require :: Bool -> WireErrorKind -> String -> String -> Decoder () +require condition kind context message = if condition then pure () else failAt kind context message + +failAt :: WireErrorKind -> String -> String -> Decoder a +failAt kind context message = Decoder $ \state -> Left (wireError kind (consumedBytes state) context message) + +takeBytes :: String -> Int -> Decoder [Word8] +takeBytes context count = Decoder $ \state -> + let (prefix, suffix) = splitAt count (remainingBytes state) + in if length prefix == count + then Right (prefix, state {remainingBytes = suffix, consumedBytes = consumedBytes state + count}) + else + Left + ( wireError + TruncatedInput + (consumedBytes state) + context + ("needed " ++ show count ++ " byte(s), found " ++ show (length prefix)) + ) + +readWord8 :: String -> Decoder Word8 +readWord8 context = do + bytes <- takeBytes context 1 + case bytes of + [value] -> pure value + _ -> failAt TruncatedInput context "byte reader received an empty result" + +readWord16 :: String -> Decoder Word16 +readWord16 context = assemble <$> takeBytes context 2 + +readWord32 :: String -> Decoder Word32 +readWord32 context = assemble <$> takeBytes context 4 + +readWord64 :: String -> Decoder Word64 +readWord64 context = assemble <$> takeBytes context 8 + +assemble :: (Integral a, Bits a) => [Word8] -> a +assemble bytes = foldr combine 0 (zip [0 ..] bytes) + where + combine (index, value) result = result .|. (fromIntegral value `shiftL` (index * 8))
+ src/Progmasoft/Tala/Core/CorePrep/Wire/Encode.hs view
@@ -0,0 +1,392 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Bounded encoder for the private CorePrep interchange document. + +The encoder validates collection and byte limits while constructing the +complete document, so callers receive either one valid byte vector or a +structured error without partial output. +-} +module Progmasoft.Tala.Core.CorePrep.Wire.Encode (encodeCorePrep, encodeCorePrepWith) where + +import Data.Bits (Bits, shiftR, (.&.)) +import Data.Char (ord) +import Data.List (unfoldr) +import Data.Word (Word16, Word32, Word64, Word8) +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.CorePrep +import Progmasoft.Tala.Core.CorePrep.Wire.Format + +type Encoder = Either WireError [Word8] + +-- | Encode with the shared default resource bounds. +encodeCorePrep :: CorePrepModule -> Either WireError [Word8] +encodeCorePrep = encodeCorePrepWith defaultWireLimits + +-- | Encode under explicit limits, including the final serialized size. +encodeCorePrepWith :: WireLimits -> CorePrepModule -> Either WireError [Word8] +encodeCorePrepWith limits moduleValue = do + payload <- encodeModule limits moduleValue + let bytes = wireMagic ++ word16 (wireVersionNumber currentWireVersion) ++ word16 0 ++ payload + requireLimit limits "wire byte length" (maximumWireBytes limits) (length bytes) + pure bytes + +encodeModule :: WireLimits -> CorePrepModule -> Encoder +encodeModule limits moduleValue = do + name <- encodeQualifiedName limits (corePrepModuleName moduleValue) + sources <- + encodeVector + limits + "source file count" + (maximumFunctions limits) + (encodeText limits "source file") + (corePrepModuleSourceFiles moduleValue) + functions <- + encodeVector + limits + "function count" + (maximumFunctions limits) + (encodeFunction limits) + (corePrepModuleFunctions moduleValue) + pure (name ++ sources ++ functions) + +encodeFunction :: WireLimits -> CorePrepFunction -> Encoder +encodeFunction limits function = do + name <- encodeResolvedName limits "function symbol" (corePrepFunctionName function) + source <- encodeText limits "function source file" (corePrepFunctionSourceFile function) + parameters <- + encodeVector + limits + "parameter count" + (maximumParametersPerFunction limits) + (encodeParameter limits) + (corePrepFunctionParameters function) + result <- encodeType limits (corePrepFunctionReturnType function) + entry <- encodeNonNegative32 "entry block" (corePrepFunctionEntry function) + blocks <- + encodeVector + limits + "block count" + (maximumBlocksPerFunction limits) + (encodeBlock limits) + (corePrepFunctionBlocks function) + pure (name ++ source ++ parameters ++ result ++ entry ++ blocks) + +encodeParameter :: WireLimits -> (ResolvedName, Type) -> Encoder +encodeParameter limits (name, valueType) = do + encodedName <- encodeResolvedName limits "parameter symbol" name + encodedType <- encodeType limits valueType + pure (encodedName ++ encodedType) + +encodeBlock :: WireLimits -> CorePrepBlock -> Encoder +encodeBlock limits block = do + identifier <- encodeNonNegative32 "block id" (corePrepBlockId block) + instructions <- + encodeVector + limits + "instruction count" + (maximumInstructionsPerBlock limits) + (encodeInstruction limits) + (corePrepBlockInstructions block) + terminator <- encodeTerminator limits (corePrepBlockTerminator block) + pure (identifier ++ instructions ++ terminator) + +encodeInstruction :: WireLimits -> CorePrepInstruction -> Encoder +encodeInstruction limits instruction = case instruction of + CorePrepBind name valueType mutable operation -> do + encodedName <- encodeResolvedName limits "binding symbol" name + encodedType <- encodeType limits valueType + encodedOperation <- encodeOperation limits operation + pure ([0] ++ encodedName ++ encodedType ++ encodeBool mutable ++ encodedOperation) + CorePrepAssign name atom -> do + encodedName <- encodeResolvedName limits "assignment symbol" name + encodedAtom <- encodeAtom limits atom + pure ([1] ++ encodedName ++ encodedAtom) + CorePrepEvaluate operation -> do + encodedOperation <- encodeOperation limits operation + pure ([2] ++ encodedOperation) + +encodeOperation :: WireLimits -> CorePrepOperation -> Encoder +encodeOperation limits operation = case operation of + CorePrepCopy atom -> encodeTaggedAtoms limits 0 [atom] + CorePrepCall callee arguments -> encodeTaggedAtoms limits 1 (callee : arguments) + CorePrepPrimitive primitive arguments -> encodeTaggedAtoms limits (primitiveTag primitive) arguments + CorePrepMakeClosure function captures -> do + encodedFunction <- encodeResolvedName limits "closure function symbol" function + encodedCaptures <- + encodeVector + limits + "closure capture count" + (maximumOperandsPerInstruction limits) + (encodeCapture limits) + captures + pure ([18] ++ encodedFunction ++ encodedCaptures) + +encodeCapture :: WireLimits -> CorePrepCapture -> Encoder +encodeCapture limits (CorePrepCapture mode name valueType atom) = do + encodedName <- encodeResolvedName limits "capture symbol" name + encodedType <- encodeType limits valueType + encodedAtom <- encodeAtom limits atom + pure (captureModeTag mode : encodedName ++ encodedType ++ encodedAtom) + +captureModeTag :: CaptureMode -> Word8 +captureModeTag mode = case mode of + StrongCapture -> 0 + WeakCapture -> 1 + UnownedCapture -> 2 + +encodeTaggedAtoms :: WireLimits -> Word8 -> [CorePrepAtom] -> Encoder +encodeTaggedAtoms limits tag atoms = do + encoded <- encodeVector limits "operand count" (maximumOperandsPerInstruction limits) (encodeAtom limits) atoms + pure (tag : encoded) + +encodeAtom :: WireLimits -> CorePrepAtom -> Encoder +encodeAtom limits atom = case atom of + CorePrepVariable name valueType -> do + encodedName <- encodeResolvedName limits "variable symbol" name + encodedType <- encodeType limits valueType + pure ([0] ++ encodedType ++ encodedName) + CorePrepLiteral literal valueType -> do + encodedType <- encodeType limits valueType + encodedLiteral <- encodeLiteral limits valueType literal + pure ([1] ++ encodedType ++ encodedLiteral) + +encodeLiteral :: WireLimits -> Type -> CoreLiteral -> Encoder +encodeLiteral limits valueType literal = case (primitiveTypeTag valueType, literal) of + (Just 0, CoreUnit) -> pure [0] + (Just 1, CoreBoolean value) -> pure (1 : encodeBool value) + (Just tag, CoreInteger value) + | integerWireTag tag || tag == 8 -> (2 :) <$> encodeInteger limits value + (Just tag, CoreFloating spelling) + | floatingWireTag tag -> (4 :) <$> encodeAscii limits "floating literal" spelling + (Just 4, CoreString value) -> (3 :) <$> encodeText limits "string literal" value + (_, CoreNull) -> pure [5] + _ -> Left (wireError UnsupportedType 0 "literal" "literal payload does not match its declared type") + +encodeTerminator :: WireLimits -> CorePrepTerminator -> Encoder +encodeTerminator limits terminator = case terminator of + CorePrepReturn atom -> do encoded <- encodeAtom limits atom; pure (0 : encoded) + CorePrepBranch atom trueTarget falseTarget -> do + encoded <- encodeAtom limits atom + trueBlock <- encodeNonNegative32 "true target" trueTarget + falseBlock <- encodeNonNegative32 "false target" falseTarget + pure ([1] ++ encoded ++ trueBlock ++ falseBlock) + CorePrepJump target -> do encoded <- encodeNonNegative32 "jump target" target; pure (2 : encoded) + CorePrepUnreachable -> pure [3] + +encodeResolvedName :: WireLimits -> String -> ResolvedName -> Encoder +encodeResolvedName limits context name = do + symbol <- encodePositive64 context (symbolIdValue (resolvedSymbol name)) + spelling <- encodeText limits (context ++ " spelling") (identifierText (resolvedSpelling name)) + pure (symbol ++ spelling) + +encodeQualifiedName :: WireLimits -> QualifiedName -> Encoder +encodeQualifiedName limits (QualifiedName parts) = + encodeVector + limits + "qualified name part count" + 65535 + (encodeText limits "qualified name part" . identifierText) + parts + +encodeType :: WireLimits -> Type -> Encoder +encodeType limits = encodeTypeAt limits 0 + +encodeTypeAt :: WireLimits -> Int -> Type -> Encoder +encodeTypeAt limits depth valueType + | depth > maximumTypeDepth limits = Left (wireError LimitExceeded 0 "type" "type nesting exceeds configured limit") + | Just tag <- primitiveTypeTag valueType = pure [tag] + | NamedType name arguments <- valueType = do + encodedName <- encodeQualifiedName limits name + encodedArguments <- + encodeVector limits "template argument count" 65535 (encodeTemplateArgument limits (depth + 1)) arguments + pure ([6] ++ encodedName ++ encodedArguments) + | FunctionType parameters result <- valueType = do + encodedParameters <- + encodeVector + limits + "function type parameter count" + 65535 + (encodeTypeAt limits (depth + 1)) + parameters + encodedResult <- encodeTypeAt limits (depth + 1) result + pure ([5] ++ encodedParameters ++ encodedResult) + | TypeVariable name <- valueType = do + encodedName <- encodeResolvedName limits "type variable symbol" name + pure ([7] ++ encodedName) + | ErrorType <- valueType = + Left (wireError UnsupportedType 0 "type" "unresolved ErrorType cannot cross the CorePrep boundary") + +encodeTemplateArgument :: WireLimits -> Int -> TemplateArgument -> Encoder +encodeTemplateArgument limits depth argument = case argument of + TypeTemplateArgument valueType -> (0 :) <$> encodeTypeAt limits depth valueType + ValueTemplateArgument value -> encodeTemplateValue limits value + +encodeTemplateValue :: WireLimits -> TemplateValue -> Encoder +encodeTemplateValue limits value = case value of + IntegerTemplateValue integer -> (1 :) <$> encodeInteger limits integer + BooleanTemplateValue boolean -> pure [2, if boolean then 1 else 0] + CharacterTemplateValue scalar -> (3 :) <$> encodeInteger limits scalar + TemplateValueParameter name -> do + encoded <- encodeResolvedName limits "template value parameter" name + pure (4 : encoded) + +primitiveTypeTag :: Type -> Maybe Word8 +primitiveTypeTag valueType + | valueType == unitType = Just 0 + | valueType == boolType = Just 1 + | valueType == stringType = Just 4 + | Just tag <- scalarTypeTag valueType = Just tag + | otherwise = Nothing + +-- Tags 0-7 preserve the v2 structural layout. New scalar tags are append-only, +-- which keeps corrupted-version diagnostics deterministic and makes wire dumps +-- easier to compare while the compiler remains pre-1.0. +scalarTypeTag :: Type -> Maybe Word8 +scalarTypeTag (NamedType (QualifiedName [Identifier name]) []) = lookup name scalarTags +scalarTypeTag _ = Nothing + +scalarTags :: [(String, Word8)] +scalarTags = + [ ("bool", 1) + , ("int", 2) + , ("long", 3) + , ("char", 8) + , ("byte", 9) + , ("short", 10) + , ("longint", 11) + , ("ubyte", 12) + , ("ushort", 13) + , ("ulong", 14) + , ("uint", 15) + , ("ulongint", 16) + , ("sfloat", 17) + , ("lfloat", 18) + , ("float", 19) + , ("double", 20) + ] + +integerWireTag :: Word8 -> Bool +integerWireTag tag = tag `elem` [2, 3, 9, 10, 11, 12, 13, 14, 15, 16] + +floatingWireTag :: Word8 -> Bool +floatingWireTag tag = tag `elem` [17, 18, 19, 20] + +primitiveTag :: CorePrimitive -> Word8 +primitiveTag primitive = case primitive of + CoreAdd -> 2 + CoreSubtract -> 3 + CoreMultiply -> 4 + CoreDivide -> 5 + CoreFloorDivide -> 6 + CoreRemainder -> 7 + CoreLessThan -> 8 + CoreLessEqual -> 9 + CoreGreaterThan -> 10 + CoreGreaterEqual -> 11 + CoreEqual -> 12 + CoreNotEqual -> 13 + CoreLogicalAnd -> 14 + CoreLogicalOr -> 15 + CoreNegate -> 16 + CoreLogicalNot -> 17 + CorePower -> 19 + CoreShiftLeft -> 20 + CoreShiftRight -> 21 + CoreBitwiseAnd -> 22 + CoreBitwiseXor -> 23 + CoreBitwiseOr -> 24 + CoreBitwiseNot -> 25 + CoreTypeIs -> 26 + CoreMemoize -> 27 + CoreRuntimeCall -> 28 + +encodeVector :: WireLimits -> String -> Int -> (a -> Encoder) -> [a] -> Encoder +encodeVector limits context maximumCount encode values = do + requireLimit limits context maximumCount (length values) + encodedCount <- encodeNonNegative32 context (length values) + encodedValues <- traverse encode values + pure (encodedCount ++ concat encodedValues) + +encodeText :: WireLimits -> String -> String -> Encoder +encodeText limits context value = do + requireLimit limits context (maximumStringCodePoints limits) (length value) + count <- encodeNonNegative32 context (length value) + codePoints <- traverse encodeCodePoint value + pure (count ++ concat codePoints) + where + encodeCodePoint character + | code >= 0xD800 && code <= 0xDFFF = + Left (wireError InvalidCodePoint 0 context "surrogate code point is not a scalar value") + | code > 0x10FFFF = Left (wireError InvalidCodePoint 0 context "code point exceeds Unicode range") + | otherwise = Right (word32 (fromIntegral code)) + where + code = ord character + +encodeInteger :: WireLimits -> Integer -> Encoder +encodeInteger limits value = do + let magnitude = integerMagnitude (abs value) + requireLimit limits "integer magnitude" (maximumNumericBytes limits) (length magnitude) + count <- encodeNonNegative32 "integer magnitude length" (length magnitude) + pure (encodeBool (value < 0) ++ count ++ magnitude) + +integerMagnitude :: Integer -> [Word8] +integerMagnitude 0 = [] +integerMagnitude value = reverse (unfoldr step value) + where + step 0 = Nothing + step remaining = Just (fromIntegral (remaining `mod` 256), remaining `div` 256) + +encodeAscii :: WireLimits -> String -> String -> Encoder +encodeAscii limits context value = do + requireLimit limits context (maximumNumericBytes limits) (length value) + count <- encodeNonNegative32 (context ++ " length") (length value) + bytes <- traverse ascii value + pure (count ++ bytes) + where + ascii character + | ord character <= 0x7f = Right (fromIntegral (ord character)) + | otherwise = Left (wireError InvalidInteger 0 context "numeric spelling must contain ASCII characters only") + +encodePositive64 :: String -> Int -> Encoder +encodePositive64 context value + | value <= 0 = Left (wireError InvalidSymbol 0 context "symbol id must be positive") + | otherwise = pure (word64 (fromIntegral value)) + +encodeNonNegative32 :: String -> Int -> Encoder +encodeNonNegative32 context value + | value < 0 || toInteger value > toInteger (maxBound :: Word32) = + Left (wireError InvalidCount 0 context "value does not fit unsigned 32-bit wire field") + | otherwise = pure (word32 (fromIntegral value)) + +encodeBool :: Bool -> [Word8] +encodeBool False = [0] +encodeBool True = [1] + +requireLimit :: WireLimits -> String -> Int -> Int -> Either WireError () +requireLimit _ context maximumValue actual + | actual > maximumValue = + Left (wireError LimitExceeded 0 context ("count " ++ show actual ++ " exceeds limit " ++ show maximumValue)) + | otherwise = Right () + +word16 :: Word16 -> [Word8] +word16 value = [byte value 0, byte value 8] + +word32 :: Word32 -> [Word8] +word32 value = [byte value 0, byte value 8, byte value 16, byte value 24] + +word64 :: Word64 -> [Word8] +word64 value = + [ byte value 0 + , byte value 8 + , byte value 16 + , byte value 24 + , byte value 32 + , byte value 40 + , byte value 48 + , byte value 56 + ] + +byte :: (Integral a, Bits a) => a -> Int -> Word8 +byte value amount = fromIntegral ((value `shiftR` amount) .&. 0xff)
+ src/Progmasoft/Tala/Core/CorePrep/Wire/Format.hs view
@@ -0,0 +1,116 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Constants and bounded error representation for the CorePrep wire format. +The format version is independent of Core and Xpp wire schemas; every decoder +uses these limits before constructing untrusted compiler data. +-} +module Progmasoft.Tala.Core.CorePrep.Wire.Format + ( WireVersion (..) + , currentWireVersion + , wireMagic + , WireLimits (..) + , defaultWireLimits + , WireErrorKind (..) + , WireError (..) + , wireError + ) where + +import Data.Word (Word16, Word8) + +-- | Unsigned schema version encoded in a CorePrep document header. +newtype WireVersion + = -- | Version number compared exactly by decoders. + WireVersion {wireVersionNumber :: Word16} + deriving (Eq, Ord, Read, Show) + +-- | Schema version emitted by current CorePrep encoders. +currentWireVersion :: WireVersion +currentWireVersion = WireVersion 8 + +-- | Four-byte ASCII identifier at the start of each CorePrep document. +wireMagic :: [Word8] +wireMagic = map (fromIntegral . fromEnum) "TACP" + +-- | Resource bounds used before and during wire encoding/decoding. +data WireLimits = WireLimits + { maximumWireBytes :: Int + -- ^ Maximum total document byte size. + , maximumStringCodePoints :: Int + -- ^ Maximum Unicode scalar count in one string. + , maximumFunctions :: Int + -- ^ Maximum functions in a module. + , maximumParametersPerFunction :: Int + -- ^ Maximum arguments or parameters per function. + , maximumBlocksPerFunction :: Int + -- ^ Maximum basic blocks in one function. + , maximumInstructionsPerBlock :: Int + -- ^ Maximum instructions in one block. + , maximumOperandsPerInstruction :: Int + -- ^ Maximum operands on an instruction or terminator. + , maximumTypeDepth :: Int + -- ^ Maximum recursive type nesting. + , maximumNumericBytes :: Int + -- ^ Maximum bytes in an arbitrary-precision numeric payload. + } + deriving (Eq, Ord, Read, Show) + +-- | Default finite bounds shared by normal CorePrep readers and writers. +defaultWireLimits :: WireLimits +defaultWireLimits = + WireLimits + { maximumWireBytes = 64 * 1024 * 1024 + , maximumStringCodePoints = 1024 * 1024 + , maximumFunctions = 65535 + , maximumParametersPerFunction = 65535 + , maximumBlocksPerFunction = 1048576 + , maximumInstructionsPerBlock = 1048576 + , maximumOperandsPerInstruction = 65535 + , maximumTypeDepth = 128 + , maximumNumericBytes = 4096 + } + +-- | Category of a malformed, unsupported, or oversized wire field. +data WireErrorKind + = -- | Header does not contain the expected format tag. + InvalidMagic + | -- | Header version differs from this implementation. + UnsupportedVersion + | -- | Input ended before the current field was complete. + TruncatedInput + | -- | Bytes remain after one complete document. + TrailingInput + | -- | An enum or sum-type tag is not defined by the schema. + InvalidTag + | -- | Boolean payload is not a canonical zero or one. + InvalidBoolean + | -- | Text contains a non-scalar Unicode value. + InvalidCodePoint + | -- | Collection length is malformed or unrepresentable. + InvalidCount + | -- | Symbol identity is invalid or reserved. + InvalidSymbol + | -- | Arbitrary-precision integer encoding is non-canonical. + InvalidInteger + | -- | A CorePrep type has no wire representation. + UnsupportedType + | -- | Configured byte, depth, or element ceiling was crossed. + LimitExceeded + deriving (Eq, Ord, Read, Show) + +-- | Wire failure with byte position, field path, and diagnostic message. +data WireError = WireError + { wireErrorKind :: WireErrorKind + -- ^ Programmatically distinguishable failure category. + , wireErrorOffset :: Int + -- ^ Byte offset where decoding or encoding failed. + , wireErrorContext :: String + -- ^ Nested field path, such as function/block/instruction. + , wireErrorMessage :: String + -- ^ Human-readable explanation for diagnostics. + } + deriving (Eq, Ord, Read, Show) + +-- | Construct a structured wire error without losing source field context. +wireError :: WireErrorKind -> Int -> String -> String -> WireError +wireError = WireError
+ src/Progmasoft/Tala/Core/Monomorphization.hs view
@@ -0,0 +1,252 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Fixed-point specialization-demand planning over verified Core. + +This pass is deliberately earlier than Core optimization and CorePrep. It +proves that every parameterized type visible in the current Core module is a +valid closed specialization and records the nested demands that declaration +instantiation will consume. It does not clone declarations yet; callers must +not confuse a successful demand plan with a completed template implementation. +-} +module Progmasoft.Tala.Core.Monomorphization + ( module Progmasoft.Tala.Core.Monomorphization.Types + , module Progmasoft.Tala.Core.Monomorphization.Graph + , TypeOccurrence (..) + , directTypeDependencies + , discoverTypeOccurrences + , findDemand + , findDemandByType + , planCoreMonomorphization + , planCoreMonomorphizationWith + , specializationCandidate + ) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Monomorphization.Discovery +import Progmasoft.Tala.Core.Monomorphization.Graph +import Progmasoft.Tala.Core.Monomorphization.Types +import Progmasoft.Tala.Core.Specialization +import Progmasoft.Tala.Core.Template + +data PendingDemand = PendingDemand + { pendingType :: Type + , pendingOrigin :: DemandOrigin + , pendingDepth :: Int + } + +data PlanningState = PlanningState + { planningCatalog :: SpecializationCatalog + , planningDemands :: Map DemandId MonomorphizationDemand + , planningIdentityIds :: Map String DemandId + , planningQueue :: [PendingDemand] + , planningRootOccurrences :: Int + , planningOriginCount :: Int + , planningCacheHits :: Int + } + +-- | Plan demands using 'defaultMonomorphizationLimits'. +planCoreMonomorphization :: CoreModule -> Either MonomorphizationError MonomorphizationPlan +planCoreMonomorphization = planCoreMonomorphizationWith defaultMonomorphizationLimits + +-- | Plan and verify the full specialization graph under caller-supplied limits. +planCoreMonomorphizationWith :: + MonomorphizationLimits -> + CoreModule -> + Either MonomorphizationError MonomorphizationPlan +planCoreMonomorphizationWith limits coreModule = do + validateLimits limits + let occurrences = discoverTypeOccurrences coreModule + initial = + PlanningState + emptyCatalog + Map.empty + Map.empty + [PendingDemand (occurrenceType item) (RootDemand (occurrenceLocation item)) 0 | item <- occurrences] + (length occurrences) + 0 + 0 + completed <- drainQueue limits initial + let plan = finishPlan completed + graphIssues = validateDemandGraph plan + if null graphIssues + then Right plan + else Left (InvalidCompletedDemandGraph (map show graphIssues)) + +drainQueue :: MonomorphizationLimits -> PlanningState -> Either MonomorphizationError PlanningState +drainQueue limits state = case planningQueue state of + [] -> Right state + pending : remaining -> do + let withoutHead = state {planningQueue = remaining} + updated <- acceptDemand limits pending withoutHead + drainQueue limits updated + +acceptDemand :: + MonomorphizationLimits -> + PendingDemand -> + PlanningState -> + Either MonomorphizationError PlanningState +acceptDemand limits pending state + | pendingDepth pending > maximumDemandDepth limits = + Left (DemandDepthExceeded (maximumDemandDepth limits) (pendingOrigin pending) (pendingType pending)) + | otherwise = do + concrete <- mapSpecializationError pending (prepareSpecialization [] [] (pendingType pending)) + let identity = renderTemplateIdentity concrete + case Map.lookup identity (planningIdentityIds state) of + Just demandId -> attachExistingOrigin limits demandId pending state + Nothing -> createDemand limits identity concrete pending state + +createDemand :: + MonomorphizationLimits -> + String -> + Type -> + PendingDemand -> + PlanningState -> + Either MonomorphizationError PlanningState +createDemand limits identity concrete pending state + | Map.size (planningDemands state) >= maximumSpecializationDemands limits = + Left (SpecializationLimitExceeded (maximumSpecializationDemands limits) (pendingOrigin pending) concrete) + | planningOriginCount state >= maximumDemandOrigins limits = + Left (DemandOriginLimitExceeded (maximumDemandOrigins limits) (pendingOrigin pending) concrete) + | otherwise = do + (specialization, inserted, catalog) <- + mapSpecializationError pending (internSpecialization concrete (planningCatalog state)) + if not inserted + then Left (InternalMissingDemand identity) + else do + let demandId = DemandId (specializationIdValue (specializationId specialization)) + dependencies = directTypeDependencies concrete + queued = + [ PendingDemand dependency (DependencyDemand demandId argumentIndex) (pendingDepth pending + 1) + | (argumentIndex, dependency) <- dependencies + ] + demand = + MonomorphizationDemand + demandId + specialization + [pendingOrigin pending] + [] + (pendingDepth pending) + DemandQueued + withDemand = + state + { planningCatalog = catalog + , planningDemands = Map.insert demandId demand (planningDemands state) + , planningIdentityIds = Map.insert identity demandId (planningIdentityIds state) + , planningQueue = planningQueue state ++ queued + , planningOriginCount = planningOriginCount state + 1 + } + pure (completeDemandDependencies demandId dependencies withDemand) + +attachExistingOrigin :: + MonomorphizationLimits -> + DemandId -> + PendingDemand -> + PlanningState -> + Either MonomorphizationError PlanningState +attachExistingOrigin limits demandId pending state = case Map.lookup demandId (planningDemands state) of + Nothing -> Left (InternalMissingDemand (renderTemplateIdentity (pendingType pending))) + Just demand + | pendingOrigin pending `elem` monomorphizationOrigins demand -> + Right state {planningCacheHits = planningCacheHits state + 1} + | planningOriginCount state >= maximumDemandOrigins limits -> + Left + ( DemandOriginLimitExceeded + (maximumDemandOrigins limits) + (pendingOrigin pending) + (pendingType pending) + ) + | otherwise -> + let updatedDemand = + demand + { monomorphizationOrigins = monomorphizationOrigins demand ++ [pendingOrigin pending] + , monomorphizationDepth = min (monomorphizationDepth demand) (pendingDepth pending) + } + in Right + state + { planningDemands = Map.insert demandId updatedDemand (planningDemands state) + , planningOriginCount = planningOriginCount state + 1 + , planningCacheHits = planningCacheHits state + 1 + } + +-- Dependency IDs may not exist when a parent is first accepted. The final +-- edge set is therefore reconstructed from canonical identities after the +-- queue reaches a fixed point. This helper only marks the parent complete +-- once its immediate children have been enqueued. +completeDemandDependencies :: DemandId -> [(Int, Type)] -> PlanningState -> PlanningState +completeDemandDependencies demandId _ state = + state + { planningDemands = + Map.adjust + (\demand -> demand {monomorphizationState = DemandComplete}) + demandId + (planningDemands state) + } + +finishPlan :: PlanningState -> MonomorphizationPlan +finishPlan state = + let demands = map (resolveDependencies state) (Map.elems (planningDemands state)) + edgeCount = sum (map (length . monomorphizationDependencies) demands) + deepest = foldl' max 0 (map monomorphizationDepth demands) + statistics = + MonomorphizationStatistics + (planningRootOccurrences state) + (length demands) + edgeCount + (planningCacheHits state) + deepest + in MonomorphizationPlan demands statistics + +resolveDependencies :: PlanningState -> MonomorphizationDemand -> MonomorphizationDemand +resolveDependencies state demand = + demand + { monomorphizationDependencies = + unique + [ dependencyId + | (_, dependency) <- directTypeDependencies (specializationType (monomorphizationSpecialization demand)) + , let identity = renderTemplateIdentity dependency + , Just dependencyId <- [Map.lookup identity (planningIdentityIds state)] + ] + } + +-- | Look up a planned specialization by its stable demand identifier. +findDemand :: DemandId -> MonomorphizationPlan -> Maybe MonomorphizationDemand +findDemand demandId = lookup demandId . map pair . monomorphizationDemands + where + pair demand = (monomorphizationDemandId demand, demand) + +-- | Find the canonical planned specialization matching a concrete type. +findDemandByType :: Type -> MonomorphizationPlan -> Maybe MonomorphizationDemand +findDemandByType valueType = + findByIdentity (renderTemplateIdentity valueType) . monomorphizationDemands + where + findByIdentity _ [] = Nothing + findByIdentity identity (demand : remaining) + | specializationIdentity (monomorphizationSpecialization demand) == identity = Just demand + | otherwise = findByIdentity identity remaining + +validateLimits :: MonomorphizationLimits -> Either MonomorphizationError () +validateLimits limits + | maximumSpecializationDemands limits <= 0 = + Left (InvalidMonomorphizationLimits "maximum demand count must be positive") + | maximumDemandDepth limits < 0 = Left (InvalidMonomorphizationLimits "maximum demand depth cannot be negative") + | maximumDemandOrigins limits <= 0 = Left (InvalidMonomorphizationLimits "maximum origin count must be positive") + | otherwise = Right () + +mapSpecializationError :: + PendingDemand -> + Either SpecializationError value -> + Either MonomorphizationError value +mapSpecializationError pending result = case result of + Left failure -> Left (InvalidDemandType (pendingOrigin pending) failure) + Right value -> Right value + +unique :: (Eq value) => [value] -> [value] +unique = foldl' append [] + where + append values value + | value `elem` values = values + | otherwise = values ++ [value]
+ src/Progmasoft/Tala/Core/Monomorphization/Discovery.hs view
@@ -0,0 +1,177 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Lossless discovery of concrete template occurrences in Core. + +Discovery does not decide whether two occurrences need separate generated +code. It records every semantic site, while the planning layer canonicalizes +types through @SpecializationCatalog@. Keeping those jobs separate makes the +source-to-Core boundary testable without depending on queue implementation. +-} +module Progmasoft.Tala.Core.Monomorphization.Discovery + ( TypeOccurrence (..) + , directTypeDependencies + , discoverTypeOccurrences + , specializationCandidate + ) where + +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Monomorphization.Types + +-- | One specialization candidate together with its exact semantic Core path. +data TypeOccurrence = TypeOccurrence + { occurrenceType :: Type + , occurrenceLocation :: DemandLocation + } + deriving (Eq, Ord, Read, Show) + +{- | A named type without arguments is nominal but not a specialization demand. +Function types are containers whose parameter/result types are visited +independently. This rule avoids manufacturing a runtime generic dictionary +demand for the callable itself. +-} +specializationCandidate :: Type -> Bool +specializationCandidate valueType = case valueType of + NamedType _ arguments -> not (null arguments) + FunctionType _ _ -> False + TypeVariable _ -> False + ErrorType -> False + +-- | Collect specialization candidates from signatures and nested Core nodes. +discoverTypeOccurrences :: CoreModule -> [TypeOccurrence] +discoverTypeOccurrences coreModule = concatMap discoverFunction (coreModuleFunctions coreModule) + +discoverFunction :: CoreFunction -> [TypeOccurrence] +discoverFunction function = + concat + [ discoverTypeAt + (location [FunctionParameterPath index]) + parameterType + | (index, (_, parameterType)) <- zip [0 ..] (coreFunctionParameters function) + ] + ++ discoverTypeAt (location [FunctionReturnPath]) (coreFunctionReturnType function) + ++ discoverStatements (location []) (coreFunctionBody function) + where + location path = DemandLocation (coreFunctionName function) path + +discoverStatements :: DemandLocation -> [CoreStatement] -> [TypeOccurrence] +discoverStatements parent statements = + concat + [ discoverStatement (appendPath parent (StatementPath index)) statement + | (index, statement) <- zip [0 ..] statements + ] + +discoverStatement :: DemandLocation -> CoreStatement -> [TypeOccurrence] +discoverStatement location statement = case statement of + CoreBind binding -> + discoverTypeAt (appendPath location BindingTypePath) (coreBindingType binding) + ++ discoverExpression (appendPath location BindingValuePath) (coreBindingValue binding) + CoreAssign _ value -> discoverExpression (appendPath location AssignmentValuePath) value + CoreReturn value -> discoverExpression (appendPath location ReturnValuePath) value + CoreIf condition trueBranch falseBranch -> + discoverExpression (appendPath location ConditionPath) condition + ++ discoverStatements (appendPath location TrueBranchPath) trueBranch + ++ discoverStatements (appendPath location FalseBranchPath) falseBranch + CoreWhile condition body -> + discoverExpression (appendPath location ConditionPath) condition + ++ discoverStatements (appendPath location LoopBodyPath) body + CoreDoWhile body condition -> + discoverStatements (appendPath location LoopBodyPath) body + ++ discoverExpression (appendPath location ConditionPath) condition + CoreFor condition body update -> + discoverExpression (appendPath location ConditionPath) condition + ++ discoverStatements (appendPath location LoopBodyPath) body + ++ discoverStatements (appendPath location LoopUpdatePath) update + CoreEvaluate value -> discoverExpression (appendPath location EvaluatedValuePath) value + CoreBreak -> [] + CoreContinue -> [] + +discoverExpression :: DemandLocation -> CoreExpression -> [TypeOccurrence] +discoverExpression location expression = + discoverTypeAt (appendPath location ExpressionResultPath) (expressionType expression) + ++ case expression of + CoreVariable _ _ -> [] + CoreLiteral _ _ -> [] + CoreApply callee arguments _ -> + discoverExpression (appendPath location CalleePath) callee + ++ concat + [ discoverExpression (appendPath location (ArgumentPath index)) argument + | (index, argument) <- zip [0 ..] arguments + ] + CorePrimitive _ operands _ -> + concat + [ discoverExpression (appendPath location (PrimitiveOperandPath index)) operand + | (index, operand) <- zip [0 ..] operands + ] + CoreLet _ bindingType value body _ -> + discoverTypeAt (appendPath location BindingTypePath) bindingType + ++ discoverExpression (appendPath location BindingValuePath) value + ++ discoverExpression (appendPath location EvaluatedValuePath) body + CoreConditional condition whenTrue whenFalse _ -> + discoverExpression (appendPath location ConditionPath) condition + ++ discoverExpression (appendPath location TrueBranchPath) whenTrue + ++ discoverExpression (appendPath location FalseBranchPath) whenFalse + CoreClosure captures parameters returnType body _ -> + concat + [ discoverCapture (appendPath location (ClosureCapturePath index)) capture + | (index, capture) <- zip [0 ..] captures + ] + ++ concat + [ discoverTypeAt + (appendPath location (ClosureParameterPath index)) + parameterType + | (index, (_, parameterType)) <- zip [0 ..] parameters + ] + ++ discoverTypeAt (appendPath location ClosureReturnPath) returnType + ++ discoverStatements (appendPath location ClosureBodyPath) body + +discoverCapture :: DemandLocation -> CoreCapture -> [TypeOccurrence] +discoverCapture location capture = + discoverTypeAt (appendPath location ClosureCaptureTypePath) (coreCaptureType capture) + ++ discoverExpression (appendPath location ClosureCaptureValuePath) (coreCaptureValue capture) + +{- | Visit a complete type tree because nested callable signatures may contain +specialization roots even when the outer type is not itself parameterized. +Nested template arguments are not emitted here: they become dependency +demands while processing the parent's queue entry. This preserves a useful +parent edge instead of flattening every type into unrelated roots. +-} +discoverTypeAt :: DemandLocation -> Type -> [TypeOccurrence] +discoverTypeAt location valueType + | specializationCandidate valueType = [TypeOccurrence valueType location] + | otherwise = case valueType of + FunctionType parameters result -> + concat + [ discoverTypeAt + (appendPath location (ClosureParameterPath index)) + parameterType + | (index, parameterType) <- zip [0 ..] parameters + ] + ++ discoverTypeAt (appendPath location ClosureReturnPath) result + _ -> [] + +{- | Immediate specialization dependencies retain argument indexes. Deeper +nodes are discovered when the immediate child is processed, giving traces a +bounded and intelligible chain. +-} +directTypeDependencies :: Type -> [(Int, Type)] +directTypeDependencies valueType = case valueType of + NamedType _ arguments -> concatMap dependencyAt (zip [0 ..] arguments) + FunctionType parameters result -> + concatMap dependencyAtType (zip [0 ..] (parameters ++ [result])) + TypeVariable _ -> [] + ErrorType -> [] + where + dependencyAt (index, argument) = case argument of + TypeTemplateArgument nested -> + if specializationCandidate nested + then [(index, nested)] + else [(childIndex, child) | (childIndex, child) <- directTypeDependencies nested] + ValueTemplateArgument _ -> [] + dependencyAtType (index, nested) + | specializationCandidate nested = [(index, nested)] + | otherwise = [(childIndex, child) | (childIndex, child) <- directTypeDependencies nested] + +appendPath :: DemandLocation -> DemandPathStep -> DemandLocation +appendPath location step = location {demandLocationPath = demandLocationPath location ++ [step]}
+ src/Progmasoft/Tala/Core/Monomorphization/Graph.hs view
@@ -0,0 +1,220 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Queries and invariants for a completed specialization-demand graph. + +Instantiation needs children before parents when concrete layout depends on a +nested specialization. The discovery queue is intentionally root-first for +good diagnostics, so emission order is derived here instead of overloading the +meaning of demand identifiers. +-} +module Progmasoft.Tala.Core.Monomorphization.Graph + ( DemandGraphIssue (..) + , demandLeaves + , demandRoots + , dependentDemands + , reachableDependencies + , renderDemandTrace + , specializationEmissionOrder + , validateDemandGraph + ) where + +import Data.List (intercalate, sort) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Progmasoft.Tala.Core.Monomorphization.Types +import Progmasoft.Tala.Core.Specialization + +-- | Structural or accounting invariant violated by a completed demand graph. +data DemandGraphIssue + = DuplicateDemandIdentifier DemandId + | NonPositiveDemandIdentifier DemandId + | MissingDependency DemandId DemandId + | DuplicateDependency DemandId DemandId + | SelfDependency DemandId + | IncompleteDemand DemandId + | CyclicDemandPath [DemandId] + | StatisticsDemandCountMismatch Int Int + | StatisticsEdgeCountMismatch Int Int + | StatisticsDepthMismatch Int Int + deriving (Eq, Ord, Read, Show) + +-- | Check identifiers, edges, completion state, acyclicity, and statistics. +validateDemandGraph :: MonomorphizationPlan -> [DemandGraphIssue] +validateDemandGraph plan = + identifierIssues + ++ dependencyIssues + ++ stateIssues + ++ cycleIssues + ++ statisticsIssues + where + demands = monomorphizationDemands plan + demandIds = map monomorphizationDemandId demands + known = Set.fromList demandIds + identifierIssues = + [ NonPositiveDemandIdentifier demandId + | demandId@(DemandId value) <- demandIds + , value <= 0 + ] + ++ [ DuplicateDemandIdentifier demandId + | groupIds@(demandId : _) <- grouped demandIds + , length groupIds > 1 + ] + dependencyIssues = concatMap (validateDependencies known) demands + stateIssues = + [ IncompleteDemand (monomorphizationDemandId demand) + | demand <- demands + , monomorphizationState demand /= DemandComplete + ] + cycleIssues = case specializationEmissionOrder plan of + Left cyclePath -> [CyclicDemandPath cyclePath] + Right _ -> [] + statistics = monomorphizationStatistics plan + actualCount = length demands + actualEdges = sum (map (length . monomorphizationDependencies) demands) + actualDepth = foldl max 0 (map monomorphizationDepth demands) + statisticsIssues = + [ StatisticsDemandCountMismatch (uniqueSpecializationDemands statistics) actualCount + | uniqueSpecializationDemands statistics /= actualCount + ] + ++ [ StatisticsEdgeCountMismatch (specializationDependencyEdges statistics) actualEdges + | specializationDependencyEdges statistics /= actualEdges + ] + ++ [ StatisticsDepthMismatch (deepestSpecializationDemand statistics) actualDepth + | deepestSpecializationDemand statistics /= actualDepth + ] + +validateDependencies :: Set DemandId -> MonomorphizationDemand -> [DemandGraphIssue] +validateDependencies known demand = + [ MissingDependency owner dependency + | dependency <- dependencies + , dependency `Set.notMember` known + ] + ++ [ DuplicateDependency owner dependency + | duplicate@(dependency : _) <- grouped dependencies + , length duplicate > 1 + ] + ++ [SelfDependency owner | owner `elem` dependencies] + where + owner = monomorphizationDemandId demand + dependencies = monomorphizationDependencies demand + +-- | Select demands that have at least one source/Core root occurrence. +demandRoots :: MonomorphizationPlan -> [MonomorphizationDemand] +demandRoots = filter hasRootOrigin . monomorphizationDemands + where + hasRootOrigin = any isRoot . monomorphizationOrigins + isRoot (RootDemand _) = True + isRoot (DependencyDemand _ _) = False + +-- | Select demands that introduce no further specialization dependencies. +demandLeaves :: MonomorphizationPlan -> [MonomorphizationDemand] +demandLeaves = filter (null . monomorphizationDependencies) . monomorphizationDemands + +-- | Find direct parents whose dependency list contains the requested demand. +dependentDemands :: DemandId -> MonomorphizationPlan -> [MonomorphizationDemand] +dependentDemands dependency = + filter (elem dependency . monomorphizationDependencies) . monomorphizationDemands + +-- | Return the transitive dependencies reachable from one demand, excluding it. +reachableDependencies :: DemandId -> MonomorphizationPlan -> [MonomorphizationDemand] +reachableDependencies root plan = + let table = demandTable plan + ids = walk table Set.empty [root] + in [demand | demandId <- ids, Just demand <- [Map.lookup demandId table], demandId /= root] + where + walk _ _ [] = [] + walk table visited (current : remaining) + | current `Set.member` visited = walk table visited remaining + | otherwise = + let dependencies = maybe [] monomorphizationDependencies (Map.lookup current table) + in current : walk table (Set.insert current visited) (dependencies ++ remaining) + +{- | Produce a stable postorder. Sibling order follows demand identifiers, +which reflect first discovery order within one deterministic compilation. +-} +specializationEmissionOrder :: MonomorphizationPlan -> Either [DemandId] [MonomorphizationDemand] +specializationEmissionOrder plan = do + let table = demandTable plan + roots = map monomorphizationDemandId (monomorphizationDemands plan) + (_, reverseOrder) <- visitMany table Set.empty [] [] roots + pure [demand | demandId <- reverse reverseOrder, Just demand <- [Map.lookup demandId table]] + +visitMany :: + Map DemandId MonomorphizationDemand -> + Set DemandId -> + [DemandId] -> + [DemandId] -> + [DemandId] -> + Either [DemandId] (Set DemandId, [DemandId]) +visitMany _ complete _ output [] = Right (complete, output) +visitMany table complete active output (demandId : remaining) = do + (updatedComplete, updatedOutput) <- visitOne table complete active output demandId + visitMany table updatedComplete active updatedOutput remaining + +visitOne :: + Map DemandId MonomorphizationDemand -> + Set DemandId -> + [DemandId] -> + [DemandId] -> + DemandId -> + Either [DemandId] (Set DemandId, [DemandId]) +visitOne table complete active output demandId + | demandId `Set.member` complete = Right (complete, output) + | demandId `elem` active = Left (cycleFrom demandId active) + | otherwise = case Map.lookup demandId table of + Nothing -> Right (complete, output) + Just demand -> do + let nextActive = demandId : active + dependencies = sort (monomorphizationDependencies demand) + (childrenComplete, childrenOutput) <- visitMany table complete nextActive output dependencies + pure (Set.insert demandId childrenComplete, demandId : childrenOutput) + +-- | Render one demand with its identity, depth, origins, and outgoing edges. +renderDemandTrace :: MonomorphizationPlan -> DemandId -> String +renderDemandTrace plan demandId = case Map.lookup demandId (demandTable plan) of + Nothing -> "unknown demand " ++ renderDemandId demandId + Just demand -> + renderDemandId demandId + ++ " " + ++ specializationIdentity (monomorphizationSpecialization demand) + ++ " depth=" + ++ show (monomorphizationDepth demand) + ++ " origins=[" + ++ intercalate ", " (map renderOrigin (monomorphizationOrigins demand)) + ++ "] dependencies=[" + ++ intercalate ", " (map renderDemandId (monomorphizationDependencies demand)) + ++ "]" + where + renderOrigin origin = case origin of + RootDemand location -> renderDemandLocation location + DependencyDemand parent argumentIndex -> + renderDemandId parent ++ ".argument[" ++ show argumentIndex ++ "]" + +demandTable :: MonomorphizationPlan -> Map DemandId MonomorphizationDemand +demandTable = + Map.fromList + . map (\demand -> (monomorphizationDemandId demand, demand)) + . monomorphizationDemands + +renderDemandId :: DemandId -> String +renderDemandId (DemandId value) = "demand#" ++ show value + +cycleFrom :: DemandId -> [DemandId] -> [DemandId] +cycleFrom repeated active = repeated : reverse (takeThrough repeated active) + where + takeThrough _ [] = [] + takeThrough target (value : remaining) + | value == target = [value] + | otherwise = value : takeThrough target remaining + +grouped :: (Ord value) => [value] -> [[value]] +grouped values = foldr collect [] (sort values) + where + collect value [] = [[value]] + collect value groups@(first@(firstValue : _) : remaining) + | value == firstValue = (value : first) : remaining + | otherwise = [value] : groups + collect value ([] : remaining) = [value] : remaining
+ src/Progmasoft/Tala/Core/Monomorphization/Types.hs view
@@ -0,0 +1,226 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Data carried by the Core specialization-demand planner. + +The planner intentionally records semantic locations instead of source spans. +Core can be loaded from an artifact, so a source file is not guaranteed to be +available. A later diagnostic layer may enrich these locations with provenance +kept by the frontend without changing the deterministic planning contract. +-} +module Progmasoft.Tala.Core.Monomorphization.Types + ( DemandId (..) + , DemandLocation (..) + , DemandOrigin (..) + , DemandPathStep (..) + , DemandState (..) + , MonomorphizationDemand (..) + , MonomorphizationError (..) + , MonomorphizationLimits (..) + , MonomorphizationPlan (..) + , MonomorphizationStatistics (..) + , defaultMonomorphizationLimits + , emptyMonomorphizationStatistics + , renderDemandLocation + , renderDemandOrigin + , renderMonomorphizationError + ) where + +import Data.List (intercalate) +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core.Specialization +import Progmasoft.Tala.Core.Template (TemplateIssue (..)) + +-- | Stable, positive identifier for one canonical specialization in a plan. +newtype DemandId = DemandId {demandIdValue :: Int} + deriving (Eq, Ord, Read, Show) + +-- | The structural route from a function body to a type-bearing Core node. +data DemandPathStep + = FunctionParameterPath Int + | FunctionReturnPath + | StatementPath Int + | TrueBranchPath + | FalseBranchPath + | LoopBodyPath + | LoopUpdatePath + | BindingTypePath + | BindingValuePath + | AssignmentValuePath + | ReturnValuePath + | ConditionPath + | EvaluatedValuePath + | CalleePath + | ArgumentPath Int + | PrimitiveOperandPath Int + | ExpressionResultPath + | ClosureCapturePath Int + | ClosureCaptureTypePath + | ClosureCaptureValuePath + | ClosureParameterPath Int + | ClosureReturnPath + | ClosureBodyPath + deriving (Eq, Ord, Read, Show) + +-- | Core-level path identifying the occurrence that requested a specialization. +data DemandLocation = DemandLocation + { demandLocationFunction :: ResolvedName + , demandLocationPath :: [DemandPathStep] + } + deriving (Eq, Ord, Read, Show) + +-- | Why a concrete specialization entered the fixed-point queue. +data DemandOrigin + = RootDemand DemandLocation + | DependencyDemand DemandId Int + deriving (Eq, Ord, Read, Show) + +-- | Processing state retained in the finalized plan for invariant checking. +data DemandState = DemandQueued | DemandComplete + deriving (Eq, Ord, Read, Show) + +-- | One deduplicated concrete specialization and its provenance/dependencies. +data MonomorphizationDemand = MonomorphizationDemand + { monomorphizationDemandId :: DemandId + , monomorphizationSpecialization :: Specialization + , monomorphizationOrigins :: [DemandOrigin] + , monomorphizationDependencies :: [DemandId] + , monomorphizationDepth :: Int + , monomorphizationState :: DemandState + } + deriving (Eq, Ord, Read, Show) + +-- | Finite resource bounds for demand count, dependency depth, and provenance. +data MonomorphizationLimits = MonomorphizationLimits + { maximumSpecializationDemands :: Int + , maximumDemandDepth :: Int + , maximumDemandOrigins :: Int + } + deriving (Eq, Ord, Read, Show) + +-- | Conservative default bounds used by ordinary Core planning. +defaultMonomorphizationLimits :: MonomorphizationLimits +defaultMonomorphizationLimits = MonomorphizationLimits 4096 128 16384 + +-- | Deterministic counters describing discovery, deduplication, and graph size. +data MonomorphizationStatistics = MonomorphizationStatistics + { discoveredRootOccurrences :: Int + , uniqueSpecializationDemands :: Int + , specializationDependencyEdges :: Int + , specializationCacheHits :: Int + , deepestSpecializationDemand :: Int + } + deriving (Eq, Ord, Read, Show) + +-- | Zero-valued statistics for a plan that has not discovered any demands. +emptyMonomorphizationStatistics :: MonomorphizationStatistics +emptyMonomorphizationStatistics = MonomorphizationStatistics 0 0 0 0 0 + +-- | Completed root-first demand graph with aggregate planning statistics. +data MonomorphizationPlan = MonomorphizationPlan + { monomorphizationDemands :: [MonomorphizationDemand] + , monomorphizationStatistics :: MonomorphizationStatistics + } + deriving (Eq, Ord, Read, Show) + +-- | Failure to bound, validate, or consistently construct a demand graph. +data MonomorphizationError + = InvalidMonomorphizationLimits String + | InvalidDemandType DemandOrigin SpecializationError + | SpecializationLimitExceeded Int DemandOrigin Type + | DemandDepthExceeded Int DemandOrigin Type + | DemandOriginLimitExceeded Int DemandOrigin Type + | InvalidCompletedDemandGraph [String] + | InternalMissingDemand String + deriving (Eq, Ord, Read, Show) + +-- | Render a stable semantic path from a function to a type occurrence. +renderDemandLocation :: DemandLocation -> String +renderDemandLocation location = + renderResolvedName (demandLocationFunction location) + ++ concatMap renderPathStep (demandLocationPath location) + +-- | Convert a planning failure into actionable diagnostic text. +renderMonomorphizationError :: MonomorphizationError -> String +renderMonomorphizationError failure = case failure of + InvalidMonomorphizationLimits message -> "invalid monomorphization limits: " ++ message + InvalidDemandType origin reason -> + "invalid specialization demand at " + ++ renderDemandOrigin origin + ++ ": " + ++ renderSpecializationError reason + SpecializationLimitExceeded maximumCount origin valueType -> + "specialization demand limit " + ++ show maximumCount + ++ " exceeded at " + ++ renderDemandOrigin origin + ++ " while requesting " + ++ show valueType + DemandDepthExceeded maximumDepth origin valueType -> + "specialization dependency depth " + ++ show maximumDepth + ++ " exceeded from " + ++ renderDemandOrigin origin + ++ " while requesting " + ++ show valueType + DemandOriginLimitExceeded maximumOrigins origin valueType -> + "specialization origin limit " + ++ show maximumOrigins + ++ " exceeded at " + ++ renderDemandOrigin origin + ++ " while requesting " + ++ show valueType + InvalidCompletedDemandGraph issues -> + "completed specialization demand graph failed validation: " + ++ intercalate "; " issues + InternalMissingDemand identity -> "internal specialization demand is missing from the completed plan: " ++ identity + +renderResolvedName :: ResolvedName -> String +renderResolvedName name = + identifierText (resolvedSpelling name) + ++ "#" + ++ show (symbolIdValue (resolvedSymbol name)) + +renderPathStep :: DemandPathStep -> String +renderPathStep step = case step of + FunctionParameterPath index -> ".parameter[" ++ show index ++ "]" + FunctionReturnPath -> ".return" + StatementPath index -> ".statement[" ++ show index ++ "]" + TrueBranchPath -> ".true" + FalseBranchPath -> ".false" + LoopBodyPath -> ".loop-body" + LoopUpdatePath -> ".loop-update" + BindingTypePath -> ".binding-type" + BindingValuePath -> ".binding-value" + AssignmentValuePath -> ".assignment-value" + ReturnValuePath -> ".return-value" + ConditionPath -> ".condition" + EvaluatedValuePath -> ".evaluated-value" + CalleePath -> ".callee" + ArgumentPath index -> ".argument[" ++ show index ++ "]" + PrimitiveOperandPath index -> ".operand[" ++ show index ++ "]" + ExpressionResultPath -> ".result" + ClosureCapturePath index -> ".capture[" ++ show index ++ "]" + ClosureCaptureTypePath -> ".capture-type" + ClosureCaptureValuePath -> ".capture-value" + ClosureParameterPath index -> ".closure-parameter[" ++ show index ++ "]" + ClosureReturnPath -> ".closure-return" + ClosureBodyPath -> ".closure-body" + +-- | Render the root occurrence or parent argument that introduced a demand. +renderDemandOrigin :: DemandOrigin -> String +renderDemandOrigin origin = case origin of + RootDemand location -> renderDemandLocation location + DependencyDemand (DemandId parent) argumentIndex -> + "demand " ++ show parent ++ " argument[" ++ show argumentIndex ++ "]" + +renderSpecializationError :: SpecializationError -> String +renderSpecializationError reason = case reason of + InvalidSpecialization issues -> + "structural validation failed (" + ++ intercalate "; " (map templateIssueMessage issues) + ++ ")" + OpenSpecialization symbols -> "unbound template parameters " ++ show (map symbolIdValue symbols) + DuplicateTypeBinding symbols -> "duplicate type bindings " ++ show (map symbolIdValue symbols) + DuplicateValueBinding symbols -> "duplicate value bindings " ++ show (map symbolIdValue symbols) + ConflictingBindingKinds symbols -> "conflicting type/value bindings " ++ show (map symbolIdValue symbols)
+ src/Progmasoft/Tala/Core/Optimizer.hs view
@@ -0,0 +1,54 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Public facade for the target-independent Core optimization pipeline. + +The optimizer accepts only verified Core and verifies its final result again. +That invariant makes the facade safe for compiler orchestration and for tools +which load a Core artifact without running the normal frontend first. +-} +module Progmasoft.Tala.Core.Optimizer + ( CoreOptimizer (..) + , OptimizerOptions (..) + , OptimizationPass (..) + , OptimizationMetrics (..) + , PassReport (..) + , OptimizationResult (..) + , Effect (..) + , FunctionEffectReport (..) + , InlineReport (..) + , defaultCoreOptimizer + , defaultOptimizerOptions + , runCoreOptimizer + , optimizeCoreWith + ) where + +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Optimizer.Analysis +import Progmasoft.Tala.Core.Optimizer.Inline +import Progmasoft.Tala.Core.Optimizer.Pipeline +import Progmasoft.Tala.Core.Optimizer.Types +import Progmasoft.Tala.Core.Verifier (verifyCore) +import Progmasoft.Tala.Diagnostic (Diagnostic) + +-- | Reusable verified-Core transformation supplied to compiler orchestration. +newtype CoreOptimizer = CoreOptimizer + { optimizeCore :: CoreModule -> Either [Diagnostic] CoreModule + } + +-- | Apply an optimizer while preserving its diagnostic-based failure contract. +runCoreOptimizer :: CoreOptimizer -> CoreModule -> Either [Diagnostic] CoreModule +runCoreOptimizer = optimizeCore + +-- | Construct the production optimizer using 'defaultOptimizerOptions'. +defaultCoreOptimizer :: CoreOptimizer +defaultCoreOptimizer = + CoreOptimizer $ \moduleValue -> optimizedCore <$> optimizeCoreWith defaultOptimizerOptions moduleValue + +-- | Verify input, run enabled passes, and verify the optimized result again. +optimizeCoreWith :: OptimizerOptions -> CoreModule -> Either [Diagnostic] OptimizationResult +optimizeCoreWith options moduleValue = do + verified <- verifyCore moduleValue + let result = runOptimizationPipeline options verified + checked <- verifyCore (optimizedCore result) + pure result {optimizedCore = checked}
+ src/Progmasoft/Tala/Core/Optimizer/Analysis.hs view
@@ -0,0 +1,241 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +module Progmasoft.Tala.Core.Optimizer.Analysis + ( Effect (..) + , EffectEnvironment + , FunctionEffectReport (..) + , emptyEffectEnvironment + , effectEnvironment + , lookupFunctionEffect + , combineEffect + , expressionEffect + , expressionEffectWith + , expressionEffectWithFacts + , primitiveEffectWithProvenNonzeroDivisor + , expressionSymbols + , statementSymbols + , statementsAlwaysReturn + , discardableExpression + , discardableExpressionWith + , discardableExpressionWithFacts + ) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Progmasoft.Tala.AST (ResolvedName, SymbolId, resolvedSymbol) +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Optimizer.IntegerFacts +import Progmasoft.Tala.Core.Scalar (isCoreFloatingType, isCoreIntegerType) +import Progmasoft.Tala.RuntimeCall (runtimeFunctionOf, runtimeObservable) + +-- Effect ordering is deliberately conservative. The optimizer currently needs +-- one decisive property: only PureEffect may disappear when its value is dead. +-- The remaining constructors retain the strongest reason in diagnostics and +-- reports without pretending that allocation, failure and divergence are +-- interchangeable language effects. + +-- | Conservative effect class used to decide whether an expression may vanish. +data Effect + = PureEffect + | FailureEffect + | AllocationEffect + | CallEffect + | DivergenceEffect + deriving (Eq, Ord, Read, Show) + +-- The environment is immutable for one optimizer pass. Recomputing it after a +-- structural rewrite is cheap relative to parsing and avoids stale call facts +-- when control-flow simplification removes a call site. +newtype EffectEnvironment = EffectEnvironment (Map SymbolId Effect) + deriving (Eq, Ord, Read, Show) + +-- | Interprocedural effect facts and call-graph properties for one function. +data FunctionEffectReport = FunctionEffectReport + { effectFunctionName :: ResolvedName + , effectClassification :: Effect + , effectDirectCallees :: [SymbolId] + , effectHasUnknownCall :: Bool + , effectIsRecursive :: Bool + } + deriving (Eq, Ord, Read, Show) + +emptyEffectEnvironment :: EffectEnvironment +emptyEffectEnvironment = EffectEnvironment Map.empty + +effectEnvironment :: [(SymbolId, Effect)] -> EffectEnvironment +effectEnvironment = EffectEnvironment . Map.fromList + +lookupFunctionEffect :: EffectEnvironment -> SymbolId -> Maybe Effect +lookupFunctionEffect (EffectEnvironment values) symbol = Map.lookup symbol values + +combineEffect :: Effect -> Effect -> Effect +combineEffect = max + +expressionEffect :: CoreExpression -> Effect +expressionEffect = expressionEffectWith emptyEffectEnvironment + +expressionEffectWith :: EffectEnvironment -> CoreExpression -> Effect +expressionEffectWith environment = expressionEffectWithFacts environment emptyIntegerFacts + +expressionEffectWithFacts :: EffectEnvironment -> IntegerFacts -> CoreExpression -> Effect +expressionEffectWithFacts environment facts expression + | isUnreachableFacts facts = PureEffect + | otherwise = case expression of + CoreVariable _ _ -> PureEffect + CoreLiteral _ _ -> PureEffect + CorePrimitive CoreLogicalAnd [left, right] _ -> + shortCircuitEffect environment facts True left right + CorePrimitive CoreLogicalOr [left, right] _ -> + shortCircuitEffect environment facts False left right + CorePrimitive primitive arguments _ -> + let (childEffect, afterArguments) = expressionListEffect environment facts arguments + divisorIsProvenNonzero = case (primitive, arguments) of + (CoreDivide, [_, CoreVariable name _]) -> knownNonzero afterArguments name + (CoreFloorDivide, [_, CoreVariable name _]) -> knownNonzero afterArguments name + (CoreRemainder, [_, CoreVariable name _]) -> knownNonzero afterArguments name + _ -> False + localEffect = primitiveEffectWithProvenNonzeroDivisor divisorIsProvenNonzero primitive arguments + in combineEffect childEffect localEffect + CoreLet name valueType value body _ -> + let valueEffect = expressionEffectWithFacts environment facts value + afterValue = transferExpressionFacts facts value + binding = CoreBind (CoreBinding name valueType False value) + bodyFacts = transferStatementFacts afterValue binding + in combineEffect valueEffect (expressionEffectWithFacts environment bodyFacts body) + CoreConditional condition whenTrue whenFalse _ -> + conditionalEffect environment facts condition whenTrue whenFalse + CoreApply callee arguments _ -> + let (nested, _) = expressionListEffect environment facts (callee : arguments) + invoked = case callee of + CoreVariable name _ -> + maybe CallEffect id (lookupFunctionEffect environment (resolvedSymbol name)) + _ -> CallEffect + in combineEffect invoked nested + CoreClosure captures _ _ _ _ -> + let (captureEffect, _) = expressionListEffect environment facts (map coreCaptureValue captures) + in combineEffect AllocationEffect captureEffect + +shortCircuitEffect :: EffectEnvironment -> IntegerFacts -> Bool -> CoreExpression -> CoreExpression -> Effect +shortCircuitEffect environment facts isAnd left right = + let leftEffect = expressionEffectWithFacts environment facts left + afterLeft = transferExpressionFacts facts left + leftTruth = conditionTruthFromFacts facts left + evaluatesRight = if isAnd then leftTruth /= Just False else leftTruth /= Just True + rightInput = refineConditionFacts isAnd left afterLeft + rightEffect + | evaluatesRight && not (isUnreachableFacts rightInput) = + expressionEffectWithFacts environment rightInput right + | otherwise = PureEffect + in combineEffect leftEffect rightEffect + +-- Only the selected arm runs. An arm whose edge is infeasible under the +-- incoming facts contributes no effect, exactly like a skipped right operand. +conditionalEffect :: + EffectEnvironment -> IntegerFacts -> CoreExpression -> CoreExpression -> CoreExpression -> Effect +conditionalEffect environment facts condition whenTrue whenFalse = + let conditionEffect = expressionEffectWithFacts environment facts condition + afterCondition = transferExpressionFacts facts condition + truth = conditionTruthFromFacts facts condition + armEffect desired arm = + let input = refineConditionFacts desired condition afterCondition + in if truth == Just (not desired) || isUnreachableFacts input + then PureEffect + else expressionEffectWithFacts environment input arm + in combineEffect conditionEffect (combineEffect (armEffect True whenTrue) (armEffect False whenFalse)) + +expressionListEffect :: EffectEnvironment -> IntegerFacts -> [CoreExpression] -> (Effect, IntegerFacts) +expressionListEffect _ facts [] = (PureEffect, facts) +expressionListEffect environment facts (expression : remaining) = + let currentEffect = expressionEffectWithFacts environment facts expression + afterCurrent = transferExpressionFacts facts expression + (laterEffect, finalFacts) = expressionListEffect environment afterCurrent remaining + in (combineEffect currentEffect laterEffect, finalFacts) + +knownNonzero :: IntegerFacts -> ResolvedName -> Bool +knownNonzero facts name = + maybe False factProvesNonzero (lookupIntegerFact facts (resolvedSymbol name)) + +-- Integer division can fail even though it has no externally visible write. +-- Treating a variable divisor as pure would let dead-code elimination erase a +-- required divide-by-zero failure. Floating division follows its IEEE target +-- semantics and does not use this failure classification. + +{- | Classify the local effect of one already type-checked primitive. The +additional proof is supplied by structured flow analysis, never guessed +from an arbitrary expression. Child-expression effects are combined by the +caller, so proving a divisor nonzero cannot erase a call in an operand. +-} +primitiveEffectWithProvenNonzeroDivisor :: Bool -> CorePrimitive -> [CoreExpression] -> Effect +primitiveEffectWithProvenNonzeroDivisor provenNonzero primitive arguments + -- A runtime call that writes to the console is observed by whoever + -- reads the output: it is kept, kept once, and kept where it stands, + -- like a call of a function that nothing is known about. The others + -- compute a string and do nothing else. + | primitive == CoreRuntimeCall = case arguments of + CoreLiteral (CoreInteger identity) _ : _ + | Just function <- runtimeFunctionOf identity + , not (runtimeObservable function) -> + AllocationEffect + _ -> CallEffect + | primitive `elem` [CoreDivide, CoreFloorDivide, CoreRemainder] + , firstTypeIsInteger arguments + , not (knownNonzeroDivisor arguments || provenNonzero) = + FailureEffect + | otherwise = PureEffect + +firstTypeIsInteger :: [CoreExpression] -> Bool +firstTypeIsInteger (first : _) = isCoreIntegerType (expressionType first) +firstTypeIsInteger [] = False + +knownNonzeroDivisor :: [CoreExpression] -> Bool +knownNonzeroDivisor [_, CoreLiteral (CoreInteger value) _] = value /= 0 +knownNonzeroDivisor [_, CoreLiteral (CoreFloating _) valueType] = isCoreFloatingType valueType +knownNonzeroDivisor _ = False + +discardableExpression :: CoreExpression -> Bool +discardableExpression = discardableExpressionWith emptyEffectEnvironment + +discardableExpressionWith :: EffectEnvironment -> CoreExpression -> Bool +discardableExpressionWith environment expression = expressionEffectWith environment expression == PureEffect + +discardableExpressionWithFacts :: EffectEnvironment -> IntegerFacts -> CoreExpression -> Bool +discardableExpressionWithFacts environment facts expression = + expressionEffectWithFacts environment facts expression == PureEffect + +expressionSymbols :: CoreExpression -> Set SymbolId +expressionSymbols expression = case expression of + CoreVariable name _ -> Set.singleton (resolvedSymbol name) + CoreLiteral _ _ -> Set.empty + CoreApply callee arguments _ -> Set.unions (map expressionSymbols (callee : arguments)) + CorePrimitive _ arguments _ -> Set.unions (map expressionSymbols arguments) + CoreLet name _ value body _ -> + Set.union (expressionSymbols value) (Set.delete (resolvedSymbol name) (expressionSymbols body)) + CoreConditional condition whenTrue whenFalse _ -> + Set.unions (map expressionSymbols [condition, whenTrue, whenFalse]) + CoreClosure captures _ _ _ _ -> Set.unions (map (expressionSymbols . coreCaptureValue) captures) + +statementSymbols :: CoreStatement -> Set SymbolId +statementSymbols statement = case statement of + CoreBind binding -> expressionSymbols (coreBindingValue binding) + CoreAssign _ value -> expressionSymbols value + CoreReturn value -> expressionSymbols value + CoreIf condition yes no -> Set.unions (expressionSymbols condition : map statementSymbols (yes ++ no)) + CoreWhile condition body -> Set.union (expressionSymbols condition) (Set.unions (map statementSymbols body)) + CoreDoWhile body condition -> Set.union (Set.unions (map statementSymbols body)) (expressionSymbols condition) + CoreFor condition body update -> + Set.unions (expressionSymbols condition : map statementSymbols (body ++ update)) + CoreEvaluate value -> expressionSymbols value + CoreBreak -> Set.empty + CoreContinue -> Set.empty + +statementsAlwaysReturn :: [CoreStatement] -> Bool +statementsAlwaysReturn [] = False +statementsAlwaysReturn (statement : remaining) = case statement of + CoreReturn _ -> True + CoreIf _ yes no -> + (not (null no) && statementsAlwaysReturn yes && statementsAlwaysReturn no) + || statementsAlwaysReturn remaining + _ -> statementsAlwaysReturn remaining
+ src/Progmasoft/Tala/Core/Optimizer/Constant.hs view
@@ -0,0 +1,395 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +module Progmasoft.Tala.Core.Optimizer.Constant + ( propagateConstants + , simplifyExpression + ) where + +import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Optimizer.Floating (floatingTruthValue, foldFloatingPrimitive) +import Progmasoft.Tala.Core.Optimizer.IntegerFacts +import Progmasoft.Tala.Core.Scalar (coreIntegerBitWidth, coreIntegerIsSigned, integerFitsCoreType) + +type ConstantEnvironment = Map SymbolId CoreExpression + +propagateConstants :: CoreModule -> CoreModule +propagateConstants moduleValue = + moduleValue {coreModuleFunctions = map simplifyFunction (coreModuleFunctions moduleValue)} + +simplifyFunction :: CoreFunction -> CoreFunction +simplifyFunction function = + let (body, _, _) = simplifyStatements Map.empty emptyIntegerFacts (coreFunctionBody function) + in function {coreFunctionBody = body} + +simplifyStatements :: + ConstantEnvironment -> IntegerFacts -> [CoreStatement] -> ([CoreStatement], ConstantEnvironment, IntegerFacts) +simplifyStatements environment facts [] = ([], environment, facts) +simplifyStatements environment facts (statement : remaining) = + let (simplified, nextEnvironment, nextFacts) = simplifyStatement environment facts statement + (rest, finalEnvironment, finalFacts) = + if statementAlwaysReturns simplified + then ([], nextEnvironment, nextFacts) + else simplifyStatements nextEnvironment nextFacts remaining + in (simplified : rest, finalEnvironment, finalFacts) + +simplifyStatement :: + ConstantEnvironment -> IntegerFacts -> CoreStatement -> (CoreStatement, ConstantEnvironment, IntegerFacts) +simplifyStatement environment facts statement = case statement of + CoreBind binding -> + let value = simplifyExpressionWithFacts environment facts (coreBindingValue binding) + changed = binding {coreBindingValue = value} + nextEnvironment + | not (coreBindingMutable binding) + , isPropagatable value = + Map.insert (resolvedSymbol (coreBindingName binding)) value environment + | otherwise = Map.delete (resolvedSymbol (coreBindingName binding)) environment + nextFacts = transferStatementFacts facts (CoreBind changed) + in (CoreBind changed, nextEnvironment, nextFacts) + CoreAssign name value -> + let simplified = simplifyExpressionWithFacts environment facts value + changed = CoreAssign name simplified + in (changed, Map.delete (resolvedSymbol name) environment, transferStatementFacts facts changed) + CoreReturn value -> + let simplified = simplifyExpressionWithFacts environment facts value + changed = CoreReturn simplified + in (changed, environment, transferStatementFacts facts changed) + CoreEvaluate value -> + let simplified = simplifyExpressionWithFacts environment facts value + changed = CoreEvaluate simplified + in (changed, environment, transferStatementFacts facts changed) + CoreIf condition yes no -> + let simplifiedCondition = simplifyExpressionWithFacts environment facts condition + afterCondition = transferExpressionFacts facts simplifiedCondition + trueInput = refineConditionFacts True simplifiedCondition afterCondition + falseInput = refineConditionFacts False simplifiedCondition afterCondition + (simplifiedYes, trueConstants, trueFacts) = simplifyStatements environment trueInput yes + (simplifiedNo, falseConstants, falseFacts) = simplifyStatements environment falseInput no + changed = CoreIf simplifiedCondition simplifiedYes simplifiedNo + knownTruth = conditionTruthFromFacts afterCondition simplifiedCondition + nextConstants = case knownTruth of + Just True -> trueConstants + Just False -> falseConstants + Nothing -> joinConstants environment trueConstants falseConstants + nextFacts = case knownTruth of + Just True -> trueFacts + Just False -> falseFacts + Nothing -> case (statementsAlwaysReturn simplifiedYes, statementsAlwaysReturn simplifiedNo) of + (True, False) -> falseFacts + (False, True) -> trueFacts + (True, True) -> emptyIntegerFacts + (False, False) -> joinIntegerFacts trueFacts falseFacts + in (changed, nextConstants, nextFacts) + CoreWhile condition body -> + let loop = CoreWhile condition body + in case loopFactSummary facts loop of + Nothing -> (loop, Map.empty, emptyIntegerFacts) + Just summary -> + let rewrittenCondition = + simplifyExpressionWithFacts environment (loopConditionFacts summary) condition + (rewrittenBody, _, _) = + simplifyStatements Map.empty (loopBodyFacts summary) body + in (CoreWhile rewrittenCondition rewrittenBody, Map.empty, loopExitFacts summary) + CoreDoWhile body condition -> + let loop = CoreDoWhile body condition + in case loopFactSummary facts loop of + Nothing -> (loop, Map.empty, emptyIntegerFacts) + Just summary -> + let (rewrittenBody, _, _) = + simplifyStatements Map.empty (loopBodyFacts summary) body + rewrittenCondition = + simplifyExpressionWithFacts Map.empty (loopConditionFacts summary) condition + in (CoreDoWhile rewrittenBody rewrittenCondition, Map.empty, loopExitFacts summary) + CoreFor condition body update -> + let loop = CoreFor condition body update + in case loopFactSummary facts loop of + Nothing -> (loop, Map.empty, emptyIntegerFacts) + Just summary -> + let rewrittenCondition = + simplifyExpressionWithFacts environment (loopConditionFacts summary) condition + (rewrittenBody, _, _) = + simplifyStatements Map.empty (loopBodyFacts summary) body + (rewrittenUpdate, _, _) = + simplifyStatements Map.empty (loopUpdateFacts summary) update + in (CoreFor rewrittenCondition rewrittenBody rewrittenUpdate, Map.empty, loopExitFacts summary) + CoreBreak -> (CoreBreak, environment, unreachableIntegerFacts) + CoreContinue -> (CoreContinue, environment, unreachableIntegerFacts) + +joinConstants :: ConstantEnvironment -> ConstantEnvironment -> ConstantEnvironment -> ConstantEnvironment +joinConstants incoming whenTrue whenFalse = + Map.filterWithKey common incoming + where + common symbol _ = Map.lookup symbol whenTrue == Map.lookup symbol whenFalse + +statementAlwaysReturns :: CoreStatement -> Bool +statementAlwaysReturns statement = case statement of + CoreReturn _ -> True + CoreIf _ whenTrue whenFalse -> + not (null whenFalse) && statementsAlwaysReturn whenTrue && statementsAlwaysReturn whenFalse + _ -> False + +statementsAlwaysReturn :: [CoreStatement] -> Bool +statementsAlwaysReturn [] = False +statementsAlwaysReturn (statement : remaining) = statementAlwaysReturns statement || statementsAlwaysReturn remaining + +-- Propagation is intentionally limited to literals. Duplicating calls, +-- closure allocations, or arbitrary primitive trees could change effects or +-- grow code. Algebraic simplification still operates on the use site. +isPropagatable :: CoreExpression -> Bool +isPropagatable CoreLiteral {} = True +isPropagatable _ = False + +simplifyExpression :: ConstantEnvironment -> CoreExpression -> CoreExpression +simplifyExpression environment = simplifyExpressionUsing environment emptyIntegerFacts + +simplifyExpressionWithFacts :: ConstantEnvironment -> IntegerFacts -> CoreExpression -> CoreExpression +simplifyExpressionWithFacts environment facts expression = + simplifyExpressionUsing environment effectiveFacts expression + where + effectiveFacts + | expressionInvokesCallable expression = emptyIntegerFacts + | otherwise = facts + +simplifyExpressionUsing :: ConstantEnvironment -> IntegerFacts -> CoreExpression -> CoreExpression +simplifyExpressionUsing environment facts expression = case expression of + CoreVariable name valueType -> + case Map.lookup (resolvedSymbol name) environment of + Just constant | expressionType constant == valueType -> constant + _ -> expression + CoreLiteral {} -> expression + CoreApply callee arguments valueType -> + CoreApply + (simplifyExpressionUsing environment facts callee) + (map (simplifyExpressionUsing environment facts) arguments) + valueType + CorePrimitive primitive arguments valueType -> + -- The facts are consulted for Boolean results only. Asking them + -- about every node would evaluate the whole operand tree again at + -- each level of an operator chain, which is quadratic in its length. + let simplified = foldPrimitive primitive (map (simplifyExpressionUsing environment facts) arguments) valueType + in if valueType /= boolType || not (withinFactQueryBudget simplified) + then simplified + else case conditionTruthFromFacts facts simplified of + Just truth -> CoreLiteral (CoreBoolean truth) boolType + Nothing -> simplified + CoreLet name bindingType value body valueType -> + let simplifiedValue = simplifyExpressionUsing environment facts value + bodyEnvironment = + if isPropagatable simplifiedValue + then Map.insert (resolvedSymbol name) simplifiedValue environment + else Map.delete (resolvedSymbol name) environment + bodyFacts = transferStatementFacts facts (CoreBind (CoreBinding name bindingType False simplifiedValue)) + in CoreLet name bindingType simplifiedValue (simplifyExpressionWithFacts bodyEnvironment bodyFacts body) valueType + CoreConditional condition whenTrue whenFalse valueType -> + let simplifiedCondition = simplifyExpressionUsing environment facts condition + afterCondition = transferExpressionFacts facts simplifiedCondition + simplifyArm desired = + simplifyExpressionWithFacts + environment + (refineConditionFacts desired simplifiedCondition afterCondition) + in -- A literal test has no effects, so the conditional is its selected arm. + case simplifiedCondition of + CoreLiteral (CoreBoolean selected) _ -> + if selected then simplifyArm True whenTrue else simplifyArm False whenFalse + CoreLiteral (CoreInteger selected) _ -> + if selected /= 0 then simplifyArm True whenTrue else simplifyArm False whenFalse + _ -> CoreConditional simplifiedCondition (simplifyArm True whenTrue) (simplifyArm False whenFalse) valueType + CoreClosure captures parameters returnType body valueType -> + let simplifiedCaptures = map simplifyCapture captures + captureConstants = + [ (resolvedSymbol (coreCaptureName capture), coreCaptureValue capture) + | capture <- simplifiedCaptures + , isPropagatable (coreCaptureValue capture) + ] + parameterSymbols = map (resolvedSymbol . fst) parameters + bodyEnvironment = foldr Map.delete (Map.fromList captureConstants) parameterSymbols + -- Captures may name mutable storage through a cell. Constant + -- propagation preserves the legacy literal case above, but a + -- zero-ness proof must not assume that a captured value stays + -- unchanged between closure creation and invocation. + bodyFacts = emptyIntegerFacts + (simplifiedBody, _, _) = simplifyStatements bodyEnvironment bodyFacts body + in CoreClosure simplifiedCaptures parameters returnType simplifiedBody valueType + where + simplifyCapture capture = + capture {coreCaptureValue = simplifyExpressionWithFacts environment facts (coreCaptureValue capture)} + +{- | The largest condition, in expression nodes, whose truth is looked up in +the integer facts while it is simplified. + +The lookup walks the condition, and it is made at every Boolean node from +the leaves up, so on a chain of @&&@ or @||@ its cost grows with a power of +the length of the chain: 200 comparisons took 47 seconds. A condition of +ordinary size is far below the budget. A longer one is still simplified by +folding; only the facts are not asked about its larger parts. +-} +factQueryNodeBudget :: Int +factQueryNodeBudget = 256 + +{- | Whether an expression has at most 'factQueryNodeBudget' nodes; the +count stops as soon as the budget is exceeded. +-} +withinFactQueryBudget :: CoreExpression -> Bool +withinFactQueryBudget root = go factQueryNodeBudget [root] + where + go _ [] = True + go remaining (expression : pending) + | remaining <= 0 = False + | otherwise = go (remaining - 1) (children expression ++ pending) + children expression = case expression of + CoreVariable {} -> [] + CoreLiteral {} -> [] + CoreApply callee arguments _ -> callee : arguments + CorePrimitive _ arguments _ -> arguments + CoreLet _ _ value body _ -> [value, body] + CoreConditional condition whenTrue whenFalse _ -> [condition, whenTrue, whenFalse] + CoreClosure captures _ _ _ _ -> map coreCaptureValue captures + +foldPrimitive :: CorePrimitive -> [CoreExpression] -> Type -> CoreExpression +foldPrimitive primitive arguments valueType = + case evaluatePrimitive primitive arguments valueType of + Just folded -> folded + Nothing -> simplifyIdentity primitive arguments valueType + +evaluatePrimitive :: CorePrimitive -> [CoreExpression] -> Type -> Maybe CoreExpression +evaluatePrimitive primitive arguments valueType = + case (primitive, mapM integerLiteral arguments) of + (CoreAdd, Just [a, b]) -> integer (a + b) + (CoreSubtract, Just [a, b]) -> integer (a - b) + (CoreMultiply, Just [a, b]) -> integer (a * b) + (CoreDivide, Just [a, b]) | b /= 0 -> integer (a `quot` b) + (CoreFloorDivide, Just [a, b]) | b /= 0 -> integer (roundedIntegerDivision a b) + (CoreRemainder, Just [a, b]) | b /= 0 -> integer (a `rem` b) + (CoreNegate, Just [value]) -> integer (-value) + (CorePower, Just [base, exponentValue]) -> integerPower base exponentValue + (CoreShiftLeft, Just [value, amount]) -> shiftInteger shiftL value amount + (CoreShiftRight, Just [value, amount]) -> shiftInteger shiftR value amount + (CoreBitwiseNot, Just [value]) -> bitwiseComplement value + (CoreBitwiseAnd, Just [a, b]) -> integer (a .&. b) + (CoreBitwiseXor, Just [a, b]) -> integer (xor a b) + (CoreBitwiseOr, Just [a, b]) -> integer (a .|. b) + (CoreBitwiseNot, Just [value]) -> integer (complement value) + (CoreLessThan, Just [a, b]) -> Just (boolean (a < b)) + (CoreLessEqual, Just [a, b]) -> Just (boolean (a <= b)) + (CoreGreaterThan, Just [a, b]) -> Just (boolean (a > b)) + (CoreGreaterEqual, Just [a, b]) -> Just (boolean (a >= b)) + (CoreEqual, Just [a, b]) -> Just (boolean (a == b)) + (CoreNotEqual, Just [a, b]) -> Just (boolean (a /= b)) + _ -> case foldFloatingPrimitive primitive arguments valueType of + Just folded -> Just folded + Nothing -> evaluateBoolean primitive arguments + where + integer result + | integerFitsCoreType valueType result = Just (CoreLiteral (CoreInteger result) valueType) + | otherwise = Nothing + boolean result = CoreLiteral (CoreBoolean result) boolType + integerPower base exponentValue = boundedPower base exponentValue + boundedPower base exponentValue + | exponentValue < 0 = Nothing + | base == 0 = integer (if exponentValue == 0 then 1 else 0) + | base == 1 = integer 1 + | base == -1 = integer (if even exponentValue then 1 else -1) + | otherwise = powerLoop 1 base exponentValue + powerLoop accumulated factor remaining + | remaining == 0 = integer accumulated + | otherwise = + let (nextAccumulated, canContinue) = + if odd remaining + then + let nextProduct = accumulated * factor + in (nextProduct, integerFitsCoreType valueType nextProduct) + else (accumulated, True) + nextRemaining = remaining `quot` 2 + in if not canContinue + then Nothing + else + if nextRemaining == 0 + then integer nextAccumulated + else + let squaredFactor = factor * factor + in if integerFitsCoreType valueType squaredFactor + then powerLoop nextAccumulated squaredFactor nextRemaining + else Nothing + shiftInteger shift value amount = do + width <- coreIntegerBitWidth valueType + if amount < 0 || amount >= toInteger width + then Nothing + else integer (shift value (fromInteger amount)) + bitwiseComplement value = do + width <- coreIntegerBitWidth valueType + isSigned <- coreIntegerIsSigned valueType + let complemented = + if isSigned + then complement value + else complement value .&. ((1 `shiftL` width) - 1) + integer complemented + +roundedIntegerDivision :: Integer -> Integer -> Integer +roundedIntegerDivision dividend divisor = + let (quotient, remainder) = dividend `quotRem` divisor + adjustment = signum dividend * signum divisor + in if 2 * abs remainder >= abs divisor then quotient + adjustment else quotient + +evaluateBoolean :: CorePrimitive -> [CoreExpression] -> Maybe CoreExpression +evaluateBoolean primitive arguments = case (primitive, mapM truthValue arguments) of + -- Equality compares Boolean values only here. Numeric equality has its own + -- exact-value rule above and must never fall back to truthiness comparison. + (CoreEqual, Just [left, right]) | all booleanLiteral arguments -> Just (boolean (left == right)) + (CoreNotEqual, Just [left, right]) | all booleanLiteral arguments -> Just (boolean (left /= right)) + (CoreLogicalNot, Just [value]) -> Just (boolean (not value)) + (CoreLogicalAnd, Just [left, right]) -> Just (boolean (left && right)) + (CoreLogicalOr, Just [left, right]) -> Just (boolean (left || right)) + _ -> Nothing + where + boolean result = CoreLiteral (CoreBoolean result) boolType + +booleanLiteral :: CoreExpression -> Bool +booleanLiteral (CoreLiteral (CoreBoolean _) _) = True +booleanLiteral _ = False + +-- View patterns would obscure the data-flow rules in diagnostics, so literal +-- extraction remains explicit and total. +integerLiteral :: CoreExpression -> Maybe Integer +integerLiteral (CoreLiteral (CoreInteger value) _) = Just value +integerLiteral _ = Nothing + +truthValue :: CoreExpression -> Maybe Bool +truthValue (CoreLiteral (CoreBoolean value) _) = Just value +truthValue (CoreLiteral (CoreInteger value) _) = Just (value /= 0) +truthValue expression@CoreLiteral {} = floatingTruthValue expression +truthValue _ = Nothing + +simplifyIdentity :: CorePrimitive -> [CoreExpression] -> Type -> CoreExpression +simplifyIdentity primitive arguments valueType = case (primitive, arguments) of + (CoreAdd, [value, zero]) | isIntegerLiteral 0 zero -> value + (CoreAdd, [zero, value]) | isIntegerLiteral 0 zero -> value + (CoreSubtract, [value, zero]) | isIntegerLiteral 0 zero -> value + (CoreMultiply, [value, one]) | isIntegerLiteral 1 one -> value + (CoreMultiply, [one, value]) | isIntegerLiteral 1 one -> value + (CoreDivide, [value, one]) | isIntegerLiteral 1 one -> value + (CoreFloorDivide, [value, one]) + | isIntegerLiteral 1 one + , expressionType value == valueType -> + value + (CoreRemainder, [value, one]) + | isIntegerLiteral 1 one, isSimpleValue value -> CoreLiteral (CoreInteger 0) valueType + (CoreNegate, [CorePrimitive CoreNegate [value] innerType]) + | innerType == valueType -> value + (CoreLogicalNot, [CorePrimitive CoreLogicalNot [value] innerType]) + | innerType == boolType, expressionType value == boolType -> value + _ -> CorePrimitive primitive arguments valueType + +-- Remainder-by-one may erase evaluation only for values which cannot carry +-- an effect. More general expressions remain intact until an effect-aware +-- rewrite can preserve their evaluation explicitly. +isSimpleValue :: CoreExpression -> Bool +isSimpleValue CoreVariable {} = True +isSimpleValue CoreLiteral {} = True +isSimpleValue _ = False + +isIntegerLiteral :: Integer -> CoreExpression -> Bool +isIntegerLiteral expected expression = integerLiteral expression == Just expected
+ src/Progmasoft/Tala/Core/Optimizer/ControlFlow.hs view
@@ -0,0 +1,112 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +module Progmasoft.Tala.Core.Optimizer.ControlFlow + ( simplifyControlFlow + , simplifyControlFlowWith + ) where + +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Optimizer.Analysis + +simplifyControlFlow :: CoreModule -> CoreModule +simplifyControlFlow = simplifyControlFlowWith emptyEffectEnvironment + +simplifyControlFlowWith :: EffectEnvironment -> CoreModule -> CoreModule +simplifyControlFlowWith environment moduleValue = + moduleValue {coreModuleFunctions = map (simplifyFunction environment) (coreModuleFunctions moduleValue)} + +simplifyFunction :: EffectEnvironment -> CoreFunction -> CoreFunction +simplifyFunction environment function = + function {coreFunctionBody = simplifyStatements environment (coreFunctionBody function)} + +simplifyStatements :: EffectEnvironment -> [CoreStatement] -> [CoreStatement] +simplifyStatements _ [] = [] +simplifyStatements environment (statement : remaining) = + let current = simplifyStatement environment statement + in if statementsAlwaysReturn current + then current + else current ++ simplifyStatements environment remaining + +simplifyStatement :: EffectEnvironment -> CoreStatement -> [CoreStatement] +simplifyStatement environment statement = case statement of + CoreBind binding -> + [CoreBind binding {coreBindingValue = simplifyNestedExpression environment (coreBindingValue binding)}] + CoreAssign name value -> [CoreAssign name (simplifyNestedExpression environment value)] + CoreReturn value -> [CoreReturn (simplifyNestedExpression environment value)] + CoreEvaluate value -> [CoreEvaluate (simplifyNestedExpression environment value)] + CoreIf condition yes no -> + let simplifiedCondition = simplifyNestedExpression environment condition + simplifiedYes = simplifyStatements environment yes + simplifiedNo = simplifyStatements environment no + in case conditionTruth simplifiedCondition of + Just True -> simplifiedYes + Just False -> simplifiedNo + Nothing + | simplifiedYes == simplifiedNo -> + preserveCondition environment simplifiedCondition simplifiedYes + | null simplifiedYes && null simplifiedNo -> + preserveCondition environment simplifiedCondition [] + | otherwise -> [CoreIf simplifiedCondition simplifiedYes simplifiedNo] + CoreWhile condition body -> + [CoreWhile (simplifyNestedExpression environment condition) (simplifyStatements environment body)] + CoreDoWhile body condition -> + [CoreDoWhile (simplifyStatements environment body) (simplifyNestedExpression environment condition)] + CoreFor condition body update -> + [ CoreFor + (simplifyNestedExpression environment condition) + (simplifyStatements environment body) + (simplifyStatements environment update) + ] + CoreBreak -> [CoreBreak] + CoreContinue -> [CoreContinue] + +preserveCondition :: EffectEnvironment -> CoreExpression -> [CoreStatement] -> [CoreStatement] +preserveCondition environment condition statements + | discardableExpressionWith environment condition = statements + | otherwise = CoreEvaluate condition : statements + +conditionTruth :: CoreExpression -> Maybe Bool +conditionTruth expression = case expression of + CoreLiteral (CoreBoolean value) _ -> Just value + CoreLiteral (CoreInteger value) _ -> Just (value /= 0) + _ -> Nothing + +simplifyNestedExpression :: EffectEnvironment -> CoreExpression -> CoreExpression +simplifyNestedExpression environment expression = case expression of + CoreVariable {} -> expression + CoreLiteral {} -> expression + CoreApply callee arguments valueType -> + CoreApply + (simplifyNestedExpression environment callee) + (map (simplifyNestedExpression environment) arguments) + valueType + CorePrimitive primitive arguments valueType -> + CorePrimitive primitive (map (simplifyNestedExpression environment) arguments) valueType + CoreLet name bindingType value body valueType -> + CoreLet + name + bindingType + (simplifyNestedExpression environment value) + (simplifyNestedExpression environment body) + valueType + CoreConditional condition whenTrue whenFalse valueType -> + let simplifiedCondition = simplifyNestedExpression environment condition + in case conditionTruth simplifiedCondition of + Just True -> simplifyNestedExpression environment whenTrue + Just False -> simplifyNestedExpression environment whenFalse + Nothing -> + CoreConditional + simplifiedCondition + (simplifyNestedExpression environment whenTrue) + (simplifyNestedExpression environment whenFalse) + valueType + CoreClosure captures parameters returnType body valueType -> + CoreClosure + [ capture {coreCaptureValue = simplifyNestedExpression environment (coreCaptureValue capture)} + | capture <- captures + ] + parameters + returnType + (simplifyStatements environment body) + valueType
+ src/Progmasoft/Tala/Core/Optimizer/EffectInference.hs view
@@ -0,0 +1,271 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Interprocedural effect inference for verified Core. + +The analysis proves only effects needed for safe dead-result elimination. A +direct call is removable when its complete transitive call graph is known, +non-recursive, allocation-free and failure-free. Unknown and indirect calls +remain observable. Recursive SCCs remain observable because removing a call +could remove nontermination even when every expression is otherwise pure. +-} +module Progmasoft.Tala.Core.Optimizer.EffectInference + ( inferFunctionEffects + ) where + +import Data.Graph (SCC (..), stronglyConnComp) +import Data.List (sort) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Progmasoft.Tala.AST (ResolvedName, SymbolId, resolvedSymbol) +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Optimizer.Analysis +import Progmasoft.Tala.Core.Optimizer.IntegerFacts + +data DirectFacts = DirectFacts + { directLocalEffect :: Effect + , directCallees :: Set SymbolId + , directHasUnknownCall :: Bool + } + deriving (Eq, Ord, Read, Show) + +emptyDirectFacts :: DirectFacts +emptyDirectFacts = DirectFacts PureEffect Set.empty False + +combineFacts :: DirectFacts -> DirectFacts -> DirectFacts +combineFacts left right = + DirectFacts + { directLocalEffect = combineEffect (directLocalEffect left) (directLocalEffect right) + , directCallees = Set.union (directCallees left) (directCallees right) + , directHasUnknownCall = directHasUnknownCall left || directHasUnknownCall right + } + +inferFunctionEffects :: CoreModule -> (EffectEnvironment, [FunctionEffectReport]) +inferFunctionEffects moduleValue = + let functions = coreModuleFunctions moduleValue + catalog = Map.fromList [(resolvedSymbol (coreFunctionName function), function) | function <- functions] + knownSymbols = Map.keysSet catalog + pureKnown = effectEnvironment [(symbol, PureEffect) | symbol <- Map.keys catalog] + facts = Map.map (functionFacts knownSymbols pureKnown) catalog + recursive = recursiveSymbols facts + initial = Map.mapWithKey (initialEffect recursive) facts + solved = solveEffects recursive facts initial + reports = map (functionReport facts recursive solved) functions + in (effectEnvironment (Map.toAscList solved), reports) + +initialEffect :: Set SymbolId -> SymbolId -> DirectFacts -> Effect +initialEffect recursive symbol facts + | Set.member symbol recursive = DivergenceEffect + | directHasUnknownCall facts = combineEffect CallEffect (directLocalEffect facts) + | otherwise = directLocalEffect facts + +solveEffects :: Set SymbolId -> Map SymbolId DirectFacts -> Map SymbolId Effect -> Map SymbolId Effect +solveEffects recursive facts initial = go 0 initial + where + maximumIterations = Map.size facts + 1 + go iteration current + | iteration >= maximumIterations = current + | next == current = current + | otherwise = go (iteration + 1) next + where + next = Map.mapWithKey (resolveOne current) facts + resolveOne current symbol direct = + foldl' + combineEffect + (initialEffect recursive symbol direct) + [Map.findWithDefault CallEffect callee current | callee <- Set.toAscList (directCallees direct)] + +functionReport :: + Map SymbolId DirectFacts -> Set SymbolId -> Map SymbolId Effect -> CoreFunction -> FunctionEffectReport +functionReport facts recursive solved function = + let name = coreFunctionName function + symbol = resolvedSymbol name + direct = Map.findWithDefault emptyDirectFacts symbol facts + in FunctionEffectReport + { effectFunctionName = name + , effectClassification = Map.findWithDefault CallEffect symbol solved + , effectDirectCallees = Set.toAscList (directCallees direct) + , effectHasUnknownCall = directHasUnknownCall direct + , effectIsRecursive = Set.member symbol recursive + } + +recursiveSymbols :: Map SymbolId DirectFacts -> Set SymbolId +recursiveSymbols facts = + Set.fromList + [ symbol + | component <- stronglyConnComp graphNodes + , symbol <- cyclicMembers component + ] + where + graphNodes = + [ (symbol, symbol, Set.toAscList (directCallees direct)) + | (symbol, direct) <- Map.toAscList facts + ] + cyclicMembers (CyclicSCC symbols) = sort symbols + cyclicMembers (AcyclicSCC _) = [] + +functionFacts :: Set SymbolId -> EffectEnvironment -> CoreFunction -> DirectFacts +functionFacts knownSymbols pureKnown function = + fst (statementsFacts knownSymbols pureKnown emptyIntegerFacts (coreFunctionBody function)) + +statementsFacts :: + Set SymbolId -> + EffectEnvironment -> + IntegerFacts -> + [CoreStatement] -> + (DirectFacts, IntegerFacts) +statementsFacts _ _ facts _ | isUnreachableFacts facts = (emptyDirectFacts, unreachableIntegerFacts) +statementsFacts _ _ facts [] = (emptyDirectFacts, facts) +statementsFacts knownSymbols pureKnown facts (statement : remaining) = + let (current, afterCurrent) = statementFacts knownSymbols pureKnown facts statement + in if statementAlwaysReturns statement + then (current, afterCurrent) + else + let (later, finalFacts) = statementsFacts knownSymbols pureKnown afterCurrent remaining + in (combineFacts current later, finalFacts) + +statementAlwaysReturns :: CoreStatement -> Bool +statementAlwaysReturns (CoreReturn _) = True +statementAlwaysReturns (CoreIf _ yes no) = not (null no) && statementsAlwaysReturn yes && statementsAlwaysReturn no +statementAlwaysReturns _ = False + +statementFacts :: Set SymbolId -> EffectEnvironment -> IntegerFacts -> CoreStatement -> (DirectFacts, IntegerFacts) +statementFacts knownSymbols pureKnown facts statement = case statement of + CoreBind binding -> + let (valueFacts, _) = expressionFacts knownSymbols pureKnown facts (coreBindingValue binding) + in (valueFacts, transferStatementFacts facts statement) + CoreAssign _ value -> + let (valueFacts, _) = expressionFacts knownSymbols pureKnown facts value + in (valueFacts, transferStatementFacts facts statement) + CoreReturn value -> + let (valueFacts, _) = expressionFacts knownSymbols pureKnown facts value + in (valueFacts, transferStatementFacts facts statement) + CoreEvaluate value -> + let (valueFacts, _) = expressionFacts knownSymbols pureKnown facts value + in (valueFacts, transferStatementFacts facts statement) + CoreIf condition yes no -> + let (conditionFacts, afterCondition) = expressionFacts knownSymbols pureKnown facts condition + whenTrue = refineConditionFacts True condition afterCondition + whenFalse = refineConditionFacts False condition afterCondition + knownTruth = conditionTruthFromFacts afterCondition condition + (trueFacts, afterTrue) = statementsFacts knownSymbols pureKnown whenTrue yes + (falseFacts, afterFalse) = statementsFacts knownSymbols pureKnown whenFalse no + trueUnreachable = isUnreachableFacts whenTrue + falseUnreachable = isUnreachableFacts whenFalse + branchFacts = case knownTruth of + Just True -> trueFacts + Just False -> falseFacts + Nothing + | trueUnreachable -> falseFacts + | falseUnreachable -> trueFacts + | otherwise -> combineFacts trueFacts falseFacts + continuationFacts = case knownTruth of + Just True -> afterTrue + Just False -> afterFalse + Nothing + | trueUnreachable -> afterFalse + | falseUnreachable -> afterTrue + | otherwise -> case (statementsAlwaysReturn yes, statementsAlwaysReturn no) of + (True, False) -> afterFalse + (False, True) -> afterTrue + (True, True) -> unreachableIntegerFacts + (False, False) -> joinIntegerFacts afterTrue afterFalse + in (combineFacts conditionFacts branchFacts, continuationFacts) + CoreWhile condition body -> + let summary = loopFactSummary facts statement + conditionInput = maybe emptyIntegerFacts loopConditionFacts summary + bodyInput = maybe emptyIntegerFacts loopBodyFacts summary + (conditionFacts, _) = expressionFacts knownSymbols pureKnown conditionInput condition + (bodyFacts, _) = statementsFacts knownSymbols pureKnown bodyInput body + divergence = emptyDirectFacts {directLocalEffect = DivergenceEffect} + afterLoop = maybe emptyIntegerFacts loopExitFacts summary + in (combineFacts divergence (combineFacts conditionFacts bodyFacts), afterLoop) + CoreDoWhile body condition -> + let summary = loopFactSummary facts statement + bodyInput = maybe emptyIntegerFacts loopBodyFacts summary + conditionInput = maybe emptyIntegerFacts loopConditionFacts summary + (bodyFacts, _) = statementsFacts knownSymbols pureKnown bodyInput body + (conditionFacts, _) = expressionFacts knownSymbols pureKnown conditionInput condition + divergence = emptyDirectFacts {directLocalEffect = DivergenceEffect} + afterLoop = maybe emptyIntegerFacts loopExitFacts summary + in (combineFacts divergence (combineFacts bodyFacts conditionFacts), afterLoop) + CoreFor condition body update -> + let summary = loopFactSummary facts statement + conditionInput = maybe emptyIntegerFacts loopConditionFacts summary + bodyInput = maybe emptyIntegerFacts loopBodyFacts summary + updateInput = maybe emptyIntegerFacts loopUpdateFacts summary + (conditionFacts, _) = expressionFacts knownSymbols pureKnown conditionInput condition + (bodyFacts, _) = statementsFacts knownSymbols pureKnown bodyInput body + (updateFacts, _) = statementsFacts knownSymbols pureKnown updateInput update + divergence = emptyDirectFacts {directLocalEffect = DivergenceEffect} + afterLoop = maybe emptyIntegerFacts loopExitFacts summary + in (combineFacts divergence (combineFacts conditionFacts (combineFacts bodyFacts updateFacts)), afterLoop) + CoreBreak -> (emptyDirectFacts, unreachableIntegerFacts) + CoreContinue -> (emptyDirectFacts, unreachableIntegerFacts) + +expressionFacts :: + Set SymbolId -> + EffectEnvironment -> + IntegerFacts -> + CoreExpression -> + (DirectFacts, IntegerFacts) +expressionFacts _ _ facts _ | isUnreachableFacts facts = (emptyDirectFacts, unreachableIntegerFacts) +expressionFacts _ _ facts (CoreVariable _ _) = (emptyDirectFacts, facts) +expressionFacts _ _ facts (CoreLiteral _ _) = (emptyDirectFacts, facts) +expressionFacts knownSymbols pureKnown facts (CorePrimitive primitive arguments _) = + let (children, afterArguments) = expressionListFacts knownSymbols pureKnown facts arguments + provenNonzero = case (primitive, arguments) of + (CoreDivide, [_, CoreVariable name _]) -> knownNonzero afterArguments name + (CoreFloorDivide, [_, CoreVariable name _]) -> knownNonzero afterArguments name + (CoreRemainder, [_, CoreVariable name _]) -> knownNonzero afterArguments name + _ -> False + local = primitiveEffectWithProvenNonzeroDivisor provenNonzero primitive arguments + in (children {directLocalEffect = combineEffect local (directLocalEffect children)}, afterArguments) +expressionFacts knownSymbols pureKnown facts (CoreLet name valueType value body _) = + let (valueFacts, afterValue) = expressionFacts knownSymbols pureKnown facts value + boundState = transferStatementFacts afterValue (CoreBind (CoreBinding name valueType False value)) + (bodyFacts, afterBody) = expressionFacts knownSymbols pureKnown boundState body + in (combineFacts valueFacts bodyFacts, afterBody) +expressionFacts knownSymbols pureKnown facts (CoreConditional condition whenTrue whenFalse _) = + -- Summaries are path-insensitive: both arms contribute their direct + -- effects and callees, and the continuation keeps only shared facts. + let (conditionFacts, afterCondition) = expressionFacts knownSymbols pureKnown facts condition + (trueFacts, afterTrue) = + expressionFacts knownSymbols pureKnown (refineConditionFacts True condition afterCondition) whenTrue + (falseFacts, afterFalse) = + expressionFacts knownSymbols pureKnown (refineConditionFacts False condition afterCondition) whenFalse + in (combineFacts conditionFacts (combineFacts trueFacts falseFacts), joinIntegerFacts afterTrue afterFalse) +expressionFacts knownSymbols pureKnown facts (CoreApply callee arguments _) = + let (children, _) = expressionListFacts knownSymbols pureKnown facts (callee : arguments) + invoked = case directCallee callee of + Just symbol + | Set.member symbol knownSymbols -> + children {directCallees = Set.insert symbol (directCallees children)} + _ -> children {directHasUnknownCall = True} + in (invoked, emptyIntegerFacts) +expressionFacts knownSymbols pureKnown facts (CoreClosure captures _ _ _ _) = + let values = map coreCaptureValue captures + (children, afterCaptures) = expressionListFacts knownSymbols pureKnown facts values + in (children {directLocalEffect = combineEffect AllocationEffect (directLocalEffect children)}, afterCaptures) + +expressionListFacts :: + Set SymbolId -> + EffectEnvironment -> + IntegerFacts -> + [CoreExpression] -> + (DirectFacts, IntegerFacts) +expressionListFacts _ _ facts [] = (emptyDirectFacts, facts) +expressionListFacts knownSymbols pureKnown facts (expression : remaining) = + let (current, afterCurrent) = expressionFacts knownSymbols pureKnown facts expression + (later, finalFacts) = expressionListFacts knownSymbols pureKnown afterCurrent remaining + in (combineFacts current later, finalFacts) + +directCallee :: CoreExpression -> Maybe SymbolId +directCallee (CoreVariable name _) = Just (resolvedSymbol name) +directCallee _ = Nothing + +knownNonzero :: IntegerFacts -> ResolvedName -> Bool +knownNonzero facts name = + maybe False factProvesNonzero (lookupIntegerFact facts (resolvedSymbol name))
+ src/Progmasoft/Tala/Core/Optimizer/Floating.hs view
@@ -0,0 +1,447 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Target-independent IEEE-754 folding for the Core optimizer. + +The frontend intentionally carries decimal floating spellings all the way to +LLVM. Constant folding must not take a shortcut through the host's 'Double': +that would silently make binary128 behave like binary64, and it would make +results depend on the machine running the compiler. This module instead uses +exact integer ratios, rounds once to the Tala destination format, and +prints a short decimal spelling that reads back to the same target value. + +Only operations whose result is specified by basic IEEE arithmetic are folded +here. Transcendentals, power, and implementation-dependent NaN payload +operations remain in the backend. That boundary is intentionally narrow: +getting fewer folds is preferable to changing a program's floating result. +-} +module Progmasoft.Tala.Core.Optimizer.Floating + ( foldFloatingPrimitive + , floatingTruthValue + ) where + +import Data.Bits (countLeadingZeros, shiftR) +import Data.Ratio (denominator, numerator, (%)) +import Data.Word (Word64) +import Progmasoft.Tala.AST (Type, boolType) +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Scalar (coreTypeSpelling, integerFitsCoreType) + +data BinaryFormat = BinaryFormat + { formatPrecision :: Int + , formatMinimumExponent :: Int + , formatMaximumExponent :: Int + } + deriving (Eq, Ord, Read, Show) + +-- The bias and exponent-field widths are derived from IEEE-754's four public +-- floating types rather than from the host's platform ABI. +formatFor :: Type -> Maybe BinaryFormat +formatFor valueType = case coreTypeSpelling valueType of + "sfloat" -> Just (BinaryFormat 11 (-14) 15) + "lfloat" -> Just (BinaryFormat 24 (-126) 127) + "float" -> Just (BinaryFormat 53 (-1022) 1023) + "double" -> Just (BinaryFormat 113 (-16382) 16383) + _ -> Nothing + +data FloatingValue + = NotANumber + | Infinity Bool + | Finite Bool Rational + deriving (Eq, Ord, Read, Show) + +-- The optimizer may decline to fold a legal literal without changing the +-- language's accepted input. This cap keeps exact Rational construction +-- bounded for externally supplied Core while leaving ample headroom over the +-- 36 significant decimal digits needed to round-trip binary128. +maximumFoldedSignificantDigits :: Int +maximumFoldedSignificantDigits = 512 + +-- The Boolean records the sign bit even when the rational magnitude is zero. +-- Rational itself has no representation for negative zero, so discarding this +-- bit would make `-0.0 + -0.0` observably wrong. +parseFloatingValue :: BinaryFormat -> String -> Maybe FloatingValue +parseFloatingValue format spelling = do + let (negative, unsigned) = stripLeadingSign spelling + case unsigned of + "nan" -> Just NotANumber + "inf" -> Just (Infinity negative) + _ -> do + (coefficient, decimalScale, significantDigits) <- parseDecimal unsigned + if coefficient == 0 + then Just (Finite negative 0) + else + if decimalOrder significantDigits decimalScale > toInteger (formatMaximumExponent format) + then Just (Infinity negative) + else + if isDefinitelyBelowHalfMinSubnormal format significantDigits decimalScale + then Just (Finite negative 0) + else do + exact <- decimalRational coefficient decimalScale + Just (roundToFormat format negative exact) + +stripLeadingSign :: String -> (Bool, String) +stripLeadingSign ('+' : remaining) = (False, remaining) +stripLeadingSign ('-' : remaining) = (True, remaining) +stripLeadingSign value = (False, value) + +-- Return the integer coefficient, its power-of-ten scale, and the count of +-- significant digits. Core verification has already bounded the text payload +-- and checked the decimal grammar before the optimizer reaches this parser. +parseDecimal :: String -> Maybe (Integer, Integer, Int) +parseDecimal spelling = do + let (mantissa, exponentText) = break (`elem` "eE") spelling + exponentValue = case exponentText of + [] -> Just 0 + _ : rest -> readSignedDecimal rest + (whole, fractionWithPoint) = break (== '.') mantissa + fraction = case fractionWithPoint of + [] -> [] + _ : remaining -> remaining + digits = whole ++ fraction + decimalExponent <- exponentValue + if null digits || any (not . isAsciiDigit) digits + then Nothing + else + let leadingZeroesRemoved = dropWhile (== '0') digits + in if null leadingZeroesRemoved + then Just (0, 0, 1) + else + let trailingZeroes = length (takeWhile (== '0') (reverse leadingZeroesRemoved)) + significantSpelling = take (length leadingZeroesRemoved - trailingZeroes) leadingZeroesRemoved + significantDigits = length significantSpelling + scale = decimalExponent - toInteger (length fraction) + toInteger trailingZeroes + in if significantDigits > maximumFoldedSignificantDigits + then Nothing + else Just (read significantSpelling, scale, significantDigits) + +readSignedDecimal :: String -> Maybe Integer +readSignedDecimal spelling = case spelling of + [] -> Nothing + '+' : digits -> readDigits False digits + '-' : digits -> readDigits True digits + digits -> readDigits False digits + where + readDigits negative digits + | null digits || length digits > 19 || any (not . isAsciiDigit) digits = Nothing + | otherwise = + let value = read digits + in Just (if negative then negate value else value) + +isAsciiDigit :: Char -> Bool +isAsciiDigit value = value >= '0' && value <= '9' + +decimalOrder :: Int -> Integer -> Integer +decimalOrder significantDigits scale = toInteger significantDigits - 1 + scale + +-- These conservative decimal bounds avoid constructing a huge power of ten +-- for hostile artifact literals. They are deliberately outside the rounding +-- boundary, so every value near zero is still handled by exact arithmetic. +isDefinitelyBelowHalfMinSubnormal :: BinaryFormat -> Int -> Integer -> Bool +isDefinitelyBelowHalfMinSubnormal format significantDigits scale = + decimalOrder significantDigits scale < toInteger (minimumSubnormalExponent format `div` 3 - 2) + +decimalRational :: Integer -> Integer -> Maybe Rational +decimalRational coefficient scale + | scale > 10000 || scale < -10000 = Nothing + | scale >= 0 = Just (coefficient * (10 ^ (fromInteger scale :: Int)) % 1) + | otherwise = Just (coefficient % (10 ^ (fromInteger (negate scale) :: Int))) + +minimumSubnormalExponent :: BinaryFormat -> Int +minimumSubnormalExponent format = formatMinimumExponent format - (formatPrecision format - 1) + +roundToFormat :: BinaryFormat -> Bool -> Rational -> FloatingValue +roundToFormat format negative exact + | exact == 0 = Finite negative 0 + | binaryExponent < formatMinimumExponent format = + let quantum = minimumSubnormalExponent format + subnormalSignificand = roundRatioToEven (scaleByPowerOfTwo exact (negate quantum)) + in if subnormalSignificand == 0 + then Finite negative 0 + else Finite negative (scaleByPowerOfTwo (subnormalSignificand % 1) quantum) + | otherwise = + let quantum = binaryExponent - (formatPrecision format - 1) + roundedSignificand = roundRatioToEven (scaleByPowerOfTwo exact (negate quantum)) + (finalExponent, finalSignificand) = + if roundedSignificand == 2 ^ formatPrecision format + then (binaryExponent + 1, roundedSignificand `quot` 2) + else (binaryExponent, roundedSignificand) + in if finalExponent > formatMaximumExponent format + then Infinity negative + else Finite negative (scaleByPowerOfTwo (finalSignificand % 1) (finalExponent - (formatPrecision format - 1))) + where + binaryExponent = floorLog2 exact + +-- IEEE-754 roundTiesToEven expressed entirely with nonnegative integers. +roundRatioToEven :: Rational -> Integer +roundRatioToEven value = + let top = numerator value + bottom = denominator value + (quotient, remainder) = top `quotRem` bottom + twiceRemainder = 2 * remainder + in case compare twiceRemainder bottom of + LT -> quotient + GT -> quotient + 1 + EQ -> if even quotient then quotient else quotient + 1 + +scaleByPowerOfTwo :: Rational -> Int -> Rational +scaleByPowerOfTwo value binaryExponent + | binaryExponent >= 0 = (numerator value * 2 ^ binaryExponent) % denominator value + | otherwise = numerator value % (denominator value * 2 ^ negate binaryExponent) + +floorLog2 :: Rational -> Int +floorLog2 value = + let top = numerator value + bottom = denominator value + estimate = integerBitLength top - integerBitLength bottom + in if compareToPowerOfTwo top bottom estimate == LT then estimate - 1 else estimate + +compareToPowerOfTwo :: Integer -> Integer -> Int -> Ordering +compareToPowerOfTwo top bottom binaryExponent + | binaryExponent >= 0 = compare top (bottom * 2 ^ binaryExponent) + | otherwise = compare (top * 2 ^ negate binaryExponent) bottom + +integerBitLength :: Integer -> Int +integerBitLength value + | value <= 0 = 0 + | value <= toInteger (maxBound :: Word64) = + 64 - countLeadingZeros (fromInteger value :: Word64) + | otherwise = 64 + integerBitLength (value `shiftR` 64) + +-- Find the shortest significant decimal that round-trips to the already +-- rounded target value. The maximum digit formula is the standard conservative +-- bound for a binary format; trying each shorter length keeps common results +-- compact without asking a host floating formatter to choose a value. +renderFloatingValue :: BinaryFormat -> FloatingValue -> String +renderFloatingValue _ NotANumber = "nan" +renderFloatingValue _ (Infinity negative) = signed negative "inf" +renderFloatingValue _ (Finite negative value) + | value == 0 = signed negative "0.0" +renderFloatingValue format target@(Finite negative value) = + signed negative (shortest 1) + where + maximumDigits = (30103 * formatPrecision format + 99999) `div` 100000 + 1 + shortest digits + | digits > maximumDigits = renderScientific maximumDigits value + | otherwise = + let spelling = renderScientific digits value + in case parseDecimal spelling of + Just (coefficient, scale, _) -> + case decimalRational coefficient scale of + Just roundTrip + | roundToFormat format negative roundTrip == target -> spelling + _ -> shortest (digits + 1) + Nothing -> shortest (digits + 1) +signed :: Bool -> String -> String +signed True value = '-' : value +signed False value = value + +renderScientific :: Int -> Rational -> String +renderScientific requestedDigits exact = + let order = floorLog10 exact + decimalShift = requestedDigits - 1 - order + scaled = + if decimalShift >= 0 + then roundRatioToEven ((numerator exact * 10 ^ decimalShift) % denominator exact) + else roundRatioToEven (numerator exact % (denominator exact * 10 ^ negate decimalShift)) + limit = 10 ^ requestedDigits + decimalSignificand = if scaled >= limit then scaled `quot` 10 else scaled + adjustedOrder = if scaled >= limit then order + 1 else order + padded = replicate (max 0 (requestedDigits - length (show decimalSignificand))) '0' ++ show decimalSignificand + leading = take 1 padded + trailing = drop 1 padded + compactFraction = reverse (dropWhile (== '0') (reverse trailing)) + fraction = if null compactFraction then "0" else compactFraction + in leading ++ "." ++ fraction ++ "e" ++ show adjustedOrder + +floorLog10 :: Rational -> Int +floorLog10 value = + let top = numerator value + bottom = denominator value + estimate = length (show top) - length (show bottom) + in if compareToPowerOfTen top bottom estimate == LT then estimate - 1 else estimate + +compareToPowerOfTen :: Integer -> Integer -> Int -> Ordering +compareToPowerOfTen top bottom decimalExponent + | decimalExponent >= 0 = compare top (bottom * 10 ^ decimalExponent) + | otherwise = compare (top * 10 ^ negate decimalExponent) bottom + +foldFloatingPrimitive :: CorePrimitive -> [CoreExpression] -> Type -> Maybe CoreExpression +foldFloatingPrimitive primitive arguments resultType = case primitive of + CoreAdd -> foldAddition + CoreSubtract -> foldSubtraction + CoreMultiply -> foldMultiplication + CoreDivide -> foldDivision + CoreRemainder -> foldRemainder + CoreNegate -> foldNegation + CoreFloorDivide -> foldRoundedDivision + CoreLessThan -> foldComparison (== LT) + CoreLessEqual -> foldComparison (/= GT) + CoreGreaterThan -> foldComparison (== GT) + CoreGreaterEqual -> foldComparison (/= LT) + CoreEqual -> foldComparison (== EQ) + CoreNotEqual -> foldNotEqual + _ -> Nothing + where + foldAddition = do + (format, [left, right]) <- floatingOperands arguments + result <- addFloating format left right + floatingResult format resultType result + + foldSubtraction = do + (format, [left, right]) <- floatingOperands arguments + result <- addFloating format left (negateValue right) + floatingResult format resultType result + + foldDivision = do + (format, [left, right]) <- floatingOperands arguments + result <- divideFloating format left right + floatingResult format resultType result + + foldMultiplication = do + (format, [left, right]) <- floatingOperands arguments + result <- multiplyFloating format left right + floatingResult format resultType result + + foldRemainder = do + (format, [left, right]) <- floatingOperands arguments + result <- remainderFloating format left right + floatingResult format resultType result + + foldNegation = do + (format, [value]) <- floatingOperands arguments + floatingResult format resultType (negateValue value) + + foldRoundedDivision = do + (format, [left, right]) <- floatingOperands arguments + roundedQuotient <- divideFloating format left right + quotient <- finiteValueToRational roundedQuotient + let rounded = roundRatioAwayFromZero quotient + if integerFitsCoreType resultType rounded + then Just (CoreLiteral (CoreInteger rounded) resultType) + else Nothing + + foldComparison relation = do + (_, [left, right]) <- floatingOperands arguments + Just (CoreLiteral (CoreBoolean (maybe False relation (compareFloating left right))) boolType) + + foldNotEqual = do + (_, [left, right]) <- floatingOperands arguments + Just (CoreLiteral (CoreBoolean (maybe True (/= EQ) (compareFloating left right))) boolType) + +floatingOperands :: [CoreExpression] -> Maybe (BinaryFormat, [FloatingValue]) +floatingOperands arguments = case arguments of + [] -> Nothing + first : _ -> do + let valueType = expressionType first + format <- formatFor valueType + if all ((== valueType) . expressionType) arguments + then (format,) <$> traverse (decodeFloating format) arguments + else Nothing + +decodeFloating :: BinaryFormat -> CoreExpression -> Maybe FloatingValue +decodeFloating format expression = case expression of + CoreLiteral (CoreFloating spelling) _ -> parseFloatingValue format spelling + _ -> Nothing + +floatingResult :: BinaryFormat -> Type -> FloatingValue -> Maybe CoreExpression +floatingResult format resultType value = + Just (CoreLiteral (CoreFloating (renderFloatingValue format value)) resultType) + +addFloating :: BinaryFormat -> FloatingValue -> FloatingValue -> Maybe FloatingValue +addFloating format left right = case (left, right) of + (NotANumber, _) -> Just NotANumber + (_, NotANumber) -> Just NotANumber + (Infinity leftSign, Infinity rightSign) + | leftSign == rightSign -> Just (Infinity leftSign) + | otherwise -> Just NotANumber + (Infinity negative, _) -> Just (Infinity negative) + (_, Infinity negative) -> Just (Infinity negative) + (Finite leftSign leftMagnitude, Finite rightSign rightMagnitude) -> + let exact = signedMagnitude leftSign leftMagnitude + signedMagnitude rightSign rightMagnitude + zeroSign = exact == 0 && leftMagnitude == 0 && rightMagnitude == 0 && leftSign && rightSign + in Just (roundToFormat format (if exact == 0 then zeroSign else exact < 0) (abs exact)) + +multiplyFloating :: BinaryFormat -> FloatingValue -> FloatingValue -> Maybe FloatingValue +multiplyFloating format left right = case (left, right) of + (NotANumber, _) -> Just NotANumber + (_, NotANumber) -> Just NotANumber + (Infinity _, Finite _ 0) -> Just NotANumber + (Finite _ 0, Infinity _) -> Just NotANumber + (Infinity leftSign, Infinity rightSign) -> Just (Infinity (leftSign /= rightSign)) + (Infinity leftSign, Finite rightSign _) -> Just (Infinity (leftSign /= rightSign)) + (Finite leftSign _, Infinity rightSign) -> Just (Infinity (leftSign /= rightSign)) + (Finite leftSign leftMagnitude, Finite rightSign rightMagnitude) -> + Just (roundToFormat format (leftSign /= rightSign) (leftMagnitude * rightMagnitude)) + +divideFloating :: BinaryFormat -> FloatingValue -> FloatingValue -> Maybe FloatingValue +divideFloating format left right = case (left, right) of + (NotANumber, _) -> Just NotANumber + (_, NotANumber) -> Just NotANumber + (Infinity _, Infinity _) -> Just NotANumber + (Finite _ 0, Finite _ 0) -> Just NotANumber + (Infinity leftSign, Finite rightSign _) -> Just (Infinity (leftSign /= rightSign)) + (Finite leftSign _, Infinity rightSign) -> Just (Finite (leftSign /= rightSign) 0) + (Finite leftSign _, Finite rightSign 0) -> Just (Infinity (leftSign /= rightSign)) + (Finite leftSign 0, Finite rightSign _) -> Just (Finite (leftSign /= rightSign) 0) + (Finite leftSign leftMagnitude, Finite rightSign rightMagnitude) -> + Just (roundToFormat format (leftSign /= rightSign) (leftMagnitude / rightMagnitude)) + +remainderFloating :: BinaryFormat -> FloatingValue -> FloatingValue -> Maybe FloatingValue +remainderFloating format left right = case (left, right) of + (NotANumber, _) -> Just NotANumber + (_, NotANumber) -> Just NotANumber + (Infinity _, _) -> Just NotANumber + (_, Infinity _) -> preserveLeft + (_, Finite _ 0) -> Just NotANumber + (Finite negative 0, _) -> Just (Finite negative 0) + (Finite negative leftMagnitude, Finite _ rightMagnitude) -> + let quotient = leftMagnitude / rightMagnitude + truncated = numerator quotient `quot` denominator quotient + remainder = leftMagnitude - toRational truncated * rightMagnitude + in Just (roundToFormat format negative remainder) + where + preserveLeft = case left of + Finite negative magnitude -> Just (roundToFormat format negative magnitude) + _ -> Just NotANumber + +finiteValueToRational :: FloatingValue -> Maybe Rational +finiteValueToRational (Finite negative magnitude) = Just (signedMagnitude negative magnitude) +finiteValueToRational _ = Nothing + +roundRatioAwayFromZero :: Rational -> Integer +roundRatioAwayFromZero value = + let negative = value < 0 + magnitude = abs value + (whole, remainder) = numerator magnitude `quotRem` denominator magnitude + rounded = if 2 * remainder >= denominator magnitude then whole + 1 else whole + in if negative then negate rounded else rounded + +compareFloating :: FloatingValue -> FloatingValue -> Maybe Ordering +compareFloating NotANumber _ = Nothing +compareFloating _ NotANumber = Nothing +compareFloating (Infinity left) (Infinity right) = Just (compare right left) +compareFloating (Infinity True) (Finite _ _) = Just LT +compareFloating (Infinity False) (Finite _ _) = Just GT +compareFloating (Finite _ _) (Infinity True) = Just GT +compareFloating (Finite _ _) (Infinity False) = Just LT +compareFloating (Finite leftSign left) (Finite rightSign right) = + Just (compare (signedMagnitude leftSign left) (signedMagnitude rightSign right)) + +negateValue :: FloatingValue -> FloatingValue +negateValue NotANumber = NotANumber +negateValue (Infinity negative) = Infinity (not negative) +negateValue (Finite negative value) = Finite (not negative) value + +signedMagnitude :: Bool -> Rational -> Rational +signedMagnitude True value = negate value +signedMagnitude False value = value + +floatingTruthValue :: CoreExpression -> Maybe Bool +floatingTruthValue expression = do + format <- formatFor (expressionType expression) + value <- decodeFloating format expression + pure $ case value of + NotANumber -> True + Infinity _ -> True + Finite _ magnitude -> magnitude /= 0
+ src/Progmasoft/Tala/Core/Optimizer/Inline.hs view
@@ -0,0 +1,454 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Capture-avoiding linear-body inlining for verified Core. + +Pure, non-recursive functions may contain immutable bindings and evaluations +before their single final return. The pass converts that straight-line body to +nested 'CoreLet' expressions. Non-trivial arguments are let-bound too, so they +are evaluated exactly once even when the callee reads a parameter repeatedly +or not at all. Every copied binder receives a fresh module-wide SymbolId. +-} +module Progmasoft.Tala.Core.Optimizer.Inline + ( InlineReport (..) + , inlineFunctions + ) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Optimizer.Analysis +import Progmasoft.Tala.Core.Symbols (nextCoreSymbolValue) + +data InlineStep + = InlineBinding ResolvedName Type CoreExpression + | InlineEvaluation CoreExpression + deriving (Eq, Ord, Read, Show) + +data InlineCandidate = InlineCandidate + { candidateParameters :: [(ResolvedName, Type)] + , candidateSteps :: [InlineStep] + , candidateResult :: CoreExpression + , candidateExpressionNodes :: Int + } + deriving (Eq, Ord, Read, Show) + +data CandidateDiscovery = CandidateDiscovery + { discoveredCandidates :: Map SymbolId InlineCandidate + , discoveredExpressionCandidates :: Int + , discoveredStatementCandidates :: Int + , rejectedNonLinearBodies :: Int + } + +-- | Counts describing candidate discovery and capture-avoiding rewrites. +data InlineReport = InlineReport + { inlineCandidateCount :: Int + , inlineExpressionCandidateCount :: Int + , inlineStatementCandidateCount :: Int + , inlineRejectedNonLinearBodies :: Int + , inlineRewrittenCalls :: Int + , inlineSkippedOversized :: Int + , inlineGeneratedParameterLets :: Int + , inlineGeneratedLocalLets :: Int + , inlineGeneratedEvaluationLets :: Int + , inlineAlphaRenamedSymbols :: Int + } + deriving (Eq, Ord, Read, Show) + +data InlineState = InlineState + { stateNextSymbol :: Int + , stateRewrittenCalls :: Int + , stateSkippedOversized :: Int + , stateGeneratedParameterLets :: Int + , stateGeneratedLocalLets :: Int + , stateGeneratedEvaluationLets :: Int + , stateAlphaRenamedSymbols :: Int + } + +initialInlineState :: CoreModule -> InlineState +initialInlineState moduleValue = + InlineState (nextCoreSymbolValue moduleValue) 0 0 0 0 0 0 + +inlineFunctions :: Int -> [FunctionEffectReport] -> CoreModule -> (CoreModule, InlineReport) +inlineFunctions maximumNodes effectReports moduleValue = + let discovery = discoverCandidates effectReports moduleValue + candidates = discoveredCandidates discovery + (functions, finalState) = + rewriteFunctions maximumNodes candidates (initialInlineState moduleValue) (coreModuleFunctions moduleValue) + in ( moduleValue {coreModuleFunctions = functions} + , InlineReport + { inlineCandidateCount = Map.size candidates + , inlineExpressionCandidateCount = discoveredExpressionCandidates discovery + , inlineStatementCandidateCount = discoveredStatementCandidates discovery + , inlineRejectedNonLinearBodies = rejectedNonLinearBodies discovery + , inlineRewrittenCalls = stateRewrittenCalls finalState + , inlineSkippedOversized = stateSkippedOversized finalState + , inlineGeneratedParameterLets = stateGeneratedParameterLets finalState + , inlineGeneratedLocalLets = stateGeneratedLocalLets finalState + , inlineGeneratedEvaluationLets = stateGeneratedEvaluationLets finalState + , inlineAlphaRenamedSymbols = stateAlphaRenamedSymbols finalState + } + ) + +discoverCandidates :: [FunctionEffectReport] -> CoreModule -> CandidateDiscovery +discoverCandidates reports moduleValue = foldl' discover emptyDiscovery (coreModuleFunctions moduleValue) + where + reportMap = Map.fromList [(resolvedSymbol (effectFunctionName report), report) | report <- reports] + emptyDiscovery = CandidateDiscovery Map.empty 0 0 0 + discover discovery function = + let symbol = resolvedSymbol (coreFunctionName function) + in case Map.lookup symbol reportMap of + Just report + | effectClassification report == PureEffect + , not (effectIsRecursive report) -> + case linearizeBody (coreFunctionBody function) of + Just (steps, result) -> + let candidate = + InlineCandidate + (coreFunctionParameters function) + steps + result + (linearizedNodeCount (length (coreFunctionParameters function)) steps result) + statementDelta = if null steps then 0 else 1 + in discovery + { discoveredCandidates = Map.insert symbol candidate (discoveredCandidates discovery) + , discoveredExpressionCandidates = discoveredExpressionCandidates discovery + 1 - statementDelta + , discoveredStatementCandidates = discoveredStatementCandidates discovery + statementDelta + } + Nothing -> discovery {rejectedNonLinearBodies = rejectedNonLinearBodies discovery + 1} + _ -> discovery + +-- Only a final return is accepted. Mutable state, branches, early returns, and +-- fallthrough retain their call boundary until a dedicated CFG inliner exists. +linearizeBody :: [CoreStatement] -> Maybe ([InlineStep], CoreExpression) +linearizeBody = go [] + where + go steps [CoreReturn result] = Just (reverse steps, result) + go steps (CoreBind binding : remaining) + | not (coreBindingMutable binding) = + go (InlineBinding (coreBindingName binding) (coreBindingType binding) (coreBindingValue binding) : steps) remaining + go steps (CoreEvaluate value : remaining) = go (InlineEvaluation value : steps) remaining + go _ _ = Nothing + +rewriteFunctions :: + Int -> Map SymbolId InlineCandidate -> InlineState -> [CoreFunction] -> ([CoreFunction], InlineState) +rewriteFunctions maximumNodes candidates = mapAccumulating rewriteFunction + where + rewriteFunction state function = + let (body, next) = rewriteStatements maximumNodes candidates state (coreFunctionBody function) + in (function {coreFunctionBody = body}, next) + +mapAccumulating :: (state -> value -> (result, state)) -> state -> [value] -> ([result], state) +mapAccumulating _ state [] = ([], state) +mapAccumulating transform state (value : remaining) = + let (result, afterValue) = transform state value + (results, finalState) = mapAccumulating transform afterValue remaining + in (result : results, finalState) + +rewriteStatements :: + Int -> Map SymbolId InlineCandidate -> InlineState -> [CoreStatement] -> ([CoreStatement], InlineState) +rewriteStatements maximumNodes candidates = mapAccumulating rewrite + where + rewrite state statement = case statement of + CoreBind binding -> + let (value, next) = rewriteExpression maximumNodes candidates state (coreBindingValue binding) + in (CoreBind binding {coreBindingValue = value}, next) + CoreAssign name value -> + let (rewritten, next) = rewriteExpression maximumNodes candidates state value + in (CoreAssign name rewritten, next) + CoreReturn value -> + let (rewritten, next) = rewriteExpression maximumNodes candidates state value + in (CoreReturn rewritten, next) + CoreEvaluate value -> + let (rewritten, next) = rewriteExpression maximumNodes candidates state value + in (CoreEvaluate rewritten, next) + CoreIf condition yes no -> + let (rewrittenCondition, afterCondition) = rewriteExpression maximumNodes candidates state condition + (rewrittenYes, afterYes) = rewriteStatements maximumNodes candidates afterCondition yes + (rewrittenNo, finalState) = rewriteStatements maximumNodes candidates afterYes no + in (CoreIf rewrittenCondition rewrittenYes rewrittenNo, finalState) + CoreWhile condition body -> + let (rewrittenCondition, afterCondition) = rewriteExpression maximumNodes candidates state condition + (rewrittenBody, finalState) = rewriteStatements maximumNodes candidates afterCondition body + in (CoreWhile rewrittenCondition rewrittenBody, finalState) + CoreDoWhile body condition -> + let (rewrittenBody, afterBody) = rewriteStatements maximumNodes candidates state body + (rewrittenCondition, finalState) = rewriteExpression maximumNodes candidates afterBody condition + in (CoreDoWhile rewrittenBody rewrittenCondition, finalState) + CoreFor condition body update -> + let (rewrittenCondition, afterCondition) = rewriteExpression maximumNodes candidates state condition + (rewrittenBody, afterBody) = rewriteStatements maximumNodes candidates afterCondition body + (rewrittenUpdate, finalState) = rewriteStatements maximumNodes candidates afterBody update + in (CoreFor rewrittenCondition rewrittenBody rewrittenUpdate, finalState) + CoreBreak -> (CoreBreak, state) + CoreContinue -> (CoreContinue, state) + +rewriteExpression :: + Int -> Map SymbolId InlineCandidate -> InlineState -> CoreExpression -> (CoreExpression, InlineState) +rewriteExpression maximumNodes candidates state expression = case expression of + CoreVariable {} -> (expression, state) + CoreLiteral {} -> (expression, state) + CorePrimitive primitive arguments valueType -> + let (rewritten, next) = mapAccumulating (rewriteExpression maximumNodes candidates) state arguments + in (CorePrimitive primitive rewritten valueType, next) + CoreLet name bindingType value body valueType -> + let (rewrittenValue, afterValue) = rewriteExpression maximumNodes candidates state value + (rewrittenBody, afterBody) = rewriteExpression maximumNodes candidates afterValue body + in (CoreLet name bindingType rewrittenValue rewrittenBody valueType, afterBody) + -- Inlined bodies stay nested inside the arm that contained the call, so + -- an unselected arm still evaluates nothing. + CoreConditional condition whenTrue whenFalse valueType -> + let (rewrittenCondition, afterCondition) = rewriteExpression maximumNodes candidates state condition + (rewrittenTrue, afterTrue) = rewriteExpression maximumNodes candidates afterCondition whenTrue + (rewrittenFalse, afterFalse) = rewriteExpression maximumNodes candidates afterTrue whenFalse + in (CoreConditional rewrittenCondition rewrittenTrue rewrittenFalse valueType, afterFalse) + CoreClosure captures parameters returnType body valueType -> + let (rewrittenCaptures, afterCaptures) = mapAccumulating rewriteCapture state captures + (rewrittenBody, finalState) = rewriteStatements maximumNodes candidates afterCaptures body + in (CoreClosure rewrittenCaptures parameters returnType rewrittenBody valueType, finalState) + where + rewriteCapture current capture = + let (value, next) = rewriteExpression maximumNodes candidates current (coreCaptureValue capture) + in (capture {coreCaptureValue = value}, next) + CoreApply callee arguments valueType -> + let (rewrittenCallee, afterCallee) = rewriteExpression maximumNodes candidates state callee + (rewrittenArguments, afterArguments) = mapAccumulating (rewriteExpression maximumNodes candidates) afterCallee arguments + rebuilt = CoreApply rewrittenCallee rewrittenArguments valueType + in tryInline maximumNodes candidates afterArguments rebuilt + +tryInline :: Int -> Map SymbolId InlineCandidate -> InlineState -> CoreExpression -> (CoreExpression, InlineState) +tryInline maximumNodes candidates state call@(CoreApply callee arguments valueType) = + case calleeSymbol callee >>= (`Map.lookup` candidates) of + Nothing -> (call, state) + Just candidate + | length (candidateParameters candidate) /= length arguments -> (call, state) + | candidateExpressionNodes candidate > normalizedMaximum -> skipped + | otherwise -> + let (expanded, afterExpansion) = expandCandidate candidate arguments state + in if expressionNodeCount expanded > normalizedMaximum || expressionType expanded /= valueType + then skipped + else (expanded, afterExpansion {stateRewrittenCalls = stateRewrittenCalls afterExpansion + 1}) + where + normalizedMaximum = max 1 maximumNodes + skipped = (call, state {stateSkippedOversized = stateSkippedOversized state + 1}) +tryInline _ _ state expression = (expression, state) + +calleeSymbol :: CoreExpression -> Maybe SymbolId +calleeSymbol (CoreVariable name _) = Just (resolvedSymbol name) +calleeSymbol _ = Nothing + +-- A substitution environment carries complete expressions. Variables and +-- literals can be copied safely; every other argument first receives a let. +expandCandidate :: InlineCandidate -> [CoreExpression] -> InlineState -> (CoreExpression, InlineState) +expandCandidate candidate arguments initialState = + let (environment, parameterLets, afterParameters) = + prepareParameters (candidateParameters candidate) arguments initialState + (body, afterBody) = cloneLinearBody environment (candidateSteps candidate) (candidateResult candidate) afterParameters + in (foldr applyLet body parameterLets, afterBody) + where + applyLet (name, valueType, value) body = CoreLet name valueType value body (expressionType body) + +type Substitution = Map SymbolId CoreExpression + +prepareParameters :: + [(ResolvedName, Type)] -> + [CoreExpression] -> + InlineState -> + (Substitution, [(ResolvedName, Type, CoreExpression)], InlineState) +prepareParameters parameters arguments = go Map.empty [] (zip parameters arguments) + where + go environment bindings [] state = (environment, reverse bindings, state) + go environment bindings (((parameter, parameterType), argument) : remaining) state + | trivialArgument argument = + go (Map.insert (resolvedSymbol parameter) argument environment) bindings remaining state + | otherwise = + let (fresh, next) = freshName "argument" parameter state + reference = CoreVariable fresh parameterType + counted = next {stateGeneratedParameterLets = stateGeneratedParameterLets next + 1} + in go + (Map.insert (resolvedSymbol parameter) reference environment) + ((fresh, parameterType, argument) : bindings) + remaining + counted + +trivialArgument :: CoreExpression -> Bool +trivialArgument CoreVariable {} = True +trivialArgument CoreLiteral {} = True +trivialArgument _ = False + +cloneLinearBody :: Substitution -> [InlineStep] -> CoreExpression -> InlineState -> (CoreExpression, InlineState) +cloneLinearBody initialEnvironment steps result initialState = + let (environment, builders, afterSteps) = cloneSteps initialEnvironment [] steps initialState + (clonedResult, afterResult) = cloneExpression environment result afterSteps + in (foldr ($) clonedResult builders, afterResult) + +cloneSteps :: + Substitution -> + [CoreExpression -> CoreExpression] -> + [InlineStep] -> + InlineState -> + (Substitution, [CoreExpression -> CoreExpression], InlineState) +cloneSteps environment builders [] state = (environment, reverse builders, state) +cloneSteps environment builders (step : remaining) state = case step of + InlineBinding oldName valueType value -> + let (clonedValue, afterValue) = cloneExpression environment value state + (fresh, afterName) = freshName "local" oldName afterValue + reference = CoreVariable fresh valueType + environment' = Map.insert (resolvedSymbol oldName) reference environment + builder body = CoreLet fresh valueType clonedValue body (expressionType body) + counted = afterName {stateGeneratedLocalLets = stateGeneratedLocalLets afterName + 1} + in cloneSteps environment' (builder : builders) remaining counted + InlineEvaluation value -> + let (clonedValue, afterValue) = cloneExpression environment value state + (fresh, afterName) = freshSynthetic "evaluation" afterValue + builder body = CoreLet fresh (expressionType clonedValue) clonedValue body (expressionType body) + counted = afterName {stateGeneratedEvaluationLets = stateGeneratedEvaluationLets afterName + 1} + in cloneSteps environment (builder : builders) remaining counted + +cloneExpression :: Substitution -> CoreExpression -> InlineState -> (CoreExpression, InlineState) +cloneExpression environment expression state = case expression of + CoreVariable name _ -> (Map.findWithDefault expression (resolvedSymbol name) environment, state) + CoreLiteral {} -> (expression, state) + CoreApply callee arguments valueType -> + let (clonedCallee, afterCallee) = cloneExpression environment callee state + (clonedArguments, afterArguments) = + mapAccumulating (\current value -> cloneExpression environment value current) afterCallee arguments + in (CoreApply clonedCallee clonedArguments valueType, afterArguments) + CorePrimitive primitive arguments valueType -> + let (clonedArguments, afterArguments) = + mapAccumulating (\current value -> cloneExpression environment value current) state arguments + in (CorePrimitive primitive clonedArguments valueType, afterArguments) + CoreLet oldName bindingType value body valueType -> + let (clonedValue, afterValue) = cloneExpression environment value state + (fresh, afterName) = freshName "let" oldName afterValue + bodyEnvironment = Map.insert (resolvedSymbol oldName) (CoreVariable fresh bindingType) environment + (clonedBody, afterBody) = cloneExpression bodyEnvironment body afterName + in (CoreLet fresh bindingType clonedValue clonedBody valueType, afterBody) + CoreConditional condition whenTrue whenFalse valueType -> + let (clonedCondition, afterCondition) = cloneExpression environment condition state + (clonedTrue, afterTrue) = cloneExpression environment whenTrue afterCondition + (clonedFalse, afterFalse) = cloneExpression environment whenFalse afterTrue + in (CoreConditional clonedCondition clonedTrue clonedFalse valueType, afterFalse) + CoreClosure captures parameters returnType body valueType -> + let (clonedValues, afterValues) = mapAccumulating cloneCaptureValue state captures + (captureEnvironment, clonedCaptures, afterCaptures) = cloneCaptureNames environment clonedValues afterValues + (closureEnvironment, clonedParameters, afterParameters) = cloneNames "closure-parameter" captureEnvironment parameters afterCaptures + (clonedBody, _, afterBody) = cloneStatements closureEnvironment body afterParameters + in (CoreClosure clonedCaptures clonedParameters returnType clonedBody valueType, afterBody) + where + cloneCaptureValue current capture = + let (value, next) = cloneExpression environment (coreCaptureValue capture) current + in (capture {coreCaptureValue = value}, next) + +cloneCaptureNames :: Substitution -> [CoreCapture] -> InlineState -> (Substitution, [CoreCapture], InlineState) +cloneCaptureNames = go [] + where + go changed environment [] state = (environment, reverse changed, state) + go changed environment (capture : remaining) state = + let oldName = coreCaptureName capture + valueType = coreCaptureType capture + (fresh, next) = freshName "capture" oldName state + environment' = Map.insert (resolvedSymbol oldName) (CoreVariable fresh valueType) environment + in go (capture {coreCaptureName = fresh} : changed) environment' remaining next + +cloneNames :: + String -> Substitution -> [(ResolvedName, Type)] -> InlineState -> (Substitution, [(ResolvedName, Type)], InlineState) +cloneNames role = go [] + where + go changed environment [] state = (environment, reverse changed, state) + go changed environment ((oldName, valueType) : remaining) state = + let (fresh, next) = freshName role oldName state + environment' = Map.insert (resolvedSymbol oldName) (CoreVariable fresh valueType) environment + in go ((fresh, valueType) : changed) environment' remaining next + +cloneStatements :: Substitution -> [CoreStatement] -> InlineState -> ([CoreStatement], Substitution, InlineState) +cloneStatements environment [] state = ([], environment, state) +cloneStatements environment (statement : remaining) state = + let (cloned, nextEnvironment, afterStatement) = cloneStatement environment statement state + (rest, finalEnvironment, finalState) = cloneStatements nextEnvironment remaining afterStatement + in (cloned : rest, finalEnvironment, finalState) + +cloneStatement :: Substitution -> CoreStatement -> InlineState -> (CoreStatement, Substitution, InlineState) +cloneStatement environment statement state = case statement of + CoreBind binding -> + let (value, afterValue) = cloneExpression environment (coreBindingValue binding) state + oldName = coreBindingName binding + valueType = coreBindingType binding + (fresh, afterName) = freshName "closure-local" oldName afterValue + changed = binding {coreBindingName = fresh, coreBindingValue = value} + environment' = Map.insert (resolvedSymbol oldName) (CoreVariable fresh valueType) environment + in (CoreBind changed, environment', afterName) + CoreAssign oldName value -> + let (clonedValue, next) = cloneExpression environment value state + changedName = case Map.lookup (resolvedSymbol oldName) environment of + Just (CoreVariable name _) -> name + _ -> oldName + in (CoreAssign changedName clonedValue, environment, next) + CoreReturn value -> + let (clonedValue, next) = cloneExpression environment value state + in (CoreReturn clonedValue, environment, next) + CoreEvaluate value -> + let (clonedValue, next) = cloneExpression environment value state + in (CoreEvaluate clonedValue, environment, next) + CoreIf condition whenTrue whenFalse -> + let (clonedCondition, afterCondition) = cloneExpression environment condition state + (clonedTrue, _, afterTrue) = cloneStatements environment whenTrue afterCondition + (clonedFalse, _, afterFalse) = cloneStatements environment whenFalse afterTrue + in (CoreIf clonedCondition clonedTrue clonedFalse, environment, afterFalse) + CoreWhile condition body -> + let (clonedCondition, afterCondition) = cloneExpression environment condition state + (clonedBody, _, finalState) = cloneStatements environment body afterCondition + in (CoreWhile clonedCondition clonedBody, environment, finalState) + CoreDoWhile body condition -> + let (clonedBody, _, afterBody) = cloneStatements environment body state + (clonedCondition, finalState) = cloneExpression environment condition afterBody + in (CoreDoWhile clonedBody clonedCondition, environment, finalState) + CoreFor condition body update -> + let (clonedCondition, afterCondition) = cloneExpression environment condition state + (clonedBody, _, afterBody) = cloneStatements environment body afterCondition + (clonedUpdate, _, finalState) = cloneStatements environment update afterBody + in (CoreFor clonedCondition clonedBody clonedUpdate, environment, finalState) + CoreBreak -> (CoreBreak, environment, state) + CoreContinue -> (CoreContinue, environment, state) + +freshName :: String -> ResolvedName -> InlineState -> (ResolvedName, InlineState) +freshName role original state = + let value = stateNextSymbol state + Identifier spelling = resolvedSpelling original + fresh = ResolvedName (SymbolId value) (Identifier ("$inline." ++ role ++ "." ++ spelling ++ "." ++ show value)) + in (fresh, state {stateNextSymbol = value + 1, stateAlphaRenamedSymbols = stateAlphaRenamedSymbols state + 1}) + +freshSynthetic :: String -> InlineState -> (ResolvedName, InlineState) +freshSynthetic role state = freshName role (ResolvedName (SymbolId 1) (Identifier role)) state + +linearizedNodeCount :: Int -> [InlineStep] -> CoreExpression -> Int +linearizedNodeCount parameterCount steps result = parameterCount + sum (map stepNodeCount steps) + expressionNodeCount result + where + stepNodeCount step = case step of + InlineBinding _ _ value -> 1 + expressionNodeCount value + InlineEvaluation value -> 1 + expressionNodeCount value + +expressionNodeCount :: CoreExpression -> Int +expressionNodeCount expression = case expression of + CoreVariable {} -> 1 + CoreLiteral {} -> 1 + CoreApply callee arguments _ -> 1 + sum (map expressionNodeCount (callee : arguments)) + CorePrimitive _ arguments _ -> 1 + sum (map expressionNodeCount arguments) + CoreLet _ _ value body _ -> 1 + expressionNodeCount value + expressionNodeCount body + CoreConditional condition whenTrue whenFalse _ -> + 1 + sum (map expressionNodeCount [condition, whenTrue, whenFalse]) + CoreClosure captures _ _ body _ -> 1 + sum (map (expressionNodeCount . coreCaptureValue) captures) + sum (map statementNodeCount body) + +statementNodeCount :: CoreStatement -> Int +statementNodeCount statement = case statement of + CoreBind binding -> 1 + expressionNodeCount (coreBindingValue binding) + CoreAssign _ value -> 1 + expressionNodeCount value + CoreReturn value -> 1 + expressionNodeCount value + CoreEvaluate value -> 1 + expressionNodeCount value + CoreIf condition yes no -> 1 + expressionNodeCount condition + sum (map statementNodeCount (yes ++ no)) + CoreWhile condition body -> 1 + expressionNodeCount condition + sum (map statementNodeCount body) + CoreDoWhile body condition -> 1 + sum (map statementNodeCount body) + expressionNodeCount condition + CoreFor condition body update -> 1 + expressionNodeCount condition + sum (map statementNodeCount (body ++ update)) + CoreBreak -> 1 + CoreContinue -> 1
+ src/Progmasoft/Tala/Core/Optimizer/IntegerFacts.hs view
@@ -0,0 +1,968 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Path-sensitive integer facts for Core optimization and effect analysis. + +Facts form a small abstract domain. Each known integer has an interval and an +independent "zero is excluded" bit; the latter preserves useful information +for disjoint intervals such as x < 0 || x > 0. The whole environment also has +a bottom element, used when a branch condition is contradictory. Unknown +calls invalidate the environment because Core does not yet carry a complete +mod/ref summary for captured mutable storage. +-} +module Progmasoft.Tala.Core.Optimizer.IntegerFacts + ( IntegerFact (..) + , IntegerFacts + , emptyIntegerFacts + , unreachableIntegerFacts + , isUnreachableFacts + , lookupIntegerFact + , forgetIntegerFact + , factOfIntegerExpression + , factProvesNonzero + , transferExpressionFacts + , transferStatementFacts + , transferStatementsFacts + , LoopFactSummary (..) + , loopFactSummary + , refineConditionFacts + , joinIntegerFacts + , conditionTruthFromFacts + , expressionInvokesCallable + ) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Progmasoft.Tala.AST (ResolvedName, SymbolId, Type, resolvedSymbol) +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Scalar + ( coreIntegerBitWidth + , coreIntegerIsSigned + , integerFitsCoreType + , isCoreIntegerType + ) + +-- | An inclusive interval plus the useful non-convex fact that zero is absent. +data IntegerFact = IntegerFact + { integerMinimum :: Maybe Integer + -- ^ Inclusive lower bound, if established. + , integerMaximum :: Maybe Integer + -- ^ Inclusive upper bound, if established. + , integerExcludesZero :: Bool + -- ^ True when every represented value is nonzero. + } + deriving (Eq, Ord, Read, Show) + +{- | Facts valid at one program point, or bottom when that point is unreachable. +Missing symbol entries mean no path-specific refinement is stored. +-} +data IntegerFacts + = ReachableFacts (Map SymbolId IntegerFact) + | UnreachableFacts + deriving (Eq, Ord, Read, Show) + +{- | Fixed-point facts for one structured loop. + +The header is the state before a pre-test loop's condition (or before a +post-test loop's first body execution). Condition, body, and update inputs are +reported separately because a @continue@ reaches different program points in +the three Core loop forms. Exit facts join the false-condition edge with every +reachable @break@ edge. Return facts are retained for clients which need to +account for effects in paths that do not leave the function normally. +-} +data LoopFactSummary = LoopFactSummary + { loopHeaderFacts :: IntegerFacts + -- ^ Widened input facts at the loop's back-edge join. + , loopConditionFacts :: IntegerFacts + -- ^ Facts immediately before evaluating the condition. + , loopBodyFacts :: IntegerFacts + -- ^ Facts on entry to the body after a true condition, or at do-loop entry. + , loopUpdateFacts :: IntegerFacts + -- ^ Facts at a @for@ update; unreachable for loops without an update. + , loopExitFacts :: IntegerFacts + -- ^ Facts valid after normal loop termination, including breaks. + , loopReturnFacts :: IntegerFacts + -- ^ Facts on function-returning paths inside the loop. + , loopFixedPointIterations :: Int + -- ^ Transfer rounds used to reach stability, or the configured cap. + , loopAnalysisWidened :: Bool + -- ^ True when the conservative cap fallback was needed. + } + deriving (Eq, Ord, Read, Show) + +-- | Reachable input state with no path-specific symbol constraints. +emptyIntegerFacts :: IntegerFacts +emptyIntegerFacts = ReachableFacts Map.empty + +-- | Bottom state used for a contradictory or infeasible control-flow edge. +unreachableIntegerFacts :: IntegerFacts +unreachableIntegerFacts = UnreachableFacts + +-- | Test whether no execution reaches the represented program point. +isUnreachableFacts :: IntegerFacts -> Bool +isUnreachableFacts UnreachableFacts = True +isUnreachableFacts _ = False + +-- | Look up the current refinement for a semantic symbol identity. +lookupIntegerFact :: IntegerFacts -> SymbolId -> Maybe IntegerFact +lookupIntegerFact (ReachableFacts facts) symbol = Map.lookup symbol facts +lookupIntegerFact UnreachableFacts _ = Nothing + +-- | Forget one symbol after a write whose resulting value is not modeled. +forgetIntegerFact :: IntegerFacts -> SymbolId -> IntegerFacts +forgetIntegerFact (ReachableFacts facts) symbol = ReachableFacts (Map.delete symbol facts) +forgetIntegerFact UnreachableFacts _ = UnreachableFacts + +setIntegerFact :: IntegerFacts -> SymbolId -> Maybe IntegerFact -> IntegerFacts +setIntegerFact UnreachableFacts _ _ = UnreachableFacts +setIntegerFact (ReachableFacts facts) symbol value = + case value of + Nothing -> ReachableFacts (Map.delete symbol facts) + Just fact + | impossibleFact fact -> UnreachableFacts + | otherwise -> ReachableFacts (Map.insert symbol fact facts) + +unknownFact :: IntegerFact +unknownFact = IntegerFact Nothing Nothing False + +exactFact :: Integer -> IntegerFact +exactFact value = IntegerFact (Just value) (Just value) (value /= 0) + +factForLiteral :: Integer -> IntegerFact +factForLiteral = exactFact + +typeRange :: Type -> IntegerFact +typeRange valueType = case (coreIntegerBitWidth valueType, coreIntegerIsSigned valueType) of + (Just width, Just True) -> + let limit = 2 ^ (width - 1) + in IntegerFact (Just (negate limit)) (Just (limit - 1)) False + (Just width, Just False) -> IntegerFact (Just 0) (Just (2 ^ width - 1)) False + _ -> unknownFact + +factIsExact :: IntegerFact -> Maybe Integer +factIsExact fact = case (integerMinimum fact, integerMaximum fact) of + (Just lower, Just upper) | lower == upper -> Just lower + _ -> Nothing + +factIsZero :: IntegerFact -> Bool +factIsZero fact = factIsExact fact == Just 0 + +factContains :: IntegerFact -> Integer -> Bool +factContains fact value = + maybe True (<= value) (integerMinimum fact) + && maybe True (>= value) (integerMaximum fact) + && not (value == 0 && integerExcludesZero fact) + +impossibleFact :: IntegerFact -> Bool +impossibleFact fact = + maybe + False + (\lower -> maybe False (lower >) (integerMaximum fact)) + (integerMinimum fact) + || (integerExcludesZero fact && factIsZero fact) + +-- | Prove that every value represented by this fact is different from zero. +factProvesNonzero :: IntegerFact -> Bool +factProvesNonzero fact = + integerExcludesZero fact + || maybe False (> 0) (integerMinimum fact) + || maybe False (< 0) (integerMaximum fact) + +factTruth :: IntegerFact -> Maybe Bool +factTruth fact + | factIsZero fact = Just False + | factProvesNonzero fact = Just True + | otherwise = Nothing + +{- | Derive an interval for the supported pure integer subset of a Core expression. +Unsupported expressions return 'Nothing'; callers must not treat that as a +proof of safety or as an empty set of values. +-} +factOfIntegerExpression :: IntegerFacts -> CoreExpression -> Maybe IntegerFact +factOfIntegerExpression facts expression = case expression of + CoreLiteral (CoreInteger value) valueType + | isCoreIntegerType valueType -> Just (factForLiteral value) + CoreVariable name valueType + | isCoreIntegerType valueType -> + Just (maybe (typeRange valueType) id (lookupIntegerFact facts (resolvedSymbol name))) + CorePrimitive CoreNegate [value] valueType + | isCoreIntegerType valueType -> negateFact valueType <$> factOfIntegerExpression facts value + CorePrimitive primitive [left, right] valueType + | isCoreIntegerType valueType -> do + leftFact <- factOfIntegerExpression facts left + rightFact <- factOfIntegerExpression facts right + combineIntegerFacts primitive valueType leftFact rightFact + CoreLet name _ value body resultType + | isCoreIntegerType resultType -> + let afterValue = transferExpressionFacts facts value + bound = setIntegerFact afterValue (resolvedSymbol name) (factOfIntegerExpression afterValue value) + in factOfIntegerExpression bound body + CoreConditional condition whenTrue whenFalse resultType + | isCoreIntegerType resultType -> + let afterCondition = transferExpressionFacts facts condition + trueFacts = refineConditionFacts True condition afterCondition + falseFacts = refineConditionFacts False condition afterCondition + in case (isUnreachableFacts trueFacts, isUnreachableFacts falseFacts) of + (True, True) -> Nothing + (True, False) -> factOfIntegerExpression falseFacts whenFalse + (False, True) -> factOfIntegerExpression trueFacts whenTrue + (False, False) -> + joinFact + <$> factOfIntegerExpression trueFacts whenTrue + <*> factOfIntegerExpression falseFacts whenFalse + _ -> Nothing + +combineIntegerFacts :: CorePrimitive -> Type -> IntegerFact -> IntegerFact -> Maybe IntegerFact +combineIntegerFacts primitive resultType left right = case primitive of + CoreAdd -> intervalResult resultType (+) left right + CoreSubtract -> intervalResult resultType (-) left right + CoreMultiply -> multiplyResult resultType left right + _ -> Nothing + +intervalResult :: Type -> (Integer -> Integer -> Integer) -> IntegerFact -> IntegerFact -> Maybe IntegerFact +intervalResult resultType operation left right = do + lowerLeft <- integerMinimum left + upperLeft <- integerMaximum left + lowerRight <- integerMinimum right + upperRight <- integerMaximum right + let candidates = + [ operation lowerLeft lowerRight + , operation lowerLeft upperRight + , operation upperLeft lowerRight + , operation upperLeft upperRight + ] + checkedInterval resultType (minimum candidates) (maximum candidates) + +multiplyResult :: Type -> IntegerFact -> IntegerFact -> Maybe IntegerFact +multiplyResult resultType left right = + intervalResultWithCandidates + resultType + left + right + [ (*) + ] + where + intervalResultWithCandidates valueType leftFact rightFact operations = do + lowerLeft <- integerMinimum leftFact + upperLeft <- integerMaximum leftFact + lowerRight <- integerMinimum rightFact + upperRight <- integerMaximum rightFact + let products = + [ operation leftValue rightValue + | operation <- operations + , leftValue <- [lowerLeft, upperLeft] + , rightValue <- [lowerRight, upperRight] + ] + result <- checkedInterval valueType (minimum products) (maximum products) + pure result {integerExcludesZero = factProvesNonzero leftFact && factProvesNonzero rightFact} + +checkedInterval :: Type -> Integer -> Integer -> Maybe IntegerFact +checkedInterval valueType lower upper + | not (integerFitsCoreType valueType lower && integerFitsCoreType valueType upper) = Nothing + | otherwise = + let excludesZero = lower > 0 || upper < 0 + in Just (IntegerFact (Just lower) (Just upper) excludesZero) + +negateFact :: Type -> IntegerFact -> IntegerFact +negateFact valueType fact = case (integerMaximum fact, integerMinimum fact) of + (Just upper, Just lower) + | integerFitsCoreType valueType (negate upper) + , integerFitsCoreType valueType (negate lower) -> + IntegerFact + (Just (negate upper)) + (Just (negate lower)) + (integerExcludesZero fact || lower > 0 || upper < 0) + _ -> unknownFact + +{- | Account for expression evaluation, invalidating refinements at calls. +Calls can mutate captured cells; Core has no complete read/write summary yet. +-} +transferExpressionFacts :: IntegerFacts -> CoreExpression -> IntegerFacts +transferExpressionFacts UnreachableFacts _ = UnreachableFacts +transferExpressionFacts facts (CorePrimitive CoreLogicalAnd [left, right] _) = + transferShortCircuitFacts True facts left right +transferExpressionFacts facts (CorePrimitive CoreLogicalOr [left, right] _) = + transferShortCircuitFacts False facts left right +transferExpressionFacts facts (CoreConditional condition whenTrue whenFalse _) = + let afterCondition = transferExpressionFacts facts condition + afterTrue = transferExpressionFacts (refineConditionFacts True condition afterCondition) whenTrue + afterFalse = transferExpressionFacts (refineConditionFacts False condition afterCondition) whenFalse + in joinIntegerFacts afterTrue afterFalse +transferExpressionFacts facts expression + | expressionInvokesCallable expression = emptyIntegerFacts + | otherwise = facts + +transferShortCircuitFacts :: Bool -> IntegerFacts -> CoreExpression -> CoreExpression -> IntegerFacts +transferShortCircuitFacts isAnd facts left right = + let afterLeft = transferExpressionFacts facts left + leftTruth = conditionTruthFromFacts facts left + rightInput = refineConditionFacts isAnd left afterLeft + afterRight = transferExpressionFacts rightInput right + evaluatesRight = if isAnd then leftTruth /= Just False else leftTruth /= Just True + in if not evaluatesRight + then afterLeft + else case leftTruth of + Just _ -> afterRight + Nothing -> joinIntegerFacts afterLeft afterRight + +-- | Whether evaluating an expression can invoke a callable. +expressionInvokesCallable :: CoreExpression -> Bool +expressionInvokesCallable expression = case expression of + CoreVariable {} -> False + CoreLiteral {} -> False + CoreApply {} -> True + CorePrimitive _ arguments _ -> any expressionInvokesCallable arguments + CoreLet _ _ value body _ -> expressionInvokesCallable value || expressionInvokesCallable body + CoreConditional condition whenTrue whenFalse _ -> + any expressionInvokesCallable [condition, whenTrue, whenFalse] + -- A closure body is deferred; only its capture initializers run now. + CoreClosure captures _ _ _ _ -> any (expressionInvokesCallable . coreCaptureValue) captures + +{- | Transfer one statement's normal-completion facts to the next program point. +Break, continue, and return edges are consumed by the nearest owning flow +construct and therefore do not appear as normal continuation here. +-} +transferStatementFacts :: IntegerFacts -> CoreStatement -> IntegerFacts +transferStatementFacts facts = flowNormalFacts . analyzeStatementFlow facts + +-- | Transfer statements in source order until no normal path remains. +transferStatementsFacts :: IntegerFacts -> [CoreStatement] -> IntegerFacts +transferStatementsFacts facts = flowNormalFacts . analyzeSequenceFlow facts + +{- | Summarize the data-flow behavior of a structured Core loop. A bounded +ascending iteration discovers loop-carried facts; interval widening prevents +induction variables from requiring one analysis round per runtime iteration. +If an unusual transfer shape does not stabilize within the cap, the pass +recomputes one sound summary from the reachable top state rather than exposing +the last, potentially under-approximating iteration. +-} +loopFactSummary :: IntegerFacts -> CoreStatement -> Maybe LoopFactSummary +loopFactSummary input statement = case statement of + CoreWhile condition body -> + Just $ solve body (whileStep condition body []) + CoreDoWhile body condition -> + Just $ solve body (doWhileStep body condition) + CoreFor condition body update -> + Just $ solve (body ++ update) (whileStep condition body update) + _ -> Nothing + where + -- Every round of the fixed point analyses the loop body, and with it + -- every loop nested in the body, each of which iterates in turn: the + -- work is the product of the rounds of all enclosing loops, which is + -- exponential in the depth of the nest. Only the innermost levels + -- iterate; a loop with a deeper nest inside it is summarized in one + -- pass from the state that assumes nothing, which is always sound + -- and is what the iteration falls back to when it does not settle. + solve nested step + | loopNestingHeight nested >= iteratedLoopNesting = summarize 1 True emptyIntegerFacts (step emptyIntegerFacts) + | otherwise = solveLoop input step + +{- | How many levels of nested loops are iterated to a fixed point. A loop +whose body holds this many levels of loops or more is summarized in a single +pass, so the cost of a nest grows with its size and not exponentially with +its depth. +-} +iteratedLoopNesting :: Int +iteratedLoopNesting = 2 + +-- | The deepest nest of loops in the statements: 0 when they hold no loop. +loopNestingHeight :: [CoreStatement] -> Int +loopNestingHeight = foldr (max . statementHeight) 0 + where + statementHeight statement = case statement of + CoreIf _ whenTrue whenFalse -> max (loopNestingHeight whenTrue) (loopNestingHeight whenFalse) + CoreWhile _ body -> 1 + loopNestingHeight body + CoreDoWhile body _ -> 1 + loopNestingHeight body + CoreFor _ body update -> 1 + max (loopNestingHeight body) (loopNestingHeight update) + _ -> 0 + +loopIterationLimit :: Int +loopIterationLimit = 8 + +data LoopStep = LoopStep + { stepConditionFacts :: IntegerFacts + , stepBodyFacts :: IntegerFacts + , stepUpdateFacts :: IntegerFacts + , stepBackEdgeFacts :: IntegerFacts + , stepExitFacts :: IntegerFacts + , stepReturnFacts :: IntegerFacts + } + +solveLoop :: IntegerFacts -> (IntegerFacts -> LoopStep) -> LoopFactSummary +solveLoop UnreachableFacts step = summarize 0 False UnreachableFacts (step UnreachableFacts) +solveLoop entry step = iterateHeader 0 entry + where + iterateHeader rounds header = + let current = step header + candidate = joinIntegerFacts header (stepBackEdgeFacts current) + widened = widenIntegerFacts header candidate + nextRound = rounds + 1 + in if widened == header + then summarize nextRound False header current + else + if nextRound >= loopIterationLimit + then conservativeSummary nextRound + else iterateHeader nextRound widened + conservativeSummary rounds = + let top = step emptyIntegerFacts + in summarize rounds True emptyIntegerFacts top + +summarize :: Int -> Bool -> IntegerFacts -> LoopStep -> LoopFactSummary +summarize rounds widened header step = + LoopFactSummary + { loopHeaderFacts = header + , loopConditionFacts = stepConditionFacts step + , loopBodyFacts = stepBodyFacts step + , loopUpdateFacts = stepUpdateFacts step + , loopExitFacts = stepExitFacts step + , loopReturnFacts = stepReturnFacts step + , loopFixedPointIterations = rounds + , loopAnalysisWidened = widened + } + +whileStep :: CoreExpression -> [CoreStatement] -> [CoreStatement] -> IntegerFacts -> LoopStep +whileStep condition body update header = + let conditionTrue = refineConditionFacts True condition header + conditionFalse = refineConditionFacts False condition header + bodyFlow = analyzeSequenceFlow conditionTrue body + updateInput = joinIntegerFacts (flowNormalFacts bodyFlow) (flowContinueFacts bodyFlow) + updateFlow = analyzeSequenceFlow updateInput update + loopBackEdge + | null update = updateInput + | otherwise = joinIntegerFacts (flowNormalFacts updateFlow) (flowContinueFacts updateFlow) + exits = + joinIntegerFacts + conditionFalse + ( joinIntegerFacts + (flowBreakFacts bodyFlow) + (flowBreakFacts updateFlow) + ) + returns = joinIntegerFacts (flowReturnFacts bodyFlow) (flowReturnFacts updateFlow) + in LoopStep + { stepConditionFacts = header + , stepBodyFacts = conditionTrue + , stepUpdateFacts = if null update then unreachableIntegerFacts else updateInput + , stepBackEdgeFacts = loopBackEdge + , stepExitFacts = exits + , stepReturnFacts = returns + } + +doWhileStep :: [CoreStatement] -> CoreExpression -> IntegerFacts -> LoopStep +doWhileStep body condition header = + let bodyFlow = analyzeSequenceFlow header body + conditionInput = joinIntegerFacts (flowNormalFacts bodyFlow) (flowContinueFacts bodyFlow) + conditionTrue = refineConditionFacts True condition conditionInput + conditionFalse = refineConditionFacts False condition conditionInput + in LoopStep + { stepConditionFacts = conditionInput + , stepBodyFacts = header + , stepUpdateFacts = unreachableIntegerFacts + , stepBackEdgeFacts = conditionTrue + , stepExitFacts = joinIntegerFacts (flowBreakFacts bodyFlow) conditionFalse + , stepReturnFacts = flowReturnFacts bodyFlow + } + +{- | Widen an ascending interval sequence. A lower bound that moves down or +an upper bound that moves up becomes unknown; stable and narrowing endpoints +are retained. A fact missing from either state is discarded, and zero +exclusion survives only if both states prove it. These rules guarantee the +result contains both represented value sets and force expanding induction +intervals to stabilize after at most one widening round. +-} +widenIntegerFacts :: IntegerFacts -> IntegerFacts -> IntegerFacts +widenIntegerFacts UnreachableFacts next = next +widenIntegerFacts previous UnreachableFacts = previous +widenIntegerFacts (ReachableFacts previous) (ReachableFacts next) = + ReachableFacts (Map.mergeWithKey widenExisting (const Map.empty) (const Map.empty) previous next) + where + widenExisting _ old new = Just (widenIntegerFact old new) + +widenIntegerFact :: IntegerFact -> IntegerFact -> IntegerFact +widenIntegerFact previous next = + IntegerFact + { integerMinimum = widenLower (integerMinimum previous) (integerMinimum next) + , integerMaximum = widenUpper (integerMaximum previous) (integerMaximum next) + , integerExcludesZero = integerExcludesZero previous && integerExcludesZero next + } + where + widenLower (Just old) (Just new) + | new >= old = Just old + | otherwise = Nothing + widenLower _ _ = Nothing + widenUpper (Just old) (Just new) + | new <= old = Just old + | otherwise = Nothing + widenUpper _ _ = Nothing + +data StatementFlowFacts = StatementFlowFacts + { flowNormalFacts :: IntegerFacts + , flowBreakFacts :: IntegerFacts + , flowContinueFacts :: IntegerFacts + , flowReturnFacts :: IntegerFacts + } + +unreachableFlow :: StatementFlowFacts +unreachableFlow = + StatementFlowFacts + { flowNormalFacts = unreachableIntegerFacts + , flowBreakFacts = unreachableIntegerFacts + , flowContinueFacts = unreachableIntegerFacts + , flowReturnFacts = unreachableIntegerFacts + } + +analyzeStatementFlow :: IntegerFacts -> CoreStatement -> StatementFlowFacts +analyzeStatementFlow UnreachableFacts _ = unreachableFlow +analyzeStatementFlow facts statement = case statement of + CoreBind binding -> + let value = coreBindingValue binding + afterValue = transferExpressionFacts facts value + known + | expressionInvokesCallable value = Nothing + | isCoreIntegerType (coreBindingType binding) = factOfIntegerExpression facts value + | otherwise = Nothing + in normalFlow (setIntegerFact afterValue (resolvedSymbol (coreBindingName binding)) known) + CoreAssign name value -> + let afterValue = transferExpressionFacts facts value + known + | expressionInvokesCallable value = Nothing + | otherwise = factOfIntegerExpression facts value + in normalFlow (setIntegerFact afterValue (resolvedSymbol name) known) + CoreReturn value -> + let afterValue = transferExpressionFacts facts value + in unreachableFlow {flowReturnFacts = afterValue} + CoreEvaluate value -> normalFlow (transferExpressionFacts facts value) + CoreIf condition whenTrue whenFalse -> + let trueInput = refineConditionFacts True condition facts + falseInput = refineConditionFacts False condition facts + trueFlow = analyzeSequenceFlow trueInput whenTrue + falseFlow = analyzeSequenceFlow falseInput whenFalse + in joinFlowFacts trueFlow falseFlow + CoreWhile {} -> loopNormalFlow facts statement + CoreDoWhile {} -> loopNormalFlow facts statement + CoreFor {} -> loopNormalFlow facts statement + CoreBreak -> unreachableFlow {flowBreakFacts = facts} + CoreContinue -> unreachableFlow {flowContinueFacts = facts} + +loopNormalFlow :: IntegerFacts -> CoreStatement -> StatementFlowFacts +loopNormalFlow facts statement = case loopFactSummary facts statement of + Nothing -> normalFlow emptyIntegerFacts + Just summary -> + StatementFlowFacts + { flowNormalFacts = loopExitFacts summary + , flowBreakFacts = unreachableIntegerFacts + , flowContinueFacts = unreachableIntegerFacts + , flowReturnFacts = loopReturnFacts summary + } + +normalFlow :: IntegerFacts -> StatementFlowFacts +normalFlow facts = unreachableFlow {flowNormalFacts = facts} + +joinFlowFacts :: StatementFlowFacts -> StatementFlowFacts -> StatementFlowFacts +joinFlowFacts left right = + StatementFlowFacts + { flowNormalFacts = joinIntegerFacts (flowNormalFacts left) (flowNormalFacts right) + , flowBreakFacts = joinIntegerFacts (flowBreakFacts left) (flowBreakFacts right) + , flowContinueFacts = joinIntegerFacts (flowContinueFacts left) (flowContinueFacts right) + , flowReturnFacts = joinIntegerFacts (flowReturnFacts left) (flowReturnFacts right) + } + +{- | Sequence a block while carrying each abrupt edge independently. In +particular, a break or continue in one conditional arm is not accidentally +joined with the normal state and mistaken for a loop exit or back-edge. +-} +analyzeSequenceFlow :: IntegerFacts -> [CoreStatement] -> StatementFlowFacts +analyzeSequenceFlow input statements = sequenceFrom input statements + where + sequenceFrom facts [] = normalFlow facts + sequenceFrom facts (statement : remaining) = + let current = analyzeStatementFlow facts statement + later = sequenceFrom (flowNormalFacts current) remaining + in StatementFlowFacts + { flowNormalFacts = flowNormalFacts later + , flowBreakFacts = joinIntegerFacts (flowBreakFacts current) (flowBreakFacts later) + , flowContinueFacts = joinIntegerFacts (flowContinueFacts current) (flowContinueFacts later) + , flowReturnFacts = joinIntegerFacts (flowReturnFacts current) (flowReturnFacts later) + } + +-- At control-flow joins, form an interval hull and retain zero exclusion only +-- when every continuing path excludes zero. Unreachable arms are identities. + +-- | Merge feasible paths, retaining only facts valid on every incoming path. +joinIntegerFacts :: IntegerFacts -> IntegerFacts -> IntegerFacts +joinIntegerFacts UnreachableFacts reachable = reachable +joinIntegerFacts reachable UnreachableFacts = reachable +joinIntegerFacts (ReachableFacts left) (ReachableFacts right) = + ReachableFacts (Map.mergeWithKey combine (const Map.empty) (const Map.empty) left right) + where + combine _ first second = Just (joinFact first second) + +joinFact :: IntegerFact -> IntegerFact -> IntegerFact +joinFact left right = + IntegerFact + { integerMinimum = lowerHull (integerMinimum left) (integerMinimum right) + , integerMaximum = upperHull (integerMaximum left) (integerMaximum right) + , integerExcludesZero = factProvesNonzero left && factProvesNonzero right + } + where + lowerHull (Just first) (Just second) = Just (min first second) + lowerHull _ _ = Nothing + upperHull (Just first) (Just second) = Just (max first second) + upperHull _ _ = Nothing + +{- | Refine facts for the requested truth edge of a condition. +True and false edges may carry different intervals or reachability. +-} +refineConditionFacts :: Bool -> CoreExpression -> IntegerFacts -> IntegerFacts +refineConditionFacts _ _ UnreachableFacts = UnreachableFacts +refineConditionFacts desired expression facts = refine expression + where + refine value = case value of + CoreLiteral (CoreBoolean literal) _ + | literal /= desired -> UnreachableFacts + CoreLiteral (CoreInteger literal) valueType + | isCoreIntegerType valueType + , (literal /= 0) /= desired -> + UnreachableFacts + CoreVariable name valueType + | isCoreIntegerType valueType -> + constrainVariable name valueType (if desired then nonzeroConstraint else zeroConstraint) facts + CorePrimitive CoreLogicalNot [nested] _ -> refineConditionFacts (not desired) nested facts + CorePrimitive CoreLogicalAnd [left, right] _ + | desired -> + refineConditionFacts True right (refineConditionFacts True left facts) + | otherwise -> + joinIntegerFacts + (refineConditionFacts False left facts) + (refineConditionFacts False right (refineConditionFacts True left facts)) + CorePrimitive CoreLogicalOr [left, right] _ + | desired -> + joinIntegerFacts + (refineConditionFacts True left facts) + (refineConditionFacts True right (refineConditionFacts False left facts)) + | otherwise -> + refineConditionFacts False right (refineConditionFacts False left facts) + CorePrimitive primitive [left, right] _ + | any expressionInvokesCallable [left, right] -> emptyIntegerFacts + | otherwise -> refineComparison desired primitive left right facts + CoreApply {} -> emptyIntegerFacts + CoreLet name valueType initializer body _ -> + let afterInitializer = transferExpressionFacts facts initializer + binding = CoreBind (CoreBinding name valueType False initializer) + afterBinding = transferStatementFacts afterInitializer binding + afterBody = refineConditionFacts desired body afterBinding + in forgetIntegerFact afterBody (resolvedSymbol name) + -- The requested truth can come from either arm; each arm is + -- reached only along its own edge of the selecting condition. + CoreConditional condition whenTrue whenFalse _ -> + let afterCondition = transferExpressionFacts facts condition + throughTrue = + refineConditionFacts desired whenTrue (refineConditionFacts True condition afterCondition) + throughFalse = + refineConditionFacts desired whenFalse (refineConditionFacts False condition afterCondition) + in joinIntegerFacts throughTrue throughFalse + _ + | expressionInvokesCallable value -> emptyIntegerFacts + | otherwise -> facts + +data IntegerConstraint + = LowerBound Integer + | UpperBound Integer + | ExactValue Integer + | ExcludeZero + +zeroConstraint, nonzeroConstraint :: IntegerConstraint +zeroConstraint = ExactValue 0 +nonzeroConstraint = ExcludeZero + +constrainVariable :: ResolvedName -> Type -> IntegerConstraint -> IntegerFacts -> IntegerFacts +constrainVariable name valueType constraint facts = + let symbol = resolvedSymbol name + current = maybe (typeRange valueType) id (lookupIntegerFact facts symbol) + refined = applyConstraint constraint current + in setIntegerFact facts symbol (Just refined) + +applyConstraint :: IntegerConstraint -> IntegerFact -> IntegerFact +applyConstraint constraint fact = case constraint of + LowerBound value -> + fact {integerMinimum = Just (maybe value (max value) (integerMinimum fact))} + UpperBound value -> + fact {integerMaximum = Just (maybe value (min value) (integerMaximum fact))} + ExactValue value + | factContains fact value -> IntegerFact (Just value) (Just value) (integerExcludesZero fact) + | otherwise -> IntegerFact (Just 1) (Just 0) True + ExcludeZero -> fact {integerExcludesZero = True} + +refineComparison :: Bool -> CorePrimitive -> CoreExpression -> CoreExpression -> IntegerFacts -> IntegerFacts +refineComparison desired primitive left right facts = + case (integerVariable left, integerVariable right) of + (Just (leftName, leftType), Just (rightName, rightType)) -> + refineVariableAgainstVariable desired primitive leftName leftType rightName rightType facts + _ -> case (integerVariable left, integerLiteral right) of + (Just (name, valueType), Just value) -> refineVariableAgainstLiteral desired primitive name valueType value facts + _ -> case (integerLiteral left, integerVariable right) of + (Just value, Just (name, valueType)) -> + refineVariableAgainstLiteral desired (reversePrimitive primitive) name valueType value facts + _ -> facts + +-- Relational comparisons transfer only interval information already proved on +-- the opposite operand. Equality additionally carries the zero-exclusion bit: +-- if equal values are known to avoid zero, both symbols must avoid zero. +refineVariableAgainstVariable :: + Bool -> CorePrimitive -> ResolvedName -> Type -> ResolvedName -> Type -> IntegerFacts -> IntegerFacts +refineVariableAgainstVariable desired primitive leftName leftType rightName rightType facts + | resolvedSymbol leftName == resolvedSymbol rightName = + if comparisonAlwaysTrueForSelf primitive == desired then facts else UnreachableFacts + | otherwise = case (primitive, desired) of + (CoreEqual, True) -> refineEquality + (CoreNotEqual, False) -> refineEquality + (CoreEqual, False) -> refineInequality + (CoreNotEqual, True) -> refineInequality + (CoreLessThan, True) -> refineStrictLessThan + (CoreLessThan, False) -> refineGreaterEqual + (CoreLessEqual, True) -> refineLessEqual + (CoreLessEqual, False) -> refineStrictGreaterThan + (CoreGreaterThan, True) -> refineStrictGreaterThan + (CoreGreaterThan, False) -> refineLessEqual + (CoreGreaterEqual, True) -> refineGreaterEqual + (CoreGreaterEqual, False) -> refineStrictLessThan + _ -> facts + where + leftSymbol = resolvedSymbol leftName + rightSymbol = resolvedSymbol rightName + leftFact = factForSymbol facts leftSymbol leftType + rightFact = factForSymbol facts rightSymbol rightType + + refineEquality = + case intersectFacts leftFact rightFact of + Nothing -> UnreachableFacts + Just common -> + setIntegerFact + (setIntegerFact facts leftSymbol (Just common)) + rightSymbol + (Just common) + + refineInequality = + case (factIsZero leftFact, factIsZero rightFact) of + (True, _) -> constrainVariable rightName rightType ExcludeZero facts + (_, True) -> constrainVariable leftName leftType ExcludeZero facts + _ -> facts + + refineStrictLessThan = + applyPairConstraints + (upperConstraint ((subtract 1) <$> integerMaximum rightFact)) + (lowerConstraint ((+ 1) <$> integerMinimum leftFact)) + + refineLessEqual = + applyPairConstraints + (upperConstraint (integerMaximum rightFact)) + (lowerConstraint (integerMinimum leftFact)) + + refineStrictGreaterThan = + applyPairConstraints + (lowerConstraint ((+ 1) <$> integerMinimum rightFact)) + (upperConstraint ((subtract 1) <$> integerMaximum leftFact)) + + refineGreaterEqual = + applyPairConstraints + (lowerConstraint (integerMinimum rightFact)) + (upperConstraint (integerMaximum leftFact)) + + applyPairConstraints leftConstraint rightConstraint = + let afterLeft = maybe facts (\constraint -> constrainVariable leftName leftType constraint facts) leftConstraint + in maybe afterLeft (\constraint -> constrainVariable rightName rightType constraint afterLeft) rightConstraint + + upperConstraint = fmap UpperBound + lowerConstraint = fmap LowerBound + +comparisonAlwaysTrueForSelf :: CorePrimitive -> Bool +comparisonAlwaysTrueForSelf primitive = case primitive of + CoreEqual -> True + CoreNotEqual -> False + CoreLessThan -> False + CoreLessEqual -> True + CoreGreaterThan -> False + CoreGreaterEqual -> True + _ -> False + +factForSymbol :: IntegerFacts -> SymbolId -> Type -> IntegerFact +factForSymbol facts symbol valueType = maybe (typeRange valueType) id (lookupIntegerFact facts symbol) + +intersectFacts :: IntegerFact -> IntegerFact -> Maybe IntegerFact +intersectFacts left right = + let common = + IntegerFact + { integerMinimum = maxLower (integerMinimum left) (integerMinimum right) + , integerMaximum = minUpper (integerMaximum left) (integerMaximum right) + , integerExcludesZero = integerExcludesZero left || integerExcludesZero right + } + in if impossibleFact common then Nothing else Just common + where + maxLower (Just first) (Just second) = Just (max first second) + maxLower (Just value) Nothing = Just value + maxLower Nothing (Just value) = Just value + maxLower Nothing Nothing = Nothing + minUpper (Just first) (Just second) = Just (min first second) + minUpper (Just value) Nothing = Just value + minUpper Nothing (Just value) = Just value + minUpper Nothing Nothing = Nothing + +refineVariableAgainstLiteral :: + Bool -> CorePrimitive -> ResolvedName -> Type -> Integer -> IntegerFacts -> IntegerFacts +refineVariableAgainstLiteral desired primitive name valueType value facts = + case constraintFor primitive desired value of + Just constraint -> constrainVariable name valueType constraint facts + Nothing -> facts + +constraintFor :: CorePrimitive -> Bool -> Integer -> Maybe IntegerConstraint +constraintFor primitive desired value = case (primitive, desired) of + (CoreEqual, True) -> Just (ExactValue value) + (CoreEqual, False) | value == 0 -> Just ExcludeZero + (CoreNotEqual, True) | value == 0 -> Just ExcludeZero + (CoreNotEqual, False) -> Just (ExactValue value) + (CoreLessThan, True) -> Just (UpperBound (value - 1)) + (CoreLessThan, False) -> Just (LowerBound value) + (CoreLessEqual, True) -> Just (UpperBound value) + (CoreLessEqual, False) -> Just (LowerBound (value + 1)) + (CoreGreaterThan, True) -> Just (LowerBound (value + 1)) + (CoreGreaterThan, False) -> Just (UpperBound value) + (CoreGreaterEqual, True) -> Just (LowerBound value) + (CoreGreaterEqual, False) -> Just (UpperBound (value - 1)) + _ -> Nothing + +integerVariable :: CoreExpression -> Maybe (ResolvedName, Type) +integerVariable (CoreVariable name valueType) + | isCoreIntegerType valueType = Just (name, valueType) +integerVariable _ = Nothing + +integerLiteral :: CoreExpression -> Maybe Integer +integerLiteral (CoreLiteral (CoreInteger value) valueType) + | isCoreIntegerType valueType = Just value +integerLiteral _ = Nothing + +reversePrimitive :: CorePrimitive -> CorePrimitive +reversePrimitive primitive = case primitive of + CoreLessThan -> CoreGreaterThan + CoreLessEqual -> CoreGreaterEqual + CoreGreaterThan -> CoreLessThan + CoreGreaterEqual -> CoreLessEqual + _ -> primitive + +-- | Determine truth only when one condition edge is provably infeasible. +conditionTruthFromFacts :: IntegerFacts -> CoreExpression -> Maybe Bool +conditionTruthFromFacts UnreachableFacts _ = Nothing +conditionTruthFromFacts facts expression + | expressionInvokesCallable expression = Nothing + | isUnreachableFacts (refineConditionFacts True expression facts) = Just False + | isUnreachableFacts (refineConditionFacts False expression facts) = Just True + | otherwise = truth expression + where + truth value = case value of + CoreLiteral (CoreBoolean boolean) _ -> Just boolean + CoreLiteral (CoreInteger integerValue) valueType + | isCoreIntegerType valueType -> Just (integerValue /= 0) + CoreVariable name valueType + | isCoreIntegerType valueType -> + factTruth =<< factOfIntegerExpression facts (CoreVariable name valueType) + CorePrimitive CoreLogicalNot [nested] _ -> not <$> conditionTruthFromFacts facts nested + CorePrimitive CoreLogicalAnd [left, right] _ -> + (&&) <$> conditionTruthFromFacts facts left <*> conditionTruthFromFacts facts right + CorePrimitive CoreLogicalOr [left, right] _ -> + (||) <$> conditionTruthFromFacts facts left <*> conditionTruthFromFacts facts right + CorePrimitive primitive [left, right] _ -> comparisonTruth facts primitive left right + CoreConditional condition whenTrue whenFalse _ -> + case conditionTruthFromFacts facts condition of + Just True -> conditionTruthFromFacts (refineConditionFacts True condition facts) whenTrue + Just False -> conditionTruthFromFacts (refineConditionFacts False condition facts) whenFalse + Nothing -> Nothing + _ -> Nothing + +comparisonTruth :: IntegerFacts -> CorePrimitive -> CoreExpression -> CoreExpression -> Maybe Bool +comparisonTruth facts primitive leftExpression rightExpression = + case (integerVariable leftExpression, integerVariable rightExpression) of + (Just (leftName, leftType), Just (rightName, rightType)) -> + compareFacts + primitive + (factForSymbol facts (resolvedSymbol leftName) leftType) + (factForSymbol facts (resolvedSymbol rightName) rightType) + _ -> case (integerVariable leftExpression, integerLiteral rightExpression) of + (Just (name, valueType), Just literal) -> + compareInterval + primitive + (Just (maybe (typeRange valueType) id (lookupIntegerFact facts (resolvedSymbol name)))) + literal + _ -> case (integerLiteral leftExpression, integerVariable rightExpression) of + (Just literal, Just (name, valueType)) -> + compareInterval + (reversePrimitive primitive) + (Just (maybe (typeRange valueType) id (lookupIntegerFact facts (resolvedSymbol name)))) + literal + _ -> case (integerLiteral leftExpression, integerLiteral rightExpression) of + (Just left, Just right) -> evaluateIntegerComparison primitive left right + _ -> Nothing + +compareFacts :: CorePrimitive -> IntegerFact -> IntegerFact -> Maybe Bool +compareFacts primitive left right + | factIsExact left == factIsExact right + , Just leftValue <- factIsExact left + , Just rightValue <- factIsExact right = + evaluateIntegerComparison primitive leftValue rightValue + | otherwise = case primitive of + CoreEqual + | disjointFacts left right -> Just False + CoreNotEqual + | disjointFacts left right -> Just True + CoreLessThan + | bothBounded (integerMaximum left) (integerMinimum right) (<) -> Just True + | bothBounded (integerMinimum left) (integerMaximum right) (>=) -> Just False + CoreLessEqual + | bothBounded (integerMaximum left) (integerMinimum right) (<=) -> Just True + | bothBounded (integerMinimum left) (integerMaximum right) (>) -> Just False + CoreGreaterThan + | bothBounded (integerMinimum left) (integerMaximum right) (>) -> Just True + | bothBounded (integerMaximum left) (integerMinimum right) (<=) -> Just False + CoreGreaterEqual + | bothBounded (integerMinimum left) (integerMaximum right) (>=) -> Just True + | bothBounded (integerMaximum left) (integerMinimum right) (<) -> Just False + _ -> Nothing + where + bothBounded (Just first) (Just second) relation = relation first second + bothBounded _ _ _ = False + +disjointFacts :: IntegerFact -> IntegerFact -> Bool +disjointFacts left right = + maybe False (\leftUpper -> maybe False (leftUpper <) (integerMinimum right)) (integerMaximum left) + || maybe False (\rightUpper -> maybe False (rightUpper <) (integerMinimum left)) (integerMaximum right) + || (factIsZero left && factProvesNonzero right) + || (factIsZero right && factProvesNonzero left) +compareInterval :: CorePrimitive -> Maybe IntegerFact -> Integer -> Maybe Bool +compareInterval primitive maybeFact literal = do + fact <- maybeFact + let lower = integerMinimum fact + upper = integerMaximum fact + alwaysTrue = case primitive of + CoreEqual -> factIsExact fact == Just literal + CoreNotEqual -> not (factContains fact literal) + CoreLessThan -> maybe False (< literal) upper + CoreLessEqual -> maybe False (<= literal) upper + CoreGreaterThan -> maybe False (> literal) lower + CoreGreaterEqual -> maybe False (>= literal) lower + _ -> False + alwaysFalse = case primitive of + CoreEqual -> not (factContains fact literal) + CoreNotEqual -> factIsExact fact == Just literal + CoreLessThan -> maybe False (>= literal) lower + CoreLessEqual -> maybe False (> literal) lower + CoreGreaterThan -> maybe False (<= literal) upper + CoreGreaterEqual -> maybe False (< literal) upper + _ -> False + if alwaysTrue then Just True else if alwaysFalse then Just False else Nothing + +evaluateIntegerComparison :: CorePrimitive -> Integer -> Integer -> Maybe Bool +evaluateIntegerComparison primitive left right = case primitive of + CoreEqual -> Just (left == right) + CoreNotEqual -> Just (left /= right) + CoreLessThan -> Just (left < right) + CoreLessEqual -> Just (left <= right) + CoreGreaterThan -> Just (left > right) + CoreGreaterEqual -> Just (left >= right) + _ -> Nothing
+ src/Progmasoft/Tala/Core/Optimizer/Liveness.hs view
@@ -0,0 +1,220 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +module Progmasoft.Tala.Core.Optimizer.Liveness + ( eliminateDeadCode + , eliminateDeadCodeWith + ) where + +import Data.Set (Set) +import Data.Set qualified as Set +import Progmasoft.Tala.AST (ResolvedName, SymbolId, resolvedSymbol) +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Optimizer.Analysis +import Progmasoft.Tala.Core.Optimizer.IntegerFacts +import Progmasoft.Tala.Core.Symbols (coreStatementSymbols) + +-- Value liveness and declaration retention are deliberately separate. A +-- retained assignment kills the previous stored value, but it still requires +-- the CoreBind which declares its storage. Using one set for both concerns +-- either drops that declaration or falsely keeps every earlier assignment. +data LiveState = LiveState + { liveValues :: Set SymbolId + , requiredDeclarations :: Set SymbolId + } + +emptyLiveState :: LiveState +emptyLiveState = LiveState Set.empty Set.empty + +stateForSymbols :: Set SymbolId -> LiveState +stateForSymbols symbols = LiveState symbols symbols + +addRequiredSymbols :: Set SymbolId -> LiveState -> LiveState +addRequiredSymbols symbols state = + LiveState + { liveValues = Set.union symbols (liveValues state) + , requiredDeclarations = Set.union symbols (requiredDeclarations state) + } + +mergeLiveStates :: [LiveState] -> LiveState +mergeLiveStates = foldl merge emptyLiveState + where + merge left right = + LiveState + { liveValues = Set.union (liveValues left) (liveValues right) + , requiredDeclarations = + Set.union (requiredDeclarations left) (requiredDeclarations right) + } + +eliminateDeadCode :: CoreModule -> CoreModule +eliminateDeadCode = eliminateDeadCodeWith emptyEffectEnvironment + +eliminateDeadCodeWith :: EffectEnvironment -> CoreModule -> CoreModule +eliminateDeadCodeWith environment moduleValue = + moduleValue {coreModuleFunctions = map (eliminateFunction environment) (coreModuleFunctions moduleValue)} + +eliminateFunction :: EffectEnvironment -> CoreFunction -> CoreFunction +eliminateFunction environment function = + function + { coreFunctionBody = + fst (eliminateStatements environment emptyIntegerFacts emptyLiveState (coreFunctionBody function)) + } + +-- Liveness runs backwards. The returned state describes storage and values +-- required before the optimized statement list executes. Function symbols +-- can occur in both sets; because they have no local CoreBind, they simply +-- flow to the function boundary and are ignored by this local pass. +eliminateStatements :: EffectEnvironment -> IntegerFacts -> LiveState -> [CoreStatement] -> ([CoreStatement], LiveState) +eliminateStatements environment incomingFacts liveAfter statements = + foldr eliminateWithFacts ([], liveAfter) (zip (factsBeforeStatements incomingFacts statements) statements) + where + eliminateWithFacts (facts, statement) = eliminateOne environment facts statement + +factsBeforeStatements :: IntegerFacts -> [CoreStatement] -> [IntegerFacts] +factsBeforeStatements _ [] = [] +factsBeforeStatements facts (statement : remaining) = + facts : factsBeforeStatements (transferStatementFacts facts statement) remaining + +eliminateOne :: + EffectEnvironment -> IntegerFacts -> CoreStatement -> ([CoreStatement], LiveState) -> ([CoreStatement], LiveState) +eliminateOne environment facts statement (remaining, liveAfter) = case statement of + CoreReturn value -> + let optimized = optimizeExpression environment value + in ([CoreReturn optimized], stateForSymbols (expressionSymbols optimized)) + CoreEvaluate value -> + let optimized = optimizeExpression environment value + in if discardableExpressionWithFacts environment facts optimized + then (remaining, liveAfter) + else + ( CoreEvaluate optimized : remaining + , addRequiredSymbols (expressionSymbols optimized) liveAfter + ) + CoreBind binding -> eliminateBinding environment facts binding remaining liveAfter + CoreAssign name value -> eliminateAssignment environment facts name value remaining liveAfter + CoreIf condition yes no -> eliminateBranch environment facts condition yes no remaining liveAfter + CoreWhile condition body -> + preserveLoop (CoreWhile (optimizeExpression environment condition) body) statement remaining liveAfter + CoreDoWhile body condition -> + preserveLoop (CoreDoWhile body (optimizeExpression environment condition)) statement remaining liveAfter + CoreFor condition body update -> + preserveLoop (CoreFor (optimizeExpression environment condition) body update) statement remaining liveAfter + CoreBreak -> (CoreBreak : remaining, liveAfter) + CoreContinue -> (CoreContinue : remaining, liveAfter) + +-- Loops have backedges, so a single reverse tree walk is not a sound liveness +-- solution. Preserve their bodies verbatim and conservatively mark every +-- symbol in the loop live until the dedicated loop fixed-point pass is added. +preserveLoop :: CoreStatement -> CoreStatement -> [CoreStatement] -> LiveState -> ([CoreStatement], LiveState) +preserveLoop optimized original remaining liveAfter = + let symbols = Set.fromList (map (resolvedSymbol) (coreStatementSymbols original)) + in (optimized : remaining, addRequiredSymbols symbols liveAfter) + +eliminateBinding :: + EffectEnvironment -> IntegerFacts -> CoreBinding -> [CoreStatement] -> LiveState -> ([CoreStatement], LiveState) +eliminateBinding environment facts binding remaining liveAfter = + let symbol = resolvedSymbol (coreBindingName binding) + value = optimizeExpression environment (coreBindingValue binding) + valueIsNeeded = Set.member symbol (liveValues liveAfter) + declarationIsNeeded = Set.member symbol (requiredDeclarations liveAfter) + beforeDefinition = + LiveState + { liveValues = Set.delete symbol (liveValues liveAfter) + , requiredDeclarations = Set.delete symbol (requiredDeclarations liveAfter) + } + in if valueIsNeeded || declarationIsNeeded + then + ( CoreBind binding {coreBindingValue = value} : remaining + , addRequiredSymbols (expressionSymbols value) beforeDefinition + ) + else preserveDeadValue environment facts value remaining beforeDefinition + +eliminateAssignment :: + EffectEnvironment -> + IntegerFacts -> + ResolvedName -> + CoreExpression -> + [CoreStatement] -> + LiveState -> + ([CoreStatement], LiveState) +eliminateAssignment environment facts name source remaining liveAfter = + let symbol = resolvedSymbol name + value = optimizeExpression environment source + beforeWrite = liveAfter {liveValues = Set.delete symbol (liveValues liveAfter)} + in if Set.member symbol (liveValues liveAfter) + then + -- The write supplies the value required later, so an earlier + -- value of the target is dead. Its declaration is different: + -- the retained assignment still needs storage to exist. + let withSource = addRequiredSymbols (expressionSymbols value) beforeWrite + withDeclaration = + withSource + { requiredDeclarations = + Set.insert symbol (requiredDeclarations withSource) + } + in (CoreAssign name value : remaining, withDeclaration) + else preserveDeadValue environment facts value remaining beforeWrite + +eliminateBranch :: + EffectEnvironment -> + IntegerFacts -> + CoreExpression -> + [CoreStatement] -> + [CoreStatement] -> + [CoreStatement] -> + LiveState -> + ([CoreStatement], LiveState) +eliminateBranch environment facts condition yes no remaining liveAfter = + let optimizedCondition = optimizeExpression environment condition + afterCondition = transferExpressionFacts facts condition + trueFacts = refineConditionFacts True condition afterCondition + falseFacts = refineConditionFacts False condition afterCondition + (optimizedYes, liveYes) = eliminateStatements environment trueFacts liveAfter yes + (optimizedNo, liveNo) = eliminateStatements environment falseFacts liveAfter no + branchState = mergeLiveStates [liveYes, liveNo] + liveBefore = addRequiredSymbols (expressionSymbols optimizedCondition) branchState + in (CoreIf optimizedCondition optimizedYes optimizedNo : remaining, liveBefore) + +preserveDeadValue :: + EffectEnvironment -> IntegerFacts -> CoreExpression -> [CoreStatement] -> LiveState -> ([CoreStatement], LiveState) +preserveDeadValue environment facts value remaining liveAfter + | discardableExpressionWithFacts environment facts value = (remaining, liveAfter) + | otherwise = + ( CoreEvaluate value : remaining + , addRequiredSymbols (expressionSymbols value) liveAfter + ) + +-- Closure bodies are independent liveness regions. Capture initializers are +-- evaluated outside the closure, while the body is analyzed from its own +-- return and effect roots. The module effect environment is still valid for +-- direct calls made when that callable eventually executes. +optimizeExpression :: EffectEnvironment -> CoreExpression -> CoreExpression +optimizeExpression environment expression = case expression of + CoreVariable {} -> expression + CoreLiteral {} -> expression + CoreApply callee arguments valueType -> + CoreApply + (optimizeExpression environment callee) + (map (optimizeExpression environment) arguments) + valueType + CorePrimitive primitive arguments valueType -> + CorePrimitive primitive (map (optimizeExpression environment) arguments) valueType + CoreLet name bindingType value body valueType -> + CoreLet + name + bindingType + (optimizeExpression environment value) + (optimizeExpression environment body) + valueType + CoreConditional condition whenTrue whenFalse valueType -> + CoreConditional + (optimizeExpression environment condition) + (optimizeExpression environment whenTrue) + (optimizeExpression environment whenFalse) + valueType + CoreClosure captures parameters returnType body valueType -> + CoreClosure + [capture {coreCaptureValue = optimizeExpression environment (coreCaptureValue capture)} | capture <- captures] + parameters + returnType + (fst (eliminateStatements environment emptyIntegerFacts emptyLiveState body)) + valueType
+ src/Progmasoft/Tala/Core/Optimizer/Pipeline.hs view
@@ -0,0 +1,99 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +module Progmasoft.Tala.Core.Optimizer.Pipeline (runOptimizationPipeline) where + +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Optimizer.Analysis (emptyEffectEnvironment) +import Progmasoft.Tala.Core.Optimizer.Constant +import Progmasoft.Tala.Core.Optimizer.ControlFlow +import Progmasoft.Tala.Core.Optimizer.EffectInference +import Progmasoft.Tala.Core.Optimizer.Inline +import Progmasoft.Tala.Core.Optimizer.Liveness +import Progmasoft.Tala.Core.Optimizer.Types + +runOptimizationPipeline :: OptimizerOptions -> CoreModule -> OptimizationResult +runOptimizationPipeline options original = + let maximumIterations = max 1 (optimizerMaximumIterations options) + (optimized, iterations, converged, reports, inlineReports) = iteratePipeline maximumIterations 1 original [] [] + in OptimizationResult + { optimizedCore = optimized + , optimizationBefore = measureModule original + , optimizationAfter = measureModule optimized + , optimizationIterations = iterations + , optimizationConverged = converged + , optimizationPassReports = reports + , optimizationEffectReports = finalEffectReports optimized + , optimizationInlineReports = inlineReports + } + where + finalEffectReports value + | optimizerInterproceduralEffects options = snd (inferFunctionEffects value) + | otherwise = [] + iteratePipeline maximumIterations iteration current reports inlineReports = + let (next, currentReports, currentInlineReports) = runIteration options iteration current + accumulated = reports ++ currentReports + accumulatedInline = inlineReports ++ currentInlineReports + in if next == current + then (next, iteration, True, accumulated, accumulatedInline) + else + if iteration >= maximumIterations + then (next, iteration, False, accumulated, accumulatedInline) + else iteratePipeline maximumIterations (iteration + 1) next accumulated accumulatedInline + +runIteration :: OptimizerOptions -> Int -> CoreModule -> (CoreModule, [PassReport], [InlineReport]) +runIteration options iteration input = + let (_, effectReports) = inferFunctionEffects input + (afterInlining, inliningReports, inlineReports) = + runInlining + (optimizerInlining options && optimizerInterproceduralEffects options) + effectReports + input + (afterConstants, constantReports) = + runEnabled + (optimizerConstantPropagation options) + ConstantPropagationPass + propagateConstants + afterInlining + controlEnvironment = inferEnvironment afterConstants + (afterControlFlow, controlFlowReports) = + runEnabled + (optimizerControlFlowSimplification options) + ControlFlowSimplificationPass + (simplifyControlFlowWith controlEnvironment) + afterConstants + deadCodeEnvironment = inferEnvironment afterControlFlow + (afterDeadCode, deadCodeReports) = + runEnabled + (optimizerDeadCodeElimination options) + DeadCodeEliminationPass + (eliminateDeadCodeWith deadCodeEnvironment) + afterControlFlow + in (afterDeadCode, inliningReports ++ constantReports ++ controlFlowReports ++ deadCodeReports, inlineReports) + where + runInlining enabled effects before + | not enabled = (before, [], []) + | otherwise = + let (after, inlineReport) = inlineFunctions (optimizerMaximumInlineExpressionNodes options) effects before + in ( after + , [PassReport iteration InliningPass (measureModule before) (measureModule after) (before /= after)] + , [inlineReport] + ) + inferEnvironment value + | optimizerInterproceduralEffects options = fst (inferFunctionEffects value) + | otherwise = emptyEffectEnvironment + runEnabled enabled passName pass before + | not enabled = (before, []) + | otherwise = + let after = pass before + in ( after + , + [ PassReport + { passReportIteration = iteration + , passReportPass = passName + , passReportBefore = measureModule before + , passReportAfter = measureModule after + , passReportChanged = before /= after + } + ] + )
+ src/Progmasoft/Tala/Core/Optimizer/Types.hs view
@@ -0,0 +1,154 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +module Progmasoft.Tala.Core.Optimizer.Types + ( OptimizerOptions (..) + , OptimizationPass (..) + , OptimizationMetrics (..) + , PassReport (..) + , OptimizationResult (..) + , defaultOptimizerOptions + , emptyMetrics + , addMetrics + , measureModule + ) where + +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Optimizer.Analysis (FunctionEffectReport) +import Progmasoft.Tala.Core.Optimizer.Inline (InlineReport) + +-- | Controls fixed-point iterations and individually selectable Core passes. +data OptimizerOptions = OptimizerOptions + { optimizerMaximumIterations :: Int + , optimizerConstantPropagation :: Bool + , optimizerControlFlowSimplification :: Bool + , optimizerDeadCodeElimination :: Bool + , optimizerInterproceduralEffects :: Bool + , optimizerInlining :: Bool + , optimizerMaximumInlineExpressionNodes :: Int + } + deriving (Eq, Ord, Read, Show) + +-- | Default bounded optimization configuration used by the compiler pipeline. +defaultOptimizerOptions :: OptimizerOptions +defaultOptimizerOptions = OptimizerOptions 12 True True True True True 24 + +-- Pass names are data rather than display strings so compiler drivers can +-- render reports without parsing human-oriented output. The order of these +-- constructors does not define execution order; Pipeline owns that policy. + +-- | Stable identifier for one transformation family in pass reports. +data OptimizationPass + = ConstantPropagationPass + | InliningPass + | ControlFlowSimplificationPass + | DeadCodeEliminationPass + deriving (Eq, Ord, Read, Show) + +-- | Structural counts collected before and after optimization. +data OptimizationMetrics = OptimizationMetrics + { metricFunctions :: Int + , metricStatements :: Int + , metricExpressions :: Int + , metricBindings :: Int + , metricAssignments :: Int + , metricBranches :: Int + , metricCalls :: Int + , metricClosures :: Int + } + deriving (Eq, Ord, Read, Show) + +-- | Verified optimized Core and deterministic reports for all executed passes. +data OptimizationResult = OptimizationResult + { optimizedCore :: CoreModule + , optimizationBefore :: OptimizationMetrics + , optimizationAfter :: OptimizationMetrics + , optimizationIterations :: Int + , optimizationConverged :: Bool + , optimizationPassReports :: [PassReport] + , optimizationEffectReports :: [FunctionEffectReport] + , optimizationInlineReports :: [InlineReport] + } + deriving (Eq, Ord, Read, Show) + +-- A report describes one enabled pass invocation in one fixed-point +-- iteration. Keeping the complete trace makes an optimizer decision +-- inspectable without exposing an unstable textual dump as a public API. + +-- | Before/after measurements for one pass in one fixed-point iteration. +data PassReport = PassReport + { passReportIteration :: Int + , passReportPass :: OptimizationPass + , passReportBefore :: OptimizationMetrics + , passReportAfter :: OptimizationMetrics + , passReportChanged :: Bool + } + deriving (Eq, Ord, Read, Show) + +emptyMetrics :: OptimizationMetrics +emptyMetrics = OptimizationMetrics 0 0 0 0 0 0 0 0 + +addMetrics :: OptimizationMetrics -> OptimizationMetrics -> OptimizationMetrics +addMetrics left right = + OptimizationMetrics + { metricFunctions = metricFunctions left + metricFunctions right + , metricStatements = metricStatements left + metricStatements right + , metricExpressions = metricExpressions left + metricExpressions right + , metricBindings = metricBindings left + metricBindings right + , metricAssignments = metricAssignments left + metricAssignments right + , metricBranches = metricBranches left + metricBranches right + , metricCalls = metricCalls left + metricCalls right + , metricClosures = metricClosures left + metricClosures right + } + +measureModule :: CoreModule -> OptimizationMetrics +measureModule moduleValue = foldl addMetrics emptyMetrics (map measureFunction (coreModuleFunctions moduleValue)) + +measureFunction :: CoreFunction -> OptimizationMetrics +measureFunction function = (measureStatements (coreFunctionBody function)) {metricFunctions = 1} + +measureStatements :: [CoreStatement] -> OptimizationMetrics +measureStatements = foldl (\total statement -> addMetrics total (measureStatement statement)) emptyMetrics + +measureStatement :: CoreStatement -> OptimizationMetrics +measureStatement statement = + let nested = case statement of + CoreBind binding -> (measureExpression (coreBindingValue binding)) {metricBindings = 1} + CoreAssign _ value -> (measureExpression value) {metricAssignments = 1} + CoreReturn value -> measureExpression value + CoreIf condition yes no -> + (addMetrics (measureExpression condition) (addMetrics (measureStatements yes) (measureStatements no))) + { metricBranches = 1 + } + CoreWhile condition body -> + (addMetrics (measureExpression condition) (measureStatements body)) {metricBranches = 1} + CoreDoWhile body condition -> + (addMetrics (measureStatements body) (measureExpression condition)) {metricBranches = 1} + CoreFor condition body update -> + (addMetrics (measureExpression condition) (addMetrics (measureStatements body) (measureStatements update))) + { metricBranches = 1 + } + CoreEvaluate value -> measureExpression value + CoreBreak -> emptyMetrics + CoreContinue -> emptyMetrics + in nested {metricStatements = metricStatements nested + 1} + +measureExpression :: CoreExpression -> OptimizationMetrics +measureExpression expression = + let nested = case expression of + CoreVariable _ _ -> emptyMetrics + CoreLiteral _ _ -> emptyMetrics + CoreApply callee arguments _ -> + (foldl addMetrics (measureExpression callee) (map measureExpression arguments)) {metricCalls = 1} + CorePrimitive _ arguments _ -> foldl addMetrics emptyMetrics (map measureExpression arguments) + CoreLet _ _ value body _ -> addMetrics (measureExpression value) (measureExpression body) + CoreConditional condition whenTrue whenFalse _ -> + foldl addMetrics (measureExpression condition) (map measureExpression [whenTrue, whenFalse]) + CoreClosure captures _ _ body _ -> + ( addMetrics + (foldl addMetrics emptyMetrics (map (measureExpression . coreCaptureValue) captures)) + (measureStatements body) + ) + { metricClosures = 1 + } + in nested {metricExpressions = metricExpressions nested + 1}
+ src/Progmasoft/Tala/Core/Scalar.hs view
@@ -0,0 +1,116 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +-- | Canonical scalar facts shared by Core verification and optimization. +module Progmasoft.Tala.Core.Scalar + ( coreTypeSpelling + , coreIntegerTypeNames + , coreFloatingTypeNames + , coreNumericTypeNames + , isCoreIntegerType + , isCoreFloatingType + , isCoreNumericType + , coreIntegerBitWidth + , coreIntegerIsSigned + , integerFitsCoreType + , validCoreFloatingSpelling + ) where + +import Progmasoft.Tala.AST + +-- | Extract the leaf spelling from a non-generic built-in type. +coreTypeSpelling :: Type -> String +coreTypeSpelling (NamedType (QualifiedName [Identifier name]) []) = name +coreTypeSpelling _ = "" + +-- | Canonical integer type names, including signed and unsigned widths. +coreIntegerTypeNames :: [String] +coreIntegerTypeNames = map fst integerLayouts + +-- | Canonical floating-point type names in the language. +coreFloatingTypeNames :: [String] +coreFloatingTypeNames = ["sfloat", "lfloat", "float", "double"] + +-- | Integer and floating-point names accepted by Core numeric rules. +coreNumericTypeNames :: [String] +coreNumericTypeNames = coreIntegerTypeNames ++ coreFloatingTypeNames + +-- | Test whether a Core type is a built-in integer scalar. +isCoreIntegerType :: Type -> Bool +isCoreIntegerType valueType = coreTypeSpelling valueType `elem` coreIntegerTypeNames + +-- | Test whether a Core type is a built-in floating scalar. +isCoreFloatingType :: Type -> Bool +isCoreFloatingType valueType = coreTypeSpelling valueType `elem` coreFloatingTypeNames + +-- | Test whether a Core type is an integer or floating scalar. +isCoreNumericType :: Type -> Bool +isCoreNumericType valueType = coreTypeSpelling valueType `elem` coreNumericTypeNames + +{- | Return the source-level storage width for a built-in integer type. +Keeping this catalog next to range validation lets optimizer operations +reject unsafe shifts without duplicating the language's integer table. +-} +coreIntegerBitWidth :: Type -> Maybe Int +coreIntegerBitWidth valueType = snd <$> lookup (coreTypeSpelling valueType) integerLayouts + +-- | Report whether a scalar integer type uses a sign bit. +coreIntegerIsSigned :: Type -> Maybe Bool +coreIntegerIsSigned valueType = fst <$> lookup (coreTypeSpelling valueType) integerLayouts + +integerLayouts :: [(String, (Bool, Int))] +integerLayouts = + [ ("char", (False, 32)) + , ("byte", (True, 8)) + , ("short", (True, 16)) + , ("long", (True, 32)) + , ("int", (True, 64)) + , ("longint", (True, 128)) + , ("ubyte", (False, 8)) + , ("ushort", (False, 16)) + , ("ulong", (False, 32)) + , ("uint", (False, 64)) + , ("ulongint", (False, 128)) + ] + +-- | Test whether an exact integer value lies in a Core integer type's range. +integerFitsCoreType :: Type -> Integer -> Bool +integerFitsCoreType valueType value = case lookup (coreTypeSpelling valueType) integerLayouts of + Just (isSigned, width) -> + let magnitude = 2 ^ (width - if isSigned then 1 else 0) + minimumValue = if isSigned then negate magnitude else 0 + maximumValue = magnitude - 1 + in value >= minimumValue && value <= maximumValue + Nothing -> False + +-- | Validate a deterministic ASCII decimal or supported special float spelling. +validCoreFloatingSpelling :: String -> Bool +validCoreFloatingSpelling spelling + | spelling `elem` ["nan", "+nan", "-nan", "inf", "+inf", "-inf"] = True + | otherwise = case dropSign spelling of + [] -> False + unsignedSpelling -> + let (mantissa, exponentPart) = break (`elem` "eE") unsignedSpelling + in validMantissa mantissa && validExponent exponentPart + where + dropSign ('+' : remaining) = remaining + dropSign ('-' : remaining) = remaining + dropSign value = value + validMantissa value = case break (== '.') value of + (whole, []) -> digits whole + (whole, _ : fraction) -> + (not (null whole) || not (null fraction)) + && digitsOrEmpty whole + && digitsOrEmpty fraction + validExponent [] = True + validExponent (_ : remaining) = digits (dropExponentSign remaining) + dropExponentSign ('+' : remaining) = remaining + dropExponentSign ('-' : remaining) = remaining + dropExponentSign value = value + -- Core artifacts are a stable, language-neutral boundary. Accepting + -- Unicode decimal categories here would make spellings depend on the + -- host implementation of character classification even though source + -- numeric tokens are deliberately ASCII. + asciiDigit character = character >= '0' && character <= '9' + digits value = not (null value) && all asciiDigit value + digitsOrEmpty value = null value || all asciiDigit value
+ src/Progmasoft/Tala/Core/Specialization.hs view
@@ -0,0 +1,175 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Deterministic specialization planning for Core monomorphization. + +Parsing and type checking preserve ordered template arguments, while this +module owns the transition from a possibly-open type to a concrete cache +entry. It deliberately contains no code generation policy: the same plan +can feed Core cloning, CorePrep scheduling, or incremental build metadata. +-} +module Progmasoft.Tala.Core.Specialization + ( Specialization (..) + , SpecializationCatalog + , SpecializationError (..) + , SpecializationId (..) + , TypeBindings + , ValueBindings + , catalogSize + , emptyCatalog + , findSpecialization + , findSpecializationByType + , internSpecialization + , internSpecializations + , prepareSpecialization + , specializationSnapshot + ) where + +import Data.List (group, sort) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core.Template + +-- | Substitution environment mapping template symbols to concrete types. +type TypeBindings = [(SymbolId, Type)] + +-- | Substitution environment mapping template symbols to constant values. +type ValueBindings = [(SymbolId, TemplateValue)] + +-- | Monotonic identity assigned to an interned concrete specialization. +newtype SpecializationId = SpecializationId {specializationIdValue :: Int} + deriving (Eq, Ord, Read, Show) + +-- | A validated closed type stored in a specialization catalog. +data Specialization = Specialization + { specializationId :: SpecializationId + -- ^ Catalog-local stable identifier. + , specializationIdentity :: String + -- ^ Canonical structural identity key. + , specializationType :: Type + -- ^ Validated concrete type. + } + deriving (Eq, Ord, Read, Show) + +-- | Persistent immutable index by canonical identity and catalog identifier. +data SpecializationCatalog = SpecializationCatalog + { catalogNextId :: SpecializationId + , catalogByIdentity :: Map String Specialization + , catalogById :: Map SpecializationId Specialization + } + deriving (Eq, Read, Show) + +-- | Rejected substitution, open type, or ambiguous binding environment. +data SpecializationError + = -- | Concrete type failed structural validation. + InvalidSpecialization [TemplateIssue] + | -- | Type/value parameter identities remain unresolved. + OpenSpecialization [SymbolId] + | -- | A type binding key occurs more than once. + DuplicateTypeBinding [SymbolId] + | -- | A value binding key occurs more than once. + DuplicateValueBinding [SymbolId] + | -- | One identity is bound as both type and value. + ConflictingBindingKinds [SymbolId] + deriving (Eq, Ord, Read, Show) + +-- | Create a catalog whose first assigned identity is one. +emptyCatalog :: SpecializationCatalog +emptyCatalog = SpecializationCatalog (SpecializationId 1) Map.empty Map.empty + +-- | Return the number of unique concrete types currently interned. +catalogSize :: SpecializationCatalog -> Int +catalogSize = Map.size . catalogById + +{- | Substitute bindings and prove that the resulting key is both structurally +valid and closed. Binding diagnostics are deterministic and reported before +structural issues, making build failures independent of map insertion order. +-} + +-- | Apply bindings, validate structure, and reject any remaining open symbols. +prepareSpecialization :: TypeBindings -> ValueBindings -> Type -> Either SpecializationError Type +prepareSpecialization typeBindings valueBindings input = do + validateBindings typeBindings valueBindings + let concrete = substituteTemplateType typeBindings valueBindings input + issues = validateTemplateType 128 concrete + parameters = collectTemplateParameters concrete + if not (null issues) + then Left (InvalidSpecialization issues) + else + if not (null parameters) + then Left (OpenSpecialization parameters) + else Right concrete + +{- | Intern one already-concrete type. The Bool distinguishes a newly planned +specialization from an existing cache hit without assigning a second id. +-} + +-- | Validate and intern one concrete type; report whether it was newly added. +internSpecialization :: + Type -> + SpecializationCatalog -> + Either SpecializationError (Specialization, Bool, SpecializationCatalog) +internSpecialization input catalog = do + concrete <- prepareSpecialization [] [] input + let identity = renderTemplateIdentity concrete + case Map.lookup identity (catalogByIdentity catalog) of + Just existing -> Right (existing, False, catalog) + Nothing -> + let entry = Specialization (catalogNextId catalog) identity concrete + next = successor (catalogNextId catalog) + updated = + SpecializationCatalog + next + (Map.insert identity entry (catalogByIdentity catalog)) + (Map.insert (specializationId entry) entry (catalogById catalog)) + in Right (entry, True, updated) + +{- | Intern a worklist atomically. Because the catalog is immutable, returning +Left naturally discards entries prepared earlier in the same batch. Repeated +keys in one worklist share their first insertion-order id. +-} + +-- | Intern a batch transactionally while preserving first-seen identity order. +internSpecializations :: + [Type] -> + SpecializationCatalog -> + Either SpecializationError ([Specialization], SpecializationCatalog) +internSpecializations inputs initial = go [] initial inputs + where + go entries catalog [] = Right (reverse entries, catalog) + go entries catalog (input : remaining) = do + (entry, _, updated) <- internSpecialization input catalog + go (entry : entries) updated remaining + +-- | Find a catalog entry by its assigned identifier. +findSpecialization :: SpecializationId -> SpecializationCatalog -> Maybe Specialization +findSpecialization key = Map.lookup key . catalogById + +-- | Find a previously interned entry by canonical type identity. +findSpecializationByType :: Type -> SpecializationCatalog -> Maybe Specialization +findSpecializationByType input catalog = + Map.lookup (renderTemplateIdentity input) (catalogByIdentity catalog) + +-- | Snapshot catalog entries ordered by specialization identifier. +specializationSnapshot :: SpecializationCatalog -> [Specialization] +specializationSnapshot = Map.elems . catalogById + +successor :: SpecializationId -> SpecializationId +successor (SpecializationId value) = SpecializationId (value + 1) + +validateBindings :: TypeBindings -> ValueBindings -> Either SpecializationError () +validateBindings typeBindings valueBindings + | not (null duplicateTypes) = Left (DuplicateTypeBinding duplicateTypes) + | not (null duplicateValues) = Left (DuplicateValueBinding duplicateValues) + | not (null conflicts) = Left (ConflictingBindingKinds conflicts) + | otherwise = Right () + where + typeKeys = map fst typeBindings + valueKeys = map fst valueBindings + duplicateTypes = duplicates typeKeys + duplicateValues = duplicates valueKeys + conflicts = Map.keys (Map.intersection (keySet typeKeys) (keySet valueKeys)) + + keySet = Map.fromList . map (,()) + duplicates values = [first | duplicate@(first : _) <- group (sort values), length duplicate > 1]
+ src/Progmasoft/Tala/Core/Symbols.hs view
@@ -0,0 +1,92 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Complete SymbolId inventory for Core. + +Optimization passes sometimes have to introduce compiler-owned binders. They +must not guess a starting value from function names alone: parameters, local +bindings, expression-local lets, closure captures, and lifted closure +parameters all inhabit the same resolved identity space. This module owns the +structural traversal used to find a collision-free fresh-symbol frontier. + +The inventory includes definitions and uses. Including uses is intentional. +A verified module cannot contain a dangling use, but transformation helpers are +also exercised on partially built fixtures. Starting above every observed id +keeps those transformations deterministic and prevents a secondary diagnostic +from obscuring the original malformed reference. +-} +module Progmasoft.Tala.Core.Symbols + ( coreModuleSymbols + , coreFunctionSymbols + , coreStatementSymbols + , coreExpressionSymbols + , maximumCoreSymbolValue + , nextCoreSymbolValue + ) where + +import Progmasoft.Tala.AST (ResolvedName, resolvedSymbol, symbolIdValue) +import Progmasoft.Tala.Core + +-- | Return every resolved name observed in deterministic source order. +coreModuleSymbols :: CoreModule -> [ResolvedName] +coreModuleSymbols = concatMap coreFunctionSymbols . coreModuleFunctions + +-- | Include the function definition before its parameter and body identities. +coreFunctionSymbols :: CoreFunction -> [ResolvedName] +coreFunctionSymbols function = + coreFunctionName function + : map fst (coreFunctionParameters function) + ++ concatMap coreStatementSymbols (coreFunctionBody function) + +-- | Traverse a statement, including both targets and expression references. +coreStatementSymbols :: CoreStatement -> [ResolvedName] +coreStatementSymbols statement = case statement of + CoreBind binding -> + coreBindingName binding : coreExpressionSymbols (coreBindingValue binding) + CoreAssign name value -> name : coreExpressionSymbols value + CoreReturn value -> coreExpressionSymbols value + CoreEvaluate value -> coreExpressionSymbols value + CoreIf condition whenTrue whenFalse -> + coreExpressionSymbols condition + ++ concatMap coreStatementSymbols whenTrue + ++ concatMap coreStatementSymbols whenFalse + CoreWhile condition body -> coreExpressionSymbols condition ++ concatMap coreStatementSymbols body + CoreDoWhile body condition -> concatMap coreStatementSymbols body ++ coreExpressionSymbols condition + CoreFor condition body update -> + coreExpressionSymbols condition + ++ concatMap coreStatementSymbols body + ++ concatMap coreStatementSymbols update + CoreBreak -> [] + CoreContinue -> [] + +-- | Traverse all expression-owned scopes, including closure bodies. +coreExpressionSymbols :: CoreExpression -> [ResolvedName] +coreExpressionSymbols expression = case expression of + CoreVariable name _ -> [name] + CoreLiteral {} -> [] + CoreApply callee arguments _ -> + coreExpressionSymbols callee ++ concatMap coreExpressionSymbols arguments + CorePrimitive _ arguments _ -> concatMap coreExpressionSymbols arguments + CoreLet name _ value body _ -> + name : coreExpressionSymbols value ++ coreExpressionSymbols body + CoreConditional condition whenTrue whenFalse _ -> + coreExpressionSymbols condition ++ coreExpressionSymbols whenTrue ++ coreExpressionSymbols whenFalse + CoreClosure captures parameters _ body _ -> + map coreCaptureName captures + ++ map fst parameters + ++ concatMap (coreExpressionSymbols . coreCaptureValue) captures + ++ concatMap coreStatementSymbols body + +-- | Largest numeric identity observed in the complete Core tree. +maximumCoreSymbolValue :: CoreModule -> Int +maximumCoreSymbolValue moduleValue = + maximum + ( 0 + : map + (symbolIdValue . resolvedSymbol) + (coreModuleSymbols moduleValue) + ) + +-- | First positive identity that is guaranteed not to collide with the module. +nextCoreSymbolValue :: CoreModule -> Int +nextCoreSymbolValue moduleValue = maximumCoreSymbolValue moduleValue + 1
+ src/Progmasoft/Tala/Core/Template.hs view
@@ -0,0 +1,284 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Template specialization identity and substitution. + +Core does not instantiate declarations yet, but it must already preserve +exact specialization identity. This module is the single semantic owner for +walking ordered type/value arguments, validating their portable payloads, +and replacing parameters when monomorphization requests a concrete type. +-} +module Progmasoft.Tala.Core.Template + ( ArrayShape (..) + , TemplateIssue (..) + , TemplateIssueKind (..) + , TemplateMetrics (..) + , classifyArrayType + , collectTemplateParameters + , concreteTemplateType + , emptyTemplateMetrics + , measureTemplateType + , renderTemplateIdentity + , substituteTemplateType + , validateTemplateType + ) where + +import Data.List (intercalate, nub, sort) +import Progmasoft.Tala.AST + +-- | Recognized form of the language's intrinsic or standard fixed array type. +data ArrayShape + = -- | Legacy intrinsic array spelling with an element type. + BuiltinArrayShape Type + | -- | Dynamic @System.Array<T>@ form. + DynamicArrayShape Type + | -- | Fixed @System.Array<T, N>@ form. + FixedArrayShape Type Integer + deriving (Eq, Ord, Read, Show) + +-- | Category of malformed template identity or unsupported type payload. +data TemplateIssueKind + = -- | Type nesting exceeds the caller's maximum depth. + TemplateDepthExceeded + | -- | A named type has no name components. + TemplateEmptyQualifiedName + | -- | A qualified name contains an empty component. + TemplateEmptyNamePart + | -- | A template variable has an invalid identity or spelling. + TemplateInvalidParameter + | -- | Character value is not a Unicode scalar. + TemplateInvalidCharacter + | -- | Fixed array extent is negative. + TemplateNegativeArraySize + | -- | Built-in array arity or argument shape is invalid. + TemplateMalformedArrayFamily + deriving (Eq, Ord, Read, Show) + +-- | One validation issue with the nested argument path that caused it. +data TemplateIssue = TemplateIssue + { templateIssueKind :: TemplateIssueKind + -- ^ Stable issue category. + , templateIssuePath :: [Int] + -- ^ Zero-based indices through nested type arguments. + , templateIssueMessage :: String + -- ^ Human-readable detail. + } + deriving (Eq, Ord, Read, Show) + +-- | Structural counts used to estimate and bound template type complexity. +data TemplateMetrics = TemplateMetrics + { templateTypeNodes :: Int + -- ^ Named, function, or variable type nodes. + , templateTypeArguments :: Int + -- ^ Type-valued template arguments. + , templateValueArguments :: Int + -- ^ Compile-time value arguments. + , templateParameterReferences :: Int + -- ^ References to open type/value parameters. + , templateMaximumDepth :: Int + -- ^ Deepest nested node or argument encountered. + } + deriving (Eq, Ord, Read, Show) + +-- | Zero-valued metric accumulator. +emptyTemplateMetrics :: TemplateMetrics +emptyTemplateMetrics = TemplateMetrics 0 0 0 0 0 + +-- | Recognize the built-in and System.Array type encodings. +classifyArrayType :: Type -> Maybe ArrayShape +classifyArrayType valueType = case valueType of + NamedType (QualifiedName [Identifier "[]"]) [TypeTemplateArgument element] -> + Just (BuiltinArrayShape element) + NamedType + (QualifiedName [Identifier "System", Identifier "Array"]) + [TypeTemplateArgument element] -> + Just (DynamicArrayShape element) + NamedType + (QualifiedName [Identifier "System", Identifier "Array"]) + [TypeTemplateArgument element, ValueTemplateArgument (IntegerTemplateValue size)] -> + Just (FixedArrayShape element size) + _ -> Nothing + +-- | Validate type names, open symbols, array forms, and nesting depth. +validateTemplateType :: Int -> Type -> [TemplateIssue] +validateTemplateType maximumDepth = validateType [] 0 + where + validateType path depth valueType + | depth > maximumDepth = + [TemplateIssue TemplateDepthExceeded path "template type nesting exceeds the configured limit"] + | otherwise = case valueType of + NamedType name arguments -> + validateName path name + ++ concat + [ validateArgument (path ++ [index]) (depth + 1) argument + | (index, argument) <- zip [0 ..] arguments + ] + ++ validateArray path name arguments + FunctionType parameters result -> + concat + [ validateType (path ++ [index]) (depth + 1) parameter + | (index, parameter) <- zip [0 ..] parameters + ] + ++ validateType (path ++ [length parameters]) (depth + 1) result + TypeVariable name -> validateParameter path name + ErrorType -> [] + + validateArgument path depth argument = case argument of + TypeTemplateArgument nested -> validateType path depth nested + ValueTemplateArgument value -> validateValue path value + +validateName :: [Int] -> QualifiedName -> [TemplateIssue] +validateName path (QualifiedName parts) + | null parts = [TemplateIssue TemplateEmptyQualifiedName path "named type has an empty qualified name"] + | otherwise = + [ TemplateIssue TemplateEmptyNamePart (path ++ [index]) "named type contains an empty name component" + | (index, Identifier part) <- zip [0 ..] parts + , null part + ] + +validateParameter :: [Int] -> ResolvedName -> [TemplateIssue] +validateParameter path name + | symbolIdValue (resolvedSymbol name) <= 0 = + [TemplateIssue TemplateInvalidParameter path "template parameter SymbolId must be positive"] + | null (identifierText (resolvedSpelling name)) = + [TemplateIssue TemplateInvalidParameter path "template parameter spelling cannot be empty"] + | otherwise = [] + +validateValue :: [Int] -> TemplateValue -> [TemplateIssue] +validateValue path value = case value of + IntegerTemplateValue _ -> [] + BooleanTemplateValue _ -> [] + CharacterTemplateValue scalar + | validUnicodeScalar scalar -> [] + | otherwise -> [TemplateIssue TemplateInvalidCharacter path "character template value is not a Unicode scalar"] + TemplateValueParameter name -> validateParameter path name + +validateArray :: [Int] -> QualifiedName -> [TemplateArgument] -> [TemplateIssue] +validateArray path name arguments + | name == QualifiedName [Identifier "[]"] = case arguments of + [TypeTemplateArgument _] -> [] + _ -> [TemplateIssue TemplateMalformedArrayFamily path "built-in [] requires exactly one type argument"] + | name == QualifiedName [Identifier "System", Identifier "Array"] = case arguments of + [TypeTemplateArgument _] -> [] + [TypeTemplateArgument _, ValueTemplateArgument (IntegerTemplateValue size)] + | size < 0 -> [TemplateIssue TemplateNegativeArraySize (path ++ [1]) "fixed System.Array size cannot be negative"] + | otherwise -> [] + [TypeTemplateArgument _, ValueTemplateArgument (TemplateValueParameter _)] -> [] + _ -> [TemplateIssue TemplateMalformedArrayFamily path "System.Array requires <T> or <T, integral size N>"] + | otherwise = [] + +validUnicodeScalar :: Integer -> Bool +validUnicodeScalar scalar = + scalar >= 0 + && scalar <= 0x10ffff + && not (scalar >= 0xd800 && scalar <= 0xdfff) + +-- | Count nested type/value arguments and open-parameter references. +measureTemplateType :: Type -> TemplateMetrics +measureTemplateType = measureType 0 + where + measureType depth valueType = case valueType of + NamedType _ arguments -> + foldl addMetrics (node depth) (map (measureArgument (depth + 1)) arguments) + FunctionType parameters result -> + foldl addMetrics (node depth) (map (measureType (depth + 1)) (parameters ++ [result])) + TypeVariable _ -> (node depth) {templateParameterReferences = 1} + ErrorType -> node depth + + measureArgument depth argument = case argument of + TypeTemplateArgument nested -> + let metrics = measureType depth nested + in metrics {templateTypeArguments = templateTypeArguments metrics + 1} + ValueTemplateArgument value -> + emptyTemplateMetrics + { templateValueArguments = 1 + , templateParameterReferences = case value of TemplateValueParameter _ -> 1; _ -> 0 + , templateMaximumDepth = depth + } + + node depth = emptyTemplateMetrics {templateTypeNodes = 1, templateMaximumDepth = depth} + +addMetrics :: TemplateMetrics -> TemplateMetrics -> TemplateMetrics +addMetrics left right = + TemplateMetrics + { templateTypeNodes = templateTypeNodes left + templateTypeNodes right + , templateTypeArguments = templateTypeArguments left + templateTypeArguments right + , templateValueArguments = templateValueArguments left + templateValueArguments right + , templateParameterReferences = templateParameterReferences left + templateParameterReferences right + , templateMaximumDepth = max (templateMaximumDepth left) (templateMaximumDepth right) + } + +-- | Collect distinct open type and value parameter identities in sorted order. +collectTemplateParameters :: Type -> [SymbolId] +collectTemplateParameters = sort . nub . collectType + where + collectType valueType = case valueType of + NamedType _ arguments -> concatMap collectArgument arguments + FunctionType parameters result -> concatMap collectType (parameters ++ [result]) + TypeVariable name -> [resolvedSymbol name] + ErrorType -> [] + collectArgument argument = case argument of + TypeTemplateArgument nested -> collectType nested + ValueTemplateArgument (TemplateValueParameter name) -> [resolvedSymbol name] + ValueTemplateArgument _ -> [] + +-- | Test whether no type or value parameter remains anywhere in the type. +concreteTemplateType :: Type -> Bool +concreteTemplateType = null . collectTemplateParameters + +-- | Replace open type/value parameters recursively using explicit bindings. +substituteTemplateType :: [(SymbolId, Type)] -> [(SymbolId, TemplateValue)] -> Type -> Type +substituteTemplateType typeBindings valueBindings = substituteType + where + substituteType valueType = case valueType of + NamedType name arguments -> NamedType name (map substituteArgument arguments) + FunctionType parameters result -> FunctionType (map substituteType parameters) (substituteType result) + TypeVariable name -> maybe valueType id (lookup (resolvedSymbol name) typeBindings) + ErrorType -> ErrorType + substituteArgument argument = case argument of + TypeTemplateArgument nested -> TypeTemplateArgument (substituteType nested) + ValueTemplateArgument (TemplateValueParameter name) -> + ValueTemplateArgument (maybe (TemplateValueParameter name) id (lookup (resolvedSymbol name) valueBindings)) + ValueTemplateArgument value -> ValueTemplateArgument value + +-- | Render a deterministic, length-delimited identity for a template type. +renderTemplateIdentity :: Type -> String +renderTemplateIdentity valueType = case valueType of + NamedType name arguments -> renderName name ++ renderArguments arguments + FunctionType parameters result -> + "fn(" ++ intercalate "," (map renderTemplateIdentity parameters) ++ ")->" ++ renderTemplateIdentity result + TypeVariable name -> "type$" ++ renderSymbol name + ErrorType -> "<error>" + +renderArguments :: [TemplateArgument] -> String +renderArguments [] = "" +renderArguments arguments = "<" ++ intercalate "," (map renderArgument arguments) ++ ">" + +renderArgument :: TemplateArgument -> String +renderArgument argument = case argument of + TypeTemplateArgument nested -> "type:" ++ renderTemplateIdentity nested + ValueTemplateArgument value -> "value:" ++ renderValue value + +renderValue :: TemplateValue -> String +renderValue value = case value of + IntegerTemplateValue integer -> "i:" ++ show integer + BooleanTemplateValue boolean -> "b:" ++ if boolean then "true" else "false" + CharacterTemplateValue scalar -> "c:" ++ show scalar + TemplateValueParameter name -> "parameter$" ++ renderSymbol name + +renderName :: QualifiedName -> String +renderName (QualifiedName parts) = intercalate "." (map renderPart parts) + where + -- Length-prefixing keeps dots and angle brackets in a future expanded + -- identifier alphabet from making two structural identities collide. + renderPart (Identifier part) = show (length part) ++ ":" ++ part + +renderSymbol :: ResolvedName -> String +renderSymbol name = + show (symbolIdValue (resolvedSymbol name)) + ++ ":" + ++ show (length spelling) + ++ ":" + ++ spelling + where + spelling = identifierText (resolvedSpelling name)
+ src/Progmasoft/Tala/Core/Verifier.hs view
@@ -0,0 +1,454 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Semantic trust boundary for target-independent Core. +Decoded artifacts and generated Core trees must pass this verifier before +CorePrep, optimization, or backend lowering consumes their identities and types. +-} +module Progmasoft.Tala.Core.Verifier (verifyCore) where + +import Data.List (group, sort) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Scalar +import Progmasoft.Tala.Core.Template +import Progmasoft.Tala.Diagnostic +import Progmasoft.Tala.RuntimeCall + +type Environment = Map.Map SymbolId (Type, Bool) + +-- | Validate module, function, type, symbol, return, and source-ownership rules. +verifyCore :: CoreModule -> Either [Diagnostic] CoreModule +verifyCore moduleValue = + case moduleProblems moduleValue of + [] -> Right moduleValue + problems -> Left problems + +moduleProblems :: CoreModule -> [Diagnostic] +moduleProblems moduleValue = + emptyName (coreModuleName moduleValue) + ++ duplicates "TAC1002" "duplicate Core function symbol" functionSymbols + ++ sourceCatalogProblems + ++ concatMap (verifyFunction functionEnvironment) (coreModuleFunctions moduleValue) + where + functions = coreModuleFunctions moduleValue + functionSymbols = map (resolvedSymbol . coreFunctionName) functions + sourceFiles = coreModuleSourceFiles moduleValue + sourceOwners = coreModuleFunctionSources moduleValue + sourceCatalogProblems = + duplicates "TAC1030" "duplicate Core source file" sourceFiles + ++ [problem "TAC1031" "Core source file path is empty or contains NUL" | any invalidPath sourceFiles] + ++ duplicates "TAC1032" "duplicate Core function source owner" (map fst sourceOwners) + ++ [ problem "TAC1033" "Core function source owner is absent from the module source catalog" + | (_, path) <- sourceOwners + , path `Set.notMember` sourceFileSet + ] + ++ [ problem "TAC1034" "Core function has no source owner" + | not (null sourceFiles) + , function <- functions + , let identifier = symbolIdValue (resolvedSymbol (coreFunctionName function)) + , identifier `Set.notMember` ownedFunctions + ] + -- Sets, because both checks run once for every function: against + -- lists, a module of thousands of functions was verified in time + -- with the square of their number. + sourceFileSet = Set.fromList sourceFiles + ownedFunctions = Set.fromList (map fst sourceOwners) + invalidPath path = null path || '\0' `elem` path + functionEnvironment = + Map.fromList + [ ( resolvedSymbol (coreFunctionName function) + , (FunctionType (map snd (coreFunctionParameters function)) (coreFunctionReturnType function), False) + ) + | function <- functions + ] + +verifyFunction :: Environment -> CoreFunction -> [Diagnostic] +verifyFunction functionEnvironment function = + invalidSymbol "TAC1006" "Core function symbol must be positive" (coreFunctionName function) + ++ unresolvedType "TAC1003" "Core function has an unresolved return type" (coreFunctionReturnType function) + ++ duplicates "TAC1004" "duplicate Core parameter symbol" parameterSymbols + ++ concatMap (uncurry verifyParameter) (coreFunctionParameters function) + ++ fst (verifyStatements initialEnvironment (coreFunctionReturnType function) OutsideLoop (coreFunctionBody function)) + ++ missingReturn + where + parameterSymbols = map (resolvedSymbol . fst) (coreFunctionParameters function) + initialEnvironment = + Map.union + (Map.fromList [(resolvedSymbol name, (valueType, False)) | (name, valueType) <- coreFunctionParameters function]) + functionEnvironment + missingReturn = + [ problem "TAC1005" "non-void Core function may complete without returning a value" + | coreFunctionReturnType function /= unitType && not (statementsAlwaysReturn (coreFunctionBody function)) + ] + +verifyParameter :: ResolvedName -> Type -> [Diagnostic] +verifyParameter name valueType = + invalidSymbol "TAC1006" "Core parameter symbol must be positive" name + ++ unresolvedType "TAC1007" "Core parameter has an unresolved type" valueType + +{- | Where a @break@ or @continue@ would transfer to. A @for@ update region is +inside its loop for @break@, which leaves the loop, but it is the loop's +continuation point itself: a @continue@ there has no later point of the same +iteration to reach and would re-enter the update without testing the +condition. A loop nested in an update opens an ordinary body scope again. +-} +data TransferScope = OutsideLoop | InLoopBody | InForUpdate + deriving (Eq) + +verifyStatements :: Environment -> Type -> TransferScope -> [CoreStatement] -> ([Diagnostic], Environment) +verifyStatements environment _ _ [] = ([], environment) +verifyStatements environment returnType scope (statement : remaining) = + let (currentProblems, nextEnvironment) = verifyStatement environment returnType scope statement + (remainingProblems, finalEnvironment) = verifyStatements nextEnvironment returnType scope remaining + in (currentProblems ++ remainingProblems, finalEnvironment) + +verifyStatement :: Environment -> Type -> TransferScope -> CoreStatement -> ([Diagnostic], Environment) +verifyStatement environment returnType scope statement = case statement of + CoreBind binding -> + let name = coreBindingName binding + symbol = resolvedSymbol name + declaredType = coreBindingType binding + expressionProblems = verifyExpression environment (coreBindingValue binding) + bindingProblems = + invalidSymbol "TAC1008" "Core binding symbol must be positive" name + ++ unresolvedType "TAC1009" "Core binding has an unresolved type" declaredType + ++ [problem "TAC1010" "Core binding symbol is already defined" | Map.member symbol environment] + ++ typeMismatch + "TAC1011" + "Core binding value type does not match its declaration" + declaredType + (expressionType (coreBindingValue binding)) + next = Map.insert symbol (declaredType, coreBindingMutable binding) environment + in (bindingProblems ++ expressionProblems, next) + CoreAssign name value -> + let symbol = resolvedSymbol name + target = Map.lookup symbol environment + targetProblems = case target of + Nothing -> [problem "TAC1012" "Core assignment targets an undefined symbol"] + Just (_, False) -> [problem "TAC1013" "Core assignment targets an immutable symbol"] + Just (targetType, True) -> + typeMismatch + "TAC1014" + "Core assignment value has the wrong type" + targetType + (expressionType value) + in ( invalidSymbol "TAC1015" "Core assignment symbol must be positive" name + ++ verifyExpression environment value + ++ targetProblems + , environment + ) + CoreReturn value -> + ( verifyExpression environment value + ++ typeMismatch "TAC1016" "Core return value has the wrong type" returnType (expressionType value) + , environment + ) + CoreIf condition trueBranch falseBranch -> + let conditionProblems = + verifyExpression environment condition + ++ [ problem "TAC1017" "Core condition must be bool or numeric" + | expressionType condition /= boolType && not (isCoreNumericType (expressionType condition)) + ] + (trueProblems, _) = verifyStatements environment returnType scope trueBranch + (falseProblems, _) = verifyStatements environment returnType scope falseBranch + in (conditionProblems ++ trueProblems ++ falseProblems, environment) + CoreEvaluate value -> (verifyExpression environment value, environment) + CoreWhile condition body -> + let conditionProblems = verifyLoopCondition environment "while" condition + (bodyProblems, _) = verifyStatements environment returnType InLoopBody body + in (conditionProblems ++ bodyProblems, environment) + CoreDoWhile body condition -> + let (bodyProblems, _) = verifyStatements environment returnType InLoopBody body + conditionProblems = verifyLoopCondition environment "do/while" condition + in (bodyProblems ++ conditionProblems, environment) + CoreFor condition body update -> + let conditionProblems = verifyLoopCondition environment "for" condition + (bodyProblems, _) = verifyStatements environment returnType InLoopBody body + (updateProblems, _) = verifyStatements environment returnType InForUpdate update + in (conditionProblems ++ bodyProblems ++ updateProblems, environment) + CoreBreak -> + ( [problem "TAC1045" "Core break is not nested in a loop" | scope == OutsideLoop] + , environment + ) + CoreContinue -> + ( [problem "TAC1046" "Core continue is not nested in a loop" | scope == OutsideLoop] + ++ [problem "TAC1066" "Core continue appears in a for update region" | scope == InForUpdate] + , environment + ) + +verifyLoopCondition :: Environment -> String -> CoreExpression -> [Diagnostic] +verifyLoopCondition environment kind condition = + verifyExpression environment condition + ++ [ problem "TAC1047" ("Core " ++ kind ++ " condition must be bool or numeric") + | expressionType condition /= boolType && not (isCoreNumericType (expressionType condition)) + ] + +verifyExpression :: Environment -> CoreExpression -> [Diagnostic] +verifyExpression environment expression = + unresolvedType "TAC1018" "Core expression has an unresolved type" (expressionType expression) + ++ case expression of + CoreVariable name valueType -> + invalidSymbol "TAC1019" "Core variable symbol must be positive" name + ++ case Map.lookup (resolvedSymbol name) environment of + Nothing -> [problem "TAC1020" "Core expression references an undefined symbol"] + Just (declaredType, _) -> + typeMismatch + "TAC1021" + "Core variable type disagrees with its definition" + declaredType + valueType + CoreLiteral literal valueType -> literalProblems literal valueType + CoreApply callee arguments valueType -> + verifyExpression environment callee + ++ concatMap (verifyExpression environment) arguments + ++ callProblems callee arguments valueType + CorePrimitive primitive arguments valueType -> + concatMap (verifyExpression environment) arguments ++ primitiveProblems primitive arguments valueType + CoreLet name bindingType value body valueType -> + invalidSymbol "TAC1040" "Core let symbol must be positive" name + ++ unresolvedType "TAC1041" "Core let binding has an unresolved type" bindingType + ++ verifyExpression environment value + ++ typeMismatch "TAC1042" "Core let value has the wrong type" bindingType (expressionType value) + ++ verifyExpression (Map.insert (resolvedSymbol name) (bindingType, False) environment) body + ++ typeMismatch "TAC1043" "Core let result type disagrees with its body" valueType (expressionType body) + CoreConditional condition whenTrue whenFalse valueType -> + verifyExpression environment condition + ++ [ problem "TAC1067" "Core conditional test must be bool or numeric" + | expressionType condition /= boolType && not (isCoreNumericType (expressionType condition)) + ] + ++ verifyExpression environment whenTrue + ++ verifyExpression environment whenFalse + ++ typeMismatch + "TAC1068" + "Core conditional result type disagrees with its first arm" + valueType + (expressionType whenTrue) + ++ typeMismatch + "TAC1069" + "Core conditional result type disagrees with its second arm" + valueType + (expressionType whenFalse) + -- The result is materialized in a plain storage slot. Owned + -- values would need move and release rules for that slot. + ++ [ problem "TAC1070" "Core conditional result must be bool or numeric" + | valueType /= boolType && not (isCoreNumericType valueType) + ] + CoreClosure captures parameters returnType body valueType -> + verifyClosure environment captures parameters returnType body valueType + +verifyClosure :: + Environment -> [CoreCapture] -> [(ResolvedName, Type)] -> Type -> [CoreStatement] -> Type -> [Diagnostic] +verifyClosure environment captures parameters returnType body valueType = + duplicates "TAC1030" "duplicate Core closure capture symbol" (map (resolvedSymbol . coreCaptureName) captures) + ++ duplicates "TAC1031" "duplicate Core closure parameter symbol" (map (resolvedSymbol . fst) parameters) + ++ concatMap verifyCapture captures + ++ concatMap (uncurry verifyParameter) parameters + ++ callableTypeProblems + ++ fst (verifyStatements closureEnvironment returnType OutsideLoop body) + ++ [ problem "TAC1032" "non-void Core closure may complete without returning" + | returnType /= unitType && not (statementsAlwaysReturn body) + ] + where + captureEnvironment = + Map.fromList + [(resolvedSymbol (coreCaptureName capture), (coreCaptureType capture, True)) | capture <- captures] + parameterEnvironment = + Map.fromList + [(resolvedSymbol name, (parameterType, False)) | (name, parameterType) <- parameters] + closureEnvironment = Map.unions [parameterEnvironment, captureEnvironment, environment] + callableTypeProblems = case valueType of + FunctionType parameterTypes result -> + concat + ( zipWith + (typeMismatch "TAC1033" "closure parameter type disagrees with callable type") + parameterTypes + (map snd parameters) + ) + ++ [problem "TAC1034" "closure callable type has the wrong arity" | length parameterTypes /= length parameters] + ++ typeMismatch "TAC1035" "closure return type disagrees with callable type" result returnType + _ -> [problem "TAC1036" "Core closure expression must have a callable type"] + verifyCapture capture = + invalidSymbol "TAC1037" "Core capture symbol must be positive" (coreCaptureName capture) + ++ unresolvedType "TAC1038" "Core capture has an unresolved type" (coreCaptureType capture) + ++ verifyExpression environment (coreCaptureValue capture) + ++ typeMismatch + "TAC1039" + "Core capture value has the wrong type" + (coreCaptureType capture) + (expressionType (coreCaptureValue capture)) + +callProblems :: CoreExpression -> [CoreExpression] -> Type -> [Diagnostic] +callProblems callee arguments resultType = case expressionType callee of + FunctionType parameterTypes declaredResult -> + [problem "TAC1022" "Core call has the wrong argument count" | length parameterTypes /= length arguments] + ++ concat + (zipWith (typeMismatch "TAC1023" "Core call argument has the wrong type") parameterTypes (map expressionType arguments)) + ++ typeMismatch "TAC1024" "Core call result type disagrees with the callee" declaredResult resultType + _ -> [problem "TAC1025" "Core call target is not a function"] + +primitiveProblems :: CorePrimitive -> [CoreExpression] -> Type -> [Diagnostic] +primitiveProblems CoreRuntimeCall arguments resultType = + -- The first operand names the function and the rest are checked against + -- the row of the catalog that function has. + case runtimeCallDefect named (map expressionType (drop 1 arguments)) resultType of + Just defect -> [problem "TAC1075" ("Core " ++ runtimeDefectText defect)] + Nothing -> [] + where + named = case arguments of + CoreLiteral (CoreInteger identity) valueType : _ | valueType == intType -> runtimeFunctionOf identity + _ -> Nothing +primitiveProblems primitive arguments resultType = + [problem "TAC1026" "Core primitive has the wrong operand count" | length arguments /= arity] + ++ operandProblems + ++ typeMismatch "TAC1028" "Core primitive result has the wrong type" expectedResult resultType + where + unary = primitive `elem` [CoreNegate, CoreLogicalNot, CoreBitwiseNot, CoreMemoize] + logical = primitive `elem` [CoreLogicalAnd, CoreLogicalOr, CoreLogicalNot] + integerOnly = primitive `elem` [CoreShiftLeft, CoreShiftRight, CoreBitwiseAnd, CoreBitwiseXor, CoreBitwiseOr, CoreBitwiseNot] + comparison = primitive `elem` [CoreLessThan, CoreLessEqual, CoreGreaterThan, CoreGreaterEqual, CoreEqual, CoreNotEqual] + arity = if unary then 1 else 2 + argumentTypes = map expressionType arguments + firstType = case argumentTypes of first : _ -> first; [] -> ErrorType + operandsAgree = all (== firstType) argumentTypes + operandsNumeric = all isCoreNumericType argumentTypes + operandsInteger = all isCoreIntegerType argumentTypes + operandsBoolean = all (\valueType -> valueType == boolType || isCoreNumericType valueType) argumentTypes + operandProblems + | primitive == CoreTypeIs = case argumentTypes of + [subjectType, identityType] + | isReferenceLike subjectType && identityType == namedType "uint" -> [] + | otherwise -> [problem "TAC1044" "Core type test requires a reference subject and uint identity"] + _ -> [] + -- A remembered result lives in the callable itself, in a slot + -- that owns nothing: only a result without ownership is kept. + | primitive == CoreMemoize = case argumentTypes of + [FunctionType [] result] + | result == boolType || isCoreNumericType result -> [] + | otherwise -> [memoizeProblem] + [_] -> [memoizeProblem] + _ -> [] + | logical && not operandsBoolean = [problem "TAC1027" "Core logical primitive requires bool or numeric operands"] + | integerOnly && not operandsInteger = [problem "TAC1027" "Core bitwise primitive requires integer operands"] + | primitive `elem` [CoreEqual, CoreNotEqual] + , operandsAgree + , firstType == boolType || isReferenceLike firstType = + [] + | not logical && not operandsNumeric = [problem "TAC1027" "Core numeric primitive requires numeric operands"] + | not logical && not operandsAgree = [problem "TAC1027" "Core numeric primitive operands must have the same type"] + | otherwise = [] + expectedResult + | logical || comparison || primitive == CoreTypeIs = boolType + | primitive == CoreFloorDivide && isCoreFloatingType firstType = intType + | otherwise = firstType + memoizeProblem = + problem "TAC1073" "Core memoization requires a callable without parameters whose result is bool or numeric" + isReferenceLike valueType = case valueType of + FunctionType _ _ -> True + NamedType _ _ -> not (isCoreNumericType valueType) && valueType /= unitType + _ -> False + +literalProblems :: CoreLiteral -> Type -> [Diagnostic] +literalProblems literal valueType = + [problem "TAC1029" "Core literal payload does not match its type or scalar range" | not matches] + where + matches = case literal of + CoreInteger value -> integerFitsCoreType valueType value + CoreFloating spelling -> isCoreFloatingType valueType && validCoreFloatingSpelling spelling + CoreString _ -> valueType == stringType + CoreBoolean _ -> valueType == boolType + CoreUnit -> valueType == unitType + CoreNull -> isReferenceLike valueType + isReferenceLike value = case value of + FunctionType _ _ -> True + NamedType _ _ -> not (isCoreNumericType value) && value /= unitType + _ -> False + +{- | Whether control can never fall off the end of the statements. + +That is so when they return on every path, and also when they hold a loop +that cannot be left: its condition is the literal true and no @break@ +leaves it. Such a loop ends only through a @return@ inside it, or not at +all, so nothing after it is reached. +-} +statementsAlwaysReturn :: [CoreStatement] -> Bool +statementsAlwaysReturn [] = False +statementsAlwaysReturn (statement : remaining) = case statement of + CoreReturn _ -> True + CoreIf _ trueBranch falseBranch -> + (not (null falseBranch) && statementsAlwaysReturn trueBranch && statementsAlwaysReturn falseBranch) + || statementsAlwaysReturn remaining + CoreWhile condition body + | cannotBeLeft condition body -> True + CoreDoWhile body condition + | cannotBeLeft condition body -> True + CoreFor condition body update + | cannotBeLeft condition (body ++ update) -> True + _ -> statementsAlwaysReturn remaining + where + cannotBeLeft condition body = isLiteralTrue condition && not (leftByBreak body) + isLiteralTrue expression = case expression of + CoreLiteral (CoreBoolean True) _ -> True + _ -> False + -- A break in a nested loop leaves that loop. + leftByBreak = any breaks + breaks nested = case nested of + CoreBreak -> True + CoreIf _ trueBranch falseBranch -> leftByBreak trueBranch || leftByBreak falseBranch + _ -> False + +emptyName :: QualifiedName -> [Diagnostic] +emptyName (QualifiedName parts) = + [ problem "TAC1001" "Core module name must contain at least one non-empty part" + | null parts || any (null . identifierText) parts + ] + +invalidSymbol :: String -> String -> ResolvedName -> [Diagnostic] +invalidSymbol code message name = [problem code message | symbolIdValue (resolvedSymbol name) <= 0] + +unresolvedType :: String -> String -> Type -> [Diagnostic] +unresolvedType code message valueType = + [problem code message | containsError valueType] + ++ map templateProblem (validateTemplateType 128 valueType) + +-- Template validation belongs at the Core boundary rather than only in the +-- artifact writer. Keeping malformed specialization keys out of verified Core +-- ensures optimization caches and every later stage observe the same type +-- identity, even when no artifact is emitted for the compilation. +templateProblem :: TemplateIssue -> Diagnostic +templateProblem issue = + problem + "TAC1040" + ( "invalid Core template type at " + ++ renderTemplatePath (templateIssuePath issue) + ++ ": " + ++ templateIssueMessage issue + ) + +renderTemplatePath :: [Int] -> String +renderTemplatePath [] = "the type root" +renderTemplatePath indexes = "argument " ++ concatMap renderIndex indexes + where + renderIndex index = "[" ++ show index ++ "]" + +containsError :: Type -> Bool +containsError valueType = case valueType of + ErrorType -> True + NamedType _ arguments -> any templateArgumentContainsError arguments + FunctionType parameters result -> any containsError parameters || containsError result + TypeVariable _ -> False + +templateArgumentContainsError :: TemplateArgument -> Bool +templateArgumentContainsError argument = case argument of + TypeTemplateArgument nested -> containsError nested + ValueTemplateArgument _ -> False + +typeMismatch :: String -> String -> Type -> Type -> [Diagnostic] +typeMismatch code message expected actual = [problem code message | expected /= actual] + +duplicates :: (Ord a) => String -> String -> [a] -> [Diagnostic] +duplicates code message values = [problem code message | groupValue <- group (sort values), length groupValue > 1] + +problem :: String -> String -> Diagnostic +problem code message = Diagnostic CoreStage Error code Nothing message
+ src/Progmasoft/Tala/Core/Wire.hs view
@@ -0,0 +1,912 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Versioned, bounded binary codec for the compiler's private Core IR. + +Core artifacts are an internal stage boundary rather than a user-facing +emission format. Decoding applies explicit resource limits before exposing a +module to verification or native compilation. +-} +module Progmasoft.Tala.Core.Wire + ( encodeCore + , decodeCore + , CoreWireVersion (..) + , currentCoreWireVersion + , CoreWireLimits (..) + , defaultCoreWireLimits + , CoreWireErrorKind (..) + , CoreWireError (..) + ) where + +import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.)) +import Data.Char (chr, ord) +import Data.Int (Int64) +import Data.List (unfoldr) +import Data.Map.Strict qualified as Map +import Data.Word (Word16, Word32, Word64, Word8) +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core + +-- | Unsigned schema version stored in a Core wire document header. +newtype CoreWireVersion = CoreWireVersion {coreWireVersionNumber :: Word16} + deriving (Eq, Ord, Read, Show) + +-- | Schema version emitted by the current Core writer. +currentCoreWireVersion :: CoreWireVersion +currentCoreWireVersion = CoreWireVersion 10 + +-- | Finite bounds for total bytes, recursion, and individual collections. +data CoreWireLimits = CoreWireLimits + { maximumCoreWireBytes :: Int + , maximumCoreTextScalars :: Int + , maximumCoreFunctions :: Int + , maximumCoreParameters :: Int + , maximumCoreStatements :: Int + , maximumCoreOperands :: Int + , maximumCoreTypeDepth :: Int + , maximumCoreExpressionDepth :: Int + , maximumCoreNumericBytes :: Int + } + deriving (Eq, Ord, Read, Show) + +-- | Default resource bounds shared by normal Core readers and writers. +defaultCoreWireLimits :: CoreWireLimits +defaultCoreWireLimits = + CoreWireLimits + { maximumCoreWireBytes = 64 * 1024 * 1024 + , maximumCoreTextScalars = 1024 * 1024 + , maximumCoreFunctions = 65535 + , maximumCoreParameters = 65535 + , maximumCoreStatements = 1048576 + , maximumCoreOperands = 65535 + , maximumCoreTypeDepth = 128 + , maximumCoreExpressionDepth = 4096 + , maximumCoreNumericBytes = 4096 + } + +-- | Category of malformed input, unsupported schema data, or exceeded limit. +data CoreWireErrorKind + = CoreInvalidMagic + | CoreUnsupportedVersion + | CoreTruncatedInput + | CoreTrailingInput + | CoreInvalidTag + | CoreInvalidBoolean + | CoreInvalidScalar + | CoreInvalidCount + | CoreInvalidSymbol + | CoreInvalidInteger + | CoreUnsupportedType + | CoreLimitExceeded + deriving (Eq, Ord, Read, Show) + +-- | Structured wire error with byte offset and nested field context. +data CoreWireError = CoreWireError + { coreWireErrorKind :: CoreWireErrorKind + , coreWireErrorOffset :: Int + , coreWireErrorContext :: String + , coreWireErrorMessage :: String + } + deriving (Eq, Ord, Read, Show) + +{- | Bytes under construction. + +An encoded module is assembled from the encodings of its parts, and a part +may hold nearly all of the module: the body of a deeply nested statement, or +the rest of an @else if@ chain. Appending lists would copy such a part once +for every level around it, which makes encoding quadratic in the nesting +depth. A function that prepends its bytes to whatever follows is composed in +constant time, and the list is produced once, at the end. +-} +newtype Bytes = Bytes ([Word8] -> [Word8]) + +instance Semigroup Bytes where + Bytes first <> Bytes second = Bytes (first . second) + +instance Monoid Bytes where + mempty = Bytes id + +tagByte :: Word8 -> Bytes +tagByte value = Bytes (value :) + +rawBytes :: [Word8] -> Bytes +rawBytes values = Bytes (values ++) + +runBytes :: Bytes -> [Word8] +runBytes (Bytes prepend) = prepend [] + +type Encoder = Either CoreWireError Bytes + +-- | Encode one Core module under explicit resource limits. +encodeCore :: CoreWireLimits -> CoreModule -> Either CoreWireError [Word8] +encodeCore limits moduleValue = do + payload <- encodeModule limits moduleValue + let output = + runBytes + (rawBytes magic <> rawBytes (word16 (coreWireVersionNumber currentCoreWireVersion)) <> rawBytes (word16 0) <> payload) + requireEncode limits "wire byte length" (maximumCoreWireBytes limits) (length output) + pure output + +encodeModule :: CoreWireLimits -> CoreModule -> Encoder +encodeModule limits moduleValue = do + name <- encodeQualifiedName limits (coreModuleName moduleValue) + sources <- + encodeVector + limits + "source file count" + (maximumCoreFunctions limits) + (encodeText limits "source file") + (coreModuleSourceFiles moduleValue) + let owners = Map.fromList (coreModuleFunctionSources moduleValue) + functions <- + encodeVector + limits + "function count" + (maximumCoreFunctions limits) + (encodeFunction limits owners) + (coreModuleFunctions moduleValue) + pure (name <> sources <> functions) + +encodeFunction :: CoreWireLimits -> Map.Map Int FilePath -> CoreFunction -> Encoder +encodeFunction limits owners function = do + name <- encodeResolvedName limits "function symbol" (coreFunctionName function) + source <- + encodeText + limits + "function source file" + (Map.findWithDefault "" (symbolIdValue (resolvedSymbol (coreFunctionName function))) owners) + parameters <- + encodeVector + limits + "parameter count" + (maximumCoreParameters limits) + (encodeParameter limits) + (coreFunctionParameters function) + result <- encodeType limits 0 (coreFunctionReturnType function) + body <- + encodeVector + limits + "statement count" + (maximumCoreStatements limits) + (encodeStatement limits) + (coreFunctionBody function) + pure (name <> source <> parameters <> result <> body) + +encodeParameter :: CoreWireLimits -> (ResolvedName, Type) -> Encoder +encodeParameter limits (name, valueType) = + (<>) + <$> encodeResolvedName limits "parameter symbol" name + <*> encodeType limits 0 valueType + +encodeStatement :: CoreWireLimits -> CoreStatement -> Encoder +encodeStatement limits statement = case statement of + CoreBind binding -> do + name <- encodeResolvedName limits "binding symbol" (coreBindingName binding) + valueType <- encodeType limits 0 (coreBindingType binding) + value <- encodeExpression limits 0 (coreBindingValue binding) + pure (tagByte 0 <> name <> valueType <> rawBytes (encodeBool (coreBindingMutable binding)) <> value) + CoreAssign name expression -> + taggedExpression 1 + <$> encodeResolvedName limits "assignment symbol" name + <*> encodeExpression limits 0 expression + CoreReturn expression -> (tagByte 2 <>) <$> encodeExpression limits 0 expression + CoreIf condition trueBranch falseBranch -> do + encodedCondition <- encodeExpression limits 0 condition + encodedTrue <- + encodeVector + limits + "true branch statement count" + (maximumCoreStatements limits) + (encodeStatement limits) + trueBranch + encodedFalse <- + encodeVector + limits + "false branch statement count" + (maximumCoreStatements limits) + (encodeStatement limits) + falseBranch + pure (tagByte 3 <> encodedCondition <> encodedTrue <> encodedFalse) + CoreEvaluate expression -> (tagByte 4 <>) <$> encodeExpression limits 0 expression + CoreWhile condition body -> do + encodedCondition <- encodeExpression limits 0 condition + encodedBody <- + encodeVector + limits + "while body statement count" + (maximumCoreStatements limits) + (encodeStatement limits) + body + pure (tagByte 5 <> encodedCondition <> encodedBody) + CoreDoWhile body condition -> do + encodedBody <- + encodeVector + limits + "do/while body statement count" + (maximumCoreStatements limits) + (encodeStatement limits) + body + encodedCondition <- encodeExpression limits 0 condition + pure (tagByte 6 <> encodedBody <> encodedCondition) + CoreFor condition body update -> do + encodedCondition <- encodeExpression limits 0 condition + encodedBody <- + encodeVector + limits + "for body statement count" + (maximumCoreStatements limits) + (encodeStatement limits) + body + encodedUpdate <- + encodeVector + limits + "for update statement count" + (maximumCoreStatements limits) + (encodeStatement limits) + update + pure (tagByte 7 <> encodedCondition <> encodedBody <> encodedUpdate) + CoreBreak -> pure (tagByte 8) + CoreContinue -> pure (tagByte 9) + where + taggedExpression tag left right = tagByte tag <> left <> right + +encodeExpression :: CoreWireLimits -> Int -> CoreExpression -> Encoder +encodeExpression limits depth expression + | depth > maximumCoreExpressionDepth limits = failure CoreLimitExceeded "expression" "expression nesting exceeds limit" + | otherwise = case expression of + CoreVariable name valueType -> do + encodedType <- encodeType limits 0 valueType + encodedName <- encodeResolvedName limits "variable symbol" name + pure (tagByte 0 <> encodedType <> encodedName) + CoreLiteral literal valueType -> do + encodedType <- encodeType limits 0 valueType + encodedLiteral <- encodeLiteral limits literal + pure (tagByte 1 <> encodedType <> encodedLiteral) + CoreApply callee arguments valueType -> do + encodedType <- encodeType limits 0 valueType + encodedCallee <- encodeExpression limits (depth + 1) callee + encodedArguments <- + encodeVector + limits + "call argument count" + (maximumCoreOperands limits) + (encodeExpression limits (depth + 1)) + arguments + pure (tagByte 2 <> encodedType <> encodedCallee <> encodedArguments) + -- The first operand of a primitive is at the depth of the + -- primitive: a chain of operators nests in it, as deep as the chain + -- is long, and every stage walks that chain in a loop. + CorePrimitive primitive arguments valueType -> do + encodedType <- encodeType limits 0 valueType + encodedArguments <- + encodeVector + limits + "primitive operand count" + (maximumCoreOperands limits) + (\(position, argument) -> encodeExpression limits (depth + position) argument) + (zip (0 : repeat 1) arguments) + pure (rawBytes [3, primitiveTag primitive] <> encodedType <> encodedArguments) + CoreClosure captures parameters returnType body valueType -> do + encodedType <- encodeType limits 0 valueType + encodedCaptures <- + encodeVector + limits + "closure capture count" + (maximumCoreOperands limits) + (encodeCoreCapture limits depth) + captures + encodedParameters <- + encodeVector + limits + "closure parameter count" + (maximumCoreParameters limits) + (encodeParameter limits) + parameters + encodedReturn <- encodeType limits 0 returnType + encodedBody <- + encodeVector + limits + "closure statement count" + (maximumCoreStatements limits) + (encodeStatement limits) + body + pure (tagByte 4 <> encodedType <> encodedCaptures <> encodedParameters <> encodedReturn <> encodedBody) + CoreLet name bindingType value body valueType -> do + encodedType <- encodeType limits 0 valueType + encodedName <- encodeResolvedName limits "let symbol" name + encodedBindingType <- encodeType limits 0 bindingType + encodedValue <- encodeExpression limits (depth + 1) value + encodedBody <- encodeExpression limits (depth + 1) body + pure (tagByte 5 <> encodedType <> encodedName <> encodedBindingType <> encodedValue <> encodedBody) + CoreConditional condition whenTrue whenFalse valueType -> do + encodedType <- encodeType limits 0 valueType + encodedCondition <- encodeExpression limits (depth + 1) condition + encodedTrue <- encodeExpression limits (depth + 1) whenTrue + encodedFalse <- encodeExpression limits (depth + 1) whenFalse + pure (tagByte 6 <> encodedType <> encodedCondition <> encodedTrue <> encodedFalse) + +encodeCoreCapture :: CoreWireLimits -> Int -> CoreCapture -> Encoder +encodeCoreCapture limits depth capture = do + encodedName <- encodeResolvedName limits "closure capture symbol" (coreCaptureName capture) + encodedType <- encodeType limits 0 (coreCaptureType capture) + encodedValue <- encodeExpression limits (depth + 1) (coreCaptureValue capture) + pure (tagByte (captureModeTag (coreCaptureMode capture)) <> encodedName <> encodedType <> encodedValue) + +captureModeTag :: CaptureMode -> Word8 +captureModeTag mode = case mode of + StrongCapture -> 0 + WeakCapture -> 1 + UnownedCapture -> 2 + +encodeLiteral :: CoreWireLimits -> CoreLiteral -> Encoder +encodeLiteral limits literal = case literal of + CoreUnit -> pure (tagByte 0) + CoreBoolean value -> pure (tagByte 1 <> rawBytes (encodeBool value)) + CoreInteger value -> (tagByte 4 <>) <$> encodeInteger limits value + CoreFloating spelling -> (tagByte 5 <>) <$> encodeAscii limits "floating literal" spelling + CoreString value -> (tagByte 3 <>) <$> encodeText limits "string literal" value + CoreNull -> pure (tagByte 6) + +encodeType :: CoreWireLimits -> Int -> Type -> Encoder +encodeType limits depth valueType + | depth > maximumCoreTypeDepth limits = failure CoreLimitExceeded "type" "type nesting exceeds limit" + | valueType == unitType = pure (tagByte 0) + | valueType == boolType = pure (tagByte 1) + | valueType == intType = pure (tagByte 2) + | valueType == stringType = pure (tagByte 3) + | Just scalarTag <- scalarTypeTag valueType = pure (tagByte scalarTag) + | NamedType name arguments <- valueType = do + encodedName <- encodeQualifiedName limits name + encodedArguments <- + encodeVector + limits + "type argument count" + (maximumCoreOperands limits) + (encodeTemplateArgument limits (depth + 1)) + arguments + pure (tagByte 4 <> encodedName <> encodedArguments) + | FunctionType parameters result <- valueType = do + encodedParameters <- + encodeVector + limits + "function type parameter count" + (maximumCoreParameters limits) + (encodeType limits (depth + 1)) + parameters + encodedResult <- encodeType limits (depth + 1) result + pure (tagByte 5 <> encodedParameters <> encodedResult) + | TypeVariable name <- valueType = (tagByte 6 <>) <$> encodeResolvedName limits "type variable symbol" name + | ErrorType <- valueType = failure CoreUnsupportedType "type" "ErrorType cannot cross the Core boundary" + +encodeTemplateArgument :: CoreWireLimits -> Int -> TemplateArgument -> Encoder +encodeTemplateArgument limits depth argument = case argument of + TypeTemplateArgument valueType -> (tagByte 0 <>) <$> encodeType limits depth valueType + ValueTemplateArgument value -> encodeTemplateValue limits value + +encodeTemplateValue :: CoreWireLimits -> TemplateValue -> Encoder +encodeTemplateValue limits value = case value of + IntegerTemplateValue integer -> (tagByte 1 <>) <$> encodeInteger limits integer + BooleanTemplateValue boolean -> pure (rawBytes [2, if boolean then 1 else 0]) + CharacterTemplateValue scalar -> (tagByte 3 <>) <$> encodeInteger limits scalar + TemplateValueParameter name -> (tagByte 4 <>) <$> encodeResolvedName limits "template value parameter" name + +encodeResolvedName :: CoreWireLimits -> String -> ResolvedName -> Encoder +encodeResolvedName limits context name + | symbolIdValue (resolvedSymbol name) <= 0 = failure CoreInvalidSymbol context "symbol id must be positive" + | otherwise = do + spelling <- encodeText limits (context ++ " spelling") (identifierText (resolvedSpelling name)) + pure (rawBytes (word64 (fromIntegral (symbolIdValue (resolvedSymbol name)))) <> spelling) + +encodeQualifiedName :: CoreWireLimits -> QualifiedName -> Encoder +encodeQualifiedName limits (QualifiedName parts) = + encodeVector + limits + "qualified name parts" + 65535 + (encodeText limits "qualified name part" . identifierText) + parts + +encodeVector :: CoreWireLimits -> String -> Int -> (a -> Encoder) -> [a] -> Encoder +encodeVector limits context maximumValue encode values = do + requireEncode limits context maximumValue (length values) + encoded <- traverse encode values + pure (rawBytes (word32 (fromIntegral (length values))) <> mconcat encoded) + +encodeText :: CoreWireLimits -> String -> String -> Encoder +encodeText limits context value = do + requireEncode limits context (maximumCoreTextScalars limits) (length value) + codePoints <- traverse encodeScalar value + pure (rawBytes (word32 (fromIntegral (length value))) <> mconcat codePoints) + where + encodeScalar character + | code >= 0xd800 && code <= 0xdfff = failure CoreInvalidScalar context "surrogate is not a Unicode scalar" + | code > 0x10ffff = failure CoreInvalidScalar context "code point exceeds Unicode range" + | otherwise = pure (rawBytes (word32 (fromIntegral code))) + where + code = ord character + +scalarTypeTag :: Type -> Maybe Word8 +scalarTypeTag (NamedType (QualifiedName [Identifier name]) []) = lookup name tags + where + tags = + [ ("char", 7) + , ("byte", 8) + , ("short", 9) + , ("long", 10) + , ("longint", 11) + , ("ubyte", 12) + , ("ushort", 13) + , ("ulong", 14) + , ("uint", 15) + , ("ulongint", 16) + , ("sfloat", 17) + , ("lfloat", 18) + , ("float", 19) + , ("double", 20) + ] +scalarTypeTag _ = Nothing + +encodeInteger :: CoreWireLimits -> Integer -> Encoder +encodeInteger limits value = do + let magnitude = integerMagnitude (abs value) + requireEncode limits "integer magnitude" (maximumCoreNumericBytes limits) (length magnitude) + pure (rawBytes (encodeBool (value < 0)) <> rawBytes (word32 (fromIntegral (length magnitude))) <> rawBytes magnitude) + +integerMagnitude :: Integer -> [Word8] +integerMagnitude 0 = [] +integerMagnitude value = reverse (unfoldr step value) + where + step 0 = Nothing + step remaining = Just (fromIntegral (remaining `mod` 256), remaining `div` 256) + +encodeAscii :: CoreWireLimits -> String -> String -> Encoder +encodeAscii limits context value = do + requireEncode limits context (maximumCoreNumericBytes limits) (length value) + characters <- traverse ascii value + pure (rawBytes (word32 (fromIntegral (length characters))) <> rawBytes characters) + where + ascii character + | ord character <= 0x7f = Right (fromIntegral (ord character)) + | otherwise = failure CoreInvalidInteger context "numeric spelling must contain ASCII characters only" + +requireEncode :: CoreWireLimits -> String -> Int -> Int -> Either CoreWireError () +requireEncode _ context maximumValue actual + | actual > maximumValue = failure CoreLimitExceeded context ("count exceeds configured limit: " ++ show actual) + | otherwise = Right () + +data DecoderState = DecoderState [Word8] Int CoreWireLimits +newtype Decoder a = Decoder {runDecoder :: DecoderState -> Either CoreWireError (a, DecoderState)} + +instance Functor Decoder where + fmap transform parser = Decoder $ \state -> do + (value, next) <- runDecoder parser state + pure (transform value, next) +instance Applicative Decoder where + pure value = Decoder $ \state -> Right (value, state) + functionParser <*> valueParser = Decoder $ \state -> do + (function, afterFunction) <- runDecoder functionParser state + (value, afterValue) <- runDecoder valueParser afterFunction + pure (function value, afterValue) +instance Monad Decoder where + parser >>= nextParser = Decoder $ \state -> do + (value, afterValue) <- runDecoder parser state + runDecoder (nextParser value) afterValue + +-- | Decode and validate one Core document under explicit resource limits. +decodeCore :: CoreWireLimits -> [Word8] -> Either CoreWireError CoreModule +decodeCore limits bytes + | length bytes > maximumCoreWireBytes limits = + failure CoreLimitExceeded "wire byte length" "input exceeds configured limit" + | otherwise = do + (moduleValue, DecoderState remaining offset _) <- runDecoder decodeDocument (DecoderState bytes 0 limits) + if null remaining + then Right moduleValue + else Left (CoreWireError CoreTrailingInput offset "document" "bytes remain after Core module") + +decodeDocument :: Decoder CoreModule +decodeDocument = do + header <- takeBytes "magic" 4 + requireDecode (header == magic) CoreInvalidMagic "magic" "input is not a Tala Core document" + version <- readWord16 "version" + requireDecode + (version == coreWireVersionNumber currentCoreWireVersion) + CoreUnsupportedVersion + "version" + "unsupported Core wire version" + flags <- readWord16 "flags" + requireDecode (flags == 0) CoreInvalidTag "flags" "reserved flags must be zero" + name <- decodeQualifiedName + sources <- decodeVector "source file count" maximumCoreFunctions (decodeText "source file") + functionsWithSources <- decodeVector "function count" maximumCoreFunctions decodeFunction + let functions = map fst functionsWithSources + owners = + [ (symbolIdValue (resolvedSymbol (coreFunctionName function)), source) + | (function, source) <- functionsWithSources + , not (null source) + ] + pure (CoreModuleWithSources name functions sources owners) + +decodeFunction :: Decoder (CoreFunction, FilePath) +decodeFunction = do + name <- decodeResolvedName "function symbol" + source <- decodeText "function source file" + parameters <- decodeVector "parameter count" maximumCoreParameters decodeParameter + result <- decodeType 0 + body <- decodeVector "statement count" maximumCoreStatements decodeStatement + pure (CoreFunction name parameters result body, source) + +decodeParameter :: Decoder (ResolvedName, Type) +decodeParameter = (,) <$> decodeResolvedName "parameter symbol" <*> decodeType 0 + +decodeStatement :: Decoder CoreStatement +decodeStatement = do + tag <- readWord8 "statement tag" + case tag of + 0 -> + CoreBind + <$> ( CoreBinding + <$> decodeResolvedName "binding symbol" + <*> decodeType 0 + <*> decodeBool "binding mutability" + <*> decodeExpression 0 + ) + 1 -> CoreAssign <$> decodeResolvedName "assignment symbol" <*> decodeExpression 0 + 2 -> CoreReturn <$> decodeExpression 0 + 3 -> + CoreIf + <$> decodeExpression 0 + <*> decodeVector "true branch statement count" maximumCoreStatements decodeStatement + <*> decodeVector "false branch statement count" maximumCoreStatements decodeStatement + 4 -> CoreEvaluate <$> decodeExpression 0 + 5 -> CoreWhile <$> decodeExpression 0 <*> decodeVector "while body statement count" maximumCoreStatements decodeStatement + 6 -> + CoreDoWhile + <$> decodeVector "do/while body statement count" maximumCoreStatements decodeStatement + <*> decodeExpression 0 + 7 -> + CoreFor + <$> decodeExpression 0 + <*> decodeVector "for body statement count" maximumCoreStatements decodeStatement + <*> decodeVector "for update statement count" maximumCoreStatements decodeStatement + 8 -> pure CoreBreak + 9 -> pure CoreContinue + _ -> invalidTag "statement tag" tag + +decodeExpression :: Int -> Decoder CoreExpression +decodeExpression depth = do + limits <- currentLimits + requireDecode + (depth <= maximumCoreExpressionDepth limits) + CoreLimitExceeded + "expression" + "expression nesting exceeds limit" + tag <- readWord8 "expression tag" + case tag of + 0 -> flip CoreVariable <$> decodeType 0 <*> decodeResolvedName "variable symbol" + 1 -> do valueType <- decodeType 0; literal <- decodeLiteral; pure (CoreLiteral literal valueType) + 2 -> do + valueType <- decodeType 0 + callee <- decodeExpression (depth + 1) + arguments <- decodeVector "call argument count" maximumCoreOperands (decodeExpression (depth + 1)) + pure (CoreApply callee arguments valueType) + 3 -> do + primitive <- readWord8 "primitive tag" >>= decodePrimitive + valueType <- decodeType 0 + count <- readWord32 "primitive operand count" + requireDecode + (toInteger count <= toInteger (maximumCoreOperands limits)) + CoreLimitExceeded + "primitive operand count" + "count exceeds configured limit" + -- The first operand is at the depth of the primitive. + arguments <- + sequence + [ decodeExpression (depth + position) + | position <- take (fromIntegral count) (0 : repeat 1) + ] + pure (CorePrimitive primitive arguments valueType) + 4 -> do + valueType <- decodeType 0 + captures <- decodeVector "closure capture count" maximumCoreOperands (decodeCoreCapture (depth + 1)) + parameters <- decodeVector "closure parameter count" maximumCoreParameters decodeParameter + returnType <- decodeType 0 + body <- decodeVector "closure statement count" maximumCoreStatements decodeStatement + pure (CoreClosure captures parameters returnType body valueType) + 5 -> do + valueType <- decodeType 0 + name <- decodeResolvedName "let symbol" + bindingType <- decodeType 0 + value <- decodeExpression (depth + 1) + body <- decodeExpression (depth + 1) + pure (CoreLet name bindingType value body valueType) + 6 -> do + valueType <- decodeType 0 + condition <- decodeExpression (depth + 1) + whenTrue <- decodeExpression (depth + 1) + whenFalse <- decodeExpression (depth + 1) + pure (CoreConditional condition whenTrue whenFalse valueType) + _ -> invalidTag "expression tag" tag + +decodeCoreCapture :: Int -> Decoder CoreCapture +decodeCoreCapture depth = do + mode <- readWord8 "closure capture mode" >>= decodeCaptureMode + name <- decodeResolvedName "closure capture symbol" + valueType <- decodeType 0 + value <- decodeExpression depth + pure (CoreCapture mode name valueType value) + +decodeCaptureMode :: Word8 -> Decoder CaptureMode +decodeCaptureMode tag = case tag of + 0 -> pure StrongCapture + 1 -> pure WeakCapture + 2 -> pure UnownedCapture + _ -> invalidTag "closure capture mode" tag + +decodeLiteral :: Decoder CoreLiteral +decodeLiteral = do + tag <- readWord8 "literal tag" + case tag of + 0 -> pure CoreUnit + 1 -> CoreBoolean <$> decodeBool "boolean literal" + 2 -> CoreInteger . fromIntegral . (fromIntegral :: Word64 -> Int64) <$> readWord64 "integer literal" + 3 -> CoreString <$> decodeText "string literal" + 4 -> CoreInteger <$> decodeInteger + 5 -> CoreFloating <$> decodeAscii "floating literal" + 6 -> pure CoreNull + _ -> invalidTag "literal tag" tag + +decodeType :: Int -> Decoder Type +decodeType depth = do + limits <- currentLimits + requireDecode (depth <= maximumCoreTypeDepth limits) CoreLimitExceeded "type" "type nesting exceeds limit" + tag <- readWord8 "type tag" + case tag of + 0 -> pure unitType + 1 -> pure boolType + 2 -> pure intType + 3 -> pure stringType + 4 -> + NamedType + <$> decodeQualifiedName + <*> decodeVector "template argument count" maximumCoreOperands (decodeTemplateArgument (depth + 1)) + 5 -> + FunctionType + <$> decodeVector "function type parameter count" maximumCoreParameters (decodeType (depth + 1)) + <*> decodeType (depth + 1) + 6 -> TypeVariable <$> decodeResolvedName "type variable symbol" + 7 -> pure (namedScalar "char") + 8 -> pure (namedScalar "byte") + 9 -> pure (namedScalar "short") + 10 -> pure (namedScalar "long") + 11 -> pure (namedScalar "longint") + 12 -> pure (namedScalar "ubyte") + 13 -> pure (namedScalar "ushort") + 14 -> pure (namedScalar "ulong") + 15 -> pure (namedScalar "uint") + 16 -> pure (namedScalar "ulongint") + 17 -> pure (namedScalar "sfloat") + 18 -> pure (namedScalar "lfloat") + 19 -> pure (namedScalar "float") + 20 -> pure (namedScalar "double") + _ -> invalidTag "type tag" tag + +decodeTemplateArgument :: Int -> Decoder TemplateArgument +decodeTemplateArgument depth = do + tag <- readWord8 "template argument tag" + case tag of + 0 -> TypeTemplateArgument <$> decodeType depth + 1 -> ValueTemplateArgument . IntegerTemplateValue <$> decodeInteger + 2 -> ValueTemplateArgument . BooleanTemplateValue <$> decodeBool "template boolean value" + 3 -> ValueTemplateArgument . CharacterTemplateValue <$> decodeInteger + 4 -> ValueTemplateArgument . TemplateValueParameter <$> decodeResolvedName "template value parameter" + _ -> invalidTag "template argument tag" tag + +namedScalar :: String -> Type +namedScalar name = NamedType (QualifiedName [Identifier name]) [] + +decodeResolvedName :: String -> Decoder ResolvedName +decodeResolvedName context = do + raw <- readWord64 context + requireDecode (raw > 0 && raw <= fromIntegral (maxBound :: Int)) CoreInvalidSymbol context "invalid symbol id" + ResolvedName (SymbolId (fromIntegral raw)) . Identifier <$> decodeText (context ++ " spelling") + +decodeQualifiedName :: Decoder QualifiedName +decodeQualifiedName = QualifiedName <$> decodeVectorMaximum "qualified name parts" 65535 (Identifier <$> decodeText "qualified name part") + +decodeVector :: String -> (CoreWireLimits -> Int) -> Decoder a -> Decoder [a] +decodeVector context selectMaximum parser = currentLimits >>= \limits -> decodeVectorMaximum context (selectMaximum limits) parser + +decodeVectorMaximum :: String -> Int -> Decoder a -> Decoder [a] +decodeVectorMaximum context maximumValue parser = do + count <- readWord32 context + requireDecode (toInteger count <= toInteger maximumValue) CoreLimitExceeded context "count exceeds configured limit" + sequence (replicate (fromIntegral count) parser) + +decodeText :: String -> Decoder String +decodeText context = do + limits <- currentLimits + count <- readWord32 (context ++ " length") + requireDecode + (toInteger count <= toInteger (maximumCoreTextScalars limits)) + CoreLimitExceeded + context + "text exceeds configured limit" + sequence (replicate (fromIntegral count) decodeScalar) + where + decodeScalar = do + value <- readWord32 context + requireDecode + (value <= 0x10ffff && not (value >= 0xd800 && value <= 0xdfff)) + CoreInvalidScalar + context + "invalid Unicode scalar" + pure (chr (fromIntegral value)) + +decodeInteger :: Decoder Integer +decodeInteger = do + negative <- decodeBool "integer sign" + limits <- currentLimits + count <- readWord32 "integer magnitude length" + requireDecode + (toInteger count <= toInteger (maximumCoreNumericBytes limits)) + CoreLimitExceeded + "integer magnitude" + "integer magnitude exceeds configured limit" + magnitude <- takeBytes "integer magnitude" (fromIntegral count) + requireDecode + (canonicalMagnitude magnitude) + CoreInvalidInteger + "integer magnitude" + "integer magnitude is not canonical" + requireDecode + (not negative || not (null magnitude)) + CoreInvalidInteger + "integer sign" + "zero cannot have a negative sign" + let value = foldl (\result octet -> result * 256 + fromIntegral octet) 0 magnitude + pure (if negative then negate value else value) + where + canonicalMagnitude [] = True + canonicalMagnitude (first : _) = first /= 0 + +decodeAscii :: String -> Decoder String +decodeAscii context = do + limits <- currentLimits + count <- readWord32 (context ++ " length") + requireDecode + (toInteger count <= toInteger (maximumCoreNumericBytes limits)) + CoreLimitExceeded + context + "numeric spelling exceeds configured limit" + bytes <- takeBytes context (fromIntegral count) + requireDecode (all (<= 0x7f) bytes) CoreInvalidInteger context "numeric spelling must contain ASCII characters only" + pure (map (chr . fromIntegral) bytes) + +decodeBool :: String -> Decoder Bool +decodeBool context = + readWord8 context >>= \value -> case value of + 0 -> pure False + 1 -> pure True + _ -> failDecode CoreInvalidBoolean context "invalid boolean byte" + +decodePrimitive :: Word8 -> Decoder CorePrimitive +decodePrimitive tag = case drop (fromIntegral tag) primitives of + primitive : _ -> pure primitive + [] -> invalidTag "primitive tag" tag + where + primitives = + [ CoreAdd + , CoreSubtract + , CoreMultiply + , CoreDivide + , CoreFloorDivide + , CoreRemainder + , CoreLessThan + , CoreLessEqual + , CoreGreaterThan + , CoreGreaterEqual + , CoreEqual + , CoreNotEqual + , CoreLogicalAnd + , CoreLogicalOr + , CoreNegate + , CoreLogicalNot + , CorePower + , CoreShiftLeft + , CoreShiftRight + , CoreBitwiseAnd + , CoreBitwiseXor + , CoreBitwiseOr + , CoreBitwiseNot + , CoreTypeIs + , CoreMemoize + , CoreRuntimeCall + ] + +primitiveTag :: CorePrimitive -> Word8 +primitiveTag primitive = fromIntegral (index primitive primitives) + where + primitives = + [ CoreAdd + , CoreSubtract + , CoreMultiply + , CoreDivide + , CoreFloorDivide + , CoreRemainder + , CoreLessThan + , CoreLessEqual + , CoreGreaterThan + , CoreGreaterEqual + , CoreEqual + , CoreNotEqual + , CoreLogicalAnd + , CoreLogicalOr + , CoreNegate + , CoreLogicalNot + , CorePower + , CoreShiftLeft + , CoreShiftRight + , CoreBitwiseAnd + , CoreBitwiseXor + , CoreBitwiseOr + , CoreBitwiseNot + , CoreTypeIs + , CoreMemoize + , CoreRuntimeCall + ] + index :: CorePrimitive -> [CorePrimitive] -> Int + index value (candidate : remaining) = if value == candidate then 0 else 1 + index value remaining + index _ [] = error "CorePrimitive enumeration is incomplete" + +currentLimits :: Decoder CoreWireLimits +currentLimits = Decoder $ \state@(DecoderState _ _ limits) -> Right (limits, state) + +requireDecode :: Bool -> CoreWireErrorKind -> String -> String -> Decoder () +requireDecode condition kind context message = if condition then pure () else failDecode kind context message + +invalidTag :: String -> Word8 -> Decoder a +invalidTag context tag = failDecode CoreInvalidTag context ("unknown tag " ++ show tag) + +failDecode :: CoreWireErrorKind -> String -> String -> Decoder a +failDecode kind context message = Decoder $ \(DecoderState _ offset _) -> Left (CoreWireError kind offset context message) + +takeBytes :: String -> Int -> Decoder [Word8] +takeBytes context count = Decoder $ \(DecoderState bytes offset limits) -> + let (prefix, suffix) = splitAt count bytes + in if length prefix == count + then Right (prefix, DecoderState suffix (offset + count) limits) + else Left (CoreWireError CoreTruncatedInput offset context "input ended before field was complete") + +readWord8 :: String -> Decoder Word8 +readWord8 context = do + bytes <- takeBytes context 1 + case bytes of + [value] -> pure value + _ -> failDecode CoreTruncatedInput context "byte reader returned no value" +readWord16 :: String -> Decoder Word16 +readWord16 context = assemble <$> takeBytes context 2 +readWord32 :: String -> Decoder Word32 +readWord32 context = assemble <$> takeBytes context 4 +readWord64 :: String -> Decoder Word64 +readWord64 context = assemble <$> takeBytes context 8 + +magic :: [Word8] +magic = map (fromIntegral . fromEnum) "TACR" + +failure :: CoreWireErrorKind -> String -> String -> Either CoreWireError a +failure kind context message = Left (CoreWireError kind 0 context message) + +encodeBool :: Bool -> [Word8] +encodeBool False = [0] +encodeBool True = [1] +word16 :: Word16 -> [Word8] +word16 value = [byte value 0, byte value 8] +word32 :: Word32 -> [Word8] +word32 value = [byte value 0, byte value 8, byte value 16, byte value 24] +word64 :: Word64 -> [Word8] +word64 value = + [byte value 0, byte value 8, byte value 16, byte value 24, byte value 32, byte value 40, byte value 48, byte value 56] +byte :: (Integral a, Bits a) => a -> Int -> Word8 +byte value amount = fromIntegral ((value `shiftR` amount) .&. 0xff) +assemble :: (Integral a, Bits a) => [Word8] -> a +assemble bytes = foldr (\(position, value) result -> result .|. (fromIntegral value `shiftL` (position * 8))) 0 (zip [0 ..] bytes)
+ src/Progmasoft/Tala/Desugarer.hs view
@@ -0,0 +1,1283 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +-- | Lower the typed source AST into target-independent, source-attributed Core. +module Progmasoft.Tala.Desugarer (Desugarer (..), defaultDesugarer, desugarerWithin, runDesugarer) where + +import Control.Monad (forM, zipWithM) +import Control.Monad.State.Strict +import Data.List (nub) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Progmasoft.Tala.AST +import Progmasoft.Tala.Completion +import Progmasoft.Tala.Core +import Progmasoft.Tala.Desugarer.Boundary +import Progmasoft.Tala.Desugarer.Branching +import Progmasoft.Tala.Desugarer.Captures +import Progmasoft.Tala.Desugarer.Effects +import Progmasoft.Tala.Desugarer.Handing +import Progmasoft.Tala.Desugarer.Laziness +import Progmasoft.Tala.Desugarer.Sequencing +import Progmasoft.Tala.Desugarer.Symbols +import Progmasoft.Tala.Desugarer.Workers +import Progmasoft.Tala.Diagnostic (Diagnostic (..), DiagnosticSeverity (Error), DiagnosticStage (DesugarerStage)) +import Progmasoft.Tala.RuntimeCall (runtimeFunctionIdentity, runtimeFunctionOfName) + +-- | Pluggable desugaring pass from typed source semantics into Core IR. +newtype Desugarer = Desugarer + { desugarTypedAST :: TypedAST -> Either [Diagnostic] CoreModule + -- ^ Lower a typed tree or return source-level lowering diagnostics. + } + +-- | Run a supplied desugaring implementation. +runDesugarer :: Desugarer -> TypedAST -> Either [Diagnostic] CoreModule +runDesugarer = desugarTypedAST + +-- | Default Core lowerer used by the compiler pipeline. +defaultDesugarer :: Desugarer +defaultDesugarer = Desugarer (\typed -> lowerTree [typed] typed) + +{- | The lowerer for one tree of a program that is lowered as several: the +methods of ordinary types and the specializations of templates. Which calls +have an effect is decided from all the trees together, because a method of +one may call a method of another. +-} +desugarerWithin :: [TypedAST] -> Desugarer +desugarerWithin program = Desugarer (lowerTree program) + +lowerTree :: [TypedAST] -> TypedAST -> Either [Diagnostic] CoreModule +lowerTree program (TypedAST tree@(SyntaxTree namespace declarations)) = + evalStateT lowerModule initial + where + effects = programEffects [programDeclarations | TypedAST (SyntaxTree _ programDeclarations) <- program] + defaultName = QualifiedName [Identifier "Main"] + sourceFiles = nub (map portableSourcePath (concatMap declarationSourceFiles declarations)) + methods = methodDeclarations declarations + initial = + LowerState + { lowerNextSymbol = 1 + maximum (0 : syntaxSymbolIds tree) + , lowerBreakTarget = Nothing + , lowerContinue = [CoreContinue] + , lowerLeave = [CoreBreak] + , lowerSettled = Nothing + , lowerFollowing = [] + , lowerDeferred = [] + , lowerMethods = methods + , lowerNeeds = methodNeeds (scalarType . lowerBoundaryType) (expressionActs effects) methods + , lowerEffects = effects + , lowerHanded = [] + , lowerSuspended = [] + , lowerWorkers = Map.empty + , lowerPendingWorkers = [] + } + lowerModule = do + functions <- concat <$> mapM lowerTop declarations + -- The functions that receive suspended computations are lowered + -- after the methods, once it is known which of them a call asks + -- for; lowering one may ask for more. + workers <- lowerWorkersUntilNone + pure + ( CoreModuleWithSources + (maybe defaultName id namespace) + (functions ++ map fst workers) + sourceFiles + (functionSources declarations ++ map snd workers) + ) + +{- | What the lowering carries besides the tree. + +The break target and the lowering of @continue@ belong to the statement +being lowered. They are state rather than arguments because a statement is +also reached through an expression: a block used as a value holds statements, +and a @break@ or @continue@ in it must reach the loop around the expression. +-} +data LowerState = LowerState + { lowerNextSymbol :: Int + -- ^ The identity of the next compiler-generated local. + , lowerBreakTarget :: BreakTarget + -- ^ Where a @break value;@ of the statement being lowered stores. + , lowerContinue :: [CoreStatement] + {- ^ What a @continue@ of the statement being lowered becomes: the Core + @continue@ in a loop body, and a @break@ of the enclosing one-pass loop + in an update clause, where it ends the update. + -} + , lowerLeave :: [CoreStatement] + {- ^ What a @break@ of the statement being lowered becomes, after the + store of its value if it carries one: the Core @break@, preceded in an + update clause that is wrapped in a one-pass loop by the store that makes + the loop around it leave as well. + -} + , lowerSettled :: Maybe [SymbolId] + {- ^ Whether bindings are evaluated by need, and if so which locals are + not: those that are assigned after their binding and those a closure + captures. Without a list every binding is evaluated where it stands. + -} + , lowerFollowing :: [Statement ResolvedName Type] + -- ^ The statements that follow the one being lowered in its block. + , lowerDeferred :: [(SymbolId, (ResolvedName, Expression ResolvedName Type))] + {- ^ The bindings whose value is computed by need: for each, the flag + that says whether it has been computed and the expression that computes + it. + -} + , lowerMethods :: Map SymbolId (Declaration ResolvedName Type) + -- ^ The methods a call can name directly. + , lowerNeeds :: MethodNeeds + -- ^ Which parameters of which methods are passed by need. + , lowerEffects :: Effects + -- ^ Which calls of the program do something that can be observed. + , lowerHanded :: [SymbolId] + {- ^ The locals of the function being lowered whose values may be handed + on by need. Such a local is suspended in a callable of its own. + -} + , lowerSuspended :: [(SymbolId, (ResolvedName, Type))] + {- ^ The names whose value is a suspended computation: for each, the + callable that computes it and remembers it, with its type. A read of + the name is a call of the callable. + -} + , lowerWorkers :: Map SymbolId (ResolvedName, Type) + {- ^ For each method that a call has handed a suspended computation, + the function that receives suspended computations in its place, with + its type. + -} + , lowerPendingWorkers :: [SymbolId] + -- ^ The methods whose such function has been named and is not lowered yet. + } + +type Lower = StateT LowerState (Either [Diagnostic]) + +{- | Lower with every binding evaluated where it stands. The body of a +function is lowered this way once, to learn which of its locals are assigned +and which a closure captures, and so is the body of a callable. +-} +inPlace :: Lower a -> Lower a +inPlace = evaluatingWith Nothing + +{- | Lower with bindings evaluated by need, except those of the given locals, +which are assigned later or captured by a closure. +-} +byNeed :: [SymbolId] -> Lower a -> Lower a +byNeed settled = evaluatingWith (Just settled) + +evaluatingWith :: Maybe [SymbolId] -> Lower a -> Lower a +evaluatingWith settled action = do + previousSettled <- gets lowerSettled + previousDeferred <- gets lowerDeferred + previousSuspended <- gets lowerSuspended + modify (\current -> current {lowerSettled = settled, lowerDeferred = [], lowerSuspended = []}) + result <- action + modify + ( \current -> + current {lowerSettled = previousSettled, lowerDeferred = previousDeferred, lowerSuspended = previousSuspended} + ) + pure result + +-- | Lower with the given locals as the ones that may be handed on by need. +handing :: [SymbolId] -> Lower a -> Lower a +handing handed action = do + previous <- gets lowerHanded + modify (\current -> current {lowerHanded = handed}) + result <- action + modify (\current -> current {lowerHanded = previous}) + pure result + +-- | Lower with the given break target, and restore the previous one after. +targeting :: BreakTarget -> Lower a -> Lower a +targeting target action = do + previous <- gets lowerBreakTarget + modify (\current -> current {lowerBreakTarget = target}) + result <- action + modify (\current -> current {lowerBreakTarget = previous}) + pure result + +{- | Lower with the given lowerings of @continue@ and of @break@, and restore +the previous ones after. +-} +transferringWith :: [CoreStatement] -> [CoreStatement] -> Lower a -> Lower a +transferringWith continues leaves action = do + previousContinue <- gets lowerContinue + previousLeave <- gets lowerLeave + modify (\current -> current {lowerContinue = continues, lowerLeave = leaves}) + result <- action + modify (\current -> current {lowerContinue = previousContinue, lowerLeave = previousLeave}) + pure result + +{- | Lower a part of a Core loop in which the transfers of the source loop +are the transfers of that Core loop: its body, and its condition. +-} +inCoreLoop :: Lower a -> Lower a +inCoreLoop = transferringWith [CoreContinue] [CoreBreak] + +{- | The branching forms as they are lowered at the current place: a +@break value;@ in a block used as a value stores where one in the statement +around it would. +-} +branching :: (BranchLowering Lower -> Lower a) -> Lower a +branching use = gets lowerBreakTarget >>= use . branchLowering + +freshPatternSubject :: Lower ResolvedName +freshPatternSubject = freshGenerated "$pattern" + +freshCoalesceSubject :: Lower ResolvedName +freshCoalesceSubject = freshGenerated "$coalesce" + +freshGenerated :: String -> Lower ResolvedName +freshGenerated prefix = do + identifier <- gets lowerNextSymbol + modify (\current -> current {lowerNextSymbol = identifier + 1}) + pure (ResolvedName (SymbolId identifier) (Identifier (prefix ++ show identifier))) + +lowerTop :: Declaration ResolvedName Type -> Lower [CoreFunction] +lowerTop TypeDeclaration {typeMembers = members} = mapM lowerDeclaration members +-- Open template bodies are retained in TypedAST until specialization chooses +-- concrete arguments. Lowering them here would leak unresolved type variables +-- into Core and create one fake unspecialized native function. +lowerTop TemplateTypeDeclaration {} = pure [] +-- An enum has no code: its members are constants of its underlying type, +-- which the type checker has put where they are used. +lowerTop EnumDeclaration {} = pure [] +lowerTop function@FunctionDeclaration {} = (: []) <$> lowerDeclaration function + +lowerDeclaration :: Declaration ResolvedName Type -> Lower CoreFunction +lowerDeclaration declaration@FunctionDeclaration {} = do + -- The body is lowered twice. The first lowering evaluates every binding + -- where it stands and is kept only for what it shows: the locals that + -- are assigned after their binding and the locals a closure captures, + -- which must have their values in place. The second evaluates every + -- other binding by need. + inPlaceBody <- inPlace (lowerFunctionBlock returnType (declarationBody declaration)) + needs <- gets lowerNeeds + acts <- gets (expressionActs . lowerEffects) + body <- + handing (handedLocals needs acts (declarationBody declaration)) $ + byNeed + (assignedSymbols inPlaceBody ++ capturedSymbols inPlaceBody) + (lowerFunctionBlock returnType (declarationBody declaration)) + pure + ( CoreFunction + (declarationName declaration) + [ (parameterName parameter, lowerBoundaryType (parameterAnnotation parameter)) + | parameter <- declarationParameters declaration + ] + returnType + body + ) + where + returnType = lowerBoundaryType $ case declarationAnnotation declaration of FunctionType _ result -> result; value -> value +lowerDeclaration TypeDeclaration {} = error "type declarations are lowered through lowerTop" +lowerDeclaration TemplateTypeDeclaration {} = error "template declarations require specialization before Core lowering" +lowerDeclaration EnumDeclaration {} = error "enum declarations are lowered through lowerTop" + +{- | Where a @break value;@ stores its value: the result slot of the loop +expression it leaves. A loop statement has no slot, and its body is lowered +without one, so a value-carrying break can only reach its own loop's slot. +-} +type BreakTarget = Maybe (ResolvedName, Type) + +{- | The lowering of this module as the branching forms of +"Progmasoft.Tala.Desugarer.Branching" receive it. The target is where a +@break value;@ among their statements stores its value: the result slot of +the loop expression around them, if there is one. +-} +branchLowering :: BreakTarget -> BranchLowering Lower +branchLowering target = + BranchLowering + { branchExpression = lowerExpression + , branchDiscarded = lowerDiscarded + , branchStatements = lowerBlockInto target . Block + , branchOperands = sequenceOperands + , branchFresh = freshGenerated + , branchType = lowerBoundaryType + , branchLiteral = lowerLiteral + } + +lowerBlock :: Block ResolvedName Type -> Lower [CoreStatement] +lowerBlock = lowerBlockInto Nothing + +{- | Lower the statements of a block in order. + +A statement an expression of which never completes ends the block: it is +lowered as the statements that run until control leaves, without the store, +the binding or the test that would have received the value, and the +statements after it, which are never reached, are not lowered. Nothing is +invented for a value that does not exist. +-} +lowerBlockInto :: BreakTarget -> Block ResolvedName Type -> Lower [CoreStatement] +lowerBlockInto target = lowerBlockBefore target [] + +{- | Lower the statements of a block that the given statements follow. The +followers are not lowered here; they are what a binding at the end of the +block looks at to learn whether its value is needed at once. +-} +lowerBlockBefore :: BreakTarget -> [Statement ResolvedName Type] -> Block ResolvedName Type -> Lower [CoreStatement] +lowerBlockBefore target followers (Block statements) = go statements + where + go [] = pure [] + go (statement : remaining) = case neverCompletingExpression statement of + Just (before, expression) -> do + leading <- concat <$> mapM (lowerStatementInto target) before + (leading ++) <$> lowerNeverCompleting (branchLowering target) expression + Nothing -> do + -- Only a statement lowered from here knows what follows it. + -- Any other lowering of a statement sees no follower, and a + -- binding there is computed by need. + modify (\current -> current {lowerFollowing = remaining ++ followers}) + lowered <- lowerStatementInto target statement + modify (\current -> current {lowerFollowing = []}) + (lowered ++) <$> go remaining + +{- | The expression of a statement that is always evaluated and never +completes, with the statements that run before it as part of the same +statement. +-} +neverCompletingExpression :: + Statement ResolvedName Type -> Maybe ([Statement ResolvedName Type], Expression ResolvedName Type) +neverCompletingExpression statement = case statement of + BindingStatement _ _ _ _ _ value -> only value + AssignmentStatement _ _ _ value -> only value + CompoundAssignmentStatement _ _ _ _ value -> only value + DiscardStatement _ value -> only value + ReturnStatement _ (Just value) -> only value + IfStatement _ condition _ _ -> only condition + GuardStatement _ condition _ -> only condition + -- A condition that leaves by a break of its own loop is lowered with + -- the loop, which that break needs around it. + WhileStatement _ condition _ + | not (any isBreak (expressionTransfers condition)) -> only condition + ForStatement _ initializer (Just condition) _ _ + | doesNotComplete condition + , not (any isBreak (expressionTransfers condition)) -> + Just (maybe [] (: []) initializer, condition) + ExpressionStatement _ value _ -> only value + _ -> Nothing + where + only value = if doesNotComplete value then Just ([], value) else Nothing + +lowerFunctionBlock :: Type -> Block ResolvedName Type -> Lower [CoreStatement] +lowerFunctionBlock returnType (Block statements) = case statementsFromEnd of + ExpressionStatement _ expression False : remaining + | returnType /= unitType + , not (blockCannotComplete (Block (reverse remaining))) + , not (doesNotComplete expression) -> do + -- The final expression is the value the function returns, so + -- it follows the statements before it as a return would. + prefix <- lowerBlockBefore Nothing (take 1 statementsFromEnd) (Block (reverse remaining)) + (valuePrefix, value) <- lowerExpression expression + pure (prefix ++ valuePrefix ++ [CoreReturn value]) + _ -> lowerBlock (Block statements) + where + statementsFromEnd = reverse statements + +lowerStatement :: Statement ResolvedName Type -> Lower [CoreStatement] +lowerStatement = lowerStatementInto Nothing + +lowerStatementInto :: BreakTarget -> Statement ResolvedName Type -> Lower [CoreStatement] +lowerStatementInto target statement = targeting target (lowerStatementWith target statement) + +-- The break target is already the current one. +lowerStatementWith :: BreakTarget -> Statement ResolvedName Type -> Lower [CoreStatement] +lowerStatementWith target statement = case statement of + BindingStatement _ kind _ name valueType value -> do + settled <- gets lowerSettled + deferred <- gets lowerDeferred + following <- gets lowerFollowing + suspended <- gets lowerSuspended + handed <- gets lowerHanded + needs <- gets (argumentNeeds . lowerNeeds) + acts <- gets (expressionActs . lowerEffects) + let loweredType = lowerBoundaryType valueType + -- A binding must compute its value where it stands when it is + -- assigned later or captured, when its value is not a scalar, + -- and when its initializer has an effect. + mustStand inPlaceLocals bound boundType initializer = + resolvedSymbol bound `elem` inPlaceLocals + || not (scalarType (lowerBoundaryType boundType)) + || not (deferrableExpression initializer) + || acts initializer + -- A binding is certain to be evaluated when it must stand in + -- place or the statement after it is certain to need it. Only + -- such a binding makes the values its initializer reads needed. + certain inPlaceLocals bound boundType initializer later = + mustStand inPlaceLocals bound boundType initializer + || neededNext needs (certain inPlaceLocals) bound later + -- Nothing can tell where a value is computed that cannot fail + -- and that reads no value computed by need. + indifferent initializer = + not (worthDeferring initializer) + && not + ( any + ((`elem` map fst deferred ++ map fst suspended) . resolvedSymbol . fst) + (expressionNames initializer) + ) + case settled of + Just inPlaceLocals + | not (certain inPlaceLocals name valueType value following) + , not (indifferent value) -> + -- A value that may be handed to another function is + -- suspended where that function can reach it. + if resolvedSymbol name `elem` handed + then suspendBinding name loweredType value + else deferBinding inPlaceLocals name loweredType value + _ -> do + (prefix, lowered) <- lowerExpression value + pure (prefix ++ [CoreBind (CoreBinding name loweredType (kind == MutableBinding) lowered)]) + AssignmentStatement _ name _ value -> do + (prefix, lowered) <- lowerExpression value + pure (prefix ++ [CoreAssign name lowered]) + ReturnStatement _ Nothing -> pure [CoreReturn (CoreLiteral CoreUnit unitType)] + ReturnStatement _ (Just value) -> do + (prefix, lowered) <- lowerExpression value + pure (prefix ++ [CoreReturn lowered]) + IfStatement _ condition trueBlock falseBlock -> do + (prefix, loweredCondition) <- lowerExpression condition + whenTrue <- lowerBlockInto target trueBlock + whenFalse <- maybe (pure []) (lowerBlockInto target) falseBlock + pure (prefix ++ [CoreIf loweredCondition whenTrue whenFalse]) + WhileStatement {} -> lowerLoop Nothing statement + -- A loop statement has no slot for break values, and a continue in its + -- body or condition is its own. + DoWhileStatement _ body condition -> do + loweredBody <- inCoreLoop (lowerBlock body) + loweredCondition <- inCoreLoop (targeting Nothing (lowerExpression condition)) + if null (fst loweredCondition) + then pure [CoreDoWhile loweredBody (snd loweredCondition)] + else do + first <- freshGenerated "$first" + pure (doWhileLoop first loweredBody loweredCondition) + ForStatement {} -> lowerLoop Nothing statement + ForEachStatement spanValue _ _ _ _ _ _ -> + lift + ( Left + [ Diagnostic + DesugarerStage + Error + "TAD0001" + (Just spanValue) + "enumerable for loops cannot be lowered without the generator and Enumerable ABI" + ] + ) + IncrementStatement _ name valueType -> + let loweredType = lowerBoundaryType valueType + in pure [stepStatement name loweredType (CoreVariable name loweredType)] + CompoundAssignmentStatement _ operator name valueType value -> lowerCompound operator name valueType value + DiscardStatement _ value -> lowerDiscarded value + BreakStatement _ Nothing -> gets lowerLeave + BreakStatement spanValue (Just value) -> case target of + Just (slot, _) -> do + (prefix, lowered) <- lowerExpression value + leave <- gets lowerLeave + pure (prefix ++ [CoreAssign slot lowered] ++ leave) + Nothing -> + lift + ( Left + [ Diagnostic + DesugarerStage + Error + "TAD0002" + (Just spanValue) + "a value-carrying break reached Core lowering outside a loop expression" + ] + ) + ContinueStatement _ -> gets lowerContinue + -- The block runs when the condition is false and never completes + -- normally, so the statements after the guard follow the empty branch. + GuardStatement _ condition block -> do + (prefix, loweredCondition) <- lowerExpression condition + whenFalse <- lowerBlockInto target block + pure (prefix ++ [CoreIf loweredCondition [] whenFalse]) + -- Core has no block statement. Every local has its own symbol, so the + -- statements of a nested block join the enclosing sequence unchanged. + BlockStatement _ block -> lowerBlockInto target block + -- The arms of a statement match are statements of the enclosing body: + -- a break in them leaves the enclosing loop and stores into its slot. + ExpressionStatement _ (MatchExpression _ subjects arms annotation) _ + | annotation == voidType -> fst <$> lowerMatch (branchLowering target) annotation subjects arms + ExpressionStatement _ value _ -> lowerDiscarded value + +{- | Bind a local whose value is computed by need. + +The binding computes nothing. It declares the local, a flag that says the +value has not been computed, and a copy of each variable the initializer +reads that is assigned somewhere in the function: the initializer means the +values those variables have here, whenever it is evaluated. The first read +of the local that is reached computes the value and sets the flag, and no +later read computes it again; see the lowering of a name. +-} +deferBinding :: + [SymbolId] -> ResolvedName -> Type -> Expression ResolvedName Type -> Lower [CoreStatement] +deferBinding inPlaceLocals name loweredType value = do + let changing = + nub + [ (seen, lowerBoundaryType seenType) + | (seen, seenType) <- expressionNames value + , resolvedSymbol seen `elem` inPlaceLocals + ] + copies <- mapM (const (freshGenerated "$seen")) changing + known <- freshGenerated "$known" + let renames = zip (map (resolvedSymbol . fst) changing) copies + rename seen = maybe seen id (lookup (resolvedSymbol seen) renames) + false = CoreLiteral (CoreBoolean False) boolType + modify + ( \current -> + current {lowerDeferred = (resolvedSymbol name, (known, renameNames rename value)) : lowerDeferred current} + ) + pure + ( [ CoreBind (CoreBinding copy seenType False (CoreVariable seen seenType)) + | ((seen, seenType), copy) <- zip changing copies + ] + ++ [ CoreBind (CoreBinding known boolType True false) + , CoreBind (CoreBinding name loweredType True (neutralValue loweredType)) + ] + ) + +{- | Lower a @while@ or @for@ loop whose body and condition store break +values into the given target. Loops nested in the body are statements of +their own and are lowered without a target. + +A @break@ in the condition leaves the loop. The statements of a condition +that has any stand at the top of the Core loop body, so the Core @break@ +there leaves the right loop without further work. + +A @continue@ in the condition abandons the rest of the condition and +evaluates the condition again; in a @for@ loop the update clause does not +run. In a @while@ loop the condition stands at the top of the Core loop +body, where the Core @continue@ does exactly that. In a @for@ loop the Core +@continue@ would run the update, so a condition that holds a @continue@ is +evaluated in a loop of its own, which the @continue@ repeats and which is +left once the condition has a result. A @break@ in such a condition leaves +that inner loop with the result still false, which leaves the @for@. + +A @continue@ in the update clause ends the update, and the condition is +tested next. Core has no such transfer inside an update region, so an update +clause that holds one is wrapped in a loop that runs once: its statements, +then a @break@. The @continue@ becomes a @break@ of that loop. + +A @break@ in the update clause leaves the loop, which the Core @break@ in an +update region does. In an update clause that is wrapped, it first sets a +flag that is bound before the loop, and the loop is left after the wrapper +when the flag is set. +-} +lowerLoop :: BreakTarget -> Statement ResolvedName Type -> Lower [CoreStatement] +lowerLoop target loop = case loop of + WhileStatement _ condition body -> do + loweredCondition <- inLoop (lowerExpression condition) + loweredBody <- inCoreLoop (lowerBlockInto target body) + pure [whileLoop loweredCondition loweredBody] + ForStatement _ initializer condition updates body -> do + modify (\current -> current {lowerFollowing = []}) + loweredInitializer <- maybe (pure []) lowerStatement initializer + evaluatedCondition <- maybe (pure ([], alwaysTrue)) (inLoop . lowerExpression) condition + loweredCondition <- + if maybe False (any isContinue . expressionTransfers) condition + then repeatable evaluatedCondition + else pure evaluatedCondition + loweredBody <- inCoreLoop (lowerBlockInto target body) + let updateTransfers = concatMap statementTransfers updates + inUpdate = lowerBlockInto target (Block updates) + (bindings, updateRegion) <- + if any isContinue updateTransfers + then + if any isBreak updateTransfers + then do + leave <- freshGenerated "$leave" + let leaving = CoreVariable leave boolType + loweredUpdates <- + transferringWith [CoreBreak] [CoreAssign leave alwaysTrue, CoreBreak] inUpdate + pure + ( [CoreBind (CoreBinding leave boolType True alwaysFalse)] + , + [ CoreWhile alwaysTrue (loweredUpdates ++ [CoreBreak]) + , CoreIf leaving [CoreBreak] [] + ] + ) + else do + loweredUpdates <- transferringWith [CoreBreak] [CoreBreak] inUpdate + pure ([], [CoreWhile alwaysTrue (loweredUpdates ++ [CoreBreak])]) + else do + loweredUpdates <- inCoreLoop inUpdate + pure ([], loweredUpdates) + pure (loweredInitializer ++ bindings ++ [forLoop loweredCondition loweredBody updateRegion]) + _ -> lowerStatement loop + where + inLoop = inCoreLoop . targeting target + alwaysTrue = CoreLiteral (CoreBoolean True) boolType + alwaysFalse = CoreLiteral (CoreBoolean False) boolType + -- The condition in a loop of its own, which a continue repeats. Its + -- result is a flag, because the condition may be numeric. + repeatable (prefix, value) = do + holds <- freshGenerated "$holds" + pure + ( + [ CoreBind (CoreBinding holds boolType True alwaysFalse) + , CoreWhile alwaysTrue (prefix ++ [CoreIf value [CoreAssign holds alwaysTrue] [], CoreBreak]) + ] + , CoreVariable holds boolType + ) + +{- | Lower an expression whose value is dropped. + +The expression is still evaluated. When it stored into a local, the stores +are its statements and the remaining value is a plain read with nothing left +to evaluate, so no evaluation statement is emitted for it. +-} +lowerDiscarded :: Expression ResolvedName Type -> Lower [CoreStatement] +lowerDiscarded value = do + (prefix, lowered) <- lowerExpression value + pure (prefix ++ [CoreEvaluate lowered | null prefix || not (survives [] lowered)]) + +-- | @target = operand + 1@, reading the given operand. +stepStatement :: ResolvedName -> Type -> CoreExpression -> CoreStatement +stepStatement name loweredType from = + CoreAssign name (CorePrimitive CoreAdd [from, CoreLiteral (CoreInteger 1) loweredType] loweredType) + +{- | Lower @target op= value@ to the statements that perform it. + +The type checker has established that the operator result has the target +type, so the stored primitive needs no conversion. The target is read before +the right operand is evaluated; when the right operand itself assigns the +target, that earlier value is kept in a temporary. +-} +lowerCompound :: BinaryOperator -> ResolvedName -> Type -> Expression ResolvedName Type -> Lower [CoreStatement] +lowerCompound operator name valueType value = do + (prefix, lowered) <- lowerExpression value + let loweredType = lowerBoundaryType valueType + current = CoreVariable name loweredType + store left = CoreAssign name (CorePrimitive (lowerBinary operator) [left, lowered] loweredType) + if survives (assignedSymbols prefix) current + then pure (prefix ++ [store current]) + else do + previous <- freshGenerated "$target" + pure + ( CoreBind (CoreBinding previous loweredType False current) + : prefix + ++ [store (CoreVariable previous loweredType)] + ) + +{- | Make a lowered operand usable after the statements of later operands. + +Operands are evaluated left to right. When a later operand has statements, +an earlier operand that would not survive them is bound to a temporary at +the point where the source evaluates it. +-} +holdAcross :: [CoreStatement] -> Lowered -> Lower Lowered +holdAcross later lowered@(prefix, value) + | null later || survives (assignedSymbols later) value = pure lowered + | otherwise = do + name <- freshGenerated "$operand" + let valueType = expressionType value + pure (prefix ++ [CoreBind (CoreBinding name valueType False value)], CoreVariable name valueType) + +-- | Combine operands that are all evaluated, in order. +sequenceOperands :: [Lowered] -> Lower ([CoreStatement], [CoreExpression]) +sequenceOperands [] = pure ([], []) +sequenceOperands (operand : later) = do + (laterPrefix, laterValues) <- sequenceOperands later + (prefix, value) <- holdAcross laterPrefix operand + pure (prefix ++ laterPrefix, value : laterValues) + +-- | Combine one operand with the operands evaluated after it. +sequenceAfter :: Lowered -> [Lowered] -> Lower ([CoreStatement], CoreExpression, [CoreExpression]) +sequenceAfter first later = do + (laterPrefix, laterValues) <- sequenceOperands later + (prefix, value) <- holdAcross laterPrefix first + pure (prefix ++ laterPrefix, value, laterValues) + +{- | Lower an expression to the statements that perform its stores and a +store-free Core expression for its value. + +An expression without assignment or increment operands has no statements, +and its Core expression is the direct translation of the source. +-} +lowerExpression :: Expression ResolvedName Type -> Lower Lowered +lowerExpression expression = do + deferred <- gets lowerDeferred + needs <- gets (argumentNeeds . lowerNeeds) + -- Whether the reads of this expression are looked through here; they + -- are when a value by need exists and the expression may be deferred. + let searched = not (null deferred) && deferrableExpression expression + case if searched then neededTwice needs (map fst deferred) expression else [] of + [] -> lowerOperands searched expression + shared -> do + -- Each read of a value by need carries the computation of that + -- value. An expression that is certain to read one several + -- times computes it once, ahead of itself, and then reads it as + -- an ordinary local; otherwise a chain of such values would + -- grow with a power of its length. + forced <- concat <$> mapM (fmap fst . lowerOperands False . snd) shared + modify + ( \current -> + current {lowerDeferred = filter ((`notElem` map (resolvedSymbol . fst) shared) . fst) deferred} + ) + (prefix, lowered) <- lowerOperands True expression + modify (\current -> current {lowerDeferred = deferred}) + pure (forced ++ prefix, lowered) + +{- | Lower an operand that its expression evaluates whenever it is itself +evaluated: the operand of a unary operator, both operands of an operator +that does not short-circuit, and the left operand of one that does. + +When the reads of the expression have been looked through, those of such an +operand need no second look. A value by need that the operand is certain to +read twice is one the expression is certain to read twice, and it has been +computed ahead of the expression. Looking again at every operand would walk +a chain of operators once for each of its operators. +-} +lowerCertainOperand :: Bool -> Expression ResolvedName Type -> Lower Lowered +lowerCertainOperand searched + | searched = lowerOperands True + | otherwise = lowerExpression + +lowerOperands :: Bool -> Expression ResolvedName Type -> Lower Lowered +lowerOperands searched expression = case expression of + -- A read of a local whose value is computed by need computes it if no + -- earlier read has, and reads it. + NameExpression _ name valueType -> do + deferred <- gets lowerDeferred + suspended <- gets lowerSuspended + let loweredType = lowerBoundaryType valueType + case lookup (resolvedSymbol name) deferred of + -- A read of a suspended value calls its callable, which + -- computes the value if nothing has, here or anywhere else. + Nothing + | Just (computation, computationType) <- lookup (resolvedSymbol name) suspended -> + pure ([], CoreApply (CoreVariable computation computationType) [] loweredType) + Nothing -> pure ([], CoreVariable name loweredType) + Just (known, initializer) -> do + (prefix, computed) <- lowerExpression initializer + pure + ( + [ CoreIf + (CoreVariable known boolType) + [] + ( prefix + ++ [ CoreAssign name computed + , CoreAssign known (CoreLiteral (CoreBoolean True) boolType) + ] + ) + ] + , CoreVariable name loweredType + ) + LiteralExpression _ literal valueType -> + let loweredType = lowerBoundaryType valueType + in pure ([], CoreLiteral (lowerLiteral loweredType literal) loweredType) + MemberAccessExpression spanValue _ _ _ -> + lift + ( Left + [ Diagnostic + DesugarerStage + Error + "TAD0003" + (Just spanValue) + "an unresolved member selector reached Core lowering" + ] + ) + MethodReferenceExpression spanValue _ _ _ -> + lift + ( Left + [ Diagnostic + DesugarerStage + Error + "TAD0003" + (Just spanValue) + "an unresolved member selector reached Core lowering" + ] + ) + -- A call of a runtime function: its identity, and then its arguments + -- in order. + CallExpression _ (NameExpression _ callee _) arguments valueType + | Just function <- runtimeFunctionOfName callee -> do + loweredArguments <- mapM lowerExpression arguments + (prefix, values) <- sequenceOperands loweredArguments + let identity = CoreLiteral (CoreInteger (runtimeFunctionIdentity function)) intType + pure (prefix, CorePrimitive CoreRuntimeCall (identity : values) (lowerBoundaryType valueType)) + -- A call that hands a value on by need goes to the function that + -- receives suspended computations. + CallExpression _ (NameExpression _ callee _) arguments valueType -> do + byNeedFlags <- handsOnByNeed callee arguments + case byNeedFlags of + Just flags -> lowerHandingCall callee flags arguments (lowerBoundaryType valueType) + Nothing -> do + loweredCallee <- lowerExpression (calleeOf expression) + loweredArguments <- mapM lowerExpression arguments + (prefix, calleeValue, argumentValues) <- sequenceAfter loweredCallee loweredArguments + pure (prefix, CoreApply calleeValue argumentValues (lowerBoundaryType valueType)) + CallExpression _ callee arguments valueType -> do + loweredCallee <- lowerExpression callee + loweredArguments <- mapM lowerExpression arguments + (prefix, calleeValue, argumentValues) <- sequenceAfter loweredCallee loweredArguments + pure (prefix, CoreApply calleeValue argumentValues (lowerBoundaryType valueType)) + UnaryExpression _ UnaryPlus value _ -> lowerCertainOperand searched value + UnaryExpression _ operator value valueType -> do + (prefix, lowered) <- lowerCertainOperand searched value + pure (prefix, CorePrimitive (lowerUnary operator) [lowered] (lowerBoundaryType valueType)) + BinaryExpression _ operator left right valueType + -- A right operand that never completes leaves when it is + -- evaluated, so the operator yields a value only on the path that + -- skips it, and that value is known: false for `&&`, true for `||`. + | operator `elem` [LogicalAnd, LogicalOr] + , doesNotComplete right -> do + (leftPrefix, loweredLeft) <- lowerCertainOperand searched left + leaving <- branching (`lowerNeverCompleting` right) + let conjunction = operator == LogicalAnd + skip = if conjunction then CoreIf loweredLeft leaving [] else CoreIf loweredLeft [] leaving + pure (leftPrefix ++ [skip], CoreLiteral (CoreBoolean (not conjunction)) boolType) + | operator `elem` [LogicalAnd, LogicalOr] -> do + (leftPrefix, loweredLeft) <- lowerCertainOperand searched left + loweredRight <- lowerExpression right + if null (fst loweredRight) + then + pure + ( leftPrefix + , CorePrimitive (lowerBinary operator) [loweredLeft, snd loweredRight] (lowerBoundaryType valueType) + ) + else do + result <- freshGenerated "$logical" + let (statements, value) = decideLogical (operator == LogicalAnd) result loweredLeft loweredRight + pure (leftPrefix ++ statements, value) + | otherwise -> do + loweredLeft <- lowerCertainOperand searched left + loweredRight <- lowerCertainOperand searched right + (prefix, leftValue, rightValues) <- sequenceAfter loweredLeft [loweredRight] + pure (prefix, CorePrimitive (lowerBinary operator) (leftValue : rightValues) (lowerBoundaryType valueType)) + IsPatternExpression _ subject patternValue _ -> do + (prefix, loweredSubject) <- lowerExpression subject + subjectName <- freshPatternSubject + let subjectType = lowerBoundaryType (expressionAnnotation subject) + subjectRead = CoreVariable subjectName subjectType + predicate = lowerPattern subjectRead subjectType patternValue + pure (prefix, CoreLet subjectName subjectType loweredSubject predicate boolType) + -- A choice that never yields a value is reached here only where the + -- place that reads it survives its statements, which is the condition + -- of a do/while loop; a statement whose expression never completes is + -- lowered by 'lowerBlockInto' without that place. The condition is + -- never tested, so the constant is not a value of the program. + ConditionalExpression _ _ _ _ valueType + | valueType == voidType -> do + statements <- branching (`lowerNeverCompleting` expression) + pure (statements, CoreLiteral (CoreBoolean False) boolType) + MatchExpression _ _ arms valueType + | valueType == voidType && not (null arms) -> do + statements <- branching (`lowerNeverCompleting` expression) + pure (statements, CoreLiteral (CoreBoolean False) boolType) + -- A branch that does not complete has no value to lower. + ConditionalExpression _ condition first second valueType + | any doesNotComplete [first, second] -> do + loweredCondition <- lowerExpression condition + branching (\lowering -> lowerSelection lowering valueType loweredCondition first second) + ConditionalExpression _ condition first second valueType -> do + (conditionPrefix, loweredCondition) <- lowerExpression condition + loweredFirst <- lowerExpression first + loweredSecond <- lowerExpression second + let loweredType = lowerBoundaryType valueType + -- A string is an object that is owned: it is selected into a + -- variable, which the rules of ownership for an assignment cover, + -- and not by an expression that would hold two objects at once. + if null (fst loweredFirst) && null (fst loweredSecond) && loweredType /= stringType + then + pure + ( conditionPrefix + , CoreConditional loweredCondition (snd loweredFirst) (snd loweredSecond) loweredType + ) + else do + result <- freshGenerated "$selected" + let (statements, value) = selectInto result loweredType loweredCondition loweredFirst loweredSecond + pure (conditionPrefix ++ statements, value) + -- The left operand is both the test and the first result. Binding it once + -- keeps its effects single even though it is read twice. + -- A fallback that never completes leaves when the left value is false + -- in Boolean context, so the operator yields the left value or nothing. + CoalesceExpression _ left fallback valueType + | doesNotComplete fallback -> do + (leftPrefix, loweredLeft) <- lowerExpression left + leaving <- branching (`lowerNeverCompleting` fallback) + subjectName <- freshCoalesceSubject + let loweredType = lowerBoundaryType valueType + subjectRead = CoreVariable subjectName loweredType + pure + ( leftPrefix + ++ [ CoreBind (CoreBinding subjectName loweredType False loweredLeft) + , CoreIf subjectRead [] leaving + ] + , subjectRead + ) + CoalesceExpression _ left fallback valueType -> do + (leftPrefix, loweredLeft) <- lowerExpression left + loweredFallback <- lowerExpression fallback + subjectName <- freshCoalesceSubject + let loweredType = lowerBoundaryType valueType + subjectRead = CoreVariable subjectName loweredType + if null (fst loweredFallback) + then + pure + ( leftPrefix + , CoreLet + subjectName + loweredType + loweredLeft + (CoreConditional subjectRead subjectRead (snd loweredFallback) loweredType) + loweredType + ) + else do + -- The fallback stores into a local, so it runs as statements + -- and only when the left value is false in Boolean context. + result <- freshGenerated "$selected" + let (statements, value) = selectInto result loweredType subjectRead ([], subjectRead) loweredFallback + pure + ( leftPrefix ++ CoreBind (CoreBinding subjectName loweredType False loweredLeft) : statements + , value + ) + -- A simple assignment stores its right operand and yields the stored + -- value, which is read back from the target. + AssignmentExpression _ Nothing name value valueType -> do + (prefix, lowered) <- lowerExpression value + pure (prefix ++ [CoreAssign name lowered], CoreVariable name (lowerBoundaryType valueType)) + AssignmentExpression _ (Just operator) name value valueType -> do + statements <- lowerCompound operator name valueType value + pure (statements, CoreVariable name (lowerBoundaryType valueType)) + -- A prefix form yields the new value, so the target is read after the + -- store. A postfix form yields the previous value, kept in a temporary. + IncrementExpression _ isPrefix name valueType -> + let loweredType = lowerBoundaryType valueType + current = CoreVariable name loweredType + in if isPrefix + then pure ([stepStatement name loweredType current], current) + else do + previous <- freshGenerated "$previous" + let previousRead = CoreVariable previous loweredType + pure + ( + [ CoreBind (CoreBinding previous loweredType False current) + , stepStatement name loweredType previousRead + ] + , previousRead + ) + -- A loop expression runs its loop as statements. Each break that leaves + -- it stores its value into the result slot first; the type checker has + -- established that the loop cannot end any other way. + -- A loop that no break leaves never yields a value; like a choice + -- that never does, it is reached here only as the condition of a + -- do/while loop. + LoopExpression _ loop valueType + | valueType == voidType -> do + statements <- lowerLoop Nothing loop + pure (statements, CoreLiteral (CoreBoolean False) boolType) + LoopExpression _ loop valueType -> do + result <- freshGenerated "$loop" + let loweredType = lowerBoundaryType valueType + statements <- lowerLoop (Just (result, loweredType)) loop + pure + ( CoreBind (CoreBinding result loweredType True (neutralValue loweredType)) : statements + , CoreVariable result loweredType + ) + BlockExpression _ block _ -> branching (`lowerValueBlock` block) + MatchExpression _ subjects arms valueType -> branching (\lowering -> lowerMatch lowering valueType subjects arms) + CallableExpression _ explicit captures parameters body valueType -> do + let loweredParameters = + [(parameterName parameter, lowerBoundaryType (parameterAnnotation parameter)) | parameter <- parameters] + -- A callable is a function of its own: no loop of the function + -- that creates it is around its body. + -- Its bindings are computed by need like those of a method, from + -- its own assigned and captured locals. While the function around + -- it is lowered in place, to learn its locals, so is the callable. + settled <- gets lowerSettled + let lowerBody = inCoreLoop (targeting Nothing (lowerCallableBody body)) + loweredBody <- case settled of + Nothing -> inPlace lowerBody + Just _ -> do + inPlaceBody <- inPlace lowerBody + byNeed (assignedSymbols inPlaceBody ++ capturedSymbols inPlaceBody) lowerBody + (prefix, loweredCaptures) <- lowerCaptures captures + let returnType = case valueType of + FunctionType _ result -> lowerBoundaryType result + _ -> ErrorType + closure sourceCaptures = + CoreClosure sourceCaptures loweredParameters returnType loweredBody (lowerBoundaryType valueType) + pure $ + if explicit + then (prefix, closure loweredCaptures) + else ([], closure (discoverImplicitCaptures loweredParameters loweredBody)) + +-- | The callee of a call expression. +calleeOf :: Expression ResolvedName Type -> Expression ResolvedName Type +calleeOf expression = case expression of + CallExpression _ callee _ _ -> callee + _ -> expression + +-- | The type of a suspended computation of a value of the given lowered type. +suspendedType :: Type -> Type +suspendedType = FunctionType [] + +{- | Whether an argument is handed on by need when its parameter allows it: +computing it later gives what computing it now would give, and it either +may fail or run without end, or reads a value that is itself computed by +need. Any other argument is computed at the call, where it costs least. +-} +handedOn :: Expression ResolvedName Type -> Lower Bool +handedOn argument = do + deferred <- gets (map fst . lowerDeferred) + suspended <- gets (map fst . lowerSuspended) + acts <- gets (expressionActs . lowerEffects) + pure + ( deferrableExpression argument + && not (acts argument) + && ( worthDeferring argument + || any ((`elem` deferred ++ suspended) . resolvedSymbol . fst) (expressionNames argument) + ) + ) + +{- | Whether a call hands a value on by need, and if so which parameters of +the method are passed by need. + +Only a call lowered for its own sake does: while a body is lowered in place, +to learn its locals, every argument is computed at the call. +-} +handsOnByNeed :: ResolvedName -> [Expression ResolvedName Type] -> Lower (Maybe [Bool]) +handsOnByNeed callee arguments = do + settled <- gets lowerSettled + needs <- gets lowerNeeds + case (settled, Map.lookup (resolvedSymbol callee) needs) of + (Just _, Just flags) | length flags == length arguments -> do + handed <- mapM handedOn arguments + pure (if or (zipWith (&&) flags handed) then Just flags else Nothing) + _ -> pure Nothing + +{- | Lower a call of the function that receives suspended computations in +place of a method. + +An argument of a parameter that is passed by need becomes a callable. One +that is handed on by need is suspended: nothing of it is computed here. One +that is already a suspended value is passed as it is, so a value handed +through several methods is still computed once. Any other argument is +computed here, as it always was, and its callable returns that value. +-} +lowerHandingCall :: ResolvedName -> [Bool] -> [Expression ResolvedName Type] -> Type -> Lower Lowered +lowerHandingCall callee flags arguments resultType = do + (worker, workerType) <- workerOf callee flags + operands <- zipWithM operand flags arguments + (prefix, values) <- sequenceOperands operands + pure (prefix, CoreApply (CoreVariable worker workerType) values resultType) + where + operand False argument = lowerExpression argument + operand True argument = do + suspended <- gets lowerSuspended + lazily <- handedOn argument + let loweredType = lowerBoundaryType (expressionAnnotation argument) + callableType = suspendedType loweredType + case argument of + NameExpression _ name _ + | Just (computation, computationType) <- lookup (resolvedSymbol name) suspended -> + pure ([], CoreVariable computation computationType) + _ + | lazily -> do + (prefix, computation) <- suspend loweredType argument + pure (prefix, CoreVariable computation callableType) + | otherwise -> do + (prefix, value) <- lowerExpression argument + kept <- freshGenerated "$value" + computation <- freshGenerated "$computed" + let keptValue = CoreVariable kept loweredType + closure = + CoreClosure + [CoreCapture StrongCapture kept loweredType keptValue] + [] + loweredType + [CoreReturn keptValue] + callableType + pure + ( prefix + ++ [ CoreBind (CoreBinding kept loweredType False value) + , CoreBind (CoreBinding computation callableType False closure) + ] + , CoreVariable computation callableType + ) + +{- | Suspend an expression: bind a callable that computes it when it is first +called and remembers the result, and return the name of the callable. + +The callable takes the values of the variables the expression reads when it +is created, so the expression means what its variables hold here, whenever +it is computed. A suspended value the expression reads is taken as its +callable, and computed only if this one is. The functions of the module are +not taken: a callable calls them as any function does. +-} +suspend :: Type -> Expression ResolvedName Type -> Lower ([CoreStatement], ResolvedName) +suspend loweredType value = do + deferred <- gets lowerDeferred + -- A value in a flag and a slot of this frame cannot be computed from + -- another function. The locals an argument reads are suspended instead, + -- see 'handedLocals'; one that is not is computed before it is read. + let framed = + foldr + (\seen others -> if resolvedSymbol (fst seen) `elem` map (resolvedSymbol . fst) others then others else seen : others) + [] + [seen | seen <- expressionNames value, resolvedSymbol (fst seen) `elem` map fst deferred] + forced <- + concat <$> mapM (\(name, nameType) -> fst <$> lowerOperands False (NameExpression (expressionSourceSpan value) name nameType)) framed + modify (\current -> current {lowerDeferred = filter ((`notElem` map (resolvedSymbol . fst) framed) . fst) deferred}) + following <- gets lowerFollowing + modify (\current -> current {lowerFollowing = []}) + (bodyPrefix, result) <- inCoreLoop (targeting Nothing (lowerExpression value)) + modify (\current -> current {lowerDeferred = deferred, lowerFollowing = following}) + methods <- gets (Map.keys . lowerMethods) + workers <- gets (map (resolvedSymbol . fst) . Map.elems . lowerWorkers) + computation <- freshGenerated "$suspended" + let body = bodyPrefix ++ [CoreReturn result] + callableType = suspendedType loweredType + captures = + [ capture + | capture <- discoverImplicitCaptures [] body + , resolvedSymbol (coreCaptureName capture) `notElem` methods ++ workers + ] + closure = CoreClosure captures [] loweredType body callableType + pure + ( forced ++ [CoreBind (CoreBinding computation callableType False (CorePrimitive CoreMemoize [closure] callableType))] + , computation + ) + +{- | Bind a local whose value may be handed to another function by need: its +value is a suspended computation, and every read of the local calls it. +-} +suspendBinding :: ResolvedName -> Type -> Expression ResolvedName Type -> Lower [CoreStatement] +suspendBinding name loweredType value = do + (prefix, computation) <- suspend loweredType value + modify + ( \current -> + current {lowerSuspended = (resolvedSymbol name, (computation, suspendedType loweredType)) : lowerSuspended current} + ) + pure prefix + +{- | The function that receives suspended computations in place of the given +method, named on the first call that asks for it and lowered later. +-} +workerOf :: ResolvedName -> [Bool] -> Lower (ResolvedName, Type) +workerOf method flags = do + workers <- gets lowerWorkers + case Map.lookup (resolvedSymbol method) workers of + Just worker -> pure worker + Nothing -> do + declaration <- gets ((Map.! resolvedSymbol method) . lowerMethods) + identifier <- gets lowerNextSymbol + let spelling = identifierText (resolvedSpelling method) ++ "$need" ++ show identifier + worker = ResolvedName (SymbolId identifier) (Identifier spelling) + parameterTypes = + [ if flag then suspendedType parameterType else parameterType + | (flag, parameter) <- zip flags (methodParameters declaration) + , let parameterType = lowerBoundaryType (parameterAnnotation parameter) + ] + workerType = FunctionType parameterTypes (declarationResultType declaration) + modify + ( \current -> + current + { lowerNextSymbol = identifier + 1 + , lowerWorkers = Map.insert (resolvedSymbol method) (worker, workerType) (lowerWorkers current) + , lowerPendingWorkers = lowerPendingWorkers current ++ [resolvedSymbol method] + } + ) + pure (worker, workerType) + +-- | The lowered result type of a method. +declarationResultType :: Declaration ResolvedName Type -> Type +declarationResultType declaration = + lowerBoundaryType $ case declarationAnnotation declaration of FunctionType _ result -> result; value -> value + +-- | Lower the functions that were asked for until no call asks for another. +lowerWorkersUntilNone :: Lower [(CoreFunction, (Int, FilePath))] +lowerWorkersUntilNone = do + pending <- gets lowerPendingWorkers + case pending of + [] -> pure [] + method : later -> do + modify (\current -> current {lowerPendingWorkers = later}) + worker <- lowerWorker method + (worker :) <$> lowerWorkersUntilNone + +{- | Lower the function that receives suspended computations in place of a +method. + +It is the method's body once more, with the parameters that are passed by +need as suspended values: a read of one calls its callable. A parameter that +a closure of the body captures is computed when the function is entered, +because a closure takes the values of its captures when it is created. +Everything the function defines takes a fresh symbol, since the method has +been lowered from the same statements. +-} +lowerWorker :: SymbolId -> Lower (CoreFunction, (Int, FilePath)) +lowerWorker method = do + declaration <- gets ((Map.! method) . lowerMethods) + flags <- gets ((Map.! method) . lowerNeeds) + (worker, _) <- gets ((Map.! method) . lowerWorkers) + needs <- gets lowerNeeds + effects <- gets lowerEffects + let returnType = declarationResultType declaration + body = methodBody declaration + inPlaceBody <- inPlace (lowerFunctionBlock returnType body) + let captured = capturedSymbols inPlaceBody + received <- + forM (zip flags (methodParameters declaration)) $ \(flag, parameter) -> do + let name = parameterName parameter + parameterType = lowerBoundaryType (parameterAnnotation parameter) + if flag + then do + computation <- freshGenerated "$argument" + pure (name, parameterType, Just computation) + else pure (name, parameterType, Nothing) + let entered = + [ CoreBind (CoreBinding name valueType False (CoreApply (CoreVariable computation (suspendedType valueType)) [] valueType)) + | (name, valueType, Just computation) <- received + , resolvedSymbol name `elem` captured + ] + suspendedParameters = + [ (resolvedSymbol name, (computation, suspendedType valueType)) + | (name, valueType, Just computation) <- received + , resolvedSymbol name `notElem` captured + ] + lowered <- + handing (handedLocals needs (expressionActs effects) body) $ + byNeed (assignedSymbols inPlaceBody ++ captured) $ do + modify (\current -> current {lowerSuspended = suspendedParameters}) + lowerFunctionBlock returnType body + let statements = entered ++ lowered + own = nub ([name | (name, _, Nothing) <- received] ++ definedNames statements) + replacements <- Map.fromList <$> mapM (\name -> (,) (resolvedSymbol name) <$> freshLike name) own + let parameters = + [ case suspendedBy of + Just computation -> (computation, suspendedType valueType) + Nothing -> (Map.findWithDefault name (resolvedSymbol name) replacements, valueType) + | (name, valueType, suspendedBy) <- received + ] + pure + ( CoreFunction worker parameters returnType (renameSymbols replacements statements) + , (symbolIdValue (resolvedSymbol worker), portableSpanSource declaration) + ) + where + freshLike name = do + identifier <- gets lowerNextSymbol + modify (\current -> current {lowerNextSymbol = identifier + 1}) + pure (ResolvedName (SymbolId identifier) (resolvedSpelling name)) + +-- Capture initializers are evaluated in order when the closure is created, +-- like the operands of any other expression. +lowerCaptures :: [Capture ResolvedName Type] -> Lower ([CoreStatement], [CoreCapture]) +lowerCaptures captures = do + initializers <- mapM lowerInitializer captures + (prefix, values) <- sequenceOperands initializers + pure (prefix, zipWith capture captures values) + where + lowerInitializer source = + maybe + (pure ([], CoreVariable (captureName source) (lowerBoundaryType (captureAnnotation source)))) + lowerExpression + (captureInitializer source) + capture source = + CoreCapture (captureMode source) (captureName source) (lowerBoundaryType (captureAnnotation source)) + +lowerCallableBody :: CallableBody ResolvedName Type -> Lower [CoreStatement] +lowerCallableBody body = case body of + CallableExpressionBody expression + | doesNotComplete expression -> branching (`lowerNeverCompleting` expression) + | otherwise -> do + (prefix, value) <- lowerExpression expression + pure (prefix ++ [CoreReturn value]) + CallableBlockBody block -> + let returnType = maybe unitType id (callableFinalType block) + in lowerFunctionBlock returnType block
+ src/Progmasoft/Tala/Desugarer/Boundary.hs view
@@ -0,0 +1,218 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | What crosses from the Typed AST into Core without the lowering state: +types, literals, patterns, type identities and the source catalog. Each is a +translation of one typed piece into its Core counterpart. +-} +module Progmasoft.Tala.Desugarer.Boundary + ( callableFinalType + , canonicalTypeName + , declarationSourceFiles + , expressionAnnotation + , functionSources + , lowerBoundaryType + , lowerLiteral + , lowerPattern + , lowerRelationalPattern + , lowerTemplateArgument + , portableSourcePath + , portableSpanSource + , scalarType + , typeIdentity + ) where + +import Data.Bits (xor) +import Data.Char (ord) +import Data.Word (Word64) +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Scalar (isCoreNumericType) +import Progmasoft.Tala.RuntimeCall (RuntimeFunction (TextEquals), runtimeFunctionIdentity) + +-- | Whether a lowered type is one whose values are computed by need. +scalarType :: Type -> Bool +scalarType lowered = lowered == boolType || isCoreNumericType lowered + +{- | The source files of a declaration and of its members. The physical file +catalog is kept even for a declaration that does not yet lower to executable +code: the driver uses it to produce stable, one-source-per-artifact output +names after optimization has removed dead functions. +-} +declarationSourceFiles :: Declaration name annotation -> [FilePath] +declarationSourceFiles declaration = case declaration of + FunctionDeclaration {} -> [portableSpanSource declaration] + TypeDeclaration {typeMembers = members} -> + portableSpanSource declaration : concatMap declarationSourceFiles members + TemplateTypeDeclaration {typeMembers = members} -> + portableSpanSource declaration : concatMap declarationSourceFiles members + EnumDeclaration {} -> [portableSpanSource declaration] + +{- | A source path with portable separators. Artifact paths always use them, +even when discovery ran on Windows, because these names become stable wire +and output identities. +-} +portableSourcePath :: FilePath -> FilePath +portableSourcePath = map (\character -> if character == '\\' then '/' else character) + +-- | The portable path of the file a declaration is written in. +portableSpanSource :: Declaration name annotation -> FilePath +portableSpanSource = portableSourcePath . sourceFile . declarationSpan + +-- | The symbol of each function of the declarations, with its portable source path. +functionSources :: [Declaration ResolvedName Type] -> [(Int, FilePath)] +functionSources = concatMap declarationFunctionSources + where + declarationFunctionSources declaration = case declaration of + FunctionDeclaration {} -> owner declaration + TypeDeclaration {typeMembers = members} -> concatMap declarationFunctionSources members + TemplateTypeDeclaration {typeMembers = members} -> concatMap declarationFunctionSources members + EnumDeclaration {} -> [] + owner declaration = + [ + ( symbolIdValue (resolvedSymbol (declarationName declaration)) + , portableSpanSource declaration + ) + ] + +-- | The type of the final expression of a callable body, when it ends in one. +callableFinalType :: Block ResolvedName Type -> Maybe Type +callableFinalType (Block statements) = case reverse statements of + ExpressionStatement _ expression False : _ -> Just (expressionAnnotation expression) + _ -> Nothing + +-- | The type the checker annotated an expression with. +expressionAnnotation :: Expression name Type -> Type +expressionAnnotation expression = case expression of + NameExpression _ _ valueType -> valueType + LiteralExpression _ _ valueType -> valueType + MemberAccessExpression _ _ _ valueType -> valueType + MethodReferenceExpression _ _ _ valueType -> valueType + CallExpression _ _ _ valueType -> valueType + UnaryExpression _ _ _ valueType -> valueType + BinaryExpression _ _ _ _ valueType -> valueType + IsPatternExpression _ _ _ valueType -> valueType + ConditionalExpression _ _ _ _ valueType -> valueType + CoalesceExpression _ _ _ valueType -> valueType + AssignmentExpression _ _ _ _ valueType -> valueType + IncrementExpression _ _ _ valueType -> valueType + LoopExpression _ _ valueType -> valueType + BlockExpression _ _ valueType -> valueType + MatchExpression _ _ _ valueType -> valueType + CallableExpression _ _ _ _ _ valueType -> valueType + +-- | The Boolean Core test of a pattern against a subject of the given type. +lowerPattern :: CoreExpression -> Type -> Pattern ResolvedName Type -> CoreExpression +lowerPattern subject subjectType patternValue = case patternValue of + WildcardPattern {} -> CoreLiteral (CoreBoolean True) boolType + NullPattern {} -> CorePrimitive CoreEqual [subject, CoreLiteral CoreNull subjectType] boolType + -- A string is compared by the characters it holds, which the runtime + -- decides. The equality primitive on two strings would compare the + -- objects, and a literal is never the object of the subject. + LiteralPattern _ literal literalType + | literalType == stringType -> textEquals literal + RelationalPattern _ PatternEqual literal literalType + | literalType == stringType -> textEquals literal + RelationalPattern _ PatternNotEqual literal literalType + | literalType == stringType -> CorePrimitive CoreLogicalNot [textEquals literal] boolType + LiteralPattern _ literal literalType -> + CorePrimitive CoreEqual [subject, CoreLiteral (lowerLiteral literalType literal) literalType] boolType + TypePattern _ _ targetType -> + CorePrimitive + CoreTypeIs + [subject, CoreLiteral (CoreInteger (toInteger (typeIdentity targetType))) (namedType "uint")] + boolType + RelationalPattern _ operator literal literalType -> + CorePrimitive + (lowerRelationalPattern operator) + [subject, CoreLiteral (lowerLiteral literalType literal) literalType] + boolType + NotPattern _ nested _ -> CorePrimitive CoreLogicalNot [lowerPattern subject subjectType nested] boolType + AndPattern _ left right _ -> + CorePrimitive CoreLogicalAnd [lowerPattern subject subjectType left, lowerPattern subject subjectType right] boolType + OrPattern _ left right _ -> + CorePrimitive CoreLogicalOr [lowerPattern subject subjectType left, lowerPattern subject subjectType right] boolType + where + textEquals literal = + CorePrimitive + CoreRuntimeCall + [ CoreLiteral (CoreInteger (runtimeFunctionIdentity TextEquals)) intType + , subject + , CoreLiteral (lowerLiteral stringType literal) stringType + ] + boolType + +-- | The Core primitive that compares like a relational pattern operator. +lowerRelationalPattern :: RelationalPatternOperator -> CorePrimitive +lowerRelationalPattern operator = case operator of + PatternLessThan -> CoreLessThan + PatternLessEqual -> CoreLessEqual + PatternGreaterThan -> CoreGreaterThan + PatternGreaterEqual -> CoreGreaterEqual + PatternEqual -> CoreEqual + PatternNotEqual -> CoreNotEqual + +{- | The identity of a type in a type test. FNV-1a is specified rather than +delegated to a host hash library: native code embeds the same canonical +identity into AARC type metadata, so a pattern test remains stable across +processes and target platforms. +-} +typeIdentity :: Type -> Word64 +typeIdentity = foldl step 14695981039346656037 . map (fromIntegral . ord) . canonicalTypeName + where + step hashValue byte = (hashValue `xor` byte) * 1099511628211 + +-- | The canonical spelling of a type that its identity is computed from. +canonicalTypeName :: Type -> String +canonicalTypeName valueType = case valueType of + NamedType (QualifiedName parts) arguments -> + joinWith "." (map identifierText parts) + ++ if null arguments then "" else "<" ++ joinWith "," (map canonicalArgument arguments) ++ ">" + FunctionType parameters result -> + "(" ++ joinWith "," (map canonicalTypeName parameters) ++ ")->" ++ canonicalTypeName result + TypeVariable name -> "$" ++ show (symbolIdValue (resolvedSymbol name)) + ErrorType -> "<error>" + where + canonicalArgument argument = case argument of + TypeTemplateArgument nested -> canonicalTypeName nested + ValueTemplateArgument value -> show value + +joinWith :: String -> [String] -> String +joinWith _ [] = "" +joinWith _ [value] = value +joinWith separator (value : rest) = value ++ separator ++ joinWith separator rest + +-- | The Core literal of a source literal of the given type. +lowerLiteral :: Type -> Literal -> CoreLiteral +lowerLiteral valueType literal = case literal of + IntegerLiteral value + | valueType == boolType -> CoreBoolean (value /= 0) + | otherwise -> CoreInteger value + FloatingLiteral spelling -> CoreFloating spelling + CharacterLiteral value -> CoreInteger value + BooleanLiteral value -> CoreBoolean value + StringLiteral value -> CoreString value + UnitLiteral -> CoreUnit + +{- | A type as it crosses from the Typed AST into Core. The frontend keeps +source @void@ separate from value-producing @unit@; the native Core contract +predates that distinction and represents no result as unit, so the erasure +happens once, here. +-} +lowerBoundaryType :: Type -> Type +lowerBoundaryType valueType + | valueType == voidType = unitType + | FunctionType parameters result <- valueType = + FunctionType (map lowerBoundaryType parameters) (lowerBoundaryType result) + -- A value of an enum is a value of its underlying integer type. An enum + -- must not cross into Core as a named type: named types are references + -- there, and an enum is not one. + | Just underlying <- enumUnderlyingType valueType = underlying + | NamedType name arguments <- valueType = NamedType name (map lowerTemplateArgument arguments) + | otherwise = valueType + +-- | A template argument as it crosses into Core. +lowerTemplateArgument :: TemplateArgument -> TemplateArgument +lowerTemplateArgument argument = case argument of + TypeTemplateArgument valueType -> TypeTemplateArgument (lowerBoundaryType valueType) + ValueTemplateArgument value -> ValueTemplateArgument value
+ src/Progmasoft/Tala/Desugarer/Branching.hs view
@@ -0,0 +1,293 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Lowering of value blocks and of @match@ to Core statements. + +Core has no block expression and no match. Both lower to the pair that every +storing expression lowers to: statements that run first, and a store-free +expression for the value. A match becomes a chain of 'CoreIf' statements that +test the arms in order, so exactly one body runs and no Core expression, wire +format, or later stage changes. + +The lowering of the expressions and blocks inside these forms belongs to the +main desugarer, which passes it in through 'BranchLowering'. +-} +module Progmasoft.Tala.Desugarer.Branching + ( BranchLowering (..) + , lowerValueBlock + , lowerMatch + , lowerSelection + , lowerNeverCompleting + ) where + +import Progmasoft.Tala.AST +import Progmasoft.Tala.Completion +import Progmasoft.Tala.Core +import Progmasoft.Tala.Desugarer.Sequencing +import Progmasoft.Tala.RuntimeCall (RuntimeFunction (TextEquals), runtimeFunctionIdentity) + +-- | The parts of the main desugarer that the branching forms are built on. +data BranchLowering lower = BranchLowering + { branchExpression :: Expression ResolvedName Type -> lower Lowered + -- ^ Lower an expression to its statements and its value. + , branchDiscarded :: Expression ResolvedName Type -> lower [CoreStatement] + -- ^ Lower an expression whose value is dropped. + , branchStatements :: [Statement ResolvedName Type] -> lower [CoreStatement] + {- ^ Lower statements in statement position. The caller decides where a + @break value;@ among them stores its value. + -} + , branchOperands :: [Lowered] -> lower ([CoreStatement], [CoreExpression]) + -- ^ Combine operands that are all evaluated, in order. + , branchFresh :: String -> lower ResolvedName + -- ^ A fresh compiler-generated local with the given name prefix. + , branchType :: Type -> Type + -- ^ The Core type of a source type. + , branchLiteral :: Type -> Literal -> CoreLiteral + -- ^ The Core literal of a source literal of the given Core type. + } + +{- | Lower an expression that never yields a value, as the statements that +run until control leaves. + +Such an expression has no Core value, so none is made up for it: there is no +result slot, no placeholder and nothing for a join to read. The operands +that are evaluated before the one that never completes are evaluated for +their effects, in order; the operands after it are never reached and are not +lowered. A choice every branch of which leaves is a conditional statement +over the statements of its branches. +-} +lowerNeverCompleting :: + (Monad lower) => BranchLowering lower -> Expression ResolvedName Type -> lower [CoreStatement] +lowerNeverCompleting lowering expression = case expression of + BlockExpression _ (Block statements) _ -> case reverse statements of + ExpressionStatement _ value False : before + | not (blockCannotComplete (Block (reverse before))) -> do + leading <- branchStatements lowering (reverse before) + final <- lowerNeverCompleting lowering value + pure (leading ++ final) + _ -> branchStatements lowering statements + ConditionalExpression _ condition first second _ + | doesNotComplete condition -> lowerNeverCompleting lowering condition + | otherwise -> do + (prefix, test) <- branchExpression lowering condition + whenTrue <- lowerNeverCompleting lowering first + whenFalse <- lowerNeverCompleting lowering second + pure (prefix ++ [CoreIf test whenTrue whenFalse]) + MatchExpression _ subjects arms _ + | not (any doesNotComplete subjects) -> fst <$> lowerMatch lowering voidType subjects arms + -- A loop that no break leaves: the loop statement itself. + LoopExpression _ loop _ -> branchStatements lowering [loop] + _ -> case neverCompletingOperand expression of + Just (before, operand) -> do + -- Reading a name or a literal has no effect to keep. + evaluated <- mapM (branchDiscarded lowering) (filter hasEvaluation before) + final <- lowerNeverCompleting lowering operand + pure (concat evaluated ++ final) + -- Not reached for an expression that never completes; an + -- expression that does is evaluated for its effects. + Nothing -> branchDiscarded lowering expression + where + hasEvaluation operand = case operand of + NameExpression {} -> False + LiteralExpression {} -> False + _ -> True + +{- | Lower a two-way choice exactly one of whose branches completes. + +The result slot is assigned only on the branch that completes. The other +branch leaves with @return@, @break@ or @continue@, which are ordinary Core +statements wherever they stand; it is lowered as its statements alone and +never reaches the read of the slot. +-} +lowerSelection :: + (Monad lower) => + BranchLowering lower -> + Type -> + Lowered -> + Expression ResolvedName Type -> + Expression ResolvedName Type -> + lower Lowered +lowerSelection lowering valueType (conditionPrefix, condition) first second = do + result <- branchFresh lowering "$selected" + let resultType = branchType lowering valueType + branch value + | doesNotComplete value = lowerNeverCompleting lowering value + | otherwise = do + (prefix, lowered) <- branchExpression lowering value + pure (prefix ++ [CoreAssign result lowered]) + whenTrue <- branch first + whenFalse <- branch second + pure + ( conditionPrefix + ++ [ CoreBind (CoreBinding result resultType True (neutralValue resultType)) + , CoreIf condition whenTrue whenFalse + ] + , CoreVariable result resultType + ) + +{- | Lower a block used as a value. + +The leading statements run in order; the value is the final expression. A +block that does not complete has no value; the forms that hold one lower it +through 'lowerNeverCompleting' and never ask for its value. +-} +lowerValueBlock :: (Monad lower) => BranchLowering lower -> Block ResolvedName Type -> lower Lowered +lowerValueBlock lowering (Block statements) = case reverse statements of + ExpressionStatement _ value False : before -> do + leading <- branchStatements lowering (reverse before) + (prefix, lowered) <- branchExpression lowering value + pure (leading ++ prefix, lowered) + _ -> do + leading <- branchStatements lowering statements + pure (leading, CoreLiteral CoreUnit unitType) + +{- | Lower a @match@. + +The subjects are evaluated once, left to right, and each is bound to a local +so that every arm tests the same values. The names the arms bind are bound +next, each to its subject: binding a scalar that was already evaluated has no +effect of its own, and no arm can see a name of another arm. The arms then +form one chain of conditionals, each arm in the false branch of the one +before it. That is the shape of an @else if@ chain, which every stage walks +in a loop, so the lowering of a match is as deep as one arm whatever the +number of arms. + +A match whose type is @void@ is the statement form: its arm bodies run for +their effects and its value is the unit literal. Otherwise every arm that +completes stores its value into a result slot, and an arm whose block leaves +stores nothing. The type checker guarantees that the slot is assigned on +every path that reaches its read, because some arm always accepts. +-} +lowerMatch :: + (Monad lower) => + BranchLowering lower -> + Type -> + [Expression ResolvedName Type] -> + [MatchArm ResolvedName Type] -> + lower Lowered +lowerMatch lowering annotation subjects arms = do + loweredSubjects <- mapM (branchExpression lowering) subjects + (subjectPrefix, subjectValues) <- branchOperands lowering loweredSubjects + subjectNames <- mapM (const (branchFresh lowering "$subject")) subjectValues + let subjectTypes = map expressionType subjectValues + subjectBindings = + [ CoreBind (CoreBinding name valueType False value) + | (name, valueType, value) <- zip3 subjectNames subjectTypes subjectValues + ] + subjectReads = zipWith CoreVariable subjectNames subjectTypes + patternBindings = + [ CoreBind (CoreBinding name (expressionType subject) True subject) + | arm <- arms + , (MatchTypePattern _ _ (Just name) _, subject) <- zip (matchArmPatterns arm) subjectReads + ] + prefix = subjectPrefix ++ subjectBindings ++ patternBindings + if annotation == voidType + then do + chain <- lowerArms lowering Nothing subjectReads arms + pure (prefix ++ chain, CoreLiteral CoreUnit unitType) + else do + result <- branchFresh lowering "$matched" + let resultType = branchType lowering annotation + chain <- lowerArms lowering (Just result) subjectReads arms + pure + ( prefix ++ CoreBind (CoreBinding result resultType True (neutralValue resultType)) : chain + , CoreVariable result resultType + ) + +{- | Lower the arms from the given one on, as the false branch of the arm +before them. + +An arm that always accepts ends the chain with its body; the type checker +has rejected any arm after it. A guard is the last operand of the arm's +test, behind the short-circuit conjunction, so it runs only when the +patterns accept. Only a guard that stores into a local needs statements of +its own; they go before the conditional of its arm, inside the false branch +of the arm before it, and that arm alone adds a level of nesting. +-} +lowerArms :: + (Monad lower) => + BranchLowering lower -> + Maybe ResolvedName -> + [CoreExpression] -> + [MatchArm ResolvedName Type] -> + lower [CoreStatement] +lowerArms _ _ _ [] = pure [] +lowerArms lowering result subjects (arm : remaining) = do + let tests = concatMap (uncurry (patternTests lowering)) (zip (matchArmPatterns arm) subjects) + body <- lowerArmBody lowering result (matchArmBody arm) + later <- lowerArms lowering result subjects remaining + case (tests, matchArmGuard arm) of + ([], Nothing) -> pure body + (_, Nothing) -> pure [CoreIf (conjunction tests) body later] + (_, Just guard) -> do + (guardPrefix, guardValue) <- branchExpression lowering guard + if null guardPrefix + then pure [CoreIf (conjunction (tests ++ [guardValue])) body later] + else + if null tests + then pure (guardPrefix ++ [CoreIf guardValue body later]) + else do + accepted <- branchFresh lowering "$accepted" + let (statements, decision) = + decideLogical True accepted (conjunction tests) (guardPrefix, guardValue) + pure (statements ++ [CoreIf decision body later]) + +{- | The comparisons one pattern needs against its subject. + +A pattern that accepts every value needs none. The @null@ and enum case +patterns are rejected by the type checker; they lower to a test that never +holds so that a tree which reached here by mistake cannot select their arm. +-} +patternTests :: + BranchLowering lower -> MatchPattern ResolvedName Type -> CoreExpression -> [CoreExpression] +patternTests lowering patternValue subject = case patternValue of + MatchWildcardPattern {} -> [] + MatchTypePattern {} -> [] + -- Two strings are equal when they hold the same characters, which the + -- runtime decides: the comparison is the call that `==` is. + MatchLiteralPattern _ literal literalType + | literalType == stringType -> + [ CorePrimitive + CoreRuntimeCall + [ CoreLiteral (CoreInteger (runtimeFunctionIdentity TextEquals)) intType + , subject + , CoreLiteral (branchLiteral lowering stringType literal) stringType + ] + boolType + ] + MatchLiteralPattern _ literal literalType -> + let loweredType = branchType lowering literalType + in [CorePrimitive CoreEqual [subject, CoreLiteral (branchLiteral lowering loweredType literal) loweredType] boolType] + MatchNullPattern {} -> [CoreLiteral (CoreBoolean False) boolType] + MatchCasePattern {} -> [CoreLiteral (CoreBoolean False) boolType] + +-- The comparisons are Booleans without effects, so for them the +-- short-circuit primitive only decides how many run. A guard, when there is +-- one, is the last operand and is therefore evaluated only when every +-- comparison held; it may be numeric, which the primitive tests in Boolean +-- context. A lone operand is used as it is: a conditional statement tests a +-- numeric condition in Boolean context as well. +conjunction :: [CoreExpression] -> CoreExpression +conjunction tests = case tests of + [] -> CoreLiteral (CoreBoolean True) boolType + [test] -> test + test : remaining -> CorePrimitive CoreLogicalAnd [test, conjunction remaining] boolType + +{- | Lower the body of an arm. + +With a result slot, the body is an expression whose value is stored. Without +one, a block body is a statement block and any other body is evaluated for +its effects. +-} +lowerArmBody :: + (Monad lower) => BranchLowering lower -> Maybe ResolvedName -> Expression ResolvedName Type -> lower [CoreStatement] +lowerArmBody lowering result body = case (result, body) of + (Just slot, _) + | doesNotComplete body -> lowerNeverCompleting lowering body + | otherwise -> do + (prefix, value) <- branchExpression lowering body + pure (prefix ++ [CoreAssign slot value]) + (Nothing, BlockExpression _ (Block statements) _) -> branchStatements lowering statements + (Nothing, _) + | doesNotComplete body -> lowerNeverCompleting lowering body + | otherwise -> branchDiscarded lowering body
+ src/Progmasoft/Tala/Desugarer/Captures.hs view
@@ -0,0 +1,87 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | What a closure takes from the place that creates it. + +A callable written without a capture list captures what its body reads and +does not define: the lowering finds those names in the lowered body. A +closure takes the value of each when it is created. +-} +module Progmasoft.Tala.Desugarer.Captures + ( discoverImplicitCaptures + , localSymbols + ) where + +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core + +{- | The captures of a closure with the given parameters and body: every name +the body reads that is neither a parameter nor a local of the body, once, +in the order of the first read. +-} +discoverImplicitCaptures :: [(ResolvedName, Type)] -> [CoreStatement] -> [CoreCapture] +discoverImplicitCaptures parameters statements = + let bound = map (resolvedSymbol . fst) parameters ++ localSymbols statements + free = filter (\(name, _) -> resolvedSymbol name `notElem` bound) (statementReads statements) + in [CoreCapture StrongCapture name valueType (CoreVariable name valueType) | (name, valueType) <- uniqueReads free] + +{- | The symbols the statements bind, in every branch and loop body they +hold. The body of a closure among them is a scope of its own and is not +searched. +-} +localSymbols :: [CoreStatement] -> [SymbolId] +localSymbols = concatMap collect + where + collect statement = case statement of + CoreBind binding -> [resolvedSymbol (coreBindingName binding)] + CoreIf _ yes no -> localSymbols yes ++ localSymbols no + CoreWhile _ body -> localSymbols body + CoreDoWhile body _ -> localSymbols body + CoreFor _ body update -> localSymbols body ++ localSymbols update + _ -> [] + +statementReads :: [CoreStatement] -> [(ResolvedName, Type)] +statementReads = concatMap collect + where + collect statement = case statement of + CoreBind binding -> expressionReads (coreBindingValue binding) + CoreAssign _ value -> expressionReads value + CoreReturn value -> expressionReads value + CoreIf condition yes no -> expressionReads condition ++ statementReads yes ++ statementReads no + CoreWhile condition body -> expressionReads condition ++ statementReads body + CoreDoWhile body condition -> statementReads body ++ expressionReads condition + CoreFor condition body update -> + expressionReads condition ++ statementReads body ++ statementReads update + CoreEvaluate value -> expressionReads value + CoreBreak -> [] + CoreContinue -> [] + +expressionReads :: CoreExpression -> [(ResolvedName, Type)] +expressionReads expression = case expression of + CoreVariable name valueType -> [(name, valueType)] + CoreLiteral _ _ -> [] + CoreApply callee arguments _ -> expressionReads callee ++ concatMap expressionReads arguments + CorePrimitive _ arguments _ -> concatMap expressionReads arguments + CoreLet name _ value body _ -> + expressionReads value ++ filter ((/= resolvedSymbol name) . resolvedSymbol . fst) (expressionReads body) + CoreConditional condition whenTrue whenFalse _ -> + expressionReads condition ++ expressionReads whenTrue ++ expressionReads whenFalse + -- A closure reads, from the place that creates it, its capture + -- initializers and whatever its body reads that is not its own: its + -- parameters, its captures and its locals belong to the closure. Without + -- that, a closure around this one would capture them as if they were + -- names of its surroundings. + CoreClosure captures parameters _ body _ -> + let own = + map (resolvedSymbol . fst) parameters + ++ map (resolvedSymbol . coreCaptureName) captures + ++ localSymbols body + in concatMap (expressionReads . coreCaptureValue) captures + ++ filter ((`notElem` own) . resolvedSymbol . fst) (statementReads body) + +uniqueReads :: [(ResolvedName, Type)] -> [(ResolvedName, Type)] +uniqueReads = foldl append [] + where + append output value@(name, _) + | any ((== resolvedSymbol name) . resolvedSymbol . fst) output = output + | otherwise = output ++ [value]
+ src/Progmasoft/Tala/Desugarer/Effects.hs view
@@ -0,0 +1,121 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Which calls do something that can be observed. + +Tala evaluates by need, and effects are not lazy: an effect happens +where it is written, whether or not the value of the expression that +contains it is ever needed. The source has no notation for an effect, so the +compiler has to know which expressions have one. A store is an effect that +shows in the expression itself. Output does not: @Log(value)@ writes to the +console only because of what the body of @Log@ does. + +This module finds the methods a call of which may write to the console. An +expression that contains such a call is evaluated where it stands, like an +expression that stores: its binding is not deferred, and it is not handed to +another function as a suspended computation. + +The answer errs on the side of an effect. A method acts when a call anywhere +in its body acts, in a callable it creates as well as in its own statements: +creating a callable that writes is taken for writing. A call through a +callable value acts when the body of any callable of the program holds a +call that acts, or when a method that acts is used as a value, because +which callable a value holds is not followed. A program in which no +callable writes keeps its calls through callables by need, and a program +without console output is unaffected altogether. +-} +module Progmasoft.Tala.Desugarer.Effects + ( Effects + , noEffects + , programEffects + , callActs + , expressionActs + ) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Progmasoft.Tala.AST +import Progmasoft.Tala.Desugarer.Handing (blockExpressions, methodBody, methodDeclarations, within) +import Progmasoft.Tala.RuntimeCall + +-- | What is known about the calls of a program. +data Effects = Effects + { effectsMethods :: Map SymbolId Bool + -- ^ For each method of the program, whether a call of it may act. + , effectsCallables :: Bool + -- ^ Whether a call through a callable value may act. + } + deriving (Eq, Show) + +-- | A program in which no call acts. +noEffects :: Effects +noEffects = Effects Map.empty False + +{- | The effects of a program given as the declarations of every tree that is +lowered for it. All of them are read together because a method of one tree +may call a method of another: the methods of ordinary types and the +specializations of templates are lowered apart. + +A method starts out as not acting and is found to act when its body holds a +call that acts; the answer is computed again from itself until it no longer +changes, which it must, because a method that acts never stops acting. +-} +programEffects :: [[Declaration ResolvedName Type]] -> Effects +programEffects trees = settle noEffects {effectsMethods = Map.map (const False) bodies} + where + bodies = Map.map (blockExpressions . methodBody) (Map.unions (map methodDeclarations trees)) + -- Every expression of the body of every callable the program + -- creates, in whatever method. + callableBodies = + [ case body of + CallableExpressionBody result -> within result + CallableBlockBody block -> blockExpressions block + | expressions <- Map.elems bodies + , CallableExpression _ _ _ _ body _ <- expressions + ] + -- The methods that are used as a value somewhere: named more often + -- than they are called by name. + heldMethods = + Map.keys + ( Map.filter + (> 0) + ( Map.unionWith + (+) + (occurrences 1 [name | NameExpression _ name _ <- everything]) + (occurrences (-1) [name | CallExpression _ (NameExpression _ name _) _ _ <- everything]) + ) + ) + everything = concat (Map.elems bodies) + occurrences :: Int -> [ResolvedName] -> Map SymbolId Int + occurrences weight names = + Map.fromListWith (+) [(resolvedSymbol name, weight) | name <- names, Map.member (resolvedSymbol name) bodies] + settle current = + let next = + Effects + (Map.map (any (callActsIn current)) bodies) + ( any (any (callActsIn current)) callableBodies + || any (\held -> Map.findWithDefault False held (effectsMethods current)) heldMethods + ) + in if next == current then current else settle next + +-- | Whether a call of the given name may act. +callActs :: Effects -> ResolvedName -> Bool +callActs effects name = case runtimeFunctionOfName name of + Just function -> runtimeObservable function + -- A name that is not a method is a callable value. + Nothing -> Map.findWithDefault (effectsCallables effects) (resolvedSymbol name) (effectsMethods effects) + +{- | Whether evaluating an expression may act: whether any call in it does. +The statements of a block, a loop or a callable inside the expression are +not searched; an expression that holds one is evaluated where it stands for +that reason alone. +-} +expressionActs :: Effects -> Expression ResolvedName annotation -> Bool +expressionActs effects = any (callActsIn effects) . within + +callActsIn :: Effects -> Expression ResolvedName annotation -> Bool +callActsIn effects expression = case expression of + CallExpression _ (NameExpression _ callee _) _ _ -> callActs effects callee + -- The callee is itself computed: a callable value. + CallExpression {} -> effectsCallables effects + _ -> False
+ src/Progmasoft/Tala/Desugarer/Handing.hs view
@@ -0,0 +1,308 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | What the lowering needs to know to hand a value on by need. + +An argument is a value like any other: it is computed when the method that +receives it first needs it, at most once, and not at all when the method +never needs it. A value that is computed where it stands needs nothing for +that. A value by need that one function hands to another needs a place both +can reach: the caller may need it too, and whoever needs it first computes +it for both. That place is a callable that remembers its result, a +/suspended computation/; see 'Progmasoft.Tala.Core.CoreMemoize'. + +This module holds the two analyses that decide where suspended computations +are used. Both read the typed tree and neither changes it. + +* 'methodNeeds' finds the parameters a method may leave unused: those are + passed by need. A parameter the method is certain to read first of all is + passed as a value, which costs nothing and can be told apart from passing + it by need only by which of two failures a caller meets. + +* 'handedLocals' finds the locals of a function whose values may be handed + on by need. Such a local is suspended in a callable of its own instead of + in a flag and a slot of the frame, because a frame cannot be reached from + another function. +-} +module Progmasoft.Tala.Desugarer.Handing + ( MethodNeeds + , methodNeeds + , argumentNeeds + , methodDeclarations + , methodParameters + , methodBody + , handedLocals + , blockExpressions + , within + ) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Progmasoft.Tala.AST +import Progmasoft.Tala.Desugarer.Laziness + +{- | For each method that has any, which of its parameters are passed by +need, in declaration order. A method all of whose parameters are passed as +values has no entry. +-} +type MethodNeeds = Map SymbolId [Bool] + +{- | The methods a call can name directly: the methods of the ordinary types +of a source set, by symbol. The methods of a template are lowered with its +specializations, in a lowering of their own. +-} +methodDeclarations :: [Declaration ResolvedName Type] -> Map SymbolId (Declaration ResolvedName Type) +methodDeclarations declarations = + Map.fromList + [ (resolvedSymbol (declarationName member), member) + | TypeDeclaration {typeMembers = members} <- declarations + , member@FunctionDeclaration {} <- members + ] + +-- | The parameters of a method; a declaration that is not a method has none. +methodParameters :: Declaration name annotation -> [Parameter name annotation] +methodParameters declaration = case declaration of + FunctionDeclaration {declarationParameters = parameters} -> parameters + _ -> [] + +-- | The body of a method; a declaration that is not a method has an empty one. +methodBody :: Declaration name annotation -> Block name annotation +methodBody declaration = case declaration of + FunctionDeclaration {declarationBody = body} -> body + _ -> Block [] + +{- | Which parameters of which methods are passed by need. + +A parameter is passed by need when its type can be suspended, as the given +predicate decides, and the method is not certain to need it before anything +else that can be observed; see 'neededFirst'. Computing such an argument at +the call then differs from computing it where the method needs it in +nothing but the place. + +Whether a statement reads a parameter depends on the methods it calls: a +call does not read an argument it passes by need. The answer therefore +starts from every parameter of a suspendable type being passed by need, +under which a call reads the fewest arguments, and is computed again from +its own result until it no longer changes. Each round can only find more +parameters that are certain to be read, so the rounds end. +-} +methodNeeds :: + (Type -> Bool) -> + -- | Whether evaluating an expression may do something observable. + (Expression ResolvedName Type -> Bool) -> + Map SymbolId (Declaration ResolvedName Type) -> + MethodNeeds +methodNeeds suspendable acts methods = Map.filter or (settle (Map.map suspendableParameters methods)) + where + suspendableParameters declaration = + [suspendable (parameterAnnotation parameter) | parameter <- methodParameters declaration] + settle current = + let next = Map.mapWithKey (refine current) current + in if next == current then current else settle next + refine current symbol flags = case Map.lookup symbol methods of + Just declaration@FunctionDeclaration {declarationBody = Block statements} -> + [ flag && not (neededFirst (argumentNeeds current) acts (parameterName parameter) statements) + | (flag, parameter) <- zip flags (methodParameters declaration) + ] + _ -> flags + +{- | Whether the first thing a body does that can be observed needs the given +parameter. + +The statements are followed in order for as long as nothing they do can be +observed. A binding whose initializer has no effect computes nothing where +it stands: it is passed over, and when its value always needs the parameter +its name is remembered, because a later need of that name is a need of the +parameter. A statement that evaluates an expression which can neither fail +nor run without end is passed over as well. The answer is found at the +first statement that needs the parameter or one of the remembered names, +and it is no at the first statement that could do anything else: fail, +never return, choose a path or leave. + +A parameter this holds for may be computed at the call. A caller can tell +only which of two failures it meets when the argument and the statement +that needs it both fail, and the language leaves that open. +-} +neededFirst :: + ArgumentNeeds ResolvedName -> + (Expression ResolvedName Type -> Bool) -> + ResolvedName -> + [Statement ResolvedName Type] -> + Bool +neededFirst needs acts parameter = go [parameter] + where + go _ [] = False + go names (statement : later) = case statement of + BindingStatement _ _ _ bound _ value + | deferrable value -> go (if needing names value then bound : names else names) later + | otherwise -> evaluated names value later + -- A remembered name that is stored into is a local that is + -- computed where it is bound, which is where it needed the + -- parameter. + AssignmentStatement _ target _ value -> target `elem` names || evaluated names value later + CompoundAssignmentStatement _ _ target _ value -> target `elem` names || evaluated names value later + IncrementStatement _ target _ -> target `elem` names || go names later + DiscardStatement _ value -> evaluated names value later + ExpressionStatement _ value _ -> evaluated names value later + ReturnStatement _ (Just value) -> needing names value + IfStatement _ condition _ _ -> needing names condition + GuardStatement _ condition _ -> needing names condition + WhileStatement _ condition _ -> needing names condition + _ -> False + evaluated names value later = needing names value || (quiet value && go names later) + quiet value = deferrable value && not (worthDeferring value) + -- An expression that acts is evaluated where it stands: what it + -- does happens before anything after it. + deferrable value = deferrableExpression value && not (acts value) + needing names value = any (\name -> alwaysReads needs name value) names + +-- | The needs of a method by its name, as the laziness analysis asks for them. +argumentNeeds :: MethodNeeds -> ArgumentNeeds ResolvedName +argumentNeeds needs name = Map.lookup (resolvedSymbol name) needs + +{- | The locals of a function body whose values may be handed on by need. + +A local is handed on when an argument that may be passed by need reads it, +and when the initializer of a local that is handed on reads it: the +suspended computation of the one reads the other, from wherever it runs. +The result may name locals that turn out to be computed where they stand; +for those it has no consequence. +-} +handedLocals :: MethodNeeds -> (Expression ResolvedName Type -> Bool) -> Block ResolvedName Type -> [SymbolId] +handedLocals needs acts body = Set.toList (close seeds) + where + expressions = blockExpressions body + initializers = + Map.fromList + [ (resolvedSymbol name, map (resolvedSymbol . fst) (expressionNames value)) + | (name, value) <- blockBindings body + , deferrableExpression value + , not (acts value) + ] + seeds = + Set.fromList + [ resolvedSymbol name + | CallExpression _ (NameExpression _ callee _) arguments _ <- expressions + , Just flags <- [Map.lookup (resolvedSymbol callee) needs] + , length flags == length arguments + , (True, argument) <- zip flags arguments + , deferrableExpression argument + , not (acts argument) + , (name, _) <- expressionNames argument + ] + close :: Set SymbolId -> Set SymbolId + close current = + let reached = + Set.fromList + [ source + | symbol <- Set.toList current + , source <- Map.findWithDefault [] symbol initializers + ] + next = Set.union current reached + in if Set.size next == Set.size current then current else close next + +-- | Every binding of a block with its initializer, at any depth. +blockBindings :: Block name annotation -> [(name, Expression name annotation)] +blockBindings block = + [(name, value) | BindingStatement _ _ _ name _ value <- statementsWithin block] + +{- | Every expression of a block: those its statements hold, and every +expression inside those, at any depth. +-} +blockExpressions :: Block name annotation -> [Expression name annotation] +blockExpressions block = concatMap within (concatMap statementExpressions (statementsWithin block)) + +{- | Every statement of a block, at any depth: the statements of the blocks +its statements hold, and of the blocks, loops and callables its expressions +hold. +-} +statementsWithin :: Block name annotation -> [Statement name annotation] +statementsWithin (Block statements) = concatMap statementsOf statements + where + statementsOf statement = + statement + : concatMap statementsWithin (statementBlocks statement) + ++ concatMap statementsOf (statementStatements statement) + ++ concatMap inExpression (statementExpressions statement) + inExpression expression = concatMap held (within expression) + held expression = case expression of + LoopExpression _ loop _ -> statementsOf loop + BlockExpression _ block _ -> statementsWithin block + CallableExpression _ _ _ _ (CallableBlockBody block) _ -> statementsWithin block + _ -> [] + +-- | The blocks a statement holds directly. +statementBlocks :: Statement name annotation -> [Block name annotation] +statementBlocks statement = case statement of + IfStatement _ _ whenTrue whenFalse -> whenTrue : maybe [] (: []) whenFalse + WhileStatement _ _ body -> [body] + DoWhileStatement _ body _ -> [body] + ForStatement _ _ _ _ body -> [body] + ForEachStatement _ _ _ _ _ _ body -> [body] + GuardStatement _ _ block -> [block] + BlockStatement _ block -> [block] + _ -> [] + +-- | The statements a statement holds directly, outside its blocks. +statementStatements :: Statement name annotation -> [Statement name annotation] +statementStatements statement = case statement of + ForStatement _ initializer _ updates _ -> maybe [] (: []) initializer ++ updates + _ -> [] + +-- | The expressions a statement holds directly. +statementExpressions :: Statement name annotation -> [Expression name annotation] +statementExpressions statement = case statement of + BindingStatement _ _ _ _ _ value -> [value] + AssignmentStatement _ _ _ value -> [value] + ReturnStatement _ value -> maybe [] (: []) value + IfStatement _ condition _ _ -> [condition] + WhileStatement _ condition _ -> [condition] + DoWhileStatement _ _ condition -> [condition] + ForStatement _ _ condition _ _ -> maybe [] (: []) condition + ForEachStatement _ _ _ _ _ source _ -> [source] + IncrementStatement {} -> [] + CompoundAssignmentStatement _ _ _ _ value -> [value] + DiscardStatement _ value -> [value] + BreakStatement _ value -> maybe [] (: []) value + ContinueStatement _ -> [] + GuardStatement _ condition _ -> [condition] + BlockStatement {} -> [] + ExpressionStatement _ value _ -> [value] + +{- | An expression and every expression inside it that belongs to the same +evaluation: operands, arms, capture initializers and the expression body of +a callable. The statements an expression holds are reached through +'statementsWithin'. + +Each expression is put in front of the ones that follow it. Appending the +expressions of one operand to those of another would copy the expressions +of a chain of operators once for each operator of the chain. +-} +within :: Expression name annotation -> [Expression name annotation] +within expression = collect expression [] + where + collect value following = value : foldr collect following (children value) + children value = case value of + NameExpression {} -> [] + LiteralExpression {} -> [] + MemberAccessExpression _ receiver _ _ -> [receiver] + MethodReferenceExpression _ receiver _ _ -> [receiver] + CallExpression _ callee arguments _ -> callee : arguments + UnaryExpression _ _ operand _ -> [operand] + BinaryExpression _ _ left right _ -> [left, right] + IsPatternExpression _ subject _ _ -> [subject] + ConditionalExpression _ condition first second _ -> [condition, first, second] + CoalesceExpression _ left fallback _ -> [left, fallback] + AssignmentExpression _ _ _ assigned _ -> [assigned] + IncrementExpression {} -> [] + LoopExpression {} -> [] + BlockExpression {} -> [] + MatchExpression _ subjects arms _ -> + subjects ++ concat [maybe [] (: []) (matchArmGuard arm) ++ [matchArmBody arm] | arm <- arms] + CallableExpression _ _ captures _ body _ -> + [initializer | Capture {captureInitializer = Just initializer} <- captures] + ++ case body of + CallableExpressionBody result -> [result] + CallableBlockBody _ -> []
+ src/Progmasoft/Tala/Desugarer/Laziness.hs view
@@ -0,0 +1,262 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | What the lowering needs to know to evaluate a value by need. + +Tala is a lazy language: a value is computed when it is first needed and +at most once, and a value that is never needed is never computed. Its effects +are not lazy: a store into a variable and a transfer of control happen where +they are written. The source has no notation for either fact; the compiler +tells the two kinds of expression apart. + +This module holds that distinction for the initializer of a local binding. +An initializer may be deferred when evaluating it later gives what evaluating +it now would give: it stores nothing, transfers nowhere, and reads the +variables it names as they are where the binding stands. Deferring it is +observable only when it might fail or never return, so only then is it worth +a flag and a test at every use. +-} +module Progmasoft.Tala.Desugarer.Laziness + ( deferrableExpression + , worthDeferring + , expressionNames + , renameNames + , capturedSymbols + , ArgumentNeeds + , alwaysReads + , neededTwice + , neededNext + ) where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core + +{- | Whether evaluating an expression at a later point of the same function +gives the value that evaluating it in place would give, provided the +variables it reads still have the values they had. + +That holds for expressions built from names, literals, operators, tests and +calls: a call cannot store into a local of its caller. It does not hold for +an expression that stores, that leaves, or that contains statements. +-} +deferrableExpression :: Expression name annotation -> Bool +deferrableExpression expression = case expression of + NameExpression {} -> True + LiteralExpression {} -> True + MemberAccessExpression _ receiver _ _ -> deferrableExpression receiver + MethodReferenceExpression _ receiver _ _ -> deferrableExpression receiver + CallExpression _ callee arguments _ -> all deferrableExpression (callee : arguments) + UnaryExpression _ _ value _ -> deferrableExpression value + BinaryExpression _ _ left right _ -> deferrableExpression left && deferrableExpression right + IsPatternExpression _ subject _ _ -> deferrableExpression subject + ConditionalExpression _ condition first second _ -> all deferrableExpression [condition, first, second] + CoalesceExpression {} -> False + AssignmentExpression {} -> False + IncrementExpression {} -> False + LoopExpression {} -> False + BlockExpression {} -> False + MatchExpression {} -> False + CallableExpression {} -> False + +{- | Whether an expression can fail or never return, which is when it matters +whether it is evaluated at all: it calls something, or it divides. +-} +worthDeferring :: Expression name annotation -> Bool +worthDeferring expression = case expression of + CallExpression {} -> True + BinaryExpression _ operator left right _ -> + operator `elem` [Divide, FloorDivide, Remainder] || worthDeferring left || worthDeferring right + MemberAccessExpression _ receiver _ _ -> worthDeferring receiver + MethodReferenceExpression _ receiver _ _ -> worthDeferring receiver + UnaryExpression _ _ value _ -> worthDeferring value + IsPatternExpression _ subject _ _ -> worthDeferring subject + ConditionalExpression _ condition first second _ -> any worthDeferring [condition, first, second] + _ -> False + +-- | The names an expression that may be deferred reads, with their types. +expressionNames :: Expression name annotation -> [(name, annotation)] +expressionNames expression = [(name, annotation) | NameExpression _ name annotation <- nameReads expression] + +{- | The reads of a name in an expression that may be deferred, in the order +they are written. + +The reads are gathered in front of the ones that follow them. Appending the +reads of a right operand to those of a left one would copy the reads of a +chain of operators once for each operator of the chain. +-} +nameReads :: Expression name annotation -> [Expression name annotation] +nameReads expression = collect expression [] + where + collect value following = case value of + NameExpression {} -> value : following + MemberAccessExpression _ receiver _ _ -> collect receiver following + MethodReferenceExpression _ receiver _ _ -> collect receiver following + CallExpression _ callee arguments _ -> foldr collect following (callee : arguments) + UnaryExpression _ _ operand _ -> collect operand following + BinaryExpression _ _ left right _ -> collect left (collect right following) + IsPatternExpression _ subject _ _ -> collect subject following + ConditionalExpression _ condition first second _ -> foldr collect following [condition, first, second] + _ -> following + +{- | Replace the names an expression that may be deferred reads. A name that +has no replacement is kept. +-} +renameNames :: (name -> name) -> Expression name annotation -> Expression name annotation +renameNames rename expression = case expression of + NameExpression spanValue name annotation -> NameExpression spanValue (rename name) annotation + MemberAccessExpression spanValue receiver member annotation -> + MemberAccessExpression spanValue (renameNames rename receiver) member annotation + MethodReferenceExpression spanValue receiver member annotation -> + MethodReferenceExpression spanValue (renameNames rename receiver) member annotation + CallExpression spanValue callee arguments annotation -> + CallExpression spanValue (renameNames rename callee) (map (renameNames rename) arguments) annotation + UnaryExpression spanValue operator value annotation -> + UnaryExpression spanValue operator (renameNames rename value) annotation + BinaryExpression spanValue operator left right annotation -> + BinaryExpression spanValue operator (renameNames rename left) (renameNames rename right) annotation + IsPatternExpression spanValue subject patternValue annotation -> + IsPatternExpression spanValue (renameNames rename subject) patternValue annotation + ConditionalExpression spanValue condition first second annotation -> + ConditionalExpression + spanValue + (renameNames rename condition) + (renameNames rename first) + (renameNames rename second) + annotation + _ -> expression + +{- | For the name of a method whose parameters may be passed by need, which +of them are, in declaration order; nothing for any other name. A call of +such a method does not read an argument it passes by need: the method may +never need it. +-} +type ArgumentNeeds name = name -> Maybe [Bool] + +{- | Whether evaluating an expression always reads the given name, whatever +values it meets: the name stands where neither a short-circuit operator, nor +a conditional, nor a parameter that is passed by need can skip it. Blocks, +matches, loops and callables used as values are not searched; the answer for +them is that it is not known. +-} +alwaysReads :: (Eq name) => ArgumentNeeds name -> name -> Expression name annotation -> Bool +alwaysReads needs name expression = case expression of + NameExpression _ found _ -> found == name + MemberAccessExpression _ receiver _ _ -> always receiver + MethodReferenceExpression _ receiver _ _ -> always receiver + CallExpression _ (NameExpression _ callee _) arguments _ + | Just flags <- needs callee + , length flags == length arguments -> + any always [argument | (False, argument) <- zip flags arguments] + CallExpression _ callee arguments _ -> any always (callee : arguments) + UnaryExpression _ _ value _ -> always value + BinaryExpression _ operator left right _ + | operator `elem` [LogicalAnd, LogicalOr] -> always left + | otherwise -> always left || always right + IsPatternExpression _ subject _ _ -> always subject + ConditionalExpression _ condition _ _ _ -> always condition + AssignmentExpression _ _ _ value _ -> always value + _ -> False + where + always = alwaysReads needs name + +{- | The reads of the given values by need that an expression is certain to +evaluate and holds more than once, one read for each such value. + +Computing those values ahead of the expression changes nothing that can be +observed except which of two computations fails first when both fail: the +expression has no effect, and it evaluates each of them whenever it is +evaluated. +-} +neededTwice :: + ArgumentNeeds ResolvedName -> + [SymbolId] -> + Expression ResolvedName annotation -> + [(ResolvedName, Expression ResolvedName annotation)] +neededTwice needs deferred expression + | null deferred || not (deferrableExpression expression) = [] + | otherwise = go Set.empty namesRead + where + namesRead = [(name, found) | found@(NameExpression _ name _) <- nameReads expression] + byNeed = Set.fromList deferred + -- How often each value by need is read. Looking for a second read + -- among the reads that follow would walk them for every name. + counts = Map.fromListWith (+) [(symbol, 1 :: Int) | (name, _) <- namesRead, let symbol = resolvedSymbol name, Set.member symbol byNeed] + go _ [] = [] + go seen ((name, found) : remaining) + | Set.member symbol seen = go seen remaining + | Map.findWithDefault 0 symbol counts > 1 + , alwaysReads needs name expression = + (name, found) : go (Set.insert symbol seen) remaining + | otherwise = go (Set.insert symbol seen) remaining + where + symbol = resolvedSymbol name + +{- | Whether the statement that follows a binding is certain to read it. + +A value that is certain to be needed by the very next statement may be +computed where its binding stands: nothing can be observed between the two +places except which of two computations fails first when both fail. That +saves the flag and the test for the common case of a value that is used at +once. + +The next statement reads the name for certain when the expression it +evaluates first always reads it. A binding evaluates its initializer first +only when it is itself evaluated in place, which the second argument +decides for it from the statements after it. +-} +neededNext :: + (Eq name) => + ArgumentNeeds name -> + -- | Whether a later binding is evaluated in place, given what follows it. + (name -> annotation -> Expression name annotation -> [Statement name annotation] -> Bool) -> + name -> + [Statement name annotation] -> + Bool +neededNext needs inPlaceBinding name following = case following of + next : later -> case next of + BindingStatement _ _ _ bound annotation value -> + always value && inPlaceBinding bound annotation value later + AssignmentStatement _ _ _ value -> always value + CompoundAssignmentStatement _ _ _ _ value -> always value + ReturnStatement _ (Just value) -> always value + IfStatement _ condition _ _ -> always condition + GuardStatement _ condition _ -> always condition + WhileStatement _ condition _ -> always condition + DiscardStatement _ value -> always value + ExpressionStatement _ value _ -> always value + _ -> False + [] -> False + where + always = alwaysReads needs name + +{- | Every local that a closure created by the statements captures, at any +depth. A closure takes the value of a capture when it is created, so a +binding that a closure captures has to have its value by then. +-} +capturedSymbols :: [CoreStatement] -> [SymbolId] +capturedSymbols = concatMap statement + where + statement value = case value of + CoreBind binding -> expression (coreBindingValue binding) + CoreAssign _ assigned -> expression assigned + CoreReturn returned -> expression returned + CoreEvaluate evaluated -> expression evaluated + CoreIf condition whenTrue whenFalse -> expression condition ++ capturedSymbols whenTrue ++ capturedSymbols whenFalse + CoreWhile condition body -> expression condition ++ capturedSymbols body + CoreDoWhile body condition -> capturedSymbols body ++ expression condition + CoreFor condition body update -> expression condition ++ capturedSymbols body ++ capturedSymbols update + CoreBreak -> [] + CoreContinue -> [] + expression value = case value of + CoreVariable {} -> [] + CoreLiteral {} -> [] + CoreApply callee arguments _ -> concatMap expression (callee : arguments) + CorePrimitive _ arguments _ -> concatMap expression arguments + CoreLet _ _ bound body _ -> expression bound ++ expression body + CoreConditional condition whenTrue whenFalse _ -> concatMap expression [condition, whenTrue, whenFalse] + CoreClosure captures _ _ body _ -> + map (resolvedSymbol . coreCaptureName) captures + ++ concatMap (expression . coreCaptureValue) captures + ++ capturedSymbols body
+ src/Progmasoft/Tala/Desugarer/Sequencing.hs view
@@ -0,0 +1,172 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Pure building blocks for lowering expressions that store into locals. + +Core expressions never write a local: only 'CoreAssign' and 'CoreBind' +statements do, and every Core optimization relies on that. A source +expression such as @a = b@, @a += b@ or @a++@ therefore lowers to a pair: the +statements that perform its stores, and a store-free expression that reads +the result. This module holds the rules for combining such pairs without +changing what the source observes: + +* an operand evaluated before a later store must not see that store; +* an operand that is evaluated lazily keeps its stores lazy; +* a loop condition that stores does so on every test of the condition. +-} +module Progmasoft.Tala.Desugarer.Sequencing + ( Lowered + , assignedSymbols + , survives + , neutralValue + , exitUnless + , whileLoop + , forLoop + , doWhileLoop + , selectInto + , decideLogical + ) where + +import Progmasoft.Tala.AST (ResolvedName (..), SymbolId, Type, boolType, stringType) +import Progmasoft.Tala.Core +import Progmasoft.Tala.Core.Scalar (isCoreFloatingType) + +{- | Statements that must run before an expression, and the expression. + +The statements are in execution order. The expression contains no store; it +is valid only after the statements have run, and it stays valid until one of +the locals it reads is assigned again. +-} +type Lowered = ([CoreStatement], CoreExpression) + +{- | Every local that the statements may assign, at any nesting depth. + +Bindings are not listed: a binding introduces a fresh symbol, which no +earlier expression can have read. Closure bodies are not entered either. A +closure captures by value when it is created, so a store inside its body +changes the closure's own copy and not the local of the enclosing function. +-} +assignedSymbols :: [CoreStatement] -> [SymbolId] +assignedSymbols = concatMap assigned + where + assigned statement = case statement of + CoreAssign name _ -> [resolvedSymbol name] + CoreIf _ whenTrue whenFalse -> assignedSymbols whenTrue ++ assignedSymbols whenFalse + CoreWhile _ body -> assignedSymbols body + CoreDoWhile body _ -> assignedSymbols body + CoreFor _ body update -> assignedSymbols body ++ assignedSymbols update + CoreBind _ -> [] + CoreReturn _ -> [] + CoreEvaluate _ -> [] + CoreBreak -> [] + CoreContinue -> [] + +{- | Whether an already evaluated operand still has its value after statements +that assign the given locals have run. + +A literal always does. A plain read of a local does unless that local is +assigned. Anything else is a computation whose evaluation order relative to +the later statements is observable, through a call, a trap or a read, so it +does not survive and must be bound first. +-} +survives :: [SymbolId] -> CoreExpression -> Bool +survives assigned expression = case expression of + CoreLiteral _ _ -> True + CoreVariable name _ -> resolvedSymbol name `notElem` assigned + _ -> False + +{- | Initial value of a result slot that every path assigns before it is read. + +The value is never observed; it only gives the slot a well-typed +initializer. It is spelled as CorePrep spells its own neutral slot value. +-} +neutralValue :: Type -> CoreExpression +neutralValue valueType + | valueType == boolType = CoreLiteral (CoreBoolean False) valueType + | isCoreFloatingType valueType = CoreLiteral (CoreFloating "0") valueType + | valueType == stringType = CoreLiteral (CoreString "") valueType + | otherwise = CoreLiteral (CoreInteger 0) valueType + +-- | Leave the innermost loop unless the condition holds. +exitUnless :: CoreExpression -> CoreStatement +exitUnless condition = CoreIf condition [] [CoreBreak] + +alwaysTrue :: CoreExpression +alwaysTrue = CoreLiteral (CoreBoolean True) boolType + +{- | A @while@ loop whose condition has statements of its own. + +Without such statements this is the plain Core loop. With them the condition +moves to the top of the body, where its statements run before every test, +including the test that follows @continue@. +-} +whileLoop :: Lowered -> [CoreStatement] -> CoreStatement +whileLoop ([], condition) body = CoreWhile condition body +whileLoop (prefix, condition) body = CoreWhile alwaysTrue (prefix ++ [exitUnless condition] ++ body) + +{- | A @for@ loop whose condition has statements of its own. + +The update clause stays in the loop's update position, so @continue@ still +runs the update and then the condition statements. +-} +forLoop :: Lowered -> [CoreStatement] -> [CoreStatement] -> CoreStatement +forLoop ([], condition) body update = CoreFor condition body update +forLoop (prefix, condition) body update = CoreFor alwaysTrue (prefix ++ [exitUnless condition] ++ body) update + +{- | A @do@/@while@ loop whose condition has statements of its own. + +The body runs once before the first test, and @continue@ must reach the +test. Both hold when the test sits at the top of an unconditional loop and +is skipped on the first pass only, which the given fresh flag records. +-} +doWhileLoop :: ResolvedName -> [CoreStatement] -> Lowered -> [CoreStatement] +doWhileLoop _ body ([], condition) = [CoreDoWhile body condition] +doWhileLoop first body (prefix, condition) = + [ CoreBind (CoreBinding first boolType True alwaysTrue) + , CoreWhile + alwaysTrue + ( CoreIf + (CoreVariable first boolType) + [CoreAssign first (CoreLiteral (CoreBoolean False) boolType)] + (prefix ++ [exitUnless condition]) + : body + ) + ] + +{- | Evaluate exactly one of two lowered arms into a fresh result slot. + +This is the statement form of a conditional expression. It is used when an +arm has statements of its own, which must run only if that arm is selected. +-} +selectInto :: ResolvedName -> Type -> CoreExpression -> Lowered -> Lowered -> Lowered +selectInto result valueType condition (firstPrefix, first) (secondPrefix, second) = + ( + [ CoreBind (CoreBinding result valueType True (neutralValue valueType)) + , CoreIf + condition + (firstPrefix ++ [CoreAssign result first]) + (secondPrefix ++ [CoreAssign result second]) + ] + , CoreVariable result valueType + ) + +{- | Statement form of a short-circuit operator whose right operand has +statements of its own. + +The right operand and its statements run only when the left operand does not +decide the result. The result is a Boolean slot; the operands are tested in +Boolean context and are never stored into it, so they may be numeric. +-} +decideLogical :: Bool -> ResolvedName -> CoreExpression -> Lowered -> Lowered +decideLogical isConjunction result left (rightPrefix, right) = + ( + [ CoreBind (CoreBinding result boolType True (CoreLiteral (CoreBoolean False) boolType)) + , if isConjunction + then CoreIf left testRight [] + else CoreIf left [setTrue] testRight + ] + , CoreVariable result boolType + ) + where + setTrue = CoreAssign result alwaysTrue + testRight = rightPrefix ++ [CoreIf right [setTrue] []]
+ src/Progmasoft/Tala/Desugarer/Symbols.hs view
@@ -0,0 +1,129 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Tables the lowering to Core reads and does not change: the symbols a +typed tree already uses, and the Core primitive each source operator stands +for. +-} +module Progmasoft.Tala.Desugarer.Symbols + ( syntaxSymbolIds + , lowerUnary + , lowerBinary + ) where + +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core + +{- | Every symbol a typed tree declares or binds. + +Generated Core bindings must never collide with source symbols. Gathering +the complete typed tree once is cheaper and more robust than reserving a +magic numeric range or deriving identities from source positions. +-} +syntaxSymbolIds :: SyntaxTree ResolvedName Type -> [Int] +syntaxSymbolIds (SyntaxTree _ declarations) = concatMap declarationSymbolIds declarations + +declarationSymbolIds :: Declaration ResolvedName Type -> [Int] +declarationSymbolIds declaration = + symbolValue (declarationName declaration) + : case declaration of + TypeDeclaration {typeMembers = members} -> concatMap declarationSymbolIds members + TemplateTypeDeclaration {declarationTemplateParameters = parameters, typeMembers = members} -> + map (symbolValue . templateParameterName) parameters ++ concatMap declarationSymbolIds members + FunctionDeclaration {declarationParameters = parameters, declarationBody = body} -> + map (symbolValue . parameterName) parameters ++ blockSymbolIds body + EnumDeclaration {} -> [] + +blockSymbolIds :: Block ResolvedName Type -> [Int] +blockSymbolIds (Block statements) = concatMap statementIds statements + +statementIds :: Statement ResolvedName Type -> [Int] +statementIds statement = case statement of + BindingStatement _ _ _ name _ value -> symbolValue name : expressionIds value + AssignmentStatement _ name _ value -> symbolValue name : expressionIds value + ReturnStatement _ value -> maybe [] expressionIds value + IfStatement _ condition yes no -> expressionIds condition ++ blockSymbolIds yes ++ maybe [] blockSymbolIds no + WhileStatement _ condition body -> expressionIds condition ++ blockSymbolIds body + DoWhileStatement _ body condition -> blockSymbolIds body ++ expressionIds condition + ForStatement _ initializer condition updates body -> + maybe [] statementIds initializer + ++ maybe [] expressionIds condition + ++ concatMap statementIds updates + ++ blockSymbolIds body + ForEachStatement _ _ _ name _ source body -> + symbolValue name : expressionIds source ++ blockSymbolIds body + IncrementStatement _ name _ -> [symbolValue name] + CompoundAssignmentStatement _ _ name _ value -> symbolValue name : expressionIds value + DiscardStatement _ value -> expressionIds value + BreakStatement _ value -> maybe [] expressionIds value + ContinueStatement {} -> [] + GuardStatement _ condition block -> expressionIds condition ++ blockSymbolIds block + BlockStatement _ block -> blockSymbolIds block + ExpressionStatement _ value _ -> expressionIds value + +expressionIds :: Expression ResolvedName Type -> [Int] +expressionIds expression = case expression of + NameExpression _ name _ -> [symbolValue name] + LiteralExpression {} -> [] + MemberAccessExpression _ receiver _ _ -> expressionIds receiver + MethodReferenceExpression _ receiver _ _ -> expressionIds receiver + CallExpression _ callee arguments _ -> expressionIds callee ++ concatMap expressionIds arguments + UnaryExpression _ _ value _ -> expressionIds value + BinaryExpression _ _ left right _ -> expressionIds left ++ expressionIds right + IsPatternExpression _ subject _ _ -> expressionIds subject + ConditionalExpression _ condition first second _ -> concatMap expressionIds [condition, first, second] + CoalesceExpression _ left fallback _ -> expressionIds left ++ expressionIds fallback + AssignmentExpression _ _ name value _ -> symbolValue name : expressionIds value + IncrementExpression _ _ name _ -> [symbolValue name] + LoopExpression _ loop _ -> statementIds loop + BlockExpression _ block _ -> blockSymbolIds block + MatchExpression _ subjects arms _ -> + [ symbolValue name + | arm <- arms + , Just name <- map matchPatternBinding (matchArmPatterns arm) + ] + ++ concatMap expressionIds (subjects ++ concatMap matchArmExpressions arms) + CallableExpression _ _ captures parameters body _ -> + map (symbolValue . captureName) captures + ++ concatMap (maybe [] expressionIds . captureInitializer) captures + ++ map (symbolValue . parameterName) parameters + ++ callableBodyIds body + +callableBodyIds :: CallableBody ResolvedName Type -> [Int] +callableBodyIds body = case body of + CallableExpressionBody expression -> expressionIds expression + CallableBlockBody block -> blockSymbolIds block + +symbolValue :: ResolvedName -> Int +symbolValue = symbolIdValue . resolvedSymbol + +-- | The Core primitive of a unary operator. +lowerUnary :: UnaryOperator -> CorePrimitive +lowerUnary UnaryNegate = CoreNegate +lowerUnary LogicalNot = CoreLogicalNot +lowerUnary BitwiseNot = CoreBitwiseNot +lowerUnary UnaryPlus = CoreAdd + +-- | The Core primitive of a binary operator. +lowerBinary :: BinaryOperator -> CorePrimitive +lowerBinary operator = case operator of + Add -> CoreAdd + Subtract -> CoreSubtract + Multiply -> CoreMultiply + Divide -> CoreDivide + FloorDivide -> CoreFloorDivide + Remainder -> CoreRemainder + Power -> CorePower + ShiftLeft -> CoreShiftLeft + ShiftRight -> CoreShiftRight + BitwiseAnd -> CoreBitwiseAnd + BitwiseXor -> CoreBitwiseXor + BitwiseOr -> CoreBitwiseOr + LessThan -> CoreLessThan + LessEqual -> CoreLessEqual + GreaterThan -> CoreGreaterThan + GreaterEqual -> CoreGreaterEqual + Equal -> CoreEqual + NotEqual -> CoreNotEqual + LogicalAnd -> CoreLogicalAnd + LogicalOr -> CoreLogicalOr
+ src/Progmasoft/Tala/Desugarer/Workers.hs view
@@ -0,0 +1,101 @@+-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 + +{- | Giving a second lowering of a method body symbols of its own. + +A method whose parameters may be passed by need is lowered twice: once as +the method itself, which receives values, and once as the function that +receives suspended computations, for the callers that hand them on. Both +come from the same source statements, whose locals carry the symbols the +renamer gave them. Symbols are unique in a module, so the second lowering +takes fresh ones for everything it defines. +-} +module Progmasoft.Tala.Desugarer.Workers + ( definedNames + , renameSymbols + ) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Progmasoft.Tala.AST +import Progmasoft.Tala.Core + +{- | Every name the statements define, at any depth: bindings, expression +bindings, and the parameters of closures. A capture is not listed: it is +the name it captures. +-} +definedNames :: [CoreStatement] -> [ResolvedName] +definedNames = concatMap statement + where + statement value = case value of + CoreBind binding -> coreBindingName binding : expression (coreBindingValue binding) + CoreAssign _ assigned -> expression assigned + CoreReturn returned -> expression returned + CoreEvaluate evaluated -> expression evaluated + CoreIf condition whenTrue whenFalse -> expression condition ++ definedNames whenTrue ++ definedNames whenFalse + CoreWhile condition body -> expression condition ++ definedNames body + CoreDoWhile body condition -> definedNames body ++ expression condition + CoreFor condition body update -> expression condition ++ definedNames body ++ definedNames update + CoreBreak -> [] + CoreContinue -> [] + expression value = case value of + CoreVariable {} -> [] + CoreLiteral {} -> [] + CoreApply callee arguments _ -> concatMap expression (callee : arguments) + CorePrimitive _ arguments _ -> concatMap expression arguments + CoreLet name _ bound body _ -> name : expression bound ++ expression body + CoreConditional condition whenTrue whenFalse _ -> concatMap expression [condition, whenTrue, whenFalse] + CoreClosure captures parameters _ body _ -> + map fst parameters + ++ concatMap (expression . coreCaptureValue) captures + ++ definedNames body + +{- | Replace every occurrence of the given symbols, where they are defined and +where they are used. A symbol without a replacement is kept: the functions +of the module, and whatever the statements read from outside. +-} +renameSymbols :: Map SymbolId ResolvedName -> [CoreStatement] -> [CoreStatement] +renameSymbols replacements = map statement + where + name original = Map.findWithDefault original (resolvedSymbol original) replacements + statement value = case value of + CoreBind binding -> + CoreBind + binding + { coreBindingName = name (coreBindingName binding) + , coreBindingValue = expression (coreBindingValue binding) + } + CoreAssign target assigned -> CoreAssign (name target) (expression assigned) + CoreReturn returned -> CoreReturn (expression returned) + CoreEvaluate evaluated -> CoreEvaluate (expression evaluated) + CoreIf condition whenTrue whenFalse -> + CoreIf (expression condition) (map statement whenTrue) (map statement whenFalse) + CoreWhile condition body -> CoreWhile (expression condition) (map statement body) + CoreDoWhile body condition -> CoreDoWhile (map statement body) (expression condition) + CoreFor condition body update -> + CoreFor (expression condition) (map statement body) (map statement update) + CoreBreak -> CoreBreak + CoreContinue -> CoreContinue + expression value = case value of + CoreVariable variable valueType -> CoreVariable (name variable) valueType + CoreLiteral {} -> value + CoreApply callee arguments valueType -> + CoreApply (expression callee) (map expression arguments) valueType + CorePrimitive primitive arguments valueType -> + CorePrimitive primitive (map expression arguments) valueType + CoreLet bound bindingType boundValue body valueType -> + CoreLet (name bound) bindingType (expression boundValue) (expression body) valueType + CoreConditional condition whenTrue whenFalse valueType -> + CoreConditional (expression condition) (expression whenTrue) (expression whenFalse) valueType + CoreClosure captures parameters returnType body valueType -> + CoreClosure + [ capture + { coreCaptureName = name (coreCaptureName capture) + , coreCaptureValue = expression (coreCaptureValue capture) + } + | capture <- captures + ] + [(name parameter, parameterType) | (parameter, parameterType) <- parameters] + returnType + (map statement body) + valueType
+ tala-core.cabal view
@@ -0,0 +1,97 @@+cabal-version: 3.12 +-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com> +-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-1.1 +name: tala-core +version: 0.1.0 +synopsis: Tala Core and CorePrep models, verification, and wire codecs +description: + The Core and CorePrep intermediate languages of Tala: their models, + desugaring into them, optimization, verification and binary codecs. + . + This is an implementation package of the Tala compiler. Its modules may + change in any release; tools should depend on tala-tooling instead. + . + The source is also offered under the Progmasoft Linking Exception 1.1 + (LICENSE-EXCEPTION), an additional permission to MPL-2.0 for works that + combine this package with independent code. +license: MPL-2.0 +license-files: + LICENSE + LICENSE-EXCEPTION +author: Progmasoft +maintainer: support@progmasoft.com +homepage: https://tala.run/ +bug-reports: https://github.com/Progmasoft/tala/issues +category: Language, Compiler +tested-with: GHC ==9.10.3 +build-type: Simple + +library + exposed-modules: + Progmasoft.Tala.Core + Progmasoft.Tala.Core.Artifact + Progmasoft.Tala.Core.CorePrep + Progmasoft.Tala.Core.CorePrep.Verifier + Progmasoft.Tala.Core.CorePrep.Wire + Progmasoft.Tala.Core.CorePrep.Wire.Decode + Progmasoft.Tala.Core.CorePrep.Wire.Encode + Progmasoft.Tala.Core.CorePrep.Wire.Format + Progmasoft.Tala.Core.Monomorphization + Progmasoft.Tala.Core.Optimizer + Progmasoft.Tala.Core.Optimizer.IntegerFacts + Progmasoft.Tala.Core.Scalar + Progmasoft.Tala.Core.Specialization + Progmasoft.Tala.Core.Symbols + Progmasoft.Tala.Core.Template + Progmasoft.Tala.Core.Verifier + Progmasoft.Tala.Core.Wire + Progmasoft.Tala.Desugarer + Progmasoft.Tala.Desugarer.Boundary + Progmasoft.Tala.Desugarer.Branching + Progmasoft.Tala.Desugarer.Captures + Progmasoft.Tala.Desugarer.Effects + Progmasoft.Tala.Desugarer.Handing + Progmasoft.Tala.Desugarer.Laziness + Progmasoft.Tala.Desugarer.Sequencing + Progmasoft.Tala.Desugarer.Symbols + Progmasoft.Tala.Desugarer.Workers + other-modules: + Progmasoft.Tala.Core.Optimizer.Analysis + Progmasoft.Tala.Core.Optimizer.Constant + Progmasoft.Tala.Core.Optimizer.ControlFlow + Progmasoft.Tala.Core.Optimizer.EffectInference + Progmasoft.Tala.Core.Optimizer.Floating + Progmasoft.Tala.Core.Optimizer.Inline + Progmasoft.Tala.Core.Optimizer.Liveness + Progmasoft.Tala.Core.Optimizer.Pipeline + Progmasoft.Tala.Core.Optimizer.Types + Progmasoft.Tala.Core.Monomorphization.Discovery + Progmasoft.Tala.Core.Monomorphization.Graph + Progmasoft.Tala.Core.Monomorphization.Types + hs-source-dirs: src + build-depends: + base >=4.20 && <4.23, + bytestring >=0.12 && <0.14, + containers >=0.7 && <0.9, + filepath >=1.5 && <1.6, + mtl >=2.3 && <2.4, + tala-syntax >=0.1.0 && <0.2 + default-language: GHC2024 + +benchmark core-benches + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: Benches + build-depends: + base >=4.20 && <4.23, + criterion >=1.6.4 && <1.7, + deepseq >=1.5 && <1.6, + tala-core >=0.1.0 && <0.2, + tala-syntax >=0.1.0 && <0.2 + default-language: GHC2024 + ghc-options: -threaded -rtsopts + +source-repository head + type: git + location: https://github.com/Progmasoft/tala + subdir: Talac/Haskell/Core