packages feed

hp2any-graph (empty) → 0.5.0

raw patch · 10 files changed

+815/−0 lines, 10 filesdep +GLUTdep +OpenGLdep +basesetup-changed

Dependencies added: GLUT, OpenGL, base, bytestring, containers, directory, filepath, hp2any-core, network, parseargs, process

Files

+ CHANGES view
@@ -0,0 +1,26 @@+0.5.0 - 090811+* made GraphData abstract (the users don't need its internals)+* switched to GLUT+* removed no-grapher flag+* added a simple test example++0.4.1 - 090809+* added no-grapher flag to cabal due to GLFW breakage++0.4.0 - 090802+* unified some functions by introducing the graph mode type++0.3.0 - 090729+* can handle the case when the executable doesn't create a .hp file or+  doesn't even start++0.2.0 - 090717+* factored OpenGL graphing capabilities into a library++0.1.0 - 090629+* added a basic relay server+* added remote profiling capability to the grapher++0.0.0 - 090613+* first public version featuring separate and cumulative graphs as+  well
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2009, Patai Gergely+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of its 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hp2any-graph.cabal view
@@ -0,0 +1,50 @@+Name:          hp2any-graph+Version:       0.5.0+Cabal-Version: >= 1.2+Synopsis:      Real-time heap graphing utility and profile stream server with a reusable graphing module.+Category:      profiling, development, utils+Description:++  This package contains two utilities: a grapher that can display heap+  profiles in real time both for local and remote processes, and a+  relay application the grapher connects to in the latter case.+  Additionally, the graphing capability is exposed to other programs+  as well in the form of a library module.++Author:        Patai Gergely+Maintainer:    Patai Gergely (patai@iit.bme.hu)+Copyright:     (c) 2009, Patai Gergely+License:       BSD3+License-File:  LICENSE+Stability:     experimental+Build-Type:    Simple+Extra-Source-Files:+  src/HandleArgs.hs+  test/heaptest.hs+  test/readme.txt+  CHANGES++Library+  HS-Source-Dirs: src+  Build-Depends:  base >= 4 && < 5, hp2any-core, OpenGL+  GHC-Options:    -Wall -O2+  Exposed-Modules:+    Profiling.Heap.OpenGL++Executable hp2any-graph+  Executable:      hp2any-graph+  HS-Source-Dirs:  src+  Main-IS:         Graph.hs+  GHC-Options:     -Wall -O2+  Extra-Libraries: glut+  Build-Depends:   base >= 4 && < 5, process, directory, filepath, containers,+                   bytestring, hp2any-core, parseargs, network,+                   OpenGL, GLUT++Executable hp2any-relay+  Executable:     hp2any-relay+  HS-Source-Dirs: src+  Main-IS:        Relay.hs+  Build-Depends:  base >= 4 && < 5, process, directory, filepath, containers,+                  bytestring, hp2any-core, parseargs, network+  GHC-Options:    -Wall -O2
+ src/Graph.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-missing-signatures #-}++{-++ glReadPixel is slow as hell, the alternative would be either to use+ the selection buffer (rumoured to be even slower...) or just+ calculate from the geometry. While the latter might be inconvenient+ for the simple purpose of finding out what the mouse cursor is+ covering at the moment, it can also be used to return the actual+ information from the data point in question (exact time and cost),+ so it should be used.++ This means that we'll have to take advantage of the data structures+ used by the simple interface in the core library while also needing+ the instant notification of the callback interface (so we don't have+ to poll). Another possibility is to add a function to be able to get+ a dirty bit, or even better, a list of new samples since the last+ reading, if we go for polling after all.++-}++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Fix+--import qualified Data.ByteString.Char8 as S+import qualified Data.IntMap as IM+import Data.IORef+import Data.List+import Data.Maybe+import Foreign.Marshal.Alloc+import Foreign.Storable+--import Graphics.UI.GLFW+import Graphics.UI.GLUT+import Graphics.Rendering.OpenGL hiding (Arg)+import Network+import Profiling.Heap.OpenGL+import Profiling.Heap.Read+import Profiling.Heap.Process+import Profiling.Heap.Types+import System.IO++import HandleArgs++data UIState = UIS+    { uisGraphMode :: GraphMode+    , uisCcid :: CostCentreId+    }++mapUisGraphMode f u = u { uisGraphMode = f (uisGraphMode u) }++startUiState = UIS+               { uisGraphMode = Accumulated+               , uisCcid = -1+               }++-- Helper functions to make type disambiguation easier.+--vertex2 :: GLfloat -> GLfloat -> IO ()+--vertex2 x y = vertex $ Vertex2 x y++translate2 :: GLfloat -> GLfloat -> IO ()+translate2 x y = translate $ Vector3 x y 0++scale2 :: GLfloat -> GLfloat -> IO ()+scale2 x y = scale x y 1++color3 :: GLfloat -> GLfloat -> GLfloat -> IO ()+color3 r g b = color $ Color3 r g b++main = withSocketsDo $ do+  profInfo <- graphArgs++  initialize "hp2any-graph" []+  initialDisplayMode $= [RGBMode, DoubleBuffered]+  initialWindowSize $= Size 800 600+  createWindow "hp2any live graph"++  clearColor $= Color4 1 1 1 1+  lineWidth $= 4++  -- Variables used for communication between callbacks.+  graphData <- newIORef emptyGraph+  uiState <- newIORef startUiState+  glLock <- newMVar ()++  let -- A helper to shorten callback declarations...+      cbv $== cb = cbv $= Just cb+      -- Lock helper+      glProtect act = do+        takeMVar glLock+        res <- act+        putMVar glLock ()+        return res++  -- The current state is redrawn whenever needed.+  displayCallback $= glProtect (displayGraph uiState graphData)++  -- Window size needs to be monitored only to adjust the viewport.+  reshapeCallback $== \size -> glProtect $ do+    viewport $= (Position 0 0,size)+    matrixMode $= Projection+    loadIdentity+    translate2 (-1) (-1)+    scale2 2 2+    matrixMode $= Modelview 0+    postRedisplay Nothing++  -- If the mouse is moved, we find out which cost centre it is+  -- hovering over, and refresh the display if there is a change.+  passiveMotionCallback $== \pos -> glProtect $ do+    -- Note: maybe we want to use colour index mode to make colour+    -- picking easier, but it's not likely, since it can put an+    -- unpredictable limit on the number of colours we can use, and+    -- traversing a list of at most a few hundred elements a few times+    -- a second shouldn't cause much problem (besides, we can switch+    -- to a map later if we want to).+    readBuffer $= FrontBuffers+    ccid <- colourToCcid <$> readIORef graphData <*> hoverColour pos+    uis <- readIORef uiState+    when (ccid /= uisCcid uis) $ do+      writeIORef uiState $ uis { uisCcid = ccid }+      postRedisplay Nothing++  keyboardMouseCallback $== \key keyState _ _ ->+      case (key,keyState) of+        (Char 'm',Down) -> do+          modifyIORef uiState (mapUisGraphMode nextGraphMode)+          postRedisplay Nothing+        _ -> return ()++  profData <- newEmptyMVar++  let procData =+          case profInfo of+            -- Connecting to the server and interpreting the profile stream+            -- messages it keeps sending while ignoring the rest.+            Left server -> Remote server+            -- Starting up the slave process and getting its heap profile+            -- updates through a message box.+            Right (exec,dir,params) -> Local (processToProfile exec dir params [])++  profileCallback procData (putMVar profData) >>= \cbres -> case cbres of+    Just (stop,_) -> do+      closeCallback $== stop+      +      -- Looping as long as the other process is running.+      forkIO $ fix $ \consume -> do+        prof <- takeMVar profData+        keepGoing <- glProtect $ accumGraph graphData prof+        when keepGoing consume++      mainLoop++    Nothing -> putStrLn "Error starting profile reader thread. Did you enable heap profiling?"++-- RGB values under the mouse cursor.+hoverColour (Position x y) = allocaBytes 4 $ \colData -> do    +  Size _ h <- get windowSize+  readPixels (Position x (h-y)) (Size 1 1) (PixelData RGBA UnsignedByte colData)+  r <- peekElemOff colData 0+  g <- peekElemOff colData 1+  b <- peekElemOff colData 2+  return (Color3 r g b)++-- RGB to cost centre id, -1 being the background colour.+colourToCcid graph col = fromMaybe 0 (elemIndex col colsUsed) - 1+    where colsUsed = take (1 + IM.size (graphNames graph)) (backgroundColour:colours)++-- Consuming profiling input. If a new id comes, we just store it. If+-- a new sample comes, we pair it up with the last one in a way that+-- common cost centres are connected, and then update the graph.++-- Note that if the breakdown is by type, a name can appear more than+-- once in the list!+accumGraph graphData profInput = do+  writeIORef graphData =<< flip growGraph profInput =<< readIORef graphData++  case profInput of+    SinkSample _ _ -> postRedisplay Nothing+    _              -> return ()++  return (profInput /= SinkStop)++displayGraph uiState graphData = do+  uis <- readIORef uiState+  graph <- readIORef graphData++  clear [ColorBuffer]+  loadIdentity++  renderGraph (uisGraphMode uis) graph++  let magn = 1+  +  loadIdentity+  Size w h <- get windowSize+  scale2 (magn/fromIntegral w) (magn/fromIntegral h)+  translate2 0 (fromIntegral h/magn-16)+  +  color3 0 0 0+  currentRasterPosition $= Vertex4 0 0 0 1+  renderString Fixed8By13 (fromMaybe "" (IM.lookup (uisCcid uis) (graphNames graph)))++  translate2 (fromIntegral w/magn-28*8) 0+  currentRasterPosition $= Vertex4 0 0 0 1+  renderString Fixed8By13 "Press M to change graph mode"++  flush+  swapBuffers
+ src/HandleArgs.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-missing-signatures #-}++module HandleArgs (graphArgs, relayArgs) where++import Control.Applicative+import Control.Monad+import Data.Maybe+import System.Console.ParseArgs+import System.Directory+import System.Exit++data ArgType = Exec+             | Cwd+             | Port+               deriving (Eq, Ord, Show)++graphArgs = do+  let fixName n = if head n `notElem` "/." then "./"++n else n++  args <- parseArgsIO ArgsTrailing+          [ Arg Exec (Just 'e') (Just "exec")+            (argDataOptional "executable" ArgtypeString)+            "Executable to profile."+          , Arg Cwd (Just 'd') (Just "cwd")+            (argDataOptional "directory" ArgtypeString)+            "Working directory of the executable."+          , Arg Port (Just 's') (Just "server")+            (argDataOptional "address:port" ArgtypeString)+            "Server to connect to."+          ]+  +  let exec = fixName <$> getArgString args Exec+      port = getArgString args Port+      params = unwords $ argsRest args++  when (exec == Nothing && port == Nothing) $ do+    putStrLn $ argsUsage args+    putStrLn $ unlines+                 ["You need to supply either a server to connect to or an executable"+                 ,"with optional working directory and parameters."+                 ]+    exitFailure++  dir <- case getArgString args Cwd of+           Just p -> Just <$> canonicalizePath p+           Nothing -> return Nothing++  let retval = case port of+                 Just p -> Left p+                 Nothing -> Right (fromJust exec,dir,params)++  return retval++relayArgs = do+  let fixName n = if head n `notElem` "/." then "./"++n else n++  args <- parseArgsIO ArgsTrailing+          [ Arg Exec (Just 'e') (Just "exec")+            (argDataRequired "executable" ArgtypeString)+            "Executable to profile."+          , Arg Cwd (Just 'd') (Just "cwd")+            (argDataOptional "directory" ArgtypeString)+            "Working directory of the executable."+          , Arg Port (Just 'p') (Just "port")+            (argDataRequired "portnum" ArgtypeString)+            "Number of server port to listen on."+          ]+  +  let Just exec = fixName <$> getArgString args Exec+      Just port = getArgString args Port+      params = unwords $ argsRest args++  dir <- case getArgString args Cwd of+           Just p -> Just <$> canonicalizePath p+           Nothing -> return Nothing++  return (read port :: Int,exec,dir,params)
+ src/Profiling/Heap/OpenGL.hs view
@@ -0,0 +1,270 @@+{-| This module provides some half-ready solutions to visualise heap+profiles both during and after execution with the help of OpenGL.  All+the rendering functions will fill the viewport if the model view+matrix is the identity (they also change the matrix), assuming the+projection matrix is the following:++@+ matrixMode $= Projection+ loadIdentity+ translate $ Vector3 (-1) (-1) 0+ scale 2 2 1+@++In other words, these functions fill the unit square at the origin. -}++module Profiling.Heap.OpenGL +    ( colours+    , backgroundColour+    , otherColour+      -- * Processing raw samples (full profiles)+    , SamplePair(..)+    , prepareSamples+    , renderSamples+    , addSample+      -- * Processing optimised renders (profile streams)+    , GraphData+    , graphNames+    , emptyGraph+    , growGraph+    , renderGraph+    , GraphMode(..)+    , nextGraphMode+    ) where++import Control.Applicative+import Control.Monad+import qualified Data.ByteString.Char8 as S+import Data.IntMap (IntMap)+import qualified Data.IntMap as IM+import Data.List+import Graphics.Rendering.OpenGL hiding (samples)+import Graphics.Rendering.OpenGL.GL.DisplayLists+import Profiling.Heap.Types++{-| Two heap profile samples which contain the exact same cost centres+in the exact same order. -}++data SamplePair = SP+    { spTime1 :: !Time+    , spTime2 :: !Time+    , spData1 :: !ProfileSample+    , spData2 :: !ProfileSample+    } deriving Show++{-| An optimised graph rendering designed to be easily updated when a+new sample arrives. -}++data GraphData = GD+    { gdNames :: IntMap String                   -- ^ Cost centre id to name mapping.+    , gdSamples :: [SamplePair]                  -- ^ List of pairwise aligned samples.+    , gdLists :: [(Int,DisplayList,DisplayList)] -- ^ Display lists caching rendering in all modes.+    , gdMinTime :: Time                          -- ^ The time of the first sample.+    }++{-| The names of cost centres in a graph rendering. -}+graphNames :: GraphData -> IntMap String+graphNames = gdNames++{-| An empty rendering. -}++emptyGraph :: GraphData+emptyGraph = GD+             { gdNames = IM.singleton 0 "Other"+             , gdSamples = [SP 0 0 [] []]+             , gdLists = []+             , gdMinTime = 0+             }++{-| The possible ways of displaying heap profiles. -}++data GraphMode+    -- | Cost centres are stacked on top of each other without+    -- overlapping.+    = Accumulated+    -- | Each cost centre yields a separate line graph on the same+    -- scale.+    | Separate+      deriving Eq++{-| A cyclic successor function for graph modes. -}++nextGraphMode :: GraphMode -> GraphMode+nextGraphMode Accumulated = Separate+nextGraphMode Separate    = Accumulated++{-| A list of highly different colours, where the differences diminish+as we advance in the list.  The first element is black, and there is+no white. -}++colours :: [Color3 GLubyte]+colours = concatMap makeCol [0..]+    where comps = 0 : 255 : unfoldr cnext (256,127 :: Int)+          cnext (s,c) = Just (fromIntegral c,if s+fromIntegral c >= 255 then (s `div` 2,s `div` 4-1) else (s,s+c))+          makeCol n = if n == 1 then init res else res+              where res = [Color3 (comps !! rn) (comps !! gn) (comps !! bn) |+                           rn <- [0..n], gn <- [0..n], bn <- [0..n],+                           rn == n || gn == n || bn == n]++{-| The colour of the background (white).  It is not a member of+'colours'. -}++backgroundColour :: Color3 GLubyte+backgroundColour = Color3 255 255 255++{-| The colour used for unimportant cost centres (black).  It is the+first element of 'colours'. -}++otherColour :: Color3 GLubyte+otherColour = Color3 0 0 0++{-| The limit under which cost centres are filtered out (grouped under+the name \"Other\"). -}++costLimit :: Cost+costLimit = 256++{-| Create a list of sample pairs where each cost centre is paired up+with the consecutive one, so it is easier to render them.  Cost+centres with small costs (below 'costLimit') are lumped together under+identifier 0, reserved for \"Other\". -}++prepareSamples :: ProfileQuery p => p -> [SamplePair]+prepareSamples prof = foldl addSample [SP 0 0 [] []] (samples prof)++-- Must be called within "renderPrimitive Quads".+renderSampleAccumulated :: SamplePair -> IO ()+renderSampleAccumulated (SP t1 t2 smp1 smp2) = do+  let acc s1 s2 = scanl accCost (undefined,0,0) (zip s1 s2)+      accCost (_,c1,c2) ((ccid,c1'),(_,c2')) = (ccid,c1+c1',c2+c2')++  forM_ (zip <*> tail $ acc smp1 smp2) $ \((_,c1,c2),(ccid,c1',c2')) -> do+    color (colours !! ccid)+    vertex2 (realToFrac t1) (fromIntegral c1)+    vertex2 (realToFrac t2) (fromIntegral c2)+    vertex2 (realToFrac t2) (fromIntegral c2')+    vertex2 (realToFrac t1) (fromIntegral c1')++-- Must be called within "renderPrimitive Lines".+renderSampleSeparate :: SamplePair -> IO ()+renderSampleSeparate (SP t1 t2 smp1 smp2) = do+  forM_ (zip smp1 smp2) $ \((ccid,cost1),(_,cost2)) -> do+    color (colours !! ccid)+    vertex2 (realToFrac t1) (fromIntegral cost1)+    vertex2 (realToFrac t2) (fromIntegral cost2)++{-| Render a given list of prepared samples in the given mode.  The+third argument is the maximum time of the graph, which affects+horizontal scaling. -}++renderSamples :: GraphMode -> [SamplePair] -> Time -> IO ()+renderSamples Accumulated smps tmax = do+  let cmax = fromIntegral . maximum $ [sum (map snd smp) | SP _ _ _ smp <- smps]++  scale2 (1/realToFrac tmax) (1/cmax)++  renderPrimitive Quads $ forM_ smps renderSampleAccumulated++renderSamples Separate smps tmax = do+  let cmax = fromIntegral . maximum $ [cost | SP _ _ _ smp <- smps, (_,cost) <- smp]++  scale2 (1/realToFrac tmax) (1/cmax)++  renderPrimitive Lines $ forM_ smps renderSampleSeparate++{-| Integrating a new sample into the list of merged sample pairs we+have so far.  The input list should start with the latest sample, and+the new sample pair will be the head of the result. -}++addSample :: [SamplePair] -> (Time,ProfileSample) -> [SamplePair]+addSample smps (t,smp) = newSample : smps+    where newSample = mergeSamples (head smps) t (groupSmalls smp)+          mergeSamples (SP _ t1 _ smp1) t2 smp2 =+              SP { spTime1 = t1, spTime2 = t2, spData1 = smp1', spData2 = smp2' }+              where (smp1',smp2') = mergeSample smp1 (sort smp2)++          groupSmalls s = (0,sum . map snd $ sn) : map (\(ccid,cost) -> (ccid+1,cost)) sy+              where (sy,sn) = partition (\(_,c) -> c >= costLimit) s++          -- Merging key-value lists ordered by the key.  For each key that is+          -- present in only one of the lists we insert it with value 0 in the+          -- other list.+          mergeSample [] s = (map (\(ccid,_) -> (ccid,0)) s,s)+          mergeSample s [] = (s,map (\(ccid,_) -> (ccid,0)) s)+          mergeSample (s1@(cid1,cost1):ss1) (s2@(cid2,cost2):ss2) =+              if cid1 == cid2 then+                  let (smp1,smp2) = mergeSample ss1 ss2+                  in (s1:smp1,s2:smp2)+              else if cid1 > cid2 then+                       let (smp1,smp2) = mergeSample (s1:ss1) ss2+                       in if cost2 > 0 then ((cid2,0):smp1,s2:smp2)+                          else (smp1,smp2)+                   else let (smp1,smp2) = mergeSample ss1 (s2:ss2)+                        in if cost1 > 0 then (s1:smp1,(cid1,0):smp2)+                           else (smp1,smp2)++{-| Integrate a new sample in an extensible graph. -}++growGraph :: GraphData -> SinkInput -> IO GraphData+growGraph graph SinkStop = return graph+growGraph graph (SinkId ccid ccname) = return (modNames (IM.insert (ccid+1) (S.unpack ccname)) graph)+    where modNames f g = g { gdNames = f (gdNames g) }+growGraph graph (SinkSample t smp) = do+  let graph' = graph { gdSamples = addSample (gdSamples graph) (t,smp) }+      graph'' = if gdMinTime graph' <= 0 then graph' { gdMinTime = t } else graph'+      smps = gdSamples graph''++      -- The heart of the optimisation: compiling a tree of display lists as we go.+      dlUnion []             = return []+      dlUnion xs@((x,_,_):_) = if length prefix >= 20 then do+                                   dlAcc <- defineNewList Compile $ mapM_ clAcc prefix+                                   dlSep <- defineNewList Compile $ mapM_ clSep prefix+                                   dlUnion ((x+1,dlAcc,dlSep):rest)+                                 else return xs+          where (prefix,rest) = span (\(y,_,_) -> y == x) xs++      clAcc = \(_,dl,_) -> callList dl+      clSep = \(_,_,dl) -> callList dl++  dlAcc <- defineNewList Compile $ renderPrimitive Quads $ renderSampleAccumulated $ head smps+  dlSep <- defineNewList Compile $ renderPrimitive Lines $ renderSampleSeparate $ head smps++  dls' <- dlUnion ((0,dlAcc,dlSep):gdLists graph'')++  return (graph'' { gdLists = dls' })++{-| Render a stream in the given graph mode. -}++renderGraph :: GraphMode -> GraphData -> IO ()++renderGraph Accumulated graph = do+  let smps = gdSamples graph+      tmin = realToFrac $ gdMinTime graph+      tmax = realToFrac . spTime2 . head $ smps+      cmax = fromIntegral . maximum $ [sum (map snd smp) | SP _ _ _ smp <- take 50 smps]++  scale2 (1/(tmax-tmin)) (1/cmax)+  translate2 (-tmin) 0+  mapM_ (\(_,dl,_) -> callList dl) . gdLists $ graph++renderGraph Separate graph = do+  let smps = gdSamples graph+      tmin = realToFrac $ gdMinTime graph+      tmax = realToFrac . spTime2 . head $ smps+      cmax = fromIntegral . maximum $ [cost | SP _ _ _ smp <- take 50 smps, (_,cost) <- smp]++  scale2 (1/(tmax-tmin)) (1/cmax)+  translate2 (-tmin) 0++  mapM_ (\(_,_,dl) -> callList dl) . gdLists $ graph++-- Helper functions to make type disambiguation easier.++vertex2 :: GLfloat -> GLfloat -> IO ()+vertex2 x y = vertex $ Vertex2 x y++scale2 :: GLfloat -> GLfloat -> IO ()+scale2 x y = scale x y 1++translate2 :: GLfloat -> GLfloat -> IO ()+translate2 x y = translate $ Vector3 x y 0
+ src/Relay.hs view
@@ -0,0 +1,78 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++import Control.Concurrent+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Fix+import qualified Data.IntMap as IM+import Data.IORef+import Network+import Profiling.Heap.Read+import Profiling.Heap.Process+import Profiling.Heap.Network+import Profiling.Heap.Types+import System.IO++import HandleArgs++-- Start up a process to profile and a server to broadcast the stream+-- to multiple clients.+main = withSocketsDo $ do+  (portNum,exec,dir,params) <- relayArgs++  let procData = processToProfile exec dir params []+      port = PortNumber $ fromIntegral portNum ++  profChan <- newChan+  stopServer <- newEmptyMVar+  names <- newIORef IM.empty++  cbres <- profileCallback (Local procData) $ \p -> do+     -- Broadcasting...+     writeChan profChan p+     -- Cleaning up the master channel that's not read by+     -- anyone.+     readChan profChan++     case p of+       SinkId ccid ccname -> modifyIORef names (IM.insert ccid ccname)+       SinkStop           -> putMVar stopServer ()+       _                  -> return ()++  case cbres of+    Nothing -> putStrLn "Error starting profile reader thread. Did you enable heap profiling?"+    Just _ -> runServer port (takeMVar stopServer) $ \chdl -> do+      -- A rather lazy way of avoiding the need to maintain an explicit+      -- client list and perform additional synchronisation...+      ownChan <- dupChan profChan+      +      -- Start by sending the currently known name mapping.+      ccmap <- readIORef names+      mapM_ (sendMsg chdl . putStream . uncurry SinkId) (IM.toList ccmap)+      +      -- Forward stream to the client.+      fix $ \sendLoop -> do+        prof <- readChan ownChan+        ok <- flip catch (const (return False)) $ do+          sendMsg chdl . putStream $ prof+          return (prof /= SinkStop)+      +        when ok sendLoop++  return ()++-- Start a loop accepting connections and running arbitrary code on+-- them in separate threads, and wait for a stopping action.+runServer port waitForStop act = do+  sock <- listenOn port++  tid <- forkIO $ forever $ do+    (hdl,_host,_cport) <- accept sock+    hSetBuffering hdl LineBuffering+    forkIO (act hdl)++  -- There might be some ugly race conditions here, where clients might+  -- be left without a message before leaving the runServer subroutine.+  waitForStop+  killThread tid
+ test/heaptest.hs view
@@ -0,0 +1,13 @@+import Text.Printf++main :: IO ()+main = exercise 500000++exercise :: Double -> IO ()+exercise d = do+  printf "Input: %f\n" d+  printf "Result: %f\n" (mean [1..d])+  exercise (d*1.5)++mean :: [Double] -> Double+mean xs = sum xs / fromIntegral (length xs)
+ test/readme.txt view
@@ -0,0 +1,61 @@+This directory contains a tiny test program to show how to perform+local and remote graphing.++1. Compilation++In order to get a heap profile out of a program, we have to compile it+with some profiling options:++ghc --make heaptest -O2 -prof -auto-all++In short, the -prof option enables profiling, while -auto-all+instruments the executable by putting a cost centre (a named point of+measurement) at every top-level declaration. If you want more+fine-grained heap profiles, you can put SCC pragmas at any expression+within the program. Consult the documentation of GHC for further+details.++2. Local profiling++Local profiling is simple: just invoke the program through+hp2any-graph and pass it the necessary parameters:++hp2any-graph -e heaptest -- +RTS -hc -K100M -i0.02++Everything after the -- is passed to the slave process as command line+parameter. In this case, we are passing profiling related parameters+to the runtime (+RTS). In particular, we ask for a heap profile by+cost centre stack (-hc), set a big stack so the program can keep+running for a little while (-K), and set a profile sample rate that's+higher than the default (-i).++Don't be surprised if the animation is not smooth, as the heap profile+might be aggressively buffered by the operating system. When a program+is more complex and there are more active cost centres, one can see+the samples almost as they are produced. That's also the reason to+increase the sampling rate for this small example.++3. Remote profiling++In order to access the heap profile of a remote process, we need a+server that relays the information to the grapher. This is essentially+the same as above, except we use hp2any-relay and also specify a port+number to listen on:++hp2any-relay -p 5678 -e heaptest -- +RTS -hc -K100M -i0.02++We can connect to such a relay by starting the grapher in remote mode,+where we only give it a server address:++hp2any-graph -s localhost:5678++It is possible to attach several viewers to the same relay at the same+time. Each grapher sees only the samples produced after it was+attached.++4. Viewing later++The grapher is not capable of viewing heap profiles of processes that+already finished. The history manager (hp2any-manager, in a separate+package) takes care of that duty, providing a much more comfortable+interface.