diff options
Diffstat (limited to 'compiler/deSugar/DsBinds.lhs')
| -rw-r--r-- | compiler/deSugar/DsBinds.lhs | 146 |
1 files changed, 39 insertions, 107 deletions
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 2b2b3229d7..f207074cd8 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -11,8 +11,7 @@ lower levels it is preserved with @let@/@letrec@s). \begin{code} module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, - dsHsWrapper, dsTcEvBinds, dsEvBinds, - AutoScc(..) + dsHsWrapper, dsTcEvBinds, dsEvBinds, ) where #include "HsVersions.h" @@ -39,8 +38,6 @@ import TcType import Type import Coercion hiding (substCo) import TysWiredIn ( eqBoxDataCon, tupleCon ) -import CostCentre -import Module import Id import Class import DataCon ( dataConWorkId ) @@ -69,70 +66,68 @@ import MonadUtils %************************************************************************ \begin{code} -dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) -dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds +dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) +dsTopLHsBinds binds = ds_lhs_binds binds dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)] -dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds +dsLHsBinds binds = do { binds' <- ds_lhs_binds binds ; return (fromOL binds') } ------------------------ -ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) +ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) - -- scc annotation policy (see below) -ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds - ; return (foldBag appOL id nilOL ds_bs) } +ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds + ; return (foldBag appOL id nilOL ds_bs) } -dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr)) -dsLHsBind auto_scc (L loc bind) - = putSrcSpanDs loc $ dsHsBind auto_scc bind +dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr)) +dsLHsBind (L loc bind) + = putSrcSpanDs loc $ dsHsBind bind -dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr)) +dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr)) -dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless }) +dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless }) = do { core_expr <- dsLExpr expr -- Dictionary bindings are always VarBinds, -- so we only need do this here - ; core_expr' <- addDictScc var core_expr - ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr' + ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr | otherwise = var - ; return (unitOL (makeCorePair var' False 0 core_expr')) } + ; return (unitOL (makeCorePair var' False 0 core_expr)) } -dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches - , fun_co_fn = co_fn, fun_tick = tick - , fun_infix = inf }) +dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches + , fun_co_fn = co_fn, fun_tick = tick + , fun_infix = inf }) = do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches - ; body' <- mkOptTickBox tick body - ; wrap_fn' <- dsHsWrapper co_fn - ; let rhs = addAutoScc auto_scc fun $ wrap_fn' (mkLams args body') - ; return (unitOL (makeCorePair fun False 0 rhs)) } - -dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) + ; let body' = mkOptTickBox tick body + ; wrap_fn' <- dsHsWrapper co_fn + ; let rhs = wrap_fn' (mkLams args body') + ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -} + return (unitOL (makeCorePair fun False 0 rhs)) } + +dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty + , pat_ticks = (rhs_tick, var_ticks) }) = do { body_expr <- dsGuarded grhss ty - ; sel_binds <- mkSelectorBinds pat body_expr + ; let body' = mkOptTickBox rhs_tick body_expr + ; sel_binds <- mkSelectorBinds var_ticks pat body' -- We silently ignore inline pragmas; no makeCorePair -- Not so cool, but really doesn't matter - ; let sel_binds' = [ (v, addAutoScc auto_scc v expr) - | (v, expr) <- sel_binds ] - ; return (toOL sel_binds') } + ; return (toOL sel_binds) } -- A common case: one exported variable -- Non-recursive bindings come through this way -- So do self-recursive bindings, and recursive bindings -- that have been chopped up with type signatures -dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = [export] - , abs_ev_binds = ev_binds, abs_binds = binds }) +dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = [export] + , abs_ev_binds = ev_binds, abs_binds = binds }) | ABE { abe_wrap = wrap, abe_poly = global , abe_mono = local, abe_prags = prags } <- export - = do { bind_prs <- ds_lhs_binds NoSccs binds + = do { bind_prs <- ds_lhs_binds binds ; ds_ev_binds <- dsTcEvBinds ev_binds ; wrap_fn <- dsHsWrapper wrap ; let core_bind = Rec (fromOL bind_prs) - rhs = addAutoScc auto_scc global $ - wrap_fn $ -- Usually the identity + rhs = wrap_fn $ -- Usually the identity mkLams tyvars $ mkLams dicts $ mkCoreLets ds_ev_binds $ Let core_bind $ @@ -146,17 +141,12 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts ; return (main_bind `consOL` spec_binds) } -dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = exports, abs_ev_binds = ev_binds - , abs_binds = binds }) - = do { bind_prs <- ds_lhs_binds NoSccs binds +dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = exports, abs_ev_binds = ev_binds + , abs_binds = binds }) + = do { bind_prs <- ds_lhs_binds binds ; ds_ev_binds <- dsTcEvBinds ev_binds - ; let env = mkABEnv exports - do_one (lcl_id,rhs) | Just export <- lookupVarEnv env lcl_id - = (lcl_id, addAutoScc auto_scc (abe_poly export) rhs) - | otherwise = (lcl_id,rhs) - - core_bind = Rec (map do_one (fromOL bind_prs)) + ; let core_bind = Rec (fromOL bind_prs) -- Monomorphic recursion possible, hence Rec tup_expr = mkBigCoreVarTup locals @@ -181,8 +171,7 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts ; let global' = addIdSpecialisations global rules ; return ((global', rhs) `consOL` spec_binds) } - ; export_binds_s <- mapM mk_bind exports - -- Don't scc (auto-)annotate the tuple itself. + ; export_binds_s <- mapM mk_bind exports ; return ((poly_tup_id, poly_tup_rhs) `consOL` concatOL export_binds_s) } @@ -310,17 +299,6 @@ makeCorePair gbl_id is_default_method dict_arity rhs dictArity :: [Var] -> Arity -- Don't count coercion variables in arity dictArity dicts = count isId dicts - - ------------------------- -type AbsBindEnv = VarEnv (ABExport Id) - -- Maps the "lcl_id" for an AbsBind to - -- its "gbl_id" and associated pragmas, if any - -mkABEnv :: [ABExport Id] -> AbsBindEnv --- Takes the exports of a AbsBinds, and returns a mapping --- lcl_id -> (tyvars, gbl_id, lcl_id, prags) -mkABEnv exports = mkVarEnv [ (abe_mono export, export) | export <- exports] \end{code} Note [Rules and inlining] @@ -691,52 +669,6 @@ as the old one, but with an Internal name and no IdInfo. %************************************************************************ %* * -\subsection[addAutoScc]{Adding automatic sccs} -%* * -%************************************************************************ - -\begin{code} -data AutoScc = NoSccs - | AddSccs Module (Id -> Bool) --- The (Id->Bool) says which Ids to add SCCs to --- But we never add a SCC to function marked INLINE - -addAutoScc :: AutoScc - -> Id -- Binder - -> CoreExpr -- Rhs - -> CoreExpr -- Scc'd Rhs - -addAutoScc NoSccs _ rhs - = rhs -addAutoScc _ id rhs | isInlinePragma (idInlinePragma id) - = rhs -addAutoScc (AddSccs mod add_scc) id rhs - | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs - | otherwise = rhs -\end{code} - -If profiling and dealing with a dict binding, -wrap the dict in @_scc_ DICT <dict>@: - -\begin{code} -addDictScc :: Id -> CoreExpr -> DsM CoreExpr -addDictScc _ rhs = return rhs - -{- DISABLED for now (need to somehow make up a name for the scc) -- SDM - | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts) - || not (isDictId var) - = return rhs -- That's easy: do nothing - - | otherwise - = do (mod, grp) <- getModuleAndGroupDs - -- ToDo: do -dicts-all flag (mark dict things with individual CCs) - return (Note (SCC (mkAllDictsCC mod grp False)) rhs) --} -\end{code} - - -%************************************************************************ -%* * Desugaring coercions %* * %************************************************************************ |