diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 209a8f94c101707624e5501975ed56ce2cd239a1..8a4c46c1de7614c3b650feb2db07e79b4a053fc5 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -28,7 +28,8 @@ import DsBinds ( dsBinds )
import DsUtils
import Bag ( unionBags )
-import CmdLineOpts ( opt_DoCoreLinting, opt_SccGroup )
+import BasicTypes ( SYN_IE(Module) )
+import CmdLineOpts ( opt_DoCoreLinting, opt_SccGroup, opt_SccProfilingOn )
import CostCentre ( IsCafCC(..), mkAutoCC )
import CoreLift ( liftCoreBindings )
import CoreLint ( lintCoreBindings )
@@ -43,7 +44,7 @@ start.
\begin{code}
deSugar :: UniqSupply -- name supply
- -> FAST_STRING -- module name
+ -> Module -- module name
-> (TypecheckedHsBinds, -- input: recsel, class, instance, and value
TypecheckedHsBinds, -- bindings; see "tcModule" (which produces
@@ -63,30 +64,30 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst
(us3, us3a) = splitUniqSupply us2a
(us4, us5) = splitUniqSupply us3a
+ module_and_group = (mod_name, grp_name)
- module_and_group = (mod_name, grp_name)
grp_name = case opt_SccGroup of
Just xx -> _PK_ xx
Nothing -> mod_name -- default: module name
(core_const_binds, shadows1)
- = initDs us0 nullIdEnv mod_name (dsBinds Nothing const_inst_binds)
+ = initDs us0 nullIdEnv module_and_group (dsBinds False const_inst_binds)
core_const_prs = pairsFromCoreBinds core_const_binds
(core_clas_binds, shadows2)
- = initDs us1 nullIdEnv mod_name (dsBinds Nothing clas_binds)
+ = initDs us1 nullIdEnv module_and_group (dsBinds False clas_binds)
core_clas_prs = pairsFromCoreBinds core_clas_binds
(core_inst_binds, shadows3)
- = initDs us2 nullIdEnv mod_name (dsBinds Nothing inst_binds)
+ = initDs us2 nullIdEnv module_and_group (dsBinds False inst_binds)
core_inst_prs = pairsFromCoreBinds core_inst_binds
(core_val_binds, shadows4)
- = initDs us3 nullIdEnv mod_name (dsBinds (Just module_and_group) val_binds)
+ = initDs us3 nullIdEnv module_and_group (dsBinds opt_SccProfilingOn val_binds)
core_val_pairs = pairsFromCoreBinds core_val_binds
(core_recsel_binds, shadows5)
- = initDs us4 nullIdEnv mod_name (dsBinds Nothing recsel_binds)
+ = initDs us4 nullIdEnv module_and_group (dsBinds False recsel_binds)
core_recsel_prs = pairsFromCoreBinds core_recsel_binds
final_binds
diff --git a/ghc/compiler/deSugar/DsBinds.hi-boot b/ghc/compiler/deSugar/DsBinds.hi-boot
index 9de9237d412f40aaeb6fca8be790ba23d44bc9ee..d1313e8ba88a3f0ac0fb5933d53741d6f38dcdc6 100644
--- a/ghc/compiler/deSugar/DsBinds.hi-boot
+++ b/ghc/compiler/deSugar/DsBinds.hi-boot
@@ -2,4 +2,4 @@ _interface_ DsBinds 1
_exports_
DsBinds dsBinds;
_declarations_
-1 dsBinds _:_ PrelBase.Maybe (BasicTypes.Module, FastString.FastString) -> TcHsSyn.TypecheckedHsBinds -> DsMonad.DsM [CoreSyn.CoreBinding] ;;
+1 dsBinds _:_ PrelBase.Bool -> TcHsSyn.TypecheckedHsBinds -> DsMonad.DsM [CoreSyn.CoreBinding] ;;
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index abffcb18a9a58999f69a5db182dbd12f9903b7f6..adc4e55b8eb1fc18cfa400a117ce41a47963a091 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -58,16 +58,17 @@ that some of the binders are of unboxed type. This is sorted out when
the caller wraps the bindings round an expression.
\begin{code}
-type Group = FAST_STRING
-dsBinds :: Maybe (Module, Group) -> TypecheckedHsBinds -> DsM [CoreBinding]
+dsBinds :: Bool -- if candidate, auto add scc's on toplevs ?
+ -> TypecheckedHsBinds
+ -> DsM [CoreBinding]
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 auto_scc (ThenBinds binds_1 binds_2)
+ = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2)
-dsBinds mb_mod_grp (MonoBind binds sigs is_rec)
- = dsMonoBinds mb_mod_grp is_rec binds `thenDs` \ prs ->
+dsBinds auto_scc (MonoBind binds sigs is_rec)
+ = dsMonoBinds auto_scc is_rec binds `thenDs` \ prs ->
returnDs (if is_rec then
[Rec prs]
else
@@ -83,15 +84,15 @@ dsBinds mb_mod_grp (MonoBind binds sigs is_rec)
%************************************************************************
\begin{code}
-dsMonoBinds :: Maybe (Module, Group) -- Nothing => don't (auto-)annotate scc on toplevs.
+dsMonoBinds :: Bool -- False => don't (auto-)annotate scc on toplevs.
-> RecFlag
-> TypecheckedMonoBinds
-> DsM [(Id,CoreExpr)]
dsMonoBinds _ is_rec EmptyMonoBinds = returnDs []
-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 auto_scc is_rec (AndMonoBinds binds_1 binds_2)
+ = andDs (++) (dsMonoBinds auto_scc is_rec binds_1) (dsMonoBinds auto_scc is_rec binds_2)
dsMonoBinds _ is_rec (CoreMonoBind var core_expr)
= returnDs [(var, core_expr)]
@@ -105,37 +106,40 @@ dsMonoBinds _ is_rec (VarMonoBind var expr)
returnDs [(var, core_expr')]
-dsMonoBinds mb_mod_grp is_rec (FunMonoBind fun _ matches locn)
+dsMonoBinds auto_scc is_rec (FunMonoBind fun _ matches locn)
= putSrcLocDs locn $
matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
- returnDs [addAutoScc mb_mod_grp (fun, mkValLam args body)]
+ addAutoScc auto_scc (fun, mkValLam args body) `thenDs` \ pair ->
+ returnDs [pair]
where
error_string = "function " ++ showForErr fun
-dsMonoBinds mb_mod_grp is_rec (PatMonoBind pat grhss_and_binds locn)
+dsMonoBinds _ is_rec (PatMonoBind pat grhss_and_binds locn)
= putSrcLocDs locn $
dsGuarded grhss_and_binds `thenDs` \ body_expr ->
mkSelectorBinds pat body_expr
-- Common special case: no type or dictionary abstraction
-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])
+dsMonoBinds auto_scc is_rec (AbsBinds [] [] exports binds)
+ = dsMonoBinds False is_rec binds `thenDs` \ prs ->
+ mapDs (addAutoScc auto_scc) [(global, Var local) | (_, global, local) <- exports] `thenDs` \ exports' ->
+ returnDs (prs ++ exports')
-- Another common case: one exported variable
-- All non-recursive bindings come through this way
-dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
+dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
= ASSERT( all (`elem` tyvars) all_tyvars )
- dsMonoBinds Nothing is_rec binds `thenDs` \ core_prs ->
+ dsMonoBinds False is_rec binds `thenDs` \ core_prs ->
let
core_binds | is_rec = [Rec core_prs]
| otherwise = [NonRec b e | (b,e) <- core_prs]
in
- returnDs [addAutoScc mb_mod_grp (global, mkLam tyvars dicts $
- mkCoLetsAny core_binds (Var local))]
+ addAutoScc auto_scc (global, mkLam tyvars dicts $
+ mkCoLetsAny core_binds (Var local)) `thenDs` \ global' ->
+ returnDs [global']
-dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts exports binds)
- = dsMonoBinds Nothing is_rec binds `thenDs` \ core_prs ->
+dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts exports binds)
+ = dsMonoBinds False is_rec binds `thenDs` \ core_prs ->
let
core_binds | is_rec = [Rec core_prs]
| otherwise = [NonRec b e | (b,e) <- core_prs]
@@ -154,10 +158,10 @@ dsMonoBinds mb_mod_grp 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 (addAutoScc mb_mod_grp $
- (global, mkLam tyvars dicts $
- mkTupleSelector locals' (locals' !! n) $
- mkValApp (mkTyApp (Var tup_id) ty_args) dict_args))
+ addAutoScc auto_scc
+ (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
@@ -177,18 +181,17 @@ dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts exports binds)
%************************************************************************
\begin{code}
-addAutoScc :: Maybe (Module, Group) -- Module and group
+addAutoScc :: Bool -- if needs be, decorate toplevs?
-> (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.
+ -> DsM (Id, CoreExpr)
+
+addAutoScc auto_scc_candidate pair@(bndr, core_expr)
+ | auto_scc_candidate && worthSCC core_expr &&
+ (opt_AutoSccsOnAllToplevs || (isExported bndr && opt_AutoSccsOnExportedToplevs))
+ = getModuleAndGroupDs `thenDs` \ (mod,grp) ->
+ returnDs (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr)
+ | otherwise
+ = returnDs pair
worthSCC (SCC _ _) = False
worthSCC (Con _ _) = False
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 49329ab8c9c09dc19a343c22d2004ef8e95906fb..1478d680a98271f1064df629c42f8e70203d51e5 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -266,7 +266,7 @@ dsExpr expr@(HsCase discrim matches src_loc)
returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code )
dsExpr (HsLet binds expr)
- = dsBinds Nothing binds `thenDs` \ core_binds ->
+ = dsBinds False binds `thenDs` \ core_binds ->
dsExpr expr `thenDs` \ core_expr ->
returnDs ( mkCoLetsAny core_binds core_expr )
@@ -654,7 +654,7 @@ dsDo do_or_lc stmts return_id then_id zero_id result_ty
VarArg (mkValLam [ignored_result_id] rest)]
go (LetStmt binds : stmts )
- = dsBinds Nothing binds `thenDs` \ binds2 ->
+ = dsBinds False binds `thenDs` \ binds2 ->
go stmts `thenDs` \ rest ->
returnDs (mkCoLetsAny binds2 rest)
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index bf670d59b5e6a2f37329afaf1efc3616bd0c99a0..63c41d70a46f5e1996f8588c07ebc18dd1fbe1c5 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -59,7 +59,7 @@ dsGuarded :: TypecheckedGRHSsAndBinds
-> DsM CoreExpr
dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
- = dsBinds Nothing binds `thenDs` \ core_binds ->
+ = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
case can_it_fail of
CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
@@ -138,8 +138,8 @@ matchGuard (GuardStmt expr _ : stmts) body_result
returnDs (MatchResult CanFail ty expr_fn cxt)
matchGuard (LetStmt binds : stmts) body_result
- = matchGuard stmts body_result `thenDs` \ match_result ->
- dsBinds Nothing binds `thenDs` \ core_binds ->
+ = matchGuard stmts body_result `thenDs` \ match_result ->
+ dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
returnDs (mkCoLetsMatchResult core_binds match_result)
matchGuard (BindStmt pat rhs _ : stmts) body_result
diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index 5f55784bd3cd6bd48d527baf2df67245645f82bc..7147a4a16f600608268dae6bfe4bacf8340314e7 100644
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -132,8 +132,8 @@ deListComp (GuardStmt guard locn : quals) list -- rule B above
-- [e | let B, qs] = let B in [e | qs]
deListComp (LetStmt binds : quals) list
- = dsBinds Nothing binds `thenDs` \ core_binds ->
- deListComp quals list `thenDs` \ core_rest ->
+ = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
+ deListComp quals list `thenDs` \ core_rest ->
returnDs (mkCoLetsAny core_binds core_rest)
deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
@@ -200,8 +200,8 @@ dfListComp c_ty c_id n_ty n_id (GuardStmt guard locn : quals)
dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals)
-- new in 1.3, local bindings
- = dsBinds Nothing binds `thenDs` \ core_binds ->
- dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
+ = dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
+ dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
returnDs (mkCoLetsAny core_binds core_rest)
dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals)
diff --git a/ghc/compiler/deSugar/DsLoop.lhi b/ghc/compiler/deSugar/DsLoop.lhi
index 9f8759607368e1f9fb38c19fe7570dff2763b007..d38d04e5c6947891caff69540454c197a85a65ef 100644
--- a/ghc/compiler/deSugar/DsLoop.lhi
+++ b/ghc/compiler/deSugar/DsLoop.lhi
@@ -27,6 +27,6 @@ matchSimply :: CoreExpr -- Scrutinee
-> CoreExpr -- Return this if it does
-> DsM CoreExpr
-dsBinds :: Maybe (FastString, FastString) -> TypecheckedHsBinds -> DsM [CoreBinding]
+dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding]
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
\end{code}
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index ce408a4cd4dff10fcc991e73126a3cb8b23cda6c..3428be64465324c973a2cb5a722228066016cb10 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -29,7 +29,8 @@ module DsMonad (
IMP_Ubiq()
import Bag ( emptyBag, snocBag, bagToList, Bag )
-import CmdLineOpts ( opt_SccGroup, opt_PprUserLength )
+import BasicTypes ( SYN_IE(Module) )
+import CmdLineOpts ( opt_PprUserLength )
import CoreSyn ( SYN_IE(CoreExpr) )
import CoreUtils ( substCoreExpr )
import HsSyn ( OutPat )
@@ -59,8 +60,8 @@ presumably include source-file location information:
\begin{code}
type DsM result =
UniqSupply
- -> SrcLoc -- to put in pattern-matching error msgs
- -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling
+ -> SrcLoc -- to put in pattern-matching error msgs
+ -> (Module, Group) -- module + group name : for SCC profiling
-> DsIdEnv
-> DsWarnings
-> (result, DsWarnings)
@@ -68,6 +69,9 @@ type DsM result =
type DsWarnings = Bag (DsWarnFlavour, DsMatchContext)
-- The desugarer reports matches which are
-- completely shadowed or incomplete patterns
+
+type Group = FAST_STRING
+
{-# INLINE andDs #-}
{-# INLINE thenDs #-}
{-# INLINE returnDs #-}
@@ -76,17 +80,12 @@ type DsWarnings = Bag (DsWarnFlavour, DsMatchContext)
initDs :: UniqSupply
-> DsIdEnv
- -> FAST_STRING -- module name: for profiling; (group name: from switches)
+ -> (Module, Group) -- module name: for profiling; (group name: from switches)
-> DsM a
-> (a, DsWarnings)
-initDs init_us env mod_name action
+initDs init_us env module_and_group action
= action init_us noSrcLoc module_and_group env emptyBag
- where
- module_and_group = (mod_name, grp_name)
- grp_name = case opt_SccGroup of
- Just xx -> _PK_ xx
- Nothing -> mod_name -- default: module name
thenDs :: DsM a -> (a -> DsM b) -> DsM b
andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index d0ce737936c478efe89bf1ffa9054b2410078d77..a0cdb445a4e00b41d310972042cb2587f9b7623c 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -613,14 +613,14 @@ matchWrapper kind [(PatMatch (VarPat var) match)] error_string
returnDs (var:vars, core_expr)
matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
- = newSysLocalDs ty `thenDs` \ var ->
+ = newSysLocalDs ty `thenDs` \ var ->
matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
returnDs (var:vars, core_expr)
matchWrapper kind [(GRHSMatch
(GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string
- = dsBinds Nothing binds `thenDs` \ core_binds ->
- dsExpr expr `thenDs` \ core_expr ->
+ = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
+ dsExpr expr `thenDs` \ core_expr ->
returnDs ([], mkCoLetsAny core_binds core_expr)
----------------------------------------------------------------------------
@@ -718,7 +718,7 @@ flattenMatches kind (match : matches)
= flatten_match (pat:pats_so_far) match
flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
- = dsBinds Nothing binds `thenDs` \ core_binds ->
+ = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
dsGRHSs ty kind pats grhss `thenDs` \ match_result ->
returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result))
where