profiling support and optimizing d2c in Prelude

sfultong · Nov 16, 2023 · 0149ba0 · 0149ba0
1 parent 012e1c3
commit 0149ba0
Show file tree

Hide file tree

Showing 6 changed files with 34 additions and 86 deletions.
diff --git 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
@@ -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,18 +64,13 @@ 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))
 
 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
@@ -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
@@ -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,23 +281,23 @@ 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
 
 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
@@ -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
@@ -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