X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FFloatOut.lhs;h=6562c84e8c6eca17c14b148c8cecb401665a164e;hb=9a4ef343a46e823bcf949af8501c13cc8ca98fb1;hp=c97bbce28e32a721b90669d0d0b600e010bf7830;hpb=2f41dd510a893312dfaa0d652f448cc3a045eb88;p=ghc-hetmet.git diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index c97bbce..6562c84 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -8,22 +8,20 @@ \begin{code} module FloatOut ( floatOutwards ) where -#include "HsVersions.h" - import CoreSyn -import CoreUtils ( mkSCC, exprIsHNF, exprIsTrivial ) +import CoreUtils import DynFlags ( DynFlags, DynFlag(..), FloatOutSwitches(..) ) import ErrUtils ( dumpIfSet_dyn ) import CostCentre ( dupifyCC, CostCentre ) import Id ( Id, idType ) import Type ( isUnLiftedType ) -import CoreLint ( showPass, endPass ) import SetLevels ( Level(..), LevelledExpr, LevelledBind, setLevels, ltMajLvl, ltLvl, isTopLvl ) import UniqSupply ( UniqSupply ) import List ( partition ) import Outputable +import FastString \end{code} ----------------- @@ -117,8 +115,6 @@ floatOutwards :: FloatOutSwitches floatOutwards float_sws dflags us pgm = do { - showPass dflags float_msg ; - let { annotated_w_levels = setLevels float_sws pgm us ; (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) } ; @@ -129,20 +125,14 @@ floatOutwards float_sws dflags us pgm let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" - (hcat [ int tlets, ptext SLIT(" Lets floated to top level; "), - int ntlets, ptext SLIT(" Lets floated elsewhere; from "), - int lams, ptext SLIT(" Lambda groups")]); + (hcat [ int tlets, ptext (sLit " Lets floated to top level; "), + int ntlets, ptext (sLit " Lets floated elsewhere; from "), + int lams, ptext (sLit " Lambda groups")]); - endPass dflags float_msg Opt_D_verbose_core2core (concat binds_s') - {- no specific flag for dumping float-out -} + return (concat binds_s') } - where - float_msg = showSDoc (text "Float out" <+> parens (sws float_sws)) - sws (FloatOutSw lam const) = pp_not lam <+> text "lambdas" <> comma <+> - pp_not const <+> text "constants" - pp_not True = empty - pp_not False = text "not" +floatTopBind :: LevelledBind -> (FloatStats, [CoreBind]) floatTopBind bind = case (floatBind bind) of { (fs, floats) -> (fs, floatsToBinds floats) @@ -224,7 +214,7 @@ floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss floatRhs lvl arg -- Used for nested non-rec rhss, and fn args -- See Note [Floating out of RHS] = case (floatExpr lvl arg) of { (fsa, floats, arg') -> - if exprIsHNF arg' || exprIsTrivial arg' then + if exprIsCheap arg' then (fsa, floats, arg') else case (partitionByMajorLevel lvl floats) of { (floats', heres) -> @@ -250,6 +240,9 @@ floatRhs lvl arg -- Used for nested non-rec rhss, and fn args -- bindings just after the '='. And some of them might (correctly) -- be strict even though the 'let f' is lazy, because f, being a value, -- gets its demand-info zapped by the simplifier. +-- +-- We use exprIsCheap because that is also what's used by the simplifier +-- to decide whether to float a let out of a let floatExpr _ (Var v) = (zeroStats, [], Var v) floatExpr _ (Type ty) = (zeroStats, [], Type ty) @@ -260,11 +253,11 @@ floatExpr lvl (App e a) case (floatRhs lvl a) of { (fsa, floats_a, a') -> (fse `add_stats` fsa, floats_e ++ floats_a, App e' a') }} -floatExpr lvl lam@(Lam _ _) +floatExpr _ lam@(Lam _ _) = let (bndrs_w_lvls, body) = collectBinders lam bndrs = [b | TB b _ <- bndrs_w_lvls] - lvls = [l | TB b l <- bndrs_w_lvls] + lvls = [l | TB _ 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 @@ -304,14 +297,12 @@ floatExpr lvl (Note note@(SCC cc) expr) ann_bind (Rec pairs) = Rec [(binder, mkSCC dupd_cc rhs) | (binder, rhs) <- pairs] -floatExpr lvl (Note InlineMe expr) -- Other than SCCs - = case floatExpr InlineCtxt expr of { (fs, floating_defns, expr') -> - -- 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 _ (Note InlineMe expr) -- Other than SCCs + = (zeroStats, [], Note InlineMe (unTag expr)) + -- Do no floating at all inside INLINE. + -- The SetLevels pass did not clone the bindings, so it's + -- unsafe to do any floating, even if we dump the results + -- inside the Note (which is what we used to do). floatExpr lvl (Note note expr) -- Other than SCCs = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> @@ -323,8 +314,9 @@ floatExpr lvl (Cast expr co) floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body) | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case - = case floatExpr lvl rhs of { (fs, rhs_floats, rhs') -> - case floatRhs bndr_lvl body of { (fs, body_floats, body') -> + -- I.e. floatExpr for rhs, floatCaseAlt for body + = case floatExpr lvl rhs of { (_, rhs_floats, rhs') -> + case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') -> (fs, rhs_floats ++ body_floats, Let (NonRec bndr rhs') body') }} floatExpr lvl (Let bind body) @@ -348,10 +340,26 @@ floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts) floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) -floatList f [] = (zeroStats, [], []) +floatList _ [] = (zeroStats, [], []) floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> case floatList f as of { (fs_as, binds_as, bs) -> (fs_a `add_stats` fs_as, binds_a ++ binds_as, b:bs) }} + +unTagBndr :: TaggedBndr tag -> CoreBndr +unTagBndr (TB b _) = b + +unTag :: TaggedExpr tag -> CoreExpr +unTag (Var v) = Var v +unTag (Lit l) = Lit l +unTag (Type ty) = Type ty +unTag (Note n e) = Note n (unTag e) +unTag (App e1 e2) = App (unTag e1) (unTag e2) +unTag (Lam b e) = Lam (unTagBndr b) (unTag e) +unTag (Cast e co) = Cast (unTag e) co +unTag (Let (Rec prs) e) = Let (Rec [(unTagBndr b,unTag r) | (b, r) <- prs]) (unTag e) +unTag (Let (NonRec b r) e) = Let (NonRec (unTagBndr b) (unTag r)) (unTag e) +unTag (Case e b ty alts) = Case (unTag e) (unTagBndr b) ty + [(c, map unTagBndr bs, unTag r) | (c,bs,r) <- alts] \end{code} %************************************************************************ @@ -369,15 +377,20 @@ data FloatStats Int -- Number of non-top-floats * lambda groups they've been past Int -- Number of lambda (groups) seen +get_stats :: FloatStats -> (Int, Int, Int) get_stats (FlS a b c) = (a, b, c) +zeroStats :: FloatStats zeroStats = FlS 0 0 0 +sum_stats :: [FloatStats] -> FloatStats sum_stats xs = foldr add_stats zeroStats xs +add_stats :: FloatStats -> FloatStats -> FloatStats add_stats (FlS a1 b1 c1) (FlS a2 b2 c2) = FlS (a1 + a2) (b1 + b2) (c1 + c2) +add_to_stats :: FloatStats -> [(Level, Bind CoreBndr)] -> FloatStats add_to_stats (FlS a b c) floats = FlS (a + length top_floats) (b + length other_floats) (c + 1) where @@ -394,8 +407,10 @@ add_to_stats (FlS a b c) floats %************************************************************************ \begin{code} -getBindLevel (NonRec (TB _ lvl) _) = lvl +getBindLevel :: Bind (TaggedBndr Level) -> Level +getBindLevel (NonRec (TB _ lvl) _) = lvl getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl +getBindLevel (Rec []) = panic "getBindLevel Rec []" \end{code} \begin{code} @@ -412,7 +427,7 @@ partitionByMajorLevel ctxt_lvl defns = partition float_further defns where -- Float it if we escape a value lambda, or if we get to the top level - float_further (my_lvl, bind) = my_lvl `ltMajLvl` ctxt_lvl || isTopLvl my_lvl + float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl || isTopLvl my_lvl -- The isTopLvl part says that if we can get to the top level, say "yes" anyway -- This means that -- x = f e