profiterole (empty) → 0.1
raw patch · 10 files changed
+342/−0 lines, 10 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, extra, filepath, ghc-prof, hashable, scientific, text
Files
- CHANGES.txt +4/−0
- LICENSE +30/−0
- README.md +25/−0
- Setup.hs +2/−0
- profiterole.cabal +44/−0
- src/Config.hs +23/−0
- src/Main.hs +80/−0
- src/Report.hs +62/−0
- src/Type.hs +57/−0
- src/Util.hs +15/−0
+ CHANGES.txt view
@@ -0,0 +1,4 @@+Changelog for Profiterole++0.1+ Initial version
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2017.+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 Neil Mitchell 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.
+ README.md view
@@ -0,0 +1,25 @@+# Profiterole [](https://hackage.haskell.org/package/profiterole) [](https://www.stackage.org/package/profiterole) [](https://travis-ci.org/ndmitchell/profiterole) [](https://ci.appveyor.com/project/ndmitchell/profiterole)++Script for reading and restructring a GHC profile script.++## The Goal++Given profile data, different ways of looking at it reveal different insights. This tool provides one of those insights - in addition to reading the standard profile output and using other tools such as [Profiteur](https://hackage.haskell.org/package/profiteur).++Profiterole aims to make the profile shorter by combining common subtrees and lifting them to the root - e.g. if you call `parseFile` from 7 places in the code, instead of having 7 pieces of `parseFile` profiling, Profiterole will give you one.++As an example compare [HLint profile input](https://gist.github.com/ndmitchell/308cd9a2774873c9a74ee613ae203b65#file-hlint-prof) to [HLint Profiterole output](https://gist.github.com/ndmitchell/ab790bbfa482a70fa2db020fda623309#file-hlint-profiterole-txt).++## Usage++To run, first install (`cabal update && cabal install profiterole`), generate a GHC profile the [normal way](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/profiling.html), then run:++ profiterole myprogram.prof++Profiterole will generate `myprogram.profiterole.txt` and `myprogram.profiterole.html` - both contain the same information, but the HTML has hyperlinks. There are three columns of numbers:++* `TOT` is the total time spent in any item under this code, what GHC calls inherited time.+* `INH` is the total time spent in the items that Profiterole did not move out to the top level.+* `IND` is the individual time, just like GHC profiles.++For large programs, using `+RTS -P` (instead of the common `-p`) will give more accurate results.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ profiterole.cabal view
@@ -0,0 +1,44 @@+cabal-version: >= 1.18+build-type: Simple+name: profiterole+version: 0.1+license: BSD3+license-file: LICENSE+category: Development+author: Neil Mitchell <ndmitchell@gmail.com>+maintainer: Neil Mitchell <ndmitchell@gmail.com>+copyright: Neil Mitchell 2017+synopsis: Restructure GHC profile reports+description:+ Given a GHC profile output, this tool generates alternative views on the data,+ which are typically more concise and may reveal new insights.+homepage: https://github.com/ndmitchell/profiterole#readme+bug-reports: https://github.com/ndmitchell/profiterole/issues+extra-doc-files:+ README.md+ CHANGES.txt+tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3++source-repository head+ type: git+ location: https://github.com/ndmitchell/profiterole.git++executable profiterole+ default-language: Haskell2010+ main-is: Main.hs+ hs-source-dirs: src+ build-depends:+ base >= 4.6 && < 5,+ containers,+ directory,+ extra,+ filepath,+ ghc-prof,+ hashable,+ scientific,+ text+ other-modules:+ Config+ Report+ Type+ Util
+ src/Config.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE ViewPatterns #-}++module Config(emptyConfig, readConfig, Config(..)) where++import Data.List.Extra+import qualified Data.Map as Map+import System.IO.Extra+import Data.Functor+import Prelude+++data Config = Root | Bury deriving Eq++readConfig :: FilePath -> IO (String -> Maybe Config)+readConfig file = do+ let f (stripPrefix "root: " -> Just x) = (x, Root)+ f (stripPrefix "bury: " -> Just x) = (x, Bury)+ f x = error $ "Bad config, got " ++ show x+ mp <- Map.fromList . map f . lines <$> readFile' file+ return $ flip Map.lookup mp++emptyConfig :: String -> Maybe Config+emptyConfig _ = Nothing
+ src/Main.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE RecordWildCards, ViewPatterns #-}++module Main(main) where++import GHC.Prof+import Control.Monad+import Data.List.Extra+import Data.Char+import Data.Monoid+import Data.Tree+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.Text.Lazy.IO as T+import System.Environment+import System.FilePath+import System.Directory+import Type+import Config+import Report+import Data.Functor+import Prelude+++main :: IO ()+main = do+ [arg] <- getArgs+ Right vals <- fmap (removeZero . valFromProfile) . decode <$> T.readFile arg+ b <- doesFileExist ".profiterole.yaml"+ config <- if b then readConfig ".profiterole.yaml" else return emptyConfig+ let roots = findRoots config vals+ let vals2 = mergeRoots $ liftRoots roots vals+ let arg0 = if takeExtension arg == ".prof" then dropExtension arg else arg+ let writeTo file x = do+ putStrLn $ "Writing to " ++ file ++ " ..."+ writeFile file x+ writeTo (arg0 <.> "profiterole.txt") $ unlines $ reportText vals2+ writeTo (arg0 <.> "profiterole.html") $ unlines $ reportHTML vals2+ putStrLn "Done"+ when False $ do+ -- Should check the time is not lost, if it is, suggest -P+ print $ sum $ map timeInd $ concatMap flatten vals2+ print $ sum $ map (timeInh . rootLabel) vals2+++---------------------------------------------------------------------+-- TRANSFORMATIONS++removeZero :: Tree Val -> Tree Val+removeZero (Node x xs) = Node x $ map removeZero $ filter (not . isZero . rootLabel) xs+ where isZero Val{..} = timeTot == 0+++-- | A root has at least two distinct parents and isn't a local binding+findRoots :: (String -> Maybe Config) -> Tree Val -> Set.Set String+findRoots config x = Map.keysSet $+ Map.filterWithKey (\k v -> case config k of+ Just Root -> True+ Just Bury -> False+ Nothing -> not (isLocal k) && Set.size v > 1) $+ Map.fromListWith (<>) $ f x+ where+ f (Node v xs) = [(name $ rootLabel x, Set.singleton $ name v) | x <- xs] +++ concatMap f xs+ isLocal (word1 -> (_, x)) = any isAlpha x && '.' `elem` x++liftRoots :: Set.Set String -> Tree Val -> [Tree Val]+liftRoots = fs+ where+ fs set x = let (y,_,ys) = f set x in y:ys++ -- return (this tree, discount to apply up, new roots)+ f :: Set.Set String -> Tree Val -> (Tree Val, Double, [Tree Val])+ f set (Node x ys)+ | name x `Set.member` set = (Node x{timeInh=0,timeInd=0} [], timeInh x, fs (Set.delete (name x) set) $ Node x ys)+ | otherwise = (Node x{timeInh = timeInh x - disc} child, disc, root)+ where (child, sum -> disc, concat -> root) = unzip3 $ map (f set) ys++mergeRoots :: [Tree Val] -> [Tree Val]+mergeRoots xs = Map.elems $ Map.fromListWith f [(name $ rootLabel x, x) | x <- xs]+ where f (Node x xs) (Node y ys) = Node (mergeVal x y) $ mergeRoots $ xs ++ ys
+ src/Report.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE RecordWildCards #-}++module Report(+ reportText,+ reportHTML+ ) where++import Data.List.Extra+import Data.Tree+import Data.Char+import Data.Hashable+import qualified Data.Set as Set+import Numeric.Extra+import Util+import Type+++presort :: [Tree Val] -> [Tree Val]+presort =+ sortOn (negate . timeInh . rootLabel) .+ fmapForest (sortOn (negate . timeTot . rootLabel))+++reportHTML :: [Tree Val] -> [String]+reportHTML vals =+ let vals2 = presort vals+ indent i x = x{name = replicate (i*2) ' ' ++ name x}+ links = Set.fromList $ map (name . rootLabel) vals2+ anchor x = "<a id='" ++ show (hash x) ++ "'></a>"+ in (["<pre>"] ++) $ (++ ["</pre>"]) $ intercalate [""] $+ (" TOT INH IND" : map (showHTML links . rootLabel) (take 25 vals2)) :+ [ anchor (name $ rootLabel x) :+ map (showHTML $ Set.delete (name $ rootLabel x) links) (flatten $ fmapTreeDepth indent x)+ | x <- vals2]++showHTML :: Set.Set String -> Val -> String+showHTML xs Val{..} = intercalate " "+ [showDouble timeTot, showDouble timeInh, showDouble timeInd+ ,spc ++ (if nam `Set.member` xs then link else nam) ++ " (" ++ show entries ++ ")"]+ where+ link = "<a href='#" ++ show (hash nam) ++ "'>" ++ nam ++ "</a>"+ (spc,nam) = span isSpace name+++reportText :: [Tree Val] -> [String]+reportText vals =+ let vals2 = presort vals+ indent i x = x{name = replicate (i*2) ' ' ++ name x}+ in intercalate ["",""] $+ (" TOT INH IND" : map (showText . rootLabel) (take 25 vals2)) :+ [map showText $ flatten $ fmapTreeDepth indent x | x <- vals2]++showText :: Val -> String+showText Val{..} = intercalate " "+ [showDouble timeTot, showDouble timeInh, showDouble timeInd, name ++ " (" ++ show entries ++ ")"]++showDouble :: Double -> String+showDouble x = case showDP 1 x of+ "0.0" -> " -"+ "100.0" -> "99.9" -- avoid making the column bigger for a corner case+ ['0','.',x] -> [' ',' ','.',x]+ x -> replicate (4 - length x) ' ' ++ x
+ src/Type.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE RecordWildCards #-}++module Type(+ Val(..),+ mergeVal,+ valFromProfile+ ) where++import GHC.Prof+import Data.Maybe+import Data.Scientific+import Data.Tree+import qualified Data.Text as T+++data Val = Val+ {name :: String -- Name of this node+ ,timeTot :: Double -- Time spent under this node+ ,timeInh :: Double -- Time spent under this node excluding rerooted+ ,timeInd :: Double -- Time spent in this code+ ,entries :: Integer -- Number of times this node was called+ } deriving Show+++mergeVal :: Val -> Val -> Val+mergeVal x y+ | name x /= name y = error "mergeRoots, invariant violated"+ | otherwise = Val+ {name = name x+ ,timeTot = timeTot x + timeTot y+ ,timeInh = timeInh x + timeInh y+ ,timeInd = timeInd x + timeInd y+ ,entries = entries x + entries y}+++valFromProfile :: Profile -> Tree Val+valFromProfile prf = case costCentres prf of+ Nothing -> error "Failed to generate value tree from profile (no idea why - corrupt profile?)"+ Just x+ | isNothing $ costCentreTicks $ rootLabel x -> fmap toValTime x+ | otherwise -> fixTotInh $ fmap (toValTick $ (* 0.01) $ fromInteger $ totalTimeTicks $ profileTotalTime prf) x++toValTime :: CostCentre -> Val+toValTime CostCentre{..} = Val+ (T.unpack costCentreModule ++ " " ++ T.unpack costCentreName)+ inh inh (toRealFloat costCentreIndTime)+ costCentreEntries+ where inh = toRealFloat costCentreInhTime++toValTick :: Double -> CostCentre -> Val+toValTick tot cc = (toValTime cc){timeInd = fromInteger (fromJust $ costCentreTicks cc) / tot}++fixTotInh :: Tree Val -> Tree Val+fixTotInh (Node x xs) = Node x{timeTot=t, timeInh=t} ys+ where+ ys = map fixTotInh xs+ t = timeInd x + sum (map (timeInh . rootLabel) ys)
+ src/Util.hs view
@@ -0,0 +1,15 @@++module Util(fmapForest, fmapTreeDepth) where++import Data.Tree+++-- | 'fmap' over a 'Tree', but passing the depth as well+fmapTreeDepth :: (Int -> a -> b) -> Tree a -> Tree b+fmapTreeDepth op = f 0+ where f i (Node x xs) = Node (op i x) $ map (f $! i+1) xs++-- | 'fmap' over a forest, bottom-up+fmapForest :: ([Tree a] -> [Tree a]) -> [Tree a] -> [Tree a]+fmapForest op = f+ where f xs = op [Node y $ f ys | Node y ys <- xs]