diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Claude Heiland-Allen + +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 Claude Heiland-Allen 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/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -0,0 +1,3 @@ +v0.1 2010-07-28 first release +The result of a few days hacking, hp2pretty is born. +Source code statistics: 397 lines, 2406 words, 14212 chars. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,39 @@ +hp2pretty +========= + +hp2ps is a tool to generate PostScript graphs of Heap Profiles. +hp2pretty is a rewrite of hp2ps, implemented in Haskell, with +the aims of being maintainable, with more flexible output, and +more beautiful output. Currently hp2pretty outputs Scalable +Vector Graphics (SVG) only, though PostScript (PS) is planned. +Also none (count'em) of hp2ps' options are implemented yet in +hp2pretty. + + +Benchmarks +---------- + +(updated 2010-07-28) + +$ wc in.hp + 1484749 2969502 37406420 in.hp + +$ time ./Main out.svg +real 0m38.786s 0m39.423s 0m38.674s +user 0m38.120s 0m38.800s 0m38.110s +sys 0m00.360s 0m00.250s 0m00.400s + +$ time hp2ps out.ps +real 0m38.474s 0m38.765s 0m38.017s +user 0m38.350s 0m38.200s 0m37.860s +sys 0m00.090s 0m00.140s 0m00.150s + +(hp2pretty compiled with "ghc -O2 --make") + +Essentially identical runtime! + +Memory usage from 'top': +hp2pretty ~275M +hp2ps ~50M + +Tests were run on 64bit GNU/Linux with ghc-6.12.3. 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/hp2pretty.cabal b/hp2pretty.cabal new file mode 100644 --- /dev/null +++ b/hp2pretty.cabal @@ -0,0 +1,40 @@ +Name: hp2pretty +Version: 0.1 +Synopsis: generate pretty graphs from heap profiles +Description: hp2pretty is a rewrite of hp2ps, implemented in Haskell, with + the aims of being maintainable, with more flexible output, and + more beautiful output. Currently hp2pretty outputs Scalable + Vector Graphics (SVG) only, though PostScript (PS) is planned. + Also none (count'em) of hp2ps' options are implemented yet in + hp2pretty. + . + Usage: "hp2pretty out.svg" +Homepage: http://gitorious.org/hp2pretty +License: BSD3 +License-file: LICENSE +Author: Claude Heiland-Allen +Maintainer: claudiusmaximus@goto10.org +Copyright: (C) 2010 Claude Heiland-Allen +Category: Development +Build-type: Simple +Extra-source-files: NEWS README +Cabal-version: >=1.6 + +Executable hp2pretty + Build-depends: base >= 4 && < 5, array, bytestring, containers, mtl + HS-source-dirs: src + Main-is: Main.hs + Other-modules: Parse + Process + Pretty + Print + Types + +Source-repository head + type: git + location: git://gitorious.org/hp2pretty/hp2pretty.git + +Source-repository this + type: git + location: git://gitorious.org/hp2pretty/hp2pretty.git + tag: v0.1 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import Prelude hiding (print, interact) +import Data.ByteString.Lazy.Char8(interact) + +import Parse (parse) +import Process (process) +import Pretty (pretty) +import Print (print) + +main :: IO () +main = interact $ print . pretty . process . parse diff --git a/src/Parse.hs b/src/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Parse.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE BangPatterns #-} +module Parse where + +import Control.Monad.State.Strict (State(), runState, get, put) +import Control.Monad (foldM) +import Data.Map (Map, empty, insertWith', alter, (!)) +import Numeric (readSigned, readFloat) +import Prelude hiding (lines, words, drop, length) +import Data.ByteString.Lazy.Char8 (ByteString, pack, unpack, lines, words, isPrefixOf, drop, length) + +import Types + +data Parse = + Parse + { symbols :: !(Map ByteString ByteString) -- intern symbols to save RAM + , totals :: !(Map ByteString Double ) -- compute running totals + } + deriving (Read, Show, Eq, Ord) + +parse0 :: Parse +parse0 = Parse{ symbols = empty, totals = empty } + +parse :: ByteString -> Run +parse s = + let ls = lines s + (hs, ss) = splitAt 4 ls + [job, date, smpU, valU] = + zipWith header [sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT] hs + (frames, parse1) = flip runState parse0 . mapM parseFrame . chunkSamples $ ss + in Run + { hprJob = job + , hprDate = date + , hprSampleUnit = smpU + , hprValueUnit = valU + , hprFrames = frames + , hprTotals = totals parse1 + } + +header :: ByteString -> ByteString -> ByteString +header name h = + if name `isPrefixOf` h + then pack . read . unpack . drop (length name + 1) $ h + else error $ "Parse.header: expected " ++ unpack name + +chunkSamples :: [ByteString] -> [[ByteString]] +chunkSamples [] = [] +chunkSamples (x:xs) + | sBEGIN_SAMPLE `isPrefixOf` x = + let (ys, zs) = break (sEND_SAMPLE `isPrefixOf`) xs + in case zs of + [] -> [] -- discard incomplete sample + (_:ws) -> (x:ys) : chunkSamples ws + | otherwise = [] -- expected BEGIN_SAMPLE or EOF... + +parseFrame :: [ByteString] -> State Parse Frame +parseFrame [] = error "Parse.parseFrame: empty" +parseFrame (l:ls) = do + let time = sampleTime sBEGIN_SAMPLE l + samples <- foldM inserter empty ls + return Frame + { hpfTime = time + , hpfSamples = samples + } + +inserter :: Map ByteString Double -> ByteString -> State Parse (Map ByteString Double) +inserter !m s = do + let [k,vs] = words s + !v = readDouble vs + p <- get + let symbols' = alter (intern k) k (symbols p) + totals' = alter (accum v) k (totals p) + put $! p{ symbols = symbols', totals = totals' } + p' <- get + return $! insertWith' (+) (symbols p' ! k) v m + +intern :: ByteString -> Maybe ByteString -> Maybe ByteString +intern s Nothing = Just s +intern _ js = js + +accum :: Double -> Maybe Double -> Maybe Double +accum x Nothing = Just x +accum x (Just y) = Just $! x + y + +sampleTime :: ByteString -> ByteString -> Double +sampleTime name h = + if name `isPrefixOf` h + then readDouble . drop (length name + 1) $ h + else error $ "Parse.sampleTime: expected " ++ unpack name ++ " but got " ++ unpack h + +readDouble :: ByteString -> Double +readDouble s = case readSigned readFloat (unpack s) of + ((x,_):_) -> x + _ -> error $ "Parse.readDouble: no parse " ++ unpack s + +sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT, sBEGIN_SAMPLE, sEND_SAMPLE :: ByteString +sJOB = pack "JOB" +sDATE = pack "DATE" +sSAMPLE_UNIT = pack "SAMPLE_UNIT" +sVALUE_UNIT = pack "VALUE_UNIT" +sBEGIN_SAMPLE = pack "BEGIN_SAMPLE" +sEND_SAMPLE = pack "END_SAMPLE" diff --git a/src/Pretty.hs b/src/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Pretty.hs @@ -0,0 +1,53 @@ +module Pretty where + +import Control.Monad (forM_, liftM2) +import Data.Array.ST +import Data.Array.Unboxed (UArray) +import Data.ByteString.Lazy.Char8 (pack) + +import Types + +pretty :: Info -> Graph +pretty hpi = + let sticks = uncurry (ticks 20) (hpiSampleRange hpi) + vticks = uncurry (ticks 20) (hpiValueRange hpi) + labels = pack "(trace elements)" : (reverse . map fst . hpiValues) hpi + values = hpiTrace hpi : (reverse . map snd . hpiValues) hpi + bands = accumulate values + in Graph + { hpgJob = hpiJob hpi + , hpgDate = hpiDate hpi + , hpgSampleUnit = hpiSampleUnit hpi + , hpgValueUnit = hpiValueUnit hpi + , hpgSampleRange= hpiSampleRange hpi + , hpgValueRange = hpiValueRange hpi + , hpgSampleTicks= sticks + , hpgValueTicks = vticks + , hpgLabels = labels + , hpgBands = bands + , hpgSamples = hpiSamples hpi + } + +accumulate :: [[Double]] -> UArray (Int, Int) Double +accumulate [] = error $ "accumulate': empty" +accumulate xss@(x:_) = runSTUArray $ do + let bands = length xss + samples = length x + a <- newListArray ((0,1),(bands,samples)) $ replicate samples 0 ++ concat xss + forM_ [1 .. samples] $ \s -> + forM_ [1 .. bands] $ \b -> + writeArray a (b, s) =<< liftM2 (+) (readArray a (b - 1, s)) (readArray a (b, s)) + return a + +ticks :: Int -> Double -> Double -> [Double] +ticks n mi ma = + let k = nearestNice $ (ma - mi) / fromIntegral n + m0 = fromIntegral (ceiling (mi / k) :: Integer) * k + m1 = fromIntegral (floor (ma / k) :: Integer) * k + in [m0, m0 + k .. m1 ] + +nearestNice :: Double -> Double +nearestNice k0 = head . dropWhile (< k0) $ nices + +nices :: [Double] +nices = [ f * k | f <- map (10**) [-6 ..], k <- [1,2,5] ] diff --git a/src/Print.hs b/src/Print.hs new file mode 100644 --- /dev/null +++ b/src/Print.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} +module Print where + +import Prelude hiding (concat, unlines) +import qualified Prelude as P +import Data.Array.Unboxed (bounds, (!)) +import Data.ByteString.Lazy.Char8 (ByteString, pack, concat) +import Numeric (showHex, showFFloat) + +import Types + +print :: Graph -> ByteString +print hpg = + let fwd = hpgSamples hpg + rwd = reverse fwd --)) (hpgBands hpg) + ((b0,s0),(b1,s1)) = bounds (hpgBands hpg) + bands = + [ (fwd ++ rwd) `zip` (bfwd ++ brwd) + | b <- [b0 + 1 .. b1] + , let bfwd = [ hpgBands hpg ! (b - 1, s) | s <- [s0 .. s1] ] + , let brwd = [ hpgBands hpg ! (b, s) | s <- [s1, s1 - 1 .. s0] ] + ] -- zipWith (\s t -> s ++ reverse t) paths (tail paths) + polygons = zipWith polygon colours . map (map p) . reverse $ bands + key = zipWith3 (keyBox (gW + border * 2.5) (border * 1.5) (gH / 16)) [0..] colours . reverse . hpgLabels $ hpg + w = 1280 + h = 720 + gW = 960 - 2 * border + gH = 720 - 3 * border + border = 60 + textOffset = 10 + (xMin, xMax) = hpgSampleRange hpg + (yMin, yMax) = hpgValueRange hpg + gRange@((gx0,gy0),(gx1,gy1)) = ((border*1.5, gH + border*1.5), (gW + border*1.5, border*1.5)) + p = rescalePoint ((xMin, yMin), (xMax, yMax)) gRange + title = [ "" , hpgJob hpg , " (" , hpgDate hpg , ")" ] + background = [ "" ] + box = [ "" ] + gStart = [ "" ] + leftLabel = [ "" , hpgValueUnit hpg , "" ] + leftTicks = map (\(y,l) -> let { (x1, y1) = p (xMin, y) ; (x2, y2) = p (xMax, y) } in + [ "" ] ++ + if l then [] else [ "" , showSI y , "" ] + ) (zip (hpgValueTicks hpg) (replicate (length (hpgValueTicks hpg) - 1) False ++ [True])) + bottomLabel = [ "" , hpgSampleUnit hpg , "" ] + bottomTicks = map (\(x,l) -> let { (x1, y1) = p (x, yMin) ; (x2, y2) = p (x, yMax) } in + [ "" ] ++ + if l then [] else [ "" , showSI x , "" ] + ) (zip (hpgSampleTicks hpg) (replicate (length (hpgSampleTicks hpg) - 1) False ++ [True])) + gEnd = [ "" ] + in concat . P.concat $ [ xmldecl, svgStart w h, background, gStart, title, leftLabel, P.concat leftTicks, bottomLabel, P.concat bottomTicks, box, P.concat polygons, P.concat key, gEnd, svgEnd ] + +showSI :: Double -> ByteString +showSI x | x < 1e3 = showF x + | x < 1e6 = concat [ showF (x/1e3 ) , "k" ] + | x < 1e9 = concat [ showF (x/1e6 ) , "M" ] + | x < 1e12 = concat [ showF (x/1e9 ) , "G" ] + | x < 1e15 = concat [ showF (x/1e12) , "T" ] + | otherwise = concat [ showF (x/1e15) , "P" ] + +showF :: Double -> ByteString +showF x = pack $ showFFloat Nothing x "" + +showI :: Int -> ByteString +showI x = pack $ show x + +keyBox :: Double -> Double -> Double -> Int -> ByteString -> ByteString -> [ByteString] +keyBox x y0 dy i c l = + let y = y0 + fromIntegral i * dy + in [ "" + , "" , l , "" ] + +polygon :: ByteString -> [(Double,Double)] -> [ByteString] +polygon c ps = [ "" ] + +path :: [(Double,Double)] -> [ByteString] +path [] = error "Print.path: []" +path (p0:ps) = + let lineTo p = [ " L " ] ++ toSVGPoint p + in [ "M " ] ++ toSVGPoint p0 ++ concatMap lineTo (ps ++ [p0]) ++ [ " Z" ] + +rescalePoint :: ((Double,Double),(Double,Double)) -> ((Double,Double),(Double,Double)) -> (Double, Double) -> (Double,Double) +rescalePoint ((inX0,inY0),(inX1,inY1)) ((outX0,outY0),(outX1,outY1)) (x,y) = + let inW = inX1 - inX0 + inH = inY1 - inY0 + outW = outX1 - outX0 + outH = outY1 - outY0 + in ((x - inX0) / inW * outW + outX0, (y - inY0) / inH * outH + outY0) + +toSVGPoint :: (Double,Double) -> [ByteString] +toSVGPoint (x,y) = [ showF x , "," , showF y ] + +xmldecl :: [ByteString] +xmldecl = [ "" ] + +svgStart :: Int -> Int -> [ByteString] +svgStart w h = [ "" ] + +svgEnd :: [ByteString] +svgEnd = [ "" ] + +phi :: Double +phi = (sqrt 5 + 1) / 2 + +hues :: [Double] +hues = [0, 2 * pi / (phi * phi) ..] + +sats :: [Double] +sats = repeat 1 + +vals :: [Double] +vals = repeat 1 + +wrap :: Double -> Double +wrap x = x - fromIntegral (floor x :: Int) + +colours :: [ByteString] +colours = map toSVGColour $ zipWith3 toRGB hues sats vals + +toRGB :: Double -> Double -> Double -> (Double, Double, Double) +toRGB h s v = + let hh = h * 3 / pi + i = floor hh `mod` 6 :: Int + f = hh - fromIntegral (floor hh :: Int) + p = v * (1 - s) + q = v * (1 - s * f) + t = v * (1 - s * (1 - f)) + in case i of + 0 -> (v,t,p) + 1 -> (q,v,p) + 2 -> (p,v,t) + 3 -> (p,q,v) + 4 -> (t,p,v) + _ -> (v,p,q) + +toSVGColour :: (Double, Double, Double) -> ByteString +toSVGColour (r,g,b) = + let toInt x = let y = floor (256 * x) in 0 `max` y `min` 255 :: Int + hex2 i = (if i < 16 then ('0':) else id) (showHex i "") + in pack $ '#' : concatMap (hex2 . toInt) [r,g,b] diff --git a/src/Process.hs b/src/Process.hs new file mode 100644 --- /dev/null +++ b/src/Process.hs @@ -0,0 +1,39 @@ +module Process where + +import Control.Arrow ((&&&)) +import Data.List (foldl', sortBy) +import Data.Map (toList, fromList, difference, elems, findWithDefault) +import Data.Ord (comparing) + +import Types + +process :: Run -> Info +process hpr = + let frames = hprFrames hpr + samples = map hpfSamples frames + ccTotals = sortBy (flip $ comparing snd) (toList $ hprTotals hpr) + sizes = map snd ccTotals + total = sum' sizes + limit = 0.99 * total + bigs = takeWhile (< limit) . drop 1 . scanl (+) 0 $ sizes + bands = zipWith const ccTotals $ take 15 bigs + ccs = map fst bands + ccsMap = fromList . map (\c -> (c, ())) $ ccs + sr = (minimum &&& maximum) . map hpfTime $ frames + vr = (0, maximum . map (sum . elems) $ samples) + values = [ (c, [ findWithDefault 0 c m | m <- samples ]) | c <- ccs ] + traces = map (sum' . elems . (`difference` ccsMap)) samples + in Info + { hpiJob = hprJob hpr + , hpiDate = hprDate hpr + , hpiSampleUnit = hprSampleUnit hpr + , hpiValueUnit = hprValueUnit hpr + , hpiSampleRange= sr + , hpiValueRange = vr + , hpiSamples = map hpfTime frames + , hpiValues = values + , hpiTrace = traces + } + +sum' :: [Double] -> Double +sum' = foldl' (+) 0 diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,53 @@ +module Types where + +import Data.Array.Unboxed (UArray) +import Data.ByteString.Lazy.Char8(ByteString) +import Data.Map (Map) + +data Run = + Run + { hprJob :: ByteString + , hprDate :: ByteString + , hprSampleUnit :: ByteString + , hprValueUnit :: ByteString + , hprFrames :: [Frame] + , hprTotals :: Map ByteString Double + } + deriving (Read, Show, Eq, Ord) + +data Frame = + Frame + { hpfTime :: Double + , hpfSamples :: Map ByteString Double + } + deriving (Read, Show, Eq, Ord) + +data Info = + Info + { hpiJob :: ByteString + , hpiDate :: ByteString + , hpiSampleUnit :: ByteString + , hpiValueUnit :: ByteString + , hpiSampleRange:: (Double, Double) + , hpiValueRange :: (Double, Double) + , hpiSamples :: [Double] + , hpiValues :: [(ByteString, [Double])] + , hpiTrace :: [Double] + } + deriving (Read, Show, Eq, Ord) + +data Graph = + Graph + { hpgJob :: ByteString + , hpgDate :: ByteString + , hpgSampleUnit :: ByteString + , hpgValueUnit :: ByteString + , hpgSampleRange:: (Double, Double) + , hpgValueRange :: (Double, Double) + , hpgSampleTicks:: [Double] + , hpgValueTicks :: [Double] + , hpgLabels :: [ByteString] + , hpgBands :: UArray (Int, Int) Double + , hpgSamples :: [Double] + } + deriving (Show, Eq, Ord)