From 0149ba0da739126aac8d3447ff394d27572f1179 Mon Sep 17 00:00:00 2001 From: Sam Griffin Date: Thu, 16 Nov 2023 14:58:34 -0500 Subject: [PATCH] profiling support and optimizing d2c in Prelude --- Prelude.tel | 8 +++---- bench/MemoryBench.hs | 18 ++++---------- flake.nix | 19 ++++++++------- src/Telomare.hs | 10 ++++---- src/Telomare/Possible.hs | 51 ---------------------------------------- telomare.cabal | 14 ++++++++--- 6 files changed, 34 insertions(+), 86 deletions(-) diff --git a/Prelude.tel b/Prelude.tel index 4acb23e..e656b53 100644 --- a/Prelude.tel +++ b/Prelude.tel @@ -8,10 +8,10 @@ not = \x -> if x then 0 else 1 succ = \x -> (x,0) -d2c = { id - , \recur i f b -> f (recur (left i) f b) - , \i f b -> b - } +d2c = \n f b -> { id + , \recur i -> f (recur (left i)) + , \i -> b + } n c2d = \c -> c succ 0 diff --git a/bench/MemoryBench.hs b/bench/MemoryBench.hs index afe0960..b516fc3 100644 --- a/bench/MemoryBench.hs +++ b/bench/MemoryBench.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CApiFFI #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,7 +22,7 @@ import Telomare.TypeChecker (TypeCheckError (..), inferType, typeCheck) import MemoryBench.Cases -import MemoryBench.LLVM +-- import MemoryBench.LLVM import Paths_telomare import Text.Parsec.Error (ParseError) @@ -32,8 +31,6 @@ import Weigh hiding (Case, Max) import Debug.Trace -foreign import capi "gc.h GC_INIT" gcInit :: IO () -foreign import ccall "gc.h GC_allow_register_threads" gcAllowRegisterThreads :: IO () -- TODO: -- Get some expressions/groups of expressions. -- Measure memory needed to: @@ -46,17 +43,15 @@ foreign import ccall "gc.h GC_allow_register_threads" gcAllowRegisterThreads :: instance NFData ParseError where rnf a = () +type Bindings = [(String, UnprocessedParsedTerm)] processCase :: Bindings -> Case -> Weigh () processCase bindings (Case label code) = do - let e_parsed = parseMain bindings code - (Right parsed) = e_parsed --Taking advantage of lazy evalutation here - details = benchLLVMDetails parsed + let e_parsed = fmap toTelomare $ parseMain bindings code + (Right (Just parsed)) = e_parsed --Taking advantage of lazy evalutation here let parsing = func "parsing" (parseMain bindings) code -- Parsing evals = [ io "simpleEval" benchEvalSimple parsed - , io "fasterEval" benchEvalFaster parsed , io "optimizedEval" benchEvalOptimized parsed - , details ] weighs = if isRight e_parsed then sequence_ (parsing : evals) @@ -69,9 +64,6 @@ processAllCases bindings cases = mapM_ (processCase bindings) cases benchEvalSimple :: IExpr -> IO IExpr benchEvalSimple iexpr = simpleEval (SetEnv (Pair (Defer iexpr) Zero)) -benchEvalFaster :: IExpr -> IO IExpr -benchEvalFaster iexpr = fasterEval (SetEnv (Pair (Defer iexpr) Zero)) - benchEvalOptimized :: IExpr -> IO IExpr benchEvalOptimized iexpr = optimizedEval (SetEnv (Pair (Defer iexpr) Zero)) @@ -79,8 +71,6 @@ config :: Config config = Config [Weigh.Case, Allocated, GCs, Live] "" Plain main = do - gcInit - gcAllowRegisterThreads preludeFile <- Strict.readFile "Prelude.tel" let diff --git a/flake.nix b/flake.nix index 49160e9..3a8ad82 100644 --- a/flake.nix +++ b/flake.nix @@ -36,9 +36,12 @@ # hl.dontHaddock ]; - overrides = self: super: { - sbv = pkgs.haskell.lib.compose.markUnbroken (pkgs.haskell.lib.dontCheck super.sbv); - }; + overrides = self: super: { + sbv = pkgs.haskell.lib.compose.markUnbroken (pkgs.haskell.lib.dontCheck super.sbv); + }; + + # uncomment for profiling: + # cabal2nixOptions = "--enable-profiling --benchmark"; }; in { @@ -51,13 +54,11 @@ cabal-install haskell-language-server hlint - ghcid - # stylish-haskell - hvm.defaultPackage. "x86_64-linux" - - + ghcid + # stylish-haskell + hvm.defaultPackage. "x86_64-linux" ]); - + checks = { build = self.packages.${system}.default; test-suit = project "telomare-test" [ ]; diff --git a/src/Telomare.hs b/src/Telomare.hs index 91b486d..6bf1f1a 100644 --- a/src/Telomare.hs +++ b/src/Telomare.hs @@ -250,7 +250,7 @@ data FragExpr a | RightFrag (FragExpr a) | TraceFrag | AuxFrag a - deriving (Eq, Ord) + deriving (Eq, Ord, Generic, NFData) makeBaseFunctor ''FragExpr -- Functorial version FragExprF. instance Plated (FragExpr a) where @@ -281,15 +281,15 @@ instance Show a => Show (FragExpr a) where newtype EIndex = EIndex { unIndex :: Int } deriving (Eq, Show, Ord) -newtype UnsizedRecursionToken = UnsizedRecursionToken { unUnsizedRecursionToken :: Int } deriving (Eq, Ord, Show, Enum) +newtype UnsizedRecursionToken = UnsizedRecursionToken { unUnsizedRecursionToken :: Int } deriving (Eq, Ord, Show, Enum, NFData, Generic) data RecursionSimulationPieces a = NestedSetEnvs UnsizedRecursionToken | SizingWrapper UnsizedRecursionToken a - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, NFData, Generic) newtype FragExprUR = FragExprUR { unFragExprUR :: FragExpr (RecursionSimulationPieces FragExprUR) } - deriving (Eq, Show) + deriving (Eq, Show, NFData, Generic) type RecursionPieceFrag = RecursionSimulationPieces FragExprUR @@ -297,7 +297,7 @@ type Term1 = ParserTerm String String type Term2 = ParserTerm () Int -- |Term3 :: Map FragIndex (FragExpr BreakExtras) -> Term3 -newtype Term3 = Term3 (Map FragIndex FragExprUR) deriving (Eq, Show) +newtype Term3 = Term3 (Map FragIndex FragExprUR) deriving (Eq, Show, Generic, NFData) newtype Term4 = Term4 (Map FragIndex (FragExpr Void)) deriving (Eq, Show) type BreakState a b = State (b, FragIndex, Map FragIndex (FragExpr a)) diff --git a/src/Telomare/Possible.hs b/src/Telomare/Possible.hs index 1587642..917cbfa 100644 --- a/src/Telomare/Possible.hs +++ b/src/Telomare/Possible.hs @@ -839,21 +839,6 @@ term3ToUnsizedExpr maxSize (Term3 termMap) = AuxFrag (NestedSetEnvs t) -> embedU . UnsizedStubF t . embed $ embedB EnvSF in convertFrag' . unFragExprUR $ rootFrag termMap -{- -newtype UnsizedAggregate = UnsizedAggregate { unUnAgg :: Map UnsizedRecursionToken Bool } -- this could probably be a set rather than map now - -instance Semigroup UnsizedAggregate where - (<>) (UnsizedAggregate a) (UnsizedAggregate b) = UnsizedAggregate $ Map.unionWith (||) a b - -instance Monoid UnsizedAggregate where - mempty = UnsizedAggregate $ Map.empty - -aggWrapper x = UnsizedAggregate $ Map.singleton x True - -readyForSizing :: UnsizedAggregate -> Bool -readyForSizing (UnsizedAggregate m) = not (null m) && and m --} - data SizedResult = AbortedSR | UnsizableSR UnsizedRecursionToken deriving (Eq, Ord, Show) @@ -885,7 +870,6 @@ sizeTerm :: Int -> UnsizedExpr -> Either UnsizedRecursionToken AbortExpr sizeTerm maxSize x = tidyUp . sizeF $ capMain x where sizeF = transformStuckM $ \case ur@(UnsizedFW (SizingWrapperF t (tm, x))) -> (Set.singleton t <> tm, unsizedEE $ SizingWrapperF t x) - -- BasicFW (SetEnvSF (tm, sep)) | readyForSizing tm -> findSize (tm, addSizingTest . basicEE $ SetEnvSF sep) BasicFW (SetEnvSF (tm, sep)) | not (null tm) -> foldSizes tm . basicEE $ SetEnvSF sep x -> embed <$> sequence x addSizingTest :: UnsizedExpr -> UnsizedExpr @@ -908,50 +892,25 @@ sizeTerm maxSize x = tidyUp . sizeF $ capMain x where selectResult (n, r) alt = case r of Just (UnsizableSR t) -> trace ("unsizable one: " <> show t) Nothing Nothing -> Just n - -- Nothing -> traceResults2 Just n _ -> alt - traceResults2 = trace ("sizing results2 are:\n" <> concatMap ((<> "\n----\n") . prettyPrint . snd) (take 3 rr)) - -- traceResults2 = id - {- - in if traceResults2 containsAbort . snd $ head rr - then Nothing - else foldr selectResult Nothing $ traceResults sizingResults --} in foldr selectResult Nothing sizingResults - {- - findSizes tm x = map (\ur -> (ur, findSize . addSizingTest $ removeOthers ur x)) $ Set.toList tm where - removeOthers ur = transformStuck f where - f :: UnsizedExprF UnsizedExpr UnsizedExpr -> UnsizedExpr - f = \case - UnsizedFW (SizingWrapperF tok _) | tok /= ur -> basicEE . PairSF (superEE AnyPF) $ basicEE ZeroSF - x -> embed x --} findSizes sm x = Map.fromList . map (\ur -> (ur, findSize . addSizingTest $ setOthers ur x)) . Set.toList $ Map.keysSet sm where setOthers ur = transformStuck f where f = \case - {- - UnsizedFW (SizingWrapperF tok _) | tok /= ur && Map.lookup tok sm == Just Nothing -> basicEE . PairSF (superEE AnyPF) $ basicEE ZeroSF - UnsizedFW (SizingWrapperF tok ix) | tok /= ur && Map.lookup tok sm == Just (Just _) -> ix - UnsizedFW (UnsizedStubF tok _) | tok /= ur && Map.lookup tok sm == Just (Just n) -> iterate (basicEE . SetEnvSF) (basicEE EnvSF) !! n --} UnsizedFW (SizingWrapperF tok ix) | tok /= ur -> case Map.lookup tok sm of Just Nothing -> basicEE . PairSF (superEE AnyPF) $ basicEE ZeroSF - -- Just (Just n) -> iterate (basicEE . SetEnvSF) (basicEE EnvSF) !! n - -- _ -> unsizedEE $ SizingWrapperF tok ix _ -> ix UnsizedFW (UnsizedStubF tok ix) | tok /= ur -> case Map.lookup tok sm of Just (Just n) -> iterate (basicEE . SetEnvSF) (basicEE EnvSF) !! n _ -> unsizedEE $ UnsizedStubF tok ix x -> embed x - -- foldSizes tm x = setSizes (Map.fromList $ findSizes tm x) x traceSizes x = trace ("findSizes results: " <> show x) x foldSizes us x = let sizeMap = traceSizes $ findSizes initM x initM = Map.fromList . map (\urt -> (urt, Nothing)) $ Set.toList us results = evalPossible . fillVars $ addSizingTest x rr = recursionResults' results unsizedSet = us Set.\\ Map.keysSet (Map.mapMaybe id sizeMap) - -- in (unsizedSet, setSizes sizeMap x) in if containsAbort . snd $ head rr then (us, x) else if length us > 1 @@ -971,10 +930,6 @@ sizeTerm maxSize x = tidyUp . sizeF $ capMain x where StuckEE _ x -> f x x -> getAny . foldMap (Any . f) $ project x tidyUp = \case - {- - (uam, _) | not (null uam) -> case Set.toList uam of - (urt:_) -> Left urt --} (uam, r) | not (null uam) -> case findSize $ addSizingTest r of -- try to size everything at once Just n -> tidyUp (mempty, setSizes (Map.fromList . map (\urt -> (urt, n)) $ Set.toList uam) r) _ -> Left . head $ Set.toList uam @@ -988,11 +943,6 @@ sizeTerm maxSize x = tidyUp . sizeF $ capMain x where clean = unsized2abortExpr setSizes :: Map UnsizedRecursionToken Int -> UnsizedExpr -> UnsizedExpr setSizes sizeMap = transformStuck $ \case - {- - UnsizedFW (UnsizedStubF _ _) -> iterate (basicEE . SetEnvSF) (basicEE EnvSF) !! n - UnsizedFW (RecursionTestF _ x) -> x - -- FourFW (SizingWrapperF _ x) -> x --} UnsizedFW sw@(SizingWrapperF tok sx) -> case Map.lookup tok sizeMap of Just _ -> sx _ -> unsizedEE sw @@ -1024,7 +974,6 @@ sizeTerm maxSize x = tidyUp . sizeF $ capMain x where in if hasBad nx then error ("found potential issue before:\n" <> prettyPrint x <> "\n---after---\n" <> prettyPrint nx) else nx - evalPossible :: UnsizedExpr -> UnsizedExpr evalPossible = evalBottomUp evalStep unhandledError x = error ("sizeTerm unhandled case\n" <> prettyPrint x) diff --git a/telomare.cabal b/telomare.cabal index 9ebf379..b3a0316 100644 --- a/telomare.cabal +++ b/telomare.cabal @@ -91,7 +91,9 @@ executable telomare executable telomare-mini-repl hs-source-dirs: app main-is: MiniRepl.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded + -rtsopts + "-with-rtsopts=-N -s -hT" build-depends: base , containers , telomare @@ -116,7 +118,11 @@ test-suite telomare-test , telomare , strict , QuickCheck - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded + -rtsopts + -- -prof -- uncomment this and the following for profiling + -- -fprof-auto + -- "-with-rtsopts=-N -p -s -hT" default-language: Haskell2010 test-suite telomare-parser-test @@ -161,7 +167,7 @@ benchmark telomare-serializer-benchmark hs-source-dirs: bench/ default-language: Haskell2010 Main-is: SerializerBench.hs - build-depends: base, telomare, deepseq, strict, vector, criterion + build-depends: base, telomare, deepseq, strict, vector, criterion, criterion-measurement ghc-options: -with-rtsopts=-T benchmark telomare-memory-benchmark @@ -183,6 +189,8 @@ benchmark telomare-memory-benchmark , bytestring -- , llvm-hs-pure -- , llvm-hs + ghc-options: + -threaded source-repository head type: git