diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/codeGen/StgCmmProf.hs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 121 | ||||
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 4 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeAsm.hs | 21 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeGen.hs | 40 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeInstr.hs | 7 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeTypes.hs | 3 | ||||
| -rw-r--r-- | compiler/ghci/GHCi.hs | 14 | ||||
| -rw-r--r-- | compiler/ghci/Linker.hs | 16 | ||||
| -rw-r--r-- | compiler/main/BreakArray.hs | 83 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 11 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 3 | ||||
| -rw-r--r-- | compiler/main/HscTypes.hs | 16 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 34 | ||||
| -rw-r--r-- | compiler/main/InteractiveEvalTypes.hs | 13 | ||||
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 8 |
16 files changed, 235 insertions, 161 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} |