From fef37a86ee6801e1532e44546dbeb6236ffd999b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Czajka?= <62751+lukaszcz@users.noreply.github.com> Date: Fri, 28 Jun 2024 18:23:27 +0200 Subject: [PATCH] Optimize `letFunctionDefs` in `Juvix.Compiler.Internal.Data.InfoTable` (#2867) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Closes #2394 * Removes the use of Uniplate in `letFunctionDefs` altogether, in favour of handwritten traversal accumulating let definitions (implemented via the new `HasLetDefs` typeclass). Benchmark results ------------------ Using Uniplate: ``` heliax@imac bench % hyperfine --prepare 'juvix clean --global' -w 1 'juvix typecheck bench.juvix -N 1' Benchmark 1: juvix typecheck bench.juvix -N 1 Time (mean ± σ): 1.399 s ± 0.023 s [User: 1.346 s, System: 0.041 s] Range (min … max): 1.374 s … 1.452 s 10 runs ``` Using `HasLetDefs`: ``` heliax@imac bench % hyperfine --prepare 'juvix clean --global' -w 1 'juvix typecheck bench.juvix -N 1' Benchmark 1: juvix typecheck bench.juvix -N 1 Time (mean ± σ): 1.098 s ± 0.015 s [User: 1.047 s, System: 0.040 s] Range (min … max): 1.074 s … 1.120 s 10 runs ``` So it's roughly 1.1s vs. 1.4s, faster by 0.2s. About 14% improvement. The benchmark file just imports the standard library: ``` module bench; import Stdlib.Prelude open; main : Nat := 0; ``` Both `juvix` binaries were compiled with optimizations, using `just install`. --- src/Juvix/Compiler/Internal/Data/InfoTable.hs | 6 +- src/Juvix/Compiler/Internal/Extra/Base.hs | 7 -- .../Compiler/Internal/Extra/HasLetDefs.hs | 103 ++++++++++++++++++ 3 files changed, 106 insertions(+), 10 deletions(-) create mode 100644 src/Juvix/Compiler/Internal/Extra/HasLetDefs.hs diff --git a/src/Juvix/Compiler/Internal/Data/InfoTable.hs b/src/Juvix/Compiler/Internal/Data/InfoTable.hs index 6813aaf20..efe550d70 100644 --- a/src/Juvix/Compiler/Internal/Data/InfoTable.hs +++ b/src/Juvix/Compiler/Internal/Data/InfoTable.hs @@ -20,10 +20,10 @@ module Juvix.Compiler.Internal.Data.InfoTable ) where -import Data.Generics.Uniplate.Data import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Internal.Extra import Juvix.Compiler.Internal.Extra.CoercionInfo +import Juvix.Compiler.Internal.Extra.HasLetDefs import Juvix.Compiler.Internal.Extra.InstanceInfo import Juvix.Compiler.Internal.Pretty (ppTrace) import Juvix.Compiler.Store.Internal.Data.FunctionsTable @@ -69,11 +69,11 @@ extendWithReplExpression e = ) ) -letFunctionDefs :: (Data from) => from -> [FunctionDef] +letFunctionDefs :: (HasLetDefs a) => a -> [FunctionDef] letFunctionDefs e = concat [ concatMap (toList . flattenClause) _letClauses - | Let {..} <- universeBi e + | Let {..} <- letDefs e ] where flattenClause :: LetClause -> NonEmpty FunctionDef diff --git a/src/Juvix/Compiler/Internal/Extra/Base.hs b/src/Juvix/Compiler/Internal/Extra/Base.hs index 35d243d64..0c3502f07 100644 --- a/src/Juvix/Compiler/Internal/Extra/Base.hs +++ b/src/Juvix/Compiler/Internal/Extra/Base.hs @@ -1,6 +1,5 @@ module Juvix.Compiler.Internal.Extra.Base where -import Data.Generics.Uniplate.Data hiding (holes) import Data.HashMap.Strict qualified as HashMap import Data.HashSet qualified as HashSet import Juvix.Compiler.Internal.Data.LocalVars @@ -766,12 +765,6 @@ isSmallUniverse' = \case ExpressionUniverse {} -> True _ -> False -allTypeSignatures :: (Data a) => a -> [Expression] -allTypeSignatures a = - [f ^. funDefType | f@FunctionDef {} <- universeBi a] - <> [f ^. axiomType | f@AxiomDef {} <- universeBi a] - <> [f ^. inductiveType | f@InductiveDef {} <- universeBi a] - explicitPatternArg :: Pattern -> PatternArg explicitPatternArg _patternArgPattern = PatternArg diff --git a/src/Juvix/Compiler/Internal/Extra/HasLetDefs.hs b/src/Juvix/Compiler/Internal/Extra/HasLetDefs.hs new file mode 100644 index 000000000..517aa81c3 --- /dev/null +++ b/src/Juvix/Compiler/Internal/Extra/HasLetDefs.hs @@ -0,0 +1,103 @@ +module Juvix.Compiler.Internal.Extra.HasLetDefs where + +import Juvix.Compiler.Internal.Language +import Juvix.Prelude + +class HasLetDefs a where + letDefs' :: [Let] -> a -> [Let] + letDefs :: a -> [Let] + letDefs = letDefs' [] + +instance (HasLetDefs a, Foldable f) => HasLetDefs (f a) where + letDefs' = foldl' letDefs' + +instance HasLetDefs Expression where + letDefs' acc = \case + ExpressionIden {} -> acc + ExpressionApplication x -> letDefs' acc x + ExpressionFunction x -> letDefs' acc x + ExpressionLiteral {} -> acc + ExpressionHole {} -> acc + ExpressionInstanceHole {} -> acc + ExpressionLet x -> letDefs' acc x + ExpressionUniverse {} -> acc + ExpressionSimpleLambda x -> letDefs' acc x + ExpressionLambda x -> letDefs' acc x + ExpressionCase x -> letDefs' acc x + +instance HasLetDefs Application where + letDefs' acc Application {..} = letDefs' (letDefs' acc _appLeft) _appRight + +instance HasLetDefs Function where + letDefs' acc Function {..} = letDefs' (letDefs' acc _functionLeft) _functionRight + +instance HasLetDefs FunctionParameter where + letDefs' acc FunctionParameter {..} = letDefs' acc _paramType + +instance HasLetDefs Let where + letDefs' acc x@Let {..} = x : letDefs' (letDefs' acc _letExpression) _letClauses + +instance HasLetDefs LetClause where + letDefs' acc = \case + LetFunDef x -> letDefs' acc x + LetMutualBlock x -> letDefs' acc x + +instance HasLetDefs SimpleLambda where + letDefs' acc SimpleLambda {..} = letDefs' (letDefs' acc _slambdaBinder) _slambdaBody + +instance HasLetDefs SimpleBinder where + letDefs' acc SimpleBinder {..} = letDefs' acc _sbinderType + +instance HasLetDefs Lambda where + letDefs' acc Lambda {..} = letDefs' (letDefs' acc _lambdaType) _lambdaClauses + +instance HasLetDefs LambdaClause where + letDefs' acc LambdaClause {..} = letDefs' (letDefs' acc _lambdaBody) _lambdaPatterns + +instance HasLetDefs PatternArg where + letDefs' acc PatternArg {..} = letDefs' acc _patternArgPattern + +instance HasLetDefs Pattern where + letDefs' acc = \case + PatternVariable {} -> acc + PatternConstructorApp x -> letDefs' acc x + PatternWildcardConstructor {} -> acc + +instance HasLetDefs ConstructorApp where + letDefs' acc ConstructorApp {..} = letDefs' (letDefs' acc _constrAppType) _constrAppParameters + +instance HasLetDefs Case where + letDefs' acc Case {..} = letDefs' (letDefs' acc _caseExpression) _caseBranches + +instance HasLetDefs CaseBranch where + letDefs' acc CaseBranch {..} = letDefs' acc _caseBranchExpression + +instance HasLetDefs MutualBlockLet where + letDefs' acc MutualBlockLet {..} = letDefs' acc _mutualLet + +instance HasLetDefs MutualBlock where + letDefs' acc MutualBlock {..} = letDefs' acc _mutualStatements + +instance HasLetDefs MutualStatement where + letDefs' acc = \case + StatementInductive x -> letDefs' acc x + StatementFunction x -> letDefs' acc x + StatementAxiom x -> letDefs' acc x + +instance HasLetDefs InductiveDef where + letDefs' acc InductiveDef {..} = letDefs' (letDefs' (letDefs' acc _inductiveType) _inductiveConstructors) _inductiveParameters + +instance HasLetDefs InductiveParameter where + letDefs' acc InductiveParameter {..} = letDefs' acc _inductiveParamType + +instance HasLetDefs ConstructorDef where + letDefs' acc ConstructorDef {..} = letDefs' acc _inductiveConstructorType + +instance HasLetDefs FunctionDef where + letDefs' acc FunctionDef {..} = letDefs' (letDefs' (letDefs' acc _funDefType) _funDefBody) _funDefArgsInfo + +instance HasLetDefs ArgInfo where + letDefs' acc ArgInfo {..} = letDefs' acc _argInfoDefault + +instance HasLetDefs AxiomDef where + letDefs' acc AxiomDef {..} = letDefs' acc _axiomType