diff options
47 files changed, 1377 insertions, 1200 deletions
diff --git a/compiler/Makefile b/compiler/Makefile index 1e8322b79a..e16bf4eca1 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -415,10 +415,6 @@ ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES" SRC_HC_OPTS += -DGHCI -package template-haskell PKG_DEPENDS += template-haskell -# Should the debugger commands be enabled? -ifeq "$(GhciWithDebugger)" "YES" -SRC_HC_OPTS += -DDEBUGGER -endif # Should GHCI be building info tables in the TABLES_NEXT_TO_CODE style # or not? ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO" diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 02ef0db142..b59ddf9654 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -718,8 +718,8 @@ zapFragileInfo info = Just (info `setSpecInfo` emptySpecInfo type TickBoxId = Int data TickBoxOp - = TickBox Module !TickBoxId -- ^Tick box for Hpc-style coverage, - -- type = State# Void# + = TickBox Module {-# UNPACK #-} !TickBoxId + -- ^Tick box for Hpc-style coverage instance Outputable TickBoxOp where ppr (TickBox mod n) = ptext SLIT("tick") <+> ppr (mod,n) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 741ca5886d..67cf5e4a6c 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -18,7 +18,7 @@ module MkId ( mkDataConIds, mkRecordSelId, - mkPrimOpId, mkFCallId, mkTickBoxOpId, + mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody, mkUnpackCase, mkProductBox, @@ -905,17 +905,28 @@ mkFCallId uniq fcall ty arity = length arg_tys strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes) -mkTickBoxOpId :: Unique - -> Module - -> TickBoxId - -> Id -mkTickBoxOpId uniq mod ix = mkGlobalId (TickBoxOpId tickbox) name ty info +-- Tick boxes and breakpoints are both represented as TickBoxOpIds, +-- except for the type: +-- +-- a plain HPC tick box has type (State# RealWorld) +-- a breakpoint Id has type forall a.a +-- +-- The breakpoint Id will be applied to a list of arbitrary free variables, +-- which is why it needs a polymorphic type. + +mkTickBoxOpId :: Unique -> Module -> TickBoxId -> Id +mkTickBoxOpId uniq mod ix = mkTickBox' uniq mod ix realWorldStatePrimTy + +mkBreakPointOpId :: Unique -> Module -> TickBoxId -> Id +mkBreakPointOpId uniq mod ix = mkTickBox' uniq mod ix ty + where ty = mkSigmaTy [openAlphaTyVar] [] openAlphaTy + +mkTickBox' uniq mod ix ty = mkGlobalId (TickBoxOpId tickbox) name ty info where tickbox = TickBox mod ix occ_str = showSDoc (braces (ppr tickbox)) name = mkTickBoxOpName uniq occ_str info = noCafIdInfo - ty = realWorldStatePrimTy \end{code} diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 72a57137c2..bd350722ff 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -607,6 +607,7 @@ stmtMacros = listToUFM [ ( FSLIT("RET_NN"), \[a,b] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]), ( FSLIT("RET_NP"), \[a,b] -> emitRetUT [(NonPtrArg,a),(PtrArg,b)]), ( FSLIT("RET_PPP"), \[a,b,c] -> emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]), + ( FSLIT("RET_NPP"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]), ( FSLIT("RET_NNP"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]), ( FSLIT("RET_NNNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]), ( FSLIT("RET_NPNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)]) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 64e65a4057..8624780231 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -1,5 +1,6 @@ % % (c) Galois, 2006 +% (c) University of Glasgow, 2007 % \section[Coverage]{@coverage@: the main function} @@ -20,7 +21,9 @@ import Bag import Var import Data.List import FastString +import StaticFlags +import Data.Array import System.Time (ClockTime(..)) import System.Directory (getModificationTime) import System.IO (FilePath) @@ -29,6 +32,9 @@ import Compat.Directory ( createDirectoryIfMissing ) #else import System.Directory ( createDirectoryIfMissing ) #endif + +import HscTypes +import BreakArray \end{code} %************************************************************************ @@ -38,15 +44,20 @@ import System.Directory ( createDirectoryIfMissing ) %************************************************************************ \begin{code} +addCoverageTicksToBinds + :: DynFlags + -> Module + -> ModLocation -- of the current module + -> LHsBinds Id + -> IO (LHsBinds Id, Int, ModBreaks) + addCoverageTicksToBinds dflags mod mod_loc binds = do let orig_file = case ml_hs_file mod_loc of Just file -> file Nothing -> panic "can not find the original file during hpc trans" - if "boot" `isSuffixOf` orig_file then return (binds, 0) else do - - modTime <- getModificationTime' orig_file + if "boot" `isSuffixOf` orig_file then return (binds, 0, emptyModBreaks) else do let mod_name = moduleNameString (moduleName mod) @@ -58,19 +69,32 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do , mixEntries = [] } - let hpc_dir = hpcDir dflags + let entries = reverse $ mixEntries st -- write the mix entries for this module - let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges. - - createDirectoryIfMissing True hpc_dir - - mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop $ reverse $ mixEntries st) + when opt_Hpc $ do + let hpc_dir = hpcDir dflags + let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges. + createDirectoryIfMissing True hpc_dir + modTime <- getModificationTime' orig_file + mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop entries) + + -- Todo: use proper src span type + breakArray <- newBreakArray $ length entries + let fn = mkFastString orig_file + let locsTicks = listArray (0,tickBoxCount st-1) + [ mkSrcSpan (mkSrcLoc fn r1 c1) (mkSrcLoc fn r2 c2) + | (P r1 c1 r2 c2, _box) <- entries ] + + let modBreaks = emptyModBreaks + { modBreaks_array = breakArray + , modBreaks_ticks = locsTicks + } doIfSet_dyn dflags Opt_D_dump_hpc $ do printDump (pprLHsBinds binds1) --- putStrLn (showSDocDebug (pprLHsBinds binds3)) - return (binds1, tickBoxCount st) + + return (binds1, tickBoxCount st, modBreaks) \end{code} @@ -87,20 +111,32 @@ addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do abs_binds' <- addTickLHsBinds abs_binds return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds' -addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do + +addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do let name = getOccString id decl_path <- getPathEntry - tick_no <- allocATickBox (if null decl_path - then TopLevelBox [name] - else LocalBox (name : decl_path)) - pos - - mg@(MatchGroup matches' ty) <- addPathEntry (getOccString id) + mg@(MatchGroup matches' ty) <- addPathEntry name $ addTickMatchGroup (fun_matches funBind) - return $ L pos $ funBind { fun_matches = MatchGroup matches' ty - , fun_tick = tick_no - } + + -- Todo: we don't want redundant ticks on simple pattern bindings + if not opt_Hpc && isSimplePatBind funBind + then + return $ L pos $ funBind { fun_matches = MatchGroup matches' ty + , fun_tick = Nothing + } + else do + tick_no <- allocATickBox (if null decl_path + then TopLevelBox [name] + else LocalBox (name : decl_path)) pos + + return $ L pos $ funBind { fun_matches = MatchGroup matches' ty + , fun_tick = tick_no + } + where + -- a binding is a simple pattern binding if it is a funbind with zero patterns + isSimplePatBind :: HsBind a -> Bool + isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 -- TODO: Revisit this addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do @@ -121,14 +157,47 @@ addTickLHsBind (VarBind var_id var_rhs) = do -} addTickLHsBind other = return other -addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExpr (L pos e0) = do +-- add a tick to the expression no matter what it is +addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprAlways (L pos e0) = do e1 <- addTickHsExpr e0 fn <- allocTickBox ExpBox pos return $ fn $ L pos e1 +-- always a breakpoint tick, maybe an HPC tick +addTickLHsExprBreakAlways :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprBreakAlways e + | opt_Hpc = addTickLHsExpr e + | otherwise = addTickLHsExprAlways e + +-- selectively add ticks to interesting expressions +addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExpr (L pos e0) = do + e1 <- addTickHsExpr e0 + if opt_Hpc || isGoodBreakExpr e0 + then do + fn <- allocTickBox ExpBox pos + return $ fn $ L pos e1 + else + return $ L pos e1 + +-- general heuristic: expressions which do not denote values are good break points +isGoodBreakExpr :: HsExpr Id -> Bool +isGoodBreakExpr (HsApp {}) = True +isGoodBreakExpr (OpApp {}) = True +isGoodBreakExpr (NegApp {}) = True +isGoodBreakExpr (HsCase {}) = True +isGoodBreakExpr (HsIf {}) = True +isGoodBreakExpr (RecordCon {}) = True +isGoodBreakExpr (RecordUpd {}) = True +isGoodBreakExpr (ArithSeq {}) = True +isGoodBreakExpr (PArrSeq {}) = True +isGoodBreakExpr other = False + addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExprOptAlt oneOfMany (L pos e0) = do +addTickLHsExprOptAlt oneOfMany (L pos e0) + | not opt_Hpc = addTickLHsExpr (L pos e0) + | otherwise = do e1 <- addTickHsExpr e0 fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos return $ fn $ L pos e1 @@ -145,7 +214,6 @@ addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) addBinTickLHsExpr boxLabel (L pos e0) = do e1 <- addTickHsExpr e0 allocBinTickBox boxLabel $ L pos e1 - addTickHsExpr :: HsExpr Id -> TM (HsExpr Id) addTickHsExpr e@(HsVar _) = return e @@ -162,7 +230,7 @@ addTickHsExpr (OpApp e1 e2 fix e3) = (addTickLHsExpr' e2) (return fix) (addTickLHsExpr e3) -addTickHsExpr ( NegApp e neg) = +addTickHsExpr (NegApp e neg) = liftM2 NegApp (addTickLHsExpr e) (addTickSyntaxExpr hpcSrcSpan neg) @@ -201,11 +269,11 @@ addTickHsExpr (HsDo cxt stmts last_exp srcloc) = addTickHsExpr (ExplicitList ty es) = liftM2 ExplicitList (return ty) - (mapM addTickLHsExpr es) + (mapM (addTickLHsExpr) es) addTickHsExpr (ExplicitPArr {}) = error "addTickHsExpr: ExplicitPArr" addTickHsExpr (ExplicitTuple es box) = liftM2 ExplicitTuple - (mapM addTickLHsExpr es) + (mapM (addTickLHsExpr) es) (return box) addTickHsExpr (RecordCon id ty rec_binds) = liftM3 RecordCon @@ -242,7 +310,7 @@ addTickHsExpr e@(HsSpliceE {}) = return e addTickHsExpr (HsProc pat cmdtop) = liftM2 HsProc (addTickLPat pat) - (liftL addTickHsCmdTop cmdtop) + (liftL (addTickHsCmdTop) cmdtop) addTickHsExpr (HsWrap w e) = liftM2 HsWrap (return w) @@ -258,7 +326,7 @@ addTickHsExpr (HsArrForm e fix cmdtop) = liftM3 HsArrForm (addTickLHsExpr e) (return fix) - (mapM (liftL addTickHsCmdTop) cmdtop) + (mapM (liftL (addTickHsCmdTop)) cmdtop) addTickHsExpr e@(HsType ty) = return e @@ -288,15 +356,15 @@ addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id) addTickGRHS isOneOfMany (GRHS stmts expr) = do stmts' <- mapM (liftL (addTickStmt (Just $ GuardBinBox))) stmts - expr' <- addTickLHsExprOptAlt isOneOfMany expr + expr' <- if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr + else addTickLHsExprAlways expr return $ GRHS stmts' expr' - addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id) addTickStmt isGuard (BindStmt pat e bind fail) = liftM4 BindStmt (addTickLPat pat) - (addTickLHsExpr e) + (addTickLHsExprBreakAlways e) (addTickSyntaxExpr hpcSrcSpan bind) (addTickSyntaxExpr hpcSrcSpan fail) addTickStmt isGuard (ExprStmt e bind' ty) = @@ -305,8 +373,8 @@ addTickStmt isGuard (ExprStmt e bind' ty) = (addTickSyntaxExpr hpcSrcSpan bind') (return ty) where - addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e - | otherwise = addTickLHsExpr e + addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e + | otherwise = addTickLHsExprBreakAlways e addTickStmt isGuard (LetStmt binds) = liftM LetStmt @@ -346,7 +414,7 @@ addTickHsValBinds (ValBindsOut binds sigs) = addTickHsIPBinds (IPBinds ipbinds dictbinds) = liftM2 IPBinds - (mapM (liftL addTickIPBind) ipbinds) + (mapM (liftL (addTickIPBind)) ipbinds) (addTickDictBinds dictbinds) addTickIPBind :: IPBind Id -> TM (IPBind Id) @@ -372,7 +440,7 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = (return ty) (return syntaxtable) -addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id) +addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id) addTickLHsCmd x = addTickLHsExpr x addTickDictBinds :: DictBinds Id -> TM (DictBinds Id) @@ -461,12 +529,18 @@ allocBinTickBox boxLabel (L pos e) | Just hpcPos <- mkHpcPos pos = TM $ \ st -> meE = (hpcPos,ExpBox) c = tickBoxCount st mes = mixEntries st - in ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e) - -- notice that F and T are reversed, - -- because we are building the list in - -- reverse... - , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes} - ) + in + if opt_Hpc + then ( L pos $ HsTick c $ L pos $ HsBinTick (c+1) (c+2) (L pos e) + -- notice that F and T are reversed, + -- because we are building the list in + -- reverse... + , st {tickBoxCount=c+3,mixEntries=meF:meT:meE:mes} + ) + else + ( L pos $ HsTick c $ L pos e + , st {tickBoxCount=c+1,mixEntries=meE:mes} + ) allocBinTickBox boxLabel e = return e diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 9da049d5e0..4b60768fc3 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -45,7 +45,6 @@ import Util import Coverage import IOEnv import Data.IORef - \end{code} %************************************************************************ @@ -85,28 +84,24 @@ deSugar hsc_env -- Desugar the program ; let export_set = availsToNameSet exports ; let auto_scc = mkAutoScc mod export_set - ; let noDbgSites = [] ; let target = hscTarget dflags ; mb_res <- case target of - HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, noDbgSites)) - _ -> do (binds_cvr,ds_hpc_info) - <- if opt_Hpc + HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks)) + _ -> do (binds_cvr,ds_hpc_info, modBreaks) + <- if opt_Hpc || target == HscInterpreted then addCoverageTicksToBinds dflags mod mod_loc binds - else return (binds, noHpcInfo) + else return (binds, noHpcInfo, emptyModBreaks) initDs hsc_env mod rdr_env type_env $ do { core_prs <- dsTopLHsBinds auto_scc binds_cvr ; (ds_fords, foreign_prs) <- dsForeigns fords ; let all_prs = foreign_prs ++ core_prs local_bndrs = mkVarSet (map fst all_prs) ; ds_rules <- mappM (dsRule mod local_bndrs) rules - ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info) - ; dbgSites_var <- getBkptSitesDs - ; dbgSites <- ioToIOEnv$ readIORef dbgSites_var - ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, dbgSites) + ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks) } ; case mb_res of { Nothing -> return Nothing ; - Just (all_prs, ds_rules, ds_fords,ds_hpc_info, dbgSites) -> do + Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var @@ -177,7 +172,7 @@ deSugar hsc_env mg_binds = ds_binds, mg_foreign = ds_fords, mg_hpc_info = ds_hpc_info, - mg_dbg_sites = dbgSites } + mg_modBreaks = modBreaks } ; return (Just mod_guts) }}} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index d974c0579f..51d6daf6ce 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -23,7 +23,6 @@ import {-# SOURCE #-} Match( matchWrapper ) import DsMonad import DsGRHSs import DsUtils -import DsBreakpoint import HsSyn -- lots of things import CoreSyn -- lots of things @@ -63,23 +62,7 @@ import Data.List \begin{code} dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)] -dsTopLHsBinds auto_scc binds = do - mb_mod_name_ref <- getModNameRefDs - debugging <- breakpoints_enabled - case mb_mod_name_ref of - Nothing | debugging -> do -- Inject a CAF with the module name as literal - mod <- getModuleDs - mod_name_ref <- do - u <- newUnique - let n = mkSystemName u (mkVarOcc "_module") - return (mkLocalId n stringTy) - let mod_name = moduleNameFS$ moduleName mod - mod_lit <- dsExpr (HsLit (HsString mod_name)) - withModNameRefDs mod_name_ref $ do - res <- ds_lhs_binds auto_scc binds - return$ (mod_name_ref, mod_lit) : res - _ -> ds_lhs_binds auto_scc binds - +dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)] dsLHsBinds binds = ds_lhs_binds NoSccs binds diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs deleted file mode 100644 index c6a090e230..0000000000 --- a/compiler/deSugar/DsBreakpoint.lhs +++ /dev/null @@ -1,217 +0,0 @@ ------------------------------------------------------------------------------ --- --- Support code for instrumentation and expansion of the breakpoint combinator --- --- Pepe Iborra (supported by Google SoC) 2006 --- ------------------------------------------------------------------------------ - -\begin{code} -module DsBreakpoint( debug_enabled - , dsAndThenMaybeInsertBreakpoint - , maybeInsertBreakpoint - , breakpoints_enabled - , mkBreakpointExpr - ) where - -import TysPrim -import TysWiredIn -import PrelNames -import Module -import SrcLoc -import TyCon -import TypeRep -import DataCon -import Type -import Id - -import IdInfo -import BasicTypes -import OccName - -import TcRnMonad -import HsSyn -import HsLit -import CoreSyn -import CoreUtils -import Outputable -import ErrUtils -import FastString -import DynFlags -import MkId - -import DsMonad -import {-#SOURCE#-}DsExpr ( dsLExpr ) -import Control.Monad -import Data.IORef -import Foreign.StablePtr -import GHC.Exts - -#ifdef GHCI -mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id) -mkBreakpointExpr loc bkptFuncId ty = do - scope <- getScope - mod <- getModuleDs - u <- newUnique - let valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc - when (not instrumenting) $ - warnDs (text "Extracted ids:" <+> (ppr scope $$ - ppr (map idType scope))) - stablePtr <- ioToIOEnv $ newStablePtr (valId:scope) - site <- if instrumenting - then recordBkpt (srcSpanStart loc) - else return 0 - ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName - jumpFuncId <- mkJumpFunc bkptFuncId - Just mod_name_ref <- getModNameRefDs - let [opaqueDataCon] = tyConDataCons opaqueTyCon - opaqueId = dataConWrapId opaqueDataCon - opaqueTy = mkTyConApp opaqueTyCon [] - wrapInOpaque id = - l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId))) - (l(HsVar id))) - -- Yes, I know... I'm gonna burn in hell. - Ptr addr# = castStablePtrToPtr stablePtr - locals = ExplicitList opaqueTy (map wrapInOpaque scope) - locInfo = nlTuple [ HsVar mod_name_ref - , HsLit (HsInt (fromIntegral site))] - funE = l$ HsVar jumpFuncId - ptrE = (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))) - locE = locInfo - msgE = srcSpanLit loc - argsE = nlTuple [ptrE, locals, msgE] - lazy_argsE = HsApp (l$ HsWrap (WpTyApp argsT) (HsVar lazyId)) (l argsE) - argsT = mkTupleType [intTy, mkListTy opaqueTy, stringTy] - return $ - l(l(funE `HsApp` l locE) `HsApp` l lazy_argsE) - - where l = L loc - nlTuple exps = ExplicitTuple (map noLoc exps) Boxed - srcSpanLit :: SrcSpan -> HsExpr Id - srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span)))) - instrumenting = idName bkptFuncId == breakpointAutoName - mkTupleType tys = mkTupleTy Boxed (length tys) tys -#else -mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints -#endif - -getScope :: DsM [Id] -getScope = getLocalBindsDs >>= return . filter(isValidType .idType ) - where isValidType (FunTy a b) = isValidType a && isValidType b - isValidType (NoteTy _ t) = isValidType t - isValidType (AppTy a b) = isValidType a && isValidType b - isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && - all isValidType ts --- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ? - isValidType _ = True - -dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id) -#ifdef DEBUG -dynBreakpoint loc | not (isGoodSrcSpan loc) = - pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc) -#endif -dynBreakpoint loc = do - let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName - breakpointAutoTy vanillaIdInfo - dflags <- getDOptsDs - ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc) - return$ L loc (HsVar autoBreakpoint) - where breakpointAutoTy = (ForAllTy alphaTyVar - (FunTy (TyVarTy alphaTyVar) - (TyVarTy alphaTyVar))) - --- Records a breakpoint site and returns the site number -recordBkpt :: SrcLoc -> DsM (Int) -recordBkpt loc = do - sites_var <- getBkptSitesDs - sites <- ioToIOEnv$ readIORef sites_var - let site = length sites + 1 - let coords = (srcLocLine loc, srcLocCol loc) - ioToIOEnv$ writeIORef sites_var ((site, coords) : sites) - return site - -mkJumpFunc :: Id -> DsM Id -mkJumpFunc bkptFuncId - | idName bkptFuncId == breakpointName - = build breakpointJumpName id - | idName bkptFuncId == breakpointCondName - = build breakpointCondJumpName (FunTy boolTy) - | idName bkptFuncId == breakpointAutoName - = build breakpointAutoJumpName id - where - tyvar = alphaTyVar - basicType extra opaqueTy = - (FunTy (mkTupleType [stringTy, intTy]) - (FunTy (mkTupleType [intTy, mkListTy opaqueTy, stringTy]) - (ForAllTy tyvar - (extra - (FunTy (TyVarTy tyvar) - (TyVarTy tyvar)))))) - build name extra = do - ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName - return$ Id.mkGlobalId VanillaGlobal name - (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo - mkTupleType tys = mkTupleTy Boxed (length tys) tys - -debug_enabled, breakpoints_enabled :: DsM Bool -dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr -maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id) - -#if defined(GHCI) && defined(DEBUGGER) -debug_enabled = do - debugging <- doptDs Opt_Debugging - b_enabled <- breakpoints_enabled - return (debugging && b_enabled) - -breakpoints_enabled = do - ghcMode <- getGhcModeDs - currentModule <- getModuleDs - dflags <- getDOptsDs - ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints - return ( not ignore_breakpoints - && hscTarget dflags == HscInterpreted - && currentModule /= iNTERACTIVE ) - -maybeInsertBreakpoint lhsexpr@(L loc _) ty = do - instrumenting <- isInstrumentationSpot lhsexpr - scope <- getScope - if instrumenting && not(isUnLiftedType ty) && - not(isEnabledNullScopeCoalescing && null scope) - then do L _ dynBkpt <- dynBreakpoint loc - return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr) - else return lhsexpr - where l = L loc -dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do - coreExpr <- dsLExpr expr - instrumenting <- isInstrumentationSpot expr - scope <- getScope - let ty = exprType coreExpr - if instrumenting && not (isUnLiftedType (exprType coreExpr)) && - not(isEnabledNullScopeCoalescing && null scope) - then do L _ dynBkpt<- dynBreakpoint loc - bkptCore <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt) - return (bkptCore `App` coreExpr) - else return coreExpr - where l = L loc -#else -maybeInsertBreakpoint expr _ = return expr -dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr -breakpoints_enabled = return False -debug_enabled = return False -#endif - - -isInstrumentationSpot (L loc e) = do - ghcmode <- getGhcModeDs - instrumenting <- debug_enabled - return$ instrumenting - && isGoodSrcSpan loc -- Avoids 'derived' code - && (not$ isRedundant e) - -isEnabledNullScopeCoalescing = True -isRedundant HsLet {} = True -isRedundant HsDo {} = True -isRedundant HsCase {} = False -isRedundant _ = False - -\end{code} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 982e315780..d09196d33b 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -22,11 +22,8 @@ import DsMonad #ifdef GHCI import PrelNames -import DsBreakpoint -- Template Haskell stuff iff bootstrapped import DsMeta -#else -import DsBreakpoint #endif import HsSyn @@ -52,8 +49,6 @@ import Util import Bag import Outputable import FastString - -import Data.Maybe \end{code} @@ -189,21 +184,6 @@ scrungleMatch var scrut body \begin{code} dsLExpr :: LHsExpr Id -> DsM CoreExpr -#if defined(GHCI) -dsLExpr (L loc expr@(HsWrap w (HsVar v))) - | idName v `elem` [breakpointName, breakpointCondName, breakpointAutoName] - , WpTyApp ty <- simpWrapper w - = do areBreakpointsEnabled <- breakpoints_enabled - if areBreakpointsEnabled - then do - L _ breakpointExpr <- mkBreakpointExpr loc v ty - dsLExpr (L loc $ HsWrap w breakpointExpr) - else putSrcSpanDs loc $ dsExpr expr - where simpWrapper (WpCompose w1 WpHole) = w1 - simpWrapper (WpCompose WpHole w1) = w1 - simpWrapper w = w -#endif - dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e dsExpr :: HsExpr Id -> DsM CoreExpr @@ -300,7 +280,7 @@ dsExpr (HsCase discrim matches) -- This is to avoid silliness in breakpoints dsExpr (HsLet binds body) = (bindLocalsDs (map unLoc $ collectLocalBinders binds) $ - dsAndThenMaybeInsertBreakpoint body) `thenDs` \ body' -> + dsLExpr body) `thenDs` \ body' -> dsLocalBinds binds body' -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) @@ -602,10 +582,10 @@ dsDo :: [LStmt Id] dsDo stmts body result_ty = go (map unLoc stmts) where - go [] = dsAndThenMaybeInsertBreakpoint body + go [] = dsLExpr body go (ExprStmt rhs then_expr _ : stmts) - = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs + = do { rhs2 <- dsLExpr rhs ; then_expr2 <- dsExpr then_expr ; rest <- go stmts ; returnDs (mkApps then_expr2 [rhs2, rest]) } @@ -625,7 +605,7 @@ dsDo stmts body result_ty ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat result_ty (cantFailMatchResult body) ; match_code <- handle_failure pat match fail_op - ; rhs' <- dsAndThenMaybeInsertBreakpoint rhs + ; rhs' <- dsLExpr rhs ; bind_op' <- dsExpr bind_op ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) } @@ -675,7 +655,7 @@ dsMDo tbl stmts body result_ty ; dsLocalBinds binds rest } go (ExprStmt rhs _ rhs_ty : stmts) - = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs + = do { rhs2 <- dsLExpr rhs ; rest <- go stmts ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) } @@ -688,7 +668,7 @@ dsMDo tbl stmts body result_ty ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg] ; match_code <- extractMatchResult match fail_expr - ; rhs' <- dsAndThenMaybeInsertBreakpoint rhs + ; rhs' <- dsLExpr rhs ; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, rhs', Lam var match_code]) } diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index 8f24239e15..31d48b6eca 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -21,7 +21,6 @@ import Type import DsMonad import DsUtils -import DsBreakpoint import Unique import PrelInfo import TysWiredIn @@ -73,8 +72,7 @@ dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = patsBinders = collectPatsBinders (map (L undefined) pats) dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs)) - = do rhs' <- maybeInsertBreakpoint rhs rhs_ty - matchGuards (map unLoc guards) hs_ctx rhs' rhs_ty + = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty \end{code} diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 9251a818ee..ac6a0c0ed7 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -23,7 +23,7 @@ module DsMonad ( DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, - bindLocalsDs, getLocalBindsDs, getBkptSitesDs, getModNameRefDs, withModNameRefDs, + bindLocalsDs, getLocalBindsDs, -- Warnings DsWarning, warnDs, failWithDs, @@ -57,7 +57,6 @@ import OccName import DynFlags import ErrUtils import Bag -import Breakpoints import OccName import Data.IORef @@ -136,17 +135,14 @@ data DsGblEnv = DsGblEnv { ds_mod :: Module, -- For SCC profiling ds_unqual :: PrintUnqualified, ds_msgs :: IORef Messages, -- Warning messages - ds_if_env :: (IfGblEnv, IfLclEnv), -- Used for looking up global, + ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things - ds_bkptSites :: IORef SiteMap -- Inserted Breakpoints sites } data DsLclEnv = DsLclEnv { ds_meta :: DsMetaEnv, -- Template Haskell bindings ds_loc :: SrcSpan, -- to put in pattern-matching error msgs - ds_locals :: OccEnv Id, -- For locals in breakpoints - ds_mod_name_ref :: Maybe Id -- The Id used to store the Module name - -- used by the breakpoint desugaring + ds_locals :: OccEnv Id -- For locals in breakpoints } -- Inside [| |] brackets, the desugarer looks @@ -209,12 +205,10 @@ mkDsEnvs mod rdr_env type_env msg_var gbl_env = DsGblEnv { ds_mod = mod, ds_if_env = (if_genv, if_lenv), ds_unqual = mkPrintUnqualified rdr_env, - ds_msgs = msg_var, - ds_bkptSites = sites_var} + ds_msgs = msg_var} lcl_env = DsLclEnv { ds_meta = emptyNameEnv, ds_loc = noSrcSpan, - ds_locals = emptyOccEnv, - ds_mod_name_ref = Nothing } + ds_locals = emptyOccEnv } return (gbl_env, lcl_env) @@ -340,21 +334,10 @@ dsExtendMetaEnv menv thing_inside getLocalBindsDs :: DsM [Id] getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) } -getModNameRefDs :: DsM (Maybe Id) -getModNameRefDs = do { env <- getLclEnv; return (ds_mod_name_ref env) } - -withModNameRefDs :: Id -> DsM a -> DsM a -withModNameRefDs id thing_inside = - updLclEnv (\env -> env {ds_mod_name_ref = Just id}) thing_inside - bindLocalsDs :: [Id] -> DsM a -> DsM a bindLocalsDs new_ids enclosed_scope = updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids}) enclosed_scope where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ] - -getBkptSitesDs :: DsM (IORef SiteMap) -getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) } - \end{code} diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 455db042f9..3c565674f2 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -69,6 +69,8 @@ import SrcLoc import Util import ListSetOps import FastString +import StaticFlags + import Data.Char infixl 4 `mkDsApp`, `mkDsApps` @@ -942,15 +944,22 @@ mkTickBox :: Int -> CoreExpr -> DsM CoreExpr mkTickBox ix e = do uq <- newUnique mod <- getModuleDs - let tick = mkTickBoxOpId uq mod ix + let tick | opt_Hpc = mkTickBoxOpId uq mod ix + | otherwise = mkBreakPointOpId uq mod ix uq2 <- newUnique let occName = mkVarOcc "tick" let name = mkInternalName uq2 occName noSrcLoc -- use mkSysLocal? let var = Id.mkLocalId name realWorldStatePrimTy - return $ Case (Var tick) - var - ty - [(DEFAULT,[],e)] + scrut <- + if opt_Hpc + then return (Var tick) + else do + locals <- getLocalBindsDs + let tickVar = Var tick + let tickType = mkFunTys (map idType locals) realWorldStatePrimTy + let scrutApTy = App tickVar (Type tickType) + return (mkApps scrutApTy (map Var locals) :: Expr Id) + return $ Case scrut var ty [(DEFAULT,[],e)] where ty = exprType e @@ -966,4 +975,4 @@ mkBinaryTickBox ixT ixF e = do [ (DataAlt falseDataCon, [], falseBox) , (DataAlt trueDataCon, [], trueBox) ] -\end{code}
\ No newline at end of file +\end{code} diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 28263f9f74..31cbd251cb 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -46,7 +46,7 @@ import Data.Bits import Data.Int ( Int64 ) import Data.Char ( ord ) -import GHC.Base ( ByteArray# ) +import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld ) import GHC.IOBase ( IO(..) ) import GHC.Ptr ( Ptr(..) ) @@ -71,13 +71,15 @@ data UnlinkedBCO unlinkedBCOInstrs :: ByteArray#, -- insns unlinkedBCOBitmap :: ByteArray#, -- bitmap unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs + unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs } data BCOPtr = BCOPtrName Name | BCOPtrPrimOp PrimOp | BCOPtrBCO UnlinkedBCO + | BCOPtrBreakInfo BreakInfo + | BCOPtrArray (MutableByteArray# RealWorld) data BCONPtr = BCONPtrWord Word @@ -158,8 +160,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced) bitmap_arr = mkBitmapArray bsize bitmap bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr - let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits - final_ptrs + let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive -- objects, since they might get run too early. Disable this until @@ -299,6 +300,11 @@ mkBits findLabel st proto_insns RETURN_UBX rep -> instr1 st (return_ubx rep) CCALL off m_addr -> do (np, st2) <- addr st m_addr instr3 st2 bci_CCALL off np + BRK_FUN array index info -> do + (p1, st2) <- ptr st (BCOPtrArray array) + (p2, st3) <- ptr st2 (BCOPtrBreakInfo info) + instr4 st3 bci_BRK_FUN p1 index p2 + PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3 i2s :: Int -> Word16 i2s = fromIntegral @@ -448,6 +454,7 @@ instrSize16s instr RETURN_UBX{} -> 1 CCALL{} -> 3 SWIZZLE{} -> 3 + BRK_FUN{} -> 4 -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 72586abc55..ca66250c8b 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -49,7 +49,7 @@ import Constants import Data.List ( intersperse, sortBy, zip4, zip6, partition ) import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8, - withForeignPtr, castFunPtrToPtr ) + withForeignPtr, castFunPtrToPtr, nullPtr, plusPtr ) import Foreign.C import Control.Exception ( throwDyn ) @@ -58,21 +58,29 @@ import GHC.Exts ( Int(..), ByteArray# ) import Control.Monad ( when ) import Data.Char ( ord, chr ) +import UniqSupply +import BreakArray +import Data.Maybe +import Module +import IdInfo + -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module byteCodeGen :: DynFlags -> [CoreBind] -> [TyCon] + -> ModBreaks -> IO CompiledByteCode -byteCodeGen dflags binds tycs +byteCodeGen dflags binds tycs modBreaks = do showPass dflags "ByteCodeGen" let flatBinds = [ (bndr, freeVars rhs) | (bndr, rhs) <- flattenBinds binds] - (BcM_State final_ctr mallocd, proto_bcos) - <- runBc (mapM schemeTopBind flatBinds) + us <- mkSplitUniqSupply 'y' + (BcM_State _us final_ctr mallocd _, proto_bcos) + <- runBc us modBreaks (mapM schemeTopBind flatBinds) when (notNull mallocd) (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") @@ -98,8 +106,11 @@ coreExprToBCOs dflags expr let invented_name = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel") invented_id = Id.mkLocalId invented_name (panic "invented_id's type") - (BcM_State final_ctr mallocd, proto_bco) - <- runBc (schemeTopBind (invented_id, freeVars expr)) + -- the uniques are needed to generate fresh variables when we introduce new + -- let bindings for ticked expressions + us <- mkSplitUniqSupply 'y' + (BcM_State _us final_ctr mallocd _ , proto_bco) + <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr)) when (notNull mallocd) (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") @@ -141,8 +152,7 @@ mkProtoBCO -> Bool -- True <=> is a return point, rather than a function -> [BcPtr] -> ProtoBCO name -mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap - is_ret mallocd_blocks +mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks = ProtoBCO { protoBCOName = nm, protoBCOInstrs = maybe_with_stack_check, @@ -199,22 +209,24 @@ argBits (rep : args) schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) -schemeTopBind (id, rhs) +schemeTopBind (id, rhs) | Just data_con <- isDataConWorkId_maybe id, - isNullaryRepDataCon data_con - = -- Special case for the worker of a nullary data con. + isNullaryRepDataCon data_con = do + -- Special case for the worker of a nullary data con. -- It'll look like this: Nil = /\a -> Nil a -- If we feed it into schemeR, we'll get -- Nil = Nil -- because mkConAppCode treats nullary constructor applications -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. + -- ioToBc (putStrLn $ "top level BCO") emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER]) - (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise = schemeR [{- No free variables -}] (id, rhs) + -- ----------------------------------------------------------------------------- -- schemeR @@ -232,7 +244,7 @@ schemeR :: [Id] -- Free vars of the RHS, ordered as they -- top-level things, which have no free vars. -> (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) -schemeR fvs (nm, rhs) +schemeR fvs (nm, rhs) {- | trace (showSDoc ( (char ' ' @@ -245,11 +257,13 @@ schemeR fvs (nm, rhs) -} = schemeR_wrk fvs nm rhs (collect [] rhs) +collect :: [Var] -> AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet) collect xs (_, AnnNote note e) = collect xs e collect xs (_, AnnCast e _) = collect xs e collect xs (_, AnnLam x e) = collect (if isTyVar x then xs else (x:xs)) e collect xs (_, not_lambda) = (reverse xs, not_lambda) +schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) = let all_args = reverse args ++ fvs @@ -267,10 +281,36 @@ schemeR_wrk fvs nm original_body (args, body) bitmap_size = length bits bitmap = mkBitmap bits in do - body_code <- schemeE szw_args 0 p_init body + body_code <- schemeER_wrk szw_args p_init body + emitBc (mkProtoBCO (getName nm) body_code (Right original_body) arity bitmap_size bitmap False{-not alts-}) +-- introduce break instructions for ticked expressions +schemeER_wrk :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList +schemeER_wrk d p rhs + | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do + code <- schemeE d 0 p newRhs + arr <- getBreakArray + let idOffSets = getVarOffSets d p tickInfo + let tickNumber = tickInfo_number tickInfo + let breakInfo = BreakInfo + { breakInfo_module = tickInfo_module tickInfo + , breakInfo_number = tickNumber + , breakInfo_vars = idOffSets + } + let breakInstr = case arr of (BA arr#) -> BRK_FUN arr# tickNumber breakInfo + return $ breakInstr `consOL` code + | otherwise = schemeE d 0 p rhs + +getVarOffSets :: Int -> BCEnv -> TickInfo -> [(Id, Int)] +getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals + +getOffSet :: Int -> BCEnv -> Id -> Maybe (Id, Int) +getOffSet d env id + = case lookupBCEnv_maybe env id of + Nothing -> Nothing + Just offset -> Just (id, d - offset) fvsToEnv :: BCEnv -> VarSet -> [Id] -- Takes the free variables of a right-hand side, and @@ -288,6 +328,18 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs, -- ----------------------------------------------------------------------------- -- schemeE +data TickInfo + = TickInfo + { tickInfo_number :: Int -- the (module) unique number of the tick + , tickInfo_module :: Module -- the origin of the ticked expression + , tickInfo_locals :: [Id] -- the local vars in scope at the ticked expression + } + +instance Outputable TickInfo where + ppr info = text "TickInfo" <+> + parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+> + ppr (tickInfo_locals info)) + -- Compile code to apply the given expression to the remaining args -- on the stack, returning a HNF. schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList @@ -382,7 +434,18 @@ schemeE d s p (AnnLet binds (_,body)) thunk_codes <- sequence compile_binds return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) - +-- introduce a let binding for a ticked case expression. This rule *should* only fire when the +-- expression was not already let-bound (the code gen for let bindings should take care of that). +-- Todo: we call exprFreeVars on a deAnnotated expression, this may not be the best way +-- to calculate the free vars but it seemed like the least intrusive thing to do +schemeE d s p exp@(AnnCase {}) + | Just (tickInfo, _exp) <- isTickedExp' exp = do + let fvs = exprFreeVars $ deAnnotate' exp + let ty = exprType $ deAnnotate' exp + id <- newId ty + -- Todo: is emptyVarSet correct on the next line? + let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id) + schemeE d s p letExp schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) @@ -396,11 +459,11 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) -- envt (it won't be bound now) because we never look such things up. = --trace "automagic mashing of case alts (# VoidArg, a #)" $ - doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2) = --trace "automagic mashing of case alts (# a, VoidArg #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc @@ -409,10 +472,10 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) -- to -- case .... of a { DEFAULT -> ... } = --trace "automagic mashing of case alts (# a #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut bndr _ alts) - = doCase d s p scrut bndr alts False{-not an unboxed tuple-} + = doCase d s p scrut bndr alts False{-not an unboxed tuple-} schemeE d s p (AnnNote note (_, body)) = schemeE d s p body @@ -424,6 +487,56 @@ schemeE d s p other = pprPanic "ByteCodeGen.schemeE: unhandled case" (pprCoreExpr (deAnnotate' other)) +{- + Ticked Expressions + ------------------ + + A ticked expression looks like this: + + case tick<n> var1 ... varN of DEFAULT -> e + + (*) <n> is the number of the tick, which is unique within a module + (*) var1 ... varN are the local variables in scope at the tick site + + If we find a ticked expression we return: + + Just ((n, [var1 ... varN]), e) + + otherwise we return Nothing. + + The idea is that the "case tick<n> ..." is really just an annotation on + the code. When we find such a thing, we pull out the useful information, + and then compile the code as if it was just the expression "e". + +-} + +isTickedExp :: AnnExpr Id a -> Maybe (TickInfo, AnnExpr Id a) +isTickedExp (annot, expr) = isTickedExp' expr + +isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a) +isTickedExp' (AnnCase scrut _bndr _type alts) + | Just tickInfo <- isTickedScrut scrut, + [(DEFAULT, _bndr, rhs)] <- alts + = Just (tickInfo, rhs) + where + isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo + isTickedScrut expr + | Var id <- f, + Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id + = Just $ TickInfo { tickInfo_number = tickNumber + , tickInfo_module = modName + , tickInfo_locals = idsOfArgs args + } + | otherwise = Nothing + where + (f, args) = collectArgs $ deAnnotate expr + idsOfArgs :: [Expr Id] -> [Id] + idsOfArgs = catMaybes . map exprId + exprId :: Expr Id -> Maybe Id + exprId (Var id) = Just id + exprId other = Nothing + +isTickedExp' other = Nothing -- Compile code to do a tail call. Specifically, push the fn, -- slide the on-stack app back down to the sequel depth, @@ -640,8 +753,7 @@ doCase :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet] -> Bool -- True <=> is an unboxed tuple case, don't enter the result -> BcM BCInstrList -doCase d s p (_,scrut) - bndr alts is_unboxed_tuple +doCase d s p (_,scrut) bndr alts is_unboxed_tuple = let -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. @@ -670,9 +782,10 @@ doCase d s p (_,scrut) isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple -- given an alt, return a discr and code for it. - codeALt alt@(DEFAULT, _, (_,rhs)) + codeAlt alt@(DEFAULT, _, (_,rhs)) = do rhs_code <- schemeE d_alts s p_alts rhs return (NoDiscr, rhs_code) + codeAlt alt@(discr, bndrs, (_,rhs)) -- primitive or nullary constructor alt: no need to UNPACK | null real_bndrs = do @@ -696,7 +809,6 @@ doCase d s p (_,scrut) where real_bndrs = filter (not.isTyVar) bndrs - my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-} my_discr (DataAlt dc, binds, rhs) | isUnboxedTupleCon dc @@ -745,6 +857,7 @@ doCase d s p (_,scrut) in do alt_stuff <- mapM codeAlt alts alt_final <- mkMultiBranch maybe_ncons alt_stuff + let alt_bco_name = getName bndr alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts) @@ -1315,9 +1428,12 @@ type BcPtr = Either ItblPtr (Ptr ()) data BcM_State = BcM_State { + uniqSupply :: UniqSupply, -- for generating fresh variable names nextlabel :: Int, -- for generating local labels - malloced :: [BcPtr] } -- thunks malloced for current BCO + malloced :: [BcPtr], -- thunks malloced for current BCO -- Should be free()d when it is GCd + breakArray :: BreakArray -- array of breakpoint flags + } newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) @@ -1326,8 +1442,11 @@ ioToBc io = BcM $ \st -> do x <- io return (st, x) -runBc :: BcM r -> IO (BcM_State, r) -runBc (BcM m) = m (BcM_State 0 []) +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 thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do @@ -1370,4 +1489,18 @@ getLabelsBc :: Int -> BcM [Int] getLabelsBc n = BcM $ \st -> let ctr = nextlabel st in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) + +getBreakArray :: BcM BreakArray +getBreakArray = BcM $ \st -> return (st, breakArray st) + +newUnique :: BcM Unique +newUnique = BcM $ + \st -> case splitUniqSupply (uniqSupply st) of + (us1, us2) -> let newState = st { uniqSupply = us2 } + in return (newState, uniqFromSupply us1) + +newId :: Type -> BcM Id +newId ty = do + uniq <- newUnique + return $ mkSysLocal FSLIT("ticked") uniq ty \end{code} diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index 5239139eb2..3f57d187dc 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -5,7 +5,7 @@ ByteCodeInstrs: Bytecode instruction definitions \begin{code} module ByteCodeInstr ( - BCInstr(..), ProtoBCO(..), bciStackUse + BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..) ) where #include "HsVersions.h" @@ -26,6 +26,10 @@ import SMRep import GHC.Ptr +import Module (Module) +import GHC.Prim + + -- ---------------------------------------------------------------------------- -- Bytecode instructions @@ -129,6 +133,22 @@ data BCInstr | RETURN -- return a lifted value | RETURN_UBX CgRep -- return an unlifted value, here's its rep + -- Breakpoints + | BRK_FUN (MutableByteArray# RealWorld) Int BreakInfo + +data BreakInfo + = BreakInfo + { breakInfo_module :: Module + , breakInfo_number :: Int + , breakInfo_vars :: [(Id,Int)] + } + +instance Outputable BreakInfo where + ppr info = text "BreakInfo" <+> + parens (ppr (breakInfo_module info) <+> + ppr (breakInfo_number info) <+> + ppr (breakInfo_vars info)) + -- ----------------------------------------------------------------------------- -- Printing bytecode instructions @@ -196,6 +216,7 @@ instance Outputable BCInstr where ppr ENTER = text "ENTER" ppr RETURN = text "RETURN" ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk + ppr (BRK_FUN breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> int index <+> ppr info -- ----------------------------------------------------------------------------- -- The stack use, in words, of each bytecode insn. These _must_ be @@ -251,6 +272,7 @@ bciStackUse RETURN{} = 0 bciStackUse RETURN_UBX{} = 1 bciStackUse CCALL{} = 0 bciStackUse SWIZZLE{} = 0 +bciStackUse BRK_FUN{} = 0 -- These insns actually reduce stack use, but we need the high-tide level, -- so can't use this info. Not that it matters much. diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 2973c03e47..9b2dac0618 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -22,6 +22,7 @@ import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE ) import CgHeapery ( mkVirtHeapOffsets ) import FastString ( FastString(..) ) import Util ( lengthIs, listLengthCmp ) +import Outputable import Foreign import Foreign.C @@ -32,7 +33,8 @@ import GHC.Exts ( Int(I#), addr2Int# ) import GHC.Ptr ( Ptr(..) ) import GHC.Prim -import Outputable +import Debug.Trace +import Text.Printf \end{code} %************************************************************************ @@ -48,9 +50,12 @@ itblCode :: ItblPtr -> Ptr () itblCode (ItblPtr ptr) = (castPtr ptr) #ifdef GHCI_TABLES_NEXT_TO_CODE - `plusPtr` (3 * wORD_SIZE) + `plusPtr` conInfoTableSizeB #endif +-- XXX bogus +conInfoTableSizeB = 3 * wORD_SIZE + type ItblEnv = NameEnv (Name, ItblPtr) -- We need the Name in the range so we know which -- elements to filter out when unloading a module @@ -290,7 +295,7 @@ instance Storable StgConInfoTable where StgConInfoTable { #ifdef GHCI_TABLES_NEXT_TO_CODE - conDesc = castPtr $ ptr `plusPtr` wORD_SIZE `plusPtr` desc + conDesc = castPtr $ ptr `plusPtr` conInfoTableSizeB `plusPtr` desc #else conDesc = desc #endif @@ -299,7 +304,7 @@ instance Storable StgConInfoTable where poke ptr itbl = runState (castPtr ptr) $ do #ifdef GHCI_TABLES_NEXT_TO_CODE - store (conDesc itbl `minusPtr` (ptr `plusPtr` wORD_SIZE)) + store (conDesc itbl `minusPtr` (ptr `plusPtr` conInfoTableSizeB)) #endif store (infoTable itbl) #ifndef GHCI_TABLES_NEXT_TO_CODE diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 9988325dd3..7304d0290b 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -27,7 +27,6 @@ import Module import PackageConfig import FastString import Panic -import Breakpoints #ifdef DEBUG import Outputable @@ -47,7 +46,7 @@ import GHC.Exts import GHC.Arr ( Array(..) ) import GHC.IOBase ( IO(..) ) import GHC.Ptr ( Ptr(..), castPtr ) -import GHC.Base ( writeArray#, RealWorld, Int(..) ) +import GHC.Base ( writeArray#, RealWorld, Int(..), Word# ) \end{code} @@ -143,6 +142,10 @@ mkPtrsArray ie ce n_ptrs ptrs = do fill (BCOPtrBCO ul_bco) i = do BCO bco# <- linkBCO' ie ce ul_bco writeArrayBCO marr i bco# + fill (BCOPtrBreakInfo brkInfo) i = + unsafeWrite marr i (unsafeCoerce# brkInfo) + fill (BCOPtrArray brkArray) i = + unsafeWrite marr i (unsafeCoerce# brkArray) zipWithM fill ptrs [0..] unsafeFreeze marr @@ -163,10 +166,16 @@ writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# -> case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# -> (# s#, () #) } +{- +writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO () +writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# -> + case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# -> + (# s#, () #) } +-} + data BCO = BCO BCO# -newBCO :: ByteArray# -> ByteArray# -> Array# a - -> Int# -> ByteArray# -> IO BCO +newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO newBCO instrs lits ptrs arity bitmap = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of (# s1, bco #) -> (# s1, BCO bco #) @@ -201,8 +210,6 @@ lookupName :: ClosureEnv -> Name -> IO HValue lookupName ce nm = case lookupNameEnv ce nm of Just (_,aa) -> return aa - Nothing | Just bk <- lookupBogusBreakpointVal nm - -> return bk Nothing -> ASSERT2(isExternalName nm, ppr nm) do let sym_to_find = nameToCLabel nm "closure" diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index a43d4fdf95..f0f8973033 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -6,10 +6,9 @@ -- ----------------------------------------------------------------------------- -module Debugger where +module Debugger (pprintClosureCommand, instantiateTyVarsToUnknown) where import Linker -import Breakpoints import RtClosureInspect import PrelNames @@ -22,8 +21,6 @@ import VarEnv import Name import NameEnv import RdrName -import Module -import Finder import UniqSupply import Type import TyCon @@ -31,23 +28,15 @@ import DataCon import TcGadt import GHC import GhciMonad -import PackageConfig import Outputable import Pretty ( Mode(..), showDocWith ) -import ErrUtils import FastString import SrcLoc -import Util -import Maybes import Control.Exception import Control.Monad -import qualified Data.Map as Map -import Data.Array.Unboxed -import Data.Array.Base import Data.List -import Data.Typeable ( Typeable ) import Data.Maybe import Data.IORef @@ -300,288 +289,3 @@ stripUnknowns names id = setIdType id . fst . go names . idType kind1 = mkArrowKind liftedTypeKind liftedTypeKind kind2 = mkArrowKind kind1 liftedTypeKind kind3 = mkArrowKind kind2 liftedTypeKind - ------------------------------ --- | The :breakpoint command ------------------------------ -bkptOptions :: String -> GHCi Bool -bkptOptions "continue" = -- We want to quit if in an inferior session - liftM not isTopLevel -bkptOptions "stop" = do - inside_break <- liftM not isTopLevel - when inside_break $ throwDyn StopChildSession - return False - -bkptOptions cmd = do - dflags <- getDynFlags - bt <- getBkptTable - sess <- getSession - bkptOptions' sess (words cmd) bt - return False - where - bkptOptions' _ ["list"] bt = do - let msgs = [ ppr mod <+> colon <+> ppr coords - | (mod,site) <- btList bt - , let coords = getSiteCoords bt mod site] - num_msgs = [parens (int n) <+> msg | (n,msg) <- zip [1..] msgs] - msg <- showForUser$ if null num_msgs - then text "There are no enabled breakpoints" - else vcat num_msgs - io$ putStrLn msg - - bkptOptions' s ("add":cmds) bt - | [line] <- cmds - , [(lineNum,[])] <- reads line - = do (toplevel,_) <- io$ GHC.getContext s - case toplevel of - (m:_) -> handleAdd (\mod->addBkptByLine mod lineNum) m - [] -> throwDyn $ CmdLineError $ "No module loaded in debugging mode" - - | [mod_name,line]<- cmds - , [(lineNum,[])] <- reads line - = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>= - handleAdd (\mod->addBkptByLine mod lineNum) - - | [mod_name,line,col] <- cmds - = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>= - handleAdd (\mod->addBkptByCoord mod (read line, read col)) - - | otherwise = throwDyn $ CmdLineError $ - "syntax: :breakpoint add Module line [col]" - where - handleAdd f mod = - either - (handleBkptEx s mod) - (\(newTable, site) -> do - setBkptTable newTable - let (x,y) = getSiteCoords newTable mod site - io (putStrLn ("Breakpoint set at " ++ showSDoc (ppr mod) - ++ ':' : show x ++ ':' : show y))) - (f mod bt) - - bkptOptions' s ("del":cmds) bt - | [i'] <- cmds - , [(i,[])] <- reads i' - , bkpts <- btList bt - = if i > length bkpts - then throwDyn $ CmdLineError - "Not a valid breakpoint #. Use :breakpoint list to see the current breakpoints." - else - let (mod, site) = bkpts !! (i-1) - in handleDel mod $ delBkptBySite mod site - - | [fn,line] <- cmds - , [(lineNum,[])] <- reads line - , mod <- GHC.mkModule mainPackageId (GHC.mkModuleName fn) - = handleDel mod $ delBkptByLine mod lineNum - - | [fn,line,col] <- cmds - , [(lineNum,[])] <- reads line - , [(colNum,[])] <- reads col - , mod <- GHC.mkModule mainPackageId (GHC.mkModuleName fn) - = handleDel mod $ delBkptByCoord mod (lineNum, colNum) - - | otherwise = throwDyn $ CmdLineError $ - "syntax: :breakpoint del (breakpoint # | [Module] line [col])" - - where delMsg = "Breakpoint deleted" - handleDel mod f = either (handleBkptEx s mod) - (\newtable-> setBkptTable newtable >> io (putStrLn delMsg)) - (f bt) - - bkptOptions' _ _ _ = throwDyn $ CmdLineError $ - "syntax: :breakpoint (list|continue|stop|add|del)" - --- Error messages --- handleBkptEx :: Session -> Module -> Debugger.BkptException -> a - handleBkptEx s m NotHandled = io$ do - isInterpreted <- findModSummary m >>= isModuleInterpreted s - if isInterpreted - then error$ "Module " ++ showSDoc (ppr m) ++ " was not loaded under debugging mode.\n" - ++ "Enable debugging mode with -fdebugging (and reload your module)" - else error$ "Module " ++ showSDoc (ppr m) ++ " was loaded in compiled (.o) mode.\n" - ++ "You must load a module in interpreted mode and with -fdebugging on to debug it." - where findModSummary m = do - mod_graph <- getModuleGraph s - return$ head [ modsum | modsum <- mod_graph, ms_mod modsum == m] - handleBkptEx _ _ e = error (show e) - -------------------------- --- Breakpoint Tables -------------------------- - -data BkptTable a = BkptTable { - -- | An array of breaks, indexed by site number - breakpoints :: Map.Map a (UArray Int Bool) - -- | A list of lines, each line can have zero or more sites, which are annotated with a column number - , sites :: Map.Map a [[(SiteNumber, Int)]] - } - deriving Show - -sitesOf :: Ord a => BkptTable a -> a -> Maybe [[(SiteNumber, Int)]] -sitesOf bt fn = Map.lookup fn (sites bt) -bkptsOf bt fn = Map.lookup fn (breakpoints bt) - - -data BkptError = - NotHandled -- Trying to manipulate a element not handled by this BkptTable - | NoBkptFound - | NotNeeded -- Used when a breakpoint was already enabled - deriving Typeable - -instance Show BkptError where - show NoBkptFound = "No suitable breakpoint site found" - show NotNeeded = "Nothing to do" - show NotHandled = "BkptTable: Element not controlled by this table" - -emptyBkptTable :: Ord a => BkptTable a -addModule :: Ord a => a -> [(SiteNumber,Coord)] -> BkptTable a -> BkptTable a --- | Lines start at index 1 -addBkptByLine :: Ord a => a -> Int -> BkptTable a -> Either BkptError (BkptTable a, SiteNumber) -addBkptByCoord :: Ord a => a -> Coord -> BkptTable a -> Either BkptError (BkptTable a, SiteNumber) -delBkptByLine :: Ord a => a -> Int -> BkptTable a -> Either BkptError (BkptTable a) -delBkptBySite :: Ord a => a -> SiteNumber -> BkptTable a -> Either BkptError (BkptTable a) -delBkptByCoord :: Ord a => a -> Coord -> BkptTable a -> Either BkptError (BkptTable a) - -isBkptEnabled :: Ord a => BkptTable a -> BkptLocation a -> Bool -btElems :: Ord a => BkptTable a -> [(a, [SiteNumber])] -btList :: Ord a => BkptTable a -> [BkptLocation a] -sitesList :: Ord a => BkptTable a -> [(a, [Coord])] -getSiteCoords :: Ord a => BkptTable a -> a -> SiteNumber -> Coord - -emptyBkptTable = BkptTable Map.empty Map.empty - -addBkptByLine a i bt - | Just lines <- sitesOf bt a - , Just bkptsArr <- bkptsOf bt a - , i < length lines - = case [line | line <- drop i lines, not (null line)] of - ((x:_):_) -> let (siteNum,col) = x - wasAlreadyOn = bkptsArr ! siteNum - newArr = bkptsArr // [(siteNum, True)] - newTable = Map.insert a newArr (breakpoints bt) - in if wasAlreadyOn - then Left NotNeeded - else Right (bt{breakpoints=newTable}, siteNum) - otherwise -> Left NoBkptFound - - | Just sites <- sitesOf bt a - = Left NoBkptFound - | otherwise = Left NotHandled - -addBkptByCoord a (r,c) bt - | Just lines <- sitesOf bt a - , Just bkptsArr <- bkptsOf bt a - , r < length lines - = case [ (sn,col) | (sn,col)<-lines!!r, col>=c] of - [] -> Left NoBkptFound - (x:_) -> let (siteNum, col) = x - wasAlreadyOn = bkptsArr ! siteNum - newArr = bkptsArr // [(siteNum, True)] - newTable = Map.insert a newArr (breakpoints bt) - in if wasAlreadyOn - then Left NotNeeded - else Right (bt{breakpoints=newTable}, siteNum) - - | Just sites <- sitesOf bt a - = Left NoBkptFound - | otherwise = Left NotHandled - -delBkptBySite a i bt - | Just bkptsArr <- bkptsOf bt a - , not (inRange (bounds bkptsArr) i) - = Left NoBkptFound - - | Just bkptsArr <- bkptsOf bt a - , bkptsArr ! i -- Check that there was a enabled bkpt here - , newArr <- bkptsArr // [(i,False)] - , newTable <- Map.insert a newArr (breakpoints bt) - = Right bt {breakpoints=newTable} - - | Just sites <- sitesOf bt a - = Left NotNeeded - - | otherwise = Left NotHandled - -delBkptByLine a l bt - | Just sites <- sitesOf bt a - , (site:_) <- [s | (s,c') <- sites !! l] - = delBkptBySite a site bt - - | Just sites <- sitesOf bt a - = Left NoBkptFound - - | otherwise = Left NotHandled - -delBkptByCoord a (r,c) bt - | Just sites <- sitesOf bt a - , (site:_) <- [s | (s,c') <- sites !! r, c>=c', isBkptEnabled bt (a,s)] - = delBkptBySite a site bt - - | Just sites <- sitesOf bt a - = Left NoBkptFound - - | otherwise = Left NotHandled - -btElems bt = [ (a, [i | (i,True) <- assocs siteArr]) - | (a, siteArr) <- Map.assocs (breakpoints bt) ] - -btList bt = [(a,site) | (a, sites) <- btElems bt, site <- sites] - -sitesList bt = [ (a, sitesCoords sitesCols) | (a, sitesCols) <- Map.assocs (sites bt) ] - where sitesCoords sitesCols = - [ (row,col) - | (row, cols) <- zip [0..] sitesCols, (_,col) <- cols ] - -getSiteCoords bt a site - | Just rows <- sitesOf bt a - = head [ (r,c) | (r,row) <- zip [0..] rows - , (s,c) <- row - , s == site ] - --- addModule is dumb and inefficient, but it does the job -addModule a [] bt = bt {sites = Map.insert a [] (sites bt)} -addModule a siteCoords bt - | nrows <- maximum$ [i | (_,(i,j)) <- siteCoords ] - , sitesByRow <- [ [(s,c) | (s,(r,c)) <- siteCoords, r==i] - | i <- [0..nrows] ] - , nsites <- length siteCoords - , initialBkpts <- listArray (0, nsites+1) (repeat False) - = bt{ sites = Map.insert a sitesByRow (sites bt) - , breakpoints = Map.insert a initialBkpts (breakpoints bt) } - --- This MUST be fast -isBkptEnabled bt site | bt `seq` site `seq` False = undefined -isBkptEnabled bt (a,site) - | Just bkpts <- bkptsOf bt a - = ASSERT (inRange (bounds bkpts) site) - unsafeAt bkpts site - ------------------ --- Other stuff ------------------ -refreshBkptTable :: Session -> BkptTable Module -> [ModSummary] -> IO (BkptTable Module) -refreshBkptTable sess = foldM updIfDebugging - where - updIfDebugging bt ms = do - isDebugging <- isDebuggingM ms - if isDebugging - then addModuleGHC sess bt (GHC.ms_mod ms) - else return bt - addModuleGHC sess bt mod = do - Just mod_info <- GHC.getModuleInfo sess mod - dflags <- GHC.getSessionDynFlags sess - let sites = GHC.modInfoBkptSites mod_info - debugTraceMsg dflags 2 - (ppr mod <> text ": inserted " <> int (length sites) <> - text " breakpoints") - return$ addModule mod sites bt -#if defined(GHCI) && defined(DEBUGGER) - isDebuggingM ms = isModuleInterpreted sess ms >>= \isInterpreted -> - return (Opt_Debugging `elem` dflags && - target == HscInterpreted && isInterpreted) - where dflags = flags (GHC.ms_hspp_opts ms) - target = hscTarget (GHC.ms_hspp_opts ms) -#else - isDebuggingM _ = return False -#endif diff --git a/compiler/ghci/Debugger.hs-boot b/compiler/ghci/Debugger.hs-boot deleted file mode 100644 index d310308683..0000000000 --- a/compiler/ghci/Debugger.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module Debugger where -import Breakpoints -import qualified Data.Map as Map -import Data.Array.Unboxed - - -data BkptTable a = BkptTable { - -- | An array of breaks, indexed by site number - breakpoints :: Map.Map a (UArray Int Bool) - -- | A list of lines, each line can have zero or more sites, which are annotated with a column number - , sites :: Map.Map a [[(SiteNumber, Int)]] - } diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index eaea844991..3cab56b40c 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -11,12 +11,12 @@ module GhciMonad where #include "HsVersions.h" import qualified GHC -import {-#SOURCE#-} Debugger -import Breakpoints import Outputable import Panic hiding (showException) import Util import DynFlags +import HscTypes +import SrcLoc import Numeric import Control.Exception as Exception @@ -43,8 +43,9 @@ data GHCiState = GHCiState session :: GHC.Session, options :: [GHCiOption], prelude :: GHC.Module, - bkptTable :: IORef (BkptTable GHC.Module), - topLevel :: Bool + topLevel :: Bool, + resume :: [IO GHC.RunResult], + breaks :: !ActiveBreakPoints } data GHCiOption @@ -53,6 +54,73 @@ data GHCiOption | RevertCAFs -- revert CAFs after every evaluation deriving Eq +data ActiveBreakPoints + = ActiveBreakPoints + { breakCounter :: !Int + , breakLocations :: ![(Int, BreakLocation)] -- break location uniquely numbered + } + +instance Outputable ActiveBreakPoints where + ppr activeBrks = prettyLocations $ breakLocations activeBrks + +emptyActiveBreakPoints :: ActiveBreakPoints +emptyActiveBreakPoints + = ActiveBreakPoints { breakCounter = 0, breakLocations = [] } + +data BreakLocation + = BreakLocation + { breakModule :: !GHC.Module + , breakLoc :: !SrcSpan + , breakTick :: {-# UNPACK #-} !Int + } + deriving Eq + +prettyLocations :: [(Int, BreakLocation)] -> SDoc +prettyLocations [] = text "No active breakpoints." +prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs + +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? +clearActiveBreakPoints :: GHCi () +clearActiveBreakPoints = 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 + (nm:_) -> return (True, nm) + [] -> do + let oldCounter = breakCounter oldActiveBreaks + newCounter = oldCounter + 1 + newActiveBreaks = + oldActiveBreaks + { breakCounter = newCounter + , breakLocations = (oldCounter, brkLoc) : oldLocations + } + setGHCiState $ st { breaks = newActiveBreaks } + return (False, oldCounter) + newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a } startGHCi :: GHCi a -> GHCiState -> IO a @@ -107,20 +175,25 @@ io m = GHCi { unGHCi = \s -> m >>= return } isTopLevel :: GHCi Bool isTopLevel = getGHCiState >>= return . topLevel -getBkptTable :: GHCi (BkptTable GHC.Module) -getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable - io$ readIORef table_ref - -setBkptTable :: BkptTable GHC.Module -> GHCi () -setBkptTable new_table = do - table_ref <- getGHCiState >>= return . bkptTable - io$ writeIORef table_ref new_table - -modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi () -modifyBkptTable f = do - bt <- getBkptTable - new_bt <- io . evaluate$ f bt - setBkptTable new_bt +getResume :: GHCi (Maybe (IO GHC.RunResult)) +getResume = do + st <- getGHCiState + case (resume st) of + [] -> return Nothing + (x:_) -> return $ Just x + +popResume :: GHCi () +popResume = do + st <- getGHCiState + case (resume st) of + [] -> return () + (_:xs) -> setGHCiState $ st { resume = xs } + +pushResume :: IO GHC.RunResult -> GHCi () +pushResume resumeAction = do + st <- getGHCiState + let oldResume = resume st + setGHCiState $ st { resume = resumeAction : oldResume } showForUser :: SDoc -> GHCi String showForUser doc = do @@ -129,17 +202,6 @@ showForUser doc = do return $! showSDocForUser unqual doc -- -------------------------------------------------------------------------- --- Inferior Sessions Exceptions (used by the debugger) - -data InfSessionException = - StopChildSession -- A child session requests to be stopped - | StopParentSession -- A child session requests to be stopped - -- AND that the parent session quits after that - | ChildSessionStopped String -- A child session has stopped - deriving Typeable - - --- -------------------------------------------------------------------------- -- timing & statistics timeIt :: GHCi a -> GHCi a diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index cea3b29c6a..b794436b95 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -41,8 +41,7 @@ import Linker import Util -- The debugger -import Breakpoints -import Debugger hiding ( addModule ) +import Debugger import HscTypes import Id import Var ( globaliseId ) @@ -74,9 +73,7 @@ import System.Console.Readline as Readline import Control.Exception as Exception -- import Control.Concurrent -import Numeric import Data.List -import Data.Int ( Int64 ) import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes ) import System.Cmd import System.Environment @@ -86,16 +83,23 @@ import System.IO import System.IO.Error as IO import Data.Char import Data.Dynamic +import Data.Array import Control.Monad as Monad -import Foreign.StablePtr ( newStablePtr ) +import Foreign.StablePtr ( StablePtr, newStablePtr, deRefStablePtr, freeStablePtr ) import GHC.Exts ( unsafeCoerce# ) -import GHC.IOBase ( IOErrorType(InvalidArgument) ) +import GHC.IOBase ( IOErrorType(InvalidArgument), IO(IO) ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Data.IORef ( IORef, readIORef, writeIORef ) import System.Posix.Internals ( setNonBlockingFD ) +-- these are needed by the new ghci debugger +import ByteCodeLink (HValue) +import ByteCodeInstr (BreakInfo (..)) +import BreakArray +import TickTree + ----------------------------------------------------------------------------- ghciWelcomeMsg = @@ -112,41 +116,37 @@ GLOBAL_VAR(commands, builtin_commands, [Command]) 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), + ("break", breakCmd, False, completeNone), ("browse", keepGoing browseCmd, False, completeModule), -#ifdef DEBUGGER - -- I think that :c should mean :continue rather than :cd, makes more sense - -- (pepe 01.11.07) - ("continue", const(bkptOptions "continue"), False, completeNone), -#endif ("cd", tlC$ keepGoing changeDirectory, False, completeFilename), + ("check", keepGoing checkModule, False, completeHomeModule), + ("continue", continueCmd, False, completeNone), + ("ctags", keepGoing createCTagsFileCmd, False, completeFilename), ("def", keepGoing defineMacro, False, completeIdentifier), + ("delete", deleteCmd, False, completeNone), ("e", keepGoing editFile, False, completeFilename), - -- Hugs users are accustomed to :e, so make sure it doesn't overlap ("edit", keepGoing editFile, False, completeFilename), + ("etags", keepGoing createETagsFileCmd, False, completeFilename), + ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier), ("help", keepGoing help, False, completeNone), - ("?", keepGoing help, False, completeNone), ("info", keepGoing info, False, completeIdentifier), + ("kind", keepGoing kindOfType, False, completeIdentifier), ("load", tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile), ("module", keepGoing setContext, False, completeModule), ("main", tlC$ keepGoing runMain, False, completeIdentifier), + ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier), + ("quit", quit, False, completeNone), ("reload", tlC$ keepGoing reloadModule, False, completeNone), - ("check", keepGoing checkModule, False, completeHomeModule), ("set", keepGoing setCmd, True, completeSetOptions), ("show", keepGoing showCmd, False, completeNone), - ("etags", keepGoing createETagsFileCmd, False, completeFilename), - ("ctags", keepGoing createCTagsFileCmd, False, completeFilename), - ("type", keepGoing typeOfExpr, False, completeIdentifier), -#if defined(DEBUGGER) - ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier), ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier), - ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier), - ("breakpoint",bkptOptions, False, completeBkpt), -#endif - ("kind", keepGoing kindOfType, False, completeIdentifier), - ("unset", keepGoing unsetOptions, True, completeSetOptions), + ("step", stepCmd, False, completeNone), + ("type", keepGoing typeOfExpr, False, completeIdentifier), ("undef", keepGoing undefineMacro, False, completeMacro), - ("quit", quit, False, completeNone) + ("unset", keepGoing unsetOptions, True, completeSetOptions) ] keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) @@ -171,10 +171,8 @@ helpText = "\n" ++ " <stmt> evaluate/run <stmt>\n" ++ " :add <filename> ... add module(s) to the current target set\n" ++ - " :breakpoint <option> commands for the GHCi debugger\n" ++ " :browse [*]<module> display the names defined by <module>\n" ++ " :cd <dir> change directory to <dir>\n" ++ - " :continue equivalent to ':breakpoint continue'\n" ++ " :def <cmd> <expr> define a command :<cmd>\n" ++ " :edit <file> edit file\n" ++ " :edit edit last module\n" ++ @@ -212,14 +210,8 @@ helpText = " +t print type after evaluation\n" ++ " -<flags> most GHC command line flags can also be set here\n" ++ " (eg. -v2, -fglasgow-exts, etc.)\n" ++ - "\n" ++ - " Options for ':breakpoint':\n" ++ - " list list the current breakpoints\n" ++ - " add [Module] line [col] add a new breakpoint\n" ++ - " del (breakpoint# | Module line [col]) delete a breakpoint\n" ++ - " continue continue execution\n" ++ - " stop Stop a computation and return to the top level\n" ++ - " step [count] Step by step execution (DISABLED)\n" + "\n" +-- Todo: add help for breakpoint commands here findEditor = do getEnv "EDITOR" @@ -277,8 +269,6 @@ interactiveUI session srcs maybe_expr = do Readline.setCompleterWordBreakCharacters word_break_chars #endif - bkptTable <- newIORef emptyBkptTable - GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable) default_editor <- findEditor startGHCi (runGHCi srcs maybe_expr) @@ -289,8 +279,9 @@ interactiveUI session srcs maybe_expr = do session = session, options = [], prelude = prel_mod, - bkptTable = bkptTable, - topLevel = True + topLevel = True, + resume = [], + breaks = emptyActiveBreakPoints } #ifdef USE_READLINE @@ -530,10 +521,84 @@ runStmt stmt session <- getSession result <- io $ withProgName (progname st) $ withArgs (args st) $ GHC.runStmt session stmt - case result of - GHC.RunFailed -> return Nothing - GHC.RunException e -> throw e -- this is caught by runCommand(Eval) - GHC.RunOk names -> return (Just names) + switchOnRunResult result + +switchOnRunResult :: GHC.RunResult -> GHCi (Maybe [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? + 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 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 + + -- | Instantiate the tyVars with GHC.Base.Unknown + instantiateIdType :: Id -> IO Id + instantiateIdType id = do + instantiatedType <- instantiateTyVarsToUnknown s (idType id) + return$ setIdType id instantiatedType -- possibly print the type and revert CAFs after evaluating an expression finishEvalExpr mb_names @@ -779,10 +844,6 @@ afterLoad ok session = do graph <- io (GHC.getModuleGraph session) graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph setContextAfterLoad session graph' - do - bt <- getBkptTable - bt' <- io$ refreshBkptTable session bt graph' - setBkptTable bt' modulesLoadedMsg ok (map GHC.ms_mod_name graph') setContextAfterLoad session [] = do @@ -851,13 +912,9 @@ kindOfType str Nothing -> return () Just ty -> do tystr <- showForUser (ppr ty) io (putStrLn (str ++ " :: " ++ tystr)) - -quit :: String -> GHCi Bool -quit _ = do in_inferior_session <- liftM not isTopLevel - if in_inferior_session - then throwDyn StopParentSession - else return True +quit :: String -> GHCi Bool +quit _ = return True shellEscape :: String -> GHCi Bool shellEscape str = io (system str >> return False) @@ -1219,7 +1276,7 @@ showCmd str = ["modules" ] -> showModules ["bindings"] -> showBindings ["linker"] -> io showLinkerState - ["breakpoints"] -> showBkptTable + ["breaks"] -> showBkptTable _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]") showModules = do @@ -1252,12 +1309,10 @@ cleanType ty = do showBkptTable :: GHCi () showBkptTable = do - bt <- getBkptTable - msg <- showForUser . vcat $ - [ ppr mod <> colon <+> fcat - [ parens(int row <> comma <> int col) | (row,col) <- sites] - | (mod, sites) <- sitesList bt ] - io (putStrLn msg) + activeBreaks <- getActiveBreakPoints + str <- showForUser $ ppr activeBreaks + io $ putStrLn str + -- ----------------------------------------------------------------------------- -- Completion @@ -1329,12 +1384,6 @@ completeSetOptions w = do return (filter (w `isPrefixOf`) options) where options = "args":"prog":allFlags -completeBkpt = unionComplete completeModule completeBkptCmds - -completeBkptCmds w = do - return (filter (w `isPrefixOf`) options) - where options = ["add","del","list","stop"] - completeFilename = Readline.filenameCompletionFunction completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename @@ -1395,18 +1444,6 @@ completeBkpt = completeNone -- handler arond the flushing operation, so if stderr is closed -- GHCi will just die gracefully rather than going into an infinite loop. handler :: Exception -> GHCi Bool -handler (DynException dyn) - | Just StopChildSession <- fromDynamic dyn - -- propagate to the parent session - = do ASSERTM (liftM not isTopLevel) - throwDyn StopChildSession - - | Just StopParentSession <- fromDynamic dyn - = do at_topLevel <- isTopLevel - if at_topLevel then return True else throwDyn StopParentSession - - | Just (ChildSessionStopped msg) <- fromDynamic dyn - = io(putStrLn msg) >> return False handler exception = do flushInterpBuffers @@ -1476,84 +1513,163 @@ setUpConsole = do #endif return () +-- commands for debugger +foreign import ccall "rts_setStepFlag" setStepFlag :: IO () + +stepCmd :: String -> GHCi Bool +stepCmd [] = doContinue setStepFlag +stepCmd expression = do + io $ setStepFlag + runCommand expression + +continueCmd :: String -> GHCi Bool +continueCmd [] = doContinue $ return () +continueCmd other = do + io $ putStrLn "The continue command accepts no arguments." + return False + +doContinue :: IO () -> GHCi Bool +doContinue actionBeforeCont = do + resumeAction <- getResume + popResume + case resumeAction of + Nothing -> do + io $ putStrLn "There is no computation running." + return False + Just action -> do + io $ actionBeforeCont + runResult <- io action + names <- switchOnRunResult runResult + finishEvalExpr names + return False + +deleteCmd :: String -> GHCi Bool +deleteCmd argLine = do + deleteSwitch $ words argLine + return False + where + deleteSwitch :: [String] -> GHCi () + deleteSwitch [] = + io $ putStrLn "The delete command requires at least one argument." + -- delete all break points + deleteSwitch ("*":_rest) = clearActiveBreakPoints + deleteSwitch idents = do + mapM_ deleteOneBreak idents + where + deleteOneBreak :: String -> GHCi () + deleteOneBreak str + | all isDigit str = deleteBreak (read str) + | otherwise = return () + +-- handle the "break" command +breakCmd :: String -> GHCi Bool +breakCmd argLine = do + session <- getSession + breakSwitch session $ words argLine + +breakSwitch :: Session -> [String] -> GHCi Bool +breakSwitch _session [] = do + io $ putStrLn "The break command requires at least one argument." + return False +breakSwitch session args@(arg1:rest) + | looksLikeModule arg1 = do + mod <- lookupModule session arg1 + breakByModule mod rest + return False + | otherwise = do + (toplevel, _) <- io $ GHC.getContext session + case toplevel of + (mod : _) -> breakByModule mod args + [] -> do + io $ putStrLn "Cannot find default module for breakpoint." + io $ putStrLn "Perhaps no modules are loaded for debugging?" + return False + where + -- Todo there may be a nicer way to test this + looksLikeModule :: String -> Bool + looksLikeModule [] = False + looksLikeModule (x:_) = isUpper x + +breakByModule :: Module -> [String] -> GHCi () +breakByModule mod args@(arg1:rest) + | all isDigit arg1 = do -- looks like a line number + breakByModuleLine mod (read arg1) rest + | looksLikeVar arg1 = do + -- break by a function definition + io $ putStrLn "Break by function definition not implemented." + | otherwise = io $ putStrLn "Invalid arguments to break command." + where + -- Todo there may be a nicer way to test this + looksLikeVar :: String -> Bool + looksLikeVar [] = False + looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+" + +breakByModuleLine :: Module -> Int -> [String] -> GHCi () +breakByModuleLine mod line args + | [] <- args = findBreakAndSet mod $ lookupTickTreeLine line + | [col] <- args, all isDigit col = + findBreakAndSet mod $ lookupTickTreeCoord (line, read col) + | otherwise = io $ putStrLn "Invalid arguments to break command." + +findBreakAndSet :: Module -> (TickTree -> Maybe (Int, SrcSpan)) -> GHCi () +findBreakAndSet mod lookupTickTree = do + (breakArray, ticks) <- getModBreak mod + let tickTree = tickTreeFromList (assocs ticks) + case lookupTickTree tickTree of + Nothing -> io $ putStrLn $ "No breakpoints found at that location." + Just (tick, span) -> do + success <- io $ setBreakFlag True breakArray tick + session <- getSession + unqual <- io $ GHC.getPrintUnqual session + if success + then do + (alreadySet, nm) <- + recordBreak $ BreakLocation + { breakModule = mod + , breakLoc = span + , breakTick = tick + } + io $ printForUser stdout unqual $ + text "Breakpoint " <> ppr nm <> + if alreadySet + then text " was already set at " <> ppr span + else text " activated at " <> ppr span + else do + str <- showForUser $ text "Breakpoint could not be activated at" + <+> ppr span + io $ putStrLn str + +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 + return (array, ticks) -instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module -instrumentationBkptHandler ref_bkptTable = BkptHandler { - isAutoBkptEnabled = \sess bkptLoc -> do - bktpTable <- readIORef ref_bkptTable - return$ isBkptEnabled bktpTable bkptLoc - - , handleBreakpoint = doBreakpoint ref_bkptTable - } - -doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b -doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do - let (ids, hValues) = unzip values - names = map idName ids - ASSERT (length names == length hValues) return () - let global_ids = map globaliseAndTidy ids - printScopeMsg locMsg global_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 }) - is_tty <- hIsTerminalDevice stdin - prel_mod <- GHC.findModule s prel_name Nothing - withExtendedLinkEnv (zip names hValues) $ - startGHCi (interactiveLoop is_tty True) GHCiState{ - progname = "<interactive>", - args = [], - prompt = locMsg ++ "> ", - session = s, - options = [], - bkptTable= ref_bkptTable, - prelude = prel_mod, - topLevel = False } - `catchDyn` (\e -> case e of - StopChildSession -> evaluate$ - throwDyn (ChildSessionStopped "") - StopParentSession -> throwDyn StopParentSession - ) `finally` do - writeIORef ref hsc_env - putStrLn $ "Returning to normal execution..." - return b - where - printScopeMsg :: String -> [Id] -> IO () - printScopeMsg location ids = do - unqual <- GHC.getPrintUnqual s - printForUser stdout unqual $ - text "Stopped at a breakpoint in " <> text (stripColumn location) <> - char '.' <+> text "Local bindings in scope:" $$ - nest 2 (pprWithCommas showId ids) - where - showId id = - ppr (idName id) <+> dcolon <+> ppr (idType id) - stripColumn = reverse . tail . dropWhile (/= ':') . reverse - --- | Give the Id a Global Name, and tidy its type - globaliseAndTidy :: Id -> Id - globaliseAndTidy id - = let tidied_type = tidyTopType$ idType id - in setIdType (globaliseId VanillaGlobal id) tidied_type +lookupModule :: Session -> String -> GHCi Module +lookupModule session modName + = io (GHC.findModule session (GHC.mkModuleName modName) Nothing) + +setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool +setBreakFlag toggle array index + | toggle = setBreakOn array index + | otherwise = 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 () --- | Instantiate the tyVars with GHC.Base.Unknown - instantiateIdType :: Id -> IO Id - instantiateIdType id = do - instantiatedType <- instantiateTyVarsToUnknown s (idType id) - return$ setIdType id instantiatedType +activeBreakPoints :: Session -> IO [(Module,Int)] +activeBreakPoints session = return [] +enableSingleStep :: Session -> IO () +enableSingleStep session = return () +disableSingleStep :: Session -> IO () +disableSingleStep session = return () diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 2c1b668e65..38d584a633 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -18,7 +18,7 @@ module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, extendLinkEnv, withExtendedLinkEnv, extendLoadedPkgs, linkPackages,initDynLinker, - recoverDataCon + dataConInfoPtrToName ) where #include "HsVersions.h" @@ -28,8 +28,9 @@ import ByteCodeLink import ByteCodeItbls import ByteCodeAsm import RtClosureInspect +import CgInfoTbls +import SMRep import IfaceEnv -import OccName import TcRnMonad import Packages import DriverPhases @@ -38,6 +39,7 @@ import HscTypes import Name import NameEnv import NameSet +import qualified OccName import UniqFM import Module import ListSetOps @@ -52,6 +54,7 @@ import ErrUtils import DriverPhases import SrcLoc import UniqSet +import Constants -- Standard libraries import Control.Monad @@ -151,12 +154,13 @@ extendLinkEnv new_bindings -- We use this string to lookup the interpreter's internal representation of the name -- using the lookupOrig. -recoverDataCon :: a -> TcM Name -recoverDataCon x = do +dataConInfoPtrToName :: Ptr () -> TcM Name +dataConInfoPtrToName x = do theString <- ioToTcRn $ do - let ptr = getInfoTablePtr x + let ptr = castPtr x :: Ptr StgInfoTable conDescAddress <- getConDescAddress ptr - peekCString conDescAddress + str <- peekCString conDescAddress + return str let (pkg, mod, occ) = parse theString occName = mkOccName OccName.dataName occ modName = mkModule (stringToPackageId pkg) (mkModuleName mod) @@ -207,18 +211,10 @@ recoverDataCon x = do getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar) getConDescAddress ptr = do #ifdef GHCI_TABLES_NEXT_TO_CODE - offsetToString <- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset - return $ ptr `plusPtr` offsetToString - where - -- subtract a word number of bytes - offset = negate (fromIntegral SIZEOF_VOID_P) -#endif -#ifndef GHCI_TABLES_NEXT_TO_CODE - peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset - where - -- add the standard info table size in bytes - infoTableSizeBytes = sTD_ITBL_SIZE * wORD_SIZE - offset = infoTableSizeBytes + offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE) + return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord)) +#else + peek $ intPtrToPtr $ (ptrToIntPtr ptr) + stdInfoTableSizeB #endif -- parsing names is a little bit fiddly because we have a string in the form: diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 26816a03ec..b12d29628f 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -12,11 +12,9 @@ module RtClosureInspect( ClosureType(..), getClosureData, -- :: a -> IO Closure - Closure ( tipe, infoTable, ptrs, nonPtrs ), - getClosureType, -- :: a -> IO ClosureType + Closure ( tipe, infoPtr, ptrs, nonPtrs ), isConstr, -- :: ClosureType -> Bool isIndirection, -- :: ClosureType -> Bool - getInfoTablePtr, -- :: a -> Ptr StgInfoTable Term(..), printTerm, @@ -77,6 +75,8 @@ import Data.Array.Base import Data.List ( partition ) import Foreign.Storable +import IO + --------------------------------------------- -- * A representation of semi evaluated Terms --------------------------------------------- @@ -139,6 +139,7 @@ data ClosureType = Constr deriving (Show, Eq) data Closure = Closure { tipe :: ClosureType + , infoPtr :: Ptr () , infoTable :: StgInfoTable , ptrs :: Array Int HValue -- What would be the type here? HValue is ok? Should I build a Ptr? @@ -148,14 +149,6 @@ data Closure = Closure { tipe :: ClosureType instance Outputable ClosureType where ppr = text . show -getInfoTablePtr :: a -> Ptr StgInfoTable -getInfoTablePtr x = - case infoPtr# x of - itbl_ptr -> castPtr ( Ptr itbl_ptr ) - -getClosureType :: a -> IO ClosureType -getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr - #include "../includes/ClosureTypes.h" aP_CODE = AP @@ -164,14 +157,14 @@ pAP_CODE = PAP #undef PAP getClosureData :: a -> IO Closure -getClosureData a = do - itbl <- peek (getInfoTablePtr a) - let tipe = readCType (BCI.tipe itbl) - case closurePayload# a of - (# ptrs, nptrs #) -> - let elems = BCI.ptrs itbl +getClosureData a = + case unpackClosure# a of + (# iptr, ptrs, nptrs #) -> do + itbl <- peek (Ptr iptr) + let tipe = readCType (BCI.tipe itbl) + elems = BCI.ptrs itbl ptrsList = Array 0 (fromIntegral$ elems) ptrs - in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs) + ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs) readCType :: Integral a => a -> ClosureType readCType i @@ -481,9 +474,10 @@ instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty) trd (x,y,z) = z cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term -cvObtainTerm hsc_env force mb_ty a = - -- Obtain the term and tidy the type before returning it - cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes +cvObtainTerm hsc_env force mb_ty a = do + -- Obtain the term and tidy the type before returning it + term <- cvObtainTerm1 hsc_env force mb_ty a + return $ tidyTypes term where tidyTypes = foldTerm idTermFold { fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt, @@ -505,21 +499,18 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do go tv hval where go tv a = do - ctype <- trIO$ getClosureType a - case ctype of + clos <- trIO $ getClosureData a + case tipe clos of -- Thunks we may want to force Thunk _ | force -> seq a $ go tv a -- We always follow indirections - _ | isIndirection ctype -> do - clos <- trIO$ getClosureData a - (go tv $! (ptrs clos ! 0)) + Indirection _ -> go tv $! (ptrs clos ! 0) -- The interesting case Constr -> do - m_dc <- trIO$ tcRnRecoverDataCon hsc_env a + m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos) case m_dc of Nothing -> panic "Can't find the DataCon for a term" Just dc -> do - clos <- trIO$ getClosureData a let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc) subTtypes = drop extra_args (dataConRepArgTys dc) (subTtypesP, subTtypesNP) = partition isPointed subTtypes @@ -537,7 +528,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do return (Term tv dc a subTerms) -- The otherwise case: can be a Thunk,AP,PAP,etc. otherwise -> do - return (Suspension ctype (Just tv) a Nothing) + return (Suspension (tipe clos) (Just tv) a Nothing) -- Access the array of pointers and recurse down. Needs to be done with -- care of no introducing a thunk! or go will fail to do its job diff --git a/compiler/ghci/TickTree.hs b/compiler/ghci/TickTree.hs new file mode 100644 index 0000000000..a472e59e75 --- /dev/null +++ b/compiler/ghci/TickTree.hs @@ -0,0 +1,110 @@ +----------------------------------------------------------------------------- +-- +-- 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/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index b6f1f484f2..b82685bee7 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -50,7 +50,6 @@ import Maybes import SrcLoc import Util import DynFlags -import Breakpoints import Control.Monad import Data.List @@ -211,7 +210,7 @@ typecheckIface iface , md_fam_insts = fam_insts , md_rules = rules , md_exports = exports - , md_dbg_sites = noDbgSites + , md_modBreaks = emptyModBreaks } } \end{code} diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs new file mode 100644 index 0000000000..788adf200c --- /dev/null +++ b/compiler/main/BreakArray.hs @@ -0,0 +1,96 @@ +-- +-- Break Arrays in the IO monad +-- Entries in the array are Word sized +-- + +module BreakArray + ( BreakArray (BA) + , newBreakArray + , getBreak + , setBreakOn + , setBreakOff + , showBreakArray + ) where + +import GHC.Exts +import GHC.IOBase +import GHC.Prim +import GHC.Word +import Constants + +data BreakArray = BA (MutableByteArray# RealWorld) + +breakOff, breakOn :: Word +breakOn = fromIntegral 1 +breakOff = fromIntegral 0 + +-- XXX crude +showBreakArray :: BreakArray -> IO () +showBreakArray array = do + let loop count sz + | count == sz = return () + | otherwise = do + val <- readBreakArray array count + putStr $ " " ++ show val + loop (count + 1) sz + loop 0 (size array) + putStr "\n" + +setBreakOn :: BreakArray -> Int -> IO Bool +setBreakOn array index + | safeIndex array index = do + writeBreakArray array index breakOn + return True + | otherwise = return False + +setBreakOff :: BreakArray -> Int -> IO Bool +setBreakOff array index + | safeIndex array index = do + writeBreakArray array index breakOff + return True + | otherwise = return False + +getBreak :: BreakArray -> Int -> IO (Maybe Word) +getBreak array index + | safeIndex array index = do + val <- readBreakArray array index + return $ Just val + | otherwise = return Nothing + +safeIndex :: BreakArray -> Int -> Bool +safeIndex array index = index < size array && index >= 0 + +size :: BreakArray -> Int +size (BA array) = (I# (sizeofMutableByteArray# array)) `div` wORD_SIZE + +allocBA :: Int -> IO BreakArray +allocBA (I# sz) = IO $ \s1 -> + case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) } + +-- create a new break array and initialise elements to zero +newBreakArray :: Int -> IO BreakArray +newBreakArray entries@(I# sz) = do + BA array <- allocBA (entries * wORD_SIZE) + case breakOff of + W# off -> do -- Todo: there must be a better way to write zero as a Word! + let loop n + | n ==# sz = return () + | otherwise = do + writeBA# array n off + loop (n +# 1#) + loop 0# + return $ BA array + +writeBA# :: MutableByteArray# RealWorld -> Int# -> Word# -> IO () +writeBA# array i word = IO $ \s -> + case writeWordArray# array i word s of { s -> (# s, () #) } + +writeBreakArray :: BreakArray -> Int -> Word -> IO () +writeBreakArray (BA array) (I# i) (W# word) = writeBA# array i word + +readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word +readBA# array i = IO $ \s -> + case readWordArray# array i s of { (# s, c #) -> (# s, W# c #) } + +readBreakArray :: BreakArray -> Int -> IO Word +readBreakArray (BA array) (I# i) = readBA# array i diff --git a/compiler/main/Breakpoints.hs b/compiler/main/Breakpoints.hs deleted file mode 100644 index c4318ca448..0000000000 --- a/compiler/main/Breakpoints.hs +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------
---
--- GHC API breakpoints. This module includes the main API (BkptHandler) and
--- utility code for implementing a client to this API used in GHCi
---
--- Pepe Iborra (supported by Google SoC) 2006
---
------------------------------------------------------------------------------
-
-module Breakpoints where
-
-#ifdef GHCI
-import {-#SOURCE#-} ByteCodeLink ( HValue )
-#endif
-
-import {-#SOURCE#-} HscTypes ( Session )
-import Name
-import Var ( Id )
-import PrelNames
-
-import GHC.Exts
-
-#ifdef GHCI
-data BkptHandler a = BkptHandler {
- handleBreakpoint :: forall b. Session -> [(Id,HValue)] -> BkptLocation a -> String -> b -> IO b
- , isAutoBkptEnabled :: Session -> BkptLocation a -> IO Bool
- }
-
-nullBkptHandler = BkptHandler {
- isAutoBkptEnabled = \ _ _ -> return False,
- handleBreakpoint = \_ _ _ _ b -> putStrLn "null Bkpt Handler" >> return b
- }
-#endif
-
-type BkptLocation a = (a, SiteNumber)
-type SiteNumber = Int
-
-type SiteMap = [(SiteNumber, Coord)]
-type Coord = (Int, Int)
-
-noDbgSites :: SiteMap
-noDbgSites = []
-
--- | Returns the 'identity' jumps
--- Used to deal with spliced code, where we don't want breakpoints
-#ifdef GHCI
-lookupBogusBreakpointVal :: Name -> Maybe HValue
-lookupBogusBreakpointVal name
- | name == breakpointJumpName = Just$ unsafeCoerce# (\_ _ a->a)
- | name == breakpointAutoJumpName = Just$ unsafeCoerce# (\_ _ a->a)
- | name == breakpointCondJumpName = Just$ unsafeCoerce# (\_ _ _ a->a)
- | otherwise = Nothing
-#else
-lookupBogusBreakpointVal _ = Nothing
-#endif /* GHCI */
-
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index f10d2f9ea5..fa5ae4b196 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -85,10 +85,6 @@ import Util ( split ) import Data.Char ( isUpper ) import System.IO ( hPutStrLn, stderr ) -#ifdef GHCI -import Breakpoints ( BkptHandler ) -import Module ( ModuleName ) -#endif -- ----------------------------------------------------------------------------- -- DynFlags @@ -208,9 +204,6 @@ data DynFlag | Opt_SplitObjs | Opt_StgStats | Opt_HideAllPackages -#if defined(GHCI) && defined(DEBUGGER) - | Opt_Debugging -#endif | Opt_PrintBindResult | Opt_Haddock | Opt_Hpc_No_Auto @@ -321,11 +314,6 @@ data DynFlags = DynFlags { -- message output log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO () - -#ifdef GHCI - -- breakpoint handling - ,bkptHandler :: Maybe (BkptHandler Module) -#endif } data HscTarget @@ -446,9 +434,6 @@ defaultDynFlags = packageFlags = [], pkgDatabase = Nothing, pkgState = panic "no package state yet: call GHC.setSessionDynFlags", -#ifdef GHCI - bkptHandler = Nothing, -#endif flags = [ Opt_ReadUserPackageConf, @@ -1079,9 +1064,6 @@ fFlags = [ ( "excess-precision", Opt_ExcessPrecision ), ( "asm-mangling", Opt_DoAsmMangling ), ( "print-bind-result", Opt_PrintBindResult ), -#if defined(GHCI) && defined(DEBUGGER) - ( "debugging", Opt_Debugging), -#endif ( "force-recomp", Opt_ForceRecomp ), ( "hpc-no-auto", Opt_Hpc_No_Auto ) ] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index eb2ca8e3dd..5f78c3e9d5 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -60,9 +60,6 @@ module GHC ( modInfoInstances, modInfoIsExportedName, modInfoLookupName, -#if defined(GHCI) - modInfoBkptSites, -#endif lookupGlobalName, -- * Printing @@ -86,9 +83,8 @@ module GHC ( isModuleInterpreted, compileExpr, HValue, dynCompileExpr, lookupName, - - getBreakpointHandler, setBreakpointHandler, obtainTerm, obtainTerm1, + modInfoModBreaks, #endif -- * Abstract syntax elements @@ -194,24 +190,16 @@ import Name ( nameOccName ) import Type ( tidyType ) import Var ( varName ) import VarEnv ( emptyTidyEnv ) -import GHC.Exts ( unsafeCoerce# ) - --- For breakpoints -import Breakpoints ( SiteNumber, Coord, nullBkptHandler, - BkptHandler(..), BkptLocation, noDbgSites ) -import Linker ( initDynLinker ) -import PrelNames ( breakpointJumpName, breakpointCondJumpName, - breakpointAutoJumpName ) - -import GHC.Exts ( Int(..), Ptr(..), int2Addr#, indexArray# ) -import GHC.Base ( Opaque(..) ) -import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr ) -import Foreign ( unsafePerformIO ) +import GHC.Exts ( unsafeCoerce#, Ptr ) +import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr, 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) #endif import Packages ( initPackages ) @@ -854,7 +842,7 @@ checkModule session@(Session ref) mod = do minf_rdr_env = Just rdr_env, minf_instances = md_insts details #ifdef GHCI - ,minf_dbg_sites = noDbgSites + ,minf_modBreaks = emptyModBreaks #endif } return (Just (CheckedModule { @@ -1799,7 +1787,7 @@ data ModuleInfo = ModuleInfo { minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [Instance] #ifdef GHCI - ,minf_dbg_sites :: [(SiteNumber,Coord)] + ,minf_modBreaks :: ModBreaks #endif -- ToDo: this should really contain the ModIface too } @@ -1840,7 +1828,7 @@ getPackageModuleInfo hsc_env mdl = do minf_exports = names, minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl), minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_dbg_sites = noDbgSites + minf_modBreaks = emptyModBreaks })) #else -- bogusly different for non-GHCI (ToDo) @@ -1858,7 +1846,7 @@ getHomeModuleInfo hsc_env mdl = minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details #ifdef GHCI - ,minf_dbg_sites = md_dbg_sites details + ,minf_modBreaks = md_modBreaks details #endif })) @@ -1894,7 +1882,7 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do (hsc_HPT hsc_env) (eps_PTE eps) name #ifdef GHCI -modInfoBkptSites = minf_dbg_sites +modInfoModBreaks = minf_modBreaks #endif isDictonaryId :: Id -> Bool @@ -1993,7 +1981,6 @@ setContext sess@(Session ref) toplev_mods export_mods = do writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, ic_exports = export_mods, ic_rn_gbl_env = all_env }} - reinstallBreakpointHandlers sess -- Make a GlobalRdrEnv based on the exports of the modules only. mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv @@ -2164,14 +2151,22 @@ 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) + +data Status a + = Break RunResult -- ^ the computation hit a breakpoint + | Complete (Either Exception a) -- ^ the computation completed with either an exception or a value --- | Run a statement in the current interactive context. Statemenet +-- | Run a statement in the current interactive context. Statement -- may bind multple values. runStmt :: Session -> String -> IO RunResult runStmt (Session ref) expr = do hsc_env <- readIORef ref + breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint + statusMVar <- newEmptyMVar -- wait on this when a computation is running + -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds @@ -2183,36 +2178,58 @@ runStmt (Session ref) expr Nothing -> return RunFailed Just (new_hsc_env, names, hval) -> do - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - either_hvals <- sandboxIO thing_to_run - + -- 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 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) -> case either_hvals of - Left e -> do - -- on error, keep the *old* interactive context, - -- so that 'it' is not bound to something - -- that doesn't exist. - return (RunException e) - + Left e -> return (RunException e) Right hvals -> do - -- Get the newly bound things, and bind them. - -- Don't need to delete any shadowed bindings; - -- the new ones override the old ones. extendLinkEnv (zip names hvals) - - writeIORef ref new_hsc_env + 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 ())) -- 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 :: IO a -> IO (Either Exception a) -sandboxIO thing = do - m <- newEmptyMVar +sandboxIO :: MVar (Status a) -> IO a -> IO (Status a) +sandboxIO statusMVar thing = do ts <- takeMVar interruptTargetThread - child <- forkIO (do res <- Exception.try thing; putMVar m res) + child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res)) putMVar interruptTargetThread (child:ts) - takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail) + takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail) {- -- This version of sandboxIO runs the expression in a completely new @@ -2261,75 +2278,6 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> where obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) ------------------------------------------------------------------------------ --- Breakpoint handlers - -getBreakpointHandler :: Session -> IO (Maybe (BkptHandler Module)) -getBreakpointHandler session = getSessionDynFlags session >>= return . bkptHandler - -setBreakpointHandler :: Session -> BkptHandler Module -> IO () -setBreakpointHandler session handler = do - dflags <- getSessionDynFlags session - setSessionDynFlags session dflags{ bkptHandler = Just handler } - let linkEnv = [ ( breakpointJumpName - , unsafeCoerce# (jumpFunction session handler)) - , ( breakpointCondJumpName - , unsafeCoerce# (jumpCondFunction session handler)) - , ( breakpointAutoJumpName - , unsafeCoerce# (jumpAutoFunction session handler)) - ] - writeIORef v_bkptLinkEnv linkEnv - dflags <- getSessionDynFlags session - reinstallBreakpointHandlers session - -reinstallBreakpointHandlers :: Session -> IO () -reinstallBreakpointHandlers session = do - dflags <- getSessionDynFlags session - let mode = ghcMode dflags - when (ghcLink dflags == LinkInMemory) $ do - linkEnv <- readIORef v_bkptLinkEnv - initDynLinker dflags - extendLinkEnv linkEnv - ------------------------------------------------------------------------ --- Jump functions - -type SiteInfo = (String, SiteNumber) -jumpFunction, jumpAutoFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> b -> b -jumpCondFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> Bool -> b -> b -jumpFunctionM :: Session -> BkptHandler a -> BkptLocation a -> (Int, [Opaque], String) -> b -> IO b - -jumpCondFunction _ _ _ _ False b = b -jumpCondFunction session handler site args True b - = jumpFunction session handler site args b - -jumpFunction session handler siteInfo args b - | site <- mkSite siteInfo - = unsafePerformIO $ jumpFunctionM session handler site args b - -jumpFunctionM session handler site (I# idsPtr, wrapped_hValues, locmsg) b = - do - ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr))) - let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues] - handleBreakpoint handler session (zip ids hValues) site locmsg b - -jumpAutoFunction session handler siteInfo args b - | site <- mkSite siteInfo - = unsafePerformIO $ do - break <- isAutoBkptEnabled handler session site - if break - then jumpFunctionM session handler site args b - else return b - -jumpStepByStepFunction session handler siteInfo args b - | site <- mkSite siteInfo - = unsafePerformIO $ do - jumpFunctionM session handler site args b - -mkSite :: SiteInfo -> BkptLocation Module -mkSite ( modName, sitenum) = - (mkModule mainPackageId (mkModuleName modName), sitenum) - obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 06279250f3..4413c52ec2 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -76,7 +76,6 @@ import CodeGen ( codeGen ) import CmmParse ( parseCmmFile ) import CodeOutput ( codeOutput ) import NameEnv ( emptyNameEnv ) -import Breakpoints ( noDbgSites ) import DynFlags import ErrUtils @@ -636,7 +635,7 @@ hscInteractive (iface, details, cgguts) prepd_binds <- {-# SCC "CorePrep" #-} corePrepPgm dflags core_binds data_tycons ; ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen dflags prepd_binds data_tycons + comp_bc <- byteCodeGen dflags prepd_binds data_tycons (md_modBreaks details) ------------------ Create f-x-dynamic C-side stuff --- (istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs @@ -682,7 +681,7 @@ hscFileCheck hsc_env mod_summary = do { md_exports = tcg_exports tc_result, md_insts = tcg_insts tc_result, md_fam_insts = tcg_fam_insts tc_result, - md_dbg_sites = noDbgSites, + md_modBreaks = emptyModBreaks, md_rules = [panic "no rules"] } -- Rules are CoreRules, not the -- RuleDecls we get out of the typechecker diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 92b7228dd5..c7926e3c23 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -59,12 +59,14 @@ module HscTypes ( Linkable(..), isObjectLinkable, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, - HpcInfo, noHpcInfo + HpcInfo, noHpcInfo, + + -- Breakpoints + ModBreaks (..), emptyModBreaks ) where #include "HsVersions.h" -import Breakpoints ( SiteNumber, Coord, noDbgSites ) #ifdef GHCI import ByteCodeAsm ( CompiledByteCode ) #endif @@ -100,6 +102,7 @@ import FiniteMap ( FiniteMap ) import CoreSyn ( CoreRule ) import Maybes ( orElse, expectJust, catMaybes, seqMaybe ) import Outputable +import BreakArray import SrcLoc ( SrcSpan, Located ) import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) @@ -109,6 +112,7 @@ import StringBuffer ( StringBuffer ) import System.Time ( ClockTime ) import Data.IORef ( IORef, readIORef ) +import Data.Array ( Array, array ) \end{code} @@ -456,7 +460,7 @@ data ModDetails md_insts :: ![Instance], -- Dfun-ids for the instances in this module md_fam_insts :: ![FamInst], md_rules :: ![CoreRule], -- Domain may include Ids from other modules - md_dbg_sites :: ![(SiteNumber, Coord)] -- Breakpoint sites inserted by the renamer + md_modBreaks :: !ModBreaks -- breakpoint information for this module } emptyModDetails = ModDetails { md_types = emptyTypeEnv, @@ -464,7 +468,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], md_rules = [], md_fam_insts = [], - md_dbg_sites = noDbgSites} + md_modBreaks = emptyModBreaks } -- A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module @@ -498,7 +502,7 @@ data ModGuts mg_foreign :: !ForeignStubs, mg_deprecs :: !Deprecations, -- Deprecations declared in the module mg_hpc_info :: !HpcInfo, -- info about coverage tick boxes - mg_dbg_sites :: ![(SiteNumber, Coord)] -- Bkpts inserted by the renamer + mg_modBreaks :: !ModBreaks } -- The ModGuts takes on several slightly different forms: @@ -1140,11 +1144,6 @@ showModMsg target recomp mod_summary = showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), char '(', text (msHsFilePath mod_summary) <> comma, case target of -#if defined(GHCI) && defined(DEBUGGER) - HscInterpreted | recomp && - Opt_Debugging `elem` modflags - -> text "interpreted(debugging)" -#endif HscInterpreted | recomp -> text "interpreted" HscNothing -> text "nothing" @@ -1153,7 +1152,6 @@ showModMsg target recomp mod_summary where mod = moduleName (ms_mod mod_summary) mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) - modflags= flags(ms_hspp_opts mod_summary) \end{code} @@ -1238,5 +1236,25 @@ byteCodeOfObject (BCOs bc) = bc byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) \end{code} +%************************************************************************ +%* * +\subsection{Breakpoint Support} +%* * +%************************************************************************ +\begin{code} +-- 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) + } +emptyModBreaks :: ModBreaks +emptyModBreaks = ModBreaks + { modBreaks_array = error "ModBreaks.modBreaks_array not initialised" + -- Todo: can we avoid this? + , modBreaks_ticks = array (0,-1) [] + } +\end{code} diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 6f44bca63a..b001e1d3b3 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -124,8 +124,9 @@ mkBootModDetails hsc_env (ModGuts { mg_module = mod , mg_exports = exports , mg_types = type_env , mg_insts = insts - , mg_fam_insts = fam_insts, - mg_dbg_sites = sites }) + , mg_fam_insts = fam_insts + , mg_modBreaks = modBreaks + }) = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy [hoot] type env" @@ -140,7 +141,8 @@ mkBootModDetails hsc_env (ModGuts { mg_module = mod , md_fam_insts = fam_insts , md_rules = [] , md_exports = exports - , md_dbg_sites = sites}) + , md_modBreaks = modBreaks + }) } where @@ -244,7 +246,7 @@ tidyProgram hsc_env mg_dir_imps = dir_imps, mg_deps = deps, mg_foreign = foreign_stubs, mg_hpc_info = hpc_info, - mg_dbg_sites = sites }) + mg_modBreaks = modBreaks }) = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy Core" @@ -303,7 +305,8 @@ tidyProgram hsc_env md_insts = tidy_insts, md_fam_insts = fam_insts, md_exports = exports, - md_dbg_sites = sites }) + md_modBreaks = modBreaks }) + } lookup_dfun type_env dfun_id diff --git a/compiler/package.conf.in b/compiler/package.conf.in index f0ecc35be4..d001c282d1 100644 --- a/compiler/package.conf.in +++ b/compiler/package.conf.in @@ -77,7 +77,6 @@ exposed-modules: DriverPipeline DsArrows DsBinds - DsBreakpoint DsCCall DsExpr DsForeign diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 16149d9eff..1d46095d4d 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1738,13 +1738,8 @@ primop NewBCOOp "newBCO#" GenPrimOp has_side_effects = True out_of_line = True -primop InfoPtrOp "infoPtr#" GenPrimOp - a -> Addr# - with - out_of_line = True - -primop ClosurePayloadOp "closurePayload#" GenPrimOp - a -> (# Array# b, ByteArr# #) +primop UnpackClosureOp "unpackClosure#" GenPrimOp + a -> (# Addr#, Array# b, ByteArr# #) with out_of_line = True diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index e26c50b584..259596332b 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -72,7 +72,6 @@ import SrcLoc import HscTypes import ListSetOps import Outputable -import Breakpoints #ifdef GHCI import Linker @@ -97,6 +96,9 @@ import Util import Bag import Control.Monad ( unless ) +import Data.Maybe ( isJust ) +import Foreign.Ptr ( Ptr ) + \end{code} @@ -318,7 +320,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_deprecs = NoDeprecs, mg_foreign = NoStubs, mg_hpc_info = noHpcInfo, - mg_dbg_sites = noDbgSites + mg_modBreaks = emptyModBreaks } } ; tcCoreDump mod_guts ; @@ -1193,11 +1195,11 @@ lookup_rdr_name rdr_name = do { return good_names } -tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) -tcRnRecoverDataCon hsc_env a +tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon) +tcRnRecoverDataCon hsc_env ptr = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env (hsc_IC hsc_env) $ - do name <- recoverDataCon a + setInteractiveContext hsc_env (hsc_IC hsc_env) $ do + name <- dataConInfoPtrToName ptr tcLookupDataCon name tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) diff --git a/compiler/typecheck/TcRnDriver.lhs-boot b/compiler/typecheck/TcRnDriver.lhs-boot index 0de156bcfa..b4208516e6 100644 --- a/compiler/typecheck/TcRnDriver.lhs-boot +++ b/compiler/typecheck/TcRnDriver.lhs-boot @@ -1,5 +1,6 @@ >module TcRnDriver where >import HscTypes >import DataCon +>import Foreign.Ptr > ->tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon)
\ No newline at end of file +>tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 4e2ae695d9..b675cf9033 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -376,11 +376,7 @@ runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) -> TcM hs_syn -- Of type t runMeta convert expr = do { -- Desugar -#if defined(GHCI) && defined(DEBUGGER) - ds_expr <- unsetOptM Opt_Debugging $ initDsTc (dsLExpr expr) -#else ds_expr <- initDsTc (dsLExpr expr) -#endif -- Compile and link it; might fail if linking fails ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM diff --git a/includes/Bytecodes.h b/includes/Bytecodes.h index 4a75b00c11..3df7ddd073 100644 --- a/includes/Bytecodes.h +++ b/includes/Bytecodes.h @@ -75,6 +75,7 @@ #define bci_RETURN_D 50 #define bci_RETURN_L 51 #define bci_RETURN_V 52 +#define bci_BRK_FUN 53 /* If you need to go past 255 then you will run into the flags */ /* If you need to go below 0x0100 then you will run into the instructions */ diff --git a/includes/Constants.h b/includes/Constants.h index cc1987d5f3..66b8fe79d8 100644 --- a/includes/Constants.h +++ b/includes/Constants.h @@ -246,9 +246,12 @@ * * TSO_INTERRUPTIBLE: the TSO can be interrupted if it blocks * interruptibly (eg. with BlockedOnMVar). + * + * TSO_STOPPED_ON_BREAKPOINT: the thread is currently stopped in a breakpoint */ #define TSO_BLOCKEX 4 #define TSO_INTERRUPTIBLE 8 +#define TSO_STOPPED_ON_BREAKPOINT 16 /* ----------------------------------------------------------------------------- RET_DYN stack frames diff --git a/includes/StgMiscClosures.h b/includes/StgMiscClosures.h index 82671287de..3c6482799b 100644 --- a/includes/StgMiscClosures.h +++ b/includes/StgMiscClosures.h @@ -589,8 +589,8 @@ RTS_FUN(readTVarzh_fast); RTS_FUN(writeTVarzh_fast); RTS_FUN(checkzh_fast); -RTS_FUN(infoPtrzh_fast); -RTS_FUN(closurePayloadzh_fast); +RTS_FUN(unpackClosurezh_fast); +RTS_FUN(getApStackValzh_fast); RTS_FUN(noDuplicatezh_fast); diff --git a/mk/config.mk.in b/mk/config.mk.in index a47a2153a5..cda113a634 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -316,9 +316,6 @@ BuildingGranSim=$(subst mg,YES,$(filter mg,$(WAYS))) HscIfaceFileVersion=6 -# Building with debugger? -GhciWithDebugger=YES - #------------------------------------------------------------------------------ # Options for Libraries diff --git a/rts/Disassembler.c b/rts/Disassembler.c index 4407c77f3b..0620e99967 100644 --- a/rts/Disassembler.c +++ b/rts/Disassembler.c @@ -43,6 +43,11 @@ disInstr ( StgBCO *bco, int pc ) instr = instrs[pc++]; switch (instr) { + case bci_BRK_FUN: + debugBelch ("BRK_FUN " ); printPtr( ptrs[instrs[pc]] ); + debugBelch (" %d ", instrs[pc+1]); printPtr( ptrs[instrs[pc+2]] ); debugBelch("\n" ); + pc += 3; + break; case bci_SWIZZLE: debugBelch("SWIZZLE stkoff %d by %d\n", instrs[pc], (signed int)instrs[pc+1]); diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 62fd2c2ef2..188693ccb6 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -83,6 +83,7 @@ allocate_NONUPD (int n_words) return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words)); } +rtsBool stop_next_breakpoint = rtsFalse; #ifdef INTERP_STATS @@ -103,6 +104,7 @@ int it_ofreq[27]; int it_oofreq[27][27]; int it_lastopc; + #define INTERP_TICK(n) (n)++ void interp_startup ( void ) @@ -175,6 +177,9 @@ static StgWord app_ptrs_itbl[] = { (W_)&stg_ap_pppppp_info, }; +HsStablePtr breakPointIOAction; // points to the IO action which is executed on a breakpoint + // it is set in main/GHC.hs:runStmt + Capability * interpretBCO (Capability* cap) { @@ -198,8 +203,8 @@ interpretBCO (Capability* cap) // +---------------+ // if (Sp[0] == (W_)&stg_enter_info) { - Sp++; - goto eval; + Sp++; + goto eval; } // ------------------------------------------------------------------------ @@ -284,8 +289,10 @@ eval_obj: break; case BCO: + { ASSERT(((StgBCO *)obj)->arity > 0); break; + } case AP: /* Copied from stg_AP_entry. */ { @@ -672,6 +679,7 @@ do_apply: // Sadly we have three different kinds of stack/heap/cswitch check // to do: + run_BCO_return: // Heap check if (doYouWantToGC()) { @@ -680,6 +688,7 @@ run_BCO_return: } // Stack checks aren't necessary at return points, the stack use // is aggregated into the enclosing function entry point. + goto run_BCO; run_BCO_return_unboxed: @@ -689,6 +698,7 @@ run_BCO_return_unboxed: } // Stack checks aren't necessary at return points, the stack use // is aggregated into the enclosing function entry point. + goto run_BCO; run_BCO_fun: @@ -715,6 +725,7 @@ run_BCO_fun: Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow); } + goto run_BCO; // Now, actually interpret the BCO... (no returning to the @@ -723,7 +734,7 @@ run_BCO: INTERP_TICK(it_BCO_entries); { register int bciPtr = 1; /* instruction pointer */ - register StgWord16 bci; + register StgWord16 bci; register StgBCO* bco = (StgBCO*)obj; register StgWord16* instrs = (StgWord16*)(bco->instrs->payload); register StgWord* literals = (StgWord*)(&bco->literals->payload[0]); @@ -753,6 +764,7 @@ run_BCO: //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu); ); + INTERP_TICK(it_insns); #ifdef INTERP_STATS @@ -769,6 +781,88 @@ run_BCO: switch (bci & 0xFF) { + /* check for a breakpoint on the beginning of a let binding */ + case bci_BRK_FUN: + { + int arg1_brk_array, arg2_array_index, arg3_freeVars; + StgArrWords *breakPoints; + int returning_from_break; /* are we resuming execution from a breakpoint? + ** if yes, then don't break this time around */ + StgClosure *ioAction; // the io action to run at a breakpoint + + StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap + int i; + int size_words; + + arg1_brk_array = BCO_NEXT; /* first argument of break instruction */ + arg2_array_index = BCO_NEXT; /* second dargument of break instruction */ + arg3_freeVars = BCO_NEXT; /* third argument of break instruction */ + + // check if we are returning from a breakpoint - this info is stored in + // the flags field of the current TSO + returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT; + + // if we are returning from a break then skip this section and continue executing + if (!returning_from_break) + { + breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array); + + // stop the current thread if either the "stop_next_breakpoint" flag is true + // OR if the breakpoint flag for this particular expression is true + if (stop_next_breakpoint == rtsTrue || breakPoints->payload[arg2_array_index] == rtsTrue) + { + stop_next_breakpoint = rtsFalse; // make sure we don't automatically stop at the next breakpoint + + // allocate memory for a new AP_STACK, enough to store the top stack frame + // plus an stg_apply_interp_info pointer and a pointer to the BCO + size_words = BCO_BITMAP_SIZE(obj) + 2; + new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words)); + SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM); + new_aps->size = size_words; + // we should never enter new_aps->fun, so it is assigned to a dummy value + // ToDo: fixme to something that explodes with an error if you enter it + new_aps->fun = &stg_dummy_ret_closure; + + // fill in the payload of the AP_STACK + new_aps->payload[0] = (W_)&stg_apply_interp_info; + new_aps->payload[1] = (W_)obj; + + // copy the contents of the top stack frame into the AP_STACK + for (i = 2; i < size_words; i++) + { + new_aps->payload[i] = (W_)Sp[i-2]; + } + + // prepare the stack so that we can call the breakPointIOAction + // and ensure that the stack is in a reasonable state for the GC + // and so that execution of this BCO can continue when we resume + ioAction = (StgClosure *) deRefStablePtr (breakPointIOAction); + Sp -= 7; + Sp[6] = (W_)obj; + Sp[5] = (W_)&stg_apply_interp_info; + Sp[4] = (W_)new_aps; /* the AP_STACK */ + Sp[3] = (W_)BCO_PTR(arg3_freeVars); /* the info about local vars of the breakpoint */ + Sp[2] = (W_)&stg_ap_ppv_info; + Sp[1] = (W_)ioAction; /* apply the IO action to its two arguments above */ + Sp[0] = (W_)&stg_enter_info; /* get ready to run the IO action */ + + // set the flag in the TSO to say that we are now stopping at a breakpoint + // so that when we resume we don't stop on the same breakpoint that we already + // stopped at just now + cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT; + + // stop this thread and return to the scheduler - eventually we will come back + // and the IO action on the top of the stack will be executed + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); + } + } + // record that this thread is not stopped at a breakpoint anymore + cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT; + + // continue normal execution of the byte code instructions + goto nextInsn; + } + case bci_STKCHECK: { // Explicit stack check at the beginning of a function // *only* (stack checks in case alternatives are @@ -1256,7 +1350,7 @@ run_BCO: bciPtr = nextpc; goto nextInsn; } - + case bci_CASEFAIL: barf("interpretBCO: hit a CASEFAIL"); @@ -1271,3 +1365,32 @@ run_BCO: barf("interpretBCO: fell off end of the interpreter"); } + +/* temporary code for peeking inside a AP_STACK and pulling out values + based on their stack offset - used in the debugger for inspecting + the local values of a breakpoint +*/ +HsStablePtr rts_getApStackVal (HsStablePtr, int); +HsStablePtr rts_getApStackVal (HsStablePtr apStackSptr, int offset) +{ + HsStablePtr resultSptr; + StgAP_STACK *apStack; + StgClosure **payload; + StgClosure *val; + + apStack = (StgAP_STACK *) deRefStablePtr (apStackSptr); + payload = apStack->payload; + val = (StgClosure *) payload[offset+2]; + resultSptr = getStablePtr (val); + return resultSptr; +} + +/* set the single step flag for the debugger to True - + it gets set back to false in the interpreter everytime + we hit a breakpoint +*/ +void rts_setStepFlag (void); +void rts_setStepFlag (void) +{ + stop_next_breakpoint = rtsTrue; +} diff --git a/rts/Linker.c b/rts/Linker.c index 4ab84eddcd..58ee9392c6 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -525,8 +525,8 @@ typedef struct _RtsSymbolVal { SymX(hs_free_stable_ptr) \ SymX(hs_free_fun_ptr) \ SymX(initLinker) \ - SymX(infoPtrzh_fast) \ - SymX(closurePayloadzh_fast) \ + SymX(unpackClosurezh_fast) \ + SymX(getApStackValzh_fast) \ SymX(int2Integerzh_fast) \ SymX(integer2Intzh_fast) \ SymX(integer2Wordzh_fast) \ diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 31f58d1f12..bb9faddef5 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -1823,6 +1823,7 @@ newBCOzh_fast W_ bco, bitmap_arr, bytes, words; bitmap_arr = R5; + words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr); bytes = WDS(words); @@ -1876,34 +1877,48 @@ mkApUpd0zh_fast RET_P(ap); } -infoPtrzh_fast -{ -/* args: R1 = closure to analyze */ - - MAYBE_GC(R1_PTR, infoPtrzh_fast); - - W_ info; - info = %GET_STD_INFO(R1); - RET_N(info); -} - -closurePayloadzh_fast +unpackClosurezh_fast { /* args: R1 = closure to analyze */ // TODO: Consider the absence of ptrs or nonptrs as a special case ? - MAYBE_GC(R1_PTR, closurePayloadzh_fast); - W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr; info = %GET_STD_INFO(R1); ptrs = TO_W_(%INFO_PTRS(info)); nptrs = TO_W_(%INFO_NPTRS(info)); - p = 0; - ALLOC_PRIM (SIZEOF_StgMutArrPtrs + WDS(ptrs), R1_PTR, closurePayloadzh_fast); - ptrs_arr = Hp - SIZEOF_StgMutArrPtrs - WDS(ptrs) + WDS(1); + // Some closures have non-standard layout, so we omit those here. + W_ type; + type = TO_W_(%INFO_TYPE(info)); + switch [0 .. N_CLOSURE_TYPES] type { + case THUNK_SELECTOR : { + ptrs = 1; + nptrs = 0; + goto out; + } + case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, + THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : { + ptrs = 0; + nptrs = 0; + goto out; + } + default: { + goto out; + }} +out: + + W_ ptrs_arr_sz, nptrs_arr_sz; + nptrs_arr_sz = SIZEOF_StgArrWords + WDS(nptrs); + ptrs_arr_sz = SIZEOF_StgMutArrPtrs + WDS(ptrs); + + ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, unpackClosurezh_fast); + + ptrs_arr = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1); + nptrs_arr = Hp - nptrs_arr_sz + WDS(1); + SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, W_[CCCS]); StgMutArrPtrs_ptrs(ptrs_arr) = ptrs; + p = 0; for: if(p < ptrs) { W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(R1,p); @@ -1911,8 +1926,6 @@ for: goto for; } - ALLOC_PRIM (SIZEOF_StgArrWords + WDS(nptrs), R1_PTR, closurePayloadzh_fast); - nptrs_arr = Hp - SIZEOF_StgArrWords - WDS(nptrs) + WDS(1); SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]); StgArrWords_words(nptrs_arr) = nptrs; p = 0; @@ -1922,7 +1935,7 @@ for2: p = p + 1; goto for2; } - RET_PP(ptrs_arr, nptrs_arr); + RET_NPP(info, ptrs_arr, nptrs_arr); } /* ----------------------------------------------------------------------------- @@ -2149,3 +2162,16 @@ noDuplicatezh_fast jump %ENTRY_CODE(Sp(0)); } } + +getApStackValzh_fast +{ + W_ ap_stack, offset, val; + + /* args: R1 = tso, R2 = offset */ + ap_stack = R1; + offset = R2; + + val = StgClosure_payload(ap_stack,offset); + + RET_P(val); +} diff --git a/rts/Printer.c b/rts/Printer.c index 6da32fc6f8..28cdd0d4ab 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -136,6 +136,7 @@ printClosure( StgClosure *obj ) case CONSTR_NOCAF_STATIC: { StgWord i, j; + #ifdef PROFILING debugBelch("%s(", info->prof.closure_desc); debugBelch("%s", obj->header.prof.ccs->cc->label); @@ -1105,6 +1106,88 @@ findPtr(P_ p, int follow) } } +/* prettyPrintClosure() is for printing out a closure using the data constructor + names found in the info tables. Closures are printed in a fashion that resembles + their Haskell representation. Useful during debugging. + + Todo: support for more closure types, and support for non pointer fields in the + payload. +*/ + +void prettyPrintClosure_ (StgClosure *); + +void prettyPrintClosure (StgClosure *obj) +{ + prettyPrintClosure_ (obj); + debugBelch ("\n"); +} + +void prettyPrintClosure_ (StgClosure *obj) +{ + StgInfoTable *info; + StgConInfoTable *con_info; + + /* collapse any indirections */ + unsigned int type; + type = get_itbl(obj)->type; + + while (type == IND || + type == IND_STATIC || + type == IND_OLDGEN || + type == IND_PERM || + type == IND_OLDGEN_PERM) + { + obj = ((StgInd *)obj)->indirectee; + type = get_itbl(obj)->type; + } + + /* find the info table for this object */ + info = get_itbl(obj); + + /* determine what kind of object we have */ + switch (info->type) + { + /* full applications of data constructors */ + case CONSTR: + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_1_1: + case CONSTR_0_2: + case CONSTR_2_0: + case CONSTR_STATIC: + case CONSTR_NOCAF_STATIC: + { + int i; + char *descriptor; + + /* find the con_info for the constructor */ + con_info = get_con_itbl (obj); + + /* obtain the name of the constructor */ + descriptor = con_info->con_desc; + + debugBelch ("(%s", descriptor); + + /* process the payload of the closure */ + /* we don't handle non pointers at the moment */ + for (i = 0; i < info->layout.payload.ptrs; i++) + { + debugBelch (" "); + prettyPrintClosure_ ((StgClosure *) obj->payload[i]); + } + debugBelch (")"); + break; + } + + /* if it isn't a constructor then just print the closure type */ + default: + { + debugBelch ("<%s>", info_type(obj)); + break; + } + } +} + #else /* DEBUG */ void printPtr( StgPtr p ) { @@ -1115,4 +1198,6 @@ void printObj( StgClosure *obj ) { debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj ); } + + #endif /* DEBUG */ diff --git a/rts/Printer.h b/rts/Printer.h index 54bf611250..689c2f8d4a 100644 --- a/rts/Printer.h +++ b/rts/Printer.h @@ -13,6 +13,7 @@ extern void printPtr ( StgPtr p ); extern void printObj ( StgClosure *obj ); #ifdef DEBUG +extern void prettyPrintClosure (StgClosure *obj); extern void printClosure ( StgClosure *obj ); extern StgStackPtr printStackObj ( StgStackPtr sp ); extern void printStackChunk ( StgStackPtr sp, StgStackPtr spLim ); |