diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/Coverage.lhs | 36 | ||||
| -rw-r--r-- | compiler/iface/MkIface.lhs | 2 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 3 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 2 |
4 files changed, 35 insertions, 8 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index fa7c343fac..c29f39edaa 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -84,6 +84,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds = , declPath = [] , tte_dflags = dflags , exports = exports + , inlines = emptyVarSet , inScope = emptyVarSet , blackList = Map.fromList [ (getSrcSpan (tyConName tyCon),()) @@ -231,6 +232,7 @@ addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, abs_exports = abs_exports })) = do withEnv add_exports $ do + withEnv add_inlines $ do binds' <- addTickLHsBinds binds return $ L pos $ bind { abs_binds = binds' } where @@ -245,9 +247,24 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , idName pid `elemNameSet` (exports env) ] } + add_inlines env = + env{ inlines = inlines env `extendVarSetList` + [ mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , isAnyInlinePragma (idInlinePragma pid) ] } + + addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do let name = getOccString id decl_path <- getPathEntry + density <- getDensity + + inline_ids <- liftM inlines getEnv + let inline = isAnyInlinePragma (idInlinePragma id) + || id `elemVarSet` inline_ids + + -- See Note [inline sccs] + if inline && opt_SccProfilingOn then return (L pos funBind) else do (fvs, (MatchGroup matches' ty)) <- getFreeVars $ @@ -255,7 +272,6 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do addTickMatchGroup False (fun_matches funBind) blackListed <- isBlackListed pos - density <- getDensity exported_names <- liftM exports getEnv -- We don't want to generate code for blacklisted positions @@ -264,8 +280,6 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do let simple = isSimplePatBind funBind toplev = null decl_path exported = idName id `elemNameSet` exported_names - inline = {- pprTrace "inline" (ppr id <+> ppr (idInlinePragma id)) $ -} - isAnyInlinePragma (idInlinePragma id) tick <- if not blackListed && shouldTickBind density toplev exported simple inline @@ -321,6 +335,21 @@ bindTick density name pos fvs = do allocATickBox box_label count_entries top_only pos fvs +-- Note [inline sccs] +-- +-- It should be reasonable to add ticks to INLINE functions; however +-- currently this tickles a bug later on because the SCCfinal pass +-- does not look inside unfoldings to find CostCentres. It would be +-- difficult to fix that, because SCCfinal currently works on STG and +-- not Core (and since it also generates CostCentres for CAFs, +-- changing this would be difficult too). +-- +-- Another reason not to add ticks to INLINE functions is that this +-- sometimes handy for avoiding adding a tick to a particular function +-- (see #6131) +-- +-- So for now we do not add any ticks to INLINE functions at all. + -- ----------------------------------------------------------------------------- -- Decorate an LHsExpr with ticks @@ -869,6 +898,7 @@ data TickTransEnv = TTE { fileName :: FastString , density :: TickDensity , tte_dflags :: DynFlags , exports :: NameSet + , inlines :: VarSet , declPath :: [String] , inScope :: VarSet , blackList :: Map SrcSpan () diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 3df54be1a7..7420dd8c32 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1095,8 +1095,6 @@ data RecompileRequired | RecompBecause String -- ^ The .o/.hi files are up to date, but something else has changed -- to force recompilation; the String says what (one-line summary) - | RecompForcedByTH - -- ^ recompile is forced due to use of TH by the module deriving Eq recompileRequired :: RecompileRequired -> Bool diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index df85d06f1b..562332d52a 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -625,7 +625,7 @@ genericHscCompile compiler hscMessage hsc_env case mb_checked_iface of Just iface | not (recompileRequired recomp_reqd) -> if mi_used_th iface && not stable - then compile RecompForcedByTH + then compile (RecompBecause "TH") else skip iface _otherwise -> compile recomp_reqd @@ -851,7 +851,6 @@ batchMsg hsc_env mb_mod_index recomp mod_summary = | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" | otherwise -> return () RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") - RecompForcedByTH -> showMsg "Compiling " " [TH]" where dflags = hsc_dflags hsc_env showMsg msg reason = diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 5afc1e31c8..a22697d217 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1177,7 +1177,7 @@ chooseBoxingStrategy arg_ty bang -- representation of the argument type -- However: even when OmitInterfacePragmas is on, we still want -- to know if we have HsUnpackFailed, because we omit a - -- warning in that case (#3676) + -- warning in that case (#3966) HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) -- Source code never has shtes where |