diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 901274d6d65d459c428d8a9819a6d064b3f2d2d6..abffcb18a9a58999f69a5db182dbd12f9903b7f6 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -10,10 +10,14 @@ lower levels it is preserved with @let@/@letrec@s).
\begin{code}
#include "HsVersions.h"
-module DsBinds ( dsBinds, dsMonoBinds ) where
+module DsBinds ( dsBinds ) where
IMP_Ubiq()
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
+#else
+import {-# SOURCE #-} DsExpr
+#endif
import HsSyn -- lots of things
import CoreSyn -- lots of things
@@ -27,6 +31,7 @@ import DsGRHSs ( dsGuarded )
import DsUtils
import Match ( matchWrapper )
+import BasicTypes ( SYN_IE(Module) )
import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals )
import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
@@ -53,13 +58,16 @@ that some of the binders are of unboxed type. This is sorted out when
the caller wraps the bindings round an expression.
\begin{code}
-dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
+type Group = FAST_STRING
-dsBinds EmptyBinds = returnDs []
-dsBinds (ThenBinds binds_1 binds_2) = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
+dsBinds :: Maybe (Module, Group) -> TypecheckedHsBinds -> DsM [CoreBinding]
-dsBinds (MonoBind binds sigs is_rec)
- = dsMonoBinds is_rec binds `thenDs` \ prs ->
+dsBinds _ EmptyBinds = returnDs []
+dsBinds mb_mod_grp (ThenBinds binds_1 binds_2)
+ = andDs (++) (dsBinds mb_mod_grp binds_1) (dsBinds mb_mod_grp binds_2)
+
+dsBinds mb_mod_grp (MonoBind binds sigs is_rec)
+ = dsMonoBinds mb_mod_grp is_rec binds `thenDs` \ prs ->
returnDs (if is_rec then
[Rec prs]
else
@@ -75,17 +83,20 @@ dsBinds (MonoBind binds sigs is_rec)
%************************************************************************
\begin{code}
-dsMonoBinds :: RecFlag -> TypecheckedMonoBinds -> DsM [(Id,CoreExpr)]
+dsMonoBinds :: Maybe (Module, Group) -- Nothing => don't (auto-)annotate scc on toplevs.
+ -> RecFlag
+ -> TypecheckedMonoBinds
+ -> DsM [(Id,CoreExpr)]
-dsMonoBinds is_rec EmptyMonoBinds = returnDs []
+dsMonoBinds _ is_rec EmptyMonoBinds = returnDs []
-dsMonoBinds is_rec (AndMonoBinds binds_1 binds_2)
- = andDs (++) (dsMonoBinds is_rec binds_1) (dsMonoBinds is_rec binds_2)
+dsMonoBinds mb_mod_grp is_rec (AndMonoBinds binds_1 binds_2)
+ = andDs (++) (dsMonoBinds mb_mod_grp is_rec binds_1) (dsMonoBinds mb_mod_grp is_rec binds_2)
-dsMonoBinds is_rec (CoreMonoBind var core_expr)
+dsMonoBinds _ is_rec (CoreMonoBind var core_expr)
= returnDs [(var, core_expr)]
-dsMonoBinds is_rec (VarMonoBind var expr)
+dsMonoBinds _ is_rec (VarMonoBind var expr)
= dsExpr expr `thenDs` \ core_expr ->
-- Dictionary bindings are always VarMonoBinds, so
@@ -94,36 +105,37 @@ dsMonoBinds is_rec (VarMonoBind var expr)
returnDs [(var, core_expr')]
-dsMonoBinds is_rec (FunMonoBind fun _ matches locn)
+dsMonoBinds mb_mod_grp is_rec (FunMonoBind fun _ matches locn)
= putSrcLocDs locn $
matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
- returnDs [(fun, mkValLam args body)]
+ returnDs [addAutoScc mb_mod_grp (fun, mkValLam args body)]
where
error_string = "function " ++ showForErr fun
-dsMonoBinds is_rec (PatMonoBind pat grhss_and_binds locn)
+dsMonoBinds mb_mod_grp is_rec (PatMonoBind pat grhss_and_binds locn)
= putSrcLocDs locn $
- dsGuarded grhss_and_binds `thenDs` \ body_expr ->
+ dsGuarded grhss_and_binds `thenDs` \ body_expr ->
mkSelectorBinds pat body_expr
-- Common special case: no type or dictionary abstraction
-dsMonoBinds is_rec (AbsBinds [] [] exports binds)
- = dsMonoBinds is_rec binds `thenDs` \ prs ->
- returnDs (prs ++ [(global, Var local) | (_, global, local) <- exports])
+dsMonoBinds mb_mod_grp is_rec (AbsBinds [] [] exports binds)
+ = dsMonoBinds Nothing is_rec binds `thenDs` \ prs ->
+ returnDs (prs ++ [ addAutoScc mb_mod_grp (global, Var local) | (_, global, local) <- exports])
-- Another common case: one exported variable
-- All non-recursive bindings come through this way
-dsMonoBinds is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
+dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
= ASSERT( all (`elem` tyvars) all_tyvars )
- dsMonoBinds is_rec binds `thenDs` \ core_prs ->
+ dsMonoBinds Nothing is_rec binds `thenDs` \ core_prs ->
let
core_binds | is_rec = [Rec core_prs]
| otherwise = [NonRec b e | (b,e) <- core_prs]
in
- returnDs [(global, mkLam tyvars dicts $ mkCoLetsAny core_binds (Var local))]
+ returnDs [addAutoScc mb_mod_grp (global, mkLam tyvars dicts $
+ mkCoLetsAny core_binds (Var local))]
-dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
- = dsMonoBinds is_rec binds `thenDs` \ core_prs ->
+dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts exports binds)
+ = dsMonoBinds Nothing is_rec binds `thenDs` \ core_prs ->
let
core_binds | is_rec = [Rec core_prs]
| otherwise = [NonRec b e | (b,e) <- core_prs]
@@ -142,9 +154,10 @@ dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
= -- Need to make fresh locals to bind in the selector, because
-- some of the tyvars will be bound to voidTy
newSysLocalsDs (map (instantiateTy env) local_tys) `thenDs` \ locals' ->
- returnDs (global, mkLam tyvars dicts $
- mkTupleSelector locals' (locals' !! n) $
- mkValApp (mkTyApp (Var tup_id) ty_args) dict_args)
+ returnDs (addAutoScc mb_mod_grp $
+ (global, mkLam tyvars dicts $
+ mkTupleSelector locals' (locals' !! n) $
+ mkValApp (mkTyApp (Var tup_id) ty_args) dict_args))
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = voidTy
@@ -152,9 +165,36 @@ dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds)
env = all_tyvars `zip` ty_args
in
zipWithDs mk_bind exports [0..] `thenDs` \ export_binds ->
+ -- don't scc (auto-)annotate the tuple itself.
returnDs ((tup_id, tup_expr) : export_binds)
\end{code}
+
+%************************************************************************
+%* *
+\subsection[addAutoScc]{Adding automatic sccs}
+%* *
+%************************************************************************
+
+\begin{code}
+addAutoScc :: Maybe (Module, Group) -- Module and group
+ -> (Id, CoreExpr)
+ -> (Id, CoreExpr)
+
+addAutoScc mb_mod_grp pair@(bndr, core_expr)
+ = case mb_mod_grp of
+ Just (mod,grp)
+ | worthSCC core_expr &&
+ (opt_AutoSccsOnAllToplevs ||
+ (isExported bndr && opt_AutoSccsOnExportedToplevs))
+ -> (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr)
+ _ -> pair -- no auto-annotation.
+
+worthSCC (SCC _ _) = False
+worthSCC (Con _ _) = False
+worthSCC core_expr = True
+\end{code}
+
If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
\begin{code}