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 ( opt_D_verbose_core2core )
21 import CoreLint ( beginPass, endPass )
22 import Const ( isDataCon )
23 import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf )
24 import Id ( isOneShotLambda )
25 import Var ( Id, idType, isTyVar )
26 import Type ( isUnLiftedType )
28 import Util ( zipEqual )
32 Top-level interface function, @floatInwards@. Note that we do not
33 actually float any bindings downwards from the top-level.
36 floatInwards :: [CoreBind] -> IO [CoreBind]
40 beginPass "Float inwards";
41 let { binds' = map fi_top_bind binds };
42 endPass "Float inwards"
43 opt_D_verbose_core2core {- 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 bindiner 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 )
144 fiExpr to_drop (_, AnnCon c args)
145 | isDataCon c -- Don't float into the args of a data construtor;
146 -- the simplifier will float straight back out
147 = mkCoLets' to_drop (Con c (map (fiExpr []) args))
150 = mkCoLets' drop_here (Con c args')
152 (drop_here : arg_drops) = sepBindsByDropPoint (map freeVarsOf args) to_drop
153 args' = zipWith fiExpr arg_drops args
156 Applications: we do float inside applications, mainly because we
157 need to get at all the arguments. The next simplifier run will
158 pull out any silly ones.
161 fiExpr to_drop (_,AnnApp fun arg)
162 = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
164 [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint [freeVarsOf fun, freeVarsOf arg] to_drop
167 We are careful about lambdas:
169 * We must be careful about floating inside inside a value lambda.
170 That risks losing laziness.
171 The float-out pass might rescue us, but then again it might not.
173 * We must be careful about type lambdas too. At one time we did, and
174 there is no risk of duplicating work thereby, but we do need to be
175 careful. In particular, here is a bad case (it happened in the
178 in let f = /\t -> \a -> ...
180 let f = /\t -> let v = ... in \a -> ...
181 This is bad as now f is an updatable closure (update PAP)
184 So we treat lambda in groups, using the following rule:
186 Float inside a group of lambdas only if
187 they are all either type lambdas or one-shot lambdas.
189 Otherwise drop all the bindings outside the group.
192 fiExpr to_drop (_, AnnLam b body)
193 = case collect [b] body of
195 | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
196 | otherwise -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body))
198 collect bs (_, AnnLam b body) = collect (b:bs) body
199 collect bs body = (reverse bs, body)
201 is_ok bndr = isTyVar bndr || isOneShotLambda bndr
204 We don't float lets inwards past an SCC.
205 ToDo: keep info on current cc, and when passing
206 one, if it is not the same, annotate all lets in binds with current
207 cc, change current cc to the new one and float binds into expr.
210 fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
211 = -- Wimp out for now
212 mkCoLets' to_drop (Note note (fiExpr [] expr))
214 fiExpr to_drop (_, AnnNote InlineCall expr)
215 = -- Wimp out for InlineCall; keep it close
216 -- the the call it annotates
217 mkCoLets' to_drop (Note InlineCall (fiExpr [] expr))
219 fiExpr to_drop (_, AnnNote InlineMe expr)
220 = -- Ditto... don't float anything into an INLINE expression
221 mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
223 fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
224 = -- Just float in past coercion
225 Note note (fiExpr to_drop expr)
227 fiExpr to_drop (_, AnnNote note@(TermUsg _) expr)
228 = -- Float in past term usage annotation
229 -- (for now; not sure if this is correct: KSW 1999-05)
230 Note note (fiExpr to_drop expr)
233 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
234 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
235 or~(b2), in each of the RHSs of the pairs of a @Rec@.
237 Note that we do {\em weird things} with this let's binding. Consider:
246 Look at the inner \tr{let}. As \tr{w} is used in both the bind and
247 body of the inner let, we could panic and leave \tr{w}'s binding where
248 it is. But \tr{v} is floatable further into the body of the inner let, and
249 {\em then} \tr{w} will also be only in the body of that inner let.
251 So: rather than drop \tr{w}'s binding here, we add it onto the list of
252 things to drop in the outer let's body, and let nature take its
256 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
257 = fiExpr new_to_drop body
259 body_fvs = freeVarsOf body
261 final_body_fvs | noFloatIntoRhs ann_rhs
262 || isUnLiftedType (idType id) = body_fvs `unionVarSet` rhs_fvs
263 | otherwise = body_fvs
264 -- See commments with letrec below
265 -- No point in floating in only to float straight out again
266 -- Ditto ok-for-speculation unlifted RHSs
268 [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint [rhs_fvs, final_body_fvs] to_drop
270 new_to_drop = body_binds ++ -- the bindings used only in the body
271 [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
272 shared_binds -- the bindings used both in rhs and body
274 -- Push rhs_binds into the right hand side of the binding
275 rhs' = fiExpr rhs_binds rhs
276 rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds
278 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
279 = fiExpr new_to_drop body
281 (binders, rhss) = unzip bindings
283 rhss_fvs = map freeVarsOf rhss
284 body_fvs = freeVarsOf body
286 -- Add to body_fvs the free vars of any RHS that has
287 -- a lambda at the top. This has the effect of making it seem
288 -- that such things are used in the body as well, and hence prevents
289 -- them getting floated in. The big idea is to avoid turning:
292 -- letrec f = \z. ...x#...f...
295 -- letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
297 -- Because now we can't float the let out again, because a letrec
298 -- can't have unboxed bindings.
300 final_body_fvs = foldr (unionVarSet . get_extras) body_fvs rhss
301 get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs
302 | otherwise = emptyVarSet
304 (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint (final_body_fvs:rhss_fvs) to_drop
306 new_to_drop = -- the bindings used only in the body
308 -- the new binding itself
309 [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
310 -- the bindings used both in rhs and body or in more than one rhs
313 rhs_fvs' = unionVarSet (unionVarSets rhss_fvs)
314 (unionVarSets (map floatedBindsFVs rhss_binds))
316 -- Push rhs_binds into the right hand side of the binding
317 fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
318 -> [(Id, CoreExprWithFVs)]
321 fi_bind to_drops pairs
322 = [ (binder, fiExpr to_drop rhs)
323 | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
326 For @Case@, the possible ``drop points'' for the \tr{to_drop}
327 bindings are: (a)~inside the scrutinee, (b)~inside one of the
328 alternatives/default [default FVs always {\em first}!].
331 fiExpr to_drop (_, AnnCase scrut case_bndr alts)
332 = mkCoLets' drop_here (Case (fiExpr scrut_drops scrut) case_bndr
333 (zipWith fi_alt alts_drops alts))
335 (drop_here : scrut_drops : alts_drops) = sepBindsByDropPoint (scrut_fvs : alts_fvs) to_drop
336 scrut_fvs = freeVarsOf scrut
337 alts_fvs = map alt_fvs alts
338 alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
339 -- Delete case_bndr and args from free vars of rhs
340 -- to get free vars of alt
342 fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
344 noFloatIntoRhs (AnnNote InlineMe _) = True
345 noFloatIntoRhs (AnnLam b _) = not (isId b && isOneShotLambda b)
346 -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
347 -- This makes a big difference for things like
348 -- f x# = let x = I# x#
349 -- in let j = \() -> ...x...
350 -- in if <condition> then normal-path else j ()
351 -- If x is used only in the error case join point, j, we must float the
352 -- boxing constructor into it, else we box it every time which is very bad
354 noFloatIntoRhs (AnnCon con _) = isDataCon con
355 noFloatIntoRhs other = False
359 %************************************************************************
361 \subsection{@sepBindsByDropPoint@}
363 %************************************************************************
365 This is the crucial function. The idea is: We have a wad of bindings
366 that we'd like to distribute inside a collection of {\em drop points};
367 insides the alternatives of a \tr{case} would be one example of some
368 drop points; the RHS and body of a non-recursive \tr{let} binding
369 would be another (2-element) collection.
371 So: We're given a list of sets-of-free-variables, one per drop point,
372 and a list of floating-inwards bindings. If a binding can go into
373 only one drop point (without suddenly making something out-of-scope),
374 in it goes. If a binding is used inside {\em multiple} drop points,
375 then it has to go in a you-must-drop-it-above-all-these-drop-points
378 We have to maintain the order on these drop-point-related lists.
382 :: [FreeVarsSet] -- One set of FVs per drop point
383 -> FloatingBinds -- Candidate floaters
384 -> [FloatingBinds] -- FIRST one is bindings which must not be floated
385 -- inside any drop point; the rest correspond
386 -- one-to-one with the input list of FV sets
388 -- Every input floater is returned somewhere in the result;
389 -- none are dropped, not even ones which don't seem to be
390 -- free in *any* of the drop-point fvs. Why? Because, for example,
391 -- a binding (let x = E in B) might have a specialised version of
392 -- x (say x') stored inside x, but x' isn't free in E or B.
394 sepBindsByDropPoint drop_pts []
395 = [] : [[] | p <- drop_pts] -- cut to the chase scene; it happens
397 sepBindsByDropPoint drop_pts floaters
398 = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
400 go :: FloatingBinds -> [(FreeVarsSet, FloatingBinds)] -> [FloatingBinds]
401 -- The *first* one in the argument list is the drop_here set
402 -- The FloatingBinds in the lists are in the reverse of
403 -- the normal FloatingBinds order; that is, they are the right way round!
405 go [] drop_boxes = map (reverse . snd) drop_boxes
407 go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes
408 = go binds (insert drop_boxes (drop_here : used_in_flags))
409 -- insert puts the find in box whose True flag comes first
411 (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
412 | (fvs, drops) <- drop_boxes]
414 drop_here = used_here || not (exactlyOneTrue used_in_flags)
416 insert ((fvs,drops) : drop_boxes) (True : _)
417 = ((fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) : drop_boxes)
418 insert (drop_box : drop_boxes) (False : others)
419 = drop_box : insert drop_boxes others
420 insert _ _ = panic "sepBindsByDropPoint" -- Should never happen
422 exactlyOneTrue :: [Bool] -> Bool
423 exactlyOneTrue flags = case [() | True <- flags] of
427 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
428 floatedBindsFVs binds = unionVarSets (map snd binds)
430 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
431 mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
432 -- Remember to_drop is in *reverse* dependency order