ghc-vis 0.3.2 → 0.4
raw patch · 9 files changed
+297/−216 lines, 9 files
Files
- ghc-vis.cabal +5/−60
- ghci +3/−2
- src/GHC/Vis.hs +30/−7
- src/GHC/Vis/Internal.hs +171/−112
- src/GHC/Vis/Types.hs +22/−7
- src/GHC/Vis/View/Common.hs +7/−2
- src/GHC/Vis/View/Graph.hs +9/−3
- src/GHC/Vis/View/Graph/Parser.hs +0/−2
- src/GHC/Vis/View/List.hs +50/−21
ghc-vis.cabal view
@@ -1,5 +1,5 @@ name: ghc-vis-version: 0.3.2+version: 0.4 license: BSD3 license-file: LICENSE category: GHC, Debug, Development@@ -15,65 +15,10 @@ 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.3.2/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"- .- <http://felsin9.de/nnis/ghc-vis/1.png>- .- 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- .- <http://felsin9.de/nnis/ghc-vis/2.png>- .- 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- .- <http://felsin9.de/nnis/ghc-vis/3.png>- .- 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- .- <http://felsin9.de/nnis/ghc-vis/4.png>- .- Clear the visualization window, this also happens when you- @:load@ or @:reload@ a source file:- .- > > :clear+ See <http://felsin9.de/nnis/ghc-vis/#basic-usage> for the+ basic usage of ghc-vis or watch a short video demonstrating+ how it can be used with GHCi's debugger:+ <http://felsin9.de/nnis/ghc-vis/#combined-debugger> tested-with: GHC == 7.4.1, GHC == 7.4.2 data-files: ghci
ghci view
@@ -15,5 +15,6 @@ -- Keep evaluating and updating on any key pressed, quit with q :def asu \x -> getChar >>= \c -> case c of { 'q' -> return ""; _ -> return $ ":step " ++ x ++ "\n:update\n:asu" } --- Evaluate one step every second until any key is pressed-:def tsu \x -> (System.Timeout.timeout 1000000 getChar) >>= \c -> case c of { Just _ -> return ""; _ -> return $ ":step " ++ x ++ "\n:update\n:tsu" }+-- :tsu t x+-- Evaluate one step of expression x every t seconds until any key is pressed+:def tsu \x -> (System.Timeout.timeout (round $ 1000000 * (read . head $ words x :: Double)) getChar) >>= \c -> case c of { Just _ -> return ""; _ -> return $ ":step " ++ (unwords . tail $ words x) ++ "\n:update\n:tsu " ++ (head $ words x) }
src/GHC/Vis.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, RankNTypes, ImpredicativeTypes #-} {- | Module : GHC.Vis Copyright : (c) Dennis Felsing@@ -44,7 +44,7 @@ ) where -import Prelude hiding (catch)+import Prelude hiding (catch, error) import Graphics.UI.Gtk hiding (Box, Signal) import qualified Graphics.UI.Gtk.Gdk.Events as E@@ -55,6 +55,7 @@ import Control.Exception hiding (evaluate) +import Data.Char import Data.IORef import System.Timeout@@ -72,6 +73,8 @@ import qualified GHC.Vis.View.Graph as Graph #endif +import Graphics.Rendering.Cairo+ views :: [View] views = View List.redraw List.click List.move List.updateObjects List.export :@@ -121,10 +124,27 @@ clear :: IO () clear = put ClearSignal --- | Export the current visualization view to an SVG file.-export :: String -> IO () -- TODO: Work with different file formats (svg, pdf, png)-export filename = put $ ExportSignal filename+-- | Export the current visualization view to a file, format depends on the+-- file ending. Currently supported: svg, png, pdf, ps+export :: String -> IO ()+export filename = case mbDrawFn of+ Right error -> putStrLn error+ Left _ -> put $ ExportSignal ((\(Left x) -> x) mbDrawFn) filename + where mbDrawFn = case map toLower (reverse . take 4 . reverse $ filename) of+ ".svg" -> Left withSVGSurface+ ".pdf" -> Left withPDFSurface+ ".png" -> Left withPNGSurface+ _:".ps" -> Left withPSSurface+ _ -> Right "Unknown file extension, try one of the following: .svg, .pdf, .ps, .png"++ withPNGSurface filePath width height action =+ withImageSurface FormatARGB32 (ceiling width) (ceiling height) $+ \surface -> do+ ret <- action surface+ surfaceWriteToPNG surface filePath+ return ret+ put :: Signal -> IO () put s = void $ timeout signalTimeout $ putMVar visSignal s @@ -184,7 +204,7 @@ if running then react canvas window else -- :r caused visRunning to be reset (do swapMVar visRunning True- putMVar visSignal UpdateSignal+ timeout signalTimeout (putMVar visSignal UpdateSignal) react canvas window) Just signal -> do case signal of@@ -193,13 +213,16 @@ ClearSignal -> modifyMVar_ visBoxes (\_ -> return []) UpdateSignal -> return () SwitchSignal -> doSwitch- ExportSignal f -> catch (runCorrect exportView >>= \e -> e f)+ ExportSignal d f -> catch (runCorrect exportView >>= \e -> e d 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?+ -- Blackholes stop our current thread and only resume after+ -- they have been replaced with their result, thereby leading+ -- to an additional element in the HeapMap we don't want. -- Example for bad behaviour that would happen then: -- λ> let xs = [1..42] :: [Int] -- λ> let x = 17 :: Int
src/GHC/Vis/Internal.hs view
@@ -35,6 +35,11 @@ import System.IO.Unsafe +-- | Maximum depth which walkHeap recurses to. Prevents users from evaluating+-- data structures which are too big and would take very long to visualize.+maxHeapWalkDepth :: Int+maxHeapWalkDepth = 100+ -- | Walk the heap for a list of objects to be visualized and their -- corresponding names. parseBoxes :: [(Box, String)] -> IO [[VisObject]]@@ -42,27 +47,29 @@ r <- generalParseBoxes evalState bs case r of Just x -> return x- _ -> parseBoxes bs+ _ -> do+ putStrLn "Failure, trying again"+ parseBoxes bs -- | 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 :: [(Box, String)] -> IO ([[VisObject]], PState) parseBoxesHeap bs = do r <- generalParseBoxes runState bs case r of (Just x, y) -> return (x,y) _ -> parseBoxesHeap bs -generalParseBoxes :: Num t =>- (PrintState (Maybe [[VisObject]]) -> (t, HeapMap, HeapMap) -> b)+generalParseBoxes ::+ (PrintState (Maybe [[VisObject]]) -> PState -> b) -> [(Box, String)] -> IO b generalParseBoxes f bs = do h <- walkHeapSimply bs h2 <- walkHeapWithBCO bs- return $ f (g bs) (0,h,h2)+ return $ f (g bs) $ PState 0 0 0 h h2 where g bs' = runMaybeT $ go bs'- go ((b',_):b's) = do (_,h,_) <- lift get+ go ((b',_):b's) = do h <- lift $ gets heapMap' (_,c) <- lookupT b' h r <- parseClosure b' c rs <- go b's@@ -105,6 +112,7 @@ insertObjects :: VisObject -> [VisObject] -> [VisObject] insertObjects _ xs@(Function _ : _) = xs+insertObjects _ xs@(Thunk _ : _) = xs insertObjects (Link name) _ = [Link name] insertObjects (Named name _) xs = [Named name xs] insertObjects (Unnamed _) xs = xs@@ -116,7 +124,7 @@ walkHeap :: [(Box, String)] -> IO HeapMap walkHeap = walkHeapGeneral Just pointersToFollow --- walkHeap, but without Top level names+-- | walkHeap, but without Top level names walkHeapSimply :: [(Box, String)] -> IO HeapMap walkHeapSimply = walkHeapGeneral (const Nothing) pointersToFollow @@ -131,22 +139,25 @@ 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+ foldM (step maxHeapWalkDepth p2f) l p+ step depth 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+ if depth == 0 && not (null p)+ then do+ putStrLn "Warning: Maximum data structure depth reached, output is truncated"+ return $ insert (b, (Nothing, maxDepthClosure)) l+ else foldM (step (depth - 1) 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+ (Nothing, ConsClosure (StgInfoTable 0 0 CONSTR 0) (map fst bs) [] "" "" ""))+ maxDepthClosure = ConsClosure (StgInfoTable 0 0 CONSTR 0) [] [] "" "" "..." --- 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.+-- 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 _ _ _ _ _ _ _) = return []+pointersToFollow BCOClosure{} = return [] pointersToFollow (MutArrClosure _ _ _ bPtrs) = do cPtrs <- mapM getBoxedClosureData bPtrs@@ -203,14 +214,29 @@ return $ h1 ++ ((b,f x) : h2) setName :: Box -> MaybeT PrintState ()-setName b = do (i, h, h2) <- lift get- h' <- MaybeT $ return $ adjust (set i) b h- lift $ put (i + 1, h', h2)- where set i (Nothing, closure) = (Just ('t' : show i), closure)- set _ _ = error "unexpected pattern"+setName b = do PState ti fi bi h h2 <- lift get+ (_,c) <- lookupT b h2+ let (n, ti',fi',bi') = case c of+ ThunkClosure{} -> ('t' : show ti, ti+1, fi, bi)+ APClosure{} -> ('t' : show ti, ti+1, fi, bi)+ FunClosure{} -> ('f' : show fi, ti, fi+1, bi)+ PAPClosure{} -> ('f' : show fi, ti, fi+1, bi)+ _ -> ('b' : show bi, ti, fi, bi+1)+ set (Nothing, closure) = (Just n, closure)+ set _ = error "unexpected pattern"+ h' <- MaybeT $ return $ adjust set b h+ h2' <- MaybeT $ return $ adjust set b h2+ lift $ put $ PState ti' fi' bi' h' h2' +setVisited :: Box -> MaybeT PrintState ()+setVisited b = do PState ti fi bi h h2 <- lift get+ let set (Nothing, closure) = (Just "visited", closure)+ set _ = error "unexpected pattern"+ h2' <- MaybeT $ return $ adjust set b h2+ lift $ put $ PState ti fi bi h h2'+ getName :: Box -> MaybeT PrintState (Maybe String)-getName b = do (_,h,_) <- lift get+getName b = do h <- lift $ gets heapMap' (name,_) <- lookupT b h return name @@ -225,12 +251,12 @@ -- How often is a box referenced in the entire heap map countReferences :: Box -> PrintState Int countReferences b = do- (_,_,h) <- get+ h <- gets heapMap' return $ sum $ map countR h where countR (_,(_,c)) = length $ filter (== b) $ allPtrs c parseInternal :: Box -> Closure -> MaybeT PrintState [VisObject]-parseInternal _ (ConsClosure _ _ [dataArg] _pkg modl name) =+parseInternal _ (ConsClosure _ [] [dataArg] _pkg modl name) = return [Unnamed $ case (modl, name) of k | k `elem` [ ("GHC.Word", "W#") , ("GHC.Word", "W8#")@@ -245,54 +271,41 @@ , ("GHC.Int", "I16#") , ("GHC.Int", "I32#") , ("GHC.Int", "I64#")- ] -> name ++ " " ++ (show $ (fromIntegral :: Word -> Int) dataArg)+ ] -> name ++ " " ++ show ((fromIntegral :: Word -> Int) dataArg) ("GHC.Types", "C#") -> show . chr $ fromIntegral dataArg+ --("GHC.Types", "C#") -> '\'' : (chr $ fromIntegral dataArg) : "'" - ("Types", "D#") -> printf "%0.5f" (unsafeCoerce dataArg :: Double)- ("Types", "F#") -> printf "%0.5f" (unsafeCoerce dataArg :: Double)+ ("GHC.Types", "D#") -> printf "D# %0.5f" (unsafeCoerce dataArg :: Double)+ ("GHC.Types", "F#") -> printf "F# %0.5f" (unsafeCoerce dataArg :: Double) - (_,name') -> printf "%s[%d]" name' dataArg+ _ -> printf "%s %d" (infixFix 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 1 3 _ _) _ [_,0,0] _ "Data.ByteString.Internal" "PS")+ = return [Unnamed "ByteString 0 0"] -parseInternal _ (ConsClosure (StgInfoTable 0 0 CONSTR_NOCAF_STATIC _) [] [] _ _ name)- = return [Unnamed name]+parseInternal _ (ConsClosure (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 0 _ CONSTR_NOCAF_STATIC _) [] args _ _ name)- = return [Unnamed (name ++ " " ++ show args)]+parseInternal _ (ConsClosure (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 _ 1) [bHead,bTail] [] _ "GHC.Types" ":")+parseInternal _ (ConsClosure (StgInfoTable 2 0 _ _) [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 _ bPtrs dArgs _ _ name) = do cPtrs <- mapM (liftM mbParens . contParse) bPtrs let tPtrs = intercalate [Unnamed " "] cPtrs- return $ Unnamed (name ++ show dArgs ++ " ") : tPtrs+ let sPtrs = if null tPtrs then [Unnamed ""] else Unnamed " " : tPtrs+ return $ Unnamed (unwords $ infixFix name : map show dArgs) : sPtrs parseInternal _ (ArrWordsClosure _ _ arrWords) = return $ intercalate [Unnamed ","] (map (\x -> [Unnamed (printf "0x%x" x)]) arrWords)@@ -316,26 +329,37 @@ = return [Unnamed $ show cTipe] -- Reversed order of ptrs-parseInternal b (ThunkClosure _ bPtrs args)- = parseThunkFun b bPtrs args+parseInternal b (ThunkClosure _ bPtrs args) = do+ name <- getSetName b+ cPtrs <- mapM contParse $ reverse bPtrs+ let tPtrs = intercalate [Unnamed ","] cPtrs+ sPtrs = if null tPtrs then [Unnamed ""] else Unnamed "(" : tPtrs ++ [Unnamed ")"]+ sArgs = Unnamed $ if null args then "" else show args+ return $ Thunk (infixFix name) : sPtrs ++ [sArgs] -parseInternal b (FunClosure _ bPtrs args)- = parseThunkFun b bPtrs args+parseInternal b (FunClosure _ bPtrs args) = do+ name <- getSetName b+ cPtrs <- mapM contParse $ reverse bPtrs+ let tPtrs = intercalate [Unnamed ","] cPtrs+ sPtrs = if null tPtrs then [Unnamed ""] else Unnamed "(" : tPtrs ++ [Unnamed ")"]+ sArgs = Unnamed $ if null args then "" else show args+ return $ Function (infixFix name) : sPtrs ++ [sArgs] -- bPtrs here can currently point to Nothing, because else we might get infinite heaps parseInternal _ (MutArrClosure _ _ _ bPtrs) = do cPtrs <- mutArrContParse bPtrs let tPtrs = intercalate [Unnamed ","] cPtrs- return $ Unnamed "(" : tPtrs ++ [Unnamed ")"]+ return $ if null tPtrs then [Unnamed ""] else Unnamed "(" : tPtrs ++ [Unnamed ")"] parseInternal _ (MutVarClosure _ b) = do c <- contParse b return $ Unnamed "MutVar " : c -parseInternal _ (BCOClosure _ _ _ bPtr _ _ _)+parseInternal b (BCOClosure _ _ _ bPtr _ _ _) = do cPtrs <- bcoContParse [bPtr] let tPtrs = intercalate [Unnamed ","] cPtrs- return $ Unnamed "(" : tPtrs ++ [Unnamed ")"]+ r <- lift $ countReferences b+ return $ if null tPtrs then if r > 1 then [Unnamed "BCO"] else [Unnamed ""] else (if r > 1 then Unnamed "BCO(" else Unnamed "(") : tPtrs ++ [Unnamed ")"] -- = do case lookup b h of -- Nothing -> c <- getBoxedClosureData bPtr -- Just (_,c) -> p <- parseClosure bPtr c@@ -352,57 +376,66 @@ -- notHasName _ _ = True -- return vs -parseInternal b (APClosure _ _ _ fun pl)- = parseAPPAP b fun pl+parseInternal b (APClosure _ _ _ fun pl) = do+ name <- getSetName b+ fPtr <- contParse fun+ pPtrs <- mapM contParse $ reverse pl+ let tPtrs = intercalate [Unnamed ","] pPtrs+ sPtrs = if null tPtrs then [Unnamed ""] else Unnamed "[" : tPtrs ++ [Unnamed "]"]+ return $ Thunk (infixFix name) : fPtr ++ sPtrs -parseInternal b (PAPClosure _ _ _ fun pl)- = parseAPPAP b fun pl+parseInternal b (PAPClosure _ _ _ fun pl) = do+ name <- getSetName b+ fPtr <- contParse fun+ pPtrs <- mapM contParse $ reverse pl+ let tPtrs = intercalate [Unnamed ","] pPtrs+ sPtrs = if null tPtrs then [Unnamed ""] else Unnamed "[" : tPtrs ++ [Unnamed "]"]+ return $ Function (infixFix name) : fPtr ++ sPtrs +--parseInternal b (APStackClosure _ fun pl) = do+-- name <- getSetName b+-- fPtr <- contParse fun+-- pPtrs <- mapM contParse $ reverse pl+-- let tPtrs = intercalate [Unnamed ","] pPtrs+-- sPtrs = if null tPtrs then [Unnamed ""] else Unnamed "[" : tPtrs ++ [Unnamed "]"]+-- return $ Thunk (infixFix name) : fPtr ++ sPtrs+ parseInternal _ (MVarClosure _ 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)]---- λ> data BinaryTree = BT BinaryTree Int BinaryTree | Leaf deriving Show--- λ> let x = BT (BT (BT Leaf 1 (BT Leaf 2 Leaf)) 3 (BT (BT Leaf 4 (BT Leaf 5 Leaf)) 6 Leaf))--- λ> :view x (in list view)-parseAPPAP :: Box -> Box -> [Box] -> MaybeT PrintState [VisObject]-parseAPPAP b fun pl = do- name <- getSetName b- fPtr <- contParse fun- pPtrs <- mapM contParse $ reverse pl- let tPtrs = intercalate [Unnamed ","] pPtrs- return $ Function name : fPtr ++ [Unnamed "["] ++ tPtrs ++ [Unnamed "]"]--parseThunkFun :: Box -> [Box] -> [Word] -> MaybeT 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 -> MaybeT PrintState [VisObject]-contParse b = do (_,h,_) <- lift get+contParse b = do h <- lift $ gets heapMap (_,c) <- lookupT b h parseClosure b c +-- It turned out that bcoContParse actually does go into an infinite loop, for+-- example for this:+-- foldr' op i [] = i+-- foldr' op i (x:xs) = op x (foldr' op i xs)+-- :view foldr'+-- We fix this by giving visited closures a dummy name, so we recognize when we+-- get into a loop. bcoContParse :: [Box] -> MaybeT PrintState [[VisObject]] bcoContParse [] = return []-bcoContParse (b:bs) = get >>= \(_,h,_) -> case lookup b h of+bcoContParse (b:bs) = gets heapMap >>= \h -> case lookup b h of Nothing -> do let ptf = unsafePerformIO $ getBoxedClosureData b >>= pointersToFollow2- bcoContParse $ ptf ++ bs -- Could go into infinite loop+ r <- lift $ countReferences b+ n <- getName b+ case n of+ Just _ -> bcoContParse bs+ Nothing -> do+ when (r > 1) $ setVisited b+ bcoContParse $ ptf ++ bs Just (_,c) -> do p <- parseClosure b c ps <- bcoContParse bs return $ p : ps mutArrContParse :: [Box] -> MaybeT PrintState [[VisObject]] mutArrContParse [] = return []-mutArrContParse (b:bs) = get >>= \(_,h,_) -> case lookup b h of+mutArrContParse (b:bs) = gets heapMap >>= \h -> case lookup b h of Nothing -> mutArrContParse bs Just (_,c) -> do p <- parseClosure b c ps <- mutArrContParse bs@@ -410,14 +443,23 @@ -- 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+mbParens t = if needsParens+ then Unnamed "(" : t ++ [Unnamed ")"]+ else t+ where needsParens = go (0 :: Int) $ show t+ go 0 (' ':_) = True+ go _ [] = False+ go c (')':ts) = go (c-1) ts+ go c ('(':ts) = go (c+1) ts+ go c ('\'':'(':ts) = go c ts+ go c ('\'':')':ts) = go c ts+ go c (_:ts) = go c ts+--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@@ -436,35 +478,30 @@ , ("GHC.Int", "I16#") , ("GHC.Int", "I32#") , ("GHC.Int", "I64#")- ] -> name ++ " " ++ (show $ (fromIntegral :: Word -> Int) dataArg)+ ] -> name ++ " " ++ 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)+ ("GHC.Types", "D#") -> printf "D# %0.5f" (unsafeCoerce dataArg :: Double)+ ("GHC.Types", "F#") -> printf "F# %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+ _ -> printf "%s %d" name dataArg showClosure (ConsClosure (StgInfoTable 1 3 _ 0) _ [_,0,0] _ "Data.ByteString.Internal" "PS")- = "ByteString[0,0]"+ = "ByteString 0 0" showClosure (ConsClosure (StgInfoTable 1 3 _ 0) [_] [_,start,end] _ "Data.ByteString.Internal" "PS")- = printf "ByteString[%d,%d]" start end+ = 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 _ _ [] _ _ name)- = name+ = printf "Chunk %d %d" start end showClosure (ConsClosure _ _ dArgs _ _ name)- = name ++ show dArgs+ = unwords $ name : map show dArgs -- Reversed order of ptrs showClosure ThunkClosure{}@@ -486,6 +523,9 @@ showClosure PAPClosure{} = "PAP" +--showClosure APStackClosure{}+-- = "APStack"+ showClosure BCOClosure{} = "BCO" @@ -514,3 +554,22 @@ = show cTipe --showClosure c = "Missing pattern for " ++ show c++-- | Make infix names prefix+infixFix :: String -> String+infixFix xs+ | isInfix xs = '(' : xs ++ ")"+ | otherwise = xs++-- | Determine whether a name is an infix name, based on+-- http://www.haskell.org/onlinereport/haskell2010/haskellch2.html+isInfix :: String -> Bool+isInfix [] = False+isInfix ('[':_) = False+isInfix ('(':_) = False+isInfix (x:_)+ | x `elem` ascSymbols = True+ | isSymbol x = True+ | isPunctuation x = True+ | otherwise = False+ where ascSymbols = "!#$%&*+./<=>?@ \\^|-~:"
src/GHC/Vis/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {- | Module : GHC.Vis.Types Copyright : (c) Dennis Felsing@@ -7,12 +7,14 @@ -} module GHC.Vis.Types (+ DrawFunction, Signal(..), View(..), ViewType(..), State(..), HeapEntry, HeapMap,+ PState(..), PrintState, VisObject(..) )@@ -23,15 +25,19 @@ import qualified Control.Monad.State as MS import Graphics.UI.Gtk hiding (Box, Signal, Point)+import Graphics.Rendering.Cairo type Point = (Double, Double) +-- | A function to draw a cairo drawing to a file.+type DrawFunction = forall a. FilePath -> Double -> Double -> (Surface -> IO a) -> IO a+ -- | 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+ | ExportSignal DrawFunction String -- ^ Export the view to a file -- | All functions a view has to provide data View = View@@ -39,7 +45,7 @@ , click :: IO () , move :: WidgetClass w => w -> IO () , updateObjects :: [(Box, String)] -> IO ()- , exportView :: String -> IO ()+ , exportView :: DrawFunction -> String -> IO () } -- | Visualization views@@ -59,25 +65,34 @@ , 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)+data PState = PState+ { tCounter :: Integer+ , fCounter :: Integer+ , bCounter :: Integer+ , heapMap :: HeapMap+ , heapMap' :: HeapMap+ } +type PrintState = MS.State PState+ -- | Simple representation of objects on the heap, so they can be arranged linearly data VisObject = Unnamed String | Named String [VisObject] | Link String+ | Thunk String | Function String deriving Eq instance Show VisObject where- show (Unnamed x) = x+ show (Unnamed x) = x show (Named x ys) = x ++ "=(" ++ show ys ++ ")"- show (Link x) = x+ show (Link x) = x+ show (Thunk x) = x show (Function x) = x showList = foldr ((.) . showString . show) (showString "")
src/GHC/Vis/View/Common.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {- | Module : GHC.Vis.View.Common Copyright : (c) Dennis Felsing@@ -14,8 +15,11 @@ ) where +import Prelude hiding (catch)+ import Control.Concurrent import Control.DeepSeq+import Control.Exception hiding (evaluate) import Data.IORef @@ -44,7 +48,8 @@ -- | Evaluate an object identified by a String. evaluate :: String -> IO () evaluate identifier = do (_,hm) <- printAll- show (map go hm) `deepseq` return ()+ (show (map go hm) `deepseq` return ()) `catch`+ \(e :: SomeException) -> putStrLn $ "Caught exception while evaluating: " ++ show e where go (Box a,(Just n, y)) | n == identifier = seq a (Just n, y) | otherwise = (Just n, y) go (_,(x,y)) = (x,y)@@ -61,5 +66,5 @@ printAll :: IO (String, HeapMap) printAll = do bs <- readMVar visBoxes- (t,(_,h,_)) <- parseBoxesHeap bs+ (t, PState{heapMap = h}) <- parseBoxesHeap bs return (show t, h)
src/GHC/Vis/View/Graph.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} {- | Module : GHC.Vis.View.Graph Copyright : (c) Dennis Felsing@@ -14,12 +15,15 @@ ) where +import Prelude hiding (catch)+ import Graphics.UI.Gtk hiding (Box, Signal, Rectangle, Object) import qualified Graphics.UI.Gtk as Gtk import Graphics.Rendering.Cairo import Control.Concurrent import Control.Monad+import Control.Exception import Data.IORef import System.IO.Unsafe@@ -56,13 +60,13 @@ modifyIORef state (\s' -> s' {bounds = boundingBoxes}) -- | Export the visualization to an SVG file-export :: String -> IO ()-export file = do+export :: DrawFunction -> String -> IO ()+export drawFn file = do s <- readIORef state let (_, _, xSize, ySize) = totalSize s - withSVGSurface file xSize ySize+ drawFn file xSize ySize (\surface -> renderWith surface (draw s (round xSize) (round ySize))) return ()@@ -132,6 +136,8 @@ APClosure{} -> a `seq` return () PAPClosure{} -> a `seq` return () _ -> return ()+ `catch`+ \(e :: SomeException) -> putStrLn $ "Caught exception while evaluating: " ++ show e -- | Handle a mouse move. Causes an 'UpdateSignal' if the mouse is hovering a -- different object now, so the object gets highlighted and the screen
src/GHC/Vis/View/Graph/Parser.hs view
@@ -90,8 +90,6 @@ bcoChildren :: [Box] -> IO [Int] bcoChildren [] = return [] bcoChildren (b:bs) = case boxPos b of- --Nothing -> let ptf = unsafePerformIO $ getBoxedClosureData b >>= pointersToFollow2- -- in bcoChildren (ptf ++ bs) h -- Could go into infinite loop Nothing -> do c <- getBoxedClosureData b ptf <- pointersToFollow2 c bcoChildren (ptf ++ bs)
src/GHC/Vis/View/List.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} {- | Module : GHC.Vis.View.List Copyright : (c) Dennis Felsing@@ -42,6 +43,9 @@ state :: IORef State state = unsafePerformIO $ newIORef $ State [] [] Nothing +layout' :: IORef (Maybe PangoLayout)+layout' = unsafePerformIO $ newIORef Nothing+ fontName :: String fontName = "Sans" --fontName = "Times Roman"@@ -63,11 +67,17 @@ colorLinkHighlighted :: RGB colorLinkHighlighted = (0.25,0.25,1) +colorThunk :: RGB+colorThunk = (1,0.5,0.5)++colorThunkHighlighted :: RGB+colorThunkHighlighted = (1,0,0)+ colorFunction :: RGB-colorFunction = (1,0.5,0.5)+colorFunction = (1,1,0.5) colorFunctionHighlighted :: RGB-colorFunctionHighlighted = (1,0,0)+colorFunctionHighlighted = (1,1,0) padding :: Double padding = 5@@ -83,11 +93,11 @@ modifyIORef state (\s' -> s' {bounds = boundingBoxes}) -- | Export the visualization to an SVG file-export :: String -> IO ()-export file = do+export :: DrawFunction -> String -> IO ()+export drawFn file = do s <- readIORef state - withSVGSurface file (fromIntegral xSize) (fromIntegral ySize)+ drawFn file (fromIntegral xSize) (fromIntegral ySize) (\surface -> renderWith surface (draw s xSize ySize)) return ()@@ -102,13 +112,14 @@ --boxes = map (\(x,_,_) -> x) os names = map ((++ ": ") . (\(_,x,_) -> x)) os + layout <- pangoEmptyLayout+ liftIO $ writeIORef layout' $ Just layout+ 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- -- TODO: This doesn't work for small font sizes- let rw = 0.9 * fromIntegral rw2+ let rw = 0.98 * fromIntegral rw2 rh = fromIntegral rh2 maxNameWidth = maximum nameWidths@@ -122,19 +133,8 @@ ox = 0 oy = 0 - translate ox oy scale sx sy - --nameWidths <- mapM (width . Unnamed) names- --widths <- mapM (mapM width) objs- --let maxNameWidth = maximum nameWidths- -- widths2 = 1 : map (\ws -> maxNameWidth + sum ws) widths- -- sw2 = maximum widths2- --scale (0.9 * rw / (sw2 * sx)) (0.9 * rw / (sw2 * sx))- --liftIO $ putStrLn $ show rw2- --liftIO $ putStrLn $ show $ sw2 * sx- --liftIO $ putStrLn "--"- let rpos = scanl (\a b -> a + b + 30) 30 pos result <- mapM (drawEntry s maxNameWidth) (zip3 objs rpos names) @@ -213,6 +213,9 @@ return [] +drawBox s o@(Thunk target) =+ drawFunctionLink s o target colorThunk colorThunkHighlighted+ drawBox s o@(Function target) = drawFunctionLink s o target colorFunction colorFunctionHighlighted @@ -260,7 +263,16 @@ pangoLayout :: String -> Render (PangoLayout, FontMetrics) pangoLayout text = do- layout <- createLayout text+ --layout <- createLayout text+ mbLayout <- liftIO $ readIORef layout'+ layout'' <- case mbLayout of+ Just layout''' -> return layout'''+ Nothing -> do layout''' <- pangoEmptyLayout+ liftIO $ writeIORef layout' $ Just layout'''+ return layout'''++ layout <- liftIO $ layoutCopy layout''+ liftIO $ layoutSetText layout text context <- liftIO $ layoutGetContext layout --fo <- liftIO $ cairoContextGetFontOptions context@@ -283,13 +295,27 @@ -- alternative font when the selected one is not available font <- liftIO $ fontDescriptionFromString fontName liftIO $ fontDescriptionSetSize font fontSize- liftIO $ layoutSetFontDescription layout (Just font)+ --liftIO $ layoutSetFontDescription layout (Just font) language <- liftIO $ contextGetLanguage context metrics <- liftIO $ contextGetMetrics context font language return (layout, metrics) +pangoEmptyLayout :: Render PangoLayout+pangoEmptyLayout = do+ layout <- createLayout ""++ liftIO $ do+ font <- fontDescriptionFromString fontName+ fontDescriptionSetSize font fontSize+ layoutSetFontDescription layout (Just font)++ return layout++ --font <- fontDescriptionFromString fontName+ --cairoCreateContext Nothing+ drawFunctionLink :: State -> VisObject -> String -> RGB -> RGB -> Render [(String, Rectangle)] drawFunctionLink s o target color1 color2 = do (x,_) <- getCurrentPoint@@ -354,6 +380,7 @@ let go (Named _ ys) = (ya + 15) + maximum (map go ys) go (Unnamed _) = ya go (Link _) = ya + 2 * padding+ go (Thunk _) = ya + 2 * padding go (Function _) = ya + 2 * padding return $ maximum $ map go xs @@ -366,6 +393,8 @@ width (Unnamed x) = simpleWidth x padding width (Link x) = simpleWidth x $ 2 * padding++width (Thunk x) = simpleWidth x $ 2 * padding width (Function x) = simpleWidth x $ 2 * padding