summaryrefslogtreecommitdiff
path: root/utils/heap-view
diff options
context:
space:
mode:
Diffstat (limited to 'utils/heap-view')
-rw-r--r--utils/heap-view/Graph.lhs165
-rw-r--r--utils/heap-view/HaskXLib.c297
-rw-r--r--utils/heap-view/HpView.lhs296
-rw-r--r--utils/heap-view/HpView2.lhs225
-rw-r--r--utils/heap-view/MAIL67
-rw-r--r--utils/heap-view/Makefile31
-rw-r--r--utils/heap-view/Makefile.original48
-rw-r--r--utils/heap-view/Parse.lhs92
-rw-r--r--utils/heap-view/README62
-rw-r--r--utils/heap-view/common-bits35
10 files changed, 1318 insertions, 0 deletions
diff --git a/utils/heap-view/Graph.lhs b/utils/heap-view/Graph.lhs
new file mode 100644
index 0000000000..b8e08dbb9b
--- /dev/null
+++ b/utils/heap-view/Graph.lhs
@@ -0,0 +1,165 @@
+Started 29/11/93:
+
+> module Main where
+> import PreludeGlaST
+> import LibSystem
+
+Program to draw a graph of last @n@ pieces of data from standard input
+continuously.
+
+> n :: Int
+> n = 40
+
+> max_sample :: Int
+> max_sample = 100
+
+> screen_size :: Int
+> screen_size = 200
+
+Version of grapher that can handle the output of ghc's @+RTS -Sstderr@
+option.
+
+Nice variant would be to take a list of numbers from the commandline
+and display several graphs at once.
+
+> main :: IO ()
+> main =
+> getArgs >>= \ r ->
+> case r of
+> [select] ->
+> let selection = read select
+> in
+> xInitialise [] screen_size screen_size >>
+> hGetContents stdin >>= \ input ->
+> graphloop2 (parseGCData selection input) []
+> _ ->
+> error "usage: graph <number in range 0..17>\n"
+
+The format of glhc18's stderr stuff is:
+
+-- start of example (view in 120 column window)
+graph +RTS -Sstderr -H500
+
+Collector: APPEL HeapSize: 500 (bytes)
+
+ Alloc Collect Live Resid GC GC TOT TOT Page Flts No of Roots Caf Mut- Old Collec Resid
+ bytes bytes bytes ency user elap user elap GC MUT Astk Bstk Reg No able Gen tion %heap
+ 248 248 60 24.2% 0.00 0.04 0.05 0.23 1 1 1 0 0 1 0 0 Minor
+-- end of example
+ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
+
+That is: 6 header lines followed by 17-18 columns of integers,
+percentages, floats and text.
+
+The scaling in the following is largely based on guesses about likely
+values - needs tuned.
+
+@gcParsers@ is a list of functions which parse the corresponding
+column and attempts to scale the numbers into the range $0.0 .. 1.0$.
+(But may return a number avove $1.0$ which graphing part will scale to
+fit screen...)
+
+(Obvious optimisation - replace by list of scaling information!)
+
+(Obvious improvement - return (x,y) pair based on elapsed (or user) time.)
+
+> gcParsers :: [ String -> Float ]
+> gcParsers = [ heap, heap, heap, percent, time, time, time, time, flts, flts, stk, stk, reg, caf, caf, heap, text, percent ]
+> where
+> heap = scale 100000.0 . fromInt . check 0 . readDec
+> stk = scale 25000.0 . fromInt . check 0 . readDec
+> int = scale 1000.0 . fromInt . check 0 . readDec
+> reg = scale 10.0 . fromInt . check 0 . readDec
+> caf = scale 100.0 . fromInt . check 0 . readDec
+> flts = scale 100.0 . fromInt . check 0 . readDec
+> percent = scale 100.0 . check 0.0 . readFloat
+> time = scale 20.0 . check 0.0 . readFloat
+> text s = 0.0
+
+> check :: a -> [(a,String)] -> a
+> check error_value parses =
+> case parses of
+> [] -> error_value
+> ((a,s):_) -> a
+
+> scale :: Float -> Float -> Float
+> scale max n = n / max
+
+> parseGCData :: Int -> String -> [Float]
+> parseGCData column input =
+> map ((gcParsers !! column) . (!! column) . words) (drop 6 (lines input))
+
+Hmmm, how to add logarithmic scaling neatly? Do I still need to?
+
+Note: unpleasant as it is, the code cannot be simplified to something
+like the following. The problem is that the graph won't start to be
+drawn until the first @n@ values are available. (Is there also a
+danger of clearing the screen while waiting for the next input value?)
+A possible alternative solution is to keep count of how many values
+have actually been received.
+
+< graphloop2 :: [Float] -> [Float] -> IO ()
+< graphloop2 [] =
+< return ()
+< graphloop2 ys =
+< let ys' = take n ys
+< m = maximum ys'
+< y_scale = (floor m) + 1
+< y_scale' = fromInt y_scale
+< in
+< xCls >>
+< drawScales y_scale >>
+< draw x_coords [ x / y_scale' | x <- ys' ] >>
+< xHandleEvent >>
+< graphloop2 (tail ys)
+
+
+> graphloop2 :: [Float] -> [Float] -> IO ()
+> graphloop2 (y:ys) xs =
+> let xs' = take n (y:xs)
+> m = maximum xs'
+> y_scale = (floor m) + 1
+> y_scale' = fromInt y_scale
+> in
+> xCls >>
+> drawScales y_scale >>
+> draw x_coords [ x / y_scale' | x <- xs' ] >>
+> xHandleEvent >>
+> graphloop2 ys xs'
+> graphloop2 [] xs =
+> return ()
+
+> x_coords :: [Float]
+> x_coords = [ 0.0, 1 / (fromInt n) .. ]
+
+Draw lines specified by coordinates in range (0.0 .. 1.0) onto screen.
+
+> draw :: [Float] -> [Float] -> IO ()
+> draw xs ys = drawPoly (zip xs' (reverse ys'))
+> where
+> xs' = [ floor (x * sz) | x <- xs ]
+> ys' = [ floor ((1.0 - y) * sz) | y <- ys ]
+> sz = fromInt screen_size
+
+> drawPoly :: [(Int, Int)] -> IO ()
+> drawPoly ((x1,y1):(x2,y2):poly) =
+> xDrawLine x1 y1 x2 y2 >>
+> drawPoly ((x2,y2):poly)
+> drawPoly _ = return ()
+
+Draw horizontal line at major points on y-axis.
+
+> drawScales :: Int -> IO ()
+> drawScales y_scale =
+> sequence (map drawScale ys) >>
+> return ()
+> where
+> ys = [ (fromInt i) / (fromInt y_scale) | i <- [1 .. y_scale - 1] ]
+
+> drawScale :: Float -> IO ()
+> drawScale y =
+> let y' = floor ((1.0 - y) * (fromInt screen_size))
+> in
+> xDrawLine 0 y' screen_size y'
+
+>#include "common-bits"
diff --git a/utils/heap-view/HaskXLib.c b/utils/heap-view/HaskXLib.c
new file mode 100644
index 0000000000..b6cf1f137c
--- /dev/null
+++ b/utils/heap-view/HaskXLib.c
@@ -0,0 +1,297 @@
+/*----------------------------------------------------------------------*
+ * X from Haskell (PicoX)
+ *
+ * (c) 1993 Andy Gill
+ *
+ *----------------------------------------------------------------------*/
+
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+#include <X11/Xatom.h>
+#include <stdio.h>
+#include <strings.h>
+
+/*----------------------------------------------------------------------*/
+
+/* First the X Globals */
+
+Display *MyDisplay;
+int MyScreen;
+Window MyWindow;
+XEvent MyWinEvent;
+GC DrawGC;
+GC UnDrawGC;
+
+/* and the Haskell globals */
+
+typedef struct {
+ int HaskButtons[5];
+ int HaskPointerX,HaskPointerY;
+ int PointMoved;
+} HaskGlobType;
+
+HaskGlobType HaskGlob;
+
+/*----------------------------------------------------------------------*/
+
+/*
+ * Now the access functions into the haskell globals
+ */
+
+int haskGetButtons(int n)
+{
+ return(HaskGlob.HaskButtons[n]);
+}
+
+int haskGetPointerX(void)
+{
+ return(HaskGlob.HaskPointerX);
+}
+
+int haskGetPointerY(void)
+{
+ return(HaskGlob.HaskPointerY);
+}
+
+/*----------------------------------------------------------------------*/
+
+/*
+ *The (rather messy) initiualisation
+ */
+
+haskXBegin(int x,int y,int sty)
+{
+ /*
+ * later include these via interface hacks
+ */
+
+ /* (int argc, char **argv) */
+ int argc = 0;
+ char **argv = 0;
+
+ XSizeHints XHints;
+ int MyWinFG, MyWinBG,tmp;
+
+ if ((MyDisplay = XOpenDisplay("")) == NULL) {
+ fprintf(stderr, "Cannot connect to X server '%s'\n", XDisplayName(""));
+ exit(1);
+ }
+
+ MyScreen = DefaultScreen(MyDisplay);
+
+ MyWinBG = WhitePixel(MyDisplay, MyScreen);
+ MyWinFG = BlackPixel(MyDisplay, MyScreen);
+
+ XHints.x = x;
+ XHints.y = y;
+ XHints.width = x;
+ XHints.height = y;
+ XHints.flags = PPosition | PSize;
+
+ MyWindow =
+ XCreateSimpleWindow(
+ MyDisplay,
+ DefaultRootWindow(MyDisplay),
+ x,y, x, y,
+ 5,
+ MyWinFG,
+ MyWinBG
+ );
+
+ XSetStandardProperties(
+ MyDisplay,
+ MyWindow,
+ "XLib for Glasgow Haskell",
+ "XLib for Glasgow Haskell",
+ None,
+ argv,
+ argc,
+ &XHints
+ );
+
+ /* Create drawing and erasing GC */
+
+ DrawGC = XCreateGC(MyDisplay,MyWindow,0, 0);
+ XSetBackground(MyDisplay,DrawGC,MyWinBG);
+ XSetForeground(MyDisplay,DrawGC,MyWinFG);
+
+ UnDrawGC = XCreateGC(MyDisplay,MyWindow,0, 0);
+ XSetBackground(MyDisplay,UnDrawGC,MyWinFG);
+ XSetForeground(MyDisplay,UnDrawGC,MyWinBG);
+
+ XSetGraphicsExposures(MyDisplay,DrawGC,False);
+ XSetGraphicsExposures(MyDisplay,UnDrawGC,False);
+ XMapRaised(MyDisplay,MyWindow);
+
+ /* the user should be able to choose which are tested for
+ */
+
+ XSelectInput(
+ MyDisplay,
+ MyWindow,
+ ButtonPressMask | ButtonReleaseMask | PointerMotionMask
+ );
+
+ /* later have more drawing styles
+ */
+
+ switch (sty)
+ {
+ case 0:
+ /* Andy, this used to be GXor not much use for Undrawing so I
+ changed it. (Not much use for colour either - see next
+ comment */
+ XSetFunction(MyDisplay,DrawGC,GXcopy);
+ XSetFunction(MyDisplay,UnDrawGC,GXcopy);
+ break;
+ case 1:
+ /* Andy, this can have totally bogus results on a colour screen */
+ XSetFunction(MyDisplay,DrawGC,GXxor);
+ XSetFunction(MyDisplay,UnDrawGC,GXxor);
+ break;
+ default:
+ /* Andy, is this really a good error message? */
+ printf(stderr,"Wrong Argument to XSet function\n");
+ }
+ /*
+ * reset the (Haskell) globals
+ */
+
+ for(tmp=0;tmp<5;tmp++)
+ {
+ HaskGlob.HaskButtons[tmp] = 0;
+ }
+ HaskGlob.HaskPointerX = 0;
+ HaskGlob.HaskPointerY = 0;
+ HaskGlob.PointMoved = 0;
+
+ XFlush(MyDisplay);
+
+}
+
+/*----------------------------------------------------------------------*/
+
+/* Boring X ``Do Something'' functions
+ */
+
+haskXClose(void)
+{
+ XFreeGC( MyDisplay, DrawGC);
+ XFreeGC( MyDisplay, UnDrawGC);
+ XDestroyWindow( MyDisplay, MyWindow);
+ XCloseDisplay( MyDisplay);
+ return(0);
+}
+
+haskXDraw(x,y,x1,y1)
+int x,y,x1,y1;
+{
+ XDrawLine(MyDisplay,
+ MyWindow,
+ DrawGC,
+ x,y,x1,y1);
+ return(0);
+}
+
+
+haskXPlot(c,x,y)
+int c;
+int x,y;
+{
+ XDrawPoint(MyDisplay,
+ MyWindow,
+ (c?DrawGC:UnDrawGC),
+ x,y);
+ return(0);
+}
+
+haskXFill(c,x,y,w,h)
+int c;
+int x, y;
+int w, h;
+{
+ XFillRectangle(MyDisplay,
+ MyWindow,
+ (c?DrawGC:UnDrawGC),
+ x, y, w, h);
+ return(0);
+}
+
+/*----------------------------------------------------------------------*/
+
+ /* This has to be called every time round the loop,
+ * it flushed the buffer and handles input from the user
+ */
+
+haskHandleEvent()
+{
+ XFlush( MyDisplay);
+ while (XEventsQueued( MyDisplay, QueuedAfterReading) != 0) {
+ XNextEvent( MyDisplay, &MyWinEvent);
+ switch (MyWinEvent.type) {
+ case ButtonPress:
+ switch (MyWinEvent.xbutton.button)
+ {
+ case Button1: HaskGlob.HaskButtons[0] = 1; break;
+ case Button2: HaskGlob.HaskButtons[1] = 1; break;
+ case Button3: HaskGlob.HaskButtons[2] = 1; break;
+ case Button4: HaskGlob.HaskButtons[3] = 1; break;
+ case Button5: HaskGlob.HaskButtons[4] = 1; break;
+ }
+ break;
+ case ButtonRelease:
+ switch (MyWinEvent.xbutton.button)
+ {
+ case Button1: HaskGlob.HaskButtons[0] = 0; break;
+ case Button2: HaskGlob.HaskButtons[1] = 0; break;
+ case Button3: HaskGlob.HaskButtons[2] = 0; break;
+ case Button4: HaskGlob.HaskButtons[3] = 0; break;
+ case Button5: HaskGlob.HaskButtons[4] = 0; break;
+ }
+ break;
+ case MotionNotify:
+ HaskGlob.HaskPointerX = MyWinEvent.xmotion.x;
+ HaskGlob.HaskPointerY = MyWinEvent.xmotion.y;
+ HaskGlob.PointMoved = 1;
+ break;
+ default:
+ printf("UNKNOWN INTERUPT ???? (%d) \n",MyWinEvent.type);
+ break;
+ } /*switch*/
+ } /*if*/
+ return(0);
+}
+
+
+/*----------------------------------------------------------------------*/
+
+ /* A function to clear the screen
+ */
+
+haskXCls(void)
+{
+ XClearWindow(MyDisplay,MyWindow);
+}
+
+/*----------------------------------------------------------------------*/
+
+ /* A function to write a string
+ */
+
+haskXDrawString(int x,int y,char *str)
+{
+ return(0);
+/* printf("GOT HERE %s %d %d",str,x,y);
+ XDrawString(MyDisplay,MyWindow,DrawGC,x,y,str,strlen(str));
+*/
+}
+
+/*----------------------------------------------------------------------*/
+
+extern int prog_argc;
+extern char **prog_argv;
+
+haskArgs()
+{
+ return(prog_argc > 1 ? atoi(prog_argv[1]) : 0);
+}
diff --git a/utils/heap-view/HpView.lhs b/utils/heap-view/HpView.lhs
new file mode 100644
index 0000000000..a7b4cbb78e
--- /dev/null
+++ b/utils/heap-view/HpView.lhs
@@ -0,0 +1,296 @@
+> 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"
diff --git a/utils/heap-view/HpView2.lhs b/utils/heap-view/HpView2.lhs
new file mode 100644
index 0000000000..fa8044b8b4
--- /dev/null
+++ b/utils/heap-view/HpView2.lhs
@@ -0,0 +1,225 @@
+> module Main where
+> import PreludeGlaST
+> import LibSystem
+
+> import Parse
+
+Program to do continuous heap profile.
+
+Bad News:
+
+ The ghc runtime system writes its heap profile information to a
+ named file (<progname>.hp). The program merrily reads its input
+ from a named file but has no way of synchronising with the program
+ generating the file.
+
+Good News 0:
+
+ You can save the heap profile to a file:
+
+ <progname> <parameters> +RTS -h -i0.1 -RTS
+
+ and then run:
+
+ hpView2 <progname>.hp Main:<functionname>
+
+ This is very like using hp2ps but much more exciting because you
+ never know what's going to happen next :-)
+
+
+Good News 1:
+
+ The prophet Stallman has blessed us with the shell command @mkfifo@
+ (is there a standard Unix version?) which creates a named pipe. If we
+ instead run:
+
+ mkfifo <progname>.hp
+ hpView2 <progname>.hp Main:<functionname> &
+ <progname> <parameters> +RTS -h -i0.1 -RTS
+ rm <progname>.hp
+
+ Good Things happen.
+
+ NB If you don't delete the pipe, Bad Things happen: the program
+ writes profiling info to the pipe until the pipe fills up then it
+ blocks...
+
+
+Right, on with the program:
+
+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
+
+In HpView.lhs, I had a fancy parser to handle all this - but it was
+immensely inefficient. We can produce something a lot more efficient
+and robust very easily by noting that the only lines we care about
+have precisely two entries on them.
+
+> type Line = String
+> type Word = String
+> type Sample = (Float, [(String, Int)])
+
+> parseProfile :: [[Word]] -> [Sample]
+> parseProfile [] = []
+> parseProfile ([keyword, time]:lines) | keyword == "BEGIN_SAMPLE" =
+> let (sample,rest) = parseSample lines
+> in
+> (read time, sample) : parseProfile rest
+> parseProfile (_:xs) = parseProfile xs
+
+> parseSample :: [[Word]] -> ([(String,Int)],[[Word]])
+> parseSample ([word, count]:lines) =
+> if word == "END_SAMPLE"
+> then ([], lines)
+> else let (samples, rest) = parseSample lines
+> in ( (word, read count):samples, rest )
+> parseSample duff_lines = ([],duff_lines)
+
+> screen_size = 200
+
+> main :: IO ()
+> main =
+> getArgs >>= \ r ->
+> case r of
+> [filename, ident] ->
+> xInitialise [] screen_size screen_size >>
+> readFile filename >>= \ hp ->
+> let samples = parseProfile (map words (lines hp))
+> totals = [ sum [ s | (_,s) <- ss ] | (t,ss) <- samples ]
+>
+> ts = map scale totals
+> is = map scale (slice samples ident)
+> in
+> graphloop2 (is, []) (ts, [])
+> _ -> error "usage: hpView2 file identifier\n"
+
+For the example I'm running this on, the following scale does nicely.
+
+> scale :: Int -> Float
+> scale n = (fromInt n) / 10000.0
+
+Slice drawing stuff... shows profile for each identifier (Ignores time
+info in this version...)
+
+> slice :: [Sample] -> String -> [Int]
+> slice samples ident =
+> [ 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
+
+Number of samples to display on screen
+
+> n :: Int
+> n = 40
+
+Graph-drawing loop. Get's the data for the particular identifier and
+the total usage, scales to get total to fit screen and draws them.
+
+> graphloop2 :: ([Float], [Float]) -> ([Float], [Float]) -> IO ()
+> graphloop2 (i:is,is') (t:ts, ts') =
+> let is'' = take n (i:is')
+> ts'' = take n (t:ts')
+>
+> -- scaling information:
+> m = maximum ts''
+> y_scale = (floor m) + 1
+> y_scale' = fromInt y_scale
+> in
+> xCls >>
+> drawScales y_scale >>
+> draw x_coords [ x / y_scale' | x <- is'' ] >>
+> draw x_coords [ x / y_scale' | x <- ts'' ] >>
+> xHandleEvent >>
+> graphloop2 (is,is'') (ts, ts'')
+> graphloop2 _ _ =
+> return ()
+
+> x_coords :: [Float]
+> x_coords = [ 0.0, 1 / (fromInt n) .. ]
+
+Note: unpleasant as it is, the code cannot be simplified to something
+like the following (which has scope for changing draw to take a list
+of pairs). The problem is that the graph won't start to be drawn
+until the first @n@ values are available. (Is there also a danger of
+clearing the screen while waiting for the next input value?) A
+possible alternative solution is to keep count of how many values have
+actually been received.
+
+< graphloop2 :: [Float] -> [Float] -> IO ()
+< graphloop2 [] =
+< return ()
+< graphloop2 ys =
+< let ys' = take n ys
+< m = maximum ys'
+< y_scale = (floor m) + 1
+< y_scale' = fromInt y_scale
+< in
+< xCls >>
+< drawScales y_scale >>
+< draw x_coords [ x / y_scale' | x <- ys' ] >>
+< xHandleEvent >>
+< graphloop2 (tail ys)
+
+Draw lines specified by coordinates in range (0.0 .. 1.0) onto screen.
+
+> draw :: [Float] -> [Float] -> IO ()
+> draw xs ys = drawPoly (zip xs' (reverse ys'))
+> where
+> xs' = [ floor (x * sz) | x <- xs ]
+> ys' = [ floor ((1.0 - y) * sz) | y <- ys ]
+> sz = fromInt screen_size
+
+> drawPoly :: [(Int, Int)] -> IO ()
+> drawPoly ((x1,y1):(x2,y2):poly) =
+> xDrawLine x1 y1 x2 y2 >>
+> drawPoly ((x2,y2):poly)
+> drawPoly _ = return ()
+
+Draw horizontal line at major points on y-axis.
+
+> drawScales :: Int -> IO ()
+> drawScales y_scale =
+> sequence (map drawScale ys) >>
+> return ()
+> where
+> ys = [ (fromInt i) / (fromInt y_scale) | i <- [1 .. y_scale - 1] ]
+
+> drawScale :: Float -> IO ()
+> drawScale y =
+> let y' = floor ((1.0 - y) * (fromInt screen_size))
+> in
+> xDrawLine 0 y' screen_size y'
+
+>#include "common-bits"
diff --git a/utils/heap-view/MAIL b/utils/heap-view/MAIL
new file mode 100644
index 0000000000..966fcdcfc7
--- /dev/null
+++ b/utils/heap-view/MAIL
@@ -0,0 +1,67 @@
+To: partain@dcs.gla.ac.uk
+cc: areid@dcs.gla.ac.uk, andy@dcs.gla.ac.uk
+Subject: Heap profiling programs
+Date: Thu, 09 Dec 93 17:33:09 +0000
+From: Alastair Reid <areid@dcs.gla.ac.uk>
+
+
+I've hacked up a couple of programs which it might be worth putting in
+the next ghc distribution. They are:
+
+graph:
+
+ Draws a continuous graph of any one column of the statistics
+ produced using the "+RTS -Sstderr" option.
+
+ I'm not convinced this is astonishingly useful since I'm yet to
+ learn anything useful from (manually) examining these statistics.
+ (Although I do vaguely remember asking Patrick if the heap profiler
+ could do stack profiles too.)
+
+ A typical usage is:
+
+ slife 2 Unis/gardenofeden +RTS -Sstderr -H1M -RTS |& graph 2
+
+ which draws a graph of the third column (ie column 2!) of the
+ stats.
+
+ (btw is there a neater way of connecting stderr to graph's stdin?)
+
+hpView2:
+
+ Draws a continuous graph of the statistics reported by the "+RTS -h"
+ option.
+
+ Since I understand what the figures mean, this seems to be the more
+ useful program.
+
+ A typical usage is:
+
+ mkfifo slife.hp
+ hpView2 slife.hp Main:mkQuad &
+ slife 2 Unis/gardenofeden +RTS -h -i0.1 -RTS
+ rm slife.hp
+
+ which draws a graph of the total heap usage and the usage for Main:mkQuad.
+
+
+Minor problems:
+
+The code is a gross hack... but it works. (Maybe distribute in rot13
+format so that you don't get accidentally get exposed to obscene code
+:-))
+
+The code uses a variant of Andy's picoXlibrary (which he was talking
+about releasing but maybe isn't ready to do yet.)
+
+Also, there are lots of obvious extensions etc which could be made but
+haven't yet... (The major one is being able to set the initial
+scale-factor for displaying the graphs or being able to graph several
+stats at once without having to tee.)
+
+
+Hope you find them interesting.
+
+Alastair
+
+ps Code is in ~areid/hask/Life and should be readable/executable.
diff --git a/utils/heap-view/Makefile b/utils/heap-view/Makefile
new file mode 100644
index 0000000000..e8fa8faf08
--- /dev/null
+++ b/utils/heap-view/Makefile
@@ -0,0 +1,31 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+
+PROGRAMS = graph hpView hpView2
+
+SRC_HC_OPTS += -hi-diffs -fglasgow-exts -fhaskell-1.3 -O -L/usr/X11/lib -cpp
+SRC_CC_OPTS += -ansi -I/usr/X11/include
+# ToDo: use AC_PATH_X in configure to get lib/include dirs for X.
+
+OBJS_graph = Graph.o HaskXLib.o
+OBJS_hpView = HpView.o Parse.o HaskXLib.o
+OBJS_hpView2 = HpView2.o Parse.o HaskXLib.o
+
+all :: $(PROGRAMS)
+
+graph : $(OBJS_graph)
+ $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS_graph) -lX11
+
+hpView : $(OBJS_hpView)
+ $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS_hpView) -lX11
+
+hpView2 : $(OBJS_hpView2)
+ $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS_hpView2) -lX11
+
+HaskXLib.o : HaskXLib.c
+ $(CC) -c $(CC_OPTS) HaskXLib.c
+
+INSTALL_PROGS += $(PROGRAMS)
+CLEAN_FILES += $(PROGRAMS)
+
+include $(TOP)/mk/target.mk
diff --git a/utils/heap-view/Makefile.original b/utils/heap-view/Makefile.original
new file mode 100644
index 0000000000..1e35bc2e43
--- /dev/null
+++ b/utils/heap-view/Makefile.original
@@ -0,0 +1,48 @@
+CC=gcc
+GLHC18 = glhc18
+GLHC19 = /users/fp/partain/bin/sun4/glhc
+HC= ghc -hi-diffs -fglasgow-exts -fhaskell-1.3
+HC_FLAGS = -O -prof -auto-all
+#HC_FLAGS = -O
+LIBS=-lX11
+FILES2 = Life2.o HaskXLib.o
+FILESS = LifeWithStability.o HaskXLib.o
+FILES = Life.o HaskXLib.o
+
+all : hpView hpView2
+
+# ADR's heap profile viewer
+hpView: HpView.o Parse.o HaskXLib.o
+ $(HC) -o hpView $(HC_FLAGS) HpView.o Parse.o HaskXLib.o $(LIBS) -L/usr/X11/lib
+clean::
+ rm -f hpView
+
+# ADR's continuous heap profile viewer (handles output of -p)
+hpView2: HpView2.o Parse.o HaskXLib.o
+ $(HC) -o hpView2 $(HC_FLAGS) HpView2.o Parse.o HaskXLib.o $(LIBS) -L/usr/X11/lib
+clean::
+ rm -f hpView2
+
+
+# ADR's continuous graph program (handles output of -Sstderr)
+graph: Graph.o HaskXLib.o
+ $(HC) -o graph $(HC_FLAGS) Graph.o HaskXLib.o $(LIBS) -L/usr/X11/lib
+clean::
+ rm -f graph
+
+# ADR's continuous graph program (part of heap profile viewer) that
+# crashes the compiler
+bugGraph: bugGraph.o HaskXLib.o
+ $(HC) -o bugGraph $(HC_FLAGS) bugGraph.o HaskXLib.o $(LIBS) -L/usr/X11/lib
+clean::
+ rm -f bugGraph
+
+%.o:%.c
+ $(CC) -c -ansi -traditional -g -I/usr/X11/include/ $< $(INC)
+
+%.o:%.lhs
+ $(HC) $(HC_FLAGS) -c $< $(INC)
+
+clean::
+ rm -f core *.o *% #*
+ rm -f *.hc
diff --git a/utils/heap-view/Parse.lhs b/utils/heap-view/Parse.lhs
new file mode 100644
index 0000000000..9d7652fdcc
--- /dev/null
+++ b/utils/heap-view/Parse.lhs
@@ -0,0 +1,92 @@
+> module Parse where
+
+The Parser monad in "Comprehending Monads"
+
+> infixr 9 `thenP`
+> infixr 9 `thenP_`
+> infixr 9 `plusP`
+
+> type P t a = [t] -> [(a,[t])]
+
+> unitP :: a -> P t a
+> unitP a = \i -> [(a,i)]
+
+> thenP :: P t a -> (a -> P t b) -> P t b
+> m `thenP` k = \i0 -> [(b,i2) | (a,i1) <- m i0, (b,i2) <- k a i1]
+
+> thenP_ :: P t a -> P t b -> P t b
+> m `thenP_` k = \i0 -> [(b,i2) | (a,i1) <- m i0, (b,i2) <- k i1]
+
+zeroP is the parser that always fails to parse its input
+
+> zeroP :: P t a
+> zeroP = \i -> []
+
+plusP combines two parsers in parallel
+(called "alt" in "Comprehending Monads")
+
+> plusP :: P t a -> P t a -> P t a
+> a1 `plusP` a2 = \i -> (a1 i) ++ (a2 i)
+
+itemP is the parser that parses a single token
+(called "next" in "Comprehending Monads")
+
+> itemP :: P t t
+> itemP = \i -> [(head i, tail i) | not (null i)]
+
+force successful parse
+
+> cutP :: P t a -> P t a
+> cutP p = \u -> let l = p u in if null l then [] else [head l]
+
+find all complete parses of a given string
+
+> useP :: P t a -> [t] -> [a]
+> useP m = \x -> [ a | (a,[]) <- m x ]
+
+find first complete parse
+
+> theP :: P t a -> [t] -> a
+> theP m = head . (useP m)
+
+
+Some standard parser definitions
+
+mapP applies f to all current parse trees
+
+> mapP :: (a -> b) -> P t a -> P t b
+> f `mapP` m = m `thenP` (\a -> unitP (f a))
+
+filter is the parser that parses a single token if it satisfies a
+predicate and fails otherwise.
+
+> filterP :: (a -> Bool) -> P t a -> P t a
+> p `filterP` m = m `thenP` (\a -> (if p a then unitP a else zeroP))
+
+lit recognises literals
+
+> litP :: Eq t => t -> P t ()
+> litP t = ((==t) `filterP` itemP) `thenP` (\c -> unitP () )
+
+> showP :: (Text a) => P t a -> [t] -> String
+> showP m xs = show (theP m xs)
+
+
+Simon Peyton Jones adds some useful operations:
+
+> zeroOrMoreP :: P t a -> P t [a]
+> zeroOrMoreP p = oneOrMoreP p `plusP` unitP []
+
+> oneOrMoreP :: P t a -> P t [a]
+> oneOrMoreP p = seq p
+> where seq p = p `thenP` (\a ->
+> (seq p `thenP` (\as -> unitP (a:as)))
+> `plusP`
+> unitP [a] )
+
+> oneOrMoreWithSepP :: P t a -> P t b -> P t [a]
+> oneOrMoreWithSepP p1 p2 = seq1 p1 p2
+> where seq1 p1 p2 = p1 `thenP` (\a -> seq2 p1 p2 a `plusP` unitP [a])
+> seq2 p1 p2 a = p2 `thenP` (\_ ->
+> seq1 p1 p2 `thenP` (\as -> unitP (a:as) ))
+
diff --git a/utils/heap-view/README b/utils/heap-view/README
new file mode 100644
index 0000000000..db9503abc4
--- /dev/null
+++ b/utils/heap-view/README
@@ -0,0 +1,62 @@
+@HpView.lhs@ is a very primitive heap profile viewer written in
+Haskell. It feeds off the same files as hp2ps. It needs a lot of
+tidying up and would be far more useful as a continuous display.
+(It's in this directory `cos there happens to be a heap profile here
+and I couldn't be bothered setting up a new directory, Makefile, etc.)
+
+@Graph.lhs@ is a continuous heap viewer that "parses" the output of
+the +RTS -Sstderr option. Typical usage:
+
+ slife 1 r4 +RTS -Sstderr |& graph 2
+
+(You might also try
+
+ cat data | graph 2
+
+ to see it in action on some sample data.
+)
+
+Things to watch:
+
+ 1) Scaling varies from column to column - consult the source.
+
+ 2) The horizontal scale is not time - it is garbage collections.
+
+ 3) The graph is of the (n+1)st column of the -Sstderr output.
+
+ The data is not always incredibly useful: For example, when using
+ the (default) Appel 2-space garbage collector, the 3rd column
+ displays the amount of "live" data in the minor space. A program
+ with a constant data usage will appear to have a sawtooth usage
+ as minor data gradually transfers to the major space and then,
+ suddenly, all gets transferred back at major collections.
+ Decreasing heap size decreases the size of the minor collections
+ and increases major collections exaggerating the sawtooth.
+
+ 4) The program is not as robust as it might be.
+
+
+@HpView2.lhs@ is the result of a casual coupling of @Graph.lhs@ and
+@HpView.lhs@ which draws continuous graphs of the heap consisting of:
+total usage and usage by one particular cost centre. For example:
+
+ mkfifo slife.hp
+ hpView2 slife.hp Main:mkQuad &
+ slife 2 Unis/gardenofeden +RTS -h -i0.1 -RTS
+ rm slife.hp
+
+draws a graph of total usage and usage by the function @mkQuad@.
+
+(You might also try
+
+ hpView2 slife.old-hp Main:mkQuad
+
+ to see it in action on some older data)
+
+The business with named pipes (mkfifo) is a little unfortunate - it
+would be nicer if the Haskell runtime system could output to stderr
+(say) which I could pipe into hpView which could just graph it's stdin
+(like graph does). It's probably worth wrapping the whole thing up in
+a little shell-script.
+
+
diff --git a/utils/heap-view/common-bits b/utils/heap-view/common-bits
new file mode 100644
index 0000000000..f41223b7f4
--- /dev/null
+++ b/utils/heap-view/common-bits
@@ -0,0 +1,35 @@
+ -----------------------------------------------------------------------------
+
+ xInitialise :: [String] -> Int -> Int -> IO ()
+ xInitialise str x y =
+ _ccall_ haskXBegin x y (0::Int) `seqPrimIO`
+ return ()
+
+ xHandleEvent :: IO ()
+ xHandleEvent =
+ _ccall_ haskHandleEvent `thenPrimIO` \ n ->
+ case (n::Int) of
+ 0 -> return ()
+ _ -> error "Unknown Message back from Handle Event"
+
+ xClose :: IO ()
+ xClose =
+ _ccall_ haskXClose `seqPrimIO`
+ return ()
+
+ xCls :: IO ()
+ xCls =
+ _ccall_ haskXCls `seqPrimIO`
+ return ()
+
+ xDrawLine :: Int -> Int -> Int -> Int -> IO ()
+ xDrawLine x1 y1 x2 y2 =
+ _ccall_ haskXDraw x1 y1 x2 y2 `seqPrimIO`
+ return ()
+
+ ----------------------------------------------------------------
+
+ usleep :: Int -> IO ()
+ usleep t =
+ _ccall_ usleep t `seqPrimIO`
+ return ()
View Lorry Controller Status