From 8bc615fdb45b8e3f2f3ef2167bbb379bf619aab2 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Dec 2006 23:15:51 +0000 Subject: [PATCH] Dynamic breakpoints in GHCi This patch adds dynamic breakpoints to GHCi There is a new ':breakpoint' command to manage breakpoints. GHCi simply uses the breakpoint api functions in ghc-api to install itself as a client. The mechanism used by GHCi to keep track of enabled breakpoints is a simple table. When a breakpoint is hit, a new interactive session is launched and the bindings in the breakpoint are injected. Some commands are disabled in this sub session --- compiler/ghci/Debugger.hs | 307 ++++++++++++++++++++++++++++++++++++++++ compiler/ghci/Debugger.hs-boot | 12 ++ compiler/ghci/GhciMonad.hs | 39 ++++- compiler/ghci/InteractiveUI.hs | 240 ++++++++++++++++++------------- 4 files changed, 500 insertions(+), 98 deletions(-) create mode 100644 compiler/ghci/Debugger.hs create mode 100644 compiler/ghci/Debugger.hs-boot diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs new file mode 100644 index 0000000..fdab651 --- /dev/null +++ b/compiler/ghci/Debugger.hs @@ -0,0 +1,307 @@ +----------------------------------------------------------------------------- +-- +-- GHCi Interactive debugging commands +-- +-- Pepe Iborra (supported by Google SoC) 2006 +-- +----------------------------------------------------------------------------- + +module Debugger where + +import Linker +import Breakpoints +import RtClosureInspect + +import PrelNames +import HscTypes +import IdInfo +--import Id +import Var hiding ( varName ) +import VarSet +import VarEnv +import Name +import NameEnv +import RdrName +import Module +import Finder +import UniqSupply +import Type +import TyCon +import DataCon +import TcGadt +import GHC +import GhciMonad +import PackageConfig + +import Outputable +import ErrUtils +import FastString +import SrcLoc +import Util + +import Control.Exception +import Control.Monad +import qualified Data.Map as Map +import Data.Array.Unboxed +import Data.Traversable ( traverse ) +import Data.Typeable ( Typeable ) +import Data.Maybe +import Data.IORef + +import System.IO +import GHC.Exts + +#include "HsVersions.h" + +----------------------------- +-- | The :breakpoint command +----------------------------- +bkptOptions :: String -> GHCi () +bkptOptions cmd = do + dflags <- getDynFlags + bt <- getBkptTable + bkptOptions' (words cmd) bt + where + bkptOptions' ["list"] bt = do + let msgs = [ ppr mod <+> colon <+> ppr coords + | (mod,site) <- btList bt + , let coords = getSiteCoords bt mod site] + num_msgs = [parens (int n) <+> msg | (n,msg) <- zip [1..] msgs] + msg <- showForUser$ if null num_msgs + then text "There are no enabled breakpoints" + else vcat num_msgs + io$ putStrLn msg + + bkptOptions' ["stop"] bt = do + inside_break <- liftM not isTopLevel + when inside_break $ throwDyn StopChildSession + + bkptOptions' ("add":cmds) bt + | [mod_name,line]<- cmds + , [(lineNum,[])] <- reads line + = handleAdd mod_name $ (\mod->addBkptByLine mod lineNum) + + | [mod_name,line,col] <- cmds + = handleAdd mod_name $ (\mod->addBkptByCoord mod (read line, read col)) + + | otherwise = throwDyn $ CmdLineError $ + "syntax: :breakpoint add Module line [col]" + where + handleAdd mod_name f = do + sess <- getSession + dflags <- getDynFlags + mod <- io$ GHC.findModule sess (GHC.mkModuleName mod_name) Nothing + ghciHandleDyn (handleBkptEx mod) $ + case f mod bt of + (newTable, site) -> do + setBkptTable newTable + io (putStrLn ("Breakpoint set at " ++ + show (getSiteCoords newTable mod site))) + + bkptOptions' ("del":cmds) bt + | [i'] <- cmds + , [(i,[])] <- reads i' + , bkpts <- btList bt + = if i > length bkpts + then throwDyn $ CmdLineError + "Not a valid breakpoint #. Use :breakpoint list to see the current breakpoints." + else + let (mod, site) = bkpts !! (i-1) + in handleDel mod $ delBkptBySite mod site + + | [fn,line] <- cmds + , [(lineNum,[])] <- reads line + , mod <- GHC.mkModule mainPackageId (GHC.mkModuleName fn) + = handleDel mod $ delBkptByLine mod lineNum + + | [fn,line,col] <- cmds + , [(lineNum,[])] <- reads line + , [(colNum,[])] <- reads col + , mod <- GHC.mkModule mainPackageId (GHC.mkModuleName fn) + = handleDel mod $ delBkptByCoord mod (lineNum, colNum) + + | otherwise = throwDyn $ CmdLineError $ + "syntax: :breakpoint del (breakpoint # | Module line [col])" + + where delMsg = "Breakpoint deleted" + handleDel mod f = ghciHandleDyn (handleBkptEx mod) $ do + modifyBkptTable f + newTable <- getBkptTable + sess <- getSession + dflags <- getDynFlags + io$ putStrLn delMsg + + bkptOptions' _ _ = throwDyn $ CmdLineError $ + "syntax: :breakpoint (list|stop|add|del)" + + handleBkptEx :: Module -> Debugger.BkptException -> a + handleBkptEx _ NoBkptFound = error "No suitable breakpoint site found" --TODO Automatically add to the next suitable line + handleBkptEx _ NotNeeded = error "Nothing to do" + handleBkptEx m NotHandled = error$ "Module " ++ showSDoc (ppr m) ++ " was not loaded under debugging mode. Enable debugging mode and reload it" + +------------------------- +-- Breakpoint Tables +------------------------- + +data BkptTable a = BkptTable { + -- | An array of breaks, indexed by site number + breakpoints :: Map.Map a (UArray Int Bool) + -- | A list of lines, each line can have zero or more sites, which are annotated with a column number + , sites :: Map.Map a [[(SiteNumber, Int)]] + } + +sitesOf :: Ord a => BkptTable a -> a -> Maybe [[(SiteNumber, Int)]] +sitesOf bt fn = Map.lookup fn (sites bt) +bkptsOf bt fn = Map.lookup fn (breakpoints bt) + + +-- The functions for manipulating BkptTables do throw exceptions +data BkptException = + NotHandled + | NoBkptFound + | NotNeeded -- Used when a breakpoint was already enabled + deriving Typeable + +emptyBkptTable :: Ord a => BkptTable a +addModule :: Ord a => a -> [(SiteNumber,Coord)] -> BkptTable a -> BkptTable a +-- | Lines start at index 1 +addBkptByLine :: Ord a => a -> Int -> BkptTable a -> (BkptTable a, SiteNumber) +addBkptByCoord :: Ord a => a -> Coord -> BkptTable a -> (BkptTable a, SiteNumber) +delBkptByLine :: Ord a => a -> Int -> BkptTable a -> BkptTable a +delBkptBySite :: Ord a => a -> SiteNumber -> BkptTable a -> BkptTable a +delBkptByCoord :: Ord a => a -> Coord -> BkptTable a -> BkptTable a + +isBkptEnabled :: Ord a => BkptTable a -> BkptLocation a -> Bool +btElems :: Ord a => BkptTable a -> [(a, [SiteNumber])] +btList :: Ord a => BkptTable a -> [BkptLocation a] +sitesList :: Ord a => BkptTable a -> [(a, [Coord])] +getSiteCoords :: Ord a => BkptTable a -> a -> SiteNumber -> Coord + +emptyBkptTable = BkptTable Map.empty Map.empty + +addBkptByLine a i bt + | Just lines <- sitesOf bt a + , Just bkptsArr <- bkptsOf bt a + , i < length lines + = case lines!!i of + [] -> throwDyn NoBkptFound + (x:_) -> let (siteNum,col) = x + wasAlreadyOn = bkptsArr ! siteNum + newArr = bkptsArr // [(siteNum, True)] + newTable = Map.insert a newArr (breakpoints bt) + in if wasAlreadyOn + then throwDyn NotNeeded + else (bt{breakpoints=newTable}, siteNum) + + | Just sites <- sitesOf bt a + = throwDyn NoBkptFound + | otherwise = throwDyn NotHandled + +addBkptByCoord a (r,c) bt + | Just lines <- sitesOf bt a + , Just bkptsArr <- bkptsOf bt a + , r < length lines + = case [ (sn,col) | (sn,col)<-lines!!r, col>=c] of + [] -> throwDyn NoBkptFound + (x:_) -> let (siteNum, col) = x + wasAlreadyOn = bkptsArr ! siteNum + newArr = bkptsArr // [(siteNum, True)] + newTable = Map.insert a newArr (breakpoints bt) + in if wasAlreadyOn + then throwDyn NotNeeded + else (bt{breakpoints=newTable}, siteNum) + + | Just sites <- sitesOf bt a + = throwDyn NoBkptFound + | otherwise = throwDyn NotHandled + +delBkptBySite a i bt + | Just bkptsArr <- bkptsOf bt a + , not (inRange (bounds bkptsArr) i) + = throwDyn NoBkptFound + + | Just bkptsArr <- bkptsOf bt a + , bkptsArr ! i -- Check that there was a enabled bkpt here + , newArr <- bkptsArr // [(i,False)] + , newTable <- Map.insert a newArr (breakpoints bt) + = bt {breakpoints=newTable} + + | Just sites <- sitesOf bt a + = throwDyn NotNeeded + + | otherwise = throwDyn NotHandled + +delBkptByLine a l bt + | Just sites <- sitesOf bt a + , (site:_) <- [s | (s,c') <- sites !! l] + = delBkptBySite a site bt + + | Just sites <- sitesOf bt a + = throwDyn NoBkptFound + + | otherwise = throwDyn NotHandled + +delBkptByCoord a (r,c) bt + | Just sites <- sitesOf bt a + , (site:_) <- [s | (s,c') <- sites !! r, c>=c', isBkptEnabled bt (a,s)] + = delBkptBySite a site bt + + | Just sites <- sitesOf bt a + = throwDyn NoBkptFound + + | otherwise = throwDyn NotHandled + +btElems bt = [ (a, [i | (i,True) <- assocs siteArr]) + | (a, siteArr) <- Map.assocs (breakpoints bt) ] + +btList bt = [(a,site) | (a, sites) <- btElems bt, site <- sites] + +sitesList bt = [ (a, sitesCoords sitesCols) | (a, sitesCols) <- Map.assocs (sites bt) ] + where sitesCoords sitesCols = + [ (row,col) + | (row, cols) <- zip [0..] sitesCols, (_,col) <- cols ] + +getSiteCoords bt a site + | Just rows <- sitesOf bt a + = head [ (r,c) | (r,row) <- zip [0..] rows + , (s,c) <- row + , s == site ] + +-- addModule is dumb and inefficient, but it does the job +--addModule fn siteCoords _ | trace ("addModule: " ++ moduleString (unsafeCoerce# fn) ++ " - " ++ show siteCoords) False = undefined +addModule a [] bt = bt +addModule a siteCoords bt + | nrows <- maximum$ [i | (_,(i,j)) <- siteCoords ] + , sitesByRow <- [ [(s,c) | (s,(r,c)) <- siteCoords, r==i] + | i <- [0..nrows] ] + , nsites <- length siteCoords + , initialBkpts <- listArray (1, nsites) (repeat False) + = bt{ sites = Map.insert a sitesByRow (sites bt) + , breakpoints = Map.insert a initialBkpts (breakpoints bt) } + +isBkptEnabled bt (a,site) + | Just bkpts <- bkptsOf bt a + , inRange (bounds bkpts) site + = bkpts ! site + | otherwise = throwDyn NotHandled -- This is an error + +----------------- +-- Other stuff +----------------- +refreshBkptTable :: [ModSummary] -> GHCi () +refreshBkptTable [] = return () +refreshBkptTable (ms:mod_sums) = do + sess <- getSession + when (Opt_Debugging `elem` flags (GHC.ms_hspp_opts ms)) $ do + old_table <- getBkptTable + new_table <- addModuleGHC sess old_table (GHC.ms_mod ms) + setBkptTable new_table + refreshBkptTable mod_sums + where addModuleGHC sess bt mod = do + Just mod_info <- io$ GHC.getModuleInfo sess mod + dflags <- getDynFlags + let sites = GHC.modInfoBkptSites mod_info + io$ debugTraceMsg dflags 2 + (ppr mod <> text ": inserted " <> int (length sites) <> + text " breakpoints") + return$ addModule mod sites bt diff --git a/compiler/ghci/Debugger.hs-boot b/compiler/ghci/Debugger.hs-boot new file mode 100644 index 0000000..d310308 --- /dev/null +++ b/compiler/ghci/Debugger.hs-boot @@ -0,0 +1,12 @@ +module Debugger where +import Breakpoints +import qualified Data.Map as Map +import Data.Array.Unboxed + + +data BkptTable a = BkptTable { + -- | An array of breaks, indexed by site number + breakpoints :: Map.Map a (UArray Int Bool) + -- | A list of lines, each line can have zero or more sites, which are annotated with a column number + , sites :: Map.Map a [[(SiteNumber, Int)]] + } diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index cf578a7..04c5ffa 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -32,7 +32,9 @@ data GHCiState = GHCiState editor :: String, session :: GHC.Session, options :: [GHCiOption], - prelude :: GHC.Module + prelude :: GHC.Module, + bkptTable :: IORef (BkptTable GHC.Module), + topLevel :: Bool } data GHCiOption @@ -92,6 +94,24 @@ unsetOption opt io :: IO a -> GHCi a io m = GHCi { unGHCi = \s -> m >>= return } +isTopLevel :: GHCi Bool +isTopLevel = getGHCiState >>= return . topLevel + +getBkptTable :: GHCi (BkptTable GHC.Module) +getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable + io$ readIORef table_ref + +setBkptTable :: BkptTable GHC.Module -> GHCi () +setBkptTable new_table = do + table_ref <- getGHCiState >>= return . bkptTable + io$ writeIORef table_ref new_table + +modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi () +modifyBkptTable f = do + bt <- getBkptTable + new_bt <- io . evaluate$ f bt + setBkptTable new_bt + showForUser :: SDoc -> GHCi String showForUser doc = do session <- getSession @@ -101,6 +121,11 @@ showForUser doc = do ----------------------------------------------------------------------------- -- User code exception handling +-- This hierarchy of exceptions is used to signal interruption of a child session +data BkptException = StopChildSession -- A child debugging session requests to be stopped + | ChildSessionStopped String + deriving Typeable + -- This is the exception handler for exceptions generated by the -- user's code and exceptions coming from children sessions; -- it normally just prints out the exception. The @@ -111,6 +136,18 @@ showForUser doc = do -- raising another exception. We therefore don't put the recursive -- handler arond the flushing operation, so if stderr is closed -- GHCi will just die gracefully rather than going into an infinite loop. +handler :: Exception -> GHCi Bool +handler (DynException dyn) + | Just StopChildSession <- fromDynamic dyn + -- propagate to the parent session + = ASSERTM (liftM not isTopLevel) >> throwDyn StopChildSession + + | Just (ChildSessionStopped msg) <- fromDynamic dyn + -- Revert CAFs and display some message + = ASSERTM (isTopLevel) >> + io (revertCAFs >> putStrLn msg) >> + return False + handler exception = do flushInterpBuffers io installSignalHandlers diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index e7a5a37..298d697 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -13,19 +13,7 @@ module InteractiveUI ( #include "HsVersions.h" -#if defined(GHCI) && defined(BREAKPOINT) -import GHC.Exts ( Int(..), Ptr(..), int2Addr# ) -import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr ) -import System.IO.Unsafe ( unsafePerformIO ) -import Var -import HscTypes -import RdrName -import NameEnv -import TcType -import qualified Id -import IdInfo -import PrelNames -#endif +import GhciMonad -- The GHC interface import qualified GHC @@ -45,13 +33,26 @@ import SrcLoc -- Other random utilities import Digraph -import BasicTypes -import Panic hiding (showException) +import BasicTypes hiding (isTopLevel) +import Panic hiding (showException) import Config import StaticFlags import Linker import Util +-- The debugger +import Breakpoints +import Debugger hiding ( addModule ) +import HscTypes +import Id +import Var ( globaliseId ) +import IdInfo +import NameEnv +import RdrName +import Module +import Type +import TcType + #ifndef mingw32_HOST_OS import System.Posix #if __GLASGOW_HASKELL__ > 504 @@ -110,9 +111,9 @@ GLOBAL_VAR(commands, builtin_commands, [Command]) builtin_commands :: [Command] builtin_commands = [ - ("add", keepGoingPaths addModule, False, completeFilename), + ("add", tlC$ keepGoingPaths addModule, False, completeFilename), ("browse", keepGoing browseCmd, False, completeModule), - ("cd", keepGoing changeDirectory, False, completeFilename), + ("cd", keepGoing changeDirectory, False, completeFilename), ("def", keepGoing defineMacro, False, completeIdentifier), ("e", keepGoing editFile, False, completeFilename), -- Hugs users are accustomed to :e, so make sure it doesn't overlap @@ -120,16 +121,19 @@ builtin_commands = [ ("help", keepGoing help, False, completeNone), ("?", keepGoing help, False, completeNone), ("info", keepGoing info, False, completeIdentifier), - ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile), + ("load", tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile), ("module", keepGoing setContext, False, completeModule), - ("main", keepGoing runMain, False, completeIdentifier), - ("reload", keepGoing reloadModule, False, completeNone), + ("main", tlC$ keepGoing runMain, False, completeIdentifier), + ("reload", tlC$ keepGoing reloadModule, False, completeNone), ("check", keepGoing checkModule, False, completeHomeModule), ("set", keepGoing setCmd, True, completeSetOptions), ("show", keepGoing showCmd, False, completeNone), ("etags", keepGoing createETagsFileCmd, False, completeFilename), ("ctags", keepGoing createCTagsFileCmd, False, completeFilename), ("type", keepGoing typeOfExpr, False, completeIdentifier), +#if defined(GHCI) + ("breakpoint",keepGoing bkptOptions, False, completeBkpt), +#endif ("kind", keepGoing kindOfType, False, completeIdentifier), ("unset", keepGoing unsetOptions, True, completeSetOptions), ("undef", keepGoing undefineMacro, False, completeMacro), @@ -139,6 +143,14 @@ builtin_commands = [ keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) keepGoing a str = a str >> return False +-- tlC: Top Level Command +tlC :: (String -> GHCi Bool) -> (String -> GHCi Bool) +tlC a str = do + top_level <- isTopLevel + if not top_level + then throwDyn (CmdLineError "Command only allowed at Top Level") + else a str + keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool) keepGoingPaths a str = a (toArgs str) >> return False @@ -150,6 +162,7 @@ helpText = "\n" ++ " evaluate/run \n" ++ " :add ... add module(s) to the current target set\n" ++ + " :breakpoint