diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012 Dennis Felsing + +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 his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +module Main where +import Distribution.Simple +main = defaultMain diff --git a/ghc-vis.cabal b/ghc-vis.cabal new file mode 100644 --- /dev/null +++ b/ghc-vis.cabal @@ -0,0 +1,98 @@ +name: ghc-vis +version: 0.1 +license: BSD3 +license-file: LICENSE +category: GHC, Debug, Development +cabal-version: >= 1.10 +build-type: Simple +author: Dennis Felsing +maintainer: Dennis Felsing +homepage: http://felsin9.de/nnis/ghc-vis +copyright: Dennis Felsing 2012 +synopsis: Live visualization of data structures in GHCi +description: Visualize live data structures in GHCi. Evaluation is not + forced and you can interact with the visualized data + structures. This allows seeing Haskell's lazy evaluation + and sharing in action. + . + To use this package add the accompanying @ghci@ file to + your @.ghci@ like this: + . + > echo ":script $HOME/.cabal/share/ghc-vis-0.1/ghci" >> ~/.ghci + . + Now you can run ghci and experiment with @ghc-vis@. Start + the visualization: + . + > $ ghci + > GHCi, version 7.4.2: http://www.haskell.org/ghc/ :? for help + > > :vis + . + A blank window should appear now. This is the visualization + window. Add an expression to the visualization: + . + > > let a = [1..3] + > > :view a + > > let b = cycle a + > > :view b + > > :view "foo" ++ "bar" + . + + . + Functions are red, named objects are green and links to an + already shown object are blue. + . + Notice how @a@ is referenced by @b@. + . + Evaluate an object that is shown in the visualization. You + can also click on the object to evaluate it. + . + > > :eval t1 + . + + . + The first element of @b@ has been evaluated. We see that + it's a reference to the value that's also referenced in a, + as they share the same name "t0". + . + Switch between the list view and the graph view: + . + > > :switch + . + + . + When an object is updated by accessing it, you have to call + @:update@ to refresh the visualization window. You can also + click on an object to force an update: + . + > > a !! 2 + > 3 + > > :update + . + + . + Clear the visualization window, this also happens when you + @:load@ or @:reload@ a source file: + . + > > :clear + +data-files: ghci + +Library + Exposed-modules: GHC.Vis GHC.Vis.Internal GHC.Vis.Graph GHC.Vis.Types GHC.Vis.GTK.Graph GHC.Vis.GTK.List GHC.Vis.GTK.Common + Default-Language: Haskell2010 + Build-depends: base == 4.5.*, + fgl, + mtl, + deepseq, + ghc-heap-view >= 0.3, + cairo, + gtk, + graphviz, + text, + xdot + Hs-source-dirs: src/ + Ghc-options: -Wall -fno-warn-unused-do-bind + +--source-repository head +-- type: darcs +-- location: http:// diff --git a/ghci b/ghci new file mode 100644 --- /dev/null +++ b/ghci @@ -0,0 +1,12 @@ +let _put s = "System.Timeout.timeout 1000000 (Control.Concurrent.MVar.putMVar GHC.Vis.visSignal $ GHC.Vis.Types." ++ s ++ ") >> return ()" + +:def vis \_ -> return $ "GHC.Vis.visualization" +:def view \x -> return $ _put $ "NewSignal (GHC.HeapView.asBox (" ++ x ++ ")) " ++ show x +:def eval \x -> return $ "GHC.Vis.evaluate \"" ++ x ++ "\"\n" ++ _put "UpdateSignal" +:def switch \_ -> return $ _put "SwitchSignal" +:def update \_ -> return $ _put "UpdateSignal" +:def clear \_ -> return $ _put "ClearSignal" +:def export \x -> return $ _put $ "ExportSignal " ++ show x + +-- Remove our temporary bindings +-- :r diff --git a/src/GHC/Vis.hs b/src/GHC/Vis.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis.hs @@ -0,0 +1,139 @@ +{- | + Module : GHC.Vis + Copyright : (c) Dennis Felsing + License : 3-Clause BSD-style + Maintainer : dennis@felsin9.de + -} +module GHC.Vis ( + visualization, + visSignal, + evaluate + ) + where + +import Prelude hiding (catch) + +import Graphics.UI.Gtk hiding (Box, Signal) +import qualified Graphics.UI.Gtk.Gdk.Events as E + +import System.IO +import Control.Concurrent +import Control.Monad + +import Control.Exception hiding (evaluate) + +import Data.IORef + +import System.Timeout +import System.Mem + +import GHC.Vis.Types +import GHC.Vis.GTK.Common +import qualified GHC.Vis.GTK.Graph as Graph +import qualified GHC.Vis.GTK.List as List + +title :: String +title = "ghc-vis" + +backgroundColor :: Color +backgroundColor = Color 0xffff 0xffff 0xffff + +defaultSize :: (Int, Int) +defaultSize = (640, 480) + +signalTimeout :: Int +signalTimeout = 1000000 + +-- | This is the main function. It's to be called from GHCi and launches a +-- graphical window in a new thread. +visualization :: IO () +visualization = do + vr <- swapMVar visRunning True + unless vr $ void $ forkIO visMainThread + +visMainThread :: IO () +visMainThread = do + initGUI + window <- windowNew + + canvas <- drawingAreaNew + + widgetModifyBg canvas StateNormal backgroundColor + + set window [ windowTitle := title + , containerChild := canvas + ] + (uncurry $ windowSetDefaultSize window) defaultSize + + onExpose canvas $ const $ do + runCorrect Graph.redraw List.redraw >>= \f -> f canvas + runCorrect Graph.move List.move >>= \f -> f canvas + return True + + onMotionNotify canvas False $ \e -> do + modifyIORef visState (\s -> s {mousePos = (E.eventX e, E.eventY e)}) + runCorrect Graph.move List.move >>= \f -> f canvas + return True + + onButtonPress canvas $ \e -> do + click <- runCorrect Graph.click List.click + when (E.eventButton e == LeftButton && E.eventClick e == SingleClick) click + return True + + widgetShowAll window + + reactThread <- forkIO $ react canvas window + --onDestroy window mainQuit -- Causes :r problems with multiple windows + onDestroy window (quit reactThread) + + mainGUI + return () + +quit :: ThreadId -> IO () +quit reactThread = do + swapMVar visRunning False + killThread reactThread + +react :: (WidgetClass w1, WidgetClass w2) => w1 -> w2 -> IO b +react canvas window = do + -- Timeout used to handle ghci reloads (:r) + -- Reloads cause the visSignal to be reinitialized, but takeMVar is still + -- waiting for the old one. This solution is not perfect, but it works for + -- now. + mbSignal <- timeout signalTimeout (takeMVar visSignal) + case mbSignal of + Nothing -> do + running <- readMVar visRunning + if running then react canvas window else + -- :r caused visRunning to be reset + (do swapMVar visRunning True + putMVar visSignal UpdateSignal + react canvas window) + Just signal -> do + case signal of + NewSignal x n -> modifyMVar_ visBoxes ( + \y -> if (x,n) `elem` y then return y else return $ y ++ [(x,n)]) + ClearSignal -> modifyMVar_ visBoxes (\_ -> return []) + UpdateSignal -> return () + SwitchSignal -> modifyIORef visState (\s -> s {view = succN (view s)}) + ExportSignal f -> catch (runCorrect Graph.export List.export >>= \e -> e f) + (\e -> do let err = show (e :: IOException) + hPutStrLn stderr $ "Couldn't export to file \"" ++ f ++ "\": " ++ err + return ()) + + boxes <- readMVar visBoxes + performGC -- TODO: Else Blackholes appear. Do we want this? + + runCorrect Graph.updateObjects List.updateObjects >>= \f -> f boxes + + postGUISync $ widgetQueueDraw canvas + react canvas window + + where succN v = if v == maxBound then minBound else succ v + +runCorrect :: f -> f -> IO f +runCorrect f1 f2 = do + s <- readIORef visState + return $ case view s of + GraphView -> f1 + ListView -> f2 diff --git a/src/GHC/Vis/GTK/Common.hs b/src/GHC/Vis/GTK/Common.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis/GTK/Common.hs @@ -0,0 +1,68 @@ +{- | + Module : GHC.Vis.GTK.Common + Copyright : (c) Dennis Felsing + License : 3-Clause BSD-style + Maintainer : dennis@felsin9.de + + -} +module GHC.Vis.GTK.Common ( + visSignal, + visRunning, + visState, + visBoxes, + evaluate, + --printOne, + --printAll + ) + where + +import Control.Concurrent +import Control.DeepSeq + +import Data.IORef + +import System.IO.Unsafe + +import GHC.Vis.Internal +import GHC.Vis.Types +import GHC.HeapView + +-- | Communication channel to the visualization +visSignal :: MVar Signal +visSignal = unsafePerformIO (newEmptyMVar :: IO (MVar Signal)) + +-- | Whether a visualization is currently running +visRunning :: MVar Bool +visRunning = unsafePerformIO (newMVar False) + +-- | Internal state of the visualization +visState :: IORef State +visState = unsafePerformIO $ newIORef $ State (0, 0) ListView + +-- | All the visualized boxes +visBoxes :: MVar [(Box, String)] +visBoxes = unsafePerformIO (newMVar [] :: IO (MVar [(Box, String)])) + +-- | Evaluate an object identified by a String. +evaluate :: String -> IO () +evaluate identifier = do (_,hm) <- printAll + show (map go hm) `deepseq` return () + where go (Box a,(Just n, y)) | n == identifier = seq a (Just n, y) + | otherwise = (Just n, y) + go (_,(x,y)) = (x,y) + +--printOne :: a -> IO String +--printOne a = do +-- bs <- readMVar visBoxes +-- case findIndex (\(b,_) -> asBox a == b) bs of +-- Just pos -> do +-- t <- parseBoxes bs +-- return $ show (t !! pos) +-- Nothing -> return "Add entry first" + +printAll :: IO (String, HeapMap) +printAll = do + bs <- readMVar visBoxes + (t,(_,h,_)) <- parseBoxesHeap bs + return (show t, h) + diff --git a/src/GHC/Vis/GTK/Graph.hs b/src/GHC/Vis/GTK/Graph.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis/GTK/Graph.hs @@ -0,0 +1,157 @@ +{- | + Module : GHC.Vis.GTK.Graph + Copyright : (c) Dennis Felsing + License : 3-Clause BSD-style + Maintainer : dennis@felsin9.de + + -} +module GHC.Vis.GTK.Graph ( + export, + redraw, + click, + move, + updateObjects + ) + where + +import Graphics.UI.Gtk hiding (Box, Signal, Rectangle) +import qualified Graphics.UI.Gtk as Gtk +import Graphics.Rendering.Cairo + +import Control.Concurrent +import Control.Monad + +import Data.IORef +import System.IO.Unsafe + +import GHC.Vis.Graph +import GHC.Vis.Types hiding (State) +import GHC.Vis.GTK.Common + +import GHC.HeapView hiding (size) + +import Graphics.XDot.Viewer +import Graphics.XDot.Types hiding (size, w, h) + +data State = State + { boxes :: [Box] + , operations :: [(Maybe Int, Operation)] + , totalSize :: (Double, Double, Double, Double) + , bounds :: [(Int, (Double, Double, Double, Double))] + , hover :: Maybe Int + } + +state :: IORef State +state = unsafePerformIO $ newIORef $ State [] [] (0, 0, 1, 1) [] Nothing + +-- | Draw visualization to screen, called on every update or when it's +-- requested from outside the program. +redraw :: WidgetClass w => w -> IO () +redraw canvas = do + s <- readIORef state + Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas + + boundingBoxes <- render canvas (draw s rw2 rh2) + + modifyIORef state (\s' -> s' {bounds = boundingBoxes}) + +-- | Export the visualization to an SVG file +export :: String -> IO () +export file = do + s <- readIORef state + + let (_, _, xSize, ySize) = totalSize s + + withSVGSurface file xSize ySize + (\surface -> renderWith surface (draw s (round xSize) (round ySize))) + + return () + +draw :: State -> Int -> Int -> Render [(Int, Rectangle)] +draw s rw2 rh2 = do + -- Line widths don't count to size, let's add a bit + let rw = 0.97 * fromIntegral rw2 + rh = 0.97 * fromIntegral rh2 + + ops = operations s + size@(_,_,sw,sh) = totalSize s + + -- Proportional scaling + sx = min (rw / sw) (rh / sh) + sy = sx + ox = 0.5 * fromIntegral rw2 + oy = 0.5 * fromIntegral rh2 + + translate ox oy + scale sx sy + + result <- drawAll (hover s) size ops + + return $ map (\(o, (x,y,w,h)) -> (o, + ( x * sx + ox -- Transformations to correct scaling and offset + , y * sy + oy + , w * sx + , h * sy + ))) result + +render :: WidgetClass w => w -> Render b -> IO b +render canvas r = do + win <- widgetGetDrawWindow canvas + renderWithDrawable win r + +-- | Handle a mouse click. If an object was clicked an 'UpdateSignal' is sent +-- that causes the object to be evaluated and the screen to be updated. +click :: IO () +click = do + s <- readIORef state + + case hover s of + Just t -> do + evaluate2 $ boxes s !! t + putMVar visSignal UpdateSignal + _ -> return () + +evaluate2 :: Box -> IO () +evaluate2 b@(Box a) = do + c <- getBoxedClosureData b + case c of + -- ghc: internal error: MUT_ARR_PTRS_FROZEN object entered! + -- (GHC version 7.4.2 for x86_64_unknown_linux) + -- Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug + --ArrWordsClosure _ _ _ -> return () -- Don't inspect ArrWords + --MutArrClosure _ _ _ _ -> return () + --MVarClosure _ _ _ _ -> return () + --_ -> a `seq` return () + IndClosure{} -> a `seq` return () + BlackholeClosure{} -> a `seq` return () + FunClosure{} -> a `seq` return () + ThunkClosure{} -> a `seq` return () + APClosure{} -> a `seq` return () + PAPClosure{} -> a `seq` return () + _ -> return () + +-- | Handle a mouse move. Causes an 'UpdateSignal' if the mouse is hovering a +-- different object now, so the object gets highlighted and the screen +-- updated. +move :: WidgetClass w => w -> IO () +move canvas = do + vs <- readIORef visState + oldS <- readIORef state + let oldHover = hover oldS + + modifyIORef state $ \s' -> ( + let (mx, my) = mousePos vs + check (o, (x,y,w,h)) = + if x <= mx && mx <= x + w && + y <= my && my <= y + h + then Just o else Nothing + in s' {hover = msum $ map check (bounds oldS)} + ) + s <- readIORef state + unless (oldHover == hover s) $ widgetQueueDraw canvas + +-- | Something might have changed on the heap, update the view. +updateObjects :: [(Box, String)] -> IO () +updateObjects bs = do + (ops, bs', size) <- xDotParse bs + modifyIORef state (\s -> s {operations = ops, boxes = bs', totalSize = size}) diff --git a/src/GHC/Vis/GTK/List.hs b/src/GHC/Vis/GTK/List.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis/GTK/List.hs @@ -0,0 +1,324 @@ +{- | + Module : GHC.Vis.GTK.List + Copyright : (c) Dennis Felsing + License : 3-Clause BSD-style + Maintainer : dennis@felsin9.de + + -} +module GHC.Vis.GTK.List ( + export, + redraw, + click, + move, + updateObjects + ) + where +import Graphics.UI.Gtk hiding (Box, Signal, Rectangle) +import qualified Graphics.UI.Gtk as Gtk +import Graphics.Rendering.Cairo + +import Control.Concurrent +import Control.Monad + +import Data.IORef +import System.IO.Unsafe + +import GHC.Vis.Internal +import GHC.Vis.Types hiding (State) +import GHC.Vis.GTK.Common + +import GHC.HeapView (Box) + +type Rectangle = (Double, Double, Double, Double) + +data State = State + { objects :: [[VisObject]] + , bounds :: [(String, Rectangle)] + , hover :: Maybe String + } + +type RGB = (Double, Double, Double) + +state :: IORef State +state = unsafePerformIO $ newIORef $ State [] [] Nothing + +fontName :: String +-- Cairo's internal font system doesn't detect this as a similar font to "Times +-- Roman", should switch to Pango +--fontName = "Nimbus Roman No9 L" +fontName = "DejaVu Sans" + +fontSize :: Double +fontSize = 15 + +colorName :: RGB +colorName = (0.5,1,0.5) + +colorNameHighlighted :: RGB +colorNameHighlighted = (0,1,0) + +colorLink :: RGB +colorLink = (0.5,0.5,1) + +colorLinkHighlighted :: RGB +colorLinkHighlighted = (0.25,0.25,1) + +colorFunction :: RGB +colorFunction = (1,0.5,0.5) + +colorFunctionHighlighted :: RGB +colorFunctionHighlighted = (1,0,0) + +padding :: Double +padding = 5 + +-- | Draw visualization to screen, called on every update or when it's +-- requested from outside the program. +redraw :: WidgetClass w => w -> IO () +redraw canvas = do + boxes <- readMVar visBoxes + s <- readIORef state + Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas + + boundingBoxes <- render canvas (draw s rw2 rh2 boxes) + modifyIORef state (\s' -> s' {bounds = boundingBoxes}) + +-- | Export the visualization to an SVG file +export :: String -> IO () +export file = do + boxes <- readMVar visBoxes + s <- readIORef state + + withSVGSurface file (fromIntegral xSize) (fromIntegral ySize) + (\surface -> renderWith surface (draw s xSize ySize boxes)) + + return () + + where xSize = 500 :: Int + ySize = 500 :: Int + +draw :: State -> Int -> Int -> [(a, String)] -> Render [(String, Rectangle)] +draw s rw2 rh2 boxes = do + let objs = objects s + names = map ((++ ": ") . snd) boxes + + nameWidths <- mapM (width . Unnamed) names + pos <- mapM height objs + widths <- mapM (mapM width) objs + + -- Text sizes aren't always perfect, assume that texts may be a bit too big + let rw = 0.97 * fromIntegral rw2 + rh = 0.99 * fromIntegral rh2 + + maxNameWidth = maximum nameWidths + widths2 = 1 : map (\ws -> maxNameWidth + sum ws) widths + + sw = maximum widths2 + sh = sum (map (+ 30) pos) - 15 + + sx = min (rw / sw) (rh / sh) + sy = sx + ox = 0 + oy = 0 + + translate ox oy + scale sx sy + + let rpos = scanl (\a b -> a + b + 30) 30 pos + result <- mapM (drawEntry s maxNameWidth) (zip3 objs rpos names) + + return $ map (\(o, (x,y,w,h)) -> (o, (x*sx+ox,y*sy+oy,w*sx,h*sy))) $ concat result + +render :: WidgetClass w => w -> Render b -> IO b +render canvas r = do + win <- widgetGetDrawWindow canvas + renderWithDrawable win $ do + selectFontFace fontName FontSlantNormal FontWeightNormal + setFontSize fontSize + r + +-- | Handle a mouse click. If an object was clicked an 'UpdateSignal' is sent +-- that causes the object to be evaluated and the screen to be updated. +click :: IO () +click = do + s <- readIORef state + + case hover s of + Just t -> do + evaluate t + putMVar visSignal UpdateSignal + _ -> return () + +-- | Handle a mouse move. Causes an 'UpdateSignal' if the mouse is hovering a +-- different object now, so the object gets highlighted and the screen +-- updated. +move :: WidgetClass w => w -> IO () +move canvas = do + vS <- readIORef visState + oldS <- readIORef state + let oldHover = hover oldS + + modifyIORef state $ \s' -> ( + let (mx, my) = mousePos vS + check (o, (x,y,w,h)) = + if x <= mx && mx <= x + w && + y <= my && my <= y + h + then Just o else Nothing + in s' {hover = msum $ map check (bounds s')} + ) + s <- readIORef state + unless (oldHover == hover s) $ widgetQueueDraw canvas + +-- | Something might have changed on the heap, update the view. +updateObjects :: [(Box, String)] -> IO () +updateObjects boxes = do + objs <- parseBoxes boxes + modifyIORef state (\s -> s {objects = objs}) + +drawEntry :: State -> Double -> ([VisObject], Double, String) -> Render [(String, Rectangle)] +drawEntry s nameWidth (obj, pos, name) = do + save + translate 0 pos + moveTo 0 0 + drawBox s $ Unnamed name + --setSourceRGB 0 0 0 + --showText name + translate nameWidth 0 + moveTo 0 0 + boundingBoxes <- mapM (drawBox s) obj + restore + return $ map (\(o, (x,y,w,h)) -> (o, (x+nameWidth,y+pos,w,h))) $ concat boundingBoxes + +drawBox :: State -> VisObject -> Render [(String, Rectangle)] +drawBox _ o@(Unnamed content) = do + (x,_) <- getCurrentPoint + wc <- width o + moveTo (x + padding/2) 0 + setSourceRGB 0 0 0 + showText content + --translate wc 0 + moveTo (x + wc) 0 + + return [] + +drawBox s o@(Function target) = + drawFunctionLink s o target colorFunction colorFunctionHighlighted + +drawBox s o@(Link target) = + drawFunctionLink s o target colorLink colorLinkHighlighted + +drawBox s o@(Named name content) = do + (x,_) <- getCurrentPoint + TextExtents xb _ _ _ xa _ <- textExtents name + FontExtents fa _ fh _ _ <- fontExtents + hc <- height content + wc <- width o + + let (ux, uy, uw, uh) = + ( x + , -fa - padding + , wc + , fh + 10 + hc + ) + + setLineCap LineCapRound + roundedRect ux uy uw uh + + setColor s name colorName colorNameHighlighted + + fillAndSurround + + moveTo ux (hc + 5 - fa - padding) + lineTo (ux + uw) (hc + 5 - fa - padding) + stroke + + save + moveTo (x + padding) 0 + bb <- mapM (drawBox s) content + restore + + moveTo (x + uw/2 - (xa - xb)/2) (hc + 7.5 - padding) + showText name + moveTo (x + wc) 0 + + return $ concat bb ++ [(name, (ux, uy, uw, uh))] + +drawFunctionLink :: State -> VisObject -> String -> RGB -> RGB -> Render [(String, Rectangle)] +drawFunctionLink s o target color1 color2 = do + (x,_) <- getCurrentPoint + FontExtents fa _ fh _ _ <- fontExtents + wc <- width o + + let (ux, uy, uw, uh) = + ( x + , (-fa) - padding + , wc + , fh + 10 + ) + + setLineCap LineCapRound + roundedRect ux uy uw uh + + setColor s target color1 color2 + + fillAndSurround + + moveTo (x + padding) 0 + showText target + moveTo (x + wc) 0 + + return [(target, (ux, uy, uw, uh))] + +setColor :: State -> String -> RGB -> RGB -> Render () +setColor s name (r,g,b) (r',g',b') = case hover s of + Just t -> if t == name then setSourceRGB r' g' b' + else setSourceRGB r g b + _ -> setSourceRGB r g b + +fillAndSurround :: Render () +fillAndSurround = do + fillPreserve + setSourceRGB 0 0 0 + stroke + +roundedRect :: Double -> Double -> Double -> Double -> Render () +roundedRect x y w h = do + moveTo x (y + pad) + lineTo x (y + h - pad) + arcNegative (x + pad) (y + h - pad) pad pi (pi/2) + lineTo (x + w - pad) (y + h) + arcNegative (x + w - pad) (y + h - pad) pad (pi/2) 0 + lineTo (x + w) (y + pad) + arcNegative (x + w - pad) (y + pad) pad 0 (-pi/2) + lineTo (x + pad) y + arcNegative (x + pad) (y + pad) pad (-pi/2) (-pi) + closePath + + where pad = 1/10 * min w h + +height :: [VisObject] -> Render Double +height xs = do + FontExtents _ _ fh _ _ <- fontExtents + let go (Named _ ys) = (fh + 15) + maximum (map go ys) + go (Unnamed _) = fh + go (Link _) = fh + 10 + go (Function _) = fh + 10 + return $ maximum $ map go xs + +width :: VisObject -> Render Double +width (Named x ys) = do + TextExtents xb _ _ _ xa _ <- textExtents x + w2s <- mapM width ys + return $ max (xa - xb) (sum w2s) + 10 + +width (Unnamed x) = do + TextExtents xb _ _ _ xa _ <- textExtents x + return $ xa - xb + 5 + +width (Link x) = do + TextExtents xb _ _ _ xa _ <- textExtents x + return $ xa - xb + 10 + +width (Function x) = do + TextExtents xb _ _ _ xa _ <- textExtents x + return $ xa - xb + 10 diff --git a/src/GHC/Vis/Graph.hs b/src/GHC/Vis/Graph.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis/Graph.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | + Module : GHC.Vis.Graph + Copyright : (c) Dennis Felsing + License : 3-Clause BSD-style + Maintainer : dennis@felsin9.de + + -} +module GHC.Vis.Graph ( + xDotParse +) +where + +import System.IO.Unsafe + +import Data.Text.IO +import qualified Data.Text.Lazy as B + +import Data.Graph.Inductive hiding (nodes, edges) + +import Data.GraphViz hiding (Ellipse, Polygon, parse) +import qualified Data.GraphViz.Types.Generalised as G +import Data.GraphViz.Attributes.Complete + +import GHC.HeapView hiding (name) +import GHC.Vis.Internal +import GHC.Vis.Types + +import Graphics.XDot.Types hiding (name, h) +import Graphics.XDot.Parser + +fontName :: B.Text +--fontName = "Times Roman" +fontName = "DejaVu Sans" + +graphFontSize :: Double +graphFontSize = 24 + +nodeFontSize :: Double +nodeFontSize = 24 + +edgeFontSize :: Double +edgeFontSize = 24 + +-- | Take the objects to be visualized and run them through @dot@ and extract +-- the drawing operations that have to be exectued to show the graph of the +-- heap map. +xDotParse :: [(Box, String)] -> IO ([(Maybe Node, Operation)], [Box], Rectangle) +xDotParse as = do + (dotGraph, boxes) <- dg as + return (getOperations dotGraph, boxes, getSize dotGraph) + +dg :: [(Box, String)] -> IO (G.DotGraph Node, [Box]) +dg as = do + hm <- walkHeap as + --hm <- walkHeapDepth as + xDotText <- graphvizWithHandle Dot (defaultVis $ toViewableGraph $ buildGraph hm) XDot hGetContents + return (parseDotGraph $ B.fromChunks [xDotText], getBoxes hm) + +-- | Convert a heap map, our internal data structure, to a graph that can be +-- converted to a dot graph. +buildGraph :: HeapMap -> Gr Closure String +buildGraph hm = insEdges edges $ insNodes nodes empty + where nodes = zip [0..] $ map (\(_,(_,c)) -> c) rhm + edges = foldr toLEdge [] $ foldr mbEdges [] nodes + -- Reversing it fixes the ordering of nodes in the graph. Should run + -- through allPtrs and sort by order inside of all allPtrs lists. + -- + -- When building the graph directly out of [Box] instead of going + -- through the HeapMap, then the order of nodes might not be right for + -- non-trivial graphs. + -- + -- In some cases it's impossible to get the order right. Maybe there is + -- a way in graphviz to specify outgoing edge orientation after all? + rhm = reverse hm + + toLEdge (0, Just t) xs = case rhm !! t of + (_,(Just name, _)) -> (0,t,name):xs + (_,(Nothing, _)) -> (0,t,""):xs + toLEdge (f, Just t) xs = (f,t,""):xs + toLEdge _ xs = xs + + mbEdges (p,BCOClosure _ _ _ bPtr _ _ _) xs = map (\b -> (p, Just b)) (bcoChildren [bPtr] hm) ++ xs + -- Using allPtrs and then filtering the closures not available in the + -- heap map out emulates pointersToFollow without being in IO + mbEdges (p,c) xs = map (\b -> (p, boxPos b)) (allPtrs c) ++ xs + + boxPos :: Box -> Maybe Int + boxPos b = lookup b $ zip (map fst rhm) [0..] + + bcoChildren :: [Box] -> HeapMap -> [Int] + bcoChildren [] _ = [] + bcoChildren (b:bs) h = case boxPos b of + Nothing -> let ptf = unsafePerformIO $ getBoxedClosureData b >>= pointersToFollow2 + in bcoChildren (ptf ++ bs) h -- Could go into infinite loop + Just pos -> pos : bcoChildren bs h + +getBoxes :: HeapMap -> [Box] +getBoxes hm = map (\(b,(_,_)) -> b) $ reverse hm + +-- Probably have to do some kind of fold over the graph to remove for example +-- unwanted pointers +toViewableGraph :: Gr Closure String -> Gr String String +toViewableGraph cg = emap id $ nmap showClosure cg + +defaultVis :: (Graph gr) => gr String String -> DotGraph Node +defaultVis = graphToDot nonClusteredParams + -- Somehow (X11Color Transparency) is white, use (RGBA 0 0 0 0) instead + { globalAttributes = [GraphAttrs [BgColor [RGBA 0 0 0 0], FontName fontName, FontSize graphFontSize]] + , fmtNode = \ (_,l) -> [toLabel l, FontName fontName, FontSize nodeFontSize] + , fmtEdge = \ (_,_,l) -> [toLabel l, FontName fontName, FontSize edgeFontSize] + } diff --git a/src/GHC/Vis/Internal.hs b/src/GHC/Vis/Internal.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis/Internal.hs @@ -0,0 +1,458 @@ +{-# LANGUAGE MagicHash #-} + +{- | + Module : GHC.Vis.Internal + Copyright : (c) Dennis Felsing + License : 3-Clause BSD-style + Maintainer : dennis@felsin9.de + + -} +module GHC.Vis.Internal ( + walkHeap, + --walkHeapDepth, + parseBoxes, + parseBoxesHeap, + --parseClosure, + --pointersToFollow, + pointersToFollow2, + showClosure + ) + where + +import GHC.Vis.Types +import GHC.HeapView hiding (name, pkg, modl, fun, arrWords) + +import Control.Monad +import Control.Monad.State hiding (State, fix) +import Data.Word +import Data.Char +import Data.List hiding (insert) +import Text.Printf +import Unsafe.Coerce + +import System.IO.Unsafe + +-- | Walk the heap for a list of objects to be visualized and their +-- corresponding names. +parseBoxes :: [(Box, String)] -> IO [[VisObject]] +parseBoxes = generalParseBoxes evalState + +-- | Walk the heap for a list of objects to be visualized and their +-- corresponding names. Also return the resulting 'HeapMap' and another +-- 'HeapMap' that does not contain BCO pointers. +parseBoxesHeap :: [(Box, String)] -> IO ([[VisObject]], (Integer, HeapMap, HeapMap)) +parseBoxesHeap = generalParseBoxes runState + +generalParseBoxes :: Num t => + (PrintState [[VisObject]] -> (t, HeapMap, HeapMap) -> b) + -> [(Box, String)] -> IO b +generalParseBoxes f bs = walkHeapSimply bs >>= \h -> walkHeapWithBCO bs >>= \h2 -> return $ f (go bs) (0,h,h2) + where go ((b',_):b's) = do (_,h,_) <- get + let (Just (_,c)) = lookup b' h + r <- parseClosure b' c + rs <- go b's + --return (r:rs) + return (simplify r:rs) + go [] = return [] + +-- Pulls together multiple Unnamed objects to one +simplify :: [VisObject] -> [VisObject] +simplify [] = [] +simplify [Named a bs] = [Named a $ simplify bs] +simplify [a] = [a] +simplify (Unnamed a : Unnamed b : xs) = simplify $ Unnamed (a ++ b) : xs +simplify (Named a bs : xs) = Named a (simplify bs) : simplify xs +simplify (a:xs) = a : simplify xs + +parseClosure :: Box -> Closure -> PrintState [VisObject] +parseClosure b c = do + o <- correctObject b + case o of + Link n -> return [Link n] -- Don't build infinite heaps + _ -> do i <- parseInternal b c + return $ insertObjects o i + +fromJust1 :: String -> Maybe t -> t +fromJust1 _ (Just n) = n +fromJust1 x _ = error $ "Invalid fromJust " ++ x + +correctObject :: Box -> PrintState VisObject +correctObject box = do + r <- countReferences box + n <- getName box + + case n of + Just name -> return $ Link name + Nothing -> if r > 1 then + (do setName box + name <- liftM (fromJust1 "1") $ getName box + return $ Named name []) + else return $ Unnamed "" + +insertObjects :: VisObject -> [VisObject] -> [VisObject] +insertObjects _ xs@(Function _ : _) = xs +insertObjects (Link name) _ = [Link name] +insertObjects (Named name _) xs = [Named name xs] +insertObjects (Unnamed _) xs = xs +insertObjects _ _ = error "unexpected arguments" + +-- | Recursively walk down the heap objects and return the resulting map. This +-- function recognizes loops and avoids them. Big data structures might still +-- be very slow. +walkHeap :: [(Box, String)] -> IO HeapMap +walkHeap = walkHeapGeneral Just pointersToFollow + +-- walkHeap, but without Top level names +walkHeapSimply :: [(Box, String)] -> IO HeapMap +walkHeapSimply = walkHeapGeneral (const Nothing) pointersToFollow + +walkHeapWithBCO :: [(Box, String)] -> IO HeapMap +walkHeapWithBCO = walkHeapGeneral (const Nothing) pointersToFollow2 + +walkHeapGeneral :: (String -> Maybe String) -> (Closure -> IO [Box]) -> [(Box, String)] -> IO HeapMap +walkHeapGeneral topF p2fF bs = foldM (topNodes topF) [dummy] bs >>= \s -> foldM (startWalk p2fF) s bs + where topNodes hn l (b,n) = do -- Adds the top nodes without looking at their pointers + c' <- getBoxedClosureData b + return $ insert (b, (hn n, c')) l + startWalk p2f l (b,_) = do -- Ignores that the top nodes are already in the heap map + c' <- getBoxedClosureData b + p <- p2f c' + foldM (step p2f) l p + step p2f l b = case lookup b l of + Just _ -> return l + Nothing -> do + c' <- getBoxedClosureData b + p <- p2f c' + foldM (step p2f) (insert (b, (Nothing, c')) l) p + dummy = (asBox (1 :: Integer), + (Nothing, ConsClosure (StgInfoTable 0 0 CONSTR_0_1 0) (map fst bs) [] "" "" "")) + +-- Don't inspect deep pointers in BCOClosures for now, they never end + +-- New: We're not inspecting the BCOs and instead later looks which of its +-- recursive children are still in the heap. Only those should be visualized. +pointersToFollow :: Closure -> IO [Box] +pointersToFollow (BCOClosure StgInfoTable{} _ _ _ _ _ _) = return [] + +pointersToFollow (MutArrClosure StgInfoTable{} _ _ bPtrs) = + do cPtrs <- mapM getBoxedClosureData bPtrs + return $ fix $ zip bPtrs cPtrs + where fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):_:_:xs) = fix xs + fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):_:xs) = fix xs + fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):xs) = fix xs + fix ((x,_):xs) = x : fix xs + fix [] = [] + +pointersToFollow x = return $ allPtrs x + +-- | Follows 'GHC.HeapView.BCOClosure's, but not the debugging data structures +-- (ByteCodeInstr.BreakInfo) of GHC. +pointersToFollow2 :: Closure -> IO [Box] +pointersToFollow2 (MutArrClosure StgInfoTable{} _ _ bPtrs) = + do cPtrs <- mapM getBoxedClosureData bPtrs + return $ fix $ zip bPtrs cPtrs + where fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):_:_:xs) = fix xs + fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):_:xs) = fix xs + fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):xs) = fix xs + fix ((x,_):xs) = x : fix xs + fix [] = [] + +pointersToFollow2 x = return $ allPtrs x + +-- walkHeap, but with a maximum depth +--walkHeapDepth :: [(Box, String)] -> IO HeapMap +--walkHeapDepth bs = foldM topNodes [dummy bs] bs >>= \s -> foldM goStart s bs +-- where topNodes l (b,n) = do -- Adds the top nodes without looking at their pointers +-- c' <- getBoxedClosureData b +-- return $ insert (b, (Just n, c')) l +-- goStart l (b,_) = do -- Ignores that the top nodes are already in the heap map +-- c' <- getBoxedClosureData b +-- p <- pointersToFollow c' +-- foldM (\l b -> go l b 30) l p +-- go l _ 0 = return l +-- go l b x = case lookup b l of +-- Just _ -> return l +-- Nothing -> do +-- c' <- getBoxedClosureData b +-- p <- pointersToFollow c' +-- foldM (\l b -> go l b (x-1)) (insert (b, (Nothing, c')) l) p + +-- Additional map operations +insert :: (Box, HeapEntry) -> HeapMap -> HeapMap +insert (b,x) xs = case find (\(c,_) -> c == b) xs of + Just _ -> xs + Nothing -> (b,x):xs + +adjust :: (HeapEntry -> HeapEntry) -> Box -> HeapMap -> HeapMap +adjust f b h = h1 ++ ((b,f x) : h2) + where i = fromJust1 "2" $ findIndex (\(y,_) -> y == b) h + (h1,(_,x):h2) = splitAt i h + +setName :: Box -> PrintState () +setName b = modify go + where go (i,h,h2) = (i + 1, adjust (set i) b h, h2) + set i (Nothing, closure) = (Just ('t' : show i), closure) + set _ _ = error "unexpected pattern" + +getName :: Box -> PrintState (Maybe String) +getName b = do (_,h,_) <- get + return $ fst $ fromJust1 "3" $ lookup b h + +getSetName :: Box -> PrintState String +getSetName b = do mn <- getName b + case mn of + Nothing -> do setName b + n <- getName b + return $ fromJust1 "4" n + Just name -> return name + +-- How often is a box referenced in the entire heap map +countReferences :: Box -> PrintState Int +countReferences b = do + (_,_,h) <- get + return $ sum $ map countR h + where countR (_,(_,c)) = length $ filter (== b) $ allPtrs c + +parseInternal :: Box -> Closure -> PrintState [VisObject] +parseInternal _ (ConsClosure StgInfoTable{} _ [dataArg] _pkg modl name) = + return [Unnamed $ case (modl, name) of + k | k `elem` [ ("GHC.Word", "W#") + , ("GHC.Word", "W8#") + , ("GHC.Word", "W16#") + , ("GHC.Word", "W32#") + , ("GHC.Word", "W64#") + ] -> show dataArg + + k | k `elem` [ ("GHC.Integer.Type", "S#") + , ("GHC.Types", "I#") + , ("GHC.Int", "I8#") + , ("GHC.Int", "I16#") + , ("GHC.Int", "I32#") + , ("GHC.Int", "I64#") + ] -> show $ (fromIntegral :: Word -> Int) dataArg + + ("GHC.Types", "C#") -> show . chr $ fromIntegral dataArg + + ("Types", "D#") -> printf "%0.5f" (unsafeCoerce dataArg :: Double) + ("Types", "F#") -> printf "%0.5f" (unsafeCoerce dataArg :: Double) + + (_,name') -> printf "%s[%d]" name' dataArg + ] + +-- Empty ByteStrings point to a nullForeignPtr, evaluating it leads to an +-- Prelude.undefined exception +parseInternal _ (ConsClosure (StgInfoTable 1 3 _ 0) _ [_,0,0] _ "Data.ByteString.Internal" "PS") + = return [Unnamed "ByteString[0,0]()"] + +parseInternal _ (ConsClosure (StgInfoTable 1 3 _ 0) [bPtr] [_,start,end] _ "Data.ByteString.Internal" "PS") + = do cPtr <- contParse bPtr + return $ Unnamed (printf "ByteString[%d,%d](" start end) : cPtr ++ [Unnamed ")"] + +parseInternal _ (ConsClosure (StgInfoTable 2 3 _ 1) [bPtr1,bPtr2] [_,start,end] _ "Data.ByteString.Lazy.Internal" "Chunk") + = do cPtr1 <- contParse bPtr1 + cPtr2 <- contParse bPtr2 + return $ Unnamed (printf "Chunk[%d,%d](" start end) : cPtr1 ++ [Unnamed ","] ++ cPtr2 ++ [Unnamed ")"] + +parseInternal _ (ConsClosure (StgInfoTable 1 0 CONSTR_1_0 _) [bPtr] [] _ _ name) + = do cPtr <- contParse bPtr + return $ Unnamed (name ++ " ") : mbParens cPtr + +parseInternal _ (ConsClosure (StgInfoTable 0 0 CONSTR_NOCAF_STATIC _) [] [] _ _ name) + = return [Unnamed name] + +parseInternal _ (ConsClosure (StgInfoTable 0 _ CONSTR_NOCAF_STATIC _) [] args _ _ name) + = return [Unnamed (name ++ " " ++ show args)] + +parseInternal _ (ConsClosure (StgInfoTable 2 0 _ 1) [bHead,bTail] [] _ "GHC.Types" ":") + = do cHead <- liftM mbParens $ contParse bHead + cTail <- liftM mbParens $ contParse bTail + return $ cHead ++ [Unnamed ":"] ++ cTail + +parseInternal _ (ConsClosure (StgInfoTable _ 0 _ _) bPtrs [] _ _ name) + = do cPtrs <- mapM (liftM mbParens . contParse) bPtrs + let tPtrs = intercalate [Unnamed " "] cPtrs + return $ Unnamed (name ++ " ") : tPtrs + +parseInternal _ (ConsClosure (StgInfoTable _ _ _ _) bPtrs dArgs _ _ name) + = do cPtrs <- mapM (liftM mbParens . contParse) bPtrs + let tPtrs = intercalate [Unnamed " "] cPtrs + return $ Unnamed (name ++ show dArgs ++ " ") : tPtrs + +parseInternal _ (ArrWordsClosure (StgInfoTable 0 0 ARR_WORDS 0) _ arrWords) + = return $ intercalate [Unnamed ","] (map (\x -> [Unnamed (printf "0x%x" x)]) arrWords) + +parseInternal _ (IndClosure (StgInfoTable 1 0 _ 0) b) + = contParse b + +parseInternal _ (BlackholeClosure (StgInfoTable 1 0 _ 0) b) + = contParse b + +-- Reversed order of ptrs +parseInternal b (ThunkClosure StgInfoTable{} bPtrs args) + = parseThunkFun b bPtrs args + +parseInternal b (FunClosure StgInfoTable{} bPtrs args) + = parseThunkFun b bPtrs args + +-- bPtrs here can currently point to Nothing, because else we might get infinite heaps +parseInternal _ (MutArrClosure StgInfoTable{} _ _ bPtrs) + = do cPtrs <- mutArrContParse bPtrs + let tPtrs = intercalate [Unnamed ","] cPtrs + return $ Unnamed "(" : tPtrs ++ [Unnamed ")"] + +parseInternal _ (BCOClosure (StgInfoTable 4 0 BCO 0) _ _ bPtr _ _ _) + = do cPtrs <- bcoContParse [bPtr] + let tPtrs = intercalate [Unnamed ","] cPtrs + return $ Unnamed "(" : tPtrs ++ [Unnamed ")"] + -- = do case lookup b h of + -- Nothing -> c <- getBoxedClosureData bPtr + -- Just (_,c) -> p <- parseClosure bPtr c + -- = do vs <- contParse bPtr + -- let ls = filter isExternal $ filter isLink vs + + -- isLink (Link _) = True + -- isLink _ = False + + -- isExternal (Link n) = all (notHasName n) vs + + -- notHasName n (Named m _) = n /= m + -- notHasName n (Function m) = n /= m + -- notHasName _ _ = True + -- return vs + +parseInternal b (APClosure (StgInfoTable 0 0 _ _) _ _ fun _) + = do cPtr <- contParse fun + getSetName b >>= \x -> return $ Function x : cPtr + +parseInternal b (PAPClosure (StgInfoTable 0 0 _ _) _ _ _ _) + = getSetName b >>= \x -> return [Function x] + +parseInternal _ (MVarClosure StgInfoTable{} qHead qTail qValue) + = do cHead <- liftM mbParens $ contParse qHead + cTail <- liftM mbParens $ contParse qTail + cValue <- liftM mbParens $ contParse qValue + return $ Unnamed "MVar#(" : cHead ++ [Unnamed ","] ++ cTail ++ [Unnamed ","] ++ cValue ++ [Unnamed ")"] + +parseInternal _ c = return [Unnamed ("Missing pattern for " ++ show c)] + +parseThunkFun :: Box -> [Box] -> [Word] -> PrintState [VisObject] +parseThunkFun b bPtrs args = do + name <- getSetName b + cPtrs <- mapM contParse $ reverse bPtrs + let tPtrs = intercalate [Unnamed ","] cPtrs + return $ if null args then + Function name : Unnamed "(" : tPtrs ++ [Unnamed ")"] else + Function name : (Unnamed $ show args ++ "(") : tPtrs ++ [Unnamed ")"] + +contParse :: Box -> PrintState [VisObject] +contParse b = get >>= \(_,h,_) -> parseClosure b (snd $ fromJust1 "5" $ lookup b h) + +bcoContParse :: [Box] -> PrintState [[VisObject]] +bcoContParse [] = return [] +bcoContParse (b:bs) = get >>= \(_,h,_) -> case lookup b h of + Nothing -> do let ptf = unsafePerformIO $ getBoxedClosureData b >>= pointersToFollow2 + bcoContParse $ ptf ++ bs -- Could go into infinite loop + Just (_,c) -> do p <- parseClosure b c + ps <- bcoContParse bs + return $ p : ps + +mutArrContParse :: [Box] -> PrintState [[VisObject]] +mutArrContParse [] = return [] +mutArrContParse (b:bs) = get >>= \(_,h,_) -> case lookup b h of + Nothing -> mutArrContParse bs + Just (_,c) -> do p <- parseClosure b c + ps <- mutArrContParse bs + return $ p : ps + +-- TODO: Doesn't work quite right, for example with (1,"fo") +mbParens :: [VisObject] -> [VisObject] +mbParens t@(Unnamed ('"':_):_) = t +mbParens t@(Unnamed ('(':_):_) = t +mbParens t | ' ' `objElem` t = Unnamed "(" : t ++ [Unnamed ")"] + | otherwise = t + where objElem c = any go + where go (Unnamed xs) = c `elem` xs + go (Named _ os) = any go os + go _ = False + +-- | Textual representation of Heap objects, used in the graph visualization. +showClosure :: Closure -> String +showClosure (ConsClosure StgInfoTable{} _ [dataArg] _ modl name) = + case (modl, name) of + k | k `elem` [ ("GHC.Word", "W#") + , ("GHC.Word", "W8#") + , ("GHC.Word", "W16#") + , ("GHC.Word", "W32#") + , ("GHC.Word", "W64#") + ] -> show dataArg + + k | k `elem` [ ("GHC.Integer.Type", "S#") + , ("GHC.Types", "I#") + , ("GHC.Int", "I8#") + , ("GHC.Int", "I16#") + , ("GHC.Int", "I32#") + , ("GHC.Int", "I64#") + ] -> show $ (fromIntegral :: Word -> Int) dataArg + + ("GHC.Types", "C#") -> show . chr $ fromIntegral dataArg + + ("Types", "D#") -> printf "%0.5f" (unsafeCoerce dataArg :: Double) + ("Types", "F#") -> printf "%0.5f" (unsafeCoerce dataArg :: Double) + + -- :m +GHC.Arr + -- let b = array ((1,1),(3,2)) [((1,1),42),((1,2),23),((2,1),999),((2,2),1000),((3,1),1001),((3,2),1002)] + -- b + -- :view b + ("GHC.Arr", "Array") -> printf "Array[%d]" dataArg + + (_,name') -> printf "%s[%d]" name' dataArg + +showClosure (ConsClosure (StgInfoTable 1 3 _ 0) _ [_,0,0] _ "Data.ByteString.Internal" "PS") + = "ByteString[0,0]" + +showClosure (ConsClosure (StgInfoTable 1 3 _ 0) [_] [_,start,end] _ "Data.ByteString.Internal" "PS") + = printf "ByteString[%d,%d]" start end + +showClosure (ConsClosure (StgInfoTable 2 3 _ 1) [_,_] [_,start,end] _ "Data.ByteString.Lazy.Internal" "Chunk") + = printf "Chunk[%d,%d]" start end + +showClosure (ConsClosure StgInfoTable{} _ [] _ _ name) + = name + +showClosure (ConsClosure StgInfoTable{} _ dArgs _ _ name) + = name ++ show dArgs + +showClosure (ArrWordsClosure (StgInfoTable 0 0 ARR_WORDS 0) _ arrWords) + = intercalate ",\n" $ map (printf "0x%x") arrWords +-- = "ArrWords" + +-- Probably should delete these from Graph +showClosure (IndClosure (StgInfoTable 1 0 _ 0) _) + = "Ind" + +showClosure (BlackholeClosure (StgInfoTable 1 0 _ 0) _) + = "Blackhole" + +-- Reversed order of ptrs +showClosure (ThunkClosure StgInfoTable{} _ _) + = "Thunk" + +showClosure (FunClosure StgInfoTable{} _ _) + = "Fun" + +showClosure (MutArrClosure StgInfoTable{} _ _ _) + = "MutArr" + +showClosure (BCOClosure (StgInfoTable 4 0 BCO 0) _ _ _ _ _ _) + = "BCO" + +showClosure (APClosure (StgInfoTable 0 0 _ _) _ _ _ _) + = "AP" + +showClosure (PAPClosure (StgInfoTable 0 0 _ _) _ _ _ _) + = "PAP" + +showClosure (MVarClosure StgInfoTable{} _ _ _) + = "MVar#" + +showClosure c = "Missing pattern for " ++ show c diff --git a/src/GHC/Vis/Types.hs b/src/GHC/Vis/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis/Types.hs @@ -0,0 +1,70 @@ +{- | + Module : GHC.Vis.Types + Copyright : (c) Dennis Felsing + License : 3-Clause BSD-style + Maintainer : dennis@felsin9.de + + -} +module GHC.Vis.Types ( + Signal(..), + ViewType(..), + State(..), + HeapEntry, + HeapMap, + PrintState, + VisObject(..) + ) + where + +import GHC.HeapView + +import Graphics.XDot.Types + +import qualified Control.Monad.State as MS + +-- | Signals that are sent to the GUI to signal changes +data Signal = NewSignal Box String -- ^ Add a new Box to be visualized + | UpdateSignal -- ^ Redraw + | ClearSignal -- ^ Remove all Boxes + | SwitchSignal -- ^ Switch to alternative view + | ExportSignal String -- ^ Export the view to a file + +-- | Visualization views +data ViewType = ListView + | GraphView + deriving (Enum, Eq, Bounded) + +-- | The global state used for the visualizations. +data State = State + { mousePos :: Point -- ^ Current position of the mouse, updated with every movement + , view :: ViewType -- ^ What kind of visualization is currently running + } + +-- | An entry in a 'HeapMap', consisting of an identifier and a parsed GHC heap entry +type HeapEntry = + ( Maybe String + , Closure + ) +-- | A map of heap objects. +-- +-- We're using a slow, eq-based list instead of a proper map because +-- StableNames' hash values aren't stable enough +type HeapMap = [(Box, HeapEntry)] + +-- | The second HeapMap includes BCO pointers, needed for list visualization +type PrintState = MS.State (Integer, HeapMap, HeapMap) + +-- | Simple representation of objects on the heap, so they can be arranged linearly +data VisObject = Unnamed String + | Named String [VisObject] + | Link String + | Function String + deriving Eq + +instance Show VisObject where + show (Unnamed x) = x + show (Named x ys) = x ++ "=(" ++ show ys ++ ")" + show (Link x) = x + show (Function x) = x + + showList = foldr ((.) . showString . show) (showString "")