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 CmdLineOpts ( DynFlags, DynFlag(..), dopt )
21 import CoreUtils ( exprIsValue, exprIsDupable )
22 import CoreLint ( beginPass, endPass )
23 import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf )
24 import Id ( isOneShotLambda )
25 import Var ( Id, idType, isTyVar )
26 import Type ( isUnLiftedType )
28 import Util ( zipEqual, zipWithEqual )
32 Top-level interface function, @floatInwards@. Note that we do not
33 actually float any bindings downwards from the top-level.
36 floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
38 floatInwards dflags binds
40 beginPass dflags "Float inwards";
41 let { binds' = map fi_top_bind binds };
42 endPass dflags "Float inwards"
43 (dopt Opt_D_verbose_core2core dflags)
44 {- no specific flag for dumping float-in -}
49 fi_top_bind (NonRec binder rhs)
50 = NonRec binder (fiExpr [] (freeVars rhs))
51 fi_top_bind (Rec pairs)
52 = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
55 %************************************************************************
57 \subsection{Mail from Andr\'e [edited]}
59 %************************************************************************
61 {\em Will wrote: What??? I thought the idea was to float as far
62 inwards as possible, no matter what. This is dropping all bindings
63 every time it sees a lambda of any kind. Help! }
65 You are assuming we DO DO full laziness AFTER floating inwards! We
66 have to [not float inside lambdas] if we don't.
68 If we indeed do full laziness after the floating inwards (we could
69 check the compilation flags for that) then I agree we could be more
70 aggressive and do float inwards past lambdas.
72 Actually we are not doing a proper full laziness (see below), which
73 was another reason for not floating inwards past a lambda.
75 This can easily be fixed. The problem is that we float lets outwards,
76 but there are a few expressions which are not let bound, like case
77 scrutinees and case alternatives. After floating inwards the
78 simplifier could decide to inline the let and the laziness would be
82 let a = expensive ==> \b -> case expensive of ...
83 in \ b -> case a of ...
88 to let bind the algebraic case scrutinees (done, I think) and
89 the case alternatives (except the ones with an
90 unboxed type)(not done, I think). This is best done in the
91 SetLevels.lhs module, which tags things with their level numbers.
93 do the full laziness pass (floating lets outwards).
95 simplify. The simplifier inlines the (trivial) lets that were
96 created but were not floated outwards.
99 With the fix I think Will's suggestion that we can gain even more from
100 strictness by floating inwards past lambdas makes sense.
102 We still gain even without going past lambdas, as things may be
103 strict in the (new) context of a branch (where it was floated to) or
106 let a = something case x of
107 in case x of alt1 -> case something of a -> a + a
108 alt1 -> a + a ==> alt2 -> b
111 let a = something let b = case something of a -> a + a
112 in let b = a + a ==> in (b,b)
115 Also, even if a is not found to be strict in the new context and is
116 still left as a let, if the branch is not taken (or b is not entered)
117 the closure for a is not built.
119 %************************************************************************
121 \subsection{Main floating-inwards code}
123 %************************************************************************
126 type FreeVarsSet = IdSet
128 type FloatingBinds = [(CoreBind, FreeVarsSet)]
129 -- In reverse dependency order (innermost bindiner first)
131 -- The FreeVarsSet is the free variables of the binding. In the case
132 -- of recursive bindings, the set doesn't include the bound
135 fiExpr :: FloatingBinds -- Binds we're trying to drop
136 -- as far "inwards" as possible
137 -> CoreExprWithFVs -- Input expr
138 -> CoreExpr -- Result
140 fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
142 fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
145 fiExpr to_drop (_, AnnLit lit) = Lit lit
148 Applications: we do float inside applications, mainly because we
149 need to get at all the arguments. The next simplifier run will
150 pull out any silly ones.
153 fiExpr to_drop (_,AnnApp fun arg)
154 = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
156 [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
159 We are careful about lambdas:
161 * We must be careful about floating inside inside a value lambda.
162 That risks losing laziness.
163 The float-out pass might rescue us, but then again it might not.
165 * We must be careful about type lambdas too. At one time we did, and
166 there is no risk of duplicating work thereby, but we do need to be
167 careful. In particular, here is a bad case (it happened in the
170 in let f = /\t -> \a -> ...
172 let f = /\t -> let v = ... in \a -> ...
173 This is bad as now f is an updatable closure (update PAP)
176 So we treat lambda in groups, using the following rule:
178 Float inside a group of lambdas only if
179 they are all either type lambdas or one-shot lambdas.
181 Otherwise drop all the bindings outside the group.
184 fiExpr to_drop (_, AnnLam b body)
185 = case collect [b] body of
187 | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
188 | otherwise -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body))
190 collect bs (_, AnnLam b body) = collect (b:bs) body
191 collect bs body = (reverse bs, body)
193 is_ok bndr = isTyVar bndr || isOneShotLambda bndr
196 We don't float lets inwards past an SCC.
197 ToDo: keep info on current cc, and when passing
198 one, if it is not the same, annotate all lets in binds with current
199 cc, change current cc to the new one and float binds into expr.
202 fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
203 = -- Wimp out for now
204 mkCoLets' to_drop (Note note (fiExpr [] expr))
206 fiExpr to_drop (_, AnnNote InlineCall expr)
207 = -- Wimp out for InlineCall; keep it close
208 -- the the call it annotates
209 mkCoLets' to_drop (Note InlineCall (fiExpr [] expr))
211 fiExpr to_drop (_, AnnNote InlineMe expr)
212 = -- Ditto... don't float anything into an INLINE expression
213 mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
215 fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
216 = -- Just float in past coercion
217 Note note (fiExpr to_drop expr)
220 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
221 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
222 or~(b2), in each of the RHSs of the pairs of a @Rec@.
224 Note that we do {\em weird things} with this let's binding. Consider:
233 Look at the inner \tr{let}. As \tr{w} is used in both the bind and
234 body of the inner let, we could panic and leave \tr{w}'s binding where
235 it is. But \tr{v} is floatable further into the body of the inner let, and
236 {\em then} \tr{w} will also be only in the body of that inner let.
238 So: rather than drop \tr{w}'s binding here, we add it onto the list of
239 things to drop in the outer let's body, and let nature take its
243 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
244 = fiExpr new_to_drop body
246 body_fvs = freeVarsOf body
248 final_body_fvs | noFloatIntoRhs ann_rhs
249 || isUnLiftedType (idType id) = body_fvs `unionVarSet` rhs_fvs
250 | otherwise = body_fvs
251 -- See commments with letrec below
252 -- No point in floating in only to float straight out again
253 -- Ditto ok-for-speculation unlifted RHSs
255 [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint False [rhs_fvs, final_body_fvs] to_drop
257 new_to_drop = body_binds ++ -- the bindings used only in the body
258 [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
259 shared_binds -- the bindings used both in rhs and body
261 -- Push rhs_binds into the right hand side of the binding
262 rhs' = fiExpr rhs_binds rhs
263 rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds
265 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
266 = fiExpr new_to_drop body
268 rhss = map snd bindings
270 rhss_fvs = map freeVarsOf rhss
271 body_fvs = freeVarsOf body
273 -- Add to body_fvs the free vars of any RHS that has
274 -- a lambda at the top. This has the effect of making it seem
275 -- that such things are used in the body as well, and hence prevents
276 -- them getting floated in. The big idea is to avoid turning:
279 -- letrec f = \z. ...x#...f...
282 -- letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
284 -- Because now we can't float the let out again, because a letrec
285 -- can't have unboxed bindings.
287 final_body_fvs = foldr (unionVarSet . get_extras) body_fvs rhss
288 get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs
289 | otherwise = emptyVarSet
291 (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint False (final_body_fvs:rhss_fvs) to_drop
293 new_to_drop = -- the bindings used only in the body
295 -- the new binding itself
296 [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
297 -- the bindings used both in rhs and body or in more than one rhs
300 rhs_fvs' = unionVarSet (unionVarSets rhss_fvs)
301 (unionVarSets (map floatedBindsFVs rhss_binds))
303 -- Push rhs_binds into the right hand side of the binding
304 fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
305 -> [(Id, CoreExprWithFVs)]
308 fi_bind to_drops pairs
309 = [ (binder, fiExpr to_drop rhs)
310 | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
313 For @Case@, the possible ``drop points'' for the \tr{to_drop}
314 bindings are: (a)~inside the scrutinee, (b)~inside one of the
315 alternatives/default [default FVs always {\em first}!].
318 fiExpr to_drop (_, AnnCase scrut case_bndr alts)
319 = mkCoLets' drop_here1 $
320 mkCoLets' drop_here2 $
321 Case (fiExpr scrut_drops scrut) case_bndr
322 (zipWith fi_alt alts_drops_s alts)
324 -- Float into the scrut and alts-considered-together just like App
325 [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
327 -- Float into the alts with the is_case flag set
328 (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops
330 scrut_fvs = freeVarsOf scrut
331 alts_fvs = map alt_fvs alts
332 all_alts_fvs = unionVarSets alts_fvs
333 alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
334 -- Delete case_bndr and args from free vars of rhs
335 -- to get free vars of alt
337 fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
339 noFloatIntoRhs (AnnNote InlineMe _) = True
340 noFloatIntoRhs (AnnLam b _) = not (isId b && isOneShotLambda b)
341 -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
342 -- This makes a big difference for things like
343 -- f x# = let x = I# x#
344 -- in let j = \() -> ...x...
345 -- in if <condition> then normal-path else j ()
346 -- If x is used only in the error case join point, j, we must float the
347 -- boxing constructor into it, else we box it every time which is very bad
350 noFloatIntoRhs rhs = exprIsValue (deAnnotate' rhs) -- We'd just float rigt back out again...
354 %************************************************************************
356 \subsection{@sepBindsByDropPoint@}
358 %************************************************************************
360 This is the crucial function. The idea is: We have a wad of bindings
361 that we'd like to distribute inside a collection of {\em drop points};
362 insides the alternatives of a \tr{case} would be one example of some
363 drop points; the RHS and body of a non-recursive \tr{let} binding
364 would be another (2-element) collection.
366 So: We're given a list of sets-of-free-variables, one per drop point,
367 and a list of floating-inwards bindings. If a binding can go into
368 only one drop point (without suddenly making something out-of-scope),
369 in it goes. If a binding is used inside {\em multiple} drop points,
370 then it has to go in a you-must-drop-it-above-all-these-drop-points
373 We have to maintain the order on these drop-point-related lists.
377 :: Bool -- True <=> is case expression
378 -> [FreeVarsSet] -- One set of FVs per drop point
379 -> FloatingBinds -- Candidate floaters
380 -> [FloatingBinds] -- FIRST one is bindings which must not be floated
381 -- inside any drop point; the rest correspond
382 -- one-to-one with the input list of FV sets
384 -- Every input floater is returned somewhere in the result;
385 -- none are dropped, not even ones which don't seem to be
386 -- free in *any* of the drop-point fvs. Why? Because, for example,
387 -- a binding (let x = E in B) might have a specialised version of
388 -- x (say x') stored inside x, but x' isn't free in E or B.
390 type DropBox = (FreeVarsSet, FloatingBinds)
392 sepBindsByDropPoint is_case drop_pts []
393 = [] : [[] | p <- drop_pts] -- cut to the chase scene; it happens
395 sepBindsByDropPoint is_case drop_pts floaters
396 = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
398 go :: FloatingBinds -> [DropBox] -> [FloatingBinds]
399 -- The *first* one in the argument list is the drop_here set
400 -- The FloatingBinds in the lists are in the reverse of
401 -- the normal FloatingBinds order; that is, they are the right way round!
403 go [] drop_boxes = map (reverse . snd) drop_boxes
405 go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes)
408 -- "here" means the group of bindings dropped at the top of the fork
410 (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
411 | (fvs, drops) <- drop_boxes]
413 drop_here = used_here || not can_push
415 -- For case expressions we duplicate the binding if it is
416 -- reasonably small, and if it is not used in all the RHSs
417 -- This is good for situations like
422 -- E -> ...not mentioning x...
424 n_alts = length used_in_flags
425 n_used_alts = length [() | True <- used_in_flags]
427 can_push = n_used_alts == 1 -- Used in just one branch
428 || (is_case && -- We are looking at case alternatives
429 n_used_alts > 1 && -- It's used in more than one
430 n_used_alts < n_alts && -- ...but not all
431 bindIsDupable bind) -- and we can duplicate the binding
433 new_boxes | drop_here = (insert here_box : fork_boxes)
434 | otherwise = (here_box : new_fork_boxes)
436 new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags
438 insert :: DropBox -> DropBox
439 insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops)
441 insert_maybe box True = insert box
442 insert_maybe box False = box
445 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
446 floatedBindsFVs binds = unionVarSets (map snd binds)
448 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
449 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
450 -- Remember to_drop is in *reverse* dependency order
452 bindIsDupable (Rec prs) = all (exprIsDupable . snd) prs
453 bindIsDupable (NonRec b r) = exprIsDupable r