diff options
Diffstat (limited to 'compiler/simplCore/FloatIn.lhs')
| -rw-r--r-- | compiler/simplCore/FloatIn.lhs | 464 |
1 files changed, 464 insertions, 0 deletions
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs new file mode 100644 index 0000000000..0e8edb5930 --- /dev/null +++ b/compiler/simplCore/FloatIn.lhs @@ -0,0 +1,464 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +%************************************************************************ +%* * +\section[FloatIn]{Floating Inwards pass} +%* * +%************************************************************************ + +The main purpose of @floatInwards@ is floating into branches of a +case, so that we don't allocate things, save them on the stack, and +then discover that they aren't needed in the chosen branch. + +\begin{code} +module FloatIn ( floatInwards ) where + +#include "HsVersions.h" + +import DynFlags ( DynFlags, DynFlag(..) ) +import CoreSyn +import CoreUtils ( exprIsHNF, exprIsDupable ) +import CoreLint ( showPass, endPass ) +import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf ) +import Id ( isOneShotBndr ) +import Var ( Id, idType ) +import Type ( isUnLiftedType ) +import VarSet +import Util ( zipEqual, zipWithEqual, count ) +import Outputable +\end{code} + +Top-level interface function, @floatInwards@. Note that we do not +actually float any bindings downwards from the top-level. + +\begin{code} +floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind] + +floatInwards dflags binds + = do { + showPass dflags "Float inwards"; + let { binds' = map fi_top_bind binds }; + endPass dflags "Float inwards" Opt_D_verbose_core2core binds' + {- no specific flag for dumping float-in -} + } + + where + fi_top_bind (NonRec binder rhs) + = NonRec binder (fiExpr [] (freeVars rhs)) + fi_top_bind (Rec pairs) + = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ] +\end{code} + +%************************************************************************ +%* * +\subsection{Mail from Andr\'e [edited]} +%* * +%************************************************************************ + +{\em Will wrote: What??? I thought the idea was to float as far +inwards as possible, no matter what. This is dropping all bindings +every time it sees a lambda of any kind. Help! } + +You are assuming we DO DO full laziness AFTER floating inwards! We +have to [not float inside lambdas] if we don't. + +If we indeed do full laziness after the floating inwards (we could +check the compilation flags for that) then I agree we could be more +aggressive and do float inwards past lambdas. + +Actually we are not doing a proper full laziness (see below), which +was another reason for not floating inwards past a lambda. + +This can easily be fixed. The problem is that we float lets outwards, +but there are a few expressions which are not let bound, like case +scrutinees and case alternatives. After floating inwards the +simplifier could decide to inline the let and the laziness would be +lost, e.g. + +\begin{verbatim} +let a = expensive ==> \b -> case expensive of ... +in \ b -> case a of ... +\end{verbatim} +The fix is +\begin{enumerate} +\item +to let bind the algebraic case scrutinees (done, I think) and +the case alternatives (except the ones with an +unboxed type)(not done, I think). This is best done in the +SetLevels.lhs module, which tags things with their level numbers. +\item +do the full laziness pass (floating lets outwards). +\item +simplify. The simplifier inlines the (trivial) lets that were + created but were not floated outwards. +\end{enumerate} + +With the fix I think Will's suggestion that we can gain even more from +strictness by floating inwards past lambdas makes sense. + +We still gain even without going past lambdas, as things may be +strict in the (new) context of a branch (where it was floated to) or +of a let rhs, e.g. +\begin{verbatim} +let a = something case x of +in case x of alt1 -> case something of a -> a + a + alt1 -> a + a ==> alt2 -> b + alt2 -> b + +let a = something let b = case something of a -> a + a +in let b = a + a ==> in (b,b) +in (b,b) +\end{verbatim} +Also, even if a is not found to be strict in the new context and is +still left as a let, if the branch is not taken (or b is not entered) +the closure for a is not built. + +%************************************************************************ +%* * +\subsection{Main floating-inwards code} +%* * +%************************************************************************ + +\begin{code} +type FreeVarsSet = IdSet + +type FloatingBinds = [(CoreBind, FreeVarsSet)] + -- In reverse dependency order (innermost bindiner first) + + -- The FreeVarsSet is the free variables of the binding. In the case + -- of recursive bindings, the set doesn't include the bound + -- variables. + +fiExpr :: FloatingBinds -- Binds we're trying to drop + -- as far "inwards" as possible + -> CoreExprWithFVs -- Input expr + -> CoreExpr -- Result + +fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) + +fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) + Type ty + +fiExpr to_drop (_, AnnLit lit) = Lit lit +\end{code} + +Applications: we do float inside applications, mainly because we +need to get at all the arguments. The next simplifier run will +pull out any silly ones. + +\begin{code} +fiExpr to_drop (_,AnnApp fun arg) + = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg)) + where + [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop +\end{code} + +We are careful about lambdas: + +* We must be careful about floating inside inside a value lambda. + That risks losing laziness. + The float-out pass might rescue us, but then again it might not. + +* We must be careful about type lambdas too. At one time we did, and + there is no risk of duplicating work thereby, but we do need to be + careful. In particular, here is a bad case (it happened in the + cichelli benchmark: + let v = ... + in let f = /\t -> \a -> ... + ==> + let f = /\t -> let v = ... in \a -> ... + This is bad as now f is an updatable closure (update PAP) + and has arity 0. + +So we treat lambda in groups, using the following rule: + + Float inside a group of lambdas only if + they are all either type lambdas or one-shot lambdas. + + Otherwise drop all the bindings outside the group. + +\begin{code} + -- Hack alert! We only float in through one-shot lambdas, + -- not (as you might guess) through big lambdas. + -- Reason: we float *out* past big lambdas (see the test in the Lam + -- case of FloatOut.floatExpr) and we don't want to float straight + -- back in again. + -- + -- It *is* important to float into one-shot lambdas, however; + -- see the remarks with noFloatIntoRhs. +fiExpr to_drop lam@(_, AnnLam _ _) + | all is_one_shot bndrs -- Float in + = mkLams bndrs (fiExpr to_drop body) + + | otherwise -- Dump it all here + = mkCoLets' to_drop (mkLams bndrs (fiExpr [] body)) + + where + (bndrs, body) = collectAnnBndrs lam +\end{code} + +We don't float lets inwards past an SCC. + ToDo: keep info on current cc, and when passing + one, if it is not the same, annotate all lets in binds with current + cc, change current cc to the new one and float binds into expr. + +\begin{code} +fiExpr to_drop (_, AnnNote note@(SCC cc) expr) + = -- Wimp out for now + mkCoLets' to_drop (Note note (fiExpr [] expr)) + +fiExpr to_drop (_, AnnNote InlineCall expr) + = -- Wimp out for InlineCall; keep it close + -- the the call it annotates + mkCoLets' to_drop (Note InlineCall (fiExpr [] expr)) + +fiExpr to_drop (_, AnnNote InlineMe expr) + = -- Ditto... don't float anything into an INLINE expression + mkCoLets' to_drop (Note InlineMe (fiExpr [] expr)) + +fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr) + = -- Just float in past coercion + Note note (fiExpr to_drop expr) + +fiExpr to_drop (_, AnnNote note@(CoreNote _) expr) + = Note note (fiExpr to_drop expr) +\end{code} + +For @Lets@, the possible ``drop points'' for the \tr{to_drop} +bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding, +or~(b2), in each of the RHSs of the pairs of a @Rec@. + +Note that we do {\em weird things} with this let's binding. Consider: +\begin{verbatim} +let + w = ... +in { + let v = ... w ... + in ... v .. w ... +} +\end{verbatim} +Look at the inner \tr{let}. As \tr{w} is used in both the bind and +body of the inner let, we could panic and leave \tr{w}'s binding where +it is. But \tr{v} is floatable further into the body of the inner let, and +{\em then} \tr{w} will also be only in the body of that inner let. + +So: rather than drop \tr{w}'s binding here, we add it onto the list of +things to drop in the outer let's body, and let nature take its +course. + +\begin{code} +fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) + = fiExpr new_to_drop body + where + body_fvs = freeVarsOf body + + final_body_fvs | noFloatIntoRhs ann_rhs + || isUnLiftedType (idType id) = body_fvs `unionVarSet` rhs_fvs + | otherwise = body_fvs + -- See commments with letrec below + -- No point in floating in only to float straight out again + -- Ditto ok-for-speculation unlifted RHSs + + [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint False [rhs_fvs, final_body_fvs] to_drop + + new_to_drop = body_binds ++ -- the bindings used only in the body + [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself + shared_binds -- the bindings used both in rhs and body + + -- Push rhs_binds into the right hand side of the binding + rhs' = fiExpr rhs_binds rhs + rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds + +fiExpr to_drop (_,AnnLet (AnnRec bindings) body) + = fiExpr new_to_drop body + where + rhss = map snd bindings + + rhss_fvs = map freeVarsOf rhss + body_fvs = freeVarsOf body + + -- Add to body_fvs the free vars of any RHS that has + -- a lambda at the top. This has the effect of making it seem + -- that such things are used in the body as well, and hence prevents + -- them getting floated in. The big idea is to avoid turning: + -- let x# = y# +# 1# + -- in + -- letrec f = \z. ...x#...f... + -- in ... + -- into + -- letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... + -- + -- Because now we can't float the let out again, because a letrec + -- can't have unboxed bindings. + + final_body_fvs = foldr (unionVarSet . get_extras) body_fvs rhss + get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs + | otherwise = emptyVarSet + + (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint False (final_body_fvs:rhss_fvs) to_drop + + new_to_drop = -- the bindings used only in the body + body_binds ++ + -- the new binding itself + [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++ + -- the bindings used both in rhs and body or in more than one rhs + shared_binds + + rhs_fvs' = unionVarSet (unionVarSets rhss_fvs) + (unionVarSets (map floatedBindsFVs rhss_binds)) + + -- Push rhs_binds into the right hand side of the binding + fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss + -> [(Id, CoreExprWithFVs)] + -> [(Id, CoreExpr)] + + fi_bind to_drops pairs + = [ (binder, fiExpr to_drop rhs) + | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] +\end{code} + +For @Case@, the possible ``drop points'' for the \tr{to_drop} +bindings are: (a)~inside the scrutinee, (b)~inside one of the +alternatives/default [default FVs always {\em first}!]. + +\begin{code} +fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) + = mkCoLets' drop_here1 $ + mkCoLets' drop_here2 $ + Case (fiExpr scrut_drops scrut) case_bndr ty + (zipWith fi_alt alts_drops_s alts) + where + -- Float into the scrut and alts-considered-together just like App + [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop + + -- Float into the alts with the is_case flag set + (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops + + scrut_fvs = freeVarsOf scrut + alts_fvs = map alt_fvs alts + all_alts_fvs = unionVarSets alts_fvs + alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args) + -- Delete case_bndr and args from free vars of rhs + -- to get free vars of alt + + fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs) + +noFloatIntoRhs (AnnNote InlineMe _) = True +noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) + -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top. + -- This makes a big difference for things like + -- f x# = let x = I# x# + -- in let j = \() -> ...x... + -- in if <condition> then normal-path else j () + -- If x is used only in the error case join point, j, we must float the + -- boxing constructor into it, else we box it every time which is very bad + -- news indeed. + +noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again... + +is_one_shot b = isId b && isOneShotBndr b +\end{code} + + +%************************************************************************ +%* * +\subsection{@sepBindsByDropPoint@} +%* * +%************************************************************************ + +This is the crucial function. The idea is: We have a wad of bindings +that we'd like to distribute inside a collection of {\em drop points}; +insides the alternatives of a \tr{case} would be one example of some +drop points; the RHS and body of a non-recursive \tr{let} binding +would be another (2-element) collection. + +So: We're given a list of sets-of-free-variables, one per drop point, +and a list of floating-inwards bindings. If a binding can go into +only one drop point (without suddenly making something out-of-scope), +in it goes. If a binding is used inside {\em multiple} drop points, +then it has to go in a you-must-drop-it-above-all-these-drop-points +point. + +We have to maintain the order on these drop-point-related lists. + +\begin{code} +sepBindsByDropPoint + :: Bool -- True <=> is case expression + -> [FreeVarsSet] -- One set of FVs per drop point + -> FloatingBinds -- Candidate floaters + -> [FloatingBinds] -- FIRST one is bindings which must not be floated + -- inside any drop point; the rest correspond + -- one-to-one with the input list of FV sets + +-- Every input floater is returned somewhere in the result; +-- none are dropped, not even ones which don't seem to be +-- free in *any* of the drop-point fvs. Why? Because, for example, +-- a binding (let x = E in B) might have a specialised version of +-- x (say x') stored inside x, but x' isn't free in E or B. + +type DropBox = (FreeVarsSet, FloatingBinds) + +sepBindsByDropPoint is_case drop_pts [] + = [] : [[] | p <- drop_pts] -- cut to the chase scene; it happens + +sepBindsByDropPoint is_case drop_pts floaters + = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) + where + go :: FloatingBinds -> [DropBox] -> [FloatingBinds] + -- The *first* one in the argument list is the drop_here set + -- The FloatingBinds in the lists are in the reverse of + -- the normal FloatingBinds order; that is, they are the right way round! + + go [] drop_boxes = map (reverse . snd) drop_boxes + + go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes) + = go binds new_boxes + where + -- "here" means the group of bindings dropped at the top of the fork + + (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind) + | (fvs, drops) <- drop_boxes] + + drop_here = used_here || not can_push + + -- For case expressions we duplicate the binding if it is + -- reasonably small, and if it is not used in all the RHSs + -- This is good for situations like + -- let x = I# y in + -- case e of + -- C -> error x + -- D -> error x + -- E -> ...not mentioning x... + + n_alts = length used_in_flags + n_used_alts = count id used_in_flags -- returns number of Trues in list. + + can_push = n_used_alts == 1 -- Used in just one branch + || (is_case && -- We are looking at case alternatives + n_used_alts > 1 && -- It's used in more than one + n_used_alts < n_alts && -- ...but not all + bindIsDupable bind) -- and we can duplicate the binding + + new_boxes | drop_here = (insert here_box : fork_boxes) + | otherwise = (here_box : new_fork_boxes) + + new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags + + insert :: DropBox -> DropBox + insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) + + insert_maybe box True = insert box + insert_maybe box False = box + + +floatedBindsFVs :: FloatingBinds -> FreeVarsSet +floatedBindsFVs binds = unionVarSets (map snd binds) + +mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr +mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop + -- Remember to_drop is in *reverse* dependency order + +bindIsDupable (Rec prs) = all (exprIsDupable . snd) prs +bindIsDupable (NonRec b r) = exprIsDupable r +\end{code} |