import CostCentre ( dupifyCC, CostCentre )
import Id ( Id )
import CoreLint ( showPass, endPass )
-import SetLevels ( setLevels, isInlineCtxt,
- Level(..), tOP_LEVEL, ltMajLvl, ltLvl, isTopLvl
- )
+import SetLevels ( Level(..), LevelledExpr, LevelledBind,
+ setLevels, ltMajLvl, ltLvl, isTopLvl )
import UniqSupply ( UniqSupply )
import List ( partition )
import Outputable
+import Util ( notNull )
\end{code}
-----------------
Well, maybe. We don't do this at the moment.
\begin{code}
-type LevelledExpr = TaggedExpr Level
-type LevelledBind = TaggedBind Level
type FloatBind = (Level, CoreBind)
type FloatBinds = [FloatBind]
\end{code}
floatTopBind bind@(Rec _)
= case (floatBind bind) of { (fs, floats, Rec pairs') ->
- WARN( not (null floats), ppr bind $$ ppr floats )
+ WARN( notNull floats, ppr bind $$ ppr floats )
(fs, [Rec (floatsToBindPairs floats ++ pairs')]) }
\end{code}
floatBind :: LevelledBind
-> (FloatStats, FloatBinds, CoreBind)
-floatBind (NonRec (name,level) rhs)
+floatBind (NonRec (TB name level) rhs)
= case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
(fs, rhs_floats, NonRec name rhs') }
where
bind_level = getBindLevel bind
- do_pair ((name, level), rhs)
+ do_pair (TB name level, rhs)
= case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
(fs, rhs_floats, (name, rhs'))
}
floatExpr lvl lam@(Lam _ _)
= let
(bndrs_w_lvls, body) = collectBinders lam
- (bndrs, lvls) = unzip bndrs_w_lvls
+ bndrs = [b | TB b _ <- bndrs_w_lvls]
+ lvls = [l | TB b l <- bndrs_w_lvls]
-- For the all-tyvar case we are prepared to pull
-- the lets out, to implement the float-out-of-big-lambda
floatExpr lvl (Note InlineMe expr) -- Other than SCCs
= case floatExpr InlineCtxt expr of { (fs, floating_defns, expr') ->
- WARN( not (null floating_defns),
- ppr expr $$ ppr floating_defns ) -- We do no floating out of Inlines
- (fs, [], Note InlineMe expr') } -- See notes in SetLevels
+ -- There can be some floating_defns, arising from
+ -- ordinary lets that were there all the time. It seems
+ -- more efficient to test once here than to avoid putting
+ -- them into floating_defns (which would mean testing for
+ -- inlineCtxt at every let)
+ (fs, [], Note InlineMe (install floating_defns expr')) } -- See notes in SetLevels
floatExpr lvl (Note note expr) -- Other than SCCs
= case (floatExpr lvl expr) of { (fs, floating_defns, expr') ->
where
bind_lvl = getBindLevel bind
-floatExpr lvl (Case scrut (case_bndr, case_lvl) alts)
+floatExpr lvl (Case scrut (TB case_bndr case_lvl) alts)
= case floatExpr lvl scrut of { (fse, fde, scrut') ->
case floatList float_alt alts of { (fsa, fda, alts') ->
(add_stats fse fsa, fda ++ fde, Case scrut' case_bndr alts')
-- don't gratuitiously float bindings out of the RHSs
float_alt (con, bs, rhs)
= case (floatRhs case_lvl rhs) of { (fs, rhs_floats, rhs') ->
- (fs, rhs_floats, (con, map fst bs, rhs')) }
+ (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
%************************************************************************
\begin{code}
-getBindLevel (NonRec (_, lvl) _) = lvl
-getBindLevel (Rec (((_,lvl), _) : _)) = lvl
+getBindLevel (NonRec (TB _ lvl) _) = lvl
+getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl
\end{code}
\begin{code}