diff --git a/ghc-time-alloc-prof.cabal b/ghc-time-alloc-prof.cabal --- a/ghc-time-alloc-prof.cabal +++ b/ghc-time-alloc-prof.cabal @@ -1,5 +1,5 @@ name: ghc-time-alloc-prof -version: 0.0.0.1 +version: 0.1.0 synopsis: Library for parsing GHC time and allocation profiling reports description: Library for parsing GHC time and allocation profiling reports homepage: https://github.com/maoe/ghc-time-alloc-prof @@ -7,10 +7,11 @@ license-file: LICENSE author: Mitsutoshi Aoe maintainer: Mitsutoshi Aoe -copyright: Copyright (C) 2013 Mitsutoshi Aoe +copyright: Copyright (C) 2013-2016 Mitsutoshi Aoe category: Development build-type: Simple cabal-version: >=1.10 +tested-with: GHC >= 7.6 && <= 8.0.1 flag dump description: Build the executable "dump" @@ -47,6 +48,26 @@ , ghc-time-alloc-prof , text ghc-options: -Wall -rtsopts + default-language: Haskell2010 + +test-suite regression + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Regression.hs + build-depends: + attoparsec >= 0.10 && < 0.14 + , base + , directory + , filepath + , ghc-time-alloc-prof + , process + , tasty < 0.12 + , tasty-hunit >= 0.9.1 && < 0.10 + , temporary + , text + ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-unused-imports default-language: Haskell2010 source-repository head diff --git a/src/GHC/RTS/TimeAllocProfile/CostCentreTree.hs b/src/GHC/RTS/TimeAllocProfile/CostCentreTree.hs --- a/src/GHC/RTS/TimeAllocProfile/CostCentreTree.hs +++ b/src/GHC/RTS/TimeAllocProfile/CostCentreTree.hs @@ -10,7 +10,7 @@ , buildCostCentresOrderBy , buildCallSitesOrderBy ) where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative import Control.Arrow ((&&&)) import Data.Foldable (asum) import Data.Function (on) diff --git a/src/GHC/RTS/TimeAllocProfile/Parser.hs b/src/GHC/RTS/TimeAllocProfile/Parser.hs --- a/src/GHC/RTS/TimeAllocProfile/Parser.hs +++ b/src/GHC/RTS/TimeAllocProfile/Parser.hs @@ -16,7 +16,7 @@ , costCentre ) where import Control.Applicative -import Control.Monad (void) +import Control.Monad import Data.Char (isSpace) import Data.Foldable (asum, foldl') import Data.Sequence (Seq, (><), (|>)) @@ -38,7 +38,7 @@ timeAllocProfile :: Parser TimeAllocProfile timeAllocProfile = do - skipSpace + skipHorizontalSpace profileTimestamp <- timestamp; skipSpace void title; skipSpace profileCommandLine <- commandLine; skipSpace @@ -47,16 +47,16 @@ profileHotCostCentres <- hotCostCentres; skipSpace profileCostCentreTree <- costCentres; skipSpace endOfInput - return TimeAllocProfile {..} + return $! TimeAllocProfile {..} timestamp :: Parser LocalTime timestamp = do - void parseDayOfTheWeek; skipSpace + parseDayOfTheWeek >> skipSpace month <- parseMonth; skipSpace day <- parseDay; skipSpace tod <- parseTimeOfDay; skipSpace year <- parseYear; skipSpace - return LocalTime + return $! LocalTime { localDay = fromGregorian year month day , localTimeOfDay = tod } @@ -92,7 +92,7 @@ <$> decimal <* string " ticks @ " <*> picoSeconds <* string ", " <*> decimal <* many1 (notChar ')') - return TotalTime + return $! TotalTime { totalTimeElapsed = elapsed , totalTimeTicks = ticks , totalTimeResolution = picosecondsToDiffTime resolution @@ -108,50 +108,85 @@ totalAlloc :: Parser TotalAlloc totalAlloc = do - void $ string "total alloc ="; skipSpace - n <- groupedDecimal - void $ string " bytes"; skipSpace + string "total alloc =" >> skipSpace + !n <- groupedDecimal + string " bytes" >> skipSpace parens $ void $ string "excludes profiling overheads" return TotalAlloc { totalAllocBytes = n } where - groupedDecimal = foldl' go 0 <$> decimal `sepBy` char ',' + groupedDecimal = do + ds <- decimal `sepBy` char ',' + return $! foldl' go 0 ds where go z n = z * 1000 + n +newtype HeaderParams = HeaderParams + { headerHasSrc :: Bool -- ^ SRC column exists + } deriving Show + +header :: Parser HeaderParams +header = do + optional_ $ do + string "individual" >> skipHorizontalSpace + string "inherited" >> skipSpace + string "COST CENTRE" >> skipHorizontalSpace + string "MODULE" >> skipHorizontalSpace + headerHasSrc <- option False $ True <$ string "SRC"; skipHorizontalSpace + optional_ $ string "no." >> skipHorizontalSpace + optional_ $ string "entries" >> skipHorizontalSpace + string "%time" >> skipHorizontalSpace + string "%alloc" >> skipHorizontalSpace + optional_ $ do + string "%time" >> skipHorizontalSpace + string "%alloc" >> skipHorizontalSpace + optional_ $ do + string "ticks" >> skipHorizontalSpace + string "bytes" >> skipHorizontalSpace + return HeaderParams + {..} + hotCostCentres :: Parser [BriefCostCentre] -hotCostCentres = - header *> skipSpace *> many1 (briefCostCentre <* skipSpace) - where - header = A.takeWhile $ not . isEndOfLine +hotCostCentres = do + params <- header; skipSpace + briefCostCentre params `sepBy1` endOfLine -briefCostCentre :: Parser BriefCostCentre -briefCostCentre = BriefCostCentre - <$> symbol <* skipSpace -- name - <*> symbol <* skipSpace -- module - <*> optional symbol <* skipSpace -- src - <*> double <* skipSpace -- %time - <*> double <* skipSpace -- %alloc - <*> optional decimal <* skipSpace -- ticks - <*> optional decimal -- bytes +briefCostCentre :: HeaderParams -> Parser BriefCostCentre +briefCostCentre HeaderParams {..} = BriefCostCentre + <$> symbol <* skipHorizontalSpace -- name + <*> symbol <* skipHorizontalSpace -- module + <*> source <* skipHorizontalSpace -- src + <*> double <* skipHorizontalSpace -- %time + <*> double <* skipHorizontalSpace -- %alloc + <*> optional decimal <* skipHorizontalSpace -- ticks + <*> optional decimal <* skipHorizontalSpace -- bytes + where + source + | headerHasSrc = Just <$> symbol + | otherwise = pure Nothing costCentres :: Parser CostCentreTree -costCentres = header *> skipSpace *> costCentreTree - where - !header = count 2 $ A.takeWhile (not . isEndOfLine) <* skipSpace +costCentres = do + params <- header; skipSpace + costCentreTree params -costCentre :: Parser CostCentre -costCentre = do - name <- symbol; skipSpace - modName <- symbol; skipSpace - src <- optional symbol; skipSpace - no <- decimal; skipSpace - entries <- decimal; skipSpace - indTime <- double; skipSpace - indAlloc <- double; skipSpace - inhTime <- double; skipSpace - inhAlloc <- double; +costCentre :: HeaderParams -> Parser CostCentre +costCentre HeaderParams {..} = do + name <- symbol; skipHorizontalSpace + modName <- symbol; skipHorizontalSpace + src <- if headerHasSrc + then do + !sym <- symbol + return $! Just sym + else pure Nothing + skipHorizontalSpace + no <- decimal; skipHorizontalSpace + entries <- decimal; skipHorizontalSpace + indTime <- double; skipHorizontalSpace + indAlloc <- double; skipHorizontalSpace + inhTime <- double; skipHorizontalSpace + inhAlloc <- double; skipHorizontalSpace optInfo <- optional optionalInfo - return CostCentre + return $! CostCentre { costCentreName = name , costCentreModule = modName , costCentreSrc = src @@ -166,16 +201,19 @@ } where optionalInfo = do - skipSpace - ticks <- decimal; skipSpace - bytes <- decimal + !ticks <- decimal + skipHorizontalSpace + !bytes <- decimal return (ticks, bytes) -costCentreTree :: Parser CostCentreTree -costCentreTree = buildTree <$> costCentreList +costCentreTree :: HeaderParams -> Parser CostCentreTree +costCentreTree params = buildTree <$> costCentreList where costCentreList = nestedCostCentre `sepBy1` endOfLine - nestedCostCentre = (,) <$> nestLevel <*> costCentre + nestedCostCentre = (,) + <$> nestLevel + <*> costCentre params + <* skipHorizontalSpace nestLevel = howMany space type Level = Int @@ -228,3 +266,9 @@ symbol :: Parser Text symbol = A.takeWhile $ not . isSpace + +skipHorizontalSpace :: Parser () +skipHorizontalSpace = void $ A.takeWhile isHorizontalSpace + +optional_ :: Parser a -> Parser () +optional_ = void . optional diff --git a/src/GHC/RTS/TimeAllocProfile/Types.hs b/src/GHC/RTS/TimeAllocProfile/Types.hs --- a/src/GHC/RTS/TimeAllocProfile/Types.hs +++ b/src/GHC/RTS/TimeAllocProfile/Types.hs @@ -2,30 +2,31 @@ module GHC.RTS.TimeAllocProfile.Types where import Data.IntMap (IntMap) import Data.Map (Map) -import Data.Monoid (mempty) +import Data.Monoid import Data.Text (Text) import Data.Time (DiffTime, LocalTime) import Data.Sequence (Seq) +import Prelude -- | Top-level profiling report data TimeAllocProfile = TimeAllocProfile - { profileTimestamp :: LocalTime - , profileCommandLine :: Text - , profileTotalTime :: TotalTime - , profileTotalAlloc :: TotalAlloc + { profileTimestamp :: !LocalTime + , profileCommandLine :: !Text + , profileTotalTime :: !TotalTime + , profileTotalAlloc :: !TotalAlloc , profileHotCostCentres :: [BriefCostCentre] - , profileCostCentreTree :: CostCentreTree + , profileCostCentreTree :: !CostCentreTree } deriving Show -- | @total time@ in the profiling reports data TotalTime = TotalTime - { totalTimeElapsed :: DiffTime + { totalTimeElapsed :: !DiffTime -- ^ Total elapsed time in seconds - , totalTimeTicks :: Integer + , totalTimeTicks :: !Integer -- ^ Total number of ticks - , totalTimeResolution :: DiffTime + , totalTimeResolution :: !DiffTime -- ^ Duration of a tick - , totalTimeProcessors :: Int + , totalTimeProcessors :: !Int -- ^ Number of processors } deriving Show @@ -36,47 +37,47 @@ } deriving Show data BriefCostCentre = BriefCostCentre - { briefCostCentreName :: Text + { briefCostCentreName :: !Text -- ^ Name of the cost-centre - , briefCostCentreModule :: Text + , briefCostCentreModule :: !Text -- ^ Module name of the cost-centre - , briefCostCentreSrc :: Maybe Text + , briefCostCentreSrc :: !(Maybe Text) -- ^ Source location of the cost-centre - , briefCostCentreTime :: Double + , briefCostCentreTime :: !Double -- ^ Total time spent in the cost-centre - , briefCostCentreAlloc :: Double + , briefCostCentreAlloc :: !Double -- ^ Total allocation in the cost-centre - , briefCostCentreTicks :: Maybe Integer + , briefCostCentreTicks :: !(Maybe Integer) -- ^ Total ticks in the cost-centre. This number exists only if -- @-P@ or @-Pa@ option is given at run-time. - , briefCostCentreBytes :: Maybe Integer + , briefCostCentreBytes :: !(Maybe Integer) -- ^ Total memory allocation in the cost-centre. This number -- exists only if @-P@ or @-Pa@ option is given at run-time. } deriving Show -- | Cost-centre node data CostCentre = CostCentre - { costCentreName :: Text + { costCentreName :: !Text -- ^ Name of the cost-centre - , costCentreModule :: Text + , costCentreModule :: !Text -- ^ Module name of the cost-centre - , costCentreSrc :: Maybe Text + , costCentreSrc :: !(Maybe Text) -- ^ Source location of the cost-centre - , costCentreNo :: CostCentreNo + , costCentreNo :: !CostCentreNo -- ^ Identifier of the cost-centre - , costCentreEntries :: Integer + , costCentreEntries :: !Integer -- ^ Number of entries to the cost-centre - , costCentreIndTime :: Double + , costCentreIndTime :: !Double -- ^ Time spent in the cost-centre itself - , costCentreIndAlloc :: Double + , costCentreIndAlloc :: !Double -- ^ Allocation incurred by the cost-centre itself - , costCentreInhTime :: Double + , costCentreInhTime :: !Double -- ^ Time spent in the cost-centre's children - , costCentreInhAlloc :: Double + , costCentreInhAlloc :: !Double -- ^ Allocation incurred by the cost-centre's children - , costCentreTicks :: Maybe Integer + , costCentreTicks :: !(Maybe Integer) -- ^ Number of ticks in the cost-centre. - , costCentreBytes :: Maybe Integer + , costCentreBytes :: !(Maybe Integer) -- ^ Number of allocated bytes in the cost-centre. } deriving Show diff --git a/tests/Regression.hs b/tests/Regression.hs new file mode 100644 --- /dev/null +++ b/tests/Regression.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +module Main where +import Data.Foldable +import Data.Traversable +import Control.Applicative +import Control.Monad +import System.Directory +import System.FilePath +import System.IO +import Prelude + +import System.IO.Temp +import System.Process +import Test.Tasty +import Test.Tasty.HUnit +import qualified Data.Text.Lazy.IO as TL +import qualified Data.Attoparsec.Text.Lazy as ATL + +import GHC.RTS.TimeAllocProfile + +#if !MIN_VERSION_directory(1, 2, 3) +import Control.Exception +#endif + +main :: IO () +main = withSystemTempDirectory "test" $ \dir -> withCurrentDirectory dir $ + defaultMain $ testCaseSteps "Regression tests" $ \step -> do + step "Generating profiling reports" + profiles <- generateProfiles + for_ profiles $ \profile -> do + step $ "Parsing " ++ profile + assertProfile profile + +generateProfiles :: IO [FilePath] +generateProfiles = do + withFile "hello.hs" WriteMode $ \h -> + hPutStrLn h "main = putStrLn \"Hello, World!\"" + void $ readProcess "ghc" ["-prof", "-rtsopts", "-fforce-recomp", "hello.hs"] "" + for profilingFlags $ \(name, flag) -> do + void $ readProcess "./hello" ["+RTS", flag, "-RTS"] "" + let profName = "hello" <.> name <.> "prof" + renameFile "hello.prof" profName + return profName + +profilingFlags :: [(String, String)] +profilingFlags = + [ ("standard", "-p") + , ("detailed", "-P") + , ("full", "-pa") + ] + +assertProfile :: FilePath -> Assertion +assertProfile path = do + text <- TL.readFile path + case ATL.parse timeAllocProfile text of + ATL.Done {} -> return () + ATL.Fail _ _ reason -> assertFailure reason + +#if !MIN_VERSION_directory(1, 2, 3) +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory dir io = bracket + (getCurrentDirectory <* setCurrentDirectory dir) + (setCurrentDirectory) + (const io) +#endif