X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FsimplCore%2FFloatOut.lhs;h=f1b190316b46d1f9700a7e7d35904e8261cb1178;hb=718c7d8e6fda41429ddcc4ca41144bbda516f705;hp=988bd53015d53474cc51ccb94b8ddf35e5657b55;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index 988bd53..f1b1903 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -8,10 +8,8 @@ \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 ) @@ -24,7 +22,7 @@ import SetLevels ( Level(..), LevelledExpr, LevelledBind, import UniqSupply ( UniqSupply ) import List ( partition ) import Outputable -import Util ( notNull ) +import FastString \end{code} ----------------- @@ -130,9 +128,9 @@ 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 -} @@ -144,15 +142,11 @@ floatOutwards float_sws dflags us pgm pp_not True = empty pp_not False = text "not" -floatTopBind bind@(NonRec _ _) - = case (floatBind bind) of { (fs, floats, bind') -> - (fs, floatsToBinds floats ++ [bind']) +floatTopBind :: LevelledBind -> (FloatStats, [CoreBind]) +floatTopBind bind + = case (floatBind bind) of { (fs, floats) -> + (fs, floatsToBinds floats) } - -floatTopBind bind@(Rec _) - = case (floatBind bind) of { (fs, floats, Rec pairs') -> - WARN( notNull floats, ppr bind $$ ppr floats ) - (fs, [Rec (floatsToBindPairs floats ++ pairs')]) } \end{code} %************************************************************************ @@ -163,21 +157,25 @@ floatTopBind bind@(Rec _) \begin{code} -floatBind :: LevelledBind - -> (FloatStats, FloatBinds, CoreBind) +floatBind :: LevelledBind -> (FloatStats, FloatBinds) floatBind (NonRec (TB name level) rhs) - = case (floatNonRecRhs level rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, NonRec name rhs') } + = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> + (fs, rhs_floats ++ [(level, NonRec name rhs')]) } floatBind bind@(Rec pairs) = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) -> - - if not (isTopLvl bind_dest_level) then - -- Standard case; the floated bindings can't mention the - -- binders, because they couldn't be escaping a major level - -- if so. - (sum_stats fss, concat rhss_floats, Rec new_pairs) + let rhs_floats = concat rhss_floats in + + if not (isTopLvl bind_dest_lvl) then + -- Find which bindings float out at least one lambda beyond this one + -- These ones can't mention the binders, because they couldn't + -- be escaping a major level if so. + -- The ones that are not going further can join the letrec; + -- they may not be mutually recursive but the occurrence analyser will + -- find that out. + case (partitionByMajorLevel bind_dest_lvl rhs_floats) of { (floats', heres) -> + (sum_stats fss, floats' ++ [(bind_dest_lvl, Rec (floatsToBindPairs heres ++ new_pairs))]) } else -- In a recursive binding, *destined for* the top level -- (only), the rhs floats may contain references to the @@ -192,11 +190,10 @@ floatBind bind@(Rec pairs) -- This can only happen for bindings destined for the top level, -- because only then will partitionByMajorLevel allow through a binding -- that only differs in its minor level - (sum_stats fss, [], - Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats))) + (sum_stats fss, [(bind_dest_lvl, Rec (new_pairs ++ floatsToBindPairs rhs_floats))]) } where - bind_dest_level = getBindLevel bind + bind_dest_lvl = getBindLevel bind do_pair (TB name level, rhs) = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> @@ -211,12 +208,12 @@ floatBind bind@(Rec pairs) %************************************************************************ \begin{code} -floatExpr, floatRhs, floatNonRecRhs +floatExpr, floatRhs, floatCaseAlt :: Level -> LevelledExpr -> (FloatStats, FloatBinds, CoreExpr) -floatRhs lvl arg -- Used rec rhss, and case-alternative rhss +floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss = case (floatExpr lvl arg) of { (fsa, floats, arg') -> case (partitionByMajorLevel lvl floats) of { (floats', heres) -> -- Dump bindings that aren't going to escape from a lambda; @@ -224,45 +221,53 @@ floatRhs lvl arg -- Used rec rhss, and case-alternative rhss -- the rec or case alternative (fsa, floats', install heres arg') }} -floatNonRecRhs lvl arg -- Used for nested non-rec rhss, and fn args +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') -> - -- Dump bindings that aren't going to escape from a lambda - -- This isn't a scoping issue (the binder isn't in scope in the RHS of a non-rec binding) - -- Rather, it is to avoid floating the x binding out of - -- f (let x = e in b) - -- unnecessarily. But we first test for values or trival rhss, - -- because (in particular) we don't want to insert new bindings between - -- the "=" and the "\". E.g. - -- f = \x -> let in - -- We do not want - -- f = let in \x -> - -- (a) The simplifier will immediately float it further out, so we may - -- as well do so right now; in general, keeping rhss as manifest - -- values is good - -- (b) If a float-in pass follows immediately, it might add yet more - -- 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. - if exprIsHNF arg' || exprIsTrivial arg' then + if exprIsCheap arg' then (fsa, floats, arg') else case (partitionByMajorLevel lvl floats) of { (floats', heres) -> (fsa, floats', install heres arg') }} +-- Note [Floating out of RHSs] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Dump bindings that aren't going to escape from a lambda +-- This isn't a scoping issue (the binder isn't in scope in the RHS +-- of a non-rec binding) +-- Rather, it is to avoid floating the x binding out of +-- f (let x = e in b) +-- unnecessarily. But we first test for values or trival rhss, +-- because (in particular) we don't want to insert new bindings between +-- the "=" and the "\". E.g. +-- f = \x -> let in +-- We do not want +-- f = let in \x -> +-- (a) The simplifier will immediately float it further out, so we may +-- as well do so right now; in general, keeping rhss as manifest +-- values is good +-- (b) If a float-in pass follows immediately, it might add yet more +-- 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) floatExpr _ (Lit lit) = (zeroStats, [], Lit lit) floatExpr lvl (App e a) = case (floatExpr lvl e) of { (fse, floats_e, e') -> - case (floatNonRecRhs lvl a) of { (fsa, floats_a, 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 @@ -302,33 +307,34 @@ 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') -> (fs, floating_defns, Note note expr') } +floatExpr lvl (Cast expr co) + = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> + (fs, floating_defns, 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) - = case (floatBind bind) of { (fsb, rhs_floats, bind') -> + = case (floatBind bind) of { (fsb, bind_floats) -> case (floatExpr lvl body) of { (fse, body_floats, body') -> (add_stats fsb fse, - rhs_floats ++ [(bind_lvl, bind')] ++ body_floats, + bind_floats ++ body_floats, body') }} - where - bind_lvl = getBindLevel bind floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts) = case floatExpr lvl scrut of { (fse, fde, scrut') -> @@ -336,18 +342,34 @@ floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts) (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr ty alts') }} where - -- Use floatRhs for the alternatives, so that we + -- Use floatCaseAlt for the alternatives, so that we -- don't gratuitiously float bindings out of the RHSs float_alt (con, bs, rhs) - = case (floatRhs case_lvl rhs) of { (fs, rhs_floats, rhs') -> + = case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') -> (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } 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} %************************************************************************ @@ -365,15 +387,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 @@ -390,8 +417,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} @@ -408,7 +437,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