diff options
| author | Simon Marlow <marlowsd@gmail.com> | 2015-10-31 17:38:34 +0000 |
|---|---|---|
| committer | Simon Marlow <marlowsd@gmail.com> | 2015-12-21 18:51:26 +0000 |
| commit | c8c44fd91b509b9eb644c826497ed5268e89363a (patch) | |
| tree | 90bc2f24a7886afb8f0036b322f839168c880057 | |
| parent | ee6fba89b066fdf8408e6a18db343a4177e613f6 (diff) | |
| download | haskell-c8c44fd91b509b9eb644c826497ed5268e89363a.tar.gz | |
Maintain cost-centre stacks in the interpreter
Summary:
Breakpoints become SCCs, so we have detailed call-stack info for
interpreted code. Currently this only works when GHC is compiled with
-prof, but D1562 (Remote GHCi) removes this constraint so that in the
future call stacks will be available without building your own GHCi.
How can you get a stack trace?
* programmatically: GHC.Stack.currentCallStack
* I've added an experimental :where command that shows the stack when
stopped at a breakpoint
* `error` attaches a call stack automatically, although since calls to
`error` are often lifted out to the top level, this is less useful
than it might be (ImplicitParams still works though).
* Later we might attach call stacks to all exceptions
Other related changes in this diff:
* I reduced the number of places that get ticks attached for
breakpoints. In particular there was a breakpoint around the whole
declaration, which was often redundant because it bound no variables.
This reduces clutter in the stack traces and speeds up compilation.
* I tidied up some RealSrcSpan stuff in InteractiveUI, and made a few
other small cleanups
Test Plan: validate
Reviewers: ezyang, bgamari, austin, hvr
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1595
GHC Trac Issues: #11047
92 files changed, 829 insertions, 610 deletions
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index efad805120..c1b149dba2 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -277,7 +277,7 @@ emitSetCCC cc tick push = do dflags <- getDynFlags if not (gopt Opt_SccProfilingOn dflags) then return () - else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW + else do tmp <- newTemp (ccsType dflags) pushCostCentre tmp curCCS cc when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp))) when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 958aa12eab..57d77c7eef 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -3,10 +3,14 @@ (c) University of Glasgow, 2007 -} -{-# LANGUAGE CPP, NondecreasingIndentation #-} +{-# LANGUAGE CPP, NondecreasingIndentation, RecordWildCards #-} module Coverage (addTicksToBinds, hpcInitCode) where +#ifdef GHCI +import qualified GHCi +import GHCi.RemoteTypes +#endif import Type import HsSyn import Module @@ -53,7 +57,7 @@ import qualified Data.Map as Map -} addTicksToBinds - :: DynFlags + :: HscEnv -> Module -> ModLocation -- ... off the current module -> NameSet -- Exported Ids. When we call addTicksToBinds, @@ -63,8 +67,9 @@ addTicksToBinds -> LHsBinds Id -> IO (LHsBinds Id, HpcInfo, ModBreaks) -addTicksToBinds dflags mod mod_loc exports tyCons binds - | let passes = coveragePasses dflags, not (null passes), +addTicksToBinds hsc_env mod mod_loc exports tyCons binds + | let dflags = hsc_dflags hsc_env + passes = coveragePasses dflags, not (null passes), Just orig_file <- ml_hs_file mod_loc = do if "boot" `isSuffixOf` orig_file @@ -94,17 +99,15 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds initState = TT { tickBoxCount = 0 , mixEntries = [] - , breakCount = 0 - , breaks = [] , uniqSupply = us } (binds1,st) = foldr tickPass (binds, initState) passes let tickCount = tickBoxCount st - hashNo <- writeMixEntries dflags mod tickCount (reverse $ mixEntries st) - orig_file2 - modBreaks <- mkModBreaks dflags (breakCount st) (reverse $ breaks st) + entries = reverse $ mixEntries st + hashNo <- writeMixEntries dflags mod tickCount entries orig_file2 + modBreaks <- mkModBreaks hsc_env mod tickCount entries when (dopt Opt_D_dump_ticked dflags) $ log_action dflags dflags SevDump noSrcSpan defaultDumpStyle @@ -127,24 +130,56 @@ guessSourceFile binds orig_file = _ -> orig_file -mkModBreaks :: DynFlags -> Int -> [MixEntry_] -> IO ModBreaks -mkModBreaks dflags count entries = do - breakArray <- newBreakArray dflags $ length entries - let - locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] - varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] - declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] - modBreaks = emptyModBreaks - { modBreaks_flags = breakArray - , modBreaks_locs = locsTicks - , modBreaks_vars = varsTicks - , modBreaks_decls = declsTicks - } - -- - return modBreaks - - -writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int +mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks +mkModBreaks hsc_env mod count entries + | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do + breakArray <- newBreakArray (length entries) +#ifdef GHCI + ccs <- mkCCSArray hsc_env mod count entries +#endif + let + locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] + varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] + declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] + return emptyModBreaks + { modBreaks_flags = breakArray + , modBreaks_locs = locsTicks + , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks +#ifdef GHCI + , modBreaks_ccs = ccs +#endif + } + | otherwise = return emptyModBreaks + +#ifdef GHCI +mkCCSArray + :: HscEnv -> Module -> Int -> [MixEntry_] + -> IO (Array BreakIndex RemotePtr {- CCostCentre -}) +mkCCSArray hsc_env modul count entries = do + if interpreterProfiled (hsc_dflags hsc_env) + then do + let module_bs = fastStringToByteString (moduleNameFS (moduleName modul)) + c_module <- GHCi.mallocData hsc_env module_bs + costcentres <- mapM (mkCostCentre hsc_env (toRemotePtr c_module)) entries + return (listArray (0,count-1) costcentres) + else do + return (listArray (0,-1) []) + where + mkCostCentre + :: HscEnv + -> RemotePtr {- CChar -} + -> MixEntry_ + -> IO (RemotePtr {- CCostCentre -}) + mkCostCentre hsc_env@HscEnv{..} c_module (srcspan, decl_path, _, _) = do + let name = concat (intersperse "." decl_path) + src = showSDoc hsc_dflags (ppr srcspan) + GHCi.mkCostCentre hsc_env c_module name src +#endif + + +writeMixEntries + :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int writeMixEntries dflags mod count entries filename | not (gopt Opt_Hpc dflags) = return 0 | otherwise = do @@ -156,7 +191,8 @@ writeMixEntries dflags mod count entries filename | moduleUnitId mod == mainUnitId = hpc_dir | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod) - tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges. + tabStop = 8 -- <tab> counts as a normal char in GHC's + -- location ranges. createDirectoryIfMissing True hpc_mod_dir modTime <- getModificationUTCTime filename @@ -203,9 +239,9 @@ shouldTickBind :: TickDensity -> Bool -- INLINE pragma? -> Bool -shouldTickBind density top_lev exported simple_pat inline +shouldTickBind density top_lev exported _simple_pat inline = case density of - TickForBreakPoints -> not simple_pat + TickForBreakPoints -> False -- we never add breakpoints to simple pattern bindings -- (there's always a tick on the rhs anyway). TickAllFunctions -> not inline @@ -296,7 +332,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do , fun_tick = tick `mbCons` fun_tick funBind } where - -- a binding is a simple pattern binding if it is a funbind with zero patterns + -- 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 @@ -329,7 +366,8 @@ addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind -bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) +bindTick + :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) bindTick density name pos fvs = do decl_path <- getPathEntry let @@ -425,18 +463,11 @@ addTickLHsExprNever (L pos e0) = do e1 <- addTickHsExpr e0 return $ L pos e1 --- general heuristic: expressions which do not denote values are good break points +-- 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 (HsIf {}) = True -isGoodBreakExpr (HsMultiIf {}) = True -isGoodBreakExpr (HsCase {}) = True -isGoodBreakExpr (RecordCon {}) = True -isGoodBreakExpr (RecordUpd {}) = True -isGoodBreakExpr (ArithSeq {}) = True -isGoodBreakExpr (PArrSeq {}) = True isGoodBreakExpr _other = False isCallSite :: HsExpr Id -> Bool @@ -957,8 +988,6 @@ liftL f (L loc a) = do data TickTransState = TT { tickBoxCount:: Int , mixEntries :: [MixEntry_] - , breakCount :: Int - , breaks :: [MixEntry_] , uniqSupply :: UniqSupply } @@ -1174,9 +1203,9 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do return $ ProfNote cc count True{-scopes-} Breakpoints -> do - c <- liftM breakCount getState - setState $ \st -> st { breakCount = c + 1 - , breaks = me:breaks st } + c <- liftM tickBoxCount getState + setState $ \st -> st { tickBoxCount = c + 1 + , mixEntries = me:mixEntries st } return $ Breakpoint c ids SourceNotes | RealSrcSpan pos' <- pos -> diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index e69cc6ef96..d7fff69c86 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -300,8 +300,8 @@ deSugar hsc_env ; (binds_cvr, ds_hpc_info, modBreaks) <- if not (isHsBootOrSig hsc_src) - then addTicksToBinds dflags mod mod_loc export_set - (typeEnvTyCons type_env) binds + then addTicksToBinds hsc_env mod mod_loc + export_set (typeEnvTyCons type_env) binds else return (binds, hpcInfo, emptyModBreaks) ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $ diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs index 875de879cb..ea3066605e 100644 --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -18,6 +18,7 @@ module ByteCodeAsm ( import ByteCodeInstr import ByteCodeItbls import ByteCodeTypes +import GHCi.RemoteTypes import HscTypes import Name @@ -359,9 +360,11 @@ assembleI dflags i = case i of RETURN_UBX rep -> emit (return_ubx rep) [] CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [SmallOp off, Op np, SmallOp i] - BRK_FUN array index info -> do p1 <- ptr (BCOPtrArray array) - p2 <- ptr (BCOPtrBreakInfo info) - emit bci_BRK_FUN [Op p1, SmallOp index, Op p2] + BRK_FUN array index info cc -> do p1 <- ptr (BCOPtrArray array) + p2 <- ptr (BCOPtrBreakInfo info) + np <- addr cc + emit bci_BRK_FUN [Op p1, SmallOp index, + Op p2, Op np] where literal (MachLabel fs (Just sz) _) @@ -383,7 +386,7 @@ assembleI dflags i = case i of literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger" litlabel fs = lit [BCONPtrLbl fs] - addr = words . mkLitPtr + addr (RemotePtr a) = words [fromIntegral a] float = words . mkLitF double = words . mkLitD dflags int = words . mkLitI @@ -422,7 +425,6 @@ return_ubx V64 = error "return_ubx: vector" mkLitI :: Int -> [Word] mkLitF :: Float -> [Word] mkLitD :: DynFlags -> Double -> [Word] -mkLitPtr :: Ptr () -> [Word] mkLitI64 :: DynFlags -> Int64 -> [Word] mkLitF f @@ -485,14 +487,5 @@ mkLitI i return [w0 :: Word] ) -mkLitPtr a - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 a - a_arr <- castSTUArray arr - w0 <- readArray a_arr 0 - return [w0 :: Word] - ) - iNTERP_STACK_CHECK_THRESH :: Int iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index f74b4c439a..fc72084292 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -60,6 +60,7 @@ import Data.Maybe import Module import Control.Arrow ( second ) +import Data.Array import Data.Map (Map) import qualified Data.Map as Map import qualified FiniteMap as Map @@ -334,7 +335,8 @@ schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList schemeER_wrk d p rhs | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs = do code <- schemeE (fromIntegral d) 0 p newRhs - arr <- getBreakArray + flag_arr <- getBreakArray + cc_arr <- getCCArray this_mod <- getCurrentModule let idOffSets = getVarOffSets d p fvs let breakInfo = BreakInfo @@ -343,9 +345,12 @@ schemeER_wrk d p rhs , breakInfo_vars = idOffSets , breakInfo_resty = exprType (deAnnotate' newRhs) } - let breakInstr = case arr of + dflags <- getDynFlags + let cc | interpreterProfiled dflags = cc_arr ! tick_no + | otherwise = toRemotePtr nullPtr + let breakInstr = case flag_arr of BA arr# -> - BRK_FUN arr# (fromIntegral tick_no) breakInfo + BRK_FUN arr# (fromIntegral tick_no) breakInfo cc return $ breakInstr `consOL` code | otherwise = schemeE (fromIntegral d) 0 p rhs @@ -782,6 +787,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple = do dflags <- getDynFlags let + profiling + | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags + | otherwise = rtsIsProfiled + -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. -- When an alt is entered, it assumes the returned value is @@ -789,6 +798,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple ret_frame_sizeW :: Word ret_frame_sizeW = 2 + -- The extra frame we push to save/restor the CCCS when profiling + save_ccs_sizeW | profiling = 2 + | otherwise = 0 + -- An unlifted value gets an extra info table pushed on top -- when it is returned. unlifted_itbl_sizeW :: Word @@ -904,8 +917,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple 0{-no arity-} bitmap_size bitmap True{-is alts-} -- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ -- "\n bitmap = " ++ show bitmap) $ do - scrut_code <- schemeE (d + ret_frame_sizeW) - (d + ret_frame_sizeW) + + scrut_code <- schemeE (d + ret_frame_sizeW + save_ccs_sizeW) + (d + ret_frame_sizeW + save_ccs_sizeW) p scrut alt_bco' <- emitBc alt_bco let push_alts @@ -1105,8 +1119,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l let ffires = primRepToFFIType dflags r_rep ffiargs = map (primRepToFFIType dflags) a_reps hsc_env <- getHscEnv - rp <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires) - let token = fromRemotePtr rp + token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires) recordFFIBc token let @@ -1633,7 +1646,7 @@ data BcM_State , nextlabel :: Word16 -- for generating local labels , ffis :: [FFIInfo] -- ffi info blocks, to free later -- Should be free()d when it is GCd - , breakArray :: BreakArray -- array of breakpoint flags + , modBreaks :: ModBreaks -- info about breakpoints } newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) @@ -1646,9 +1659,7 @@ ioToBc io = BcM $ \st -> do runBc :: HscEnv -> UniqSupply -> Module -> ModBreaks -> BcM r -> IO (BcM_State, r) runBc hsc_env us this_mod modBreaks (BcM m) - = m (BcM_State hsc_env us this_mod 0 [] breakArray) - where - breakArray = modBreaks_flags modBreaks + = m (BcM_State hsc_env us this_mod 0 [] modBreaks) thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do @@ -1689,7 +1700,7 @@ emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) emitBc bco = BcM $ \st -> return (st{ffis=[]}, bco (ffis st)) -recordFFIBc :: Ptr () -> BcM () +recordFFIBc :: RemotePtr -> BcM () recordFFIBc a = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ()) @@ -1706,7 +1717,10 @@ getLabelsBc n in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) getBreakArray :: BcM BreakArray -getBreakArray = BcM $ \st -> return (st, breakArray st) +getBreakArray = BcM $ \st -> return (st, modBreaks_flags (modBreaks st)) + +getCCArray :: BcM (Array BreakIndex RemotePtr {- CCostCentre -}) +getCCArray = BcM $ \st -> return (st, modBreaks_ccs (modBreaks st)) newUnique :: BcM Unique newUnique = BcM $ diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs index 4f2b82ba27..74c4f9692e 100644 --- a/compiler/ghci/ByteCodeInstr.hs +++ b/compiler/ghci/ByteCodeInstr.hs @@ -13,6 +13,7 @@ module ByteCodeInstr ( #include "../includes/MachDeps.h" import ByteCodeTypes +import GHCi.RemoteTypes import StgCmmLayout ( ArgRep(..) ) import PprCore import Outputable @@ -124,7 +125,7 @@ data BCInstr -- For doing calls to C (via glue code generated by libffi) | CCALL Word16 -- stack frame size - (Ptr ()) -- addr of the glue code + RemotePtr -- addr of the glue code Word16 -- whether or not the call is interruptible -- (XXX: inefficient, but I don't know -- what the alignment constraints are.) @@ -139,7 +140,7 @@ data BCInstr | RETURN_UBX ArgRep -- return an unlifted value, here's its rep -- Breakpoints - | BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo + | BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo RemotePtr -- ----------------------------------------------------------------------------- -- Printing bytecode instructions @@ -239,7 +240,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>" <+> ppr index <+> ppr info + ppr (BRK_FUN _breakArray index info _cc) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info <+> text "<cc>" -- ----------------------------------------------------------------------------- -- The stack use, in words, of each bytecode insn. These _must_ be diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs index 0a8dd304b6..500fd77c5b 100644 --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs @@ -20,6 +20,7 @@ import Outputable import PrimOp import SizedSeq import Type +import GHCi.RemoteTypes import Foreign import Data.Array.Base ( UArray(..) ) @@ -33,7 +34,7 @@ data CompiledByteCode [FFIInfo] -- ffi blocks we allocated -- ToDo: we're not tracking strings that we malloc'd -newtype FFIInfo = FFIInfo (Ptr ()) +newtype FFIInfo = FFIInfo RemotePtr deriving Show instance Outputable CompiledByteCode where diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs index d9c26c1d47..b7e0eb33f5 100644 --- a/compiler/ghci/GHCi.hs +++ b/compiler/ghci/GHCi.hs @@ -13,6 +13,8 @@ module GHCi , evalString , evalStringToIOString , mallocData + , mkCostCentre + , costCentreStackInfo -- * The object-code linker , initObjLinker @@ -207,7 +209,7 @@ handleEvalStatus :: HscEnv -> EvalStatus [HValueRef] -> IO (EvalStatus [ForeignHValue]) handleEvalStatus hsc_env status = case status of - EvalBreak a b c d -> return (EvalBreak a b c d) + EvalBreak a b c d e -> return (EvalBreak a b c d e) EvalComplete alloc res -> EvalComplete alloc <$> addFinalizer res where @@ -239,6 +241,16 @@ evalStringToIOString hsc_env fhv str = do mallocData :: HscEnv -> ByteString -> IO (Ptr ()) mallocData hsc_env bs = fromRemotePtr <$> iservCmd hsc_env (MallocData bs) +mkCostCentre + :: HscEnv -> RemotePtr {- CChar -} -> String -> String + -> IO RemotePtr {- CCostCentre -} +mkCostCentre hsc_env c_module name src = + iservCmd hsc_env (MkCostCentre c_module name src) + + +costCentreStackInfo :: HscEnv -> RemotePtr {- CCostCentreStack -} -> IO [String] +costCentreStackInfo hsc_env ccs = + iservCmd hsc_env (CostCentreStackInfo ccs) -- ----------------------------------------------------------------------------- -- Interface to the object-code linker diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 11936c7c75..a95120d906 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -820,7 +820,7 @@ dynLinkObjs hsc_env pls objs = do unlinkeds = concatMap linkableUnlinked new_objs wanted_objs = map nameOfObject unlinkeds - if loadingDynamicHSLibs (hsc_dflags hsc_env) + if interpreterDynamic (hsc_dflags hsc_env) then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs return (pls2, Succeeded) else do mapM_ (loadObj hsc_env) wanted_objs @@ -1248,16 +1248,6 @@ loadFrameworks hsc_env platform pkg Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: " ++ fw ++ " (" ++ err ++ ")" )) -loadingDynamicHSLibs :: DynFlags -> Bool -loadingDynamicHSLibs dflags - | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags - | otherwise = dynamicGhc - -loadingProfiledHSLibs :: DynFlags -> Bool -loadingProfiledHSLibs dflags - | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags - | otherwise = rtsIsProfiled - -- Try to find an object file for a given library in the given paths. -- If it isn't present, we assume that addDLL in the RTS can find it, -- which generally means that it should be a dynamic library in the @@ -1306,8 +1296,8 @@ locateLib hsc_env is_hs dirs lib arch_file = "lib" ++ lib ++ lib_tag <.> "a" lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" - loading_profiled_hs_libs = loadingProfiledHSLibs dflags - loading_dynamic_hs_libs = loadingDynamicHSLibs dflags + loading_profiled_hs_libs = interpreterProfiled dflags + loading_dynamic_hs_libs = interpreterDynamic dflags hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs index 9b84931390..447490266c 100644 --- a/compiler/main/BreakArray.hs +++ b/compiler/main/BreakArray.hs @@ -2,13 +2,16 @@ ------------------------------------------------------------------------------- -- --- | Break Arrays in the IO monad +-- (c) The University of Glasgow 2007 -- --- Entries in the array are Word sized Conceptually, a zero-indexed IOArray of --- Bools, initially False. They're represented as Words with 0==False, 1==True. --- They're used to determine whether GHCI breakpoints are on or off. +-- | Break Arrays -- --- (c) The University of Glasgow 2007 +-- An array of bytes, indexed by a breakpoint number (breakpointId in Tickish) +-- There is one of these arrays per module. +-- +-- Each byte is +-- 1 if the corresponding breakpoint is enabled +-- 0 otherwise -- ------------------------------------------------------------------------------- @@ -27,10 +30,10 @@ module BreakArray #endif ) where -import DynFlags - #ifdef GHCI import Control.Monad +import Data.Word +import GHC.Word import GHC.Exts import GHC.IO ( IO(..) ) @@ -38,43 +41,43 @@ import System.IO.Unsafe ( unsafeDupablePerformIO ) data BreakArray = BA (MutableByteArray# RealWorld) -breakOff, breakOn :: Word +breakOff, breakOn :: Word8 breakOn = 1 breakOff = 0 -showBreakArray :: DynFlags -> BreakArray -> IO () -showBreakArray dflags array = do - forM_ [0 .. (size dflags array - 1)] $ \i -> do +showBreakArray :: BreakArray -> IO () +showBreakArray array = do + forM_ [0 .. (size array - 1)] $ \i -> do val <- readBreakArray array i putStr $ ' ' : show val putStr "\n" -setBreakOn :: DynFlags -> BreakArray -> Int -> IO Bool -setBreakOn dflags array index - | safeIndex dflags array index = do +setBreakOn :: BreakArray -> Int -> IO Bool +setBreakOn array index + | safeIndex array index = do writeBreakArray array index breakOn return True | otherwise = return False -setBreakOff :: DynFlags -> BreakArray -> Int -> IO Bool -setBreakOff dflags array index - | safeIndex dflags array index = do +setBreakOff :: BreakArray -> Int -> IO Bool +setBreakOff array index + | safeIndex array index = do writeBreakArray array index breakOff return True | otherwise = return False -getBreak :: DynFlags -> BreakArray -> Int -> IO (Maybe Word) -getBreak dflags array index - | safeIndex dflags array index = do +getBreak :: BreakArray -> Int -> IO (Maybe Word8) +getBreak array index + | safeIndex array index = do val <- readBreakArray array index return $ Just val | otherwise = return Nothing -safeIndex :: DynFlags -> BreakArray -> Int -> Bool -safeIndex dflags array index = index < size dflags array && index >= 0 +safeIndex :: BreakArray -> Int -> Bool +safeIndex array index = index < size array && index >= 0 -size :: DynFlags -> BreakArray -> Int -size dflags (BA array) = size `div` wORD_SIZE dflags +size :: BreakArray -> Int +size (BA array) = size where -- We want to keep this operation pure. The mutable byte array -- is never resized so this is safe. @@ -90,30 +93,28 @@ 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 :: DynFlags -> Int -> IO BreakArray -newBreakArray dflags entries@(I# sz) = do - BA array <- allocBA (entries * wORD_SIZE dflags) +newBreakArray :: Int -> IO BreakArray +newBreakArray entries@(I# sz) = do + BA array <- allocBA entries case breakOff of - W# off -> do -- Todo: there must be a better way to write zero as a Word! - let loop n | isTrue# (n ==# sz) = return () - | otherwise = do - writeBA# array n off - loop (n +# 1#) - loop 0# + W8# off -> do + let loop n | isTrue# (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, () #) } + case writeWord8Array# array i word s of { s -> (# s, () #) } -writeBreakArray :: BreakArray -> Int -> Word -> IO () -writeBreakArray (BA array) (I# i) (W# word) = writeBA# array i word +writeBreakArray :: BreakArray -> Int -> Word8 -> IO () +writeBreakArray (BA array) (I# i) (W8# word) = writeBA# array i word -readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word +readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word8 readBA# array i = IO $ \s -> - case readWordArray# array i s of { (# s, c #) -> (# s, W# c #) } + case readWord8Array# array i s of { (# s, c #) -> (# s, W8# c #) } -readBreakArray :: BreakArray -> Int -> IO Word +readBreakArray :: BreakArray -> Int -> IO Word8 readBreakArray (BA array) (I# i) = readBA# array i #else /* !GHCI */ @@ -124,8 +125,8 @@ readBreakArray (BA array) (I# i) = readBA# array i -- presumably have a different representation. data BreakArray = Unspecified -newBreakArray :: DynFlags -> Int -> IO BreakArray -newBreakArray _ _ = return Unspecified +newBreakArray :: Int -> IO BreakArray +newBreakArray _ = return Unspecified #endif /* GHCI */ diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index a23ecfa8d3..556175c0ea 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -81,6 +81,7 @@ module DynFlags ( defaultDynFlags, -- Settings -> DynFlags defaultWays, interpWays, + interpreterProfiled, interpreterDynamic, initDynFlags, -- DynFlags -> IO DynFlags defaultFatalMessager, defaultLogAction, @@ -1522,6 +1523,16 @@ interpWays | rtsIsProfiled = [WayProf] | otherwise = [] +interpreterProfiled :: DynFlags -> Bool +interpreterProfiled dflags + | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags + | otherwise = rtsIsProfiled + +interpreterDynamic :: DynFlags -> Bool +interpreterDynamic dflags + | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags + | otherwise = dynamicGhc + -------------------------------------------------------------------------- type FatalMessager = String -> IO () diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 4bf9a5845f..0ac1331d26 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -136,8 +136,7 @@ module GHC ( -- ** The debugger SingleStep(..), - Resume(resumeStmt, resumeBreakInfo, resumeSpan, - resumeHistory, resumeHistoryIx), + Resume(..), History(historyBreakInfo, historyEnclosingDecls), GHC.getHistorySpan, getHistoryModule, abandon, abandonAll, diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 3766b57df1..ea921fe79a 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -112,6 +112,7 @@ module HscTypes ( -- * Breakpoints ModBreaks (..), BreakIndex, emptyModBreaks, + CCostCentre, -- * Vectorisation information VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, @@ -136,7 +137,7 @@ module HscTypes ( import ByteCodeTypes ( CompiledByteCode ) import InteractiveEvalTypes ( Resume ) import GHCi.Message ( Pipe ) -import GHCi.RemoteTypes ( HValueRef ) +import GHCi.RemoteTypes #endif import HsSyn @@ -191,15 +192,14 @@ import Platform import Util import GHC.Serialized ( Serialized ) +import Foreign import Control.Monad ( guard, liftM, when, ap ) import Control.Concurrent import Data.Array ( Array, array ) import Data.IORef import Data.Time -import Data.Word import Data.Typeable ( Typeable ) import Exception -import Foreign import System.FilePath import System.Process ( ProcessHandle ) @@ -2872,6 +2872,9 @@ byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) -- | Breakpoint index type BreakIndex = Int +-- | C CostCentre type +data CCostCentre + -- | All the information about the breakpoints for a given module data ModBreaks = ModBreaks @@ -2884,6 +2887,10 @@ data ModBreaks -- ^ An array giving the names of the free variables at each breakpoint. , modBreaks_decls :: !(Array BreakIndex [String]) -- ^ An array giving the names of the declarations enclosing each breakpoint. +#ifdef GHCI + , modBreaks_ccs :: !(Array BreakIndex (RemotePtr {- CCostCentre -})) + -- ^ Array pointing to cost centre for each breakpoint +#endif } -- | Construct an empty ModBreaks @@ -2894,4 +2901,7 @@ emptyModBreaks = ModBreaks , modBreaks_locs = array (0,-1) [] , modBreaks_vars = array (0,-1) [] , modBreaks_decls = array (0,-1) [] +#ifdef GHCI + , modBreaks_ccs = array (0,-1) [] +#endif } diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 2f819e4a60..eb23a60f82 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -94,7 +94,7 @@ import qualified Parser (parseStmt, parseModule, parseDeclaration) import System.Directory import Data.Dynamic import Data.Either -import Data.List (find) +import Data.List (find,intercalate) import StringBuffer (stringToStringBuffer) import Control.Monad import GHC.Exts @@ -293,7 +293,7 @@ handleRunStatus step expr bindings final_ids status history | otherwise = not_tracing where tracing - | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status + | EvalBreak is_exception apStack_ref info_ref resume_ctxt _ccs <- status , not is_exception = do hsc_env <- getSession @@ -320,7 +320,7 @@ handleRunStatus step expr bindings final_ids status history not_tracing -- Hit a breakpoint - | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status + | EvalBreak is_exception apStack_ref info_ref resume_ctxt ccs <- status = do hsc_env <- getSession let dflags = hsc_dflags hsc_env @@ -330,7 +330,7 @@ handleRunStatus step expr bindings final_ids status history apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref let mb_info | is_exception = Nothing | otherwise = Just info - (hsc_env1, names, span) <- liftIO $ + (hsc_env1, names, span, decl) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack_fhv mb_info let resume = Resume @@ -338,6 +338,8 @@ handleRunStatus step expr bindings final_ids status history , resumeBindings = bindings, resumeFinalIds = final_ids , resumeApStack = apStack_fhv, resumeBreakInfo = mb_info , resumeSpan = span, resumeHistory = toListBL history + , resumeDecl = decl + , resumeCCS = ccs , resumeHistoryIx = 0 } hsc_env2 = pushResume hsc_env1 resume @@ -365,8 +367,7 @@ isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool isBreakEnabled hsc_env inf = case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of Just hmi -> do - w <- getBreak (hsc_dflags hsc_env) - (modBreaks_flags (getModBreaks hmi)) + w <- getBreak (modBreaks_flags (getModBreaks hmi)) (breakInfo_number inf) case w of Just n -> return (n /= 0); _other -> return False _ -> @@ -419,13 +420,13 @@ resumeExec canLogSpan step fromListBL 50 hist handleRunStatus step expr bindings final_ids status hist' -back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) +back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) back n = moveHist (+n) -forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) +forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) forward n = moveHist (subtract n) -moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) +moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String) moveHist fn = do hsc_env <- getSession case ic_resume (hsc_IC hsc_env) of @@ -443,15 +444,15 @@ moveHist fn = do let update_ic apStack mb_info = do - (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env - apStack mb_info + (hsc_env1, names, span, decl) <- + liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } ic' = ic { ic_resume = r':rs } modifySession (\_ -> hsc_env1{ hsc_IC = ic' }) - return (names, new_ix, span) + return (names, new_ix, span, decl) -- careful: we want apStack to be the AP_STACK itself, not a thunk -- around it, hence the cases are carefully constructed below to @@ -474,7 +475,7 @@ bindLocalsAtBreakpoint :: HscEnv -> ForeignHValue -> Maybe BreakInfo - -> IO (HscEnv, [Name], SrcSpan) + -> IO (HscEnv, [Name], SrcSpan, String) -- Nothing case: we stopped when an exception was raised, not at a -- breakpoint. We have no location information or local variables to @@ -482,7 +483,7 @@ bindLocalsAtBreakpoint -- value. bindLocalsAtBreakpoint hsc_env apStack Nothing = do let exn_occ = mkVarOccFS (fsLit "_exception") - span = mkGeneralSrcSpan (fsLit "<exception thrown>") + span = mkGeneralSrcSpan (fsLit "<unknown>") exn_name <- newInteractiveBinder hsc_env exn_occ span let e_fs = fsLit "e" @@ -495,7 +496,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do -- Linker.extendLinkEnv [(exn_name, apStack)] - return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span) + return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>") -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. @@ -510,6 +511,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do result_ty = breakInfo_resty info occs = modBreaks_vars breaks ! index span = modBreaks_locs breaks ! index + decl = intercalate "." $ modBreaks_decls breaks ! index -- Filter out any unboxed ids; -- we can't bind these at the prompt @@ -556,7 +558,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do Linker.extendLinkEnv (zip names fhvs) when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, if result_ok then result_name:names else names, span) + return (hsc_env1, if result_ok then result_name:names else names, span, decl) where -- We need a fresh Unique for each Id we bind, because the linker -- state is single-threaded and otherwise we'd spam old bindings diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs index 98090bbaed..4372891bd8 100644 --- a/compiler/main/InteractiveEvalTypes.hs +++ b/compiler/main/InteractiveEvalTypes.hs @@ -17,7 +17,7 @@ module InteractiveEvalTypes ( #ifdef GHCI -import GHCi.RemoteTypes (ForeignHValue) +import GHCi.RemoteTypes import GHCi.Message (EvalExpr) import Id import Name @@ -67,9 +67,13 @@ data Resume resumeBreakInfo :: Maybe BreakInfo, -- the breakpoint we stopped at -- (Nothing <=> exception) - resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain - -- to fetch the ModDetails & ModBreaks - -- to get this. + resumeSpan :: SrcSpan, -- just a copy of the SrcSpan + -- from the ModBreaks, + -- otherwise it's a pain to + -- fetch the ModDetails & + -- ModBreaks to get this. + resumeDecl :: String, -- ditto + resumeCCS :: RemotePtr {- CostCentreStack -}, resumeHistory :: [History], resumeHistoryIx :: Int -- 0 <==> at the top of the history } @@ -81,4 +85,3 @@ data History historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint } #endif - diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index de14e30f76..dc85a209cf 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -2558,6 +2558,14 @@ primop GetCurrentCCSOp "getCurrentCCS#" GenPrimOp simplifier, which would result in an uninformative stack ("CAF"). } +primop ClearCCSOp "clearCCS#" GenPrimOp + (State# s -> (# State# s, a #)) -> State# s -> (# State# s, a #) + { Run the supplied IO action with an empty CCS. For example, this + is used by the interpreter to run an interpreted computation + without the call stack showing that it was invoked from GHC. } + with + out_of_line = True + ------------------------------------------------------------------------ section "Etc" {Miscellaneous built-ins} diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 0b22d1e29d..993a758d3e 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -118,7 +118,7 @@ data GHCiState = GHCiState noBuffering :: ForeignHValue } -type TickArray = Array Int [(BreakIndex,SrcSpan)] +type TickArray = Array Int [(BreakIndex,RealSrcSpan)] -- | A GHCi command data Command diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 1742253332..9e2256010b 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -58,6 +58,7 @@ import PrelNames import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName ) import SrcLoc import qualified Lexer +import ByteCodeTypes (BreakInfo(..)) import StringBuffer import Outputable hiding ( printForUser, printForUserPartWay, bold ) @@ -97,6 +98,7 @@ import qualified Data.Map as M import Exception hiding (catch) import Foreign +import GHC.Stack hiding (SrcLoc(..)) import System.Directory import System.Environment @@ -197,7 +199,8 @@ ghciCommands = map mkCmd [ ("type", keepGoing' typeOfExpr, completeExpression), ("trace", keepGoing traceCmd, completeExpression), ("undef", keepGoing undefineMacro, completeMacro), - ("unset", keepGoing unsetOptions, completeSetOptions) + ("unset", keepGoing unsetOptions, completeSetOptions), + ("where", keepGoing whereCmd, noCompletion) ] ++ map mkCmdHidden [ -- hidden commands ("all-types", keepGoing' allTypesCmd), ("complete", keepGoing completeCmd), @@ -1017,8 +1020,7 @@ toBreakIdAndLocation (Just inf) = do printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi () printStoppedAtBreakInfo res names = do - printForUser $ ptext (sLit "Stopped at") <+> - ppr (GHC.resumeSpan res) + printForUser $ pprStopped res -- printTypeOfNames session names let namesSorted = sortBy compareNames names tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted @@ -1118,6 +1120,15 @@ getCurrentBreakSpan = do pan <- GHC.getHistorySpan hist return (Just pan) +getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String]) +getCallStackAtCurrentBreakpoint = do + resumes <- GHC.getResumeContext + case resumes of + [] -> return Nothing + (r:_) -> do + hsc_env <- GHC.getSession + Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r)) + getCurrentBreakModule :: GHCi (Maybe Module) getCurrentBreakModule = do resumes <- GHC.getResumeContext @@ -2623,7 +2634,18 @@ showContext = do where pp_resume res = ptext (sLit "--> ") <> text (GHC.resumeStmt res) - $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res)) + $$ nest 2 (pprStopped res) + +pprStopped :: GHC.Resume -> SDoc +pprStopped res = + ptext (sLit "Stopped in") + <+> ((case mb_mod_name of + Nothing -> empty + Just mod_name -> text (moduleNameString mod_name) <> char '.') + <> text (GHC.resumeDecl res)) + <> char ',' <+> ppr (GHC.resumeSpan res) + where + mb_mod_name = moduleName <$> breakInfo_module <$> GHC.resumeBreakInfo res showPackages :: GHCi () showPackages = do @@ -2875,7 +2897,7 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg Just loc -> do Just md <- getCurrentBreakModule current_toplevel_decl <- enclosingTickSpan md loc - doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep + doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep stepModuleCmd :: String -> GHCi () stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg @@ -2891,17 +2913,22 @@ stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg doContinue f GHC.SingleStep -- | Returns the span of the largest tick containing the srcspan given -enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan +enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" enclosingTickSpan md (RealSrcSpan src) = do ticks <- getTickArray md let line = srcSpanStartLine src ASSERT(inRange (bounds ticks) line) do - let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" - toRealSrcSpan (RealSrcSpan s) = s - enclosing_spans = [ pan | (_,pan) <- ticks ! line - , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src] - return . head . sortBy leftmost_largest $ enclosing_spans + let enclosing_spans = [ pan | (_,pan) <- ticks ! line + , realSrcSpanEnd pan >= realSrcSpanEnd src] + return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans + where + +leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering +leftmostLargestRealSrcSpan a b = + (realSrcSpanStart a `compare` realSrcSpanStart b) + `thenCmp` + (realSrcSpanEnd b `compare` realSrcSpanEnd a) traceCmd :: String -> GHCi () traceCmd arg @@ -2980,7 +3007,7 @@ backCmd arg | otherwise = liftIO $ putStrLn "Syntax: :back [num]" where back num = withSandboxOnly ":back" $ do - (names, _, pan) <- GHC.back num + (names, _, pan, _) <- GHC.back num printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan printTypeOfNames names -- run the command set with ":set stop <cmd>" @@ -2994,7 +3021,7 @@ forwardCmd arg | otherwise = liftIO $ putStrLn "Syntax: :back [num]" where forward num = withSandboxOnly ":forward" $ do - (names, ix, pan) <- GHC.forward num + (names, ix, pan, _) <- GHC.forward num printForUser $ (if (ix == 0) then ptext (sLit "Stopped at") else ptext (sLit "Logged breakpoint at")) <+> ppr pan @@ -3024,16 +3051,13 @@ breakSwitch (arg1:rest) liftIO $ putStrLn "No modules are loaded with debugging support." | otherwise = do -- try parsing it as an identifier wantNameFromInterpretedModule noCanDo arg1 $ \name -> do - let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) - case loc of - RealSrcLoc l -> + maybe_info <- GHC.getModuleInfo (GHC.nameModule name) + case maybe_info of + Nothing -> noCanDo name (ptext (sLit "cannot get module info")) + Just minf -> ASSERT( isExternalName name ) findBreakAndSet (GHC.nameModule name) $ - findBreakByCoord (Just (GHC.srcLocFile l)) - (GHC.srcLocLine l, - GHC.srcLocCol l) - UnhelpfulLoc _ -> - noCanDo name $ text "can't find its location: " <> ppr loc + findBreakForBind name (GHC.modInfoModBreaks minf) where noCanDo n why = printForUser $ text "cannot set breakpoint on " <> ppr n <> text ": " <> why @@ -3047,29 +3071,30 @@ breakByModule _ _ breakByModuleLine :: Module -> Int -> [String] -> GHCi () breakByModuleLine md line args - | [] <- args = findBreakAndSet md $ findBreakByLine line + | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line | [col] <- args, all isDigit col = - findBreakAndSet md $ findBreakByCoord Nothing (line, read col) + findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col) | otherwise = breakSyntax breakSyntax :: a breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]") -findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () +findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi () findBreakAndSet md lookupTickTree = do - dflags <- getDynFlags tickArray <- getTickArray md (breakArray, _) <- getModBreak md case lookupTickTree tickArray of - Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location." - Just (tick, pan) -> do - success <- liftIO $ setBreakFlag dflags True breakArray tick + [] -> liftIO $ putStrLn $ "No breakpoints found at that location." + some -> mapM_ (breakAt breakArray) some + where + breakAt breakArray (tick, pan) = do + success <- liftIO $ setBreakFlag True breakArray tick if success then do (alreadySet, nm) <- recordBreak $ BreakLocation { breakModule = md - , breakLoc = pan + , breakLoc = RealSrcSpan pan , breakTick = tick , onBreakCmd = "" } @@ -3088,49 +3113,61 @@ findBreakAndSet md lookupTickTree = do -- - the leftmost subexpression starting on the specified line, or -- - the rightmost subexpression enclosing the specified line -- -findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan) +findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan) findBreakByLine line arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy (leftmost_largest `on` snd) comp) `mplus` - listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus` - listToMaybe (sortBy (rightmost `on` snd) ticks) + listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus` + listToMaybe (sortBy (compare `on` snd) incomp) `mplus` + listToMaybe (sortBy (flip compare `on` snd) ticks) where ticks = arr ! line - starts_here = [ tick | tick@(_,pan) <- ticks, - GHC.srcSpanStartLine (toRealSpan pan) == line ] + starts_here = [ (ix,pan) | (ix, pan) <- ticks, + GHC.srcSpanStartLine pan == line ] (comp, incomp) = partition ends_here starts_here - where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line - toRealSpan (RealSrcSpan pan) = pan - toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan" + where ends_here (_,pan) = GHC.srcSpanEndLine pan == line + +-- The aim is to find the breakpionts for all the RHSs of the +-- equations corresponding to a binding. So we find all breakpoints +-- for +-- (a) this binder only (not a nested declaration) +-- (b) that do not have an enclosing breakpoint +findBreakForBind :: Name -> GHC.ModBreaks -> TickArray + -> [(BreakIndex,RealSrcSpan)] +findBreakForBind name modbreaks _ = filter (not . enclosed) ticks + where + ticks = [ (index, span) + | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks), + n == occNameString (nameOccName name), + RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ] + enclosed (_,sp0) = any subspan ticks + where subspan (_,sp) = sp /= sp0 && + realSrcSpanStart sp <= realSrcSpanStart sp0 && + realSrcSpanEnd sp0 <= realSrcSpanEnd sp findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray - -> Maybe (BreakIndex,SrcSpan) + -> Maybe (BreakIndex,RealSrcSpan) findBreakByCoord mb_file (line, col) arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy (rightmost `on` snd) contains ++ - sortBy (leftmost_smallest `on` snd) after_here) + listToMaybe (sortBy (flip compare `on` snd) contains ++ + sortBy (compare `on` snd) after_here) where ticks = arr ! line -- the ticks that span this coordinate - contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col), + contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col), is_correct_file pan ] is_correct_file pan - | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f + | Just f <- mb_file = GHC.srcSpanFile pan == f | otherwise = True after_here = [ tick | tick@(_,pan) <- ticks, - let pan' = toRealSpan pan, - GHC.srcSpanStartLine pan' == line, - GHC.srcSpanStartCol pan' >= col ] - - toRealSpan (RealSrcSpan pan) = pan - toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan" + GHC.srcSpanStartLine pan == line, + GHC.srcSpanStartCol pan >= col ] -- For now, use ANSI bold on terminals that we know support it. -- Otherwise, we add a line of carets under the active expression instead. @@ -3147,6 +3184,15 @@ start_bold = "\ESC[1m" end_bold :: String end_bold = "\ESC[0m" +----------------------------------------------------------------------------- +-- :where + +whereCmd :: String -> GHCi () +whereCmd = noArgs $ do + mstrs <- getCallStackAtCurrentBreakpoint + case mstrs of + Nothing -> return () + Just strs -> liftIO $ putStrLn (renderStack strs) ----------------------------------------------------------------------------- -- :list @@ -3199,8 +3245,7 @@ list2 [arg] = do tickArray case mb_span of Nothing -> listAround (realSrcLocSpan l) False - Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan" - Just (_, RealSrcSpan pan) -> listAround pan False + Just (_, pan) -> listAround pan False UnhelpfulLoc _ -> noCanDo name $ text "can't find its location: " <> ppr loc @@ -3315,14 +3360,10 @@ discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv}) mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray mkTickArray ticks = accumArray (flip (:)) [] (1, max_line) - [ (line, (nm,pan)) | (nm,pan) <- ticks, - let pan' = toRealSpan pan, - line <- srcSpanLines pan' ] + [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ] where - max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks) + max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ] srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ] - toRealSpan (RealSrcSpan pan) = pan - toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan" -- don't reset the counter back to zero? discardActiveBreakPoints :: GHCi () @@ -3345,9 +3386,8 @@ deleteBreak identity = do turnOffBreak :: BreakLocation -> GHCi Bool turnOffBreak loc = do - dflags <- getDynFlags (arr, _) <- getModBreak (breakModule loc) - liftIO $ setBreakFlag dflags False arr (breakTick loc) + liftIO $ setBreakFlag False arr (breakTick loc) getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) getModBreak m = do @@ -3357,10 +3397,10 @@ getModBreak m = do let ticks = GHC.modBreaks_locs modBreaks return (arr, ticks) -setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> IO Bool -setBreakFlag dflags toggle arr i - | toggle = GHC.setBreakOn dflags arr i - | otherwise = GHC.setBreakOff dflags arr i +setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool +setBreakFlag toggle arr i + | toggle = GHC.setBreakOn arr i + | otherwise = GHC.setBreakOff arr i -- --------------------------------------------------------------------------- diff --git a/includes/rts/prof/CCS.h b/includes/rts/prof/CCS.h index 607931d536..f3c158d8e2 100644 --- a/includes/rts/prof/CCS.h +++ b/includes/rts/prof/CCS.h @@ -174,6 +174,7 @@ extern unsigned int RTS_VAR(era); CostCentreStack * pushCostCentre (CostCentreStack *, CostCentre *); void enterFunCCS (StgRegTable *reg, CostCentreStack *); +CostCentre *mkCostCentre (char *label, char *module, char *srcloc); /* ----------------------------------------------------------------------------- Registering CCs and CCSs diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index 06d937a6c9..1236d735ff 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -446,6 +446,7 @@ RTS_FUN_DECL(stg_numSparkszh); RTS_FUN_DECL(stg_noDuplicatezh); RTS_FUN_DECL(stg_traceCcszh); +RTS_FUN_DECL(stg_clearCCSzh); RTS_FUN_DECL(stg_traceEventzh); RTS_FUN_DECL(stg_traceMarkerzh); diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs index 8f57239a84..d7c5c94193 100644 --- a/libraries/base/GHC/Stack.hs +++ b/libraries/base/GHC/Stack.hs @@ -33,6 +33,7 @@ module GHC.Stack ( CostCentre, getCurrentCCS, getCCSOf, + clearCCS, ccsCC, ccsParent, ccLabel, diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc index b62c80a473..d40d92dc91 100644 --- a/libraries/base/GHC/Stack/CCS.hsc +++ b/libraries/base/GHC/Stack/CCS.hsc @@ -26,6 +26,7 @@ module GHC.Stack.CCS ( CostCentre, getCurrentCCS, getCCSOf, + clearCCS, ccsCC, ccsParent, ccLabel, @@ -60,6 +61,9 @@ getCCSOf obj = IO $ \s -> case getCCSOf## obj s of (## s', addr ##) -> (## s', Ptr addr ##) +clearCCS :: IO a -> IO a +clearCCS (IO m) = IO $ \s -> clearCCS## m s + ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre) ccsCC p = (# peek CostCentreStack, cc) p diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index 0d28c68db1..5406854f31 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -114,6 +114,18 @@ data Message a where :: HValueRef {- IO a -} -> Message (EvalResult ()) + -- | Create a CostCentre + MkCostCentre + :: RemotePtr -- module, RemotePtr so it can be shared + -> String -- name + -> String -- SrcSpan + -> Message RemotePtr + + -- | Show a 'CostCentreStack' as a @[String]@ + CostCentreStackInfo + :: RemotePtr {- from EvalBreak -} + -> Message [String] + -- Template Haskell ------------------------------------------- -- | Start a new TH module, return a state token that should be @@ -191,6 +203,7 @@ data EvalStatus a HValueRef{- AP_STACK -} HValueRef{- BreakInfo -} HValueRef{- ResumeContext -} + RemotePtr -- Cost centre stack deriving (Generic, Show) instance Binary a => Binary (EvalStatus a) @@ -264,24 +277,26 @@ getMessage = do 21 -> Msg <$> (EvalString <$> get) 22 -> Msg <$> (EvalStringToString <$> get <*> get) 23 -> Msg <$> (EvalIO <$> get) - 24 -> Msg <$> return StartTH - 25 -> Msg <$> FinishTH <$> get - 26 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) - 27 -> Msg <$> NewName <$> get - 28 -> Msg <$> (Report <$> get <*> get) - 29 -> Msg <$> (LookupName <$> get <*> get) - 30 -> Msg <$> Reify <$> get - 31 -> Msg <$> ReifyFixity <$> get - 32 -> Msg <$> (ReifyInstances <$> get <*> get) - 33 -> Msg <$> ReifyRoles <$> get - 34 -> Msg <$> (ReifyAnnotations <$> get <*> get) - 35 -> Msg <$> ReifyModule <$> get - 36 -> Msg <$> AddDependentFile <$> get - 37 -> Msg <$> AddTopDecls <$> get - 38 -> Msg <$> (IsExtEnabled <$> get) - 39 -> Msg <$> return ExtsEnabled - 40 -> Msg <$> return QDone - 41 -> Msg <$> QException <$> get + 24 -> Msg <$> (MkCostCentre <$> get <*> get <*> get) + 25 -> Msg <$> (CostCentreStackInfo <$> get) + 26 -> Msg <$> return StartTH + 27 -> Msg <$> FinishTH <$> get + 28 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) + 29 -> Msg <$> NewName <$> get + 30 -> Msg <$> (Report <$> get <*> get) + 31 -> Msg <$> (LookupName <$> get <*> get) + 32 -> Msg <$> Reify <$> get + 33 -> Msg <$> ReifyFixity <$> get + 34 -> Msg <$> (ReifyInstances <$> get <*> get) + 35 -> Msg <$> ReifyRoles <$> get + 36 -> Msg <$> (ReifyAnnotations <$> get <*> get) + 37 -> Msg <$> ReifyModule <$> get + 38 -> Msg <$> AddDependentFile <$> get + 39 -> Msg <$> AddTopDecls <$> get + 40 -> Msg <$> (IsExtEnabled <$> get) + 41 -> Msg <$> return ExtsEnabled + 42 -> Msg <$> return QDone + 43 -> Msg <$> QException <$> get _ -> Msg <$> QFail <$> get putMessage :: Message a -> Put @@ -310,25 +325,27 @@ putMessage m = case m of EvalString val -> putWord8 21 >> put val EvalStringToString str val -> putWord8 22 >> put str >> put val EvalIO val -> putWord8 23 >> put val - StartTH -> putWord8 24 - FinishTH val -> putWord8 25 >> put val - RunTH st q loc ty -> putWord8 26 >> put st >> put q >> put loc >> put ty - NewName a -> putWord8 27 >> put a - Report a b -> putWord8 28 >> put a >> put b - LookupName a b -> putWord8 29 >> put a >> put b - Reify a -> putWord8 30 >> put a - ReifyFixity a -> putWord8 31 >> put a - ReifyInstances a b -> putWord8 32 >> put a >> put b - ReifyRoles a -> putWord8 33 >> put a - ReifyAnnotations a b -> putWord8 34 >> put a >> put b - ReifyModule a -> putWord8 35 >> put a - AddDependentFile a -> putWord8 36 >> put a - AddTopDecls a -> putWord8 37 >> put a - IsExtEnabled a -> putWord8 38 >> put a - ExtsEnabled -> putWord8 39 - QDone -> putWord8 40 - QException a -> putWord8 41 >> put a - QFail a -> putWord8 42 >> put a + MkCostCentre name mod src -> putWord8 24 >> put name >> put mod >> put src + CostCentreStackInfo ptr -> putWord8 25 >> put ptr + StartTH -> putWord8 26 + FinishTH val -> putWord8 27 >> put val + RunTH st q loc ty -> putWord8 28 >> put st >> put q >> put loc >> put ty + NewName a -> putWord8 29 >> put a + Report a b -> putWord8 30 >> put a >> put b + LookupName a b -> putWord8 31 >> put a >> put b + Reify a -> putWord8 32 >> put a + ReifyFixity a -> putWord8 33 >> put a + ReifyInstances a b -> putWord8 34 >> put a >> put b + ReifyRoles a -> putWord8 35 >> put a + ReifyAnnotations a b -> putWord8 36 >> put a >> put b + ReifyModule a -> putWord8 37 >> put a + AddDependentFile a -> putWord8 38 >> put a + AddTopDecls a -> putWord8 39 >> put a + IsExtEnabled a -> putWord8 40 >> put a + ExtsEnabled -> putWord8 41 + QDone -> putWord8 42 + QException a -> putWord8 43 >> put a + QFail a -> putWord8 44 >> put a -- ----------------------------------------------------------------------------- -- Reading/writing messages diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs index fc142a2043..8934437a10 100644 --- a/libraries/ghci/GHCi/Run.hs +++ b/libraries/ghci/GHCi/Run.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables #-} +{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | @@ -24,6 +24,7 @@ import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Unsafe as B import GHC.Exts +import GHC.Stack import Foreign import Foreign.C import GHC.Conc.Sync @@ -56,6 +57,9 @@ run m = case m of EvalString r -> evalString r EvalStringToString r s -> evalStringToString r s EvalIO r -> evalIO r + MkCostCentre name mod src -> + toRemotePtr <$> mkCostCentre (fromRemotePtr name) mod src + CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr) MallocData bs -> mkString bs PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res FreeFFI p -> freeForeignCallInfo (fromRemotePtr p) @@ -112,7 +116,7 @@ sandboxIO opts io = do breakMVar <- newEmptyMVar statusMVar <- newEmptyMVar withBreakAction opts breakMVar statusMVar $ do - let runIt = measureAlloc $ tryEval $ rethrow opts io + let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io if useSandboxThread opts then do tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar @@ -237,7 +241,8 @@ withBreakAction opts breakMVar statusMVar act resume_r <- mkHValueRef (unsafeCoerce resume) apStack_r <- mkHValueRef apStack info_r <- mkHValueRef info - putMVar statusMVar (EvalBreak is_exception apStack_r info_r resume_r) + ccs <- toRemotePtr <$> getCCSOf apStack + putMVar statusMVar $ EvalBreak is_exception apStack_r info_r resume_r ccs takeMVar breakMVar resetBreakAction stablePtr = do @@ -305,3 +310,18 @@ mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do ptr <- mallocBytes len copyBytes ptr cstr len return (toRemotePtr ptr) + +data CCostCentre + +mkCostCentre :: Ptr CChar -> String -> String -> IO (Ptr CCostCentre) +#if defined(PROFILING) +mkCostCentre c_module srcspan decl_path = do + c_name <- newCString decl_path + c_srcspan <- newCString srcspan + c_mkCostCentre c_name c_module c_srcspan + +foreign import ccall unsafe "mkCostCentre" + c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CCostCentre) +#else +mkCostCentre _ _ _ = return nullPtr +#endif diff --git a/rts/Disassembler.c b/rts/Disassembler.c index 7e3529bb7f..2e1790ef8d 100644 --- a/rts/Disassembler.c +++ b/rts/Disassembler.c @@ -67,8 +67,9 @@ disInstr ( StgBCO *bco, int pc ) switch (instr & 0xff) { 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; + debugBelch (" %d ", instrs[pc+1]); printPtr( ptrs[instrs[pc+2]] ); + debugBelch(" %s\n", ((CostCentre*)(literals[instrs[pc+3]]))->label); + pc += 4; break; case bci_SWIZZLE: debugBelch("SWIZZLE stkoff %d by %d\n", diff --git a/rts/Interpreter.c b/rts/Interpreter.c index e1510db97f..37fef9c65e 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -18,6 +18,7 @@ #include "Prelude.h" #include "Stable.h" #include "Printer.h" +#include "Profiling.h" #include "Disassembler.h" #include "Interpreter.h" #include "ThreadPaused.h" @@ -80,7 +81,25 @@ SpLim = tso_SpLim(cap->r.rCurrentTSO); #define SAVE_STACK_POINTERS \ - cap->r.rCurrentTSO->stackobj->sp = Sp + cap->r.rCurrentTSO->stackobj->sp = Sp; + +#ifdef PROFILING +#define LOAD_THREAD_STATE() \ + LOAD_STACK_POINTERS \ + cap->r.rCCCS = cap->r.rCurrentTSO->prof.cccs; +#else +#define LOAD_THREAD_STATE() \ + LOAD_STACK_POINTERS +#endif + +#ifdef PROFILING +#define SAVE_THREAD_STATE() \ + SAVE_STACK_POINTERS \ + cap->r.rCurrentTSO->prof.cccs = cap->r.rCCCS; +#else +#define SAVE_THREAD_STATE() \ + SAVE_STACK_POINTERS +#endif // Note [Not true: ASSERT(Sp > SpLim)] // @@ -90,14 +109,14 @@ // less than SpLim both when leaving to return to the scheduler. #define RETURN_TO_SCHEDULER(todo,retcode) \ - SAVE_STACK_POINTERS; \ + SAVE_THREAD_STATE(); \ cap->r.rCurrentTSO->what_next = (todo); \ - threadPaused(cap,cap->r.rCurrentTSO); \ + threadPaused(cap,cap->r.rCurrentTSO); \ cap->r.rRet = (retcode); \ return cap; #define RETURN_TO_SCHEDULER_NO_PAUSE(todo,retcode) \ - SAVE_STACK_POINTERS; \ + SAVE_THREAD_STATE(); \ cap->r.rCurrentTSO->what_next = (todo); \ cap->r.rRet = (retcode); \ return cap; @@ -217,11 +236,24 @@ interpretBCO (Capability* cap) register StgClosure *tagged_obj = 0, *obj; nat n, m; - LOAD_STACK_POINTERS; + LOAD_THREAD_STATE(); cap->r.rHpLim = (P_)1; // HpLim is the context-switch flag; when it // goes to zero we must return to the scheduler. + IF_DEBUG(interpreter, + debugBelch( + "\n---------------------------------------------------------------\n"); + debugBelch("Entering the interpreter, Sp = %p\n", Sp); +#ifdef PROFILING + fprintCCS(stderr, cap->r.rCCCS); + debugBelch("\n"); +#endif + debugBelch("\n"); + printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size); + debugBelch("\n\n"); + ); + // ------------------------------------------------------------------------ // Case 1: // @@ -231,6 +263,8 @@ interpretBCO (Capability* cap) // +---------------+ // Sp | -------------------> closure // +---------------+ + // | stg_enter | + // +---------------+ // if (Sp[0] == (W_)&stg_enter_info) { Sp++; @@ -280,6 +314,10 @@ eval_obj: "\n---------------------------------------------------------------\n"); debugBelch("Evaluating: "); printObj(obj); debugBelch("Sp = %p\n", Sp); +#ifdef PROFILING + fprintCCS(stderr, cap->r.rCCCS); + debugBelch("\n"); +#endif debugBelch("\n" ); printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size); @@ -333,16 +371,20 @@ eval_obj: words = ap->n_args; // Stack check - if (Sp - (words+sizeofW(StgUpdateFrame)) < SpLim) { + if (Sp - (words+sizeofW(StgUpdateFrame)+2) < SpLim) { Sp -= 2; Sp[1] = (W_)tagged_obj; Sp[0] = (W_)&stg_enter_info; RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow); } - ENTER_CCS_THUNK(cap,ap); +#ifdef PROFILING + // restore the CCCS after evaluating the AP + Sp -= 2; + Sp[1] = (W_)cap->r.rCCCS; + Sp[0] = (W_)&stg_restore_cccs_info; +#endif - /* Ok; we're safe. Party on. Push an update frame. */ Sp -= sizeofW(StgUpdateFrame); { StgUpdateFrame *__frame; @@ -351,6 +393,8 @@ eval_obj: __frame->updatee = (StgClosure *)(ap); } + ENTER_CCS_THUNK(cap,ap); + /* Reload the stack */ Sp -= words; for (i=0; i < words; i++) { @@ -379,6 +423,12 @@ eval_obj: debugBelch("evaluating unknown closure -- yielding to sched\n"); printObj(obj); ); +#ifdef PROFILING + // restore the CCCS after evaluating the closure + Sp -= 2; + Sp[1] = (W_)cap->r.rCCCS; + Sp[0] = (W_)&stg_restore_cccs_info; +#endif Sp -= 2; Sp[1] = (W_)tagged_obj; Sp[0] = (W_)&stg_enter_info; @@ -398,7 +448,11 @@ do_return: "\n---------------------------------------------------------------\n"); debugBelch("Returning: "); printObj(obj); debugBelch("Sp = %p\n", Sp); - debugBelch("\n" ); +#ifdef PROFILING + fprintCCS(stderr, cap->r.rCCCS); + debugBelch("\n"); +#endif + debugBelch("\n"); printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size); debugBelch("\n\n"); ); @@ -412,6 +466,13 @@ do_return: // NOTE: not using get_itbl(). info = ((StgClosure *)Sp)->header.info; + + if (info == (StgInfoTable *)&stg_restore_cccs_info) { + cap->r.rCCCS = (CostCentreStack*)Sp[1]; + Sp += 2; + goto do_return; + } + if (info == (StgInfoTable *)&stg_ap_v_info) { n = 1; m = 0; goto do_apply; } @@ -528,6 +589,20 @@ do_return_unboxed: || Sp[0] == (W_)&stg_ret_l_info ); + IF_DEBUG(interpreter, + debugBelch( + "\n---------------------------------------------------------------\n"); + debugBelch("Returning: "); printObj(obj); + debugBelch("Sp = %p\n", Sp); +#ifdef PROFILING + fprintCCS(stderr, cap->r.rCCCS); + debugBelch("\n"); +#endif + debugBelch("\n"); + printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size); + debugBelch("\n\n"); + ); + // get the offset of the stg_ctoi_ret_XXX itbl offset = stack_frame_sizeW((StgClosure *)Sp); @@ -610,6 +685,10 @@ do_apply: Sp[i] = (W_)pap->payload[i]; } obj = UNTAG_CLOSURE(pap->fun); + +#ifdef PROFILING + enterFunCCS(&cap->r, pap->header.prof.ccs); +#endif goto run_BCO_fun; } else if (arity == n) { @@ -618,6 +697,9 @@ do_apply: Sp[i] = (W_)pap->payload[i]; } obj = UNTAG_CLOSURE(pap->fun); +#ifdef PROFILING + enterFunCCS(&cap->r, pap->header.prof.ccs); +#endif goto run_BCO_fun; } else /* arity > n */ { @@ -685,6 +767,8 @@ do_apply: // No point in us applying machine-code functions default: defer_apply_to_sched: + IF_DEBUG(interpreter, + debugBelch("Cannot apply compiled function; yielding to scheduler\n")); Sp -= 2; Sp[1] = (W_)tagged_obj; Sp[0] = (W_)&stg_enter_info; @@ -845,22 +929,40 @@ run_BCO: case bci_BRK_FUN: { int arg1_brk_array, arg2_array_index, arg3_freeVars; +#ifdef PROFILING + int arg4_cc; +#endif StgArrBytes *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 + int returning_from_break; + + // the io action to run at a breakpoint + StgClosure *ioAction; + + // a closure to save the top stack frame on the heap + StgAP_STACK *new_aps; - StgAP_STACK *new_aps; // a closure to save the top stack frame on the heap int i; int size_words; - arg1_brk_array = BCO_GET_LARGE_ARG; // 1st arg of break instruction - arg2_array_index = BCO_NEXT; // 2nd arg of break instruction - arg3_freeVars = BCO_GET_LARGE_ARG; // 3rd arg of break instruction + arg1_brk_array = BCO_GET_LARGE_ARG; + arg2_array_index = BCO_NEXT; + arg3_freeVars = BCO_GET_LARGE_ARG; +#ifdef PROFILING + arg4_cc = BCO_GET_LARGE_ARG; +#else + BCO_GET_LARGE_ARG; +#endif // 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; + // is stored in the flags field of the current TSO. If true, + // then don't break this time around. + returning_from_break = + cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT; + +#ifdef PROFILING + cap->r.rCCCS = pushCostCentre(cap->r.rCCCS, + (CostCentre*)BCO_LIT(arg4_cc)); +#endif // if we are returning from a break then skip this section // and continue executing @@ -873,7 +975,8 @@ run_BCO: // breakpoint flag for this particular expression is // true if (rts_stop_next_breakpoint == rtsTrue || - breakPoints->payload[arg2_array_index] == rtsTrue) + ((StgWord8*)breakPoints->payload)[arg2_array_index] + == rtsTrue) { // make sure we don't automatically stop at the // next breakpoint @@ -983,9 +1086,14 @@ run_BCO: case bci_PUSH_ALTS: { int o_bco = BCO_GET_LARGE_ARG; - Sp[-2] = (W_)&stg_ctoi_R1p_info; - Sp[-1] = BCO_PTR(o_bco); Sp -= 2; + Sp[1] = BCO_PTR(o_bco); + Sp[0] = (W_)&stg_ctoi_R1p_info; +#ifdef PROFILING + Sp -= 2; + Sp[1] = (W_)cap->r.rCCCS; + Sp[0] = (W_)&stg_restore_cccs_info; +#endif goto nextInsn; } @@ -994,6 +1102,11 @@ run_BCO: Sp[-2] = (W_)&stg_ctoi_R1unpt_info; Sp[-1] = BCO_PTR(o_bco); Sp -= 2; +#ifdef PROFILING + Sp -= 2; + Sp[1] = (W_)cap->r.rCCCS; + Sp[0] = (W_)&stg_restore_cccs_info; +#endif goto nextInsn; } @@ -1002,6 +1115,11 @@ run_BCO: Sp[-2] = (W_)&stg_ctoi_R1n_info; Sp[-1] = BCO_PTR(o_bco); Sp -= 2; +#ifdef PROFILING + Sp -= 2; + Sp[1] = (W_)cap->r.rCCCS; + Sp[0] = (W_)&stg_restore_cccs_info; +#endif goto nextInsn; } @@ -1010,6 +1128,11 @@ run_BCO: Sp[-2] = (W_)&stg_ctoi_F1_info; Sp[-1] = BCO_PTR(o_bco); Sp -= 2; +#ifdef PROFILING + Sp -= 2; + Sp[1] = (W_)cap->r.rCCCS; + Sp[0] = (W_)&stg_restore_cccs_info; +#endif goto nextInsn; } @@ -1018,6 +1141,11 @@ run_BCO: Sp[-2] = (W_)&stg_ctoi_D1_info; Sp[-1] = BCO_PTR(o_bco); Sp -= 2; +#ifdef PROFILING + Sp -= 2; + Sp[1] = (W_)cap->r.rCCCS; + Sp[0] = (W_)&stg_restore_cccs_info; +#endif goto nextInsn; } @@ -1026,6 +1154,11 @@ run_BCO: Sp[-2] = (W_)&stg_ctoi_L1_info; Sp[-1] = BCO_PTR(o_bco); Sp -= 2; +#ifdef PROFILING + Sp -= 2; + Sp[1] = (W_)cap->r.rCCCS; + Sp[0] = (W_)&stg_restore_cccs_info; +#endif goto nextInsn; } @@ -1034,6 +1167,11 @@ run_BCO: Sp[-2] = (W_)&stg_ctoi_V_info; Sp[-1] = BCO_PTR(o_bco); Sp -= 2; +#ifdef PROFILING + Sp -= 2; + Sp[1] = (W_)cap->r.rCCCS; + Sp[0] = (W_)&stg_restore_cccs_info; +#endif goto nextInsn; } @@ -1469,7 +1607,7 @@ run_BCO: Sp[1] = (W_)obj; Sp[0] = (W_)&stg_ret_p_info; - SAVE_STACK_POINTERS; + SAVE_THREAD_STATE(); tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse); // We already made a copy of the arguments above. @@ -1477,7 +1615,7 @@ run_BCO: // And restart the thread again, popping the stg_ret_p frame. cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r))); - LOAD_STACK_POINTERS; + LOAD_THREAD_STATE(); if (Sp[0] != (W_)&stg_ret_p_info) { // the stack is not how we left it. This probably diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 7d0c661937..2989f29462 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -1243,7 +1243,6 @@ stg_catchRetryzh (P_ first_code, /* :: STM a */ (first_code); } - stg_retryzh /* no arg list: explicit stack layout */ { W_ frame_type; @@ -1914,7 +1913,7 @@ stg_newBCOzh ( P_ instrs, ALLOC_PRIM (bytes); bco = Hp - bytes + WDS(1); - SET_HDR(bco, stg_BCO_info, CCCS); + SET_HDR(bco, stg_BCO_info, CCS_MAIN); StgBCO_instrs(bco) = instrs; StgBCO_literals(bco) = literals; @@ -1950,7 +1949,7 @@ stg_mkApUpd0zh ( P_ bco ) CCCS_ALLOC(SIZEOF_StgAP); ap = Hp - SIZEOF_StgAP + WDS(1); - SET_HDR(ap, stg_AP_info, CCCS); + SET_HDR(ap, stg_AP_info, CCS_MAIN); StgAP_n_args(ap) = HALF_W_(0); StgAP_fun(ap) = bco; @@ -2351,6 +2350,14 @@ stg_getSparkzh () #endif } +stg_clearCCSzh (P_ arg) +{ +#ifdef PROFILING + CCCS = CCS_MAIN; +#endif + jump stg_ap_v_fast(arg); +} + stg_numSparkszh () { W_ n; diff --git a/rts/Printer.c b/rts/Printer.c index 637cd9a861..e2fa57c306 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -17,6 +17,10 @@ #include "Printer.h" #include "RtsUtils.h" +#ifdef PROFILING +#include "Profiling.h" +#endif + #include <string.h> #ifdef DEBUG @@ -422,42 +426,6 @@ void printGraph( StgClosure *obj ) } */ -StgPtr -printStackObj( StgPtr sp ) -{ - /*debugBelch("Stack[%d] = ", &stgStack[STACK_SIZE] - sp); */ - - StgClosure* c = (StgClosure*)(*sp); - printPtr((StgPtr)*sp); - if (c == (StgClosure*)&stg_ctoi_R1p_info) { - debugBelch("\t\t\tstg_ctoi_ret_R1p_info\n" ); - } else - if (c == (StgClosure*)&stg_ctoi_R1n_info) { - debugBelch("\t\t\tstg_ctoi_ret_R1n_info\n" ); - } else - if (c == (StgClosure*)&stg_ctoi_F1_info) { - debugBelch("\t\t\tstg_ctoi_ret_F1_info\n" ); - } else - if (c == (StgClosure*)&stg_ctoi_D1_info) { - debugBelch("\t\t\tstg_ctoi_ret_D1_info\n" ); - } else - if (c == (StgClosure*)&stg_ctoi_V_info) { - debugBelch("\t\t\tstg_ctoi_ret_V_info\n" ); - } else - if (get_itbl(c)->type == BCO) { - debugBelch("\t\t\t"); - debugBelch("BCO(...)\n"); - } - else { - debugBelch("\t\t\t"); - printClosure ( (StgClosure*)(*sp)); - } - sp += 1; - - return sp; - -} - static void printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size ) { @@ -513,15 +481,58 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) case CATCH_FRAME: case UNDERFLOW_FRAME: case STOP_FRAME: - printObj((StgClosure*)sp); + printClosure((StgClosure*)sp); continue; - case RET_SMALL: - debugBelch("RET_SMALL (%p)\n", info); + case RET_SMALL: { + StgWord c = *sp; + if (c == (StgWord)&stg_ctoi_R1p_info) { + debugBelch("tstg_ctoi_ret_R1p_info\n" ); + } else if (c == (StgWord)&stg_ctoi_R1n_info) { + debugBelch("stg_ctoi_ret_R1n_info\n" ); + } else if (c == (StgWord)&stg_ctoi_F1_info) { + debugBelch("stg_ctoi_ret_F1_info\n" ); + } else if (c == (StgWord)&stg_ctoi_D1_info) { + debugBelch("stg_ctoi_ret_D1_info\n" ); + } else if (c == (StgWord)&stg_ctoi_V_info) { + debugBelch("stg_ctoi_ret_V_info\n" ); + } else if (c == (StgWord)&stg_ap_v_info) { + debugBelch("stg_ap_v_info\n" ); + } else if (c == (StgWord)&stg_ap_f_info) { + debugBelch("stg_ap_f_info\n" ); + } else if (c == (StgWord)&stg_ap_d_info) { + debugBelch("stg_ap_d_info\n" ); + } else if (c == (StgWord)&stg_ap_l_info) { + debugBelch("stg_ap_l_info\n" ); + } else if (c == (StgWord)&stg_ap_n_info) { + debugBelch("stg_ap_n_info\n" ); + } else if (c == (StgWord)&stg_ap_p_info) { + debugBelch("stg_ap_p_info\n" ); + } else if (c == (StgWord)&stg_ap_pp_info) { + debugBelch("stg_ap_pp_info\n" ); + } else if (c == (StgWord)&stg_ap_ppp_info) { + debugBelch("stg_ap_ppp_info\n" ); + } else if (c == (StgWord)&stg_ap_pppp_info) { + debugBelch("stg_ap_pppp_info\n" ); + } else if (c == (StgWord)&stg_ap_ppppp_info) { + debugBelch("stg_ap_ppppp_info\n" ); + } else if (c == (StgWord)&stg_ap_pppppp_info) { + debugBelch("stg_ap_pppppp_info\n" ); +#ifdef PROFILING + } else if (c == (StgWord)&stg_restore_cccs_info) { + debugBelch("stg_restore_cccs_info\n" ); + fprintCCS(stderr, (CostCentreStack*)sp[1]); + debugBelch("\n" ); + continue; +#endif + } else { + debugBelch("RET_SMALL (%p)\n", info); + } bitmap = info->layout.bitmap; printSmallBitmap(spBottom, sp+1, BITMAP_BITS(bitmap), BITMAP_SIZE(bitmap)); continue; + } case RET_BCO: { StgBCO *bco; @@ -963,4 +974,3 @@ void info_hdr_type(StgClosure *closure, char *res){ strcpy(res,closure_type_names[get_itbl(closure)->type]); } - diff --git a/rts/Printer.h b/rts/Printer.h index 96656c4602..31185aaf34 100644 --- a/rts/Printer.h +++ b/rts/Printer.h @@ -24,7 +24,6 @@ char * info_update_frame ( StgClosure *closure ); #ifdef DEBUG extern void prettyPrintClosure (StgClosure *obj); extern void printClosure ( StgClosure *obj ); -extern StgPtr printStackObj ( StgPtr sp ); extern void printStackChunk ( StgPtr sp, StgPtr spLim ); extern void printTSO ( StgTSO *tso ); diff --git a/rts/Profiling.c b/rts/Profiling.c index 982b9461a0..2c2981a02f 100644 --- a/rts/Profiling.c +++ b/rts/Profiling.c @@ -227,6 +227,15 @@ freeProfiling (void) arenaFree(prof_arena); } +CostCentre *mkCostCentre (char *label, char *module, char *srcloc) +{ + CostCentre *cc = stgMallocBytes (sizeof(CostCentre), "mkCostCentre"); + cc->label = label; + cc->module = module; + cc->srcloc = srcloc; + return cc; +} + static void initProfilingLogFile(void) { diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index 4b0a1d5b60..ffb5c39100 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -670,6 +670,7 @@ SymI_HasProto(stg_restore_cccs_info) \ SymI_HasProto(enterFunCCS) \ SymI_HasProto(pushCostCentre) \ + SymI_HasProto(mkCostCentre) \ SymI_HasProto(era) #else #define RTS_PROF_SYMBOLS /* empty */ @@ -731,6 +732,7 @@ SymI_HasProto(stg_catchRetryzh) \ SymI_HasProto(stg_catchSTMzh) \ SymI_HasProto(stg_checkzh) \ + SymI_HasProto(stg_clearCCSzh) \ SymI_HasProto(closure_flags) \ SymI_HasProto(cmp_thread) \ SymI_HasProto(createAdjustor) \ diff --git a/testsuite/tests/ghci.debugger/scripts/T2740.script b/testsuite/tests/ghci.debugger/scripts/T2740.script index a7bd833690..68554eca2e 100644 --- a/testsuite/tests/ghci.debugger/scripts/T2740.script +++ b/testsuite/tests/ghci.debugger/scripts/T2740.script @@ -1,7 +1,6 @@ :seti -XMonomorphismRestriction :l T2740.hs :step f 1 2 3 -:step :print x :print y :force x diff --git a/testsuite/tests/ghci.debugger/scripts/T2740.stdout b/testsuite/tests/ghci.debugger/scripts/T2740.stdout index 1f3e6d9ac5..efa5b1dd1e 100644 --- a/testsuite/tests/ghci.debugger/scripts/T2740.stdout +++ b/testsuite/tests/ghci.debugger/scripts/T2740.stdout @@ -1,6 +1,4 @@ -Stopped at T2740.hs:(3,1)-(4,25) -_result :: a2 = _ -Stopped at T2740.hs:3:11-13 +Stopped in Test.f, T2740.hs:3:11-13 _result :: Bool = _ x :: Integer = 1 y :: Integer = 2 diff --git a/testsuite/tests/ghci.debugger/scripts/break001.script b/testsuite/tests/ghci.debugger/scripts/break001.script index ec02c70dcc..a4d2634feb 100644 --- a/testsuite/tests/ghci.debugger/scripts/break001.script +++ b/testsuite/tests/ghci.debugger/scripts/break001.script @@ -3,8 +3,6 @@ :b 5 f (1 :: Integer) :st -:st -:st -- Test that the binding for x is now gone :show bindings y diff --git a/testsuite/tests/ghci.debugger/scripts/break001.stdout b/testsuite/tests/ghci.debugger/scripts/break001.stdout index 02ba1bbe93..99ffda067a 100644 --- a/testsuite/tests/ghci.debugger/scripts/break001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break001.stdout @@ -1,13 +1,9 @@ -Breakpoint 0 activated at ../Test2.hs:3:1-9 -Breakpoint 1 activated at ../Test2.hs:5:1-7 -Stopped at ../Test2.hs:3:1-9 -_result :: r = _ -Stopped at ../Test2.hs:3:7-9 +Breakpoint 0 activated at ../Test2.hs:3:7-9 +Breakpoint 1 activated at ../Test2.hs:5:7 +Stopped in Test2.f, ../Test2.hs:3:7-9 _result :: Integer = _ x :: Integer = 1 -Stopped at ../Test2.hs:5:1-7 -_result :: r = _ -Stopped at ../Test2.hs:5:7 +Stopped in Test2.g, ../Test2.hs:5:7 _result :: Integer = _ y :: Integer = 1 y :: Integer = 1 diff --git a/testsuite/tests/ghci.debugger/scripts/break003.stdout b/testsuite/tests/ghci.debugger/scripts/break003.stdout index b1aa8ba2d2..1d0844c6cc 100644 --- a/testsuite/tests/ghci.debugger/scripts/break003.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break003.stdout @@ -1,5 +1,5 @@ Breakpoint 0 activated at ../Test3.hs:2:18-31 -Stopped at ../Test3.hs:2:18-31 +Stopped in Main.mymap, ../Test3.hs:2:18-31 _result :: [t] = _ f :: t1 -> t = _ x :: t1 = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break005.stdout b/testsuite/tests/ghci.debugger/scripts/break005.stdout index 65eeb56cf1..81eae63726 100644 --- a/testsuite/tests/ghci.debugger/scripts/break005.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break005.stdout @@ -1,9 +1,10 @@ -Stopped at ../QSort.hs:(4,1)-(6,55) -_result :: [t] = _ -Stopped at ../QSort.hs:5:16-51 +Stopped in QSort.qsort, ../QSort.hs:5:16-51 _result :: [Integer] = _ a :: Integer = 1 left :: [Integer] = _ right :: [Integer] = _ +Stopped in QSort.qsort, ../QSort.hs:5:17-26 +_result :: [t] = _ +left :: [t] = _ () left = [] diff --git a/testsuite/tests/ghci.debugger/scripts/break006.script b/testsuite/tests/ghci.debugger/scripts/break006.script index 38cd1e14ba..6cbc050742 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.script +++ b/testsuite/tests/ghci.debugger/scripts/break006.script @@ -1,6 +1,5 @@ :l ../Test3.hs :st mymap (+1) [1::Integer,2,3] -:st :show bindings f x -- should fail, unknown return type let y = f x @@ -11,4 +10,3 @@ y -- we know the result is Integer now f x -- should work now - diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr index 58faa697c5..3b57eb3a64 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr @@ -1,9 +1,9 @@ -<interactive>:5:1: error: +<interactive>:4:1: error: • No instance for (Show t) arising from a use of ‘print’ Cannot resolve unknown runtime type ‘t’ Use :print or :force to determine these types - Relevant bindings include it :: t (bound at <interactive>:5:1) + Relevant bindings include it :: t (bound at <interactive>:4:1) These potential instances exist: instance (Show a, Show b) => Show (Either a b) -- Defined in ‘Data.Either’ @@ -14,11 +14,11 @@ (use -fprint-potential-instances to see them all) • In a stmt of an interactive GHCi command: print it -<interactive>:7:1: error: +<interactive>:6:1: error: • No instance for (Show t) arising from a use of ‘print’ Cannot resolve unknown runtime type ‘t’ Use :print or :force to determine these types - Relevant bindings include it :: t (bound at <interactive>:7:1) + Relevant bindings include it :: t (bound at <interactive>:6:1) These potential instances exist: instance (Show a, Show b) => Show (Either a b) -- Defined in ‘Data.Either’ diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stdout b/testsuite/tests/ghci.debugger/scripts/break006.stdout index 374fffd29a..d8f1b65864 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break006.stdout @@ -1,6 +1,4 @@ -Stopped at ../Test3.hs:(1,1)-(2,31) -_result :: [t] = _ -Stopped at ../Test3.hs:2:18-31 +Stopped in Main.mymap, ../Test3.hs:2:18-31 _result :: [t] = _ f :: Integer -> t = _ x :: Integer = 1 diff --git a/testsuite/tests/ghci.debugger/scripts/break008.stdout b/testsuite/tests/ghci.debugger/scripts/break008.stdout index 6961fa3cec..1a8427fa4f 100644 --- a/testsuite/tests/ghci.debugger/scripts/break008.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break008.stdout @@ -1,3 +1,3 @@ Breakpoint 0 activated at ../Test3.hs:1:14-15 -Stopped at ../Test3.hs:1:14-15 +Stopped in Main.mymap, ../Test3.hs:1:14-15 _result :: [a] = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break009.stdout b/testsuite/tests/ghci.debugger/scripts/break009.stdout index 9a4fa56446..49515cf98f 100644 --- a/testsuite/tests/ghci.debugger/scripts/break009.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break009.stdout @@ -1,5 +1,5 @@ Breakpoint 0 activated at ../Test6.hs:5:8-11 -Stopped at ../Test6.hs:5:8-11 +Stopped in Main.main, ../Test6.hs:5:8-11 _result :: a2 = _ *** Exception: Prelude.head: empty list CallStack (from ImplicitParams): diff --git a/testsuite/tests/ghci.debugger/scripts/break010.stdout b/testsuite/tests/ghci.debugger/scripts/break010.stdout index 682f4c3c1c..0bc0da7916 100644 --- a/testsuite/tests/ghci.debugger/scripts/break010.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break010.stdout @@ -1,5 +1,5 @@ Breakpoint 0 activated at ../Test6.hs:5:8-11 -Stopped at ../Test6.hs:5:8-11 +Stopped in Main.main, ../Test6.hs:5:8-11 _result :: a2 = _ -Stopped at ../Test6.hs:5:8-11 +Stopped in Main.main, ../Test6.hs:5:8-11 _result :: a2 = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break011.stdout b/testsuite/tests/ghci.debugger/scripts/break011.stdout index ec0b3e9609..5839067e8c 100644 --- a/testsuite/tests/ghci.debugger/scripts/break011.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break011.stdout @@ -1,9 +1,9 @@ *** Exception: foo CallStack (from ImplicitParams): error, called at <interactive>:2:1 in interactive:Ghci1 -Stopped at <exception thrown> +Stopped in <exception thrown>, <unknown> _exception :: e = _ -Stopped at <exception thrown> +Stopped in <exception thrown>, <unknown> _exception :: e = _ -1 : main (../Test7.hs:2:18-28) -2 : main (../Test7.hs:2:8-29) @@ -15,7 +15,7 @@ _result :: IO a3 no more logged breakpoints Logged breakpoint at ../Test7.hs:2:18-28 _result :: a3 -Stopped at <exception thrown> +Stopped at <unknown> _exception :: e already at the beginning of the history _exception = SomeException @@ -32,13 +32,13 @@ _exception :: SomeException = SomeException *** Exception: foo CallStack (from ImplicitParams): error, called at ../Test7.hs:2:18 in main:Main -Stopped at <exception thrown> +Stopped in <exception thrown>, <unknown> _exception :: e = SomeException (ErrorCallWithLocation "foo" "CallStack (from ImplicitParams): error, called at ../Test7.hs:2:18 in main:Main") -Stopped at <exception thrown> +Stopped in <exception thrown>, <unknown> _exception :: e = SomeException (ErrorCallWithLocation "foo" diff --git a/testsuite/tests/ghci.debugger/scripts/break012.script b/testsuite/tests/ghci.debugger/scripts/break012.script index 749947a4a9..acb5230051 100644 --- a/testsuite/tests/ghci.debugger/scripts/break012.script +++ b/testsuite/tests/ghci.debugger/scripts/break012.script @@ -1,9 +1,8 @@ -- Test polymorphic types in a breakpoint :l break012 :st g 5 `seq` () -:st -:t a -:t b -:t c +:t a +:t b +:t c :t d :p a b c d diff --git a/testsuite/tests/ghci.debugger/scripts/break012.stdout b/testsuite/tests/ghci.debugger/scripts/break012.stdout index 6b023718dc..4eed1e61f0 100644 --- a/testsuite/tests/ghci.debugger/scripts/break012.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break012.stdout @@ -1,6 +1,4 @@ -Stopped at break012.hs:(1,1)-(5,18) -_result :: (r, a3 -> a3, (), a2 -> a2 -> a2) = _ -Stopped at break012.hs:5:10-18 +Stopped in Main.g, break012.hs:5:10-18 _result :: (r, a3 -> a3, (), a2 -> a2 -> a2) = _ a :: r = _ b :: a4 -> a4 = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break013.script b/testsuite/tests/ghci.debugger/scripts/break013.script index b14e4c135f..1b0a84272d 100644 --- a/testsuite/tests/ghci.debugger/scripts/break013.script +++ b/testsuite/tests/ghci.debugger/scripts/break013.script @@ -1,5 +1,4 @@ -- Available bindings at where(s) :l break013 :st g 1 `seq` () -:st :show bindings diff --git a/testsuite/tests/ghci.debugger/scripts/break013.stdout b/testsuite/tests/ghci.debugger/scripts/break013.stdout index 13d203f0b3..52aa48ee83 100644 --- a/testsuite/tests/ghci.debugger/scripts/break013.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break013.stdout @@ -1,6 +1,4 @@ -Stopped at break013.hs:(1,1)-(4,18) -_result :: (Bool, Bool, ()) = _ -Stopped at break013.hs:1:7-13 +Stopped in Main.g, break013.hs:1:7-13 _result :: (Bool, Bool, ()) = _ a :: Bool = _ b :: Bool = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break014.stdout b/testsuite/tests/ghci.debugger/scripts/break014.stdout index 3d284bf11f..9197622dc8 100644 --- a/testsuite/tests/ghci.debugger/scripts/break014.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break014.stdout @@ -1,5 +1,5 @@ Breakpoint 0 activated at break014.hs:3:15-19 -Stopped at break014.hs:3:15-19 +Stopped in Main.g.c, break014.hs:3:15-19 _result :: (Bool, Bool) = _ a :: Bool = _ b :: Bool = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break017.stdout b/testsuite/tests/ghci.debugger/scripts/break017.stdout index e7e1817ecf..6c8513f00b 100644 --- a/testsuite/tests/ghci.debugger/scripts/break017.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break017.stdout @@ -1,4 +1,4 @@ -"Stopped at <exception thrown> +"Stopped in <exception thrown>, <unknown> _exception :: e = _ Logged breakpoint at ../QSort.hs:6:24-38 _result :: [Char] diff --git a/testsuite/tests/ghci.debugger/scripts/break018.script b/testsuite/tests/ghci.debugger/scripts/break018.script index 0a4c70ef5a..a30af6bfd1 100644 --- a/testsuite/tests/ghci.debugger/scripts/break018.script +++ b/testsuite/tests/ghci.debugger/scripts/break018.script @@ -1,9 +1,8 @@ -- Check mdo statements: availability of local bindings. --- Maybe we should not want to put in scope the things binded in the mdo scope, to avoid silliness. +-- Maybe we should not want to put in scope the things binded in the mdo scope, to avoid silliness. :set -XRecursiveDo :l ../mdo.hs :st l2dll "hello world" :st :st -:st diff --git a/testsuite/tests/ghci.debugger/scripts/break018.stdout b/testsuite/tests/ghci.debugger/scripts/break018.stdout index d9c6b6e06a..4ca3d6aece 100644 --- a/testsuite/tests/ghci.debugger/scripts/break018.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break018.stdout @@ -1,13 +1,14 @@ -Stopped at ../mdo.hs:(30,1)-(32,27) -_result :: IO (N a7) = _ -Stopped at ../mdo.hs:(30,16)-(32,27) +Stopped in Main.l2dll, ../mdo.hs:(30,16)-(32,27) _result :: IO (N Char) = _ x :: Char = 'h' xs :: [Char] = _ -Stopped at ../mdo.hs:30:30-42 +Stopped in Main.l2dll, ../mdo.hs:30:30-42 _result :: IO (N Char) = _ f :: N Char = _ l :: N Char = _ x :: Char = 'h' -Stopped at ../mdo.hs:(8,1)-(9,42) -_result :: IO (N a7) = _ +Stopped in Main.newNode, ../mdo.hs:(8,17)-(9,42) +_result :: IO (N Char) = _ +b :: N Char = _ +c :: Char = 'h' +f :: N Char = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break020.stdout b/testsuite/tests/ghci.debugger/scripts/break020.stdout index 0c7b0a4fc9..cab4e5ecde 100644 --- a/testsuite/tests/ghci.debugger/scripts/break020.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break020.stdout @@ -1,4 +1,4 @@ -Stopped at break020.hs:(9,8)-(15,11) +Stopped in Main.main, break020.hs:(9,8)-(15,11) _result :: IO () = _ 8 vv @@ -10,31 +10,31 @@ _result :: IO () = _ 14 line2 1 15 return () ^^ -Stopped at break020.hs:10:3-9 +Stopped in Main.main, break020.hs:10:3-9 _result :: IO () = _ 9 main = do 10 line1 0 ^^^^^^^ 11 line2 0 -Stopped at break020.hs:11:3-9 +Stopped in Main.main, break020.hs:11:3-9 _result :: IO () = _ 10 line1 0 11 line2 0 ^^^^^^^ 12 in_another_decl 0 -Stopped at break020.hs:12:3-19 +Stopped in Main.main, break020.hs:12:3-19 _result :: IO () = _ 11 line2 0 12 in_another_decl 0 ^^^^^^^^^^^^^^^^^ 13 in_another_module 0 -Stopped at break020.hs:13:3-21 +Stopped in Main.main, break020.hs:13:3-21 _result :: IO () = _ 12 in_another_decl 0 13 in_another_module 0 ^^^^^^^^^^^^^^^^^^^ 14 line2 1 -Stopped at break020.hs:14:3-9 +Stopped in Main.main, break020.hs:14:3-9 _result :: IO () = _ 13 in_another_module 0 14 line2 1 diff --git a/testsuite/tests/ghci.debugger/scripts/break021.script b/testsuite/tests/ghci.debugger/scripts/break021.script index e9251d6613..c72831d3fd 100644 --- a/testsuite/tests/ghci.debugger/scripts/break021.script +++ b/testsuite/tests/ghci.debugger/scripts/break021.script @@ -16,8 +16,3 @@ :stepmodule :stepmodule :stepmodule -:stepmodule -:stepmodule -:stepmodule -:stepmodule -:stepmodule
\ No newline at end of file diff --git a/testsuite/tests/ghci.debugger/scripts/break021.stdout b/testsuite/tests/ghci.debugger/scripts/break021.stdout index 3a78eafce7..cc680a5b30 100644 --- a/testsuite/tests/ghci.debugger/scripts/break021.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break021.stdout @@ -1,4 +1,4 @@ -Stopped at break020.hs:(9,8)-(15,11) +Stopped in Main.main, break020.hs:(9,8)-(15,11) _result :: IO () = _ 8 vv @@ -10,57 +10,37 @@ _result :: IO () = _ 14 line2 1 15 return () ^^ -Stopped at break020.hs:10:3-9 +Stopped in Main.main, break020.hs:10:3-9 _result :: IO () = _ 9 main = do 10 line1 0 ^^^^^^^ 11 line2 0 -Stopped at break020.hs:3:1-19 -_result :: IO () = _ -2 -3 line1 _ = return () - ^^^^^^^^^^^^^^^^^^^ -4 line2 _ = return () -Stopped at break020.hs:3:11-19 +Stopped in Main.line1, break020.hs:3:11-19 _result :: IO () = _ 2 3 line1 _ = return () ^^^^^^^^^ 4 line2 _ = return () -Stopped at break020.hs:11:3-9 +Stopped in Main.main, break020.hs:11:3-9 _result :: IO () = _ 10 line1 0 11 line2 0 ^^^^^^^ 12 in_another_decl 0 -Stopped at break020.hs:4:1-19 -_result :: IO () = _ -3 line1 _ = return () -4 line2 _ = return () - ^^^^^^^^^^^^^^^^^^^ -5 -Stopped at break020.hs:4:11-19 +Stopped in Main.line2, break020.hs:4:11-19 _result :: IO () = _ 3 line1 _ = return () 4 line2 _ = return () ^^^^^^^^^ 5 -Stopped at break020.hs:12:3-19 +Stopped in Main.main, break020.hs:12:3-19 _result :: IO () = _ 11 line2 0 12 in_another_decl 0 ^^^^^^^^^^^^^^^^^ 13 in_another_module 0 -Stopped at break020.hs:(6,1)-(7,30) -_result :: m () = _ -5 - vv -6 in_another_decl _ = do line1 0 -7 line2 0 - ^^ -8 -Stopped at break020.hs:(6,21)-(7,30) +Stopped in Main.in_another_decl, break020.hs:(6,21)-(7,30) _result :: m () = _ 5 vv @@ -68,67 +48,49 @@ _result :: m () = _ 7 line2 0 ^^ 8 -Stopped at break020.hs:6:24-30 +Stopped in Main.in_another_decl, break020.hs:6:24-30 _result :: m () = _ 5 6 in_another_decl _ = do line1 0 ^^^^^^^ 7 line2 0 -Stopped at break020.hs:3:1-19 -_result :: m () = _ -2 -3 line1 _ = return () - ^^^^^^^^^^^^^^^^^^^ -4 line2 _ = return () -Stopped at break020.hs:3:11-19 +Stopped in Main.line1, break020.hs:3:11-19 _result :: m () = _ 2 3 line1 _ = return () ^^^^^^^^^ 4 line2 _ = return () -Stopped at break020.hs:7:24-30 +Stopped in Main.in_another_decl, break020.hs:7:24-30 _result :: m () = _ 6 in_another_decl _ = do line1 0 7 line2 0 ^^^^^^^ 8 -Stopped at break020.hs:4:1-19 -_result :: m () = _ -3 line1 _ = return () -4 line2 _ = return () - ^^^^^^^^^^^^^^^^^^^ -5 -Stopped at break020.hs:4:11-19 +Stopped in Main.line2, break020.hs:4:11-19 _result :: m () = _ 3 line1 _ = return () 4 line2 _ = return () ^^^^^^^^^ 5 -Stopped at break020.hs:13:3-21 +Stopped in Main.main, break020.hs:13:3-21 _result :: IO () = _ 12 in_another_decl 0 13 in_another_module 0 ^^^^^^^^^^^^^^^^^^^ 14 line2 1 -Stopped at break020.hs:14:3-9 +Stopped in Main.main, break020.hs:14:3-9 _result :: IO () = _ 13 in_another_module 0 14 line2 1 ^^^^^^^ 15 return () -Stopped at break020.hs:4:1-19 -_result :: IO () = _ -3 line1 _ = return () -4 line2 _ = return () - ^^^^^^^^^^^^^^^^^^^ -5 -Stopped at break020.hs:4:11-19 +Stopped in Main.line2, break020.hs:4:11-19 _result :: IO () = _ 3 line1 _ = return () 4 line2 _ = return () ^^^^^^^^^ 5 -Stopped at break020.hs:15:3-11 +Stopped in Main.main, break020.hs:15:3-11 _result :: IO () = _ 14 line2 1 15 return () diff --git a/testsuite/tests/ghci.debugger/scripts/break022/break022.script b/testsuite/tests/ghci.debugger/scripts/break022/break022.script index 15e505ff71..33780a1408 100644 --- a/testsuite/tests/ghci.debugger/scripts/break022/break022.script +++ b/testsuite/tests/ghci.debugger/scripts/break022/break022.script @@ -6,7 +6,7 @@ -- B.boot (imports A) -- C (imports A and B) --- And we load C, to debug some function in A which enters B. +-- And we load C, to debug some function in A which enters B. -- But first we touch A, and reload. B.boot will be reloaded, but not B, which will end up with an empty modbreaks. When we :step into B, ghci will die with an out of bounds access in B's break array. -- The effect we want is B.boot being reloaded while B is not. @@ -17,5 +17,4 @@ :break a a () :st -:st -:st -- here we step into B, and produce the exception
\ No newline at end of file +:st -- here we step into B, and produce the exception diff --git a/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout b/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout index f4b804296f..b74e590ccc 100644 --- a/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout @@ -1,8 +1,7 @@ -Breakpoint 0 activated at A.hs:4:1-9 -Stopped at A.hs:4:1-9 -_result :: a3 = _ -Stopped at A.hs:4:7-9 +Breakpoint 0 activated at A.hs:4:7-9 +Stopped in A.a, A.hs:4:7-9 +_result :: () = _ +x :: () = () +Stopped in B.b, B.hs:5:7 _result :: () = _ x :: () = () -Stopped at B.hs:5:1-7 -_result :: r = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break023/break023.stdout b/testsuite/tests/ghci.debugger/scripts/break023/break023.stdout index 2b6c85daf4..e43c7cebaf 100644 --- a/testsuite/tests/ghci.debugger/scripts/break023/break023.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break023/break023.stdout @@ -1,2 +1,2 @@ -Breakpoint 0 activated at B.hs:5:1-7 -Breakpoint 1 activated at B.hs:5:1-7 +Breakpoint 0 activated at B.hs:5:7 +Breakpoint 1 activated at B.hs:5:7 diff --git a/testsuite/tests/ghci.debugger/scripts/break024.stdout b/testsuite/tests/ghci.debugger/scripts/break024.stdout index 548e7a4470..8c09cb5533 100644 --- a/testsuite/tests/ghci.debugger/scripts/break024.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break024.stdout @@ -1,19 +1,19 @@ Left user error (error) -Stopped at <exception thrown> +Stopped in <exception thrown>, <unknown> _exception :: e = _ _exception = SomeException (GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing) *** Exception: user error (error) -Stopped at <exception thrown> +Stopped in <exception thrown>, <unknown> _exception :: e = _ _exception = SomeException (GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing) -Stopped at <exception thrown> +Stopped in <exception thrown>, <unknown> _exception :: e = SomeException (GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError ....) -Stopped at <exception thrown> +Stopped in <exception thrown>, <unknown> _exception :: e = _ _exception = SomeException (GHC.IO.Exception.IOError diff --git a/testsuite/tests/ghci.debugger/scripts/break025.stdout b/testsuite/tests/ghci.debugger/scripts/break025.stdout index e38f173aff..f3ddd73d2e 100644 --- a/testsuite/tests/ghci.debugger/scripts/break025.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break025.stdout @@ -1,3 +1,3 @@ -Stopped at <exception thrown> +Stopped in <exception thrown>, <unknown> _exception :: e = _ () diff --git a/testsuite/tests/ghci.debugger/scripts/break026.script b/testsuite/tests/ghci.debugger/scripts/break026.script index b2dd79ef97..3d1da54f4d 100644 --- a/testsuite/tests/ghci.debugger/scripts/break026.script +++ b/testsuite/tests/ghci.debugger/scripts/break026.script @@ -2,9 +2,6 @@ :step foldl (+) 0 [1::Integer .. 5] :step :step -:step -:step -:step :force c -- answer should be 1 @@ -12,9 +9,6 @@ :step foldl (+) 0 [1::Integer .. 5] :step :step -:step -:step -:step -- a diversion to single-step the evaluation of c: :step c `seq` () :step diff --git a/testsuite/tests/ghci.debugger/scripts/break026.stdout b/testsuite/tests/ghci.debugger/scripts/break026.stdout index 9afc3f470e..90c1f2ee9e 100644 --- a/testsuite/tests/ghci.debugger/scripts/break026.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break026.stdout @@ -1,55 +1,39 @@ -Stopped at break026.hs:(5,1)-(7,35) -_result :: t = _ -Stopped at break026.hs:5:16-22 +Stopped in Test.foldl, break026.hs:5:16-22 _result :: Integer = _ c :: Integer = 0 go :: Integer -> [t1] -> Integer = _ xs :: [t1] = _ -Stopped at break026.hs:(6,9)-(7,35) -_result :: t = _ -f :: t -> t1 -> t = _ -Stopped at break026.hs:7:23-35 +Stopped in Test.foldl.go, break026.hs:7:23-35 _result :: Integer = _ c :: Integer = 0 f :: Integer -> Integer -> Integer = _ x :: Integer = 1 xs :: [Integer] = _ -Stopped at break026.hs:(6,9)-(7,35) -_result :: t = _ -f :: t -> t1 -> t = _ -Stopped at break026.hs:7:23-35 +Stopped in Test.foldl.go, break026.hs:7:23-35 _result :: t = _ c :: t = _ f :: t -> Integer -> t = _ x :: Integer = 2 xs :: [Integer] = _ c = 1 -Stopped at break026.hs:(5,1)-(7,35) -_result :: t = _ -Stopped at break026.hs:5:16-22 +Stopped in Test.foldl, break026.hs:5:16-22 _result :: Integer = _ c :: Integer = 0 go :: Integer -> [t1] -> Integer = _ xs :: [t1] = _ -Stopped at break026.hs:(6,9)-(7,35) -_result :: t = _ -f :: t -> t1 -> t = _ -Stopped at break026.hs:7:23-35 +Stopped in Test.foldl.go, break026.hs:7:23-35 _result :: Integer = _ c :: Integer = 0 f :: Integer -> Integer -> Integer = _ x :: Integer = 1 xs :: [Integer] = _ -Stopped at break026.hs:(6,9)-(7,35) -_result :: t = _ -f :: t -> t1 -> t = _ -Stopped at break026.hs:7:23-35 +Stopped in Test.foldl.go, break026.hs:7:23-35 _result :: t = _ c :: t = _ f :: t -> Integer -> t = _ x :: Integer = 2 xs :: [Integer] = _ -Stopped at break026.hs:7:27-31 +Stopped in Test.foldl.go, break026.hs:7:27-31 _result :: Integer = _ c :: Integer = 0 f :: Integer -> Integer -> Integer = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break027.script b/testsuite/tests/ghci.debugger/scripts/break027.script index 5c5a5f9c65..039e18a7b5 100644 --- a/testsuite/tests/ghci.debugger/scripts/break027.script +++ b/testsuite/tests/ghci.debugger/scripts/break027.script @@ -1,5 +1,4 @@ :l ../QSort :break qsort qsort [3::Integer,2,1] -:step :i a diff --git a/testsuite/tests/ghci.debugger/scripts/break027.stdout b/testsuite/tests/ghci.debugger/scripts/break027.stdout index 903b7b772a..895ce8bcfa 100644 --- a/testsuite/tests/ghci.debugger/scripts/break027.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break027.stdout @@ -1,9 +1,8 @@ -Breakpoint 0 activated at ..\QSort.hs:(4,1)-(6,55)
-Stopped at ..\QSort.hs:(4,1)-(6,55)
-_result :: [t] = _
-Stopped at ..\QSort.hs:5:16-51
-_result :: [Integer] = _
-a :: Integer = 3
-left :: [Integer] = _
-right :: [Integer] = _
-a :: Integer -- Defined in ‘interactive:Ghci2’
+Breakpoint 0 activated at ../QSort.hs:4:12-13 +Breakpoint 1 activated at ../QSort.hs:5:16-51 +Stopped in QSort.qsort, ../QSort.hs:5:16-51 +_result :: [Integer] = _ +a :: Integer = 3 +left :: [Integer] = _ +right :: [Integer] = _ +a :: Integer -- Defined in ‘interactive:Ghci1’ diff --git a/testsuite/tests/ghci.debugger/scripts/break028.stdout b/testsuite/tests/ghci.debugger/scripts/break028.stdout index bbe47267b0..790795669f 100644 --- a/testsuite/tests/ghci.debugger/scripts/break028.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break028.stdout @@ -1,5 +1,6 @@ -Stopped at break028.hs:15:1-24 -_result :: Id a4 = _ -Stopped at break028.hs:15:23-24 +Stopped in Main.g, break028.hs:15:23-24 _result :: Id a4 = _ x' :: Id a4 = _ +Stopped in Main.g.x', break028.hs:15:16-18 +_result :: Id Bool = _ +x :: Bool = False diff --git a/testsuite/tests/ghci.debugger/scripts/dynbrk002.stdout b/testsuite/tests/ghci.debugger/scripts/dynbrk002.stdout index 4eda16ea26..f4d7444aac 100644 --- a/testsuite/tests/ghci.debugger/scripts/dynbrk002.stdout +++ b/testsuite/tests/ghci.debugger/scripts/dynbrk002.stdout @@ -1,5 +1,5 @@ Breakpoint 0 activated at ../QSort.hs:5:16-51 -Stopped at ../QSort.hs:5:16-51 +Stopped in QSort.qsort, ../QSort.hs:5:16-51 _result :: [Integer] = _ a :: Integer = 8 left :: [Integer] = _ diff --git a/testsuite/tests/ghci.debugger/scripts/dynbrk007.stdout b/testsuite/tests/ghci.debugger/scripts/dynbrk007.stdout index 22adee0db2..f9d528151e 100644 --- a/testsuite/tests/ghci.debugger/scripts/dynbrk007.stdout +++ b/testsuite/tests/ghci.debugger/scripts/dynbrk007.stdout @@ -1,11 +1,11 @@ -Stopped at dynbrk007.hs:(2,5)-(6,11) +Stopped in Main.f, dynbrk007.hs:(2,5)-(6,11) _result :: Maybe Int = _ -Stopped at dynbrk007.hs:3:9-16 +Stopped in Main.f, dynbrk007.hs:3:9-16 _result :: Maybe Int = _ -Stopped at dynbrk007.hs:4:9-16 +Stopped in Main.f, dynbrk007.hs:4:9-16 _result :: Maybe Integer = _ -Stopped at dynbrk007.hs:5:9-16 +Stopped in Main.f, dynbrk007.hs:5:9-16 _result :: Maybe Integer = _ -Stopped at dynbrk007.hs:6:4-11 +Stopped in Main.f, dynbrk007.hs:6:4-11 _result :: Maybe Int = _ i :: Int = 1 diff --git a/testsuite/tests/ghci.debugger/scripts/dynbrk008.script b/testsuite/tests/ghci.debugger/scripts/dynbrk008.script index e99ee6076e..e40c6d92b5 100644 --- a/testsuite/tests/ghci.debugger/scripts/dynbrk008.script +++ b/testsuite/tests/ghci.debugger/scripts/dynbrk008.script @@ -6,4 +6,3 @@ :st :st :st -:st diff --git a/testsuite/tests/ghci.debugger/scripts/dynbrk008.stdout b/testsuite/tests/ghci.debugger/scripts/dynbrk008.stdout index 722f2991f3..88a7964a21 100644 --- a/testsuite/tests/ghci.debugger/scripts/dynbrk008.stdout +++ b/testsuite/tests/ghci.debugger/scripts/dynbrk008.stdout @@ -1,15 +1,13 @@ -Stopped at dynbrk008.hs:2:1-41 -_result :: [Int] = _ -Stopped at dynbrk008.hs:2:7-41 +Stopped in Main.f, dynbrk008.hs:2:7-41 _result :: [Int] = _ i :: Int = 42 -Stopped at dynbrk008.hs:2:18-20 +Stopped in Main.f, dynbrk008.hs:2:18-20 _result :: [Int] = _ i :: Int = 42 -Stopped at dynbrk008.hs:2:28-30 +Stopped in Main.f, dynbrk008.hs:2:28-30 _result :: [Int] = _ j :: Int = 42 -Stopped at dynbrk008.hs:2:38-40 +Stopped in Main.f, dynbrk008.hs:2:38-40 _result :: [Int] = _ h :: Int = 42 [42] diff --git a/testsuite/tests/ghci.debugger/scripts/dynbrk009.script b/testsuite/tests/ghci.debugger/scripts/dynbrk009.script index 7d00f193a5..c90a31c6aa 100644 --- a/testsuite/tests/ghci.debugger/scripts/dynbrk009.script +++ b/testsuite/tests/ghci.debugger/scripts/dynbrk009.script @@ -7,4 +7,3 @@ :st :st :st -:st diff --git a/testsuite/tests/ghci.debugger/scripts/dynbrk009.stdout b/testsuite/tests/ghci.debugger/scripts/dynbrk009.stdout index 65ab5e6126..96a086f91f 100644 --- a/testsuite/tests/ghci.debugger/scripts/dynbrk009.stdout +++ b/testsuite/tests/ghci.debugger/scripts/dynbrk009.stdout @@ -1,8 +1,7 @@ -Stopped at dynbrk009.hs:8:22 +Stopped in Main.test.(...), dynbrk009.hs:8:22 _result :: Int = _ -Stopped at dynbrk009.hs:8:27-36 +Stopped in Main.test, dynbrk009.hs:8:27-36 _result :: Int = _ -Stopped at dynbrk009.hs:8:31-35 -Stopped at dynbrk009.hs:6:1-9 -Stopped at dynbrk009.hs:6:9 +Stopped in Main.test, dynbrk009.hs:8:31-35 +Stopped in Main.f, dynbrk009.hs:6:9 3 diff --git a/testsuite/tests/ghci.debugger/scripts/getargs.stdout b/testsuite/tests/ghci.debugger/scripts/getargs.stdout index 659308cd77..3169eb6b1f 100644 --- a/testsuite/tests/ghci.debugger/scripts/getargs.stdout +++ b/testsuite/tests/ghci.debugger/scripts/getargs.stdout @@ -1,3 +1,3 @@ -Stopped at ..\getargs.hs:3:8-24 +Stopped in Main.main, ../getargs.hs:3:8-24 _result :: IO () = _ ["42"] diff --git a/testsuite/tests/ghci.debugger/scripts/hist001.stdout b/testsuite/tests/ghci.debugger/scripts/hist001.stdout index 3a70f6aa1e..7ef5dc1e8e 100644 --- a/testsuite/tests/ghci.debugger/scripts/hist001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/hist001.stdout @@ -1,19 +1,13 @@ Breakpoint 0 activated at ../Test3.hs:1:14-15 -[2,3Stopped at ../Test3.hs:1:14-15 +[2,3Stopped in Main.mymap, ../Test3.hs:1:14-15 _result :: [a] = _ --1 : mymap (../Test3.hs:(1,1)-(2,31)) --2 : mymap (../Test3.hs:2:22-31) --3 : mymap (../Test3.hs:2:18-20) --4 : mymap (../Test3.hs:2:18-31) --5 : mymap (../Test3.hs:(1,1)-(2,31)) --6 : mymap (../Test3.hs:2:22-31) --7 : mymap (../Test3.hs:2:18-20) --8 : mymap (../Test3.hs:2:18-31) --9 : mymap (../Test3.hs:(1,1)-(2,31)) +-1 : mymap (../Test3.hs:2:22-31) +-2 : mymap (../Test3.hs:2:18-20) +-3 : mymap (../Test3.hs:2:18-31) +-4 : mymap (../Test3.hs:2:22-31) +-5 : mymap (../Test3.hs:2:18-20) +-6 : mymap (../Test3.hs:2:18-31) <end of history> -Logged breakpoint at ../Test3.hs:(1,1)-(2,31) -_result :: [t] -_result :: [t] = _ Logged breakpoint at ../Test3.hs:2:22-31 _result :: [t] f :: t1 -> t @@ -21,11 +15,19 @@ xs :: [t1] xs :: [t1] = [] f :: t1 -> t = _ _result :: [t] = _ -*** Ignoring breakpoint -_result = [] Logged breakpoint at ../Test3.hs:2:18-20 _result :: t f :: Integer -> t x :: Integer -Logged breakpoint at ../Test3.hs:2:22-31 +xs :: [t1] = [] +x :: Integer = 2 +f :: Integer -> t = _ +_result :: t = _ +_result = 3 +Logged breakpoint at ../Test3.hs:2:18-31 _result :: [t] +f :: Integer -> t +x :: Integer +xs :: [Integer] +Logged breakpoint at ../Test3.hs:2:18-20 +_result :: t diff --git a/testsuite/tests/ghci.debugger/scripts/listCommand001.stdout b/testsuite/tests/ghci.debugger/scripts/listCommand001.stdout index 26a27ac5a5..956ae6a97a 100644 --- a/testsuite/tests/ghci.debugger/scripts/listCommand001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/listCommand001.stdout @@ -5,7 +5,6 @@ cannot list source code for map: module GHC.Base is not interpreted 1 mymap f [] = [] 2 mymap f (x:xs) = f x:mymap f xs 3 -3 4 main = mapM_ putStrLn $ mymap ('a':) ["hello","bye"] 5 3 diff --git a/testsuite/tests/ghci.debugger/scripts/listCommand002.stdout b/testsuite/tests/ghci.debugger/scripts/listCommand002.stdout index 95854884b2..574f3e341a 100644 --- a/testsuite/tests/ghci.debugger/scripts/listCommand002.stdout +++ b/testsuite/tests/ghci.debugger/scripts/listCommand002.stdout @@ -1,6 +1,6 @@ -Stopped at listCommand002.hs:(3,8)-(5,24) +Stopped in Main.main, listCommand002.hs:(3,8)-(5,24) _result :: IO () = _ -Stopped at listCommand002.hs:4:3-26 +Stopped in Main.main, listCommand002.hs:4:3-26 _result :: IO () = _ -Stopped at listCommand002.hs:5:3-24 +Stopped in Main.main, listCommand002.hs:5:3-24 _result :: IO () = _ diff --git a/testsuite/tests/ghci.debugger/scripts/print005.stdout b/testsuite/tests/ghci.debugger/scripts/print005.stdout index b193d1350f..171055ade6 100644 --- a/testsuite/tests/ghci.debugger/scripts/print005.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print005.stdout @@ -1,5 +1,5 @@ Breakpoint 0 activated at ../QSort.hs:5:16-51 -Stopped at ../QSort.hs:5:16-51 +Stopped in QSort.qsort, ../QSort.hs:5:16-51 _result :: [Integer] = _ a :: Integer = 8 left :: [Integer] = _ @@ -12,7 +12,7 @@ left = (_t2::[Integer]) left = 4 : (_t3::[Integer]) 1 left = [4] -Stopped at ../QSort.hs:5:16-51 +Stopped in QSort.qsort, ../QSort.hs:5:16-51 _result :: [Integer] = _ a :: Integer = 4 left :: [Integer] = _ diff --git a/testsuite/tests/ghci.debugger/scripts/print018.script b/testsuite/tests/ghci.debugger/scripts/print018.script index 695dfca291..12f7cc1519 100644 --- a/testsuite/tests/ghci.debugger/scripts/print018.script +++ b/testsuite/tests/ghci.debugger/scripts/print018.script @@ -6,7 +6,6 @@ :break poly poly Unary -:step :p x :t x seq x () diff --git a/testsuite/tests/ghci.debugger/scripts/print018.stdout b/testsuite/tests/ghci.debugger/scripts/print018.stdout index 614b7d3657..65e4302f7c 100644 --- a/testsuite/tests/ghci.debugger/scripts/print018.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print018.stdout @@ -1,7 +1,5 @@ -Breakpoint 0 activated at ../Test.hs:40:1-17 -Stopped at ../Test.hs:40:1-17 -_result :: () = _ -Stopped at ../Test.hs:40:10-17 +Breakpoint 0 activated at ../Test.hs:40:10-17 +Stopped in Test.Test2.poly, ../Test.hs:40:10-17 _result :: () = _ x :: a41 = _ x = (_t1::a41) diff --git a/testsuite/tests/ghci.debugger/scripts/print020.stdout b/testsuite/tests/ghci.debugger/scripts/print020.stdout index 80e9473911..bbeeae1223 100644 --- a/testsuite/tests/ghci.debugger/scripts/print020.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print020.stdout @@ -1,14 +1,19 @@ -Breakpoint 0 activated at ../HappyTest.hs:(226,1)-(237,35) -Stopped at ../HappyTest.hs:(226,1)-(237,35) -_result :: [Token] = _ -*** Ignoring breakpoint -*** Ignoring breakpoint -*** Ignoring breakpoint -*** Ignoring breakpoint -*** Ignoring breakpoint -*** Ignoring breakpoint -*** Ignoring breakpoint -*** Ignoring breakpoint -*** Ignoring breakpoint -*** Ignoring breakpoint -_result = [TokenInt 1,TokenPlus,TokenInt 2,TokenPlus,TokenInt 3] +Breakpoint 0 activated at ../HappyTest.hs:226:12-13 +Breakpoint 1 activated at ../HappyTest.hs:228:11-19 +Breakpoint 2 activated at ../HappyTest.hs:228:23-30 +Breakpoint 3 activated at ../HappyTest.hs:229:11-19 +Breakpoint 4 activated at ../HappyTest.hs:229:23-35 +Breakpoint 5 activated at ../HappyTest.hs:230:11-19 +Breakpoint 6 activated at ../HappyTest.hs:230:23-35 +Breakpoint 7 activated at ../HappyTest.hs:231:18-35 +Breakpoint 8 activated at ../HappyTest.hs:232:18-37 +Breakpoint 9 activated at ../HappyTest.hs:233:18-38 +Breakpoint 10 activated at ../HappyTest.hs:234:18-38 +Breakpoint 11 activated at ../HappyTest.hs:235:18-36 +Breakpoint 12 activated at ../HappyTest.hs:236:18-35 +Breakpoint 13 activated at ../HappyTest.hs:237:18-35 +Stopped in Main.lexer, ../HappyTest.hs:228:11-19 +_result :: Bool = _ +c :: Char = '1' +*** Ignoring breakpoint +_result = False diff --git a/testsuite/tests/ghci.debugger/scripts/print022.script b/testsuite/tests/ghci.debugger/scripts/print022.script index cfed80380e..66f3ef848d 100644 --- a/testsuite/tests/ghci.debugger/scripts/print022.script +++ b/testsuite/tests/ghci.debugger/scripts/print022.script @@ -4,6 +4,5 @@ seq test () :print test :break f f test2 -:step :fo x -:t x
\ No newline at end of file +:t x diff --git a/testsuite/tests/ghci.debugger/scripts/print022.stdout b/testsuite/tests/ghci.debugger/scripts/print022.stdout index 85111a2c7e..47c1483fc4 100644 --- a/testsuite/tests/ghci.debugger/scripts/print022.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print022.stdout @@ -1,9 +1,7 @@ () test = C 1 32 1.2 1.23 'x' 1 1.2 1.23 -Breakpoint 0 activated at print022.hs:11:1-7 -Stopped at print022.hs:11:1-7 -_result :: r = _ -Stopped at print022.hs:11:7 +Breakpoint 0 activated at print022.hs:11:7 +Stopped in Main.f, print022.hs:11:7 _result :: r = _ x :: r = _ x = C2 1 (W# 32) (TwoFields 'a' 3) diff --git a/testsuite/tests/ghci.debugger/scripts/print025.script b/testsuite/tests/ghci.debugger/scripts/print025.script index 926890f4bc..655267332c 100644 --- a/testsuite/tests/ghci.debugger/scripts/print025.script +++ b/testsuite/tests/ghci.debugger/scripts/print025.script @@ -5,4 +5,3 @@ i f i -- RTTI happens implicitly when the bindings at f come into context :step -:step
\ No newline at end of file diff --git a/testsuite/tests/ghci.debugger/scripts/print025.stdout b/testsuite/tests/ghci.debugger/scripts/print025.stdout index 3936640210..5dbd12b57f 100644 --- a/testsuite/tests/ghci.debugger/scripts/print025.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print025.stdout @@ -1,8 +1,6 @@ T 1 -Breakpoint 0 activated at print025.hs:2:1-7 -Stopped at print025.hs:2:1-7 -_result :: r = _ -Stopped at print025.hs:2:7 +Breakpoint 0 activated at print025.hs:2:7 +Stopped in Main.f, print025.hs:2:7 _result :: T Int s = _ x :: T Int s = T 1 T 1 diff --git a/testsuite/tests/ghci.debugger/scripts/print029.script b/testsuite/tests/ghci.debugger/scripts/print029.script index b320153d17..6e350fde04 100644 --- a/testsuite/tests/ghci.debugger/scripts/print029.script +++ b/testsuite/tests/ghci.debugger/scripts/print029.script @@ -3,8 +3,7 @@ let a = MkT2 [Just (1::Int)] a :break f f a -:step -- Unsound! A false type is assigned to x --- reconstructType decides to stop too soon because +-- reconstructType decides to stop too soon because -- its BFS has recovered a monomorphic type -:p x
\ No newline at end of file +:p x diff --git a/testsuite/tests/ghci.debugger/scripts/print029.stdout b/testsuite/tests/ghci.debugger/scripts/print029.stdout index 366d1d480a..838570f9ce 100644 --- a/testsuite/tests/ghci.debugger/scripts/print029.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print029.stdout @@ -1,8 +1,6 @@ MkT2 [Just 1] -Breakpoint 0 activated at print029.hs:4:1-7 -MkT2 Stopped at print029.hs:4:1-7 -_result :: t Int = _ -Stopped at print029.hs:4:7 +Breakpoint 0 activated at print029.hs:4:7 +MkT2 Stopped in Main.f, print029.hs:4:7 _result :: t Int = _ x :: t Int = [Just 1] x = [Just 1] diff --git a/testsuite/tests/ghci.debugger/scripts/print030.script b/testsuite/tests/ghci.debugger/scripts/print030.script index 9296c90163..d3042d01bd 100644 --- a/testsuite/tests/ghci.debugger/scripts/print030.script +++ b/testsuite/tests/ghci.debugger/scripts/print030.script @@ -3,7 +3,6 @@ let a = MkT2 (map Just [(1::Int)]) :break f seq a () f a -:step -- Unsound! A false type is assigned to x -- reconstructType is forced to stop too soon -- because the elements of the list in x are not evaluated yet diff --git a/testsuite/tests/ghci.debugger/scripts/print030.stdout b/testsuite/tests/ghci.debugger/scripts/print030.stdout index a67d0492d2..1c7bf3c18e 100644 --- a/testsuite/tests/ghci.debugger/scripts/print030.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print030.stdout @@ -1,7 +1,5 @@ -Breakpoint 0 activated at print029.hs:4:1-7 +Breakpoint 0 activated at print029.hs:4:7 () -MkT2 Stopped at print029.hs:4:1-7 -_result :: t Int = _ -Stopped at print029.hs:4:7 +MkT2 Stopped in Main.f, print029.hs:4:7 _result :: t Int = _ x :: t Int = _ : _ diff --git a/testsuite/tests/ghci.debugger/scripts/print031.script b/testsuite/tests/ghci.debugger/scripts/print031.script index fb6308ffcf..2e3223e354 100644 --- a/testsuite/tests/ghci.debugger/scripts/print031.script +++ b/testsuite/tests/ghci.debugger/scripts/print031.script @@ -3,8 +3,7 @@ let a = MkT2 [Just (Phantom 1)] :break f a f a -:step --- ghc crashes now when the type for x is recovered +-- ghc crashes now when the type for x is recovered -- and unifyRTTI fails to compute a substitution -:p x +:p x :q diff --git a/testsuite/tests/ghci.debugger/scripts/print031.stdout b/testsuite/tests/ghci.debugger/scripts/print031.stdout index 81a2518a31..6a326a6fae 100644 --- a/testsuite/tests/ghci.debugger/scripts/print031.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print031.stdout @@ -1,8 +1,6 @@ -Breakpoint 0 activated at print031.hs:7:1-19 +Breakpoint 0 activated at print031.hs:7:7-19 MkT2 [Just (Phantom 1)] -Stopped at print031.hs:7:1-19 -_result :: Bool = _ -Stopped at print031.hs:7:7-19 +Stopped in Print031.f, print031.hs:7:7-19 _result :: Bool = _ x :: t (Phantom a6) = [Just (Phantom 1)] x = [Just (Phantom 1)] diff --git a/testsuite/tests/ghci.debugger/scripts/print032.script b/testsuite/tests/ghci.debugger/scripts/print032.script index fa872af5d3..25abb3718f 100644 --- a/testsuite/tests/ghci.debugger/scripts/print032.script +++ b/testsuite/tests/ghci.debugger/scripts/print032.script @@ -5,4 +5,3 @@ let b = MkT2 (map Just [2::Int]) -- Want to obtain a thunk :break f2 f2 a b :step - diff --git a/testsuite/tests/ghci.debugger/scripts/print032.stdout b/testsuite/tests/ghci.debugger/scripts/print032.stdout index 766139fd67..9fe9911513 100644 --- a/testsuite/tests/ghci.debugger/scripts/print032.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print032.stdout @@ -1,8 +1,7 @@ MkT2 [Just 1] -Breakpoint 0 activated at print029.hs:7:1-14 -Stopped at print029.hs:7:1-14 -_result :: (t Int, t Int) = _ -Stopped at print029.hs:7:10-14 +Breakpoint 0 activated at print029.hs:7:10-14 +Stopped in Main.f2, print029.hs:7:10-14 _result :: (t Int, t Int) = _ x :: t Int = [Just 1] y :: t Int = _ +(MkT2 [Just 1],MkT2 [Just 2]) diff --git a/testsuite/tests/ghci.debugger/scripts/result001.stdout b/testsuite/tests/ghci.debugger/scripts/result001.stdout index 0d2173dcd8..2ff2838182 100644 --- a/testsuite/tests/ghci.debugger/scripts/result001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/result001.stdout @@ -1,4 +1,4 @@ Breakpoint 0 activated at result001.hs:1:13-21 -Stopped at result001.hs:1:13-21 +Stopped in Main.f, result001.hs:1:13-21 _result :: [b] = _ xs :: [b] = _ |