path: root/ghc/utils/heap-view/HpView.lhs

> module Main where
> import PreludeGlaST
> import LibSystem

> import Parse

Program to interpret a heap profile.

Started 28/11/93: parsing of profile
Tweaked 28/11/93: parsing fiddled till it worked and graphical backend added

To be done:

0) think about where I want to go with this
1) further processing... sorting, filtering, ...
2) get dynamic display
3) maybe use widgets

Here's an example heap profile

          JOB "a.out -p"
          DATE "Fri Apr 17 11:43:45 1992"
          SAMPLE_UNIT "seconds"
          VALUE_UNIT "bytes"
          BEGIN_SAMPLE 0.00
            SYSTEM 24
          END_SAMPLE 0.00
          BEGIN_SAMPLE 1.00
            elim 180
            insert 24
            intersect 12
            disin 60
            main 12
            reduce 20
            SYSTEM 12
          END_SAMPLE 1.00
          MARK 1.50
          MARK 1.75
          MARK 1.80
          BEGIN_SAMPLE 2.00
            elim 192
            insert 24
            intersect 12
            disin 84
            main 12
            SYSTEM 24
          END_SAMPLE 2.00
          BEGIN_SAMPLE 2.82
          END_SAMPLE 2.82

By inspection, the format seems to be:

profile :== header { sample }
header :== job date { unit }
job :== "JOB" command
date :== "DATE" dte
unit :== "SAMPLE_UNIT" string | "VALUE_UNIT" string

sample :== samp | mark
samp :== "BEGIN_SAMPLE" time {pairs} "END_SAMPLE" time
pairs :== identifer count
mark :== "MARK" time

command :== string
dte :== string
time :== float
count :== integer

But, this doesn't indicate the line structure.  The simplest way to do
this is to treat each line as a single token --- for which the
following parser is useful:

Special purpose parser that recognises a string if it matches a given
prefix and returns the remainder.

> prefixP :: String -> P String String
> prefixP p =
>	itemP 			`thenP` \ a -> 
>	let (p',a') = splitAt (length p) a
>	in 	if p == p'
>		then unitP a'
>		else zeroP


To begin with I want to parse a profile into a list of readings for
each identifier at each time.

> type Sample = (Float, [(String, Int)])

> type Line = String


> profile :: P Line [Sample]
> profile = 
>	header			`thenP_`
>	zeroOrMoreP sample	

> header :: P Line ()
> header =
>	job			`thenP_`
>	date			`thenP_`
>	zeroOrMoreP unit	`thenP_`
>	unitP ()

> job :: P Line String
> job =	prefixP "JOB "

> date :: P Line String
> date = prefixP "DATE "

> unit :: P Line String
> unit =
>	( prefixP "SAMPLE_UNIT " )
>	`plusP`
>	( prefixP "VALUE_UNIT " )

> sample :: P Line Sample
> sample =
>	samp `plusP` mark

> mark :: P Line Sample
> mark =
>	prefixP "MARK "		`thenP` \ time ->
>	unitP (read time, [])

ToDo: check that @time1 == time2@

> samp :: P Line Sample
> samp = 
>	prefixP "BEGIN_SAMPLE " 	`thenP` \ time1 ->
>	zeroOrMoreP pair		`thenP` \ pairs ->
>	prefixP "END_SAMPLE "		`thenP` \ time2 ->
>	unitP (read time1, pairs)

> pair :: P Line (String, Int)
> pair =
>	prefixP "  "			`thenP` \ sample_line ->
>	let [identifier,count] = words sample_line
>	in unitP (identifier, read count)

This test works fine

> {-
> test :: String -> String
> test str = ppSamples (theP profile (lines str))

> test1 = test example

> test2 :: String -> Dialogue
> test2 file =
>	readFile file				exit
>	(\ hp -> appendChan stdout (test hp)	exit
>	done)
> -}

Inefficient pretty-printer (uses ++ excessively)

> ppSamples :: [ Sample ] -> String
> ppSamples = unlines . map ppSample

> ppSample :: Sample -> String
> ppSample (time, samps) = 
>	(show time) ++ unwords (map ppSamp samps)

> ppSamp :: (String, Int) -> String
> ppSamp (identifier, count) = identifier ++ ":" ++ show count

To get the test1 to work in gofer, you need to fiddle with the input
a bit to get over Gofer's lack of string-parsing code.

> example =
>  "JOB \"a.out -p\"\n" ++
>  "DATE \"Fri Apr 17 11:43:45 1992\"\n" ++
>  "SAMPLE_UNIT \"seconds\"\n" ++
>  "VALUE_UNIT \"bytes\"\n" ++
>  "BEGIN_SAMPLE 0.00\n" ++
>  "  SYSTEM 24\n" ++
>  "END_SAMPLE 0.00\n" ++
>  "BEGIN_SAMPLE 1.00\n" ++
>  "  elim 180\n" ++
>  "  insert 24\n" ++
>  "  intersect 12\n" ++
>  "  disin 60\n" ++
>  "  main 12\n" ++
>  "  reduce 20\n" ++
>  "  SYSTEM 12\n" ++
>  "END_SAMPLE 1.00\n" ++
>  "MARK 1.50\n" ++
>  "MARK 1.75\n" ++
>  "MARK 1.80\n" ++
>  "BEGIN_SAMPLE 2.00\n" ++
>  "  elim 192\n" ++
>  "  insert 24\n" ++
>  "  intersect 12\n" ++
>  "  disin 84\n" ++
>  "  main 12\n" ++
>  "  SYSTEM 24\n" ++
>  "END_SAMPLE 2.00\n" ++
>  "BEGIN_SAMPLE 2.82\n" ++
>  "END_SAMPLE 2.82"

 


Hack to let me test this code... Gofer doesn't have integer parsing built in.

> {-
> read :: String -> Int
> read s = 0
> -}

> screen_size = 200

ToDo: 

1) the efficiency of finding slices can probably be dramatically
   improved... if it matters.

2) the scaling should probably depend on the slices used

3) labelling graphs, colour, ...

4) responding to resize events

> main :: IO ()
> main =
>	getArgs				>>= \ r ->
>	case r of 
>	  filename:idents -> 
>		readFile filename	>>= \ hp ->
>		let samples = theP profile (lines hp)
>
>		    times = [ t | (t,ss) <- samples ]
>		    names = [ n | (t,ss) <- samples, (n,c) <- ss ]
>		    counts = [ c | (t,ss) <- samples, (n,c) <- ss ]
>
>		    time = maximum times
>		    x_scale = (fromInt screen_size) / time
>
>		    max_count = maximum counts
>		    y_scale = (fromInt screen_size) / (fromInt max_count)
>
>		    slices = map (slice samples) idents
>		in
>		xInitialise [] screen_size screen_size		    >>
> --		drawHeap x_scale y_scale samples		    >>
> 		sequence (map (drawSlice x_scale y_scale) slices)   >>
>		freeze
>	  _ -> error "usage: hpView filename identifiers\n"

> freeze :: IO ()
> freeze =
>	xHandleEvent				>>
> 	usleep 100				>>
>	freeze


Slice drawing stuff... shows profile for each identifier

> slice :: [Sample] -> String -> [(Float,Int)]
> slice samples ident =
>	[ (t,c) | (t,ss) <- samples, c <- [lookupPairs ss ident 0] ]

> lookupPairs :: Eq a => [(a, b)] -> a -> b -> b
> lookupPairs ((a', b') : hs) a b =
>	if a == a' then b' else lookupPairs hs a b
> lookupPairs [] a b = b

> drawSlice :: Float -> Float -> [(Float,Int)] -> IO ()
> drawSlice x_scale y_scale slc = 
>	drawPoly 
>	[ (round (x*x_scale), screen_size - (round ((fromInt y)*y_scale))) | (x,y) <- slc ]

> drawPoly :: [(Int, Int)] -> IO ()
> drawPoly ((x1,y1):(x2,y2):poly) =
>	xDrawLine x1 y1 x2 y2		>>
>	drawPoly ((x2,y2):poly)
> drawPoly _ = return ()


Very simple heap profiler... doesn't do a proper job at all.  Good for
testing.

> drawHeap :: Float -> Float -> [Sample] -> IO ()
> drawHeap x_scale y_scale samples =
>	sequence (map xBar 
>		[ (t*x_scale, (fromInt c)*y_scale) 
>		| (t,ss) <- samples, (n,c) <- ss ])	>>	
>	return ()

> xBar :: (Float, Float) -> IO ()
> xBar (x, y) = 
>	let {x' = round x; y' = round y} 
>	in xDrawLine x' screen_size x' (screen_size - y')

>#include "common-bits"