From 38e7ac3ffa32d75c1922e7247a910e06d9957116 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Wed, 18 Apr 2007 11:47:00 +0000 Subject: [PATCH] Various cleanups and improvements to the breakpoint support - move parts of the debugger implementation below the GHC API where they belong. There is still more in Debugger that violates the layering, hopefully I'll get to that later. - instead of returning an IO action from runStmt for resuming, return a ResumeHandle that is passed to GHC.resume. - breakpoints now return [Name] which is displayed in the same way as when a binding statement is executed. - :load, :add, :reload now clear the active breakpoints and context - :break gives a sensible error when used on a non-interpreted module - export breakpoint-related types from GHC - remove a bunch of layer-violating imports from InteractiveUI - remove some more vestiges of the old breakpoint code (topLevel in the GHCi state). - remove TickTree and use a simple array instead, cached per module --- compiler/basicTypes/SrcLoc.lhs | 4 +- compiler/deSugar/Coverage.lhs | 35 +++--- compiler/ghci/ByteCodeGen.lhs | 2 +- compiler/ghci/Debugger.hs | 63 ++-------- compiler/ghci/GhciMonad.hs | 46 ++++---- compiler/ghci/InteractiveUI.hs | 249 ++++++++++++++++++++-------------------- compiler/ghci/TickTree.hs | 110 ------------------ compiler/main/GHC.hs | 198 +++++++++++++++++++------------- compiler/main/HscTypes.lhs | 18 +-- 9 files changed, 316 insertions(+), 409 deletions(-) delete mode 100644 compiler/ghci/TickTree.hs diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 99ce717..e028c12 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -30,7 +30,9 @@ module SrcLoc ( -- These are dubious exports, because they crash on some inputs, -- used only in Lexer.x where we are sure what the Span looks like - srcSpanFile, srcSpanEndLine, srcSpanEndCol, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc ) where diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index ce975fe..cf8e914 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -87,8 +87,8 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do | (P r1 c1 r2 c2, _box) <- entries ] let modBreaks = emptyModBreaks - { modBreaks_array = breakArray - , modBreaks_ticks = locsTicks + { modBreaks_flags = breakArray + , modBreaks_locs = locsTicks } doIfSet_dyn dflags Opt_D_dump_hpc $ do @@ -170,6 +170,19 @@ addTickLHsExprBreakAlways e | opt_Hpc = addTickLHsExpr e | otherwise = addTickLHsExprAlways e +-- version of addTick that does not actually add a tick, +-- because the scope of this tick is completely subsumed by +-- another. +addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprNever (L pos e0) = do + e1 <- addTickHsExpr e0 + return $ L pos e1 + +addTickLHsExprBreakOnly :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprBreakOnly e + | opt_Hpc = addTickLHsExprNever e + | otherwise = addTickLHsExprAlways e + -- selectively add ticks to interesting expressions addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id) addTickLHsExpr (L pos e0) = do @@ -202,14 +215,6 @@ addTickLHsExprOptAlt oneOfMany (L pos e0) fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos return $ fn $ L pos e1 --- version of addTick that does not actually add a tick, --- because the scope of this tick is completely subsumed by --- another. -addTickLHsExpr' :: LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExpr' (L pos e0) = do - e1 <- addTickHsExpr e0 - return $ L pos e1 - addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) addBinTickLHsExpr boxLabel (L pos e0) = do e1 <- addTickHsExpr e0 @@ -223,18 +228,18 @@ addTickHsExpr e@(HsLit _) = return e addTickHsExpr e@(HsLam matchgroup) = liftM HsLam (addTickMatchGroup matchgroup) addTickHsExpr (HsApp e1 e2) = - liftM2 HsApp (addTickLHsExpr' e1) (addTickLHsExpr e2) + liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2) addTickHsExpr (OpApp e1 e2 fix e3) = liftM4 OpApp (addTickLHsExpr e1) - (addTickLHsExpr' e2) + (addTickLHsExprNever e2) (return fix) (addTickLHsExpr e3) addTickHsExpr (NegApp e neg) = liftM2 NegApp (addTickLHsExpr e) (addTickSyntaxExpr hpcSrcSpan neg) -addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExpr' e) +addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExprNever e) addTickHsExpr (SectionL e1 e2) = liftM2 SectionL (addTickLHsExpr e1) @@ -255,7 +260,7 @@ addTickHsExpr (HsIf e1 e2 e3) = addTickHsExpr (HsLet binds e) = liftM2 HsLet (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsExpr' e) + (addTickLHsExprBreakOnly e) addTickHsExpr (HsDo cxt stmts last_exp srcloc) = liftM4 HsDo (return cxt) @@ -289,7 +294,7 @@ addTickHsExpr (RecordUpd e rec_binds ty1 ty2) = addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig" addTickHsExpr (ExprWithTySigOut e ty) = liftM2 ExprWithTySigOut - (addTickLHsExpr' e) -- No need to tick the inner expression + (addTickLHsExprNever e) -- No need to tick the inner expression -- for expressions with signatures (return ty) addTickHsExpr (ArithSeq ty arith_seq) = diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index ca66250..b09d739 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -1446,7 +1446,7 @@ runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r) runBc us modBreaks (BcM m) = m (BcM_State us 0 [] breakArray) where - breakArray = modBreaks_array modBreaks + breakArray = modBreaks_flags modBreaks thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index f0f8973..4389213 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -4,10 +4,15 @@ -- -- Pepe Iborra (supported by Google SoC) 2006 -- +-- ToDo: lots of violation of layering here. This module should +-- decide whether it is above the GHC API (import GHC and nothing +-- else) or below it. +-- ----------------------------------------------------------------------------- -module Debugger (pprintClosureCommand, instantiateTyVarsToUnknown) where +module Debugger (pprintClosureCommand) where +import qualified DebuggerTys import Linker import RtClosureInspect @@ -24,7 +29,6 @@ import RdrName import UniqSupply import Type import TyCon -import DataCon import TcGadt import GHC import GhciMonad @@ -203,56 +207,6 @@ newGrimName cms userName = do name = mkInternalName unique occname noSrcLoc return name ----------------------------------------------------------------------------- --- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown ----------------------------------------------------------------------------- -instantiateTyVarsToUnknown :: Session -> Type -> IO Type -instantiateTyVarsToUnknown cms ty --- We have a GADT, so just fix its tyvars - | Just (tycon, args) <- splitTyConApp_maybe ty - , tycon /= funTyCon - , isGADT tycon - = mapM fixTyVars args >>= return . mkTyConApp tycon --- We have a regular TyCon, so map recursively to its args - | Just (tycon, args) <- splitTyConApp_maybe ty - , tycon /= funTyCon - = do unknownTyVar <- unknownTV - args' <- mapM (instantiateTyVarsToUnknown cms) args - return$ mkTyConApp tycon args' --- we have a tyvar of kind * - | Just tyvar <- getTyVar_maybe ty - , ([],_) <- splitKindFunTys (tyVarKind tyvar) - = unknownTV --- we have a higher kind tyvar, so insert an unknown of the appropriate kind - | Just tyvar <- getTyVar_maybe ty - , (args,_) <- splitKindFunTys (tyVarKind tyvar) - = liftM mkTyConTy $ unknownTC !! length args --- Base case - | otherwise = return ty - - where unknownTV = do - Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName - return$ mkTyConTy unknown_tc - unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3] - unknownTC1 = do - Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName - return unknown_tc - unknownTC2 = do - Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName - return unknown_tc - unknownTC3 = do - Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName - return unknown_tc --- isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined - isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs - | otherwise = False - fixTyVars ty - | Just (tycon, args) <- splitTyConApp_maybe ty - = mapM fixTyVars args >>= return . mkTyConApp tycon --- Fix the tyvar so that the interactive environment doesn't choke on it TODO - | Just tv <- getTyVar_maybe ty = return ty --TODO - | otherwise = return ty - -- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names stripUnknowns :: [Name] -> Id -> Id stripUnknowns names id = setIdType id . fst . go names . idType @@ -289,3 +243,8 @@ stripUnknowns names id = setIdType id . fst . go names . idType kind1 = mkArrowKind liftedTypeKind liftedTypeKind kind2 = mkArrowKind kind1 liftedTypeKind kind3 = mkArrowKind kind2 liftedTypeKind + +instantiateTyVarsToUnknown :: Session -> Type -> IO Type +instantiateTyVarsToUnknown (Session ref) ty + = do hsc_env <- readIORef ref + DebuggerTys.instantiateTyVarsToUnknown hsc_env ty diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index 3cab56b..d56a581 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -17,11 +17,13 @@ import Util import DynFlags import HscTypes import SrcLoc +import Module import Numeric +import Control.Concurrent import Control.Exception as Exception +import Data.Array import Data.Char -import Data.Dynamic import Data.Int ( Int64 ) import Data.IORef import Data.List @@ -43,11 +45,16 @@ data GHCiState = GHCiState session :: GHC.Session, options :: [GHCiOption], prelude :: GHC.Module, - topLevel :: Bool, - resume :: [IO GHC.RunResult], - breaks :: !ActiveBreakPoints + resume :: [(SrcSpan, ThreadId, GHC.ResumeHandle)], + breaks :: !ActiveBreakPoints, + tickarrays :: ModuleEnv TickArray + -- tickarrays caches the TickArray for loaded modules, + -- so that we don't rebuild it each time the user sets + -- a breakpoint. } +type TickArray = Array Int [(BreakIndex,SrcSpan)] + data GHCiOption = ShowTiming -- show time/allocs after evaluation | ShowType -- show the type of expressions @@ -86,8 +93,8 @@ getActiveBreakPoints :: GHCi ActiveBreakPoints getActiveBreakPoints = liftM breaks getGHCiState -- don't reset the counter back to zero? -clearActiveBreakPoints :: GHCi () -clearActiveBreakPoints = do +discardActiveBreakPoints :: GHCi () +discardActiveBreakPoints = do st <- getGHCiState let oldActiveBreaks = breaks st newActiveBreaks = oldActiveBreaks { breakLocations = [] } @@ -172,28 +179,23 @@ unsetOption opt io :: IO a -> GHCi a io m = GHCi { unGHCi = \s -> m >>= return } -isTopLevel :: GHCi Bool -isTopLevel = getGHCiState >>= return . topLevel - -getResume :: GHCi (Maybe (IO GHC.RunResult)) -getResume = do - st <- getGHCiState - case (resume st) of - [] -> return Nothing - (x:_) -> return $ Just x - -popResume :: GHCi () +popResume :: GHCi (Maybe (SrcSpan, ThreadId, GHC.ResumeHandle)) popResume = do st <- getGHCiState case (resume st) of - [] -> return () - (_:xs) -> setGHCiState $ st { resume = xs } + [] -> return Nothing + (x:xs) -> do setGHCiState $ st { resume = xs } ; return (Just x) -pushResume :: IO GHC.RunResult -> GHCi () -pushResume resumeAction = do +pushResume :: SrcSpan -> ThreadId -> GHC.ResumeHandle -> GHCi () +pushResume span threadId resumeAction = do st <- getGHCiState let oldResume = resume st - setGHCiState $ st { resume = resumeAction : oldResume } + setGHCiState $ st { resume = (span, threadId, resumeAction) : oldResume } + +discardResumeContext :: GHCi () +discardResumeContext = do + st <- getGHCiState + setGHCiState st { resume = [] } showForUser :: SDoc -> GHCi String showForUser doc = do diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index b794436..4a98b9e 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -18,13 +18,16 @@ import GhciMonad -- The GHC interface import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), - Type, Module, ModuleName, TyThing(..), Phase ) + Type, Module, ModuleName, TyThing(..), Phase, + BreakIndex ) +import Debugger import DynFlags import Packages import PackageConfig import UniqFM import PprTyThing import Outputable +import Module -- for ModuleEnv -- for createtags import Name @@ -40,18 +43,6 @@ import StaticFlags import Linker import Util --- The debugger -import Debugger -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 @@ -74,7 +65,7 @@ import Control.Exception as Exception -- import Control.Concurrent import Data.List -import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes ) +import Data.Maybe import System.Cmd import System.Environment import System.Exit ( exitWith, ExitCode(..) ) @@ -85,8 +76,8 @@ import Data.Char import Data.Dynamic import Data.Array import Control.Monad as Monad -import Foreign.StablePtr ( StablePtr, newStablePtr, deRefStablePtr, freeStablePtr ) +import Foreign.StablePtr ( newStablePtr ) import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument), IO(IO) ) @@ -98,7 +89,6 @@ import System.Posix.Internals ( setNonBlockingFD ) import ByteCodeLink (HValue) import ByteCodeInstr (BreakInfo (..)) import BreakArray -import TickTree ----------------------------------------------------------------------------- @@ -118,10 +108,10 @@ builtin_commands :: [Command] builtin_commands = [ -- Hugs users are accustomed to :e, so make sure it doesn't overlap ("?", keepGoing help, False, completeNone), - ("add", tlC$ keepGoingPaths addModule, False, completeFilename), + ("add", keepGoingPaths addModule, False, completeFilename), ("break", breakCmd, False, completeNone), ("browse", keepGoing browseCmd, False, completeModule), - ("cd", tlC$ keepGoing changeDirectory, False, completeFilename), + ("cd", keepGoing changeDirectory, False, completeFilename), ("check", keepGoing checkModule, False, completeHomeModule), ("continue", continueCmd, False, completeNone), ("ctags", keepGoing createCTagsFileCmd, False, completeFilename), @@ -134,12 +124,12 @@ builtin_commands = [ ("help", keepGoing help, False, completeNone), ("info", keepGoing info, False, completeIdentifier), ("kind", keepGoing kindOfType, False, completeIdentifier), - ("load", tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile), + ("load", keepGoingPaths loadModule_,False, completeHomeModuleOrFile), ("module", keepGoing setContext, False, completeModule), - ("main", tlC$ keepGoing runMain, False, completeIdentifier), + ("main", keepGoing runMain, False, completeIdentifier), ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier), ("quit", quit, False, completeNone), - ("reload", tlC$ keepGoing reloadModule, False, completeNone), + ("reload", keepGoing reloadModule, False, completeNone), ("set", keepGoing setCmd, True, completeSetOptions), ("show", keepGoing showCmd, False, completeNone), ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier), @@ -152,14 +142,6 @@ builtin_commands = [ keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) keepGoing a str = a str >> return False --- tlC: Top Level Command, not allowed in inferior sessions -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 @@ -279,9 +261,9 @@ interactiveUI session srcs maybe_expr = do session = session, options = [], prelude = prel_mod, - topLevel = True, resume = [], - breaks = emptyActiveBreakPoints + breaks = emptyActiveBreakPoints, + tickarrays = emptyModuleEnv } #ifdef USE_READLINE @@ -462,7 +444,7 @@ mkPrompt toplevs exports prompt perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> hsep (map (ppr . GHC.moduleName) exports) - + #ifdef USE_READLINE readlineLoop :: GHCi () @@ -513,9 +495,9 @@ runCommandEval c = ghciHandle handleEval (doCommand c) -- failure to run the command causes exit(1) for ghc -e. _ -> finishEvalExpr nms -runStmt :: String -> GHCi (Maybe [Name]) +runStmt :: String -> GHCi (Maybe (Bool,[Name])) runStmt stmt - | null (filter (not.isSpace) stmt) = return (Just []) + | null (filter (not.isSpace) stmt) = return (Just (False,[])) | otherwise = do st <- getGHCiState session <- getSession @@ -523,90 +505,34 @@ runStmt stmt GHC.runStmt session stmt switchOnRunResult result -switchOnRunResult :: GHC.RunResult -> GHCi (Maybe [Name]) +switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name])) switchOnRunResult GHC.RunFailed = return Nothing switchOnRunResult (GHC.RunException e) = throw e -switchOnRunResult (GHC.RunOk names) = return $ Just names -switchOnRunResult (GHC.RunBreak apStack _threadId info resume) = do -- Todo: we don't use threadID, perhaps delete? +switchOnRunResult (GHC.RunOk names) = return $ Just (False,names) +switchOnRunResult (GHC.RunBreak threadId names info resume) = do session <- getSession Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info) let modBreaks = GHC.modInfoModBreaks mod_info - let ticks = modBreaks_ticks modBreaks - io $ displayBreakInfo session ticks info - io $ extendEnvironment session apStack (breakInfo_vars info) - pushResume resume - return Nothing - -displayBreakInfo :: Session -> Array Int SrcSpan -> BreakInfo -> IO () -displayBreakInfo session ticks info = do - unqual <- GHC.getPrintUnqual session + let ticks = GHC.modBreaks_locs modBreaks + + -- display information about the breakpoint let location = ticks ! breakInfo_number info - printForUser stdout unqual $ - ptext SLIT("Stopped at") <+> ppr location $$ localsMsg - where - vars = map fst $ breakInfo_vars info - localsMsg = if null vars - then text "No locals in scope." - else text "Locals:" <+> (pprWithCommas showId vars) - showId id = ppr (idName id) <+> dcolon <+> ppr (idType id) - --- Todo: turn this into a primop, and provide special version(s) for unboxed things -foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b) - -getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue) -getIdValFromApStack apStack (identifier, stackDepth) = do - -- ToDo: check the type of the identifer and decide whether it is unboxed or not - apSptr <- newStablePtr apStack - resultSptr <- getApStackVal apSptr (stackDepth - 1) - result <- deRefStablePtr resultSptr - freeStablePtr apSptr - freeStablePtr resultSptr - return (identifier, unsafeCoerce# result) - -extendEnvironment :: Session -> a -> [(Id, Int)] -> IO () -extendEnvironment s@(Session ref) apStack idsOffsets = do - idsVals <- mapM (getIdValFromApStack apStack) idsOffsets - let (ids, hValues) = unzip idsVals - let names = map idName ids - let global_ids = map globaliseAndTidy ids - typed_ids <- mapM instantiateIdType global_ids - hsc_env <- readIORef ref - let ictxt = hsc_IC hsc_env - rn_env = ic_rn_local_env ictxt - type_env = ic_type_env ictxt - bound_names = map idName typed_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 (typed_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 }) - extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint - where - globaliseAndTidy :: Id -> Id - globaliseAndTidy id - = let tidied_type = tidyTopType$ idType id - in setIdType (globaliseId VanillaGlobal id) tidied_type + unqual <- io $ GHC.getPrintUnqual session + io $ printForUser stdout unqual $ + ptext SLIT("Stopped at") <+> ppr location - -- | Instantiate the tyVars with GHC.Base.Unknown - instantiateIdType :: Id -> IO Id - instantiateIdType id = do - instantiatedType <- instantiateTyVarsToUnknown s (idType id) - return$ setIdType id instantiatedType + pushResume location threadId resume + return (Just (True,names)) -- possibly print the type and revert CAFs after evaluating an expression finishEvalExpr mb_names - = do b <- isOptionSet ShowType + = do show_types <- isOptionSet ShowType session <- getSession case mb_names of Nothing -> return () - Just names -> when b (mapM_ (showTypeOfName session) names) + Just (is_break,names) -> + when (is_break || show_types) $ + mapM_ (showTypeOfName session) names flushInterpBuffers io installSignalHandlers @@ -841,6 +767,9 @@ reloadModule m = do afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. + discardResumeContext + discardTickArrays + discardActiveBreakPoints graph <- io (GHC.getModuleGraph session) graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph setContextAfterLoad session graph' @@ -1043,10 +972,8 @@ browseCmd m = browseModule m exports_only = do s <- getSession - modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing - is_interpreted <- io (GHC.moduleIsInterpreted s modl) - when (not is_interpreted && not exports_only) $ - throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted")) + modl <- if exports_only then lookupModule s m + else wantInterpretedModule s m -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified @@ -1530,15 +1457,15 @@ continueCmd other = do doContinue :: IO () -> GHCi Bool doContinue actionBeforeCont = do - resumeAction <- getResume - popResume + resumeAction <- popResume case resumeAction of Nothing -> do io $ putStrLn "There is no computation running." return False - Just action -> do + Just (_,_,handle) -> do io $ actionBeforeCont - runResult <- io action + session <- getSession + runResult <- io $ GHC.resume session handle names <- switchOnRunResult runResult finishEvalExpr names return False @@ -1552,7 +1479,7 @@ deleteCmd argLine = do deleteSwitch [] = io $ putStrLn "The delete command requires at least one argument." -- delete all break points - deleteSwitch ("*":_rest) = clearActiveBreakPoints + deleteSwitch ("*":_rest) = discardActiveBreakPoints deleteSwitch idents = do mapM_ deleteOneBreak idents where @@ -1573,7 +1500,7 @@ breakSwitch _session [] = do return False breakSwitch session args@(arg1:rest) | looksLikeModule arg1 = do - mod <- lookupModule session arg1 + mod <- wantInterpretedModule session arg1 breakByModule mod rest return False | otherwise = do @@ -1590,6 +1517,14 @@ breakSwitch session args@(arg1:rest) looksLikeModule [] = False looksLikeModule (x:_) = isUpper x +wantInterpretedModule :: Session -> String -> GHCi Module +wantInterpretedModule session str = do + modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing + is_interpreted <- io (GHC.moduleIsInterpreted session modl) + when (not is_interpreted) $ + throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted")) + return modl + breakByModule :: Module -> [String] -> GHCi () breakByModule mod args@(arg1:rest) | all isDigit arg1 = do -- looks like a line number @@ -1606,16 +1541,16 @@ breakByModule mod args@(arg1:rest) breakByModuleLine :: Module -> Int -> [String] -> GHCi () breakByModuleLine mod line args - | [] <- args = findBreakAndSet mod $ lookupTickTreeLine line + | [] <- args = findBreakAndSet mod $ findBreakByLine line | [col] <- args, all isDigit col = - findBreakAndSet mod $ lookupTickTreeCoord (line, read col) + findBreakAndSet mod $ findBreakByCoord (line, read col) | otherwise = io $ putStrLn "Invalid arguments to break command." - -findBreakAndSet :: Module -> (TickTree -> Maybe (Int, SrcSpan)) -> GHCi () + +findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () findBreakAndSet mod lookupTickTree = do - (breakArray, ticks) <- getModBreak mod - let tickTree = tickTreeFromList (assocs ticks) - case lookupTickTree tickTree of + tickArray <- getTickArray mod + (breakArray, _) <- getModBreak mod + case lookupTickTree tickArray of Nothing -> io $ putStrLn $ "No breakpoints found at that location." Just (tick, span) -> do success <- io $ setBreakFlag True breakArray tick @@ -1639,13 +1574,79 @@ findBreakAndSet mod lookupTickTree = do <+> ppr span io $ putStrLn str +-- When a line number is specified, the current policy for choosing +-- the best breakpoint is this: +-- - the leftmost complete subexpression on the specified line, or +-- - the leftmost subexpression starting on the specified line, or +-- - the rightmost subexpression enclosing the specified line +-- +findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan) +findBreakByLine line arr = + listToMaybe (sortBy leftmost complete) `mplus` + listToMaybe (sortBy leftmost incomplete) `mplus` + listToMaybe (sortBy rightmost ticks) + where + ticks = arr ! line + + starts_here = [ tick | tick@(nm,span) <- ticks, + srcSpanStartLine span == line ] + + (complete,incomplete) = partition ends_here starts_here + where ends_here (nm,span) = srcSpanEndLine span == line + +findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan) +findBreakByCoord (line, col) arr = + listToMaybe (sortBy rightmost contains) + where + ticks = arr ! line + + -- the ticks that span this coordinate + contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ] + +leftmost (_,a) (_,b) = a `compare` b +rightmost (_,a) (_,b) = b `compare` a + +spans :: SrcSpan -> (Int,Int) -> Bool +spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span + where loc = mkSrcLoc (srcSpanFile span) l c + + +-- -------------------------------------------------------------------------- +-- Tick arrays + +getTickArray :: Module -> GHCi TickArray +getTickArray modl = do + st <- getGHCiState + let arrmap = tickarrays st + case lookupModuleEnv arrmap modl of + Just arr -> return arr + Nothing -> do + (breakArray, ticks) <- getModBreak modl + let arr = mkTickArray (assocs ticks) + setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr} + return arr + +discardTickArrays :: GHCi () +discardTickArrays = do + st <- getGHCiState + setGHCiState st{tickarrays = emptyModuleEnv} + +mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray +mkTickArray ticks + = accumArray (flip (:)) [] (1, max_line) + [ (line, (nm,span)) | (nm,span) <- ticks, + line <- srcSpanLines span ] + where + max_line = maximum (map srcSpanEndLine (map snd ticks)) + srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ] + getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan) getModBreak mod = do session <- getSession Just mod_info <- io $ GHC.getModuleInfo session mod let modBreaks = GHC.modInfoModBreaks mod_info - let array = modBreaks_array modBreaks - let ticks = modBreaks_ticks modBreaks + let array = GHC.modBreaks_flags modBreaks + let ticks = GHC.modBreaks_locs modBreaks return (array, ticks) lookupModule :: Session -> String -> GHCi Module diff --git a/compiler/ghci/TickTree.hs b/compiler/ghci/TickTree.hs deleted file mode 100644 index a472e59..0000000 --- a/compiler/ghci/TickTree.hs +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------ --- --- Trees of source spans used by the breakpoint machinery --- --- (c) The University of Glasgow 2007 --- ------------------------------------------------------------------------------ - -module TickTree - ( TickTree, lookupTickTreeCoord, lookupTickTreeLine, tickTreeFromList ) - where - -import SrcLoc - -import Data.List (partition, foldl') - -type TickNumber = Int - -newtype TickTree = Root [SpanTree] - -data SpanTree - = Node - { spanTreeTick :: TickNumber - , spanTreeLoc :: SrcSpan - , spanTreeChildren :: [SpanTree] - } - -mkNode :: TickNumber -> SrcSpan -> [SpanTree] -> SpanTree -mkNode tick loc kids - = Node { spanTreeTick = tick, spanTreeLoc = loc, spanTreeChildren = kids } - -emptyTickTree :: TickTree -emptyTickTree = Root [] - -tickTreeFromList :: [(TickNumber, SrcSpan)] -> TickTree -tickTreeFromList - = foldl' (\tree (tick,loc) -> insertTickTree tick loc tree) emptyTickTree - -insertTickTree :: TickNumber -> SrcSpan -> TickTree -> TickTree -insertTickTree tick loc (Root children) - = Root $ insertSpanTree tick loc children - -insertSpanTree :: TickNumber -> SrcSpan -> [SpanTree] -> [SpanTree] -insertSpanTree tick loc [] = [mkNode tick loc []] -insertSpanTree tick loc children@(kid:siblings) - | null containedKids = insertDeeper tick loc children - | otherwise = mkNode tick loc children : rest - where - (containedKids, rest) = getContainedKids loc children - insertDeeper :: TickNumber -> SrcSpan -> [SpanTree] -> [SpanTree] - insertDeeper tick loc [] = [mkNode tick loc []] - insertDeeper tick loc nodes@(kid:siblings) - | srcSpanStart loc < srcSpanStart kidLoc = newBranch : nodes - | kidLoc `contains` loc = newKid : siblings - | otherwise = kid : insertDeeper tick loc siblings - where - newBranch = mkNode tick loc [] - kidLoc = spanTreeLoc kid - newKid = mkNode (spanTreeTick kid) (spanTreeLoc kid) - (insertSpanTree tick loc $ spanTreeChildren kid) - -getContainedKids :: SrcSpan -> [SpanTree] -> ([SpanTree], [SpanTree]) -getContainedKids loc = Data.List.partition (\tree -> loc `contains` (spanTreeLoc tree)) - --- True if the left loc contains the right loc -contains :: SrcSpan -> SrcSpan -> Bool -contains span1 span2 - = srcSpanStart span1 <= srcSpanStart span2 && - srcSpanEnd span1 <= srcSpanEnd span2 - -type TickLoc = (TickNumber, SrcSpan) -type LineNumber = Int -type ColumnNumber = Int -type Coord = (LineNumber, ColumnNumber) - -srcSpanStartLine = srcLocLine . srcSpanStart - -lookupTickTreeLine :: LineNumber -> TickTree -> Maybe TickLoc -lookupTickTreeLine line (Root children) = lookupSpanTreeLine line children - -lookupSpanTreeLine :: LineNumber -> [SpanTree] -> Maybe TickLoc -lookupSpanTreeLine line [] = Nothing -lookupSpanTreeLine line (node:nodes) - | startLine == line && endLine == line - = Just (spanTreeTick node, spanTreeLoc node) - | startLine > line - = lookupSpanTreeLine line nodes - | otherwise = - case lookupSpanTreeLine line (spanTreeChildren node) of - Nothing -> lookupSpanTreeLine line nodes - x@(Just _) -> x - where - startLine = srcSpanStartLine (spanTreeLoc node) - endLine = srcSpanEndLine (spanTreeLoc node) - -lookupTickTreeCoord :: Coord -> TickTree -> Maybe TickLoc -lookupTickTreeCoord coord (Root children) = lookupSpanTreeCoord coord children Nothing - -lookupSpanTreeCoord :: Coord -> [SpanTree] -> Maybe TickLoc -> Maybe TickLoc -lookupSpanTreeCoord coord [] acc = acc -lookupSpanTreeCoord coord (kid:siblings) acc - | spanTreeLoc kid `spans` coord - = lookupSpanTreeCoord coord (spanTreeChildren kid) - (Just (spanTreeTick kid, spanTreeLoc kid)) - | otherwise - = lookupSpanTreeCoord coord siblings acc - where - spans :: SrcSpan -> Coord -> Bool - spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span - where loc = mkSrcLoc (srcSpanFile span) l c diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 5f78c3e..a04c06c 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -77,13 +77,16 @@ module GHC ( exprType, typeKind, parseName, - RunResult(..), + RunResult(..), ResumeHandle, runStmt, + resume, showModule, isModuleInterpreted, compileExpr, HValue, dynCompileExpr, lookupName, obtainTerm, obtainTerm1, + ModBreaks(..), BreakIndex, + BreakInfo(breakInfo_number, breakInfo_module), modInfoModBreaks, #endif @@ -182,69 +185,50 @@ module GHC ( import RtClosureInspect ( cvObtainTerm, Term ) import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, tcRnLookupName, getModuleExports ) -import RdrName ( plusGlobalRdrEnv, Provenance(..), - ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - mkGlobalRdrEnv ) -import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) -import Name ( nameOccName ) -import Type ( tidyType ) -import Var ( varName ) import VarEnv ( emptyTidyEnv ) import GHC.Exts ( unsafeCoerce#, Ptr ) -import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr, StablePtr, newStablePtr, freeStablePtr ) +import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr ) import Foreign ( poke ) -import Data.Maybe ( fromMaybe) import qualified Linker import Data.Dynamic ( Dynamic ) import Linker ( HValue, getHValue, extendLinkEnv ) -import ByteCodeInstr (BreakInfo) +import ByteCodeInstr +import DebuggerTys +import IdInfo +import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt ) #endif -import Packages ( initPackages ) -import NameSet ( NameSet, nameSetToList, elemNameSet ) -import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), - globalRdrEnvElts, extendGlobalRdrEnv, - emptyGlobalRdrEnv ) +import Packages +import NameSet +import RdrName import HsSyn -import Type ( Kind, Type, dropForAlls, PredType, ThetaType, - pprThetaArrow, pprParendType, splitForAllTys, - pprTypeApp, funResultTy ) -import Id ( Id, idType, isImplicitId, isDeadBinder, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, recordSelectorFieldLabel, - isPrimOpId, isFCallId, isClassOpId_maybe, - isDataConWorkId, idDataCon, - isBottomingId ) -import Var ( TyVar ) +import Type hiding (typeKind) +import Id +import Var hiding (setIdType) import TysPrim ( alphaTyVars ) -import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon, - isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity, - tyConTyVars, tyConDataCons, synTyConDefn, - synTyConType, synTyConResKind ) -import Class ( Class, classSCTheta, classTvsFds, classMethods ) -import FunDeps ( pprFundeps ) -import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon, - dataConFieldLabels, dataConStrictMarks, - dataConIsInfix, isVanillaDataCon ) -import Name ( Name, nameModule, NamedThing(..), nameSrcLoc ) +import TyCon +import Class +import FunDeps +import DataCon +import Name hiding ( varName ) import OccName ( parenSymOcc ) -import NameEnv ( nameEnvElts ) +import NameEnv import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) import SrcLoc import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo ( getImports, getOptions ) import Finder -import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) +import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) import HscTypes import DynFlags import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) import Module import UniqFM -import PackageConfig ( PackageId, stringToPackageId, mainPackageId ) +import PackageConfig import FiniteMap import Panic import Digraph @@ -259,15 +243,15 @@ import Outputable import BasicTypes import TcType ( tcSplitSigmaTy, isDictTy ) import Maybes ( expectJust, mapCatMaybes ) -import HaddockParse ( parseHaddockParagraphs, parseHaddockString ) +import HaddockParse import HaddockLex ( tokenise ) import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist ) -import Data.Maybe ( isJust, isNothing ) -import Data.List ( partition, nub ) +import Data.Maybe +import Data.List import qualified Data.List as List -import Control.Monad ( unless, when ) +import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) import System.Time ( ClockTime ) import Control.Exception as Exception hiding (handle) @@ -2151,11 +2135,13 @@ data RunResult = RunOk [Name] -- ^ names bound by this evaluation | RunFailed -- ^ statement failed compilation | RunException Exception -- ^ statement raised an exception - | forall a . RunBreak a ThreadId BreakInfo (IO RunResult) + | RunBreak ThreadId [Name] BreakInfo ResumeHandle -data Status a - = Break RunResult -- ^ the computation hit a breakpoint - | Complete (Either Exception a) -- ^ the computation completed with either an exception or a value +data Status + = Break HValue BreakInfo ThreadId ResumeHandle -- ^ the computation hit a breakpoint + | Complete (Either Exception [HValue]) -- ^ the computation completed with either an exception or a value + +data ResumeHandle = ResumeHandle (MVar ()) (MVar Status) [Name] -- | Run a statement in the current interactive context. Statement -- may bind multple values. @@ -2177,60 +2163,67 @@ runStmt (Session ref) expr case maybe_stuff of Nothing -> return RunFailed Just (new_hsc_env, names, hval) -> do + writeIORef ref new_hsc_env - -- resume says what to do when we continue execution from a breakpoint - -- onBreakAction says what to do when we hit a breakpoint - -- they are mutually recursive, hence the strange use tuple let-binding - let (resume, onBreakAction) - = ( do stablePtr <- newStablePtr onBreakAction - poke breakPointIOAction stablePtr - putMVar breakMVar () - status <- takeMVar statusMVar - switchOnStatus ref new_hsc_env names status - , \ids apStack -> do - tid <- myThreadId - putMVar statusMVar (Break (RunBreak apStack tid ids resume)) - takeMVar breakMVar - ) - - -- set the onBreakAction to be performed when we hit a breakpoint - -- this is visible in the Byte Code Interpreter, thus it is a global - -- variable, implemented with stable pointers - stablePtr <- newStablePtr onBreakAction - poke breakPointIOAction stablePtr + let resume_handle = ResumeHandle breakMVar statusMVar names + -- set the onBreakAction to be performed when we hit a + -- breakpoint this is visible in the Byte Code + -- Interpreter, thus it is a global variable, + -- implemented with stable pointers + stablePtr <- setBreakAction resume_handle let thing_to_run = unsafeCoerce# hval :: IO [HValue] status <- sandboxIO statusMVar thing_to_run freeStablePtr stablePtr -- be careful not to leak stable pointers! - switchOnStatus ref new_hsc_env names status - where - switchOnStatus ref hs_env names status = - case status of - -- did we hit a breakpoint or did we complete? - (Break result) -> return result - (Complete either_hvals) -> + handleRunStatus ref names status + +handleRunStatus ref names status = + case status of + -- did we hit a breakpoint or did we complete? + (Break apStack info tid res) -> do + hsc_env <- readIORef ref + (new_hsc_env, names) <- extendEnvironment hsc_env apStack + (breakInfo_vars info) + writeIORef ref new_hsc_env + return (RunBreak tid names info res) + (Complete either_hvals) -> case either_hvals of Left e -> return (RunException e) Right hvals -> do extendLinkEnv (zip names hvals) - writeIORef ref hs_env return (RunOk names) -- this points to the IO action that is executed when a breakpoint is hit foreign import ccall "&breakPointIOAction" - breakPointIOAction :: Ptr (StablePtr (a -> BreakInfo -> IO ())) + breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ())) -- When running a computation, we redirect ^C exceptions to the running -- thread. ToDo: we might want a way to continue even if the target -- thread doesn't die when it receives the exception... "this thread -- is not responding". -sandboxIO :: MVar (Status a) -> IO a -> IO (Status a) +sandboxIO :: MVar Status -> IO [HValue] -> IO Status sandboxIO statusMVar thing = do ts <- takeMVar interruptTargetThread child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res)) putMVar interruptTargetThread (child:ts) takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail) +setBreakAction res@(ResumeHandle breakMVar statusMVar names) = do + stablePtr <- newStablePtr onBreak + poke breakPointIOAction stablePtr + return stablePtr + where onBreak ids apStack = do + tid <- myThreadId + putMVar statusMVar (Break apStack ids tid res) + takeMVar breakMVar + +resume :: Session -> ResumeHandle -> IO RunResult +resume (Session ref) res@(ResumeHandle breakMVar statusMVar names) = do + stablePtr <- setBreakAction res + putMVar breakMVar () + status <- takeMVar statusMVar + handleRunStatus ref names status + {- -- This version of sandboxIO runs the expression in a completely new -- RTS main thread. It is disabled for now because ^C exceptions @@ -2261,6 +2254,57 @@ XXX the type of rts_evalStableIO no longer matches the above -} +-- ----------------------------------------------------------------------------- +-- After stopping at a breakpoint, add free variables to the environment + +-- Todo: turn this into a primop, and provide special version(s) for unboxed things +foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b) + +getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue) +getIdValFromApStack apStack (identifier, stackDepth) = do + -- ToDo: check the type of the identifer and decide whether it is unboxed or not + apSptr <- newStablePtr apStack + resultSptr <- getApStackVal apSptr (stackDepth - 1) + result <- deRefStablePtr resultSptr + freeStablePtr apSptr + freeStablePtr resultSptr + return (identifier, unsafeCoerce# result) + +extendEnvironment :: HscEnv -> a -> [(Id, Int)] -> IO (HscEnv, [Name]) +extendEnvironment hsc_env apStack idsOffsets = do + idsVals <- mapM (getIdValFromApStack apStack) idsOffsets + let (ids, hValues) = unzip idsVals + let names = map idName ids + let global_ids = map globaliseAndTidy ids + typed_ids <- mapM instantiateIdType global_ids + let ictxt = hsc_IC hsc_env + rn_env = ic_rn_local_env ictxt + type_env = ic_type_env ictxt + bound_names = map idName typed_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 (typed_ids) + new_ic = ictxt { ic_rn_local_env = new_rn_env, + ic_type_env = new_type_env } + extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint + return (hsc_env{hsc_IC = new_ic}, names) + where + globaliseAndTidy :: Id -> Id + globaliseAndTidy id + = let tidied_type = tidyTopType$ idType id + in setIdType (globaliseId VanillaGlobal id) tidied_type + + -- | Instantiate the tyVars with GHC.Base.Unknown + instantiateIdType :: Id -> IO Id + instantiateIdType id = do + instantiatedType <- instantiateTyVarsToUnknown hsc_env (idType id) + return$ setIdType id instantiatedType ----------------------------------------------------------------------------- -- show a module and it's source/object filenames diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index c7926e3..1101e86 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -62,7 +62,7 @@ module HscTypes ( HpcInfo, noHpcInfo, -- Breakpoints - ModBreaks (..), emptyModBreaks + ModBreaks (..), BreakIndex, emptyModBreaks ) where #include "HsVersions.h" @@ -1243,18 +1243,22 @@ byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) %************************************************************************ \begin{code} --- all the information about the breakpoints for a given module +type BreakIndex = Int + +-- | all the information about the breakpoints for a given module data ModBreaks = ModBreaks - { modBreaks_array :: BreakArray - -- the array of breakpoint flags indexed by tick number - , modBreaks_ticks :: !(Array Int SrcSpan) + { modBreaks_flags :: BreakArray + -- The array of flags, one per breakpoint, + -- indicating which breakpoints are enabled. + , modBreaks_locs :: !(Array BreakIndex SrcSpan) + -- An array giving the source span of each breakpoint. } emptyModBreaks :: ModBreaks emptyModBreaks = ModBreaks - { modBreaks_array = error "ModBreaks.modBreaks_array not initialised" + { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" -- Todo: can we avoid this? - , modBreaks_ticks = array (0,-1) [] + , modBreaks_locs = array (0,-1) [] } \end{code} -- 1.7.10.4