> 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"