From e1b8996040150d5b4027ebd50c2df1f24d79a531 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 3 May 2007 13:19:55 +0000 Subject: [PATCH] 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. --- compiler/ghci/GhciMonad.hs | 51 ++------ compiler/ghci/InteractiveUI.hs | 217 +++++++++++++++++++++----------- compiler/main/GHC.hs | 10 +- compiler/main/InteractiveEval.hs | 253 +++++++++++++++++++++++++------------- 4 files changed, 329 insertions(+), 202 deletions(-) diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index 5086022..d380463 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -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 } diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index fc4f30d..ad708f5 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -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 " + 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 " + 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 () diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 97d21fc..af1a817 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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, diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index ef9e5af..7ed6fac 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -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 hsc_env <- readIORef ref - let - mod_name = moduleName (breakInfo_module info) - mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name) - breaks = md_modBreaks (expectJust "handlRunStatus" mod_details) - -- - (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env - apStack info breaks + (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env apStack info let resume = Resume expr tid breakMVar statusMVar - bindings final_ids apStack info span + bindings final_ids apStack info span + (toListBL history) 0 hsc_env2 = pushResume hsc_env1 resume -- writeIORef ref hsc_env2 @@ -210,28 +230,47 @@ handleRunStatus expr ref bindings final_ids breakMVar statusMVar status = Linker.extendLinkEnv (zip final_names hvals) return (RunOk final_names) -{- -traceRunStatus ref final_ids + +traceRunStatus expr ref bindings final_ids breakMVar statusMVar status history = do hsc_env <- readIORef ref case status of -- when tracing, if we hit a breakpoint that is not explicitly -- enabled, then we just log the event in the history and continue. - (Break apStack info tid) | not (isBreakEnabled hsc_env info) -> do - let history' = consBL (apStack,info) history - withBreakAction breakMVar statusMVar $ do - status <- withInterruptsSentTo - (do putMVar breakMVar () -- this awakens the stopped thread... - return tid) - (takeMVar statusMVar) -- and wait for the result - - traceRunStatus ref final_ids - breakMVar statusMVar status history' + (Break apStack info tid) -> do + b <- isBreakEnabled hsc_env info + if b + then handle_normally + else do + let history' = consBL (History apStack info) history + -- probably better make history strict here, otherwise + -- our BoundedList will be pointless. + evaluate history' + setStepFlag + status <- withBreakAction breakMVar statusMVar $ do + withInterruptsSentTo + (do putMVar breakMVar () -- awaken the stopped thread + return tid) + (takeMVar statusMVar) -- and wait for the result + traceRunStatus expr ref bindings final_ids + breakMVar statusMVar status history' _other -> - handleRunStatus ref final_ids - breakMVar statusMVar status - --} + handle_normally + where + handle_normally = handleRunStatus expr ref bindings final_ids + breakMVar statusMVar status history + + +isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool +isBreakEnabled hsc_env inf = + case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of + Just hmi -> do + w <- getBreak (modBreaks_flags (md_modBreaks (hm_details hmi))) + (breakInfo_number inf) + case w of Just n -> return (n /= 0); _other -> return False + _ -> + return False + foreign import ccall "rts_setStepFlag" setStepFlag :: IO () @@ -277,17 +316,8 @@ withBreakAction breakMVar statusMVar io noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction noBreakAction info apStack = putStrLn "*** Ignoring breakpoint" -resume :: Session -> IO RunResult -resume session = resume_ session RunToCompletion - -stepResume :: Session -> IO RunResult -stepResume session = resume_ session SingleStep - --- traceResume :: Session -> IO RunResult --- traceResume session handle = resume_ session handle RunAndLogSteps - -resume_ :: Session -> SingleStep -> IO RunResult -resume_ (Session ref) step +resume :: Session -> SingleStep -> IO RunResult +resume (Session ref) step = do hsc_env <- readIORef ref let ic = hsc_IC hsc_env @@ -311,11 +341,10 @@ resume_ (Session ref) step (ic_tmp_ids ic)) Linker.deleteFromLinkEnv new_names - when (isStep step) $ setStepFlag case r of Resume expr tid breakMVar statusMVar bindings - final_ids apStack info _ -> do + final_ids apStack info _ _ _ -> do withBreakAction breakMVar statusMVar $ do status <- withInterruptsSentTo (do putMVar breakMVar () @@ -323,8 +352,58 @@ resume_ (Session ref) step return tid) (takeMVar statusMVar) -- and wait for the result - handleRunStatus expr ref bindings final_ids - breakMVar statusMVar status + case step of + RunAndLogSteps -> + traceRunStatus expr ref bindings final_ids + breakMVar statusMVar status emptyHistory + _other -> + handleRunStatus expr ref bindings final_ids + breakMVar statusMVar status emptyHistory + + +back :: Session -> IO ([Name], Int, SrcSpan) +back = moveHist (+1) + +forward :: Session -> IO ([Name], Int, SrcSpan) +forward = moveHist (subtract 1) + +moveHist fn (Session ref) = do + hsc_env <- readIORef ref + case ic_resume (hsc_IC hsc_env) of + [] -> throwDyn (ProgramError "not stopped at a breakpoint") + (r:rs) -> do + let ix = resumeHistoryIx r + history = resumeHistory r + new_ix = fn ix + -- + when (new_ix >= length history) $ + throwDyn (ProgramError "no more logged breakpoints") + when (new_ix < 0) $ + throwDyn (ProgramError "already at the beginning of the history") + + let + update_ic apStack info = do + (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env + apStack info + let ic = hsc_IC hsc_env1 + r' = r { resumeHistoryIx = new_ix } + ic' = ic { ic_resume = r':rs } + + writeIORef ref hsc_env1{ hsc_IC = ic' } + + return (names, new_ix, span) + + -- careful: we want apStack to be the AP_STACK itself, not a thunk + -- around it, hence the cases are carefully constructed below to + -- make this the case. ToDo: this is v. fragile, do something better. + if new_ix == 0 + then case r of + Resume { resumeApStack = apStack, + resumeBreakInfo = info } -> + update_ic apStack info + else case history !! (new_ix - 1) of + History apStack info -> + update_ic apStack info -- ----------------------------------------------------------------------------- -- After stopping at a breakpoint, add free variables to the environment @@ -333,11 +412,13 @@ bindLocalsAtBreakpoint :: HscEnv -> HValue -> BreakInfo - -> ModBreaks -> IO (HscEnv, [Name], SrcSpan) -bindLocalsAtBreakpoint hsc_env apStack info breaks = do +bindLocalsAtBreakpoint hsc_env apStack info = do let + mod_name = moduleName (breakInfo_module info) + mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name) + breaks = md_modBreaks (expectJust "handlRunStatus" mod_details) index = breakInfo_number info vars = breakInfo_vars info result_ty = breakInfo_resty info @@ -352,7 +433,7 @@ bindLocalsAtBreakpoint hsc_env apStack info breaks = do let (ids, offsets) = unzip pointers hValues <- mapM (getIdValFromApStack apStack) offsets new_ids <- zipWithM mkNewId occs ids - let names = map idName ids + let names = map idName new_ids -- make an Id for _result. We use the Unique of the FastString "_result"; -- we don't care about uniqueness here, because there will only be one @@ -369,16 +450,15 @@ bindLocalsAtBreakpoint hsc_env apStack info breaks = do -- - tidy the type variables -- - globalise the Id (Ids are supposed to be Global, apparently). -- - let all_ids | isPointer result_id = result_id : ids - | otherwise = ids + let all_ids | isPointer result_id = result_id : new_ids + | otherwise = new_ids (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys new_tyvars = unionVarSets tyvarss - new_ids = zipWith setIdType all_ids tidy_tys - global_ids = map (globaliseId VanillaGlobal) new_ids + final_ids = zipWith setIdType all_ids tidy_tys let ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContext ictxt0 global_ids new_tyvars + ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars Linker.extendLinkEnv (zip names hValues) Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] @@ -389,7 +469,7 @@ bindLocalsAtBreakpoint hsc_env apStack info breaks = do let uniq = idUnique id loc = nameSrcLoc (idName id) name = mkInternalName uniq occ loc - ty = tidyTopType (idType id) + ty = idType id new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) return new_id @@ -410,7 +490,7 @@ skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) foreign import ccall unsafe "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b) -getIdValFromApStack :: a -> Int -> IO HValue +getIdValFromApStack :: HValue -> Int -> IO HValue getIdValFromApStack apStack stackDepth = do apSptr <- newStablePtr apStack resultSptr <- getApStackVal apSptr (stackDepth - 1) @@ -459,10 +539,13 @@ data BoundedList a = BL [a] -- left [a] -- right, list is (left ++ reverse right) +nilBL :: Int -> BoundedList a +nilBL bound = BL 0 bound [] [] + consBL a (BL len bound left right) | len < bound = BL (len+1) bound (a:left) right - | null right = BL len bound [] $! tail (reverse left) - | otherwise = BL len bound [] $! tail right + | null right = BL len bound [a] $! tail (reverse left) + | otherwise = BL len bound (a:left) $! tail right toListBL (BL _ _ left right) = left ++ reverse right -- 1.7.10.4