Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

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