diff --git a/BUGS b/BUGS new file mode 100644 --- /dev/null +++ b/BUGS @@ -0,0 +1,1 @@ +empty heap profile gives NaN in SVG - detect and abort? diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,17 @@ +v0.4 2011-05-18 comparability + +Colours are stable across program runs (based on a hash of +the label names). + +Command line flag to use the same scale for all input files +(--uniform-scale=none|time|memory|both). + +Usage change: specify XX.hp file(s) on the command line, the +output is to corresponding XX.svg files. + +Source code statistics: 543 lines, 3273 words, 20045 chars. + + v0.3 2010-11-02 special characters Fixes a bug where broken SVG was generated when label names diff --git a/THANKS b/THANKS --- a/THANKS +++ b/THANKS @@ -1,1 +1,2 @@ Ian Lynagh (label text XML escaping bugfix patch) +Edward Z. Yang (feature requests for stable colours and uniform scales) diff --git a/hp2pretty.cabal b/hp2pretty.cabal --- a/hp2pretty.cabal +++ b/hp2pretty.cabal @@ -1,5 +1,5 @@ Name: hp2pretty -Version: 0.3 +Version: 0.4 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 @@ -8,20 +8,33 @@ Also none (count'em) of hp2ps' options are implemented yet in hp2pretty. . - Usage: "hp2pretty out.svg" + Usage has changed since the previous release: + . + hp2pretty *.hp + . + hp2pretty --uniform-scale=time *.hp + . + hp2pretty --uniform-scale=memory *.hp + . + hp2pretty --uniform-scale=both *.hp + . + Colours have also changed: now they are based on a hash of the + cost label, which should make colours have stable semantics + across program runs. + Homepage: http://gitorious.org/hp2pretty License: BSD3 License-file: LICENSE Author: Claude Heiland-Allen Maintainer: claudiusmaximus@goto10.org -Copyright: (C) 2010 Claude Heiland-Allen +Copyright: (C) 2010,2011 Claude Heiland-Allen Category: Development Build-type: Simple -Extra-source-files: NEWS README THANKS +Extra-source-files: BUGS NEWS README THANKS Cabal-version: >=1.6 Executable hp2pretty - Build-depends: base >= 4 && < 5, array, bytestring, containers, mtl + Build-depends: base >= 4 && < 5, array, bytestring, containers, filepath, mtl GHC-options: -Wall GHC-prof-options: -prof -auto-all HS-source-dirs: src @@ -42,4 +55,4 @@ Source-repository this type: git location: git://gitorious.org/hp2pretty/hp2pretty.git - tag: v0.3 + tag: v0.4 diff --git a/src/Graphics.hs b/src/Graphics.hs --- a/src/Graphics.hs +++ b/src/Graphics.hs @@ -1,6 +1,9 @@ module Graphics where -import Data.ByteString.Char8 (ByteString) +import Data.ByteString.Char8 (ByteString, foldl') +import Data.Char (ord) +import Data.Bits (shiftR) +import Data.Int (Int32, Int64) type Point = (Double, Double) type Size = (Double, Double) @@ -35,23 +38,43 @@ black = RGB 0 0 0 white = RGB 1 1 1 -colours :: [RGB] -colours = map hueToRGB [0, 2 * pi / (phi * phi) ..] +colour :: ByteString -> RGB +colour s = hsvToRGB (c 0x12345) (c 0x6789a) (c 0xbcdef) where - phi = (sqrt 5 + 1) / 2 - hueToRGB h = - let s = 1 - v = 1 - 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 -> RGB v t p - 1 -> RGB q v p - 2 -> RGB p v t - 3 -> RGB p q v - 4 -> RGB t p v - _ -> RGB v p q + c m = fromIntegral (hashByteString m s) * 667 / fromIntegral (maxBound :: Int32) + +hsvToRGB :: Double -> Double -> Double -> RGB +hsvToRGB h0 s0 v0 = + let s = 0.5 + 0.5 * (s0 - (fromIntegral (floor s0 :: Int))) + v = 0.5 + 0.5 * (v0 - (fromIntegral (floor v0 :: Int))) + h = floor h0 :: Int + i = h `mod` 6 + f = h0 - fromIntegral h + p = v * (1 - s) + q = v * (1 - s * f) + t = v * (1 - s * (1 - f)) + in case i of + 0 -> RGB v t p + 1 -> RGB q v p + 2 -> RGB p v t + 3 -> RGB p q v + 4 -> RGB t p v + _ -> RGB v p q + +-- hashing functions copied and modified from BSD-style LICENSE'd +-- base-4.3.1.0:Data.HashTable (c) The University of Glasgow 2003 + +hashByteString :: Int32 -> ByteString -> Int32 +hashByteString magic = foldl' f golden + where f m c = fromIntegral (ord c) * magic + hashInt32 m + +hashInt32 :: Int32 -> Int32 +hashInt32 x = mulHi x golden + x + +mulHi :: Int32 -> Int32 -> Int32 +mulHi a b = fromIntegral (r `shiftR` 32) + where r :: Int64 + r = fromIntegral a * fromIntegral b + +golden :: Int32 +golden = 1013904242 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,15 @@ +{-# LANGUAGE BangPatterns #-} module Main (main) where -import Prelude hiding (print, getContents, putStr) -import Data.ByteString.Char8 (getContents, putStr) +import Prelude hiding (print, readFile) +import Data.ByteString.Char8 (readFile, hPutStr) +import Control.Monad (forM_, when) +import Data.List (foldl1', isPrefixOf, partition) +import Data.Monoid (Last(..), mconcat) +import System.Environment (getArgs) +import System.Exit (exitSuccess) +import System.FilePath (replaceExtension) +import System.IO (withFile, IOMode(WriteMode)) import Total (total) import Prune (prune) @@ -9,13 +17,39 @@ import Pretty (pretty) import Print (print) import SVG (svg) +import Types (Header(..)) main :: IO () main = do - input <- getContents - let (header, totals) = total input - keeps = prune totals - (times, vals) = bands header keeps input - ((sticks, vticks), (labels, coords)) = pretty header vals keeps - outputs = print svg header sticks vticks labels times coords - mapM_ putStr outputs + args <- getArgs + let (flags, files) = partition (isPrefixOf "--") args + uniformity "--uniform-scale=none" = Last (Just (False, False)) + uniformity "--uniform-scale=time" = Last (Just (True, False)) + uniformity "--uniform-scale=memory" = Last (Just (False, True)) + uniformity "--uniform-scale=both" = Last (Just (True, True)) + uniformity _ = Last Nothing + Last (Just (uniformTime, uniformMemory)) = mconcat (Last (Just (False, False)) : map uniformity flags) + when (null files) exitSuccess + if not (uniformTime || uniformMemory) + then forM_ files $ \file -> do + input <- readFile file + let (header, totals) = total input + keeps = prune totals + (times, vals) = bands header keeps input + ((sticks, vticks), (labels, coords)) = pretty header vals keeps + outputs = print svg header sticks vticks labels times coords + withFile (replaceExtension file "svg") WriteMode $ \h -> mapM_ (hPutStr h) outputs + else do + inputs <- mapM readFile files + let hts0 = map total inputs + (smima, vmima) = foldl1' (\((!smi, !sma), (!vmi, !vma)) ((!smi', !sma'), (!vmi', !vma')) -> ((smi`min`smi', sma`max`sma'), (vmi`min`vmi', vma`max`vma'))) . map (\(h, _) -> (hSampleRange h, hValueRange h)) $ hts0 + hts1 | uniformTime = map (\(h, t) -> (h{ hSampleRange = smima }, t)) hts0 + | otherwise = hts0 + hts | uniformMemory = map (\(h, t) -> (h{ hValueRange = vmima }, t)) hts1 + | otherwise = hts1 + forM_ (zip3 files inputs hts) $ \(file, input, (header, totals)) -> do + let keeps = prune totals + (times, vals) = bands header keeps input + ((sticks, vticks), (labels, coords)) = pretty header vals keeps + outputs = print svg header sticks vticks labels times coords + withFile (replaceExtension file "svg") WriteMode $ \h -> mapM_ (hPutStr h) outputs diff --git a/src/Print.hs b/src/Print.hs --- a/src/Print.hs +++ b/src/Print.hs @@ -12,8 +12,10 @@ print gfx header sticks vticks labels times coords = let bands = toPoints (bounds coords) times coords filled c = visual gfx (Just c) Nothing Nothing Nothing + labels' = reverse labels + colours = map colour labels' polygons = concat . zipWith (\c ps -> filled c (polygon gfx ps)) colours . map (map p) $ bands - key = concat . zipWith3 (keyBox (gW + border * 2.5) (border * 1.5) (gH / 16)) [(0::Int) ..] colours . reverse $ labels + key = concat . zipWith3 (keyBox (gW + border * 2.5) (border * 1.5) (gH / 16)) [(0::Int) ..] colours $ labels' keyBox x y0 dy i c l = let y = y0 + fromIntegral i * dy in (filled c $ rect gfx (x, y + 0.1 * dy) (dy * 0.8, dy * 0.8)) ++