2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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"
23 import Id ( emptyIdSet, unionIdSets, unionManyIdSets,
24 elementOfIdSet, IdSet, GenId, Id
26 import Util ( nOfThem, panic, zipEqual )
29 Top-level interface function, @floatInwards@. Note that we do not
30 actually float any bindings downwards from the top-level.
33 floatInwards :: [CoreBinding] -> [CoreBinding]
36 = map fi_top_bind binds
38 fi_top_bind (NonRec binder rhs)
39 = NonRec binder (fiExpr [] (freeVars rhs))
40 fi_top_bind (Rec pairs)
41 = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
44 %************************************************************************
46 \subsection{Mail from Andr\'e [edited]}
48 %************************************************************************
50 {\em Will wrote: What??? I thought the idea was to float as far
51 inwards as possible, no matter what. This is dropping all bindings
52 every time it sees a lambda of any kind. Help! }
54 You are assuming we DO DO full laziness AFTER floating inwards! We
55 have to [not float inside lambdas] if we don't.
57 If we indeed do full laziness after the floating inwards (we could
58 check the compilation flags for that) then I agree we could be more
59 aggressive and do float inwards past lambdas.
61 Actually we are not doing a proper full laziness (see below), which
62 was another reason for not floating inwards past a lambda.
64 This can easily be fixed.
65 The problem is that we float lets outwards,
66 but there are a few expressions which are not
67 let bound, like case scrutinees and case alternatives.
68 After floating inwards the simplifier could decide to inline
69 the let and the laziness would be lost, e.g.
71 let a = expensive ==> \b -> case expensive of ...
72 in \ b -> case a of ...
77 to let bind the algebraic case scrutinees (done, I think) and
78 the case alternatives (except the ones with an
79 unboxed type)(not done, I think). This is best done in the
80 SetLevels.lhs module, which tags things with their level numbers.
82 do the full laziness pass (floating lets outwards).
84 simplify. The simplifier inlines the (trivial) lets that were
85 created but were not floated outwards.
88 With the fix I think Will's suggestion that we can gain even more from
89 strictness by floating inwards past lambdas makes sense.
91 We still gain even without going past lambdas, as things may be
92 strict in the (new) context of a branch (where it was floated to) or
95 let a = something case x of
96 in case x of alt1 -> case something of a -> a + a
97 alt1 -> a + a ==> alt2 -> b
100 let a = something let b = case something of a -> a + a
101 in let b = a + a ==> in (b,b)
104 Also, even if a is not found to be strict in the new context and is
105 still left as a let, if the branch is not taken (or b is not entered)
106 the closure for a is not built.
108 %************************************************************************
110 \subsection{Main floating-inwards code}
112 %************************************************************************
115 type FreeVarsSet = IdSet
117 type FloatingBinds = [(CoreBinding, FreeVarsSet)]
118 -- In dependency order (outermost first)
120 -- The FreeVarsSet is the free variables of the binding. In the case
121 -- of recursive bindings, the set doesn't include the bound
124 fiExpr :: FloatingBinds -- binds we're trying to drop
125 -- as far "inwards" as possible
126 -> CoreExprWithFVs -- input expr
127 -> CoreExpr -- result
129 fiExpr to_drop (_,AnnVar v) = mkCoLets' to_drop (Var v)
131 fiExpr to_drop (_,AnnLit k) = mkCoLets' to_drop (Lit k)
133 fiExpr to_drop (_,AnnCon c atoms)
134 = mkCoLets' to_drop (Con c atoms)
136 fiExpr to_drop (_,AnnPrim c atoms)
137 = mkCoLets' to_drop (Prim c atoms)
140 Here we are not floating inside lambda (type lambdas are OK):
142 fiExpr to_drop (_,AnnLam b@(ValBinder binder) body)
143 = mkCoLets' to_drop (Lam b (fiExpr [] body))
145 fiExpr to_drop (_,AnnLam b@(TyBinder tyvar) body)
147 -- we do not float into type lambdas if they are followed by
148 -- a whnf (actually we check for lambdas and constructors).
149 -- The reason is that a let binding will get stuck
150 -- in between the type lambda and the whnf and the simplifier
151 -- does not know how to pull it back out from a type lambda.
154 -- in let f = /\t -> \a -> ...
156 -- let f = /\t -> let v = ... in \a -> ...
157 -- which is bad as now f is an updatable closure (update PAP)
158 -- and has arity 0. This example comes from cichelli.
160 = mkCoLets' to_drop (Lam b (fiExpr [] body))
162 = Lam b (fiExpr to_drop body)
164 whnf :: CoreExprWithFVs -> Bool
166 whnf (_,AnnLit _) = True
167 whnf (_,AnnCon _ _) = True
168 whnf (_,AnnLam x e) = if isValBinder x then True else whnf e
169 whnf (_,AnnNote _ e) = whnf e
173 Applications: we could float inside applications, but it's probably
174 not worth it (a purely practical choice, hunch- [not experience-]
177 fiExpr to_drop (_,AnnApp fun arg)
179 = mkCoLets' to_drop (App (fiExpr [] fun) arg)
181 = App (fiExpr to_drop fun) arg
184 We don't float lets inwards past an SCC.
186 ToDo: SCC: {\em should}
189 fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
190 = -- Wimp out for now
191 -- ToDo: keep info on current cc, and when passing
192 -- one, if it is not the same, annotate all lets in binds with current
193 -- cc, change current cc to the new one and float binds into expr.
194 mkCoLets' to_drop (Note note (fiExpr [] expr))
196 fiExpr to_drop (_, AnnNote InlineCall expr)
197 = -- Wimp out for InlineCall; keep it close
198 -- the the call it annotates
199 mkCoLets' to_drop (Note InlineCall (fiExpr [] expr))
201 fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
202 = -- Just float in past coercion
203 Note note (fiExpr to_drop expr)
206 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
207 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
208 or~(b2), in each of the RHSs of the pairs of a @Rec@.
210 Note that we do {\em weird things} with this let's binding. Consider:
219 Look at the inner \tr{let}. As \tr{w} is used in both the bind and
220 body of the inner let, we could panic and leave \tr{w}'s binding where
221 it is. But \tr{v} is floatable into the body of the inner let, and
222 {\em then} \tr{w} will also be only in the body of that inner let.
224 So: rather than drop \tr{w}'s binding here, we add it onto the list of
225 things to drop in the outer let's body, and let nature take its
229 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs) body)
230 = fiExpr new_to_drop body
232 rhs_fvs = freeVarsOf rhs
233 body_fvs = freeVarsOf body
235 ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
237 new_to_drop = body_binds ++ -- the bindings used only in the body
238 [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
239 shared_binds -- the bindings used both in rhs and body
241 -- Push rhs_binds into the right hand side of the binding
242 rhs' = fiExpr rhs_binds rhs
243 rhs_fvs' = rhs_fvs `unionIdSets` floatedBindsFVs rhs_binds
245 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
246 = fiExpr new_to_drop body
248 (binders, rhss) = unzip bindings
250 rhss_fvs = map freeVarsOf rhss
251 body_fvs = freeVarsOf body
253 (body_binds:rhss_binds, shared_binds)
254 = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
256 new_to_drop = -- the bindings used only in the body
258 -- the new binding itself
259 [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
260 -- the bindings used both in rhs and body or in more than one rhs
263 rhs_fvs' = unionIdSets (unionManyIdSets rhss_fvs)
264 (unionManyIdSets (map floatedBindsFVs rhss_binds))
266 -- Push rhs_binds into the right hand side of the binding
267 fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
268 -> [(Id, CoreExprWithFVs)]
271 fi_bind to_drops pairs
272 = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
275 For @Case@, the possible ``drop points'' for the \tr{to_drop}
276 bindings are: (a)~inside the scrutinee, (b)~inside one of the
277 alternatives/default [default FVs always {\em first}!].
280 fiExpr to_drop (_, AnnCase scrut alts)
282 fvs_scrut = freeVarsOf scrut
283 drop_pts_fvs = fvs_scrut : (get_fvs_from_deflt_and_alts alts)
285 case (sepBindsByDropPoint drop_pts_fvs to_drop)
286 of (scrut_drops : deflt_drops : alts_drops, drop_here) ->
287 mkCoLets' drop_here (Case (fiExpr scrut_drops scrut)
288 (fi_alts deflt_drops alts_drops alts))
291 ----------------------------
292 -- pin default FVs on first!
294 get_fvs_from_deflt_and_alts (AnnAlgAlts alts deflt)
295 = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ]
297 get_fvs_from_deflt_and_alts (AnnPrimAlts alts deflt)
298 = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts]
300 get_deflt_fvs AnnNoDefault = emptyIdSet
301 get_deflt_fvs (AnnBindDefault b rhs) = freeVarsOf rhs
303 ----------------------------
304 fi_alts to_drop_deflt to_drop_alts (AnnAlgAlts alts deflt)
306 [ (con, params, fiExpr to_drop rhs)
307 | ((con, params, rhs), to_drop) <- zipEqual "fi_alts" alts to_drop_alts ]
308 (fi_default to_drop_deflt deflt)
310 fi_alts to_drop_deflt to_drop_alts (AnnPrimAlts alts deflt)
312 [ (lit, fiExpr to_drop rhs)
313 | ((lit, rhs), to_drop) <- zipEqual "fi_alts2" alts to_drop_alts ]
314 (fi_default to_drop_deflt deflt)
316 fi_default to_drop AnnNoDefault = NoDefault
317 fi_default to_drop (AnnBindDefault b e) = BindDefault b (fiExpr to_drop e)
320 %************************************************************************
322 \subsection{@sepBindsByDropPoint@}
324 %************************************************************************
326 This is the crucial function. The idea is: We have a wad of bindings
327 that we'd like to distribute inside a collection of {\em drop points};
328 insides the alternatives of a \tr{case} would be one example of some
329 drop points; the RHS and body of a non-recursive \tr{let} binding
330 would be another (2-element) collection.
332 So: We're given a list of sets-of-free-variables, one per drop point,
333 and a list of floating-inwards bindings. If a binding can go into
334 only one drop point (without suddenly making something out-of-scope),
335 in it goes. If a binding is used inside {\em multiple} drop points,
336 then it has to go in a you-must-drop-it-above-all-these-drop-points
339 We have to maintain the order on these drop-point-related lists.
343 :: [FreeVarsSet] -- one set of FVs per drop point
344 -> FloatingBinds -- candidate floaters
345 -> ([FloatingBinds], -- floaters that *can* be floated into
346 -- the corresponding drop point
347 FloatingBinds) -- everything else, bindings which must
348 -- not be floated inside any drop point
350 sepBindsByDropPoint drop_pts []
351 = ([[] | p <- drop_pts], []) -- cut to the chase scene; it happens
353 sepBindsByDropPoint drop_pts floaters
355 (per_drop_pt, must_stay_here, _)
356 --= sep drop_pts emptyIdSet{-fvs of prev drop_pts-} floaters
357 = split' drop_pts floaters [] empty_boxes
358 empty_boxes = nOfThem (length drop_pts) []
360 (map reverse per_drop_pt, reverse must_stay_here)
362 split' drop_pts_fvs [] mult_branch drop_boxes
363 = (drop_boxes, mult_branch, drop_pts_fvs)
365 split' drop_pts_fvs (bind:binds) mult_branch drop_boxes
366 | no_of_branches == 1 -- Exactly one branch
367 = split' drop_pts_fvs' binds mult_branch drop_boxes'
369 | otherwise -- Zero or many branches; drop it here
370 = split' drop_pts_fvs binds (bind:mult_branch) drop_boxes
373 binders = bindersOf (fst bind)
374 no_of_branches = length [() | True <- in_branch_flags]
375 in_branch_flags = [ any (`elementOfIdSet` branch_fvs) binders
376 | branch_fvs <- drop_pts_fvs ]
378 (drop_pts_fvs', drop_boxes') = unzip (zipWith3 drop in_branch_flags drop_pts_fvs drop_boxes)
379 drop True drop_fvs box = (drop_fvs `unionIdSets` fvsOfBind bind, bind:box)
380 drop False drop_fvs box = (drop_fvs, box)
383 -------------------------
384 fvsOfBind (_,fvs) = fvs
386 floatedBindsFVs :: FloatingBinds -> FreeVarsSet
387 floatedBindsFVs binds = unionManyIdSets (map snd binds)
389 mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
390 mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e