visual-prof 0.2 → 0.3
raw patch · 4 files changed
+33/−557 lines, 4 filesdep +split
Dependencies added: split
Files
- GraphUtils.hs +0/−86
- ParseProfile.hs +0/−414
- Prof2Html.hs +24/−54
- visual-prof.cabal +9/−3
− GraphUtils.hs
@@ -1,86 +0,0 @@------ GraphUtils.hs------ Copyright (c) 2007, 2008 Antiope Associates LLC, all rights reserved.-----module GraphUtils (- collapseParallel,- prune,- totalCost-) where--import Data.IntMap as IntMap-import Data.List as List--import ParseProfile----- For a list of calls, compute the sum of the counts (number of--- calls), ticks and allocs----totalCost :: [ CallInfo ] -> (Integer, Integer, Integer)-totalCost cis = let- cis' = nubBy (\x y -> stackNumber x == stackNumber y) cis- in- foldl (\(c, t, a) ci -> (c + counts ci, t + ticks ci, a + allocs ci)) (0, 0, 0) cis'---collapseCost :: [ CallInfo ] -> CallInfo-collapseCost = foldl (\ci ci' -> ci { parentNodeNumber = parentNodeNumber ci',- stackNumber = stackNumber ci',- counts = counts ci + counts ci',- ticks = ticks ci + ticks ci',- allocs = allocs ci + allocs ci'} ) emptyCallInfo- where- emptyCallInfo = CallInfo { parentNodeNumber = undefined,- stackNumber = undefined,- counts = 0,- ticks = 0,- allocs = 0 }--prunable :: Node -> Bool-prunable n = isLeaf n && totalCost (parentNodes n) == (0, 0, 0)----- The first thing to do is to find all the leaf nodes and delete--- the ones that have no costs associated with them. The pruneOnce--- function deletes the zero cost leaf nodes and returns a pair--- of the number of changes made and the pruned profile graph.----pruneOnce :: ProfileGraph -> (Int, ProfileGraph)-pruneOnce g = let- pruneNode :: (Int, ProfileGraph) -> Int -> (Int, ProfileGraph)- pruneNode (i, g') nc = if prunable (g' ! nc)- then (i + 1, IntMap.delete nc g')- else (i, g')- (nChanges, g'') = foldl pruneNode (0, g) (keys g)- in- (nChanges, markParents g'')---- repeatedly prune until there are no more changes----prune :: ProfileGraph -> ProfileGraph-prune g = let- (nChanges, g') = pruneOnce g- in- if nChanges == 0 then g' else prune g'----- Collapse parallel edges to a single edge----collapseParallel :: ProfileGraph -> ProfileGraph-collapseParallel = IntMap.map collapseParents----- For a given node n, collapse all of the parents with the same--- parentNode number.----collapseParents :: Node -> Node-collapseParents n = let- ps = parentNodes n- ps' = group (sort ps)- ci = List.map collapseCost ps'- in- n { parentNodes = ci }-
− ParseProfile.hs
@@ -1,414 +0,0 @@------ ParseProfile.hs------ Copyright (c) 2008 Antiope Associates LLC, all rights reserved.--------- This module parses the profile file generated when a program is run--- with the +RTS -px -RTS flag. The result is a Profile record that--- contains all of the information from the file.------ Although it does not describe the exact format output when using the--- +RTS -px -RTS flag, the best reference on the cost center stack accounting--- scheme is------ Morgan, R.G. and S.A. Jarvis, "Profiling large-scale lazy--- functional programs", J. Functional Prog 8 (3), 1998,--- pp. 201 - 237.--- --- The format of the profile file generated when using the "-px" flag:------ The first line is a quoted string giving the time of day when the--- profile was generated:------ <timestamp>------ The second line is a quoted string giving the sampling interval, e.g.,--- "20 ms":------ <tick interval>------ The profiling data begins with lines listing the names of all the cost--- centers, and the module to which each belongs. Each line begins with--- a literal '1':------ 1 <cost center number> <cost center name> <module name>------ The <cost center number> is a integer, the <cost center name> and--- <module name> are quoted strings.------ The call tree itself is given by lines beginning with a literal '2'.--- Each line looks like:------ 2 <cost center stack code> <root code> <cost center number> <parent node>------ The <cost center stack code> is identifies the stack to which this--- <cost center number> belongs. The <root code> is a literal '1' if this--- cost center is the root of the call tree, a literal '2' otherwise.--- The <parent node> is the cost center stack code of the parent of this--- cost center. If the <root code> is '1' the <parent node> field is--- absent. The <cost center stack code>, <cost center number> and--- <parent node> are all integers.------ One important thing to note is that multiple lines can have the same--- <cost center stack code>. Only the first entry contains cost accounting--- data. The other lines with the same <cost center stack code> are "back edges",--- used internally by the run time system to efficiently navigate the--- cost center stack graph, but not containing any additional accounting--- information.------ The final line of the file contains all of the actual profiling data.--- The format is:------ 5 <total ticks> {1 <cost center stack code> <call count> <tick count> <alloc count>}+ 0------ where the expression in curly braces is repeated for all of the--- cost center stack codes. Each cost reports for <cost center stack code>--- begins with a literal '1'. The <cost center stack code> and the--- <call count>, <tick count> and <alloc count> are all integers. The end--- of the profiling data is indicated by a literal '0'.------ So what's a cost center and what is a cost center stack? A cost center--- is simply a section of code to which costs are attributed. It is--- often a function, but source code annotations can be used to divide--- a function into several cost centers.------ For the purpose of understanding the profiling file format, a cost--- center stack is just a cost center and its calling cost center.--- Costs --- call counts, ticks spent executing and allocations --- are--- sttributed to call center stacks. This means, for example, that if--- both function_1 and function_2 call map, the costs of map will be--- in two call center stacks, one with function_1 as the parent of--- map, and another with function_2 as its parent. In essence, a--- call center stack can be thought of as an _edge_ of the call graph,--- while the cost centers themselves are the nodes.------ Note that the <cost center stack code> may not be unique. This can--- happen, for instance, if there are mutually recursive cost centers.--- In that case costs, while attributable to a particular node (cost center)--- can't be attributed to a specific edge (cost center stack).------ Parsing the profile returns a data structure called a ProfileGraph.--- This is an IntMap keyed by <cost center number>. The entries in the--- map are records giving the name of the cost center and the module to--- which it belongs, and an incidence list giving the nodes that call--- this cost center and the costs associated with each.------ Note that the conversion from call tree (in which each cost center--- can appear multiple times) to call graph (where each cost center--- appears only once) is implicitly done as part of the generation of--- the ProfileGraph record.-----module ParseProfile (- CallInfo(..),- Node(..),- Profile(..),- ProfileGraph,- markParents,- parseProfile-) where---import Control.Exception-import Data.IntMap as IntMap-import Data.List as List-import Data.Maybe as Maybe-import Text.ParserCombinators.Parsec as Parsec----- The CostCenter, CostCenterStack and CostCenterReport records--- hold the raw results of parsing the profile.----data CostCenter =- CostCenter { ccName :: String,- ccModule :: String }- deriving (Show)--data CostCenterStack =- CostCenterStack { childNode :: Int,- parentStack :: Maybe Int }- deriving (Show)--data CostCenterReport =- CostCenterReport { reportCount :: Integer,- reportTicks :: Integer,- reportAlloc :: Integer }- deriving (Show)---defaultCostCenterReport :: CostCenterReport-defaultCostCenterReport =- CostCenterReport { reportCount = 0,- reportTicks = 0,- reportAlloc = 0 }----- The Profile, ProfileGraph, Node and CallingNode types are--- used to return the annotated call graph.----type EdgeCode = Int-type NodeCode = Int-type ProfileGraph = IntMap Node--data Node =- Node { nodeNumber :: Int,- nodeName :: String,- nodeModule :: String,- isLeaf :: Bool,- parentNodes :: [ CallInfo ] }- deriving (Show)--data CallInfo =- CallInfo { parentNodeNumber :: Int,- stackNumber :: Int,- counts :: Integer,- ticks :: Integer,- allocs :: Integer }- deriving (Show)---data Profile =- Profile { timestamp :: String,- tickInterval :: String,- profileTicks :: Integer,- profileGraph :: ProfileGraph }- deriving (Show)----- Instances of Eq and Ord for CallInfo are handy for grouping--- and sorting the parent nodes.--- -instance Eq CallInfo where- (==) c1 c2 | pn1 == pn2 = True- | otherwise = False- where- pn1 = parentNodeNumber c1- pn2 = parentNodeNumber c2---instance Ord CallInfo where- compare c1 c2 | pn1 == pn2 = EQ- | pn1 < pn2 = LT- | otherwise = GT- where- pn1 = parentNodeNumber c1- pn2 = parentNodeNumber c2----- The parser----costCenterCode :: Parser Char-costCenterCode = char '1'--costCenterStackCode :: Parser Char-costCenterStackCode = char '2'--timeUpdateCode :: Parser Char-timeUpdateCode = char '5'--eol :: Parser ()-eol = do- Parsec.try (do char '\r'; newline) <|> newline- return ()- <?> "eol"--natural :: Parser Int-natural = do- digits <- many1 digit- return ((read digits) :: Int)- <?> "natural"--naturalLong :: Parser Integer-naturalLong = do- digits <- many1 digit- return ((read digits) :: Integer)- <?> "naturalLong"--quotedString :: Parser String-quotedString = do- char '"'- manyTill anyChar (Parsec.try (char '"'))- <?> "quotedString"--headerStr :: Parser String-headerStr = do - header <- quotedString; eol- return header- <?> "headerString"--costCenter :: Parser (NodeCode, CostCenter)-costCenter = do- costCenterCode; space- ccId <- natural; space- name <- quotedString; space- modul <- quotedString; eol- return (ccId, CostCenter { ccName = name,- ccModule = modul })- <?> "costCenter"--costCenterStack :: Parser (EdgeCode, [ CostCenterStack ])-costCenterStack = do- costCenterStackCode; space- ccsId <- natural; space- stackCode <- oneOf "12"; space- node <- natural- parent <- do if stackCode == '1'- then return Nothing- else do- space- p <- natural- return (Just p)- eol- return (ccsId, [ CostCenterStack { childNode = node,- parentStack = parent } ] )- <?> "costCenterStack"---ccsReport :: Parser (EdgeCode, CostCenterReport)-ccsReport = do- char '1'; space- ccsId <- natural; space- cs <- naturalLong; space- ts <- naturalLong; space- as <- naturalLong; space- return (ccsId, CostCenterReport { reportCount = cs,- reportTicks = ts,- reportAlloc = as })- <?> "ccsReport"---totalTicks :: Parser Integer-totalTicks = do- timeUpdateCode; space- ts <- naturalLong; space- return ts- <?> "totalTicks"---profile :: Parser Profile-profile = do- stamp <- headerStr- step <- headerStr- costCenters <- many costCenter- costCenterStacks <- many costCenterStack- totalTime <- totalTicks- times <- manyTill ccsReport (Parsec.try (char '0'))- let- p = mkProfileGraph costCenters costCenterStacks times-- return Profile { timestamp = stamp,- tickInterval = step,- profileTicks = totalTime,- profileGraph = p }- <?> "profile"----- Helper functions for converting the CostCenter, CostCenterStack--- and CostCenterReport lists into a ProfileGraph.----allSame :: Eq a => [ a ] -> Bool-allSame [] = True-allSame (_ : []) = True-allSame (x : xs) = if x /= head xs then False else allSame xs-- -mkEdge :: IntMap [ CostCenterStack ]- -> IntMap CostCenterReport- -> EdgeCode- -> (NodeCode, [ CallInfo ])-mkEdge edgeMap costMap e = let- sts = edgeMap ! e- children = List.map childNode sts- child = assert (allSame children) (head children)-- getCallInfo :: CostCenterStack -> Maybe CallInfo- getCallInfo st = let- parent = if isJust (parentStack st)- then let offspring = List.map childNode (edgeMap ! (fromJust (parentStack st)))- in assert (allSame children) (Just (head offspring))- else Nothing- in- if isJust parent- then let- c = findWithDefault defaultCostCenterReport e costMap- in- Just CallInfo { parentNodeNumber = fromJust parent,- stackNumber = e,- counts = reportCount c,- ticks = reportTicks c,- allocs = reportAlloc c }- else Nothing- in- (child, Maybe.mapMaybe getCallInfo sts)---mkEdges :: [ (EdgeCode, [ CostCenterStack ]) ]- -> [ (EdgeCode, CostCenterReport) ]- -> [ (NodeCode, [ CallInfo ]) ]-mkEdges ccss costs = let- edgeMap = fromListWith (\_ x -> x) ccss- costMap = fromList costs- mkEdge' = mkEdge edgeMap costMap- in- List.map mkEdge' (keys edgeMap)---edgesToNodes :: [ (NodeCode, CostCenter) ]- -> [ (NodeCode, [ CallInfo ]) ]- -> [ (NodeCode, Node) ] -edgesToNodes nodes edges = let- nodeMap = fromList nodes- mkNode :: (NodeCode, [ CallInfo ]) -> (NodeCode, Node)- mkNode (n, ci) = (n, Node { nodeNumber = n,- nodeName = ccName (nodeMap ! n),- nodeModule = ccModule (nodeMap ! n),- isLeaf = True,- parentNodes = ci } )- in- List.map mkNode edges---concatParents :: Node -> Node -> Node-concatParents n n' = Node { nodeNumber = nodeNumber n,- nodeName = nodeName n,- nodeModule = nodeModule n,- isLeaf = (isLeaf n) && (isLeaf n'),- parentNodes = (parentNodes n) ++ (parentNodes n') }----- Mark the Leaf nodes----markAll :: ProfileGraph -> ProfileGraph-markAll g = IntMap.map (\n -> n { isLeaf = True }) g--markParents :: ProfileGraph -> ProfileGraph-markParents g = let- nonLeaf = concatMap (\n -> List.map parentNodeNumber (parentNodes (g ! n))) (keys g)- g' = markAll g-- markAsParent :: ProfileGraph -> NodeCode -> ProfileGraph- markAsParent gr n = update (\n' -> Just n' { isLeaf = False }) n gr- in- foldl markAsParent g' nonLeaf----- Convert the raw CostCenter, CostCenterStack and CostCenterReport--- lists into a ProfileGraph.----mkProfileGraph :: [ (NodeCode, CostCenter) ]- -> [ (EdgeCode, [ CostCenterStack ] ) ]- -> [ (EdgeCode, CostCenterReport) ]- -> ProfileGraph-mkProfileGraph ccs ccss costs = let- edges = mkEdges ccss costs -- [ (NodeCode, [ CallInfo ]) ]- nodes = edgesToNodes ccs edges -- [ (NodeCode, Node) ]- in- markParents $ fromListWith concatParents nodes-- -parseProfile :: FilePath -> String -> Maybe Profile-parseProfile name input =- case parse profile name input of- Left _ -> Nothing- Right prof -> Just prof
Prof2Html.hs view
@@ -6,9 +6,8 @@ import Control.Applicative import Control.Arrow import qualified Control.Exception as Exc-import qualified Pretty as P import qualified Language.Haskell.Exts.Pretty as PP-import ParseProfile+import qualified Pretty as P import System.Process import System.Directory import System.Environment@@ -16,11 +15,10 @@ import System.IO.Error import System.IO import Data.Maybe-import GraphUtils import Data.Char+import Data.List.Split import qualified Data.IntMap as IMap import Text.RegexPR-import Debug.Trace import Numeric import Data.List @@ -35,101 +33,73 @@ = do st <- get put (st + 1) return $ addSCC st $ strip e- + strip :: Exp_ -> Exp_ strip (SCCPragma _ e) = e strip e = e- + addSCC :: Int -> Exp_ -> Exp_ addSCC _ e@(Var _) = e addSCC _ e@(Lit _) = e addSCC num e = Paren $ SCCPragma (show num) e++addColour :: IMap.IntMap Float -> String -> String addColour m s = gsubRegexPRBy (pref ++ ".*?" ++ suf) (\ str -> pref ++ sccNumToColour str ++ suf) s- where + where sccNumToColour :: String -> String sccNumToColour str- = maybe transparentColour toColour $ lookup (readSCCNumber str) m- + = maybe transparentColour toColour (readSCCNumber str `IMap.lookup` m)+ readSCCNumber :: String -> Int readSCCNumber str = fst $ head $ reads $ drop (length pref) str pref = "color: #" suf = "\">"+ transparentColour = "00ffffff"- + toColour :: Float -> String toColour fl | 0 <= fl && fl < 1.0e-2 = transparentColour | 1.0e-2 <= fl && fl < yellow = (pad $ showHex (truncate $ fl * 255 * (1 / yellow)) "") ++ "ff00" | yellow <= fl && fl <= 1 =- "ff" ++- (pad $- showHex (255 - (truncate $ (fl - yellow) * 255 / (1 - yellow))) "")- ++ "00"- where + "ff" ++ (pad $ showHex (255 - (truncate $ (fl - yellow) * 255 / (1 - yellow))) "") ++ "00"+ where pad :: String -> String pad str = if length str == 1 then '0' : str else str yellow = 0.1- + parseModuleFromFile :: FilePath -> IO Module parseModuleFromFile path = fromParseResult <$> parseFile path- -computeTicksMap :: Profile -> [(Int, Float)]-computeTicksMap prof- = map (\ n -> (read $ nodeName n :: Int, ticksFraction n)) $- filter (isNumber . head . nodeName) $ IMap.elems graph- where totalTicks = profileTicks prof- graph = profileGraph prof- ticksFraction n- = (fromInteger $ snd3 $ totalCost $ parentNodes n) /- (fromInteger totalTicks)- -computeAllocMap :: Profile -> [(Int, Float)]-computeAllocMap prof- = allocFraction $- map (\ n -> (read $ nodeName n :: Int, alloc n)) $- filter (isNumber . head . nodeName) $ IMap.elems graph- where graph = profileGraph prof- - alloc :: Node -> Float- alloc n = fromInteger $ trd3 $ totalCost $ parentNodes n- allocFraction l = map (second (/ sumSnd l)) l- - sumSnd :: [(Int, Float)] -> Float- sumSnd l = sum $ map snd l- -snd3 :: (Integer, Integer, Integer) -> Integer-snd3 (_, x, _) = x- -trd3 :: (Integer, Integer, Integer) -> Integer-trd3 (_, _, x) = x+ ind l n = if length l > n then Just $ l !! n else Nothing+ outputHTML file profName tm = do putStrLn "parsing profiling results"- profFile <- readFile $ profName- let prof = fromJust $ parseProfile profName profFile- when (profileTicks prof == 0)- (error "the program has to run longer to get enough information")- let profMap = computeTicksMap prof+ profFile <- lines <$> readFile profName+ let prof = map (wordsBy (==' ')) $ takeWhile (/="") $ drop 9 profFile+ {-when (profileTicks prof == 0)-}+ {-(error "the program has to run longer to get enough information")-}+ let profMap = IMap.fromList $ zip (map (read . (!!0)) prof) (map ((/100) . read . (!!2)) prof) putStrLn "printing output html file" let html = addColour profMap $ pprint tm writeFile (file ++ ".html") html- + main :: IO () main = do args <- getArgs let mode = args !! 0 let file = args !! 1 let run = args !! 2- unless ("-h" `isPrefixOf` mode || "-px" `isPrefixOf` mode)+ unless ("-h" `isPrefixOf` mode || "-p" `isPrefixOf` mode) (error "mode should be -h or -px") let programArgs = ind args 3 let inpFile = ind args 4 let bak = file ++ ".bak"- let profName = (takeBaseName run) ++ ".prof"+ let profName = takeBaseName run ++ ".prof" (do removeFile bak `catch` (\ e -> unless (isDoesNotExistError e) $ ioError e) renameFile file bak
visual-prof.cabal view
@@ -1,5 +1,5 @@ Name: visual-prof-Version: 0.2+Version: 0.3 Cabal-Version: >= 1.2 License: BSD3 License-file: LICENSE@@ -19,6 +19,12 @@ This will profile the C.hs file used by run.hs which contains the Main module of your project. Arguments to ./run are passed as shown (arg1, arg2,...). The parameters should be given in that order.+ .+ The simplest way to run it is:+ .+ > visual-prof -px test.hs test+ .+ which will generate a profile for the file test.hs (which needs to have a main function) Maintainer: djvelkov@gmail.com Category: Development@@ -32,7 +38,7 @@ Build-Depends: base >= 3 && < 5, containers else Build-Depends: base < 3- Build-depends: parsec, filepath, haskell-src-exts, regexpr, directory, process, pretty, mtl, uniplate+ Build-depends: parsec, filepath, haskell-src-exts, regexpr, directory, process, pretty, mtl, uniplate, split Main-is: Prof2Html.hs- Other-modules: GraphUtils ParseProfile Pretty+ Other-modules: Pretty