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

5 files changed, 88 insertions, 16 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
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index bccb1f93a6..c941df1b6e 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -975,14 +975,59 @@ rec { b &lt;- f a c     ===>    (b,c) &lt;- mfix (\~(b,c) -> do { b &lt;- f a c
 </para>
 
 <para>
-    The <literal>mdo</literal>-notation removes the burden of placing explicit <literal>rec</literal> blocks in the code.
-    It automatically identifies minimally dependent recursive groups, treating them as if the user wrapped a
-    <literal>rec</literal> qualified around them. The definition of <emphasis>minimal</emphasis> in this context
-    is syntax oriented: Two bindings are called dependent if the latter one uses a variable defined by the former. Furthermore,
-    if a binding is dependent on another, then all the bindings that textually appear in between them are dependent on each other
-    as well.  A minimally dependent group of bindings is simply a contagious group where none of the textually following
-    bindings depend on it. (Segments in this sense are related to <emphasis>strongly-connected components</emphasis>
-    analysis, with the exception that bindings in a segment cannot be reordered and has to be contagious.)
+    The <literal>mdo</literal> notation removes the burden of placing
+    explicit <literal>rec</literal> blocks in the code.  Unlike an
+    ordinary <literal>do</literal> expression, in which variables bound by
+    statements are only in scope for later statements, variables bound in
+    an <literal>mdo</literal> expression are in scope for all statements
+    of the expression.  The compiler then automatically identifies minimal
+    mutually recursively dependent segments of statements, treating them as
+    if the user had wrapped a <literal>rec</literal> qualifier around them.
+</para>
+
+<para>
+   The definition is syntactic:
+</para>
+<itemizedlist>
+   <listitem>
+       <para>
+         A generator <replaceable>g</replaceable>
+         <emphasis>depends</emphasis> on a textually following generator
+         <replaceable>g'</replaceable>, if
+       </para>
+       <itemizedlist>
+         <listitem>
+           <para>
+             <replaceable>g'</replaceable> defines a variable that
+             is used by <replaceable>g</replaceable>, or
+           </para>
+         </listitem>
+         <listitem>
+           <para>
+           <replaceable>g'</replaceable> textually appears between
+           <replaceable>g</replaceable> and
+           <replaceable>g''</replaceable>, where <replaceable>g</replaceable>
+           depends on <replaceable>g''</replaceable>.
+           </para>
+         </listitem>
+       </itemizedlist>
+   </listitem>
+   <listitem>
+       <para>
+         A <emphasis>segment</emphasis> of a given
+         <literal>mdo</literal>-expression is a minimal sequence of generators
+         such that no generator of the sequence depends on an outside
+         generator. As a special case, although it is not a generator,
+         the final expression in an <literal>mdo</literal>-expression is
+         considered to form a segment by itself.
+       </para>
+   </listitem>
+</itemizedlist>
+<para>
+   Segments in this sense are
+   related to <emphasis>strongly-connected components</emphasis> analysis,
+   with the exception that bindings in a segment cannot be reordered and
+   must be contiguous.
 </para>
 
 <para>