import Module
import Numeric
-import Control.Concurrent
import Control.Exception as Exception
import Data.Array
import Data.Char
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
| 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
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 }
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
("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),
("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),
("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)
]
session = session,
options = [],
prelude = prel_mod,
- breaks = emptyActiveBreakPoints,
+ break_ctr = 0,
+ breaks = [],
tickarrays = emptyModuleEnv
}
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 ()
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
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
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
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
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
[] -> 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)
showBkptTable :: GHCi ()
showBkptTable = do
- activeBreaks <- getActiveBreakPoints
- printForUser $ ppr activeBreaks
+ st <- getGHCiState
+ printForUser $ prettyLocations (breaks st)
showContext :: GHCi ()
showContext = 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
| 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
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
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
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 ()
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,
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,
import Maybes
import Util
import SrcLoc
+import BreakArray
import RtClosureInspect
import Packages
import BasicTypes
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]
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
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
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 ()
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
(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 ()
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
:: 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
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
-- - 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)]
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
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)
[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
projects / ghc-hetmet.git / commitdiff