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,45 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where +import Control.Applicative ((<$>)) +import Data.Tree (drawTree) +import System.Environment (getArgs) +import qualified Data.Text as T +import qualified Data.Text.Lazy.IO as TLIO +import qualified Data.Foldable as Fold + +import qualified Data.Attoparsec.Text.Lazy as ATL + +import GHC.RTS.TimeAllocProfile + + +main :: IO () +main = do + file:restArgs <- getArgs + text <- TLIO.readFile file + let ATL.Done _ prof = ATL.parse timeAllocProfile text + case restArgs of + [] -> Fold.mapM_ putStrLn $ drawTree . fmap makeCCName <$> profileCostCentres prof + name:modName:_ -> do + case profileCallSites (T.pack name) (T.pack modName) prof of + Nothing -> putStrLn "failed to parse call sites" + Just (callee, callSites) -> do + print callee + Fold.mapM_ print callSites + _ -> fail "Invalid parameters" + +makeCCName :: CostCentre -> String +makeCCName cc = T.unpack (costCentreModule cc) + ++ "." + ++ T.unpack (costCentreName cc) + ++ ":" + ++ show (costCentreNo cc) + ++ " (" + ++ show (costCentreInhTime cc) + ++ "," + ++ show (costCentreIndTime cc) + ++ "," + ++ show (costCentreInhAlloc cc) + ++ "," + ++ show (costCentreIndAlloc cc) + ++ ")" + diff --git a/ghc-time-alloc-prof.cabal b/ghc-time-alloc-prof.cabal new file mode 100644 --- /dev/null +++ b/ghc-time-alloc-prof.cabal @@ -0,0 +1,54 @@ +name: ghc-time-alloc-prof +version: 0.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-time-alloc-prof +license: BSD3 +license-file: LICENSE +author: Mitsutoshi Aoe +maintainer: Mitsutoshi Aoe +copyright: Copyright (C) 2013 Mitsutoshi Aoe +category: Development +build-type: Simple +cabal-version: >=1.10 + +flag dump + description: Build the executable "dump" + default: False + +library + exposed-modules: + GHC.RTS.TimeAllocProfile + GHC.RTS.TimeAllocProfile.Parser + GHC.RTS.TimeAllocProfile.Types + GHC.RTS.TimeAllocProfile.CostCentreTree + build-depends: + base == 4.* + , attoparsec + , containers + , 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-time-alloc-prof + , text + ghc-options: -Wall -rtsopts + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/maoe/ghc-time-alloc-prof.git diff --git a/src/GHC/RTS/TimeAllocProfile.hs b/src/GHC/RTS/TimeAllocProfile.hs new file mode 100644 --- /dev/null +++ b/src/GHC/RTS/TimeAllocProfile.hs @@ -0,0 +1,24 @@ +module GHC.RTS.TimeAllocProfile + ( TimeAllocProfile(..) + , TotalTime(..) + , TotalAlloc(..) + , BriefCostCentre(..) + , CostCentre(..) + , CostCentreNo + , Callee(..) + , CallSite(..) + + -- * Parser + , timeAllocProfile + + -- * Cost-centre tree + , CostCentreTree + , profileCostCentres + , profileCostCentresOrderBy + , profileCallSites + , profileCallSitesOrderBy + ) where + +import GHC.RTS.TimeAllocProfile.CostCentreTree +import GHC.RTS.TimeAllocProfile.Parser (timeAllocProfile) +import GHC.RTS.TimeAllocProfile.Types diff --git a/src/GHC/RTS/TimeAllocProfile/CostCentreTree.hs b/src/GHC/RTS/TimeAllocProfile/CostCentreTree.hs new file mode 100644 --- /dev/null +++ b/src/GHC/RTS/TimeAllocProfile/CostCentreTree.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +module GHC.RTS.TimeAllocProfile.CostCentreTree + ( profileCostCentres + , profileCostCentresOrderBy + , profileCallSites + , profileCallSitesOrderBy + + , buildCostCentresOrderBy + , buildCallSitesOrderBy + ) where +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow ((&&&)) +import Data.Foldable (asum) +import Data.Function (on) +import Data.Maybe (listToMaybe) +import Data.Sequence (Seq) +import Data.Text (Text) +import Data.Traversable (mapM) +import Data.Tree (Tree) +import Prelude hiding (mapM) +import qualified Data.Foldable as Fold +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq +import qualified Data.Tree as Tree + +import GHC.RTS.TimeAllocProfile.Types + +-- | Build a tree of cost-centres from a profiling report. +profileCostCentres :: TimeAllocProfile -> Maybe (Tree CostCentre) +profileCostCentres = profileCostCentresOrderBy 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. +profileCostCentresOrderBy + :: Ord a + => (CostCentre -> a) + -- ^ Sorting key function + -> TimeAllocProfile + -> Maybe (Tree CostCentre) +profileCostCentresOrderBy sortKey = + buildCostCentresOrderBy sortKey . profileCostCentreTree + +-- | Build a list of call-sites (caller functions) for a specified +-- cost-centre name and module name. +profileCallSites + :: Text + -- ^ Cost-centre name + -> Text + -- ^ Module name + -> TimeAllocProfile + -> Maybe (Callee, Seq CallSite) +profileCallSites = profileCallSitesOrderBy 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. +profileCallSitesOrderBy + :: Ord a + => (CostCentre -> a) + -- ^ Sorting key function + -> Text + -- ^ Cost-centre name + -> Text + -- ^ Module name + -> TimeAllocProfile + -> Maybe (Callee, Seq CallSite) +profileCallSitesOrderBy sortKey name modName = + buildCallSitesOrderBy sortKey name modName . profileCostCentreTree + +----------------------------------------------------------- + +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 <*> callSites + where + lookupCallees = Map.lookup (name, modName) costCentreCallSites + !callee = do + callees <- lookupCallees + return $ buildCallee name modName callees + callSites = 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/RTS/TimeAllocProfile/Parser.hs b/src/GHC/RTS/TimeAllocProfile/Parser.hs new file mode 100644 --- /dev/null +++ b/src/GHC/RTS/TimeAllocProfile/Parser.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +module GHC.RTS.TimeAllocProfile.Parser + ( timeAllocProfile + + , timestamp + , title + , commandLine + , totalTime + , totalAlloc + , hotCostCentres + , briefCostCentre + , costCentres + , costCentre + ) where +import Control.Applicative +import Control.Monad (void) +import Data.Char (isSpace) +import Data.Foldable (asum, foldl') +import Data.Sequence (Seq, (><), (|>)) +import Data.Text (Text) +import Data.Time +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq + +import Data.Attoparsec.Text as A + +import GHC.RTS.TimeAllocProfile.Types + +timeAllocProfile :: Parser TimeAllocProfile +timeAllocProfile = do + skipSpace + profileTimestamp <- timestamp; skipSpace + void title; skipSpace + profileCommandLine <- commandLine; skipSpace + profileTotalTime <- totalTime; skipSpace + profileTotalAlloc <- totalAlloc; skipSpace + profileHotCostCentres <- hotCostCentres; skipSpace + profileCostCentreTree <- costCentres; skipSpace + endOfInput + return TimeAllocProfile {..} + +timestamp :: Parser LocalTime +timestamp = do + void 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 + void $ string "total alloc ="; skipSpace + n <- groupedDecimal + void $ string " bytes"; skipSpace + parens $ void $ string "excludes profiling overheads" + return TotalAlloc { totalAllocBytes = n } + where + groupedDecimal = foldl' go 0 <$> decimal `sepBy` char ',' + where + go z n = z * 1000 + n + +hotCostCentres :: Parser [BriefCostCentre] +hotCostCentres = + header *> skipSpace *> many1 (briefCostCentre <* skipSpace) + where + header = A.takeWhile $ not . isEndOfLine + +briefCostCentre :: Parser BriefCostCentre +briefCostCentre = BriefCostCentre + <$> symbol <* skipSpace -- name + <*> symbol <* skipSpace -- module + <*> double <* skipSpace -- %time + <*> double <* skipSpace -- %alloc + <*> optional decimal <* skipSpace -- ticks + <*> optional decimal -- bytes + +costCentres :: Parser CostCentreTree +costCentres = header *> skipSpace *> costCentreTree + where + !header = count 2 $ A.takeWhile (not . isEndOfLine) <* skipSpace + +costCentre :: Parser CostCentre +costCentre = do + name <- A.takeWhile (not . isSpace); skipSpace + modName <- A.takeWhile (not . isSpace); skipSpace + no <- decimal; skipSpace + entries <- decimal; skipSpace + indTime <- double; skipSpace + indAlloc <- double; skipSpace + inhTime <- double; skipSpace + inhAlloc <- double; + optInfo <- optional optionalInfo + return CostCentre + { costCentreName = name + , costCentreModule = modName + , costCentreNo = no + , costCentreEntries = entries + , costCentreIndTime = indTime + , costCentreIndAlloc = indAlloc + , costCentreInhTime = inhTime + , costCentreInhAlloc = inhAlloc + , costCentreTicks = fst <$> optInfo + , costCentreBytes = snd <$> optInfo + } + where + optionalInfo = do + skipSpace + ticks <- decimal; skipSpace + bytes <- decimal + return (ticks, bytes) + +costCentreTree :: Parser CostCentreTree +costCentreTree = buildTree <$> costCentreList + where + costCentreList = nestedCostCentre `sepBy1` endOfLine + nestedCostCentre = (,) <$> nestLevel <*> costCentre + nestLevel = howMany space + +type Level = Int +type TreePath = Seq Level + +buildTree :: [(Level, CostCentre)] -> CostCentreTree +buildTree = snd . foldl' go (Seq.empty, emptyCostCentreTree) + where + go + :: (TreePath, CostCentreTree) + -> (Level, CostCentre) + -> (TreePath, CostCentreTree) + go (treePath, tree) (level, node) = (treePath', tree') + where + !treePath' = Seq.take level treePath |> costCentreNo node + !tree' = if Seq.length treePath == 0 + then CostCentreTree + { costCentreNodes = IntMap.singleton nodeNo node + , costCentreParents = IntMap.empty + , costCentreChildren = IntMap.empty + , costCentreCallSites = Map.singleton + (costCentreName node, costCentreModule node) + Seq.empty + } + else CostCentreTree + { costCentreNodes = IntMap.insert nodeNo node + (costCentreNodes tree) + , costCentreParents = IntMap.insert nodeNo parent + (costCentreParents tree) + , costCentreChildren = IntMap.insertWith (><) + parent + (Seq.singleton node) + (costCentreChildren tree) + , costCentreCallSites = Map.insertWith (><) + (costCentreName node, costCentreModule node) + (Seq.singleton node) + (costCentreCallSites tree) + } + where + nodeNo = costCentreNo node + parent = Seq.index treePath (level - 1) + +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 diff --git a/src/GHC/RTS/TimeAllocProfile/Types.hs b/src/GHC/RTS/TimeAllocProfile/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHC/RTS/TimeAllocProfile/Types.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE RecordWildCards #-} +module GHC.RTS.TimeAllocProfile.Types where +import Data.IntMap (IntMap) +import Data.Map (Map) +import Data.Monoid (mempty) +import Data.Text (Text) +import Data.Time (DiffTime, LocalTime) +import Data.Sequence (Seq) + +-- | Top-level profiling report +data TimeAllocProfile = TimeAllocProfile + { profileTimestamp :: LocalTime + , profileCommandLine :: Text + , profileTotalTime :: TotalTime + , profileTotalAlloc :: TotalAlloc + , profileHotCostCentres :: [BriefCostCentre] + , 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 BriefCostCentre = BriefCostCentre + { briefCostCentreName :: Text + -- ^ Name of the cost-centre + , briefCostCentreModule :: Text + -- ^ Module name of the cost-centre + , briefCostCentreTime :: Double + -- ^ Total time spent in the cost-centre + , briefCostCentreAlloc :: Double + -- ^ Total allocation in the cost-centre + , 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 + -- ^ 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 + , costCentreNo :: CostCentreNo + -- ^ Identifier of the cost-centre + , costCentreEntries :: Integer + -- ^ Number of entries to the cost-centre + , costCentreIndTime :: Double + -- ^ Time spent in the cost-centre itself + , costCentreIndAlloc :: Double + -- ^ Allocation incurred by the cost-centre itself + , costCentreInhTime :: Double + -- ^ Time spent in the cost-centre's children + , costCentreInhAlloc :: Double + -- ^ 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)) + } deriving Show + +emptyCostCentreTree :: CostCentreTree +emptyCostCentreTree = CostCentreTree + { costCentreNodes = mempty + , costCentreParents = mempty + , costCentreChildren = mempty + , costCentreCallSites = 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 :: !Double + -- ^ Time spent in the callee function + , calleeAlloc :: !Double + -- ^ 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 :: !Double + -- ^ Time contributed by the caller function + , callSiteContribAlloc :: !Double + -- ^ 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