Commit 8bc615fd authored by mnislaih's avatar mnislaih

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
parent 8099fc7e
-----------------------------------------------------------------------------
--
-- 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
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)]]
}
......@@ -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
......
......@@ -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" ++
" <stmt> evaluate/run <stmt>\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
" :breakpoint <option> commands for the GHCi debugger\n" ++
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
......@@ -186,73 +199,14 @@ helpText =
" +s print timing/memory stats after each evaluation\n" ++
" +t print type after evaluation\n" ++
" -<flags> most GHC command line flags can also be set here\n" ++
" (eg. -v2, -fglasgow-exts, etc.)\n"
#if defined(GHCI) && defined(BREAKPOINT)
globaliseAndTidy :: Id -> Id
globaliseAndTidy id
-- Give the Id a Global Name, and tidy its type
= Id.setIdType (globaliseId VanillaGlobal id) tidy_type
where
tidy_type = tidyTopType (idType id)
printScopeMsg :: Session -> String -> [Id] -> IO ()
printScopeMsg session location ids
= GHC.getPrintUnqual session >>= \unqual ->
printForUser stdout unqual $
text "Local bindings in scope:" $$
nest 2 (pprWithCommas showId ids)
where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
jumpCondFunction session ptr hValues location True b = b
jumpCondFunction session ptr hValues location False b
= jumpFunction session ptr hValues location b
jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
jumpFunction session@(Session ref) (I# idsPtr) hValues location b
= unsafePerformIO $
do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
let names = map idName ids
ASSERT (length names == length hValues) return ()
printScopeMsg session location ids
hsc_env <- readIORef ref
let ictxt = hsc_IC hsc_env
global_ids = map globaliseAndTidy ids
rn_env = ic_rn_local_env ictxt
type_env = ic_type_env ictxt
bound_names = map idName global_ids
new_rn_env = extendLocalRdrEnv rn_env bound_names
-- Remove any shadowed bindings from the type_env;
-- they are inaccessible but might, I suppose, cause
-- a space leak if we leave them there
shadowed = [ n | name <- bound_names,
let rdr_name = mkRdrUnqual (nameOccName name),
Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
filtered_type_env = delListFromNameEnv type_env shadowed
new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
new_ic = ictxt { ic_rn_local_env = new_rn_env,
ic_type_env = new_type_env }
writeIORef ref (hsc_env { hsc_IC = new_ic })
is_tty <- hIsTerminalDevice stdin
prel_mod <- GHC.findModule session prel_name Nothing
default_editor <- findEditor
withExtendedLinkEnv (zip names hValues) $
startGHCi (interactiveLoop is_tty True)
GHCiState{ progname = "<interactive>",
args = [],
prompt = location++"> ",
editor = default_editor,
session = session,
options = [],
prelude = prel_mod }
writeIORef ref hsc_env
putStrLn $ "Returning to normal execution..."
return b
#endif
" (eg. -v2, -fglasgow-exts, etc.)\n" ++
"\n" ++
" Options for ':breakpoint':\n" ++
" list list the current breakpoints\n" ++
" add Module line [col] add a new breakpoint\n" ++
" del (breakpoint# | Module line [col]) delete a breakpoint\n" ++
" stop Stop a computation and return to the top level\n" ++
" step [count] Step by step execution (DISABLED)\n"
findEditor = do
getEnv "EDITOR"
......@@ -266,11 +220,6 @@ findEditor = do
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
interactiveUI session srcs maybe_expr = do
#if defined(GHCI) && defined(BREAKPOINT)
initDynLinker =<< GHC.getSessionDynFlags session
extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
#endif
-- HACK! If we happen to get into an infinite loop (eg the user
-- types 'let x=x in x' at the prompt), then the thread will block
-- on a blackhole, and become unreachable during GC. The GC will
......@@ -315,6 +264,8 @@ interactiveUI session srcs maybe_expr = do
Readline.setCompleterWordBreakCharacters word_break_chars
#endif
bkptTable <- newIORef emptyBkptTable
GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
default_editor <- findEditor
startGHCi (runGHCi srcs maybe_expr)
......@@ -324,7 +275,10 @@ interactiveUI session srcs maybe_expr = do
editor = default_editor,
session = session,
options = [],
prelude = prel_mod }
prelude = prel_mod,
bkptTable = bkptTable,
topLevel = True
}
#ifdef USE_READLINE
Readline.resetTerminal Nothing
......@@ -812,11 +766,8 @@ afterLoad ok session = do
graph <- io (GHC.getModuleGraph session)
graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
setContextAfterLoad session graph'