packages feed

ghc-prof (empty) → 1.0.0

raw patch · 9 files changed

+920/−0 lines, 9 filesdep +attoparsecdep +basedep +containerssetup-changed

Dependencies added: attoparsec, base, containers, directory, filepath, ghc-prof, process, scientific, tasty, tasty-hunit, temporary, text, time

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Mitsutoshi Aoe++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Mitsutoshi Aoe nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bin/dump.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where+import Control.Applicative ((<$>))+import Data.Foldable+import Prelude hiding (concat, foldl)+import System.Console.GetOpt+import System.Environment (getArgs)+import Text.Printf++import Data.Scientific+import Data.Tree (drawTree)+import qualified Data.Attoparsec.Text.Lazy as ATL+import qualified Data.Text as T+import qualified Data.Text.Lazy.IO as TLIO++import GHC.Prof++main :: IO ()+main = do+  (opts, file:restArgs) <- parseOpts =<< getArgs+  text <- TLIO.readFile file+  case ATL.parse profile text of+    ATL.Fail unconsumed contexts reason ->+      fail $ show (unconsumed, contexts, reason)+    ATL.Done _ prof -> case optMode opts of+      AggregateMode ->+        traverse_ (putStrLn . makeAggregateCCName) $ aggregateCostCentres prof+      TreeMode -> case restArgs of+        [] ->+          traverse_ putStrLn $ drawTree . fmap makeCCName <$> costCentres prof+        name:modName:_ -> do+          case callSites (T.pack name) (T.pack modName) prof of+            Nothing -> putStrLn "failed to parse call sites"+            Just (callee, callers) -> do+              print callee+              traverse_ print callers+        _ -> fail "Invalid parameters"++makeCCName :: CostCentre -> String+makeCCName cc = printf "%s.%s:%d (%s,%s,%s,%s)"+  (T.unpack $ costCentreModule cc)+  (T.unpack $ costCentreName cc)+  (costCentreNo cc)+  (showScientific $ costCentreInhTime cc)+  (showScientific $ costCentreIndTime cc)+  (showScientific $ costCentreInhAlloc cc)+  (showScientific $ costCentreIndAlloc cc)++makeAggregateCCName :: AggregateCostCentre -> String+makeAggregateCCName aggregate = printf+  "%s%%\t%s%%\t%s.%s"+  (showScientific $ aggregateCostCentreTime aggregate)+  (showScientific $ aggregateCostCentreAlloc aggregate)+  (T.unpack $ aggregateCostCentreModule aggregate)+  (T.unpack $ aggregateCostCentreName aggregate)++showScientific :: Scientific -> String+showScientific = formatScientific Fixed Nothing++data Options = Options+  { optMode :: Mode+  }++defaultOptions :: Options+defaultOptions = Options+  { optMode = TreeMode+  }++data Mode = AggregateMode | TreeMode++options :: [OptDescr (Options -> Options)]+options =+  [ Option ['a'] ["aggregate"]+    (NoArg (\opts -> opts { optMode = AggregateMode }))+      "Aggregate mode"+  ]++parseOpts :: [String] -> IO (Options, [String])+parseOpts argv = case getOpt Permute options argv of+  (opts, rest, []) -> return (foldl (flip id) defaultOptions opts, rest)+  (_, _, errs) -> fail $ concat errs ++ usageInfo header options+  where+    header = "Usage: dump [OPTION...] ..."
+ ghc-prof.cabal view
@@ -0,0 +1,77 @@+name: ghc-prof+version: 1.0.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-prof+license: BSD3+license-file: LICENSE+author: Mitsutoshi Aoe+maintainer: Mitsutoshi Aoe <maoe@foldr.in>+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"+  default: False++library+  exposed-modules:+    GHC.Prof+    GHC.Prof.Parser+    GHC.Prof.Types+    GHC.Prof.CostCentreTree+  build-depends:+      base == 4.*+    , attoparsec < 0.14+    , containers >= 0.5 && < 0.6+    , scientific < 0.4+    , text+    , time+  hs-source-dirs: src+  ghc-options: -Wall+  default-language: Haskell2010++executable dump+  if flag(dump)+    buildable: True+  else+    buildable: False++  main-is: dump.hs+  hs-source-dirs: bin+  build-depends:+      base+    , attoparsec+    , containers+    , ghc-prof+    , scientific < 0.4+    , 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-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+  type: git+  location: https://github.com/maoe/ghc-prof.git
+ src/GHC/Prof.hs view
@@ -0,0 +1,26 @@+module GHC.Prof+  ( Profile(..)+  , TotalTime(..)+  , TotalAlloc(..)+  , AggregateCostCentre(..)+  , CostCentre(..)+  , CostCentreNo+  , Callee(..)+  , CallSite(..)++  -- * Parser+  , profile++  -- * Cost-centre tree+  , CostCentreTree+  , aggregateCostCentres+  , aggregateCostCentresOrderBy+  , costCentres+  , costCentresOrderBy+  , callSites+  , callSitesOrderBy+  ) where++import GHC.Prof.CostCentreTree+import GHC.Prof.Parser (profile)+import GHC.Prof.Types
+ src/GHC/Prof/CostCentreTree.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fsimpl-tick-factor=115 #-}+module GHC.Prof.CostCentreTree+  ( aggregateCostCentres+  , aggregateCostCentresOrderBy++  , costCentres+  , costCentresOrderBy++  , callSites+  , callSitesOrderBy++  , buildCostCentresOrderBy+  , buildCallSitesOrderBy+  ) where+import Control.Applicative+import Control.Arrow ((&&&))+import Data.Foldable (asum)+import Data.Function (on)+import Data.List+import Data.Maybe (listToMaybe)+import Data.Traversable (mapM)+import Prelude hiding (mapM)+import qualified Data.Foldable as Fold+import qualified Data.Sequence as Seq++import Data.Sequence (Seq)+import Data.Text (Text)+import Data.Tree (Tree)+import qualified Data.Tree as Tree++import GHC.Prof.Types++#if MIN_VERSION_containers(0, 5, 0)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict as Map+#else+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+#endif++aggregateCostCentres :: Profile -> [AggregateCostCentre]+aggregateCostCentres = aggregateCostCentresOrderBy sortKey+  where+    sortKey = aggregateCostCentreTime &&& aggregateCostCentreAlloc++aggregateCostCentresOrderBy+  :: Ord a+  => (AggregateCostCentre -> a)+  -- ^ Sorting key function+  -> Profile+  -> [AggregateCostCentre]+aggregateCostCentresOrderBy sortKey =+  buildAggregateCostCentresOrderBy sortKey . profileCostCentreTree++-- | Build a tree of cost-centres from a profiling report.+costCentres :: Profile -> Maybe (Tree CostCentre)+costCentres = costCentresOrderBy sortKey+  where+    sortKey =+      costCentreInhTime &&& costCentreIndTime &&&+      costCentreInhAlloc &&& costCentreIndAlloc++-- | Build a tree of cost-centres from a profiling report.+-- Nodes are sorted by the given key function for each level+-- of the tree.+costCentresOrderBy+  :: Ord a+  => (CostCentre -> a)+  -- ^ Sorting key function+  -> Profile+  -> Maybe (Tree CostCentre)+costCentresOrderBy sortKey =+  buildCostCentresOrderBy sortKey . profileCostCentreTree++-- | Build a list of call-sites (caller functions) for a specified+-- cost-centre name and module name.+callSites+  :: Text+  -- ^ Cost-centre name+  -> Text+  -- ^ Module name+  -> Profile+  -> Maybe (Callee, Seq CallSite)+callSites = callSitesOrderBy sortKey+  where+    sortKey =+      costCentreInhTime &&& costCentreIndTime &&&+      costCentreInhAlloc &&& costCentreIndAlloc++-- | Build a list of call-sites (caller function) for a specified+-- cost-centre name and module name. Nodes are sorted by the given+-- key function.+callSitesOrderBy+  :: Ord a+  => (CostCentre -> a)+  -- ^ Sorting key function+  -> Text+  -- ^ Cost-centre name+  -> Text+  -- ^ Module name+  -> Profile+  -> Maybe (Callee, Seq CallSite)+callSitesOrderBy sortKey name modName =+  buildCallSitesOrderBy sortKey name modName . profileCostCentreTree++-----------------------------------------------------------++buildAggregateCostCentresOrderBy+  :: Ord a+  => (AggregateCostCentre -> a)+  -> CostCentreTree+  -> [AggregateCostCentre]+buildAggregateCostCentresOrderBy sortKey CostCentreTree {..} =+  sortBy (flip compare `on` sortKey) $ Map.elems $ costCentreAggregate++buildCostCentresOrderBy+  :: Ord a+  => (CostCentre -> a)+  -- ^ Sorting key function+  -> CostCentreTree+  -> Maybe (Tree CostCentre)+buildCostCentresOrderBy sortKey CostCentreTree {..} = do+  -- Invariant:+  --   The root node (MAIN.MAIN) should have the least cost centre ID+  rootKey <- listToMaybe $ IntMap.keys costCentreNodes+  Tree.unfoldTreeM build rootKey+  where+    build key = do+      node <- IntMap.lookup key costCentreNodes+      return (node, children)+      where+          !children = maybe [] Fold.toList $ do+            nodes <- IntMap.lookup key costCentreChildren+            return $ costCentreNo+                <$> Seq.unstableSortBy (flip compare `on` sortKey) nodes++buildCallSitesOrderBy+  :: Ord a+  => (CostCentre -> a)+  -- ^ Sorting key function+  -> Text+  -- ^ Cost-centre name+  -> Text+  -- ^ Module name+  -> CostCentreTree+  -> Maybe (Callee, Seq CallSite)+buildCallSitesOrderBy sortKey name modName tree@CostCentreTree {..} =+  (,) <$> callee <*> callers+  where+    lookupCallees = Map.lookup (name, modName) costCentreCallSites+    !callee = do+      callees <- lookupCallees+      return $ buildCallee name modName callees+    callers = do+      callees <- lookupCallees+      mapM (buildCallSite tree) $+        Seq.unstableSortBy (flip compare `on` sortKey) callees++buildCallee :: Text -> Text -> Seq CostCentre -> Callee+buildCallee name modName callees = Callee+  { calleeName = name+  , calleeModule = modName+  , calleeEntries = Fold.sum $ costCentreEntries <$> callees+  , calleeTime = Fold.sum $ costCentreIndTime <$> callees+  , calleeAlloc = Fold.sum $ costCentreIndAlloc <$> callees+  , calleeTicks = asum $ costCentreTicks <$> callees+  , calleeBytes = asum $ costCentreBytes <$> callees+  }++buildCallSite :: CostCentreTree -> CostCentre -> Maybe CallSite+buildCallSite CostCentreTree {..} CostCentre {..} = do+  parentNo <- IntMap.lookup costCentreNo costCentreParents+  parent <- IntMap.lookup parentNo costCentreNodes+  return CallSite+    { callSiteCostCentre = parent+    , callSiteContribEntries = costCentreEntries+    , callSiteContribTime = costCentreIndTime+    , callSiteContribAlloc = costCentreIndAlloc+    , callSiteContribTicks = costCentreTicks+    , callSiteContribBytes = costCentreBytes+    }
+ src/GHC/Prof/Parser.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+module GHC.Prof.Parser+  ( profile++  , timestamp+  , title+  , commandLine+  , totalTime+  , totalAlloc+  , topCostCentres+  , aggregateCostCentre+  , costCentres+  , costCentre+  ) where+import Control.Applicative+import Control.Monad+import Data.Char (isSpace)+import Data.Foldable (asum, foldl')+import Data.Sequence ((><))+import Data.Maybe+import Data.Text (Text)+import Data.Time+import qualified Data.Sequence as Seq++import Data.Attoparsec.Text as A++import GHC.Prof.Types++#if MIN_VERSION_containers(0, 5, 0)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict as Map+#else+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+#endif++profile :: Parser Profile+profile = do+  skipHorizontalSpace+  profileTimestamp <- timestamp; skipSpace+  void title; skipSpace+  profileCommandLine <- commandLine; skipSpace+  profileTotalTime <- totalTime; skipSpace+  profileTotalAlloc <- totalAlloc; skipSpace+  profileTopCostCentres <- topCostCentres; skipSpace+  profileCostCentreTree <- costCentres; skipSpace+  endOfInput+  return $! Profile {..}++timestamp :: Parser LocalTime+timestamp = do+  parseDayOfTheWeek >> skipSpace+  month <- parseMonth; skipSpace+  day <- parseDay; skipSpace+  tod <- parseTimeOfDay; skipSpace+  year <- parseYear; skipSpace+  return $! LocalTime+    { localDay = fromGregorian year month day+    , localTimeOfDay = tod+    }+  where+    parseYear = decimal+    parseMonth = A.take 3 >>= nameToInt+      where+        nameToInt name = case name of+          "Jan" -> return 1; "Feb" -> return 2; "Mar" -> return 3+          "Apr" -> return 4; "May" -> return 5; "Jun" -> return 6+          "Jul" -> return 7; "Aug" -> return 8; "Sep" -> return 9+          "Oct" -> return 10; "Nov" -> return 11; "Dec" -> return 12+          _ -> fail $ "timestamp.toNum: invalid month - " ++ show name+    parseDay = decimal+    parseTimeOfDay = TimeOfDay+      <$> decimal <* string ":"+      <*> decimal+      <*> pure 0+    parseDayOfTheWeek = takeTill isSpace++title :: Parser Text+title = string "Time and Allocation Profiling Report  (Final)"++commandLine :: Parser Text+commandLine = A.takeWhile $ not . isEndOfLine++totalTime :: Parser TotalTime+totalTime = do+  void $ string "total time  ="; skipSpace+  elapsed <- rational+  void $ string " secs"; skipSpace+  (ticks, resolution, processors) <- parens $ (,,)+    <$> decimal <* string " ticks @ "+    <*> picoSeconds <* string ", "+    <*> decimal <* many1 (notChar ')')+  return $! TotalTime+    { totalTimeElapsed = elapsed+    , totalTimeTicks = ticks+    , totalTimeResolution = picosecondsToDiffTime resolution+    , totalTimeProcessors = processors+    }+  where+    picoSeconds = asum+      [ ((10 `pow` 3)*) <$> decimal <* string " us"+      , ((10 `pow` 6)*) <$> decimal <* string " ms"+      ]+    pow :: Integer -> Int -> Integer+    pow = (^)++totalAlloc :: Parser TotalAlloc+totalAlloc = do+  string "total alloc =" >> skipSpace+  !n <- groupedDecimal+  string " bytes" >> skipSpace+  parens $ void $ string "excludes profiling overheads"+  return TotalAlloc { totalAllocBytes = n }+  where+    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+    {..}++topCostCentres :: Parser [AggregateCostCentre]+topCostCentres = do+  params <- header; skipSpace+  aggregateCostCentre params `sepBy1` endOfLine++aggregateCostCentre :: HeaderParams -> Parser AggregateCostCentre+aggregateCostCentre HeaderParams {..} = AggregateCostCentre+  <$> symbol <* skipHorizontalSpace -- name+  <*> symbol <* skipHorizontalSpace -- module+  <*> source <* skipHorizontalSpace -- src+  <*> scientific <* skipHorizontalSpace -- %time+  <*> scientific <* skipHorizontalSpace -- %alloc+  <*> optional decimal <* skipHorizontalSpace -- ticks+  <*> optional decimal <* skipHorizontalSpace -- bytes+  where+    source+      | headerHasSrc = Just <$> symbol+      | otherwise = pure Nothing++costCentres :: Parser CostCentreTree+costCentres = do+  params <- header; skipSpace+  costCentreTree params++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 <- scientific; skipHorizontalSpace+  indAlloc <- scientific; skipHorizontalSpace+  inhTime <- scientific; skipHorizontalSpace+  inhAlloc <- scientific; skipHorizontalSpace+  optInfo <- optional optionalInfo+  return $! CostCentre+    { costCentreName = name+    , costCentreModule = modName+    , costCentreSrc = src+    , costCentreNo = no+    , costCentreEntries = entries+    , costCentreIndTime = indTime+    , costCentreIndAlloc = indAlloc+    , costCentreInhTime = inhTime+    , costCentreInhAlloc = inhAlloc+    , costCentreTicks = fst <$> optInfo+    , costCentreBytes = snd <$> optInfo+    }+  where+    optionalInfo = do+      !ticks <- decimal+      skipHorizontalSpace+      !bytes <- decimal+      return (ticks, bytes)++costCentreTree :: HeaderParams -> Parser CostCentreTree+costCentreTree params = buildTree <$> costCentreList+  where+    costCentreList = nestedCostCentre `sepBy1` endOfLine+    nestedCostCentre = (,)+      <$> nestLevel+      <*> costCentre params+      <* skipHorizontalSpace+    nestLevel = howMany space++type Level = Int++-- | TreePath represents a path to a node in a cost centre tree.+--+-- Invariant: @'treePathLevel' == length 'treePath'@+data TreePath = TreePath+  { treePathLevel :: !Level+  -- ^ Current depth of the path+  , treePath :: [CostCentreNo]+  -- ^ Path to the node+  }++push :: CostCentreNo -> TreePath -> TreePath+push ccNo path@TreePath {..} = path+  { treePathLevel = treePathLevel + 1+  , treePath = ccNo:treePath+  }++popTo :: Level -> TreePath -> TreePath+popTo level path@TreePath {..} = path+  { treePathLevel = level+  , treePath = drop (treePathLevel - level) treePath+  }++currentNo :: TreePath -> Maybe CostCentreNo+currentNo TreePath {treePath} = listToMaybe treePath++buildTree :: [(Level, CostCentre)] -> CostCentreTree+buildTree = snd . foldl' go (TreePath 0 [], emptyCostCentreTree)+  where+    go+      :: (TreePath, CostCentreTree)+      -> (Level, CostCentre)+      -> (TreePath, CostCentreTree)+    go (!path, !CostCentreTree {..}) (level, node) = (path', tree')+      where+        ccNo = costCentreNo node+        parentPath = popTo level path+        parentNo = currentNo parentPath+        path' = push ccNo parentPath+        tree' = CostCentreTree+          { costCentreNodes = IntMap.insert ccNo node costCentreNodes+          , costCentreParents = maybe costCentreParents+            (\parent -> IntMap.insert ccNo parent costCentreParents)+            parentNo+          , costCentreChildren = maybe costCentreChildren+            (\parent -> IntMap.insertWith (><) parent+              (Seq.singleton node)+              costCentreChildren)+            parentNo+          , costCentreCallSites = Map.insertWith (><)+            (costCentreName node, costCentreModule node)+            (Seq.singleton node)+            costCentreCallSites+          , costCentreAggregate = Map.insertWith addCostCentre+            (costCentreName node, costCentreModule node)+            (AggregateCostCentre+              { aggregateCostCentreName = costCentreName node+              , aggregateCostCentreModule = costCentreModule node+              , aggregateCostCentreSrc = costCentreSrc node+              , aggregateCostCentreTime = costCentreIndTime node+              , aggregateCostCentreAlloc = costCentreIndAlloc node+              , aggregateCostCentreTicks = costCentreTicks node+              , aggregateCostCentreBytes = costCentreBytes node+              })+            costCentreAggregate+          }+        addCostCentre x y = x+          { aggregateCostCentreTime =+            aggregateCostCentreTime x + aggregateCostCentreTime y+          , aggregateCostCentreAlloc =+            aggregateCostCentreAlloc x + aggregateCostCentreAlloc y+          , aggregateCostCentreTicks = (+)+            <$> aggregateCostCentreTicks x+            <*> aggregateCostCentreTicks y+          , aggregateCostCentreBytes = (+)+            <$> aggregateCostCentreBytes x+            <*> aggregateCostCentreBytes y+          }+++howMany :: Parser a -> Parser Int+howMany p = loop 0+  where+    loop !n = (p >> loop (succ n)) <|> return n++parens :: Parser a -> Parser a+parens p = string "(" *> p <* string ")"++symbol :: Parser Text+symbol = A.takeWhile $ not . isSpace++skipHorizontalSpace :: Parser ()+skipHorizontalSpace = void $ A.takeWhile isHorizontalSpace++optional_ :: Parser a -> Parser ()+optional_ = void . optional
+ src/GHC/Prof/Types.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE RecordWildCards #-}+module GHC.Prof.Types where+import Data.Monoid+import Prelude++import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Scientific (Scientific)+import Data.Sequence (Seq)+import Data.Text (Text)+import Data.Time (DiffTime, LocalTime)++-- | Top-level profiling report+data Profile = Profile+  { profileTimestamp :: !LocalTime+  , profileCommandLine :: !Text+  , profileTotalTime :: !TotalTime+  , profileTotalAlloc :: !TotalAlloc+  , profileTopCostCentres :: [AggregateCostCentre]+  , profileCostCentreTree :: !CostCentreTree+  } deriving Show++-- | @total time@ in the profiling reports+data TotalTime = TotalTime+  { totalTimeElapsed :: !DiffTime+  -- ^ Total elapsed time in seconds+  , totalTimeTicks :: !Integer+  -- ^ Total number of ticks+  , totalTimeResolution :: !DiffTime+  -- ^ Duration of a tick+  , totalTimeProcessors :: !Int+  -- ^ Number of processors+  } deriving Show++-- | @total alloc@ in the profiling reports+newtype TotalAlloc = TotalAlloc+  { totalAllocBytes :: Integer+  -- ^ Total memory allocation in bytes+  } deriving Show++data AggregateCostCentre = AggregateCostCentre+  { aggregateCostCentreName :: !Text+  -- ^ Name of the cost-centre+  , aggregateCostCentreModule :: !Text+  -- ^ Module name of the cost-centre+  , aggregateCostCentreSrc :: !(Maybe Text)+  -- ^ Source location of the cost-centre+  , aggregateCostCentreTime :: !Scientific+  -- ^ Total time spent in the cost-centre+  , aggregateCostCentreAlloc :: !Scientific+  -- ^ Total allocation in the cost-centre+  , aggregateCostCentreTicks :: !(Maybe Integer)+  -- ^ Total ticks in the cost-centre. This number exists only if+  -- @-P@ or @-Pa@ option is given at run-time.+  , aggregateCostCentreBytes :: !(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+  -- ^ Name of the cost-centre+  , costCentreModule :: !Text+  -- ^ Module name of the cost-centre+  , costCentreSrc :: !(Maybe Text)+  -- ^ Source location of the cost-centre+  , costCentreNo :: !CostCentreNo+  -- ^ Identifier of the cost-centre+  , costCentreEntries :: !Integer+  -- ^ Number of entries to the cost-centre+  , costCentreIndTime :: !Scientific+  -- ^ Time spent in the cost-centre itself+  , costCentreIndAlloc :: !Scientific+  -- ^ Allocation incurred by the cost-centre itself+  , costCentreInhTime :: !Scientific+  -- ^ Time spent in the cost-centre's children+  , costCentreInhAlloc :: !Scientific+  -- ^ Allocation incurred by the cost-centre's children+  , costCentreTicks :: !(Maybe Integer)+  -- ^ Number of ticks in the cost-centre.+  , costCentreBytes :: !(Maybe Integer)+  -- ^ Number of allocated bytes in the cost-centre.+  } deriving Show++type CostCentreNo = Int++data CostCentreTree = CostCentreTree+  { costCentreNodes :: !(IntMap CostCentre)+  , costCentreParents :: !(IntMap CostCentreNo)+  , costCentreChildren :: !(IntMap (Seq CostCentre))+  , costCentreCallSites :: !(Map (Text, Text) (Seq CostCentre))+  , costCentreAggregate :: !(Map (Text, Text) AggregateCostCentre)+  } deriving Show++emptyCostCentreTree :: CostCentreTree+emptyCostCentreTree = CostCentreTree+  { costCentreNodes = mempty+  , costCentreParents = mempty+  , costCentreChildren = mempty+  , costCentreCallSites = mempty+  , costCentreAggregate = mempty+  }++data Callee = Callee+  { calleeName :: Text+  -- ^ Name of the callee function+  , calleeModule :: Text+  -- ^ Module name of the calle function+  , calleeEntries :: !Integer+  -- ^ Number of entries to the callee function+  , calleeTime :: !Scientific+  -- ^ Time spent in the callee function+  , calleeAlloc :: !Scientific+  -- ^ Allocation incurred by the callee function+  , calleeTicks :: !(Maybe Integer)+  -- ^ Number of ticks in the callee function+  , calleeBytes :: !(Maybe Integer)+  -- ^ Number of allocated bytes in the callee function+  } deriving Show++data CallSite = CallSite+  { callSiteCostCentre :: CostCentre+  -- ^ Metrics for the caller function+  , callSiteContribEntries :: !Integer+  -- ^ Number of entries contriubted by the caller function+  , callSiteContribTime :: !Scientific+  -- ^ Time contributed by the caller function+  , callSiteContribAlloc :: !Scientific+  -- ^ Allocation contributed by the caller function+  , callSiteContribTicks :: !(Maybe Integer)+  -- ^ Number of tikcs contributed by the caller function+  , callSiteContribBytes :: !(Maybe Integer)+  -- ^ Number of allocated bytes contributed byt hte caller function+  } deriving Show
+ tests/Regression.hs view
@@ -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.Prof++#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 $ \prof -> do+      step $ "Parsing " ++ prof+      assertProfile prof++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 profile 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