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 )
\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
(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
_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] ;;
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
%************************************************************************
\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)]
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]
= -- 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
%************************************************************************
\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
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 )
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)
-> 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")))
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
-- [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
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)
-> 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}
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 )
\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)
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 #-}
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
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)
----------------------------------------------------------------------------
= 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
projects / ghc-hetmet.git / commitdiff