From 45dd50a9c3c6ca40b16b0f8eccb397650838cdf8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Michael=20R=C3=A4tzel?= Date: Fri, 31 May 2024 13:04:42 +0000 Subject: [PATCH] Refactor in Elm compiler for compilation efficiency + Find and replace some instances of partial application to avoid expensive wrapping. --- implement/Pine.Core/Pine.Core.csproj | 6 +- .../compile-elm-program/src/ElmCompiler.elm | 214 ++++++++------- .../compile-elm-program/src/FirCompiler.elm | 244 ++++++++++-------- implement/pine/Program.cs | 2 +- implement/pine/pine.csproj | 4 +- 5 files changed, 257 insertions(+), 213 deletions(-) diff --git a/implement/Pine.Core/Pine.Core.csproj b/implement/Pine.Core/Pine.Core.csproj index cead1754..0238181e 100644 --- a/implement/Pine.Core/Pine.Core.csproj +++ b/implement/Pine.Core/Pine.Core.csproj @@ -3,13 +3,13 @@ net8.0 enable - 0.3.9 - 0.3.9 + 0.3.10 + 0.3.10 Pine.Core - 0.3.9 + 0.3.10 The cross-platform Elm runtime environment Functional;Elm;Runtime;Compiler;VM;DBMS https://github.com/pine-vm/pine.git diff --git a/implement/pine/ElmTime/compile-elm-program/src/ElmCompiler.elm b/implement/pine/ElmTime/compile-elm-program/src/ElmCompiler.elm index 396193ea..fe26d993 100644 --- a/implement/pine/ElmTime/compile-elm-program/src/ElmCompiler.elm +++ b/implement/pine/ElmTime/compile-elm-program/src/ElmCompiler.elm @@ -464,27 +464,25 @@ compileElmModuleIntoNamedExports availableModules moduleToTranslate = declName (ElmModuleChoiceTypeDeclaration { tags = - choiceTypeDeclaration.constructors - |> List.filter - (Elm.Syntax.Node.value - >> .name - >> Elm.Syntax.Node.value - >> Dict.get - >> (|>) elmDeclarationsOverridesExpressions - >> (==) Nothing - ) - |> List.foldl - (\(Elm.Syntax.Node.Node _ valueConstructor) -> - let - (Elm.Syntax.Node.Node _ valueConstructorName) = - valueConstructor.name - in - Dict.insert - valueConstructorName - { argumentsCount = List.length valueConstructor.arguments - } - ) - Dict.empty + List.foldl + (\(Elm.Syntax.Node.Node _ valueConstructor) constructorsDict -> + let + (Elm.Syntax.Node.Node _ valueConstructorName) = + valueConstructor.name + in + case Dict.get valueConstructorName elmDeclarationsOverridesExpressions of + Nothing -> + Dict.insert + valueConstructorName + { argumentsCount = List.length valueConstructor.arguments + } + constructorsDict + + Just _ -> + constructorsDict + ) + Dict.empty + choiceTypeDeclaration.constructors } ) aggregate @@ -587,24 +585,24 @@ compileElmModuleIntoNamedExports availableModules moduleToTranslate = localFunctionDeclarations : Dict.Dict String Elm.Syntax.Expression.Function localFunctionDeclarations = - moduleToTranslate.parsedModule.declarations - |> List.foldl - (\(Elm.Syntax.Node.Node _ declaration) aggregate -> - case declaration of - Elm.Syntax.Declaration.FunctionDeclaration functionDeclaration -> - let - (Elm.Syntax.Node.Node _ function) = - functionDeclaration.declaration + List.foldl + (\(Elm.Syntax.Node.Node _ declaration) aggregate -> + case declaration of + Elm.Syntax.Declaration.FunctionDeclaration functionDeclaration -> + let + (Elm.Syntax.Node.Node _ function) = + functionDeclaration.declaration - (Elm.Syntax.Node.Node _ name) = - function.name - in - Dict.insert name functionDeclaration aggregate + (Elm.Syntax.Node.Node _ name) = + function.name + in + Dict.insert name functionDeclaration aggregate - _ -> - aggregate - ) - Dict.empty + _ -> + aggregate + ) + Dict.empty + moduleToTranslate.parsedModule.declarations exposedFunctionDecls : Set.Set String exposedFunctionDecls = @@ -819,30 +817,30 @@ compilationAndEmitStackFromModulesInCompilation availableModules { moduleAliases , recordTypeDeclarations : Dict.Dict String (List String) } localTypeDeclarationsSeparate = - localTypeDeclarations - |> Dict.foldl - (\typeName typeDeclaration aggregate -> - case typeDeclaration of - ElmModuleChoiceTypeDeclaration choiceTypeDeclaration -> - { aggregate - | choiceTypeTagDeclarations = - Dict.union - (Dict.map - (\_ tag -> { argumentsCount = tag.argumentsCount }) - choiceTypeDeclaration.tags - ) - aggregate.choiceTypeTagDeclarations - } + Dict.foldl + (\typeName typeDeclaration aggregate -> + case typeDeclaration of + ElmModuleChoiceTypeDeclaration choiceTypeDeclaration -> + { aggregate + | choiceTypeTagDeclarations = + Dict.union + (Dict.map + (\_ tag -> { argumentsCount = tag.argumentsCount }) + choiceTypeDeclaration.tags + ) + aggregate.choiceTypeTagDeclarations + } - ElmModuleRecordTypeDeclaration fields -> - { aggregate - | recordTypeDeclarations = - Dict.insert typeName fields aggregate.recordTypeDeclarations - } - ) - { recordTypeDeclarations = Dict.empty - , choiceTypeTagDeclarations = Dict.empty - } + ElmModuleRecordTypeDeclaration fields -> + { aggregate + | recordTypeDeclarations = + Dict.insert typeName fields aggregate.recordTypeDeclarations + } + ) + { recordTypeDeclarations = Dict.empty + , choiceTypeTagDeclarations = Dict.empty + } + localTypeDeclarations declarationsFromTypeAliasesFieldsNames = Dict.union @@ -2020,11 +2018,15 @@ compileElmSyntaxPattern compilation elmPattern = conditionExpressions = \deconstructedExpression -> matchesLengthCondition deconstructedExpression - :: List.concatMap (.conditions >> (|>) deconstructedExpression) itemsResults + :: List.concatMap + (\{ conditions } -> + conditions deconstructedExpression + ) + itemsResults in Ok { conditionExpressions = conditionExpressions - , declarations = itemsResults |> List.concatMap .declarations + , declarations = List.concatMap .declarations itemsResults } in case elmPattern of @@ -2072,10 +2074,10 @@ compileElmSyntaxPattern compilation elmPattern = declarations = List.concat - [ leftSide.declarations - |> List.map (Tuple.mapSecond ((::) (ListItemDeconstruction 0))) - , rightSide.declarations - |> List.map (Tuple.mapSecond ((::) (SkipItemsDeconstruction 1))) + [ List.map (Tuple.mapSecond ((::) (ListItemDeconstruction 0))) + leftSide.declarations + , List.map (Tuple.mapSecond ((::) (SkipItemsDeconstruction 1))) + rightSide.declarations ] in Ok @@ -2192,22 +2194,29 @@ compileElmSyntaxPattern compilation elmPattern = ] argumentsConditions = - itemsResults - |> List.concatMap - (.conditions - >> (|>) (listItemFromIndexExpression 1 deconstructedExpression) - ) + List.concatMap + (\{ conditions } -> + conditions (listItemFromIndexExpression 1 deconstructedExpression) + ) + itemsResults in List.concat [ matchingTagConditions, argumentsConditions ] - declarations = - itemsResults - |> List.concatMap .declarations - |> List.map (Tuple.mapSecond ((::) (ListItemDeconstruction 1))) + mergedDeclarations : List ( String, List Deconstruction ) + mergedDeclarations = + List.concatMap + (\{ declarations } -> + List.map + (\( declName, deconstruction ) -> + ( declName, ListItemDeconstruction 1 :: deconstruction ) + ) + declarations + ) + itemsResults in Ok { conditionExpressions = conditionExpressions - , declarations = declarations + , declarations = mergedDeclarations } Elm.Syntax.Pattern.CharPattern char -> @@ -2236,15 +2245,16 @@ compileElmSyntaxPattern compilation elmPattern = List.map (\(Elm.Syntax.Node.Node _ fieldName) -> ( fieldName - , [ Pine.ParseAndEvalExpression - { expression = Pine.LiteralExpression pineFunctionForRecordAccessAsValue - , environment = - Pine.ListExpression - [ Pine.environmentExpr - , Pine.LiteralExpression (Pine.valueFromString fieldName) - ] - } - |> PineFunctionApplicationDeconstruction + , [ PineFunctionApplicationDeconstruction + (Pine.ParseAndEvalExpression + { expression = Pine.LiteralExpression pineFunctionForRecordAccessAsValue + , environment = + Pine.ListExpression + [ Pine.environmentExpr + , Pine.LiteralExpression (Pine.valueFromString fieldName) + ] + } + ) ] ) ) @@ -2801,13 +2811,17 @@ getDeclarationValueFromCompilation : ( List String, String ) -> CompilationStack getDeclarationValueFromCompilation ( localModuleName, nameInModule ) compilation = let canonicalModuleName = - Dict.get localModuleName compilation.moduleAliases - |> Maybe.withDefault localModuleName + case Dict.get localModuleName compilation.moduleAliases of + Just aliasedModuleName -> + aliasedModuleName + + Nothing -> + localModuleName flatName = String.join "." (List.concat [ canonicalModuleName, [ nameInModule ] ]) in - case compilation.availableModules |> Dict.get canonicalModuleName of + case Dict.get canonicalModuleName compilation.availableModules of Nothing -> Err ("Did not find module '" @@ -2887,9 +2901,13 @@ emitModuleValue parsedModule = let typeDescriptions : List ( String, Pine.Value ) typeDescriptions = - parsedModule.typeDeclarations - |> Dict.toList - |> List.map (Tuple.mapSecond emitTypeDeclarationValue) + Dict.foldr + (\typeName typeDeclaration aggregate -> + ( typeName, emitTypeDeclarationValue typeDeclaration ) + :: aggregate + ) + [] + parsedModule.typeDeclarations emittedFunctions = Dict.toList parsedModule.functionDeclarations @@ -3048,10 +3066,12 @@ emitModuleFunctionDeclarations stackBefore declarations = (List.concat [ alreadyEmitted, [ emittedDomain ] ]) followingRecursionDomains in - emitRecursionDomainsRecursive - [] - recursionDomains - |> Result.map (\domains -> List.concatMap .exposedDeclarations domains) + case emitRecursionDomainsRecursive [] recursionDomains of + Err err -> + Err err + + Ok domains -> + Ok (List.concatMap .exposedDeclarations domains) emitRecursionDomain : @@ -3141,8 +3161,8 @@ emitRecursionDomain { exposedDeclarationsNames, allModuleDeclarations, usedImpor getFunctionInnerExpressionFromIndex declarationIndex = let getEnvFunctionsExpression = - Pine.environmentExpr - |> listItemFromIndexExpression_Pine 0 + listItemFromIndexExpression_Pine 0 + Pine.environmentExpr in Pine.LiteralExpression (Pine.encodeExpressionAsValue diff --git a/implement/pine/ElmTime/compile-elm-program/src/FirCompiler.elm b/implement/pine/ElmTime/compile-elm-program/src/FirCompiler.elm index 577f3a20..3f1b0e9f 100644 --- a/implement/pine/ElmTime/compile-elm-program/src/FirCompiler.elm +++ b/implement/pine/ElmTime/compile-elm-program/src/FirCompiler.elm @@ -259,8 +259,8 @@ emitExpressionInDeclarationBlock stackBeforeAddingDeps blockDeclarations mainExp { stackBeforeAddingDeps | declarationsDependencies = Dict.foldl - (\declName declExpression -> - Dict.insert declName (listDirectDependenciesOfExpression declExpression) + (\declName declExpression aggregate -> + Dict.insert declName (listDirectDependenciesOfExpression declExpression) aggregate ) stackBeforeAddingDeps.declarationsDependencies blockDeclarations @@ -366,19 +366,19 @@ emitDeclarationBlock stackBefore blockDeclarations config = availableEmittedDependencies : Dict.Dict String (Set.Set String) availableEmittedDependencies = Dict.foldl - (\_ ( availableEmitted, _ ) -> - Dict.insert - availableEmitted.functionName - (case availableEmitted.expectedEnvironment of - LocalEnvironment localEnv -> - Set.fromList localEnv.expectedDecls - - ImportedEnvironment _ -> - Set.empty - - IndependentEnvironment -> - Set.empty - ) + (\_ ( availableEmitted, _ ) aggregate -> + case availableEmitted.expectedEnvironment of + LocalEnvironment localEnv -> + Dict.insert + availableEmitted.functionName + (Set.fromList localEnv.expectedDecls) + aggregate + + ImportedEnvironment _ -> + aggregate + + IndependentEnvironment -> + aggregate ) Dict.empty stackBefore.importedFunctions @@ -386,8 +386,8 @@ emitDeclarationBlock stackBefore blockDeclarations config = blockDeclarationsDirectDependencies : Dict.Dict String (Set.Set String) blockDeclarationsDirectDependencies = Dict.foldl - (\declName declExpression -> - Dict.insert declName (listDirectDependenciesOfExpression declExpression) + (\declName declExpression aggregate -> + Dict.insert declName (listDirectDependenciesOfExpression declExpression) aggregate ) Dict.empty blockDeclarations @@ -981,9 +981,10 @@ listDirectDependenciesOfExpression expression = listDirectDependenciesOfExpression application.argument ConditionalExpression conditional -> - listDirectDependenciesOfExpression conditional.condition - |> Set.union (listDirectDependenciesOfExpression conditional.ifTrue) - |> Set.union (listDirectDependenciesOfExpression conditional.ifFalse) + Set.union (listDirectDependenciesOfExpression conditional.ifFalse) + (Set.union (listDirectDependenciesOfExpression conditional.ifTrue) + (listDirectDependenciesOfExpression conditional.condition) + ) ReferenceExpression reference -> Set.singleton reference @@ -996,9 +997,12 @@ listDirectDependenciesOfExpression expression = functionParamNames = List.foldl (\param aggregate -> - List.foldl Set.insert + List.foldl + (\( declName, _ ) declAggregate -> + Set.insert declName declAggregate + ) aggregate - (List.map Tuple.first param) + param ) Set.empty functionParam @@ -1289,11 +1293,11 @@ emitFunctionApplicationPine emitStack arguments functionExpressionPine = Ok functionRecord -> let combinedArguments = - [ List.map Pine.LiteralExpression - functionRecord.argumentsAlreadyCollected - , arguments - ] - |> List.concat + List.concat + [ List.map Pine.LiteralExpression + functionRecord.argumentsAlreadyCollected + , arguments + ] in if functionRecord.parameterCount /= List.length combinedArguments then Ok (genericPartialApplication ()) @@ -1302,9 +1306,8 @@ emitFunctionApplicationPine emitStack arguments functionExpressionPine = let mappedEnvironment = Pine.ListExpression - [ functionRecord.envFunctions - |> List.map Pine.LiteralExpression - |> Pine.ListExpression + [ Pine.ListExpression + (List.map Pine.LiteralExpression functionRecord.envFunctions) , Pine.ListExpression combinedArguments ] @@ -1348,36 +1351,39 @@ emitApplyFunctionFromCurrentEnvironment compilation { functionName } arguments = Just ( functionIndexInEnv, function ) -> let getEnvFunctionsExpression = - Pine.environmentExpr - |> listItemFromIndexExpression_Pine 0 + listItemFromIndexExpression_Pine + 0 + Pine.environmentExpr getFunctionExpression = - getEnvFunctionsExpression - |> listItemFromIndexExpression_Pine functionIndexInEnv + listItemFromIndexExpression_Pine + functionIndexInEnv + getEnvFunctionsExpression in case function.expectedEnvironment of ImportedEnvironment importedEnv -> let funcRecordLessTag = - getFunctionExpression - |> pineExpressionForDeconstructions importedEnv.pathToRecordFromEnvEntry + pineExpressionForDeconstructions + importedEnv.pathToRecordFromEnvEntry + getFunctionExpression {- The paths here mirror the composition in 'buildRecordOfPartiallyAppliedFunction' -} importedGetFunctionExpr = - funcRecordLessTag - |> pineExpressionForDeconstructions - [ ListItemDeconstruction 1 - , ListItemDeconstruction 0 - ] + pineExpressionForDeconstructions + [ ListItemDeconstruction 1 + , ListItemDeconstruction 0 + ] + funcRecordLessTag importedGetEnvFunctionsExpression = - funcRecordLessTag - |> pineExpressionForDeconstructions - [ ListItemDeconstruction 1 - , ListItemDeconstruction 2 - ] + pineExpressionForDeconstructions + [ ListItemDeconstruction 1 + , ListItemDeconstruction 2 + ] + funcRecordLessTag in Just (Ok @@ -1392,21 +1398,22 @@ emitApplyFunctionFromCurrentEnvironment compilation { functionName } arguments = } else - Pine.ParseAndEvalExpression - { expression = - Pine.ListExpression - [ Pine.LiteralExpression Pine.stringAsValue_Literal - , funcRecordLessTag - ] - , environment = - Pine.ListExpression - [ Pine.ListExpression [] - , Pine.ListExpression arguments - ] - } - |> partialApplicationExpressionFromListOfArguments - arguments - compilation + partialApplicationExpressionFromListOfArguments + arguments + compilation + (Pine.ParseAndEvalExpression + { expression = + Pine.ListExpression + [ Pine.LiteralExpression Pine.stringAsValue_Literal + , funcRecordLessTag + ] + , environment = + Pine.ListExpression + [ Pine.ListExpression [] + , Pine.ListExpression arguments + ] + } + ) ) ) @@ -1480,27 +1487,27 @@ emitApplyFunctionFromCurrentEnvironment compilation { functionName } arguments = } else - (if function.parameterCount == 0 then - Pine.ParseAndEvalExpression - { expression = getFunctionExpression - , environment = - Pine.ListExpression - [ expectedEnvironment - , Pine.ListExpression [] - ] - } - - else - buildRecordOfPartiallyAppliedFunction - { getFunctionInnerExpression = getFunctionExpression - , getEnvFunctionsExpression = expectedEnvironment - , parameterCount = function.parameterCount - , argumentsAlreadyCollected = [] - } - ) - |> partialApplicationExpressionFromListOfArguments - arguments - compilation + partialApplicationExpressionFromListOfArguments + arguments + compilation + (if function.parameterCount == 0 then + Pine.ParseAndEvalExpression + { expression = getFunctionExpression + , environment = + Pine.ListExpression + [ expectedEnvironment + , Pine.ListExpression [] + ] + } + + else + buildRecordOfPartiallyAppliedFunction + { getFunctionInnerExpression = getFunctionExpression + , getEnvFunctionsExpression = expectedEnvironment + , parameterCount = function.parameterCount + , argumentsAlreadyCollected = [] + } + ) ) ) @@ -1653,20 +1660,20 @@ adaptivePartialApplicationRecursiveExpression = listItemFromIndexExpression_Pine 1 functionLocalExpression innerFunction = - partiallyAppliedFunctionRecord - |> listItemFromIndexExpression_Pine 0 + listItemFromIndexExpression_Pine 0 + partiallyAppliedFunctionRecord numberOfParametersExpectedByInnerFunction = - partiallyAppliedFunctionRecord - |> listItemFromIndexExpression_Pine 1 + listItemFromIndexExpression_Pine 1 + partiallyAppliedFunctionRecord environmentFunctions = - partiallyAppliedFunctionRecord - |> listItemFromIndexExpression_Pine 2 + listItemFromIndexExpression_Pine 2 + partiallyAppliedFunctionRecord previouslyCollectedArguments = - partiallyAppliedFunctionRecord - |> listItemFromIndexExpression_Pine 3 + listItemFromIndexExpression_Pine 3 + partiallyAppliedFunctionRecord collectedArguments = Pine.KernelApplicationExpression @@ -2008,10 +2015,10 @@ searchForExpressionReduction expression = attemptReduceViaEval () Ok skipCount -> - expressionList - |> List.drop skipCount - |> Pine.ListExpression - |> Just + Just + (Pine.ListExpression + (List.drop skipCount expressionList) + ) _ -> attemptReduceViaEval () @@ -2364,19 +2371,36 @@ estimatePineValueSize value = 10 + List.length blob Pine.ListValue list -> - -- Reduce stack depths by matching the most common cases with up to two elements inline. - case list of - [] -> - 10 - - [ single ] -> - 10 + estimatePineValueSize single - - first :: second :: remaining -> - 10 - + estimatePineValueSize first - + estimatePineValueSize second - + List.foldl - (\item sum -> sum + estimatePineValueSize item) - 0 - remaining + 10 + estimatePineListValueSizeHelper 0 list + + +estimatePineListValueSizeHelper : Int -> List Pine.Value -> Int +estimatePineListValueSizeHelper accumulated list = + -- Reduce stack depths by matching the most common cases with few elements inline. + case list of + [] -> + accumulated + + [ first ] -> + accumulated + + estimatePineValueSize first + + [ first, second ] -> + accumulated + + estimatePineValueSize first + + estimatePineValueSize second + + [ first, second, third ] -> + accumulated + + estimatePineValueSize first + + estimatePineValueSize second + + estimatePineValueSize third + + first :: second :: third :: remaining -> + estimatePineListValueSizeHelper + (accumulated + + estimatePineValueSize first + + estimatePineValueSize second + + estimatePineValueSize third + ) + remaining diff --git a/implement/pine/Program.cs b/implement/pine/Program.cs index 2c59284d..2a04ebc0 100644 --- a/implement/pine/Program.cs +++ b/implement/pine/Program.cs @@ -18,7 +18,7 @@ namespace ElmTime; public class Program { - public static string AppVersionId => "0.3.9"; + public static string AppVersionId => "0.3.10"; private static int AdminInterfaceDefaultPort => 4000; diff --git a/implement/pine/pine.csproj b/implement/pine/pine.csproj index e89e1d32..82940f5f 100644 --- a/implement/pine/pine.csproj +++ b/implement/pine/pine.csproj @@ -4,8 +4,8 @@ Exe net8.0 pine - 0.3.9 - 0.3.9 + 0.3.10 + 0.3.10 enable true