diff --git a/ghc-vis.cabal b/ghc-vis.cabal --- a/ghc-vis.cabal +++ b/ghc-vis.cabal @@ -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" - . - - . - 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 + See for the + basic usage of ghc-vis or watch a short video demonstrating + how it can be used with GHCi's debugger: + tested-with: GHC == 7.4.1, GHC == 7.4.2 data-files: ghci diff --git a/ghci b/ghci --- a/ghci +++ b/ghci @@ -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) } diff --git a/src/GHC/Vis.hs b/src/GHC/Vis.hs --- a/src/GHC/Vis.hs +++ b/src/GHC/Vis.hs @@ -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 diff --git a/src/GHC/Vis/Internal.hs b/src/GHC/Vis/Internal.hs --- a/src/GHC/Vis/Internal.hs +++ b/src/GHC/Vis/Internal.hs @@ -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 = "!#$%&*+./<=>?@ \\^|-~:" diff --git a/src/GHC/Vis/Types.hs b/src/GHC/Vis/Types.hs --- a/src/GHC/Vis/Types.hs +++ b/src/GHC/Vis/Types.hs @@ -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 "") diff --git a/src/GHC/Vis/View/Common.hs b/src/GHC/Vis/View/Common.hs --- a/src/GHC/Vis/View/Common.hs +++ b/src/GHC/Vis/View/Common.hs @@ -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) diff --git a/src/GHC/Vis/View/Graph.hs b/src/GHC/Vis/View/Graph.hs --- a/src/GHC/Vis/View/Graph.hs +++ b/src/GHC/Vis/View/Graph.hs @@ -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 diff --git a/src/GHC/Vis/View/Graph/Parser.hs b/src/GHC/Vis/View/Graph/Parser.hs --- a/src/GHC/Vis/View/Graph/Parser.hs +++ b/src/GHC/Vis/View/Graph/Parser.hs @@ -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) diff --git a/src/GHC/Vis/View/List.hs b/src/GHC/Vis/View/List.hs --- a/src/GHC/Vis/View/List.hs +++ b/src/GHC/Vis/View/List.hs @@ -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