ghc-vis 0.9 → 0.9.1
raw patch · 8 files changed
+92/−42 lines, 8 filesdep ~basedep ~cairodep ~containers
Dependency ranges changed: base, cairo, containers, fgl, gtk3, mtl, svgcairo, text, transformers
Files
- ghc-vis.cabal +10/−10
- src/GHC/Vis.hs +3/−1
- src/GHC/Vis/Internal.hs +47/−16
- src/GHC/Vis/Types.hs +1/−1
- src/GHC/Vis/View/Common.hs +8/−2
- src/GHC/Vis/View/Graph.hs +11/−1
- src/GHC/Vis/View/Graph/Parser.hs +2/−2
- src/GHC/Vis/View/List.hs +10/−9
ghc-vis.cabal view
@@ -1,5 +1,5 @@ name: ghc-vis-version: 0.9+version: 0.9.1 license: BSD3 license-file: LICENSE category: GHC, Debug, Development@@ -40,16 +40,16 @@ Exposed-modules: GHC.Vis Other-modules: GHC.Vis.Internal GHC.Vis.Types GHC.Vis.View.List GHC.Vis.View.Common Paths_ghc_vis Default-Language: Haskell2010- Build-depends: base >= 4.5 && < 4.10,- mtl >= 2.0 && < 2.3,- fgl >= 5.4 && < 5.6,+ Build-depends: base >= 4.5 && < 4.15,+ mtl >= 2.0,+ fgl >= 5.4, deepseq >= 1.3,- text >= 0.11 && < 1.3,- transformers >= 0.3 && < 0.6,- containers >= 0.4 && < 0.6,- gtk3 >= 0.12 && < 0.15,- svgcairo >= 0.12 && < 0.14,- cairo >= 0.12 && < 0.14,+ text >= 0.11,+ transformers >= 0.3,+ containers >= 0.4,+ gtk3 >= 0.12,+ svgcairo >= 0.12,+ cairo >= 0.12, ghc-heap-view >= 0.5 Hs-source-dirs: src/ Ghc-options: -Wall -fno-warn-unused-do-bind
src/GHC/Vis.hs view
@@ -90,6 +90,7 @@ #endif import Graphics.Rendering.Cairo hiding (restore, x, y, width, height)+import Debug.Trace #ifdef FULL_WINDOW import Graphics.Rendering.Cairo.SVG@@ -309,6 +310,7 @@ setupGUI window canvas legendCanvas = do widgetAddEvents canvas [PointerMotionMask] on canvas motionNotifyEvent $ do+ liftIO $ traceIO "on canvas motionNotifyEvent" (x,y) <- eventCoordinates lift $ do state <- readIORef visState@@ -323,7 +325,7 @@ widgetQueueDraw canvas else runCorrect move >>= \f -> f canvas-+ traceIO "on canvas motionNotifyEvent End" return True on canvas buttonPressEvent $ do
src/GHC/Vis/Internal.hs view
@@ -22,7 +22,7 @@ import GHC.HeapView hiding (pkg, modl, fun, arrWords) import Control.Monad-import Control.Monad.State hiding (State, fix)+import Control.Monad.State.Strict hiding (State, fix) import Data.Char import Data.List hiding (insert)@@ -36,6 +36,7 @@ -- TODO: Remove instance Eq Box where a == b = unsafePerformIO $ areBoxesEqual a b+ {-# NoINLINE (==) #-} -- | Parse a closure to a list of VisObjects parseClosure :: HeapGraphIndex -> PrintState [VisObject]@@ -101,7 +102,9 @@ insertObjects _ _ = error "unexpected arguments" parseInternal :: HeapGraphIndex -> GenClosure (Maybe HeapGraphIndex) -> PrintState [VisObject]-parseInternal _ (ConsClosure _ [] [dataArg] _pkg modl name) =++-- TODO remove old cases replaced by closure types+parseInternal _ (ConstrClosure _ [] [dataArg] _pkg modl name) = return [Unnamed $ case (modl, name) of k | k `elem` [ ("GHC.Word", "W#") , ("GHC.Word", "W8#")@@ -127,24 +130,38 @@ _ -> printf "%s %d" (infixFix name) dataArg ] -parseInternal _ (ConsClosure (StgInfoTable 1 3 _ _) _ [_,0,0] _ "Data.ByteString.Internal" "PS")+parseInternal _ (IntClosure _ val) = return [Unnamed $ "I# " ++ show val]++parseInternal _ (Int64Closure _ val) = return [Unnamed $ "I64# " ++ show val]++parseInternal _ (WordClosure _ val) = return [Unnamed $ "W# " ++ show val]++parseInternal _ (Word64Closure _ val) = return [Unnamed $ "W64# " ++ show val]++parseInternal _ (FloatClosure _ val) = return [Unnamed $ printf "F# %0.5f" val]++parseInternal _ (DoubleClosure _ val) = return [Unnamed $ printf "D# %0.5f" val]++parseInternal _ (AddrClosure _ val) = return [Unnamed $ printf "Addr# %p" val]++parseInternal _ (ConstrClosure (StgInfoTable _ 1 3 _ _ _) _ [_,0,0] _ "Data.ByteString.Internal" "PS") = return [Unnamed "ByteString 0 0"] -parseInternal _ (ConsClosure (StgInfoTable 1 3 _ _) [bPtr] [_,start,end] _ "Data.ByteString.Internal" "PS")+parseInternal _ (ConstrClosure (StgInfoTable _ 1 3 _ _ _) [bPtr] [_,start,end] _ "Data.ByteString.Internal" "PS") = do cPtr <- liftM mbParens $ contParse bPtr return $ Unnamed (printf "ByteString %d %d " start end) : cPtr -parseInternal _ (ConsClosure (StgInfoTable 2 3 _ _) [bPtr1,bPtr2] [_,start,end] _ "Data.ByteString.Lazy.Internal" "Chunk")+parseInternal _ (ConstrClosure (StgInfoTable _ 2 3 _ _ _) [bPtr1,bPtr2] [_,start,end] _ "Data.ByteString.Lazy.Internal" "Chunk") = do cPtr1 <- liftM mbParens $ contParse bPtr1 cPtr2 <- liftM mbParens $ contParse bPtr2 return $ Unnamed (printf "Chunk %d %d " start end) : cPtr1 ++ [Unnamed " "] ++ cPtr2 -parseInternal _ (ConsClosure (StgInfoTable 2 0 _ _) [bHead,bTail] [] _ "GHC.Types" ":")+parseInternal _ (ConstrClosure (StgInfoTable _ 2 0 _ _ _) [bHead,bTail] [] _ "GHC.Types" ":") = do cHead <- liftM mbParens $ contParse bHead cTail <- liftM mbParens $ contParse bTail return $ cHead ++ [Unnamed ":"] ++ cTail -parseInternal _ (ConsClosure _ bPtrs dArgs _ _ name)+parseInternal _ (ConstrClosure _ bPtrs dArgs _ _ name) = do cPtrs <- mapM (liftM mbParens . contParse) bPtrs let tPtrs = intercalate [Unnamed " "] cPtrs let sPtrs = if null tPtrs then [Unnamed ""] else Unnamed " " : tPtrs@@ -165,10 +182,10 @@ parseInternal _ BlockingQueueClosure{} = return [Unnamed "BlockingQueue"] -parseInternal _ (OtherClosure (StgInfoTable _ _ cTipe _) _ _)+parseInternal _ (OtherClosure (StgInfoTable _ _ _ cTipe _ _) _ _) = return [Unnamed $ show cTipe] -parseInternal _ (UnsupportedClosure (StgInfoTable _ _ cTipe _))+parseInternal _ (UnsupportedClosure (StgInfoTable _ _ _ cTipe _ _)) = return [Unnamed $ show cTipe] -- Reversed order of ptrs@@ -294,7 +311,7 @@ -- | Textual representation of Heap objects, used in the graph visualization. showClosureFields :: GenClosure t -> [String]-showClosureFields (ConsClosure _ _ [dataArg] _ modl name) =+showClosureFields (ConstrClosure _ _ [dataArg] _ modl name) = case (modl, name) of k | k `elem` [ ("GHC.Word", "W#") , ("GHC.Word", "W8#")@@ -322,16 +339,30 @@ -- :view b _ -> [name, show dataArg] -showClosureFields (ConsClosure (StgInfoTable 1 3 _ 0) _ [_,0,0] _ "Data.ByteString.Internal" "PS")+showClosureFields (IntClosure _ val) = ["I# " ++ show val]++showClosureFields (Int64Closure _ val) = ["I64# " ++ show val]++showClosureFields (WordClosure _ val) = ["W# " ++ show val]++showClosureFields (Word64Closure _ val) = ["W64# " ++ show val]++showClosureFields (FloatClosure _ val) = [printf "F# %0.5f" val]++showClosureFields (DoubleClosure _ val) = [printf "D# %0.5f" val]++showClosureFields (AddrClosure _ val) = [printf "Addr# %p" val]++showClosureFields (ConstrClosure (StgInfoTable _ 1 3 _ 0 _) _ [_,0,0] _ "Data.ByteString.Internal" "PS") = ["ByteString","0","0"] -showClosureFields (ConsClosure (StgInfoTable 1 3 _ 0) [_] [_,start,end] _ "Data.ByteString.Internal" "PS")+showClosureFields (ConstrClosure (StgInfoTable _ 1 3 _ 0 _) [_] [_,start,end] _ "Data.ByteString.Internal" "PS") = ["ByteString",printf "%d" start,printf "%d" end] -showClosureFields (ConsClosure (StgInfoTable 2 3 _ 1) [_,_] [_,start,end] _ "Data.ByteString.Lazy.Internal" "Chunk")+showClosureFields (ConstrClosure (StgInfoTable _ 2 3 _ 1 _) [_,_] [_,start,end] _ "Data.ByteString.Lazy.Internal" "Chunk") = ["Chunk",printf "%d" start,printf "%d" end] -showClosureFields (ConsClosure _ _ dArgs _ _ name)+showClosureFields (ConstrClosure _ _ dArgs _ _ name) = name : map show dArgs -- Reversed order of ptrs@@ -378,10 +409,10 @@ showClosureFields BlockingQueueClosure{} = ["BlockingQueue"] -showClosureFields (OtherClosure (StgInfoTable _ _ cTipe _) _ _)+showClosureFields (OtherClosure (StgInfoTable _ _ _ cTipe _ _) _ _) = [show cTipe] -showClosureFields (UnsupportedClosure (StgInfoTable _ _ cTipe _))+showClosureFields (UnsupportedClosure (StgInfoTable _ _ _ cTipe _ _)) = [show cTipe] --showClosure c = "Missing pattern for " ++ show c
src/GHC/Vis/Types.hs view
@@ -23,7 +23,7 @@ import GHC.HeapView -import qualified Control.Monad.State as MS+import qualified Control.Monad.State.Strict as MS import Graphics.UI.Gtk hiding (Box, Signal, Point) import Graphics.Rendering.Cairo hiding (x)
src/GHC/Vis/View/Common.hs view
@@ -29,7 +29,7 @@ import Control.DeepSeq import Control.Exception hiding (evaluate) -import Control.Monad.State hiding (State, fix)+import Control.Monad.State.Strict hiding (State, fix) import qualified Data.IntMap as M @@ -46,10 +46,12 @@ -- | Communication channel to the visualization visSignal :: MVar Signal+{-# NOINLINE visSignal #-} visSignal = unsafePerformIO (newEmptyMVar :: IO (MVar Signal)) -- | Whether a visualization is currently running visRunning :: MVar Bool+{-# NOINLINE visRunning #-} visRunning = unsafePerformIO (newMVar False) defaultDepth :: Int@@ -64,18 +66,22 @@ -- | Internal state of the visualization visState :: IORef State+{-# NOINLINE visState #-} visState = unsafePerformIO $ newIORef $ State (0, 0) defaultView 1 (0, 0) False False defaultDepth -- | All the visualized boxes visBoxes :: MVar [NamedBox]+{-# NOINLINE visBoxes #-} visBoxes = unsafePerformIO (newMVar [] :: IO (MVar [NamedBox])) -- | Hidden boxes visHidden :: MVar [Box]+{-# NOINLINE visHidden #-} visHidden = unsafePerformIO (newMVar [] :: IO (MVar [Box])) -- | All heap graphs since the last clear command visHeapHistory :: MVar (Int, [(HeapGraph Identifier, [(Identifier, HeapGraphIndex)])])+{-# NOINLINE visHeapHistory #-} visHeapHistory = unsafePerformIO (newMVar (0, [(HeapGraph M.empty, [])]) :: IO (MVar (Int, [(HeapGraph Identifier, [(Identifier, HeapGraphIndex)])]))) -- | Get the currently selected heap graph@@ -124,7 +130,7 @@ -- second parameter adds external references, commonly @[heapGraphRoot]@. boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex] boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $- roots ++ concatMap (catMaybes . allPtrs . hgeClosure) (M.elems m)+ roots ++ concatMap (catMaybes . allClosures . hgeClosure) (M.elems m) -- Pulls together multiple Unnamed objects to one simplify :: [VisObject] -> [VisObject]
src/GHC/Vis/View/Graph.hs view
@@ -42,6 +42,7 @@ import Graphics.Rendering.Cairo.SVG import Paths_ghc_vis as My+import Debug.Trace hoverIconWidth :: Double hoverIconWidth = 35@@ -67,21 +68,27 @@ } state :: IORef State+{-# NOINLINE state #-} state = unsafePerformIO $ newIORef $ State [] [] (0, 0, 1, 1) [] [] None Nothing iconEvaluateSVG :: SVG+{-# NOINLINE iconEvaluateSVG #-} iconEvaluateSVG = unsafePerformIO $ My.getDataFileName "data/icon_evaluate.svg" >>= svgNewFromFile iconCollapseSVG :: SVG+{-# NOINLINE iconCollapseSVG #-} iconCollapseSVG = unsafePerformIO $ My.getDataFileName "data/icon_collapse.svg" >>= svgNewFromFile hoverEvaluateSVG :: SVG+{-# NOINLINE hoverEvaluateSVG #-} hoverEvaluateSVG = unsafePerformIO $ My.getDataFileName "data/hover_evaluate.svg" >>= svgNewFromFile hoverCollapseSVG :: SVG+{-# NOINLINE hoverCollapseSVG #-} hoverCollapseSVG = unsafePerformIO $ My.getDataFileName "data/hover_collapse.svg" >>= svgNewFromFile -- | Draw visualization to screen, called on every update or when it's -- requested from outside the program. redraw :: WidgetClass w => w -> Render () redraw canvas = do+ liftIO $ traceIO "redraw" s <- liftIO $ readIORef state rw2 <- liftIO $ Gtk.widgetGetAllocatedWidth canvas rh2 <- liftIO $ Gtk.widgetGetAllocatedHeight canvas@@ -89,6 +96,7 @@ (bbs, hibbs) <- draw s rw2 rh2 liftIO $ modifyIORef state (\s' -> s' {bounds = bbs, hoverIconBounds = hibbs})+ liftIO $ traceIO "redraw End" -- | Export the visualization to an SVG file export :: DrawFunction -> String -> IO ()@@ -103,7 +111,7 @@ return () draw :: State -> Int -> Int -> Render ([(Object Int, Rectangle)], [(Object Int, [(Icon, Rectangle)])])-draw s rw2 rh2 = do+draw s rw2 rh2 = if null $ boxes s then return ([], []) else do vS <- liftIO $ readIORef visState@@ -264,7 +272,9 @@ -- | Something might have changed on the heap, update the view. updateObjects :: [NamedBox] -> IO () updateObjects _boxes = do+ traceIO "updateObjects" hidden <- readMVar visHidden (ops, bs', _ , size) <- xDotParse $ hidden modifyIORef state (\s -> s {operations = ops, boxes = bs', totalSize = size, hover = None})+ traceIO "updateObjects End"
src/GHC/Vis/View/Graph/Parser.hs view
@@ -80,7 +80,7 @@ -- = (map show byteCode, 0) = (["BCO"], length (concatMap F.toList byteCode)) | otherwise- = (showClosureFields (hgeClosure hge), length $ allPtrs (hgeClosure hge))+ = (showClosureFields (hgeClosure hge), length $ allClosures (hgeClosure hge)) -- Adds edges between the closures, treating BCOs specially addEdges = mconcat [@@ -92,7 +92,7 @@ where myPtrs | Just byteCode <- disassembleBCO deref (hgeClosure hge) = concatMap F.toList byteCode | otherwise- = allPtrs (hgeClosure hge)+ = allClosures (hgeClosure hge) -- Adds the nodes and edges for the names addNameList = zip [-1,-2..] $ reverse -- Reverse to display from left to right
src/GHC/Vis/View/List.hs view
@@ -54,9 +54,11 @@ type RGB = (Double, Double, Double) state :: IORef State+{-# NOINLINE state #-} state = unsafePerformIO $ newIORef $ State [] [] Nothing (0, 0, 1, 1) layout' :: IORef (Maybe PangoLayout)+{-# NOINLINE layout' #-} layout' = unsafePerformIO $ newIORef Nothing fontName :: String@@ -172,13 +174,13 @@ s <- readIORef state hm <- inHistoryMode- when (not hm) $ case hover s of- Just t -> do- evaluate t- -- Without forkIO it would hang indefinitely if some action is currently- -- executed- void $ forkIO $ putMVar visSignal UpdateSignal- _ -> return ()+ unless hm $ case hover s of+ Just t -> do+ evaluate t+ -- Without forkIO it would hang indefinitely if some action is currently+ -- executed+ void $ forkIO $ 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@@ -189,14 +191,13 @@ oldS <- readIORef state let oldHover = hover oldS - modifyIORef state $ \s' -> (+ 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