2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %************************************************************************
6 \section[FloatIn]{Floating Inwards pass}
8 %************************************************************************
10 The main purpose of @floatInwards@ is floating into branches of a
11 case, so that we don't allocate things, save them on the stack, and
12 then discover that they aren't needed in the chosen branch.
15 module FloatIn ( floatInwards ) where
17 #include "HsVersions.h"
19 import DynFlags ( DynFlags, DynFlag(..) )
21 import CoreUtils ( exprIsHNF, exprIsDupable )
22 import CoreLint ( showPass, endPass )
23 import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars )
24 import Id ( isOneShotBndr, idType )
26 import Type ( isUnLiftedType )
28 import Util ( zipEqual, zipWithEqual, count )
33 Top-level interface function, @floatInwards@. Note that we do not
34 actually float any bindings downwards from the top-level.
37 floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
39 floatInwards dflags binds
41 showPass dflags "Float inwards";
42 let { binds' = map fi_top_bind binds };
43 endPass dflags "Float inwards" Opt_D_verbose_core2core binds'
44 {- no specific flag for dumping float-in -}
48 fi_top_bind (NonRec binder rhs)
49 = NonRec binder (fiExpr [] (freeVars rhs))
50 fi_top_bind (Rec pairs)
51 = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
54 %************************************************************************
56 \subsection{Mail from Andr\'e [edited]}
58 %************************************************************************
60 {\em Will wrote: What??? I thought the idea was to float as far
61 inwards as possible, no matter what. This is dropping all bindings
62 every time it sees a lambda of any kind. Help! }
64 You are assuming we DO DO full laziness AFTER floating inwards! We
65 have to [not float inside lambdas] if we don't.
67 If we indeed do full laziness after the floating inwards (we could
68 check the compilation flags for that) then I agree we could be more
69 aggressive and do float inwards past lambdas.
71 Actually we are not doing a proper full laziness (see below), which
72 was another reason for not floating inwards past a lambda.
74 This can easily be fixed. The problem is that we float lets outwards,
75 but there are a few expressions which are not let bound, like case
76 scrutinees and case alternatives. After floating inwards the
77 simplifier could decide to inline the let and the laziness would be
81 let a = expensive ==> \b -> case expensive of ...
82 in \ b -> case a of ...
87 to let bind the algebraic case scrutinees (done, I think) and
88 the case alternatives (except the ones with an
89 unboxed type)(not done, I think). This is best done in the
90 SetLevels.lhs module, which tags things with their level numbers.
92 do the full laziness pass (floating lets outwards).
94 simplify. The simplifier inlines the (trivial) lets that were
95 created but were not floated outwards.
98 With the fix I think Will's suggestion that we can gain even more from
99 strictness by floating inwards past lambdas makes sense.
101 We still gain even without going past lambdas, as things may be
102 strict in the (new) context of a branch (where it was floated to) or
105 let a = something case x of
106 in case x of alt1 -> case something of a -> a + a
107 alt1 -> a + a ==> alt2 -> b
110 let a = something let b = case something of a -> a + a
111 in let b = a + a ==> in (b,b)
114 Also, even if a is not found to be strict in the new context and is
115 still left as a let, if the branch is not taken (or b is not entered)
116 the closure for a is not built.
118 %************************************************************************
120 \subsection{Main floating-inwards code}
122 %************************************************************************
125 type FreeVarsSet = IdSet
127 type FloatingBinds = [(CoreBind, FreeVarsSet)]
128 -- In reverse dependency order (innermost binder first)
130 -- The FreeVarsSet is the free variables of the binding. In the case
131 -- of recursive bindings, the set doesn't include the bound
134 fiExpr :: FloatingBinds -- Binds we're trying to drop
135 -- as far "inwards" as possible
136 -> CoreExprWithFVs -- Input expr
137 -> CoreExpr -- Result
139 fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
141 fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
143 fiExpr to_drop (_, AnnCast expr co)
144 = Cast (fiExpr to_drop expr) co -- Just float in past coercion
146 fiExpr _ (_, AnnLit lit) = Lit lit
149 Applications: we do float inside applications, mainly because we
150 need to get at all the arguments. The next simplifier run will
151 pull out any silly ones.
154 fiExpr to_drop (_,AnnApp fun arg)
155 = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
157 [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
160 Note [Floating in past a lambda group]
161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
162 * We must be careful about floating inside inside a value lambda.
163 That risks losing laziness.
164 The float-out pass might rescue us, but then again it might not.
166 * We must be careful about type lambdas too. At one time we did, and
167 there is no risk of duplicating work thereby, but we do need to be
168 careful. In particular, here is a bad case (it happened in the
171 in let f = /\t -> \a -> ...
173 let f = /\t -> let v = ... in \a -> ...
174 This is bad as now f is an updatable closure (update PAP)
177 * Hack alert! We only float in through one-shot lambdas,
178 not (as you might guess) through lone big lambdas.
179 Reason: we float *out* past big lambdas (see the test in the Lam
180 case of FloatOut.floatExpr) and we don't want to float straight
183 It *is* important to float into one-shot lambdas, however;
184 see the remarks with noFloatIntoRhs.
186 So we treat lambda in groups, using the following rule:
188 Float in if (a) there is at least one Id,
189 and (b) there are no non-one-shot Ids
191 Otherwise drop all the bindings outside the group.
193 This is what the 'go' function in the AnnLam case is doing.
195 Urk! if all are tyvars, and we don't float in, we may miss an
196 opportunity to float inside a nested case branch
199 fiExpr to_drop lam@(_, AnnLam _ _)
200 | go False bndrs -- Float in
201 = mkLams bndrs (fiExpr to_drop body)
203 | otherwise -- Dump it all here
204 = mkCoLets' to_drop (mkLams bndrs (fiExpr [] body))
207 (bndrs, body) = collectAnnBndrs lam
209 go seen_one_shot_id [] = seen_one_shot_id
210 go seen_one_shot_id (b:bs)
211 | isTyVar b = go seen_one_shot_id bs
212 | isOneShotBndr b = go True bs
213 | otherwise = False -- Give up at a non-one-shot Id
216 We don't float lets inwards past an SCC.
217 ToDo: keep info on current cc, and when passing
218 one, if it is not the same, annotate all lets in binds with current
219 cc, change current cc to the new one and float binds into expr.
222 fiExpr to_drop (_, AnnNote note@(SCC _) expr)
223 = -- Wimp out for now
224 mkCoLets' to_drop (Note note (fiExpr [] expr))
226 fiExpr to_drop (_, AnnNote InlineMe expr)
227 = -- Ditto... don't float anything into an INLINE expression
228 mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
230 fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
231 = Note note (fiExpr to_drop expr)
234 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
235 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
236 or~(b2), in each of the RHSs of the pairs of a @Rec@.
238 Note that we do {\em weird things} with this let's binding. Consider:
247 Look at the inner \tr{let}. As \tr{w} is used in both the bind and
248 body of the inner let, we could panic and leave \tr{w}'s binding where
249 it is. But \tr{v} is floatable further into the body of the inner let, and
250 {\em then} \tr{w} will also be only in the body of that inner let.
252 So: rather than drop \tr{w}'s binding here, we add it onto the list of
253 things to drop in the outer let's body, and let nature take its
256 Note [extra_fvs (1): avoid floating into RHS]
257 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
258 Consdider let x=\y....t... in body. We do not necessarily want to float
259 a binding for t into the RHS, because it'll immediately be floated out
260 again. (It won't go inside the lambda else we risk losing work.)
261 In letrec, we need to be more careful still. We don't want to transform
264 letrec f = \z. ...x#...f...
267 letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
268 because now we can't float the let out again, because a letrec
269 can't have unboxed bindings.
271 So we make "extra_fvs" which is the rhs_fvs of such bindings, and
272 arrange to dump bindings that bind extra_fvs before the entire let.
274 Note [extra_fvs (s): free variables of rules]
275 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
276 Consider let x{rule mentioning y} = rhs in body
277 Here y is not free in rhs or body; but we still want to dump bindings
278 that bind y outside the let. So we augment extra_fvs with the
283 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
284 = fiExpr new_to_drop body
286 body_fvs = freeVarsOf body
288 rule_fvs = idRuleVars id -- See Note [extra_fvs (2): free variables of rules]
289 extra_fvs | noFloatIntoRhs ann_rhs
290 || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs
291 | otherwise = rule_fvs
292 -- See Note [extra_fvs (2): avoid floating into RHS]
293 -- No point in floating in only to float straight out again
294 -- Ditto ok-for-speculation unlifted RHSs
296 [shared_binds, extra_binds, rhs_binds, body_binds]
297 = sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop
299 new_to_drop = body_binds ++ -- the bindings used only in the body
300 [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
301 extra_binds ++ -- bindings from extra_fvs
302 shared_binds -- the bindings used both in rhs and body
304 -- Push rhs_binds into the right hand side of the binding
305 rhs' = fiExpr rhs_binds rhs
306 rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds `unionVarSet` rule_fvs
307 -- Don't forget the rule_fvs; the binding mentions them!
309 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
310 = fiExpr new_to_drop body
312 (ids, rhss) = unzip bindings
313 rhss_fvs = map freeVarsOf rhss
314 body_fvs = freeVarsOf body
316 -- See Note [extra_fvs (1,2)]
317 rule_fvs = foldr (unionVarSet . idRuleVars) emptyVarSet ids
318 extra_fvs = rule_fvs `unionVarSet`
319 unionVarSets [ fvs | (fvs, rhs) <- rhss
320 , noFloatIntoRhs rhs ]
322 (shared_binds:extra_binds:body_binds:rhss_binds)
323 = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop
325 new_to_drop = body_binds ++ -- the bindings used only in the body
326 [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
327 -- The new binding itself
328 extra_binds ++ -- Note [extra_fvs (1,2)]
329 shared_binds -- Used in more than one place
331 rhs_fvs' = unionVarSets rhss_fvs `unionVarSet`
332 unionVarSets (map floatedBindsFVs rhss_binds) `unionVarSet`
333 rule_fvs -- Don't forget the rule variables!
335 -- Push rhs_binds into the right hand side of the binding
336 fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
337 -> [(Id, CoreExprWithFVs)]
340 fi_bind to_drops pairs
341 = [ (binder, fiExpr to_drop rhs)
342 | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
345 For @Case@, the possible ``drop points'' for the \tr{to_drop}
346 bindings are: (a)~inside the scrutinee, (b)~inside one of the
347 alternatives/default [default FVs always {\em first}!].
350 fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
351 = mkCoLets' drop_here1 $
352 mkCoLets' drop_here2 $
353 Case (fiExpr scrut_drops scrut) case_bndr ty
354 (zipWith fi_alt alts_drops_s alts)
356 -- Float into the scrut and alts-considered-together just like App
357 [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
359 -- Float into the alts with the is_case flag set
360 (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops
362 scrut_fvs = freeVarsOf scrut
363 alts_fvs = map alt_fvs alts
364 all_alts_fvs = unionVarSets alts_fvs
365 alt_fvs (_con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
366 -- Delete case_bndr and args from free vars of rhs
367 -- to get free vars of alt
369 fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
371 noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool
372 noFloatIntoRhs (AnnNote InlineMe _) = True
373 noFloatIntoRhs (AnnLam b _) = not (is_one_shot b)
374 -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
375 -- This makes a big difference for things like
376 -- f x# = let x = I# x#
377 -- in let j = \() -> ...x...
378 -- in if <condition> then normal-path else j ()
379 -- If x is used only in the error case join point, j, we must float the
380 -- boxing constructor into it, else we box it every time which is very bad
383 noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again...
385 is_one_shot :: Var -> Bool
386 is_one_shot b = isIdVar b && isOneShotBndr b
390 %************************************************************************
392 \subsection{@sepBindsByDropPoint@}
394 %************************************************************************
396 This is the crucial function. The idea is: We have a wad of bindings
397 that we'd like to distribute inside a collection of {\em drop points};
398 insides the alternatives of a \tr{case} would be one example of some
399 drop points; the RHS and body of a non-recursive \tr{let} binding
400 would be another (2-element) collection.
402 So: We're given a list of sets-of-free-variables, one per drop point,
403 and a list of floating-inwards bindings. If a binding can go into
404 only one drop point (without suddenly making something out-of-scope),
405 in it goes. If a binding is used inside {\em multiple} drop points,
406 then it has to go in a you-must-drop-it-above-all-these-drop-points
409 We have to maintain the order on these drop-point-related lists.
413 :: Bool -- True <=> is case expression
414 -> [FreeVarsSet] -- One set of FVs per drop point
415 -> FloatingBinds -- Candidate floaters
416 -> [FloatingBinds] -- FIRST one is bindings which must not be floated
417 -- inside any drop point; the rest correspond
418 -- one-to-one with the input list of FV sets
420 -- Every input floater is returned somewhere in the result;
421 -- none are dropped, not even ones which don't seem to be
422 -- free in *any* of the drop-point fvs. Why? Because, for example,
423 -- a binding (let x = E in B) might have a specialised version of
424 -- x (say x') stored inside x, but x' isn't free in E or B.
426 type DropBox = (FreeVarsSet, FloatingBinds)
428 sepBindsByDropPoint _is_case drop_pts []
429 = [] : [[] | _ <- drop_pts] -- cut to the chase scene; it happens
431 sepBindsByDropPoint is_case drop_pts floaters
432 = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
434 go :: FloatingBinds -> [DropBox] -> [FloatingBinds]
435 -- The *first* one in the argument list is the drop_here set
436 -- The FloatingBinds in the lists are in the reverse of
437 -- the normal FloatingBinds order; that is, they are the right way round!
439 go [] drop_boxes = map (reverse . snd) drop_boxes
441 go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes)
444 -- "here" means the group of bindings dropped at the top of the fork
446 (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
447 | (fvs, _) <- drop_boxes]
449 drop_here = used_here || not can_push
451 -- For case expressions we duplicate the binding if it is
452 -- reasonably small, and if it is not used in all the RHSs
453 -- This is good for situations like
458 -- E -> ...not mentioning x...
460 n_alts = length used_in_flags
461 n_used_alts = count id used_in_flags -- returns number of Trues in list.
463 can_push = n_used_alts == 1 -- Used in just one branch
464 || (is_case && -- We are looking at case alternatives
465 n_used_alts > 1 && -- It's used in more than one
466 n_used_alts < n_alts && -- ...but not all
467 bindIsDupable bind) -- and we can duplicate the binding
469 new_boxes | drop_here = (insert here_box : fork_boxes)
470 | otherwise = (here_box : new_fork_boxes)
472 new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags
474 insert :: DropBox -> DropBox
475 insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops)
477 insert_maybe box True = insert box
478 insert_maybe box False = box
480 go _ _ = panic "sepBindsByDropPoint/go"
483 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
484 floatedBindsFVs binds = unionVarSets (map snd binds)
486 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
487 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
488 -- Remember to_drop is in *reverse* dependency order
490 bindIsDupable :: Bind CoreBndr -> Bool
491 bindIsDupable (Rec prs) = all (exprIsDupable . snd) prs
492 bindIsDupable (NonRec _ r) = exprIsDupable r