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.
16 -- The above warning supression flag is a temporary kludge.
17 -- While working on this module you are encouraged to remove it and fix
18 -- any warnings in the module. See
19 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
22 module FloatIn ( floatInwards ) where
24 #include "HsVersions.h"
26 import DynFlags ( DynFlags, DynFlag(..) )
28 import CoreUtils ( exprIsHNF, exprIsDupable )
29 import CoreLint ( showPass, endPass )
30 import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars )
31 import Id ( isOneShotBndr )
32 import Var ( Id, idType )
33 import Type ( isUnLiftedType )
35 import Util ( zipEqual, zipWithEqual, count )
39 Top-level interface function, @floatInwards@. Note that we do not
40 actually float any bindings downwards from the top-level.
43 floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
45 floatInwards dflags binds
47 showPass dflags "Float inwards";
48 let { binds' = map fi_top_bind binds };
49 endPass dflags "Float inwards" Opt_D_verbose_core2core binds'
50 {- no specific flag for dumping float-in -}
54 fi_top_bind (NonRec binder rhs)
55 = NonRec binder (fiExpr [] (freeVars rhs))
56 fi_top_bind (Rec pairs)
57 = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
60 %************************************************************************
62 \subsection{Mail from Andr\'e [edited]}
64 %************************************************************************
66 {\em Will wrote: What??? I thought the idea was to float as far
67 inwards as possible, no matter what. This is dropping all bindings
68 every time it sees a lambda of any kind. Help! }
70 You are assuming we DO DO full laziness AFTER floating inwards! We
71 have to [not float inside lambdas] if we don't.
73 If we indeed do full laziness after the floating inwards (we could
74 check the compilation flags for that) then I agree we could be more
75 aggressive and do float inwards past lambdas.
77 Actually we are not doing a proper full laziness (see below), which
78 was another reason for not floating inwards past a lambda.
80 This can easily be fixed. The problem is that we float lets outwards,
81 but there are a few expressions which are not let bound, like case
82 scrutinees and case alternatives. After floating inwards the
83 simplifier could decide to inline the let and the laziness would be
87 let a = expensive ==> \b -> case expensive of ...
88 in \ b -> case a of ...
93 to let bind the algebraic case scrutinees (done, I think) and
94 the case alternatives (except the ones with an
95 unboxed type)(not done, I think). This is best done in the
96 SetLevels.lhs module, which tags things with their level numbers.
98 do the full laziness pass (floating lets outwards).
100 simplify. The simplifier inlines the (trivial) lets that were
101 created but were not floated outwards.
104 With the fix I think Will's suggestion that we can gain even more from
105 strictness by floating inwards past lambdas makes sense.
107 We still gain even without going past lambdas, as things may be
108 strict in the (new) context of a branch (where it was floated to) or
111 let a = something case x of
112 in case x of alt1 -> case something of a -> a + a
113 alt1 -> a + a ==> alt2 -> b
116 let a = something let b = case something of a -> a + a
117 in let b = a + a ==> in (b,b)
120 Also, even if a is not found to be strict in the new context and is
121 still left as a let, if the branch is not taken (or b is not entered)
122 the closure for a is not built.
124 %************************************************************************
126 \subsection{Main floating-inwards code}
128 %************************************************************************
131 type FreeVarsSet = IdSet
133 type FloatingBinds = [(CoreBind, FreeVarsSet)]
134 -- In reverse dependency order (innermost binder first)
136 -- The FreeVarsSet is the free variables of the binding. In the case
137 -- of recursive bindings, the set doesn't include the bound
140 fiExpr :: FloatingBinds -- Binds we're trying to drop
141 -- as far "inwards" as possible
142 -> CoreExprWithFVs -- Input expr
143 -> CoreExpr -- Result
145 fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
147 fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
149 fiExpr to_drop (_, AnnCast expr co)
150 = Cast (fiExpr to_drop expr) co -- Just float in past coercion
152 fiExpr to_drop (_, AnnLit lit) = Lit lit
155 Applications: we do float inside applications, mainly because we
156 need to get at all the arguments. The next simplifier run will
157 pull out any silly ones.
160 fiExpr to_drop (_,AnnApp fun arg)
161 = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
163 [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
166 We are careful about lambdas:
168 * We must be careful about floating inside inside a value lambda.
169 That risks losing laziness.
170 The float-out pass might rescue us, but then again it might not.
172 * We must be careful about type lambdas too. At one time we did, and
173 there is no risk of duplicating work thereby, but we do need to be
174 careful. In particular, here is a bad case (it happened in the
177 in let f = /\t -> \a -> ...
179 let f = /\t -> let v = ... in \a -> ...
180 This is bad as now f is an updatable closure (update PAP)
183 So we treat lambda in groups, using the following rule:
185 Float inside a group of lambdas only if
186 they are all either type lambdas or one-shot lambdas.
188 Otherwise drop all the bindings outside the group.
191 -- Hack alert! We only float in through one-shot lambdas,
192 -- not (as you might guess) through big lambdas.
193 -- Reason: we float *out* past big lambdas (see the test in the Lam
194 -- case of FloatOut.floatExpr) and we don't want to float straight
197 -- It *is* important to float into one-shot lambdas, however;
198 -- see the remarks with noFloatIntoRhs.
199 fiExpr to_drop lam@(_, AnnLam _ _)
200 | all is_one_shot 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
210 We don't float lets inwards past an SCC.
211 ToDo: keep info on current cc, and when passing
212 one, if it is not the same, annotate all lets in binds with current
213 cc, change current cc to the new one and float binds into expr.
216 fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
217 = -- Wimp out for now
218 mkCoLets' to_drop (Note note (fiExpr [] expr))
220 fiExpr to_drop (_, AnnNote InlineMe expr)
221 = -- Ditto... don't float anything into an INLINE expression
222 mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
224 fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
225 = Note note (fiExpr to_drop expr)
228 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
229 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
230 or~(b2), in each of the RHSs of the pairs of a @Rec@.
232 Note that we do {\em weird things} with this let's binding. Consider:
241 Look at the inner \tr{let}. As \tr{w} is used in both the bind and
242 body of the inner let, we could panic and leave \tr{w}'s binding where
243 it is. But \tr{v} is floatable further into the body of the inner let, and
244 {\em then} \tr{w} will also be only in the body of that inner let.
246 So: rather than drop \tr{w}'s binding here, we add it onto the list of
247 things to drop in the outer let's body, and let nature take its
250 Note [extra_fvs (1): avoid floating into RHS]
251 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
252 Consdider let x=\y....t... in body. We do not necessarily want to float
253 a binding for t into the RHS, because it'll immediately be floated out
254 again. (It won't go inside the lambda else we risk losing work.)
255 In letrec, we need to be more careful still. We don't want to transform
258 letrec f = \z. ...x#...f...
261 letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
262 because now we can't float the let out again, because a letrec
263 can't have unboxed bindings.
265 So we make "extra_fvs" which is the rhs_fvs of such bindings, and
266 arrange to dump bindings that bind extra_fvs before the entire let.
268 Note [extra_fvs (s): free variables of rules]
269 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
270 Consider let x{rule mentioning y} = rhs in body
271 Here y is not free in rhs or body; but we still want to dump bindings
272 that bind y outside the let. So we augment extra_fvs with the
277 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
278 = fiExpr new_to_drop body
280 body_fvs = freeVarsOf body
282 rule_fvs = idRuleVars id -- See Note [extra_fvs (2): free variables of rules]
283 extra_fvs | noFloatIntoRhs ann_rhs
284 || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs
285 | otherwise = rule_fvs
286 -- See Note [extra_fvs (2): avoid floating into RHS]
287 -- No point in floating in only to float straight out again
288 -- Ditto ok-for-speculation unlifted RHSs
290 [shared_binds, extra_binds, rhs_binds, body_binds]
291 = sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop
293 new_to_drop = body_binds ++ -- the bindings used only in the body
294 [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
295 extra_binds ++ -- bindings from extra_fvs
296 shared_binds -- the bindings used both in rhs and body
298 -- Push rhs_binds into the right hand side of the binding
299 rhs' = fiExpr rhs_binds rhs
300 rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds
302 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
303 = fiExpr new_to_drop body
305 rhss = map snd bindings
307 rhss_fvs = map freeVarsOf rhss
308 body_fvs = freeVarsOf body
310 -- See Note [extra_fvs (1,2)]
311 extra_fvs = foldr (unionVarSet . get_extras) emptyVarSet bindings
312 get_extras (id, (rhs_fvs, rhs))
313 | noFloatIntoRhs rhs = idRuleVars id `unionVarSet` rhs_fvs
314 | otherwise = idRuleVars id
316 (shared_binds:extra_binds:body_binds:rhss_binds)
317 = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop
319 new_to_drop = body_binds ++ -- the bindings used only in the body
320 [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
321 -- The new binding itself
322 extra_binds ++ -- Note [extra_fvs (1,2)]
323 shared_binds -- Used in more than one place
325 rhs_fvs' = unionVarSet (unionVarSets rhss_fvs)
326 (unionVarSets (map floatedBindsFVs rhss_binds))
328 -- Push rhs_binds into the right hand side of the binding
329 fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
330 -> [(Id, CoreExprWithFVs)]
333 fi_bind to_drops pairs
334 = [ (binder, fiExpr to_drop rhs)
335 | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
338 For @Case@, the possible ``drop points'' for the \tr{to_drop}
339 bindings are: (a)~inside the scrutinee, (b)~inside one of the
340 alternatives/default [default FVs always {\em first}!].
343 fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
344 = mkCoLets' drop_here1 $
345 mkCoLets' drop_here2 $
346 Case (fiExpr scrut_drops scrut) case_bndr ty
347 (zipWith fi_alt alts_drops_s alts)
349 -- Float into the scrut and alts-considered-together just like App
350 [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
352 -- Float into the alts with the is_case flag set
353 (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops
355 scrut_fvs = freeVarsOf scrut
356 alts_fvs = map alt_fvs alts
357 all_alts_fvs = unionVarSets alts_fvs
358 alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
359 -- Delete case_bndr and args from free vars of rhs
360 -- to get free vars of alt
362 fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
364 noFloatIntoRhs (AnnNote InlineMe _) = True
365 noFloatIntoRhs (AnnLam b _) = not (is_one_shot b)
366 -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
367 -- This makes a big difference for things like
368 -- f x# = let x = I# x#
369 -- in let j = \() -> ...x...
370 -- in if <condition> then normal-path else j ()
371 -- If x is used only in the error case join point, j, we must float the
372 -- boxing constructor into it, else we box it every time which is very bad
375 noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again...
377 is_one_shot b = isId b && isOneShotBndr b
381 %************************************************************************
383 \subsection{@sepBindsByDropPoint@}
385 %************************************************************************
387 This is the crucial function. The idea is: We have a wad of bindings
388 that we'd like to distribute inside a collection of {\em drop points};
389 insides the alternatives of a \tr{case} would be one example of some
390 drop points; the RHS and body of a non-recursive \tr{let} binding
391 would be another (2-element) collection.
393 So: We're given a list of sets-of-free-variables, one per drop point,
394 and a list of floating-inwards bindings. If a binding can go into
395 only one drop point (without suddenly making something out-of-scope),
396 in it goes. If a binding is used inside {\em multiple} drop points,
397 then it has to go in a you-must-drop-it-above-all-these-drop-points
400 We have to maintain the order on these drop-point-related lists.
404 :: Bool -- True <=> is case expression
405 -> [FreeVarsSet] -- One set of FVs per drop point
406 -> FloatingBinds -- Candidate floaters
407 -> [FloatingBinds] -- FIRST one is bindings which must not be floated
408 -- inside any drop point; the rest correspond
409 -- one-to-one with the input list of FV sets
411 -- Every input floater is returned somewhere in the result;
412 -- none are dropped, not even ones which don't seem to be
413 -- free in *any* of the drop-point fvs. Why? Because, for example,
414 -- a binding (let x = E in B) might have a specialised version of
415 -- x (say x') stored inside x, but x' isn't free in E or B.
417 type DropBox = (FreeVarsSet, FloatingBinds)
419 sepBindsByDropPoint is_case drop_pts []
420 = [] : [[] | p <- drop_pts] -- cut to the chase scene; it happens
422 sepBindsByDropPoint is_case drop_pts floaters
423 = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
425 go :: FloatingBinds -> [DropBox] -> [FloatingBinds]
426 -- The *first* one in the argument list is the drop_here set
427 -- The FloatingBinds in the lists are in the reverse of
428 -- the normal FloatingBinds order; that is, they are the right way round!
430 go [] drop_boxes = map (reverse . snd) drop_boxes
432 go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes)
435 -- "here" means the group of bindings dropped at the top of the fork
437 (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
438 | (fvs, drops) <- drop_boxes]
440 drop_here = used_here || not can_push
442 -- For case expressions we duplicate the binding if it is
443 -- reasonably small, and if it is not used in all the RHSs
444 -- This is good for situations like
449 -- E -> ...not mentioning x...
451 n_alts = length used_in_flags
452 n_used_alts = count id used_in_flags -- returns number of Trues in list.
454 can_push = n_used_alts == 1 -- Used in just one branch
455 || (is_case && -- We are looking at case alternatives
456 n_used_alts > 1 && -- It's used in more than one
457 n_used_alts < n_alts && -- ...but not all
458 bindIsDupable bind) -- and we can duplicate the binding
460 new_boxes | drop_here = (insert here_box : fork_boxes)
461 | otherwise = (here_box : new_fork_boxes)
463 new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags
465 insert :: DropBox -> DropBox
466 insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops)
468 insert_maybe box True = insert box
469 insert_maybe box False = box
472 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
473 floatedBindsFVs binds = unionVarSets (map snd binds)
475 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
476 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
477 -- Remember to_drop is in *reverse* dependency order
479 bindIsDupable (Rec prs) = all (exprIsDupable . snd) prs
480 bindIsDupable (NonRec b r) = exprIsDupable r