diff --git a/GraphUtils.hs b/GraphUtils.hs deleted file mode 100644 --- a/GraphUtils.hs +++ /dev/null @@ -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 } - diff --git a/ParseProfile.hs b/ParseProfile.hs deleted file mode 100644 --- a/ParseProfile.hs +++ /dev/null @@ -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: --- --- --- --- The second line is a quoted string giving the sampling interval, e.g., --- "20 ms": --- --- --- --- 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 --- --- The is a integer, the and --- are quoted strings. --- --- The call tree itself is given by lines beginning with a literal '2'. --- Each line looks like: --- --- 2 --- --- The is identifies the stack to which this --- belongs. The is a literal '1' if this --- cost center is the root of the call tree, a literal '2' otherwise. --- The is the cost center stack code of the parent of this --- cost center. If the is '1' the field is --- absent. The , and --- are all integers. --- --- One important thing to note is that multiple lines can have the same --- . Only the first entry contains cost accounting --- data. The other lines with the same 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 {1 }+ 0 --- --- where the expression in curly braces is repeated for all of the --- cost center stack codes. Each cost reports for --- begins with a literal '1'. The and the --- , and 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 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 . 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 diff --git a/Prof2Html.hs b/Prof2Html.hs --- a/Prof2Html.hs +++ b/Prof2Html.hs @@ -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 diff --git a/visual-prof.cabal b/visual-prof.cabal --- a/visual-prof.cabal +++ b/visual-prof.cabal @@ -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