ghc-time-alloc-prof 0.0.0.1 → 0.1.0

raw patch · 5 files changed

+207/−75 lines, 5 filesdep +directorydep +filepathdep +processdep ~attoparsecdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: directory, filepath, process, tasty, tasty-hunit, temporary

Dependency ranges changed: attoparsec, base

API changes (from Hackage documentation)

Files

• ghc-time-alloc-prof.cabal +23/−2
• src/GHC/RTS/TimeAllocProfile/CostCentreTree.hs +1/−1
• src/GHC/RTS/TimeAllocProfile/Parser.hs +88/−44
• src/GHC/RTS/TimeAllocProfile/Types.hs +29/−28
• tests/Regression.hs +66/−0

@@ -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 <maoe@foldr.in>-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

@@ -10,7 +10,7 @@   , buildCostCentresOrderBy   , buildCallSitesOrderBy   ) where-import Control.Applicative ((<$>), (<*>))+import Control.Applicative import Control.Arrow ((&&&)) import Data.Foldable (asum) import Data.Function (on)

@@ -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

@@ -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 

@@ -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