Commit e1b89960 authored by Simon Marlow's avatar Simon Marlow
Browse files

Add history/trace functionality to the GHCi debugger

The debugger can now log each step of the evaluation without actually
stopping, keeping a history of the recent steps (currently 50).  When
a (real) breakpoint is hit, you can examine previous steps in the
history (and their free variables) using the :history, :back and
:forward commands.
parent cddf971c
......@@ -21,7 +21,6 @@ import SrcLoc
import Module
import Numeric
import Control.Concurrent
import Control.Exception as Exception
import Data.Array
import Data.Char
......@@ -47,7 +46,8 @@ data GHCiState = GHCiState
session :: GHC.Session,
options :: [GHCiOption],
prelude :: GHC.Module,
breaks :: !ActiveBreakPoints,
break_ctr :: !Int,
breaks :: ![(Int, BreakLocation)],
tickarrays :: ModuleEnv TickArray
-- tickarrays caches the TickArray for loaded modules,
-- so that we don't rebuild it each time the user sets
......@@ -62,19 +62,6 @@ data GHCiOption
| RevertCAFs -- revert CAFs after every evaluation
deriving Eq
data ActiveBreakPoints
= ActiveBreakPoints
{ breakCounter :: !Int
, breakLocations :: ![(Int, BreakLocation)] -- break location uniquely numbered
}
instance Outputable ActiveBreakPoints where
ppr activeBrks = prettyLocations $ breakLocations activeBrks
emptyActiveBreakPoints :: ActiveBreakPoints
emptyActiveBreakPoints
= ActiveBreakPoints { breakCounter = 0, breakLocations = [] }
data BreakLocation
= BreakLocation
{ breakModule :: !GHC.Module
......@@ -90,43 +77,19 @@ prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $
instance Outputable BreakLocation where
ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
getActiveBreakPoints :: GHCi ActiveBreakPoints
getActiveBreakPoints = liftM breaks getGHCiState
-- don't reset the counter back to zero?
discardActiveBreakPoints :: GHCi ()
discardActiveBreakPoints = do
st <- getGHCiState
let oldActiveBreaks = breaks st
newActiveBreaks = oldActiveBreaks { breakLocations = [] }
setGHCiState $ st { breaks = newActiveBreaks }
deleteBreak :: Int -> GHCi ()
deleteBreak identity = do
st <- getGHCiState
let oldActiveBreaks = breaks st
oldLocations = breakLocations oldActiveBreaks
newLocations = filter (\loc -> fst loc /= identity) oldLocations
newActiveBreaks = oldActiveBreaks { breakLocations = newLocations }
setGHCiState $ st { breaks = newActiveBreaks }
recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
recordBreak brkLoc = do
st <- getGHCiState
let oldActiveBreaks = breaks st
let oldLocations = breakLocations oldActiveBreaks
-- don't store the same break point twice
case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
(nm:_) -> return (True, nm)
[] -> do
let oldCounter = breakCounter oldActiveBreaks
let oldCounter = break_ctr st
newCounter = oldCounter + 1
newActiveBreaks =
oldActiveBreaks
{ breakCounter = newCounter
, breakLocations = (oldCounter, brkLoc) : oldLocations
}
setGHCiState $ st { breaks = newActiveBreaks }
setGHCiState $ st { break_ctr = newCounter,
breaks = (oldCounter, brkLoc) : oldActiveBreaks
}
return (False, oldCounter)
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
......
......@@ -21,7 +21,7 @@ import Debugger
import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
Type, Module, ModuleName, TyThing(..), Phase,
BreakIndex, Name, SrcSpan, Resume )
BreakIndex, Name, SrcSpan, Resume, SingleStep )
import DynFlags
import Packages
import PackageConfig
......@@ -104,6 +104,7 @@ builtin_commands = [
("add", keepGoingPaths addModule, False, completeFilename),
("abandon", keepGoing abandonCmd, False, completeNone),
("break", keepGoing breakCmd, False, completeIdentifier),
("back", keepGoing backCmd, False, completeNone),
("browse", keepGoing browseCmd, False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
("check", keepGoing checkModule, False, completeHomeModule),
......@@ -115,7 +116,9 @@ builtin_commands = [
("edit", keepGoing editFile, False, completeFilename),
("etags", keepGoing createETagsFileCmd, False, completeFilename),
("force", keepGoing forceCmd, False, completeIdentifier),
("forward", keepGoing forwardCmd, False, completeNone),
("help", keepGoing help, False, completeNone),
("history", keepGoing historyCmd, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
("kind", keepGoing kindOfType, False, completeIdentifier),
("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
......@@ -130,6 +133,7 @@ builtin_commands = [
("sprint", keepGoing sprintCmd, False, completeIdentifier),
("step", stepCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
("trace", traceCmd, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
("unset", keepGoing unsetOptions, True, completeSetOptions)
]
......@@ -268,7 +272,8 @@ interactiveUI session srcs maybe_expr = do
session = session,
options = [],
prelude = prel_mod,
breaks = emptyActiveBreakPoints,
break_ctr = 0,
breaks = [],
tickarrays = emptyModuleEnv
}
......@@ -412,11 +417,9 @@ checkPerms name =
fileLoop :: Handle -> Bool -> GHCi ()
fileLoop hdl show_prompt = do
session <- getSession
(mod,imports) <- io (GHC.getContext session)
st <- getGHCiState
resumes <- io $ GHC.getResumeContext session
when show_prompt (io (putStr (mkPrompt mod imports resumes (prompt st))))
when show_prompt $ do
prompt <- mkPrompt
(io (putStr prompt))
l <- io (IO.try (hGetLine hdl))
case l of
Left e | isEOFError e -> return ()
......@@ -441,25 +444,40 @@ stringLoop (s:ss) = do
l -> do quit <- runCommand l
if quit then return True else stringLoop ss
mkPrompt toplevs exports resumes prompt
= showSDoc $ f prompt
where
f ('%':'s':xs) = perc_s <> f xs
f ('%':'%':xs) = char '%' <> f xs
f (x:xs) = char x <> f xs
f [] = empty
perc_s
| eval:rest <- resumes
= (if not (null rest) then text "... " else empty)
<> brackets (ppr (GHC.resumeSpan eval)) <+> modules_prompt
| otherwise
= modules_prompt
modules_prompt =
mkPrompt = do
session <- getSession
(toplevs,exports) <- io (GHC.getContext session)
resumes <- io $ GHC.getResumeContext session
context_bit <-
case resumes of
[] -> return empty
r:rs -> do
let ix = GHC.resumeHistoryIx r
if ix == 0
then return (brackets (ppr (GHC.resumeSpan r)) <> space)
else do
let hist = GHC.resumeHistory r !! (ix-1)
span <- io $ GHC.getHistorySpan session hist
return (brackets (ppr (negate ix) <> char ':'
<+> ppr span) <> space)
let
dots | r:rs <- resumes, not (null rs) = text "... "
| otherwise = empty
modules_bit =
hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
hsep (map (ppr . GHC.moduleName) exports)
deflt_prompt = dots <> context_bit <> modules_bit
f ('%':'s':xs) = deflt_prompt <> f xs
f ('%':'%':xs) = char '%' <> f xs
f (x:xs) = char x <> f xs
f [] = empty
--
st <- getGHCiState
return (showSDoc (f (prompt st)))
#ifdef USE_READLINE
......@@ -470,9 +488,9 @@ readlineLoop = do
io yield
saveSession -- for use by completion
st <- getGHCiState
resumes <- io $ GHC.getResumeContext session
l <- io (readline (mkPrompt mod imports resumes (prompt st))
`finally` setNonBlockingFD 0)
mb_span <- getCurrentBreakSpan
prompt <- mkPrompt
l <- io (readline prompt `finally` setNonBlockingFD 0)
-- readline sometimes puts stdin into blocking mode,
-- so we need to put it back for the IO library
splatSavedSession
......@@ -492,7 +510,7 @@ runCommand c = ghciHandle handler (doCommand c)
where
doCommand (':' : command) = specialCommand command
doCommand stmt
= do timeIt $ runStmt stmt
= do timeIt $ runStmt stmt GHC.RunToCompletion
return False
-- This version is for the GHC command-line option -e. The only difference
......@@ -506,20 +524,20 @@ runCommandEval c = ghciHandle handleEval (doCommand c)
doCommand (':' : command) = specialCommand command
doCommand stmt
= do r <- runStmt stmt
= do r <- runStmt stmt GHC.RunToCompletion
case r of
False -> io (exitWith (ExitFailure 1))
-- failure to run the command causes exit(1) for ghc -e.
_ -> return True
runStmt :: String -> GHCi Bool
runStmt stmt
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
| null (filter (not.isSpace) stmt) = return False
| otherwise
= do st <- getGHCiState
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt
GHC.runStmt session stmt step
afterRunStmt result
return False
......@@ -527,7 +545,6 @@ runStmt stmt
afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
afterRunStmt run_result = do
mb_result <- switchOnRunResult run_result
-- possibly print the type and revert CAFs after evaluating an expression
show_types <- isOptionSet ShowType
session <- getSession
......@@ -593,9 +610,29 @@ lookupCommand str = do
[] -> return Nothing
c:_ -> return (Just c)
getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
session <- getSession
resumes <- io $ GHC.getResumeContext session
case resumes of
[] -> return Nothing
(r:rs) -> do
let ix = GHC.resumeHistoryIx r
if ix == 0
then return (Just (GHC.resumeSpan r))
else do
let hist = GHC.resumeHistory r !! (ix-1)
span <- io $ GHC.getHistorySpan session hist
return (Just span)
-----------------------------------------------------------------------------
-- Commands
noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
noArgs m _ = io $ putStrLn "This command takes no arguments"
help :: String -> GHCi ()
help _ = io (putStr helpText)
......@@ -1149,8 +1186,8 @@ cleanType ty = do
showBkptTable :: GHCi ()
showBkptTable = do
activeBreaks <- getActiveBreakPoints
printForUser $ ppr activeBreaks
st <- getGHCiState
printForUser $ prettyLocations (breaks st)
showContext :: GHCi ()
showContext = do
......@@ -1375,33 +1412,32 @@ pprintCommand bind force str = do
io $ pprintClosureCommand session bind force str
stepCmd :: String -> GHCi Bool
stepCmd [] = doContinue True
stepCmd expression = do
runCommand expression
stepCmd [] = doContinue GHC.SingleStep
stepCmd expression = runStmt expression GHC.SingleStep
traceCmd :: String -> GHCi Bool
traceCmd [] = doContinue GHC.RunAndLogSteps
traceCmd expression = runStmt expression GHC.RunAndLogSteps
continueCmd :: String -> GHCi Bool
continueCmd [] = doContinue False
continueCmd [] = doContinue GHC.RunToCompletion
continueCmd other = do
io $ putStrLn "The continue command accepts no arguments."
return False
doContinue :: Bool -> GHCi Bool
doContinue :: SingleStep -> GHCi Bool
doContinue step = do
session <- getSession
let resume | step = GHC.stepResume
| otherwise = GHC.resume
runResult <- io $ resume session
runResult <- io $ GHC.resume session step
afterRunStmt runResult
return False
abandonCmd :: String -> GHCi ()
abandonCmd "" = do
abandonCmd = noArgs $ do
s <- getSession
b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
when (not b) $ io $ putStrLn "There is no computation running."
return ()
abandonCmd _ = do
io $ putStrLn "The abandon command accepts no arguments."
deleteCmd :: String -> GHCi ()
deleteCmd argLine = do
......@@ -1420,6 +1456,41 @@ deleteCmd argLine = do
| all isDigit str = deleteBreak (read str)
| otherwise = return ()
historyCmd :: String -> GHCi ()
historyCmd = noArgs $ do
s <- getSession
resumes <- io $ GHC.getResumeContext s
case resumes of
[] -> io $ putStrLn "Not stopped at a breakpoint"
(r:rs) -> do
let hist = GHC.resumeHistory r
spans <- mapM (io . GHC.getHistorySpan s) hist
printForUser (vcat (map ppr spans))
backCmd :: String -> GHCi ()
backCmd = noArgs $ do
s <- getSession
(names, ix, span) <- io $ GHC.back s
printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
mapM_ (showTypeOfName s) names
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
runCommand (stop st)
return ()
forwardCmd :: String -> GHCi ()
forwardCmd = noArgs $ do
s <- getSession
(names, ix, span) <- io $ GHC.forward s
printForUser $ (if (ix == 0)
then ptext SLIT("Stopped at")
else ptext SLIT("Logged breakpoint at")) <+> ppr span
mapM_ (showTypeOfName s) names
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
runCommand (stop st)
return ()
-- handle the "break" command
breakCmd :: String -> GHCi ()
breakCmd argLine = do
......@@ -1566,11 +1637,10 @@ end_bold = BS.pack "\ESC[0m"
listCmd :: String -> GHCi ()
listCmd str = do
session <- getSession
resumes <- io $ GHC.getResumeContext session
case resumes of
[] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
eval:_ -> io $ listAround (GHC.resumeSpan eval) True
mb_span <- getCurrentBreakSpan
case mb_span of
Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
Just span -> io $ listAround span True
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
......@@ -1646,6 +1716,33 @@ mkTickArray ticks
srcSpanLines span = [ GHC.srcSpanStartLine span ..
GHC.srcSpanEndLine span ]
lookupModule :: Session -> String -> GHCi Module
lookupModule session modName
= io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
-- don't reset the counter back to zero?
discardActiveBreakPoints :: GHCi ()
discardActiveBreakPoints = do
st <- getGHCiState
mapM (turnOffBreak.snd) (breaks st)
setGHCiState $ st { breaks = [] }
deleteBreak :: Int -> GHCi ()
deleteBreak identity = do
st <- getGHCiState
let oldLocations = breaks st
(this,rest) = partition (\loc -> fst loc == identity) oldLocations
if null this
then printForUser (text "Breakpoint" <+> ppr identity <+>
text "does not exist")
else do
mapM (turnOffBreak.snd) this
setGHCiState $ st { breaks = rest }
turnOffBreak loc = do
(arr, _) <- getModBreak (breakModule loc)
io $ setBreakFlag False arr (breakTick loc)
getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
getModBreak mod = do
session <- getSession
......@@ -1655,28 +1752,8 @@ getModBreak mod = do
let ticks = GHC.modBreaks_locs modBreaks
return (array, ticks)
lookupModule :: Session -> String -> GHCi Module
lookupModule session modName
= io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
setBreakFlag toggle array index
| toggle = GHC.setBreakOn array index
| otherwise = GHC.setBreakOff array index
{- these should probably go to the GHC API at some point -}
enableBreakPoint :: Session -> Module -> Int -> IO ()
enableBreakPoint session mod index = return ()
disableBreakPoint :: Session -> Module -> Int -> IO ()
disableBreakPoint session mod index = return ()
activeBreakPoints :: Session -> IO [(Module,Int)]
activeBreakPoints session = return []
enableSingleStep :: Session -> IO ()
enableSingleStep session = return ()
disableSingleStep :: Session -> IO ()
disableSingleStep session = return ()
......@@ -78,11 +78,15 @@ module GHC (
typeKind,
parseName,
RunResult(..),
runStmt, stepStmt, -- traceStmt,
resume, stepResume, -- traceResume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan),
runStmt, SingleStep(..),
resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
History(historyBreakInfo), getHistorySpan,
getResumeContext,
abandon, abandonAll,
InteractiveEval.back,
InteractiveEval.forward,
showModule,
isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
......
......@@ -8,11 +8,13 @@
module InteractiveEval (
#ifdef GHCI
RunResult(..), Status(..), Resume(..),
runStmt, stepStmt, -- traceStmt,
resume, stepResume, -- traceResume,
RunResult(..), Status(..), Resume(..), History(..),
runStmt, SingleStep(..),
resume,
abandon, abandonAll,
getResumeContext,
getHistorySpan,
back, forward,
setContext, getContext,
nameSetToGlobalRdrEnv,
getNamesInScope,
......@@ -58,6 +60,7 @@ import UniqFM
import Maybes
import Util
import SrcLoc
import BreakArray
import RtClosureInspect
import Packages
import BasicTypes
......@@ -99,9 +102,11 @@ data Resume
resumeApStack :: HValue, -- The object from which we can get
-- value of the free variables.
resumeBreakInfo :: BreakInfo, -- the breakpoint we stopped at.
resumeSpan :: SrcSpan -- just a cache, otherwise it's a pain
resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
-- to fetch the ModDetails & ModBreaks
-- to get this.
resumeHistory :: [History],
resumeHistoryIx :: Int -- 0 <==> at the top of the history
}
getResumeContext :: Session -> IO [Resume]
......@@ -115,37 +120,46 @@ data SingleStep
isStep RunToCompletion = False
isStep _ = True
-- type History = [HistoryItem]
--
-- data HistoryItem = HistoryItem HValue BreakInfo
--
-- historyBreakInfo :: HistoryItem -> BreakInfo
-- historyBreakInfo (HistoryItem _ bi) = bi
--
-- setContextToHistoryItem :: Session -> HistoryItem -> IO ()
-- setContextToHistoryItem
-- We need to track two InteractiveContexts:
-- - the IC before runStmt, which is restored on each resume
-- - the IC binding the results of the original statement, which
-- will be the IC when runStmt returns with RunOk.
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
runStmt :: Session -> String -> IO RunResult
runStmt session expr = runStmt_ session expr RunToCompletion
data History
= History {
historyApStack :: HValue,
historyBreakInfo :: BreakInfo
}
-- | Run a statement, stopping at the first breakpoint location encountered
-- (regardless of whether the breakpoint is enabled).
stepStmt :: Session -> String -> IO RunResult
stepStmt session expr = runStmt_ session expr SingleStep
getHistorySpan :: Session -> History -> IO SrcSpan
getHistorySpan s hist = withSession s $ \hsc_env -> do
let inf = historyBreakInfo hist
num = breakInfo_number inf
case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num)
_ -> panic "getHistorySpan"
-- | Run a statement, logging breakpoints passed, and stopping when either
-- an enabled breakpoint is reached, or the statement completes.
-- traceStmt :: Session -> String -> IO (RunResult, History)
-- traceStmt session expr = runStmt_ session expr RunAndLogSteps
{-
[Main.hs:42:(1,0)-(3,52)] *Main> :history 2
Foo.hs:1:3-5
Bar.hs:5:23-48
[Main.hs:42:(1,0)-(3,52)] *Main> :back
Logged breakpoint at Foo.hs:1:3-5
x :: Int
y :: a
_result :: [Char]
[-1: Foo.hs:1:3-5] *Main> :back
Logged breakpoint at Bar.hs:5:23-48
z :: a
_result :: Float
[-2: Bar.hs:5:23-48] *Main> :forward
Logged breakpoint at Foo.hs:1:3-5
x :: Int
y :: a
_result :: [Char]
[-1: Foo.hs:1:3-5] *Main> :cont
.. continues
-}
runStmt_ (Session ref) expr step
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
runStmt :: Session -> String -> SingleStep -> IO RunResult
runStmt (Session ref) expr step
= do
hsc_env <- readIORef ref
......@@ -176,23 +190,29 @@ runStmt_ (Session ref) expr step
let ic = hsc_IC hsc_env
bindings = (ic_tmp_ids ic, ic_tyvars ic)
handleRunStatus expr ref bindings ids breakMVar statusMVar status
handleRunStatus expr ref bindings final_ids breakMVar statusMVar status =
case step of
RunAndLogSteps ->
traceRunStatus expr ref bindings ids
breakMVar statusMVar status emptyHistory
_other ->
handleRunStatus expr ref bindings ids
breakMVar statusMVar status emptyHistory
emptyHistory = nilBL 50 -- keep a log of length 50
handleRunStatus expr ref bindings final_ids breakMVar statusMVar status
history =
case status of
-- did we hit a breakpoint or did we complete?
(Break apStack info tid) -> do