diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bin/dump.hs b/bin/dump.hs new file mode 100644 --- /dev/null +++ b/bin/dump.hs @@ -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...] ..." diff --git a/ghc-prof.cabal b/ghc-prof.cabal new file mode 100644 --- /dev/null +++ b/ghc-prof.cabal @@ -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 +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 diff --git a/src/GHC/Prof.hs b/src/GHC/Prof.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Prof.hs @@ -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 diff --git a/src/GHC/Prof/CostCentreTree.hs b/src/GHC/Prof/CostCentreTree.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Prof/CostCentreTree.hs @@ -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 + } diff --git a/src/GHC/Prof/Parser.hs b/src/GHC/Prof/Parser.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Prof/Parser.hs @@ -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 diff --git a/src/GHC/Prof/Types.hs b/src/GHC/Prof/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Prof/Types.hs @@ -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 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.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