From: Simon Marlow Date: Tue, 17 Apr 2007 14:24:58 +0000 (+0000) Subject: Re-working of the breakpoint support X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cdce647711c0f46f5799b24de087622cb77e647f Re-working of the breakpoint support This is the result of Bernie Pope's internship work at MSR Cambridge, with some subsequent improvements by me. The main plan was to (a) Reduce the overhead for breakpoints, so we could enable the feature by default without incurrent a significant penalty (b) Scatter more breakpoint sites throughout the code Currently we can set a breakpoint on almost any subexpression, and the overhead is around 1.5x slower than normal GHCi. I hope to be able to get this down further and/or allow breakpoints to be turned off. This patch also fixes up :print following the recent changes to constructor info tables. (most of the :print tests now pass) We now support single-stepping, which just enables all breakpoints. :step executes with single-stepping turned on :step single-steps from the current breakpoint The mechanism is quite different to the previous implementation. We share code with the HPC (haskell program coverage) implementation now. The coverage pass annotates source code with "tick" locations which are tracked by the coverage tool. In GHCi, each "tick" becomes a potential breakpoint location. Previously breakpoints were compiled into code that magically invoked a nested instance of GHCi. Now, a breakpoint causes the current thread to block and control is returned to GHCi. See the wiki page for more details and the current ToDo list: http://hackage.haskell.org/trac/ghc/wiki/NewGhciDebugger --- diff --git a/compiler/Makefile b/compiler/Makefile index 1e8322b..e16bf4e 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 02ef0db..b59ddf9 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 741ca58..67cf5e4 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 72a5713..bd35072 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 64e65a4..8624780 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 -- 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 -- 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 9da049d..4b60768 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 d974c05..51d6daf 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 c6a090e..0000000 --- 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 982e315..d09196d 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 8f24239..31d48b6 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 9251a81..ac6a0c0 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 455db04..3c56567 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 28263f9..31cbd25 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 72586ab..ca66250 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 var1 ... varN of DEFAULT -> e + + (*) 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 ..." 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 5239139..3f57d18 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 "" <+> 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 2973c03..9b2dac0 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 9988325..7304d02 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 a43d4fd..f0f8973 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 d310308..0000000 --- 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 eaea844..3cab56b 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 cea3b29..b794436 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" ++ " evaluate/run \n" ++ " :add ... add module(s) to the current target set\n" ++ - " :breakpoint