diff options
Diffstat (limited to 'compiler')
26 files changed, 290 insertions, 271 deletions
diff --git a/compiler/DLL-NOTES b/compiler/DLL-NOTES deleted file mode 100644 index c710b14251..0000000000 --- a/compiler/DLL-NOTES +++ /dev/null @@ -1,58 +0,0 @@ - The DLL story - ------------- - -*** - -This file is intended to be a focal point for notes on how DLLs work. Please -add cross-references to source and other docs, especially when you don't -find something here that you need. - -*** - - -Introduction ------------- - -On Windows, DLLs are synonymous with packages (since 4.07; this change -simplified a rather horrible mess). Hence whenever a module is to be -compiled to go in a DLL, it must be compiled with -package-name dll-name. -Typically, failing to do this gives Windows error message boxes of the form -"The instruction at address <x> tried to read memory at address <x>". - - -Dependencies ------------- - -Because references in DLLs must be fully resolved when the DLL is compiled -(except for references to other DLLs), it is not possible for DLLs to call -the main program. This means that the parts of the RTS and standard package -which call the main program cannot be compiled into the relevant DLLs, and -must instead be compiled as standalone object files and linked in to each -executable. This gives the following picture of dependencies within a program: - - ___________ ___________ - | |------>| | GHC-land | Application-land -DLL-land | HSrts.dll | | HSstd.dll | | - |___________|<------|___________| | - | ^ | ------------------|-------------------|-------------------| - _____v_____ _____|______ | -.o-land | | | | | - | Main.o | | PrelMain.o |----------------------- - |___________| |____________| | | - | | ______v______ - | | | | - ------------------------------------------>| Main.o | - | |_____________| - -(The application's dependencies are not shown.) - - -Bits of the compiler that deal with DLLs ----------------------------------------- - -basicTypes/Module.lhs is the most important place, as it deals with which -modules identifiers are in. - -basicTypes/name.lhs, other bits of basicTypes/, nativeGen/, codeGen/, -abcCSyn/, and even profiling/ have other references. diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs index 6fba95c0b5..f99a50cfeb 100644 --- a/compiler/basicTypes/Unique.lhs +++ b/compiler/basicTypes/Unique.lhs @@ -56,10 +56,10 @@ module Unique ( mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, + mkCostCentreUnique, mkBuiltinUnique, - mkPseudoUniqueC, - mkPseudoUniqueD, + mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH ) where @@ -359,11 +359,10 @@ mkPArrDataConUnique a = mkUnique ':' (2*a) initTyVarUnique :: Unique initTyVarUnique = mkUnique 't' 0 -mkPseudoUniqueC, mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, +mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, mkBuiltinUnique :: Int -> Unique mkBuiltinUnique i = mkUnique 'B' i -mkPseudoUniqueC i = mkUnique 'C' i -- used for getUnique on Regs mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs @@ -374,6 +373,9 @@ mkRegSubUnique = mkUnique 'S' mkRegPairUnique = mkUnique 'P' mkRegClassUnique = mkUnique 'L' +mkCostCentreUnique :: Int -> Unique +mkCostCentreUnique = mkUnique 'C' + mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique -- See Note [The Unique of an OccName] in OccName mkVarOccUnique fs = mkUnique 'i' (iBox (uniqueOfFS fs)) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 270ce12670..d2a95b6599 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -447,9 +447,6 @@ pprLit platform lit = case lit of -- WARNING: -- * the lit must occur in the info table clbl2 -- * clbl1 must be an SRT, a slow entry point or a large bitmap - -- The Mangler is expected to convert any reference to an SRT, - -- a slow entry point or a large bitmap - -- from an info table to an offset. -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i where diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 2ff422299b..25ba154d12 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -24,7 +24,7 @@ module CgInfoTbls ( cmmGetClosureType, infoTable, infoTableClosureType, infoTablePtrs, infoTableNonPtrs, - funInfoTable, makeRelativeRefTo + funInfoTable ) where @@ -386,25 +386,3 @@ emitInfoTableAndCode emitInfoTableAndCode entry_ret_lbl info args blocks = emitProc info entry_ret_lbl args blocks -------------------------------------------------------------------------- --- --- Position independent code --- -------------------------------------------------------------------------- --- In order to support position independent code, we mustn't put absolute --- references into read-only space. Info tables in the tablesNextToCode --- case must be in .text, which is read-only, so we doctor the CmmLits --- to use relative offsets instead. - --- Note that this is done even when the -fPIC flag is not specified, --- as we want to keep binary compatibility between PIC and non-PIC. - -makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit - -makeRelativeRefTo info_lbl (CmmLabel lbl) - | tablesNextToCode - = CmmLabelDiffOff lbl info_lbl 0 -makeRelativeRefTo info_lbl (CmmLabelOff lbl off) - | tablesNextToCode - = CmmLabelDiffOff lbl info_lbl off -makeRelativeRefTo _ lit = lit diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 72bbf6cc58..43a570d41e 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -38,6 +38,7 @@ import Module import Constants import Outputable import FastString +import StaticFlags -- --------------------------------------------------------------------------- -- Code generation for PrimOps @@ -155,7 +156,13 @@ emitPrimOp [res] SparkOp [arg] live = do where newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) -emitPrimOp [res] GetCCCSOp [] _live +emitPrimOp [res] GetCCSOfOp [arg] _live + = stmtC (CmmAssign (CmmLocal res) val) + where + val | opt_SccProfilingOn = costCentreFrom (cmmUntag arg) + | otherwise = CmmLit zeroCLit + +emitPrimOp [res] GetCurrentCCSOp [_dummy_arg] _live = stmtC (CmmAssign (CmmLocal res) curCCS) emitPrimOp [res] ReadMutVarOp [mutv] _ diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 3e247ff4d6..a2e40d0f78 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -35,7 +35,7 @@ module CgProf ( #include "../includes/rts/Constants.h" -- For LDV_CREATE_MASK, LDV_STATE_USE -- which are StgWords -#include "../includes/DerivedConstants.h" +#include "../includes/dist-derivedconstants/header/DerivedConstants.h" -- For REP_xxx constants, which are MachReps import ClosureInfo @@ -170,11 +170,15 @@ emitCostCentreDecl cc = do -- All cost centres will be in the main package, since we -- don't normally use -auto-all or add SCCs to other packages. -- Hence don't emit the package name in the module here. + ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ + showSDoc (ppr (costCentreSrcSpan cc)) + -- XXX going via FastString to get UTF-8 encoding is silly ; let lits = [ zero, -- StgInt ccID, label, -- char *label, modl, -- char *module, - zero, -- StgWord time_ticks + loc, -- char *srcloc, + zero, -- StgWord time_ticks zero64, -- StgWord64 mem_alloc is_caf, -- StgInt is_caf zero -- struct _CostCentre *link diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index 04f38ac8c4..0ff440e6bf 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -43,7 +43,7 @@ module CgTicky ( staticTickyHdr, ) where -#include "../includes/DerivedConstants.h" +#include "../includes/dist-derivedconstants/header/DerivedConstants.h" -- For REP_xxx constants, which are MachReps import ClosureInfo diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index d546c38a90..a2337aee91 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -42,6 +42,7 @@ import Constants import Module import FastString import Outputable +import StaticFlags ------------------------------------------------------------------------ -- Primitive operations and foreign calls @@ -228,7 +229,13 @@ emitPrimOp [res] SparkOp [arg] [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] emit (mkAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) -emitPrimOp [res] GetCCCSOp [] +emitPrimOp [res] GetCCSOfOp [arg] + = emit (mkAssign (CmmLocal res) val) + where + val | opt_SccProfilingOn = costCentreFrom (cmmUntag arg) + | otherwise = CmmLit zeroCLit + +emitPrimOp [res] GetCurrentCCSOp [_dummy_arg] = emit (mkAssign (CmmLocal res) curCCS) emitPrimOp [res] ReadMutVarOp [mutv] diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index d9b3583382..88031dce48 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -36,7 +36,7 @@ module StgCmmProf ( #include "../includes/rts/Constants.h" -- For LDV_CREATE_MASK, LDV_STATE_USE -- which are StgWords -#include "../includes/DerivedConstants.h" +#include "../includes/dist-derivedconstants/header/DerivedConstants.h" -- For REP_xxx constants, which are MachReps import StgCmmClosure @@ -58,6 +58,7 @@ import Constants -- Lots of field offsets import Outputable import Control.Monad +import Data.Char (ord) ----------------------------------------------------------------------------- -- @@ -217,18 +218,25 @@ emitCostCentreDecl cc = do ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS $ Module.moduleName $ cc_mod cc) + ; loc <- newStringCLit (showSDoc (ppr (costCentreSrcSpan cc))) + -- XXX should UTF-8 encode -- All cost centres will be in the main package, since we -- don't normally use -auto-all or add SCCs to other packages. -- Hence don't emit the package name in the module here. ; let lits = [ zero, -- StgInt ccID, label, -- char *label, - modl, -- char *module, - zero, -- StgWord time_ticks + modl, -- char *module, + loc, -- char *srcloc, + zero, -- StgWord time_ticks zero64, -- StgWord64 mem_alloc + is_caf, -- StgInt is_caf zero -- struct _CostCentre *link ] ; emitDataLits (mkCCLabel cc) lits } + where + is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF + | otherwise = zero emitCostCentreStackDecl :: CostCentreStack -> FCode () emitCostCentreStackDecl ccs diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 8b8ab34989..a6c592cfd8 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -46,7 +46,7 @@ module StgCmmTicky ( ) where #include "HsVersions.h" -#include "../includes/DerivedConstants.h" +#include "../includes/dist-derivedconstants/header/DerivedConstants.h" -- For REP_xxx constants, which are MachReps import StgCmmClosure diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 78c733d830..04bb9d4a68 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -38,7 +38,7 @@ module CoreSyn ( -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, - collectArgs, coreExprCc, flattenBinds, + collectArgs, flattenBinds, isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, @@ -1184,14 +1184,6 @@ collectArgs expr go e as = (e, as) \end{code} -\begin{code} --- | Gets the cost centre enclosing an expression, if any. --- It looks inside lambdas because @(scc \"foo\" \\x.e) = \\x. scc \"foo\" e@ -coreExprCc :: Expr b -> CostCentre -coreExprCc (Tick (ProfNote { profNoteCC = cc}) _) = cc -coreExprCc _ = noCostCentre -\end{code} - %************************************************************************ %* * \subsection{Predicates} diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index fd2895d072..84cb6d628f 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -33,6 +33,7 @@ import HscTypes import Platform import StaticFlags import TyCon +import Unique import BasicTypes import MonadUtils import Maybes @@ -177,8 +178,7 @@ data TickDensity | TickAllFunctions -- for -prof-auto-all | TickTopFunctions -- for -prof-auto-top | TickExportedFunctions -- for -prof-auto-exported - -- maybe also: - -- | TickCallSites -- for stack tracing + | TickCallSites -- for stack tracing deriving Eq mkDensity :: DynFlags -> TickDensity @@ -188,8 +188,13 @@ mkDensity dflags | ProfAutoAll <- profAuto dflags = TickAllFunctions | ProfAutoTop <- profAuto dflags = TickTopFunctions | ProfAutoExports <- profAuto dflags = TickExportedFunctions + | ProfAutoCalls <- profAuto dflags = TickCallSites | otherwise = panic "desnity" - + -- ToDo: -fhpc is taking priority over -fprof-auto here. It seems + -- that coverage works perfectly well with profiling, but you don't + -- get any auto-generated SCCs. It would make perfect sense to + -- allow both of them, and indeed to combine some of the other flags + -- (-fprof-auto-calls -fprof-auto-top, for example) -- | Decide whether to add a tick to a binding or not. shouldTickBind :: TickDensity @@ -208,6 +213,7 @@ shouldTickBind density top_lev exported simple_pat inline TickTopFunctions -> top_lev && not inline TickExportedFunctions -> exported && not inline TickForCoverage -> True + TickCallSites -> False shouldTickPatBind :: TickDensity -> Bool -> Bool shouldTickPatBind density top_lev @@ -217,6 +223,7 @@ shouldTickPatBind density top_lev TickTopFunctions -> top_lev TickExportedFunctions -> False TickForCoverage -> False + TickCallSites -> False -- ----------------------------------------------------------------------------- -- Adding ticks to bindings @@ -323,38 +330,60 @@ bindTick density name pos fvs = do -- selectively add ticks to interesting expressions addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExpr (L pos e0) = do +addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of + TickForBreakPoints | isGoodBreakExpr e0 -> tick_it TickForCoverage -> tick_it - TickForBreakPoints -> if isGoodBreakExpr e0 then tick_it else dont_tick_it + TickCallSites | isCallSite e0 -> tick_it _other -> dont_tick_it where tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = do e1 <- addTickHsExpr e0; return $ L pos e1 - --- Add a tick to the expression no matter what it is. There is one exception: --- for the debugger, if the expression is a 'let', then we don't want to add --- a tick here because there will definititely be a tick on the body anyway. -addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExprAlways (L pos e0) = do + dont_tick_it = addTickLHsExprNever e + +-- Add a tick to an expression which is the RHS of an equation or a binding. +-- We always consider these to be breakpoints, unless the expression is a 'let' +-- (because the body will definitely have a tick somewhere). ToDo: perhaps +-- we should treat 'case' and 'if' the same way? +addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprRHS e@(L pos e0) = do d <- getDensity case d of - TickForBreakPoints | HsLet _ _ <- e0 -> dont_tick_it - | otherwise -> tick_it + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it TickForCoverage -> tick_it + TickCallSites | isCallSite e0 -> tick_it _other -> dont_tick_it where tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 - dont_tick_it = do e1 <- addTickHsExpr e0; return $ L pos e1 - --- | A let body is ticked only if we're doing breakpoints. For coverage, the --- whole let is ticked, so there's no need to tick the body. + dont_tick_it = addTickLHsExprNever e + +-- The inner expression of an evaluation context: +-- let binds in [], ( [] ) +-- we never tick these if we're doing HPC, but otherwise +-- we treat it like an ordinary expression. +addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id) +addTickLHsExprEvalInner e = do + d <- getDensity + case d of + TickForCoverage -> addTickLHsExprNever e + _otherwise -> addTickLHsExpr e + +-- | A let body is treated differently from addTickLHsExprEvalInner +-- above with TickForBreakPoints, because for breakpoints we always +-- want to tick the body, even if it is not a redex. See test +-- break012. This gives the user the opportunity to inspect the +-- values of the let-bound variables. addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id) -addTickLHsExprLetBody e - = ifDensity TickForBreakPoints - (addTickLHsExprAlways e) - (addTickLHsExprNever e) +addTickLHsExprLetBody e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + _other -> addTickLHsExprEvalInner e + where + tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e -- version of addTick that does not actually add a tick, -- because the scope of this tick is completely subsumed by @@ -369,14 +398,19 @@ isGoodBreakExpr :: HsExpr Id -> Bool isGoodBreakExpr (HsApp {}) = True isGoodBreakExpr (OpApp {}) = True isGoodBreakExpr (NegApp {}) = True -isGoodBreakExpr (HsCase {}) = True isGoodBreakExpr (HsIf {}) = True +isGoodBreakExpr (HsCase {}) = True isGoodBreakExpr (RecordCon {}) = True isGoodBreakExpr (RecordUpd {}) = True isGoodBreakExpr (ArithSeq {}) = True isGoodBreakExpr (PArrSeq {}) = True isGoodBreakExpr _other = False +isCallSite :: HsExpr Id -> Bool +isCallSite HsApp{} = True +isCallSite OpApp{} = True +isCallSite _ = False + addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id) addTickLHsExprOptAlt oneOfMany (L pos e0) = ifDensity TickForCoverage @@ -413,16 +447,14 @@ addTickHsExpr (NegApp e neg) = (addTickLHsExpr e) (addTickSyntaxExpr hpcSrcSpan neg) addTickHsExpr (HsPar e) = - liftM HsPar $ - ifDensity TickForCoverage (addTickLHsExprNever e) - (addTickLHsExpr e) -addTickHsExpr (SectionL e1 e2) = + liftM HsPar (addTickLHsExprEvalInner e) +addTickHsExpr (SectionL e1 e2) = liftM2 SectionL (addTickLHsExpr e1) - (addTickLHsExpr e2) + (addTickLHsExprNever e2) addTickHsExpr (SectionR e1 e2) = liftM2 SectionR - (addTickLHsExpr e1) + (addTickLHsExprNever e1) (addTickLHsExpr e2) addTickHsExpr (ExplicitTuple es boxity) = liftM2 ExplicitTuple @@ -430,7 +462,8 @@ addTickHsExpr (ExplicitTuple es boxity) = (return boxity) addTickHsExpr (HsCase e mgs) = liftM2 HsCase - (addTickLHsExpr e) + (addTickLHsExpr e) -- not an EvalInner; e might not necessarily + -- be evaluated. (addTickMatchGroup False mgs) addTickHsExpr (HsIf cnd e1 e2 e3) = liftM3 (HsIf cnd) @@ -551,7 +584,7 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $ addTickHsExpr e0 _otherwise -> - addTickLHsExprAlways expr + addTickLHsExprRHS expr addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id] addTickLStmts isGuard stmts = do @@ -574,7 +607,7 @@ addTickStmt _isGuard (LastStmt e ret) = do addTickStmt _isGuard (BindStmt pat e bind fail) = do liftM4 BindStmt (addTickLPat pat) - (addTickLHsExprAlways e) + (addTickLHsExprRHS e) (addTickSyntaxExpr hpcSrcSpan bind) (addTickSyntaxExpr hpcSrcSpan fail) addTickStmt isGuard (ExprStmt e bind' guard' ty) = do @@ -598,8 +631,8 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts , trS_ret = returnExpr, trS_bind = bindExpr , trS_fmap = liftMExpr }) = do t_s <- addTickLStmts isGuard stmts - t_y <- fmapMaybeM addTickLHsExprAlways by - t_u <- addTickLHsExprAlways using + t_y <- fmapMaybeM addTickLHsExprRHS by + t_u <- addTickLHsExprRHS using t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr @@ -616,7 +649,7 @@ addTickStmt isGuard stmt@(RecStmt {}) addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e - | otherwise = addTickLHsExprAlways e + | otherwise = addTickLHsExprRHS e addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a) -> TM ([LStmt Id], a) @@ -987,7 +1020,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = cc_name | topOnly = head decl_path | otherwise = concat (intersperse "." decl_path) - cc = mkUserCC (mkFastString cc_name) (this_mod env) + cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c) count = countEntries && dopt Opt_ProfCountEntries (dflags env) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 74644dd564..a47e617a7c 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -307,10 +307,11 @@ dsExpr (ExplicitTuple tup_args boxity) mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args)) (map (Type . exprType) args ++ args) } -dsExpr (HsSCC cc expr) = do +dsExpr (HsSCC cc expr@(L loc _)) = do mod_name <- getModuleDs count <- doptDs Opt_ProfCountEntries - Tick (ProfNote (mkUserCC cc mod_name) count True) <$> dsLExpr expr + uniq <- newUnique + Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr dsExpr (HsCoreAnn _ expr) = dsLExpr expr diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index eb6ca87ba3..792421daa5 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -938,26 +938,31 @@ instance Binary IsCafCC where _ -> do return NotCafCC instance Binary CostCentre where - put_ bh NoCostCentre = do + put_ bh (NormalCC aa ab ac _ad ae) = do putByte bh 0 - put_ bh (NormalCC aa ab ac) = do - putByte bh 1 put_ bh aa put_ bh ab put_ bh ac - put_ bh (AllCafsCC ae) = do - putByte bh 2 + put_ bh ae + put_ bh (AllCafsCC ae _af) = do + putByte bh 1 put_ bh ae get bh = do h <- getByte bh case h of - 0 -> do return NoCostCentre - 1 -> do aa <- get bh + 0 -> do aa <- get bh ab <- get bh ac <- get bh - return (NormalCC aa ab ac) + ae <- get bh + return (NormalCC aa ab ac noSrcSpan ae) _ -> do ae <- get bh - return (AllCafsCC ae) + return (AllCafsCC ae noSrcSpan) + + -- We ignore the SrcSpans in CostCentres when we serialise them, + -- and set the SrcSpans to noSrcSpan when deserialising. This is + -- ok, because we only need the SrcSpan when declaring the + -- CostCentre in the original module, it is not used by importing + -- modules. ------------------------------------------------------------------------- -- IfaceTypes and friends diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index b29c215ad2..f802fc414c 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -36,7 +36,8 @@ import System.IO llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () llvmCodeGen dflags h us cmms = let cmm = concat cmms - (cdata,env) = foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm + (cdata,env) = {-# SCC "llvm_split" #-} + foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) split (CmmProc i l _) (d,e) = let lbl = strCLabel_llvm env $ case i of @@ -49,8 +50,10 @@ llvmCodeGen dflags h us cmms bufh <- newBufHandle h Prt.bufLeftRender bufh $ pprLlvmHeader ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags - env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] - cmmProcLlvmGens dflags bufh us env' cmm 1 [] + env' <- {-# SCC "llvm_datas_gen" #-} + cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] + {-# SCC "llvm_procs_gen" #-} + cmmProcLlvmGens dflags bufh us env' cmm 1 [] bFlush bufh return () @@ -62,17 +65,24 @@ cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)] -> [LlvmUnresData] -> IO ( LlvmEnv ) cmmDataLlvmGens dflags h env [] lmdata - = let (env', lmdata') = resolveLlvmDatas env lmdata [] - lmdoc = Prt.vcat $ map pprLlvmData lmdata' + = let (env', lmdata') = {-# SCC "llvm_resolve" #-} + resolveLlvmDatas env lmdata + lmdoc = {-# SCC "llvm_data_ppr" #-} + Prt.vcat $ map pprLlvmData lmdata' in do dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc - Prt.bufLeftRender h lmdoc + {-# SCC "llvm_data_out" #-} + Prt.bufLeftRender h lmdoc return env' cmmDataLlvmGens dflags h env (cmm:cmms) lmdata - = let lmdata'@(l, _, ty, _) = genLlvmData env cmm - env' = funInsert (strCLabel_llvm env l) ty env - in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata']) + = let lm@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-} + genLlvmData env cmm + env' = {-# SCC "llvm_data_insert" #-} + funInsert (strCLabel_llvm env l) ty env + lmdata' = {-# SCC "llvm_data_append" #-} + lm:lmdata + in cmmDataLlvmGens dflags h env' cmms lmdata' -- ----------------------------------------------------------------------------- @@ -93,7 +103,8 @@ cmmProcLlvmGens _ h _ _ [] _ ivars usedArray = LMStaticArray (map cast ivars') ty lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray) - in Prt.bufLeftRender h $ pprLlvmData ([lmUsed], []) + in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-} + pprLlvmData ([lmUsed], []) cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars = cmmProcLlvmGens dflags h us env cmms count ivars @@ -104,7 +115,7 @@ cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivar cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm - Prt.bufLeftRender h $ Prt.vcat docs + Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} Prt.vcat docs cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars) @@ -113,13 +124,15 @@ cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl -> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] ) cmmLlvmGen dflags us env cmm = do -- rewrite assignments to global regs - let fixed_cmm = fixStgRegisters cmm + let fixed_cmm = {-# SCC "llvm_fix_regs" #-} + fixStgRegisters cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup (targetPlatform dflags) [fixed_cmm]) -- generate llvm code from cmm - let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm + let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-} + initUs us $ genLlvmProc env fixed_cmm dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" (vcat $ map (docToSDoc . fst . pprLlvmCmmDecl env' 0) llvmBC) diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index f075aaa362..3d0ee5cf50 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -158,17 +158,26 @@ initLlvmEnv platform = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion, platform -- | Clear variables from the environment. clearVars :: LlvmEnv -> LlvmEnv -clearVars (LlvmEnv (e1, _, n, p)) = LlvmEnv (e1, emptyUFM, n, p) +clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-} + LlvmEnv (e1, emptyUFM, n, p) -- | Insert functions into the environment. -varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv -varInsert s t (LlvmEnv (e1, e2, n, p)) = LlvmEnv (e1, addToUFM e2 s t, n, p) -funInsert s t (LlvmEnv (e1, e2, n, p)) = LlvmEnv (addToUFM e1 s t, e2, n, p) +varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv +varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-} + LlvmEnv (e1, addToUFM e2 s t, n, p) + +funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv +funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-} + LlvmEnv (addToUFM e1 s t, e2, n, p) -- | Lookup functions in the environment. -varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType -varLookup s (LlvmEnv (_, e2, _, _)) = lookupUFM e2 s -funLookup s (LlvmEnv (e1, _, _, _)) = lookupUFM e1 s +varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType +varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-} + lookupUFM e2 s + +funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType +funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-} + lookupUFM e1 s -- | Get the LLVM version we are generating code for getLlvmVer :: LlvmEnv -> LlvmVersion @@ -188,8 +197,8 @@ getLlvmPlatform (LlvmEnv (_, _, _, p)) = p -- | Pretty print a 'CLabel'. strCLabel_llvm :: LlvmEnv -> CLabel -> LMString -strCLabel_llvm env l - = (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l +strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-} + (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l -- | Create an external definition for a 'CLabel' defined in another module. genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal @@ -201,7 +210,6 @@ genStringLabelRef cl = let ty = LMPointer $ LMArray 0 llvmWord in (LMGlobalVar cl ty External Nothing Nothing False, Nothing) - -- ---------------------------------------------------------------------------- -- * Misc -- diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 1ea5d0c038..d8507ab810 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -28,7 +28,6 @@ import Unique import Util import Data.List ( partition ) -import Control.Monad ( liftM ) type LlvmStatements = OrdList LlvmStatement @@ -57,8 +56,7 @@ basicBlocksCodeGen env ([]) (blocks, tops) = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks let allocs' = concat allocs let ((BasicBlock id fstmts):rblks) = blocks' - fplog <- funPrologue - let fblocks = (BasicBlock id (fplog ++ allocs' ++ fstmts)):rblks + let fblocks = (BasicBlock id $ funPrologue ++ allocs' ++ fstmts):rblks return (env, fblocks, tops) basicBlocksCodeGen env (block:blocks) (lblocks', ltops') @@ -1189,13 +1187,13 @@ genLit _ CmmHighStackMark -- -- | Function prologue. Load STG arguments into variables for function. -funPrologue :: UniqSM [LlvmStatement] -funPrologue = liftM concat $ mapM getReg activeStgRegs +funPrologue :: [LlvmStatement] +funPrologue = concat $ map getReg activeStgRegs where getReg rr = - let reg = lmGlobalRegVar rr - arg = lmGlobalRegArg rr + let reg = lmGlobalRegVar rr + arg = lmGlobalRegArg rr alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - in return [alloc, Store arg reg] + in [alloc, Store arg reg] -- | Function epilogue. Load STG variables to use as argument for call. diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index c773e1c009..8e42149dce 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -18,8 +18,7 @@ import OldCmm import FastString import qualified Outputable -import Data.Maybe - +import Data.List (foldl') -- ---------------------------------------------------------------------------- -- * Constants @@ -51,37 +50,33 @@ genLlvmData env (sec, Statics lbl xs) = in (lbl, sec, alias, static) -resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> [LlvmData] - -> (LlvmEnv, [LlvmData]) -resolveLlvmDatas env [] ldata - = (env, ldata) - -resolveLlvmDatas env (udata : rest) ldata - = let (env', ndata) = resolveLlvmData env udata - in resolveLlvmDatas env' rest (ldata ++ [ndata]) +resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> (LlvmEnv, [LlvmData]) +resolveLlvmDatas env ldata + = foldl' res (env, []) ldata + where res (e, xs) ll = + let (e', nd) = resolveLlvmData e ll + in (e', nd:xs) -- | Fix up CLabel references now that we should have passed all CmmData. resolveLlvmData :: LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData) resolveLlvmData env (lbl, sec, alias, unres) = let (env', static, refs) = resDatas env unres ([], []) - refs' = catMaybes refs struct = Just $ LMStaticStruc static alias label = strCLabel_llvm env lbl link = if (externallyVisibleCLabel lbl) then ExternallyVisible else Internal const = isSecConstant sec glob = LMGlobalVar label alias link Nothing Nothing const - in (env', (refs' ++ [(glob, struct)], [alias])) - + in (env', ((glob,struct):refs, [alias])) -- | Should a data in this section be considered constant isSecConstant :: Section -> Bool isSecConstant Text = True -isSecConstant Data = False isSecConstant ReadOnlyData = True isSecConstant RelocatableReadOnlyData = True -isSecConstant UninitialisedData = False isSecConstant ReadOnlyData16 = True +isSecConstant Data = False +isSecConstant UninitialisedData = False isSecConstant (OtherSection _) = False @@ -90,13 +85,13 @@ isSecConstant (OtherSection _) = False -- -- | Resolve data list -resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [Maybe LMGlobal]) - -> (LlvmEnv, [LlvmStatic], [Maybe LMGlobal]) +resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [LMGlobal]) + -> (LlvmEnv, [LlvmStatic], [LMGlobal]) -resDatas env [] (stat, glob) - = (env, stat, glob) +resDatas env [] (stats, glob) + = (env, stats, glob) -resDatas env (cmm : rest) (stats, globs) +resDatas env (cmm:rest) (stats, globs) = let (env', nstat, nglob) = resData env cmm in resDatas env' rest (stats ++ [nstat], globs ++ nglob) @@ -106,9 +101,9 @@ resDatas env (cmm : rest) (stats, globs) -- module. If it has we can retrieve its type and make a pointer, otherwise -- we introduce a generic external definition for the referenced label and -- then make a pointer. -resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [Maybe LMGlobal]) +resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [LMGlobal]) -resData env (Right stat) = (env, stat, [Nothing]) +resData env (Right stat) = (env, stat, []) resData env (Left cmm@(CmmLabel l)) = let label = strCLabel_llvm env l @@ -120,14 +115,14 @@ resData env (Left cmm@(CmmLabel l)) = let glob@(var, _) = genStringLabelRef label env' = funInsert label (pLower $ getVarType var) env ptr = LMStaticPointer var - in (env', LMPtoI ptr lmty, [Just glob]) + in (env', LMPtoI ptr lmty, [glob]) -- Referenced data exists in this module, retrieve type and make -- pointer to it. Just ty' -> let var = LMGlobalVar label (LMPointer ty') ExternallyVisible Nothing Nothing False ptr = LMStaticPointer var - in (env, LMPtoI ptr lmty, [Nothing]) + in (env, LMPtoI ptr lmty, []) resData env (Left (CmmLabelOff label off)) = let (env', var, glob) = resData env (Left (CmmLabel label)) @@ -161,7 +156,6 @@ genData (CmmUninitialised bytes) genData (CmmStaticLit lit) = genStaticLit lit - -- | Generate Llvm code for a static literal. -- -- Will either generate the code or leave it unresolved if it is a 'CLabel' @@ -183,7 +177,6 @@ genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b genStaticLit (CmmHighStackMark) = panic "genStaticLit: CmmHighStackMark unsupported!" - -- ----------------------------------------------------------------------------- -- * Misc -- diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs index 6ad9b72b4f..83a2be7f8d 100644 --- a/compiler/llvmGen/LlvmMangler.hs +++ b/compiler/llvmGen/LlvmMangler.hs @@ -41,7 +41,7 @@ type Section = (B.ByteString, B.ByteString) -- | Read in assembly file and process llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () -llvmFixupAsm dflags f1 f2 = do +llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do showPass dflags "LlVM Mangler" r <- openBinaryFile f1 ReadMode w <- openBinaryFile f2 WriteMode diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index c97be6e13e..e845460413 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -165,7 +165,9 @@ outputAsm dflags filenm flat_absC outputLlvm :: DynFlags -> FilePath -> [RawCmmGroup] -> IO () outputLlvm dflags filenm flat_absC = do ncg_uniqs <- mkSplitUniqSupply 'n' - doOutput filenm $ \f -> llvmCodeGen dflags f ncg_uniqs flat_absC + {-# SCC "llvm_output" #-} doOutput filenm $ + \f -> {-# SCC "llvm_CodeGen" #-} + llvmCodeGen dflags f ncg_uniqs flat_absC \end{code} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 9d6d15c0df..947b320e97 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -589,6 +589,7 @@ data ProfAuto | ProfAutoAll -- ^ top-level and nested functions are annotated | ProfAutoTop -- ^ top-level functions annotated only | ProfAutoExports -- ^ exported functions annotated only + | ProfAutoCalls -- ^ annotate call-sites data Settings = Settings { sTargetPlatform :: Platform, -- Filled in by SysTools @@ -1637,6 +1638,7 @@ dynamic_flags = [ , Flag "fprof-auto" (noArg (\d -> d { profAuto = ProfAutoAll } )) , Flag "fprof-auto-top" (noArg (\d -> d { profAuto = ProfAutoTop } )) , Flag "fprof-auto-exported" (noArg (\d -> d { profAuto = ProfAutoExports } )) + , Flag "fprof-auto-calls" (noArg (\d -> d { profAuto = ProfAutoCalls } )) , Flag "fno-prof-auto" (noArg (\d -> d { profAuto = NoProfAuto } )) ------ Compiler flags ----------------------------------------------- diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 2b6a14bb27..9fad73a9f8 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -141,8 +141,17 @@ getOptionsFromFile dflags filename (openBinaryFile filename ReadMode) (hClose) (\handle -> do - opts <- fmap getOptions' $ lazyGetToks dflags filename handle + opts <- fmap getOptions' $ lazyGetToks dflags' filename handle seqList opts $ return opts) + where -- We don't need to get haddock doc tokens when we're just + -- getting the options from pragmas, and lazily lexing them + -- correctly is a little tricky: If there is "\n" or "\n-" + -- left at the end of a buffer then the haddock doc may + -- continue past the end of the buffer, despite the fact that + -- we already have an apparently-complete token. + -- We therefore just turn Opt_Haddock off when doing the lazy + -- lex. + dflags' = dopt_unset dflags Opt_Haddock blockSize :: Int -- blockSize = 17 -- for testing :-) @@ -237,9 +246,6 @@ getOptions' toks parseToks (open:xs) | ITlanguage_prag <- getToken open = parseLanguage xs - parseToks (x:xs) - | ITdocCommentNext _ <- getToken x - = parseToks xs parseToks _ = [] parseLanguage (L loc (ITconid fs):rest) = checkExtension (L loc fs) : diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index ceb9226594..304ad70ce2 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1793,14 +1793,16 @@ section "Misc" {These aren't nearly as wired in as Etc...} ------------------------------------------------------------------------ -primop TraceCcsOp "traceCcs#" GenPrimOp - a -> b -> b - with - has_side_effects = True - out_of_line = True - -primop GetCCCSOp "getCCCS#" GenPrimOp - State# s -> (# State# s, Addr# #) +primop GetCCSOfOp "getCCSOf#" GenPrimOp + a -> State# s -> (# State# s, Addr# #) + +primop GetCurrentCCSOp "getCurrentCCS#" GenPrimOp + a -> State# s -> (# State# s, Addr# #) + { Returns the current {\tt CostCentreStack} (value is {\tt NULL} if + not profiling). Takes a dummy argument which can be used to + avoid the call to {\tt getCCCS\#} being floated out by the + simplifier, which would result in an uninformative stack + ("CAF"). } ------------------------------------------------------------------------ section "Etc" diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 2a44121dfd..a4d7d1a398 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -15,7 +15,6 @@ module CostCentre ( CostCentreStack, CollectedCCs, noCCS, currentCCS, dontCareCCS, - noCostCentre, noCCAttached, noCCSAttached, isCurrentCCS, maybeSingletonCCS, @@ -25,6 +24,7 @@ module CostCentre ( pprCostCentreCore, costCentreUserName, costCentreUserNameFS, + costCentreSrcSpan, cmpCostCentre -- used for removing dups in a list ) where @@ -35,6 +35,7 @@ import Module import Unique import Outputable import FastTypes +import SrcLoc import FastString import Util @@ -43,20 +44,30 @@ import Data.Data ----------------------------------------------------------------------------- -- Cost Centres --- | A Cost Centre is the argument of an _scc_ expression. +-- | A Cost Centre is a single @{-# SCC #-}@ annotation. data CostCentre - = NoCostCentre -- Having this constructor avoids having - -- to use "Maybe CostCentre" all the time. - - | NormalCC { - cc_name :: CcName, -- Name of the cost centre itself - cc_mod :: Module, -- Name of module defining this CC. + = NormalCC { + cc_key :: {-# UNPACK #-} !Int, + -- ^ Two cost centres may have the same name and + -- module but different SrcSpans, so we need a way to + -- distinguish them easily and give them different + -- object-code labels. So every CostCentre has a + -- Unique that is distinct from every other + -- CostCentre in the same module. + -- + -- XXX: should really be using Unique here, but we + -- need to derive Data below and there's no Data + -- instance for Unique. + cc_name :: CcName, -- ^ Name of the cost centre itself + cc_mod :: Module, -- ^ Name of module defining this CC. + cc_loc :: SrcSpan, cc_is_caf :: IsCafCC -- see below } | AllCafsCC { - cc_mod :: Module -- Name of module defining this CC. + cc_mod :: Module, -- Name of module defining this CC. + cc_loc :: SrcSpan } deriving (Data, Typeable) @@ -65,9 +76,6 @@ type CcName = FastString data IsCafCC = NotCafCC | CafCC deriving (Eq, Ord, Data, Typeable) -noCostCentre :: CostCentre -noCostCentre = NoCostCentre - instance Eq CostCentre where c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } @@ -80,10 +88,10 @@ cmpCostCentre :: CostCentre -> CostCentre -> Ordering cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2 -cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1}) - (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2}) - -- first key is module name, then the name, then the cafness - = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `compare` c2) +cmpCostCentre NormalCC {cc_key = n1, cc_mod = m1} + NormalCC {cc_key = n2, cc_mod = m2} + -- first key is module name, then the integer key + = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) cmpCostCentre other_1 other_2 = let @@ -92,18 +100,17 @@ cmpCostCentre other_1 other_2 in if tag1 <# tag2 then LT else GT where - tag_CC NoCostCentre = _ILIT(0) - tag_CC (NormalCC {}) = _ILIT(1) - tag_CC (AllCafsCC {}) = _ILIT(2) + tag_CC (NormalCC {}) = _ILIT(0) + tag_CC (AllCafsCC {}) = _ILIT(1) ----------------------------------------------------------------------------- -- Predicates on CostCentre isCafCC :: CostCentre -> Bool -isCafCC (AllCafsCC {}) = True +isCafCC (AllCafsCC {}) = True isCafCC (NormalCC {cc_is_caf = CafCC}) = True -isCafCC _ = False +isCafCC _ = False -- | Is this a cost-centre which records scc counts isSccCountCC :: CostCentre -> Bool @@ -112,7 +119,6 @@ isSccCountCC cc | isCafCC cc = False -- | Is this a cost-centre which can be sccd ? sccAbleCC :: CostCentre -> Bool -sccAbleCC NoCostCentre = panic "sccAbleCC:NoCostCentre" sccAbleCC cc | isCafCC cc = False | otherwise = True @@ -123,15 +129,17 @@ ccFromThisModule cc m = cc_mod cc == m ----------------------------------------------------------------------------- -- Building cost centres -mkUserCC :: FastString -> Module -> CostCentre -mkUserCC cc_name mod - = NormalCC { cc_name = cc_name, cc_mod = mod, +mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre +mkUserCC cc_name mod loc key + = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod = mod, cc_loc = loc, cc_is_caf = NotCafCC {-might be changed-} } mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre mkAutoCC id mod is_caf - = NormalCC { cc_name = str, cc_mod = mod, + = NormalCC { cc_key = getKey (getUnique id), + cc_name = str, cc_mod = mod, + cc_loc = nameSrcSpan (getName id), cc_is_caf = is_caf } where @@ -144,8 +152,8 @@ mkAutoCC id mod is_caf | otherwise = mkFastString $ showSDoc $ ftext (occNameFS (getOccName id)) <> char '_' <> pprUnique (getUnique name) -mkAllCafsCC :: Module -> CostCentre -mkAllCafsCC m = AllCafsCC { cc_mod = m } +mkAllCafsCC :: Module -> SrcSpan -> CostCentre +mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } ----------------------------------------------------------------------------- -- Cost Centre Stacks @@ -198,10 +206,6 @@ noCCSAttached :: CostCentreStack -> Bool noCCSAttached NoCCS = True noCCSAttached _ = False -noCCAttached :: CostCentre -> Bool -noCCAttached NoCostCentre = True -noCCAttached _ = False - isCurrentCCS :: CostCentreStack -> Bool isCurrentCCS CurrentCCS = True isCurrentCCS _ = False @@ -253,16 +257,15 @@ instance Outputable CostCentre where -- Printing in Core pprCostCentreCore :: CostCentre -> SDoc -pprCostCentreCore NoCostCentre - = text "__no_cc" pprCostCentreCore (AllCafsCC {cc_mod = m}) = text "__sccC" <+> braces (ppr m) -pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, +pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc, cc_is_caf = caf}) = text "__scc" <+> braces (hsep [ - ftext (zEncodeFS n), - ppr m, - pp_caf caf + ppr m <> char '.' <> ftext n, + ifPprDebug (ppr key), + pp_caf caf, + ifPprDebug (ppr loc) ]) pp_caf :: IsCafCC -> SDoc @@ -271,11 +274,11 @@ pp_caf _ = empty -- Printing as a C label ppCostCentreLbl :: CostCentre -> SDoc -ppCostCentreLbl (NoCostCentre) = text "NONE_cc" ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" -ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf}) - = ppr m <> char '_' <> ftext (zEncodeFS n) <> - text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc" +ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m, + cc_is_caf = is_caf}) + = ppr m <> char '_' <> ftext (zEncodeFS n) <> char '_' <> + case is_caf of { CafCC -> ptext (sLit "CAF"); _ -> ppr (mkUniqueGrimily k)} <> text "_cc" -- This is the name to go in the user-displayed string, -- recorded in the cost centre declaration @@ -283,10 +286,12 @@ costCentreUserName :: CostCentre -> String costCentreUserName = unpackFS . costCentreUserNameFS costCentreUserNameFS :: CostCentre -> FastString -costCentreUserNameFS (NoCostCentre) = mkFastString "NO_CC" costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf}) = case is_caf of CafCC -> mkFastString "CAF:" `appendFS` name _ -> name + +costCentreSrcSpan :: CostCentre -> SrcSpan +costCentreSrcSpan = cc_loc \end{code} diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs index 96a21eb056..6fc44c1df9 100644 --- a/compiler/profiling/SCCfinal.lhs +++ b/compiler/profiling/SCCfinal.lhs @@ -32,6 +32,8 @@ import UniqSupply ( UniqSupply ) import ListSetOps ( removeDups ) import Outputable import DynFlags +import FastString +import SrcLoc stgMassageForProfiling @@ -60,7 +62,8 @@ stgMassageForProfiling dflags mod_name _us stg_binds fixed_cc_stacks ++ cc_stacks), stg_binds2) where - all_cafs_cc = mkAllCafsCC mod_name + span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better + all_cafs_cc = mkAllCafsCC mod_name span all_cafs_ccs = mkSingletonCCS all_cafs_cc ---------- @@ -244,8 +247,7 @@ thenMM_ expr cont = MassageM $ \mod ccs -> collectCC :: CostCentre -> MassageM () collectCC cc = MassageM $ \mod_name (local_ccs, extern_ccs, ccss) - -> ASSERT(not (noCCAttached cc)) - if (cc `ccFromThisModule` mod_name) then + -> if (cc `ccFromThisModule` mod_name) then ((cc : local_ccs, extern_ccs, ccss), ()) else -- must declare it "extern" ((local_ccs, cc : extern_ccs, ccss), ()) diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 4cf2695b76..cc3603baeb 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -35,7 +35,7 @@ import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_, myThreadId ) import Data.Dynamic import Debug.Trace ( trace ) -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe import System.Exit import System.Environment @@ -47,6 +47,9 @@ import System.Posix.Signals import GHC.ConsoleHandler #endif +#if __GLASGOW_HASKELL__ >= 703 +import GHC.Stack +#endif -- | GHC's own exception type -- error messages all take the form: @@ -160,7 +163,16 @@ handleGhcException = ghandle -- | Panics and asserts. panic, sorry, pgmError :: String -> a +#if __GLASGOW_HASKELL__ >= 703 +panic x = unsafeDupablePerformIO $ do + stack <- ccsToStrings =<< getCurrentCCS x + if null stack + then throwGhcException (Panic x) + else throwGhcException (Panic (x ++ '\n' : renderStack stack)) +#else panic x = throwGhcException (Panic x) +#endif + sorry x = throwGhcException (Sorry x) pgmError x = throwGhcException (ProgramError x) |