From e607d5d0567fdf6d3f8591dcf75039193e121977 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Michael=20R=C3=A4tzel?= Date: Tue, 2 Jan 2024 17:04:35 +0000 Subject: [PATCH] Optimize compiler code to reduce compile times Refactor the implementation of the Elm compiler in various places to reduce memory allocations and transformation steps during compilation. --- .../src/ElmInteractive.elm | 100 +++---- .../compile-elm-program/src/FirCompiler.elm | 19 +- .../ElmTime/compile-elm-program/src/Hex.elm | 90 ++++++ .../ElmTime/compile-elm-program/src/Pine.elm | 283 +++++++++--------- implement/elm-time/Program.cs | 2 +- implement/elm-time/elm-time.csproj | 4 +- 6 files changed, 291 insertions(+), 207 deletions(-) create mode 100644 implement/elm-time/ElmTime/compile-elm-program/src/Hex.elm diff --git a/implement/elm-time/ElmTime/compile-elm-program/src/ElmInteractive.elm b/implement/elm-time/ElmTime/compile-elm-program/src/ElmInteractive.elm index e134b0d7..0e458bed 100644 --- a/implement/elm-time/ElmTime/compile-elm-program/src/ElmInteractive.elm +++ b/implement/elm-time/ElmTime/compile-elm-program/src/ElmInteractive.elm @@ -707,51 +707,34 @@ compilationAndEmitStackFromInteractiveEnvironment environmentDeclarations = json_encode_pineValue : Dict.Dict String Pine.Value -> Pine.Value -> Json.Encode.Value json_encode_pineValue dictionary value = let - blobDict = - dictionary - |> Dict.toList - |> List.filterMap - (\( entryName, entryValue ) -> - case entryValue of - Pine.BlobValue blob -> - Just ( blob, entryName ) - - _ -> - Nothing - ) - |> Dict.fromList - - listDict = - dictionary - |> Dict.toList - |> List.filterMap - (\( entryName, entryValue ) -> - case entryValue of - Pine.ListValue list -> - Just ( list, entryName ) + dicts = + Dict.foldl + (\entryName entryValue aggregate -> + case entryValue of + Pine.BlobValue blob -> + { aggregate + | blobDict = Dict.insert blob entryName aggregate.blobDict + } + + Pine.ListValue list -> + let + hash = + pineListValueFastHash list - _ -> - Nothing - ) - |> List.foldl - (\( nextList, nextName ) intermediateDict -> - let - hash = - pineListValueFastHash nextList - - assocList = - intermediateDict - |> Dict.get hash - |> Maybe.withDefault [] - |> (::) ( nextList, nextName ) - in - intermediateDict - |> Dict.insert hash assocList - ) - Dict.empty + assocList = + Dict.get hash aggregate.listDict + |> Maybe.withDefault [] + |> (::) ( list, entryName ) + in + { aggregate + | listDict = Dict.insert hash assocList aggregate.listDict + } + ) + { blobDict = Dict.empty, listDict = Dict.empty } + dictionary in json_encode_pineValue_Internal - { blobDict = blobDict, listDict = listDict } + dicts value @@ -971,20 +954,25 @@ json_decode_pineValueGeneric config = pineListValueFastHash : List Pine.Value -> Int pineListValueFastHash list = - list - |> List.indexedMap - (\index entry -> - (case entry of - Pine.BlobValue blob -> - 71 * List.length blob - - Pine.ListValue innerList -> - 7919 * List.length innerList - ) - * (index + 1) - ) - |> List.sum - |> (+) (List.length list) + let + calculateEntryHash : Pine.Value -> Int + calculateEntryHash entry = + case entry of + Pine.BlobValue blob -> + 71 * List.length blob + + Pine.ListValue innerList -> + 7919 * List.length innerList + in + case list of + [] -> + 8831 + + [ entry ] -> + calculateEntryHash entry * 31 + + entry1 :: entry2 :: _ -> + calculateEntryHash entry1 * 41 + calculateEntryHash entry2 * 47 + List.length list json_decode_optionalNullableField : String -> Json.Decode.Decoder a -> Json.Decode.Decoder (Maybe a) diff --git a/implement/elm-time/ElmTime/compile-elm-program/src/FirCompiler.elm b/implement/elm-time/ElmTime/compile-elm-program/src/FirCompiler.elm index 21413868..e84dfbdb 100644 --- a/implement/elm-time/ElmTime/compile-elm-program/src/FirCompiler.elm +++ b/implement/elm-time/ElmTime/compile-elm-program/src/FirCompiler.elm @@ -193,19 +193,18 @@ emitExpressionInDeclarationBlock stackBeforeAddingDeps blockDeclarations mainExp importedModulesDeclarationsFlat : Dict.Dict String Expression importedModulesDeclarationsFlat = stackBeforeAddingDeps.moduleImports.importedModules - |> Dict.toList - |> List.concatMap - (\( moduleName, importedModule ) -> + |> Dict.foldl + (\moduleName importedModule aggregate -> importedModule.declarations - |> Dict.toList - |> List.map - (\( declName, declValue ) -> - ( String.join "." (moduleName ++ [ declName ]) - , LiteralExpression declValue - ) + |> Dict.foldl + (\declName declValue -> + Dict.insert + (String.join "." (moduleName ++ [ declName ])) + (LiteralExpression declValue) ) + aggregate ) - |> Dict.fromList + Dict.empty importedDeclarations : Dict.Dict String Expression importedDeclarations = diff --git a/implement/elm-time/ElmTime/compile-elm-program/src/Hex.elm b/implement/elm-time/ElmTime/compile-elm-program/src/Hex.elm new file mode 100644 index 00000000..2a425bb4 --- /dev/null +++ b/implement/elm-time/ElmTime/compile-elm-program/src/Hex.elm @@ -0,0 +1,90 @@ +module Hex exposing (..) + +{-| Convert a decimal integer to a hexdecimal string such as `"abc94f"`. + + Hex.toString 165 == "a5" + +-} + + +toString : Int -> String +toString num = + String.fromList + (if num < 0 then + '-' :: unsafePositiveToDigits [] (negate num) + + else + unsafePositiveToDigits [] num + ) + + +{-| ONLY EVER CALL THIS WITH POSITIVE INTEGERS! +-} +unsafePositiveToDigits : List Char -> Int -> List Char +unsafePositiveToDigits digits num = + if num < 16 then + unsafeToDigit num :: digits + + else + unsafePositiveToDigits (unsafeToDigit (modBy 16 num) :: digits) (num // 16) + + +{-| ONLY EVER CALL THIS WITH INTEGERS BETWEEN 0 and 15! +-} +unsafeToDigit : Int -> Char +unsafeToDigit num = + case num of + 0 -> + '0' + + 1 -> + '1' + + 2 -> + '2' + + 3 -> + '3' + + 4 -> + '4' + + 5 -> + '5' + + 6 -> + '6' + + 7 -> + '7' + + 8 -> + '8' + + 9 -> + '9' + + 10 -> + 'a' + + 11 -> + 'b' + + 12 -> + 'c' + + 13 -> + 'd' + + 14 -> + 'e' + + 15 -> + 'f' + + _ -> + -- if this ever gets called with a number over 15, it will never + -- terminate! If that happens, debug further by uncommenting this: + -- + -- Debug.todo ("Tried to convert " ++ toString num ++ " to hexadecimal.") + unsafeToDigit num diff --git a/implement/elm-time/ElmTime/compile-elm-program/src/Pine.elm b/implement/elm-time/ElmTime/compile-elm-program/src/Pine.elm index 349567e6..aa79459c 100644 --- a/implement/elm-time/ElmTime/compile-elm-program/src/Pine.elm +++ b/implement/elm-time/ElmTime/compile-elm-program/src/Pine.elm @@ -2,6 +2,7 @@ module Pine exposing (..) import BigInt import Dict +import Hex import Maybe.Extra import Result.Extra @@ -146,21 +147,6 @@ valueFromContextExpansionWithName ( declName, declValue ) = ListValue [ valueFromString declName, declValue ] -namedValueFromValue : Value -> Maybe ( String, Value ) -namedValueFromValue value = - case value of - ListValue [ elementLabelCandidate, elementValue ] -> - case stringFromValue elementLabelCandidate of - Ok elementLabel -> - Just ( elementLabel, elementValue ) - - Err _ -> - Nothing - - _ -> - Nothing - - kernelFunctions : Dict.Dict String KernelFunction kernelFunctions = [ ( "equal" @@ -599,23 +585,36 @@ stringFromValue value = stringFromListValue : List Value -> Result String String -stringFromListValue = - List.map - (bigIntFromUnsignedValue - >> Result.fromMaybe "Failed to map to big int" - >> Result.andThen intFromBigInt - >> Result.andThen - (\int -> - if int <= 0xFFFF then - Ok int +stringFromListValue values = + let + continueRecursive : List Value -> List Char -> Result String (List Char) + continueRecursive remaining processed = + case remaining of + [] -> + Ok processed + + value :: rest -> + case value of + BlobValue intValueBytes -> + case intValueBytes of + [ b1 ] -> + continueRecursive rest (Char.fromCode b1 :: processed) + + [ b1, b2 ] -> + continueRecursive rest (Char.fromCode ((b1 * 256) + b2) :: processed) + + _ -> + Err + ("Failed to map to int - unsupported number of bytes: " + ++ String.fromInt (List.length intValueBytes) + ) - else - Err "Avoiding codes above 0xFFFF since transfer encoding failed for 0x10000." - ) - ) - >> Result.Extra.combine - >> Result.mapError ((++) "Failed to map list items to chars: ") - >> Result.map (List.map Char.fromCode >> String.fromList) + _ -> + Err "Failed to map to int - not a BlobValue" + in + continueRecursive values [] + |> Result.mapError ((++) "Failed to map list items to chars: ") + |> Result.map (String.fromList >> String.reverse) valueFromBigInt : BigInt.BigInt -> Value @@ -722,16 +721,6 @@ bigIntFromBlobValue blobValue = Err ("Unexpected value for sign byte of integer: " ++ String.fromInt sign) -bigIntFromUnsignedValue : Value -> Maybe BigInt.BigInt -bigIntFromUnsignedValue value = - case value of - BlobValue intValueBytes -> - Just (bigIntFromUnsignedBlobValue intValueBytes) - - _ -> - Nothing - - bigIntFromUnsignedBlobValue : List Int -> BigInt.BigInt bigIntFromUnsignedBlobValue intValueBytes = intValueBytes @@ -744,8 +733,7 @@ bigIntFromUnsignedBlobValue intValueBytes = hexadecimalRepresentationFromBlobValue : List Int -> String hexadecimalRepresentationFromBlobValue = - List.map BigInt.fromInt - >> List.map (BigInt.toHexString >> String.padLeft 2 '0') + List.map (Hex.toString >> String.padLeft 2 '0') >> String.join "" @@ -808,66 +796,71 @@ encodeExpressionAsValue expression = decodeExpressionFromValue : Value -> Result String Expression -decodeExpressionFromValue value = - value - |> decodeUnionFromPineValue - (Dict.fromList - [ ( "Literal" - , LiteralExpression >> Ok - ) - , ( "List" - , decodePineListValue - >> Result.andThen - (List.indexedMap - (\itemIndex item -> - item +decodeExpressionFromValue = + decodeUnionFromPineValue decodeExpressionFromValueDict + + +decodeExpressionFromValueDict : Dict.Dict String (Value -> Result String Expression) +decodeExpressionFromValueDict = + Dict.fromList + [ ( "Literal" + , LiteralExpression >> Ok + ) + , ( "List" + , decodePineListValue + >> Result.andThen + (List.indexedMap + (\itemIndex item -> + item + |> decodeExpressionFromValue + |> Result.mapError ((++) ("Failed to decode item at index " ++ String.fromInt itemIndex ++ ": ")) + ) + >> Result.Extra.combine + ) + >> Result.map ListExpression + ) + , ( "DecodeAndEvaluate" + , decodeDecodeAndEvaluateExpression >> Result.map DecodeAndEvaluateExpression + ) + , ( "KernelApplication" + , decodeKernelApplicationExpression >> Result.map KernelApplicationExpression + ) + , ( "Conditional" + , decodeConditionalExpression >> Result.map ConditionalExpression + ) + , ( "Environment" + , always (Ok EnvironmentExpression) + ) + , ( "StringTag" + , decodePineListValue + >> Result.andThen decodeListWithExactlyTwoElements + >> Result.andThen + (\( tagValue, taggedValue ) -> + tagValue + |> stringFromValue + |> Result.mapError ((++) "Failed to decode tag: ") + |> Result.andThen + (\tag -> + taggedValue |> decodeExpressionFromValue - |> Result.mapError ((++) ("Failed to decode item at index " ++ String.fromInt itemIndex ++ ": ")) + |> Result.mapError ((++) "Failed to decoded tagged expression: ") + |> Result.map (\tagged -> StringTagExpression tag tagged) ) - >> Result.Extra.combine - ) - >> Result.map ListExpression - ) - , ( "DecodeAndEvaluate" - , decodeDecodeAndEvaluateExpression >> Result.map DecodeAndEvaluateExpression - ) - , ( "KernelApplication" - , decodeKernelApplicationExpression >> Result.map KernelApplicationExpression - ) - , ( "Conditional" - , decodeConditionalExpression >> Result.map ConditionalExpression - ) - , ( "Environment" - , always (Ok EnvironmentExpression) - ) - , ( "StringTag" - , decodePineListValue - >> Result.andThen decodeListWithExactlyTwoElements - >> Result.andThen - (\( tagValue, taggedValue ) -> - tagValue - |> stringFromValue - |> Result.mapError ((++) "Failed to decode tag: ") - |> Result.andThen - (\tag -> - taggedValue - |> decodeExpressionFromValue - |> Result.mapError ((++) "Failed to decoded tagged expression: ") - |> Result.map (\tagged -> StringTagExpression tag tagged) - ) - ) - ) - ] - ) + ) + ) + ] decodeDecodeAndEvaluateExpression : Value -> Result String DecodeAndEvaluateExpressionStructure decodeDecodeAndEvaluateExpression = decodeRecordFromPineValue >> Result.andThen - (always (Ok DecodeAndEvaluateExpressionStructure) - |> decodeRecordField "expression" decodeExpressionFromValue - |> decodeRecordField "environment" decodeExpressionFromValue + (\recordDict -> + (always (Ok DecodeAndEvaluateExpressionStructure) + |> decodeRecordField "expression" decodeExpressionFromValue + |> decodeRecordField "environment" decodeExpressionFromValue + ) + recordDict ) @@ -875,17 +868,20 @@ decodeKernelApplicationExpression : Value -> Result String KernelApplicationExpr decodeKernelApplicationExpression = decodeRecordFromPineValue >> Result.andThen - (always (Ok KernelApplicationExpressionStructure) - |> decodeRecordField "functionName" - (stringFromValue - >> Result.andThen - (\functionName -> - functionName - |> decodeKernelFunctionFromName - |> Result.map (always functionName) - ) - ) - |> decodeRecordField "argument" decodeExpressionFromValue + (\recordDict -> + (always (Ok KernelApplicationExpressionStructure) + |> decodeRecordField "functionName" + (stringFromValue + >> Result.andThen + (\functionName -> + functionName + |> decodeKernelFunctionFromName + |> Result.map (always functionName) + ) + ) + |> decodeRecordField "argument" decodeExpressionFromValue + ) + recordDict ) @@ -910,10 +906,13 @@ decodeConditionalExpression : Value -> Result String ConditionalExpressionStruct decodeConditionalExpression = decodeRecordFromPineValue >> Result.andThen - (always (Ok ConditionalExpressionStructure) - |> decodeRecordField "condition" decodeExpressionFromValue - |> decodeRecordField "ifTrue" decodeExpressionFromValue - |> decodeRecordField "ifFalse" decodeExpressionFromValue + (\recordDict -> + (always (Ok ConditionalExpressionStructure) + |> decodeRecordField "condition" decodeExpressionFromValue + |> decodeRecordField "ifTrue" decodeExpressionFromValue + |> decodeRecordField "ifFalse" decodeExpressionFromValue + ) + recordDict ) @@ -942,39 +941,47 @@ decodeRecordField fieldName fieldDecoder finalDecoder = decodeRecordFromPineValue : Value -> Result String (Dict.Dict String Value) decodeRecordFromPineValue = + let + parseListRecursively : Dict.Dict String Value -> List Value -> Result String (Dict.Dict String Value) + parseListRecursively aggregate remaining = + case remaining of + [] -> + Ok aggregate + + fieldAsValue :: rest -> + fieldAsValue + |> decodePineListValue + |> Result.andThen + (\fieldList -> + case fieldList of + [ fieldNameValue, fieldValue ] -> + stringFromValue fieldNameValue + |> Result.mapError ((++) "Failed to decode field name string: ") + |> Result.andThen + (\fieldName -> + parseListRecursively + (Dict.insert fieldName fieldValue aggregate) + rest + ) + + _ -> + Err + ("Unexpected number of list items for field: " + ++ String.fromInt (List.length fieldList) + ) + ) + in decodePineListValue - >> Result.andThen - (List.foldl - (\fieldAsValue -> - Result.andThen - (\fields -> - fieldAsValue - |> decodePineListValue - |> Result.andThen - (\fieldList -> - case fieldList of - [ fieldNameValue, fieldValue ] -> - stringFromValue fieldNameValue - |> Result.mapError ((++) "Failed to decode field name string: ") - |> Result.map (\fieldName -> ( fieldName, fieldValue ) :: fields) - - _ -> - Err ("Unexpected number of list items for field: " ++ String.fromInt (List.length fieldList)) - ) - ) - ) - (Ok []) - ) - >> Result.map Dict.fromList + >> Result.andThen (parseListRecursively Dict.empty) encodeRecordToPineValue : Dict.Dict String Value -> Value encodeRecordToPineValue = - Dict.toList - >> List.map - (\( fieldName, fieldValue ) -> - ListValue [ valueFromString fieldName, fieldValue ] - ) + Dict.foldr + (\fieldName fieldValue aggregate -> + ListValue [ valueFromString fieldName, fieldValue ] :: aggregate + ) + [] >> ListValue diff --git a/implement/elm-time/Program.cs b/implement/elm-time/Program.cs index 7cd43b84..d1b27669 100644 --- a/implement/elm-time/Program.cs +++ b/implement/elm-time/Program.cs @@ -18,7 +18,7 @@ namespace ElmTime; public class Program { - public static string AppVersionId => "2024-01-01"; + public static string AppVersionId => "2024-01-02"; private static int AdminInterfaceDefaultPort => 4000; diff --git a/implement/elm-time/elm-time.csproj b/implement/elm-time/elm-time.csproj index 95681706..65150a0c 100644 --- a/implement/elm-time/elm-time.csproj +++ b/implement/elm-time/elm-time.csproj @@ -5,8 +5,8 @@ net8.0 ElmTime elm-time - 2024.0101.0.0 - 2024.0101.0.0 + 2024.0102.0.0 + 2024.0102.0.0 enable true