packages feed

ghc-time-alloc-prof (empty) → 0.0.0

raw patch · 8 files changed

+650/−0 lines, 8 filesdep +attoparsecdep +basedep +containerssetup-changed

Dependencies added: attoparsec, base, containers, ghc-time-alloc-prof, 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,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)+  ++ ")"+
+ ghc-time-alloc-prof.cabal view
@@ -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 <maoe@foldr.in>+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
+ src/GHC/RTS/TimeAllocProfile.hs view
@@ -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
+ src/GHC/RTS/TimeAllocProfile/CostCentreTree.hs view
@@ -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+    }
+ src/GHC/RTS/TimeAllocProfile/Parser.hs view
@@ -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
+ src/GHC/RTS/TimeAllocProfile/Types.hs view
@@ -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