-- 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
| (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
| 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
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
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)
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)
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) =
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
--
-- 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
import UniqSupply
import Type
import TyCon
-import DataCon
import TcGadt
import GHC
import GhciMonad
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
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
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
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
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 = [] }
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
-- 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
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
-- 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(..) )
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) )
import ByteCodeLink (HValue)
import ByteCodeInstr (BreakInfo (..))
import BreakArray
-import TickTree
-----------------------------------------------------------------------------
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),
("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),
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
session = session,
options = [],
prelude = prel_mod,
- topLevel = True,
resume = [],
- breaks = emptyActiveBreakPoints
+ breaks = emptyActiveBreakPoints,
+ tickarrays = emptyModuleEnv
}
#ifdef USE_READLINE
perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
hsep (map (ppr . GHC.moduleName) exports)
-
+
#ifdef USE_READLINE
readlineLoop :: GHCi ()
-- 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
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
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'
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
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
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
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
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
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
<+> 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
+++ /dev/null
------------------------------------------------------------------------------
---
--- 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
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
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
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)
= 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.
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
-}
+-- -----------------------------------------------------------------------------
+-- 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
HpcInfo, noHpcInfo,
-- Breakpoints
- ModBreaks (..), emptyModBreaks
+ ModBreaks (..), BreakIndex, emptyModBreaks
) where
#include "HsVersions.h"
%************************************************************************
\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}
projects / ghc-hetmet.git / commitdiff