packages feed

hp2pretty (empty) → 0.1

raw patch · 11 files changed

+511/−0 lines, 11 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, containers, mtl

Files

+ LICENSE view
@@ -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.
+ NEWS view
@@ -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.
+ README view
@@ -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 <in.hp >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 <in.hp >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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hp2pretty.cabal view
@@ -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 <in.hp >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
+ src/Main.hs view
@@ -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
+ src/Parse.hs view
@@ -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"
+ src/Pretty.hs view
@@ -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] ]
+ src/Print.hs view
@@ -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 = [ "<text font-size='25' text-anchor='middle' x='" , showF (fromIntegral w / 2) , "' y='" , showF (border * 0.75) , "'>" , hpgJob hpg , " (" , hpgDate hpg , ")</text>" ]+      background = [ "<rect fill='white' x='0' y='0' width='" , showI w , "' height='" , showI h , "' />" ]+      box = [ "<rect fill='white' x='" , showF gx0 , "' y='" , showF gy1 , "' width='" , showF gW , "' height='" , showF gH , "' />" ]+      gStart = [ "<g fill-opacity='0.5' fill='black' stroke='black' stroke-width='1'>" ]+      leftLabel = [ "<text font-size='20' text-anchor='middle' transform='translate(" , showF (border/2) , "," , showF ((gy0 + gy1)/2) , ") rotate(-90)'>" , hpgValueUnit hpg , "</text>" ]+      leftTicks = map (\(y,l) -> let { (x1, y1) = p (xMin, y) ; (x2, y2) = p (xMax, y) } in+          [ "<line x1='" , showF (x1 - border/2) , "' x2='" , showF x2 , "' y1='" , showF y1 , "' y2='" , showF y2 , "' />" ] +++          if l then [] else [ "<text font-size='15' text-anchor='end'   x='" , showF (x1 - textOffset) , "' y='" , showF (y1 - textOffset) , "'>" , showSI y , "</text>" ]+        ) (zip (hpgValueTicks hpg) (replicate (length (hpgValueTicks hpg) - 1) False ++ [True]))+      bottomLabel = [ "<text font-size='20' text-anchor='middle' x='" , showF ((gx0 + gx1)/2) , "' y='" , showF (gy0 + border) , "'>" , hpgSampleUnit hpg , "</text>" ]+      bottomTicks = map (\(x,l) -> let { (x1, y1) = p (x, yMin) ; (x2, y2) = p (x, yMax) } in+          [ "<line y1='" , showF (y1 + border/2) , "' y2='" , showF y2 , "' x1='" , showF x1 , "' x2='" , showF x2 , "' />" ] +++          if l then [] else [ "<text font-size='15' text-anchor='start' x='" , showF (x1 + textOffset) , "' y='" , showF (y1+2*textOffset) , "'>" , showSI x , "</text>" ]+        ) (zip (hpgSampleTicks hpg) (replicate (length (hpgSampleTicks hpg) - 1) False ++ [True]))+      gEnd = [ "</g>" ]+  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  [ "<rect fill-opacity='0.7' fill='" , c , "' x='" , showF x , "' y='" , showF (y + 0.1 * dy) , "' width='" , showF (dy * 0.8) , "' height='" , showF (dy * 0.8) , "' />"+      , "<text font-size='15' text-anchor='start' x='" , showF (x + dy) , "' y='" , showF (y + dy * 0.6) , "'>" , l , "</text>" ]++polygon :: ByteString -> [(Double,Double)] -> [ByteString]+polygon c ps = [ "<path fill-opacity='0.7' fill='" , c , "' d='" ] ++ path 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 = [ "<?xml version='1.0' encoding='UTF-8' ?>" ]++svgStart :: Int -> Int -> [ByteString]+svgStart w h = [ "<svg xmlns='http://www.w3.org/2000/svg' version='1.0' width='" , showI w , "' height='" , showI h , "'>" ]++svgEnd :: [ByteString]+svgEnd = [ "</svg>" ]++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]
+ src/Process.hs view
@@ -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
+ src/Types.hs view
@@ -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)